swu.F90

Go to the documentation of this file.

!OPTIONS XOPT(HSFUN)
SUBROUTINE swu &
 & ( kidia, kfdia , klon  , klev,&
 & psct , pcardi, pcldsw, ppmb , ppsol, prmu0, ptave, pwv,&
 & paki , pcld  , pclear, pdsig, pfact, prmu , psec , pud &
 & )  

!**** *SWU* - SHORTWAVE RADIATION, ABSORBER AMOUNTS

!     PURPOSE.
!     --------
!           COMPUTES THE ABSORBER AMOUNTS USED IN SHORTWAVE RADIATION
!     CALCULATIONS

!**   INTERFACE.
!     ----------
!          *SWU* IS CALLED BY *SW*

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

!     ==== INPUTS ===
!     ==== OUTPUTS ===

!     METHOD.
!     -------

!          1. COMPUTES ABSORBER AMOUNTS WITH TEMPERATURE AND PRESSURE
!     SCALING.

!     EXTERNALS.
!     ----------

!          *SWTT*

!     REFERENCE.
!     ----------

!        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
!        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)

!     AUTHOR.
!     -------
!        JEAN-JACQUES MORCRETTE  *ECMWF*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 89-07-14
!        03-03-18   JJMorcrette  security on normalized cloud cover
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        Y.Seity 06-09-09 : add modset from O.Thouron (MesoNH) under NOVLP tests

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

USE parkind1  ,ONLY : jpim     ,jprb
USE yomhook   ,ONLY : lhook,   dr_hook

USE yoecld   , ONLY : repsec
!USE YOERAD   , ONLY :   NOVLP    ,NSW
! NSW mis dans .def MPL 20140211
USE yoerad   , ONLY :   novlp    
USE yoerdu   , ONLY : repscq
USE yoesw    , ONLY : rpdh1    ,rpdu1    ,rpnh     ,rpnu     ,&
 & rtdh2o   ,rtdumg   ,rth2o    ,rtumg  
USE yoeovlp  , ONLY : ra1ovlp

IMPLICIT NONE

include "clesphys.h"
INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSCT 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCARDI 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLDSW(klon,klev) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PPMB(klon,klev+1) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PPSOL(klon) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRMU0(klon) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAVE(klon,klev) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PWV(klon,klev) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PAKI(klon,2,nsw) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PCLD(klon,klev) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCLEAR(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDSIG(klon,klev) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFACT(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PRMU(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSEC(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PUD(klon,5,klev+1) 
!     ------------------------------------------------------------------

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

INTEGER(KIND=JPIM) :: INUIR  

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

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

INTEGER(KIND=JPIM) :: IIND(2)
REAL(KIND=JPRB) :: ZC1J(klon,klev+1),ZCLEAR(klon),ZCLOUD(klon)&
 & ,  ZN175(KLON), ZN190(KLON), ZO175(KLON)&
 & ,  ZO190(KLON), ZSIGN(KLON)&
 & ,  ZR(KLON,2) , ZSIGO(KLON), ZUD(KLON,2)  

INTEGER(KIND=JPIM) :: JA, JK, JKL, JKLP1, JKP1, JL, JNU

REAL(KIND=JPRB) :: ZDSCO2, ZDSH2O, ZFPPW, ZRTH, ZRTU, ZWH2O, ZALPHA1
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "swtt1.intfb.h"

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

!*         1.     COMPUTES AMOUNTS OF ABSORBERS
!                 -----------------------------

repsec=1.e-12_jprb   !!!!! A REVOIR (MPL)
IF (lhook) CALL dr_hook('SWU',0,zhook_handle)
iind(1)=1
iind(2)=2

!*         1.1    INITIALIZES QUANTITIES
!                 ----------------------

DO jl = kidia,kfdia
  pud(jl,1,klev+1)=0.0_jprb
  pud(jl,2,klev+1)=0.0_jprb
  pud(jl,3,klev+1)=0.0_jprb
  pud(jl,4,klev+1)=0.0_jprb
  pud(jl,5,klev+1)=0.0_jprb
  pfact(jl)= prmu0(jl) * psct
!- already accounted for in RADINT      
!      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
  prmu(jl)=prmu0(jl)
  psec(jl)=1.0_jprb/prmu(jl)
  zc1j(jl,klev+1)=0.0_jprb
ENDDO

!*          1.3    AMOUNTS OF ABSORBERS
!                  --------------------

DO jl= kidia,kfdia
  zud(jl,1) = 0.0_jprb
  zud(jl,2) = 0.0_jprb
  zo175(jl) = ppsol(jl)** rpdu1
  zo190(jl) = ppsol(jl)** rpdh1
  zsigo(jl) = ppsol(jl)
  zclear(jl)=1.0_jprb
  zcloud(jl)=0.0_jprb
ENDDO

DO jk = 1 , klev
  jkp1 = jk + 1
  jkl = klev+1 - jk
  jklp1 = jkl+1
  zalpha1=ra1ovlp(klev+1-jk)
  
  DO jl = kidia,kfdia
    zrth=(rth2o/ptave(jl,jk))**rtdh2o
    zrtu=(rtumg/ptave(jl,jk))**rtdumg
    zwh2o = max(pwv(jl,jkl) , repscq )

    zsign(jl) = 100._jprb * ppmb(jl,jkp1)
    pdsig(jl,jk) = (zsigo(jl) - zsign(jl))/ppsol(jl)
    zn175(jl) = zsign(jl) ** rpdu1
    zn190(jl) = zsign(jl) ** rpdh1
    zdsco2 = zo175(jl) - zn175(jl)
    zdsh2o = zo190(jl) - zn190(jl)
    pud(jl,1,jk) = rpnh * zdsh2o * zwh2o  * zrth
    pud(jl,2,jk) = rpnu * zdsco2 * pcardi * zrtu
    
    zfppw=1.6078_jprb*zwh2o/(1.0_jprb+0.608_jprb*zwh2o)
    pud(jl,4,jk)=pud(jl,1,jk)*zfppw
    pud(jl,5,jk)=pud(jl,1,jk)*(1.0_jprb-zfppw)
    zud(jl,1) = zud(jl,1) + pud(jl,1,jk)
    zud(jl,2) = zud(jl,2) + pud(jl,2,jk)
    zsigo(jl) = zsign(jl)
    zo175(jl) = zn175(jl)
    zo190(jl) = zn190(jl)
!print *,'SWU: RTH2O RTDH2O RTUMG RTDUMG',RTH2O,RTDH2O,RTUMG,RTDUMG
!print *,'SWU: RPNH ZDSH2O ZWH2O ZRTH',RPNH,ZDSH2O,ZWH2O,ZRTH
!print *,'SWU: RPNU ZDSCO2 PCARDI ZRTU',RPNU,ZDSCO2,PCARDI,ZRTU

!++MODIFCODE
    IF ((novlp == 1).OR.(novlp==6).OR.(novlp==8)) THEN
      zclear(jl)=zclear(jl)&
       & *(1.0_jprb-max(pcldsw(jl,jkl),zcloud(jl)))&
       & /(1.0_jprb-min(zcloud(jl),1.0_jprb-repsec))  
      zc1j(jl,jkl)= 1.0_jprb - zclear(jl)
      zcloud(jl) = pcldsw(jl,jkl)
    ELSEIF ((novlp == 2).OR.(novlp==7)) THEN
      zcloud(jl) = max(pcldsw(jl,jkl),zcloud(jl))
      zc1j(jl,jkl) = zcloud(jl)
    ELSEIF ((novlp == 3).OR.(novlp==5)) THEN
      zclear(jl) = zclear(jl)*(1.0_jprb-pcldsw(jl,jkl))
      zcloud(jl) = 1.0_jprb - zclear(jl)
      zc1j(jl,jkl) = zcloud(jl)
    ELSEIF (novlp == 4) THEN
!** Hogan & Illingworth (2001)      
      zclear(jl)=zclear(jl)*( &
       & zalpha1*(1.0_jprb-max(pcldsw(jl,jkl),zcloud(jl))) &
       & /(1.0_jprb-min(zcloud(jl),1.0_jprb-repsec)) &
       & +(1.0_jprb-zalpha1)*(1.0_jprb-pcldsw(jl,jkl)) )  
      zc1j(jl,jkl) = 1.0_jprb - zclear(jl) 
      zcloud(jl) = pcldsw(jl,jkl)
    ENDIF
!--MODIFCODE
  ENDDO
ENDDO

DO jl=kidia,kfdia
  pclear(jl)=1.0_jprb-zc1j(jl,1)
ENDDO
DO jk=1,klev
  DO jl=kidia,kfdia
    IF (pclear(jl) < 1.0_jprb) THEN
      pcld(jl,jk)=pcldsw(jl,jk)/(1.0_jprb-pclear(jl))
    ELSE
      pcld(jl,jk)=0.0_jprb
    ENDIF
    pcld(jl,jk)=max(0.0_jprb,min(1.0_jprb,pcld(jl,jk)))
  ENDDO
ENDDO

!*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
!                 -----------------------------------------------

DO ja = 1,2
  DO jl = kidia,kfdia
    zud(jl,ja) = zud(jl,ja) * psec(jl)
  ENDDO
ENDDO

IF (nsw <= 4) THEN
  inuir=2
ELSEIF (nsw == 6) THEN
  inuir=4
ENDIF     

DO jnu= inuir,nsw

  CALL swtt1 ( kidia,kfdia,klon, jnu, 2, iind,&
   & zud,&
   & zr                            )  

  DO ja = 1,2
    DO jl = kidia,kfdia
      paki(jl,ja,jnu) = -log( zr(jl,ja) ) / zud(jl,ja)
    ENDDO
  ENDDO
ENDDO

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

IF (lhook) CALL dr_hook('SWU',1,zhook_handle)
END SUBROUTINE swu