olwc.F90

Go to the documentation of this file.

SUBROUTINE olwc ( KIDIA,KFDIA,KLON,KLEV &
     &  , pbint,pbsuin,pcldld,pcldlu,pcntrb,pemis,pfdn,pfup &
     &  , pflux                                                 )
!
!**** *LWC*   - LONGWAVE RADIATION, CLOUD EFFECTS
!
!     PURPOSE.
!     --------
!           INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
!           RADIANCES
!
!**   INTERFACE.
!     ----------
!
!        EXPLICIT ARGUMENTS :
!        --------------------
!     ==== INPUTS ===
! PBINT  : (KLON,KLEV+1)     ; HALF LEVEL PLANCK FUNCTION
! PBSUIN : (KLON)            ; SURFACE PLANCK FUNCTION
! PCLDLD : (KLON,KLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
! PCLDLU : (KLON,KLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
! PCNTRB : (KLON,KLEV+1,KLEV+1); CLEAR-SKY ENERGY EXCHANGE
! PEMIS  : (KLON)            ; SURFACE EMISSIVITY
! PFDN   : (KLON,KLEV+1)     ; CLEAR-SKY DOWNWARD FLUX
! PFUP   : (KLON,KLEV+1)     ; CLEAR-SKY UPWARD FLUX
!     ==== OUTPUTS ===
! PFLUX(KLON,2,KLEV)         ; RADIATIVE FLUXES :
!                     1  ==>  UPWARD   FLUX TOTAL
!                     2  ==>  DOWNWARD FLUX TOTAL
!
!        IMPLICIT ARGUMENTS :   NONE
!        --------------------
!
!     METHOD.
!     -------
!
!          1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
!          2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
!          3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
!     CLOUDS
!
!     EXTERNALS.
!     ----------
!
!          NONE
!
!     REFERENCE.
!     ----------
!
!        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
!
!     AUTHOR.
!     -------
!        JEAN-JACQUES MORCRETTE  *ECMWF*
!
!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 89-07-14
!-----------------------------------------------------------------------

#include "tsmbkind.h"

USE yoerad   , ONLY : novlp
USE yoerdi   , ONLY : repclc
USE yoedbug  , ONLY : ldebug


IMPLICIT NONE



!     DUMMY INTEGER SCALARS
integer_m :: kfdia
integer_m :: kidia
integer_m :: klev
integer_m :: klon

!-----------------------------------------------------------------------
!
!*       0.1   ARGUMENTS
!              ---------
!
real_b :: pbint(klon,klev+1),pbsuin(klon),pcldld(klon,klev) &
     &  ,  pcldlu(klon,klev) &
     &  ,  pcntrb(klon,klev+1,klev+1) &
     &  ,  pfdn(klon,klev+1),pfup(klon,klev+1) &
     &  ,  pemis(klon)
!
real_b :: pflux(klon,2,klev+1)
!
!-----------------------------------------------------------------------
!
!*       0.2   LOCAL ARRAYS
!              ------------
!
integer_m :: imx(klon), imxp(klon)
!
real_b :: zclear(klon),zcloud(klon),zdnf(klon,klev+1,klev+1) &
     &  , zfd(klon), zfn10(klon), zfu(klon) &
     &  , zupf(klon,klev+1,klev+1) &
     &  , zclm(klon,klev+1,klev+1)
!
!     LOCAL INTEGER SCALARS
integer_m :: ikcp1, ikm1, ikp1, imaxc, imxm1, imxp1, jcloud,&
             &jk, jk1, jk2, jkj, jl, imx1, imx2, jkc, jkcp1, jkm1, jkp1

!     LOCAL REAL SCALARS
real_b :: zcfrac

!     ------------------------------------------------------------------
!
!*         1.     INITIALIZATION
!                 --------------
!
imaxc = 0
!
DO jl = kidia,kfdia
  imx(jl)=0
  imxp(jl)=0
  zcloud(jl) = 0.
END DO
!
!*         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
!                 -------------------------------------------
!
DO jk = 1 , klev
  DO jl = kidia,kfdia
    imx1=imx(jl)
    imx2=jk
    IF (pcldlu(jl,jk).GT.repclc) THEN
      imxp(jl)=imx2
    ELSE
      imxp(jl)=imx1
    END IF
    imaxc=max(imxp(jl),imaxc)
    imx(jl)=imxp(jl)
  END DO
END DO
!CGM*******
imaxc=klev
!CGM*******
!
DO jk = 1 , klev+1
  DO jl = kidia,kfdia
    pflux(jl,1,jk) = pfup(jl,jk)
    pflux(jl,2,jk) = pfdn(jl,jk)
  END DO
END DO
!
!     ------------------------------------------------------------------
!
!*         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
!                  ---------------------------------------
!
IF (imaxc.GT.0) THEN
!
  imxp1 = imaxc + 1
  imxm1 = imaxc - 1
!
!*         2.0     INITIALIZE TO CLEAR-SKY FLUXES
!                  ------------------------------
!
  DO jk1=1,klev+1
    DO jk2=1,klev+1
      DO jl = kidia,kfdia
        zupf(jl,jk2,jk1)=pfup(jl,jk1)
        zdnf(jl,jk2,jk1)=pfdn(jl,jk1)
      END DO
    END DO
  END DO
!
!*         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
!                  ----------------------------------------------
!
  DO jkc = 1 , imaxc
    jcloud=jkc
    jkcp1=jcloud+1
!
!*         2.1.1   ABOVE THE CLOUD
!                  ---------------
!
    DO jk=jkcp1,klev+1
      jkm1=jk-1
      DO jl = kidia,kfdia
        zfu(jl)=0.
      END DO
      IF (jk .GT. jkcp1) THEN
        DO jkj=jkcp1,jkm1
          DO jl = kidia,kfdia
            zfu(jl) = zfu(jl) + pcntrb(jl,jk,jkj)
          END DO
        END DO
      END IF
!
      DO jl = kidia,kfdia
        zupf(jl,jkcp1,jk)=pbint(jl,jk)-zfu(jl)
      END DO
    END DO
!
!*         2.1.2   BELOW THE CLOUD
!                  ---------------
!
    DO jk=1,jcloud
      jkp1=jk+1
      DO jl = kidia,kfdia
        zfd(jl)=0.
      END DO
!
      IF (jk .LT. jcloud) THEN
        DO jkj=jkp1,jcloud
          DO jl = kidia,kfdia
            zfd(jl) = zfd(jl) + pcntrb(jl,jk,jkj)
          END DO
        END DO
      END IF
      DO jl = kidia,kfdia
        zdnf(jl,jkcp1,jk)=-pbint(jl,jk)-zfd(jl)
      END DO
    END DO
!
  END DO
!
!
!*         2.2     CLOUD COVER MATRIX
!                  ------------------
!
!*    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
!     HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
!
  DO jk1 = 1 , klev+1
    DO jk2 = 1 , klev+1
      DO jl = kidia,kfdia
        zclm(jl,jk1,jk2) = 0.
      END DO
    END DO
  END DO
!
!
!
!*         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
!                  ------------------------------------------
!
  DO jk1 = 2 , klev+1
    DO jl = kidia,kfdia
      zclear(jl)=1.
      zcloud(jl)=0.
    END DO
    DO jk = jk1 - 1 , 1 , -1
      DO jl = kidia,kfdia
        IF (novlp.EQ.1) THEN
!* maximum-random       
          zclear(jl)=zclear(jl)*(1.0-max(pcldlu(jl,jk),zcloud(jl))) &
          &                       /(1.0-min(zcloud(jl),1.-repclc))
          zclm(jl,jk1,jk) = 1.0 - zclear(jl)
          zcloud(jl) = pcldlu(jl,jk)
        ELSE IF (novlp.EQ.2) THEN 
!* maximum      
          zcloud(jl) = max(zcloud(jl) , pcldlu(jl,jk))
          zclm(jl,jk1,jk) = zcloud(jl)
        ELSE IF (novlp.EQ.3) THEN
!* random      
          zclear(jl) = zclear(jl)*(1.0 - pcldlu(jl,jk))
          zcloud(jl) = 1.0 - zclear(jl)
          zclm(jl,jk1,jk) = zcloud(jl)
        END IF
      END DO
    END DO
  END DO
!
!
!*         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
!                  ------------------------------------------
!
  DO jk1 = 1 , klev
    DO jl = kidia,kfdia
      zclear(jl)=1.
      zcloud(jl)=0.
    END DO
    DO jk = jk1 , klev
      DO jl = kidia,kfdia
        IF (novlp.EQ.1) THEN
!* maximum-random       
           zclear(jl)=zclear(jl)*(1.0-max(pcldld(jl,jk),zcloud(jl))) &
           &                    /(1.0-min(zcloud(jl),1.-repclc))
           zclm(jl,jk1,jk) = 1.0 - zclear(jl)
           zcloud(jl) = pcldld(jl,jk)
         ELSE IF (novlp.EQ.2) THEN 
!* maximum      
           zcloud(jl) = max(zcloud(jl) , pcldld(jl,jk))
           zclm(jl,jk1,jk) = zcloud(jl)
         ELSE IF (novlp.EQ.3) THEN
!* random      
           zclear(jl) = zclear(jl)*(1.0 - pcldld(jl,jk))
           zcloud(jl) = 1.0 - zclear(jl)
           zclm(jl,jk1,jk) = zcloud(jl)
         END IF
       END DO
     END DO
   END DO
!
!
!
!*         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
!                  ----------------------------------------------
!
!*         3.1     DOWNWARD FLUXES
!                  ---------------
!
  DO jl = kidia,kfdia
    pflux(jl,2,klev+1) = 0.
  END DO
!
  DO jk1 = klev , 1 , -1
!
!*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
!
    DO jl = kidia,kfdia
      zfd(jl) = (1. - zclm(jl,jk1,klev)) * zdnf(jl,1,jk1)
!
!*                 CONTRIBUTION FROM ADJACENT CLOUD
!
      zfd(jl) = zfd(jl) + zclm(jl,jk1,jk1) * zdnf(jl,jk1+1,jk1)
    END DO
!
!*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
!
    DO jk = klev-1 , jk1 , -1
      DO jl = kidia,kfdia
        zcfrac = zclm(jl,jk1,jk+1) - zclm(jl,jk1,jk)
        zfd(jl) =  zfd(jl) + zcfrac * zdnf(jl,jk+2,jk1)
      END DO
    END DO
!
    DO jl = kidia,kfdia
      pflux(jl,2,jk1) = zfd(jl)
    END DO
!
  END DO
!
!
!
!
!*         3.2     UPWARD FLUX AT THE SURFACE
!                  --------------------------
!
  DO jl = kidia,kfdia
    pflux(jl,1,1) = pemis(jl)*pbsuin(jl)-(1.-pemis(jl))*pflux(jl,2,1)
  END DO
!
!
!
!*         3.3     UPWARD FLUXES
!                  -------------
!
  DO jk1 = 2 , klev+1
!
!*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
!
    DO jl = kidia,kfdia
      zfu(jl) = (1. - zclm(jl,jk1,1)) * zupf(jl,1,jk1)
!
!*                 CONTRIBUTION FROM ADJACENT CLOUD
!
      zfu(jl) =  zfu(jl) + zclm(jl,jk1,jk1-1) * zupf(jl,jk1,jk1)
    END DO
!
!*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
!
    DO jk = 2 , jk1-1
      DO jl = kidia,kfdia
        zcfrac = zclm(jl,jk1,jk-1) - zclm(jl,jk1,jk)
        zfu(jl) =  zfu(jl) + zcfrac * zupf(jl,jk  ,jk1)
      END DO
    END DO
!
    DO jl = kidia,kfdia
      pflux(jl,1,jk1) = zfu(jl)
    END DO
!
  END DO
!
!
END IF
!
!
!*         2.3     END OF CLOUD EFFECT COMPUTATIONS
!
!----------------------------------------------------------------------
RETURN
END SUBROUTINE olwc