rrtm_taumol3.F90

Go to the documentation of this file.

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

!     BAND 3:  500-630 cm-1 (low - H2O,CO2; high - H2O,CO2)

! Modifications
!
!     D Salmond 2000-05-15 speed-up


#include "tsmbkind.h"

USE parrrtm  , ONLY : jplay  ,jpband ,jpgpt  ,jpxsec  , ngs2
USE yoerrtwn , ONLY : ng     ,nspa   ,nspb
USE yoerrta3 , ONLY : ng3    ,absa   ,absb   ,fracrefa, fracrefb,&
            &forref   ,ka     ,kb     ,selfref , absn2oa ,&
            &absn2ob  ,etaref ,h2oref ,n2oref  , co2ref  ,&
            &strrat

!  Input
!#include "yoeratm.h"

!      REAL TAUAER(JPLAY)

IMPLICIT NONE

!  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 PRECISE             
real_b :: oneminus

!- from PROFDATA             
real_b :: colh2o(jplay)
real_b :: colco2(jplay)
real_b :: coln2o(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)

integer_m :: ijs(jplay)
real_b :: zfs(jplay),speccomb(jplay)
integer_m :: ind0(jplay),ind1(jplay),inds(jplay)
real_b :: n2omult(jplay)

!     LOCAL INTEGER SCALARS
integer_m :: ig, js, lay, ns

!     LOCAL REAL SCALARS
real_b :: colref1, colref2, currn2o, fac000, fac001,&
          &fac010, fac011, fac100, fac101, fac110, fac111, &
          &fp, fs, ratio, specmult, specparm, wcomb1, &
          &wcomb2

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

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

DO lay = 1, laytrop
  speccomb(lay) = colh2o(lay) + strrat*colco2(lay)
  specparm = colh2o(lay)/speccomb(lay)
  specparm=min(oneminus,specparm)
  specmult = 8._jprb*(specparm)
  js = 1 + int(specmult)
  fs = mod(specmult,_one_)
  IF (js  ==  8) THEN
    IF (fs  >=  0.9_jprb) THEN
      js = 9
      fs = 10._jprb * (fs - 0.9_jprb)
    ELSE
      fs = fs/0.9_jprb
    ENDIF
  ENDIF

  ns = js + int(fs + _half_)
  fp = fac01(lay) + fac11(lay)
  ind0(lay) = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js
  ind1(lay) = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js
  inds(lay) = indself(lay)
  colref1 = n2oref(jp(lay))
  colref2 = n2oref(jp(lay)+1)
  IF (ns  ==  10) THEN
    wcomb1 = _one_/h2oref(jp(lay))
    wcomb2 = _one_/h2oref(jp(lay)+1)
  ELSE
    wcomb1 = (_one_-etaref(ns))/(strrat * co2ref(jp(lay)))
    wcomb2 = (_one_-etaref(ns))/(strrat * co2ref(jp(lay)+1))
  ENDIF
  ratio = (colref1*wcomb1)+fp*((colref2*wcomb2)-(colref1*wcomb1))
  currn2o = speccomb(lay) * ratio
  n2omult(lay) = coln2o(lay) - currn2o

  zfs(lay)=fs
  ijs(lay)=js

ENDDO

!-- DS_000515
DO ig = 1, ng3
  DO lay = 1, laytrop
!-- DS_000515

    fs=zfs(lay)
    js=ijs(lay)

!---jjm
!    FAC000 = (_ONE_ - FS) * FAC00(LAY)
!    FAC010 = (_ONE_ - FS) * FAC10(LAY)
!    FAC100 = FS * FAC00(LAY)
!    FAC110 = FS * FAC10(LAY)
!    FAC001 = (_ONE_ - FS) * FAC01(LAY)
!    FAC011 = (_ONE_ - FS) * FAC11(LAY)
!    FAC101 = FS * FAC01(LAY)
!    FAC111 = FS * FAC11(LAY)
!------        

    tau(ngs2+ig,lay) = speccomb(lay) *   &
!-- DS_000515
     & ( (1. - fs) *(fac00(lay) * absa(ind0(lay)   ,ig) +   &
     &               fac10(lay) * absa(ind0(lay)+10,ig) +   &
     &               fac01(lay) * absa(ind1(lay)   ,ig) +   &
     &               fac11(lay) * absa(ind1(lay)+10,ig))+   &
     &      fs     *(fac00(lay) * absa(ind0(lay)+ 1,ig) +   &
     &               fac10(lay) * absa(ind0(lay)+11,ig) +   &
     &               fac01(lay) * absa(ind1(lay)+ 1,ig) +   &
     &               fac11(lay) * absa(ind1(lay)+11,ig))) + &
!     &(FAC000 * ABSA(IND0(LAY)   ,IG) +&
!     & FAC100 * ABSA(IND0(LAY)+ 1,IG) +&
!     & FAC010 * ABSA(IND0(LAY)+10,IG) +&
!     & FAC110 * ABSA(IND0(LAY)+11,IG) +&
!     & FAC001 * ABSA(IND1(LAY),   IG) +&
!     & FAC101 * ABSA(IND1(LAY)+ 1,IG) +&
!     & FAC011 * ABSA(IND1(LAY)+10,IG) +&
!     & FAC111 * ABSA(IND1(LAY)+11,IG))+&
!-- DS_000515
     &colh2o(lay) * &
     &selffac(lay) * (selfref(inds(lay),ig) + &
     &selffrac(lay) *&
     &(selfref(inds(lay)+1,ig) - selfref(inds(lay),ig))&
     &+ forfac(lay) * forref(ig) ) &
     &+ n2omult(lay) * absn2oa(ig) &
     &+ tauaerl(lay,3)
    pfrac(ngs2+ig,lay) = fracrefa(ig,js) + fs *&
     &(fracrefa(ig,js+1) - fracrefa(ig,js))
  ENDDO
ENDDO

DO lay = laytrop+1, klev
  speccomb(lay) = colh2o(lay) + strrat*colco2(lay)
  specparm = colh2o(lay)/speccomb(lay)
  specparm=min(oneminus,specparm)
  specmult = 4._jprb*(specparm)
  js = 1 + int(specmult)
  fs = mod(specmult,_one_)
  ns = js + int(fs + _half_)
  fp = fac01(lay) + fac11(lay)
  ind0(lay) = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js
  ind1(lay) = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js
  colref1 = n2oref(jp(lay))
  colref2 = n2oref(jp(lay)+1)
  IF (ns  ==  5) THEN
    wcomb1 = _one_/h2oref(jp(lay))
    wcomb2 = _one_/h2oref(jp(lay)+1)
  ELSE
    wcomb1 = (_one_-etaref(ns))/(strrat * co2ref(jp(lay)))
    wcomb2 = (_one_-etaref(ns))/(strrat * co2ref(jp(lay)+1))
  ENDIF
  ratio = (colref1*wcomb1)+fp*((colref2*wcomb2)-(colref1*wcomb1))
  currn2o = speccomb(lay) * ratio
  n2omult(lay) = coln2o(lay) - currn2o

  zfs(lay)=fs
  ijs(lay)=js

ENDDO

DO lay = laytrop+1, klev

  fs=zfs(lay)
  js=ijs(lay)
!---jjm
!  FAC000 = (_ONE_ - FS) * FAC00(LAY)
!  FAC010 = (_ONE_ - FS) * FAC10(LAY)
!  FAC100 = FS * FAC00(LAY)
!  FAC110 = FS * FAC10(LAY)
!  FAC001 = (_ONE_ - FS) * FAC01(LAY)
!  FAC011 = (_ONE_ - FS) * FAC11(LAY)
!  FAC101 = FS * FAC01(LAY)
!  FAC111 = FS * FAC11(LAY)
!---        

  DO ig = 1, ng3
    tau(ngs2+ig,lay) = speccomb(lay) *   &
!-- DS_000515
     & ( (1. - fs) *(fac00(lay) * absb(ind0(lay)  ,ig) +   &
     &               fac10(lay) * absb(ind0(lay)+5,ig) +   &
     &               fac01(lay) * absb(ind1(lay)  ,ig) +   & 
     &               fac11(lay) * absb(ind1(lay)+5,ig))+   &
     &      fs     *(fac00(lay) * absb(ind0(lay)+1,ig) +   &
     &               fac10(lay) * absb(ind0(lay)+6,ig) +   &
     &               fac01(lay) * absb(ind1(lay)+1,ig) +   &
     &               fac11(lay) * absb(ind1(lay)+6,ig)))   &
!     &(FAC000 * ABSB(IND0(LAY)  ,IG) +&
!     & FAC100 * ABSB(IND0(LAY)+1,IG) +&
!     & FAC010 * ABSB(IND0(LAY)+5,IG) +&
!     & FAC110 * ABSB(IND0(LAY)+6,IG) +&
!     & FAC001 * ABSB(IND1(LAY)  ,IG) +&
!     & FAC101 * ABSB(IND1(LAY)+1,IG) +&
!     & FAC011 * ABSB(IND1(LAY)+5,IG) +&
!     & FAC111 * ABSB(IND1(LAY)+6,IG))&
!-- DS_000515
     &+ colh2o(lay)*forfac(lay)*forref(ig) &
     &+ n2omult(lay) * absn2ob(ig)&
     &+ tauaerl(lay,3)
    pfrac(ngs2+ig,lay) = fracrefb(ig,js) + fs *&
     &(fracrefb(ig,js+1) - fracrefb(ig,js))
  ENDDO
ENDDO

RETURN
END SUBROUTINE rrtm_taumol3