LMDZ
lwvd.F90
Go to the documentation of this file.
1 SUBROUTINE lwvd &
2  &( kidia, kfdia, klon , klev , ktraer &
3  &, pabcu, pdbdt &
4  &, pga , pgb &
5  &, pcntrb, pdisd, pdisu, pdwfsu &
6  &)
7 
8 !**** *LWVD* - L.W., VERTICAL INTEGRATION, DISTANT LAYERS
9 
10 ! PURPOSE.
11 ! --------
12 ! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
13 
14 !** INTERFACE.
15 ! ----------
16 
17 ! EXPLICIT ARGUMENTS :
18 ! --------------------
19 ! ==== INPUTS ===
20 ! PABCU : (KLON,NUA,3*KLEV+1) ; ABSORBER AMOUNTS
21 ! PDBDT : (KLON,KLEV) ; LAYER PLANCK FUNCTION GRADIENT
22 ! PGA, PGB ; PADE APPROXIMANTS
23 ! ==== OUTPUTS ===
24 ! PCNTRB : (KLON,KLEV+1,KLEV+1); ENERGY EXCHANGE MATRIX
25 ! PDIS.. : (KLON,KLEV+1) ; CONTRIBUTION BY DISTANT LAYERS
26 ! PDWFSU : (KLON,NSIL) ; SPECTRAL DOWNWARD FLUX AT SURFACE
27 
28 ! IMPLICIT ARGUMENTS : NONE
29 ! --------------------
30 
31 ! METHOD.
32 ! -------
33 
34 ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
35 ! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
36 
37 ! EXTERNALS.
38 ! ----------
39 
40 ! *LWTT*
41 
42 ! REFERENCE.
43 ! ----------
44 
45 ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
46 ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
47 
48 ! AUTHOR.
49 ! -------
50 ! JEAN-JACQUES MORCRETTE *ECMWF*
51 
52 ! MODIFICATIONS.
53 ! --------------
54 ! ORIGINAL : 89-07-14
55 ! JJ Morcrette 97-04-18 Revised continuum + Surf. Emissiv.
56 !-----------------------------------------------------------------------
57 
58 #include "tsmbkind.h"
59 
60 USE yoelw , ONLY : nsil ,nipd ,ntra ,nua ,ng1p1
61 
62 
63 IMPLICIT NONE
64 
65 
66 ! DUMMY INTEGER SCALARS
67 integer_m :: kfdia
68 integer_m :: kidia
69 integer_m :: klev
70 integer_m :: klon
71 integer_m :: ktraer
72 
73 
74 
75 !-----------------------------------------------------------------------
76 
77 !* 0.1 ARGUMENTS
78 ! ---------
79 
80 
81 real_b :: pabcu(klon,nua,3*klev+1)&
82  &, pdbdt(klon,nsil,klev)&
83  &, pga(klon,nipd,2,klev) , pgb(klon,nipd,2,klev)
84 
85 real_b :: pcntrb(klon,klev+1,klev+1)&
86  &, pdisd(klon,klev+1) , pdisu(klon,klev+1)&
87  &, pdwfsu(klon,nsil)
88 
89 !-----------------------------------------------------------------------
90 
91 !* 0.2 LOCAL ARRAYS
92 ! ------------
93 
94 real_b :: ztt(klon,ntra), ztt1(klon,ntra), ztt2(klon,ntra)
95 
96 ! LOCAL INTEGER SCALARS
97 integer_m :: ijkl, ikd1, ikd2, ikj, ikjp1, ikm1, ikn,&
98  &ikp1, iku1, iku2, itt, ja, jk, jkj, jl, jlk
99 
100 ! LOCAL REAL SCALARS
101 real_b :: zww, zww1, zww2, zww3, zww4, zww5, zww6
102 
103 
104 !-----------------------------------------------------------------------
105 
106 !* 1. INITIALIZATION
107 ! --------------
108 
109 !* 1.1 INITIALIZE LAYER CONTRIBUTIONS
110 ! ------------------------------
111 
112 DO jk = 1, klev+1
113  DO jl = kidia,kfdia
114  pdisd(jl,jk) = _zero_
115  pdisu(jl,jk) = _zero_
116  ENDDO
117 ENDDO
118 
119 !* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
120 ! ---------------------------------
121 
122 DO ja = 1, ntra
123  DO jl = kidia,kfdia
124  ztt(jl,ja) = _one_
125  ztt1(jl,ja) = _one_
126  ztt2(jl,ja) = _one_
127  ENDDO
128 ENDDO
129 
130 ! ------------------------------------------------------------------
131 
132 !* 2. VERTICAL INTEGRATION
133 ! --------------------
134 
135 
136 !* 2.2 CONTRIBUTION FROM DISTANT LAYERS
137 ! ---------------------------------
138 
139 
140 !* 2.2.1 DISTANT AND ABOVE LAYERS
141 ! ------------------------
142 
143 
144 !* 2.2.2 FIRST UPPER LEVEL
145 ! -----------------
146 
147 DO jk = 1 , klev-1
148  ikp1=jk+1
149  ikn=(jk-1)*ng1p1+1
150  ikd1= jk *ng1p1+1
151 
152  CALL lwttm &
153  &( kidia , kfdia , klon &
154  &, pga(1,1,1,jk) , pgb(1,1,1,jk)&
155  &, pabcu(1,1,ikn), pabcu(1,1,ikd1), ztt1 &
156  &)
157 
158 
159 
160 !* 2.2.3 HIGHER UP
161 ! ---------
162 
163  itt=1
164  DO jkj=ikp1,klev
165  IF(itt == 1) THEN
166  itt=2
167  ELSE
168  itt=1
169  ENDIF
170  ikjp1=jkj+1
171  ikd2= jkj *ng1p1+1
172 
173  IF(itt == 1) THEN
174  CALL lwttm &
175  &( kidia , kfdia , klon &
176  &, pga(1,1,1,jkj), pgb(1,1,1,jkj)&
177  &, pabcu(1,1,ikn), pabcu(1,1,ikd2), ztt1 &
178  &)
179 
180 
181  ELSE
182  CALL lwttm &
183  &( kidia , kfdia , klon &
184  &, pga(1,1,1,jkj), pgb(1,1,1,jkj)&
185  &, pabcu(1,1,ikn), pabcu(1,1,ikd2), ztt2 &
186  &)
187 
188 
189  ENDIF
190 
191  DO ja = 1, ktraer
192  DO jl = kidia,kfdia
193  ztt(jl,ja) = (ztt1(jl,ja)+ztt2(jl,ja))*_half_
194  ENDDO
195  ENDDO
196 
197  DO jl = kidia,kfdia
198  zww1=pdbdt(jl,1,jkj)*ztt(jl,1) *ztt(jl,10)
199  zww2=pdbdt(jl,2,jkj)*ztt(jl,2)*ztt(jl,7)*ztt(jl,11)
200  zww3=pdbdt(jl,3,jkj)*ztt(jl,4)*ztt(jl,8)*ztt(jl,12)
201  zww4=pdbdt(jl,4,jkj)*ztt(jl,5)*ztt(jl,9)*ztt(jl,13)
202  zww5=pdbdt(jl,5,jkj)*ztt(jl,3) *ztt(jl,14)
203  zww6=pdbdt(jl,6,jkj)*ztt(jl,6) *ztt(jl,15)
204  zww=zww1+zww2+zww3+zww4+zww5+zww6
205  pdisd(jl,jk)=pdisd(jl,jk)+zww
206  pcntrb(jl,jk,ikjp1)=zww
207  IF (jk == 1) THEN
208  pdwfsu(jl,1)=pdwfsu(jl,1)+zww1
209  pdwfsu(jl,2)=pdwfsu(jl,2)+zww2
210  pdwfsu(jl,3)=pdwfsu(jl,3)+zww3
211  pdwfsu(jl,4)=pdwfsu(jl,4)+zww4
212  pdwfsu(jl,5)=pdwfsu(jl,5)+zww5
213  pdwfsu(jl,6)=pdwfsu(jl,6)+zww6
214  ENDIF
215  ENDDO
216 
217 
218  ENDDO
219 ENDDO
220 
221 
222 !* 2.2.4 DISTANT AND BELOW LAYERS
223 ! ------------------------
224 
225 
226 !* 2.2.5 FIRST LOWER LEVEL
227 ! -----------------
228 
229 DO jk=3,klev+1
230  ikn=(jk-1)*ng1p1+1
231  ikm1=jk-1
232  ikj=jk-2
233  iku1= ikj *ng1p1+1
234 
235 
236  CALL lwttm &
237  &( kidia , kfdia , klon &
238  &, pga(1,1,1,ikj) , pgb(1,1,1,ikj)&
239  &, pabcu(1,1,iku1), pabcu(1,1,ikn), ztt1 &
240  &)
241 
242 
243 
244 
245 !* 2.2.6 DOWN BELOW
246 ! ----------
247 
248  itt=1
249  DO jlk=1,ikj
250  IF(itt == 1) THEN
251  itt=2
252  ELSE
253  itt=1
254  ENDIF
255  ijkl=ikm1-jlk
256  iku2=(ijkl-1)*ng1p1+1
257 
258 
259  IF(itt == 1) THEN
260  CALL lwttm &
261  &( kidia , kfdia , klon &
262  &, pga(1,1,1,ijkl), pgb(1,1,1,ijkl)&
263  &, pabcu(1,1,iku2), pabcu(1,1,ikn) , ztt1 &
264  &)
265 
266 
267  ELSE
268  CALL lwttm &
269  &( kidia , kfdia , klon &
270  &, pga(1,1,1,ijkl), pgb(1,1,1,ijkl)&
271  &, pabcu(1,1,iku2), pabcu(1,1,ikn) , ztt2 &
272  &)
273 
274 
275  ENDIF
276 
277  DO ja = 1, ktraer
278  DO jl = kidia,kfdia
279  ztt(jl,ja) = (ztt1(jl,ja)+ztt2(jl,ja))*_half_
280  ENDDO
281  ENDDO
282 
283  DO jl = kidia,kfdia
284  zww=pdbdt(jl,1,ijkl)*ztt(jl,1) *ztt(jl,10)&
285  &+pdbdt(jl,2,ijkl)*ztt(jl,2)*ztt(jl,7)*ztt(jl,11)&
286  &+pdbdt(jl,3,ijkl)*ztt(jl,4)*ztt(jl,8)*ztt(jl,12)&
287  &+pdbdt(jl,4,ijkl)*ztt(jl,5)*ztt(jl,9)*ztt(jl,13)&
288  &+pdbdt(jl,5,ijkl)*ztt(jl,3) *ztt(jl,14)&
289  &+pdbdt(jl,6,ijkl)*ztt(jl,6) *ztt(jl,15)
290  pdisu(jl,jk)=pdisu(jl,jk)+zww
291  pcntrb(jl,jk,ijkl)=zww
292  ENDDO
293 
294 
295  ENDDO
296 ENDDO
297 
298 ! ------------------------------------------------------------------
299 
300 RETURN
301 END SUBROUTINE lwvd
yoelw::nipd
integer(kind=jpim) nipd
Definition: yoelw.F90:15
yoelw
Definition: yoelw.F90:1
yoelw::nsil
integer(kind=jpim) nsil
Definition: yoelw.F90:14
dimphy::kidia
integer, save kidia
Definition: dimphy.F90:6
dimphy::klon
integer, save klon
Definition: dimphy.F90:3
yoelw::nua
integer(kind=jpim) nua
Definition: yoelw.F90:19
dimphy::klev
integer, save klev
Definition: dimphy.F90:7
lwvd
subroutine lwvd(KIDIA, KFDIA, KLON, KLEV, KTRAER, PABCU, PDBDT, PGA, PGB, PCNTRB, PDISD, PDISU, PDWFSU)
Definition: lwvd.F90:7
dimphy::kfdia
integer, save kfdia
Definition: dimphy.F90:5
yoelw::ng1p1
integer(kind=jpim) ng1p1
Definition: yoelw.F90:21
lwttm
subroutine lwttm(KIDIA, KFDIA, KLON, PGA, PGB, PUU1, PUU2, PTT)
Definition: lwttm.F90:3
yoelw::ntra
integer(kind=jpim) ntra
Definition: yoelw.F90:18