Context Navigation

ajsec.F @ 943

Last change on this file since 943 was 766, checked in by Laurent Fairhead, 17 years ago
Merge entre la version V3_conv et le HEAD YM, JG, 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