source: LMDZ5/trunk/libf/phylmd/rrtm/swni.F90 @ 2820

Last change on this file since 2820 was 2401, checked in by oboucher, 9 years ago

Correction of a bug in swni.F90
should enable new SW radiation to run smoothly

  • 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: 19.6 KB
Line 
1SUBROUTINE 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
72USE PARKIND1  ,ONLY : JPIM     ,JPRB
73USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
74
75USE YOESW    , ONLY : RRAY     ,RSUN     ,RSWCE    ,RSWCP
76!++MODIFCODE
77!USE YOERAD   , ONLY : NSW      ,NOVLP
78! NSW mis dans .def MPL 20140211
79USE YOERAD   , ONLY : NOVLP
80!--MODIFCODE
81USE YOERDU   , ONLY : REPLOG   ,REPSCQ   ,REPSC
82USE write_field_phy
83
84IMPLICIT NONE
85
86include "clesphys.h"
87
88character*1 str1
89INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
90INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
91INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA
92INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA
93INTEGER(KIND=JPIM),INTENT(IN)    :: KAER
94INTEGER(KIND=JPIM),INTENT(IN)    :: KNU
95REAL(KIND=JPRB)   ,INTENT(IN)    :: PAER(KLON,6,KLEV)
96REAL(KIND=JPRB)   ,INTENT(IN)    :: PAKI(KLON,2,NSW)
97REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBD(KLON,NSW)
98REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBP(KLON,NSW)
99REAL(KIND=JPRB)   ,INTENT(IN)    :: PCG(KLON,NSW,KLEV)
100REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLD(KLON,KLEV)
101REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLEAR(KLON)
102REAL(KIND=JPRB)   ,INTENT(IN)    :: PDSIG(KLON,KLEV)
103REAL(KIND=JPRB)   ,INTENT(IN)    :: POMEGA(KLON,NSW,KLEV)
104REAL(KIND=JPRB)   ,INTENT(IN)    :: POZ(KLON,KLEV)
105REAL(KIND=JPRB)   ,INTENT(IN)    :: PRMU(KLON)
106REAL(KIND=JPRB)   ,INTENT(IN)    :: PSEC(KLON)
107REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAU(KLON,NSW,KLEV)
108REAL(KIND=JPRB)   ,INTENT(IN)    :: PUD(KLON,5,KLEV+1)
109REAL(KIND=JPRB)   ,INTENT(IN)    :: PWV(KLON,KLEV)
110REAL(KIND=JPRB)   ,INTENT(IN)    :: PQS(KLON,KLEV)
111!++MODIFCODE
112LOGICAL           ,INTENT(IN)    :: LRDUST
113REAL(KIND=JPRB)   ,INTENT(IN)    :: PPIZA_DST(KLON,KLEV)
114REAL(KIND=JPRB)   ,INTENT(IN)    :: PCGA_DST(KLON,KLEV)
115REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUREL_DST(KLON,KLEV)
116!--MODIFCODE
117REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFDOWN(KLON,KLEV+1)
118REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFUP(KLON,KLEV+1)
119REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCDOWN(KLON,KLEV+1)
120REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCUP(KLON,KLEV+1)
121REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSUDU2(KLON)
122REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDIFF(KLON,KLEV)
123REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDIRF(KLON,KLEV)
124!#include "yoeaer.h"
125!     ------------------------------------------------------------------
126
127!*       0.1   ARGUMENTS
128!              ---------
129
130!     ------------------------------------------------------------------
131
132!              ------------
133
134INTEGER(KIND=JPIM) :: IIND2(2), IIND3(6)
135REAL(KIND=JPRB) :: ZCGAZ(KLON,KLEV)  , ZDIFF(KLON)         , ZDIRF(KLON)&
136 & ,  ZFD(KLON,KLEV+1)  , ZFU(KLON,KLEV+1) &
137 & ,  ZG(KLON)          , ZGG(KLON) 
138REAL(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) 
149REAL(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
157INTEGER(KIND=JPIM) :: IABS, IKL, IKM1, JABS, JAJ, JAJP, JK, JKKI,&
158 & JKKP4, JKL, JKLP1, JKM1, JL, JN, JN2J, JREF 
159
160REAL(KIND=JPRB) :: ZAA, ZBB, ZCNEB, ZRE11, ZRKI, ZRMUM1, ZWH2O, ZCHKG, ZCHKS
161REAL(KIND=JPRB) :: ZRR,ZRRJ,ZRRK
162REAL(KIND=JPRB) :: ZHOOK_HANDLE
163!++MODIF_CODE
164REAL(KIND=JPRB) :: ZB_ODI(KLON)
165!--MODIF_CODE
166LOGICAL         :: 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
174LLDEBUG=.FALSE.
175
176IF(LLDEBUG) THEN
177  write(str1,'(i1)') knu
178! call writefield_phy("sw_zcduvs"//str1,zcduvs,klev+1)
179ENDIF
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
189IF (LHOOK) CALL DR_HOOK('SWNI',0,ZHOOK_HANDLE)
190DO 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)
196ENDDO
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
220CALL 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
232JN = 2
233
234DO 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
371ENDDO
372
373!     ------------------------------------------------------------------
374
375!*         4.    INVERT GREY AND CONTINUUM FLUXES
376!                --------------------------------
377
378!*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
379!                ---------------------------------------------
380
381DO 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
391ENDDO
392
393DO 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
400ENDDO
401
402!*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
403!                 ---------------------------------------------
404
405DO 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!--correction Olivier Boucher based on ECMWF code
424        ZW2(JL,1) = LOG( MAX(1.0_JPRB,ZRRJ) ) * ZRR
425        ZW2(JL,2) = LOG( MAX(1.0_JPRB,ZRRK) ) * ZRR
426      ENDDO
427
428!*         4.2.2  TRANSMISSION FUNCTION
429!                 ---------------------
430
431      CALL SWTT1 ( KIDIA,KFDIA,KLON, KNU, 2, IIND2,&
432       & ZW2,&
433       & ZR2                              ) 
434
435      DO JL = KIDIA,KFDIA
436        ZRL(JL,JKKI) = ZR2(JL,1)
437        ZRUEF(JL,JKKI) = ZW2(JL,1)
438        ZRL(JL,JKKP4) = ZR2(JL,2)
439        ZRUEF(JL,JKKP4) = ZW2(JL,2)
440      ENDDO
441
442      JKKI=JKKI+1
443    ENDDO
444  ENDDO
445
446!*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
447!                 ------------------------------------------------------
448
449  DO JL = KIDIA,KFDIA
450    PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)&
451     & + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4) 
452    PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)&
453     & + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8) 
454  ENDDO
455!   WRITE(*,'("---> Dans SWNI: ZRK1 ZRK2  ",2E12.5)') ZRK(1,1,JK),ZRK(1,2,JK)
456!   WRITE(*,'("ZRK1 ZRL5 ZRL7  ",3E12.5)') ZRK(1,1,JK),ZRL(1,5),ZRL(1,7)
457!   WRITE(*,'("ZRK2 ZRL6 ZRL8  ",3E12.5)') ZRK(1,2,JK),ZRL(1,6),ZRL(1,8)
458ENDDO
459
460!     ------------------------------------------------------------------
461
462!*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
463!                ----------------------------------------
464
465!*         5.1   DOWNWARD FLUXES
466!                ---------------
467
468JAJ = 2
469IIND3(1)=1
470IIND3(2)=2
471IIND3(3)=3
472IIND3(4)=1
473IIND3(5)=2
474IIND3(6)=3
475
476DO JL = KIDIA,KFDIA
477  ZW3(JL,1)=0.0_JPRB
478  ZW3(JL,2)=0.0_JPRB
479  ZW3(JL,3)=0.0_JPRB
480  ZW3(JL,4)=0.0_JPRB
481  ZW3(JL,5)=0.0_JPRB
482  ZW3(JL,6)=0.0_JPRB
483
484  ZW4(JL,1)=0.0_JPRB
485  ZW5(JL,1)=0.0_JPRB
486  ZR4(JL,1)=1.0_JPRB
487  ZW4(JL,2)=0.0_JPRB
488  ZW5(JL,2)=0.0_JPRB
489  ZR4(JL,2)=1.0_JPRB
490  ZFD(JL,KLEV+1)= ZRJ0(JL,JAJ,KLEV+1)
491ENDDO
492DO JK = 1 , KLEV
493  IKL = KLEV+1-JK
494  DO JL = KIDIA,KFDIA
495    ZRR=1.0_JPRB/ZRMU0(JL,IKL)
496    ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)*ZRR
497    ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)*ZRR
498    ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)*ZRR
499    ZW4(JL,1)=ZW4(JL,1)+PUD(JL,4,IKL)*ZRR
500    ZW5(JL,1)=ZW5(JL,1)+PUD(JL,5,IKL)*ZRR
501
502    ZRR=1.0_JPRB/ZRMUE(JL,IKL)
503    ZW3(JL,4)=ZW3(JL,4)+PUD(JL,1,IKL)*ZRR
504    ZW3(JL,5)=ZW3(JL,5)+PUD(JL,2,IKL)*ZRR
505    ZW3(JL,6)=ZW3(JL,6)+POZ(JL,  IKL)*ZRR
506    ZW4(JL,2)=ZW4(JL,2)+PUD(JL,4,IKL)*ZRR
507    ZW5(JL,2)=ZW5(JL,2)+PUD(JL,5,IKL)*ZRR
508  ENDDO
509
510  CALL SWTT1 ( KIDIA,KFDIA,KLON, KNU, 6, IIND3,&
511   & ZW3,&
512   & ZR3                              ) 
513
514  DO JL = KIDIA,KFDIA
515    ZR4(JL,1) = EXP(-RSWCE(KNU)*ZW4(JL,1)-RSWCP(KNU)*ZW5(JL,1))
516    ZR4(JL,2) = EXP(-RSWCE(KNU)*ZW4(JL,2)-RSWCP(KNU)*ZW5(JL,2))
517    ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL,1)* ZRJ0(JL,JAJ,IKL)
518  ENDDO
519ENDDO
520IF(LLDEBUG) THEN
521  call writefield_phy('swni_zfd'//str1,ZFD,KLEV+1)
522  call writefield_phy('swni_zrj0'//str1,ZRJ0(:,jaj,:),KLEV+1)
523ENDIF
524
525DO JL=KIDIA,KFDIA
526  ZDIFF(JL) = ZR3(JL,4)*ZR3(JL,5)*ZR3(JL,6)*ZR4(JL,2)*ZTRCLD(JL)
527  ZDIRF(JL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL,1)*ZTRCLR(JL)
528  PSUDU2(JL) = ((1.0_JPRB-PCLEAR(JL)) * ZDIFF(JL)&
529   & +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU) 
530ENDDO
531
532!*         5.2   UPWARD FLUXES
533!                -------------
534
535DO JL = KIDIA,KFDIA
536  ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
537ENDDO
538
539DO JK = 2 , KLEV+1
540  IKM1=JK-1
541  DO JL = KIDIA,KFDIA
542    ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66_JPRB
543    ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66_JPRB
544    ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66_JPRB
545    ZW4(JL,1)=ZW4(JL,1)+PUD(JL,4,IKM1)*1.66_JPRB
546    ZW5(JL,1)=ZW5(JL,1)+PUD(JL,5,IKM1)*1.66_JPRB
547  ENDDO
548
549  CALL SWTT1 ( KIDIA,KFDIA,KLON, KNU, 3, IIND3,&
550   & ZW3,&
551   & ZR3                              ) 
552
553  DO JL = KIDIA,KFDIA
554    ZR4(JL,1) = EXP(-RSWCE(KNU)*ZW4(JL,1)-RSWCP(KNU)*ZW5(JL,1))
555    ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL,1)* ZRK0(JL,JAJ,JK)
556  ENDDO
557ENDDO
558
559!     ------------------------------------------------------------------
560
561!*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
562!                 --------------------------------------------------
563
564IABS=3
565
566!*         6.1    DOWNWARD FLUXES
567!                 ---------------
568
569DO JL = KIDIA,KFDIA
570  ZW1(JL)=0.0_JPRB
571  ZW4(JL,1)=0.0_JPRB
572  ZW5(JL,1)=0.0_JPRB
573  ZR1(JL)=0.0_JPRB
574  PFDOWN(JL,KLEV+1) = ((1.0_JPRB-PCLEAR(JL))*PFDOWN(JL,KLEV+1)&
575   & + PCLEAR(JL) * ZFD(JL,KLEV+1)) * RSUN(KNU) 
576  PCDOWN(JL,KLEV+1) = ZFD(JL,KLEV+1) * RSUN(KNU)
577ENDDO
578
579DO JK = 1 , KLEV
580  IKL=KLEV+1-JK
581  DO JL = KIDIA,KFDIA
582    ZRR=1.0_JPRB/ZRMUE(JL,IKL)
583    ZW1(JL) = ZW1(JL)+POZ(JL,  IKL) * ZRR
584    ZW4(JL,1) = ZW4(JL,1)+PUD(JL,4,IKL) * ZRR
585    ZW5(JL,1) = ZW5(JL,1)+PUD(JL,5,IKL) * ZRR
586    ZR4(JL,1) = EXP(-RSWCE(KNU)*ZW4(JL,1)-RSWCP(KNU)*ZW5(JL,1))
587  ENDDO
588
589  CALL SWTT ( KIDIA,KFDIA,KLON, KNU, IABS, ZW1, ZR1 )
590
591  DO JL = KIDIA,KFDIA
592    PDIFF(JL,IKL)=ZR1(JL)*ZR4(JL,1)*PFDOWN(JL,IKL)*RSUN(KNU)*(1.0_JPRB-PCLEAR(JL))
593    PDIRF(JL,IKL)=ZFD(JL,IKL)*RSUN(KNU)* PCLEAR(JL)
594    PFDOWN(JL,IKL) = ((1.0_JPRB-PCLEAR(JL))*ZR1(JL)*ZR4(JL,1)*PFDOWN(JL,IKL)&
595     & +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU) 
596    PCDOWN(JL,IKL) = ZFD(JL,IKL) * RSUN(KNU)
597  ENDDO
598ENDDO
599
600!*         6.2    UPWARD FLUXES
601!                 -------------
602
603DO JL = KIDIA,KFDIA
604  PFUP(JL,1) = ((1.0_JPRB-PCLEAR(JL))*ZR1(JL)*ZR4(JL,1) * PFUP(JL,1)&
605   & +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU) 
606  PCUP(JL,1) = ZFU(JL,1) * RSUN(KNU)
607ENDDO
608
609DO JK = 2 , KLEV+1
610  IKM1=JK-1
611  DO JL = KIDIA,KFDIA
612    ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66_JPRB
613    ZW4(JL,1) = ZW4(JL,1)+PUD(JL,4,IKM1)*1.66_JPRB
614    ZW5(JL,1) = ZW5(JL,1)+PUD(JL,5,IKM1)*1.66_JPRB
615    ZR4(JL,1) = EXP(-RSWCE(KNU)*ZW4(JL,1)-RSWCP(KNU)*ZW5(JL,1))
616  ENDDO
617
618  CALL SWTT ( KIDIA,KFDIA,KLON, KNU, IABS, ZW1, ZR1 )
619
620  DO JL = KIDIA,KFDIA
621    PFUP(JL,JK) = ((1.0_JPRB-PCLEAR(JL))*ZR1(JL)*ZR4(JL,1) * PFUP(JL,JK)&
622     & +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU) 
623    PCUP(JL,JK) = ZFU(JL,JK) * RSUN(KNU)
624  ENDDO
625ENDDO
626
627IF(LLDEBUG) THEN
628  call writefield_phy('swni_zfd_fin'//str1,ZFD,KLEV+1)
629  call writefield_phy('swni_pcdown'//str1,PCDOWN,KLEV+1)
630ENDIF
631!     ------------------------------------------------------------------
632
633IF (LHOOK) CALL DR_HOOK('SWNI',1,ZHOOK_HANDLE)
634END SUBROUTINE SWNI
Note: See TracBrowser for help on using the repository browser.