rrtm_taumol2.F90

Go to the documentation of this file.

!----------------------------------------------------------------------------
SUBROUTINE rrtm_taumol2 (KLEV,TAU,COLDRY,&
  &tauaerl,fac00,fac01,fac10,fac11,forfac,jp,jt,jt1,&
  &colh2o,laytrop,selffac,selffrac,indself,pfrac)

!     BAND 2:  250-500 cm-1 (low - H2O; high - H2O)

! Modifications
!
!     D Salmond   2000-05-15 speed-up
!     JJMorcrette 2000-05-17 speed-up
!     JJMorcrette 2000-07-14 bugfix


#include "tsmbkind.h"

USE parrrtm  , ONLY : jplay  ,jpband ,jpgpt  ,jpxsec  , ngs1
USE yoerrtwn , ONLY : ng     ,nspa   ,nspb
USE yoerrta2 , ONLY : ng2    ,absa   ,absb   ,fracrefa, fracrefb,&
            &forref   ,ka     ,kb     ,selfref , refparam
USE yoerrtbg2, ONLY : corr1  ,corr2

!  Input
!#include "yoeratm.h"


IMPLICIT NONE

real_b :: coldry(jplay)

!  Output
real_b :: tau(jpgpt,jplay)

!     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 PROFDATA             
real_b :: colh2o(jplay)
integer_m :: laytrop

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

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

real_b :: fc00(jplay),fc01(jplay),fc10(jplay),fc11(jplay)
!      REAL TAUAER(JPLAY)
real_b :: fracint(jplay)
integer_m :: ind0(jplay),ind1(jplay),inds(jplay), index(jplay)

!     LOCAL INTEGER SCALARS
integer_m :: ifp, ifrac, ig, jfrac, lay

!     LOCAL REAL SCALARS
real_b :: fp, h2oparam, water

!      EQUIVALENCE (TAUAERL(1,2),TAUAER)

!     Compute the optical depth by interpolating in ln(pressure) and 
!     temperature.  Below LAYTROP, the water vapor self-continuum is 
!     interpolated (in temperature) separately.

DO lay = 1, laytrop
  water = 1.e20_jprb * colh2o(lay) / coldry(lay)
  h2oparam = water/(water +.002_jprb)
  
!  DO IFRAC = 2, 12
!    IF (H2OPARAM  >=  REFPARAM(IFRAC)) GO TO 1900
!  ENDDO
!  1900 CONTINUE
!  FRACINT(LAY) = (H2OPARAM-REFPARAM(IFRAC))/&
!   &(REFPARAM(IFRAC-1)-REFPARAM(IFRAC))

  IF (h2oparam >= refparam(2)) THEN
    index(lay)=2
  ELSE
    DO jfrac = 2, 12
      IF (h2oparam < refparam(jfrac)) THEN
        index(lay)=jfrac+1
      END IF  
    ENDDO
  ENDIF  
  
!---- JJM_000714
  ifrac=index(lay)
  fracint(lay) = (h2oparam-refparam(ifrac))/&
   &(refparam(ifrac-1)-refparam(ifrac))
ENDDO

DO lay = 1, laytrop

  fp = fac11(lay) + fac01(lay)
  ifp = 2.e2_jprb*fp+_half_

!---MI 981104        
!       IF (IFP.LE.0) IFP=0

  ifp=max(0,int(ifp))

  fc00(lay) = fac00(lay) * corr2(ifp)
  fc10(lay) = fac10(lay) * corr2(ifp)
  fc01(lay) = fac01(lay) * corr1(ifp)
  fc11(lay) = fac11(lay) * corr1(ifp)
  ind0(lay) = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1
  ind1(lay) = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1
  inds(lay) = indself(lay)
ENDDO

!-- DS_000515  
DO ig = 1, ng2
  DO lay = 1, laytrop
!-- JJM_000714
    ifrac=index(lay)  
!-- DS_000515  
    tau(ngs1+ig,lay) = colh2o(lay) *&
     &(fc00(lay) * absa(ind0(lay)  ,ig) +&
     & fc10(lay) * absa(ind0(lay)+1,ig) +&
     & fc01(lay) * absa(ind1(lay)  ,ig) +&
     & fc11(lay) * absa(ind1(lay)+1,ig) +&
     &selffac(lay) * (selfref(inds(lay),ig) + &
     &selffrac(lay) *&
     &(selfref(inds(lay)+1,ig) - selfref(inds(lay),ig)))&
     &+ forfac(lay) * forref(ig) ) &
     &+ tauaerl(lay,2)
    pfrac(ngs1+ig,lay) = fracrefa(ig,ifrac) + fracint(lay) *&
     &(fracrefa(ig,ifrac-1)-fracrefa(ig,ifrac))
  ENDDO
ENDDO

DO lay = laytrop+1, klev
  fp = fac11(lay) + fac01(lay)
  ifp = 2.e2_jprb*fp+_half_

!---MI 981104        
  IF (ifp <= 0) ifp=0

  fc00(lay) = fac00(lay) * corr2(ifp)
  fc10(lay) = fac10(lay) * corr2(ifp)
  fc01(lay) = fac01(lay) * corr1(ifp)
  fc11(lay) = fac11(lay) * corr1(ifp)
  ind0(lay) = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1
  ind1(lay) = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1
ENDDO

!-- JJM_000517
DO ig = 1, ng2
  DO lay = laytrop+1, klev
!-- JJM_000517
    tau(ngs1+ig,lay) = colh2o(lay) *&
     &(fc00(lay) * absb(ind0(lay)  ,ig) +&
     & fc10(lay) * absb(ind0(lay)+1,ig) +&
     & fc01(lay) * absb(ind1(lay)  ,ig) +&
     & fc11(lay) * absb(ind1(lay)+1,ig)&
     &+ forfac(lay) * forref(ig) ) &
     &+ tauaerl(lay,2)
    pfrac(ngs1+ig,lay) = fracrefb(ig)
  ENDDO
ENDDO

RETURN
END SUBROUTINE rrtm_taumol2