source: LMDZ5/branches/IPSLCM6.0.10/libf/phymar/sw.F90 @ 5215

Last change on this file since 5215 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: 7.6 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 &, PHEAT, PFDOWN, PFUP  &
7 &, PCEAT, PCDOWN, PCUP  &
8 &, PFDNN, PFDNV , PFUPN, PFUPV &
9 &, PCDNN, PCDNV , PCUPN, PCUPV &
10 &, PSUDU, PUVDF , PPARF &
11 &)
12
13!**** *SW* - COMPUTES THE SHORTWAVE RADIATION FLUXES.
14
15!     PURPOSE.
16!     --------
17
18!          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
19!     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
20
21!**   INTERFACE.
22!     ----------
23
24!          *SW* IS CALLED FROM *RADLSW*
25
26
27!        IMPLICIT ARGUMENTS :
28!        --------------------
29
30!     ==== INPUTS ===
31!     ==== OUTPUTS ===
32
33!     METHOD.
34!     -------
35
36!          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
37!          2. COMPUTES FLUXES IN U.V./VISIBLE  SPECTRAL INTERVAL (SW1S)
38!          3. COMPUTES FLUXES IN NEAR-INFRARED SPECTRAL INTERVAL (SWNI)
39
40!     EXTERNALS.
41!     ----------
42
43!          *SWU*, *SW1S*, *SWNI*
44
45!     REFERENCE.
46!     ----------
47
48!        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
49!        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
50
51!     AUTHOR.
52!     -------
53!        JEAN-JACQUES MORCRETTE  *ECMWF*
54
55!     MODIFICATIONS.
56!     --------------
57!        ORIGINAL : 89-07-14
58!        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
59!        95-12-07   J.-J. MORCRETTE  Near-Infrared in nsw-1 Intervals
60!        990128     JJMorcrette      sunshine duration
61!        99-05-25   JJMorcrette      Revised aerosols
62!        00-12-18   JJMorcrette      6 spectral intervals
63
64!     ------------------------------------------------------------------
65
66
67#include "tsmbkind.h"
68
69USE YOERAD   , ONLY : NSW
70USE YOERDU   , ONLY : RCDAY
71
72
73IMPLICIT NONE
74
75
76!     DUMMY INTEGER SCALARS
77INTEGER_M :: KAER
78INTEGER_M :: KFDIA
79INTEGER_M :: KIDIA
80INTEGER_M :: KLEV
81INTEGER_M :: KLON
82
83!     DUMMY REAL SCALARS
84REAL_B :: PCARDI
85REAL_B :: PSCT
86
87
88
89!     ------------------------------------------------------------------
90
91!*       0.1   ARGUMENTS
92!              ---------
93
94REAL_B :: PPSOL(KLON), PAER(KLON,6,KLEV),PRMU0(KLON)&
95  &,  PWV(KLON,KLEV),PQS(KLON,KLEV)
96
97REAL_B :: PALBD(KLON,NSW)      , PALBP(KLON,NSW)&
98  &,  PCG(KLON,NSW,KLEV)   , PCLDSW(KLON,KLEV)&
99  &,  PDP(KLON,KLEV)  &
100  &,  POMEGA(KLON,NSW,KLEV), POZ(KLON,KLEV)&
101  &,  PPMB(KLON,KLEV+1)&
102  &,  PTAU(KLON,NSW,KLEV)  , PTAVE(KLON,KLEV)
103
104REAL_B :: PHEAT(KLON,KLEV), PFDOWN(KLON,KLEV+1), PFUP(KLON,KLEV+1),&
105     &PFUPV(KLON), PFUPN(KLON), PFDNV(KLON), PFDNN(KLON)&
106  &,  PCEAT(KLON,KLEV), PCDOWN(KLON,KLEV+1), PCUP(KLON,KLEV+1)&
107  &,  PCUPV(KLON), PCUPN(KLON), PCDNV(KLON), PCDNN(KLON)&
108  &,  PSUDU(KLON), PUVDF(KLON), PPARF(KLON)
109
110!     ------------------------------------------------------------------
111
112!*       0.2   LOCAL ARRAYS
113!              ------------
114
115REAL_B :: ZAKI(KLON,2,NSW)&
116  &,  ZCLD(KLON,KLEV)    , ZCLEAR(KLON) &
117  &,  ZDSIG(KLON,KLEV)   , ZFACT(KLON)&
118  &,  ZFD(KLON,KLEV+1)   , ZCD(KLON,KLEV+1)&
119  &,  ZCDOWN(KLON,KLEV+1), ZCDNIR(KLON,KLEV+1), ZCDUVS(KLON,KLEV+1)&
120  &,  ZFDOWN(KLON,KLEV+1), ZFDNIR(KLON,KLEV+1), ZFDUVS(KLON,KLEV+1)&
121  &,  ZFU(KLON,KLEV+1)   , ZCU(KLON,KLEV+1)&
122  &,  ZCUP(KLON,KLEV+1)  , ZCUNIR(KLON,KLEV+1), ZCUUVS(KLON,KLEV+1)&
123  &,  ZFUP(KLON,KLEV+1)  , ZFUNIR(KLON,KLEV+1), ZFUUVS(KLON,KLEV+1)&
124  &,  ZRMU(KLON)         , ZSEC(KLON)         &
125  &,  ZSUDU1(KLON)       , ZSUDU2(KLON)       &
126  &,  ZSUDU1T(KLON)      , ZSUDU2T(KLON)      &
127  &,  ZUD(KLON,5,KLEV+1)
128
129!     LOCAL INTEGER SCALARS
130INTEGER_M :: INU, JK, JKL, JL, JNU, INUVS, INUIR
131
132!     LOCAL REAL SCALARS
133REAL_B :: ZDCNET, ZDFNET
134
135
136!     ------------------------------------------------------------------
137
138!*         1.     ABSORBER AMOUNTS AND OTHER USEFUL QUANTITIES
139!                 --------------------------------------------
140
141CALL SWU ( KIDIA,KFDIA ,KLON  ,KLEV &
142         &, PSCT ,PCARDI,PCLDSW,PPMB ,PPSOL &
143         &, PRMU0,PTAVE ,PWV &
144         &, ZAKI ,ZCLD  ,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD )
145         
146!print *,'After SWU'         
147
148!     ------------------------------------------------------------------
149
150!*         2.     INTERVAL (0.185/0.25-0.68 MICRON): U.V. AND VISIBLE
151!                 ---------------------------------------------------
152
153IF (NSW.LE.4) THEN
154  INUVS=1
155  INUIR=2
156ELSE IF (NSW.EQ.6) THEN
157  INUVS=1
158  INUIR=4
159END IF     
160
161DO JK = 1 , KLEV+1
162  DO JL = KIDIA,KFDIA
163    ZFD(JL,JK) =_ZERO_
164    ZFU(JL,JK) =_ZERO_
165    ZCD(JL,JK) =_ZERO_
166    ZCU(JL,JK) =_ZERO_
167    ZSUDU1T(JL)=_ZERO_
168    PUVDF(JL)  =_ZERO_
169    PPARF(JL)  =_ZERO_
170  ENDDO
171ENDDO
172
173DO JNU = INUVS , INUIR-1
174
175  CALL SW1S &
176    &( KIDIA , KFDIA, KLON , KLEV , KAER  , JNU &
177    &,  PAER , PALBD , PALBP, PCG  , ZCLD , ZCLEAR &
178    &,  ZDSIG, POMEGA, POZ  , ZRMU , ZSEC , PTAU  , ZUD  &
179    &,  ZFDUVS,ZFUUVS, ZCDUVS,ZCUUVS, ZSUDU1 &
180    &)
181
182  DO JK = 1 , KLEV+1
183    DO JL = KIDIA,KFDIA
184      ZFD(JL,JK)=ZFD(JL,JK)+ZFDUVS(JL,JK)
185      ZFU(JL,JK)=ZFU(JL,JK)+ZFUUVS(JL,JK)
186      ZCD(JL,JK)=ZCD(JL,JK)+ZCDUVS(JL,JK)
187      ZCU(JL,JK)=ZCU(JL,JK)+ZCUUVS(JL,JK)
188    ENDDO
189  ENDDO
190  DO JL = KIDIA,KFDIA
191    ZSUDU1T(JL)=ZSUDU1T(JL)+ZSUDU1(JL)
192  ENDDO
193 
194  IF (NSW.EQ.6) THEN
195    IF (JNU.LT.INUIR-1) THEN
196      DO JL=KIDIA,KFDIA
197        PUVDF(JL)=PUVDF(JL)+ZFDUVS(JL,1)
198      END DO
199    ELSE     
200      DO JL=KIDIA,KFDIA
201        PPARF(JL)=PPARF(JL)+ZFDUVS(JL,1)
202      END DO
203    END IF
204  END IF   
205 
206ENDDO
207!print *,'After SW1S'
208!     ------------------------------------------------------------------
209
210!*         3.     INTERVAL (0.68-4.00 MICRON): NEAR-INFRARED
211!                 ------------------------------------------
212
213
214DO JK = 1 , KLEV+1
215  DO JL = KIDIA,KFDIA
216    ZFDOWN(JL,JK)=_ZERO_
217    ZFUP  (JL,JK)=_ZERO_
218    ZCDOWN(JL,JK)=_ZERO_
219    ZCUP  (JL,JK)=_ZERO_
220    ZSUDU2T(JL)  =_ZERO_
221  ENDDO
222ENDDO
223
224DO JNU = INUIR , NSW
225
226  CALL SWNI &
227   &(  KIDIA ,KFDIA , KLON , KLEV , KAER , JNU &
228   &,  PAER  ,ZAKI  , PALBD, PALBP, PCG  , ZCLD, ZCLEAR &
229   &,  ZDSIG ,POMEGA, POZ  , ZRMU , ZSEC , PTAU, ZUD      &
230   &,  PWV   ,PQS &
231   &,  ZFDNIR,ZFUNIR,ZCDNIR,ZCUNIR,ZSUDU2 &
232   &)
233
234  DO JK = 1 , KLEV+1
235    DO JL = KIDIA,KFDIA
236      ZFDOWN(JL,JK)=ZFDOWN(JL,JK)+ZFDNIR(JL,JK)
237      ZFUP  (JL,JK)=ZFUP  (JL,JK)+ZFUNIR(JL,JK)
238      ZCDOWN(JL,JK)=ZCDOWN(JL,JK)+ZCDNIR(JL,JK)
239      ZCUP  (JL,JK)=ZCUP  (JL,JK)+ZCUNIR(JL,JK)
240    ENDDO
241  ENDDO
242  DO JL = KIDIA,KFDIA
243    ZSUDU2T(JL)=ZSUDU2T(JL)+ZSUDU2(JL)
244  ENDDO
245ENDDO
246
247!     ------------------------------------------------------------------
248
249!*         4.     FILL THE DIAGNOSTIC ARRAYS
250!                 --------------------------
251
252
253DO JL = KIDIA,KFDIA
254  PFDNN(JL)=ZFDOWN(JL,1)*ZFACT(JL)
255  PFDNV(JL)=ZFD(JL,1)*ZFACT(JL)
256  PFUPN(JL)=ZFUP(JL,KLEV+1)*ZFACT(JL)
257  PFUPV(JL)=ZFU(JL,KLEV+1)*ZFACT(JL)
258
259  PCDNN(JL)=ZCDOWN(JL,1)*ZFACT(JL)
260  PCDNV(JL)=ZCD(JL,1)*ZFACT(JL)
261  PCUPN(JL)=ZCUP(JL,KLEV+1)*ZFACT(JL)
262  PCUPV(JL)=ZCU(JL,KLEV+1)*ZFACT(JL)
263
264  PSUDU(JL)=(ZSUDU1T(JL)+ZSUDU2T(JL))*ZFACT(JL)
265  PUVDF(JL)=PUVDF(JL)*ZFACT(JL)
266  PPARF(JL)=PPARF(JL)*ZFACT(JL)
267ENDDO
268
269DO JK = 1 , KLEV+1
270  DO JL = KIDIA,KFDIA
271    PFUP(JL,JK)   = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
272    PFDOWN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
273    PCUP(JL,JK)   = (ZCUP(JL,JK)   + ZCU(JL,JK)) * ZFACT(JL)
274    PCDOWN(JL,JK) = (ZCDOWN(JL,JK) + ZCD(JL,JK)) * ZFACT(JL)
275  ENDDO
276ENDDO
277
278DO JKL = 1 , KLEV
279  JK = KLEV+1 - JKL
280  DO JL = KIDIA,KFDIA
281    ZDFNET = PFUP(JL,JK+1) - PFDOWN(JL,JK+1)-PFUP(JL,JK  ) + PFDOWN(JL,JK  )
282    PHEAT(JL,JK) = RCDAY * ZDFNET / PDP(JL,JKL)
283    ZDCNET = PCUP(JL,JK+1) - PCDOWN(JL,JK+1)-PCUP(JL,JK  ) + PCDOWN(JL,JK  )
284    PCEAT(JL,JK) = RCDAY * ZDCNET / PDP(JL,JKL)
285  ENDDO
286ENDDO
287
288!     ------------------------------------------------------------------
289
290RETURN
291END SUBROUTINE SW
Note: See TracBrowser for help on using the repository browser.