SUBROUTINE RRTM_SETCOEF_140GP (KIDIA,KFDIA,KLEV,P_COLDRY,P_WBROAD,P_WKL,& & P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,& & P_COLH2O,P_COLCO2,P_COLO3,P_COLN2O,P_COLCH4, P_COLO2,P_CO2MULT, P_COLBRD, & & K_LAYTROP,K_LAYSWTCH,K_LAYLOW,PAVEL,P_TAVEL,P_SELFFAC,P_SELFFRAC,K_INDSELF,& & K_INDMINOR,P_SCALEMINOR,P_SCALEMINORN2,P_MINORFRAC,& & PRAT_H2OCO2, PRAT_H2OCO2_1, PRAT_H2OO3, PRAT_H2OO3_1, & & PRAT_H2ON2O, PRAT_H2ON2O_1, PRAT_H2OCH4, PRAT_H2OCH4_1, & & PRAT_N2OCO2, PRAT_N2OCO2_1, PRAT_O3CO2, PRAT_O3CO2_1) ! Reformatted for F90 by JJMorcrette, ECMWF, 980714 ! NEC 25-Oct-2007 Optimisations ! 201305 ABozzo updated to rrtmg_lw_v4.85 ! Purpose: For a given atmosphere, calculate the indices and ! fractions related to the pressure and temperature interpolations. ! Also calculate the values of the integrated Planck functions ! for each band at the level and layer temperatures. USE PARKIND1 , ONLY : JPIM, JPRB USE YOMHOOK , ONLY : LHOOK, DR_HOOK USE PARRRTM , ONLY : JPINPX USE YOERRTRF , ONLY : PREFLOG ,TREF, CHI_MLS IMPLICIT NONE INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA INTEGER(KIND=JPIM),INTENT(IN) :: KLEV REAL(KIND=JPRB) ,INTENT(IN) :: P_COLDRY(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: P_WBROAD(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLBRD(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: P_WKL(KIDIA:KFDIA,JPINPX,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC00(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC01(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC10(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_FAC11(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_FORFAC(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_FORFRAC(KIDIA:KFDIA,KLEV) INTEGER(KIND=JPIM),INTENT(OUT) :: K_JP(KIDIA:KFDIA,KLEV) INTEGER(KIND=JPIM),INTENT(OUT) :: K_JT(KIDIA:KFDIA,KLEV) INTEGER(KIND=JPIM),INTENT(OUT) :: K_JT1(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLH2O(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLCO2(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLO3(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLN2O(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLCH4(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_COLO2(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_CO2MULT(KIDIA:KFDIA,KLEV) INTEGER(KIND=JPIM),INTENT(OUT) :: K_LAYTROP(KIDIA:KFDIA) INTEGER(KIND=JPIM),INTENT(OUT) :: K_LAYSWTCH(KIDIA:KFDIA) INTEGER(KIND=JPIM),INTENT(OUT) :: K_LAYLOW(KIDIA:KFDIA) REAL(KIND=JPRB) ,INTENT(IN) :: PAVEL(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(IN) :: P_TAVEL(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_SELFFAC(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_SELFFRAC(KIDIA:KFDIA,KLEV) INTEGER(KIND=JPIM),INTENT(OUT) :: K_INDSELF(KIDIA:KFDIA,KLEV) INTEGER(KIND=JPIM),INTENT(OUT) :: K_INDFOR(KIDIA:KFDIA,KLEV) INTEGER(KIND=JPIM),INTENT(OUT) :: K_INDMINOR(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_SCALEMINOR(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_SCALEMINORN2(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: P_MINORFRAC(KIDIA:KFDIA,KLEV) REAL(KIND=JPRB) ,INTENT(OUT) :: & ! & PRAT_H2OCO2(KIDIA:KFDIA,KLEV),PRAT_H2OCO2_1(KIDIA:KFDIA,KLEV), & & PRAT_H2OO3(KIDIA:KFDIA,KLEV) ,PRAT_H2OO3_1(KIDIA:KFDIA,KLEV), & & PRAT_H2ON2O(KIDIA:KFDIA,KLEV),PRAT_H2ON2O_1(KIDIA:KFDIA,KLEV), & & PRAT_H2OCH4(KIDIA:KFDIA,KLEV),PRAT_H2OCH4_1(KIDIA:KFDIA,KLEV), & & PRAT_N2OCO2(KIDIA:KFDIA,KLEV),PRAT_N2OCO2_1(KIDIA:KFDIA,KLEV), & & PRAT_O3CO2(KIDIA:KFDIA,KLEV) ,PRAT_O3CO2_1(KIDIA:KFDIA,KLEV) !- from INTFAC !- from INTIND !- from PROFDATA !- from PROFILE !- from SELF INTEGER(KIND=JPIM) :: JP1, JLAY INTEGER(KIND=JPIM) :: JLON REAL(KIND=JPRB) :: Z_CO2REG, Z_COMPFP, Z_FACTOR, Z_FP, Z_FT, Z_FT1, Z_PLOG, Z_SCALEFAC, Z_STPFAC, Z_WATER REAL(KIND=JPRB) :: ZHOOK_HANDLE !#include "yoeratm.h" ASSOCIATE(NFLEVG=>KLEV) IF (LHOOK) CALL DR_HOOK('RRTM_SETCOEF_140GP',0,ZHOOK_HANDLE) DO JLON = KIDIA, KFDIA Z_STPFAC = 296._JPRB/1013._JPRB K_LAYTROP(JLON) = 0 K_LAYSWTCH(JLON) = 0 K_LAYLOW(JLON) = 0 DO JLAY = 1, KLEV ! Find the two reference pressures on either side of the ! layer pressure. Store them in JP and JP1. Store in FP the ! fraction of the difference (in ln(pressure)) between these ! two values that the layer pressure lies. Z_PLOG = LOG(PAVEL(JLON,JLAY)) K_JP(JLON,JLAY) = INT(36._JPRB - 5*(Z_PLOG+0.04_JPRB)) IF (K_JP(JLON,JLAY) < 1) THEN K_JP(JLON,JLAY) = 1 ELSEIF (K_JP(JLON,JLAY) > 58) THEN K_JP(JLON,JLAY) = 58 ENDIF JP1 = K_JP(JLON,JLAY) + 1 Z_FP = 5._JPRB * (PREFLOG(K_JP(JLON,JLAY)) - Z_PLOG) ! bound Z_FP in case Z_PLOG is outside range of ref. pressure PREFLOG ! (in LVERTFE, pressure at last full level is known, but not in finite diff (NH) Z_FP = max(-1._JPRB,min(1._JPRB,Z_FP)) ! Determine, for each reference pressure (JP and JP1), which ! reference temperature (these are different for each ! reference pressure) is nearest the layer temperature but does ! not exceed it. Store these indices in JT and JT1, resp. ! Store in FT (resp. FT1) the fraction of the way between JT ! (JT1) and the next highest reference temperature that the ! layer temperature falls. K_JT(JLON,JLAY) = INT(3._JPRB + (P_TAVEL(JLON,JLAY)-TREF(K_JP(JLON,JLAY)))/15._JPRB) IF (K_JT(JLON,JLAY) < 1) THEN K_JT(JLON,JLAY) = 1 ELSEIF (K_JT(JLON,JLAY) > 4) THEN K_JT(JLON,JLAY) = 4 ENDIF Z_FT = ((P_TAVEL(JLON,JLAY)-TREF(K_JP(JLON,JLAY)))/15._JPRB) - REAL(K_JT(JLON,JLAY)-3) K_JT1(JLON,JLAY) = INT(3._JPRB + (P_TAVEL(JLON,JLAY)-TREF(JP1))/15._JPRB) IF (K_JT1(JLON,JLAY) < 1) THEN K_JT1(JLON,JLAY) = 1 ELSEIF (K_JT1(JLON,JLAY) > 4) THEN K_JT1(JLON,JLAY) = 4 ENDIF Z_FT1 = ((P_TAVEL(JLON,JLAY)-TREF(JP1))/15._JPRB) - REAL(K_JT1(JLON,JLAY)-3) Z_WATER = P_WKL(JLON,1,JLAY)/P_COLDRY(JLON,JLAY) Z_SCALEFAC = PAVEL(JLON,JLAY) * Z_STPFAC / P_TAVEL(JLON,JLAY) ! If the pressure is less than ~100mb, perform a different ! set of species interpolations. ! IF (PLOG .LE. 4.56) GO TO 5300 !-------------------------------------- IF (Z_PLOG > 4.56_JPRB) THEN K_LAYTROP(JLON) = K_LAYTROP(JLON) + 1 ! For one band, the "switch" occurs at ~300 mb. ! IF (Z_PLOG >= 5.76_JPRB) K_LAYSWTCH(JLON) = K_LAYSWTCH(JLON) + 1 ! IF (Z_PLOG >= 6.62_JPRB) K_LAYLOW(JLON) = K_LAYLOW(JLON) + 1 ! water vapor foreign continuum P_FORFAC(JLON,JLAY) = Z_SCALEFAC / (1.0_JPRB+Z_WATER) Z_FACTOR = (332.0_JPRB-P_TAVEL(JLON,JLAY))/36.0_JPRB K_INDFOR(JLON,JLAY) = MIN(2, MAX(1, INT(Z_FACTOR))) P_FORFRAC(JLON,JLAY) = Z_FACTOR - REAL(K_INDFOR(JLON,JLAY)) ! Set up factors needed to separately include the water vapor ! self-continuum in the calculation of absorption coefficient. !C SELFFAC(LAY) = WATER * SCALEFAC / (1.+WATER) P_SELFFAC(JLON,JLAY) = Z_WATER * P_FORFAC(JLON,JLAY) Z_FACTOR = (P_TAVEL(JLON,JLAY)-188.0_JPRB)/7.2_JPRB K_INDSELF(JLON,JLAY) = MIN(9, MAX(1, INT(Z_FACTOR)-7)) P_SELFFRAC(JLON,JLAY) = Z_FACTOR - REAL(K_INDSELF(JLON,JLAY) + 7) ! Set up factors needed to separately include the minor gases ! in the calculation of absorption coefficient P_SCALEMINOR(JLON,JLAY) = PAVEL(JLON,JLAY)/P_TAVEL(JLON,JLAY) P_SCALEMINORN2(JLON,JLAY) = (PAVEL(JLON,JLAY)/P_TAVEL(JLON,JLAY)) & & *(P_WBROAD(JLON,JLAY)/(P_COLDRY(JLON,JLAY)+P_WKL(JLON,1,JLAY))) Z_FACTOR = (P_TAVEL(JLON,JLAY)-180.8_JPRB)/7.2_JPRB K_INDMINOR(JLON,JLAY) = MIN(18, MAX(1, INT(Z_FACTOR))) P_MINORFRAC(JLON,JLAY) = Z_FACTOR - REAL(K_INDMINOR(JLON,JLAY)) ! Setup reference ratio to be used in calculation of binary ! species parameter in lower atmosphere. PRAT_H2OCO2(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY))/CHI_MLS(2,K_JP(JLON,JLAY)) PRAT_H2OCO2_1(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY)+1)/CHI_MLS(2,K_JP(JLON,JLAY)+1) PRAT_H2OO3(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY))/CHI_MLS(3,K_JP(JLON,JLAY)) PRAT_H2OO3_1(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY)+1)/CHI_MLS(3,K_JP(JLON,JLAY)+1) PRAT_H2ON2O(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY))/CHI_MLS(4,K_JP(JLON,JLAY)) PRAT_H2ON2O_1(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY)+1)/CHI_MLS(4,K_JP(JLON,JLAY)+1) PRAT_H2OCH4(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY))/CHI_MLS(6,K_JP(JLON,JLAY)) PRAT_H2OCH4_1(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY)+1)/CHI_MLS(6,K_JP(JLON,JLAY)+1) PRAT_N2OCO2(JLON,JLAY)=CHI_MLS(4,K_JP(JLON,JLAY))/CHI_MLS(2,K_JP(JLON,JLAY)) PRAT_N2OCO2_1(JLON,JLAY)=CHI_MLS(4,K_JP(JLON,JLAY)+1)/CHI_MLS(2,K_JP(JLON,JLAY)+1) ! Calculate needed column amounts. P_COLH2O(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,1,JLAY) P_COLCO2(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,2,JLAY) P_COLO3(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,3,JLAY) P_COLN2O(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,4,JLAY) P_COLCH4(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,6,JLAY) P_COLO2(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,7,JLAY) P_COLBRD(JLON,JLAY) = 1.E-20_JPRB * P_WBROAD(JLON,JLAY) IF (P_COLCO2(JLON,JLAY) == 0.0_JPRB) P_COLCO2(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) IF (P_COLN2O(JLON,JLAY) == 0.0_JPRB) P_COLN2O(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) IF (P_COLCH4(JLON,JLAY) == 0.0_JPRB) P_COLCH4(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) ! Using E = 1334.2 cm-1. Z_CO2REG = 3.55E-24_JPRB * P_COLDRY(JLON,JLAY) P_CO2MULT(JLON,JLAY)= (P_COLCO2(JLON,JLAY) - Z_CO2REG) *& & 272.63_JPRB*EXP(-1919.4_JPRB/P_TAVEL(JLON,JLAY))/(8.7604E-4_JPRB*P_TAVEL(JLON,JLAY)) ! GO TO 5400 !------------------ ELSE ! Above LAYTROP. ! 5300 CONTINUE ! Calculate needed column amounts. P_FORFAC(JLON,JLAY) = Z_SCALEFAC / (1.0_JPRB+Z_WATER) Z_FACTOR = (P_TAVEL(JLON,JLAY)-188.0_JPRB)/36.0_JPRB K_INDFOR(JLON,JLAY) = 3 P_FORFRAC(JLON,JLAY) = Z_FACTOR - 1.0_JPRB ! Set up factors needed to separately include the water vapor ! self-continuum in the calculation of absorption coefficient. P_SELFFAC(JLON,JLAY) = Z_WATER * P_FORFAC(JLON,JLAY) ! Set up factors needed to separately include the minor gases ! in the calculation of absorption coefficient P_SCALEMINOR(JLON,JLAY) = PAVEL(JLON,JLAY)/P_TAVEL(JLON,JLAY) P_SCALEMINORN2(JLON,JLAY) = (PAVEL(JLON,JLAY)/P_TAVEL(JLON,JLAY)) & & * (P_WBROAD(JLON,JLAY)/(P_COLDRY(JLON,JLAY)+P_WKL(JLON,1,JLAY))) Z_FACTOR = (P_TAVEL(JLON,JLAY)-180.8_JPRB)/7.2_JPRB K_INDMINOR(JLON,JLAY) = MIN(18, MAX(1, INT(Z_FACTOR))) P_MINORFRAC(JLON,JLAY) = Z_FACTOR - REAL(K_INDMINOR(JLON,JLAY)) ! Setup reference ratio to be used in calculation of binary ! species parameter in upper atmosphere. PRAT_H2OCO2(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY))/CHI_MLS(2,K_JP(JLON,JLAY)) PRAT_H2OCO2_1(JLON,JLAY)=CHI_MLS(1,K_JP(JLON,JLAY)+1)/CHI_MLS(2,K_JP(JLON,JLAY)+1) PRAT_O3CO2(JLON,JLAY)=CHI_MLS(3,K_JP(JLON,JLAY))/CHI_MLS(2,K_JP(JLON,JLAY)) PRAT_O3CO2_1(JLON,JLAY)=CHI_MLS(3,K_JP(JLON,JLAY)+1)/CHI_MLS(2,K_JP(JLON,JLAY)+1) ! Calculate needed column amounts. P_COLH2O(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,1,JLAY) P_COLCO2(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,2,JLAY) P_COLO3(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,3,JLAY) P_COLN2O(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,4,JLAY) P_COLCH4(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,6,JLAY) P_COLO2(JLON,JLAY) = 1.E-20_JPRB * P_WKL(JLON,7,JLAY) P_COLBRD(JLON,JLAY) = 1.E-20_JPRB * P_WBROAD(JLON,JLAY) IF (P_COLCO2(JLON,JLAY) == 0.0_JPRB) P_COLCO2(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) IF (P_COLN2O(JLON,JLAY) == 0.0_JPRB) P_COLN2O(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) IF (P_COLCH4(JLON,JLAY) == 0.0_JPRB) P_COLCH4(JLON,JLAY) = 1.E-32_JPRB * P_COLDRY(JLON,JLAY) Z_CO2REG = 3.55E-24_JPRB * P_COLDRY(JLON,JLAY) P_CO2MULT(JLON,JLAY)= (P_COLCO2(JLON,JLAY) - Z_CO2REG) *& & 272.63_JPRB*EXP(-1919.4_JPRB/P_TAVEL(JLON,JLAY))/(8.7604E-4_JPRB*P_TAVEL(JLON,JLAY)) !---------------- ENDIF ! 5400 CONTINUE ! We have now isolated the layer ln pressure and temperature, ! between two reference pressures and two reference temperatures ! (for each reference pressure). We multiply the pressure ! fraction FP with the appropriate temperature fractions to get ! the factors that will be needed for the interpolation that yields ! the optical depths (performed in routines TAUGBn for band n). Z_COMPFP = 1.0_JPRB - Z_FP P_FAC10(JLON,JLAY) = Z_COMPFP * Z_FT P_FAC00(JLON,JLAY) = Z_COMPFP * (1.0_JPRB - Z_FT) P_FAC11(JLON,JLAY) = Z_FP * Z_FT1 P_FAC01(JLON,JLAY) = Z_FP * (1.0_JPRB - Z_FT1) ! Rescale selffac and forfac for use in taumol P_SELFFAC(JLON,JLAY) = P_COLH2O(JLON,JLAY)*P_SELFFAC(JLON,JLAY) P_FORFAC(JLON,JLAY) = P_COLH2O(JLON,JLAY)*P_FORFAC(JLON,JLAY) ENDDO ! MT 981104 !-- Set LAYLOW for profiles with surface pressure less than 750 hPa. IF (K_LAYLOW(JLON) == 0) K_LAYLOW(JLON)=1 ENDDO IF (LHOOK) CALL DR_HOOK('RRTM_SETCOEF_140GP',1,ZHOOK_HANDLE) END ASSOCIATE END SUBROUTINE RRTM_SETCOEF_140GP