Context Navigation

ajsec.F @ 91

Last change on this file since 91 was 3, checked in by slebonnois, 15 years ago

Creation de repertoires:

chantiers : pour communiquer sur nos projets de modifs
documentation : pour stocker les docs

Ajout de:

libf/phytitan : physique de Titan
libf/chimtitan: chimie de Titan
libf/phyvenus : physique de Venus

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

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

Download in other formats:

Original Format