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,&
 & p_zemis , p_zemiw,&
 & pq    , pcco2 , pozn,&
 & pcldf , ptaucld,&
 & ptau_lw,&
 & 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

USE parkind1  ,ONLY : jpim     ,jprb
USE yomhook   ,ONLY : lhook,   dr_hook
USE yoerad    ,ONLY : nlw
USE parrrtm  , ONLY : jpband   ,jpxsec   ,jpgpt    ,jplay    ,&
 & jpinpx  
!------------------------------Arguments--------------------------------

! Input arguments

IMPLICIT NONE
INTEGER(KIND=JPIM),INTENT(IN)    :: KLON! Number of atmospheres (longitudes) 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV! Number of atmospheric layers 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA ! First atmosphere index
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA ! Last atmosphere index
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAER(klon,6,klev) ! Aerosol optical thickness
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPH(klon,klev+1) ! Interface pressures (Pa)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAP(klon,klev) ! Layer pressures (Pa)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTS(klon) ! Surface temperature (I_K)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTH(klon,klev+1) ! Interface temperatures (I_K)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PT(klon,klev) ! Layer temperature (I_K)
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ZEMIS(klon) ! Non-window surface emissivity
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ZEMIW(klon) ! Window surface emissivity
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQ(klon,klev) ! H2O specific humidity (mmr)
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCCO2 ! CO2 mass mixing ratio
REAL(KIND=JPRB)   ,INTENT(IN)    :: POZN(klon,klev) ! O3 mass mixing ratio
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLDF(klon,klev) ! Cloud fraction
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUCLD(klon,klev,jpband) ! Cloud optical depth
!--C.Kleinschmitt
REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAU_LW(klon,klev,nlw) ! LW Optical depth of aerosols
!--end
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PEMIT(klon) ! Surface LW emissivity
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFLUX(klon,2,klev+1) ! LW total sky flux (1=up, 2=down)
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFLUC(klon,2,klev+1) ! LW clear sky flux (1=up, 2=down)
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTCLEAR(klon) ! clear-sky fraction of column
INTEGER(KIND=JPIM) :: ICLDLYR(jplay)        ! Cloud indicator
REAL(KIND=JPRB) :: Z_CLDFRAC(jplay)           ! Cloud fraction
REAL(KIND=JPRB) :: Z_TAUCLD(jplay,jpband)     ! Spectral optical thickness

REAL(KIND=JPRB) :: Z_ABSS1 (jpgpt*jplay)
REAL(KIND=JPRB) :: Z_ATR1  (jpgpt,jplay)
equivalence(z_abss1(1),z_atr1(1,1))

REAL(KIND=JPRB) :: Z_OD    (jpgpt,jplay)

REAL(KIND=JPRB) :: Z_TAUSF1(jpgpt*jplay)
REAL(KIND=JPRB) :: Z_TF1   (jpgpt,jplay)
equivalence(z_tausf1(1),z_tf1(1,1))

REAL(KIND=JPRB) :: Z_COLDRY(jplay)
REAL(KIND=JPRB) :: Z_WKL(jpinpx,jplay)

REAL(KIND=JPRB) :: Z_WX(jpxsec,jplay)         ! Amount of trace gases

REAL(KIND=JPRB) :: Z_CLFNET  (0:jplay)
REAL(KIND=JPRB) :: Z_CLHTR   (0:jplay)
REAL(KIND=JPRB) :: Z_FNET    (0:jplay)
REAL(KIND=JPRB) :: Z_HTR     (0:jplay)
REAL(KIND=JPRB) :: Z_TOTDFLUC(0:jplay)
REAL(KIND=JPRB) :: Z_TOTDFLUX(0:jplay)
REAL(KIND=JPRB) :: Z_TOTUFLUC(0:jplay)
REAL(KIND=JPRB) :: Z_TOTUFLUX(0:jplay)

INTEGER(KIND=JPIM) :: i, icld, iplon, I_K
INTEGER(KIND=JPIM) :: ISTART
INTEGER(KIND=JPIM) :: IEND

REAL(KIND=JPRB) :: Z_FLUXFAC, Z_HEATFAC, Z_PI, ZEPSEC, ZTCLEAR

!- from AER
REAL(KIND=JPRB) :: Z_TAUAERL(jplay,jpband)

!- from INTFAC      
REAL(KIND=JPRB) :: Z_FAC00(jplay)
REAL(KIND=JPRB) :: Z_FAC01(jplay)
REAL(KIND=JPRB) :: Z_FAC10(jplay)
REAL(KIND=JPRB) :: Z_FAC11(jplay)
REAL(KIND=JPRB) :: Z_FORFAC(jplay)

!- from INTIND
INTEGER(KIND=JPIM) :: JP(jplay)
INTEGER(KIND=JPIM) :: JT(jplay)
INTEGER(KIND=JPIM) :: JT1(jplay)

!- from PRECISE             
REAL(KIND=JPRB) :: Z_ONEMINUS

!- from PROFDATA             
REAL(KIND=JPRB) :: Z_COLH2O(jplay)
REAL(KIND=JPRB) :: Z_COLCO2(jplay)
REAL(KIND=JPRB) :: Z_COLO3 (jplay)
REAL(KIND=JPRB) :: Z_COLN2O(jplay)
REAL(KIND=JPRB) :: Z_COLCH4(jplay)
REAL(KIND=JPRB) :: Z_COLO2 (jplay)
REAL(KIND=JPRB) :: Z_CO2MULT(jplay)
INTEGER(KIND=JPIM) :: I_LAYTROP
INTEGER(KIND=JPIM) :: I_LAYSWTCH
INTEGER(KIND=JPIM) :: I_LAYLOW

!- from PROFILE             
REAL(KIND=JPRB) :: Z_PAVEL(jplay)
REAL(KIND=JPRB) :: Z_TAVEL(jplay)
REAL(KIND=JPRB) :: Z_PZ(0:jplay)
REAL(KIND=JPRB) :: Z_TZ(0:jplay)
REAL(KIND=JPRB) :: Z_TBOUND
INTEGER(KIND=JPIM) :: I_NLAYERS

!- from SELF             
REAL(KIND=JPRB) :: Z_SELFFAC(jplay)
REAL(KIND=JPRB) :: Z_SELFFRAC(jplay)
INTEGER(KIND=JPIM) :: INDSELF(jplay)

!- from SP             
REAL(KIND=JPRB) :: Z_PFRAC(jpgpt,jplay)

!- from SURFACE             
REAL(KIND=JPRB) :: Z_SEMISS(jpband)
REAL(KIND=JPRB) :: Z_SEMISLW
INTEGER(KIND=JPIM) :: IREFLECT
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "rrtm_ecrt_140gp.intfb.h"
#include "rrtm_gasabs1a_140gp.intfb.h"
#include "rrtm_rtrn1a_140gp.intfb.h"
#include "rrtm_setcoef_140gp.intfb.h"

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

IF (lhook) CALL dr_hook('RRTM_RRTM_140GP',0,zhook_handle)
zepsec = 1.e-06_jprb
z_oneminus = 1.0_jprb - zepsec
z_pi = 2.0_jprb*asin(1.0_jprb)
z_fluxfac = z_pi * 2.d4
z_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=1.0_jprb

  CALL rrtm_ecrt_140gp &
   & ( iplon, klon , klev, icld,&
   & paer , paph , pap,&
   & pts  , pth  , pt,&
   & p_zemis, p_zemiw,&
   & pq   , pcco2, pozn, pcldf, ptaucld, ztclear,&
   & z_cldfrac,z_taucld,&
   & ptau_lw,&
   & z_coldry,z_wkl,z_wx,&
   & z_tauaerl,z_pavel,z_tavel,z_pz,z_tz,z_tbound,i_nlayers,z_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. 

  CALL rrtm_setcoef_140gp (klev,z_coldry,z_wkl,&
   & z_fac00,z_fac01,z_fac10,z_fac11,z_forfac,jp,jt,jt1,&
   & z_colh2o,z_colco2,z_colo3,z_coln2o,z_colch4,z_colo2,z_co2mult,&
   & i_laytrop,i_layswtch,i_laylow,z_pavel,z_tavel,z_selffac,z_selffrac,indself)  

  CALL rrtm_gasabs1a_140gp (klev,z_atr1,z_od,z_tf1,z_coldry,z_wx,&
   & z_tauaerl,z_fac00,z_fac01,z_fac10,z_fac11,z_forfac,jp,jt,jt1,z_oneminus,&
   & z_colh2o,z_colco2,z_colo3,z_coln2o,z_colch4,z_colo2,z_co2mult,&
   & i_laytrop,i_layswtch,i_laylow,z_selffac,z_selffrac,indself,z_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 i_k = 1, klev
    IF (icld == 1.AND.z_cldfrac(i_k) > zepsec) THEN
      icldlyr(i_k) = 1
    ELSE
      icldlyr(i_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.

  CALL rrtm_rtrn1a_140gp (klev,istart,iend,icldlyr,z_cldfrac,z_taucld,z_abss1,&
   & z_od,z_tausf1,z_clfnet,z_clhtr,z_fnet,z_htr,z_totdfluc,z_totdflux,z_totufluc,z_totuflux,&
   & z_tavel,z_pz,z_tz,z_tbound,z_pfrac,z_semiss,z_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) = z_semislw
  DO i = 0, klev
    pfluc(iplon,1,i+1) =  z_totufluc(i)*z_fluxfac
    pfluc(iplon,2,i+1) = -z_totdfluc(i)*z_fluxfac
    pflux(iplon,1,i+1) =  z_totuflux(i)*z_fluxfac
    pflux(iplon,2,i+1) = -z_totdflux(i)*z_fluxfac
  ENDDO
ENDDO

IF (lhook) CALL dr_hook('RRTM_RRTM_140GP',1,zhook_handle)
END SUBROUTINE rrtm_rrtm_140gp