Context Navigation

ajsec.F @ 5373

Last change on this file since 5373 was 704, checked in by Laurent Fairhead, 18 years ago
Inclusion des modifs de Y. Meurdesoif pour la version V3 LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 6.6 KB

Line
1	!
2	! $Header$
3	!
4	SUBROUTINE ajsec(paprs, pplay, t,q, 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, limhau ! les couches a ajuster
24	ccc PARAMETER (limbas=klev-3, limhau=klev)
25	cym 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	cym
42	limbas=1
43	limhau=klev
44
45	DO k = 1, klev
46	DO i = 1, klon
47	d_t(i,k) = 0.0
48	d_q(i,k) = 0.0
49	ENDDO
50	ENDDO
51	c------------------------------------- detection des profils a modifier
52	DO k = limbas, limhau
53	DO i = 1, klon
54	zpk(i,k) = pplay(i,k)**RKAPPA
55	zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
56	zq(i,k) = q(i,k)
57	ENDDO
58	ENDDO
59	c
60	DO k = limbas, limhau
61	DO i = 1, klon
62	zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
63	ENDDO
64	ENDDO
65	c
66	DO i = 1, klon
67	modif(i) = .FALSE.
68	ENDDO
69	DO k = limbas+1, limhau
70	DO i = 1, klon
71	IF (.NOT.modif(i)) THEN
72	IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
73	ENDIF
74	ENDDO
75	ENDDO
76	c------------------------------------- correction des profils instables
77	DO 1080 i = 1, klon
78	IF (modif(i)) THEN
79	k2 = limbas
80	8000 CONTINUE
81	k2 = k2 + 1
82	IF (k2 .GT. limhau) goto 8001
83	IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
84	k1 = k2 - 1
85	k = k1
86	sm = zpkdp(i,k2)
87	hm = zh(i,k2)
88	qm = zq(i,k2)
89	8020 CONTINUE
90	sm = sm +zpkdp(i,k)
91	hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
92	qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
93	down = .FALSE.
94	IF (k1 .ne. limbas) THEN
95	IF (hm .LT. zh(i,k1-1)) down = .TRUE.
96	ENDIF
97	IF (down) THEN
98	k1 = k1 - 1
99	k = k1
100	ELSE
101	IF ((k2 .EQ. limhau)) GOTO 8021
102	IF ((zh(i,k2+1).GE.hm)) GOTO 8021
103	k2 = k2 + 1
104	k = k2
105	ENDIF
106	GOTO 8020
107	8021 CONTINUE
108	c------------ nouveau profil : constant (valeur moyenne)
109	DO k = k1, k2
110	zh(i,k) = hm
111	zq(i,k) = qm
112	ENDDO
113	k2 = k2 + 1
114	ENDIF
115	GOTO 8000
116	8001 CONTINUE
117	ENDIF
118	1080 CONTINUE
119	c
120	DO k = limbas, limhau
121	DO i = 1, klon
122	d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
123	d_q(i,k) = zq(i,k) - q(i,k)
124	ENDDO
125	ENDDO
126	c
127	IF (limbas.GT.1) THEN
128	DO k = 1, limbas-1
129	DO i = 1, klon
130	d_t(i,k) = 0.0
131	d_q(i,k) = 0.0
132	ENDDO
133	ENDDO
134	ENDIF
135	c
136	IF (limhau.LT.klev) THEN
137	DO k = limhau+1, klev
138	DO i = 1, klon
139	d_t(i,k) = 0.0
140	d_q(i,k) = 0.0
141	ENDDO
142	ENDDO
143	ENDIF
144	c
145	IF (.NOT.mixq) THEN
146	DO k = 1, klev
147	DO i = 1, klon
148	d_q(i,k) = 0.0
149	ENDDO
150	ENDDO
151	ENDIF
152	c
153	RETURN
154	END
155	SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
156	USE dimphy
157	IMPLICIT none
158	c======================================================================
159	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
160	c Objet: ajustement sec (adaptation du GCM du LMD)
161	c======================================================================
162	c Arguments:
163	c t-------input-R- Temperature
164	c
165	c d_t-----output-R-Incrementation de la temperature
166	c======================================================================
167	cym#include "dimensions.h"
168	cym#include "dimphy.h"
169	#include "YOMCST.h"
170	REAL paprs(klon,klev+1), pplay(klon,klev)
171	REAL t(klon,klev)
172	REAL d_t(klon,klev)
173	c
174	REAL local_h(klon,klev)
175	REAL hm, sm
176	LOGICAL modif(klon), down
177	INTEGER i, l, l1, l2
178	c------------------------------------- detection des profils a modifier
179	DO i = 1, klon
180	modif(i) = .false.
181	ENDDO
182	c
183	DO l = 1, klev
184	DO i = 1, klon
185	local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA)
186	ENDDO
187	ENDDO
188	c
189	DO l = 2, klev
190	DO i = 1, klon
191	IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN
192	modif(i) = .true.
193	ELSE
194	modif(i) = modif(i)
195	ENDIF
196	ENDDO
197	ENDDO
198	c------------------------------------- correction des profils instables
199	do 1080 i = 1, klon
200	if (modif(i)) then
201	l2 = 1
202	8000 continue
203	l2 = l2 + 1
204	if (l2 .gt. klev) goto 8001
205	if (local_h(i, l2) .lt. local_h(i, l2-1)) then
206	l1 = l2 - 1
207	l = l1
208	sm = pplay(i,l2)*rkappa (paprs(i,l2)-paprs(i,l2+1))
209	hm = local_h(i, l2)
210	8020 continue
211	sm = sm +pplay(i,l)*rkappa(paprs(i,l)-paprs(i,l+1))
212	hm = hm +pplay(i,l)*rkappa(paprs(i,l)-paprs(i,l+1))
213	. * (local_h(i, l) - hm) / sm
214	down = .false.
215	if (l1 .ne. 1) then
216	if (hm .lt. local_h(i, l1-1)) then
217	down = .true.
218	end if
219	end if
220	if (down) then
221	l1 = l1 - 1
222	l = l1
223	else
224	if ((l2 .eq. klev)) GOTO 8021
225	IF ((local_h(i, l2+1).ge.hm)) goto 8021
226	l2 = l2 + 1
227	l = l2
228	end if
229	go to 8020
230	8021 continue
231	c------------ nouveau profil : constant (valeur moyenne)
232	do 1100 l = l1, l2
233	local_h(i, l) = hm
234	1100 continue
235	l2 = l2 + 1
236	end if
237	go to 8000
238	8001 continue
239	end if
240	1080 continue
241	c
242	DO l = 1, klev
243	DO i = 1, klon
244	d_t(i,l) = local_h(i,l)(pplay(i,l)*rkappa)/RCPD - t(i,l)
245	ENDDO
246	ENDDO
247	c
248	RETURN
249	END

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

Download in other formats:

Original Format