source: LMDZ6/branches/Amaury_dev/libf/phylmd/ecrad.v1.5.1/rrtm_taumol1.F90

Last change on this file was 5159, checked in by abarral, 3 months ago

Put dimensions.h and paramet.h into modules
File size: 15.3 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
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=JPRB) :: 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.