Context Navigation

ajsec.F @ 1907

Last change on this file since 1907 was 1907, checked in by lguez, 10 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
Name of program: LMDZ
Creation date: 1984
Version: LMDZ5
License: CeCILL version 2
Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
See the license file in the root directory

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

Property copyright set to
Name of program: LMDZ
Creation date: 1984
Version: LMDZ5
License: CeCILL version 2
Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
See the license file in the root directory
Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 10.5 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