rrtm_taumol3.F90

Go to the documentation of this file.

!----------------------------------------------------------------------------
SUBROUTINE rrtm_taumol3 (KLEV,P_TAU,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,p_forfac,k_jp,k_jt,k_jt1,p_oneminus,&
 & p_colh2o,p_colco2,p_coln2o,k_laytrop,p_selffac,p_selffrac,k_indself,pfrac)  

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

! Modifications
!        M.Hamrud      01-Oct-2003 CY28 Cleaning

!     D Salmond 2000-05-15 speed-up

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

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

!  Input
!#include "yoeratm.h"

!      REAL TAUAER(JPLAY)

IMPLICIT NONE

!  Output
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAU(jpgpt,jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_TAUAERL(jplay,jpband) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC00(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC01(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC10(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC11(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFAC(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_JP(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT1(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ONEMINUS 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLH2O(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLCO2(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLN2O(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYTROP 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFAC(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFRAC(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDSELF(jplay) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFRAC(jpgpt,jplay) 
!- from AER
!- from INTFAC      
!- from INTIND
!- from PRECISE             
!- from PROFDATA             
!- from SELF             
!- from SP             
INTEGER(KIND=JPIM) :: IJS(jplay)
REAL(KIND=JPRB) :: ZFS(jplay),Z_SPECCOMB(jplay)
INTEGER(KIND=JPIM) :: IND0(jplay),IND1(jplay),INDS(jplay)
REAL(KIND=JPRB) :: Z_N2OMULT(jplay)

INTEGER(KIND=JPIM) :: IG, JS, I_LAY, I_NS

REAL(KIND=JPRB) :: Z_COLREF1, Z_COLREF2, Z_CURRN2O, Z_FAC000, Z_FAC001,&
 & Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101, Z_FAC110, Z_FAC111, &
 & Z_FP, Z_FS, Z_RATIO, Z_SPECMULT, Z_SPECPARM, Z_WCOMB1, &
 & Z_WCOMB2  
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

IF (lhook) CALL dr_hook('RRTM_TAUMOL3',0,zhook_handle)
DO i_lay = 1, k_laytrop
  z_speccomb(i_lay) = p_colh2o(i_lay) + strrat*p_colco2(i_lay)
  z_specparm = p_colh2o(i_lay)/z_speccomb(i_lay)
  z_specparm=min(p_oneminus,z_specparm)
  z_specmult = 8._jprb*(z_specparm)
  js = 1 + int(z_specmult)
  z_fs = mod(z_specmult,1.0_jprb)
  IF (js  ==  8) THEN
    IF (z_fs  >=  0.9_jprb) THEN
      js = 9
      z_fs = 10._jprb * (z_fs - 0.9_jprb)
    ELSE
      z_fs = z_fs/0.9_jprb
    ENDIF
  ENDIF

  i_ns = js + int(z_fs + 0.5_jprb)
  z_fp = p_fac01(i_lay) + p_fac11(i_lay)
  ind0(i_lay) = ((k_jp(i_lay)-1)*5+(k_jt(i_lay)-1))*nspa(3) + js
  ind1(i_lay) = (k_jp(i_lay)*5+(k_jt1(i_lay)-1))*nspa(3) + js
  inds(i_lay) = k_indself(i_lay)
  z_colref1 = n2oref(k_jp(i_lay))
  z_colref2 = n2oref(k_jp(i_lay)+1)
  IF (i_ns  ==  10) THEN
    z_wcomb1 = 1.0_jprb/h2oref(k_jp(i_lay))
    z_wcomb2 = 1.0_jprb/h2oref(k_jp(i_lay)+1)
  ELSE
    z_wcomb1 = (1.0_jprb-etaref(i_ns))/(strrat * co2ref(k_jp(i_lay)))
    z_wcomb2 = (1.0_jprb-etaref(i_ns))/(strrat * co2ref(k_jp(i_lay)+1))
  ENDIF
  z_ratio = (z_colref1*z_wcomb1)+z_fp*((z_colref2*z_wcomb2)-(z_colref1*z_wcomb1))
  z_currn2o = z_speccomb(i_lay) * z_ratio
  z_n2omult(i_lay) = p_coln2o(i_lay) - z_currn2o

  zfs(i_lay)=z_fs
  ijs(i_lay)=js

ENDDO

!-- DS_000515
DO ig = 1, ng3
  DO i_lay = 1, k_laytrop
!-- DS_000515

    z_fs=zfs(i_lay)
    js=ijs(i_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)
!------        

    p_tau(ngs2+ig,i_lay) = z_speccomb(i_lay) *   &
     !-- DS_000515
     & ( (1. - z_fs) *(p_fac00(i_lay) * absa(ind0(i_lay)   ,ig) +   &
     & p_fac10(i_lay) * absa(ind0(i_lay)+10,ig) +   &
     & p_fac01(i_lay) * absa(ind1(i_lay)   ,ig) +   &
     & p_fac11(i_lay) * absa(ind1(i_lay)+10,ig))+   &
     & z_fs     *(p_fac00(i_lay) * absa(ind0(i_lay)+ 1,ig) +   &
     & p_fac10(i_lay) * absa(ind0(i_lay)+11,ig) +   &
     & p_fac01(i_lay) * absa(ind1(i_lay)+ 1,ig) +   &
     & p_fac11(i_lay) * absa(ind1(i_lay)+11,ig))) + &
     !     &(Z_FAC000 * ABSA(IND0(I_LAY)   ,IG) +&
     !     & Z_FAC100 * ABSA(IND0(I_LAY)+ 1,IG) +&
     !     & Z_FAC010 * ABSA(IND0(I_LAY)+10,IG) +&
     !     & Z_FAC110 * ABSA(IND0(I_LAY)+11,IG) +&
     !     & Z_FAC001 * ABSA(IND1(I_LAY),   IG) +&
     !     & Z_FAC101 * ABSA(IND1(I_LAY)+ 1,IG) +&
     !     & Z_FAC011 * ABSA(IND1(I_LAY)+10,IG) +&
     !     & Z_FAC111 * ABSA(IND1(I_LAY)+11,IG))+&
     !-- DS_000515
     & p_colh2o(i_lay) * &
     & p_selffac(i_lay) * (selfref(inds(i_lay),ig) + &
     & p_selffrac(i_lay) *&
     & (selfref(inds(i_lay)+1,ig) - selfref(inds(i_lay),ig))&
     & + p_forfac(i_lay) * forref(ig) ) &
     & + z_n2omult(i_lay) * absn2oa(ig) &
     & + p_tauaerl(i_lay,3)  
    pfrac(ngs2+ig,i_lay) = fracrefa(ig,js) + z_fs *&
     & (fracrefa(ig,js+1) - fracrefa(ig,js))  
  ENDDO
ENDDO

DO i_lay = k_laytrop+1, klev
  z_speccomb(i_lay) = p_colh2o(i_lay) + strrat*p_colco2(i_lay)
  z_specparm = p_colh2o(i_lay)/z_speccomb(i_lay)
  z_specparm=min(p_oneminus,z_specparm)
  z_specmult = 4._jprb*(z_specparm)
  js = 1 + int(z_specmult)
  z_fs = mod(z_specmult,1.0_jprb)
  i_ns = js + int(z_fs + 0.5_jprb)
  z_fp = p_fac01(i_lay) + p_fac11(i_lay)
  ind0(i_lay) = ((k_jp(i_lay)-13)*5+(k_jt(i_lay)-1))*nspb(3) + js
  ind1(i_lay) = ((k_jp(i_lay)-12)*5+(k_jt1(i_lay)-1))*nspb(3) + js
  z_colref1 = n2oref(k_jp(i_lay))
  z_colref2 = n2oref(k_jp(i_lay)+1)
  IF (i_ns  ==  5) THEN
    z_wcomb1 = 1.0_jprb/h2oref(k_jp(i_lay))
    z_wcomb2 = 1.0_jprb/h2oref(k_jp(i_lay)+1)
  ELSE
    z_wcomb1 = (1.0_jprb-etaref(i_ns))/(strrat * co2ref(k_jp(i_lay)))
    z_wcomb2 = (1.0_jprb-etaref(i_ns))/(strrat * co2ref(k_jp(i_lay)+1))
  ENDIF
  z_ratio = (z_colref1*z_wcomb1)+z_fp*((z_colref2*z_wcomb2)-(z_colref1*z_wcomb1))
  z_currn2o = z_speccomb(i_lay) * z_ratio
  z_n2omult(i_lay) = p_coln2o(i_lay) - z_currn2o

  zfs(i_lay)=z_fs
  ijs(i_lay)=js

ENDDO

DO i_lay = k_laytrop+1, klev

  z_fs=zfs(i_lay)
  js=ijs(i_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
    p_tau(ngs2+ig,i_lay) = z_speccomb(i_lay) *   &
     !-- DS_000515
     & ( (1. - z_fs) *(p_fac00(i_lay) * absb(ind0(i_lay)  ,ig) +   &
     & p_fac10(i_lay) * absb(ind0(i_lay)+5,ig) +   &
     & p_fac01(i_lay) * absb(ind1(i_lay)  ,ig) +    &
     & p_fac11(i_lay) * absb(ind1(i_lay)+5,ig))+   &
     & z_fs     *(p_fac00(i_lay) * absb(ind0(i_lay)+1,ig) +   &
     & p_fac10(i_lay) * absb(ind0(i_lay)+6,ig) +   &
     & p_fac01(i_lay) * absb(ind1(i_lay)+1,ig) +   &
     & p_fac11(i_lay) * absb(ind1(i_lay)+6,ig)))   &
     !     &(Z_FAC000 * ABSB(IND0(I_LAY)  ,IG) +&
     !     & Z_FAC100 * ABSB(IND0(I_LAY)+1,IG) +&
     !     & Z_FAC010 * ABSB(IND0(I_LAY)+5,IG) +&
     !     & Z_FAC110 * ABSB(IND0(I_LAY)+6,IG) +&
     !     & Z_FAC001 * ABSB(IND1(I_LAY)  ,IG) +&
     !     & Z_FAC101 * ABSB(IND1(I_LAY)+1,IG) +&
     !     & Z_FAC011 * ABSB(IND1(I_LAY)+5,IG) +&
     !     & Z_FAC111 * ABSB(IND1(I_LAY)+6,IG))&
     !-- DS_000515
     & + p_colh2o(i_lay)*p_forfac(i_lay)*forref(ig) &
     & + z_n2omult(i_lay) * absn2ob(ig)&
     & + p_tauaerl(i_lay,3)  
    pfrac(ngs2+ig,i_lay) = fracrefb(ig,js) + z_fs *&
     & (fracrefb(ig,js+1) - fracrefb(ig,js))  
  ENDDO
ENDDO

IF (lhook) CALL dr_hook('RRTM_TAUMOL3',1,zhook_handle)
END SUBROUTINE rrtm_taumol3