source: LMDZ6/branches/cirrus/libf/phylmd/ecrad/ifsrrtm/rrtm_taumol1.F90 @ 5407

Last change on this file since 5407 was 4773, checked in by idelkadi, 12 months ago
  • Update of Ecrad in LMDZ The same organization of the Ecrad offline version is retained in order to facilitate the updating of Ecrad in LMDZ and the comparison between online and offline results. version 1.6.1 of Ecrad (​https://github.com/lguez/ecrad.git)
  • Implementation of the double call of Ecrad in LMDZ


File size: 15.4 KB
Line 
1SUBROUTINE RRTM_TAUMOL1 (KIDIA,KFDIA,KLEV,P_TAU,PAVEL,&
2 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,&
3 & P_COLH2O,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC,P_MINORFRAC,K_INDMINOR,PSCALEMINORN2,PCOLBRD) 
4
5!******************************************************************************
6!                                                                             *
7!                  Optical depths developed for the                           *
8!                                                                             *
9!                RAPID RADIATIVE TRANSFER MODEL (RRTM)                        *
10!                                                                             *
11!            ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC.                     *
12!                        840 MEMORIAL DRIVE                                   *
13!                        CAMBRIDGE, MA 02139                                  *
14!                                                                             *
15!                           ELI J. MLAWER                                     *
16!                         STEVEN J. TAUBMAN                                   *
17!                         SHEPARD A. CLOUGH                                   *
18!                                                                             *
19!                       email:  mlawer@aer.com                                *
20!                                                                             *
21!        The authors wish to acknowledge the contributions of the             *
22!        following people:  Patrick D. Brown, Michael J. Iacono,              *
23!        Ronald E. Farren, Luke Chen, Robert Bergstrom.                       *
24!                                                                             *
25!******************************************************************************
26!     TAUMOL                                                                  *
27!                                                                             *
28!     This file contains the subroutines TAUGBn (where n goes from            *
29!     1 to 16).  TAUGBn calculates the optical depths and Planck fractions    *
30!     per g-value and layer for band n.                                       *
31!                                                                             *
32!  Output:  optical depths (unitless)                                         *
33!           fractions needed to compute Planck functions at every layer       *
34!               and g-value                                                   *
35!                                                                             *
36!     COMMON /TAUGCOM/  TAUG(MXLAY,MG)                                        *
37!     COMMON /PLANKG/   FRACS(MXLAY,MG)                                       *
38!                                                                             *
39!  Input                                                                      *
40!                                                                             *
41!     COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS)                  *
42!     COMMON /PRECISE/  ONEMINUS                                              *
43!     COMMON /PROFILE/  NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY),                    *
44!    &                  PZ(0:MXLAY),TZ(0:MXLAY),TBOUND                        *
45!     COMMON /PROFDATA/ LAYTROP,LAYSWTCH,LAYLOW,                              *
46!    &                  COLH2O(MXLAY),COLCO2(MXLAY),                          *
47!    &                  COLO3(MXLAY),COLN2O(MXLAY),COLCH4(MXLAY),             *
48!    &                  COLO2(MXLAY),CO2MULT(MXLAY)                           *
49!     COMMON /INTFAC/   FAC00(MXLAY),FAC01(MXLAY),                            *
50!    &                  FAC10(MXLAY),FAC11(MXLAY)                             *
51!     COMMON /INTIND/   JP(MXLAY),JT(KIDIA:KFDIA,MXLAY),JT1(KIDIA:KFDIA,MXLAY)                        *
52!     COMMON /SELF/     SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(KIDIA:KFDIA,MXLAY)       *
53!                                                                             *
54!     Description:                                                            *
55!     NG(IBAND) - number of g-values in band IBAND                            *
56!     NSPA(IBAND) - for the lower atmosphere, the number of reference         *
57!                   atmospheres that are stored for band IBAND per            *
58!                   pressure level and temperature.  Each of these            *
59!                   atmospheres has different relative amounts of the         *
60!                   key species for the band (i.e. different binary           *
61!                   species parameters).                                      *
62!     NSPB(IBAND) - same for upper atmosphere                                 *
63!     ONEMINUS - since problems are caused in some cases by interpolation     *
64!                parameters equal to or greater than 1, for these cases       *
65!                these parameters are set to this value, slightly < 1.        *
66!     PAVEL - layer pressures (mb)                                            *
67!     TAVEL - layer temperatures (degrees K)                                  *
68!     PZ - level pressures (mb)                                               *
69!     TZ - level temperatures (degrees K)                                     *
70!     LAYTROP - layer at which switch is made from one combination of         *
71!               key species to another                                        *
72!     COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water         *
73!               vapor,carbon dioxide, ozone, nitrous ozide, methane,          *
74!               respectively (molecules/cm**2)                                *
75!     CO2MULT - for bands in which carbon dioxide is implemented as a         *
76!               trace species, this is the factor used to multiply the        *
77!               band's average CO2 absorption coefficient to get the added    *
78!               contribution to the optical depth relative to 355 ppm.        *
79!     FACij(JLAY) - for layer JLAY, these are factors that are needed to        *
80!                  compute the interpolation factors that multiply the        *
81!                  appropriate reference k-values.  A value of 0 (1) for      *
82!                  i,j indicates that the corresponding factor multiplies     *
83!                  reference k-value for the lower (higher) of the two        *
84!                  appropriate temperatures, and altitudes, respectively.     *
85!     JP - the index of the lower (in altitude) of the two appropriate        *
86!          reference pressure levels needed for interpolation                 *
87!     JT, JT1 - the indices of the lower of the two appropriate reference     *
88!               temperatures needed for interpolation (for pressure           *
89!               levels JP and JP+1, respectively)                             *
90!     SELFFAC - scale factor needed to water vapor self-continuum, equals     *
91!               (water vapor density)/(atmospheric density at 296K and        *
92!               1013 mb)                                                      *
93!     SELFFRAC - factor needed for temperature interpolation of reference     *
94!                water vapor self-continuum data                              *
95!     INDSELF - index of the lower of the two appropriate reference           *
96!               temperatures needed for the self-continuum interpolation      *
97!                                                                             *
98!  Data input                                                                 *
99!     COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG) *
100!        (note:  n is the band number)                                        *
101!                                                                             *
102!     Description:                                                            *
103!     KA - k-values for low reference atmospheres (no water vapor             *
104!          self-continuum) (units: cm**2/molecule)                            *
105!     KB - k-values for high reference atmospheres (all sources)              *
106!          (units: cm**2/molecule)                                            *
107!     SELFREF - k-values for water vapor self-continuum for reference         *
108!               atmospheres (used below LAYTROP)                              *
109!               (units: cm**2/molecule)                                       *
110!                                                                             *
111!     DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG)                     *
112!     EQUIVALENCE (KA,ABSA),(KB,ABSB)                                         *
113!                                                                             *
114!******************************************************************************
115
116!     BAND 1:  10-250 cm-1 (low - H2O; high - H2O)
117 
118!     AUTHOR.
119!     -------
120!      JJMorcrette, ECMWF, from
121!      Eli J. Mlawer, Atmospheric & Environmental Research.
122!      (Revised by Michael J. Iacono, Atmospheric & Environmental Research.)
123
124!     MODIFICATIONS.
125!     --------------
126!      D Salmond   2000-05-15 speed-up
127!      JJMorcrette 2000-05-17 speed-up
128!      M.Hamrud      01-Oct-2003 CY28 Cleaning
129!      NEC           25-Oct-2007 Optimisations
130!      JJMorcrette 20110613 flexible number of g-points
131!      ABozzo 200130517 updated to rrtmg_lw_v4.85:
132!*********
133!     band 1:  10-350 cm-1 (low key - h2o; low minor - n2)
134!                          (high key - h2o; high minor - n2)
135!
136!     note: previous versions of rrtm band 1:
137!           10-250 cm-1 (low - h2o; high - h2o)
138! ---------------------------------------------------------------------------
139
140USE PARKIND1  ,ONLY : JPIM     ,JPRB
141USE YOMHOOK   ,ONLY : LHOOK, DR_HOOK, JPHOOK
142
143USE PARRRTM  , ONLY : JPBAND
144USE YOERRTM  , ONLY : JPGPT  ,NG1
145USE YOERRTWN , ONLY : NSPA   ,NSPB
146USE YOERRTA1 , ONLY : ABSA   ,ABSB   ,FRACREFA, FRACREFB,&
147 & FORREF   ,SELFREF,  KA_MN2, KB_MN2   
148
149IMPLICIT NONE
150
151INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA
152INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA
153INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
154REAL(KIND=JPRB)   ,INTENT(IN)    :: PAVEL(KIDIA:KFDIA,KLEV) ! Layer pressures (hPa)
155REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV)
156REAL(KIND=JPRB)   ,INTENT(IN)    :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND)
157REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC00(KIDIA:KFDIA,KLEV)
158REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC01(KIDIA:KFDIA,KLEV)
159REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC10(KIDIA:KFDIA,KLEV)
160REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC11(KIDIA:KFDIA,KLEV)
161REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFAC(KIDIA:KFDIA,KLEV)
162REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFRAC(KIDIA:KFDIA,KLEV)
163INTEGER(KIND=JPIM),INTENT(IN)    :: K_JP(KIDIA:KFDIA,KLEV)
164INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT(KIDIA:KFDIA,KLEV)
165INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT1(KIDIA:KFDIA,KLEV)
166REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLH2O(KIDIA:KFDIA,KLEV)
167INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYTROP(KIDIA:KFDIA)
168REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFAC(KIDIA:KFDIA,KLEV)
169REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFRAC(KIDIA:KFDIA,KLEV)
170REAL(KIND=JPRB)   ,INTENT(IN)    :: P_MINORFRAC(KIDIA:KFDIA,KLEV)
171INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDSELF(KIDIA:KFDIA,KLEV)
172REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV)
173
174INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDFOR(KIDIA:KFDIA,KLEV)
175INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDMINOR(KIDIA:KFDIA,KLEV)
176REAL(KIND=JPRB)   ,INTENT(IN)    :: PSCALEMINORN2(KIDIA:KFDIA,KLEV)
177REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLBRD(KIDIA:KFDIA,KLEV)         
178! ---------------------------------------------------------------------------
179
180INTEGER(KIND=JPIM) :: IND0(KLEV),IND1(KLEV),INDS(KLEV)
181INTEGER(KIND=JPIM) :: INDF(KLEV),INDM(KLEV)
182
183INTEGER(KIND=JPIM) :: IG, JLAY
184INTEGER(KIND=JPIM) :: JLON
185REAL(KIND=JPRB) :: ZTAUFOR,ZTAUSELF,ZTAUN2,ZCORRADJ,ZPP,ZSCALEN2
186REAL(KIND=JPHOOK) :: ZHOOK_HANDLE
187
188! Minor gas mapping levels:
189!     lower - n2, p = 142.5490 mbar, t = 215.70 k
190!     upper - n2, p = 142.5490 mbar, t = 215.70 k
191
192!     Compute the optical depth by interpolating in ln(pressure) and
193!     temperature.  Below LAYTROP, the water vapor self-continuum and
194!     foreign continuum is interpolated (in temperature) separately.
195
196ASSOCIATE(NFLEVG=>KLEV)
197IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL1',0,ZHOOK_HANDLE)
198
199DO JLAY = 1, KLEV
200  DO JLON = KIDIA, KFDIA
201  IF (JLAY <= K_LAYTROP(JLON)) THEN
202    IND0(JLAY) = ((K_JP(JLON,JLAY)-1)*5+(K_JT(JLON,JLAY)-1))*NSPA(1) + 1
203    IND1(JLAY) = (K_JP(JLON,JLAY)*5+(K_JT1(JLON,JLAY)-1))*NSPA(1) + 1
204    INDS(JLAY) = K_INDSELF(JLON,JLAY)
205    INDF(JLAY) = K_INDFOR(JLON,JLAY)
206    INDM(JLAY) = K_INDMINOR(JLON,JLAY)
207    ZPP = PAVEL(JLON,JLAY) !hPa(mb)
208    ZCORRADJ =  1.
209    IF (ZPP < 250._JPRB) THEN
210        ZCORRADJ = 1._JPRB - 0.15_JPRB * (250._JPRB-ZPP) / 154.4_JPRB
211    ENDIF
212
213    ZSCALEN2 = PCOLBRD(JLON,JLAY) * PSCALEMINORN2(JLON,JLAY)
214
215!CDIR UNROLL=NG1
216    DO IG = 1, NG1
217!-- DS_000515 
218           ZTAUSELF = P_SELFFAC(JLON,JLAY) * (SELFREF(INDS(JLAY),IG) + &
219     &           P_SELFFRAC(JLON,JLAY) * &
220     &           (SELFREF(INDS(JLAY)+1,IG) - SELFREF(INDS(JLAY),IG)))
221
222            ZTAUFOR =  P_FORFAC(JLON,JLAY) * (FORREF(INDF(JLAY),IG) + &
223     &           P_FORFRAC(JLON,JLAY) * (FORREF(INDF(JLAY)+1,IG) - &
224     &           FORREF(INDF(JLAY),IG))) 
225
226            ZTAUN2 = ZSCALEN2*(KA_MN2(INDM(JLAY),IG) +   &
227     &           P_MINORFRAC(JLON,JLAY) * &
228     &           (KA_MN2(INDM(JLAY)+1,IG) - KA_MN2(INDM(JLAY),IG)))
229
230            P_TAU(JLON,IG,JLAY) = ZCORRADJ * (P_COLH2O(JLON,JLAY) *  &
231     &          (P_FAC00(JLON,JLAY) * ABSA(IND0(JLAY),IG) + &
232     &           P_FAC10(JLON,JLAY) * ABSA(IND0(JLAY)+1,IG) + &
233     &           P_FAC01(JLON,JLAY) * ABSA(IND1(JLAY),IG) +  &
234     &           P_FAC11(JLON,JLAY) * ABSA(IND1(JLAY)+1,IG))  &
235     &           + ZTAUSELF + ZTAUFOR &
236     &           + ZTAUN2) + P_TAUAERL(JLON,JLAY,1)
237
238            PFRAC(JLON,IG,JLAY) = FRACREFA(IG)
239
240    ENDDO
241  ENDIF
242
243  IF (JLAY > K_LAYTROP(JLON)) THEN
244    IND0(JLAY) = ((K_JP(JLON,JLAY)-13)*5+(K_JT(JLON,JLAY)-1))*NSPB(1) + 1
245    IND1(JLAY) = ((K_JP(JLON,JLAY)-12)*5+(K_JT1(JLON,JLAY)-1))*NSPB(1) + 1
246    INDF(JLAY) = K_INDFOR(JLON,JLAY)
247    INDM(JLAY) = K_INDMINOR(JLON,JLAY)
248    ZPP = PAVEL(JLON,JLAY)  !hPa(mb)
249    ZCORRADJ =  1._JPRB - 0.15_JPRB * (ZPP / 95.6_JPRB)
250
251    ZSCALEN2 = PCOLBRD(JLON,JLAY) * PSCALEMINORN2(JLON,JLAY)
252
253!-- JJM000517
254!CDIR UNROLL=NG1
255    DO IG = 1, NG1
256!-- JJM000517
257            ZTAUFOR = P_FORFAC(JLON,JLAY) * (FORREF(INDF(JLAY),IG) + &
258     &           P_FORFRAC(JLON,JLAY) * &
259     &           (FORREF(INDF(JLAY)+1,IG) - FORREF(INDF(JLAY),IG)))
260
261            ZTAUN2 = ZSCALEN2*(KB_MN2(INDM(JLAY),IG) +  &
262     &           P_MINORFRAC(JLON,JLAY) * &
263     &           (KB_MN2(INDM(JLAY)+1,IG) - KB_MN2(INDM(JLAY),IG)))
264
265            P_TAU(JLON,IG,JLAY) = ZCORRADJ * (P_COLH2O(JLON,JLAY) * &
266     &          (P_FAC00(JLON,JLAY) * ABSB(IND0(JLAY),IG) + &
267     &           P_FAC10(JLON,JLAY) * ABSB(IND0(JLAY)+1,IG) + &
268     &           P_FAC01(JLON,JLAY) * ABSB(IND1(JLAY),IG) + &
269     &           P_FAC11(JLON,JLAY) * ABSB(IND1(JLAY)+1,IG)) & 
270     &           + ZTAUFOR &
271     &           + ZTAUN2)+ P_TAUAERL(JLON,JLAY,1)
272      PFRAC(JLON,IG,JLAY) = FRACREFB(IG)
273
274
275    ENDDO
276  ENDIF
277  ENDDO
278ENDDO
279
280IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL1',1,ZHOOK_HANDLE)
281
282END ASSOCIATE
283END SUBROUTINE RRTM_TAUMOL1
Note: See TracBrowser for help on using the repository browser.