rrtm_setcoef_140gp.F90

Go to the documentation of this file.

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

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

#include "tsmbkind.h"

USE parrrtm  , ONLY : jplay     ,jpband    ,jpgpt   ,jpinpx
USE yoerrtrf , ONLY : pref      ,preflog   ,tref

IMPLICIT NONE

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

!     DUMMY INTEGER SCALARS
integer_m :: klev

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

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


!     LOCAL INTEGER SCALARS
integer_m :: jp1, lay

!     LOCAL REAL SCALARS
real_b :: co2reg, compfp, factor, fp, ft, ft1, plog, scalefac, stpfac, water


!#include "yoeratm.h"    

stpfac = 296._jprb/1013._jprb

laytrop  = 0
layswtch = 0
laylow   = 0

!Martin control
!PRINT*,'PAVEL(:)',PAVEL(:)
!PRINT*,'SIZE(PAVEL)',SIZE(PAVEL)
!Martin control

DO 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.
  ! Martin modif to gather MAR and LMDZ:
  IF (pavel(lay) == 0. ) pavel(lay) = (pavel(lay-1))/2.
  plog = log(pavel(lay))
  jp(lay) = int(36._jprb - 5*(plog+0.04_jprb))
  IF (jp(lay)  <  1) THEN
    jp(lay) = 1
  ELSEIF (jp(lay)  >  58) THEN
    jp(lay) = 58
  ENDIF
  jp1 = jp(lay) + 1
  fp = 5._jprb * (preflog(jp(lay)) - 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.
  jt(lay) = int(3._jprb + (tavel(lay)-tref(jp(lay)))/15._jprb)
  IF (jt(lay)  <  1) THEN
    jt(lay) = 1
  ELSEIF (jt(lay)  >  4) THEN
    jt(lay) = 4
  ENDIF
  ft = ((tavel(lay)-tref(jp(lay)))/15._jprb) - REAL(jt(lay)-3)
  jt1(lay) = int(3._jprb + (tavel(lay)-tref(jp1))/15._jprb)
  IF (jt1(lay)  <  1) THEN
    jt1(lay) = 1
  ELSEIF (jt1(lay)  >  4) THEN
    jt1(lay) = 4
  ENDIF
  ft1 = ((tavel(lay)-tref(jp1))/15._jprb) - REAL(jt1(lay)-3)

  water = wkl(1,lay)/coldry(lay)
  scalefac = pavel(lay) * stpfac / tavel(lay)

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

    forfac(lay) = scalefac / (_one_+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)
    selffac(lay) = water * forfac(lay)
    factor = (tavel(lay)-188.0_jprb)/7.2_jprb
    indself(lay) = min(9, max(1, int(factor)-7))
    selffrac(lay) = factor - REAL(INDSELF(LAY) + 7)

!        Calculate needed column amounts.
    colh2o(lay) = 1.e-20_jprb * wkl(1,lay)
    colco2(lay) = 1.e-20_jprb * wkl(2,lay)
    colo3(lay)  = 1.e-20_jprb * wkl(3,lay)
    coln2o(lay) = 1.e-20_jprb * wkl(4,lay)
    colch4(lay) = 1.e-20_jprb * wkl(6,lay)
    colo2(lay)  = 1.e-20_jprb * wkl(7,lay)
    IF (colco2(lay)  ==  _zero_) colco2(lay) = 1.e-32_jprb * coldry(lay)
    IF (coln2o(lay)  ==  _zero_) coln2o(lay) = 1.e-32_jprb * coldry(lay)
    IF (colch4(lay)  ==  _zero_) colch4(lay) = 1.e-32_jprb * coldry(lay)
!        Using E = 1334.2 cm-1.
    co2reg = 3.55e-24_jprb * coldry(lay)
    co2mult(lay)= (colco2(lay) - co2reg) *&
     &272.63_jprb*exp(-1919.4_jprb/tavel(lay))/(8.7604e-4_jprb*tavel(lay))
!         GO TO 5400
!------------------
  ELSE
!        Above LAYTROP.
! 5300    CONTINUE

!        Calculate needed column amounts.
    forfac(lay) = scalefac / (_one_+water)

    colh2o(lay) = 1.e-20_jprb * wkl(1,lay)
    colco2(lay) = 1.e-20_jprb * wkl(2,lay)
    colo3(lay)  = 1.e-20_jprb * wkl(3,lay)
    coln2o(lay) = 1.e-20_jprb * wkl(4,lay)
    colch4(lay) = 1.e-20_jprb * wkl(6,lay)
    colo2(lay)  = 1.e-20_jprb * wkl(7,lay)
    IF (colco2(lay)  ==  _zero_) colco2(lay) = 1.e-32_jprb * coldry(lay)
    IF (coln2o(lay)  ==  _zero_) coln2o(lay) = 1.e-32_jprb * coldry(lay)
    IF (colch4(lay)  ==  _zero_) colch4(lay) = 1.e-32_jprb * coldry(lay)
    co2reg = 3.55e-24_jprb * coldry(lay)
    co2mult(lay)= (colco2(lay) - co2reg) *&
     &272.63_jprb*exp(-1919.4_jprb/tavel(lay))/(8.7604e-4_jprb*tavel(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).

  compfp = _one_ - fp
  fac10(lay) = compfp * ft
  fac00(lay) = compfp * (_one_ - ft)
  fac11(lay) = fp * ft1
  fac01(lay) = fp * (_one_ - ft1)

ENDDO

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

RETURN
END SUBROUTINE rrtm_setcoef_140gp