rrtm_setcoef_140gp.F90

Go to the documentation of this file.

SUBROUTINE rrtm_setcoef_140gp (KLEV,P_COLDRY,P_WKL,&
 & p_fac00,p_fac01,p_fac10,p_fac11,p_forfac,k_jp,k_jt,k_jt1,&
 & p_colh2o,p_colco2,p_colo3,p_coln2o,p_colch4,p_colo2,p_co2mult,&
 & k_laytrop,k_layswtch,k_laylow,pavel,p_tavel,p_selffac,p_selffrac,k_indself)  

!     Reformatted for F90 by JJMorcrette, ECMWF, 980714

!     Purpose:  For a given atmosphere, calculate the indices and
!     fractions related to the pressure and temperature interpolations.
!     Also calculate the values of the integrated Planck functions 
!     for each band at the level and layer temperatures.

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

USE parrrtm  , ONLY : jplay     ,jpinpx
USE yoerrtrf , ONLY :       preflog   ,tref

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLDRY(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_WKL(jpinpx,jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_FAC00(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_FAC01(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_FAC10(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_FAC11(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_FORFAC(jplay) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: K_JP(jplay) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: K_JT(jplay) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: K_JT1(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_COLH2O(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_COLCO2(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_COLO3(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_COLN2O(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_COLCH4(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_COLO2(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_CO2MULT(jplay) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: K_LAYTROP 
INTEGER(KIND=JPIM),INTENT(OUT)   :: K_LAYSWTCH 
INTEGER(KIND=JPIM),INTENT(OUT)   :: K_LAYLOW 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PAVEL(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_TAVEL(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_SELFFAC(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_SELFFRAC(jplay) 
INTEGER(KIND=JPIM),INTENT(OUT)   :: K_INDSELF(jplay) 
!- from INTFAC      
!- from INTIND
!- from PROFDATA             
!- from PROFILE             
!- from SELF             
INTEGER(KIND=JPIM) :: JP1, I_LAY

REAL(KIND=JPRB) :: Z_CO2REG, Z_COMPFP, Z_FACTOR, Z_FP, Z_FT, Z_FT1, Z_PLOG, Z_SCALEFAC, Z_STPFAC, Z_WATER
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!#include "yoeratm.h"    

IF (lhook) CALL dr_hook('RRTM_SETCOEF_140GP',0,zhook_handle)
z_stpfac = 296._jprb/1013._jprb

k_laytrop  = 0
k_layswtch = 0
k_laylow   = 0
DO i_lay = 1, klev
!        Find the two reference pressures on either side of the
!        layer pressure.  Store them in JP and JP1.  Store in FP the
!        fraction of the difference (in ln(pressure)) between these
!        two values that the layer pressure lies.
  z_plog = log(pavel(i_lay))
  k_jp(i_lay) = int(36._jprb - 5*(z_plog+0.04_jprb))
  IF (k_jp(i_lay)  <  1) THEN
    k_jp(i_lay) = 1
  ELSEIF (k_jp(i_lay)  >  58) THEN
    k_jp(i_lay) = 58
  ENDIF
  jp1 = k_jp(i_lay) + 1
  z_fp = 5._jprb * (preflog(k_jp(i_lay)) - z_plog)

!        Determine, for each reference pressure (JP and JP1), which
!        reference temperature (these are different for each  
!        reference pressure) is nearest the layer temperature but does
!        not exceed it.  Store these indices in JT and JT1, resp.
!        Store in FT (resp. FT1) the fraction of the way between JT
!        (JT1) and the next highest reference temperature that the 
!        layer temperature falls.

  k_jt(i_lay) = int(3._jprb + (p_tavel(i_lay)-tref(k_jp(i_lay)))/15._jprb)
  IF (k_jt(i_lay)  <  1) THEN
    k_jt(i_lay) = 1
  ELSEIF (k_jt(i_lay)  >  4) THEN
    k_jt(i_lay) = 4
  ENDIF
  z_ft = ((p_tavel(i_lay)-tref(k_jp(i_lay)))/15._jprb) - REAL(k_jt(i_lay)-3)
  k_jt1(i_lay) = int(3._jprb + (p_tavel(i_lay)-tref(jp1))/15._jprb)
  IF (k_jt1(i_lay)  <  1) THEN
    k_jt1(i_lay) = 1
  ELSEIF (k_jt1(i_lay)  >  4) THEN
    k_jt1(i_lay) = 4
  ENDIF
  z_ft1 = ((p_tavel(i_lay)-tref(jp1))/15._jprb) - REAL(k_jt1(i_lay)-3)

  z_water = p_wkl(1,i_lay)/p_coldry(i_lay)
  z_scalefac = pavel(i_lay) * z_stpfac / p_tavel(i_lay)

!        If the pressure is less than ~100mb, perform a different
!        set of species interpolations.
!         IF (PLOG .LE. 4.56) GO TO 5300
!--------------------------------------         
  IF (z_plog  >  4.56_jprb) THEN
    k_laytrop =  k_laytrop + 1
!        For one band, the "switch" occurs at ~300 mb. 
    IF (z_plog  >=  5.76_jprb) k_layswtch = k_layswtch + 1
    IF (z_plog  >=  6.62_jprb) k_laylow = k_laylow + 1

    p_forfac(i_lay) = z_scalefac / (1.0_jprb+z_water)

!        Set up factors needed to separately include the water vapor
!        self-continuum in the calculation of absorption coefficient.
!C           SELFFAC(LAY) = WATER * SCALEFAC / (1.+WATER)
    p_selffac(i_lay) = z_water * p_forfac(i_lay)
    z_factor = (p_tavel(i_lay)-188.0_jprb)/7.2_jprb
    k_indself(i_lay) = min(9, max(1, int(z_factor)-7))
    p_selffrac(i_lay) = z_factor - REAL(K_INDSELF(I_LAY) + 7)

!        Calculate needed column amounts.
    p_colh2o(i_lay) = 1.e-20_jprb * p_wkl(1,i_lay)
    p_colco2(i_lay) = 1.e-20_jprb * p_wkl(2,i_lay)
    p_colo3(i_lay)  = 1.e-20_jprb * p_wkl(3,i_lay)
    p_coln2o(i_lay) = 1.e-20_jprb * p_wkl(4,i_lay)
    p_colch4(i_lay) = 1.e-20_jprb * p_wkl(6,i_lay)
    p_colo2(i_lay)  = 1.e-20_jprb * p_wkl(7,i_lay)
    IF (p_colco2(i_lay)  ==  0.0_jprb) p_colco2(i_lay) = 1.e-32_jprb * p_coldry(i_lay)
    IF (p_coln2o(i_lay)  ==  0.0_jprb) p_coln2o(i_lay) = 1.e-32_jprb * p_coldry(i_lay)
    IF (p_colch4(i_lay)  ==  0.0_jprb) p_colch4(i_lay) = 1.e-32_jprb * p_coldry(i_lay)
!        Using E = 1334.2 cm-1.
    z_co2reg = 3.55e-24_jprb * p_coldry(i_lay)
    p_co2mult(i_lay)= (p_colco2(i_lay) - z_co2reg) *&
     & 272.63_jprb*exp(-1919.4_jprb/p_tavel(i_lay))/(8.7604e-4_jprb*p_tavel(i_lay))  
!         GO TO 5400
!------------------
  ELSE
!        Above LAYTROP.
! 5300    CONTINUE

!        Calculate needed column amounts.
    p_forfac(i_lay) = z_scalefac / (1.0_jprb+z_water)

    p_colh2o(i_lay) = 1.e-20_jprb * p_wkl(1,i_lay)
    p_colco2(i_lay) = 1.e-20_jprb * p_wkl(2,i_lay)
    p_colo3(i_lay)  = 1.e-20_jprb * p_wkl(3,i_lay)
    p_coln2o(i_lay) = 1.e-20_jprb * p_wkl(4,i_lay)
    p_colch4(i_lay) = 1.e-20_jprb * p_wkl(6,i_lay)
    p_colo2(i_lay)  = 1.e-20_jprb * p_wkl(7,i_lay)
    IF (p_colco2(i_lay)  ==  0.0_jprb) p_colco2(i_lay) = 1.e-32_jprb * p_coldry(i_lay)
    IF (p_coln2o(i_lay)  ==  0.0_jprb) p_coln2o(i_lay) = 1.e-32_jprb * p_coldry(i_lay)
    IF (p_colch4(i_lay)  ==  0.0_jprb) p_colch4(i_lay) = 1.e-32_jprb * p_coldry(i_lay)
    z_co2reg = 3.55e-24_jprb * p_coldry(i_lay)
    p_co2mult(i_lay)= (p_colco2(i_lay) - z_co2reg) *&
     & 272.63_jprb*exp(-1919.4_jprb/p_tavel(i_lay))/(8.7604e-4_jprb*p_tavel(i_lay))  
!----------------     
  ENDIF
! 5400    CONTINUE

!        We have now isolated the layer ln pressure and temperature,
!        between two reference pressures and two reference temperatures 
!        (for each reference pressure).  We multiply the pressure 
!        fraction FP with the appropriate temperature fractions to get 
!        the factors that will be needed for the interpolation that yields
!        the optical depths (performed in routines TAUGBn for band n).

  z_compfp = 1.0_jprb - z_fp
  p_fac10(i_lay) = z_compfp * z_ft
  p_fac00(i_lay) = z_compfp * (1.0_jprb - z_ft)
  p_fac11(i_lay) = z_fp * z_ft1
  p_fac01(i_lay) = z_fp * (1.0_jprb - z_ft1)

ENDDO

! MT 981104 
!-- Set LAYLOW for profiles with surface pressure less than 750 hPa. 
IF (k_laylow == 0) k_laylow=1

IF (lhook) CALL dr_hook('RRTM_SETCOEF_140GP',1,zhook_handle)
END SUBROUTINE rrtm_setcoef_140gp