Context Navigation

ajsec.F @ 102

Last change on this file since 102 was 102, checked in by slebonnois, 14 years ago
SL : corrections et modifications dans phytitan correspondant a celles faites apres compilation Venus. Titan pas encore compile.
File size: 6.0 KB

Line
1	!
2	! $Header: /home/cvsroot/LMDZ4/libf/phylmd/ajsec.F,v 1.1.1.1 2004/05/19 12:53:08 lmdzadmin Exp $
3	!
4	! ADAPTATION GCM POUR CP(T)
5	SUBROUTINE ajsec(paprs, pplay, ppk, tfi, ufi, vfi, nq, qfi,
6	. d_tfi, d_ufi, d_vfi, d_qfi)
7
8	use dimphy
9	IMPLICIT none
10	c======================================================================
11	c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
12	c Objet: ajustement sec (adaptation du GCM du LMD)
13	c S. Lebonnois, 10/2007:
14	c melange u et v comme dans convadj (MARS)
15	c======================================================================
16	c Arguments:
17	c tfi-------input-R- Temperature
18	c ufi-------input-R- vent zonal
19	c vfi-------input-R- vent meridien
20	c nq--------input-R- nombre de traceurs
21	c qfi-------input-R- traceurs
22	c
23	c d_tfi-----output-R-Incrementation de la temperature
24	c d_ufi-----output-R-Incrementation du vent zonal
25	c d_vfi-----output-R-Incrementation du vent meridien
26	c d_qfi-----output-R-Incrementation des traceurs
27	c======================================================================
28	#include "dimensions.h"
29	#include "YOMCST.h"
30	REAL paprs(klon,klev+1), pplay(klon,klev)
31	REAL ppk(klon,klev)
32	INTEGER nq
33	REAL tfi(klon,klev), d_tfi(klon,klev)
34	REAL ufi(klon,klev), d_ufi(klon,klev)
35	REAL vfi(klon,klev), d_vfi(klon,klev)
36	REAL qfi(klon,klev,nq), d_qfi(klon,klev,nq)
37	c
38	INTEGER,save :: limbas, limhau ! les couches a ajuster
39	c
40	REAL zh(klon,klev)
41	REAL zu(klon,klev),zv(klon,klev)
42	REAL zt(klon,klev),zq(klon,klev,nq)
43	REAL zdp(klon,klev)
44	REAL zpkdp(klon,klev)
45	REAL hm,sm,zum,zvm,zalpha,zqm(nq)
46	LOGICAL modif(klon), down
47	INTEGER i, k, k1, k2, iq
48	c
49	c Initialisation:
50	c
51	limbas=1
52	limhau=klev
53
54	DO k = 1, klev
55	DO i = 1, klon
56	d_tfi(i,k) = 0.0
57	d_ufi(i,k) = 0.0
58	d_vfi(i,k) = 0.0
59	d_qfi(i,k,:) = 0.0
60	zu(i,k) = ufi(i,k)
61	zv(i,k) = vfi(i,k)
62	zq(i,k,:) = qfi(i,k,:)
63	ENDDO
64	ENDDO
65	c------------------------------------- passage en temperature potentielle
66	! ADAPTATION GCM POUR CP(T)
67	call t2tpot(klon*llm,tfi,zh,ppk)
68	c
69	DO k = limbas, limhau
70	DO i = 1, klon
71	zdp(i,k) = paprs(i,k)-paprs(i,k+1)
72	zpkdp(i,k) = ppk(i,k) * zdp(i,k)
73	ENDDO
74	ENDDO
75	c
76	c------------------------------------- detection des profils a modifier
77	DO i = 1, klon
78	modif(i) = .FALSE.
79	ENDDO
80	DO k = limbas+1, limhau
81	DO i = 1, klon
82	IF (.NOT.modif(i)) THEN
83	IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
84	ENDIF
85	ENDDO
86	ENDDO
87	c------------------------------------- correction des profils instables
88	DO 1080 i = 1, klon
89	IF (modif(i)) THEN
90	k2 = limbas
91	8000 CONTINUE
92	k2 = k2 + 1
93	IF (k2 .GT. limhau) goto 8001
94	IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
95	k1 = k2 - 1
96	k = k1
97	sm = zpkdp(i,k2)
98	hm = zh(i,k2)
99	8020 CONTINUE
100	sm = sm +zpkdp(i,k)
101	hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
102	down = .FALSE.
103	IF (k1 .ne. limbas) THEN
104	IF (hm .LT. zh(i,k1-1)) down = .TRUE.
105	ENDIF
106	IF (down) THEN
107	k1 = k1 - 1
108	k = k1
109	ELSE
110	IF ((k2 .EQ. limhau)) GOTO 8021
111	IF ((zh(i,k2+1).GE.hm)) GOTO 8021
112	k2 = k2 + 1
113	k = k2
114	ENDIF
115	GOTO 8020
116	8021 CONTINUE
117	c------------ nouveau profil : constant (valeur moyenne)
118	c------------ et melange partiel des vents
119	zalpha=0.
120	zum=0.
121	zvm=0.
122	zqm=0.
123	DO k = k1, k2
124	zalpha=zalpha+ABS(zh(i,k)-hm)*zdp(i,k)
125	zh(i,k) = hm
126	zum=zum+ufi(i,k)*zdp(i,k)
127	zvm=zvm+vfi(i,k)*zdp(i,k)
128	do iq=1,nq
129	zqm(iq)=zqm(iq)+qfi(i,k,iq)*zdp(i,k)
130	enddo
131	ENDDO
132	zalpha=zalpha/(hm*(paprs(i,k1)-paprs(i,k2+1)))
133	zum=zum/(paprs(i,k1)-paprs(i,k2+1))
134	zvm=zvm/(paprs(i,k1)-paprs(i,k2+1))
135	do iq=1,nq
136	zqm(iq)=zqm(iq)/(paprs(i,k1)-paprs(i,k2+1))
137	enddo
138
139	IF(zalpha.GT.1.) THEN
140	PRINT*,'WARNING dans ajsec zalpha=',zalpha
141	c STOP
142	zalpha=1.
143	ELSE
144	c IF(zalpha.LT.0.) STOP
145	IF(zalpha.LT.1.e-5) zalpha=1.e-4
146	ENDIF
147	c ----------------------------
148	c TEST --- PAS DE MELANGE DE U
149	c zalpha=0.
150	c ----------------------------
151
152	DO k=k1,k2
153	zu(i,k)=ufi(i,k)+zalpha*(zum-ufi(i,k))
154	zv(i,k)=vfi(i,k)+zalpha*(zvm-vfi(i,k))
155	do iq=1,nq
156	zq(i,k,iq)=qfi(i,k,iq)+zalpha*(zqm(iq)-qfi(i,k,iq))
157	enddo
158	ENDDO
159	k2 = k2 + 1
160	ENDIF
161	GOTO 8000
162	8001 CONTINUE
163	ENDIF
164	1080 CONTINUE
165	c
166	c------------------------------------- passage en temperature
167	c------------------------------------- et calcul du d_t
168	! ADAPTATION GCM POUR CP(T)
169	call tpot2t(klon*llm,zh,zt,ppk)
170
171	DO k = limbas, limhau
172	DO i = 1, klon
173	d_tfi(i,k) = zt(i,k) - tfi(i,k)
174	d_ufi(i,k) = zu(i,k) - ufi(i,k)
175	d_vfi(i,k) = zv(i,k) - vfi(i,k)
176	do iq=1,nq
177	d_qfi(i,k,iq) = zq(i,k,iq) - qfi(i,k,iq)
178	enddo
179	ENDDO
180	ENDDO
181	c
182	IF (limbas.GT.1) THEN
183	DO k = 1, limbas-1
184	DO i = 1, klon
185	d_tfi(i,k) = 0.0
186	d_ufi(i,k) = 0.0
187	d_vfi(i,k) = 0.0
188	do iq=1,nq
189	d_qfi(i,k,iq) = 0.0
190	enddo
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_tfi(i,k) = 0.0
199	d_ufi(i,k) = 0.0
200	d_vfi(i,k) = 0.0
201	do iq=1,nq
202	d_qfi(i,k,iq) = 0.0
203	enddo
204	ENDDO
205	ENDDO
206	ENDIF
207	c
208	RETURN
209	END
210

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

Download in other formats:

Original Format