source: LMDZ5/trunk/libf/phylmd/rrtm/sw.F90 @ 1997

Last change on this file since 1997 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: 11.0 KB
Line 
1SUBROUTINE SW &
2 & ( KIDIA, KFDIA , KLON  , KLEV , KAER,&
3 & PSCT , PCARDI, PPSOL , PALBD, PALBP , PWV, PQS,&
4 & PRMU0, PCG   , PCLDSW, PDP  , POMEGA, POZ, PPMB,&
5 & PTAU , PTAVE , PAER,&
6 & PFDOWN, PFUP,&
7 & PCDOWN, PCUP,&
8 & PFDNN, PFDNV , PFUPN, PFUPV,&
9 & PCDNN, PCDNV , PCUPN, PCUPV,&
10 & PSUDU, PUVDF , PPARF, PPARCF, PDIFFS , PDIRFS, &
11 & LRDUST, PPIZA_DST,PCGA_DST,PTAUREL_DST &
12 & )
13
14
15!**** *SW* - COMPUTES THE SHORTWAVE RADIATION FLUXES.
16
17!     PURPOSE.
18!     --------
19
20!          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
21!     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
22
23!**   INTERFACE.
24!     ----------
25
26!          *SW* IS CALLED FROM *RADLSW*
27
28!        IMPLICIT ARGUMENTS :
29!        --------------------
30
31!     ==== INPUTS ===
32!     ==== OUTPUTS ===
33
34!     METHOD.
35!     -------
36
37!          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
38!          2. COMPUTES FLUXES IN U.V./VISIBLE  SPECTRAL INTERVAL (SW1S)
39!          3. COMPUTES FLUXES IN NEAR-INFRARED SPECTRAL INTERVAL (SWNI)
40
41!     EXTERNALS.
42!     ----------
43
44!          *SWU*, *SW1S*, *SWNI*
45
46!     REFERENCE.
47!     ----------
48
49!        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
50!        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
51
52!     AUTHOR.
53!     -------
54!        JEAN-JACQUES MORCRETTE  *ECMWF*
55
56!     MODIFICATIONS.
57!     --------------
58!        ORIGINAL : 89-07-14
59!        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
60!        95-12-07   J.-J. MORCRETTE  Near-Infrared in nsw-1 Intervals
61!        990128     JJMorcrette      sunshine duration
62!        99-05-25   JJMorcrette      Revised aerosols
63!        00-12-18   JJMorcrette      6 spectral intervals
64!        02-09-01   JJMorcrette      UV and PAR
65!        M.Hamrud      01-Oct-2003 CY28 Cleaning
66!        Y.Seity  04-11-18 : add two arguments for AROME extern. surface
67!        Y.Seity  05-10-10 : add add 3 optional arg. for dust SW properties
68!        JJMorcrette 20060721 PP of clear-sky PAR
69!     ------------------------------------------------------------------
70
71USE PARKIND1  ,ONLY : JPIM     ,JPRB
72USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
73!USE YOERAD   , ONLY : NSW
74! NSW mis dans .def MPL 20140211
75USE write_field_phy
76
77IMPLICIT NONE
78
79include "clesphys.h"
80
81integer, save :: icount=0
82INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
83INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
84INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA
85INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA
86INTEGER(KIND=JPIM),INTENT(IN)    :: KAER
87REAL(KIND=JPRB)   ,INTENT(IN)    :: PSCT
88REAL(KIND=JPRB)   ,INTENT(IN)    :: PCARDI
89REAL(KIND=JPRB)   ,INTENT(IN)    :: PPSOL(KLON)
90REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBD(KLON,NSW)
91REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBP(KLON,NSW)
92REAL(KIND=JPRB)   ,INTENT(IN)    :: PWV(KLON,KLEV)
93REAL(KIND=JPRB)   ,INTENT(IN)    :: PQS(KLON,KLEV)
94REAL(KIND=JPRB)   ,INTENT(IN)    :: PRMU0(KLON)
95REAL(KIND=JPRB)   ,INTENT(IN)    :: PCG(KLON,NSW,KLEV)
96REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLDSW(KLON,KLEV)
97REAL(KIND=JPRB)                  :: PDP(KLON,KLEV) ! Argument NOT used
98REAL(KIND=JPRB)   ,INTENT(IN)    :: POMEGA(KLON,NSW,KLEV)
99REAL(KIND=JPRB)   ,INTENT(IN)    :: POZ(KLON,KLEV)
100REAL(KIND=JPRB)   ,INTENT(IN)    :: PPMB(KLON,KLEV+1)
101REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAU(KLON,NSW,KLEV)
102REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAVE(KLON,KLEV)
103REAL(KIND=JPRB)   ,INTENT(IN)    :: PAER(KLON,6,KLEV)
104!++MODIFCODE
105LOGICAL           ,INTENT(IN)    :: LRDUST
106REAL(KIND=JPRB)   ,INTENT(IN)    :: PPIZA_DST(KLON,KLEV,NSW)
107REAL(KIND=JPRB)   ,INTENT(IN)    :: PCGA_DST(KLON,KLEV,NSW)
108REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUREL_DST(KLON,KLEV,NSW)
109!--MODIFCODE
110REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFDOWN(KLON,KLEV+1)
111REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFUP(KLON,KLEV+1)
112REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCDOWN(KLON,KLEV+1)
113REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCUP(KLON,KLEV+1)
114REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFDNN(KLON)
115REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFDNV(KLON)
116REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFUPN(KLON)
117REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFUPV(KLON)
118REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCDNN(KLON)
119REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCDNV(KLON)
120REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCUPN(KLON)
121REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCUPV(KLON)
122REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSUDU(KLON)
123REAL(KIND=JPRB)   ,INTENT(OUT)   :: PUVDF(KLON)
124REAL(KIND=JPRB)   ,INTENT(OUT)   :: PPARF(KLON)
125REAL(KIND=JPRB)   ,INTENT(OUT)   :: PPARCF(KLON)
126REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDIFFS(KLON,NSW)
127REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDIRFS(KLON,NSW)
128!     ------------------------------------------------------------------
129
130!*       0.1   ARGUMENTS
131!              ---------
132
133!     ------------------------------------------------------------------
134
135!              ------------
136
137REAL(KIND=JPRB) :: ZAKI(KLON,2,NSW)&
138 & ,  ZCLD(KLON,KLEV)    , ZCLEAR(KLON) &
139 & ,  ZDSIG(KLON,KLEV)   , ZFACT(KLON)&
140 & ,  ZFD(KLON,KLEV+1)   , ZCD(KLON,KLEV+1)&
141 & ,  ZCDOWN(KLON,KLEV+1), ZCDNIR(KLON,KLEV+1), ZCDUVS(KLON,KLEV+1)&
142 & ,  ZFDOWN(KLON,KLEV+1), ZFDNIR(KLON,KLEV+1), ZFDUVS(KLON,KLEV+1)&
143 & ,  ZFU(KLON,KLEV+1)   , ZCU(KLON,KLEV+1)&
144 & ,  ZCUP(KLON,KLEV+1)  , ZCUNIR(KLON,KLEV+1), ZCUUVS(KLON,KLEV+1)&
145 & ,  ZFUP(KLON,KLEV+1)  , ZFUNIR(KLON,KLEV+1), ZFUUVS(KLON,KLEV+1)&
146 & ,  ZRMU(KLON)         , ZSEC(KLON)         &
147 & ,  ZSUDU1(KLON)       , ZSUDU2(KLON)       &
148 & ,  ZSUDU1T(KLON)      , ZSUDU2T(KLON)      &
149 & ,  ZUD(KLON,5,KLEV+1) ,ZDIFF(KLON,KLEV)   ,ZDIRF(KLON,KLEV)    &
150 & ,  ZDIFF2(KLON,KLEV)  , ZDIRF2(KLON,KLEV)
151
152INTEGER(KIND=JPIM) ::  JK, JL, JNU, INUVS, INUIR
153
154REAL(KIND=JPRB) :: ZHOOK_HANDLE
155LOGICAL         :: LLDEBUG
156character*1 str1
157
158#include "sw1s.intfb.h"
159#include "swni.intfb.h"
160#include "swu.intfb.h"
161
162!     ------------------------------------------------------------------
163
164!*         1.     ABSORBER AMOUNTS AND OTHER USEFUL QUANTITIES
165!                 --------------------------------------------
166
167IF (LHOOK) CALL DR_HOOK('SW',0,ZHOOK_HANDLE)
168LLDEBUG=.FALSE.
169CALL SWU ( KIDIA,KFDIA ,KLON  ,KLEV,&
170 & PSCT ,PCARDI,PCLDSW,PPMB ,PPSOL,&
171 & PRMU0,PTAVE ,PWV,&
172 & ZAKI ,ZCLD  ,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD ) 
173
174!     ------------------------------------------------------------------
175!*         2.     INTERVAL (0.185/0.25-0.68 MICRON): U.V. AND VISIBLE
176!                 ---------------------------------------------------
177IF (NSW <= 4) THEN
178  INUVS=1
179  INUIR=2
180ELSEIF (NSW == 6) THEN
181  INUVS=1
182  INUIR=4
183ENDIF     
184
185DO JK = 1 , KLEV+1
186  DO JL = KIDIA,KFDIA
187    ZFD(JL,JK) =0.0_JPRB
188    ZFU(JL,JK) =0.0_JPRB
189    ZCD(JL,JK) =0.0_JPRB
190    ZCU(JL,JK) =0.0_JPRB
191  ENDDO
192ENDDO
193DO JL = KIDIA,KFDIA
194  ZSUDU1T(JL)=0.0_JPRB
195  PUVDF(JL)  =0.0_JPRB
196  PPARF(JL)  =0.0_JPRB
197  PPARCF(JL) =0.0_JPRB
198ENDDO
199
200IF(LLDEBUG) THEN
201call writefield_phy('sw_zsec',ZSEC,1)
202call writefield_phy('sw_zrmu',ZRMU,1)
203call writefield_phy('sw_prmu0',PRMU0,1)
204call writefield_phy('sw_zfact',ZFACT,1)
205ENDIF
206
207icount=icount+1
208DO JNU = INUVS , INUIR-1
209   !++MODIFCODE
210     CALL SW1S &
211           &( KIDIA , KFDIA, KLON , KLEV , KAER  , JNU &
212           &,  PAER , PALBD , PALBP, PCG  , ZCLD , ZCLEAR &
213           &,  ZDSIG, POMEGA, POZ  , ZRMU , ZSEC , PTAU  , ZUD  &
214           &,  ZFDUVS,ZFUUVS, ZCDUVS,ZCUUVS, ZSUDU1, ZDIFF,ZDIRF &
215           &,  LRDUST,PPIZA_DST(:,:,JNU) &       ! SSA for this wavelength
216           &,  PCGA_DST(:,:,JNU)   &            ! GCA for this wavelengt
217           &,  PTAUREL_DST(:,:,JNU) )           ! TAUREL for this wavelength
218  !--MODIFCODE
219IF(LLDEBUG) THEN
220! Ecriture des champs avec un indicage du fichier par l'intervalle spectral
221  write(str1,'(i1)') jnu
222  call writefield_phy("sw_zcduvs"//str1,zcduvs,klev+1)
223ENDIF
224
225
226  DO JL=KIDIA,KFDIA
227  PDIFFS(JL,JNU)=ZDIFF(JL,1)*ZFACT(JL)
228  PDIRFS(JL,JNU)=ZDIRF(JL,1)*ZFACT(JL)
229  ENDDO
230  DO JK = 1 , KLEV+1
231    DO JL = KIDIA,KFDIA
232      ZFD(JL,JK)=ZFD(JL,JK)+ZFDUVS(JL,JK)
233      ZFU(JL,JK)=ZFU(JL,JK)+ZFUUVS(JL,JK)
234      ZCD(JL,JK)=ZCD(JL,JK)+ZCDUVS(JL,JK)
235      ZCU(JL,JK)=ZCU(JL,JK)+ZCUUVS(JL,JK)
236    ENDDO
237  ENDDO
238  DO JL = KIDIA,KFDIA
239    ZSUDU1T(JL)=ZSUDU1T(JL)+ZSUDU1(JL)
240  ENDDO
241
242  IF (NSW == 6) THEN
243    IF (JNU <= 2) THEN
244      DO JL = KIDIA,KFDIA
245        PUVDF(JL)=PUVDF(JL)+ZFDUVS(JL,1)
246      ENDDO
247    ELSEIF (JNU == 3) THEN
248      DO JL=KIDIA,KFDIA
249        PPARF(JL)=PPARF(JL)+ZFDUVS(JL,1)
250        PPARCF(JL)=PPARCF(JL)+ZCDUVS(JL,1)
251      ENDDO
252    ENDIF   
253  ENDIF 
254ENDDO
255
256!if (icount==5) stop'on arrete dans sw.F90 au bout de 5 appels'
257!     ------------------------------------------------------------------
258
259!*         3.     INTERVAL (0.68-4.00 MICRON): NEAR-INFRARED
260!                 ------------------------------------------
261
262DO JK = 1 , KLEV+1
263  DO JL = KIDIA,KFDIA
264    ZFDOWN(JL,JK)=0.0_JPRB
265    ZFUP  (JL,JK)=0.0_JPRB
266    ZCDOWN(JL,JK)=0.0_JPRB
267    ZCUP  (JL,JK)=0.0_JPRB
268    ZSUDU2T(JL)  =0.0_JPRB
269  ENDDO
270ENDDO
271
272DO JNU = INUIR , NSW
273   !++MODIFCODE
274      CALL SWNI &
275           &(  KIDIA ,KFDIA , KLON , KLEV , KAER , JNU &
276           &,  PAER  ,ZAKI  , PALBD, PALBP, PCG  , ZCLD, ZCLEAR &
277           &,  ZDSIG ,POMEGA, POZ  , ZRMU , ZSEC , PTAU, ZUD      &
278           &,  PWV   ,PQS &
279           &,  ZFDNIR,ZFUNIR,ZCDNIR,ZCUNIR,ZSUDU2,ZDIFF2,ZDIRF2 &
280           &,  LRDUST,PPIZA_DST(:,:,JNU)  &
281           &,  PCGA_DST(:,:,JNU)    &
282           &,  PTAUREL_DST(:,:,JNU) &
283           &)
284    !--MODIFCODE
285
286IF(LLDEBUG) THEN
287! Ecriture des champs avec un indicage du fichier par l'intervalle spectral
288  write(str1,'(i1)') jnu
289  call writefield_phy("sw_zcdnir"//str1,zcdnir,klev+1)
290ENDIF
291
292  DO JL=KIDIA,KFDIA
293    PDIFFS(JL,JNU)=ZDIFF2(JL,1)*ZFACT(JL)
294    PDIRFS(JL,JNU)=ZDIRF2(JL,1)*ZFACT(JL)
295  ENDDO
296  DO JK = 1 , KLEV+1
297    DO JL = KIDIA,KFDIA
298      ZFDOWN(JL,JK)=ZFDOWN(JL,JK)+ZFDNIR(JL,JK)
299      ZFUP  (JL,JK)=ZFUP  (JL,JK)+ZFUNIR(JL,JK)
300      ZCDOWN(JL,JK)=ZCDOWN(JL,JK)+ZCDNIR(JL,JK)
301      ZCUP  (JL,JK)=ZCUP  (JL,JK)+ZCUNIR(JL,JK)
302    ENDDO
303  ENDDO
304  DO JL = KIDIA,KFDIA
305    ZSUDU2T(JL)=ZSUDU2T(JL)+ZSUDU2(JL)
306  ENDDO
307ENDDO
308
309!     ------------------------------------------------------------------
310
311!*         4.     FILL THE DIAGNOSTIC ARRAYS
312!                 --------------------------
313
314DO JL = KIDIA,KFDIA
315  PFDNN(JL)=ZFDOWN(JL,1)*ZFACT(JL)
316  PFDNV(JL)=ZFD(JL,1)*ZFACT(JL)
317  PFUPN(JL)=ZFUP(JL,KLEV+1)*ZFACT(JL)
318  PFUPV(JL)=ZFU(JL,KLEV+1)*ZFACT(JL)
319
320  PCDNN(JL)=ZCDOWN(JL,1)*ZFACT(JL)
321  PCDNV(JL)=ZCD(JL,1)*ZFACT(JL)
322  PCUPN(JL)=ZCUP(JL,KLEV+1)*ZFACT(JL)
323  PCUPV(JL)=ZCU(JL,KLEV+1)*ZFACT(JL)
324
325  PSUDU(JL)=(ZSUDU1T(JL)+ZSUDU2T(JL))*ZFACT(JL)
326  PUVDF(JL)=PUVDF(JL)*ZFACT(JL)
327  PPARF(JL)=PPARF(JL)*ZFACT(JL)
328  PPARCF(JL)=PPARCF(JL)*ZFACT(JL)
329ENDDO
330
331!WRITE(*,'("---> Dans SW:")')
332!WRITE(*,'("ZFUP  ",10E12.5)') (ZFUP(1,JK),JK=1,KLEV+1)
333!WRITE(*,'("ZFU   ",10E12.5)') (ZFU(1,JK),JK=1,KLEV+1)
334!WRITE(*,'("ZFUNIR",10E12.5)') (ZFUNIR(1,JK),JK=1,KLEV+1)
335!WRITE(*,'("ZFACT ",E12.5)') ZFACT(1)
336
337DO JK = 1 , KLEV+1
338  DO JL = KIDIA,KFDIA
339    PFUP(JL,JK)   = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
340    PFDOWN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
341    PCUP(JL,JK)   = (ZCUP(JL,JK)   + ZCU(JL,JK)) * ZFACT(JL)
342    PCDOWN(JL,JK) = (ZCDOWN(JL,JK) + ZCD(JL,JK)) * ZFACT(JL)
343  ENDDO
344ENDDO
345IF(LLDEBUG) THEN
346call writefield_phy('sw_pcdown',PCDOWN,KLEV+1)
347ENDIF
348
349!     ------------------------------------------------------------------
350
351IF (LHOOK) CALL DR_HOOK('SW',1,ZHOOK_HANDLE)
352END SUBROUTINE SW
Note: See TracBrowser for help on using the repository browser.