Context Navigation

lwxd.F @ 3807

Last change on this file since 3807 was 3757, checked in by emillour, 6 weeks ago
Mars PCM: More code tidying: puting routines in modules and modernizing some old constructs. Tested to not change results with respect to previous version. EM
File size: 9.4 KB

Line
1	module lwxd_mod
2
3	implicit none
4
5	contains
6
7	subroutine lwxd (ig0,kdlon,kflev,emis
8	. ,aer_t,co2_u,co2_up)
9
10	c----------------------------------------------------------------------
11	c LWXD computes transmission function and exchange coefficiants
12	c for distant layers
13	c (co2 / aerosols)
14	c (bands 1 and 2 of co2)
15	c----------------------------------------------------------------------
16	c
17	c \|---\|---\|---\|---\|---\|---\|---\|---\|
18	c kflev+1 \| \| \| \| \| \| \| \| 0 \| (space)
19	c \|---\|---\|---\|---\|---\|---\|---\|---\|
20	c kflev \| \|*\|\|\|*\| \| 0 \| \|
21	c \|---\|---\|---\|---\|---\|---\|---\|---\|
22	c ... \| \|*\|\|**\| \| 0 \| \| \|
23	c \|---\|---\|---\|---\|---\|---\|---\|---\|
24	c 4 \| \|*\|\| \| 0 \| \|**\| \|
25	c \|---\|---\|---\|---\|---\|---\|---\|---\|
26	c 3 \| \|*\| \| 0 \| \|\|**\| \|
27	c \|---\|---\|---\|---\|---\|---\|---\|---\|
28	c 2 \| \| \| 0 \| \| \|*\|*\| \|
29	c \|---\|---\|---\|---\|---\|---\|---\|---\|
30	c 1 \| \| 0 \| \| \|*\|\|**\| \|
31	c \|---\|---\|---\|---\|---\|---\|---\|---\|
32	c 0 \| 0 \| \| \|*\|\|\|*\| \| (ground)
33	c \|---\|---\|---\|---\|---\|---\|---\|---\|
34	c 0 1 2 3 4 ... k \|k+1
35	c (ground) (space)
36	c
37	c (*) xi computed in this subroutine
38	c----------------------------------------------------------------------
39
40	use dimradmars_mod, only: ndlon, nuco2, nflev, ndlo2
41	use yomlw_h, only: nlaylte, xi, xi_emis
42	use callkeys_mod, only: callemis
43	use lwtt_mod, only: lwtt
44	implicit none
45
46	c----------------------------------------------------------------------
47	c 0.1 arguments
48	c ---------
49	c inputs:
50	c -------
51	integer,intent(in) :: ig0
52	integer,intent(in) :: kdlon ! part of ngrid
53	integer,intent(in) :: kflev ! part of nalyer
54
55	real,intent(in) :: emis (ndlo2) ! surface emissivity
56	real,intent(in) :: aer_t (ndlo2,nuco2,kflev+1) ! transmission (aer)
57	real,intent(in) :: co2_u (ndlo2,nuco2,kflev+1) ! absorber amounts (co2)
58	real,intent(in) :: co2_up (ndlo2,nuco2,kflev+1) ! idem scaled by the pressure (co2)
59
60	c----------------------------------------------------------------------
61	c 0.2 local arrays
62	c ------------
63
64	integer ja,jl,jk,jkk
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	ksi_emis(:,:,:,:)=0
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	end subroutine lwxd
257
258	end module lwxd_mod

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

Download in other formats:

Original Format