source: LMDZ5/branches/testing/libf/phymar/swr.F90 @ 5003

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

Merged trunk changes -r2070:2158 into testing branch. Compilation problems introduced by revision r2155 have been corrected by hand
File size: 10.5 KB
RevLine 
[2089]1SUBROUTINE SWR &
2 &( KIDIA , KFDIA , KLON , KLEV  , KNU &
3 &, PALBD , PCG   , PCLD , POMEGA, PSEC , PTAU &
4 &, PCGAZ , PPIZAZ, PRAY1, PRAY2 , PREFZ, PRJ  , PRK , PRMUE &
5 &, PTAUAZ, PTRA1 , PTRA2, PTRCLD &
6 &)
7
8!**** *SWR* - CONTINUUM SCATTERING COMPUTATIONS
9
10!     PURPOSE.
11!     --------
12!           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
13!     CONTINUUM SCATTERING
14
15!**   INTERFACE.
16!     ----------
17
18!          *SWR* IS CALLED EITHER FROM *SW1S*
19!                              OR FROM *SWNI*
20
21!        IMPLICIT ARGUMENTS :
22!        --------------------
23
24!     ==== INPUTS ===
25!     ==== OUTPUTS ===
26
27!     METHOD.
28!     -------
29
30!          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
31!     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
32
33!     EXTERNALS.
34!     ----------
35
36!          *SWDE*
37
38!     REFERENCE.
39!     ----------
40
41!        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
42!        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
43
44!     AUTHOR.
45!     -------
46!        JEAN-JACQUES MORCRETTE  *ECMWF*
47
48!     MODIFICATIONS.
49!     --------------
50!        ORIGINAL : 89-07-14
51!        Ph. DANDIN Meteo-France 05-96 : Effect of cloud layer
52!        JJMorcrette 990128 : sunshine duration
53!        JJMorcrette 001218 : 6 spectral intervals
54!     ------------------------------------------------------------------
55
56
57#include "tsmbkind.h"
58
59USE YOERAD   , ONLY : NOVLP    ,NSW
60USE YOECLD   , ONLY : REPSEC
61USE YOEOVLP  , ONLY : RA1OVLP
62
63
64IMPLICIT NONE
65
66
67!     DUMMY INTEGER SCALARS
68INTEGER_M :: KFDIA
69INTEGER_M :: KIDIA
70INTEGER_M :: KLEV
71INTEGER_M :: KLON
72INTEGER_M :: KNU
73
74
75
76!     ------------------------------------------------------------------
77
78!*       0.1   ARGUMENTS
79!              ---------
80
81REAL_B :: PALBD(KLON,NSW)      , PCG(KLON,NSW,KLEV)&
82  &,  PCLD(KLON,KLEV)&
83  &,  POMEGA(KLON,NSW,KLEV)&
84  &,  PSEC(KLON)           , PTAU(KLON,NSW,KLEV)
85
86REAL_B :: PRAY1(KLON,KLEV+1)   , PRAY2(KLON,KLEV+1)&
87  &,  PREFZ(KLON,2,KLEV+1) , PRJ(KLON,6,KLEV+1)&
88  &,  PRK(KLON,6,KLEV+1)   , PRMUE(KLON,KLEV+1)&
89  &,  PCGAZ(KLON,KLEV)     , PPIZAZ(KLON,KLEV)&
90  &,  PTAUAZ(KLON,KLEV)&
91  &,  PTRA1(KLON,KLEV+1)   , PTRA2(KLON,KLEV+1)&
92  &,  PTRCLD(KLON)
93
94!     ------------------------------------------------------------------
95
96!*       0.2   LOCAL ARRAYS
97!              ------------
98
99REAL_B :: ZC1I(KLON,KLEV+1)    , ZCLEQ(KLON,KLEV)&
100  &,  ZCLEAR(KLON)         , ZCLOUD(KLON) &
101  &,  ZGG(KLON)            , ZREF(KLON)&
102  &,  ZRE1(KLON)           , ZRE2(KLON)&
103  &,  ZRMUZ(KLON)          , ZRNEB(KLON)&
104  &,  ZR21(KLON)           , ZR22(KLON)&
105  &,  ZR23(KLON)           , ZSS1(KLON)&
106  &,  ZTO1(KLON)           , ZTR(KLON,2,KLEV+1)&
107  &,  ZTR1(KLON)           , ZTR2(KLON)&
108  &,  ZW(KLON)
109
110!     LOCAL INTEGER SCALARS
111INTEGER_M :: IKL, IKLP1, JA, JAJ, JK, JKM1, JL, INU1
112
113!     LOCAL REAL SCALARS
114REAL_B :: ZBMU0, ZBMU1, ZCORAE, ZCORCD, ZDEN, ZDEN1,&
115          &ZFACOA, ZFACOC, ZGAP, ZMU1, ZMUE, ZRE11, &
116          &ZTO, ZWW, ZALPHA1
117
118
119
120
121!     ------------------------------------------------------------------
122
123!*         1.    INITIALIZATION
124!                --------------
125
126
127DO JK = 1 , KLEV+1
128  DO JA = 1 , 6
129    DO JL = KIDIA,KFDIA
130      PRJ(JL,JA,JK) = _ZERO_
131      PRK(JL,JA,JK) = _ZERO_
132    ENDDO
133  ENDDO
134ENDDO
135
136
137!     ------------------------------------------------------------------
138
139!*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
140!                ----------------------------------------------
141
142
143DO JL = KIDIA,KFDIA
144  ZR23(JL) = _ZERO_
145  ZC1I(JL,KLEV+1) = _ZERO_
146  ZCLEAR(JL) = _ONE_
147  ZCLOUD(JL) = _ZERO_
148ENDDO
149
150JK = 1
151IKL = KLEV+1 - JK
152IKLP1 = IKL + 1
153DO JL = KIDIA,KFDIA
154  ZFACOA = _ONE_ - PPIZAZ(JL,IKL)*PCGAZ(JL,IKL)*PCGAZ(JL,IKL)
155  ZFACOC = _ONE_ - POMEGA(JL,KNU,IKL) * PCG(JL,KNU,IKL)* PCG(JL,KNU,IKL)
156  ZCORAE = ZFACOA * PTAUAZ(JL,IKL) * PSEC(JL)
157  ZCORCD = ZFACOC * PTAU(JL,KNU,IKL) * PSEC(JL)
158  ZR21(JL) = EXP(MIN(-ZCORAE,500.)   )
159  ZR22(JL) = EXP(MIN(-ZCORCD,500.)   )
160  ZSS1(JL) = PCLD(JL,IKL)*(_ONE_-ZR21(JL)*ZR22(JL))&
161   &+ (_ONE_-PCLD(JL,IKL))*(_ONE_-ZR21(JL))
162  ZCLEQ(JL,IKL) = ZSS1(JL)
163
164  IF (NOVLP == 1) THEN
165!* maximum-random     
166    ZCLEAR(JL) = ZCLEAR(JL)&
167     &*(_ONE_-MAX(ZSS1(JL),ZCLOUD(JL)))&
168     &/(_ONE_-MIN(ZCLOUD(JL),_ONE_-REPSEC))
169    ZC1I(JL,IKL) = _ONE_ - ZCLEAR(JL)
170    ZCLOUD(JL) = ZSS1(JL)
171  ELSEIF (NOVLP == 2) THEN
172!* maximum
173    ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
174    ZC1I(JL,IKL) = ZCLOUD(JL)
175  ELSEIF (NOVLP == 3) THEN
176!* random
177    ZCLEAR(JL) = ZCLEAR(JL)*(_ONE_ - ZSS1(JL))
178    ZCLOUD(JL) = _ONE_ - ZCLEAR(JL)
179    ZC1I(JL,IKL) = ZCLOUD(JL)
180  ELSEIF (NOVLP == 4) THEN
181!* Hogan & Illingworth, 2001 
182    ZALPHA1=RA1OVLP(KLEV+1-JK)
183    ZCLEAR(JL)=ZCLEAR(JL)*( &
184      & ZALPHA1*(_ONE_-MAX(ZSS1(JL),ZCLOUD(JL))) &
185      &        /(_ONE_-MIN(ZCLOUD(JL),_ONE_-REPSEC)) &
186      & +(_ONE_-ZALPHA1)*(_ONE_-ZSS1(JL)) )
187    ZC1I(JL,IKL) = _ONE_ - ZCLEAR(JL)
188    ZCLOUD(JL) = ZSS1(JL)
189  ENDIF
190ENDDO
191
192DO JK = 2 , KLEV
193  IKL = KLEV+1 - JK
194  IKLP1 = IKL + 1
195  DO JL = KIDIA,KFDIA
196    ZFACOA = _ONE_ - PPIZAZ(JL,IKL)*PCGAZ(JL,IKL)*PCGAZ(JL,IKL)
197    ZFACOC = _ONE_ - POMEGA(JL,KNU,IKL) * PCG(JL,KNU,IKL)* PCG(JL,KNU,IKL)
198    ZCORAE = ZFACOA * PTAUAZ(JL,IKL) * PSEC(JL)
199    ZCORCD = ZFACOC * PTAU(JL,KNU,IKL) * PSEC(JL)
200    ZR21(JL) = EXP(MIN(-ZCORAE,500.)   )
201    ZR22(JL) = EXP(MIN(-ZCORCD,500.)   )
202    ZSS1(JL) = PCLD(JL,IKL)*(_ONE_-ZR21(JL)*ZR22(JL))&
203     &+ (_ONE_-PCLD(JL,IKL))*(_ONE_-ZR21(JL))
204    ZCLEQ(JL,IKL) = ZSS1(JL)
205
206    IF (NOVLP == 1) THEN
207!* maximum-random     
208      ZCLEAR(JL) = ZCLEAR(JL)&
209       &*(_ONE_-MAX(ZSS1(JL),ZCLOUD(JL)))&
210       &/(_ONE_-MIN(ZCLOUD(JL),_ONE_-REPSEC))
211      ZC1I(JL,IKL) = _ONE_ - ZCLEAR(JL)
212      ZCLOUD(JL) = ZSS1(JL)
213    ELSEIF (NOVLP == 2) THEN
214!* maximum
215      ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
216      ZC1I(JL,IKL) = ZCLOUD(JL)
217    ELSEIF (NOVLP == 3) THEN
218!* random
219      ZCLEAR(JL) = ZCLEAR(JL)*(_ONE_ - ZSS1(JL))
220      ZCLOUD(JL) = _ONE_ - ZCLEAR(JL)
221      ZC1I(JL,IKL) = ZCLOUD(JL)
222    ELSEIF (NOVLP == 4) THEN
223!* Hogan & Illingworth, 2001 
224      ZALPHA1=RA1OVLP(KLEV+1-JK)
225      ZCLEAR(JL)=ZCLEAR(JL)*( &
226        & ZALPHA1*(_ONE_-MAX(ZSS1(JL),ZCLOUD(JL))) &
227        &        /(_ONE_-MIN(ZCLOUD(JL),_ONE_-REPSEC)) &
228        & +(_ONE_-ZALPHA1)*(_ONE_-ZSS1(JL)) )
229      ZC1I(JL,IKL) = _ONE_ - ZCLEAR(JL)
230      ZCLOUD(JL) = ZSS1(JL)
231    ENDIF
232  ENDDO
233ENDDO
234
235!     ------------------------------------------------------------------
236
237!*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
238!                -----------------------------------------------
239
240
241DO JL = KIDIA,KFDIA
242  PRAY1(JL,KLEV+1) = _ZERO_
243  PRAY2(JL,KLEV+1) = _ZERO_
244  PREFZ(JL,2,1) = PALBD(JL,KNU)
245  PREFZ(JL,1,1) = PALBD(JL,KNU)
246  PTRA1(JL,KLEV+1) = _ONE_
247  PTRA2(JL,KLEV+1) = _ONE_
248ENDDO
249
250DO JK = 2 , KLEV+1
251  JKM1 = JK-1
252  DO JL = KIDIA,KFDIA
253    ZRNEB(JL)= PCLD(JL,JKM1)
254    ZRE1(JL)=_ZERO_
255    ZTR1(JL)=_ZERO_
256    ZRE2(JL)=_ZERO_
257    ZTR2(JL)=_ZERO_
258
259
260!     ------------------------------------------------------------------
261
262!*         3.1  EQUIVALENT ZENITH ANGLE
263!               -----------------------
264
265
266    ZMUE = (_ONE_-ZC1I(JL,JK)) * PSEC(JL)+ ZC1I(JL,JK) * 1.66_JPRB
267!-- just to test Box-type computations
268!    ZMUE = PSEC(JL)
269    PRMUE(JL,JK) = _ONE_/ZMUE
270
271
272!     ------------------------------------------------------------------
273
274!*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
275!               ----------------------------------------------------
276
277
278    ZGAP = PCGAZ(JL,JKM1)
279    ZBMU0 = _HALF_ - 0.75_JPRB * ZGAP / ZMUE
280    ZWW = PPIZAZ(JL,JKM1)
281    ZTO = PTAUAZ(JL,JKM1)
282    ZDEN = _ONE_ + (_ONE_ - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE &
283     &+ (1-ZWW) * (_ONE_ - ZWW +_TWO_*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
284    PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
285    PTRA1(JL,JKM1) = _ONE_ / ZDEN
286
287    ZMU1 = _HALF_
288    ZBMU1 = _HALF_ - 0.75_JPRB * ZGAP * ZMU1
289    ZDEN1= _ONE_ + (_ONE_ - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1 &
290     &+ (1-ZWW) * (_ONE_ - ZWW +_TWO_*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
291    PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
292    PTRA2(JL,JKM1) = _ONE_ / ZDEN1
293
294
295!     ------------------------------------------------------------------
296
297!*         3.3  EFFECT OF CLOUD LAYER
298!               ---------------------
299
300
301    ZW(JL) = POMEGA(JL,KNU,JKM1)
302    ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)+ PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
303    ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
304    ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
305    ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)&
306     &+ (_ONE_ - ZR22(JL)) * PCGAZ(JL,JKM1)
307    IF (ZW(JL) == _ONE_ .AND. PPIZAZ(JL,JKM1) == _ONE_) THEN
308      ZW(JL)=_ONE_
309    ELSE
310      ZW(JL) = ZR21(JL) / ZTO1(JL)
311    ENDIF
312    ZREF(JL) = PREFZ(JL,1,JKM1)
313    ZRMUZ(JL) = PRMUE(JL,JK)
314  ENDDO
315
316  CALL SWDE ( KIDIA, KFDIA , KLON &
317   &, ZGG  , ZREF  , ZRMUZ , ZTO1 , ZW &
318   &, ZRE1 , ZRE2  , ZTR1  , ZTR2      )
319
320  DO JL = KIDIA,KFDIA
321
322    PREFZ(JL,1,JK) = (_ONE_-ZRNEB(JL)) * (PRAY1(JL,JKM1)&
323     &+ PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)&
324     &* PTRA2(JL,JKM1)&
325     &/ (_ONE_-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))&
326     &+ ZRNEB(JL) * ZRE2(JL)
327
328    ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)&
329     &/ (_ONE_-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))&
330     &* (_ONE_-ZRNEB(JL))
331
332    PREFZ(JL,2,JK) = (_ONE_-ZRNEB(JL)) * (PRAY1(JL,JKM1)&
333     &+ PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)&
334     &* PTRA2(JL,JKM1) )&
335     &+ ZRNEB(JL) * ZRE1(JL)
336
337    ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)+ PTRA1(JL,JKM1) * (_ONE_-ZRNEB(JL))
338
339  ENDDO
340ENDDO
341DO JL = KIDIA,KFDIA
342  ZMUE = (_ONE_-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66_JPRB
343!-- just to test Box-type computations
344!  ZMUE = PSEC(JL)
345  PRMUE(JL,1)=_ONE_/ZMUE
346  PTRCLD(JL)=_ONE_-ZC1I(JL,1)
347ENDDO
348
349
350!     ------------------------------------------------------------------
351
352!*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
353!                 -------------------------------------------------
354
355
356IF (NSW <= 4) THEN
357  INU1=1
358ELSE IF (NSW == 6) THEN
359  INU1=3
360END IF   
361
362IF (KNU <= INU1) THEN
363  JAJ = 2
364  DO JL = KIDIA,KFDIA
365    PRJ(JL,JAJ,KLEV+1) = _ONE_
366    PRK(JL,JAJ,KLEV+1) = PREFZ(JL, 1,KLEV+1)
367  ENDDO
368
369  DO JK = 1 , KLEV
370    IKL = KLEV+1 - JK
371    IKLP1 = IKL + 1
372    DO JL = KIDIA,KFDIA
373      ZRE11= PRJ(JL,JAJ,IKLP1) * ZTR(JL,  1,IKL)
374      PRJ(JL,JAJ,IKL) = ZRE11
375      PRK(JL,JAJ,IKL) = ZRE11 * PREFZ(JL,  1,IKL)
376    ENDDO
377  ENDDO
378
379ELSE
380
381  DO JAJ = 1 , 2
382    DO JL = KIDIA,KFDIA
383      PRJ(JL,JAJ,KLEV+1) = _ONE_
384      PRK(JL,JAJ,KLEV+1) = PREFZ(JL,JAJ,KLEV+1)
385    ENDDO
386
387    DO JK = 1 , KLEV
388      IKL = KLEV+1 - JK
389      IKLP1 = IKL + 1
390      DO JL = KIDIA,KFDIA
391        ZRE11= PRJ(JL,JAJ,IKLP1) * ZTR(JL,JAJ,IKL)
392        PRJ(JL,JAJ,IKL) = ZRE11
393        PRK(JL,JAJ,IKL) = ZRE11 * PREFZ(JL,JAJ,IKL)
394      ENDDO
395    ENDDO
396  ENDDO
397
398ENDIF
399
400!     ------------------------------------------------------------------
401
402RETURN
403END SUBROUTINE SWR
Note: See TracBrowser for help on using the repository browser.