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
    
!-----------------------------------------------------------------------

#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 :: puu(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, 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


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

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

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

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

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),_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 (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(_one_ + ro1h * zuxy ) - _one_
  zsq2 = sqrt(_one_ + ro2h * zuxy ) - _one_
  zvxy = rpialf0 * zy / (_two_ * 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(_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 = puu(jl,21)
  zyn2o = puu(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 = _two_ * puu(jl,23) * 4.404e+05_jprb
  zttf11 = _one_ - za11 * 0.003225_jprb

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

  za12 = _two_ * puu(jl,24) * 6.7435e+05_jprb
  zttf12 = _one_ - 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

RETURN
END SUBROUTINE lwtt