rrtm_gasabs1a_140gp.F90

Go to the documentation of this file.

SUBROUTINE rrtm_gasabs1a_140gp (KLEV,P_ATR1,P_OD,P_TF1,P_COLDRY,P_WX,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,p_forfac,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_colco2,p_colo3,p_coln2o,p_colch4,p_colo2,p_co2mult,&
 & k_laytrop,k_layswtch,k_laylow,p_selffac,p_selffrac,k_indself,pfrac)  

!     Reformatted for F90 by JJMorcrette, ECMWF, 980714

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

USE parrrtm  , ONLY : jplay    ,jpband   ,jpgpt   ,jpxsec
USE yoerrtab , ONLY : trans    ,bpade

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_ATR1(jpgpt,jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_OD(jpgpt,jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TF1(jpgpt,jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLDRY(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_WX(jpxsec,jplay) ! Amount of trace gases
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_TAUAERL(jplay,jpband) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC00(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC01(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC10(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC11(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFAC(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_JP(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT1(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ONEMINUS 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLH2O(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLCO2(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLO3(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLN2O(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLCH4(jplay) 
REAL(KIND=JPRB)                  :: P_COLO2(jplay) ! Argument NOT used
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_CO2MULT(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYTROP 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYSWTCH 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYLOW 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFAC(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFRAC(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDSELF(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFRAC(jpgpt,jplay) 
!- from AER
!- from INTFAC      
!- from INTIND
!- from PRECISE             
!- from PROFDATA             
!- from SELF             
!- from SP             
REAL(KIND=JPRB) :: Z_TAU   (jpgpt,jplay)

INTEGER(KIND=JPIM) :: IPR, ITR, I_LAY

REAL(KIND=JPRB) :: Z_ODEPTH, Z_SECANG, Z_TF
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "rrtm_taumol1.intfb.h"
#include "rrtm_taumol10.intfb.h"
#include "rrtm_taumol11.intfb.h"
#include "rrtm_taumol12.intfb.h"
#include "rrtm_taumol13.intfb.h"
#include "rrtm_taumol14.intfb.h"
#include "rrtm_taumol15.intfb.h"
#include "rrtm_taumol16.intfb.h"
#include "rrtm_taumol2.intfb.h"
#include "rrtm_taumol3.intfb.h"
#include "rrtm_taumol4.intfb.h"
#include "rrtm_taumol5.intfb.h"
#include "rrtm_taumol6.intfb.h"
#include "rrtm_taumol7.intfb.h"
#include "rrtm_taumol8.intfb.h"
#include "rrtm_taumol9.intfb.h"

!- SECANG is equal to the secant of the diffusivity angle.
IF (lhook) CALL dr_hook('RRTM_GASABS1A_140GP',0,zhook_handle)
z_secang = 1.66_jprb

CALL rrtm_taumol1  (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,p_forfac,k_jp,k_jt,k_jt1,&
 & p_colh2o,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol2  (klev,z_tau,p_coldry,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,p_forfac,k_jp,k_jt,k_jt1,&
 & p_colh2o,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol3  (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,p_forfac,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_colco2,p_coln2o,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol4  (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,p_forfac,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_colco2,p_colo3,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol5  (klev,z_tau,p_wx,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,p_forfac,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_colco2,p_colo3,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol6  (klev,z_tau,p_wx,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,&
 & p_colh2o,p_co2mult,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol7  (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_colo3,p_co2mult,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol8  (klev,z_tau,p_wx,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,&
 & p_colh2o,p_colo3,p_coln2o,p_co2mult,k_layswtch,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol9  (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_coln2o,p_colch4,k_laytrop,k_layswtch,k_laylow,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol10 (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,&
 & p_colh2o,k_laytrop,pfrac)  
CALL rrtm_taumol11 (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,&
 & p_colh2o,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol12 (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_colco2,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol13 (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_coln2o,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol14 (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,&
 & p_colco2,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol15 (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_colco2,p_coln2o,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  
CALL rrtm_taumol16 (klev,z_tau,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_colch4,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  

!- Loop over g-channels.
DO i_lay = 1, klev
  DO ipr = 1, jpgpt
    z_odepth = z_secang * z_tau(ipr,i_lay)
    p_od(ipr,i_lay) = z_odepth
    z_odepth=0.5d0*(abs(z_odepth)+z_odepth)

!-- revised code to get the pre-computed transmission
!          IF (ODEPTH.LE.0.) PRINT*, 'ODEPTH = ',ODEPTH
!!  IF (ODEPTH <= _ZERO_)THEN
!!    ATR1(IPR,LAY) = _ONE_ - TRANS(0)
!!    TF1(IPR,LAY) = _ZERO_
!!  ELSE

    z_tf = z_odepth/(bpade+z_odepth)
    itr=int(5.e+03_jprb*z_tf+0.5_jprb)
    IF (itr.LT.0) itr=0     ! MPL 12.12.08
    p_atr1(ipr,i_lay) = 1.0_jprb - trans(itr)
    p_tf1(ipr,i_lay) = z_tf

!!  ENDIF
  ENDDO
ENDDO

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

IF (lhook) CALL dr_hook('RRTM_GASABS1A_140GP',1,zhook_handle)
END SUBROUTINE rrtm_gasabs1a_140gp