Context Navigation

ajsec.F @ 674

Last change on this file since 674 was 524, checked in by lmdzadmin, 21 years ago
Initial revision
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 6.5 KB

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

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

Download in other formats:

Original Format