source: LMDZ5/trunk/libf/phylmd/rrtm/swde.F90 @ 5308

!OPTIONS XOPT(HSFUN)
SUBROUTINE SWDE &
 & ( KIDIA, KFDIA, KLON,&
 & PGG  , PREF , PRMUZ, PTO1, PW,&
 & PRE1 , PRE2 , PTR1 , PTR2 &
 & )  

!**** *SWDE* - DELTA-EDDINGTON IN A CLOUDY LAYER

!     PURPOSE.
!     --------
!           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
!     LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.

!**   INTERFACE.
!     ----------
!          *SWDE* IS CALLED BY *SWR*, *SWNI*

!        EXPLICIT ARGUMENTS :
!        --------------------
! PGG    : (KLON)             ; ASSYMETRY FACTOR
! PREF   : (KLON)             ; REFLECTIVITY OF THE UNDERLYING LAYER
! PRMUZ  : (KLON)             ; COSINE OF SOLAR ZENITH ANGLE
! PTO1   : (KLON)             ; OPTICAL THICKNESS
! PW     : (KLON)             ; SINGLE SCATTERING ALBEDO
!     ==== OUTPUTS ===
! PRE1   : (KLON)             ; LAYER REFLECTIVITY ASSUMING NO
!                             ; REFLECTION FROM UNDERLYING LAYER
! PTR1   : (KLON)             ; LAYER TRANSMISSIVITY ASSUMING NO
!                             ; REFLECTION FROM UNDERLYING LAYER
! PRE2   : (KLON)             ; LAYER REFLECTIVITY ASSUMING
!                             ; REFLECTION FROM UNDERLYING LAYER
! PTR2   : (KLON)             ; LAYER TRANSMISSIVITY ASSUMING
!                             ; REFLECTION FROM UNDERLYING LAYER

!        IMPLICIT ARGUMENTS :   NONE
!        --------------------

!     METHOD.
!     -------

!          STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.

!     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: 88-12-15
!                   96-05-30 Michel Deque (security in EXP())
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        Modified: 03-10-10 Deborah Salmond and Marta Janiskova Optimisation
!        Modified: 03-12-13 John Hague - MASS Vector Fns
!        Y.Seity 06-09-09 : add modset from O.Thouron (MesoNH) under NOVLP tests
!     ------------------------------------------------------------------

!     ------------------------------------------------------------------

!*       0.1   ARGUMENTS
!              ---------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOERDU   , ONLY : REPLOG
USE YOMJFH   , ONLY : N_VMASS
!++MODIFCODE
USE YOERAD   , ONLY : NOVLP 
!--MODIFCODE
IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PGG(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PREF(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRMUZ(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTO1(KLON) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PW(KLON) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PRE1(KLON) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PRE2(KLON) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTR1(KLON) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTR2(KLON) 
REAL(KIND=JPRB) :: ZTMP   (4,KFDIA-KIDIA+1)
REAL(KIND=JPRB) :: ZTMP2  (KFDIA-KIDIA+1+N_VMASS)
REAL(KIND=JPRB) :: ZTMP3  (KFDIA-KIDIA+1+N_VMASS)
REAL(KIND=JPRB) :: ZZARG  (KFDIA-KIDIA+1+N_VMASS)
REAL(KIND=JPRB) :: ZZARG2 (KFDIA-KIDIA+1+N_VMASS)

INTEGER(KIND=JPIM) :: JL, JLL, JLEN

REAL(KIND=JPRB) :: ZA11, ZA12, ZA13, ZA21, ZA22, ZA23, ZALPHA,&
 & ZAM2B, ZAP2B,  ZB21, ZB22, ZB23, &
 & ZBETA, ZC1A, ZC1B, ZC2A, ZC2B, ZDENA, ZDENB, &
 & ZDT, ZEXKM, ZEXKP, ZEXMU0, ZFF, ZGP, ZRI0A, &
 & ZRI0B, ZRI0C, ZRI0D, ZRI1A, ZRI1B, ZRI1C, &
 & ZRI1D, ZRK, ZRM2, ZRP, ZTOP, ZWCP, ZWM, ZX1, &
 & ZX2, ZXM2P, ZXP2P  


REAL(KIND=JPRB) :: MINJ, MAXJ, X, Y
REAL(KIND=JPRB) :: ZPRMUZ,ZIDENA,ZIDENB,ZRR
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!     STATEMENT DUNCTIONS
MINJ(X,Y) = Y - 0.5_JPRB*(ABS(X-Y)-(X-Y))
MAXJ(X,Y) = Y + 0.5_JPRB*(ABS(X-Y)+(X-Y))

!     ------------------------------------------------------------------

!*         1.      DELTA-EDDINGTON CALCULATIONS

IF (LHOOK) CALL DR_HOOK('SWDE',0,ZHOOK_HANDLE)

ZDT = 2.0_JPRB/3._JPRB

  DO JL   =   KIDIA,KFDIA
    JLL=JL-KIDIA+1
    ZPRMUZ=1.0_JPRB/PRMUZ(JL)
!++MODIFCODE
  IF (NOVLP >= 5) THEN !MESONH_VERSION
   ZGP = PGG(JL)
   ZTOP = PTO1(JL)
   ZWCP = PW(JL)  
  ELSE !ECMWF VERSION
    ZFF = PGG(JL)*PGG(JL)
    ZGP = PGG(JL)/(1.0_JPRB+PGG(JL))
    ZTOP = (1.0_JPRB- PW(JL) * ZFF) * PTO1(JL)
    ZWCP = (1-ZFF)* PW(JL) /(1.0_JPRB- PW(JL) * ZFF)
  ENDIF
!--MODIFCODE
    ZX1 = 1.0_JPRB-ZWCP*ZGP
    ZWM = 1.0_JPRB-ZWCP
    ZRM2 =  PRMUZ(JL) * PRMUZ(JL)
    ZRK = SQRT(MAXJ(REPLOG,3._JPRB*ZWM*ZX1))
    ZX2 = (1.0_JPRB-ZRK*ZRK*ZRM2)*(4._JPRB/3._JPRB)
    ZRR = 1.0_JPRB/ZX2
    ZRP=ZRK/ZX1
    ZALPHA = ZWCP*ZRM2*(1.0_JPRB+ZGP*ZWM)*ZRR 
    ZBETA = ZWCP* PRMUZ(JL) *(1.0_JPRB+3._JPRB*ZGP*ZRM2*ZWM)*ZRR 
    ZZARG(JLL)   = -MAXJ( -200._JPRB, MINJ( ZTOP*ZPRMUZ, 200._JPRB) )
    ZZARG2(JLL)  = MINJ( ZRK*ZTOP, 200._JPRB)
    ZTMP(1,JLL) = ZPRMUZ
    ZTMP(2,JLL) = ZALPHA
    ZTMP(3,JLL) = ZBETA
    ZTMP(4,JLL) = ZRP
  ENDDO

  IF(N_VMASS /= 0 ) THEN  !USING VECTOR MASS
    JLEN=KFDIA-KIDIA+N_VMASS-MOD(KFDIA-KIDIA,N_VMASS)
    IF(KFDIA-KIDIA+1 /= JLEN) THEN
      ZZARG  (KFDIA-KIDIA+2:JLEN)=1.0_JPRB
      ZZARG2 (KFDIA-KIDIA+2:JLEN)=1.0_JPRB
    ENDIF
! Commente par MPL le 21.11.08
!   CALL VEXP(ZTMP2,ZZARG, JLEN)
!   CALL VEXP(ZTMP3,ZZARG2,JLEN)
  ELSE
    DO JL   =   KIDIA,KFDIA
      JLL=JL-KIDIA+1
      ZTMP2(JLL) = EXP(ZZARG(JLL))
      ZTMP3(JLL) = EXP(ZZARG2(JLL))
    ENDDO
  ENDIF

  DO JL   =   KIDIA,KFDIA
    JLL=JL-KIDIA+1
    ZEXMU0 = ZTMP2(JLL)
    ZEXKP  = ZTMP3(JLL)
    ZPRMUZ = ZTMP(1,JLL)
    ZALPHA = ZTMP(2,JLL)
    ZBETA  = ZTMP(3,JLL)
    ZRP    = ZTMP(4,JLL)
    ZEXKM = 1.0_JPRB/ZEXKP
    ZXP2P = 1.0_JPRB+ZDT*ZRP
    ZXM2P = 1.0_JPRB-ZDT*ZRP
    ZAP2B = ZALPHA+ZDT*ZBETA
    ZAM2B = ZALPHA-ZDT*ZBETA

!*         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER

    ZA11 = ZXP2P
    ZA12 = ZXM2P
    ZA13 = ZAP2B
    ZA22 = ZXP2P*ZEXKP
    ZA21 = ZXM2P*ZEXKM
    ZA23 = ZAM2B*ZEXMU0
    ZDENA = ZA11 * ZA22 - ZA21 * ZA12
    ZIDENA=1.0_JPRB/ZDENA
    ZC1A = (ZA22*ZA13-ZA12*ZA23)*ZIDENA
    ZC2A = (ZA11*ZA23-ZA21*ZA13)*ZIDENA
    ZRI0A = ZC1A+ZC2A-ZALPHA
    ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
    PRE1(JL) = (ZRI0A-ZDT*ZRI1A)*ZPRMUZ
    ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
    ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
    PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)*ZPRMUZ

!*         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER

    ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
    ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
    ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
    ZDENB = ZA11 * ZB22 - ZB21 * ZA12
    ZIDENB= 1.0_JPRB/ZDENB
    ZC1B = (ZB22*ZA13-ZA12*ZB23)*ZIDENB
    ZC2B = (ZA11*ZB23-ZB21*ZA13)*ZIDENB
    ZRI0C = ZC1B+ZC2B-ZALPHA
    ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
    PRE2(JL) = (ZRI0C-ZDT*ZRI1C) * ZPRMUZ
    ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
    ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
    PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) * ZPRMUZ
  ENDDO

IF (LHOOK) CALL DR_HOOK('SWDE',1,ZHOOK_HANDLE)
END SUBROUTINE SWDE