source: LMDZ5/branches/testing/libf/phylmd/rrtm/rrtm_ecrt_140gp.F90 @ 1999

Last change on this file since 1999 was 1999, checked in by Laurent Fairhead, 10 years ago

Merged trunk changes r1920:1997 into testing branch
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 12.9 KB
Line 
1!****************** SUBROUTINE RRTM_ECRT_140GP **************************
2
3SUBROUTINE RRTM_ECRT_140GP &
4 & ( K_IPLON, klon , klev, kcld,&
5 & paer , paph , pap,&
6 & pts  , pth  , pt,&
7 & P_ZEMIS, P_ZEMIW,&
8 & pq   , pcco2, pozn, pcldf, ptaucld, ptclear,&
9 & P_CLDFRAC,P_TAUCLD,P_COLDRY,P_WKL,P_WX,&
10 & P_TAUAERL,PAVEL,P_TAVEL,PZ,P_TZ,P_TBOUND,K_NLAYERS,P_SEMISS,K_IREFLECT) 
11
12!     Reformatted for F90 by JJMorcrette, ECMWF, 980714
13
14!     Read in atmospheric profile from ECMWF radiation code, and prepare it
15!     for use in RRTM.  Set other RRTM input parameters.  Values are passed
16!     back through existing RRTM arrays and commons.
17
18!- Modifications
19
20!     2000-05-15 Deborah Salmond  Speed-up
21
22USE PARKIND1  ,ONLY : JPIM     ,JPRB
23USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
24
25USE PARRRTM  , ONLY : JPBAND   ,JPXSEC   ,JPLAY   ,&
26 & JPINPX 
27USE YOERAD   , ONLY : NOVLP
28USE YOERDI   , ONLY :    RCH4     ,RN2O    ,RCFC11  ,RCFC12
29USE YOESW    , ONLY : RAER
30
31!------------------------------Arguments--------------------------------
32
33IMPLICIT NONE
34
35INTEGER(KIND=JPIM),INTENT(IN)    :: KLON! Number of atmospheres (longitudes)
36INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV! Number of atmospheric layers
37INTEGER(KIND=JPIM),INTENT(IN)    :: K_IPLON
38INTEGER(KIND=JPIM),INTENT(OUT)   :: KCLD
39REAL(KIND=JPRB)   ,INTENT(IN)    :: PAER(KLON,6,KLEV) ! Aerosol optical thickness
40REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPH(KLON,KLEV+1) ! Interface pressures (Pa)
41REAL(KIND=JPRB)   ,INTENT(IN)    :: PAP(KLON,KLEV) ! Layer pressures (Pa)
42REAL(KIND=JPRB)   ,INTENT(IN)    :: PTS(KLON) ! Surface temperature (K)
43REAL(KIND=JPRB)   ,INTENT(IN)    :: PTH(KLON,KLEV+1) ! Interface temperatures (K)
44REAL(KIND=JPRB)   ,INTENT(IN)    :: PT(KLON,KLEV) ! Layer temperature (K)
45REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ZEMIS(KLON) ! Non-window surface emissivity
46REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ZEMIW(KLON) ! Window surface emissivity
47REAL(KIND=JPRB)   ,INTENT(IN)    :: PQ(KLON,KLEV) ! H2O specific humidity (mmr)
48REAL(KIND=JPRB)   ,INTENT(IN)    :: PCCO2 ! CO2 mass mixing ratio
49REAL(KIND=JPRB)   ,INTENT(IN)    :: POZN(KLON,KLEV) ! O3 mass mixing ratio
50REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLDF(KLON,KLEV) ! Cloud fraction
51REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUCLD(KLON,KLEV,JPBAND) ! Cloud optical depth
52REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTCLEAR
53REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_CLDFRAC(JPLAY) ! Cloud fraction
54REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAUCLD(JPLAY,JPBAND) ! Spectral optical thickness
55REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_COLDRY(JPLAY)
56REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_WKL(JPINPX,JPLAY)
57REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_WX(JPXSEC,JPLAY) ! Amount of trace gases
58REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAUAERL(JPLAY,JPBAND)
59REAL(KIND=JPRB)   ,INTENT(OUT)   :: PAVEL(JPLAY)
60REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAVEL(JPLAY)
61REAL(KIND=JPRB)   ,INTENT(OUT)   :: PZ(0:JPLAY)
62REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TZ(0:JPLAY)
63REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TBOUND
64INTEGER(KIND=JPIM),INTENT(OUT)   :: K_NLAYERS
65REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_SEMISS(JPBAND)
66INTEGER(KIND=JPIM),INTENT(OUT)   :: K_IREFLECT
67!      real rch4                       ! CH4 mass mixing ratio
68!      real rn2o                       ! N2O mass mixing ratio
69!      real rcfc11                     ! CFC11 mass mixing ratio
70!      real rcfc12                     ! CFC12 mass mixing ratio
71!- from AER
72!- from PROFILE             
73!- from SURFACE             
74REAL(KIND=JPRB) :: ztauaer(5)
75REAL(KIND=JPRB) :: zc1j(0:klev)               ! total cloud from top and level k
76REAL(KIND=JPRB) :: Z_AMD                  ! Effective molecular weight of dry air (g/mol)
77REAL(KIND=JPRB) :: Z_AMW                  ! Molecular weight of water vapor (g/mol)
78REAL(KIND=JPRB) :: Z_AMCO2                ! Molecular weight of carbon dioxide (g/mol)
79REAL(KIND=JPRB) :: Z_AMO                  ! Molecular weight of ozone (g/mol)
80REAL(KIND=JPRB) :: Z_AMCH4                ! Molecular weight of methane (g/mol)
81REAL(KIND=JPRB) :: Z_AMN2O                ! Molecular weight of nitrous oxide (g/mol)
82REAL(KIND=JPRB) :: Z_AMC11                ! Molecular weight of CFC11 (g/mol) - CFCL3
83REAL(KIND=JPRB) :: Z_AMC12                ! Molecular weight of CFC12 (g/mol) - CF2CL2
84REAL(KIND=JPRB) :: Z_AVGDRO               ! Avogadro's number (molecules/mole)
85REAL(KIND=JPRB) :: Z_GRAVIT               ! Gravitational acceleration (cm/sec2)
86
87! Atomic weights for conversion from mass to volume mixing ratios; these
88!  are the same values used in ECRT to assure accurate conversion to vmr
89data Z_AMD   /  28.970_JPRB    /
90data Z_AMW   /  18.0154_JPRB   /
91data Z_AMCO2 /  44.011_JPRB    /
92data Z_AMO   /  47.9982_JPRB   /
93data Z_AMCH4 /  16.043_JPRB    /
94data Z_AMN2O /  44.013_JPRB    /
95data Z_AMC11 / 137.3686_JPRB   /
96data Z_AMC12 / 120.9140_JPRB   /
97data Z_AVGDRO/ 6.02214E23_JPRB /
98data Z_GRAVIT/ 9.80665E02_JPRB /
99
100INTEGER(KIND=JPIM) :: IATM, IMOL, IXMAX, J1, J2, JAE, JB, JK, JL, I_L
101INTEGER(KIND=JPIM) :: I_NMOL, I_NXMOL
102
103REAL(KIND=JPRB) :: Z_AMM, ZCLDLY, ZCLEAR, ZCLOUD, ZEPSEC
104REAL(KIND=JPRB) :: ZHOOK_HANDLE
105
106! ***
107
108! *** mji
109! Initialize all molecular amounts and aerosol optical depths to zero here,
110! then pass ECRT amounts into RRTM arrays below.
111
112!      DATA ZWKL /MAXPRDW*0.0/
113!      DATA ZWX  /MAXPROD*0.0/
114!      DATA KREFLECT /0/
115
116! Activate cross section molecules:
117!     NXMOL     - number of cross-sections input by user
118!     IXINDX(I) - index of cross-section molecule corresponding to Ith
119!                 cross-section specified by user
120!                 = 0 -- not allowed in RRTM
121!                 = 1 -- CCL4
122!                 = 2 -- CFC11
123!                 = 3 -- CFC12
124!                 = 4 -- CFC22
125!      DATA KXMOL  /2/
126!      DATA KXINDX /0,2,3,0,31*0/
127
128!      IREFLECT=KREFLECT
129!      NXMOL=KXMOL
130
131IF (LHOOK) CALL DR_HOOK('RRTM_ECRT_140GP',0,ZHOOK_HANDLE)
132K_IREFLECT=0
133I_NXMOL=2
134
135DO J1=1,35
136! IXINDX(J1)=0
137  DO J2=1,KLEV
138    P_WKL(J1,J2)=0.0_JPRB
139  ENDDO
140ENDDO
141!IXINDX(2)=2
142!IXINDX(3)=3
143
144!     Set parameters needed for RRTM execution:
145IATM    = 0
146!      IXSECT  = 1
147!      NUMANGS = 0
148!      IOUT    = -1
149IXMAX   = 4
150
151!     Bands 6,7,8 are considered the 'window' and allowed to have a
152!     different surface emissivity (as in ECMWF).  Eli wrote this part....
153P_SEMISS(1)  = P_ZEMIS(K_IPLON)
154P_SEMISS(2)  = P_ZEMIS(K_IPLON)
155P_SEMISS(3)  = P_ZEMIS(K_IPLON)
156P_SEMISS(4)  = P_ZEMIS(K_IPLON)
157P_SEMISS(5)  = P_ZEMIS(K_IPLON)
158P_SEMISS(6)  = P_ZEMIW(K_IPLON)
159P_SEMISS(7)  = P_ZEMIW(K_IPLON)
160P_SEMISS(8)  = P_ZEMIW(K_IPLON)
161P_SEMISS(9)  = P_ZEMIS(K_IPLON)
162P_SEMISS(10) = P_ZEMIS(K_IPLON)
163P_SEMISS(11) = P_ZEMIS(K_IPLON)
164P_SEMISS(12) = P_ZEMIS(K_IPLON)
165P_SEMISS(13) = P_ZEMIS(K_IPLON)
166P_SEMISS(14) = P_ZEMIS(K_IPLON)
167P_SEMISS(15) = P_ZEMIS(K_IPLON)
168P_SEMISS(16) = P_ZEMIS(K_IPLON)
169
170!     Set surface temperature. 
171
172P_TBOUND = pts(K_IPLON)
173
174!     Install ECRT arrays into RRTM arrays for pressure, temperature,
175!     and molecular amounts.  Pressures are converted from Pascals
176!     (ECRT) to mb (RRTM).  H2O, CO2, O3 and trace gas amounts are
177!     converted from mass mixing ratio to volume mixing ratio.  CO2
178!     converted with same dry air and CO2 molecular weights used in
179!     ECRT to assure correct conversion back to the proper CO2 vmr.
180!     The dry air column COLDRY (in molec/cm2) is calculated from
181!     the level pressures PZ (in mb) based on the hydrostatic equation
182!     and includes a correction to account for H2O in the layer.  The
183!     molecular weight of moist air (amm) is calculated for each layer.
184!     Note: RRTM levels count from bottom to top, while the ECRT input
185!     variables count from the top down and must be reversed here.
186
187K_NLAYERS = klev
188I_NMOL = 6
189PZ(0) = paph(K_IPLON,klev+1)/100._JPRB
190P_TZ(0) = pth(K_IPLON,klev+1)
191DO I_L = 1, KLEV
192  PAVEL(I_L) = pap(K_IPLON,KLEV-I_L+1)/100._JPRB
193  P_TAVEL(I_L) = pt(K_IPLON,KLEV-I_L+1)
194  PZ(I_L) = paph(K_IPLON,KLEV-I_L+1)/100._JPRB
195  P_TZ(I_L) = pth(K_IPLON,KLEV-I_L+1)
196  P_WKL(1,I_L) = pq(K_IPLON,KLEV-I_L+1)*Z_AMD/Z_AMW
197  P_WKL(2,I_L) = pcco2*Z_AMD/Z_AMCO2
198  P_WKL(3,I_L) = pozn(K_IPLON,KLEV-I_L+1)*Z_AMD/Z_AMO
199  P_WKL(4,I_L) = rn2o*Z_AMD/Z_AMN2O
200  P_WKL(6,I_L) = rch4*Z_AMD/Z_AMCH4
201  Z_AMM = (1-P_WKL(1,I_L))*Z_AMD + P_WKL(1,I_L)*Z_AMW
202  P_COLDRY(I_L) = (PZ(I_L-1)-PZ(I_L))*1.E3_JPRB*Z_AVGDRO/(Z_GRAVIT*Z_AMM*(1+P_WKL(1,I_L)))
203ENDDO
204
205!- Fill RRTM aerosol arrays with operational ECMWF aerosols,
206!  do the mixing and distribute over the 16 spectral intervals
207
208DO I_L=1,KLEV
209  JK=KLEV-I_L+1
210!       DO JAE=1,5
211  JAE=1
212  ZTAUAER(JAE) =&
213   & RAER(JAE,1)*PAER(K_IPLON,1,JK)+RAER(JAE,2)*PAER(K_IPLON,2,JK)&
214   & +RAER(JAE,3)*PAER(K_IPLON,3,JK)+RAER(JAE,4)*PAER(K_IPLON,4,JK)&
215   & +RAER(JAE,5)*PAER(K_IPLON,5,JK)+RAER(JAE,6)*PAER(K_IPLON,6,JK) 
216  P_TAUAERL(I_L, 1)=ZTAUAER(1)
217  P_TAUAERL(I_L, 2)=ZTAUAER(1)
218  JAE=2
219  ZTAUAER(JAE) =&
220   & RAER(JAE,1)*PAER(K_IPLON,1,JK)+RAER(JAE,2)*PAER(K_IPLON,2,JK)&
221   & +RAER(JAE,3)*PAER(K_IPLON,3,JK)+RAER(JAE,4)*PAER(K_IPLON,4,JK)&
222   & +RAER(JAE,5)*PAER(K_IPLON,5,JK)+RAER(JAE,6)*PAER(K_IPLON,6,JK) 
223  P_TAUAERL(I_L, 3)=ZTAUAER(2)
224  P_TAUAERL(I_L, 4)=ZTAUAER(2)
225  P_TAUAERL(I_L, 5)=ZTAUAER(2)
226  JAE=3
227  ZTAUAER(JAE) =&
228   & RAER(JAE,1)*PAER(K_IPLON,1,JK)+RAER(JAE,2)*PAER(K_IPLON,2,JK)&
229   & +RAER(JAE,3)*PAER(K_IPLON,3,JK)+RAER(JAE,4)*PAER(K_IPLON,4,JK)&
230   & +RAER(JAE,5)*PAER(K_IPLON,5,JK)+RAER(JAE,6)*PAER(K_IPLON,6,JK) 
231  P_TAUAERL(I_L, 6)=ZTAUAER(3)
232  P_TAUAERL(I_L, 8)=ZTAUAER(3)
233  P_TAUAERL(I_L, 9)=ZTAUAER(3)
234  JAE=4
235  ZTAUAER(JAE) =&
236   & RAER(JAE,1)*PAER(K_IPLON,1,JK)+RAER(JAE,2)*PAER(K_IPLON,2,JK)&
237   & +RAER(JAE,3)*PAER(K_IPLON,3,JK)+RAER(JAE,4)*PAER(K_IPLON,4,JK)&
238   & +RAER(JAE,5)*PAER(K_IPLON,5,JK)+RAER(JAE,6)*PAER(K_IPLON,6,JK) 
239  P_TAUAERL(I_L, 7)=ZTAUAER(4)
240  JAE=5
241  ZTAUAER(JAE) =&
242   & RAER(JAE,1)*PAER(K_IPLON,1,JK)+RAER(JAE,2)*PAER(K_IPLON,2,JK)&
243   & +RAER(JAE,3)*PAER(K_IPLON,3,JK)+RAER(JAE,4)*PAER(K_IPLON,4,JK)&
244   & +RAER(JAE,5)*PAER(K_IPLON,5,JK)+RAER(JAE,6)*PAER(K_IPLON,6,JK) 
245!       END DO
246  P_TAUAERL(I_L,10)=ZTAUAER(5)
247  P_TAUAERL(I_L,11)=ZTAUAER(5)
248  P_TAUAERL(I_L,12)=ZTAUAER(5)
249  P_TAUAERL(I_L,13)=ZTAUAER(5)
250  P_TAUAERL(I_L,14)=ZTAUAER(5)
251  P_TAUAERL(I_L,15)=ZTAUAER(5)
252  P_TAUAERL(I_L,16)=ZTAUAER(5)
253ENDDO
254
255DO J2=1,KLEV
256  DO J1=1,JPXSEC
257    P_WX(J1,J2)=0.0_JPRB
258  ENDDO
259ENDDO
260
261DO I_L = 1, KLEV
262!- Set cross section molecule amounts from ECRT; convert to vmr
263  P_WX(2,I_L) = rcfc11*Z_AMD/Z_AMC11
264  P_WX(3,I_L) = rcfc12*Z_AMD/Z_AMC12
265  P_WX(2,I_L) = P_COLDRY(I_L) * P_WX(2,I_L) * 1.E-20_JPRB
266  P_WX(3,I_L) = P_COLDRY(I_L) * P_WX(3,I_L) * 1.E-20_JPRB
267
268!- Here, all molecules in WKL and WX are in volume mixing ratio; convert to
269!  molec/cm2 based on COLDRY for use in RRTM
270
271  DO IMOL = 1, I_NMOL
272    P_WKL(IMOL,I_L) = P_COLDRY(I_L) * P_WKL(IMOL,I_L)
273  ENDDO 
274 
275! DO IX = 1,JPXSEC
276! IF (IXINDX(IX)  /=  0) THEN
277!     WX(IXINDX(IX),L) = COLDRY(L) * WX(IX,L) * 1.E-20_JPRB
278! ENDIF
279! END DO 
280
281ENDDO
282
283!- Approximate treatment for various cloud overlaps
284ZCLEAR=1.0_JPRB
285ZCLOUD=0.0_JPRB
286ZC1J(0)=0.0_JPRB
287ZEPSEC=1.E-03_JPRB
288JL=K_IPLON
289
290!++MODIFCODE
291IF ((NOVLP == 1).OR.(NOVLP ==6).OR.(NOVLP ==8)) THEN
292!--MODIFCODE
293
294  DO JK=1,KLEV
295    IF (pcldf(JL,JK) > ZEPSEC) THEN
296      ZCLDLY=pcldf(JL,JK)
297      ZCLEAR=ZCLEAR &
298       & *(1.0_JPRB-MAX( ZCLDLY , ZCLOUD ))&
299       & /(1.0_JPRB-MIN( ZCLOUD , 1.0_JPRB-ZEPSEC )) 
300      ZCLOUD = ZCLDLY
301      ZC1J(JK)= 1.0_JPRB - ZCLEAR
302    ELSE
303      ZCLDLY=0.0_JPRB
304      ZCLEAR=ZCLEAR &
305       & *(1.0_JPRB-MAX( ZCLDLY , ZCLOUD ))&
306       & /(1.0_JPRB-MIN( ZCLOUD , 1.0_JPRB-ZEPSEC )) 
307      ZCLOUD = ZCLDLY
308      ZC1J(JK)= 1.0_JPRB - ZCLEAR
309    ENDIF
310  ENDDO
311
312!++MODIFCODE
313ELSEIF ((NOVLP == 2).OR.(NOVLP ==7)) THEN
314!--MODIFCODE
315
316  DO JK=1,KLEV
317    IF (pcldf(JL,JK) > ZEPSEC) THEN
318      ZCLDLY=pcldf(JL,JK)
319      ZCLOUD = MAX( ZCLDLY , ZCLOUD )
320      ZC1J(JK) = ZCLOUD
321    ELSE
322      ZCLDLY=0.0_JPRB
323      ZCLOUD = MAX( ZCLDLY , ZCLOUD )
324      ZC1J(JK) = ZCLOUD
325    ENDIF
326  ENDDO
327
328!++MODIFCODE
329ELSEIF ((NOVLP == 3).OR.(NOVLP ==5)) THEN
330!--MODIFCODE
331
332  DO JK=1,KLEV
333    IF (pcldf(JL,JK) > ZEPSEC) THEN
334      ZCLDLY=pcldf(JL,JK)
335      ZCLEAR = ZCLEAR * (1.0_JPRB-ZCLDLY)
336      ZCLOUD = 1.0_JPRB - ZCLEAR
337      ZC1J(JK) = ZCLOUD
338    ELSE
339      ZCLDLY=0.0_JPRB
340      ZCLEAR = ZCLEAR * (1.0_JPRB-ZCLDLY)
341      ZCLOUD = 1.0_JPRB - ZCLEAR
342      ZC1J(JK) = ZCLOUD
343    ENDIF
344  ENDDO
345
346ELSEIF (NOVLP == 4) THEN
347
348ENDIF
349PTCLEAR=1.0_JPRB-ZC1J(KLEV)
350
351! Transfer cloud fraction and cloud optical depth to RRTM arrays;
352! invert array index for pcldf to go from bottom to top for RRTM
353
354!- clear-sky column
355IF (PTCLEAR  >  1.0_JPRB-ZEPSEC) THEN
356  KCLD=0
357  DO I_L = 1, KLEV
358    P_CLDFRAC(I_L) = 0.0_JPRB
359  ENDDO
360  DO JB=1,JPBAND
361    DO I_L=1,KLEV
362      P_TAUCLD(I_L,JB) = 0.0_JPRB
363    ENDDO
364  ENDDO
365
366ELSE
367
368!- cloudy column
369!   The diffusivity factor (Savijarvi, 1997) on the cloud optical
370!   thickness TAUCLD has already been applied in RADLSW
371
372  KCLD=1
373  DO I_L=1,KLEV
374    P_CLDFRAC(I_L) = pcldf(K_IPLON,I_L)
375  ENDDO
376  DO JB=1,JPBAND
377    DO I_L=1,KLEV
378      P_TAUCLD(I_L,JB) = ptaucld(K_IPLON,I_L,JB)
379    ENDDO
380  ENDDO
381
382ENDIF
383
384!     ------------------------------------------------------------------
385
386IF (LHOOK) CALL DR_HOOK('RRTM_ECRT_140GP',1,ZHOOK_HANDLE)
387END SUBROUTINE RRTM_ECRT_140GP
Note: See TracBrowser for help on using the repository browser.