LMDZ
swni.F90
Go to the documentation of this file.
1 SUBROUTINE swni &
2  & ( kidia , kfdia , klon , klev , kaer , knu,&
3  & paer , paki , palbd , palbp, pcg , pcld, pclear,&
4  & pdsig , pomega, poz , prmu , psec , ptau,&
5  & pud , pwv , pqs,&
6  & pfdown, pfup , pcdown, pcup , psudu2, pdiff , pdirf, &
7 !++MODIFCODE
8 & lrdust,ppiza_dst,pcga_dst,ptaurel_dst )
9 !--MODIFCODE
10 
11 !**** *SWNI* - SHORTWAVE RADIATION, NEAR-INFRARED SPECTRAL INTERVALS
12 
13 ! PURPOSE.
14 ! --------
15 
16 ! COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE NEAR-INFRARED
17 ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
18 
19 !** INTERFACE.
20 ! ----------
21 
22 ! *SWNI* IS CALLED FROM *SW*.
23 
24 ! IMPLICIT ARGUMENTS :
25 ! --------------------
26 
27 ! ==== INPUTS ===
28 ! ==== OUTPUTS ===
29 
30 ! METHOD.
31 ! -------
32 
33 ! 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
34 ! CONTINUUM SCATTERING
35 ! 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
36 ! A GREY MOLECULAR ABSORPTION
37 ! 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
38 ! OF ABSORBERS
39 ! 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
40 ! 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
41 
42 ! EXTERNALS.
43 ! ----------
44 
45 ! *SWCLR*, *SWR*, *SWDE*, *SWTT*
46 
47 ! REFERENCE.
48 ! ----------
49 
50 ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
51 ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
52 
53 ! AUTHOR.
54 ! -------
55 ! JEAN-JACQUES MORCRETTE *ECMWF*
56 
57 ! MODIFICATIONS.
58 ! --------------
59 ! ORIGINAL : 89-07-14
60 ! 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
61 ! 95-12-07 J.-J. MORCRETTE NEAR-INFRARED SW
62 ! 990128 JJMorcrette Sunshine duration
63 ! 99-05-25 JJMorcrette Revised aerosols
64 ! 03-03-17 JJMorcrette Sunshine duration (correction)
65 ! 03-10-10 Deborah Salmond and Marta Janiskova Optimisation
66 ! M.Hamrud 01-Oct-2003 CY28 Cleaning
67 ! 04-11-18 Y.Seity : add 2 arguments for AROME extern. surface
68 ! Y.Seity 05-10-10 : add add 3 optional arg. for dust SW properties
69 ! Y.Seity 06-09-09 : add modset from O.Thouron (MesoNH) under NOVLP tests
70 ! ------------------------------------------------------------------
71 
72 USE parkind1 ,ONLY : jpim ,jprb
73 USE yomhook ,ONLY : lhook, dr_hook
74 
75 USE yoesw , ONLY : rray ,rsun ,rswce ,rswcp
76 !++MODIFCODE
77 !USE YOERAD , ONLY : NSW ,NOVLP
78 ! NSW mis dans .def MPL 20140211
79 USE yoerad , ONLY : novlp
80 !--MODIFCODE
81 USE yoerdu , ONLY : replog ,repscq ,repsc
82 USE write_field_phy
83 
84 IMPLICIT NONE
85 
86 include "clesphys.h"
87 
88 character*1 str1
89 INTEGER(KIND=JPIM),INTENT(IN) :: KLON
90 INTEGER(KIND=JPIM),INTENT(IN) :: KLEV
91 INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA
92 INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA
93 INTEGER(KIND=JPIM),INTENT(IN) :: KAER
94 INTEGER(KIND=JPIM),INTENT(IN) :: KNU
95 REAL(KIND=JPRB) ,INTENT(IN) :: PAER(klon,6,klev)
96 REAL(KIND=JPRB) ,INTENT(IN) :: PAKI(klon,2,nsw)
97 REAL(KIND=JPRB) ,INTENT(IN) :: PALBD(klon,nsw)
98 REAL(KIND=JPRB) ,INTENT(IN) :: PALBP(klon,nsw)
99 REAL(KIND=JPRB) ,INTENT(IN) :: PCG(klon,nsw,klev)
100 REAL(KIND=JPRB) ,INTENT(IN) :: PCLD(klon,klev)
101 REAL(KIND=JPRB) ,INTENT(IN) :: PCLEAR(klon)
102 REAL(KIND=JPRB) ,INTENT(IN) :: PDSIG(klon,klev)
103 REAL(KIND=JPRB) ,INTENT(IN) :: POMEGA(klon,nsw,klev)
104 REAL(KIND=JPRB) ,INTENT(IN) :: POZ(klon,klev)
105 REAL(KIND=JPRB) ,INTENT(IN) :: PRMU(klon)
106 REAL(KIND=JPRB) ,INTENT(IN) :: PSEC(klon)
107 REAL(KIND=JPRB) ,INTENT(IN) :: PTAU(klon,nsw,klev)
108 REAL(KIND=JPRB) ,INTENT(IN) :: PUD(klon,5,klev+1)
109 REAL(KIND=JPRB) ,INTENT(IN) :: PWV(klon,klev)
110 REAL(KIND=JPRB) ,INTENT(IN) :: PQS(klon,klev)
111 !++MODIFCODE
112 LOGICAL ,INTENT(IN) :: LRDUST
113 REAL(KIND=JPRB) ,INTENT(IN) :: PPIZA_DST(klon,klev)
114 REAL(KIND=JPRB) ,INTENT(IN) :: PCGA_DST(klon,klev)
115 REAL(KIND=JPRB) ,INTENT(IN) :: PTAUREL_DST(klon,klev)
116 !--MODIFCODE
117 REAL(KIND=JPRB) ,INTENT(OUT) :: PFDOWN(klon,klev+1)
118 REAL(KIND=JPRB) ,INTENT(OUT) :: PFUP(klon,klev+1)
119 REAL(KIND=JPRB) ,INTENT(OUT) :: PCDOWN(klon,klev+1)
120 REAL(KIND=JPRB) ,INTENT(OUT) :: PCUP(klon,klev+1)
121 REAL(KIND=JPRB) ,INTENT(OUT) :: PSUDU2(klon)
122 REAL(KIND=JPRB) ,INTENT(OUT) :: PDIFF(klon,klev)
123 REAL(KIND=JPRB) ,INTENT(OUT) :: PDIRF(klon,klev)
124 !#include "yoeaer.h"
125 ! ------------------------------------------------------------------
126 
127 !* 0.1 ARGUMENTS
128 ! ---------
129 
130 ! ------------------------------------------------------------------
131 
132 ! ------------
133 
134 INTEGER(KIND=JPIM) :: IIND2(2), IIND3(6)
135 REAL(KIND=JPRB) :: ZCGAZ(klon,klev) , ZDIFF(klon) , ZDIRF(klon)&
136  & , ZFD(KLON,KLEV+1) , ZFU(KLON,KLEV+1) &
137  & , ZG(KLON) , ZGG(KLON)
138 REAL(KIND=JPRB) :: ZPIZAZ(klon,klev)&
139  & , ZRAYL(KLON) , ZRAY1(KLON,KLEV+1) , ZRAY2(KLON,KLEV+1)&
140  & , ZREF(KLON) , ZREFZ(KLON,2,KLEV+1)&
141  & , ZRE1(KLON) , ZRE2(KLON)&
142  & , ZRJ(KLON,6,KLEV+1), ZRJ0(KLON,6,KLEV+1)&
143  & , ZRK(KLON,6,KLEV+1), ZRK0(KLON,6,KLEV+1)&
144  & , ZRL(KLON,8)&
145  & , ZRMUE(KLON,KLEV+1), ZRMU0(KLON,KLEV+1) , ZRMUZ(KLON)&
146  & , ZRNEB(KLON) , ZRUEF(KLON,8) , ZR1(KLON) &
147  & , ZR2(KLON,2) , ZR3(KLON,6) , ZR4(KLON,2)&
148  & , ZR21(KLON) , ZR22(KLON)
149 REAL(KIND=JPRB) :: ZS(klon)&
150  & , ZTAUAZ(KLON,KLEV) , ZTO1(KLON) , ZTR(KLON,2,KLEV+1)&
151  & , ZTRA1(KLON,KLEV+1), ZTRA2(KLON,KLEV+1)&
152  & , ZTRCLD(KLON) , ZTRCLR(KLON)&
153  & , ZTR1(KLON) , ZTR2(KLON)&
154  & , ZW(KLON) , ZW1(KLON) , ZW2(KLON,2)&
155  & , ZW3(KLON,6) , ZW4(KLON,2) , ZW5(KLON,2)
156 
157 INTEGER(KIND=JPIM) :: IABS, IKL, IKM1, JABS, JAJ, JAJP, JK, JKKI,&
158  & JKKP4, JKL, JKLP1, JKM1, JL, JN, JN2J, JREF
159 
160 REAL(KIND=JPRB) :: ZAA, ZBB, ZCNEB, ZRE11, ZRKI, ZRMUM1, ZWH2O, ZCHKG, ZCHKS
161 REAL(KIND=JPRB) :: ZRR,ZRRJ,ZRRK
162 REAL(KIND=JPRB) :: ZHOOK_HANDLE
163 !++MODIF_CODE
164 REAL(KIND=JPRB) :: ZB_ODI(klon)
165 !--MODIF_CODE
166 LOGICAL :: LLDEBUG
167 
168 #include "swclr.intfb.h"
169 #include "swde.intfb.h"
170 #include "swr.intfb.h"
171 #include "swtt.intfb.h"
172 #include "swtt1.intfb.h"
173 
174 lldebug=.false.
175 
176 IF(lldebug) THEN
177  write(str1,'(i1)') knu
178 ! call writefield_phy("sw_zcduvs"//str1,zcduvs,klev+1)
179 ENDIF
180 
181 ! ------------------------------------------------------------------
182 
183 !* 1. NEAR-INFRARED SPECTRAL INTERVAL (0.68-4.00 MICRON)
184 ! --------------------------------------------------
185 
186 !* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
187 ! -----------------------------------------
188 
189 IF (lhook) CALL dr_hook('SWNI',0,zhook_handle)
190 DO jl = kidia,kfdia
191  zrmum1 = 1.0_jprb - prmu(jl)
192  zrayl(jl) = rray(knu,1) + zrmum1 * (rray(knu,2) + zrmum1 &
193  & * (rray(knu,3) + zrmum1 * (rray(knu,4) + zrmum1 &
194  & * (rray(knu,5) + zrmum1 * rray(knu,6) ))))
195  zrayl(jl) = max(zrayl(jl), 0.0_jprb)
196 ENDDO
197 
198 ! ------------------------------------------------------------------
199 
200 !* 2. CONTINUUM SCATTERING CALCULATIONS
201 ! ---------------------------------
202 
203 !* 2.1 CLEAR-SKY FRACTION OF THE COLUMN
204 ! --------------------------------
205 
206 
207 !++MODIFCODE
208  CALL swclr &
209  &( kidia , kfdia , klon , klev , kaer , knu &
210  &, paer , palbp , pdsig , zrayl, psec &
211  &, zcgaz , zpizaz, zray1 , zray2, zrefz, zrj0 &
212  &, zrk0 , zrmu0 , ztauaz, ztra1, ztra2, ztrclr &
213  &, lrdust,ppiza_dst,pcga_dst,ptaurel_dst &
214  &)
215 !--MODIFCODE
216 
217 !* 2.2 CLOUDY FRACTION OF THE COLUMN
218 ! -----------------------------
219 
220 CALL swr &
221  & ( kidia , kfdia , klon , klev , knu,&
222  & palbd , pcg , pcld , pomega, psec , ptau,&
223  & zcgaz , zpizaz, zray1, zray2 , zrefz, zrj , zrk, zrmue,&
224  & ztauaz, ztra1 , ztra2, ztrcld &
225  & )
226 
227 ! ------------------------------------------------------------------
228 
229 !* 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
230 ! ------------------------------------------------------
231 
232 jn = 2
233 
234 DO jabs=1,2
235 
236 !* 3.1 SURFACE CONDITIONS
237 ! ------------------
238 
239  DO jl = kidia,kfdia
240  zrefz(jl,2,1) = palbd(jl,knu)
241  zrefz(jl,1,1) = palbd(jl,knu)
242  ENDDO
243 
244 !* 3.2 INTRODUCING CLOUD EFFECTS
245 ! -------------------------
246 
247  DO jk = 2 , klev+1
248  jkm1 = jk - 1
249  ikl=klev+1-jkm1
250  DO jl = kidia,kfdia
251  zrneb(jl) = pcld(jl,jkm1)
252  IF (jabs == 1.AND. zrneb(jl) > repsc ) THEN
253  zwh2o=max(pwv(jl,ikl),repscq)
254  zcneb=max(repsc ,min(zrneb(jl),1.0_jprb-repsc ))
255  zbb=pud(jl,jabs,jkm1)*pqs(jl,ikl)/zwh2o
256  zaa=max((pud(jl,jabs,jkm1)-zcneb*zbb)/(1.0_jprb-zcneb),repscq)
257  ELSE
258  zaa=pud(jl,jabs,jkm1)
259  zbb=zaa
260  zcneb=0.0_jprb
261  zwh2o=max(pwv(jl,ikl),repscq)
262  ENDIF
263 
264 ! ZEXP1=-ZRKI * ZAA * 1.66_JPRB
265 ! ZEXP2=-ZRKI * ZAA / ZRMUE(JL,JK)
266 ! IF ( ZEXP1 > _ZERO_ .OR. ZEXP2 > _ZERO_ &
267 ! & .OR. ZEXP1 < -700._JPRB .OR. ZEXP2 < -700._JPRB ) THEN
268 ! WRITE (NULOUT,'(" SWNI 3.2 : JK=",I4," JL=",I4," JABS=",I4,,8E13.6)') &
269 ! & JK,JL,JABS,ZAA,ZBB,ZRKI,ZCNEB,ZWH2O,ZRMUE(JL,JK),ZEXP1,ZEXP2
270 ! END IF
271 
272  zrki = paki(jl,jabs,knu)
273 ! ZS(JL) = EXP(-ZRKI * ZAA * 1.66_JPRB)
274 ! ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK) )
275 
276  zchks = min( 200._jprb, zrki * zaa * 1.66_jprb )
277  zchkg = min( 200._jprb, zrki * zaa / zrmue(jl,jk))
278  zs(jl) = exp( - zchks )
279  zg(jl) = exp( - zchkg )
280 
281  ztr1(jl) = 0.0_jprb
282  zre1(jl) = 0.0_jprb
283  ztr2(jl) = 0.0_jprb
284  zre2(jl) = 0.0_jprb
285 
286 !++MODIFCODE
287  IF (novlp >= 5)THEN !MESONH VERSION
288  zw(jl) =pcg(jl,knu,jkm1)*pcg(jl,knu,jkm1)
289  zto1(jl) = ptau(jl,knu,jkm1)*(1-(pomega(jl,knu,jkm1)*zw(jl)))
290  zw(jl) =pomega(jl,knu,jkm1)*(1-zw(jl))/(1-(pomega(jl,knu,jkm1)*zw(jl)))
291  zgg(jl) =pcg(jl,knu,jkm1)/(1+pcg(jl,knu,jkm1))
292  zgg(jl)=zto1(jl)*zw(jl)*zgg(jl)+ztauaz(jl,jkm1)*zpizaz(jl,jkm1)*zcgaz(jl,jkm1)
293  zgg(jl)=zgg(jl)/(zto1(jl)*zw(jl)+ztauaz(jl,jkm1)*zpizaz(jl,jkm1))
294  zb_odi(jl)=zto1(jl) / zw(jl)&
295  &+ ztauaz(jl,jkm1) / zpizaz(jl,jkm1)&
296  !if g=0 tau/w=tau'/w'
297  &+ zbb * zrki
298  zb_odi(jl)=(1/( (zto1(jl) / zw(jl))&
299  &+ (ztauaz(jl,jkm1) / zpizaz(jl,jkm1)) ))-(1/zb_odi(jl))
300  zb_odi(jl)=((zto1(jl) + ztauaz(jl,jkm1))**2)*zb_odi(jl)
301  zw(jl)=zto1(jl)*zw(jl)+ztauaz(jl,jkm1)*zpizaz(jl,jkm1)-zb_odi(jl)
302  zto1(jl) = zto1(jl) + ztauaz(jl,jkm1)
303  zw(jl)=zw(jl)/zto1(jl)
304  ELSE !ECMWF VERSION
305  zw(jl)= pomega(jl,knu,jkm1)
306  zto1(jl) = ptau(jl,knu,jkm1) / zw(jl)&
307  & + ztauaz(jl,jkm1) / zpizaz(jl,jkm1)&
308  & + zbb * zrki
309  zr21(jl) = ptau(jl,knu,jkm1) + ztauaz(jl,jkm1)
310  zr22(jl) = ptau(jl,knu,jkm1) / zr21(jl)
311  zgg(jl) = zr22(jl) * pcg(jl,knu,jkm1)&
312  & + (1.0_jprb - zr22(jl)) * zcgaz(jl,jkm1)
313  zw(jl) = zr21(jl) / zto1(jl)
314  ENDIF
315 !--MODIFCODE
316  zref(jl) = zrefz(jl,1,jkm1)
317  zrmuz(jl) = zrmue(jl,jk)
318  ENDDO
319 
320  CALL swde ( kidia, kfdia, klon,&
321  & zgg , zref , zrmuz, zto1, zw,&
322  & zre1 , zre2 , ztr1 , ztr2 )
323 
324  DO jl = kidia,kfdia
325 
326  zrr=1.0_jprb/(1.0_jprb-zray2(jl,jkm1)*zrefz(jl,1,jkm1))
327  zrefz(jl,2,jk) = (1.0_jprb-zrneb(jl)) * (zray1(jl,jkm1)&
328  & + zrefz(jl,2,jkm1) * ztra1(jl,jkm1)&
329  & * ztra2(jl,jkm1) ) * zg(jl) * zs(jl)&
330  & + zrneb(jl) * zre1(jl)
331 
332  ztr(jl,2,jkm1)=zrneb(jl)*ztr1(jl)&
333  & + (ztra1(jl,jkm1)) * zg(jl) * (1.0_jprb-zrneb(jl))
334 
335  zrefz(jl,1,jk)=(1.0_jprb-zrneb(jl))*(zray1(jl,jkm1)&
336  & +zrefz(jl,1,jkm1)*ztra1(jl,jkm1)*ztra2(jl,jkm1)&
337  & *zrr ) &
338  & *zg(jl)*zs(jl)&
339  & + zrneb(jl) * zre2(jl)
340 
341  ztr(jl,1,jkm1)= zrneb(jl) * ztr2(jl)&
342  & + (ztra1(jl,jkm1) &
343  & *zrr ) &
344  & * zg(jl) * (1.0_jprb -zrneb(jl))
345 
346  ENDDO
347  ENDDO
348 
349 !* 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
350 ! -------------------------------------------------
351 
352  DO jref=1,2
353 
354  jn = jn + 1
355 
356  DO jl = kidia,kfdia
357  zrj(jl,jn,klev+1) = 1.0_jprb
358  zrk(jl,jn,klev+1) = zrefz(jl,jref,klev+1)
359  ENDDO
360 
361  DO jk = 1 , klev
362  jkl = klev+1 - jk
363  jklp1 = jkl + 1
364  DO jl = kidia,kfdia
365  zre11 = zrj(jl,jn,jklp1) * ztr(jl,jref,jkl)
366  zrj(jl,jn,jkl) = zre11
367  zrk(jl,jn,jkl) = zre11 * zrefz(jl,jref,jkl)
368  ENDDO
369  ENDDO
370  ENDDO
371 ENDDO
372 
373 ! ------------------------------------------------------------------
374 
375 !* 4. INVERT GREY AND CONTINUUM FLUXES
376 ! --------------------------------
377 
378 !* 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
379 ! ---------------------------------------------
380 
381 DO jk = 1 , klev+1
382  DO jaj = 1 , 5 , 2
383  jajp = jaj + 1
384  DO jl = kidia,kfdia
385  zrj(jl,jaj,jk)= zrj(jl,jaj,jk) - zrj(jl,jajp,jk)
386  zrk(jl,jaj,jk)= zrk(jl,jaj,jk) - zrk(jl,jajp,jk)
387  zrj(jl,jaj,jk)= max( zrj(jl,jaj,jk) , replog )
388  zrk(jl,jaj,jk)= max( zrk(jl,jaj,jk) , replog )
389  ENDDO
390  ENDDO
391 ENDDO
392 
393 DO jk = 1 , klev+1
394  DO jaj = 2 , 6 , 2
395  DO jl = kidia,kfdia
396  zrj(jl,jaj,jk)= max( zrj(jl,jaj,jk) , replog )
397  zrk(jl,jaj,jk)= max( zrk(jl,jaj,jk) , replog )
398  ENDDO
399  ENDDO
400 ENDDO
401 
402 !* 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
403 ! ---------------------------------------------
404 
405 DO jk = 1 , klev+1
406  jkki = 1
407  DO jaj = 1 , 2
408  iind2(1)=jaj
409  iind2(2)=jaj
410  DO jn = 1 , 2
411  jn2j = jn + 2 * jaj
412  jkkp4 = jkki + 4
413 
414 !* 4.2.1 EFFECTIVE ABSORBER AMOUNTS
415 ! --------------------------
416 
417  DO jl = kidia,kfdia
418  zrr=1.0_jprb/paki(jl,jaj,knu)
419  zrrj=zrj(jl,jn,jk) / zrj(jl,jn2j,jk)
420  zrrk=zrk(jl,jn,jk) / zrk(jl,jn2j,jk)
421  zw2(jl,1) = log( zrrj ) * zrr
422  zw2(jl,2) = log( zrrk ) * zrr
423  ENDDO
424 
425 !* 4.2.2 TRANSMISSION FUNCTION
426 ! ---------------------
427 
428  CALL swtt1 ( kidia,kfdia,klon, knu, 2, iind2,&
429  & zw2,&
430  & zr2 )
431 
432  DO jl = kidia,kfdia
433  zrl(jl,jkki) = zr2(jl,1)
434  zruef(jl,jkki) = zw2(jl,1)
435  zrl(jl,jkkp4) = zr2(jl,2)
436  zruef(jl,jkkp4) = zw2(jl,2)
437  ENDDO
438 
439  jkki=jkki+1
440  ENDDO
441  ENDDO
442 
443 !* 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
444 ! ------------------------------------------------------
445 
446  DO jl = kidia,kfdia
447  pfdown(jl,jk) = zrj(jl,1,jk) * zrl(jl,1) * zrl(jl,3)&
448  & + zrj(jl,2,jk) * zrl(jl,2) * zrl(jl,4)
449  pfup(jl,jk) = zrk(jl,1,jk) * zrl(jl,5) * zrl(jl,7)&
450  & + zrk(jl,2,jk) * zrl(jl,6) * zrl(jl,8)
451  ENDDO
452 ! WRITE(*,'("---> Dans SWNI: ZRK1 ZRK2 ",2E12.5)') ZRK(1,1,JK),ZRK(1,2,JK)
453 ! WRITE(*,'("ZRK1 ZRL5 ZRL7 ",3E12.5)') ZRK(1,1,JK),ZRL(1,5),ZRL(1,7)
454 ! WRITE(*,'("ZRK2 ZRL6 ZRL8 ",3E12.5)') ZRK(1,2,JK),ZRL(1,6),ZRL(1,8)
455 ENDDO
456 
457 ! ------------------------------------------------------------------
458 
459 !* 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
460 ! ----------------------------------------
461 
462 !* 5.1 DOWNWARD FLUXES
463 ! ---------------
464 
465 jaj = 2
466 iind3(1)=1
467 iind3(2)=2
468 iind3(3)=3
469 iind3(4)=1
470 iind3(5)=2
471 iind3(6)=3
472 
473 DO jl = kidia,kfdia
474  zw3(jl,1)=0.0_jprb
475  zw3(jl,2)=0.0_jprb
476  zw3(jl,3)=0.0_jprb
477  zw3(jl,4)=0.0_jprb
478  zw3(jl,5)=0.0_jprb
479  zw3(jl,6)=0.0_jprb
480 
481  zw4(jl,1)=0.0_jprb
482  zw5(jl,1)=0.0_jprb
483  zr4(jl,1)=1.0_jprb
484  zw4(jl,2)=0.0_jprb
485  zw5(jl,2)=0.0_jprb
486  zr4(jl,2)=1.0_jprb
487  zfd(jl,klev+1)= zrj0(jl,jaj,klev+1)
488 ENDDO
489 DO jk = 1 , klev
490  ikl = klev+1-jk
491  DO jl = kidia,kfdia
492  zrr=1.0_jprb/zrmu0(jl,ikl)
493  zw3(jl,1)=zw3(jl,1)+pud(jl,1,ikl)*zrr
494  zw3(jl,2)=zw3(jl,2)+pud(jl,2,ikl)*zrr
495  zw3(jl,3)=zw3(jl,3)+poz(jl, ikl)*zrr
496  zw4(jl,1)=zw4(jl,1)+pud(jl,4,ikl)*zrr
497  zw5(jl,1)=zw5(jl,1)+pud(jl,5,ikl)*zrr
498 
499  zrr=1.0_jprb/zrmue(jl,ikl)
500  zw3(jl,4)=zw3(jl,4)+pud(jl,1,ikl)*zrr
501  zw3(jl,5)=zw3(jl,5)+pud(jl,2,ikl)*zrr
502  zw3(jl,6)=zw3(jl,6)+poz(jl, ikl)*zrr
503  zw4(jl,2)=zw4(jl,2)+pud(jl,4,ikl)*zrr
504  zw5(jl,2)=zw5(jl,2)+pud(jl,5,ikl)*zrr
505  ENDDO
506 
507  CALL swtt1 ( kidia,kfdia,klon, knu, 6, iind3,&
508  & zw3,&
509  & zr3 )
510 
511  DO jl = kidia,kfdia
512  zr4(jl,1) = exp(-rswce(knu)*zw4(jl,1)-rswcp(knu)*zw5(jl,1))
513  zr4(jl,2) = exp(-rswce(knu)*zw4(jl,2)-rswcp(knu)*zw5(jl,2))
514  zfd(jl,ikl) = zr3(jl,1)*zr3(jl,2)*zr3(jl,3)*zr4(jl,1)* zrj0(jl,jaj,ikl)
515  ENDDO
516 ENDDO
517 IF(lldebug) THEN
518  call writefield_phy('swni_zfd'//str1,zfd,klev+1)
519  call writefield_phy('swni_zrj0'//str1,zrj0(:,jaj,:),klev+1)
520 ENDIF
521 
522 DO jl=kidia,kfdia
523  zdiff(jl) = zr3(jl,4)*zr3(jl,5)*zr3(jl,6)*zr4(jl,2)*ztrcld(jl)
524  zdirf(jl) = zr3(jl,1)*zr3(jl,2)*zr3(jl,3)*zr4(jl,1)*ztrclr(jl)
525  psudu2(jl) = ((1.0_jprb-pclear(jl)) * zdiff(jl)&
526  & +pclear(jl) * zdirf(jl)) * rsun(knu)
527 ENDDO
528 
529 !* 5.2 UPWARD FLUXES
530 ! -------------
531 
532 DO jl = kidia,kfdia
533  zfu(jl,1) = zfd(jl,1)*palbp(jl,knu)
534 ENDDO
535 
536 DO jk = 2 , klev+1
537  ikm1=jk-1
538  DO jl = kidia,kfdia
539  zw3(jl,1)=zw3(jl,1)+pud(jl,1,ikm1)*1.66_jprb
540  zw3(jl,2)=zw3(jl,2)+pud(jl,2,ikm1)*1.66_jprb
541  zw3(jl,3)=zw3(jl,3)+poz(jl, ikm1)*1.66_jprb
542  zw4(jl,1)=zw4(jl,1)+pud(jl,4,ikm1)*1.66_jprb
543  zw5(jl,1)=zw5(jl,1)+pud(jl,5,ikm1)*1.66_jprb
544  ENDDO
545 
546  CALL swtt1 ( kidia,kfdia,klon, knu, 3, iind3,&
547  & zw3,&
548  & zr3 )
549 
550  DO jl = kidia,kfdia
551  zr4(jl,1) = exp(-rswce(knu)*zw4(jl,1)-rswcp(knu)*zw5(jl,1))
552  zfu(jl,jk) = zr3(jl,1)*zr3(jl,2)*zr3(jl,3)*zr4(jl,1)* zrk0(jl,jaj,jk)
553  ENDDO
554 ENDDO
555 
556 ! ------------------------------------------------------------------
557 
558 !* 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
559 ! --------------------------------------------------
560 
561 iabs=3
562 
563 !* 6.1 DOWNWARD FLUXES
564 ! ---------------
565 
566 DO jl = kidia,kfdia
567  zw1(jl)=0.0_jprb
568  zw4(jl,1)=0.0_jprb
569  zw5(jl,1)=0.0_jprb
570  zr1(jl)=0.0_jprb
571  pfdown(jl,klev+1) = ((1.0_jprb-pclear(jl))*pfdown(jl,klev+1)&
572  & + pclear(jl) * zfd(jl,klev+1)) * rsun(knu)
573  pcdown(jl,klev+1) = zfd(jl,klev+1) * rsun(knu)
574 ENDDO
575 
576 DO jk = 1 , klev
577  ikl=klev+1-jk
578  DO jl = kidia,kfdia
579  zrr=1.0_jprb/zrmue(jl,ikl)
580  zw1(jl) = zw1(jl)+poz(jl, ikl) * zrr
581  zw4(jl,1) = zw4(jl,1)+pud(jl,4,ikl) * zrr
582  zw5(jl,1) = zw5(jl,1)+pud(jl,5,ikl) * zrr
583  zr4(jl,1) = exp(-rswce(knu)*zw4(jl,1)-rswcp(knu)*zw5(jl,1))
584  ENDDO
585 
586  CALL swtt ( kidia,kfdia,klon, knu, iabs, zw1, zr1 )
587 
588  DO jl = kidia,kfdia
589  pdiff(jl,ikl)=zr1(jl)*zr4(jl,1)*pfdown(jl,ikl)*rsun(knu)*(1.0_jprb-pclear(jl))
590  pdirf(jl,ikl)=zfd(jl,ikl)*rsun(knu)* pclear(jl)
591  pfdown(jl,ikl) = ((1.0_jprb-pclear(jl))*zr1(jl)*zr4(jl,1)*pfdown(jl,ikl)&
592  & +pclear(jl)*zfd(jl,ikl)) * rsun(knu)
593  pcdown(jl,ikl) = zfd(jl,ikl) * rsun(knu)
594  ENDDO
595 ENDDO
596 
597 !* 6.2 UPWARD FLUXES
598 ! -------------
599 
600 DO jl = kidia,kfdia
601  pfup(jl,1) = ((1.0_jprb-pclear(jl))*zr1(jl)*zr4(jl,1) * pfup(jl,1)&
602  & +pclear(jl)*zfu(jl,1)) * rsun(knu)
603  pcup(jl,1) = zfu(jl,1) * rsun(knu)
604 ENDDO
605 
606 DO jk = 2 , klev+1
607  ikm1=jk-1
608  DO jl = kidia,kfdia
609  zw1(jl) = zw1(jl)+poz(jl ,ikm1)*1.66_jprb
610  zw4(jl,1) = zw4(jl,1)+pud(jl,4,ikm1)*1.66_jprb
611  zw5(jl,1) = zw5(jl,1)+pud(jl,5,ikm1)*1.66_jprb
612  zr4(jl,1) = exp(-rswce(knu)*zw4(jl,1)-rswcp(knu)*zw5(jl,1))
613  ENDDO
614 
615  CALL swtt ( kidia,kfdia,klon, knu, iabs, zw1, zr1 )
616 
617  DO jl = kidia,kfdia
618  pfup(jl,jk) = ((1.0_jprb-pclear(jl))*zr1(jl)*zr4(jl,1) * pfup(jl,jk)&
619  & +pclear(jl)*zfu(jl,jk)) * rsun(knu)
620  pcup(jl,jk) = zfu(jl,jk) * rsun(knu)
621  ENDDO
622 ENDDO
623 
624 IF(lldebug) THEN
625  call writefield_phy('swni_zfd_fin'//str1,zfd,klev+1)
626  call writefield_phy('swni_pcdown'//str1,pcdown,klev+1)
627 ENDIF
628 ! ------------------------------------------------------------------
629 
630 IF (lhook) CALL dr_hook('SWNI',1,zhook_handle)
631 END SUBROUTINE swni
swclr
subroutine swclr(KIDIA, KFDIA, KLON, KLEV, KAER, KNU, PAER, PALBP, PDSIG, PRAYL, PSEC, PCGAZ, PPIZAZ, PRAY1, PRAY2, PREFZ, PRJ, PRK, PRMU0, PTAUAZ, PTRA1, PTRA2, PTRCLR,
Definition: swclr.F90:7
yoesw
Definition: yoesw.F90:1
swni
subroutine swni(KIDIA, KFDIA, KLON, KLEV, KAER, KNU, PAER, PAKI, PALBD, PALBP, PCG, PCLD, PCLEAR, PDSIG, POMEGA, POZ, PRMU, PSEC, PTAU, PUD, PWV, PQS, PFDOWN, PFUP, PCDOWN, PCUP, PSUDU2, PDIFF, PDIRF,
Definition: swni.F90:8
dimphy::kidia
integer, save kidia
Definition: dimphy.F90:6
dimphy::klon
integer, save klon
Definition: dimphy.F90:3
yoerad::novlp
integer(kind=jpim) novlp
Definition: yoerad.F90:24
yoesw::rsun
real(kind=jprb), dimension(:), allocatable rsun
Definition: yoesw.F90:16
dimphy::klev
integer, save klev
Definition: dimphy.F90:7
yoesw::rswce
real(kind=jprb), dimension(6) rswce
Definition: yoesw.F90:22
false
!$Id itapm1 ENDIF!IM on interpole les champs sur les niveaux STD de pression!IM a chaque pas de temps de la physique c!positionnement de l argument logique a false c!pour ne pas recalculer deux fois la meme chose!c!a cet effet un appel a plevel_new a ete deplace c!a la fin de la serie d appels c!la boucle DO nlevSTD a ete internalisee c!dans d ou la creation de cette routine c c!CALL false
Definition: calcul_STDlev.h:26
dimphy::kfdia
integer, save kfdia
Definition: dimphy.F90:5
swr
subroutine swr(KIDIA, KFDIA, KLON, KLEV, KNU, PALBD, PCG, PCLD, POMEGA, PSEC, PTAU, PCGAZ, PPIZAZ, PRAY1, PRAY2, PREFZ, PRJ, PRK, PRMUE, PTAUAZ, PTRA1, PTRA2, PTRCLD)
Definition: swr.F90:7
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:31
yoerad
Definition: yoerad.F90:1
write_field_phy
Definition: write_field_phy.F90:4
yoerdu::replog
real(kind=jprb) replog
Definition: yoerdu.F90:19
yomhook::lhook
logical lhook
Definition: yomhook.F90:12
yoerdu::repscq
real(kind=jprb) repscq
Definition: yoerdu.F90:22
swde
subroutine swde(KIDIA, KFDIA, KLON, PGG, PREF, PRMUZ, PTO1, PW, PRE1, PRE2, PTR1, PTR2)
Definition: swde.F90:7
swtt1
subroutine swtt1(KIDIA, KFDIA, KLON, KNU, KABS, KIND, PU, PTR)
Definition: swtt1.F90:2
yomhook::dr_hook
subroutine dr_hook(CDNAME, KSWITCH, PKEY)
Definition: yomhook.F90:17
write_field_phy::writefield_phy
subroutine writefield_phy(name, Field, ll)
Definition: write_field_phy.F90:11
parkind1::jpim
integer, parameter jpim
Definition: parkind1.F90:13
yoesw::rray
real(kind=jprb), dimension(6, 6) rray
Definition: yoesw.F90:15
paer
INTERFACE SUBROUTINE RRTM_ECRT_140GP && paer
Definition: rrtm_ecrt_140gp.intfb.h:3
yoerdu::repsc
real(kind=jprb) repsc
Definition: yoerdu.F90:20
swtt
subroutine swtt(KIDIA, KFDIA, KLON, KNU, KA, PU, PTR)
Definition: swtt.F90:2
yoerdu
Definition: yoerdu.F90:1
yoesw::rswcp
real(kind=jprb), dimension(6) rswcp
Definition: yoesw.F90:23