Context Navigation

ajsec.F @ 400

Last change on this file since 400 was 2, checked in by lmdz, 25 years ago
Initial revision
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 8.0 KB

Line
1	SUBROUTINE ajsec(paprs, pplay, t,q, d_t,d_q, itr, tr, d_tr)
2	IMPLICIT none
3	c======================================================================
4	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
5	c Objet: ajustement sec (adaptation du GCM du LMD)
6	c======================================================================
7	c Arguments:
8	c t-------input-R- Temperature
9	c
10	c d_t-----output-R-Incrementation de la temperature
11	c======================================================================
12	#include "dimensions.h"
13	#include "dimphy.h"
14	#include "YOMCST.h"
15	REAL paprs(klon,klev+1), pplay(klon,klev)
16	REAL t(klon,klev), q(klon,klev)
17	REAL d_t(klon,klev), d_q(klon,klev)
18	c
19	INTEGER it, itr
20	REAL tr(klon,klev,nbtr), d_tr(klon,klev,nbtr)
21	REAL ztr(klon,klev,nbtr), trm(nbtr)
22	c
23	INTEGER limbas, limhau ! les couches a ajuster
24	ccc PARAMETER (limbas=klev-3, limhau=klev)
25	PARAMETER (limbas=1, limhau=klev)
26	c
27	LOGICAL mixq
28	ccc PARAMETER (mixq=.TRUE.)
29	PARAMETER (mixq=.FALSE.)
30	c
31	REAL zh(klon,klev)
32	REAL zq(klon,klev)
33	REAL zpk(klon,klev)
34	REAL zpkdp(klon,klev)
35	REAL hm, sm, qm
36	LOGICAL modif(klon), down
37	INTEGER i, k, k1, k2
38	c
39	c Initialisation:
40	c
41	DO k = 1, klev
42	DO i = 1, klon
43	d_t(i,k) = 0.0
44	d_q(i,k) = 0.0
45	ENDDO
46	ENDDO
47	IF (itr.GE.1) THEN
48	DO it = 1, itr
49	DO k = 1, klev
50	DO i = 1, klon
51	d_tr(i,k,it) = 0.0
52	ENDDO
53	ENDDO
54	ENDDO
55	ENDIF
56	c------------------------------------- detection des profils a modifier
57	DO k = limbas, limhau
58	DO i = 1, klon
59	zpk(i,k) = pplay(i,k)**RKAPPA
60	zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
61	zq(i,k) = q(i,k)
62	ENDDO
63	ENDDO
64	c
65	IF (itr.GE.1) THEN
66	DO it = 1, itr
67	DO k = limbas, limhau
68	DO i = 1, klon
69	ztr(i,k,it) = tr(i,k,it)
70	ENDDO
71	ENDDO
72	ENDDO
73	ENDIF
74	c
75	DO k = limbas, limhau
76	DO i = 1, klon
77	zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
78	ENDDO
79	ENDDO
80	c
81	DO i = 1, klon
82	modif(i) = .FALSE.
83	ENDDO
84	DO k = limbas+1, limhau
85	DO i = 1, klon
86	IF (.NOT.modif(i)) THEN
87	IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
88	ENDIF
89	ENDDO
90	ENDDO
91	c------------------------------------- correction des profils instables
92	DO 1080 i = 1, klon
93	IF (modif(i)) THEN
94	k2 = limbas
95	8000 CONTINUE
96	k2 = k2 + 1
97	IF (k2 .GT. limhau) goto 8001
98	IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
99	k1 = k2 - 1
100	k = k1
101	sm = zpkdp(i,k2)
102	hm = zh(i,k2)
103	qm = zq(i,k2)
104	IF (itr.GE.1) THEN
105	DO it = 1, itr
106	trm(it) = ztr(i,k2,it)
107	ENDDO
108	ENDIF
109	8020 CONTINUE
110	sm = sm +zpkdp(i,k)
111	hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
112	qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
113	IF (itr.GE.1) THEN
114	DO it = 1, itr
115	trm(it) = trm(it) +
116	. zpkdp(i,k) * (ztr(i,k,it)-trm(it)) / sm
117	ENDDO
118	ENDIF
119	down = .FALSE.
120	IF (k1 .ne. limbas) THEN
121	IF (hm .LT. zh(i,k1-1)) down = .TRUE.
122	ENDIF
123	IF (down) THEN
124	k1 = k1 - 1
125	k = k1
126	ELSE
127	IF ((k2 .EQ. limhau)) GOTO 8021
128	IF ((zh(i,k2+1).GE.hm)) GOTO 8021
129	k2 = k2 + 1
130	k = k2
131	ENDIF
132	GOTO 8020
133	8021 CONTINUE
134	c------------ nouveau profil : constant (valeur moyenne)
135	DO k = k1, k2
136	zh(i,k) = hm
137	zq(i,k) = qm
138	ENDDO
139	IF (itr.GE.1) THEN
140	DO it = 1, itr
141	DO k = k1, k2
142	ztr(i,k,it) = trm(it)
143	ENDDO
144	ENDDO
145	ENDIF
146	k2 = k2 + 1
147	ENDIF
148	GOTO 8000
149	8001 CONTINUE
150	ENDIF
151	1080 CONTINUE
152	c
153	DO k = limbas, limhau
154	DO i = 1, klon
155	d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
156	d_q(i,k) = zq(i,k) - q(i,k)
157	ENDDO
158	ENDDO
159	c
160	IF (limbas.GT.1) THEN
161	DO k = 1, limbas-1
162	DO i = 1, klon
163	d_t(i,k) = 0.0
164	d_q(i,k) = 0.0
165	ENDDO
166	ENDDO
167	ENDIF
168	c
169	IF (limhau.LT.klev) THEN
170	DO k = limhau+1, klev
171	DO i = 1, klon
172	d_t(i,k) = 0.0
173	d_q(i,k) = 0.0
174	ENDDO
175	ENDDO
176	ENDIF
177	c
178	IF (itr.GE.1) THEN
179	DO it = 1, itr
180	c
181	DO k = limbas, limhau
182	DO i = 1, klon
183	d_tr(i,k,it) = ztr(i,k,it) - tr(i,k,it)
184	ENDDO
185	ENDDO
186	c
187	IF (limbas.GT.1) THEN
188	DO k = 1, limbas-1
189	DO i = 1, klon
190	d_tr(i,k,it) = 0.0
191	ENDDO
192	ENDDO
193	ENDIF
194	c
195	IF (limhau.LT.klev) THEN
196	DO k = limhau+1, klev
197	DO i = 1, klon
198	d_tr(i,k,it) = 0.0
199	ENDDO
200	ENDDO
201	ENDIF
202	c
203	ENDDO
204	ENDIF
205	c
206	IF (.NOT.mixq) THEN
207	DO k = 1, klev
208	DO i = 1, klon
209	d_q(i,k) = 0.0
210	ENDDO
211	ENDDO
212	ENDIF
213	c
214	RETURN
215	END
216	SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
217	IMPLICIT none
218	c======================================================================
219	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
220	c Objet: ajustement sec (adaptation du GCM du LMD)
221	c======================================================================
222	c Arguments:
223	c t-------input-R- Temperature
224	c
225	c d_t-----output-R-Incrementation de la temperature
226	c======================================================================
227	#include "dimensions.h"
228	#include "dimphy.h"
229	#include "YOMCST.h"
230	REAL paprs(klon,klev+1), pplay(klon,klev)
231	REAL t(klon,klev)
232	REAL d_t(klon,klev)
233	c
234	REAL local_h(klon,klev)
235	REAL hm, sm
236	LOGICAL modif(klon), down
237	INTEGER i, l, l1, l2
238	c------------------------------------- detection des profils a modifier
239	DO i = 1, klon
240	modif(i) = .false.
241	ENDDO
242	c
243	DO l = 1, klev
244	DO i = 1, klon
245	local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA)
246	ENDDO
247	ENDDO
248	c
249	DO l = 2, klev
250	DO i = 1, klon
251	IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN
252	modif(i) = .true.
253	ELSE
254	modif(i) = modif(i)
255	ENDIF
256	ENDDO
257	ENDDO
258	c------------------------------------- correction des profils instables
259	do 1080 i = 1, klon
260	if (modif(i)) then
261	l2 = 1
262	8000 continue
263	l2 = l2 + 1
264	if (l2 .gt. klev) goto 8001
265	if (local_h(i, l2) .lt. local_h(i, l2-1)) then
266	l1 = l2 - 1
267	l = l1
268	sm = pplay(i,l2)*rkappa (paprs(i,l2)-paprs(i,l2+1))
269	hm = local_h(i, l2)
270	8020 continue
271	sm = sm +pplay(i,l)*rkappa(paprs(i,l)-paprs(i,l+1))
272	hm = hm +pplay(i,l)*rkappa(paprs(i,l)-paprs(i,l+1))
273	. * (local_h(i, l) - hm) / sm
274	down = .false.
275	if (l1 .ne. 1) then
276	if (hm .lt. local_h(i, l1-1)) then
277	down = .true.
278	end if
279	end if
280	if (down) then
281	l1 = l1 - 1
282	l = l1
283	else
284	if ((l2 .eq. klev)) GOTO 8021
285	IF ((local_h(i, l2+1).ge.hm)) goto 8021
286	l2 = l2 + 1
287	l = l2
288	end if
289	go to 8020
290	8021 continue
291	c------------ nouveau profil : constant (valeur moyenne)
292	do 1100 l = l1, l2
293	local_h(i, l) = hm
294	1100 continue
295	l2 = l2 + 1
296	end if
297	go to 8000
298	8001 continue
299	end if
300	1080 continue
301	c
302	DO l = 1, klev
303	DO i = 1, klon
304	d_t(i,l) = local_h(i,l)(pplay(i,l)*rkappa)/RCPD - t(i,l)
305	ENDDO
306	ENDDO
307	c
308	RETURN
309	END

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

Download in other formats:

Original Format