Context Navigation

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

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

Download in other formats:

Original Format