Context Navigation

ajsec.F90

Last change on this file was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 10.6 KB

Line
1	!
2	! $Header$
3	!
4	SUBROUTINE ajsec(paprs, pplay, t,q,limbas,d_t,d_q)
5	USE dimphy
6	IMPLICIT none
7	!c======================================================================
8	!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
9	!c Objet: ajustement sec (adaptation du GCM du LMD)
10	!c======================================================================
11	!c Arguments:
12	!c t-------input-R- Temperature
13	!c
14	!c d_t-----output-R-Incrementation de la temperature
15	!c======================================================================
16	!cym#include "dimensions.h"
17	!cym#include "dimphy.h"
18	#include "YOMCST.h"
19	REAL paprs(klon,klev+1), pplay(klon,klev)
20	REAL t(klon,klev), q(klon,klev)
21	REAL d_t(klon,klev), d_q(klon,klev)
22	!c
23	INTEGER limbas(klon), limhau ! les couches a ajuster
24	!c
25	LOGICAL mixq
26	!ccc PARAMETER (mixq=.TRUE.)
27	PARAMETER (mixq=.FALSE.)
28	!c
29	REAL zh(klon,klev)
30	REAL zho(klon,klev)
31	REAL zq(klon,klev)
32	REAL zpk(klon,klev)
33	REAL zpkdp(klon,klev)
34	REAL hm, sm, qm
35	LOGICAL modif(klon), down
36	INTEGER i, k, k1, k2
37	!c
38	!c Initialisation:
39	!c
40	!cym
41	limhau=klev
42
43	DO k = 1, klev
44	DO i = 1, klon
45	d_t(i,k) = 0.0
46	d_q(i,k) = 0.0
47	ENDDO
48	ENDDO
49	!c------------------------------------- detection des profils a modifier
50	DO k = 1, limhau
51	DO i = 1, klon
52	zpk(i,k) = pplay(i,k)**RKAPPA
53	zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
54	zho(i,k) = zh(i,k)
55	zq(i,k) = q(i,k)
56	ENDDO
57	ENDDO
58	!c
59	DO k = 1, limhau
60	DO i = 1, klon
61	zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
62	ENDDO
63	ENDDO
64	!c
65	DO i = 1, klon
66	modif(i) = .FALSE.
67	ENDDO
68	DO k = 2, limhau
69	DO i = 1, klon
70	IF (.NOT.modif(i).and.k-1>limbas(i)) THEN
71	IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
72	ENDIF
73	ENDDO
74	ENDDO
75	!c------------------------------------- correction des profils instables
76	DO 1080 i = 1, klon
77	IF (modif(i)) THEN
78	k2 = limbas(i)
79	8000 CONTINUE
80	k2 = k2 + 1
81	IF (k2 .GT. limhau) goto 8001
82	IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
83	k1 = k2 - 1
84	k = k1
85	sm = zpkdp(i,k2)
86	hm = zh(i,k2)
87	qm = zq(i,k2)
88	8020 CONTINUE
89	sm = sm +zpkdp(i,k)
90	hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
91	qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
92	down = .FALSE.
93	IF (k1 .ne. limbas(i)) THEN
94	IF (hm .LT. zh(i,k1-1)) down = .TRUE.
95	ENDIF
96	IF (down) THEN
97	k1 = k1 - 1
98	k = k1
99	ELSE
100	IF ((k2 .EQ. limhau)) GOTO 8021
101	IF ((zh(i,k2+1).GE.hm)) GOTO 8021
102	k2 = k2 + 1
103	k = k2
104	ENDIF
105	GOTO 8020
106	8021 CONTINUE
107	!c------------ nouveau profil : constant (valeur moyenne)
108	DO k = k1, k2
109	zh(i,k) = hm
110	zq(i,k) = qm
111	ENDDO
112	k2 = k2 + 1
113	ENDIF
114	GOTO 8000
115	8001 CONTINUE
116	ENDIF
117	1080 CONTINUE
118	!c
119	DO k = 1, limhau
120	DO i = 1, klon
121	d_t(i,k) = (zh(i,k)-zho(i,k))*zpk(i,k)/RCPD
122	d_q(i,k) = zq(i,k) - q(i,k)
123	ENDDO
124	ENDDO
125	!c
126	! FH : les d_q et d_t sont maintenant calcules de facon a valoir
127	! effectivement 0. si on ne fait rien.
128	!
129	! IF (limbas.GT.1) THEN
130	! DO k = 1, limbas-1
131	! DO i = 1, klon
132	! d_t(i,k) = 0.0
133	! d_q(i,k) = 0.0
134	! ENDDO
135	! ENDDO
136	! ENDIF
137	!c
138	! IF (limhau.LT.klev) THEN
139	! DO k = limhau+1, klev
140	! DO i = 1, klon
141	! d_t(i,k) = 0.0
142	! d_q(i,k) = 0.0
143	! ENDDO
144	! ENDDO
145	! ENDIF
146	!c
147	IF (.NOT.mixq) THEN
148	DO k = 1, klev
149	DO i = 1, klon
150	d_q(i,k) = 0.0
151	ENDDO
152	ENDDO
153	ENDIF
154	!c
155	RETURN
156	END
157
158	SUBROUTINE ajsec_convV2(paprs, pplay, t,q, d_t,d_q)
159	USE dimphy
160	IMPLICIT none
161	!c======================================================================
162	!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
163	!c Objet: ajustement sec (adaptation du GCM du LMD)
164	!c======================================================================
165	!c Arguments:
166	!c t-------input-R- Temperature
167	!c
168	!c d_t-----output-R-Incrementation de la temperature
169	!c======================================================================
170	!cym#include "dimensions.h"
171	!cym#include "dimphy.h"
172	#include "YOMCST.h"
173	REAL paprs(klon,klev+1), pplay(klon,klev)
174	REAL t(klon,klev), q(klon,klev)
175	REAL d_t(klon,klev), d_q(klon,klev)
176	!c
177	INTEGER limbas, limhau ! les couches a ajuster
178	!ccc PARAMETER (limbas=klev-3, limhau=klev)
179	!cym PARAMETER (limbas=1, limhau=klev)
180	!c
181	LOGICAL mixq
182	!ccc PARAMETER (mixq=.TRUE.)
183	PARAMETER (mixq=.FALSE.)
184	!c
185	REAL zh(klon,klev)
186	REAL zq(klon,klev)
187	REAL zpk(klon,klev)
188	REAL zpkdp(klon,klev)
189	REAL hm, sm, qm
190	LOGICAL modif(klon), down
191	INTEGER i, k, k1, k2
192	!c
193	!c Initialisation:
194	!c
195	!cym
196	limbas=1
197	limhau=klev
198
199	DO k = 1, klev
200	DO i = 1, klon
201	d_t(i,k) = 0.0
202	d_q(i,k) = 0.0
203	ENDDO
204	ENDDO
205	!c------------------------------------- detection des profils a modifier
206	DO k = limbas, limhau
207	DO i = 1, klon
208	zpk(i,k) = pplay(i,k)**RKAPPA
209	zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
210	zq(i,k) = q(i,k)
211	ENDDO
212	ENDDO
213	!c
214	DO k = limbas, limhau
215	DO i = 1, klon
216	zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
217	ENDDO
218	ENDDO
219	!c
220	DO i = 1, klon
221	modif(i) = .FALSE.
222	ENDDO
223	DO k = limbas+1, limhau
224	DO i = 1, klon
225	IF (.NOT.modif(i)) THEN
226	IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
227	ENDIF
228	ENDDO
229	ENDDO
230	!c------------------------------------- correction des profils instables
231	DO 1080 i = 1, klon
232	IF (modif(i)) THEN
233	k2 = limbas
234	8000 CONTINUE
235	k2 = k2 + 1
236	IF (k2 .GT. limhau) goto 8001
237	IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
238	k1 = k2 - 1
239	k = k1
240	sm = zpkdp(i,k2)
241	hm = zh(i,k2)
242	qm = zq(i,k2)
243	8020 CONTINUE
244	sm = sm +zpkdp(i,k)
245	hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
246	qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
247	down = .FALSE.
248	IF (k1 .ne. limbas) THEN
249	IF (hm .LT. zh(i,k1-1)) down = .TRUE.
250	ENDIF
251	IF (down) THEN
252	k1 = k1 - 1
253	k = k1
254	ELSE
255	IF ((k2 .EQ. limhau)) GOTO 8021
256	IF ((zh(i,k2+1).GE.hm)) GOTO 8021
257	k2 = k2 + 1
258	k = k2
259	ENDIF
260	GOTO 8020
261	8021 CONTINUE
262	!c------------ nouveau profil : constant (valeur moyenne)
263	DO k = k1, k2
264	zh(i,k) = hm
265	zq(i,k) = qm
266	ENDDO
267	k2 = k2 + 1
268	ENDIF
269	GOTO 8000
270	8001 CONTINUE
271	ENDIF
272	1080 CONTINUE
273	!c
274	DO k = limbas, limhau
275	DO i = 1, klon
276	d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
277	d_q(i,k) = zq(i,k) - q(i,k)
278	ENDDO
279	ENDDO
280	!c
281	IF (limbas.GT.1) THEN
282	DO k = 1, limbas-1
283	DO i = 1, klon
284	d_t(i,k) = 0.0
285	d_q(i,k) = 0.0
286	ENDDO
287	ENDDO
288	ENDIF
289	!c
290	IF (limhau.LT.klev) THEN
291	DO k = limhau+1, klev
292	DO i = 1, klon
293	d_t(i,k) = 0.0
294	d_q(i,k) = 0.0
295	ENDDO
296	ENDDO
297	ENDIF
298	!c
299	IF (.NOT.mixq) THEN
300	DO k = 1, klev
301	DO i = 1, klon
302	d_q(i,k) = 0.0
303	ENDDO
304	ENDDO
305	ENDIF
306	!c
307	RETURN
308	END
309	SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
310	USE dimphy
311	IMPLICIT none
312	!c======================================================================
313	!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
314	!c Objet: ajustement sec (adaptation du GCM du LMD)
315	!c======================================================================
316	!c Arguments:
317	!c t-------input-R- Temperature
318	!c
319	!c d_t-----output-R-Incrementation de la temperature
320	!c======================================================================
321	!cym#include "dimensions.h"
322	!cym#include "dimphy.h"
323	#include "YOMCST.h"
324	REAL paprs(klon,klev+1), pplay(klon,klev)
325	REAL t(klon,klev)
326	REAL d_t(klon,klev)
327	!c
328	REAL local_h(klon,klev)
329	REAL hm, sm
330	LOGICAL modif(klon), down
331	INTEGER i, l, l1, l2
332	!c------------------------------------- detection des profils a modifier
333	DO i = 1, klon
334	modif(i) = .false.
335	ENDDO
336	!c
337	DO l = 1, klev
338	DO i = 1, klon
339	local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA)
340	ENDDO
341	ENDDO
342	!c
343	DO l = 2, klev
344	DO i = 1, klon
345	IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN
346	modif(i) = .true.
347	ELSE
348	modif(i) = modif(i)
349	ENDIF
350	ENDDO
351	ENDDO
352	!c------------------------------------- correction des profils instables
353	do 1080 i = 1, klon
354	if (modif(i)) then
355	l2 = 1
356	8000 continue
357	l2 = l2 + 1
358	if (l2 .gt. klev) goto 8001
359	if (local_h(i, l2) .lt. local_h(i, l2-1)) then
360	l1 = l2 - 1
361	l = l1
362	sm = pplay(i,l2)*rkappa (paprs(i,l2)-paprs(i,l2+1))
363	hm = local_h(i, l2)
364	8020 continue
365	sm = sm +pplay(i,l)*rkappa(paprs(i,l)-paprs(i,l+1))
366	hm = hm +pplay(i,l)*rkappa(paprs(i,l)-paprs(i,l+1)) &
367	& * (local_h(i, l) - hm) / sm
368	down = .false.
369	if (l1 .ne. 1) then
370	if (hm .lt. local_h(i, l1-1)) then
371	down = .true.
372	end if
373	end if
374	if (down) then
375	l1 = l1 - 1
376	l = l1
377	else
378	if ((l2 .eq. klev)) GOTO 8021
379	IF ((local_h(i, l2+1).ge.hm)) goto 8021
380	l2 = l2 + 1
381	l = l2
382	end if
383	go to 8020
384	8021 continue
385	!c------------ nouveau profil : constant (valeur moyenne)
386	do 1100 l = l1, l2
387	local_h(i, l) = hm
388	1100 continue
389	l2 = l2 + 1
390	end if
391	go to 8000
392	8001 continue
393	end if
394	1080 continue
395	!c
396	DO l = 1, klev
397	DO i = 1, klon
398	d_t(i,l) = local_h(i,l)(pplay(i,l)*rkappa)/RCPD - t(i,l)
399	ENDDO
400	ENDDO
401	!c
402	RETURN
403	END

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

Download in other formats:

Original Format