      PROGRAM PAKGCMH                                                                                                               
C     PROGRAM PAKGCMH (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     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  (READ DATA LABEL WITH FBUFFIN SINCE PUTSTG6                                                            
C                             NOW WRITING IN STANDARD 64-BIT INTEGERS.                                                              
C                             ALSO, BY-PASS BACKSPACES, ETC. IF FIRST RECORD                                                        
C                             OF "NPAK" AT BEGINNING IS EMPTY. THIS IS                                                              
C                             REQURIED TO WORK PROPERLY ON SV08)                                                                    
C     JUN 12/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     MAR 04/91 - F.MAJAESS (CORRECT COMPLEX ARRAY DIMENSIONS)                                                                      
C     MAY 15/89 - M.LAZARE (CHANGE OBEG, OUFS ,OVFS AND GT PACKING DENSITIES)                                                       
C     SEP 23/88 - M.LAZARE (CHANGED TO ENSURE CAN RUN AT 50 LEVELS).                                                                
C     JUL 08/88 - M.LAZARE (CHANGED TO ENSURE THE DISCRETE-VALUED FIELD                                                             
C                           LTCV IS NOT PACKED (IBUF(8)=1).                                                                         
C     JUL 04/88 - M.LAZARE (CHANGED TO ENSURE THE DISCRETE-VALUED FIELDS                                                            
C                           PVEG, SVEG AND SOIL ARE NOT PACKED (IBUF(8)=1).                                                         
C     MAY 24/88 - M.LAZARE (INCREASE NUMBER OF ALLOWED LEVELS TO 50).                                                               
C     MAR 09/88 - R.LAPRISE.                                                                                                        
C                                                                               J2                                                  
CPAKGCMH - 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 - A "PHI" FIELD IS DEFINED AS PHIS+INT(R*T*D LN ETA)            J3                                                  
C                 FOR UPWARD COMPATIBILITY IN GSAPZL.                           J3                                                  
C                 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 LSPHI(100)                                                                                                            
      INTEGER KT(3),LEV(100),LS(100)                                                                                                
                                                                                                                                    
      REAL RLSPHI(100)                                                                                                              
      REAL TMEAN (100),TMEANH(100),PEEMN(100),SF(100),RLS(100)                                                                      
                                                                                                                                    
      COMPLEX PHIS(2145),PS(2145),T(214500),PEE(214500),                                                                            
     1        PHI(214500)                                                                                                           
      EQUIVALENCE (T(1),PHI(1),PEE(1))                                                                                              
                                                                                                                                    
                                                                                                                                    
      COMMON/BLANCK/ F(271600)                                                                                                      
      COMMON/BUFCOM/ IBUF(8),IDAT(271600)                                                                                           
                                                                                                                                    
C     DATA KT/4HSPEC,4HGRID,4HENRG/                                                                                                 
      DATA MAXX/271600/, MAXL/100/                                                                                                  
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('PAKGCMH',-1)                                                                
                                                                                                                                    
      IF ( NFIL.LT.5) THEN                                                                                                          
        NKIND=2                                                                                                                     
      ELSE                                                                                                                          
        NKIND=3                                                                                                                     
      ENDIF                                                                                                                         
                                                                                                                                    
C                                                                                                                                   
C     * GENERATE SS, GS, AND ENERGY FILES FIRST.                                                                                    
C                                                                                                                                   
                                                                                                                                    
C     * LOOP OVER UP TO THE THREE "KIND" OF DATA.                                                                                   
                                                                                                                                    
      DO 400 N=1,NKIND                                                                                                              
                                                                                                                                    
      NPAK  = 20+N                                                                                                                  
      KTYP  = KT(N)                                                                                                                 
      REWIND 1                                                                                                                      
      REWIND NPAK                                                                                                                   
      NRECS = 0                                                                                                                     
                                                                                                                                    
                                                                                                                                    
  150 IF(KTYP.EQ.NC4TO8("SPEC")) THEN                                                                                               
                                                                                                                                    
C        * FIND NECESSARY DATA FOR T TO "PHI" CONVERSION                                                                            
C        * IF NONE FOUND, NO SPECTRAL FIELDS ARE BEING SAVED.                                                                       
                                                                                                                                    
         CALL FIND (1,NC4TO8("ZONL"),-1,NC4TO8("DATA"),1,OK)                                                                        
         IF(OK) THEN                                                                                                                
            CALL FBUFFIN(1,IBUF,-8,K,LEN)                                                                                           
            IF(K.GE.0) GO TO 902                                                                                                    
            BACKSPACE 1                                                                                                             
            READ(1,END=903,ERR=902) RILEV,RLA,RGAS,PSMN,                                                                            
     1                    ( TMEAN(L),L=1,INT(RILEV)),                                                                               
     2                    (TMEANH(L),L=1,INT(RILEV)),                                                                               
     3                    ( PEEMN(L),L=1,INT(RILEV)),                                                                               
     4                    (    SF(L),L=1,INT(RILEV)),                                                                               
     5                    (   RLS(L),L=1,INT(RILEV)),                                                                               
     6                    (RLSPHI(L),L=1,INT(RILEV))                                                                                
            ILEV  = INT(RILEV)                                                                                                      
            IF((ILEV.LT.1).OR.(ILEV.GT.MAXL)) CALL XIT('PAKGCMH',-2)                                                                
            LA    = INT(  RLA)                                                                                                      
            DO 200 L=1,ILEV                                                                                                         
              LSPHI(L) = INT(RLSPHI(L))                                                                                             
              LS   (L) = INT(RLS   (L))                                                                                             
  200       CONTINUE                                                                                                                
         ENDIF                                                                                                                      
         REWIND 1                                                                                                                   
      ENDIF                                                                                                                         
                                                                                                                                    
C     * SELECT FIELDS OF TYPE KTYP FROM OUTGCM AND ADD TO NPAK.                                                                     
C     * SKIP OVER SPECTRAL DATA RECORDS.                                                                                            
                                                                                                                                    
  210 CALL GETFLD2 (1,F,KTYP,0,NC4TO8("NEXT"),0,IBUF,MAXX,OK)                                                                       
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6020) KTYP,NRECS                                                                                                    
        GO TO 400                                                                                                                   
      ENDIF                                                                                                                         
      IF(IBUF(3).EQ.NC4TO8("DATA"))  GO TO 210                                                                                      
                                                                                                                                    
C     * CHOOSE PACKING DENSITY AND PUT FIELD ONTO NPAK.                                                                             
                                                                                                                                    
      IF(KTYP.EQ.NC4TO8("ENRG"))     THEN                                                                                           
        IBUF(8)=1                                                                                                                   
        GO TO 270                                                                                                                   
      ENDIF                                                                                                                         
                                                                                                                                    
      IBUF(8)=2                                                                                                                     
      IF(KTYP.EQ.NC4TO8("SPEC")) THEN                                                                                               
          IF(IBUF(3).EQ.NC4TO8("PHIS")) THEN                                                                                        
                                                                                                                                    
C             * CALCULATE "PHI" AND                                                                                                 
C             * CONVERT LOG OF SURFACE PRESSURE LNSP FORM PA TO MB.                                                                 
                                                                                                                                    
              KTIME =IBUF(2)                                                                                                        
              KPACK =IBUF(8)                                                                                                        
              NWDS =IBUF(5)*IBUF(6)                                                                                                 
              DO 240 I=1,NWDS                                                                                                       
  240         PHIS(I)=CMPLX(F(2*I-1),F(2*I))                                                                                        
              CALL PUTFLD2 (NPAK,F,IBUF,MAXX)                                                                                       
              IF(NRECS.EQ.0) WRITE(6,6030) (IBUF(I),I=1,8)                                                                          
              NRECS =NRECS+1                                                                                                        
                                                                                                                                    
              CALL GETFLD2 (1,F,NC4TO8("SPEC"),KTIME,NC4TO8("LNSP"),                                                                
     +                                               1,IBUF,MAXX,OK)                                                                
              IF(.NOT.OK) CALL                     XIT('PAKGCMH',-3)                                                                
              IF((IBUF(5)*IBUF(6)).NE.NWDS) CALL   XIT('PAKGCMH',-4)                                                                
              DO 250 I=1,NWDS                                                                                                       
  250         PS(I)=CMPLX(F(2*I-1),F(2*I))                                                                                          
                                                                                                                                    
              CALL GETSET2 (1,T,LEV,NLEV,IBUF,MAXX,OK)                                                                              
              IF(.NOT.OK) CALL                     XIT('PAKGCMH',-5)                                                                
              IF((IBUF(5)*IBUF(6)).NE.NWDS) CALL   XIT('PAKGCMH',-6)                                                                
              IF(NLEV.NE.ILEV) CALL                XIT('PAKGCMH',-7)                                                                
              IF(IBUF(2).NE.KTIME) CALL            XIT('PAKGCMH',-8)                                                                
              CALL BPFT   (PEE,T,PS,PHIS,LA,ILEV,TMEAN,RGAS,SF)                                                                     
              CALL GZFBP  (PHI,PEE,PS,TMEAN,PEEMN,PSMN,LA,ILEV,RGAS)                                                                
              IBUF(3)=NC4TO8(" PHI")                                                                                                
              IBUF(8)=KPACK                                                                                                         
              CALL PUTSET2 (NPAK,PHI,LSPHI,ILEV,IBUF,MAXX)                                                                          
              NRECS   =NRECS+ILEV                                                                                                   
              IBUF(3) =NC4TO8("LNSP")                                                                                               
              IBUF(4) =1                                                                                                            
              F(1)=F(1)+PSMN-LOG(100.E0)*SQRT(2.E0)                                                                                 
          ENDIF                                                                                                                     
          GO TO 270                                                                                                                 
      ENDIF                                                                                                                         
                                                                                                                                    
      IBUF(8)=4                                                                                                                     
      IF(IBUF(3).EQ.NC4TO8("PVEG")) IBUF(8)=1                                                                                       
      IF(IBUF(3).EQ.NC4TO8("SVEG")) IBUF(8)=1                                                                                       
      IF(IBUF(3).EQ.NC4TO8("SOIL")) IBUF(8)=1                                                                                       
      IF(IBUF(3).EQ.NC4TO8("LTCV")) IBUF(8)=1                                                                                       
      IF(IBUF(3).EQ.NC4TO8(" PCP")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8("  GT")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8(" SIC")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8(" SNO")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8(" HFS")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8(" QFS")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8(" UFS")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8("OUFS")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8(" VFS")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8("OVFS")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8(" BEG")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8("OBEG")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8("  FN")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8("  ZN")) IBUF(8)=2                                                                                       
      IF(IBUF(3).EQ.NC4TO8("  GC")) IBUF(8)=4                                                                                       
C                                                                                                                                   
      IF(IBUF(8).EQ.0) IBUF(8)=1                                                                                                    
C                                                                                                                                   
  270 CALL PUTFLD2 (NPAK,F,IBUF,MAXX)                                                                                               
      IF(NRECS.EQ.0) WRITE(6,6030) (IBUF(I),I=1,8)                                                                                  
      NRECS =NRECS+1                                                                                                                
      GO TO 210                                                                                                                     
                                                                                                                                    
  400 CONTINUE                                                                                                                      
                                                                                                                                    
      CALL                                         XIT('PAKGCMH',0)                                                                 
                                                                                                                                    
C     * ERROR EXIT.                                                                                                                 
                                                                                                                                    
  901 CALL                                         XIT('PAKGCMH',-9)                                                                
  902 CALL                                         XIT('PAKGCMH',-10)                                                               
  903 CALL                                         XIT('PAKGCMH',-11)                                                               
C---------------------------------------------------------------------                                                              
 6020 FORMAT (' ',A4,' RECORDS = ',I6)                                                                                              
 6030 FORMAT (' ',50X,A4,I10,1X,A4,I10,4I6)                                                                                         
      END                                                                                                                           
