      PROGRAM CLDPRG4                                                                                                               
C     PROGRAM CLDPRG4(T,Q,LNSP,PBLT,TCV,GC,GSTCLD,GSCLD,GSTLWC,                 J2                                                  
C    1               GSEMI,GSTAC,GSZTAC,GSLWCD,GSRADE,RH,CX,TX,EX,              J2                                                  
C    2               INPUT,OUTPUT,                                      )       J2                                                  
C    3               TAPE1=T,TAPE2=Q,TAPE3=LNSP,TAPE7=PBLT,                                                                         
C    4               TAPE8=TCV,TAPE9=GC,TAPE11=GSTCLD,TAPE12=GSCLD,TAPE13=GSTLWC,                                                   
C    5               TAPE14=GSEMI,TAPE15=GSTAC,TAPE16=GSZTAC,                                                                       
C    6               TAPE17=GSLWCD,TAPE18=GSRADE,                                                                                   
C    7               TAPE19=RH,TAPE20=CX,TAPE21=TX,TAPE22=EX,                                                                       
C    8               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     FEB 22/94 - M.LAZARE. CALL NEW CLOUDS SUBROUTINE CLOUDS6 FOR GCM10.                                                           
C     FEB 22/93 - M.LAZARE,E.CHAN. PREVIOUS VERSION CLDPRG3 FOR GCM7/8/9.                                                           
C                                                                               J2                                                  
CCLDPRG4 - 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/L20 RESOLUTION.  J3                                                  
C                                                                               J3                                                  
CINPUT FILES...                                                                 J3                                                  
C                                                                               J3                                                  
C      T      = MODEL TEMPERATURES.                                             J3                                                  
C      Q      = MODEL SPECIFIC HUMIDITY.                                        J3                                                  
C      LNSP   = MODEL LN(SURFACE PRESSURE).                                     J3                                                  
C      PBLT   = MODEL DIAGNOSED TOP-OF-PLANETARY BOUNDARY LAYER INDEX.          J3                                                  
C      TCV    = MODEL DIAGNOSED TOP-OF-CONVECTION         LAYER INDEX.          J3                                                  
C      GC     = MODEL GROUND COVER.                                             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      GSLWCD = LOG10(CLOUD LIQUID WATER).                                      J3                                                  
C      GSRADE = WATER DROPLET/ICE CRYSTAL EQUIVALENT RADIUS (MICRONS).          J3                                                  
C      RH     = MODEL RELATIVE HUMIDITY.                                        J3                                                  
C      CX     = BLOCK CLOUD AMOUNT.                                             J3                                                  
C      TX     = BLOCK CLOUD AMOUNT*OPTICAL DEPTH.                               J3                                                  
C      EX     = BLOCK CLOUD AMOUNT*EMISSIVITY.                                  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      DELT   = MODEL TIMESTEP IN SECONDS.                                      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*CLDPRG4.    3  ETA      500.     1200.    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),WF(18528),TC(18528),PBLTOP(18528),                                                                     
     1              TCONV (18528),GCOVER(18528)                                                                                     
                                                                                                                                    
C     * VECTORS OR GRID SLICE FIELDS.                                                                                               
                                                                                                                                    
      INTEGER LEV(100),LEVTOP(5),LEVBASE(5)                                                                                         
      REAL SH(100),SHB(100)                                                                                                         
      REAL ACH(100),BCH(100),AH(100),BH(100)                                                                                        
      REAL PSFC(193),PCP(193),PBLT(193),SHLT(193),TCV(193),GC(193)                                                                  
      REAL*8 SINL(96),WGT(96),COSL(96),RAD(96),WOCS(96)                                                                             
                                                                                                                                    
      REAL T(193,101),Q(193,101),H(193,101),CG(193,2,101),                                                                          
     1     DSHJ(193,100),TAC(193,101),                                                                                              
     2     CMTX(193,102,102),SHJ(193,100),                                                                                          
     3     SHTJ(193,101),SHXKJ(193,100)                                                                                             
                                                                                                                                    
C     * THE FOLLOWING ARE COMPLETE 3-D GRIDS.                                                                                       
                                                                                                                                    
      REAL TF(18528,100),SHUM(18528,100),                                                                                           
     1     EMI(18528,100),TAUZ(18528,100),LWCD(18528,100),                                                                          
     2     RADE(18528,100),RH(18528,100),XTRACLD(18528,5),                                                                          
     3     XTRATAU(18528,5),XTRAEMI(18528,5)                                                                                        
C                                                                                                                                   
C     * THE FOLLOWING ARE WORK ARRAYS FOR SUBROUTINES CONVEC7/RELHUM4/                                                              
C     * CLOUDS6.                                                                                                                    
C                                                                                                                                   
      REAL RADEQV(193,101),WCL(193,101),WCD(193,101),                                                                               
     1     TB(193,101)                                                                                                              
                                                                                                                                    
      REAL VEC2D1(193,101),  VEC2D2(193,101),                                                                                       
     1     VEC2D3(193,101),  VEC2D4(193,101),                                                                                       
     2     VEC2D5(193,101),  VEC2D6(193,101),                                                                                       
     3     VEC2D7(193,101),  VEC2D8(193,101),                                                                                       
     4     VEC2D9(193,101), VEC2D10(193,101),                                                                                       
     5    VEC2D11(193,101)                                                                                                          
                                                                                                                                    
      REAL VEC1 (193), VEC2(193), VEC3(193), VEC4(193),                                                                             
     1     VEC5 (193), VEC6(193), VEC7(193), VEC8(193),                                                                             
     2     VEC9 (193),VEC10(193),VEC11(193),VEC12(193),                                                                             
     3     VEC13(193),VEC14(193),VEC15(193),VEC16(193),                                                                             
     4     VEC17(193),VEC18(193),VEC19(193),VEC20(193),                                                                             
     5     VEC21(193),VEC22(193),VEC23(193),VEC24(193),                                                                             
     6     VEC25(193),VEC26(193),VEC27(193),VEC28(193),                                                                             
     7     VEC29(193),VEC30(193),VEC31(193),VEC32(193),                                                                             
     8     VEC33(193),VEC34(193),VEC35(193),VEC36(193),                                                                             
     9     VEC37(193),VEC38(193),VEC39(193),VEC40(193),                                                                             
     A     VEC41(193),VEC42(193),VEC43(193),VEC44(193),                                                                             
     B     VEC45(193),VEC46(193),VEC47(193),VEC48(193),                                                                             
     C     VEC49(193),VEC50(193),VEC51(193),VEC52(193)                                                                              
                                                                                                                                    
      INTEGER IVEC1(193),IVEC2(193),IVEC3(193),IVEC4(193),                                                                          
     1        IVEC5(193)                                                                                                            
                                                                                                                                    
      REAL VECST(193,99,6)                                                                                                          
C                                                                                                                                   
      COMMON/ICOM/ IBUF(8),IDAT(18528)                                                                                              
      COMMON/JCOM/ JBUF(8),JDAT(18528)                                                                                              
      COMMON/KCOM/ KBUF(8),KDAT(18528)                                                                                              
      COMMON/ADJPCP/ HC,HF,HM,AA,DEPTH,LHEAT,MOIADJ,MOIFLX                                                                          
      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                                                                                                  
      COMMON/GAMS/ EPSS,CAPA                                                                                                        
                                                                                                                                    
      LOGICAL OK, SPEC                                                                                                              
                                                                                                                                    
      DATA MAXX,MAXI,MAXL,MAXLTP /18528,193,100,5/                                                                                  
C----------------------------------------------------------------------                                                             
                                                                                                                                    
      M=20                                                                                                                          
      CALL JCLPNT(M,1,2,3,7,8,9,11,12,13,14,15,16,17,18,19,20,21,22,5,6)                                                            
C                                                                                                                                   
C     * GET THERMODYNAMIC CONSTANTS.                                                                                                
C                                                                                                                                   
      CALL SPWCON7(FVORT,PI)                                                                                                        
                                                                                                                                    
      DO 10 I=1,4                                                                                                                   
         REWIND I                                                                                                                   
   10 CONTINUE                                                                                                                      
      REWIND 7                                                                                                                      
      REWIND 8                                                                                                                      
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('CLDPRG4',-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('CLDPRG4',-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,DELT,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('CLDPRG4',-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,DELT,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('CLDPRG4',-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('CLDPRG4',-5)                                                                
C                                                                                                                                   
C     * COMPARE THESE FILES.                                                                                                        
C                                                                                                                                   
      CALL CMPLBL(0,IBUF,0,JBUF,OK)                                                                                                 
      IF(.NOT.OK) CALL                             XIT('CLDPRG4',-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 MOON LAYER GRIDS FOR CLOUDS SUBROUTINE.                                                                          
C                                                                                                                                   
      DO 70 I=1,ILG                                                                                                                 
         T(I,1) = 0.E0                                                                                                              
         Q(I,1) = 0.E0                                                                                                              
         H(I,1) = 0.E0                                                                                                              
   70 CONTINUE                                                                                                                      
      MSG=0                                                                                                                         
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('CLDPRG4',-7)                                                                
      IF(NSETS.EQ.0) WRITE(6,6025) JBUF                                                                                             
      IF(.NOT.OK) THEN                                                                                                              
         WRITE(6,6020) NSETS                                                                                                        
         CALL                                      XIT('CLDPRG4',0)                                                                 
      ENDIF                                                                                                                         
C                                                                                                                                   
C     * GET TOP-OF-PLANETARY BOUNDARY LAYER INDEX.                                                                                  
C                                                                                                                                   
      CALL GETFLD2(7,PBLTOP,KIND,-1,NC4TO8("PBLT"),1,KBUF,MAXX,OK)                                                                  
      IF(.NOT.OK.AND.NSETS.EQ.0) CALL              XIT('CLDPRG4',-8)                                                                
      IF(NSETS.EQ.0) WRITE(6,6025) KBUF                                                                                             
C                                                                                                                                   
C     * COMPARE THESE FILES.                                                                                                        
C                                                                                                                                   
      CALL CMPLBL(0,JBUF,0,KBUF,OK)                                                                                                 
      IF(.NOT.OK) CALL                             XIT('CLDPRG4',-9)                                                                
C                                                                                                                                   
C     * GET TOP-OF-CONVECTION LAYER INDEX.                                                                                          
C                                                                                                                                   
      CALL GETFLD2(8,TCONV,KIND,-1,NC4TO8(" TCV"),1,KBUF,MAXX,OK)                                                                   
      IF(.NOT.OK.AND.NSETS.EQ.0)              CALL XIT('CLDPRG4',-10)                                                               
      IF(NSETS.EQ.0) WRITE(6,6025) KBUF                                                                                             
C                                                                                                                                   
C     * COMPARE THESE FILES.                                                                                                        
C                                                                                                                                   
      CALL CMPLBL(0,JBUF,0,KBUF,OK)                                                                                                 
      IF(.NOT.OK)                             CALL XIT('CLDPRG4',-11)                                                               
C                                                                                                                                   
C     * GET GROUND COVER FIELD.                                                                                                     
C                                                                                                                                   
      CALL GETFLD2(9,GCOVER,KIND,-1,NC4TO8("  GC"),1,KBUF,MAXX,OK)                                                                  
      IF(.NOT.OK.AND.NSETS.EQ.0)              CALL XIT('CLDPRG4',-12)                                                               
      IF(NSETS.EQ.0) WRITE(6,6025) KBUF                                                                                             
C                                                                                                                                   
C     * COMPARE THESE FILES.                                                                                                        
C                                                                                                                                   
      CALL CMPLBL(0,JBUF,0,KBUF,OK)                                                                                                 
      IF(.NOT.OK)                             CALL XIT('CLDPRG4',-13)                                                               
C                                                                                                                                   
C     * INITIALIZE TOTAL LIQUID WATER VECTOR AND GET SURFACE PRESSURE.                                                              
C                                                                                                                                   
      DO 150 I=1,NWDS                                                                                                               
         WF(I)= 0.0E0                                                                                                               
         P(I) = 100.0E0*EXP(P(I))                                                                                                   
  150 CONTINUE                                                                                                                      
C                                                                                                                                   
C    * GET TEMPERATURE, MOISTURE AND VERTICAL VELOCITY 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('CLDPRG4',-14)                                                               
         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('CLDPRG4',-15)                                                               
         ENDIF                                                                                                                      
         IF(NSETS.EQ.0)                                      THEN                                                                   
C                                                                                                                                   
C          * DETERMINE "MSG" BY FINDING NUMBER OF LEVELS WHERE                                                                      
C          * SUM OF SHUM AROUND LATITUDE CIRCLE IS ZERO, I.E.                                                                       
C          * ALL INITIALIZED TO ZERO IN PROGRAM GSHUMH.                                                                             
C                                                                                                                                   
           SUMSHUM=0.E0                                                                                                             
           DO 200 IJ=1,NWDS                                                                                                         
             SUMSHUM=SUMSHUM+SHUM(IJ,L)                                                                                             
  200      CONTINUE                                                                                                                 
           IF(SUMSHUM.EQ.0.E0)                      MSG=MSG+1                                                                       
         ENDIF                                                                                                                      
C                                                                                                                                   
C     * COMPARE THESE FILES.                                                                                                        
C                                                                                                                                   
      CALL CMPLBL(0,IBUF,0,JBUF,OK)                                                                                                 
      IF(.NOT.OK) CALL                             XIT('CLDPRG4',-16)                                                               
  250 CONTINUE                                                                                                                      
C                                                                                                                                   
      IF(NSETS.EQ.0) WRITE(6,6018) MSG                                                                                              
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 CLOUDS6.                                                                        
C                                                                                                                                   
         K = 1                                                                                                                      
         DO 300 I=ISTART,IEND                                                                                                       
            PSFC(K) = P(I)                                                                                                          
            PBLT(K) = PBLTOP(I)                                                                                                     
            TCV(K)  = TCONV(I)                                                                                                      
            GC(K)   = GCOVER(I)                                                                                                     
            PCP(K) = 0.E0                                                                                                           
            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                                                                                                                   
                                                                                                                                    
         DO 420 L=1,NLEV                                                                                                            
         DO 420 IL=IL1,IL2                                                                                                          
             DSHJ(IL,L)   = SHTJ(IL,L+1) - SHTJ(IL,L)                                                                               
            SHXKJ(IL,L)   = SHJ(IL,L) ** RGOCP                                                                                      
  420    CONTINUE                                                                                                                   
C                                                                                                                                   
C       *  LAYER INTERFACE TEMPERATURES, WITH EXTRA ONE AT TOP                                                                      
C       *  (ISOTHERMAL).                                                                                                            
C       *  TEMPERATURE DISCONTINUITY AT THE GROUND BASED ON ADIABATIC                                                               
C       *  EXTRAPOLATION TO SURFACE SINCE "GT" IS NOT AVAILABLE IN THE                                                              
C       *  DIAGNOSTIC. THIS IS NOT A SERIOUS DIFFERENCE SINCE "TB" IS                                                               
C       *  ONLY USED IN CLOUDS TO CALCULATE "CLSTFAC" AT THE LOWEST                                                                 
C       *  LEVEL, WHICH IS NEAR ZERO ANYWAY.                                                                                        
C                                                                                                                                   
         DO 425 IL=IL1,IL2                                                                                                          
             TB(IL,1)     =T(IL,2)                                                                                                  
             TB(IL,NLEV+1)=T(IL,NLEV+1)/SHXKJ(IL,NLEV)                                                                              
  425    CONTINUE                                                                                                                   
C                                                                                                                                   
         DO 430 L=1,NLEV-1                                                                                                          
         DO 430 IL=IL1,IL2                                                                                                          
             TB(IL,L+1) = (T(IL,L+1)*LOG(SHJ (IL,L+1)/SHTJ(IL,L+1))                                                                 
     1                   + T(IL,L+2)*LOG(SHTJ(IL,L+1)/SHJ (IL ,L)))                                                                 
     2                              /LOG(SHJ (IL,L+1)/SHJ (IL ,L))                                                                  
  430    CONTINUE                                                                                                                   
C                                                                                                                                   
C        * SHALLOW MIXING (NO BETTS-MILLER WITH ICON=0).                                                                            
C                                                                                                                                   
         ICON=0                                                                                                                     
         NUPS=0                                                                                                                     
         NSUPS=0                                                                                                                    
         IFIZPHS=0                                                                                                                  
         TWODTI=1.E0/(2.E0*DELT)                                                                                                    
         CALL CONVEC7 (T(1,2),Q(1,2),PCP,PSFC,                                                                                      
     1                PBLT,SHLT,TCV,DSHJ,SHJ,SHTJ,SHXKJ,                                                                            
     2                NLEV,NLEV-1,NLEV+1,MAXI,1,ILG-1,MSG,NUPS,NSUPS,                                                               
     3                RGOCP,SH,DELT,IFIZPHS,TWODTI,ICON,                                                                            
     4                TCROW,QCROW,MAXL,MAXL-1,MAXL+1,                                                                               
     5                VEC2D1,VEC2D2,VEC2D3,VECST,VEC1,                                                                              
     6                VEC2 ,VEC3 ,VEC4 ,VEC5 ,VEC6 ,                                                                                
     7                VEC7 ,VEC8 ,VEC9 ,VEC10,VEC11,                                                                                
     8                VEC12,VEC13,VEC14,VEC15,VEC16,                                                                                
     9                VEC17,VEC18,VEC19,VEC20,VEC21,                                                                                
     A                VEC22,VEC23,VEC24,VEC25,VEC26,                                                                                
     B                VEC27,VEC28,VEC29,VEC30,VEC31,                                                                                
     C                VEC32,VEC33,VEC34,VEC35,VEC36,                                                                                
     D                VEC37,VEC38,VEC39,VEC40,VEC41,                                                                                
     E                VEC42,VEC43,VEC44,VEC45,VEC46,                                                                                
     F                VEC47,VEC48,VEC49,VEC50,VEC51,                                                                                
     G                VEC52,VEC2D4,VEC2D5,VEC2D6,VEC2D7,                                                                            
     H                VEC2D8,VEC2D9,VEC2D10,VEC2D11,IVEC1,                                                                          
     I                IVEC2,IVEC3,IVEC4,IVEC5               )                                                                       
C                                                                                                                                   
C        * CALCULATE RELATIVE HUMIDITY.                                                                                             
C                                                                                                                                   
         CALL RELHUM4(H(1,2),T(1,2),Q(1,2),PCP,PSFC,                                                                                
     1                PBLT,DSHJ,SHJ,                                                                                                
     2                NLEV,MAXL,MAXI,1,ILG-1,MSG,                                                                                   
     3                VEC2D1,VEC1,VEC2,VEC3,VEC4,                                                                                   
     4                VEC5,VEC6,VEC7,VEC8,VEC9,                                                                                     
     5                VEC10,VEC11,VEC12,VEC13,VEC14,                                                                                
     6                VEC15,VEC16,VEC17,VEC18       )                                                                               
C                                                                                                                                   
C        * SET RELATIVE HUMIDITY TO ZERO IN MISSING MOISTURE                                                                        
C        * LAYERS, IF PRESENT.                                                                                                      
C                                                                                                                                   
         IF(MSG.GT.0)                                   THEN                                                                        
            DO 440 L=2,MSG+1                                                                                                        
            DO 440 IL=IL1,IL2                                                                                                       
               H(IL,L) = 0.E0                                                                                                       
  440       CONTINUE                                                                                                                
         ENDIF                                                                                                                      
C                                                                                                                                   
C        * THE FOLLOWING IS THE MAIN CLOUDS SUBROUTINE AS USED IN GCM.                                                              
C                                                                                                                                   
         CALL CLOUDS6(C MTX,TAC,SHJ,SHTJ,TB,T,H,                                                                                    
     1               CG,PSFC,PBLT,SHLT,TCV,GC,                                                                                      
     2               VEC2D1,RADEQV,VEC2D2,WCL,WCD,                                                                                  
     3               VEC2D3,VEC2D4,VEC2D5,VEC2D6,VEC2D7,                                                                            
     4               VEC2D8,VEC2D9,VEC2D10,IVEC1,VEC1,                                                                              
     5               VEC2,VEC3,VEC4,VEC5,VEC6,                                                                                      
     6               VEC7,VEC8,VEC9,VEC10,VEC11,                                                                                    
     7               VEC12,IVEC2,VEC13,VEC14,                                                                                       
     8               MAXI,IL1,IL2,NLEV+2,NLEV+1,NLEV,                                                                               
     9               MAXL+2,MAXL+1,MAXL)                                                                                            
C                                                                                                                                   
C        * SAVE TOTAL CLOUD COVER.                                                                                                  
C                                                                                                                                   
         K = 1                                                                                                                      
         DO 450 I=ISTART,IEND                                                                                                       
            TC(I) = CMTX(K,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)                                                                                           
               WF(I) = WF(I)+(WCL(K,L+1)*SHUM(I,L))                                                                                 
               LWCD(I,L) = LOG10(WCD(K,L+1))                                                                                        
               RADE(I,L) = RADEQV(K,L+1)                                                                                            
               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)                                                                                           
            LWCD(IEND+1,L) = LWCD(ISTART,L)                                                                                         
            RADE(IEND+1,L) = RADE(ISTART,L)                                                                                         
            RH(IEND+1,L) = RH(ISTART,L)                                                                                             
  550    CONTINUE                                                                                                                   
         WF(IEND+1) = WF(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                                                                                                                   
      JBUF(4) = 1                                                                                                                   
                                                                                                                                    
C     * (1) SINGLE DIMENSIONAL FIELDS.                                                                                              
                                                                                                                                    
      JBUF(3) = NC4TO8("CLDS")                                                                                                      
      CALL PUTFLD2(11,TC,JBUF,MAXX)                                                                                                 
      IF(NSETS.EQ.0) WRITE(6,6025) JBUF                                                                                             
      JBUF(3) = NC4TO8("TLWC")                                                                                                      
      CALL PUTFLD2(13,WF,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("LWCD")                                                                                                   
         CALL PUTFLD2(17,LWCD(1,L),IBUF,MAXX)                                                                                       
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IBUF(3) = NC4TO8("RADE")                                                                                                   
         CALL PUTFLD2(18,RADE(1,L),IBUF,MAXX)                                                                                       
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IBUF(3) = NC4TO8(" RHC")                                                                                                   
         CALL PUTFLD2(19,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(20,XTRACLD(1,N),IBUF,MAXX)                                                                                    
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IBUF(3) = NC4TO8("ITAC")                                                                                                   
         CALL PUTFLD2(21,XTRATAU(1,N),IBUF,MAXX)                                                                                    
         IF(NSETS.EQ.0.AND.L.EQ.1) WRITE(6,6025) IBUF                                                                               
         IBUF(3) = NC4TO8("IEMI")                                                                                                   
         CALL PUTFLD2(22,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('CLDPRG4',-90)                                                               
 901  CALL                                         XIT('CLDPRG4',-91)                                                               
 902  CALL                                         XIT('CLDPRG4',-92)                                                               
C----------------------------------------------------------------                                                                   
 5000 FORMAT(10X,I5,1X,A4,2E10.0,I5)                                            J4                                                  
 5010 FORMAT(10X,5I5)                                                           J4                                                  
 6000 FORMAT('0LAY,ICOORD,PLID,DELT,NBLKS  = ',I5,1X,A4,E10.3,F10.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)))                                                                      
 6018 FORMAT('0 NUMBER OF MISSING MOISTURE LEVELS IS: ',I3)                                                                         
 6020 FORMAT('0 ',I3,' RECORDS TRANSFERRED THROUGH CLDPRG4')                                                                        
 6025 FORMAT(' ',A4,I10,2X,A4,5I10)                                                                                                 
                                                                                                                                    
      END                                                                                                                           
