sw.F90

Go to the documentation of this file.

SUBROUTINE sw &
 & ( kidia, kfdia , klon  , klev , kaer,&
 & psct , pcardi, ppsol , palbd, palbp , pwv, pqs,&
 & prmu0, pcg   , pcldsw, pdp  , pomega, poz, ppmb,&
 & ptau , ptave , paer,&
 & pfdown, pfup,&
 & pcdown, pcup,&
 & pfdnn, pfdnv , pfupn, pfupv,&
 & pcdnn, pcdnv , pcupn, pcupv,&
 & psudu, puvdf , pparf, pparcf, pdiffs , pdirfs, &
 & lrdust, ppiza_dst,pcga_dst,ptaurel_dst &
 & )


!**** *SW* - COMPUTES THE SHORTWAVE RADIATION FLUXES.

!     PURPOSE.
!     --------

!          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
!     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).

!**   INTERFACE.
!     ----------

!          *SW* IS CALLED FROM *RADLSW*

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

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

!     METHOD.
!     -------

!          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
!          2. COMPUTES FLUXES IN U.V./VISIBLE  SPECTRAL INTERVAL (SW1S)
!          3. COMPUTES FLUXES IN NEAR-INFRARED SPECTRAL INTERVAL (SWNI)

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

!          *SWU*, *SW1S*, *SWNI*

!     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
!        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
!        95-12-07   J.-J. MORCRETTE  Near-Infrared in nsw-1 Intervals
!        990128     JJMorcrette      sunshine duration
!        99-05-25   JJMorcrette      Revised aerosols
!        00-12-18   JJMorcrette      6 spectral intervals
!        02-09-01   JJMorcrette      UV and PAR
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        Y.Seity  04-11-18 : add two arguments for AROME extern. surface
!        Y.Seity  05-10-10 : add add 3 optional arg. for dust SW properties
!        JJMorcrette 20060721 PP of clear-sky PAR
!     ------------------------------------------------------------------

USE parkind1  ,ONLY : jpim     ,jprb
USE yomhook   ,ONLY : lhook,   dr_hook
!USE YOERAD   , ONLY : NSW
! NSW mis dans .def MPL 20140211
USE write_field_phy

IMPLICIT NONE

include "clesphys.h"

integer, save :: icount=0
!$OMP THREADPRIVATE(icount)
INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KAER 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSCT 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCARDI 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PPSOL(klon) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBD(klon,nsw) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBP(klon,nsw) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PWV(klon,klev) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQS(klon,klev) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PRMU0(klon) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCG(klon,nsw,klev) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLDSW(klon,klev) 
REAL(KIND=JPRB)                  :: PDP(klon,klev) ! Argument NOT used
REAL(KIND=JPRB)   ,INTENT(IN)    :: POMEGA(klon,nsw,klev) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: POZ(klon,klev) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PPMB(klon,klev+1) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAU(klon,nsw,klev) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAVE(klon,klev) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAER(klon,6,klev) 
!++MODIFCODE
LOGICAL           ,INTENT(IN)    :: LRDUST
REAL(KIND=JPRB)   ,INTENT(IN)    :: PPIZA_DST(klon,klev,nsw)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCGA_DST(klon,klev,nsw)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUREL_DST(klon,klev,nsw)
!--MODIFCODE
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFDOWN(klon,klev+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFUP(klon,klev+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCDOWN(klon,klev+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCUP(klon,klev+1) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFDNN(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFDNV(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFUPN(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFUPV(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCDNN(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCDNV(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCUPN(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCUPV(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSUDU(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PUVDF(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PPARF(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PPARCF(klon) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDIFFS(klon,nsw) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDIRFS(klon,nsw) 
!     ------------------------------------------------------------------

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

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

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

REAL(KIND=JPRB) :: ZAKI(klon,2,nsw)&
 & ,  ZCLD(KLON,KLEV)    , ZCLEAR(KLON) &
 & ,  ZDSIG(KLON,KLEV)   , ZFACT(KLON)&
 & ,  ZFD(KLON,KLEV+1)   , ZCD(KLON,KLEV+1)&
 & ,  ZCDOWN(KLON,KLEV+1), ZCDNIR(KLON,KLEV+1), ZCDUVS(KLON,KLEV+1)&
 & ,  ZFDOWN(KLON,KLEV+1), ZFDNIR(KLON,KLEV+1), ZFDUVS(KLON,KLEV+1)&
 & ,  ZFU(KLON,KLEV+1)   , ZCU(KLON,KLEV+1)&
 & ,  ZCUP(KLON,KLEV+1)  , ZCUNIR(KLON,KLEV+1), ZCUUVS(KLON,KLEV+1)&
 & ,  ZFUP(KLON,KLEV+1)  , ZFUNIR(KLON,KLEV+1), ZFUUVS(KLON,KLEV+1)&
 & ,  ZRMU(KLON)         , ZSEC(KLON)         &
 & ,  ZSUDU1(KLON)       , ZSUDU2(KLON)       &
 & ,  ZSUDU1T(KLON)      , ZSUDU2T(KLON)      &
 & ,  ZUD(KLON,5,KLEV+1) ,ZDIFF(KLON,KLEV)   ,ZDIRF(KLON,KLEV)    &
 & ,  ZDIFF2(KLON,KLEV)  , ZDIRF2(KLON,KLEV)

INTEGER(KIND=JPIM) ::  JK, JL, JNU, INUVS, INUIR

REAL(KIND=JPRB) :: ZHOOK_HANDLE
LOGICAL         :: LLDEBUG
character*1 str1

#include "sw1s.intfb.h"
#include "swni.intfb.h"
#include "swu.intfb.h"

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

!*         1.     ABSORBER AMOUNTS AND OTHER USEFUL QUANTITIES
!                 --------------------------------------------

IF (lhook) CALL dr_hook('SW',0,zhook_handle)
lldebug=.false.
CALL swu ( kidia,kfdia ,klon  ,klev,&
 & psct ,pcardi,pcldsw,ppmb ,ppsol,&
 & prmu0,ptave ,pwv,&
 & zaki ,zcld  ,zclear,zdsig,zfact,zrmu,zsec,zud )  

!     ------------------------------------------------------------------
!*         2.     INTERVAL (0.185/0.25-0.68 MICRON): U.V. AND VISIBLE
!                 ---------------------------------------------------
IF (nsw <= 4) THEN
  inuvs=1
  inuir=2
ELSEIF (nsw == 6) THEN
  inuvs=1
  inuir=4
ENDIF     

DO jk = 1 , klev+1
  DO jl = kidia,kfdia
    zfd(jl,jk) =0.0_jprb
    zfu(jl,jk) =0.0_jprb
    zcd(jl,jk) =0.0_jprb
    zcu(jl,jk) =0.0_jprb
  ENDDO
ENDDO
DO jl = kidia,kfdia
  zsudu1t(jl)=0.0_jprb
  puvdf(jl)  =0.0_jprb
  pparf(jl)  =0.0_jprb
  pparcf(jl) =0.0_jprb
ENDDO

IF(lldebug) THEN
call writefield_phy('sw_zsec',zsec,1)
call writefield_phy('sw_zrmu',zrmu,1)
call writefield_phy('sw_prmu0',prmu0,1)
call writefield_phy('sw_zfact',zfact,1)
ENDIF

icount=icount+1
DO jnu = inuvs , inuir-1
   !++MODIFCODE
     CALL sw1s &
           &( kidia , kfdia, klon , klev , kaer  , jnu &
           &,  paer , palbd , palbp, pcg  , zcld , zclear &
           &,  zdsig, pomega, poz  , zrmu , zsec , ptau  , zud  &
           &,  zfduvs,zfuuvs, zcduvs,zcuuvs, zsudu1, zdiff,zdirf &
           &,  lrdust,ppiza_dst(:,:,jnu) &       ! SSA for this wavelength
           &,  pcga_dst(:,:,jnu)   &            ! GCA for this wavelengt
           &,  ptaurel_dst(:,:,jnu) )           ! TAUREL for this wavelength
  !--MODIFCODE
IF(lldebug) THEN
! Ecriture des champs avec un indicage du fichier par l'intervalle spectral
  write(str1,'(i1)') jnu
  call writefield_phy("sw_zcduvs"//str1,zcduvs,klev+1)
ENDIF


  DO jl=kidia,kfdia
  pdiffs(jl,jnu)=zdiff(jl,1)*zfact(jl)
  pdirfs(jl,jnu)=zdirf(jl,1)*zfact(jl)
  ENDDO
  DO jk = 1 , klev+1
    DO jl = kidia,kfdia
      zfd(jl,jk)=zfd(jl,jk)+zfduvs(jl,jk)
      zfu(jl,jk)=zfu(jl,jk)+zfuuvs(jl,jk)
      zcd(jl,jk)=zcd(jl,jk)+zcduvs(jl,jk)
      zcu(jl,jk)=zcu(jl,jk)+zcuuvs(jl,jk)
    ENDDO
  ENDDO
  DO jl = kidia,kfdia
    zsudu1t(jl)=zsudu1t(jl)+zsudu1(jl)
  ENDDO

  IF (nsw == 6) THEN
    IF (jnu <= 2) THEN
      DO jl = kidia,kfdia
        puvdf(jl)=puvdf(jl)+zfduvs(jl,1)
      ENDDO
    ELSEIF (jnu == 3) THEN
      DO jl=kidia,kfdia
        pparf(jl)=pparf(jl)+zfduvs(jl,1)
        pparcf(jl)=pparcf(jl)+zcduvs(jl,1)
      ENDDO
    ENDIF    
  ENDIF  
ENDDO

!if (icount==5) stop'on arrete dans sw.F90 au bout de 5 appels'
!     ------------------------------------------------------------------

!*         3.     INTERVAL (0.68-4.00 MICRON): NEAR-INFRARED
!                 ------------------------------------------

DO jk = 1 , klev+1
  DO jl = kidia,kfdia
    zfdown(jl,jk)=0.0_jprb
    zfup(jl,jk)=0.0_jprb
    zcdown(jl,jk)=0.0_jprb
    zcup(jl,jk)=0.0_jprb
    zsudu2t(jl)  =0.0_jprb
  ENDDO
ENDDO

DO jnu = inuir , nsw
   !++MODIFCODE
      CALL swni &
           &(  kidia ,kfdia , klon , klev , kaer , jnu &
           &,  paer  ,zaki  , palbd, palbp, pcg  , zcld, zclear &
           &,  zdsig ,pomega, poz  , zrmu , zsec , ptau, zud      &
           &,  pwv   ,pqs &
           &,  zfdnir,zfunir,zcdnir,zcunir,zsudu2,zdiff2,zdirf2 &
           &,  lrdust,ppiza_dst(:,:,jnu)  &
           &,  pcga_dst(:,:,jnu)    &
           &,  ptaurel_dst(:,:,jnu) &
           &)
    !--MODIFCODE

IF(lldebug) THEN
! Ecriture des champs avec un indicage du fichier par l'intervalle spectral
  write(str1,'(i1)') jnu
  call writefield_phy("sw_zcdnir"//str1,zcdnir,klev+1)
ENDIF

  DO jl=kidia,kfdia
    pdiffs(jl,jnu)=zdiff2(jl,1)*zfact(jl)
    pdirfs(jl,jnu)=zdirf2(jl,1)*zfact(jl)
  ENDDO
  DO jk = 1 , klev+1
    DO jl = kidia,kfdia
      zfdown(jl,jk)=zfdown(jl,jk)+zfdnir(jl,jk)
      zfup(jl,jk)=zfup(jl,jk)+zfunir(jl,jk)
      zcdown(jl,jk)=zcdown(jl,jk)+zcdnir(jl,jk)
      zcup(jl,jk)=zcup(jl,jk)+zcunir(jl,jk)
    ENDDO
  ENDDO
  DO jl = kidia,kfdia
    zsudu2t(jl)=zsudu2t(jl)+zsudu2(jl)
  ENDDO
ENDDO

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

!*         4.     FILL THE DIAGNOSTIC ARRAYS
!                 --------------------------

DO jl = kidia,kfdia
  pfdnn(jl)=zfdown(jl,1)*zfact(jl)
  pfdnv(jl)=zfd(jl,1)*zfact(jl)
  pfupn(jl)=zfup(jl,klev+1)*zfact(jl)
  pfupv(jl)=zfu(jl,klev+1)*zfact(jl)

  pcdnn(jl)=zcdown(jl,1)*zfact(jl)
  pcdnv(jl)=zcd(jl,1)*zfact(jl)
  pcupn(jl)=zcup(jl,klev+1)*zfact(jl)
  pcupv(jl)=zcu(jl,klev+1)*zfact(jl)

  psudu(jl)=(zsudu1t(jl)+zsudu2t(jl))*zfact(jl)
  puvdf(jl)=puvdf(jl)*zfact(jl)
  pparf(jl)=pparf(jl)*zfact(jl)
  pparcf(jl)=pparcf(jl)*zfact(jl)
ENDDO

!WRITE(*,'("---> Dans SW:")')
!WRITE(*,'("ZFUP  ",10E12.5)') (ZFUP(1,JK),JK=1,KLEV+1)
!WRITE(*,'("ZFU   ",10E12.5)') (ZFU(1,JK),JK=1,KLEV+1)
!WRITE(*,'("ZFUNIR",10E12.5)') (ZFUNIR(1,JK),JK=1,KLEV+1)
!WRITE(*,'("ZFACT ",E12.5)') ZFACT(1)

DO jk = 1 , klev+1
  DO jl = kidia,kfdia
    pfup(jl,jk)   = (zfup(jl,jk)   + zfu(jl,jk)) * zfact(jl)
    pfdown(jl,jk) = (zfdown(jl,jk) + zfd(jl,jk)) * zfact(jl)
    pcup(jl,jk)   = (zcup(jl,jk)   + zcu(jl,jk)) * zfact(jl)
    pcdown(jl,jk) = (zcdown(jl,jk) + zcd(jl,jk)) * zfact(jl)
  ENDDO
ENDDO
IF(lldebug) THEN
call writefield_phy('sw_pcdown',pcdown,klev+1)
ENDIF

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

IF (lhook) CALL dr_hook('SW',1,zhook_handle)
END SUBROUTINE sw