rrtm_taumol8.F90

Go to the documentation of this file.

!*******************************************************************************
SUBROUTINE rrtm_taumol8 (KLEV,P_TAU,P_WX,&
 & p_tauaerl,p_fac00,p_fac01,p_fac10,p_fac11,k_jp,k_jt,k_jt1,&
 & p_colh2o,p_colo3,p_coln2o,p_co2mult,k_layswtch,p_selffac,p_selffrac,k_indself,pfrac)  

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

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

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

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

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

!  Input
!#include "yoeratm.h"

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAU(jpgpt,jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_WX(jpxsec,jplay) ! Amount of trace gases
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) 
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_COLH2O(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLO3(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLN2O(jplay) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_CO2MULT(jplay) 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYSWTCH 
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) 
!  Output
!- from AER
!- from INTFAC      
!- from INTIND
!- from PROFDATA             
!- from SELF             
!- from SP             
INTEGER(KIND=JPIM) :: IND0(jplay),IND1(jplay),INDS(jplay)

!      REAL TAUAER(JPLAY)
REAL(KIND=JPRB) :: Z_N2OMULT(jplay)

INTEGER(KIND=JPIM) :: IG, I_LAY

REAL(KIND=JPRB) :: Z_COLREF1, Z_COLREF2, Z_CURRN2O, Z_FP, Z_RATIO, Z_WCOMB1, Z_WCOMB2
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

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

IF (lhook) CALL dr_hook('RRTM_TAUMOL8',0,zhook_handle)
DO i_lay = 1, k_layswtch
  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(8) + 1
  ind1(i_lay) = (k_jp(i_lay)*5+(k_jt1(i_lay)-1))*nspa(8) + 1
  inds(i_lay) = k_indself(i_lay)
  z_colref1 = n2oref(k_jp(i_lay))
  z_colref2 = n2oref(k_jp(i_lay)+1)
  z_wcomb1 = 1.0_jprb/h2oref(k_jp(i_lay))
  z_wcomb2 = 1.0_jprb/h2oref(k_jp(i_lay)+1)
  z_ratio = (z_colref1*z_wcomb1)+z_fp*((z_colref2*z_wcomb2)-(z_colref1*z_wcomb1))
  z_currn2o = p_colh2o(i_lay) * z_ratio
  z_n2omult(i_lay) = p_coln2o(i_lay) - z_currn2o
ENDDO

!-- DS_000515
DO ig = 1, ng8
  DO i_lay = 1, k_layswtch
!-- DS_000515
    p_tau(ngs7+ig,i_lay) = p_colh2o(i_lay) *&
     & (p_fac00(i_lay) * absa(ind0(i_lay)  ,ig) +&
     & p_fac10(i_lay) * absa(ind0(i_lay)+1,ig) +&
     & p_fac01(i_lay) * absa(ind1(i_lay)  ,ig) +&
     & p_fac11(i_lay) * absa(ind1(i_lay)+1,ig) +&
     & 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_wx(3,i_lay) * cfc12(ig)&
     & + p_wx(4,i_lay) * cfc22adj(ig)&
     & + p_co2mult(i_lay) * absco2a(ig)&
     & + z_n2omult(i_lay) * absn2oa(ig)&
     & + p_tauaerl(i_lay,8)  
    pfrac(ngs7+ig,i_lay) = fracrefa(ig)
  ENDDO
ENDDO

DO i_lay = k_layswtch+1, klev
  z_fp = p_fac01(i_lay) + p_fac11(i_lay)
  ind0(i_lay) = ((k_jp(i_lay)-7)*5+(k_jt(i_lay)-1))*nspb(8) + 1
  ind1(i_lay) = ((k_jp(i_lay)-6)*5+(k_jt1(i_lay)-1))*nspb(8) + 1
  z_colref1 = n2oref(k_jp(i_lay))
  z_colref2 = n2oref(k_jp(i_lay)+1)
  z_wcomb1 = 1.0_jprb/o3ref(k_jp(i_lay))
  z_wcomb2 = 1.0_jprb/o3ref(k_jp(i_lay)+1)
  z_ratio = (z_colref1*z_wcomb1)+z_fp*((z_colref2*z_wcomb2)-(z_colref1*z_wcomb1))
  z_currn2o = p_colo3(i_lay) * z_ratio
  z_n2omult(i_lay) = p_coln2o(i_lay) - z_currn2o
ENDDO

!-- JJM_000517
DO ig = 1, ng8
  DO i_lay = k_layswtch+1, klev
!-- JJM_000517
    p_tau(ngs7+ig,i_lay) = p_colo3(i_lay) *&
     & (p_fac00(i_lay) * absb(ind0(i_lay)  ,ig) +&
     & p_fac10(i_lay) * absb(ind0(i_lay)+1,ig) +&
     & p_fac01(i_lay) * absb(ind1(i_lay)  ,ig) +&
     & p_fac11(i_lay) * absb(ind1(i_lay)+1,ig)) &
     & + p_wx(3,i_lay) * cfc12(ig)&
     & + p_wx(4,i_lay) * cfc22adj(ig)&
     & + p_co2mult(i_lay) * absco2b(ig)&
     & + z_n2omult(i_lay) * absn2ob(ig)&
     & + p_tauaerl(i_lay,8)  
    pfrac(ngs7+ig,i_lay) = fracrefb(ig)
  ENDDO
ENDDO

IF (lhook) CALL dr_hook('RRTM_TAUMOL8',1,zhook_handle)
END SUBROUTINE rrtm_taumol8