*IDENT CLDFX404
*/
*/ Modset to diagnose cloud extinctions and absorptivities.
*/ This version is built against 4.4.
*/
*/ Required for HADCM3.
*/
*DECLARE RAD_CTL1
*B RAD_CTL1.36
!LL   4.x  Nov. 1997 Diagnostics of SW cloud extinction
!LL                  and LW cloud absorptivity and of total cloud
!LL                  amount on model levels added.
!LL                                      (J. M. Edwards)
*I ADB2F404.1002
     &        STASHWORK(SI(239,1,im_index)+JS), SF(239,1),
     &        STASHWORK(SI(240,1,im_index)+JS), SF(240,1),
*I ADB2F404.1034
     &        STASHWORK(JS_LOCAL(I)+SI(239,2,im_index)), SF(239,2),
     &        STASHWORK(JS_LOCAL(I)+SI(240,2,im_index)), SF(240,2),
     &        STASHWORK(JS_LOCAL(I)+SI(241,2,im_index)), SF(241,2),
*DECLARE SWRAD3A
*B SWRAD3A.20
!       4.x             12-11-97                Diagnostics of 
!                                               extinction added.
!                                               (J. M. Edwards)
!
*I ADB2F404.1513
     &   , CLOUD_EXTINCTION, L_CLOUD_EXTINCTION
     &   , CLOUD_WEIGHT_EXTINCTION, L_CLOUD_WEIGHT_EXTINCTION
*I ADB2F404.1533
     &   , L_CLOUD_EXTINCTION
!             CALCULATE EXTINCTION OF CLOUDS
     &   , L_CLOUD_WEIGHT_EXTINCTION
!             CALCULATE WEIGHT FOR EXTINCTION OF CLOUDS
*I ADB2F404.1537
     &   , CLOUD_EXTINCTION(NPD_FIELD, NCLDS)
!             MEAN EXTINCTION COEFFICIENT IN CLOUDS WEIGHTED BY THE
!             CLOUD AMOUNT AND THE CLEAR-SKY FLUX
     &   , CLOUD_WEIGHT_EXTINCTION(NPD_FIELD, NCLDS)
!             WEIGHTING FACTOR FOR EXTINCTION IN CLOUDS: THE PRODUCT
!             OF THE CLOUD AMOUNT AND THE CLEAR-SKY DIRECT FLUX
*I SWRAD3A.485
     &   , CLOUD_EXTINCTION_G(NPD_PROFILE, NPD_LAYER)
!             MEAN EXTINCTION COEFFICIENT IN CLOUDS WEIGHTED BY THE
!             CLOUD AMOUNT AND THE CLEAR-SKY FLUX (GATHERED ARRAY)
     &   , CLOUD_WEIGHT_EXTINCTION_G(NPD_PROFILE, NPD_LAYER)
!             WEIGHTING FACTOR FOR EXTINCTION IN CLOUDS: THE PRODUCT
!             OF THE CLOUD AMOUNT AND THE CLEAR-SKY DIRECT FLUX 
!             (GATHERED ARRAY)
*I SWRAD3A.627
!     CLEAR-SKY FLUXES ARE REQUIRED TO WEIGHT SOME CLOUDY DIAGNOSTICS.
*D SWRAD3A.630
     &        L_CLEAR_HR.OR.
     &        (L_CLOUD_EXTINCTION.AND.L_CLOUD_WEIGHT_EXTINCTION)
*I SWRAD3A.657
!
!     CHECK THE CONSISTENCY OF CLOUD DIAGNOSTICS
      IF (L_CLOUD_EXTINCTION) THEN
         IF (.NOT.L_CLOUD_WEIGHT_EXTINCTION) THEN
            WRITE(IU_ERR, '(/A, /A)') 
     &         '*** ERROR: THE CLOUDY EXTINCTION MAY BE DIAGNOSED.'
     &         , 'ONLY IN CONJUNCTION WITH THE CORREPONDING WEIGHTS.'
            IERR=I_ERR_FATAL
            RETURN
         ENDIF
      ENDIF
*I SWRAD3A.767
     &   , L_CLOUD_EXTINCTION, CLOUD_EXTINCTION_G
     &   , CLOUD_WEIGHT_EXTINCTION_G
     &   , .FALSE., DUMMY, DUMMY
*I ADB2F404.1685
!
!
!     CLOUD EXTINCTION DIAGNOSTICS:
!
      IF (L_CLOUD_EXTINCTION) THEN
!        SCATTER AND INVERT THE DIAGNOSTICS RETURNED FROM BELOW.
         DO I=1, NCLDS
            CALL R2_ZERO_1D(N_PROFILE, CLOUD_EXTINCTION(1, I))
            CALL R2_ZERO_1D(N_PROFILE, CLOUD_WEIGHT_EXTINCTION(1, I))
            DO L=1, NLIT
               CLOUD_EXTINCTION(LIST(L), I)
     &            =CLOUD_EXTINCTION_G(L, NLEVS+1-I)
               CLOUD_WEIGHT_EXTINCTION(LIST(L), I)
     &            =CLOUD_WEIGHT_EXTINCTION_G(L, NLEVS+1-I)
            ENDDO
         ENDDO
      ENDIF
*DECLARE LWRAD3A
*B LWRAD3A.19
!       4.3             24-02-97                Diagnostics of flux
!                                               at the tropopause, of
!                                               cloud absorptivity and
!                                               of total cloud on model
!                                               layers added.
!                                               (J. M. Edwards)
!
*I ADB2F404.641
     &   , CLOUD_ABSORPTIVITY, L_CLOUD_ABSORPTIVITY
     &   , CLOUD_WEIGHT_ABSORPTIVITY, L_CLOUD_WEIGHT_ABSORPTIVITY
     &   , TOTAL_CLOUD_ON_LEVELS, L_TOTAL_CLOUD_ON_LEVELS
*I ADB2F404.660
     &   , L_CLOUD_ABSORPTIVITY
!             CALCULATE ABSORPTION COEFFICIENTS IN CLOUDS
     &   , L_CLOUD_WEIGHT_ABSORPTIVITY
!             CALCULATE WEIGHTING FOR ABSORPTION COEFFICIENTS IN CLOUDS
     &   , L_TOTAL_CLOUD_ON_LEVELS
!             CALCULATE THE TOTAL AMOUNT OF CLOUD ON MODEL LEVELS
*I ADB2F404.664
     &   , CLOUD_ABSORPTIVITY(NPD_FIELD, NCLDS)
!             MEAN ABSORPTION COEFFICIENT IN CLOUDS WEIGHTED BY THE
!             CLOUD AMOUNT AND THE CLEAR-SKY FLUX
     &   , CLOUD_WEIGHT_ABSORPTIVITY(NPD_FIELD, NCLDS)
!             WEIGHTING FACTOR FOR ABSORPTION IN CLOUDS: THE PRODUCT
!             OF THE CLOUD AMOUNT AND THE CLEAR-SKY FLUX
     &   , TOTAL_CLOUD_ON_LEVELS(NPD_FIELD, NCLDS)
!             TOTAL CLOUD FRACTION ON MODEL LEVELS
*I LWRAD3A.368
!
!     LOCAL FIELDS FOR CLOUD DIAGNOSTICS:
      REAL
     &     CLOUD_ABSORPTIVITY_G(NPD_PROFILE, NPD_LAYER)
!             MEAN ABSORPTION COEFFICIENT IN CLOUDS WEIGHTED BY THE
!             CLOUD AMOUNT AND THE CLEAR-SKY FLUX
     &   , CLOUD_WEIGHT_ABSORPTIVITY_G(NPD_PROFILE, NPD_LAYER)
!             WEIGHTING FACTOR FOR ABSORPTION IN CLOUDS: THE PRODUCT
!             OF THE CLOUD AMOUNT AND THE CLEAR-SKY FLUX
*I LWRAD3A.510
!     CLEAR-SKY FLUXES ARE REQUIRED TO WEIGHT SOME CLOUDY DIAGNOSTICS.
*D LWRAD3A.513
     &        L_CLEAR_HR.OR.
     &        (L_CLOUD_ABSORPTIVITY.AND.L_CLOUD_WEIGHT_ABSORPTIVITY)
*I LWRAD3A.540
!
!     CHECK THE CONSISTENCY OF CLOUD DIAGNOSTICS
      IF (L_CLOUD_ABSORPTIVITY) THEN
         IF (.NOT.L_CLOUD_WEIGHT_ABSORPTIVITY) THEN
            WRITE(IU_ERR, '(/A, /A)') 
     &         '*** ERROR: THE CLOUDY ABSORPTIVITY MAY BE DIAGNOSED.'
     &         , 'ONLY IN CONJUNCTION WITH THE CORREPONDING WEIGHTS.'
            IERR=I_ERR_FATAL
            RETURN
         ENDIF
      ENDIF
*I LWRAD3A.634
     &   , .FALSE., DUMMY, DUMMY
     &   , L_CLOUD_ABSORPTIVITY, CLOUD_ABSORPTIVITY_G
     &   , CLOUD_WEIGHT_ABSORPTIVITY_G
*I ADB2F404.807
!
!
!     CLOUD ABSORPTIVITY DIAGNOSTICS:
!
      IF (L_CLOUD_ABSORPTIVITY) THEN
!        SCATTER AND INVERT THE DIAGNOSTICS RETURNED FROM BELOW.
         DO I=1, NCLDS
            CALL R2_ZERO_1D(N_PROFILE, CLOUD_ABSORPTIVITY(1, I))
            CALL R2_ZERO_1D(N_PROFILE, CLOUD_WEIGHT_ABSORPTIVITY(1, I))
            DO L=1, N_PROFILE
               CLOUD_ABSORPTIVITY(L, I)
     &            =CLOUD_ABSORPTIVITY_G(L, NLEVS+1-I)
               CLOUD_WEIGHT_ABSORPTIVITY(L, I)
     &            =CLOUD_WEIGHT_ABSORPTIVITY_G(L, NLEVS+1-I)
            ENDDO
         ENDDO
      ENDIF
!
!
!     TOTAL CLOUD FRACTION ON MODEL LEVELS.
!
      IF (L_TOTAL_CLOUD_ON_LEVELS) THEN
         DO I=1, NCLDS
            DO L=1, N_PROFILE
               TOTAL_CLOUD_ON_LEVELS(L, I)=W_CLOUD(L, NLEVS+1-I)
            ENDDO
         ENDDO
      ENDIF
*DECLARE FXCA3A
*I FXCA3A.87
     &   , L_CLOUD_EXTINCTION, CLOUD_EXTINCTION
     &   , CLOUD_WEIGHT_EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY, CLOUD_ABSORPTIVITY
     &   , CLOUD_WEIGHT_ABSORPTIVITY
*I FXCA3A.456
     &   , L_CLOUD_ABSORPTIVITY
!             FLAG TO CALCULATE ABSORPTIVITY OF CLOUDS
!             (ONLY INFRA-RED)
     &   , L_CLOUD_EXTINCTION
!             FLAG TO CALCULATE EXTINCTION OF CLOUDS
!             (ONLY SOLAR)
*I ADB1F401.450
!
!     DIAGNOSTICS FOR CLOUDS
      REAL      !, INTENT(OUT)
     &     CLOUD_ABSORPTIVITY(NPD_PROFILE, NPD_LAYER)
!             ABSORPTIVITY OF CLOUD WEIGHTED BY CLOUD FRACTION
!             AND UPWARD CLEAR-SKY INFRA-RED FLUX.
     &   , CLOUD_WEIGHT_ABSORPTIVITY(NPD_PROFILE, NPD_LAYER)
!             WEIGHTS TO BE APPLIED TO ABSORPTIVIES.
     &   , CLOUD_EXTINCTION(NPD_PROFILE, NPD_LAYER)
!             ABSORPTIVITY OF CLOUD WEIGHTED BY CLOUD FRACTION
!             AND DOWNWARD CLEAR-SKY SOLAR FLUX.
     &   , CLOUD_WEIGHT_EXTINCTION(NPD_PROFILE, NPD_LAYER)
!             WEIGHTS TO BE APPLIED TO EXTINCTIONS.
*I ADB1F401.454
!
!     SECONDARY ARRAYS FOR DIAGNOSTICS
      REAL
     &     CLOUD_ABSORPTIVITY_BAND(NPD_PROFILE, NPD_LAYER)
!             ABSORPTIVITY OF CLOUD IN A PARTICULAR BAND
     &   , CLOUD_EXTINCTION_BAND(NPD_PROFILE, NPD_LAYER)
!             ABSORPTIVITY OF CLOUD IN A PARTICULAR BAND
*I ADB1F401.462
     &   , L_CLOUD_EXTINCTION, CLOUD_EXTINCTION
     &   , CLOUD_WEIGHT_EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY, CLOUD_ABSORPTIVITY
     &   , CLOUD_WEIGHT_ABSORPTIVITY
*D FXCA3A.874
     &   , NPD_PROFILE, NPD_LAYER
*I FXCA3A.1027
     &      , FRAC_CLOUD
     &      , L_CLOUD_EXTINCTION, CLOUD_EXTINCTION_BAND
     &      , L_CLOUD_ABSORPTIVITY, CLOUD_ABSORPTIVITY_BAND
*D FXCA3A.1515
         CALL R2_COUPLE_DIAG(N_PROFILE, N_LAYER, L_NET, ISOLIR
*D FXCA3A.1531
     &   , L_CLOUD_EXTINCTION, CLOUD_EXTINCTION_BAND
     &   , FLUX_DIRECT_CLEAR_BAND
     &   , N_CLOUD_TOP, N_CLOUD_PROFILE, I_CLOUD_PROFILE
     &   , W_CLOUD
     &   , CLOUD_EXTINCTION, CLOUD_WEIGHT_EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY, CLOUD_ABSORPTIVITY_BAND
     &   , FLUX_TOTAL_CLEAR_BAND
     &   , CLOUD_ABSORPTIVITY, CLOUD_WEIGHT_ABSORPTIVITY
     &   , NPD_PROFILE, NPD_LAYER
*DECLARE DIAG3A
*I DIAG3A.76
     &   , L_CLOUD_EXTINCTION, CLOUD_EXTINCTION
     &   , CLOUD_WEIGHT_EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY, CLOUD_ABSORPTIVITY
     &   , CLOUD_WEIGHT_ABSORPTIVITY
*D DIAG3A.77
     &   , NPD_PROFILE, NPD_LAYER
*I DIAG3A.90
     &   , NPD_LAYER
!             MAXIMUM NUMBER OF LAYERS
*I DIAG3A.105
      LOGICAL   !, INTENT(IN)
     &     L_CLOUD_EXTINCTION
!             FLAG TO CALCULATE CLOUDY EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY
!             FLAG TO CALCULATE CLOUDY ABSORPTIVITY
*I DIAG3A.118
!
      REAL      !, INTENT(OUT)
     &     CLOUD_EXTINCTION(NPD_PROFILE, NPD_LAYER)
!             OVERALL EXTINCTION OF CLOUDS
     &   , CLOUD_WEIGHT_EXTINCTION(NPD_PROFILE, NPD_LAYER)
!             WEIGHTING FOR CLOUD EXTINCTION
     &   , CLOUD_ABSORPTIVITY(NPD_PROFILE, NPD_LAYER)
!             OVERALL ABSORPTIVITY OF CLOUDS
     &   , CLOUD_WEIGHT_ABSORPTIVITY(NPD_PROFILE, NPD_LAYER)
!             WEIGHTING FOR CLOUD ABSORPTIVITY
!
!
!
!     LOCAL VARIABLES
      INTEGER
     &     I
!             LOOP VARIABLE 
*I DIAG3A.138
!
      IF (L_CLOUD_EXTINCTION) THEN
         DO I=1, NPD_LAYER
            CALL R2_ZERO_1D(N_PROFILE, CLOUD_EXTINCTION(1, I))
            CALL R2_ZERO_1D(N_PROFILE, CLOUD_WEIGHT_EXTINCTION(1, I))
         ENDDO
      ENDIF
!
      IF (L_CLOUD_ABSORPTIVITY) THEN
         DO I=1, NPD_LAYER
            CALL R2_ZERO_1D(N_PROFILE, CLOUD_ABSORPTIVITY(1, I))
            CALL R2_ZERO_1D(N_PROFILE, CLOUD_WEIGHT_ABSORPTIVITY(1, I))
         ENDDO
      ENDIF
*D DIAG3A.163
      SUBROUTINE R2_COUPLE_DIAG(N_PROFILE, N_LAYER, L_NET, ISOLIR
*D DIAG3A.175
     &   , L_CLOUD_EXTINCTION, CLOUD_EXTINCTION_BAND
     &   , FLUX_DIRECT_CLEAR_BAND
     &   , N_CLOUD_TOP, N_CLOUD_PROFILE, I_CLOUD_PROFILE
     &   , W_CLOUD
     &   , CLOUD_EXTINCTION, CLOUD_WEIGHT_EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY, CLOUD_ABSORPTIVITY_BAND
     &   , FLUX_TOTAL_CLEAR_BAND
     &   , CLOUD_ABSORPTIVITY, CLOUD_WEIGHT_ABSORPTIVITY
     &   , NPD_PROFILE, NPD_LAYER
*I DIAG3A.192
     &   , NPD_LAYER
!             MAXIMUM NUMBER OF ATMOSPHERIC LAYERS
*I DIAG3A.196
     &   , N_LAYER
!             NUMBER OF LAYERS IN THE ATMOSPHERE
*I DIAG3A.214
     &   , L_CLOUD_EXTINCTION
!             CALCULATE CLOUD EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY
!             CALCULATE CLOUD ABSORPTIVITY
*I DIAG3A.248
!
!
!     PROPERTIES OF CLOUDS:
!
      INTEGER   !, INTENT(IN)
     &     N_CLOUD_TOP
!             TOPMOST CLOUDY LAYER
     &   , N_CLOUD_PROFILE(NPD_LAYER)
!             NUMBER OF CLOUDY PROFILES IN EACH LAYER
     &   , I_CLOUD_PROFILE(NPD_PROFILE, NPD_LAYER)
!             PROFILES CONTAINING CLOUDS
!
      REAL      !, INTENT(IN)
     &     CLOUD_EXTINCTION_BAND(NPD_PROFILE, NPD_LAYER)
!             EXTINCTION OF CLOUD IN THE CURRENT BAND
     &   , CLOUD_ABSORPTIVITY_BAND(NPD_PROFILE, NPD_LAYER)
!             ABSORPTIVITY OF CLOUD IN THE CURRENT BAND
     &   , W_CLOUD(NPD_PROFILE, NPD_LAYER)
!             TOTAL CLOUD FRACTION
!
!     FLUXES FOR WEIGHTING CLOUDY DIAGNOSTICS
      REAL
     &     FLUX_DIRECT_CLEAR_BAND(NPD_PROFILE, 0: NPD_LAYER)
!             DIRECT CLEAR-SKY FLUX
     &   , FLUX_TOTAL_CLEAR_BAND(NPD_PROFILE, 2*NPD_LAYER+2)
!             TOTAL (DIFFERENTIAL) CLEAR-SKY FLUX
!
*I DIAG3A.262
!
!     INCREMENTED CLOUDY FIELDS:
      REAL      !, INTENT(INOUT)
     &     CLOUD_EXTINCTION(NPD_PROFILE, NPD_LAYER)
!             OVERALL EXTINCTION OF CLOUDS WEIGHTED WITH CLOUD AMOUNT
!             AND CLEAR-SKY DIRECT FLUX.
     &   , CLOUD_WEIGHT_EXTINCTION(NPD_PROFILE, NPD_LAYER)
!             WEIGHTING FOR CLOUD EXTINCTION
     &   , CLOUD_ABSORPTIVITY(NPD_PROFILE, NPD_LAYER)
!             OVERALL ABSORPTIVITY OF CLOUDS WEIGHTED WITH CLOUD AMOUNT
!             AND CLEAR-SKY FLUX.
     &   , CLOUD_WEIGHT_ABSORPTIVITY(NPD_PROFILE, NPD_LAYER)
!             WEIGHTING FOR CLOUD ABSORPTIVITY
*I DIAG3A.268
     &   , I
!             LOOP VARIABLE
     &   , LL
!             GATHERED LOOP VARIABLE
*I DIAG3A.414
!
!
!
!     SPECTRAL DIAGNOSTICS FOR CLOUDS:
!
      IF (L_CLOUD_EXTINCTION) THEN
!
!        INCREMENT THE ARRAYS OF DIAGNOSTICS. THE EXTINCTION 
!        CALCULATED IN THIS BAND IS A MEAN VALUE WEIGHTED WITH THE
!        FRACTIONS OF INDIVIDUAL TYPES OF CLOUD (WHICH SUM TO 1).
!        HERE IT IS WEIGHTED WITH THE CLEAR-SKY DIRECT SOLAR
!        FLUX IN THE BAND AT THE TOP OF THE CURRENT 
!        LAYER AND THE TOTAL AMOUNT OF CLOUD IN THE GRID-BOX.
!        THIS DEFINITION HAS THE ADVANTAGE OF CONVENIENCE, BUT THERE
!        APPEARS TO BE NO OPTIMAL DEFINITION OF AN AVERAGE EXTINCTION.
!
         DO I=N_CLOUD_TOP, N_LAYER
            DO LL=1, N_CLOUD_PROFILE(I)
               L=I_CLOUD_PROFILE(LL, I)
               CLOUD_WEIGHT_EXTINCTION(L, I)
     &            =CLOUD_WEIGHT_EXTINCTION(L, I)
     &            +W_CLOUD(L, I)*FLUX_DIRECT_CLEAR_BAND(L, I-1)
               CLOUD_EXTINCTION(L, I)
     &            =CLOUD_EXTINCTION(L, I)
     &            +W_CLOUD(L, I)*FLUX_DIRECT_CLEAR_BAND(L, I-1)
     &            *CLOUD_EXTINCTION_BAND(L, I)
            ENDDO
         ENDDO
!
      ENDIF
!
      IF (L_CLOUD_ABSORPTIVITY) THEN
!
!        INCREMENT THE ARRAYS OF DIAGNOSTICS. THE ABSORPTIVITY 
!        CALCULATED IN THIS BAND IS A MEAN VALUE WEIGHTED WITH THE
!        FRACTIONS OF INDIVIDUAL TYPES OF CLOUD (WHICH SUM TO 1).
!        HERE IT IS WEIGHTED WITH THE MODULUS OF THE CLEAR_SKY 
!        DIFFERENTIAL FLUX IN THE BAND AT THE TOP OF THE CURRENT 
!        LAYER AND THE TOTAL AMOUNT OF CLOUD IN THE GRID-BOX AS THE
!        DIAGNOSTIC IS A MEASURE OF THE EFFECT OF INTRODUCING AN
!        INFINITESIMAL LAYER OF LAYER AT THE TOP OF THE CURRENT
!        LAYER INTO A CLEAR ATMOSPHERE ON THE UPWARD FLUX AT THE
!        TOP OF THE CLOUD.
!
         DO I=N_CLOUD_TOP, N_LAYER
            DO LL=1, N_CLOUD_PROFILE(I)
               L=I_CLOUD_PROFILE(LL, I)
               CLOUD_WEIGHT_ABSORPTIVITY(L, I)
     &            =CLOUD_WEIGHT_ABSORPTIVITY(L, I)
     &            +W_CLOUD(L, I)*ABS(FLUX_TOTAL_CLEAR_BAND(L, 2*I-1))
               CLOUD_ABSORPTIVITY(L, I)
     &            =CLOUD_ABSORPTIVITY(L, I)
     &            +W_CLOUD(L, I)*ABS(FLUX_TOTAL_CLEAR_BAND(L, 2*I-1))
     &            *CLOUD_ABSORPTIVITY_BAND(L, I)
            ENDDO
         ENDDO
!
      ENDIF
*DECLARE GREYK3A
*I GREYK3A.45
     &   , FRAC_CLOUD
     &   , L_CLOUD_EXTINCTION, CLOUD_EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY, CLOUD_ABSORPTIVITY
*I GREYK3A.225
!
!
!     VARIABLES REQUIRED FOR EXTRA DIAGNOSTIC CALCULATIONS.
!
      LOGICAL   !, INTENT(IN)
     &     L_CLOUD_EXTINCTION
!             FLAG FOR EXPLICIT CALCULATION OF EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY
!             FLAG FOR EXPLICIT CALCULATION OF ABSORPTIVITY
!
      REAL      !, INTENT(IN)
     &     FRAC_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE)
!             FRACTIONS OF EACH TYPE OF CLOUD
*I GREYK3A.247
!
      REAL      !, INTENT(OUT)
     &     CLOUD_EXTINCTION(NPD_PROFILE, NPD_LAYER)
!             MEAN CLOUD EXTINCTION
     &   , CLOUD_ABSORPTIVITY(NPD_PROFILE, NPD_LAYER)
!             MEAN CLOUD ABSORPTIVITY
*I GREYK3A.484
!
!
!     INITIALIZE ARRAYS FOR DIAGNOSTIC USE.
!
      IF (L_CLOUD_EXTINCTION) THEN
         DO I=1, N_LAYER
            DO L=1, N_PROFILE
               CLOUD_EXTINCTION(L, I)=0.0E+00
            ENDDO
         ENDDO
      ENDIF
!
      IF (L_CLOUD_ABSORPTIVITY) THEN
         DO I=1, N_LAYER
            DO L=1, N_PROFILE
               CLOUD_ABSORPTIVITY(L, I)=0.0E+00
            ENDDO
         ENDDO
      ENDIF
*I GREYK3A.584
!
!
!           EXTRA CALCULATIONS FOR DIAGNOSTICS.
!
            IF (L_CLOUD_EXTINCTION) THEN
               DO I=N_CLOUD_TOP, N_LAYER
                  DO LL=1, N_CLOUD_PROFILE(I)
                     L=I_CLOUD_PROFILE(LL, I)
                     CLOUD_EXTINCTION(L, I)
     &                  =CLOUD_EXTINCTION(L, I)
     &                  +K_EXT_TOT_CLOUD_COMP(L, I)
     &                  *FRAC_CLOUD(L, I, I_CLOUD_TYPE(K))
                  ENDDO
               ENDDO
            ENDIF
!
!
            IF (L_CLOUD_ABSORPTIVITY) THEN
               DO I=N_CLOUD_TOP, N_LAYER
                  DO LL=1, N_CLOUD_PROFILE(I)
                     L=I_CLOUD_PROFILE(LL, I)
                     CLOUD_ABSORPTIVITY(L, I)
     &                  =CLOUD_ABSORPTIVITY(L, I)
     &                  +(K_EXT_TOT_CLOUD_COMP(L, I)
     &                  -K_EXT_SCAT_CLOUD_COMP(L, I))
     &                  *FRAC_CLOUD(L, I, I_CLOUD_TYPE(K))
                  ENDDO
               ENDDO
            ENDIF
*DECLARE GREYK3B
*I GREYK3B.64
     &   , FRAC_CLOUD
     &   , L_CLOUD_EXTINCTION, CLOUD_EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY, CLOUD_ABSORPTIVITY
*I GREYK3B.244
!
!
!     VARIABLES REQUIRED FOR EXTRA DIAGNOSTIC CALCULATIONS.
!
      LOGICAL   !, INTENT(IN)
     &     L_CLOUD_EXTINCTION
!             FLAG FOR EXPLICIT CALCULATION OF EXTINCTION
     &   , L_CLOUD_ABSORPTIVITY
!             FLAG FOR EXPLICIT CALCULATION OF ABSORPTIVITY
!
      REAL      !, INTENT(IN)
     &     FRAC_CLOUD(NPD_PROFILE, NPD_LAYER, NPD_CLOUD_TYPE)
!             FRACTIONS OF EACH TYPE OF CLOUD
*I GREYK3B.266
!
      REAL      !, INTENT(OUT)
     &     CLOUD_EXTINCTION(NPD_PROFILE, NPD_LAYER)
!             MEAN CLOUD EXTINCTION
     &   , CLOUD_ABSORPTIVITY(NPD_PROFILE, NPD_LAYER)
!             MEAN CLOUD ABSORPTIVITY
*I GREYK3B.545
!
!
!     INITIALIZE ARRAYS FOR DIAGNOSTIC USE.
!
      IF (L_CLOUD_EXTINCTION) THEN
         DO I=1, N_LAYER
            DO L=1, N_PROFILE
               CLOUD_EXTINCTION(L, I)=0.0E+00
            ENDDO
         ENDDO
      ENDIF
!
      IF (L_CLOUD_ABSORPTIVITY) THEN
         DO I=1, N_LAYER
            DO L=1, N_PROFILE
               CLOUD_ABSORPTIVITY(L, I)=0.0E+00
            ENDDO
         ENDDO
      ENDIF
*I GREYK3B.630
!
!
!           EXTRA CALCULATIONS FOR DIAGNOSTICS.
!
            IF (L_CLOUD_EXTINCTION) THEN
               DO I=N_CLOUD_TOP, N_LAYER
                  DO LL=1, N_CLOUD_PROFILE(I)
                     L=I_CLOUD_PROFILE(LL, I)
                     CLOUD_EXTINCTION(L, I)
     &                  =CLOUD_EXTINCTION(L, I)
     &                  +K_EXT_TOT_CLOUD_COMP(L, I)
     &                  *FRAC_CLOUD(L, I, I_CLOUD_TYPE(K))
                  ENDDO
               ENDDO
            ENDIF
!
!
            IF (L_CLOUD_ABSORPTIVITY) THEN
               DO I=N_CLOUD_TOP, N_LAYER
                  DO LL=1, N_CLOUD_PROFILE(I)
                     L=I_CLOUD_PROFILE(LL, I)
                     CLOUD_ABSORPTIVITY(L, I)
     &                  =CLOUD_ABSORPTIVITY(L, I)
     &                  +(K_EXT_TOT_CLOUD_COMP(L, I)
     &                  -K_EXT_SCAT_CLOUD_COMP(L, I))
     &                  *FRAC_CLOUD(L, I, I_CLOUD_TYPE(K))
                  ENDDO
               ENDDO
            ENDIF