rrtm_taumol15.F90

Go to the documentation of this file.

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

!     BAND 15:  2380-2600 cm-1 (low - N2O,CO2; high - nothing)

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

!     D Salmond 1999-07-14 speed-up

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

USE parrrtm  , ONLY : jplay  ,jpband ,jpgpt  ,ngs14
USE yoerrtwn , ONLY :      nspa   
USE yoerrta15, ONLY : absa   ,fracrefa,selfref,strrat

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) 
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) :: IG, IND0, IND1, INDS, JS, I_LAY

REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,&
 & Z_FAC110, Z_FAC111, Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM  
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!  Input
!#include "yoeratm.h"

!      REAL TAUAER(JPLAY)
!      EQUIVALENCE (TAUAERL(1,15),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_TAUMOL15',0,zhook_handle)
DO i_lay = 1, k_laytrop
  z_speccomb = p_coln2o(i_lay) + strrat*p_colco2(i_lay)
  z_specparm = p_coln2o(i_lay)/z_speccomb
  z_specparm = min(z_specparm,p_oneminus)
  z_specmult = 8._jprb*(z_specparm)
  js = 1 + int(z_specmult)
  z_fs = mod(z_specmult,1.0_jprb)
!-----jjm        
  z_fac000 = (1.0_jprb - z_fs) * p_fac00(i_lay)
  z_fac010 = (1.0_jprb - z_fs) * p_fac10(i_lay)
  z_fac100 = z_fs * p_fac00(i_lay)
  z_fac110 = z_fs * p_fac10(i_lay)
  z_fac001 = (1.0_jprb - z_fs) * p_fac01(i_lay)
  z_fac011 = (1.0_jprb - z_fs) * p_fac11(i_lay)
  z_fac101 = z_fs * p_fac01(i_lay)
  z_fac111 = z_fs * p_fac11(i_lay)
!------         
  ind0 = ((k_jp(i_lay)-1)*5+(k_jt(i_lay)-1))*nspa(15) + js
  ind1 = (k_jp(i_lay)*5+(k_jt1(i_lay)-1))*nspa(15) + js
  inds = k_indself(i_lay)
!-- DS_990714  
!         DO IG = 1, NG15
  ig=1
  p_tau(ngs14+ig,i_lay) = z_speccomb *&
   !     &((1. - Z_FS)*(P_FAC00(I_LAY) * ABSA(IND0,IG) +
   !     &            P_FAC10(I_LAY) * ABSA(IND0+9,IG) +
   !     &            P_FAC01(I_LAY) * ABSA(IND1,IG) + 
   !     &            P_FAC11(I_LAY) * ABSA(IND1+9,IG)) +
   !     &     Z_FS *  (P_FAC01(I_LAY) * ABSA(IND1+1,IG) +
   !     &            P_FAC10(I_LAY) * ABSA(IND0+10,IG) +
   !     &            P_FAC00(I_LAY) * ABSA(IND0+1,IG) +
   !     &            P_FAC11(I_LAY) * ABSA(IND1+10,IG))) +
   & (z_fac000 * absa(ind0   ,ig) +&
   & z_fac100 * absa(ind0+ 1,ig) +&
   & z_fac010 * absa(ind0+ 9,ig) +&
   & z_fac110 * absa(ind0+10,ig) +&
   & z_fac001 * absa(ind1   ,ig) +&
   & z_fac101 * absa(ind1+ 1,ig) +&
   & z_fac011 * absa(ind1+ 9,ig) +&
   & z_fac111 * absa(ind1+10,ig))+&
   & p_colh2o(i_lay) * &
   & p_selffac(i_lay) * (selfref(inds,ig) + &
   & p_selffrac(i_lay) *&
   & (selfref(inds+1,ig) - selfref(inds,ig)))&
   & + p_tauaerl(i_lay,15)  
  pfrac(ngs14+ig,i_lay) = fracrefa(ig,js) + z_fs *&
   & (fracrefa(ig,js+1) - fracrefa(ig,js))  
  ig=2
  p_tau(ngs14+ig,i_lay) = z_speccomb *&
   !     &((1. - Z_FS)*(P_FAC00(I_LAY) * ABSA(IND0,IG) +
   !     &            P_FAC10(I_LAY) * ABSA(IND0+9,IG) +
   !     &            P_FAC01(I_LAY) * ABSA(IND1,IG) +
   !     &            P_FAC11(I_LAY) * ABSA(IND1+9,IG)) +
   !     &     Z_FS *  (P_FAC01(I_LAY) * ABSA(IND1+1,IG) +
   !     &            P_FAC10(I_LAY) * ABSA(IND0+10,IG) +
   !     &            P_FAC00(I_LAY) * ABSA(IND0+1,IG) +
   !     &            P_FAC11(I_LAY) * ABSA(IND1+10,IG))) +
   & (z_fac000 * absa(ind0   ,ig) +&
   & z_fac100 * absa(ind0+ 1,ig) +&
   & z_fac010 * absa(ind0+ 9,ig) +&
   & z_fac110 * absa(ind0+10,ig) +&
   & z_fac001 * absa(ind1   ,ig) +&
   & z_fac101 * absa(ind1+ 1,ig) +&
   & z_fac011 * absa(ind1+ 9,ig) +&
   & z_fac111 * absa(ind1+10,ig))+&
   & p_colh2o(i_lay) *&
   & p_selffac(i_lay) * (selfref(inds,ig) +&
   & p_selffrac(i_lay) *&
   & (selfref(inds+1,ig) - selfref(inds,ig)))&
   & + p_tauaerl(i_lay,15)  
  pfrac(ngs14+ig,i_lay) = fracrefa(ig,js) + z_fs *&
   & (fracrefa(ig,js+1) - fracrefa(ig,js))  

!         END DO
!-- DS_990714  
ENDDO

DO i_lay = k_laytrop+1, klev
!         DO IG = 1, NG15
!-- DS_990714  
  ig=1
  p_tau(ngs14+ig,i_lay) = p_tauaerl(i_lay,15)
  pfrac(ngs14+ig,i_lay) = 0.0_jprb
  ig=2
  p_tau(ngs14+ig,i_lay) = p_tauaerl(i_lay,15)
  pfrac(ngs14+ig,i_lay) = 0.0_jprb
!-- DS_990714  
!         END DO
ENDDO

IF (lhook) CALL dr_hook('RRTM_TAUMOL15',1,zhook_handle)
END SUBROUTINE rrtm_taumol15