rrtm_taumol8.F90

Go to the documentation of this file.

!*******************************************************************************
SUBROUTINE rrtm_taumol8 (KLEV,TAU,WX,&
  &tauaerl,fac00,fac01,fac10,fac11,jp,jt,jt1,&
  &colh2o,colo3,coln2o,co2mult,layswtch,selffac,selffrac,indself,pfrac)

!     BAND 8:  1080-1180 cm-1 (low (i.e.>~300mb) - H2O; high - O3)

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


#include "tsmbkind.h"

USE parrrtm  , ONLY : jplay  ,jpband ,jpgpt  ,jpxsec  , ngs7
USE yoerrtwn , ONLY : ng     ,nspa   ,nspb
USE yoerrta8 , ONLY : ng8    ,absa   ,absb   ,fracrefa, fracrefb,&
            &ka      , kb     ,selfref,absco2a , absco2b ,&
            &absn2oa , absn2ob,cfc12  ,cfc22adj, h2oref  ,&
            &n2oref  , o3ref

!  Input
!#include "yoeratm.h"


IMPLICIT NONE

real_b :: wx(jpxsec,jplay)             ! Amount of trace gases
!  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)

!- from INTIND
integer_m :: jp(jplay)
integer_m :: jt(jplay)
integer_m :: jt1(jplay)

!- from PROFDATA             
real_b :: colh2o(jplay)
real_b :: colo3(jplay)
real_b :: coln2o(jplay)
real_b :: co2mult(jplay)
integer_m :: layswtch

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

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

integer_m :: ind0(jplay),ind1(jplay),inds(jplay)

!      REAL TAUAER(JPLAY)
real_b :: n2omult(jplay)

!     LOCAL INTEGER SCALARS
integer_m :: ig, lay

!     LOCAL REAL SCALARS
real_b :: colref1, colref2, currn2o, fp, ratio, wcomb1, wcomb2

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

!     Compute the optical depth by interpolating in ln(pressure) and 
!     temperature.  

DO lay = 1, layswtch
  fp = fac01(lay) + fac11(lay)
  ind0(lay) = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1
  ind1(lay) = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1
  inds(lay) = indself(lay)
  colref1 = n2oref(jp(lay))
  colref2 = n2oref(jp(lay)+1)
  wcomb1 = _one_/h2oref(jp(lay))
  wcomb2 = _one_/h2oref(jp(lay)+1)
  ratio = (colref1*wcomb1)+fp*((colref2*wcomb2)-(colref1*wcomb1))
  currn2o = colh2o(lay) * ratio
  n2omult(lay) = coln2o(lay) - currn2o
ENDDO

!-- DS_000515
DO ig = 1, ng8
  DO lay = 1, layswtch
!-- DS_000515
    tau(ngs7+ig,lay) = colh2o(lay) *&
     &(fac00(lay) * absa(ind0(lay)  ,ig) +&
     & fac10(lay) * absa(ind0(lay)+1,ig) +&
     & fac01(lay) * absa(ind1(lay)  ,ig) +&
     & fac11(lay) * absa(ind1(lay)+1,ig) +&
     &selffac(lay) * (selfref(inds(lay),ig) + &
     &selffrac(lay) *&
     &(selfref(inds(lay)+1,ig) - selfref(inds(lay),ig))))&
     &+ wx(3,lay) * cfc12(ig)&
     &+ wx(4,lay) * cfc22adj(ig)&
     &+ co2mult(lay) * absco2a(ig)&
     &+ n2omult(lay) * absn2oa(ig)&
     &+ tauaerl(lay,8)
    pfrac(ngs7+ig,lay) = fracrefa(ig)
  ENDDO
ENDDO

DO lay = layswtch+1, klev
  fp = fac01(lay) + fac11(lay)
  ind0(lay) = ((jp(lay)-7)*5+(jt(lay)-1))*nspb(8) + 1
  ind1(lay) = ((jp(lay)-6)*5+(jt1(lay)-1))*nspb(8) + 1
  colref1 = n2oref(jp(lay))
  colref2 = n2oref(jp(lay)+1)
  wcomb1 = _one_/o3ref(jp(lay))
  wcomb2 = _one_/o3ref(jp(lay)+1)
  ratio = (colref1*wcomb1)+fp*((colref2*wcomb2)-(colref1*wcomb1))
  currn2o = colo3(lay) * ratio
  n2omult(lay) = coln2o(lay) - currn2o
ENDDO

!-- JJM_000517
DO ig = 1, ng8
  DO lay = layswtch+1, klev
!-- JJM_000517
    tau(ngs7+ig,lay) = colo3(lay) *&
     &(fac00(lay) * absb(ind0(lay)  ,ig) +&
     & fac10(lay) * absb(ind0(lay)+1,ig) +&
     & fac01(lay) * absb(ind1(lay)  ,ig) +&
     & fac11(lay) * absb(ind1(lay)+1,ig)) &
     &+ wx(3,lay) * cfc12(ig)&
     &+ wx(4,lay) * cfc22adj(ig)&
     &+ co2mult(lay) * absco2b(ig)&
     &+ n2omult(lay) * absn2ob(ig)&
     &+ tauaerl(lay,8)
    pfrac(ngs7+ig,lay) = fracrefb(ig)
  ENDDO
ENDDO

RETURN
END SUBROUTINE rrtm_taumol8