      PROGRAM PAKGCM7                                                                                                               
C     PROGRAM PAKGCM7 (OUTGCM,       NPAKSS,       NPAKGS,       NPAKEN,        J2                                                  
C    1                                                           OUTPUT,)       J2                                                  
C    2           TAPE1=OUTGCM,TAPE21=NPAKSS,TAPE22=NPAKGS,TAPE23=NPAKEN,                                                            
C    3                                                     TAPE6=OUTPUT)                                                            
C     ------------------------------------------------------------------        J2                                                  
C                                                                               J2                                                  
C     JUN 01/09 - F.MAJAESS (USE NPACK=2 FOR "FN/ZN" FIELDS)                    J2                                                  
C     MAR 26/08 - F.MAJAESS (PHASE OUT APPEND MODE OPTION FOR NPAK[SS,GS,EN])                                                       
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)                                                           
C     APR 06/01 - F.MAJAESS (REWRITE IN ORDER TO OPTIMIZE I/O OPERATIONS)                                                           
C     APR 12/99 - R. HARVEY (REVISE PACKING DENSITY FOR BWG, OBWG).                                                                 
C     NOV 06/95 - F.MAJAESS (REVISE DEFAULT PACKING DENSITY VALUE)                                                                  
C     AUG 12/94 - F.MAJAESS (REWIND EMPTY FILE BEFORE WRITING ON IT)                                                                
C     JUN 14/94 - E. CHAN   (REMOVE PACKING OF RESTART FILE)                                                                        
C     OCT 23/93 - M. LAZARE (BY-PASS BACKSPACES, ETC. IF FIRST RECORD                                                               
C                            OF "NPAK" AT BEGINNING IS EMPTY. THIS IS                                                               
C                            REQURIED TO WORK PROPERLY ON SV08)                                                                     
C     AUG 10/92 - E. CHAN   (ADD RESTART FILE, ENSURE THAT ALL FIELDS ARE                                                           
C                            CONVERTED TO 64-BIT IEEE FORMAT, AND MODIFY I/O                                                        
C                            FOR 2-RECORD FORMAT)                                                                                   
C     JAN 29/92 - E. CHAN   (CONVERT HOLLERITH LITERALS TO ASCII AND REVISE                                                         
C                            RETRIEVAL OF LAST TIMESTEP FROM FILE BY USING                                                          
C                            NULL READS TO MOVE POINTER TO THE END OF FILE)                                                         
C     MAY 23/90 - M.LAZARE  (REPLACE "LTCV" BY "PBLT", CHANGE GC PACKING DEN.)                                                      
C     AUG 25/89 - M.LAZARE  BASED ON PAKGCMH, EXCEPT OUTPUTS TEMPERATURE.                                                           
C                                                                               J2                                                  
CPAKGCM7 - SAVES SPECTRAL, GRID AND ENERGY OUTPUT FROM THE HYBRID GCM   1  3    J1                                                  
C                                                                               J3                                                  
CAUTHOR  - R. LAPRISE                                                           J3                                                  
C                                                                               J3                                                  
CPURPOSE - SEPARATES AND PACKS THE THREE KINDS OF HYBRID GCM RUN OUTPUT         J3                                                  
C          DATA (SPECTRAL, GRID, ENERGY) INTO THEIR RESPECTIVE HISTORY FILES.   J3                                                  
C                                                                               J3                                                  
C          NOTE - SPECTRAL AND GRID FIELDS ARE PACKED, ENERGIES ARE NOT PACKED. J3                                                  
C                 "NPAKEN" FILE IS GENERATED ONLY IF THE CORRESPONDING FILE     J3                                                  
C                 FOR IT IS SPECIFIED ON THE PROGRAM CALL.                      J3                                                  
C                                                                               J3                                                  
CINPUT FILE(S)...                                                               J3                                                  
C                                                                               J3                                                  
C      OUTGCM       = FILE CONTAINING ALL FIELDS SAVED BY THE LAST JOB OF THE   J3                                                  
C                     HYBRID GCM.                                               J3                                                  
C                                                                               J3                                                  
COUTPUT FILES...                                                                J3                                                  
C                                                                               J3                                                  
C      NPAKSS,GS,EN = PACKED HISTORY FILES OF SPECTRAL, GRID AND ENERGY WITH    J3                                                  
C                     LATEST COMPUTED HYBRID GCM RUN FIELDS APPROPRIATELY       J3                                                  
C                     SEPARATED INTO THEM.                                      J3                                                  
C                     (IF NOT EMPTY, ANY EXISTING RECORDS WILL GET OVERWRITTEN) J3                                                  
C-------------------------------------------------------------------------                                                          
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      LOGICAL OK                                                                                                                    
                                                                                                                                    
      INTEGER KT(3),NREC(3),NPAK(3),IBUFS(8,3)                                                                                      
                                                                                                                                    
      COMMON/BLANCK/ F(271600)                                                                                                      
      COMMON/BUFCOM/ IBUF(8),IDAT(271600)                                                                                           
                                                                                                                                    
C     DATA KT/4HSPEC,4HGRID,4HENRG/                                                                                                 
      DATA MAXX/271600/                                                                                                             
C----------------------------------------------------------------------                                                             
      KT(1)=NC4TO8("SPEC")                                                                                                          
      KT(2)=NC4TO8("GRID")                                                                                                          
      KT(3)=NC4TO8("ENRG")                                                                                                          
C                                                                                                                                   
      NFIL=5                                                                                                                        
      CALL JCLPNT (NFIL,1,21,22,23,6)                                                                                               
                                                                                                                                    
C     * CHECK IF "NPAKEN" FILE IS REQUESTED BASED ON THE "NFIL" VALUE                                                               
C     * RETURNED BY "JCLPNT", THEN ADJUST "NKIND" VARIABLE ACCORDINGLY.                                                             
                                                                                                                                    
      IF ( NFIL.LT.4) CALL                         XIT('PAKGCM7',-1)                                                                
                                                                                                                                    
      IF ( NFIL.LT.5) THEN                                                                                                          
        NKIND=2                                                                                                                     
      ELSE                                                                                                                          
        NKIND=3                                                                                                                     
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * SETUP FOR EACH "KIND" AND ITS RESPECTIVE OUTPUT FILE.                                                                       
C                                                                                                                                   
      DO 100 N=1,NKIND                                                                                                              
                                                                                                                                    
       NREC(N)=0                                                                                                                    
       NPAK(N)  = 20+N                                                                                                              
       REWIND NPAK(N)                                                                                                               
                                                                                                                                    
  100 CONTINUE                                                                                                                      
                                                                                                                                    
C     * PROCESS THE INPUT DATA RECORDS.                                                                                             
                                                                                                                                    
      REWIND 1                                                                                                                      
      NRECS = 0                                                                                                                     
                                                                                                                                    
C     * PROCESS INPUT FIELDS AND WRITE SELECTED ONES TO THE APPROPRIATE                                                             
C     * OUTPUT FILE.                                                                                                                
                                                                                                                                    
  210 CALL RECGET(1,-1,-1,-1,-1,IBUF,MAXX,OK)                                                                                       
      IF(.NOT.OK) GO TO 400                                                                                                         
      NRECS=NRECS+1                                                                                                                 
                                                                                                                                    
C     ****************************                                                                                                  
C     * SKIP "DATA" NAMED RECORDS.                                                                                                  
C     ****************************                                                                                                  
                                                                                                                                    
      IF(IBUF(3).EQ.NC4TO8("DATA")) GO TO 210                                                                                       
                                                                                                                                    
C     ********************************************************                                                                      
C     * CHECK "ENRG" KIND RECORDS AND PROCESS IF REQUESTED ...                                                                      
C     ********************************************************                                                                      
                                                                                                                                    
      IF(IBUF(1).EQ.KT(3)) THEN                                                                                                     
        N=3                                                                                                                         
        IF(NKIND.LT.3) THEN                                                                                                         
                                                                                                                                    
C         * SKIP IF "ENRG" IS NOT ASKED FOR...                                                                                      
                                                                                                                                    
          GO TO 210                                                                                                                 
        ELSE                                                                                                                        
          NREC(N)=NREC(N)+1                                                                                                         
                                                                                                                                    
C                                                                                                                                   
C         * SET DEFAULT PACKING DENSITY FOR MATCHING RECORDS.                                                                       
C                                                                                                                                   
          NPACK=1                                                                                                                   
                                                                                                                                    
C         * UNPACK THE FIELD ONLY IF THE PACKING DENSITY IS CHANGED,                                                                
C         * OTHERWISE WRITE THE READ DATA OUT WITHOUT INVOKING THE                                                                  
C         * PACKER ROUTINES.                                                                                                        
                                                                                                                                    
          IF(IBUF(8).NE.NPACK) THEN                                                                                                 
C           * "UNPACK" THE FIELD...                                                                                                 
            CALL RECUP2(F,IBUF)                                                                                                     
            IBUF(8)=NPACK                                                                                                           
            GO TO 270                                                                                                               
          ELSE                                                                                                                      
                                                                                                                                    
C           * PRESERVE THE LABEL OF THE FIRST MATCHING RECORD                                                                       
C           * TO BE DISPLAYED AT THE END TO THE STANDARD OUTPUT                                                                     
C           * FILE.                                                                                                                 
                                                                                                                                    
            IF(NREC(N).EQ.1 ) THEN                                                                                                  
              DO I=1,8                                                                                                              
                IBUFS(I,N)=IBUF(I)                                                                                                  
              ENDDO                                                                                                                 
            ENDIF                                                                                                                   
                                                                                                                                    
            CALL RECPUT(NPAK(N),IBUF)                                                                                               
            GO TO 210                                                                                                               
          ENDIF                                                                                                                     
        ENDIF                                                                                                                       
      ENDIF                                                                                                                         
                                                                                                                                    
                                                                                                                                    
C     ************************                                                                                                      
C     * "SPEC" KIND RECORDS...                                                                                                      
C     ************************                                                                                                      
                                                                                                                                    
      IF(IBUF(1).EQ.KT(1)) THEN                                                                                                     
        N=1                                                                                                                         
        NREC(N)=NREC(N)+1                                                                                                           
                                                                                                                                    
C                                                                                                                                   
C       * SET DEFAULT PACKING DENSITY FOR MATCHING RECORDS.                                                                         
C                                                                                                                                   
        NPACK=2                                                                                                                     
                                                                                                                                    
C       * UNPACK THE FIELD ONLY IF THE PACKING DENSITY IS CHANGED                                                                   
C       * OR PROCESSING AN "LNSP" RECORD,                                                                                           
C       * OTHERWISE WRITE THE READ DATA OUT WITHOUT INVOKING THE                                                                    
C       * PACKER ROUTINES.                                                                                                          
                                                                                                                                    
        IF(IBUF(3).EQ.NC4TO8("LNSP").OR.IBUF(8).NE.NPACK) THEN                                                                      
C         * "UNPACK" THE FIELD...                                                                                                   
          CALL RECUP2(F,IBUF)                                                                                                       
          IBUF(8)=NPACK                                                                                                             
          IF(IBUF(3).EQ.NC4TO8("LNSP")) THEN                                                                                        
                                                                                                                                    
C          * CONVERT LOG OF SURFACE PRESSURE LNSP FROM PA TO MB.                                                                    
                                                                                                                                    
           IBUF(4)=1                                                                                                                
           F(1)=F(1)-LOG(100.E0)*SQRT(2.E0)                                                                                         
          ENDIF                                                                                                                     
          GO TO 270                                                                                                                 
        ELSE                                                                                                                        
                                                                                                                                    
C         * PRESERVE THE LABEL OF THE FIRST MATCHING RECORD                                                                         
C         * TO BE DISPLAYED AT THE END TO THE STANDARD OUTPUT                                                                       
C         * FILE.                                                                                                                   
                                                                                                                                    
          IF(NREC(N).EQ.1 ) THEN                                                                                                    
            DO I=1,8                                                                                                                
              IBUFS(I,N)=IBUF(I)                                                                                                    
            ENDDO                                                                                                                   
          ENDIF                                                                                                                     
                                                                                                                                    
          CALL RECPUT(NPAK(N),IBUF)                                                                                                 
          GO TO 210                                                                                                                 
        ENDIF                                                                                                                       
      ENDIF                                                                                                                         
                                                                                                                                    
C     *********************************************************                                                                     
C     * OTHERS RECORDS, INCLUDING "GRID" KIND, NOT MATCHING ANY                                                                     
C     * OF THE ABOVE TYPES...                                                                                                       
C     *********************************************************                                                                     
                                                                                                                                    
      N=2                                                                                                                           
      NREC(N)=NREC(N)+1                                                                                                             
                                                                                                                                    
C                                                                                                                                   
C     * SET DEFAULT PACKING DENSITY FOR MATCHING RECORDS.                                                                           
C                                                                                                                                   
      NPACK=4                                                                                                                       
                                                                                                                                    
      NAME=IBUF(3)                                                                                                                  
C                                                                                                                                   
      IF(NAME.EQ.NC4TO8("PVEG") .OR. NAME.EQ.NC4TO8("SVEG") .OR.                                                                    
     1   NAME.EQ.NC4TO8("SOIL") .OR. NAME.EQ.NC4TO8("PBLT") .OR.                                                                    
     2                               NAME.EQ.NC4TO8("  GC")                                                                         
     3                                                     ) NPACK=1                                                                
C                                                                                                                                   
      IF(NAME.EQ.NC4TO8(" PCP") .OR. NAME.EQ.NC4TO8("  GT") .OR.                                                                    
     1   NAME.EQ.NC4TO8(" SIC") .OR. NAME.EQ.NC4TO8(" SNO") .OR.                                                                    
     2   NAME.EQ.NC4TO8(" HFS") .OR. NAME.EQ.NC4TO8(" QFS") .OR.                                                                    
     3   NAME.EQ.NC4TO8(" UFS") .OR. NAME.EQ.NC4TO8("OUFS") .OR.                                                                    
     4   NAME.EQ.NC4TO8(" VFS") .OR. NAME.EQ.NC4TO8("OVFS") .OR.                                                                    
     5   NAME.EQ.NC4TO8(" BEG") .OR. NAME.EQ.NC4TO8("OBEG") .OR.                                                                    
     6   NAME.EQ.NC4TO8(" BWG") .OR. NAME.EQ.NC4TO8("OBWG") .OR.                                                                    
     7   NAME.EQ.NC4TO8("  FN") .OR. NAME.EQ.NC4TO8("  ZN")                                                                         
     8                                                     ) NPACK=2                                                                
                                                                                                                                    
C     * UNPACK THE FIELD ONLY IF THE PACKING DENSITY IS CHANGED,                                                                    
C     * OTHERWISE WRITE THE READ DATA OUT WITHOUT INVOKING THE                                                                      
C     * PACKER ROUTINES.                                                                                                            
                                                                                                                                    
      IF(IBUF(8).NE.NPACK) THEN                                                                                                     
C       * "UNPACK" THE FIELD...                                                                                                     
        CALL RECUP2(F,IBUF)                                                                                                         
        IBUF(8)=NPACK                                                                                                               
        GO TO 270                                                                                                                   
      ELSE                                                                                                                          
                                                                                                                                    
C       * PRESERVE THE LABEL OF THE FIRST MATCHING RECORD                                                                           
C       * TO BE DISPLAYED AT THE END TO THE STANDARD OUTPUT                                                                         
C       * FILE.                                                                                                                     
                                                                                                                                    
        IF(NREC(N).EQ.1 ) THEN                                                                                                      
          DO I=1,8                                                                                                                  
            IBUFS(I,N)=IBUF(I)                                                                                                      
          ENDDO                                                                                                                     
        ENDIF                                                                                                                       
                                                                                                                                    
        CALL RECPUT(NPAK(N),IBUF)                                                                                                   
        GO TO 210                                                                                                                   
      ENDIF                                                                                                                         
C                                                                                                                                   
  270 CONTINUE                                                                                                                      
                                                                                                                                    
C     * PRESERVE THE LABEL OF THE FIRST MATCHING RECORD                                                                             
C     * TO BE DISPLAYED AT THE END TO THE STANDARD OUTPUT                                                                           
C     * FILE.                                                                                                                       
                                                                                                                                    
      IF(NREC(N).EQ.1 ) THEN                                                                                                        
        DO I=1,8                                                                                                                    
          IBUFS(I,N)=IBUF(I)                                                                                                        
        ENDDO                                                                                                                       
      ENDIF                                                                                                                         
                                                                                                                                    
      CALL PUTFLD2 (NPAK(N),F,IBUF,MAXX)                                                                                            
      GO TO 210                                                                                                                     
                                                                                                                                    
  400 CONTINUE                                                                                                                      
                                                                                                                                    
C     * ABORT ON EMPTY INPUT FILE.                                                                                                  
                                                                                                                                    
      IF(NRECS.EQ.0) THEN                                                                                                           
        WRITE(6,6000)                                                                                                               
        CALL                                       XIT('PAKGCM7',-2)                                                                
      ENDIF                                                                                                                         
                                                                                                                                    
C     *********************************************************                                                                     
C     * FOR EACH KIND; DISPLAY THE LABEL OF THE FIRST PROCESSED                                                                     
C     *                RECORD AND THE NUMBER OF RECORDS ADDED.                                                                      
C     *********************************************************                                                                     
                                                                                                                                    
      WRITE(6,6010) NRECS                                                                                                           
      DO N=1,NKIND                                                                                                                  
        WRITE(6,6030) (IBUFS(I,N),I=1,8)                                                                                            
        WRITE(6,6020) KT(N),NREC(N)                                                                                                 
      ENDDO                                                                                                                         
      CALL                                         XIT('PAKGCM7',0)                                                                 
C---------------------------------------------------------------------                                                              
 6000 FORMAT (' EMPTY INPUT FILE ...')                                                                                              
 6010 FORMAT (' PROCESSED A TOTAL OF ',I9,' INPUT RECORDS,',                                                                        
     +        ' AND WROTE:',/)                                                                                                      
 6020 FORMAT (' ',A4,' RECORDS =',I9)                                                                                               
 6030 FORMAT (' ',50X,A4,I10,1X,A4,I10,4I6)                                                                                         
      END                                                                                                                           
