rrtm_rrtm_140gp.F90

Go to the documentation of this file.

!***************************************************************************
!                                                                          *
!                RRTM :  RAPID RADIATIVE TRANSFER MODEL                    *
!                                                                          *
!             ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC.                 *
!                        840 MEMORIAL DRIVE                                *
!                        CAMBRIDGE, MA 02139                               *
!                                                                          *
!                           ELI J. MLAWER                                  *
!                         STEVEN J. TAUBMAN~                               *
!                         SHEPARD A. CLOUGH                                *
!                                                                          *
!                        ~currently at GFDL                                *
!                                                                          *
!                       email:  mlawer@aer.com                             *
!                                                                          *
!        The authors wish to acknowledge the contributions of the          *
!        following people:  Patrick D. Brown, Michael J. Iacono,           *
!        Ronald E. Farren, Luke Chen, Robert Bergstrom.                    *
!                                                                          *
!***************************************************************************
!     Reformatted for F90 by JJMorcrette, ECMWF, 980714                    * 
!                                                                          *
!***************************************************************************
! *** mji ***
! *** This version of RRTM has been altered to interface with either
!     the ECMWF numerical weather prediction model or the ECMWF column 
!     radiation model (ECRT) package. 

!     Revised, April, 1997;  Michael J. Iacono, AER, Inc.
!          - initial implementation of RRTM in ECRT code
!     Revised, June, 1999;  Michael J. Iacono and Eli J. Mlawer, AER, Inc.
!          - to implement generalized maximum/random cloud overlap

SUBROUTINE rrtm_rrtm_140gp &
 &( kidia , kfdia , klon , klev &
 &, paer  , paph  , pap &
 &, pts   , pth   , pt &
 &, zemis , zemiw &
 &, pq    , pcco2 , pozn &
 &, pcldf , ptaucld &
 &, pemit , pflux , pfluc, ptclear &
 &)

! *** This program is the driver for RRTM, the AER rapid model.  
!     For each atmosphere the user wishes to analyze, this routine
!     a) calls ECRTATM to read in the atmospheric profile 
!     b) calls SETCOEF to calculate various quantities needed for 
!        the radiative transfer algorithm
!     c) calls RTRN to do the radiative transfer calculation for
!        clear or cloudy sky
!     d) writes out the upward, downward, and net flux for each
!        level and the heating rate for each layer


#include "tsmbkind.h"

USE parrrtm  , ONLY : jpband   ,jpg      ,jpxsec   ,jpgpt    ,jplay    ,&
            &jpinpx
USE yoerrtwn , ONLY : wavenum1 ,wavenum2 ,delwave  ,ng       ,nspa     ,nspb

!------------------------------Arguments--------------------------------

! Input arguments


IMPLICIT NONE
integer_m :: kidia                 ! First atmosphere index
integer_m :: kfdia                 ! Last atmosphere index
integer_m :: klon                  ! Number of atmospheres (longitudes)
integer_m :: klev                  ! Number of atmospheric layers
real_b :: paer(klon,6,klev)        ! Aerosol optical thickness
real_b :: pap(klon,klev)           ! Layer pressures (Pa)
real_b :: paph(klon,klev+1)        ! Interface pressures (Pa)
real_b :: pts(klon)                ! Surface temperature (K)
real_b :: pt(klon,klev)            ! Layer temperature (K)
real_b :: zemis(klon)              ! Non-window surface emissivity
real_b :: zemiw(klon)              ! Window surface emissivity
real_b :: pth(klon,klev+1)         ! Interface temperatures (K)
real_b :: pq(klon,klev)            ! H2O specific humidity (mmr)
real_b :: pozn(klon,klev)          ! O3 mass mixing ratio
real_b :: pcco2                    ! CO2 mass mixing ratio
real_b :: rch4                     ! CH4 mass mixing ratio
real_b :: rn2o                     ! N2O mass mixing ratio
real_b :: rcfc11                   ! CFC11 mass mixing ratio
real_b :: rcfc12                   ! CFC12 mass mixing ratio
real_b :: pcldf(klon,klev)         ! Cloud fraction
real_b :: ptaucld(klon,klev,jpband)! Cloud optical depth
real_b :: pflux(klon,2,klev+1)     ! LW total sky flux (1=up, 2=down)
real_b :: pfluc(klon,2,klev+1)     ! LW clear sky flux (1=up, 2=down)
real_b :: pemit(klon)              ! Surface LW emissivity
real_b :: ptclear(klon)            ! clear-sky fraction of column

integer_m :: icldlyr(jplay)        ! Cloud indicator
real_b :: cldfrac(jplay)           ! Cloud fraction
real_b :: taucld(jplay,jpband)     ! Spectral optical thickness

real_b :: abss1(jpgpt*jplay)
real_b :: atr1(jpgpt,jplay)
equivalence(abss1(1),atr1(1,1))

real_b :: od(jpgpt,jplay)

real_b :: tausf1(jpgpt*jplay)
real_b :: tf1(jpgpt,jplay)
equivalence(tausf1(1),tf1(1,1))

real_b :: coldry(jplay)
real_b :: wkl(jpinpx,jplay)

real_b :: wx(jpxsec,jplay)         ! Amount of trace gases

real_b :: clfnet(0:jplay)
real_b :: clhtr(0:jplay)
real_b :: fnet(0:jplay)
real_b :: htr(0:jplay)
real_b :: totdfluc(0:jplay)
real_b :: totdflux(0:jplay)
real_b :: totufluc(0:jplay)
real_b :: totuflux(0:jplay)

!     LOCAL INTEGER SCALARS
integer_m :: i, icld, iplon, k
integer_m :: istart
integer_m :: iend

!     LOCAL REAL SCALARS
real_b :: fluxfac, heatfac, pi, zepsec, ztclear

!- 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 PROFILE             
real_b :: pavel(jplay)
real_b :: tavel(jplay)
real_b :: pz(0:jplay)
real_b :: tz(0:jplay)
real_b :: tbound
integer_m :: nlayers

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

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

!- from SURFACE             
real_b :: semiss(jpband)
real_b :: semislw
integer_m :: ireflect


!     HEATFAC is the factor by which one must multiply delta-flux/ 
!     delta-pressure, with flux in w/m-2 and pressure in mbar, to get 
!     the heating rate in units of degrees/day.  It is equal to 
!           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
!        =  (9.8066)(86400)(1e-5)/(1.004)

zepsec = 1.e-06_jprb
oneminus = _one_ - zepsec
pi = _two_*asin(_one_)
fluxfac = pi * 2.d4
heatfac = 8.4391_jprb

! *** mji ***
! For use with ECRT, this loop is over atmospheres (or longitudes)
DO iplon = kidia,kfdia

! *** mji ***
!- Prepare atmospheric profile from ECRT for use in RRTM, and define
!  other RRTM input parameters.  Arrays are passed back through the
!  existing RRTM commons and arrays.
  ztclear=_one_

!  print *,'before RRTM_ECRT_140GP'

  CALL rrtm_ecrt_140gp &
   &( iplon, klon , klev, icld &
   &, paer , paph , pap &
   &, pts  , pth  , pt &
   &, zemis, zemiw &
   &, pq   , pcco2, pozn, pcldf, ptaucld, ztclear &
   &, cldfrac,taucld,coldry,wkl,wx &
   &, tauaerl,pavel,tavel,pz,tz,tbound,nlayers,semiss,ireflect)

  ptclear(iplon)=ztclear

  istart = 1
  iend   = 16

!  Calculate information needed by the radiative transfer routine
!  that is specific to this atmosphere, especially some of the 
!  coefficients and indices needed to compute the optical depths
!  by interpolating data from stored reference atmospheres. 

!  print *,'before RRTM_SETCOEF_140GP'
  
    CALL rrtm_setcoef_140gp (klev,coldry,wkl &
   &, fac00,fac01,fac10,fac11,forfac,jp,jt,jt1 &
   &, colh2o,colco2,colo3,coln2o,colch4,colo2,co2mult &
   &, laytrop,layswtch,laylow,pavel,tavel,selffac,selffrac,indself)

! print *,'before RRTM_GASABS1A_140GP'

  CALL 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)

!- Call the radiative transfer routine.

! *** mji ***
!  Check for cloud in column.  Use ECRT threshold set as flag icld in
!  routine ECRTATM.  If icld=1 then column is cloudy, otherwise it is
!  clear.  Also, set up flag array, icldlyr, for use in radiative
!  transfer.  Set icldlyr to one for each layer with non-zero cloud
!  fraction.

  DO k = 1, klev
    IF (icld == 1.AND.cldfrac(k) > zepsec) THEN
      icldlyr(k) = 1
    ELSE
      icldlyr(k) = 0
    ENDIF
  ENDDO

!  Clear and cloudy parts of column are treated together in RTRN.
!  Clear radiative transfer is done for clear layers and cloudy radiative
!  transfer is done for cloudy layers as identified by icldlyr.
  
! print *,'before RRTM_RTRN1A_140GP'
 
  CALL rrtm_rtrn1a_140gp (klev,istart,iend,icldlyr,cldfrac,taucld,abss1 &
   &, od,tausf1,clfnet,clhtr,fnet,htr,totdfluc,totdflux,totufluc,totuflux &
   &, tavel,pz,tz,tbound,pfrac,semiss,semislw,ireflect)

! ***   Pass clear sky and total sky up and down flux profiles to ECRT
!       output arrays (zflux, zfluc). Array indexing from bottom to top 
!       is preserved for ECRT.
!       Invert down flux arrays for consistency with ECRT sign conventions.

  pemit(iplon) = semislw
  DO i = 0, klev
    pfluc(iplon,1,i+1) =  totufluc(i)*fluxfac
    pfluc(iplon,2,i+1) = -totdfluc(i)*fluxfac
    pflux(iplon,1,i+1) =  totuflux(i)*fluxfac
    pflux(iplon,2,i+1) = -totdflux(i)*fluxfac
  ENDDO
ENDDO

RETURN
END SUBROUTINE rrtm_rrtm_140gp