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

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


#include "tsmbkind.h"

USE yoecld   , ONLY : repsec
USE yoerad   , ONLY : novlp    ,nsw
USE yoerdu   , ONLY : repscq
USE yoesw    , ONLY : rpdh1    ,rpdu1    ,rpnh     ,rpnu     ,&
            &rtdh2o   ,rtdumg   ,rth2o    ,rtumg
USE yoeovlp  , ONLY : ra1ovlp


IMPLICIT NONE


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

!     DUMMY REAL SCALARS
real_b :: pcardi
real_b :: psct



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

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

real_b :: pcldsw(klon,klev), ppmb(klon,klev+1), ppsol(klon)&
  &,  prmu0(klon)      , ptave(klon,klev) , pwv(klon,klev)

real_b :: paki(klon,2,nsw)&
  &,  pcld(klon,klev)  , pclear(klon)&
  &,  pdsig(klon,klev) , pfact(klon)      , prmu(klon)&
  &,  psec(klon)       , pud(klon,5,klev+1)
  
integer_m :: inuir  

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

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

integer_m :: iind(2)
real_b :: 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)

!     LOCAL INTEGER SCALARS
integer_m :: ja, jk, jkl, jklp1, jkp1, jl, jnu

!     LOCAL REAL SCALARS
real_b :: zdsco2, zdsh2o, zfppw, zrth, zrtu, zwh2o, zalpha1


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

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


iind(1)=1
iind(2)=2


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


DO jl = kidia,kfdia
  pud(jl,1,klev+1)=_zero_
  pud(jl,2,klev+1)=_zero_
  pud(jl,3,klev+1)=_zero_
  pud(jl,4,klev+1)=_zero_
  pud(jl,5,klev+1)=_zero_
  pfact(jl)= prmu0(jl) * psct
!- already accounted for in RADINT      
!      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
  prmu(jl)=prmu0(jl)
! Martin control
!  PRINT*,'PRMU(',JL,')=',PRMU(JL)
! Martin modif to avoid cos(sza)=0 for LMDZ:
  IF (prmu(jl) .LE. 1e-3) prmu(jl) = 1e-3
  psec(jl)=_one_/prmu(jl)
  zc1j(jl,klev+1)=_zero_
ENDDO

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


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

DO jk = 1 , klev
  jkp1 = jk + 1
  jkl = klev+1 - jk
  jklp1 = jkl+1
  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/(_one_+0.608_jprb*zwh2o)
    pud(jl,4,jk)=pud(jl,1,jk)*zfppw
    pud(jl,5,jk)=pud(jl,1,jk)*(_one_-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)

    IF (novlp == 1) THEN
      zclear(jl)=zclear(jl)&
       &*(_one_-max(pcldsw(jl,jkl),zcloud(jl)))&
       &/(_one_-min(zcloud(jl),_one_-repsec))
      zc1j(jl,jkl)= _one_ - zclear(jl)
      zcloud(jl) = pcldsw(jl,jkl)
    ELSEIF (novlp == 2) THEN
      zcloud(jl) = max(pcldsw(jl,jkl),zcloud(jl))
      zc1j(jl,jkl) = zcloud(jl)
    ELSEIF (novlp == 3) THEN
      zclear(jl) = zclear(jl)*(_one_-pcldsw(jl,jkl))
      zcloud(jl) = _one_ - zclear(jl)
      zc1j(jl,jkl) = zcloud(jl)
    ELSEIF (novlp == 4) THEN
!** Hogan & Illingworth (2001)      
      zalpha1=ra1ovlp(klev+1-jk)
      zclear(jl)=zclear(jl)*( &
        & zalpha1*(_one_-max(pcldsw(jl,jkl),zcloud(jl))) &
        &        /(_one_-min(zcloud(jl),_one_-repsec)) &
        & +(_one_-zalpha1)*(_one_-pcldsw(jl,jkl)) )
      zc1j(jl,jkl) = _one_ - zclear(jl) 
      zcloud(jl) = pcldsw(jl,jkl)
    ENDIF
  ENDDO
ENDDO
DO jl=kidia,kfdia
  pclear(jl)=_one_-zc1j(jl,1)
ENDDO
DO jk=1,klev
  DO jl=kidia,kfdia
    IF (pclear(jl) < _one_) THEN
      pcld(jl,jk)=pcldsw(jl,jk)/(_one_-pclear(jl))
    ELSE
      pcld(jl,jk)=_zero_
    ENDIF
  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.LE.4) THEN
  inuir=2
ELSE IF (nsw.EQ.6) THEN
  inuir=4
END IF     


DO jnu= inuir,nsw

  kkind=2
  CALL swtt1 ( kidia,kfdia,klon, jnu, kkind, 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


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

RETURN
END SUBROUTINE swu