      PROGRAM INITCL6                                                                                                               
C     PROGRAM INITCL6 (ICTL,       CLLX,       CLDTAC,       OUTPUT,    )       I2                                                  
C    1          TAPE99=ICTL, TAPE1=CLLX, TAPE2=CLDTAC, TAPE6=OUTPUT)                                                                
C     --------------------------------------------------------------            I2                                                  
C                                                                               I2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       I2                                                  
C     JUN 12/96 - F. MAJAESS (REPLACE FSEEK CALLS BY FORTRAN CODE)                                                                  
C     JUL 13/92 - E. CHAN  (DIMENSION SELECTED VARIABLES AS REAL*8 AND                                                              
C                           USE STANDARD ROUTINES FOR I/O TO UNIT 1).                                                               
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII AND                                                                 
C                           REPLACE CALLS TO SKIPF WITH CALLS TO THE                                                                
C                           C ROUTINE FSEEK).                                                                                       
C     JUN 07/88 - M.LAZARE (FIX BUG WHERE IDAY NOT MONTH BOUNDARY).                                                                 
C     MAY 24/88 - M.LAZARE (DERIVED FROM INITCL5 AND INITCLH).                                                                      
C                                                                               I2                                                  
CINITCL6 - COMPUTES ZONALLY AVERAGED CLOUDS ON GAUSSIAN GRID FOR GCM6   2  1    I1                                                  
C                                                                               I3                                                  
CAUTHOR  - M.LAZARE                                                             I3                                                  
C                                                                               I3                                                  
CPURPOSE - COMPUTES THE ZONALLY AVERAGED CLOUDS ON THE GAUSSIAN GRID            I3                                                  
C          OF THE MODEL.                                                        I3                                                  
C          NOTE - THE SIGMA/ETA EFFECT IS NOT ACCOUNTED FOR IN THE              I3                                                  
C                 VERTICAL INTERPOLATION.                                       I3                                                  
C                                                                               I3                                                  
CINPUT FILES...                                                                 I3                                                  
C                                                                               I3                                                  
C      ICTL   = GCM INITIALIZATION CONTROL FILE. (SEE ICNTRL6)                  I3                                                  
C      CLLX   = MONTHLY LATITUDE-HEIGHT CROSS-SECTIONS OF CLOUD AMOUNT,         I3                                                  
C               CLOUD BASE, AND CLOUD TOPS.                                     I3                                                  
C                                                                               I3                                                  
COUTPUT FILE...                                                                 I3                                                  
C                                                                               I3                                                  
C      CLDTAC = MONTHLY VALUES (CROSS-SECTIONS) OF CLOUD AND TAC.               I3                                                  
C               IF THE MODEL HAS ILEV LAYERS AND ILAT LATITUDES                 I3                                                  
C               CLOUD AMOUNT IS PRODUCED IN AN ARRAY WHOSE SIZE IS              I3                                                  
C               (ILAT,ILEV+2,ILEV+2), WHERE ITEM (J,L1,L2) IS THE               I3                                                  
C               NEBULOSITY AT LATITUDE J BETWEEN LEVEL L1-1 AND L2-1.           I3                                                  
C               OPTICAL THICKNESS APPEARS AS A REGULAR CROSS-SECTION            I3                                                  
C               DEFINED ON ILAT LATITUDES AND ILEV HALF LEVELS.                 I3                                                  
C-------------------------------------------------------------------------------                                                    
C                                                                                                                                   
C     *    MONTH = 1 TO 12.                                                                                                         
C     *    LEVS  = NUMBER OF LEVELS.                                                                                                
C     *    ILAT  = SOUTH - NORTH NUMBER OF GRID POINTS.                                                                             
C     *    CB    = 0  FOR CB NOT TO BE CONSIDERED,                                                                                  
C     *            OTHERWISE CB INCLUDED.                                                                                           
C     *    S     = VECTOR OF SIGMA COORDINATES.                                                                                     
C     *    AMT   = BASIC CLOUD NEBULOSITY DATA.                                                                                     
C     *    BASE  =             BASE       DATA.                                                                                     
C     *    TOP   =             TOP        DATA.                                                                                     
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      LOGICAL OK                                                                                                                    
      CHARACTER*4 STRING                                                                                                            
      INTEGER CB,RNDOFF                                                                                                             
      INTEGER NFDM(12)                                                                                                              
                                                                                                                                    
      REAL*8 SL(96),CL(96),WL(96),WOSSL(96),RADL(96)                                                                                
      REAL SG(100),SH(100),SGB(100),SHB(100)                                                                                        
      REAL S(101)                                                                                                                   
      REAL DLAT(96),TAUC(19300)                                                                                                     
C                                                                                                                                   
C     * WORK ARRAYS FOR SUBROUTINE CLOUD6.                                                                                          
C                                                                                                                                   
      REAL P(100),Z(100),TO(101),W(100)                                                                                             
      REAL FINEGR(110,6),OCCUPY(100,6),TC(18,100),BNEB(18,100,100)                                                                  
      REAL ALAT(19),OVRLAP(6,6),LWC(6),LWP(6)                                                                                       
      REAL AMT(18,6),BASE(18,6),TOP(18,6)                                                                                           
      INTEGER IZ(101),LBL(96),LB(6),LT(6),LXTND(6)                                                                                  
C                                                                                                                                   
C     * A SIZE OF 90000 FOR THE CLOUD ARRAYS ALLOWS RUNNING THE GCM                                                                 
C     * UP TO 50 LEVELS WITH T20 RESOLUTION, OR 20 LEVELS WITH T60                                                                  
C     * RESOLUTION.                                                                                                                 
                                                                                                                                    
      COMMON/BLANCK/ CCC(998784),CCCM(998784),CCCP(998784)                                                                          
      COMMON /ICOM / IBUF(8),IDAT(998784)                                                                                           
C                                                                                                                                   
C    **** TYPICAL LIQUID WATER CONTENT (LWC), EXCEPT FOR TYPE 1 (CI) AND                                                            
C         4 (ST) TO ACCOUNT FOR ARTIFICIALLY REDUCED PHYSICAL THICKNESS.                                                            
C                                                                                                                                   
      DATA LWC/0.195E0,0.15E0,0.22E0,0.51E0,0.33E0,0.50E0/                                                                          
C                                                                                                                                   
      DATA NFDM /1,32,60,91,121,152,182,213,244,274,305,335/                                                                        
      DATA AMT /108*0.E0/, BASE /108*0.E0/, TOP /108*0.E0/                                                                          
      DATA CB,RNDOFF,NLAT,IFINE/1,1,18,110/                                                                                         
      DATA MAXX/998784/, MAXL/100/                                                                                                  
C-----------------------------------------------------------------------                                                            
      NFIL=4                                                                                                                        
      CALL JCLPNT (NFIL,99,1,2,6)                                                                                                   
      NLATP1=NLAT+1                                                                                                                 
                                                                                                                                    
C     * GET PARAMETERS FROM CONTROL FILE.                                                                                           
                                                                                                                                    
      REWIND 99                                                                                                                     
      READ(99,END=902) LABL,LEVS,                                                                                                   
     1                 (SG(L),L=1,LEVS),                                                                                            
     2                 (SH(L),L=1,LEVS),                                                                                            
     3                 LAY,ICOORD,PTOIT,MOIST                                                                                       
      READ(99,END=903) LABL,IXX,IXX,IXX,ILAT,IXX,IDAY,GMT                                                                           
      WRITE(6,6010)    LEVS,ILAT,CB,RNDOFF                                                                                          
      IF((LEVS.LT.1).OR.(LEVS.GT.MAXL)) CALL       XIT('INITCL6',-1)                                                                
      STRING=' SG '                                                                                                                 
      WRITE(6,6015)    STRING,(SG(L),L=1,LEVS)                                                                                      
      STRING=' SH '                                                                                                                 
      WRITE(6,6015)    STRING,(SH(L),L=1,LEVS)                                                                                      
      WRITE(6,6016)    LAY,ICOORD,PTOIT,MOIST                                                                                       
      WRITE(6,6025)    IDAY,GMT                                                                                                     
                                                                                                                                    
C    * SET S TO MODEL THERMODYNAMIC LAYER INTERFACES.                                                                               
C    * TOP LEVEL DEFINED FOR UPWARD COMPATIBILITY WITH EARLIER                                                                      
C    * STAGGERED VERSION.                                                                                                           
                                                                                                                                    
      LEV=LEVS+1                                                                                                                    
      CALL BASCAL (SGB,SHB,SG,SH,LEVS,LAY)                                                                                          
      S(1)=SH(1)**2/SHB(1)                                                                                                          
      DO 20 L=1,LEVS                                                                                                                
   20 S(L+1)=SHB(L)                                                                                                                 
      STRING='SHT '                                                                                                                 
      WRITE(6,6015)    STRING,(S(L),L=1,LEVS)                                                                                       
                                                                                                                                    
C     * READ UNPACKED AMT,BASE,TOP IN THAT ORDER.                                                                                   
                                                                                                                                    
      DO 350 MONTH=1,12                                                                                                             
                                                                                                                                    
        NDAY=NFDM(MONTH)                                                                                                            
        REWIND 1                                                                                                                    
        CALL FIND (1,NC4TO8("ZONL"),NDAY,NC4TO8("CLLX"),0,OK)                                                                       
        IF(.NOT.OK) CALL                           XIT('INITCL6',-2)                                                                
        CALL GETFLD2(1,AMT,-1,-1,-1,-1,IBUF,MAXX,OK)                                                                                
        WRITE(6,6020)   IBUF                                                                                                        
        CALL GETFLD2(1,BASE,-1,-1,-1,-1,IBUF,MAXX,OK)                                                                               
        WRITE(6,6020)   IBUF                                                                                                        
        CALL GETFLD2(1,TOP,-1,-1,-1,-1,IBUF,MAXX,OK)                                                                                
        WRITE(6,6020)   IBUF                                                                                                        
                                                                                                                                    
C       * TEST FOR INCLUSION OF CB TYPE.                                                                                            
                                                                                                                                    
        NTYPE=6                                                                                                                     
        IF(CB.NE.0) GO TO 70                                                                                                        
          NTYPE=5                                                                                                                   
          DO 60 J=1,18                                                                                                              
            AMT(J,6)=0.E0                                                                                                           
            BASE(J,6)=0.E0                                                                                                          
            TOP(J,6)=0.E0                                                                                                           
   60     CONTINUE                                                                                                                  
   70   CONTINUE                                                                                                                    
                                                                                                                                    
C       * DEFINE THE LATITUDE GRID.                                                                                                 
                                                                                                                                    
        ILATH=ILAT/2                                                                                                                
        CALL GAUSSG  (ILATH,SL,WL,CL,RADL,WOSSL)                                                                                    
        CALL  TRIGL  (ILATH,SL,WL,CL,RADL,WOSSL)                                                                                    
        DO 110 J=1,ILAT                                                                                                             
  110   DLAT(J)=RADL(J)*180.E0/3.14159E0                                                                                            
                                                                                                                                    
C       * CALCULATION OF THE CLOUD AMOUNT AT GIVEN GRID POINTS.                                                                     
C       * INCLUDING MOON LEVEL.                                                                                                     
                                                                                                                                    
        CALL CLOUD6 (CCC,TAUC,  S,LEVS,LEV,LEV+1,DLAT,                                                                              
     1               ILAT,IFINE,NLAT,NLATP1,NTYPE,RNDOFF,AMT,BASE,TOP,                                                              
     2               FINEGR,P,Z,TO,IZ,OCCUPY,LBL,W,TC,BNEB,                                                                         
     3               ALAT,OVRLAP,LWC,LWP,LB,LT,LXTND)                                                                               
                                                                                                                                    
C       * OUTPUT CROSS SECTION IN STANDARD FORMAT.                                                                                  
                                                                                                                                    
        LEVPSQ=(LEV+1)**2                                                                                                           
        CALL SETLAB  (IBUF,NC4TO8("ZONL"),NDAY,NC4TO8(" CLD"),0,                                                                    
     +                                          LEVPSQ,ILAT,0,1)                                                                    
        CALL PUTFLD2 (2,CCC,IBUF,MAXX)                                                                                              
        WRITE(6,6020)IBUF                                                                                                           
                                                                                                                                    
        CALL SETLAB  (IBUF,NC4TO8("ZONL"),NDAY,NC4TO8(" TAC"),0,                                                                    
     +                                               ILAT,1,0,1)                                                                    
        DO 300 L=1,LEVS                                                                                                             
          DO 250 J=1,ILAT                                                                                                           
            N=(L-1)*ILAT+J                                                                                                          
            CCC(J)=TAUC(N)                                                                                                          
  250     CONTINUE                                                                                                                  
          IBUF(4)=L                                                                                                                 
          CALL PUTFLD2 (2,CCC,IBUF,MAXX)                                                                                            
          WRITE(6,6020) IBUF                                                                                                        
  300   CONTINUE                                                                                                                    
                                                                                                                                    
  350 CONTINUE                                                                                                                      
C                                                                                                                                   
C     * ADD EXTRA DATA FOR STARTING DATE (IDAY) OF A NEW MODEL RUN                                                                  
C     * WHICH IS NOT A MONTH BOUNDARY. TO DO THIS, INTERPOLATE BETWEEN                                                              
C     * THE TWO ADJACENT MONTH-BOUNDARY VALUES.                                                                                     
C                                                                                                                                   
      PARTDAY=GMT/24.E0                                                                                                             
      RDAY=FLOAT(IDAY)+PARTDAY                                                                                                      
      LL=0                                                                                                                          
      MM=0                                                                                                                          
      DO 375 N=1,12                                                                                                                 
        IF(IDAY.GE.NFDM(N)) LL=N                                                                                                    
        IF(IDAY.EQ.NFDM(N)) MM=N                                                                                                    
  375 CONTINUE                                                                                                                      
      IF(LL.EQ.0) CALL                             XIT('INITCL6',-3)                                                                
                                                                                                                                    
      IF(MM.EQ.0) THEN                                                                                                              
                                                                                                                                    
        NDAYM=NFDM(LL)                                                                                                              
        RFDM=FLOAT(NDAYM)                                                                                                           
        IF(LL.LT.12) THEN                                                                                                           
          RFDP=FLOAT(NFDM(LL+1))                                                                                                    
          NDAYP=NFDM(LL+1)                                                                                                          
        ELSE                                                                                                                        
          RFDP=FLOAT(NFDM(1)+365)                                                                                                   
          NDAYP=NFDM(1)                                                                                                             
        ENDIF                                                                                                                       
        WRITE(6,6040) RDAY,NDAYM,NDAYP                                                                                              
C                                                                                                                                   
C     * CLD.                                                                                                                        
C                                                                                                                                   
        CALL GETFLD2(-2,CCCM,NC4TO8("ZONL"),NDAYM,NC4TO8(" CLD"),                                                                   
     +                                            0,IBUF,MAXX,OK)                                                                   
        IF(.NOT.OK) CALL                           XIT('INITCL6',-4)                                                                
        WRITE(6,6020) IBUF                                                                                                          
        CALL GETFLD2(-2,CCCP,NC4TO8("ZONL"),NDAYP,NC4TO8(" CLD"),                                                                   
     +                                            0,IBUF,MAXX,OK)                                                                   
        IF(.NOT.OK) CALL                           XIT('INITCL6',-5)                                                                
        WRITE(6,6020) IBUF                                                                                                          
        NWDS=IBUF(5)*IBUF(6)                                                                                                        
        DO 400 I=1,NWDS                                                                                                             
          CALL LININT(RFDM,CCCM(I),RFDP,CCCP(I),RDAY,CCC(I))                                                                        
  400   CONTINUE                                                                                                                    
        IBUF(2)=IDAY                                                                                                                
C                                                                                                                                   
C       * POSITION FILE POINTER TO THE END OF THE FILE AND APPEND DATA.                                                             
C                                                                                                                                   
C       ISTAT=FSEEK(2,0,2)                                                                                                          
  450   READ(2,END=460)                                                                                                             
        GOTO 450                                                                                                                    
  460   BACKSPACE 2                                                                                                                 
        CALL PUTFLD2(2,CCC,IBUF,MAXX)                                                                                               
        WRITE(6,6020) IBUF                                                                                                          
C                                                                                                                                   
C     * TAC.                                                                                                                        
C                                                                                                                                   
        DO 700 L=1,LEVS                                                                                                             
                                                                                                                                    
          CALL GETFLD2(-2,CCCM,NC4TO8("ZONL"),NDAYM,NC4TO8(" TAC"),                                                                 
     +                                              L,IBUF,MAXX,OK)                                                                 
          IF(.NOT.OK) CALL                         XIT('INITCL6',-6)                                                                
          IF(L.EQ.1) WRITE(6,6020) IBUF                                                                                             
          CALL GETFLD2(-2,CCCP,NC4TO8("ZONL"),NDAYP,NC4TO8(" TAC"),                                                                 
     +                                              L,IBUF,MAXX,OK)                                                                 
          IF(.NOT.OK) CALL                         XIT('INITCL6',-7)                                                                
          IF(L.EQ.1) WRITE(6,6020) IBUF                                                                                             
          NWDS=IBUF(5)*IBUF(6)                                                                                                      
          DO 600 I=1,NWDS                                                                                                           
            CALL LININT(RFDM,CCCM(I),RFDP,CCCP(I),RDAY,CCC(I))                                                                      
  600     CONTINUE                                                                                                                  
          IBUF(2)=IDAY                                                                                                              
C                                                                                                                                   
C         * POSITION FILE POINTER TO THE END OF THE FILE AND APPEND DATA.                                                           
C                                                                                                                                   
C         ISTAT=FSEEK(2,0,2)                                                                                                        
  650     READ(2,END=660)                                                                                                           
          GOTO 650                                                                                                                  
  660     BACKSPACE 2                                                                                                               
          CALL PUTFLD2(2,CCC,IBUF,MAXX)                                                                                             
          WRITE(6,6020) IBUF                                                                                                        
                                                                                                                                    
  700   CONTINUE                                                                                                                    
                                                                                                                                    
      ENDIF                                                                                                                         
                                                                                                                                    
      CALL                                         XIT('INITCL6',0)                                                                 
                                                                                                                                    
C     * E.O.F. ON FILE ICTL.                                                                                                        
                                                                                                                                    
  902 CALL                                         XIT('INITCL6',-8)                                                                
  903 CALL                                         XIT('INITCL6',-9)                                                                
                                                                                                                                    
C     * E.O.F. ON FILE CLLX.                                                                                                        
                                                                                                                                    
  904 CALL                                         XIT('INITCL6',-10)                                                               
  905 CALL                                         XIT('INITCL6',-11)                                                               
  906 CALL                                         XIT('INITCL6',-12)                                                               
C-----------------------------------------------------------------------                                                            
 6010 FORMAT ('0 LEVS,ILAT,CB,RNDOFF=',6I5)                                                                                         
 6015 FORMAT (1X,A4,/,(5X,10F6.3))                                                                                                  
 6016 FORMAT (' LAY=',I5,', COORD=',A4,', P.LID=',F10.3,' (PA)',                                                                    
     1        ', MOIST=',A4)                                                                                                        
 6020 FORMAT (' ',A4,I10,2X,A4,I10,4I6)                                                                                             
 6025 FORMAT(' IDAY,GMT= ',I5,2X,F5.2)                                                                                              
 6040 FORMAT('0INTERPOLATING FOR RDAY= ',F6.2,' BETWEEN ',I3,' AND ',                                                               
     1           I3,')')                                                                                                            
      END                                                                                                                           
