source: LMDZ5/branches/LMDZ5_SPLA/libf/phylmd/rrtm/swni.F90 @ 2699

Last change on this file since 2699 was 1990, checked in by Laurent Fairhead, 11 years ago

Corrections à la version r1989 pour permettre la compilation avec RRTM
Inclusion de la licence CeCILL_V2 pour RRTM

Changes to revision r1989 to enable RRTM code compilation
RRTM part put under CeCILL_V2 licence
  • 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.4 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      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)
455ENDDO
456
457!     ------------------------------------------------------------------
458
459!*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
460!                ----------------------------------------
461
462!*         5.1   DOWNWARD FLUXES
463!                ---------------
464
465JAJ = 2
466IIND3(1)=1
467IIND3(2)=2
468IIND3(3)=3
469IIND3(4)=1
470IIND3(5)=2
471IIND3(6)=3
472
473DO 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)
488ENDDO
489DO 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
516ENDDO
517IF(LLDEBUG) THEN
518  call writefield_phy('swni_zfd'//str1,ZFD,KLEV+1)
519  call writefield_phy('swni_zrj0'//str1,ZRJ0(:,jaj,:),KLEV+1)
520ENDIF
521
522DO 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) 
527ENDDO
528
529!*         5.2   UPWARD FLUXES
530!                -------------
531
532DO JL = KIDIA,KFDIA
533  ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
534ENDDO
535
536DO 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
554ENDDO
555
556!     ------------------------------------------------------------------
557
558!*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
559!                 --------------------------------------------------
560
561IABS=3
562
563!*         6.1    DOWNWARD FLUXES
564!                 ---------------
565
566DO 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)
574ENDDO
575
576DO 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
595ENDDO
596
597!*         6.2    UPWARD FLUXES
598!                 -------------
599
600DO 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)
604ENDDO
605
606DO 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
622ENDDO
623
624IF(LLDEBUG) THEN
625  call writefield_phy('swni_zfd_fin'//str1,ZFD,KLEV+1)
626  call writefield_phy('swni_pcdown'//str1,PCDOWN,KLEV+1)
627ENDIF
628!     ------------------------------------------------------------------
629
630IF (LHOOK) CALL DR_HOOK('SWNI',1,ZHOOK_HANDLE)
631END SUBROUTINE SWNI
Note: See TracBrowser for help on using the repository browser.