rrtm_gasabs1a_140gp.F90

Go to the documentation of this file.

SUBROUTINE rrtm_gasabs1a_140gp (KLEV,ATR1,OD,TF1,COLDRY,WX,&
  &tauaerl,fac00,fac01,fac10,fac11,forfac,jp,jt,jt1,oneminus,&
  &colh2o,colco2,colo3,coln2o,colch4,colo2,co2mult,&
  &laytrop,layswtch,laylow,selffac,selffrac,indself,pfrac)

!     Reformatted for F90 by JJMorcrette, ECMWF, 980714

#include "tsmbkind.h"

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

IMPLICIT NONE

real_b :: atr1(jpgpt,jplay)
real_b :: od(jpgpt,jplay)
real_b :: tf1(jpgpt,jplay)
real_b :: coldry(jplay)
real_b :: wx(jpxsec,jplay)           ! Amount of trace gases

!     DUMMY INTEGER SCALARS
integer_m :: klev

!- from AER
real_b :: tauaerl(jplay,jpband)

!- from INTFAC      
real_b :: fac00(jplay)
real_b :: fac01(jplay)
real_b :: fac10(jplay)
real_b :: fac11(jplay)
real_b :: forfac(jplay)

!- from INTIND
integer_m :: jp(jplay)
integer_m :: jt(jplay)
integer_m :: jt1(jplay)

!- from PRECISE             
real_b :: oneminus

!- from PROFDATA             
real_b :: colh2o(jplay)
real_b :: colco2(jplay)
real_b :: colo3(jplay)
real_b :: coln2o(jplay)
real_b :: colch4(jplay)
real_b :: colo2(jplay)
real_b :: co2mult(jplay)
integer_m :: laytrop
integer_m :: layswtch
integer_m :: laylow

!- from SELF             
real_b :: selffac(jplay)
real_b :: selffrac(jplay)
integer_m :: indself(jplay)

!- from SP             
real_b :: pfrac(jpgpt,jplay)


real_b :: tau(jpgpt,jplay)

!     LOCAL INTEGER SCALARS
integer_m :: ipr, itr, lay

!     LOCAL REAL SCALARS
real_b :: odepth, secang, tf


!- SECANG is equal to the secant of the diffusivity angle.
secang = 1.66_jprb

CALL rrtm_taumol1  (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,forfac,jp,jt,jt1,&
  &colh2o,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol2  (klev,tau,coldry,&
  &tauaerl,fac00,fac01,fac10,fac11,forfac,jp,jt,jt1,&
  &colh2o,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol3  (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,forfac,jp,jt,jt1,oneminus,&
  &colh2o,colco2,coln2o,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol4  (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,forfac,jp,jt,jt1,oneminus,&
  &colh2o,colco2,colo3,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol5  (klev,tau,wx,&
  &tauaerl,fac00,fac01,fac10,fac11,forfac,jp,jt,jt1,oneminus,&
  &colh2o,colco2,colo3,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol6  (klev,tau,wx,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,&
  &colh2o,co2mult,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol7  (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,oneminus,&
  &colh2o,colo3,co2mult,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol8  (klev,tau,wx,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,&
  &colh2o,colo3,coln2o,co2mult,layswtch,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol9  (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,oneminus,&
  &colh2o,coln2o,colch4,laytrop,layswtch,laylow,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol10 (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,&
  &colh2o,laytrop,pfrac)
CALL rrtm_taumol11 (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,&
  &colh2o,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol12 (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,oneminus,&
  &colh2o,colco2,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol13 (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,oneminus,&
  &colh2o,coln2o,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol14 (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,&
  &colco2,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol15 (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,oneminus,&
  &colh2o,colco2,coln2o,laytrop,selffac,selffrac,indself,pfrac)
CALL rrtm_taumol16 (klev,tau,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,oneminus,&
  &colh2o,colch4,laytrop,selffac,selffrac,indself,pfrac)

!- Loop over g-channels.
DO lay = 1, klev
  DO ipr = 1, jpgpt
    odepth = secang * tau(ipr,lay)
    od(ipr,lay) = odepth
!-- revised code to get the pre-computed transmission            
    tf = odepth/(bpade+odepth)
!          IF (ODEPTH.LE.0.) PRINT*, 'ODEPTH = ',ODEPTH
    IF (odepth <= _zero_) tf = _zero_
    itr=int(5.e+03_jprb*tf+_half_)
    atr1(ipr,lay) = _one_ - trans(itr)
    tf1(ipr,lay) = tf
  ENDDO
ENDDO

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

RETURN
END SUBROUTINE rrtm_gasabs1a_140gp