      PROGRAM PAKGCM9                                                                                                               
C     PROGRAM PAKGCM9 (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     NOV 11/18 - S.KHARIN (DO NO PRINT IBUF IF NO RECORDS ARE FOUND).          J2                                                  
C     JUL 24/13 - K.VONSALZEN (USE NPACK=1 FOR "PLA" VARIABLES, AND CHANGE      J2                                                  
C                              DEFAULT NPACK=4 TO NPACK=2)                      J2                                                  
C     JUL 24/13 - K.VONSALZEN PREVIOUS VERSION PAKGCM8.                                                                             
C                                                                               J2                                                  
CPAKGCM9 - 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                 GRID FIELDS ARE CONVERTED FROM MODEL INTERNAL CHAINED         J3                                                  
C                 S-N ALTERNATING QUARTETS TO REGULAR (S-N) ORDERING PRIOR      J3                                                  
C                 TO BEING WRITTEN.                                             J3                                                  
C                 SIMILARILY, SPEC FIELDS ARE CONVERTED FROM HIGH-LOW           J3                                                  
C                 ZONAL WAVENUMBER PAIRS INTO USUAL TRIANGULAR ORDER.           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)                                                                                                                 
C                                                                                                                                   
      INTEGER LSR(2,66)                                                                                                             
C                                                                                                                                   
      LOGICAL OK                                                                                                                    
                                                                                                                                    
      INTEGER KT(3),NREC(3),NPAK(3),IBUFS(8,3)                                                                                      
                                                                                                                                    
      COMMON/BLANCK/ F(271600),G(271600)                                                                                            
      COMMON/BUFCOM/ IBUF(8),IDAT(271600)                                                                                           
                                                                                                                                    
      DATA MAXX/271600/                                                                                                             
C----------------------------------------------------------------------                                                             
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('PAKGCM9',-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                                                                                                                     
      NSP=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                                                                                                                                   
C         * SKIP IF "ENRG" IS NOT ASKED FOR...                                                                                      
C                                                                                                                                   
          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                                                                                                                                   
C           * "UNPACK" THE FIELD...                                                                                                 
C                                                                                                                                   
            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       * CALCULATE SPECTRAL TRIANGLE INFORMATION (INVARIANT                                                                        
C       * SO ONLY NEED TO DO THIS ONCE).                                                                                            
C                                                                                                                                   
        NPACK=2                                                                                                                     
        IF(NSP.EQ.0) CALL DIMGT(LSR,LA,LR,LM,KTR,IBUF(7))                                                                           
        NSP=1                                                                                                                       
C                                                                                                                                   
C       * CONVERT ORDERED LOW-HIGH ZONAL WAVENUMBER PAIRS TO USUAL                                                                  
C       * SPECTRAL TRIANGLE ORDER, IE (1,LM,2,LM-1...) -> (1,2,...LM-1,LM).                                                         
C                                                                                                                                   
        CALL RECUP2(G,IBUF)                                                                                                         
        IBUF(8)=NPACK                                                                                                               
        CALL REC2TRI (F,G,LA,LSR,LM)                                                                                                
C                                                                                                                                   
        IF(IBUF(3).EQ.NC4TO8("LNSP")) THEN                                                                                          
C                                                                                                                                   
C          * CONVERT LOG OF SURFACE PRESSURE LNSP FROM PA TO MB.                                                                    
C                                                                                                                                   
           IBUF(4)=1                                                                                                                
           F(1)=F(1)-LOG(100.E0)*SQRT(2.E0)                                                                                         
        ENDIF                                                                                                                       
        GO TO 270                                                                                                                   
      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=2                                                                                                                       
                                                                                                                                    
      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") .OR. NAME.EQ.NC4TO8(" TCV") .OR.                                                                    
     3   NAME.EQ.NC4TO8("WTAB") .OR. NAME.EQ.NC4TO8("SUNL")) NPACK=1                                                                
C                                                                                                                                   
      IF(NAME.EQ.NC4TO8("CF01") .OR. NAME.EQ.NC4TO8("CF02") .OR.                                                                    
     1   NAME.EQ.NC4TO8("CF03") .OR. NAME.EQ.NC4TO8("CF04")) NPACK=1                                                                
C                                                                                                                                   
      IF(NAME.EQ.NC4TO8("OT01") .OR. NAME.EQ.NC4TO8("OT02") .OR.                                                                    
     1   NAME.EQ.NC4TO8("OT03") .OR. NAME.EQ.NC4TO8("OT04") .OR.                                                                    
     2   NAME.EQ.NC4TO8("OT05") .OR. NAME.EQ.NC4TO8("OT06") .OR.                                                                    
     3   NAME.EQ.NC4TO8("OT07") .OR. NAME.EQ.NC4TO8("OT08") .OR.                                                                    
     4   NAME.EQ.NC4TO8("OT09") .OR. NAME.EQ.NC4TO8("OT10") .OR.                                                                    
     5   NAME.EQ.NC4TO8("OT11") .OR. NAME.EQ.NC4TO8("OT12") .OR.                                                                    
     6   NAME.EQ.NC4TO8("OT13") .OR. NAME.EQ.NC4TO8("OT14") .OR.                                                                    
     7   NAME.EQ.NC4TO8("OT15") .OR. NAME.EQ.NC4TO8("OT16") .OR.                                                                    
     8   NAME.EQ.NC4TO8("OT17") .OR. NAME.EQ.NC4TO8("OT18") .OR.                                                                    
     9   NAME.EQ.NC4TO8("OT19") .OR. NAME.EQ.NC4TO8("OT20")) NPACK=1                                                                
      IF(NAME.EQ.NC4TO8("OT21") .OR. NAME.EQ.NC4TO8("OT22") .OR.                                                                    
     1   NAME.EQ.NC4TO8("OT23") .OR. NAME.EQ.NC4TO8("OT24") .OR.                                                                    
     2   NAME.EQ.NC4TO8("OT25") .OR. NAME.EQ.NC4TO8("OT26") .OR.                                                                    
     3   NAME.EQ.NC4TO8("OT27") .OR. NAME.EQ.NC4TO8("OT28") .OR.                                                                    
     4   NAME.EQ.NC4TO8("OT29") .OR. NAME.EQ.NC4TO8("OT30") .OR.                                                                    
     5   NAME.EQ.NC4TO8("OT31") .OR. NAME.EQ.NC4TO8("OT32") .OR.                                                                    
     6   NAME.EQ.NC4TO8("OT33") .OR. NAME.EQ.NC4TO8("OT34") .OR.                                                                    
     7   NAME.EQ.NC4TO8("OT35") .OR. NAME.EQ.NC4TO8("OT36") .OR.                                                                    
     8   NAME.EQ.NC4TO8("OT37") .OR. NAME.EQ.NC4TO8("OT38") .OR.                                                                    
     9   NAME.EQ.NC4TO8("OT39") .OR. NAME.EQ.NC4TO8("OT40")) NPACK=1                                                                
      IF(NAME.EQ.NC4TO8("OT41") .OR. NAME.EQ.NC4TO8("OT42") .OR.                                                                    
     1   NAME.EQ.NC4TO8("OT43") .OR. NAME.EQ.NC4TO8("OT44") .OR.                                                                    
     2   NAME.EQ.NC4TO8("OT45") .OR. NAME.EQ.NC4TO8("OT46") .OR.                                                                    
     3   NAME.EQ.NC4TO8("OT47") .OR. NAME.EQ.NC4TO8("OT48") .OR.                                                                    
     4                               NAME.EQ.NC4TO8("OT49")) 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")) NPACK=2                                                                
C                                                                                                                                   
      IF(NAME.EQ.NC4TO8("VOAE") .OR. NAME.EQ.NC4TO8("VBCE") .OR.                                                                    
     1   NAME.EQ.NC4TO8("VASE") .OR. NAME.EQ.NC4TO8("VMDE") .OR.                                                                    
     2   NAME.EQ.NC4TO8("VSSE") .OR. NAME.EQ.NC4TO8("VOAW") .OR.                                                                    
     3   NAME.EQ.NC4TO8("VBCW") .OR. NAME.EQ.NC4TO8("VASW") .OR.                                                                    
     4   NAME.EQ.NC4TO8("VMDW") .OR. NAME.EQ.NC4TO8("VSSW") .OR.                                                                    
     5   NAME.EQ.NC4TO8("VOAD") .OR. NAME.EQ.NC4TO8("VBCD") .OR.                                                                    
     6   NAME.EQ.NC4TO8("VASD") .OR. NAME.EQ.NC4TO8("VMDD") .OR.                                                                    
     7   NAME.EQ.NC4TO8("VSSD") .OR. NAME.EQ.NC4TO8("VOAG") .OR.                                                                    
     8   NAME.EQ.NC4TO8("VBCG") .OR. NAME.EQ.NC4TO8("VASG") .OR.                                                                    
     9   NAME.EQ.NC4TO8("VMDG") .OR. NAME.EQ.NC4TO8("VSSG") .OR.                                                                    
     1   NAME.EQ.NC4TO8("VOAC") .OR. NAME.EQ.NC4TO8("VBCC") .OR.                                                                    
     2   NAME.EQ.NC4TO8("VASC") .OR. NAME.EQ.NC4TO8("VMDC") .OR.                                                                    
     3   NAME.EQ.NC4TO8("VSSC") .OR. NAME.EQ.NC4TO8("VASI") .OR.                                                                    
     4   NAME.EQ.NC4TO8("VAS1") .OR. NAME.EQ.NC4TO8("VAS2") .OR.                                                                    
     5   NAME.EQ.NC4TO8("VAS3")) NPACK=1                                                                                            
C                                                                                                                                   
C     * "UNPACK" THE FIELD...                                                                                                       
C                                                                                                                                   
      CALL RECUP2(G,IBUF)                                                                                                           
C                                                                                                                                   
C     * CONVERT FROM MODEL INTERNAL FORMAT TO "REGULAR" GRID.                                                                       
C     * NOTE THAT NO GRID CONVERSION IS DONE IF IBUF(7).NE.0 SINCE THIS                                                             
C     * SPECIAL FLAG IS SET ONLY FOR S/L FIELDS OR RCM.                                                                             
C     * RESET IBUF(7) TO ZERO IF S/L FIELD SO THAT DIAGNOSTICS WILL WORK                                                            
C     * (FOR INSTANCE, "CMPLBL" OF TRANSFORMED TEMPERATURE FROM SPECTRAL                                                            
C     * VERSUS S/L MOISTURE). THIS IS NOT DONE FOR THE RCM CASES.                                                                   
C                                                                                                                                   
      IF(IBUF(7).EQ.0)                                        THEN                                                                  
        CALL CGTORG (F,G,IBUF(5),IBUF(6))                                                                                           
      ELSE                                                                                                                          
        DO I=1,IBUF(5)*IBUF(6)                                                                                                      
          F(I)=G(I)                                                                                                                 
        ENDDO                                                                                                                       
        IF(IBUF(7).EQ.10) IBUF(7)=0                                                                                                 
      ENDIF                                                                                                                         
      IBUF(8)=NPACK                                                                                                                 
  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('PAKGCM9',-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                                                                                                                  
        IF(NREC(N).GT.0)WRITE(6,6030) (IBUFS(I,N),I=1,8)                                                                            
        WRITE(6,6020) KT(N),NREC(N)                                                                                                 
      ENDDO                                                                                                                         
      CALL                                         XIT('PAKGCM9',0)                                                                 
C---------------------------------------------------------------------                                                              
 6000 FORMAT (' EMPTY INPUT FILE ...')                                                                                              
 6010 FORMAT (' PROCESSED A TOTAL OF ',I9,' INPUT RECORDS,',                                                                        
     1        ' AND WROTE:',/)                                                                                                      
 6020 FORMAT (' ',A4,' RECORDS =',I9)                                                                                               
 6030 FORMAT (' ',50X,A4,I10,1X,A4,I10,4I6)                                                                                         
      END                                                                                                                           
