C--------------------------------------------------------------------------
	      FUNCTION NALLOC( IWRDS,NAME)
C--------------------------------------------------------------------------
C     NAMED-NUMBERED-STORAGE                                            
C                                                                       
C     2/3/75 - S. PIEPER                                                
C     11/7/75 - STORE NAME IN COMMON FOR IALLOC ERROR MESSAGES.         
C     4/25/78 - CRAY VERSION WITH NO ENTRIES - S.P.                     
C     12/28/79 - STANDARD MORTRAN - RPG                                 
C     1/16/80 - CHARACTER*8 THENAM - RPG                                
C     2/25/80 - USE MORTRAN MACRO  USAGE  - RPG                         
C     6/13/80 - CHAR*8 NAME FOR CDC - S.P.                              
C     7/14/80 - CRAY VERSION #2 -- MUCH CLOSER TO IBM - S.P.            
C                                                                       
C     USE AS                                                            
C                                                                       
C     1)   ILOC = NALLOC( IWRDS, 'NAME' )                               
C       WHERE ILOC WILL BE AS IS RETURNED FROM IALLOC.  'NAME'          
C       (WHICH NEED NOT BE ON AN 8-BYTE BOUNDRY) IS A NAME THAT WILL    
C       BE ASSOCIATED WITH THE ILOC'TH LOCATION IN THE QUERY STACK.     
C       IF 'NAME' IS ALREADY IN THE QUERY STACK THEN IT WILL BE FREED   
C       AND AN ATTEMPT MADE TO REUSE THE SPACE.  IN THIS CASE IALLOC    
C       IS NOT CALLED.                                                  
C     2)   ILOC = NAMLOC( 'NAME' )                                      
C       RETURNS THE QUERY STACK LOCATION OF AN ALREADY DEFINED NAME.    
C       IF 'NAME' IS NOT IN THE QUERY STACK AS A NON-FREED ELEMENT,     
C       THEN 0 IS RETURNED.                                             
C                                                                       
      IMPLICIT REAL*8 (A-H, O-Z)                                        
C                                                                       
      CHARACTER*1 NAME(8)                                               
CWD      CHARACTER*8 NAME                                               
C                                                                       
      CHARACTER*8 NAMES                                                 
      COMMON /NAMCOM/ NAMES(100)
      COMMON /LOCKT/ L(100)
      COMMON /LENGTH/ LENG(100)
C                                                                       
      LOGICAL NSPTSW                                                    
      COMMON/USAGE/IBASE, NWORDS, IMAX, INAME, IGOT, NLOC, IPEAK, NAMPEK
     *, NUMCOM, ICHEC, THENAM, IWASAT, NAMLC2, NSPTSW                   
C                                                                       
      LOGICAL FNDSW 
      CHARACTER*8 BLANK, THENAM 
	DATA BLANK/' '/
C                                                                       
      CHARACTER*1 NAME1(8), BLNK1                                       
	DATA BLNK1/' '/
      CHARACTER*8 NAME8                                                 
      EQUIVALENCE (NAME8, NAME1(1))                                     
C                                                                       
C     IS IT DEFINED                                                     
C                                                                       
      ASSIGN 100 TO IGO  
      GO TO 800                                                         
 100  IF ( .NOT. FNDSW ) GO TO 150                                      
C
C     FOUND - FREE IT AND TRY TO REUSE                                  
C                                                                       
      L(IL) = IABS(L(IL))                                               
      IF ( L(IL) .EQ. IWRDS ) GOTO 180                                  
      L(IL) = -L(IL)                                                    
      NAMES(IL) = BLANK                                                 
C                                                                       
 150  THENAM = NAME8                                                    
C      print 1919, iwrds, name8
      IL = IALLOC(IWRDS)                                                
C      print 1920, il, l(il)
C1919  format (x,I15,3x,A8)
C1920  format (2I15)
      THENAM = BLANK
      IF ( IL .EQ. 0 ) GO TO 200
 180  NAMES(IL) = NAME8                                                 
 200  NALLOC = IL                                                       
      RETURN                                                            
C
C     LOCATE A NAME                                                     
C
      ENTRY NAMLOC ( NAME )                                             
      assign 300 to igo 
      GO TO 800                                                         
 300  NALLOC = 0                                                        
      IF ( .NOT. FNDSW ) RETURN                                         
      IF ( L(IL) .LT. 0 ) RETURN                                        
      NALLOC = IL                                                       
      RETURN                                                            
C
C     SEARCH FOR A NAME, GET THE NAME FROM THE ARGUMENT LIST            
C
 800  FNDSW = .FALSE.                                                   
      IL = 0                                                            
CWD      NAME8 = NAME                                                   
C
C     PAD IT OUT WITH BLANKS FOR IBM ETC.                               
C
      NAME8 = BLANK                                                     
      DO 809 I = 1, 8                                                   
      NAME1(I) = NAME(I)                                                
      IF (NAME1(I) .EQ. BLNK1 ) GO TO 810                               
 809  CONTINUE                                                          
C
 810  DO 839 I = 1, IMAX                                                
      IF ( NAMES(I) .NE. NAME8 ) GO TO 839                              
      IF ( L(I) .GT. 0 ) GO TO 850                                      
C     SEMI FOUND - PERHAPS THERE IS A BETTER ENTRY                      
      NAMES(I) = BLANK                                                  
      IL = I                                                            
      FNDSW = .TRUE.                                                    
 839  CONTINUE                                                          
      GO TO 870                                                         
C
C     REALLY FOUND                                                      
 850  IL = I                                                            
      FNDSW = .TRUE.                                                    
 870  GO TO IGO                                          
C
      END                                                               
C-----------------------------------------------------------------------
      FUNCTION IALLOC(IWRDS)                                            
C
C     THIS IS THE ENTIRE NUMBERED STORAGE PACKAGE                       
C-----------------------------------------------------------------------
C  THIS ROUTINE ASSIGNS SPACE IN THE ALLOCATED REGION WHICH BEGINS      
C  AT ALLOC(IBASE) AND EXTENDS TO ALLOC(IBASE+NWORDS)                   
C                                                                       
C  THE ALLOCATED ARRAY IS LABELED BY A NUMBER- RETURNED AS THE          
C  FUNCTIONAL VALUE FROM IALLOC                                         
C                                                                       
C  SPACE IS ASSIGNED TO UP TO NAMDIM ARRAYS.  EACH ALLOCATION ICREMENTS 
C  THE SCALAR IAM BY 1.  THE LOCATION OF THE FIRST BYTE OF THE ARRAY    
C  IS KEPT IN L(IAM) AND ITS LENGTH (IWRDS) IS SAVED IN LENG(IAM).      
C  AN ARRAY IS FREED FOR FUTURE RE-USE BY THE OPERATION                 
C                L(NUMBER)=-L(NUMBER)                                   
C  WHERE NUMBER IS THE IDENTIFYING ARRAY NUMBER (FUNCTION VALUE OF      
C  IALLOC) AND L IS THE INTEGER*4 ARRAY IN THE LABELED COMMON LOC       
C                                                                       
C  IF ALLOCATION IS IMPOSSIBLE IALLOC RETURNS A FUNCTION VALUE 0        
C     UNLESS IF   STOPSW = .TRUE.  (SEE BELOW)  INWHICH CASE THE JOB IS 
C     TERMINATED WITH AN ERROR TRACE.                                   
C                                                                       
C  TO CHANGE THE MAXIMUM NUMBER OF NAMES RE-COMPILE WITH                
C  COMMON AREAS NAMES,LOC AND LENGTH WITH NEW DIMENSIONS                
C  AND WITH THE NEW SIZE IN THE NAMDIM DATA STATEMENT BELOW.            
C                                                                       
C-----------------------------------------------------------------------
C                                                                       
C  THIS VERSION 7/14/73    D.GLOECKNER                                  
C     2/3/75 - STOPSW ADDED, NEW STATISTIC IN NSCAT; NSSTAT ENTRY - S.P.
C              ALSO ADD SOME STUFF FOR NAMED-NUMBERED-STORAGE -- ALL    
C              SUCH ADDITIONS CONTAIN A REFERENCE TO "NAMES" OR "BLANK" 
C     2/16/75 - MANY CHANGES - S.P.                                     
C     2/24/75 - FIX BUG IN COMPRESSING (IGOT UNDEFINED) S.P.            
C     8/15/75 - ADD GIVEAL AND CHOPIT ENTRIES D.G.                      
C     11/7/75 - MAKE REFRESHABLE;  STOP FOR =< 0 SIZE.                  
C     6/6/76 - WORD SIZE FACTORS IN ALLOCS                              
C     9/10/76 - ADD IREDEF                                              
C     12/28/76 - FIX BUG IN ABOVE                                       
C     4/17/77 - ALLOW OVERLAYS BETWEEN GIVEAL AND CHOPIT                
C     5/10/77 - FIX GIVEAL BUG WHEN NAMESTACK IS FULL                   
C     6/11/77 - FIX COMPRESS BUG WHEN IT IS ALREADY COMPRESSED.         
C     1/25/78 - FIX BUG FOR EXACT FIT COMPRESS.                         
C     4/25/78 - NO ENTRIES FOR CRAY VERSION - S.P.                      
C     4/26/78 - PRINT DIAGNOSTICS BASED ON NSPTSW - S.P.                
C     7/3/78 - AVOID CDC OVERFLOW ON INTEGRETIY HCHECK                  
C     7/24/79 - NEW NSDUMP MADE A SEPARATE SUBROUTINE - S.P.            
C     11/4/79 - INCREASE TO 100 NAMES - S.P.                            
C     12/31/79 - STANDARD MORTRAN; CVA, CUN VERSIONS - RPG              
C     1/24/80 - CHARACTER*8 THENAM; LIB%STOP FOR CVA; CORRECT URWALK    
C        FOR CUN; 9950 TO 9550; NAMLCA (NOT NAMLOC) ARG TO IREDEF - RPG 
C     6/15/80 - CORRECT BOB'S IREDEF FIX FOR CDC - S.P.                 
C     7/14/80 - CRAY #2 VERSION -- MUCH CLOSER TO IBM FORTRAN - S.P.    
C     7/23/80 - CRAY VERSION CAN ALOS HAVE EXPANDING ALLOCATOR - S.P.   
C     7/28/80 - ALOW COMPRESS LOOP TO VECTORIZE - S.P.                  
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/IASYMP,ICHECK,IECHO,IELAST,IFIT,IVRTEX,IRLWAV, 
     * ITSO,LINEAR,NUCONL,NEXT,IFITER,IEPOW,ISAVMX,ISAVB,LABANG, 
     * PROBLM,MASTYP,R0TYPE,IBSPAS,ISW1,ISW2,ISW3,ISCRFL,NOBFAC, 
     * CONVRG,IEXTYP,IBRNSB,MEORD,KFRMTP,IWRTWV,LORNTZ,IRELPT,ISAVSM                                                            
C                                                                       
      INTEGER GIVEAL, CHOPIT                                            
C                                                                       
      DATA NAMDIM /100/                                                 
      COMMON/LOCKT/L(100)                                                 
      COMMON /LENGTH/ LENG(100)                                         
      CHARACTER*8 NAMES
      COMMON /NAMCOM/ NAMES(100)                                        
C                                                                       
C     FOLLOWING COMMON CONTROLS NUMBERED STORAGE                        
C                                                                       
C     IBASE - OFFSET (IN 8-BYTE WORDS) TO START OF ALLOCATOR            
C     NWORDS - NUMBER OF 8-BYTE WORDS ASSIGNED TO ALLOCATOR.            
C     IMAX - SIZE OF NAME STACK                                         
C     INAME - HIGHEST LOCATION REACHED IN NAME STACK                    
C     IGOT - CURRENT NUMBER OF "ACTIVE" SLOTS IN NAME STACK             
C     NLOC - FIRST FREE WORD AT END OF ALLOCATOR                        
C     IPEAK - PEAK ACTUALLY USED SPACE IN UNITS OF 8-BYTES.             
C     NAMPEK - PEAK NUMBER OF NAMES ACTUALLY IN USE.                    
C     NUMCOM - NUMBER OF COMPRESSES THAT HAVE OCCURED.                  
C     ICHEC - ADDRESS (IN 8-BYTE WORDS) OF END OF ALLOCATOR.            
C     THENAM - NAME OF OBJECT BEING ALLOCATED (SET BY NALLOC).          
C     IWASAT - GIVEAL OBJECT LOCATION                                   
C     NAMLC2 - GIVEAL NAME STACK LOCATION                               
C                                                                       
      LOGICAL NSPTSW                                                    
      COMMON/USAGE/IBASE,NWORDS,IMAX,INAME,IGOT,NLOC,IPEAK,NAMPEK,
     * NUMCOM,ICHEC,THENAM,IWASAT,NAMLC2,NSPTSW                   
C                                                                       
C     STRUCTURE OF EACH ITEM IN THE ALLOCATOR IS                        
C                                                                       
C     WORD         IBM ETC.           CDC ETC.                          
C       1  NNNN 0000 FFFF 0000    00000 NNNNN                           
C     2,3..        DATA               DATA                              
C                                                                       
C             WORD = 8 BYTES       WORD = 60 BITS                       
C     IN BOTH CASES NNNN = NUMBER OF OBJECT (USED FOR VALIDITY          
C     CHECKS).  IN IBM THE HEXADECIMAL STRUCTURE IS SHOWN;              
C     IN THE CDC THE NUMBER IS JUST A FULL-WORD INTEGER.                
C                                                                       
      INTEGER FACFR4, FACFR2, FACFR1                                    
      COMMON/ALLOCS/ FACFR4, FACFR2, FACFR1                             
      DIMENSION ALLOC(1)
      INTEGER*2 LLOC(1)                                                 
      EQUIVALENCE ( FACFR4, ALLOC(1),LLOC(1))                           
CDC      ALLOCLEVEL ALLOC, LLOC, FACFR4, FACFR2, FACFR1                 
C                                                                       
CIB      REAL*8  ANAME / Z 0000 0000 FFFF 0000 /                        
CUN      REAL*4 ANAME4(2) / O000000000000, O777777000000 /              
CUN      EQUIVALENCE  ( ANAME4(1), ANAME )                              
      REAL*8 ANAME                                                      
      DATA ANAME / '00000000FFFF0000'X /                                
      INTEGER*2 NUMBER(4)                                               
      EQUIVALENCE(NUMBER(1),ANAME)                                      
C                                                                       
      LOGICAL STOPSW, REDFSW                                            
      LOGICAL ERRSW, PRTSW, FONDSW, ALLSW                               
      CHARACTER*8 BLANK, THENAM                                         
      DATA STOPSW / .TRUE. /                                            
      DATA BLANK / ' ' /                                                
C          
      REDFSW = .FALSE.                                                  
      IF ( NSPTSW ) WRITE(6,3) THENAM, IWRDS                              
  3   FORMAT ( ' IALLOC/NALLOC: ', A8, I15 )                            
C                                                                       
  5   IF(IWRDS.GT.0)GO TO 100                                           
      WRITE(6,13) THENAM, IWRDS                                           
 13   FORMAT('0**** ', A8, '  - REQUEST FOR ', I15, ' WORDS. ****')     
      GO TO 9500                                                        
C                                                                       
C     PREPARE TO ALLOCATE AN OBJECT.                                    
C     FIRST GO THROUGH THE LIST AND FIND USED SPACE AND NUMBERS.        
C     DURING THIS PASS WE ACCUMULATE INFO FOR STATISTICAL PURPOSES      
C     AND CHECK THE INTEGRETY OF THE ALLOCATOR.  ALSO WE LOOK FOR AN    
C     EXACT FIT TO A FREED SPOT WHICH WILL BE USED IF FOUND.            
C     WE ALSO LOOK FOR AN AVAILABLE NAME SPOT.                          
C                                                                       
 100  FONDSW = .FALSE.
      NAMUSE = 0                                                        
      LUSE = 0                                                          
      NAMLOC = 0                                                        
      IF ( INAME .EQ. 0 ) GO TO 150                                     
      DO 149 N = 1, INAME                                               
C                                                                       
C     IS THIS AN EMPTY SLOT                                             
C                                                                       
      IF (L(N) .NE. 0) GO TO 120                                        
      IF ( NAMLOC .EQ. 0 ) NAMLOC = N                                   
      GO TO 149                                                         
C                                                                       
C     IT IS IN USE OR IS A FREED SPOT.  CHECK INTEGRETY                 
C                                                                       
 120  NUMBER(1) = N                                                     
      GO TO 130            
CK----The following original command is NOT acceptable by ALPHA-------------
CK    if(alloc(iabs(l(n))-1).eq.aname)go to 130
CDC      IF ( LLOC(IABS(L(N))-1) .EQ. NUMBER(1) )  GO TO 130            
CK      PRINT 123, N,L(N),LENG(N),NAMES(N),L(N-1),LENG(N-1),NAMES(N-1)
CK 123  FORMAT ('0*** HEADER OF OBJECT', I4, ' HAS BEEN DESTROYED.' /  ' T
CK     *HIS AND PREVIOUS OBJECT LOCATION, LENGTH AND NAME ARE:' /  ( 2I15,
CK     * 2X, A8 ) )                                                       
C---------------------------------------------------------------------------
C     IS IT FREE SPACE OR A STILL IN USE OBJECT                         
C                                                                       
 130  IF ( L(N) .LT. 0 ) GO TO 140
      NAMUSE = NAMUSE + 1                                               
      LUSE = LUSE + LENG(N) + 1                                         
      GO TO 149                                                         
C                                                                       
 140  IF (FONDSW) GO TO 149                                             
      IF ( IWRDS .NE. LENG(N) ) GO TO 149                               
      NAMLOC = N                                                        
      ILOC = -L(NAMLOC) - 1                                             
      FONDSW = .TRUE.                                                   
C                                                                       
 149  CONTINUE                                                          
C                                                                       
C     SOME STATISTICS                                                   
C                                                                       
 150  IPEAK = MAX0( IPEAK, LUSE+IWRDS+1 )                               
      NAMPEK = MAX0( NAMPEK, NAMUSE+1 )                                 
C                                                                       
C     DID WE FIND AN EXACT FIT                                          
C                                                                       
      IF ( FONDSW ) GO TO 250                                           
C                                                                       
C     NO, DID WE ATLEAST FIND A NAME SLOT                               
C                                                                       
      IF ( NAMLOC .NE. 0 ) GO TO 200                                    
C                                                                       
C     NO, WE MUST GET A NEW NAME SLOT IF THERE ARE MORE AVAILABLE       
C                                                                       
      IF(INAME.LT.IMAX)GO TO 170                                        
C                                                                       
C     WE HAVE GONE THROUGH THE WHOLE STACK OF NAMES, ARE THERE HOLES    
C                                                                       
      IF ( NAMUSE .LT. IMAX ) GO TO 200                                 
 160  WRITE(6,163) THENAM                                                 
 163  FORMAT ('0*** ', A8, 2X, '-- NO MORE NAME SLOTS AVAILABLE ***')   
      GO TO 9500                                                        
C                                                                       
C     ADD TO END OF NAME LIST                                           
C                                                                       
 170  INAME = INAME + 1                                                 
      NAMLOC = INAME                                                    
C                                                                       
C     IS THERE SPACE AT THE END OF THE ALLOCATOR                        
C                                                                       
 200  IF ( NLOC+IWRDS .LE. ICHEC ) GO TO 220                            
C                                                                       
C     NO, WILL COMPRESSION SOLVE IT                                     
C                                                                       
      IF ( LUSE+IWRDS .LT. NWORDS ) GO TO 500                           
CNVC                                                                    
CNVC     ON CDC & CRAY ATTEMPT TO EXPAND THE ALLOCATOR                  
CNVC                                                                    
CNV      NNEED = LUSE + IWRDS + 1                                       
CNV      NASK  = MAX0( NNEED, LUSE+10000 )                              
CNV      CALL GRAB ( ALLOC, FACFR1, IBASE, NASK )                       
CNV      IF ( NASK .LT. NNEED ) GO TO 210                               
CNV      NWORDS = NASK                                                  
CNV      ICHEC = IBASE + NWORDS - 1                                     
CNV      GO TO 100                                                      
C                                                                       
 210  WRITE(6,213) THENAM, IWRDS, IPEAK                                   
213   FORMAT (' *** ', A8, 2X, '-- NOT ENOUGH ALLOCATOR.  ATTEMPTING',  
     *' TO DEFINE A', I12, ' WORD OBJECT.' /  5X, 'TOTAL ALLOCATOR SIZE 
     *MUST BE AT LEAST', I13, ' WORDS.' )                              
      GO TO 9500                                                        
C                                                                       
C     THERE IS ROOM TO ALLOCATE AND ALSO A NAME SLOT IS AVAILABLE.      
C     IF NAMLOC IS NOT YET ASSIGNED THEN WE MUST COMPRESS TO GET THE    
C     SLOT.                                                             
C                                                                       
 220  IF ( NAMLOC .EQ. 0 ) GO TO 500                                    
      ILOC = NLOC                                                       
      NLOC = NLOC + IWRDS + 1                                           
      IGOT = IGOT + 1                                                   
C                                                                       
C     DEFINE THE OBJECT                                                 
C                                                                       
 250  IF ( NSPTSW ) WRITE(6,253) NAMLOC, ILOC, NLOC                       
 253  FORMAT ( ' ASSIGNED', I4, I12, 5X, 'NLOC =', I12 )                
C                                                                       
      L(NAMLOC)=ILOC+1                                                  
C                                                                       
C  PUT NAME (NUMBER) IN FIRST INTEGER*2 PART OF ARRAY                   
C                                                                       
      NUMBER(1)=NAMLOC                                                  
      ALLOC(ILOC)=aname
      LENG(NAMLOC)=IWRDS                                                
      NAMES(NAMLOC) = BLANK                                             
      IALLOC=NAMLOC                                                     
      NAMLC2 = NAMLOC                                                   
      IF ( REDFSW ) GO TO 620                                           
      RETURN
      ENTRY GIVEAL(IWRDS)                                               
C                                                                       
C  COMPRESS THE ALLOCATOR AND                                        
C  GIVE LARGEST CONTIGUOUS PIECE FROM TOP OF ALLOCATOR TO END           
C  RETURNS NUMBER OF WORDS YOU GOT                                      
C  A CALL TO THIS ENTRY SHOULD BE IMMEDIATELY FOLLOWED WITH A CALL TO   
C  CHOPIT                                                               
C                                                                       
      IF ( NSPTSW ) WRITE(6,303)
 303  FORMAT ( ' GIVEAL CALLED' )                                       
      REDFSW = .FALSE.                                                  
      ALLSW = .TRUE.                                                    
      IF ( NLOC .GT. IBASE ) GO TO 505                                  
 300  IWRDS=ICHEC-NLOC-2                                                
      IWASAT=NLOC                                                       
      IF ( IWRDS .GE. 2 ) GO TO 310                                     
      WRITE(6,301)                                                      
301   FORMAT(' ***ERROR/NOTHING TO GIVE IN GIVEAL  CALL')               
      GO TO 9500                                                        
C                                                                       
C     FIND A NAME STACK LOCATION FOR GIVEAL                             
C                                                                       
 310  IF ( INAME .EQ. 0 ) GO TO 170                                     
      DO 304 N = 1, INAME                                               
      IF ( L(N) .NE. 0 ) GO TO 304                                      
      NAMLOC = N                                                        
      GO TO 200                                                         
 304  CONTINUE                                                          
      IF ( INAME .LT. IMAX ) GO TO 170                                  
      GO TO 160                                                         
C                                                                       
      ENTRY CHOPIT(IWRDS)                                               
C                                                                       
C                                                                       
C  THIS CALL MUST FOLLOW GIVEAL--IT TRUNCATES N.STORAGE OBJECT          
C                                                                       
C  PASS NUMBER OF WORDS YOU REALLY WANT                                 
C  CHECK IF THIS CALL IMMEDIATELY FOLLOWS GIVEAL                        
C                                                                       
      IF ( NSPTSW ) WRITE(6,323) IWRDS                                    
 323  FORMAT ( ' CHOPIT CALLED:', I15 )                                 
      ANAME=ALLOC(IWASAT)                                               
      IHAD=number(1)
      IPEAK=IPEAK+IWRDS+1                                               
      IF(NAMLC2.NE.IHAD)GO TO 320                                       
      NAMPEK=NAMPEK+1                                                   
      NLOC=IWASAT+IWRDS+1                                               
      LENG(NAMLC2)=IWRDS                                                
      RETURN                                                            
320   WRITE (6,321)                                                     
321   FORMAT(' ***ERROR CALL TO CHOPIT MUST IMMEDIATELY FOLLOW GIVEAL') 
      GO TO 9500                                                        
C                                                                       
C     COMPRESSION IS NECESSARY AND IT WILL SOLVE OUR PROBLEMS           
C     OR                                                                
C     GIVEAL HAS BEEN CALLED AND WE WANT TO GET THE MOST POSSIBLE       
C                                                                       
C                                                                       
C  THIS SECTION FOR COMPRESSION                                         
C                                                                       
C                                                                       
 500  ALLSW = .FALSE.                                                   
C                                                                       
      IF ( NAMLOC .NE. 0 ) WRITE(6,7432) THENAM                         
7432  FORMAT( X, A8, '  --  COMPRESSION IS OCCURING NOW.' )          
      IF ( NAMLOC .EQ. 0 ) WRITE(6,7433) THENAM                           
7433  FORMAT( X, A8, '  --  NAME STACK COMPRESSION IS OCCURING NOW.' 
     * )                                                                
C                                                                       
 505  LL=IBASE                                                          
      LCNT=0                                                            
      LSUM = 0                                                          
      NUMCOM = NUMCOM + 1                                               
C                                                                       
C     FIND FIRST FREE OBJECT                                            
C                                                                       
 510  LLOW = LL                                                         
      IF ( LCNT .GE. IGOT ) GO TO 600                                   
C                                                                       
      ANAME=ALLOC(LL)                                                   
C                                                                       
C  NEGATIVE LOCATION INDICATES A FREE LOCATION                          
C                                                                       
C  STRUCTURE CHECK                                                      
      NAMLOC = number(1)
      IF(IABS(L(NAMLOC)).NE.(LL+1))GO TO 8171                           
      IF(L(NAMLOC).LT.0)GO TO 520                                       
      LL=LL+LENG(NAMLOC)+1                                              
      LCNT=LCNT+1                                                       
      GO TO 510                                                         
8171  WRITE(6,7170)LL, ANAME, NAMLOC, LENG(NAMLOC), L(NAMLOC), NAMES(NA
     *MLOC)                                                             
7170  FORMAT(' **** STRUCTURE CHECK: LOC, HEADER, NAMLOC, LENG, L,',   
     *'NAME:',  / I13, Z18, 3I13, 2X, A8 )                               
CDC     1  I8, O22, I5, 2I13, 2X, A8 )                                  
      GO TO 9500                                                        
C                                                                       
C     FIRST FREE LOCATION FOUND                                         
C                                                                       
C  LOWEST FREE LOCATION IS AT LLOW-- CORRESPONDING TO THE ARRAY NUMBER  
C  NAMLOC... THE LCNT(TH) ONE UP FROM THE BOTTOM OF THE ALLOCATOR       
C                                                                       
 520  IHCNT=LCNT                                                        
C                                                                       
C     HAVE FOUND A FREE LOCATION.  MARK IT NOT IN USE AND GO ON.        
C                                                                       
 530  L(NAMLOC)=0                                                       
      LSUM = LSUM + LENG(NAMLOC) + 1                                    
C                                                                       
C  HAVE FOUND FIRST FREE LOCATION--NOW FIND NEXT FILLED ONE             
C                                                                       
 540  IF(IHCNT.GE.(IGOT-1))GO TO 600                                    
      IHCNT=IHCNT+1                                                     
      LL=LL+LENG(NAMLOC)+1                                              
      IF(LL.GE.NLOC)GO TO 600                                           
      ANAME=ALLOC(LL)                                                   
      NAMLOC = number(1)
C                                                                       
C  INTERNAL STRUCTURE CHECK                                             
C                                                                       
      IF(IABS(L(NAMLOC)).NE.(LL+1))GO TO 8171                           
      IF(L(NAMLOC).LT.0)GO TO 530                                       
C                                                                       
C     FOUND A STILL-IN-USE OBJECT, COMPRESS                             
C                                                                       
      N=LENG(NAMLOC)+1                                                  
CRACDIR$ IVDEP                                                          
      DO 579 I=1,N                                                      
579   ALLOC(LLOW+I-1)=ALLOC(LL+I-1)                                     
C                                                                       
C  NOTE WE HAVE ALSO MOVED THE IDENTIFYING NUMBER                       
C                                                                       
      LCNT=LCNT+1                                                       
      L(NAMLOC)=LLOW+1                                                  
      LLOW = LLOW+N                                                     
      GO TO 540                                                         
C                                                                       
C     COMPRESS ALL DONE.  UPDATE NUMBER OF ACTIVE SLOTS AND TOP         
C     OF ALLOCATOR "IN USE".                                            
C                                                                       
 600  IGOT=LCNT                                                         
      NLOC = LLOW                                                       
      IF ( ALLSW ) GO TO 300                                            
C                                                                       
      WRITE(6,5101)IGOT, LSUM                                           
5101  FORMAT(' ',I5,' ARRAYS COMPRESSED', I8, ' WORDS FREED' / )        
      GO TO 100                                                         
C                                                                       
C     CALL IREDEF ( NEWSIZE, NUMBER )   REDEFINES THE LENGTH            
C     OF AN EXISTING OBJECT AND DUPLICATES THE EXISTING INFORMATION     
C     INTO IT.  THE NUMBER AND NAME ARE NOT CHANGED BUT THE             
C     LOCATION IN THE ALLOCATOR IS CHANGED.  SPACE MUST BE              
C     AVAILABLE TO MAKE A TEMPORARY DUPLICATE COPY (EVEN FRO            
C     REDUCTIONS IN THE SIZE OF AN OBJECT).                             
C                                                                       
      ENTRY IREDEF ( IWRDS, NAMLCA )                                    
C                                                                       
CDC      ENTRY  IREDF2 ( IWRDS )                                        
CDC      NAMLCA = MOD( IWRDS, 256 )                                     
CDC      IWRDS = IWRDS/256                                              
C                                                                       
      NAMLOC = NAMLCA                                                   
      NAMOLD = NAMLOC                                                   
      THENAM = NAMES(NAMOLD)                                            
      IF ( NSPTSW ) WRITE(6,613) THENAM, IWRDS                            
 613  FORMAT ( ' IREDEF: ', A8, I15 )                                   
      IWDOLD = LENG(NAMOLD)                                             
      REDFSW = .TRUE.                                                   
      GO TO 5                                                           
C                                                                       
C     COPY OLD TO NEW INCLUDING HEADER                                  
C                                                                       
 620  N = MIN0( IWRDS, IWDOLD ) + 1                                     
      LL = L(NAMOLD) - 1                                                
      DO 629 I = 1, N                                                   
      ALLOC(ILOC-1+I) = ALLOC(LL-1+I)                                   
 629  CONTINUE                                                          
C                                                                       
C     CHANGE OLD TO POINT TO NEW                                        
C                                                                       
      L(NAMOLD) = ILOC+1                                                
      LENG(NAMOLD) = IWRDS                                              
      NAMES(NAMOLD) = THENAM                                            
C                                                                       
C     CHANGE NEW TO POINT TO OLD AND FREE IT                            
C                                                                       
      ALLOC(LL) = ANAME                                                 
      LENG(NAMLOC) = IWDOLD                                             
      L(NAMLOC) = -(LL+1)                                               
      IALLOC = NAMOLD                                                   
      NAMLOC = NAMOLD                                                   
C                                                                       
      RETURN                                                            
C                                                                       
      ENTRY ISTART(NBYTES)                                              
CDC      NBYTES = IWRDS                                                 
C                                                                       
C  INITIALIZE ALLOCATION                                                
C                                                                       
C     THE INPUT IS THE NUMBER OF BYTES TO ALLOCATE, OR IF NEGATIVE, THE 
C     NUMBER OF BYTES TO LEAVE FREE.                                    
C                                                                       
      NUMCOM = 0                                                        
      FACFR4 = 2                                                        
      FACFR2 = 4                                                        
      FACFR1 = 8                                                        
CDC      FACFR4 = 1                                                     
CDC      FACFR2 = 1                                                     
CDC      FACFR1 = 1                                                     
CRA      FACFR4 = 1                                                     
CRA      FACFR2 = 1                                                     
CRA      FACFR1 = 1                                                     
C                                                                       
      NWORDS = NBYTES                                                   
      CALL GRAB(ALLOC,FACFR1,IBASE,NWORDS)                              
      ICHEC=IBASE+NWORDS-1                                              
C                                                                       
C  ALLOC(IBASE) IS FIRST BYTE OF ALLOCATED AREA--- ALLOC(IBASE+NWORDS)  
C  IS LAST BYTE                                                         
C                                                                       
      IMAX= NAMDIM                                                      
      IPEAK = 0                                                         
      NAMPEK = 0                                                        
      NUMCOM = 0                                                        
C                                                                       
 710  NLOC = IBASE                                                      
      INAME = 0                                                         
      IGOT = 0                                                          
      THENAM = BLANK                                                    
      DO 719 I=1, IMAX                                                  
      NAMES(I) = BLANK                                                  
719   L(I)=0                                                            
C                                                                       
      IF ( NSPTSW ) WRITE(6,723) IBASE, ICHEC, IMAX                       
 723  FORMAT ( ' ALLOCATOR RANGE:', 2I12, 5X, '# NAMES =', I5 )         
      IALLOC=IBASE                                                      
      RETURN                                                            
C                                                                       
      ENTRY ICLEAR(IDUM)                                                
C                                                                       
C  THIS ENTRY CLEARS ALL DATA                                           
C                                                                       
      WRITE(6,8429)                                                     
 8429 FORMAT(/'   -------  ALL NUMBERED OBJECTS CLEARED  ------'/)      
      GO TO 710                                                         
C                                                                       
C     NSSTAT  PRINTS NUMBERED STORAGE STATISTICS                        
C                                                                       
      ENTRY NSSTAT (IDUM)                                               
      PRTSW = .FALSE.                                                   
      ALLSW = .FALSE.                                                   
      GO TO 900                                                         
C                                                                       
C  NSCAT GIVES A LISTING OF NUMBERED OBJECT,THEIR LENGTHS AND LOCATIONS 
C                                                                       
C     IF  IDUM = -1  THEN FREE AREAS ARE ALSO LISTED                    
C                                                                       
C                                                                       
      ENTRY NSCAT(IDUM)                                                 
C                                                                       
CDC      IDUM = IWRDS                                                   
C                                                                       
      PRTSW = .TRUE.                                                    
      ALLSW = IDUM .EQ. -1                                              
 900  ERRSW = .FALSE.                                                   
C                                                                       
 910  LUSE = 0                                                          
      NAMUSE = 0                                                        
C                                                                       
      IF (PRTSW) WRITE(6,923 )                                          
923   FORMAT ( '             ---- NUMBERED STORAGE CATALOG ----' )      
      IF ( NSPTSW .OR. PRTSW .AND. ALLSW ) WRITE(6,924) IBASE,NLOC, 
     *ICHEC,IGOT
 924  FORMAT ('     FROM', I8, 3X, 'TO', I8, 6X,  'TOP OF ALLOC =', I8,
     * I8, ' ACTIVE NAME SLOTS' )                                       
      IF ( PRTSW ) WRITE(6,927)
 927  FORMAT ('         NUMBER   NAME     LENGTH     START     END')   
      DO 949 III=1,INAME                                                
      LLOW = IABS(L(III))                                               
      LL = LLOW + LENG(III)+1                                           
      IF(L(III).LE.0)GO TO 940                                          
      LUSE = LUSE + LENG(III) + 1                                       
      NAMUSE = NAMUSE + 1                                               
      IF (PRTSW) WRITE(6, 933)III, NAMES(III), LENG(III), LLOW, LL      
 933  FORMAT(' ', 4X, I10, 2X, A8, I8, I10, I8 )                        
      GO TO 949                                                         
 940  IF ( ALLSW .AND. LLOW .GT. 0 ) WRITE(6,943) III,NAMES(III),  
     *LENG(III), LLOW, LL                                                     
 943  FORMAT(' ', 4X, I10, 2X, A8, I8, I10, I8, 5X, 'FREED' )           
 949  CONTINUE                                                          
C                                                                       
      LSIZE = NLOC - IBASE                                              
      BSIZE = LSIZE/128.                                                
      BAVAIL = NWORDS/128.                                              
      BUSE = LUSE/128.                                                  
      BPEAK = IPEAK/128.                                                
      WRITE(6,5427) NWORDS,BAVAIL,LSIZE,BSIZE,LUSE,BUSE,IPEAK,BPEAK, 
     *IMAX, INAME, NAMUSE, NAMPEK, NUMCOM                            
 5427 FORMAT ( X, T17, 'ALLOCATOR STATISTICS' /  T41, 'WORDS   KILOBYT
     *ES' /  ' ALLOCATOR SIZE:', T38, I8, F10.1 /  ' CURRENT UNCOMPRESSE
     *D SIZE:', T38, I8, F10.1 /  ' CURRENT COMPRESSED SIZE:', T38, I8, 
     *F10.1 /  ' PEAK COMPRESSED SIZE:', T38, I8, F10.1 /  ' NAME STACK 
     *SIZE:', T38, I8 /  ' CURRENT HIGHEST NAME:', T38, I8 /  ' CURRENT 
     *NAMES IN USE:', T38, I8 /  ' PEAK NAMES IN USE:', T38, I8 /  ' NUM
     *BER OF ALLOCATOR COMPRESSES:', T38, I8 //)                        
C                                                                       
      IF (ERRSW) GO TO 9550                                             
C                                                                       
      RETURN                                                            
C                                                                       
C     NO ROOM FOR ALLOCATION, STOP OR RETURN A 0                        
C                                                                       
 9500 IALLOC = 0                                                        
      IF ( .NOT. STOPSW ) RETURN                                        
C                                                                       
      WRITE(6,9503)
 9503 FORMAT (' ****** EXECUTION IS BEING TERMINATED BY NUMBERED',  ' ST
     *ORAGE ******' / )                                                 
      ERRSW = .TRUE.                                                    
      PRTSW = .TRUE.                                                    
      ALLSW = .TRUE.                                                    
      GO TO 910                                                         
CIB 9550 CALL ERRTRA                                                    
CDC 9550 CALL SYSERR                                                    
CRA 9550 CALL TRBK( 101 )                                               
CRA      CALL TRBK                                                      
CUN 9550 CALL URWALK ( 'IALLOC' )                                       
CK 9550 CALL LIB$STOP(%VAL(4))
CK      STOP 1234                                                         

 9550 STOP

CDC      FUNCTION  IREDEF ( IWRDS, NAMLOC )                             
CDC      IREDEF = IREDF2 ( 256*IWRDS + NAMLOC )                         
CDC      RETURN                                                         
      END                                                               
