Context Navigation

lwxn.F @ 1112

Last change on this file since 1112 was 1047, checked in by emillour, 11 years ago

Mars GCM:

IMPORTANT CHANGE: Removed all reference/use of ngridmx (dimphys.h) in routines (necessary prerequisite to using parallel dynamics); in most cases this just means adding 'ngrid' as routine argument, and making local saved variables allocatable (and allocated at first call). In the process, had to convert many *.h files to equivalent modules: yomaer.h => yomaer_h.F90 , surfdat.h => surfdat_h.F90 , comsaison.h => comsaison_h.F90 , yomlw.h => yomlw_h.F90 , comdiurn.h => comdiurn_h.F90 , dimradmars.h => dimradmars_mod.F90 , comgeomfi.h => comgeomfi_h.F90, comsoil.h => comsoil_h.F90 , slope.h => slope_mod.F90
Also updated EOF routines, everything is now in eofdump_mod.F90
Removed unused routine lectfux.F (in dyn3d)

File size: 12.6 KB

Line
1	subroutine lwxn ( ig0,kdlon,kflev
2	. , dp
3	. , aer_t,co2_u,co2_up)
4
5	c----------------------------------------------------------------------
6	c LWXN computes transmission function and exchange coefficiants
7	c for neighbours layers
8	c (co2 / aerosols)
9	c (bands 1 and 2 of co2)
10	c----------------------------------------------------------------------
11	c
12	c \|---\|---\|---\|---\|---\|---\|---\|---\|
13	c kflev+1 \| \| \| \| \| \| \| \| 0 \| (space)
14	c \|---\|---\|---\|---\|---\|---\|---\|---\|
15	c kflev \| \| \| \| \| \|***\| 0 \| \|
16	c \|---\|---\|---\|---\|---\|---\|---\|---\|
17	c ... \| \| \| \| \|*\| 0 \|*\| \|
18	c \|---\|---\|---\|---\|---\|---\|---\|---\|
19	c 4 \| \| \| \|*\| 0 \|*\| \| \|
20	c \|---\|---\|---\|---\|---\|---\|---\|---\|
21	c 3 \| \| \|*\| 0 \|*\| \| \| \|
22	c \|---\|---\|---\|---\|---\|---\|---\|---\|
23	c 2 \| \|*\| 0 \|*\| \| \| \| \|
24	c \|---\|---\|---\|---\|---\|---\|---\|---\|
25	c 1 \| \| 0 \|***\| \| \| \| \| \|
26	c \|---\|---\|---\|---\|---\|---\|---\|---\|
27	c 0 \| 0 \| \| \| \| \| \| \| \| (ground)
28	c \|---\|---\|---\|---\|---\|---\|---\|---\|
29	c 0 1 2 3 4 ... k \|k+1
30	c (ground) (space)
31	c
32	c (*) xi computed in this subroutine
33	c----------------------------------------------------------------------
34	c
35	c *********************************************************** nj=1
36	c
37	c
38	c sublayer 1
39	c
40	c
41	c ----------------------------- nj=2
42	c
43	c sublayer 2
44	c
45	c - - - - LAYER j - - - - - ----------------------------- nj=3
46	c
47	c sublayer 3
48	c ----------------------------- nj=4
49	c sublayer ncouche
50	c *********************************************************** ni=nj=ncouche+1
51	c sublayer ncouche
52	c ----------------------------- ni=4
53	c sublayer 3
54	c
55	c - - - - LAYER i - - - - - ----------------------------- ni=3
56	c
57	c sublayer 2
58	c
59	c ----------------------------- ni=2
60	c
61	c
62	c sublayer 1
63	c
64	c
65	c *********************************************************** ni=1
66	c
67	c-----------------------------------------------------------------------
68	c ATTENTION AUX UNITES:
69	c le facteur 10*g fait passer des kg m-2 aux g cm-2
70	c-----------------------------------------------------------------------
71
72	use dimradmars_mod, only: ndlo2, nuco2, ndlon, nflev
73	use yomlw_h, only: nlaylte, xi, xi_ground, xi_emis
74	implicit none
75
76	!#include "dimensions.h"
77	!#include "dimphys.h"
78	!#include "dimradmars.h"
79
80	!#include "yomlw.h"
81	#include "callkeys.h"
82
83	c----------------------------------------------------------------------
84	c 0.1 arguments
85	c ---------
86	c inputs:
87	c -------
88	integer ig0
89	integer kdlon ! part of ngrid
90	integer kflev ! part of nalyer
91
92	real dp (ndlo2,kflev) ! layer pressure thickness (Pa)
93
94	real aer_t (ndlo2,nuco2,kflev+1) ! transmission (aer)
95	real co2_u (ndlo2,nuco2,kflev+1) ! absorber amounts (co2)
96	real co2_up (ndlo2,nuco2,kflev+1) ! idem scaled by the pressure (co2)
97
98	c----------------------------------------------------------------------
99	c 0.2 local arrays
100	c ------------
101
102	integer ja,jl,jk,nlmd,ni,nj
103
104	integer nmax
105	parameter (nmax=50) ! max: 50 sublayers
106
107	real cn (nmax), cb (nmax)
108
109	real zu_layer_i (ndlon,nuco2)
110	real zup_layer_i (ndlon,nuco2)
111	real zt_aer_layer_i (ndlon,nuco2)
112
113	real zu_layer_j (ndlon,nuco2)
114	real zup_layer_j (ndlon,nuco2)
115	real zt_aer_layer_j (ndlon,nuco2)
116
117	real zu (ndlon,nuco2)
118	real zup (ndlon,nuco2)
119	real zt_co2 (ndlon,nuco2)
120	real zt_aer (ndlon,nuco2)
121
122	real zu_i (ndlon,nuco2,nmax+1)
123	real zup_i (ndlon,nuco2,nmax+1)
124	real zu_j (ndlon,nuco2,nmax+1)
125	real zup_j (ndlon,nuco2,nmax+1)
126	real zt_aer_i (ndlon,nuco2,nmax+1)
127	real zt_aer_j (ndlon,nuco2,nmax+1)
128
129	real trans (ndlon,nuco2,nmax+1,nmax+1)
130	real ksi (ndlon,nuco2,nflev-1)
131
132	c----------------------------------------------------------------------
133	c 0.3 Initialisation
134	c --------------
135
136	jk=ncouche+1
137	do ja = 1 ,nuco2
138	do jl = 1 , kdlon
139	zu_i (jl,ja,jk) = 0.
140	zup_i (jl,ja,jk) = 0.
141	zu_j (jl,ja,jk) = 0.
142	zup_j (jl,ja,jk) = 0.
143	zt_aer_i (jl,ja,jk) = 1.
144	zt_aer_j (jl,ja,jk) = 1.
145	enddo
146	enddo
147
148	if (linear) then
149
150	do nlmd = 1 ,ncouche
151	cn(nlmd)=(1.0/ncouche)
152	cb(nlmd)=(ncouche-nlmd+0.5)/ncouche
153	c print*,nlmd,cb(nlmd),cn(nlmd)
154	enddo
155
156	else
157
158	do nlmd = 1 ,ncouche-1
159	cn(nlmd)=(1-alphan)alphan*(nlmd-1)
160	cb(nlmd)=0.5(1+alphan)alphan**(nlmd-1)
161	enddo
162	cn(ncouche)=alphan**(ncouche-1)
163	cb(ncouche)=0.5alphan*(ncouche-1)
164
165	endif
166
167	c test
168	if (nmax .LT. ncouche) then
169	print*,'!!!!! ATTENTION !!!!! '
170	print*,'probleme dans lwxn.F'
171	print*,' nmax=',nmax,' < ncouche=',ncouche
172	call exit(1)
173	endif
174
175	c----------------------------------------------------------------------
176	do jk = 1 , nlaylte-1
177	c----------------------------------------------------------------------
178	c 1.0 (co2) amount and (aer) transmission for all sublayers
179	c ----------------------------------------------------
180
181	do ja = 1 , nuco2
182	do jl = 1 , kdlon
183
184	c layer i (down)
185	c -------------
186	zu_layer_i(jl,ja) = co2_u(jl,ja,jk) - co2_u(jl,ja,jk+1)
187	zup_layer_i(jl,ja) = co2_up(jl,ja,jk) - co2_up(jl,ja,jk+1)
188	zt_aer_layer_i(jl,ja) = aer_t(jl,ja,jk)
189	. / aer_t(jl,ja,jk+1)
190
191	do nlmd=1,ncouche
192	zu_i(jl,ja,nlmd)=cn(nlmd)*zu_layer_i(jl,ja)
193	zup_i(jl,ja,nlmd)=cn(nlmd)*zup_layer_i(jl,ja)
194	zt_aer_i(jl,ja,nlmd)=zt_aer_layer_i(jl,ja)**cn(nlmd)
195	enddo
196
197	c layer j (up)
198	c ------------
199	zu_layer_j(jl,ja) = co2_u(jl,ja,jk+1) - co2_u(jl,ja,jk+2)
200	zup_layer_j(jl,ja) = co2_up(jl,ja,jk+1) - co2_up(jl,ja,jk+2)
201	zt_aer_layer_j(jl,ja) = aer_t(jl,ja,jk+1)
202	. / aer_t(jl,ja,jk+2)
203
204	do nlmd=1,ncouche
205	zu_j(jl,ja,nlmd)=cn(nlmd)*zu_layer_j(jl,ja)
206	zup_j(jl,ja,nlmd)=cn(nlmd)*zup_layer_j(jl,ja)
207	zt_aer_j(jl,ja,nlmd)=zt_aer_layer_j(jl,ja)**cn(nlmd)
208	enddo
209
210	enddo
211	enddo
212
213	c----------------------------------------------------------------------
214	c 2.0 transmissions between all sublayers
215	c ------------------------------------
216
217	do ni = 1 ,ncouche+1
218
219	do ja = 1 ,nuco2
220	do jl = 1 , kdlon
221	zu(jl,ja)=0.
222	zup(jl,ja)=0.
223	zt_aer(jl,ja)=1.
224
225	do nlmd=ni,ncouche+1
226	zu(jl,ja)=zu(jl,ja)+zu_i(jl,ja,nlmd)
227	zup(jl,ja)=zup(jl,ja)+zup_i(jl,ja,nlmd)
228	zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_i(jl,ja,nlmd)
229	enddo
230	enddo
231	enddo
232
233	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
234
235	do ja = 1 ,nuco2
236	do jl = 1 , kdlon
237	trans(jl,ja,ni,ncouche+1)=zt_co2(jl,ja)*zt_aer(jl,ja)
238	enddo
239	enddo
240
241	c on ajoute la couche J
242	do ja = 1 ,nuco2
243	do jl = 1 , kdlon
244	zu(jl,ja)=zu(jl,ja)+zu_layer_j(jl,ja)
245	zup(jl,ja)=zup(jl,ja)+zup_layer_j(jl,ja)
246	zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_layer_j(jl,ja)
247	enddo
248	enddo
249
250	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
251
252	do ja = 1 ,nuco2
253	do jl = 1 , kdlon
254	trans(jl,ja,ni,1)=zt_co2(jl,ja)*zt_aer(jl,ja)
255	enddo
256	enddo
257
258	enddo
259	ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
260
261	do nj = 1 ,ncouche+1
262
263	do ja = 1 ,nuco2
264	do jl = 1 , kdlon
265	zu(jl,ja)=0.
266	zup(jl,ja)=0.
267	zt_aer(jl,ja)=1.
268
269	do nlmd=nj,ncouche+1
270	zu(jl,ja)=zu(jl,ja)+zu_j(jl,ja,nlmd)
271	zup(jl,ja)=zup(jl,ja)+zup_j(jl,ja,nlmd)
272	zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_j(jl,ja,nlmd)
273	enddo
274	enddo
275	enddo
276
277	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
278
279	do ja = 1 ,nuco2
280	do jl = 1 , kdlon
281	trans(jl,ja,ncouche+1,nj)=zt_co2(jl,ja)*zt_aer(jl,ja)
282	enddo
283	enddo
284
285	c on ajoute la couche I
286	do ja = 1 ,nuco2
287	do jl = 1 , kdlon
288	zu(jl,ja)=zu(jl,ja)+zu_layer_i(jl,ja)
289	zup(jl,ja)=zup(jl,ja)+zup_layer_i(jl,ja)
290	zt_aer(jl,ja)=zt_aer(jl,ja)*zt_aer_layer_i(jl,ja)
291	enddo
292	enddo
293
294	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
295
296	do ja = 1 ,nuco2
297	do jl = 1 , kdlon
298	trans(jl,ja,1,nj)=zt_co2(jl,ja)*zt_aer(jl,ja)
299	enddo
300	enddo
301
302	enddo
303
304	c----------------------------------------------------------------------
305	c 3.0 global exchange coefficiant between neigthbours
306	c -----------------------------------------------
307
308	do ja = 1 ,nuco2
309	do jl = 1 , kdlon
310	ksi(jl,ja,jk) = 0.
311	enddo
312	enddo
313
314	do ni = 1 ,ncouche
315	do ja = 1 ,nuco2
316	do jl = 1 , kdlon
317
318	ksi(jl,ja,jk)=ksi(jl,ja,jk) +
319	. ( trans(jl,ja,ni+1,ncouche+1)
320	. - trans(jl,ja,ni,ncouche+1)
321	. - trans(jl,ja,ni+1,1)
322	. + trans(jl,ja,ni,1) )
323	. * (cb(ni)dp(jl,jk)) 2
324	. / (dp(jl,jk) + dp(jl,jk+1)) !!!!!!!!!!!!!!!!!!!
325
326	enddo
327	enddo
328	enddo
329
330	do nj = 1 ,ncouche
331	do ja = 1 ,nuco2
332	do jl = 1 , kdlon
333
334	ksi(jl,ja,jk)=ksi(jl,ja,jk) +
335	. ( trans(jl,ja,ncouche+1,nj+1)
336	. - trans(jl,ja,1,nj+1)
337	. - trans(jl,ja,ncouche+1,nj)
338	. + trans(jl,ja,1,nj) )
339	. * (cb(nj)dp(jl,jk+1)) 2
340	. / (dp(jl,jk) + dp(jl,jk+1)) !!!!!!!!!!!!!!!!!!!
341
342	enddo
343	enddo
344	enddo
345
346	do ja = 1 ,nuco2
347	do jl = 1 , kdlon
348	xi(ig0+jl,ja,jk,jk+1) = ksi(jl,ja,jk)
349	. + xi_emis(ig0+jl,ja,jk)
350
351	c ksi reciprocity
352	c ---------------
353	xi(ig0+jl,ja,jk+1,jk) = xi(ig0+jl,ja,jk,jk+1)
354	enddo
355	enddo
356
357	c----------------------------------------------------------------------
358	c 4.0 Special treatment for ground
359	c ----------------------------
360
361
362	if (jk .EQ. 1) then
363
364	do ja = 1 ,nuco2
365	do jl = 1 , kdlon
366	xi_ground(ig0+jl,ja)=0.
367	enddo
368	enddo
369
370	do ni = 1 ,ncouche
371	do ja = 1 ,nuco2
372	do jl = 1 , kdlon
373
374	xi_ground(ig0+jl,ja) = xi_ground(ig0+jl,ja)
375	. + ( trans(jl,ja,ni+1,ncouche+1)
376	. -trans(jl,ja,ni,ncouche+1))
377	. * 2 * cb(ni)
378	enddo
379	enddo
380	enddo
381
382	endif
383
384	c----------------------------------------------------------------------
385	enddo ! boucle sur jk
386	c----------------------------------------------------------------------
387	return
388	end
389
390
391

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format