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

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

#include "tsmbkind.h"

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


IMPLICIT NONE


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



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

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

real_b :: puu1(klon,nua), puu2(klon,nua), ptt(klon,ntra)&
  &,  pga(klon,8,2) , pgb(klon,8,2)

!     LOCAL INTEGER SCALARS
integer_m :: ja, jl

!     LOCAL REAL SCALARS
real_b :: 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


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


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

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),_zero_)
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(_one_ + ro1h * zuxy ) - _one_
  zsq2 = sqrt(_one_ + ro2h * zuxy ) - _one_
  zvxy = rpialf0 * zy / (_two_ * 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(_one_ + 33.7_jprb * zuxy) - _one_
  zvxy = 0.103_jprb * zych4 / (_two_ * 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(_one_ + 21.3_jprb * zuxy) - _one_
  zvxy = 0.416_jprb * zyn2o / (_two_ * zxn2o)
  zodn21 = zvxy * zsqn21

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

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

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

  zuxy = 4._jprb * zxn2o*zxn2o/(0.197_jprb*zyn2o)
  zsqn22 = sqrt(_one_ + 2000._jprb * zuxy) - _one_
  zvxy = 0.197_jprb * zyn2o / (_two_ * 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 = _one_ - 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 = _one_ - 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

RETURN
END SUBROUTINE lwttm