Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

ajsec.F @ 521

Last change on this file since 521 was 79, checked in by (none), 25 years ago
This commit was manufactured by cvs2svn to create branch 'rel-LF'.
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 6.5 KB

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

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

Download in other formats:

Original Format