lwtt.F90

Go to the documentation of this file.

!OPTIONS XOPT(HSFUN)
SUBROUTINE lwtt ( KIDIA, KFDIA, KLON, PGA  , PGB, PUU  , PTT             )

!**** *LWTT* - LONGWAVE TRANSMISSION FUNCTIONS

!     PURPOSE.
!     --------
!           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
!     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
!     INTERVALS.

!**   INTERFACE.
!     ----------
!          *LWTT* IS CALLED FROM *LWVN*, *LWVD*, *LWVB*

!        EXPLICIT ARGUMENTS :
!        --------------------
!     ==== INPUTS ===
! KND    :                    ; WEIGHTING INDEX
! PUU    : (KLON,NUA)         ; ABSORBER AMOUNTS
!     ==== OUTPUTS ===
! PTT    : (KLON,NTRA)        ; TRANSMISSION FUNCTIONS

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

!     METHOD.
!     -------

!          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
!     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
!          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
!          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
!     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.

!     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
!        97-04-18  JJ Morcrette        Revised continuum
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
    
!-----------------------------------------------------------------------

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

USE yoelw    , ONLY : ntra     ,nua      ,rptype   ,retype   ,&
 & ro1h     ,ro2h     ,rpialf0  

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)    :: PGA(klon,8,2) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PGB(klon,8,2) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PUU(klon,nua) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTT(klon,ntra) 
!     ------------------------------------------------------------------

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

INTEGER(KIND=JPIM) :: JA, JL

REAL(KIND=JPRB) :: ZA11, ZA12, ZAERCN, ZEU10, ZEU11, ZEU12,&
 & ZEU13, ZODH41, ZODH42, ZODN21, ZODN22, ZPU10, &
 & ZPU11, ZPU12, ZPU13, ZSQ1, ZSQ2, ZSQH41, &
 & ZSQH42, ZSQN21, ZSQN22, ZTO1, ZTO2, ZTTF11, &
 & ZTTF12, ZUU11, ZUU12, ZUXY, ZVXY, ZX, ZXCH4, &
 & ZXD, ZXN, ZXN2O, ZY, ZYCH4, ZYN2O, ZZ  
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

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

!     ------------------------------------------------------------------
!DIR$ VFUNCTION SQRTHF

!*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
!                 -----------------------------------------------

IF (lhook) CALL dr_hook('LWTT',0,zhook_handle)
DO ja = 1 , 8
  DO jl = kidia,kfdia
    zz  = sqrt(puu(jl,ja))
    zxd = pgb( jl,ja,1) + zz* (pgb( jl,ja,2) + zz )
    zxn = pga( jl,ja,1) + zz* (pga( jl,ja,2)      )
    ptt(jl,ja) = zxn / zxd
  ENDDO
ENDDO

DO jl = kidia,kfdia
  ptt(jl,3)=max(ptt(jl,3),0.0_jprb)
ENDDO
!     ------------------------------------------------------------------

!*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
!                 ---------------------------------------------------

DO jl = kidia,kfdia
  ptt(jl, 9) = ptt(jl, 8)

!-  CONTINUUM ABSORPTION: E- AND P-TYPE (from Giorgetta and Wild, 1997)

  zpu10 = rptype(1) * puu(jl,10)
  zpu11 = rptype(2) * puu(jl,10)
  zpu12 = rptype(3) * puu(jl,10)
  zpu13 = rptype(4) * puu(jl,10)
  zeu10 = retype(1) * puu(jl,11)
  zeu11 = retype(2) * puu(jl,11)
  zeu12 = retype(3) * puu(jl,11)
  zeu13 = retype(4) * puu(jl,11)

!-  OZONE ABSORPTION

  zx = puu(jl,12)
  zy = puu(jl,13)
  zuxy = 4._jprb * zx * zx / (rpialf0 * zy)
  zsq1 = sqrt(1.0_jprb + ro1h * zuxy ) - 1.0_jprb
  zsq2 = sqrt(1.0_jprb + ro2h * zuxy ) - 1.0_jprb
  zvxy = rpialf0 * zy / (2.0_jprb * zx)
  zaercn = puu(jl,17) + zeu12 + zpu12
  zto1 = exp( - zvxy * zsq1 - zaercn )
  zto2 = exp( - zvxy * zsq2 - zaercn )

!-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)

!* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1

  zxch4 = puu(jl,19)
  zych4 = puu(jl,20)
  zuxy = 4._jprb * zxch4*zxch4/(0.103_jprb*zych4)
  zsqh41 = sqrt(1.0_jprb + 33.7_jprb * zuxy) - 1.0_jprb
  zvxy = 0.103_jprb * zych4 / (2.0_jprb * zxch4)
  zodh41 = zvxy * zsqh41

!* N2O IN INTERVAL 800-970 + 1110-1250 CM-1

  zxn2o = puu(jl,21)
  zyn2o = puu(jl,22)
  zuxy = 4._jprb * zxn2o*zxn2o/(0.416_jprb*zyn2o)
  zsqn21 = sqrt(1.0_jprb + 21.3_jprb * zuxy) - 1.0_jprb
  zvxy = 0.416_jprb * zyn2o / (2.0_jprb * zxn2o)
  zodn21 = zvxy * zsqn21

!* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1

  zuxy = 4._jprb * zxch4*zxch4/(0.113_jprb*zych4)
  zsqh42 = sqrt(1.0_jprb + 400._jprb * zuxy) - 1.0_jprb
  zvxy = 0.113_jprb * zych4 / (2.0_jprb * zxch4)
  zodh42 = zvxy * zsqh42

!* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1

  zuxy = 4._jprb * zxn2o*zxn2o/(0.197_jprb*zyn2o)
  zsqn22 = sqrt(1.0_jprb + 2000._jprb * zuxy) - 1.0_jprb
  zvxy = 0.197_jprb * zyn2o / (2.0_jprb * zxn2o)
  zodn22 = zvxy * zsqn22

!* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1

  za11 = 2.0_jprb * puu(jl,23) * 4.404e+05_jprb
  zttf11 = 1.0_jprb - za11 * 0.003225_jprb

!* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1

  za12 = 2.0_jprb * puu(jl,24) * 6.7435e+05_jprb
  zttf12 = 1.0_jprb - za12 * 0.003225_jprb

  zuu11 = - puu(jl,15) - zeu10 - zpu10
  zuu12 = - puu(jl,16) - zeu11 - zpu11 - zodh41 - zodn21
  ptt(jl,10) = exp( - puu(jl,14) )
  ptt(jl,11) = exp( zuu11 )
  ptt(jl,12) = exp( zuu12 ) * zttf11 * zttf12
  ptt(jl,13) = 0.7554_jprb * zto1 + 0.2446_jprb * zto2
  ptt(jl,14) = ptt(jl,10) * exp( - zeu13 - zpu13 )
  ptt(jl,15) = exp( - puu(jl,14) - zodh42 - zodn22 )

ENDDO

IF (lhook) CALL dr_hook('LWTT',1,zhook_handle)
END SUBROUTINE lwtt