Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

lwxd.F @ 706

Last change on this file since 706 was 38, checked in by emillour, 14 years ago
Ajout du modè Martien (mon LMDZ.MARS.BETA, du 28/01/2011) dans le rértoire mars, pour pouvoir suivre plus facilement les modifs. EM
File size: 9.2 KB

Line
1	subroutine lwxd (ig0,kdlon,kflev,emis
2	. ,aer_t,co2_u,co2_up)
3
4	c----------------------------------------------------------------------
5	c LWXD computes transmission function and exchange coefficiants
6	c for distant layers
7	c (co2 / aerosols)
8	c (bands 1 and 2 of co2)
9	c----------------------------------------------------------------------
10	c
11	c \|---\|---\|---\|---\|---\|---\|---\|---\|
12	c kflev+1 \| \| \| \| \| \| \| \| 0 \| (space)
13	c \|---\|---\|---\|---\|---\|---\|---\|---\|
14	c kflev \| \|*\|\|\|*\| \| 0 \| \|
15	c \|---\|---\|---\|---\|---\|---\|---\|---\|
16	c ... \| \|*\|\|**\| \| 0 \| \| \|
17	c \|---\|---\|---\|---\|---\|---\|---\|---\|
18	c 4 \| \|*\|\| \| 0 \| \|**\| \|
19	c \|---\|---\|---\|---\|---\|---\|---\|---\|
20	c 3 \| \|*\| \| 0 \| \|\|**\| \|
21	c \|---\|---\|---\|---\|---\|---\|---\|---\|
22	c 2 \| \| \| 0 \| \| \|*\|*\| \|
23	c \|---\|---\|---\|---\|---\|---\|---\|---\|
24	c 1 \| \| 0 \| \| \|*\|\|**\| \|
25	c \|---\|---\|---\|---\|---\|---\|---\|---\|
26	c 0 \| 0 \| \| \|*\|\|\|*\| \| (ground)
27	c \|---\|---\|---\|---\|---\|---\|---\|---\|
28	c 0 1 2 3 4 ... k \|k+1
29	c (ground) (space)
30	c
31	c (*) xi computed in this subroutine
32	c----------------------------------------------------------------------
33
34	implicit none
35
36	#include "dimensions.h"
37	#include "dimphys.h"
38	#include "dimradmars.h"
39
40	#include "yomlw.h"
41	#include "callkeys.h"
42
43	c----------------------------------------------------------------------
44	c 0.1 arguments
45	c ---------
46	c inputs:
47	c -------
48	integer ig0
49	integer kdlon ! part of ngrid
50	integer kflev ! part of nalyer
51
52	real emis (ndlo2) ! surface emissivity
53	real aer_t (ndlo2,nuco2,kflev+1) ! transmission (aer)
54	real co2_u (ndlo2,nuco2,kflev+1) ! absorber amounts (co2)
55	real co2_up (ndlo2,nuco2,kflev+1) ! idem scaled by the pressure (co2)
56
57	c----------------------------------------------------------------------
58	c 0.2 local arrays
59	c ------------
60
61	integer ja,jl,jk,jkk,ndim
62	parameter(ndim = ndlonnuco2(nflev+2)*(nflev+2))
63
64
65	real zu (ndlon,nuco2)
66	real zup (ndlon,nuco2)
67	real zt_co2 (ndlon,nuco2)
68	real zt_aer (ndlon,nuco2)
69
70	real ksi (ndlon,nuco2,0:nflev+1,0:nflev+1)
71	real ksi_emis (ndlon,nuco2,0:nflev+1,0:nflev+1)
72	real trans (ndlon,nuco2,0:nflev+1,0:nflev+1)
73	real trans_emis (ndlon,nuco2,0:nflev+1,0:nflev+1)
74
75	c----------------------------------------------------------------------
76	call zerophys(ndim,ksi_emis)
77	c----------------------------------------------------------------------
78	c 1.0 Transmission functions
79	c ----------------------
80
81	c----------------------------------------------------------------------
82	c 1.1 Direct transmission
83	c -------------------
84
85	do jk = 1 , nlaylte+1
86	do jkk = jk , nlaylte+1
87
88	do ja = 1 , nuco2
89	do jl = 1 , kdlon
90	c co2
91	c ---
92	zu(jl,ja) = co2_u(jl,ja,jk) - co2_u(jl,ja,jkk)
93	zup(jl,ja) = co2_up(jl,ja,jk) - co2_up(jl,ja,jkk)
94	c aer
95	c ---
96	zt_aer(jl,ja)= aer_t(jl,ja,jk)
97	. /aer_t(jl,ja,jkk)
98
99	enddo
100	enddo
101
102	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
103	c co2 and aer
104	c -----------
105	do ja = 1 , nuco2
106	do jl = 1 , kdlon
107	trans(jl,ja,jk,jkk) = zt_co2(jl,ja) * zt_aer(jl,ja)
108	enddo
109	enddo
110	c trans reciprocity
111	c -----------------
112	do ja = 1 , nuco2
113	do jl = 1 , kdlon
114	trans(jl,ja,jkk,jk) = trans(jl,ja,jk,jkk)
115	c if (trans(jl,ja,jk,jkk) .LT. 0 ) then
116	c print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
117	c endif
118	c if (trans(jl,ja,jk,jkk) .GT. 1) then
119	c print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
120	c trans(jl,ja,jk,jkk)=1
121	c print*,'trans bande',ja,jk,jkk,trans(jl,ja,jk,jkk)
122	c endif
123
124	enddo
125	enddo
126
127	enddo
128	enddo
129
130	c----------------------------------------------------------------------
131	c 1.2 Transmission with reflexion
132	c ---------------------------
133
134	do jk = 1 , nlaylte+1
135	do jkk = jk , nlaylte+1
136
137	if (callemis) then
138	do ja = 1 , nuco2
139	do jl = 1 , kdlon
140	c co2
141	c ---
142	zu(jl,ja) = 2 * co2_u(jl,ja,1) - co2_u(jl,ja,jk)
143	. - co2_u(jl,ja,jkk)
144	zup(jl,ja) = 2 * co2_up(jl,ja,1) - co2_up(jl,ja,jk)
145	. - co2_up(jl,ja,jkk)
146	c aer
147	c ---
148	zt_aer(jl,ja) = aer_t(jl,ja,1)
149	. * aer_t(jl,ja,1)
150	. / aer_t(jl,ja,jk)
151	. / aer_t(jl,ja,jkk)
152	enddo
153	enddo
154
155	call lwtt(kdlon,zu,zup,nuco2,zt_co2)
156	c co2 and aer
157	c -----------
158	do ja = 1 , nuco2
159	do jl = 1 , kdlon
160	trans_emis(jl,ja,jk,jkk) = zt_co2(jl,ja)
161	. * zt_aer(jl,ja)
162	enddo
163	enddo
164
165	else
166
167	do ja = 1 , nuco2
168	do jl = 1 , kdlon
169	trans_emis(jl,ja,jk,jkk) = 1.
170	enddo
171	enddo
172
173	endif
174	c trans reciprocity
175	c -----------------
176	do ja = 1 , nuco2
177	do jl = 1 , kdlon
178	trans_emis(jl,ja,jkk,jk) = trans_emis(jl,ja,jk,jkk)
179	c if (trans_emis(jl,ja,jk,jkk) .LT. 0
180	c . .OR. trans_emis(jl,ja,jk,jkk) .GT. 1) then
181	c print*,'trans_emis bande',ja,jk,jkk,trans_emis(jl,ja,jk,jkk)
182	c endif
183	enddo
184	enddo
185
186	enddo
187	enddo
188
189	c----------------------------------------------------------------------
190	c 2.0 Exchange Coefficiants
191	c ---------------------
192
193	do jk = 1 , nlaylte-2
194	do jkk = jk+2 , nlaylte
195	do ja = 1 , nuco2
196	do jl = 1 , kdlon
197
198	ksi(jl,ja,jk,jkk) =
199	. trans(jl,ja,jk+1,jkk) - trans(jl,ja,jk,jkk)
200	. - trans(jl,ja,jk+1,jkk+1) + trans(jl,ja,jk,jkk+1)
201
202	ksi_emis(jl,ja,jk,jkk) =
203	. trans_emis(jl,ja,jk,jkk) - trans_emis(jl,ja,jk+1,jkk)
204	. - trans_emis(jl,ja,jk,jkk+1) + trans_emis(jl,ja,jk+1,jkk+1)
205
206	c if (ksi(jl,ja,jk,jkk) .LT. 0 ) then
207	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
208	c ksi(jl,ja,jk,jkk)=0
209	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
210	c endif
211	c if (ksi(jl,ja,jk,jkk) .GT. 1) then
212	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
213	c ksi(jl,ja,jk,jkk)=1
214	c print*,'ksi bande',ja,jk,jkk,ksi(jl,ja,jk,jkk)
215	c endif
216
217	c if (ksi_emis(jl,ja,jk,jkk) .LT. 0
218	c . .OR. ksi_emis(jl,ja,jk,jkk) .GT. 1) then
219	c print*,'ksi_emis bande',ja,jk,jkk,ksi_emis(jl,ja,jk,jkk)
220	c endif
221
222	xi(ig0+jl,ja,jk,jkk) = ksi(jl,ja,jk,jkk)
223	. + ksi_emis(jl,ja,jk,jkk) * (1 - emis(jl))
224
225	c ksi reciprocity
226	c ---------------
227	ksi(jl,ja,jkk,jk) = ksi(jl,ja,jk,jkk)
228	ksi_emis(jl,ja,jkk,jk) = ksi_emis(jl,ja,jk,jkk)
229	xi(ig0+jl,ja,jkk,jk) = xi(ig0+jl,ja,jk,jkk)
230
231	enddo
232	enddo
233	enddo
234	enddo
235
236	c----------------------------------------------------------------------
237	c 2.1 Save xi_emis for neighbours (lwxn.F)
238	c -----------------------------------
239
240	do jk = 1 , nlaylte-1
241	do ja = 1 , nuco2
242	do jl = 1 , kdlon
243
244	c ksi_emis(jl,ja,jk,jk+1) =
245	c . trans_emis(jl,ja,jk,jk+1) - trans_emis(jl,ja,jk+1,jk+1)
246	c . - trans_emis(jl,ja,jk,jk+2) + trans_emis(jl,ja,jk+1,jk+2)
247
248	xi_emis(ig0+jl,ja,jk) =
249	. ksi_emis(jl,ja,jk,jk+1) * (1-emis(jl))
250
251	enddo
252	enddo
253	enddo
254
255	c----------------------------------------------------------------------
256	return
257	end

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

Download in other formats:

Original Format