SUBROUTINE RRTM_GASABS1A_140GP (KLEV,P_ATR1,P_OD,P_TF1,P_COLDRY,P_WX,& & 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_COLO3,P_COLN2O,P_COLCH4,P_COLO2,P_CO2MULT,& & K_LAYTROP,K_LAYSWTCH,K_LAYLOW,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) ! Reformatted for F90 by JJMorcrette, ECMWF, 980714 USE PARKIND1 ,ONLY : JPIM ,JPRB USE YOMHOOK ,ONLY : LHOOK, DR_HOOK USE PARRRTM , ONLY : JPLAY ,JPBAND ,JPGPT ,JPXSEC USE YOERRTAB , ONLY : TRANS ,BPADE IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KLEV REAL(KIND=JPRB) ,INTENT(OUT) :: P_ATR1(JPGPT,JPLAY) REAL(KIND=JPRB) ,INTENT(OUT) :: P_OD(JPGPT,JPLAY) REAL(KIND=JPRB) ,INTENT(OUT) :: P_TF1(JPGPT,JPLAY) REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(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) 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_COLO3(JPLAY) REAL(KIND=JPRB) ,INTENT(IN) :: P_COLN2O(JPLAY) REAL(KIND=JPRB) ,INTENT(IN) :: P_COLCH4(JPLAY) REAL(KIND=JPRB) :: P_COLO2(JPLAY) ! Argument NOT used REAL(KIND=JPRB) ,INTENT(IN) :: P_CO2MULT(JPLAY) INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYTROP INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYSWTCH INTEGER(KIND=JPIM),INTENT(IN) :: K_LAYLOW 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 REAL(KIND=JPRB) :: Z_TAU (JPGPT,JPLAY) INTEGER(KIND=JPIM) :: IPR, ITR, I_LAY REAL(KIND=JPRB) :: Z_ODEPTH, Z_SECANG, Z_TF REAL(KIND=JPRB) :: ZHOOK_HANDLE #include "rrtm_taumol1.intfb.h" #include "rrtm_taumol10.intfb.h" #include "rrtm_taumol11.intfb.h" #include "rrtm_taumol12.intfb.h" #include "rrtm_taumol13.intfb.h" #include "rrtm_taumol14.intfb.h" #include "rrtm_taumol15.intfb.h" #include "rrtm_taumol16.intfb.h" #include "rrtm_taumol2.intfb.h" #include "rrtm_taumol3.intfb.h" #include "rrtm_taumol4.intfb.h" #include "rrtm_taumol5.intfb.h" #include "rrtm_taumol6.intfb.h" #include "rrtm_taumol7.intfb.h" #include "rrtm_taumol8.intfb.h" #include "rrtm_taumol9.intfb.h" !- SECANG is equal to the secant of the diffusivity angle. IF (LHOOK) CALL DR_HOOK('RRTM_GASABS1A_140GP',0,ZHOOK_HANDLE) Z_SECANG = 1.66_JPRB CALL RRTM_TAUMOL1 (KLEV,Z_TAU,& & 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) CALL RRTM_TAUMOL2 (KLEV,Z_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) CALL RRTM_TAUMOL3 (KLEV,Z_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) CALL RRTM_TAUMOL4 (KLEV,Z_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_COLO3,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) CALL RRTM_TAUMOL5 (KLEV,Z_TAU,P_WX,& & 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_COLO3,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) CALL RRTM_TAUMOL6 (KLEV,Z_TAU,P_WX,& & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,& & P_COLH2O,P_CO2MULT,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) CALL RRTM_TAUMOL7 (KLEV,Z_TAU,& & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,& & P_COLH2O,P_COLO3,P_CO2MULT,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) CALL RRTM_TAUMOL8 (KLEV,Z_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) CALL RRTM_TAUMOL9 (KLEV,Z_TAU,& & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,& & P_COLH2O,P_COLN2O,P_COLCH4,K_LAYTROP,K_LAYSWTCH,K_LAYLOW,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) CALL RRTM_TAUMOL10 (KLEV,Z_TAU,& & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,& & P_COLH2O,K_LAYTROP,PFRAC) CALL RRTM_TAUMOL11 (KLEV,Z_TAU,& & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,& & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) CALL RRTM_TAUMOL12 (KLEV,Z_TAU,& & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,& & P_COLH2O,P_COLCO2,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) CALL RRTM_TAUMOL13 (KLEV,Z_TAU,& & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,& & P_COLH2O,P_COLN2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) CALL RRTM_TAUMOL14 (KLEV,Z_TAU,& & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,& & P_COLCO2,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) CALL RRTM_TAUMOL15 (KLEV,Z_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) CALL RRTM_TAUMOL16 (KLEV,Z_TAU,& & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,K_JP,K_JT,K_JT1,P_ONEMINUS,& & P_COLH2O,P_COLCH4,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC) !- Loop over g-channels. DO I_LAY = 1, KLEV DO IPR = 1, JPGPT Z_ODEPTH = Z_SECANG * Z_TAU(IPR,I_LAY) P_OD(IPR,I_LAY) = Z_ODEPTH Z_ODEPTH=0.5D0*(ABS(Z_ODEPTH)+Z_ODEPTH) !-- revised code to get the pre-computed transmission ! IF (ODEPTH.LE.0.) PRINT*, 'ODEPTH = ',ODEPTH !! IF (ODEPTH <= _ZERO_)THEN !! ATR1(IPR,LAY) = _ONE_ - TRANS(0) !! TF1(IPR,LAY) = _ZERO_ !! ELSE Z_TF = Z_ODEPTH/(BPADE+Z_ODEPTH) ITR=INT(5.E+03_JPRB*Z_TF+0.5_JPRB) IF (ITR.LT.0) ITR=0 ! MPL 12.12.08 P_ATR1(IPR,I_LAY) = 1.0_JPRB - TRANS(ITR) P_TF1(IPR,I_LAY) = Z_TF !! ENDIF ENDDO ENDDO ! ----------------------------------------------------------------- IF (LHOOK) CALL DR_HOOK('RRTM_GASABS1A_140GP',1,ZHOOK_HANDLE) END SUBROUTINE RRTM_GASABS1A_140GP