lwttm.F90

Go to the documentation of this file.

!OPTIONS XOPT(HSFUN)
SUBROUTINE lwttm ( KIDIA, KFDIA, KLON, PGA  , PGB, PUU1 , PUU2 , PTT        )

!**** *LWTTM* - 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.
!     ----------
!          *LWTTM* IS CALLED FROM *LWVD*

!        EXPLICIT ARGUMENTS :
!        --------------------
!     ==== INPUTS ===
! PGA, PGB                    ; PADE APPROXIMANTS
! PUU1   : (KLON,NUA)         ; ABSORBER AMOUNTS FROM TOP TO LEVEL 1
! PUU2   : (KLON,NUA)         ; ABSORBER AMOUNTS FROM TOP TO LEVEL 2  
!     ==== 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)    :: PUU1(klon,nua) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PUU2(klon,nua) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTT(klon,ntra) 
!     ------------------------------------------------------------------

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

INTEGER(KIND=JPIM) :: JA, JL

REAL(KIND=JPRB) :: ZA11, ZA12, ZAERCN, ZEU, ZEU10, ZEU11, ZEU12,&
 & ZEU13, ZODH41, ZODH42, ZODN21, ZODN22, ZPU, &
 & 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('LWTTM',0,zhook_handle)
DO ja = 1 , 8
  DO jl = kidia,kfdia
    zz  = sqrt(puu1(jl,ja) - puu2(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

  zpu   = (puu1(jl,10) - puu2(jl,10))
  zpu10 = rptype(1) * zpu
  zpu11 = rptype(2) * zpu
  zpu12 = rptype(3) * zpu
  zpu13 = rptype(4) * zpu
  zeu   = (puu1(jl,11) - puu2(jl,11))
  zeu10 = retype(1) * zeu
  zeu11 = retype(2) * zeu
  zeu12 = retype(3) * zeu
  zeu13 = retype(4) * zeu

!-  OZONE ABSORPTION

  zx = (puu1(jl,12) - puu2(jl,12))
  zy = (puu1(jl,13) - puu2(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 = (puu1(jl,17) -puu2(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 = (puu1(jl,19) - puu2(jl,19))
  zych4 = (puu1(jl,20) - puu2(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 = (puu1(jl,21) - puu2(jl,21))
  zyn2o = (puu1(jl,22) - puu2(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 = (puu1(jl,23) - puu2(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 = (puu1(jl,24) - puu2(jl,24)) * 6.7435e+05_jprb
  zttf12 = 1.0_jprb - za12 * 0.003225_jprb

  zuu11 = - (puu1(jl,15) - puu2(jl,15)) - zeu10 - zpu10
  zuu12 = - (puu1(jl,16) - puu2(jl,16)) - zeu11 - zpu11 -zodh41 - zodn21
  ptt(jl,10) = exp( - (puu1(jl,14)- puu2(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( - (puu1(jl,14) - puu2(jl,14)) - zodh42-zodn22 )

ENDDO

IF (lhook) CALL dr_hook('LWTTM',1,zhook_handle)
END SUBROUTINE lwttm