rrtm_taumol2.F90

Go to the documentation of this file.

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

!     BAND 2:  250-500 cm-1 (low - H2O; high - H2O)

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

!     D Salmond   2000-05-15 speed-up
!     JJMorcrette 2000-05-17 speed-up
!     JJMorcrette 2000-07-14 bugfix
!     Y. Seity    2006-09-26 Nec optimisation

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

USE parrrtm  , ONLY : jplay  ,jpband ,jpgpt  ,ng2   ,ngs1
USE yoerrtwn , ONLY :      nspa   ,nspb
USE yoerrta2 , ONLY : absa   ,absb   ,fracrefa, fracrefb,&
 & forref   ,selfref , refparam  
USE yoerrtbg2, ONLY : corr1  ,corr2

!  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_COLDRY(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_COLH2O(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) 
!  Output
!- from AER
!- from INTFAC      
!- from INTIND
!- from PROFDATA             
!- from SELF             
!- from SP             
REAL(KIND=JPRB) :: Z_FC00(jplay),Z_FC01(jplay),Z_FC10(jplay),Z_FC11(jplay)
!      REAL TAUAER(JPLAY)
REAL(KIND=JPRB) :: Z_FRACINT(jplay)
INTEGER(KIND=JPIM) :: IND0(jplay),IND1(jplay),INDS(jplay), INDEX(jplay)

INTEGER(KIND=JPIM) :: IFP, IFRAC, IG, JFRAC, I_LAY

REAL(KIND=JPRB) :: Z_FP, Z_H2OPARAM, Z_WATER
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

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

IF (lhook) CALL dr_hook('RRTM_TAUMOL2',0,zhook_handle)
DO i_lay = 1, k_laytrop
  z_water = 1.e20_jprb * p_colh2o(i_lay) / p_coldry(i_lay)
  z_h2oparam = z_water/(z_water +.002_jprb)
  
!  DO IFRAC = 2, 12
!    IF (H2OPARAM  >=  REFPARAM(IFRAC)) GO TO 1900
!  ENDDO
!  1900 CONTINUE
!  FRACINT(LAY) = (H2OPARAM-REFPARAM(IFRAC))/&
!   &(REFPARAM(IFRAC-1)-REFPARAM(IFRAC))
  ifrac=index(i_lay)
  IF (z_h2oparam >= refparam(2)) THEN
          ifrac=2
  ELSE
!cdir unroll=11
    DO jfrac = 2, 12
      IF (z_h2oparam < refparam(jfrac)) THEN
         ifrac=jfrac+1
      ENDIF  
    ENDDO
  ENDIF  
  
!---- JJM_000714
! set above IFRAC instead of INDEX(I_LAY), store now - NEC jh
! IFRAC=INDEX(I_LAY)
  index(i_lay)=ifrac

  z_fracint(i_lay) = (z_h2oparam-refparam(ifrac))/&
   & (refparam(ifrac-1)-refparam(ifrac))  
ENDDO

DO i_lay = 1, k_laytrop

  z_fp = p_fac11(i_lay) + p_fac01(i_lay)
  ifp = 2.e2_jprb*z_fp+0.5_jprb

!---MI 981104        
!       IF (IFP.LE.0) IFP=0

  ifp=max(0,ifp)

  z_fc00(i_lay) = p_fac00(i_lay) * corr2(ifp)
  z_fc10(i_lay) = p_fac10(i_lay) * corr2(ifp)
  z_fc01(i_lay) = p_fac01(i_lay) * corr1(ifp)
  z_fc11(i_lay) = p_fac11(i_lay) * corr1(ifp)
  ind0(i_lay) = ((k_jp(i_lay)-1)*5+(k_jt(i_lay)-1))*nspa(2) + 1
  ind1(i_lay) = (k_jp(i_lay)*5+(k_jt1(i_lay)-1))*nspa(2) + 1
  inds(i_lay) = k_indself(i_lay)
ENDDO

!-- DS_000515  
DO ig = 1, ng2
  DO i_lay = 1, k_laytrop
!-- JJM_000714
    ifrac=index(i_lay)  
!-- DS_000515  
    p_tau(ngs1+ig,i_lay) = p_colh2o(i_lay) *&
     & (z_fc00(i_lay) * absa(ind0(i_lay)  ,ig) +&
     & z_fc10(i_lay) * absa(ind0(i_lay)+1,ig) +&
     & z_fc01(i_lay) * absa(ind1(i_lay)  ,ig) +&
     & z_fc11(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_forfac(i_lay) * forref(ig) ) &
     & + p_tauaerl(i_lay,2)  
    pfrac(ngs1+ig,i_lay) = fracrefa(ig,ifrac) + z_fracint(i_lay) *&
     & (fracrefa(ig,ifrac-1)-fracrefa(ig,ifrac))  
  ENDDO
ENDDO

DO i_lay = k_laytrop+1, klev
  z_fp = p_fac11(i_lay) + p_fac01(i_lay)
  ifp = 2.e2_jprb*z_fp+0.5_jprb

!---MI 981104        
  IF (ifp <= 0) ifp=0

  z_fc00(i_lay) = p_fac00(i_lay) * corr2(ifp)
  z_fc10(i_lay) = p_fac10(i_lay) * corr2(ifp)
  z_fc01(i_lay) = p_fac01(i_lay) * corr1(ifp)
  z_fc11(i_lay) = p_fac11(i_lay) * corr1(ifp)
  ind0(i_lay) = ((k_jp(i_lay)-13)*5+(k_jt(i_lay)-1))*nspb(2) + 1
  ind1(i_lay) = ((k_jp(i_lay)-12)*5+(k_jt1(i_lay)-1))*nspb(2) + 1
ENDDO

!-- JJM_000517
DO ig = 1, ng2
  DO i_lay = k_laytrop+1, klev
!-- JJM_000517
    p_tau(ngs1+ig,i_lay) = p_colh2o(i_lay) *&
     & (z_fc00(i_lay) * absb(ind0(i_lay)  ,ig) +&
     & z_fc10(i_lay) * absb(ind0(i_lay)+1,ig) +&
     & z_fc01(i_lay) * absb(ind1(i_lay)  ,ig) +&
     & z_fc11(i_lay) * absb(ind1(i_lay)+1,ig)&
     & + p_forfac(i_lay) * forref(ig) ) &
     & + p_tauaerl(i_lay,2)  
    pfrac(ngs1+ig,i_lay) = fracrefb(ig)
  ENDDO
ENDDO

IF (lhook) CALL dr_hook('RRTM_TAUMOL2',1,zhook_handle)
END SUBROUTINE rrtm_taumol2