      PROGRAM GGACOL                                                                                                                
C     PROGRAM GGACOL (GGFIL,       COLFIL,       OUTPUT,                )       D2                                                  
C    1          TAPE1=GGFIL, TAPE2=COLFIL, TAPE6=OUTPUT)                                                                            
C     --------------------------------------------------                        D2                                                  
C                                                                               D2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       D2                                                  
C     SEP 01/94 - B.DENIS  (CORRECT LOGIC TEST FOR GRID/ZONL)                   D2                                                  
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     JAN 30/87 - J.HASLIP                                                                                                          
C                                                                               D2                                                  
CGGACOL  - PRODUCES COLUMNS THROUGH A MULTI LEVEL GRID FILE             1  1   GD1                                                  
C                                                                               D3                                                  
CAUTHOR - J.HASLIP                                                              D3                                                  
C                                                                               D3                                                  
CPURPOSE - READS IN MULTI-LEVEL SETS OF GAUSSIAN GRIDS OR ZONAL                 D3                                                  
C          CROSS-SECTIONS FROM FILE GGFIL AND PRODUCES SETS OF                  D3                                                  
C          VERTICAL COLUMNS IN COLFIL FILE.                                     D3                                                  
C          THIS PROGRAM CAN ONLY PROCESS A GRID OF A MAXIMUM                    D3                                                  
C          RESOLUTION OF $IM1$ BY $J$ BY $L$ LEVELS ( OR ANY GRID               D3                                                  
C          FIELD THAT DOES NOT EXCEED $IM1$ X $J$ X $L$ )                       D3                                                  
C                                                                               D3                                                  
CINPUT FILE...                                                                  D3                                                  
C                                                                               D3                                                  
C      GGFIL  = FILE CONTAINING ONE OR MORE MULTI-LEVEL SETS OF                 D3                                                  
C               GAUSSIAN GRIDS OR ZONAL CROSS-SECTIONS.                         D3                                                  
C                                                                               D3                                                  
COUTPUT FILE...                                                                 D3                                                  
C                                                                               D3                                                  
C      COLFIL = FILE CONTAINING ONE OR MORE SETS OF COLUMNS                     D3                                                  
C               THROUGH THE MULTI-LEVEL GRID(S)                                 D3                                                  
C                                                                               D3                                                  
C         WITH THE OUTPUT FILE LABEL CONTAINING :                               D3                                                  
C                                                                               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----------------------------------------------------------------------------                                                       
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      INTEGER LEV(100)                                                                                                              
      REAL COLUMN(100)                                                                                                              
      EQUIVALENCE (LEV(1),COLUMN(1))                                                                                                
C                                                                                                                                   
      COMMON /ICOM/ IBUF(8),IDAT(18528)                                                                                             
      COMMON /BLANCK/ G(1852800)                                                                                                    
C                                                                                                                                   
      LOGICAL OK                                                                                                                    
C                                                                                                                                   
      DATA MAXPK, MAXDAT, NPACK, MAXLEV /18528, 1852800, 1, 100/                                                                    
C                                                                                                                                   
      NFIL=3                                                                                                                        
      CALL JCLPNT(NFIL,1,2,6)                                                                                                       
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
C                                                                                                                                   
      NSET=0                                                                                                                        
C                                                                                                                                   
  050 NLEV=0                                                                                                                        
      OK=.TRUE.                                                                                                                     
C                                                                                                                                   
C     * GET MULTI-LEVEL GRID OR ZONAL                                                                                               
C     * CROSS SECTION FROM FILE                                                                                                     
C                                                                                                                                   
      CALL GETSET2(1,G,LEV,NLEV,IBUF,MAXPK,OK)                                                                                      
      IF(.NOT.OK)THEN                                                                                                               
        IF(NSET.GT.0)THEN                                                                                                           
          CALL                                     XIT('GGACOL',0)                                                                  
        ELSE                                                                                                                        
          CALL                                     XIT('GGACOL',-1)                                                                 
        ENDIF                                                                                                                       
      ENDIF                                                                                                                         
      IF(NLEV.GT.MAXLEV) CALL                      XIT('GGACOL',-2)                                                                 
      IF(IBUF(1).NE.NC4TO8("GRID").AND.IBUF(1).NE.NC4TO8("ZONL"))                                                                   
     1  CALL                                       XIT('GGACOL',-3)                                                                 
      NSET=NSET+1                                                                                                                   
C                                                                                                                                   
C     * GET LONG AND LAT DIMENSIONS FROM LABEL                                                                                      
C                                                                                                                                   
      ILG=IBUF(5)                                                                                                                   
      JLAT=IBUF(6)                                                                                                                  
C                                                                                                                                   
C     * ENCODE DIMENSIONS OF ORIGINAL GRID                                                                                          
C                                                                                                                                   
      IBUF(7)=ILG*1000+JLAT                                                                                                         
C                                                                                                                                   
      NWDS=ILG*JLAT                                                                                                                 
      ISIZ=NWDS*NLEV                                                                                                                
      IF (ISIZ.GT.MAXDAT) THEN                                                                                                      
        WRITE(6,6000) ILG, JLAT, NLEV                                                                                               
        CALL                                       XIT('GGACOL',-4)                                                                 
      ENDIF                                                                                                                         
      CALL SETLAB(IBUF,NC4TO8("ZONL"),-1,-1,-1,NLEV,1,-1,NPACK)                                                                     
C                                                                                                                                   
C     * CALCULATE COLUMN ELEMENTS AND WRITE COLUMNS TO FILE                                                                         
C                                                                                                                                   
      DO 200 IPGRID=1,NWDS                                                                                                          
          DO 100 IPCOL=1,NLEV                                                                                                       
              COLUMN(IPCOL)=G(IPGRID+(IPCOL-1)*NWDS)                                                                                
  100     CONTINUE                                                                                                                  
          IBUF(4)=IPGRID                                                                                                            
          CALL PUTFLD2(2,COLUMN,IBUF,MAXPK)                                                                                         
  200 CONTINUE                                                                                                                      
C                                                                                                                                   
      IF (NSET.EQ.1) THEN                                                                                                           
        WRITE(6,6010) ILG, JLAT, NLEV                                                                                               
        WRITE(6,6020) NWDS, NLEV                                                                                                    
      ENDIF                                                                                                                         
C                                                                                                                                   
      GOTO 050                                                                                                                      
C                                                                                                                                   
C-----------------------------------------------------------------                                                                  
 6000 FORMAT(/,/,I5," BY ",I5," BY ",I5," ARRAY TOO LARGE",/,/)                                                                     
 6010 FORMAT(1X, I5," BY ",I5," BY ",I5," LEVELS CONVERTED",/)                                                                      
 6020 FORMAT(1X,"TO ",I5," COLUMNS OF ",I5," LEVELS EACH",/)                                                                        
      END                                                                                                                           
