Context Navigation

ajsec.F @ 24

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

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

Download in other formats:

Original Format