swclr.F90

Go to the documentation of this file.

SUBROUTINE swclr &
  &( kidia , kfdia , klon  , klev  , kaer  , knu &
  &, paer  , palbp , pdsig , prayl , psec &
  &, pcgaz , ppizaz, pray1 , pray2 , prefz , prj  &
  &, prk   , prmu0 , ptauaz, ptra1 , ptra2 , ptrclr &
  &)

!**** *SWCLR* - CLEAR-SKY COLUMN COMPUTATIONS

!     PURPOSE.
!     --------
!           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
!     CLEAR-SKY COLUMN

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

!          *SWCLR* IS CALLED EITHER FROM *SW1S*
!                                OR FROM *SWNI*

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

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

!     METHOD.
!     -------


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

!          NONE

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

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

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

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 94-11-15
!        Modified : 96-03-19 JJM-PhD (loop 107 in absence of aerosols)
!        JJMorcrette 990128 : sunshine duration
!        JJMorcrette 990128 : sunshine duration
!        99-05-25   JJMorcrette    Revised aerosols
!        JJMorcrette 001218 : 6 spectral intervals
   
!     ------------------------------------------------------------------


#include "tsmbkind.h"

USE yoesw    , ONLY : rtaua    ,rpiza    ,rcga
USE yoerad   , ONLY : novlp    ,nsw
USE yoerdi   , ONLY : repclc
USE yoerdu   , ONLY : repsct


IMPLICIT NONE


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



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

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

real_b :: paer(klon,6,klev), palbp(klon,nsw)&
  &,  pdsig(klon,klev)&
  &,  prayl(klon)&
  &,  psec(klon)

real_b ::&
     &pcgaz(klon,klev)     &
  &,  ppizaz(klon,klev)&
  &,  pray1(klon,klev+1)  , pray2(klon,klev+1)&
  &,  prefz(klon,2,klev+1), prj(klon,6,klev+1)&
  &,  prk(klon,6,klev+1)  , prmu0(klon,klev+1)&
  &,  ptauaz(klon,klev)&
  &,  ptra1(klon,klev+1)  , ptra2(klon,klev+1)&
  &,  ptrclr(klon)

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

!*       0.2   LOCAL ARRAYS
!              ------------

real_b :: zc0i(klon,klev+1)&
  &,  zcle0(klon,klev), zclear(klon) &
  &,  zr21(klon)&
  &,  zr23(klon) , zss0(klon) , zscat(klon)&
  &,  ztr(klon,2,klev+1)

!     LOCAL INTEGER SCALARS
integer_m :: ikl, ja, jae, jaj, jk, jkl, jklp1, jkm1, jl, inu1

!     LOCAL REAL SCALARS
real_b :: zbmu0, zbmu1, zcorae, zden, zden1, zfacoa,&
          &zff, zgap, zgar, zmu1, zmue, zratio, zre11, &
          &zto, ztray, zww


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

!*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
!                --------------------------------------------


DO jk = 1 , klev+1
  DO ja = 1 , 6
    DO jl = kidia,kfdia
      prj(jl,ja,jk) = _zero_
      prk(jl,ja,jk) = _zero_
    ENDDO
  ENDDO
ENDDO

! ------   NB: 'PAER' AEROSOLS ARE ENTERED FROM TOP TO BOTTOM

DO jk = 1 , klev
  ikl=klev+1-jk
  DO jl = kidia,kfdia
    pcgaz(jl,jk) = _zero_
    ppizaz(jl,jk) =  _zero_
    ptauaz(jl,jk) = _zero_
  ENDDO
  DO jae=1,6
    DO jl = kidia,kfdia
      ptauaz(jl,jk)=ptauaz(jl,jk)+paer(jl, jae, ikl)*rtaua(knu,jae)
      ppizaz(jl,jk)=ppizaz(jl,jk)+paer(jl, jae, ikl)&
       &* rtaua(knu,jae)*rpiza(knu,jae)
      pcgaz(jl,jk) =  pcgaz(jl,jk) +paer(jl, jae, ikl)&
       &* rtaua(knu,jae)*rpiza(knu,jae)*rcga(knu,jae)
    ENDDO
  ENDDO

  DO jl = kidia,kfdia
    IF (kaer /= 0) THEN
      pcgaz(jl,jk)=pcgaz(jl,jk)/ppizaz(jl,jk)
      ppizaz(jl,jk)=ppizaz(jl,jk)/ptauaz(jl,jk)
      ztray = prayl(jl) * pdsig(jl,jk)
      zratio = ztray / (ztray + ptauaz(jl,jk))
      zgar = pcgaz(jl,jk)
      zff = zgar * zgar
      ptauaz(jl,jk)=ztray+ptauaz(jl,jk)*(_one_-ppizaz(jl,jk)*zff)
      pcgaz(jl,jk) = zgar * (_one_ - zratio) / (_one_ + zgar)
      ppizaz(jl,jk) =zratio+(_one_-zratio)*ppizaz(jl,jk)*(_one_-zff)&
       &/ (_one_ - ppizaz(jl,jk) * zff)
    ELSE
      ztray = prayl(jl) * pdsig(jl,jk)
      ptauaz(jl,jk) = ztray
      pcgaz(jl,jk) = _zero_
      ppizaz(jl,jk) = _one_-repsct
    ENDIF
  ENDDO
ENDDO

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

!*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
!                ----------------------------------------------


DO jl = kidia,kfdia
  zr23(jl) = _zero_
  zc0i(jl,klev+1) = _zero_
  zclear(jl) = _one_
  zscat(jl) = _zero_
ENDDO

jk = 1
jkl = klev+1 - jk
jklp1 = jkl + 1
DO jl = kidia,kfdia
  zfacoa = _one_ - ppizaz(jl,jkl)*pcgaz(jl,jkl)*pcgaz(jl,jkl)
  zcorae = zfacoa * ptauaz(jl,jkl) * psec(jl)
  zr21(jl) = exp(-zcorae   )
  zss0(jl) = _one_-zr21(jl)
  zcle0(jl,jkl) = zss0(jl)

  IF (novlp == 1 .OR. novlp == 4) THEN
!* maximum-random      
    zclear(jl) = zclear(jl)&
     &*(_one_-max(zss0(jl),zscat(jl)))&
     &/(_one_-min(zscat(jl),_one_-repclc))
    zc0i(jl,jkl) = _one_ - zclear(jl)
    zscat(jl) = zss0(jl)
  ELSEIF (novlp == 2) THEN
!* maximum
    zscat(jl) = max( zss0(jl) , zscat(jl) )
    zc0i(jl,jkl) = zscat(jl)
  ELSEIF (novlp == 3) THEN
!* random
    zclear(jl)=zclear(jl)*(_one_-zss0(jl))
    zscat(jl) = _one_ - zclear(jl)
    zc0i(jl,jkl) = zscat(jl)
  ENDIF
ENDDO

DO jk = 2 , klev
  jkl = klev+1 - jk
  jklp1 = jkl + 1
  DO jl = kidia,kfdia
    zfacoa = _one_ - ppizaz(jl,jkl)*pcgaz(jl,jkl)*pcgaz(jl,jkl)
    zcorae = zfacoa * ptauaz(jl,jkl) * psec(jl)
    zr21(jl) = exp(-zcorae   )
    zss0(jl) = _one_-zr21(jl)
    zcle0(jl,jkl) = zss0(jl)

    IF (novlp == 1 .OR. novlp == 4) THEN
!* maximum-random      
      zclear(jl) = zclear(jl)&
       &*(_one_-max(zss0(jl),zscat(jl)))&
       &/(_one_-min(zscat(jl),_one_-repclc))
      zc0i(jl,jkl) = _one_ - zclear(jl)
      zscat(jl) = zss0(jl)
    ELSEIF (novlp == 2) THEN
!* maximum
      zscat(jl) = max( zss0(jl) , zscat(jl) )
      zc0i(jl,jkl) = zscat(jl)
    ELSEIF (novlp == 3) THEN
!* random
      zclear(jl)=zclear(jl)*(_one_-zss0(jl))
      zscat(jl) = _one_ - zclear(jl)
      zc0i(jl,jkl) = zscat(jl)
    ENDIF
  ENDDO
ENDDO

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

!*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
!                -----------------------------------------------


DO jl = kidia,kfdia
  pray1(jl,klev+1) = _zero_
  pray2(jl,klev+1) = _zero_
  prefz(jl,2,1) = palbp(jl,knu)
  prefz(jl,1,1) = palbp(jl,knu)
  ptra1(jl,klev+1) = _one_
  ptra2(jl,klev+1) = _one_
ENDDO

DO jk = 2 , klev+1
  jkm1 = jk-1
  DO jl = kidia,kfdia


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

!*         3.1  EQUIVALENT ZENITH ANGLE
!               -----------------------


    zmue = (_one_-zc0i(jl,jk)) * psec(jl)+ zc0i(jl,jk) * 1.66_jprb
    prmu0(jl,jk) = _one_/zmue


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

!*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
!               ----------------------------------------------------


    zgap = pcgaz(jl,jkm1)
    zbmu0 = _half_ - 0.75_jprb * zgap / zmue
    zww = ppizaz(jl,jkm1)
    zto = ptauaz(jl,jkm1)
    zden = _one_ + (_one_ - zww + zbmu0 * zww) * zto * zmue &
     &+ (1-zww) * (_one_ - zww +_two_*zbmu0*zww)*zto*zto*zmue*zmue
    pray1(jl,jkm1) = zbmu0 * zww * zto * zmue / zden
    ptra1(jl,jkm1) = _one_ / zden

    zmu1 = _half_
    zbmu1 = _half_ - 0.75_jprb * zgap * zmu1
    zden1= _one_ + (_one_ - zww + zbmu1 * zww) * zto / zmu1 &
     &+ (1-zww) * (_one_ - zww +_two_*zbmu1*zww)*zto*zto/zmu1/zmu1
    pray2(jl,jkm1) = zbmu1 * zww * zto / zmu1 / zden1
    ptra2(jl,jkm1) = _one_ / zden1



    prefz(jl,1,jk) = (pray1(jl,jkm1)&
     &+ prefz(jl,1,jkm1) * ptra1(jl,jkm1)&
     &* ptra2(jl,jkm1)&
     &/ (_one_-pray2(jl,jkm1)*prefz(jl,1,jkm1)))

    ztr(jl,1,jkm1) = (ptra1(jl,jkm1)&
     &/ (_one_-pray2(jl,jkm1)*prefz(jl,1,jkm1)))

    prefz(jl,2,jk) = (pray1(jl,jkm1)&
     &+ prefz(jl,2,jkm1) * ptra1(jl,jkm1)&
     &* ptra2(jl,jkm1) )

    ztr(jl,2,jkm1) = ptra1(jl,jkm1)

  ENDDO
ENDDO
DO jl = kidia,kfdia
  zmue = (_one_-zc0i(jl,1))*psec(jl)+zc0i(jl,1)*1.66_jprb
  prmu0(jl,1)=_one_/zmue
  ptrclr(jl)=_one_-zc0i(jl,1)
ENDDO


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

!*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
!                 -------------------------------------------------

IF (nsw <= 4) THEN
  inu1=1
ELSE IF (nsw == 6) THEN
  inu1=3
END IF    

IF (knu <= inu1) THEN
  jaj = 2
  DO jl = kidia,kfdia
    prj(jl,jaj,klev+1) = _one_
    prk(jl,jaj,klev+1) = prefz(jl, 1,klev+1)
  ENDDO

  DO jk = 1 , klev
    jkl = klev+1 - jk
    jklp1 = jkl + 1
    DO jl = kidia,kfdia
      zre11= prj(jl,jaj,jklp1) * ztr(jl,  1,jkl)
      prj(jl,jaj,jkl) = zre11
      prk(jl,jaj,jkl) = zre11 * prefz(jl,  1,jkl)
    ENDDO
  ENDDO

ELSE

  DO jaj = 1 , 2
    DO jl = kidia,kfdia
      prj(jl,jaj,klev+1) = _one_
      prk(jl,jaj,klev+1) = prefz(jl,jaj,klev+1)
    ENDDO

    DO jk = 1 , klev
      jkl = klev+1 - jk
      jklp1 = jkl + 1
      DO jl = kidia,kfdia
        zre11= prj(jl,jaj,jklp1) * ztr(jl,jaj,jkl)
        prj(jl,jaj,jkl) = zre11
        prk(jl,jaj,jkl) = zre11 * prefz(jl,jaj,jkl)
      ENDDO
    ENDDO
  ENDDO

ENDIF

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

RETURN
END SUBROUTINE swclr