      PROGRAM CLDPROG                                                                                                               
C     PROGRAM CLDPROG (T,Q,GSLNSP,LTOP,GSTCLD,GSCLD,GSTLWC,                     J2                                                  
C    1                 GSEMI,GSTAC,GSZTAC,CX,TX,EX,RH,INPUT,OUTPUT,     )       J2                                                  
                                                                                                                                    
C    2                TAPE1=T,TAPE2=Q,TAPE3=GSLNSP,TAPE4=LTOP,                                                                      
C    3                TAPE11=GSTCLD,TAPE12=GSCLD,TAPE13=GSTLWC,                                                                     
C    4                TAPE14=GSEMI,TAPE15=GSTAC,TAPE16=GSZTAC,                                                                      
C    5                TAPE17=CX,TAPE18=TX,TAPE19=EX,TAPE20=RH,                                                                      
C    6                TAPE5=INPUT,TAPE6=OUTPUT)                                                                                     
C     -------------------------------------------------------------             J2                                                  
C                                                                               J2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       J2                                                  
C     NOV 06/95 - F.MAJAESS (REVISE DEFAULT PACKING DENSITY VALUE)                                                                  
C     AUG 18/95 - F.MAJAESS(FIX A BUG FOR ZRDM CLOUDS3 CALL)                                                                        
C     JAN 07/93 - E. CHAN  (DECODE LEVELS IN 8-WORD LABEL)                                                                          
C     JUL 13/92 - E. CHAN  (DIMENSION SELECTED VARIABLES AS REAL*8)                                                                 
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     MAY 15/89 - M.LAZARE (MINOR ADJUSTMENTS ON VERTICAL LEVEL INDEX)                                                              
C     JAN 30/89 - M.LAZARE (ADD 'EPSICE' COMMON BLOCK)                                                                              
C     DEC 12/88 - H.BARKER, JP.BLANCHET, M.LAZARE.                                                                                  
C                                                                               J2                                                  
CCLDPROG - CALCULATES CLOUD PROPERTIES BASED ON MODEL OUTPUT DATA.      4  9 C GJ1                                                  
C                                                                               J3                                                  
CAUTHOR  - H.BARKER, JP.BLANCHET, M.LAZARE.                                     J3                                                  
C                                                                               J3                                                  
CPURPOSE - THIS PROGRAM UTILIZES MODEL OUTPUT OF TEMPERATURE (DEG K),           J3                                                  
C          SPECIFIC HUMIDITY, LN(SURFACE PRESSURE) AND TOP-OF-                  J3                                                  
C          CONVECTION LEVEL INDEX, TO DERIVED ASSOCIATED DIAGNOSTIC             J3                                                  
C          PROPERTIES OF CLOUDS.                                                J3                                                  
C          NOTE - THE CLOUDS AND RELATIVE HUMIDITY SUBROUTINES CALLED INSIDE    J3                                                  
C                 THIS PROGRAM SHOULD BE THE SAME AS THOSE CALLED IN THE        J3                                                  
C                 PHYSICS SECTION OF THE MODEL. THE ABSOLUTE OF THIS PROGRAM    J3                                                  
C                 (IF EXISTS) SHOULD BE RE-GENERATED WHENEVER EITHER OF THESE   J3                                                  
C                 SUBROUTINES ARE MODIFIED, OR NEW VERSIONS CREATED (IN THE     J3                                                  
C                 LATTER CASE, A NEW VERSION OF THIS PROGRAM AND AN ASSOCIATED  J3                                                  
C                 NEW DIAGNOSTIC DECK CALLING IT SHOULD ALSO BE CREATED).       J3                                                  
C                 THE DIMENSIONS ARE APPROPRIATE FOR UP TO T30/L15 RESOLUTION.  J3                                                  
C                                                                               J3                                                  
CINPUT FILES...                                                                 J3                                                  
C                                                                               J3                                                  
C      T      = MODEL TEMPERATURES.                                             J3                                                  
C      Q      = MODEL SPECIFIC HUMIDITY.                                        J3                                                  
C      GSLNSP = MODEL LN(SURFACE PRESSURE).                                     J3                                                  
C      LTOP   = MODEL TOP-OF-CONVECTION LEVEL INDEX.                            J3                                                  
C                                                                               J3                                                  
COUTPUT FILES...                                                                J3                                                  
C                                                                               J3                                                  
C      GSTCLD = TOTAL OVERLAPPED CLOUD AMOUNT.                                  J3                                                  
C      GSCLD  = CLOUD AMOUNT BY LAYER.                                          J3                                                  
C      GSTLWC = TOTAL CLOUD LIQUID WATER PATH.                                  J3                                                  
C      GSEMI  = CLOUD AMOUNT*EMISSIVITY BY LATER.                               J3                                                  
C      GSTAC  = CLOUD AMOUNT*OPTICAL DEPTH BY LAYER.                            J3                                                  
C      GSZTAC = CLOUD OPTICAL DEPTH PER 100 MB.                                 J3                                                  
C      CX     = BLOCK CLOUD AMOUNT.                                             J3                                                  
C      TX     = BLOCK CLOUD AMOUNT*OPTICAL DEPTH.                               J3                                                  
C      EX     = BLOCK CLOUD AMOUNT*EMISSIVITY.                                  J3                                                  
C      RH     = MODEL RELATIVE HUMIDITY.                                        J3                                                  
C                                                                                                                                   
CINPUT PARAMETERS...                                                                                                                
C                                                                               J5                                                  
C      LAY    = LAYERING SCHEME USED IN MODEL.                                  J5                                                  
C      ICOORD = VERTICAL COORDINATE (ETA OR SIG).                               J5                                                  
C      PLID   = MODEL "LID" IN PASCALS.                                         J5                                                  
C      NBLKS  = NUMBER OF BLOCKS TO DISCRETIZE VERTICAL STRUCTURE.              J5                                                  
C               IF NBLKS=0, THE DEFAULT OF 4 BLOCKS IS USED, WITH THE FOLLOWING J5                                                  
C               VERTICAL DISCRETIZATION:                                        J5                                                  
C                        STRATOSPHERIC CLOUDS:               SIG.LT.0.110       J5                                                  
C                        CIRRUS        CLOUDS:      0.110.GE.SIG.LT.0.340       J5                                                  
C                        MID           CLOUDS:      0.340.GE.SIG.LT.0.850       J5                                                  
C                        LOW           CLOUDS:               SIG.GE.0.850       J5                                                  
C      LEVTOP = LEVEL INDICES OF TOP    OF EACH BLOCK (MAX 5).                  J5                                                  
C      LEVBASE= LEVEL BASES   OF BOTTOM OF EACH BLOCK (MAX 5).                  J5                                                  
C                                                                               J5                                                  
CEXAMPLE OF INPUT CARDS...                                                      J5                                                  
C                                                                               J5                                                  
C*CLDPROG.    3  ETA      500.    3                                             J5                                                  
C*   TOP      1    5    8                                                       J5                                                  
C*   BASE     5    8   11                                                       J5                                                  
C-----------------------------------------------------------------------------                                                      
                                                                                                                                    
C     * ONE-LEVEL GRIDS.                                                                                                            
                                                                                                                                    
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMMON/BLANCK/P(18528),TCV(18528),W(18528),TC(18528)                                                                          
                                                                                                                                    
C     * VECTORS OR GRID SLICE FIELDS.                                                                                               
                                                                                                                                    
      INTEGER LEV(100),LEVTOP(5),LEVBASE(5)                                                                                         
      REAL SIGHAF(100),SIGFUL(101),SH(100),SHB(100)                                                                                 
      REAL ACH(100),BCH(100),AH(100),BH(100)                                                                                        
      REAL PSFC(193),TOPCV(193)                                                                                                     
      REAL*8 SINL(96),WGT(96),COSL(96),RAD(96),WOCS(96)                                                                             
                                                                                                                                    
      REAL T(193,101),Q(193,101),H(193,101),                                                                                        
     1     TAC(193,101),CMTX(193,102,102),                                                                                          
     2     CZON(102,102),SHJ(193,100),SHTJ(193,101)                                                                                 
                                                                                                                                    
C     * THE FOLLOWING ARE COMPLETE 3-D GRIDS.                                                                                       
                                                                                                                                    
      REAL TF(18528,100),SHUM(18528,100),RH(18528,100),                                                                             
     1     TAUZ(18528,100),EMI(18528,100),XTRACLD(18528,5),                                                                         
     2     XTRATAU(18528,5),XTRAEMI(18528,5)                                                                                        
                                                                                                                                    
C     * THE FOLLOWING ARE WORK ARRAYS FOR SUBROUTINE CLOUDS3.                                                                       
                                                                                                                                    
      REAL EMICOEF(193,101),RADEQV(193,101),WCL(193,101),                                                                           
     1     WCD(193,101),C VEC(193),H VEC(193),D MIN(193),                                                                           
     2     D MAX(193),H AVE(101),T AVE(101),D LG SIG(102),                                                                          
     3     C REF(193),E REF(193),EST(193),HT(193),ALWC(193),                                                                        
     4     XLENGTH(193),H0(193),E(193),ZRDM(193)                                                                                    
                                                                                                                                    
      INTEGER I RDM(193)                                                                                                            
C                                                                                                                                   
      COMMON/ICOM/ IBUF(8),IDAT(18528)                                                                                              
      COMMON/JCOM/ JBUF(8),JDAT(18528)                                                                                              
      COMMON/EPS / A, B, EPS1, EPS2                                                                                                 
      COMMON/EPSICE/ AICE,BICE,TICE,QMIN                                                                                            
      COMMON/HTCP  / T1S,T2S,AI,BI,AW,BW,SLP                                                                                        
      COMMON /PARAMS/ WW,TW,RAYON,ASQ,GRAV,RGAS,RGOCP,RGOASQ,CPRES                                                                  
      COMMON /PARAMS/ RGASV,CPRESV                                                                                                  
                                                                                                                                    
      LOGICAL OK, SPEC                                                                                                              
                                                                                                                                    
      DATA MAXX,MAXI,MAXL,MAXLTP /18528,193,100,5/                                                                                  
C----------------------------------------------------------------------                                                             
                                                                                                                                    
      NFF=16                                                                                                                        
      CALL JCLPNT(NFF,1,2,3,4,11,12,13,14,15,16,17,18,19,20,5,6)                                                                    
C                                                                                                                                   
C     * GET THERMODYNAMIC CONSTANTS.                                                                                                
C                                                                                                                                   
      CALL SPWCONH(FVORT,PI)                                                                                                        
                                                                                                                                    
      DO 10 I=1,4                                                                                                                   
         REWIND I                                                                                                                   
   10 CONTINUE                                                                                                                      
C                                                                                                                                   
C     * CHECK TEMPERATURE FILE AND OBTAIN LEVEL INFORMATION.                                                                        
C                                                                                                                                   
      CALL FILEV(LEV,NLEV,IBUF,1)                                                                                                   
      IF((NLEV.LT.1).OR.(NLEV.GT.MAXL)) CALL       XIT('CLDPROG',-1)                                                                
      WRITE(6,6015) NLEV,(LEV(L),L=1,NLEV)                                                                                          
      KIND = IBUF(1)                                                                                                                
      SPEC = (KIND.EQ.NC4TO8("SPEC").OR.KIND.EQ.NC4TO8("FOUR"))                                                                     
      IF(SPEC)                                CALL XIT('CLDPROG',-2)                                                                
C                                                                                                                                   
C     * CALCULATE SIGMA VALUES FROM MODEL FILE LABEL.                                                                               
C     * CALCULATE "LOCAL" SIGMA INFORMATION ARRAYS.                                                                                 
C                                                                                                                                   
      CALL LVDCODE(SH,LEV,NLEV)                                                                                                     
      DO 50 L=1,NLEV                                                                                                                
         SH(L) = SH(L) * 0.001E0                                                                                                    
   50 CONTINUE                                                                                                                      
                                                                                                                                    
      READ(5,5000,END=900) LAY,ICOORD,PLID,NBLKS                                J4                                                  
      IF(ICOORD.EQ.NC4TO8(" SIG")) THEN                                                                                             
        PLID=MAX(PLID,0.00E0)                                                                                                       
      ELSE                                                                                                                          
        PLID=MAX(PLID, 0.100E-09)                                                                                                   
      ENDIF                                                                                                                         
      IF(NBLKS.GT.MAXLTP) CALL                     XIT('CLDPROG',-3)                                                                
                                                                                                                                    
      CALL SIGLOC(ACH,BCH,AH,BH,SH,SHB,NLEV,LAY,ICOORD,PLID)                                                                        
                                                                                                                                    
      IF(NBLKS.GT.0)                          THEN                                                                                  
         READ(5,5010,END=901) (LEVTOP(I), I=1,NBLKS)                            J4                                                  
         READ(5,5010,END=902) (LEVBASE(I),I=1,NBLKS)                            J4                                                  
      ELSE                                                                                                                          
C                                                                                                                                   
C        * DETERMINE VERTICAL LEVEL INDICES FOR STANDARD STRATOSPHERIC/CIRRUS/                                                      
C        * MID/LOW CLOUDS.                                                                                                          
C                                                                                                                                   
         LEVTOP(1) = 1                                                                                                              
         INDLOW = ISRCHFGE(NLEV,SH,1,0.850E0)                                                                                       
         INDMID = ISRCHFGE(NLEV,SH,1,0.340E0)                                                                                       
         IF(SH(1).LT.0.110E0)                   THEN                                                                                
            NBLKS = 4                                                                                                               
            LEVTOP(2)  = ISRCHFGE(NLEV,SH,1,0.110E0)                                                                                
            LEVBASE(1) = LEVTOP(2)                                                                                                  
            LEVTOP(3)  = INDMID                                                                                                     
            LEVBASE(2) = LEVTOP(3)                                                                                                  
            LEVTOP(4)  = INDLOW                                                                                                     
            LEVBASE(3) = LEVTOP(4)                                                                                                  
            LEVBASE(4) = NLEV+1                                                                                                     
         ELSE                                                                                                                       
            NBLKS = 3                                                                                                               
            LEVTOP(2)  = INDMID                                                                                                     
            LEVBASE(1) = LEVTOP(2)                                                                                                  
            LEVTOP(3)  = INDLOW                                                                                                     
            LEVBASE(2) = LEVTOP(3)                                                                                                  
            LEVBASE(3) = NLEV+1                                                                                                     
         ENDIF                                                                                                                      
      ENDIF                                                                                                                         
C                                                                                                                                   
      WRITE(6,6000) LAY,ICOORD,PLID,NBLKS                                                                                           
      WRITE(6,6005) (LEVTOP(I),I=1,NBLKS)                                                                                           
      WRITE(6,6010) (LEVBASE(I),I=1,NBLKS)                                                                                          
C                                                                                                                                   
C                                                                                                                                   
C     * CHECK MOISTURE FILE.                                                                                                        
C                                                                                                                                   
      CALL FILEV(LEV,NLEV,JBUF,2)                                                                                                   
      IF((NLEV.LT.1).OR.(NLEV.GT.MAXL)) CALL       XIT('CLDPROG',-4)                                                                
      WRITE(6,6015) NLEV,(LEV(L),L=1,NLEV)                                                                                          
      KIND = JBUF(1)                                                                                                                
      SPEC = (KIND.EQ.NC4TO8("SPEC").OR.KIND.EQ.NC4TO8("FOUR"))                                                                     
      IF(SPEC)                                CALL XIT('CLDPROG',-5)                                                                
C                                                                                                                                   
C     * COMPARE THESE FILES.                                                                                                        
C                                                                                                                                   
      CALL CMPLBL(0,IBUF,0,JBUF,OK)                                                                                                 
      IF(.NOT.OK)                             CALL XIT('CLDPROG',-6)                                                                
      NSETS = 0                                                                                                                     
      NWDS = IBUF(5)*IBUF(6)                                                                                                        
      ILG = IBUF(5)                                                                                                                 
      IL1 = 1                                                                                                                       
      IL2 = ILG-1                                                                                                                   
      ILATH = IBUF(6)/2                                                                                                             
C                                                                                                                                   
C     * CALCULATE GAUSSIAN LATITUDE INFORMATION.                                                                                    
C                                                                                                                                   
      CALL GAUSSG(ILATH,SINL,WGT,COSL,RAD,WOCS)                                                                                     
      CALL TRIGL (ILATH,SINL,WGT,COSL,RAD,WOCS)                                                                                     
                                                                                                                                    
C     * INITIALIZE ZONAL CLOUD ARRAY AND MOON LAYER GRIDS FOR                                                                       
C     * CLOUDS SUBROUTINE.                                                                                                          
C                                                                                                                                   
      DO 60 LL=1,NLEV+2                                                                                                             
      DO 60 LLL=1,NLEV+2                                                                                                            
         CZON(LL,LLL) = 0.E0                                                                                                        
   60 CONTINUE                                                                                                                      
C                                                                                                                                   
      DO 70 I=1,ILG                                                                                                                 
         T(I,1) = 0.E0                                                                                                              
         Q(I,1) = 0.E0                                                                                                              
         H(I,1) = 0.E0                                                                                                              
   70 CONTINUE                                                                                                                      
C                                                                                                                                   
C     * FIND VERTICAL LEVEL INDEX BELOW SIG=0.150 FOR CALCULATING TOTAL                                                             
C     * CLOUD COVER (TRANSPARENT TO SURFACE-BASED OBSERVER ABOVE THIS).                                                             
C                                                                                                                                   
      IF(SH(1).LT.0.150E0) THEN                                                                                                     
         LEV150=ISRCHFGT(NLEV,SH,1,0.150E0)                                                                                         
      ELSE                                                                                                                          
         LEV150=1                                                                                                                   
      ENDIF                                                                                                                         
C=======================================================================                                                            
C     * ENTERING TIME LOOP                                                                                                          
C                                                                                                                                   
C     * GET SURFACE PRESSURE FIELD                                                                                                  
C                                                                                                                                   
  100 CALL GETFLD2(3,P,KIND,-1,NC4TO8("LNSP"),1,JBUF,MAXX,OK)                                                                       
      IF(.NOT.OK.AND.NSETS.EQ.0)              CALL XIT('CLDPROG',-7)                                                                
      IF(NSETS.EQ.0) WRITE(6,6025) JBUF                                                                                             
      IF(.NOT.OK) THEN                                                                                                              
         WRITE(6,6020) NSETS                                                                                                        
                                              CALL XIT('CLDPROG',0)                                                                 
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * INITIALIZE TOTAL LIQUID WATER VECTOR AND GET SURFACE PRESSURE.                                                              
C                                                                                                                                   
      DO 150 I=1,NWDS                                                                                                               
         W(I) = 0.0E0                                                                                                               
         P(I) = 100.0E0*EXP(P(I))                                                                                                   
  150 CONTINUE                                                                                                                      
C                                                                                                                                   
C    * GET TEMPERATURE AND MOISTURE FIELDS.                                                                                         
C                                                                                                                                   
      DO 250 L=1,NLEV                                                                                                               
         CALL GETFLD2(1,TF(1,L),KIND,-1,NC4TO8("TEMP"),LEV(L),                                                                      
     +                                           IBUF,MAXX,OK)                                                                      
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IF(.NOT.OK) THEN                                                                                                           
            WRITE(6,6020) NSETS                                                                                                     
                                              CALL XIT('CLDPROG',-8)                                                                
         ENDIF                                                                                                                      
         CALL GETFLD2(2,SHUM(1,L),KIND,-1,NC4TO8("SHUM"),LEV(L),                                                                    
     +                                             IBUF,MAXX,OK)                                                                    
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IF(.NOT.OK) THEN                                                                                                           
            WRITE(6,6020) NSETS                                                                                                     
                                              CALL XIT('CLDPROG',-9)                                                                
         ENDIF                                                                                                                      
  250 CONTINUE                                                                                                                      
C                                                                                                                                   
C     * GET TOP CONVECTION LEVEL.                                                                                                   
C                                                                                                                                   
      CALL GETFLD2(4,TCV,KIND,-1,NC4TO8("LTCV"),1,JBUF,MAXX,OK)                                                                     
      IF(NSETS.EQ.0) WRITE(6,6025) JBUF                                                                                             
      IF(.NOT.OK) THEN                                                                                                              
            WRITE(6,6020) NSETS                                                                                                     
                                              CALL XIT('CLDPROG',-10)                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * LOOP OVER LATITUDE BANDS.                                                                                                   
C                                                                                                                                   
      ISTART = 1-ILG                                                                                                                
      DO 750 LAT=1,IBUF(6)                                                                                                          
         ISTART = ISTART+ILG                                                                                                        
         IEND = ISTART+ILG-2                                                                                                        
C                                                                                                                                   
C        * SET UP ARRAYS TO BE PASSED TO SUBROUTINE CLOUDS3.                                                                        
C                                                                                                                                   
         K = 1                                                                                                                      
         DO 300 I=ISTART,IEND                                                                                                       
            PSFC(K) = P(I)                                                                                                          
            TOPCV(K) = TCV(I)                                                                                                       
            K = K+1                                                                                                                 
  300    CONTINUE                                                                                                                   
         DO 400 L=1,NLEV                                                                                                            
            K = 1                                                                                                                   
            DO 350 I=ISTART,IEND                                                                                                    
               T(K,L+1) = TF(I,L)                                                                                                   
               Q(K,L+1) = SHUM(I,L)                                                                                                 
               K = K+1                                                                                                              
  350       CONTINUE                                                                                                                
  400    CONTINUE                                                                                                                   
C                                                                                                                                   
C        * CALCULATE "LOCAL" SIGMA ARRAYS IN MANNER CONSISTENT WITH GCM.                                                            
C                                                                                                                                   
         DO 405 L=1,NLEV                                                                                                            
         DO 405 IL=IL1,IL2                                                                                                          
              SHJ(IL,L)   = ACH(L)/PSFC(IL) + BCH(L)                                                                                
             SHTJ(IL,L+1) =  AH(L)/PSFC(IL) +  BH(L)                                                                                
  405    CONTINUE                                                                                                                   
                                                                                                                                    
         DO 410 IL=IL1,IL2                                                                                                          
             SHTJ(IL,1) = PLID/PSFC(IL)                                                                                             
  410    CONTINUE                                                                                                                   
C                                                                                                                                   
C        * CALCULATE ZONALLY-AVERAGED SIGMA ARRAYS.                                                                                 
C                                                                                                                                   
         PTSTM1=1.E0/FLOAT(IL2-IL1+1)                                                                                               
         DO 430 L=1,NLEV                                                                                                            
             SIGFUL(L) = 0.E0                                                                                                       
             SIGHAF(L) = 0.E0                                                                                                       
             DO 420 IL=IL1,IL2                                                                                                      
                 SIGFUL(L) = SIGFUL(L) +SHTJ(IL,L)                                                                                  
                 SIGHAF(L) = SIGHAF(L) + SHJ(IL,L)                                                                                  
  420        CONTINUE                                                                                                               
             SIGFUL(L) = SIGFUL(L) * PTSTM1                                                                                         
             SIGHAF(L) = SIGHAF(L) * PTSTM1                                                                                         
  430    CONTINUE                                                                                                                   
         SIGFUL(NLEV+1)=1.E0                                                                                                        
C                                                                                                                                   
C        * CALCULATE RELATIVE HUMIDITY.                                                                                             
C                                                                                                                                   
         CALL RELHUM2(H(1,2),T(1,2),Q(1,2),SHJ,PSFC,EST,                                                                            
     1                NLEV,MAXL,1,ILG-1,MAXI)                                                                                       
C                                                                                                                                   
C        * THE FOLLOWING IS THE MAIN CLOUDS SUBROUTINE AS USED IN GCM.                                                              
C                                                                                                                                   
         CALL CLOUDS3(C MTX,TAC,SHJ,SHTJ,                                                                                           
     1               CZON,Q,T,H,SIGHAF,SIGFUL,PSFC,TOPCV,                                                                           
     2               EMICOEF,RADEQV,WCL,WCD,                                                                                        
     3               CVEC,HVEC,DMIN,DMAX,                                                                                           
     4               HAVE,TAVE,DLGSIG,ZRDM,CREF,EREF,                                                                               
     5               EST,HT,ALWC,XLENGTH,                                                                                           
     6               H0,E,                                                                                                          
     7               MAXI,IL1,IL2,NLEV+2,NLEV+1,NLEV,COSL(LAT),                                                                     
     8               MAXL+2,MAXL+1,MAXL)                                                                                            
C                                                                                                                                   
C        * SAVE TOTAL CLOUD COVER.                                                                                                  
C                                                                                                                                   
         K = 1                                                                                                                      
         DO 450 I=ISTART,IEND                                                                                                       
            TC(I) = CMTX(K,LEV150+1,NLEV+2)                                                                                         
            K = K+1                                                                                                                 
  450    CONTINUE                                                                                                                   
         TC(IEND+1) = TC(ISTART)                                                                                                    
C                                                                                                                                   
C        * SAVE LAYER AMOUNTS OF CLOUD, (OPTICAL DEPTH)*(CLOUD),                                                                    
C        * EMI, AND TOTAL LWC.                                                                                                      
C                                                                                                                                   
         DO 550 L=1,NLEV                                                                                                            
            K = 1                                                                                                                   
            DO 500 I=ISTART,IEND                                                                                                    
               SHUM(I,L) = CMTX(K,L+1,L+2)                                                                                          
               TF(I,L) = TAC(K,L+1)*SHUM(I,L)                                                                                       
               TAUZ(I,L) = TF(I,L)*10000.E0/                                                                                        
     &           ((SHTJ(K,L+1)-SHTJ(K,L))*P(I))                                                                                     
               EMI(I,L) = CMTX(K,L+2,L+1)                                                                                           
               W(I) = W(I)+(WCL(K,L+1)*SHUM(I,L))                                                                                   
               RH(I,L) = H(K,L+1)                                                                                                   
               K = K+1                                                                                                              
  500       CONTINUE                                                                                                                
            SHUM(IEND+1,L) = SHUM(ISTART,L)                                                                                         
            TF(IEND+1,L) = TF(ISTART,L)                                                                                             
            TAUZ(IEND+1,L) = TAUZ(ISTART,L)                                                                                         
            EMI(IEND+1,L) = EMI(ISTART,L)                                                                                           
            RH(IEND+1,L) = RH(ISTART,L)                                                                                             
  550    CONTINUE                                                                                                                   
         W(IEND+1) = W(ISTART)                                                                                                      
C                                                                                                                                   
C        * SELECT THE BLOCKS OF CLOUDS TO BE SAVED.                                                                                 
C                                                                                                                                   
         DO 700 N=1,NBLKS                                                                                                           
            K = 1                                                                                                                   
            DO 650 I=ISTART,IEND                                                                                                    
               XTRACLD(I,N) = CMTX(K,LEVTOP(N)+1,LEVBASE(N)+1)                                                                      
               XTRAEMI(I,N) = CMTX(K,LEVBASE(N)+1,LEVTOP(N)+1)                                                                      
               S = 0.0E0                                                                                                            
               DO 600 KN=LEVTOP(N),LEVBASE(N)-1                                                                                     
                  S = S+TF(I,KN)                                                                                                    
  600          CONTINUE                                                                                                             
               XTRATAU(I,N) = S                                                                                                     
               K=K+1                                                                                                                
  650       CONTINUE                                                                                                                
            XTRACLD(IEND+1,N) = XTRACLD(ISTART,N)                                                                                   
            XTRAEMI(IEND+1,N) = XTRAEMI(ISTART,N)                                                                                   
            XTRATAU(IEND+1,N) = XTRATAU(ISTART,N)                                                                                   
  700    CONTINUE                                                                                                                   
  750 CONTINUE                                                                                                                      
C                                                                                                                                   
C     * REPACK DATA.                                                                                                                
C                                                                                                                                   
      IBUF(8) = 4                                                                                                                   
      JBUF(8) = 4                                                                                                                   
                                                                                                                                    
C     * (1) SINGLE DIMENSIONAL FIELDS.                                                                                              
                                                                                                                                    
      JBUF(3) = NC4TO8("CLDT")                                                                                                      
      CALL PUTFLD2(11,TC,JBUF,MAXX)                                                                                                 
      IF(NSETS.EQ.0) WRITE(6,6025) JBUF                                                                                             
      JBUF(3) = NC4TO8("TLWC")                                                                                                      
      CALL PUTFLD2(13,W,JBUF,MAXX)                                                                                                  
      IF(NSETS.EQ.0) WRITE(6,6025) JBUF                                                                                             
                                                                                                                                    
C     * (2) SIGMA LAYER AMOUNTS.                                                                                                    
                                                                                                                                    
      DO 825 L=1,NLEV                                                                                                               
         IBUF(4) = LEV(L)                                                                                                           
C                                                                                                                                   
         IBUF(3) = NC4TO8("ICLD")                                                                                                   
         CALL PUTFLD2(12,SHUM(1,L),IBUF,MAXX)                                                                                       
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IBUF(3) = NC4TO8("IEMI")                                                                                                   
         CALL PUTFLD2(14,EMI(1,L),IBUF,MAXX)                                                                                        
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IBUF(3) = NC4TO8("ITAC")                                                                                                   
         CALL PUTFLD2(15,TF(1,L),IBUF,MAXX)                                                                                         
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IBUF(3) = NC4TO8("ZTAC")                                                                                                   
         CALL PUTFLD2(16,TAUZ(1,L),IBUF,MAXX)                                                                                       
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IBUF(3) = NC4TO8(" RHC")                                                                                                   
         CALL PUTFLD2(17,RH(1,L),IBUF,MAXX)                                                                                         
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
  825 CONTINUE                                                                                                                      
                                                                                                                                    
C     * (3) BLOCK AMOUNTS.                                                                                                          
                                                                                                                                    
      DO 875 N=1,NBLKS                                                                                                              
         IBUF(4) = 900+N                                                                                                            
C                                                                                                                                   
         IBUF(3) = NC4TO8("ICLD")                                                                                                   
         CALL PUTFLD2(18,XTRACLD(1,N),IBUF,MAXX)                                                                                    
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IBUF(3) = NC4TO8("ITAC")                                                                                                   
         CALL PUTFLD2(19,XTRATAU(1,N),IBUF,MAXX)                                                                                    
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IBUF(3) = NC4TO8("IEMI")                                                                                                   
         CALL PUTFLD2(20,XTRAEMI(1,N),IBUF,MAXX)                                                                                    
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
  875 CONTINUE                                                                                                                      
      NSETS = NSETS+1                                                                                                               
      GOTO 100                                                                                                                      
C                                                                                                                                   
 900                                          CALL XIT('CLDPROG',-11)                                                               
 901                                          CALL XIT('CLDPROG',-12)                                                               
 902                                          CALL XIT('CLDPROG',-13)                                                               
C----------------------------------------------------------------                                                                   
 5000 FORMAT(10X,I5,1X,A4,E10.0,I5)                                             J4                                                  
 5010 FORMAT(10X,5I5)                                                           J4                                                  
 6000 FORMAT('0LAY,ICOORD,PLID,NBLKS  = ',I5,1X,A4,E10.3,I5)                                                                        
 6005 FORMAT(' LEVTOP = ',10I5/(10X,10I5))                                                                                          
 6010 FORMAT(' LEVBASE= ',10I5/(10X,10I5))                                                                                          
 6015 FORMAT('0 ',I2,' LAYERS AT: ',20(I3,1X)/(16X,20(I3,1X)))                                                                      
 6020 FORMAT('0 ',I3,' RECORDS TRANSFERRED THROUGH CLDPROG')                                                                        
 6025 FORMAT(' ',A4,I10,2X,A4,5I10)                                                                                                 
                                                                                                                                    
      END                                                                                                                           
