      PROGRAM COLAGG                                                                                                                
C     PROGRAM COLAGG (COLFIL,       GGFILE,       INPUT,       OUTPUT,  )       D2                                                  
C    1          TAPE1=COLFIL, TAPE2=GGFILE, TAPE5=INPUT, TAPE6=OUTPUT)                                                              
C     ----------------------------------------------------------------          D2                                                  
C                                                                               D2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       D2                                                  
C     NOV 06/95 - F.MAJAESS (REVISE DEFAULT PACKING DENSITY VALUE)                                                                  
C     JAN 07/93 - E. CHAN  (READ LEVELS INTO INTEGER ARRAY)                                                                         
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     JAN 30/87 - J.HASLIP                                                                                                          
C                                                                               D2                                                  
CCOLAGG  - CONVERTS A SERIES OF COLUMNS TO A MULTI LEVEL GRID FILE      1  1 C GD1                                                  
C                                                                               D3                                                  
CAUTHOR - J.HASLIP                                                              D3                                                  
C                                                                               D3                                                  
CPURPOSE - PROGRAM READS SETS OF VERTICAL COLUMNS, FROM A MULTILEVEL GRID       D3                                                  
C          FILE COLFIL, AND RESTORES THE FILE TO ITS ORIGINAL MULTILEVEL        D3                                                  
C          GRID OR CROSS SECTION CONFIGURATION IN FILE GGFILE.                  D3                                                  
C          THE PROGRAM WILL ACCOMODATE A GRID OF UP TO $IM1$ BY $J$ BY $L$      D3                                                  
C          LEVELS (OR SOME GRID NOT EXCEEDING $IM1$ X $J$ X $L$ ).              D3                                                  
C          VALUE OF LEVELS TO BE RESTORED ARE READ IN FROM AN                   D3                                                  
C          INPUT CARD.                                                          D3                                                  
C                                                                               D3                                                  
CINPUT FILE...                                                                  D3                                                  
C                                                                               D3                                                  
C      COLFIL = FILE OF COLUMNS THROUGH A MULTILEVEL GRID(S)                    D3                                                  
C                                                                               D3                                                  
C        INPUT FILE LABEL:                                                      D3                                                  
C          IBUF(1): 4HZONL                                                      D3                                                  
C          IBUF(2): TIMESTEP (UNCHANGED)                                        D3                                                  
C          IBUF(3): NAME (UNCHANGED)                                            D3                                                  
C          IBUF(4): COLUMN NUMBER                                               D3                                                  
C          IBUF(5): NUMBER OF LEVELS                                            D3                                                  
C          IBUF(6): SET TO 1 (COLUMN OF ONE DIMENSION)                          D3                                                  
C          IBUF(7): ENCODED ORIGINAL DIMENSIONS OF GRID OR                      D3                                                  
C                   ZONAL PROFILE. IBUF(7)=IBUF(5)*1000+IBUF(6)                 D3                                                  
C          IBUF(8): NPACK=1 (COLUMN NOT PACKED.)                                D3                                                  
C                                                                               D3                                                  
COUTPUT FILE...                                                                 D3                                                  
C                                                                               D3                                                  
C      GGFILE = RESTORED FILE OF MULTILEVEL GRID(S)                             D3                                                  
C                                                                                                                                   
CINPUT PARAMETERS...                                                                                                                
C                                                                               D5                                                  
C      NIV = NUMBER OF LEVELS TO BE RESTORED                                    D5                                                  
C      ILEVS = ARRAY CONTAINING VALUES OF LEVELS TO BE RESTORED                 D5                                                  
C                                                                               D5                                                  
CEXAMPLE OF INPUT CARDS...                                                      D5                                                  
C                                                                               D5                                                  
C*COLAGG     10                                                                 D5                                                  
C* 10   32   80  150  235  360  550  750  880  970                              D5                                                  
C-------------------------------------------------------------------                                                                
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      INTEGER ILEVS(100), ICOL(18528)                                                                                               
      REAL ROW(18528)                                                                                                               
      EQUIVALENCE (ICOL(1),ROW(1))                                                                                                  
C                                                                                                                                   
      COMMON/ICOM/ IBUF(8), IDAT(18528)                                                                                             
      COMMON/BLANCK/ G(1852800)                                                                                                     
C                                                                                                                                   
      LOGICAL OK                                                                                                                    
C                                                                                                                                   
      DATA MAXPK,MAXDAT,NPACK,MAXL /18528,1852800, 2,100/                                                                           
C                                                                                                                                   
      NFIL=4                                                                                                                        
      CALL JCLPNT(NFIL,1,2,5,6)                                                                                                     
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
C                                                                                                                                   
C     * READ IN LEVELS FROM INPUT CARD.                                                                                             
C                                                                                                                                   
      READ(5,5000,END=900) NIV                                                  D4                                                  
      IF((NIV.LT.1).OR.(NIV.GT.MAXL)) CALL         XIT('COLAGG',-1)                                                                 
      READ(5,5010,END=901) (ILEVS(I),I=1,NIV)                                   D4                                                  
      WRITE(6,6000)                                                                                                                 
      WRITE(6,6010) (ILEVS(I),I=1,NIV)                                                                                              
C                                                                                                                                   
      NSET=0                                                                                                                        
C                                                                                                                                   
  075 NCOL=0                                                                                                                        
      OK=.TRUE.                                                                                                                     
      CALL GETSET2(1,G,ICOL,NCOL,IBUF,MAXPK,OK)                                                                                     
      IF(.NOT.OK)THEN                                                                                                               
        IF(NSET.GT.0)THEN                                                                                                           
          CALL                                     XIT('COLAGG',0)                                                                  
        ELSE                                                                                                                        
          CALL                                     XIT('COLAGG',-2)                                                                 
        ENDIF                                                                                                                       
      ENDIF                                                                                                                         
      IF (IBUF(1).NE.NC4TO8("ZONL")) CALL          XIT('COLAGG',-3)                                                                 
      IF (NSET.EQ.0) THEN                                                                                                           
        NPACK=MIN(NPACK,IBUF(8))                                                                                                    
      ENDIF                                                                                                                         
      NLEV=IBUF(5)                                                                                                                  
      ISIZ=NCOL*NLEV                                                                                                                
      IF (ISIZ.GT.MAXDAT)    THEN                                                                                                   
          WRITE(6,6020) NCOL, IBUF(5)                                                                                               
          CALL                                     XIT('COLAGG',-4)                                                                 
      ENDIF                                                                                                                         
      NSET=NSET+1                                                                                                                   
C                                                                                                                                   
C     * DECODE DIMENSIONS FROM LABEL                                                                                                
C                                                                                                                                   
      ILG=IBUF(7)/1000                                                                                                              
      JLAT=IBUF(7)-ILG*1000                                                                                                         
      IF (ILG*JLAT*NLEV.NE.ISIZ) CALL              XIT('COLAGG',-5)                                                                 
      IBUF(7)=0                                                                                                                     
      IF (JLAT.EQ.1) THEN                                                                                                           
          CALL SETLAB(IBUF,NC4TO8("ZONL"),-1,-1,-1,ILG,JLAT,-1,NPACK)                                                               
      ELSE                                                                                                                          
          CALL SETLAB(IBUF,NC4TO8("GRID"),-1,-1,-1,ILG,JLAT,-1,NPACK)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * CALCULATE ELEMENTS OF GRID OR ZONAL CROSS SECTION                                                                           
C     * AND WRITE THEM TO THE OUTPUT FILE                                                                                           
C                                                                                                                                   
      DO 200 IPCOL=1,NLEV                                                                                                           
          DO 100 IPGRID=1,NCOL                                                                                                      
              ROW(IPGRID)=G(IPCOL+(IPGRID-1)*NLEV)                                                                                  
  100     CONTINUE                                                                                                                  
          IBUF(4)=ILEVS(IPCOL)                                                                                                      
          IF (NSET.EQ.1.E0) WRITE(6,6030) IBUF                                                                                      
          CALL PUTFLD2(2,ROW,IBUF,MAXPK)                                                                                            
  200 CONTINUE                                                                                                                      
C                                                                                                                                   
      GOTO 075                                                                                                                      
C                                                                                                                                   
C     *** EOF ON INPUT CARD ***                                                                                                     
C                                                                                                                                   
  900 CALL                                         XIT('COLAGG',-100)                                                               
  901 CALL                                         XIT('COLAGG',-101)                                                               
C                                                                                                                                   
C----------------------------------------------------------------------                                                             
 5000 FORMAT(10X,I5)                                                            D4                                                  
 5010 FORMAT(16I5)                                                              D4                                                  
 6000 FORMAT(24X,"--- SELECTED COLUMN LEVELS ARE ---",/)                                                                            
 6010 FORMAT(16I5,/)                                                                                                                
 6020 FORMAT(1X,1I5," COLUMNS ",1I5," IN LENGTH IS TOO LARGE.")                                                                     
 6030 FORMAT(1X,1A4,1I10,2X,1A4,5I10)                                                                                               
      END                                                                                                                           
