Context Navigation

integrd_p.F @ 4249

Last change on this file since 4249 was 1454, checked in by Laurent Fairhead, 14 years ago

Merge of LMDZ5V1.0-dev branch r1453 into LMDZ5 trunk r1434

Fusion entre la version r1453 de la branche de développement LMDZ5V1.0-dev
et le tronc LMDZ5 (r1434)

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 8.5 KB

Line
1	!
2	! $Id: integrd_p.F 1454 2010-11-18 12:01:24Z aclsce $
3	!
4	SUBROUTINE integrd_p
5	$ ( nq,vcovm1,ucovm1,tetam1,psm1,massem1,
6	$ dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis,finvmaold)
7	USE parallel
8	USE control_mod, only : planet_type
9	IMPLICIT NONE
10
11
12	c=======================================================================
13	c
14	c Auteur: P. Le Van
15	c -------
16	c
17	c objet:
18	c ------
19	c
20	c Incrementation des tendances dynamiques
21	c
22	c=======================================================================
23	c-----------------------------------------------------------------------
24	c Declarations:
25	c -------------
26
27	#include "dimensions.h"
28	#include "paramet.h"
29	#include "comconst.h"
30	#include "comgeom.h"
31	#include "comvert.h"
32	#include "logic.h"
33	#include "temps.h"
34	#include "serre.h"
35
36	c Arguments:
37	c ----------
38
39	INTEGER nq
40
41	REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
42	REAL q(ip1jmp1,llm,nq)
43	REAL ps0(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1)
44
45	REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
46	REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm)
47
48	REAL dv(ip1jm,llm),du(ip1jmp1,llm)
49	REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
50	REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm)
51
52	c Local:
53	c ------
54
55	REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
56	REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm)
57	REAL,SAVE :: p(ip1jmp1,llmp1)
58	REAL tpn,tps,tppn(iim),tpps(iim)
59	REAL qpn,qps,qppn(iim),qpps(iim)
60	REAL,SAVE :: deltap( ip1jmp1,llm )
61
62	INTEGER l,ij,iq
63
64	REAL SSUM
65	EXTERNAL SSUM
66	INTEGER ijb,ije,jjb,jje
67	REAL,SAVE :: ps(ip1jmp1)
68	LOGICAL :: checksum
69	INTEGER :: stop_it
70	c-----------------------------------------------------------------------
71	c$OMP BARRIER
72	if (pole_nord) THEN
73	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
74	DO l = 1,llm
75	DO ij = 1,iip1
76	ucov( ij , l) = 0.
77	uscr( ij ) = 0.
78	ENDDO
79	ENDDO
80	c$OMP END DO NOWAIT
81	ENDIF
82
83	if (pole_sud) THEN
84	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
85	DO l = 1,llm
86	DO ij = 1,iip1
87	ucov( ij +ip1jm, l) = 0.
88	uscr( ij +ip1jm ) = 0.
89	ENDDO
90	ENDDO
91	c$OMP END DO NOWAIT
92	ENDIF
93
94	c ............ integration de ps ..............
95
96	c CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
97
98	ijb=ij_begin
99	ije=ij_end
100	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
101	DO l = 1,llm
102	massescr(ijb:ije,l)=masse(ijb:ije,l)
103	ENDDO
104	c$OMP END DO NOWAIT
105
106	c$OMP DO SCHEDULE(STATIC)
107	DO 2 ij = ijb,ije
108	pscr (ij) = ps0(ij)
109	ps (ij) = psm1(ij) + dt * dp(ij)
110	2 CONTINUE
111	c$OMP END DO
112	c$OMP BARRIER
113	c --> ici synchro OPENMP pour ps
114
115	checksum=.TRUE.
116	stop_it=0
117
118	c$OMP DO SCHEDULE(STATIC)
119	DO ij = ijb,ije
120	IF( ps(ij).LT.0. ) THEN
121	IF (checksum) stop_it=ij
122	checksum=.FALSE.
123	ENDIF
124	ENDDO
125	c$OMP END DO NOWAIT
126
127	IF( .NOT. checksum ) THEN
128	PRINT*,' Au point ij = ',stop_it, ' , pression sol neg. '
129	& , ps(stop_it)
130	STOP' dans integrd'
131	ENDIF
132
133	c
134	C$OMP MASTER
135	if (pole_nord) THEN
136
137	DO ij = 1, iim
138	tppn(ij) = aire( ij ) * ps( ij )
139	ENDDO
140	tpn = SSUM(iim,tppn,1)/apoln
141	DO ij = 1, iip1
142	ps( ij ) = tpn
143	ENDDO
144
145	ENDIF
146
147	if (pole_sud) THEN
148
149	DO ij = 1, iim
150	tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
151	ENDDO
152	tps = SSUM(iim,tpps,1)/apols
153	DO ij = 1, iip1
154	ps(ij+ip1jm) = tps
155	ENDDO
156
157	ENDIF
158	c$OMP END MASTER
159	c$OMP BARRIER
160	c
161	c ... Calcul de la nouvelle masse d'air au dernier temps integre t+1 ...
162	c
163
164	CALL pression_p ( ip1jmp1, ap, bp, ps, p )
165	c$OMP BARRIER
166	CALL massdair_p ( p , masse )
167
168	c CALL SCOPY( ijp1llm , masse, 1, finvmasse, 1 )
169	ijb=ij_begin
170	ije=ij_end
171
172	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
173	DO l = 1,llm
174	finvmasse(ijb:ije,l)=masse(ijb:ije,l)
175	ENDDO
176	c$OMP END DO NOWAIT
177
178	jjb=jj_begin
179	jje=jj_end
180	CALL filtreg_p( finvmasse,jjb,jje, jjp1, llm, -2, 2, .TRUE., 1 )
181	c
182
183	c ............ integration de ucov, vcov, h ..............
184
185	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
186	DO 10 l = 1,llm
187
188	ijb=ij_begin
189	ije=ij_end
190	if (pole_nord) ijb=ij_begin+iip1
191	if (pole_sud) ije=ij_end-iip1
192
193	DO 4 ij = ijb,ije
194	uscr( ij ) = ucov( ij,l )
195	ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
196	4 CONTINUE
197
198	ijb=ij_begin
199	ije=ij_end
200	if (pole_sud) ije=ij_end-iip1
201
202	DO 5 ij = ijb,ije
203	vscr( ij ) = vcov( ij,l )
204	vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
205	5 CONTINUE
206
207	ijb=ij_begin
208	ije=ij_end
209
210	DO 6 ij = ijb,ije
211	hscr( ij ) = teta(ij,l)
212	teta ( ij,l ) = tetam1(ij,l) * massem1(ij,l) / masse(ij,l)
213	$ + dt * dteta(ij,l) / masse(ij,l)
214	6 CONTINUE
215
216	c .... Calcul de la valeur moyenne, unique aux poles pour teta ......
217	c
218	c
219	IF (pole_nord) THEN
220
221	DO ij = 1, iim
222	tppn(ij) = aire( ij ) * teta( ij ,l)
223	ENDDO
224	tpn = SSUM(iim,tppn,1)/apoln
225
226	DO ij = 1, iip1
227	teta( ij ,l) = tpn
228	ENDDO
229
230	ENDIF
231
232	IF (pole_sud) THEN
233
234	DO ij = 1, iim
235	tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
236	ENDDO
237	tps = SSUM(iim,tpps,1)/apols
238
239	DO ij = 1, iip1
240	teta(ij+ip1jm,l) = tps
241	ENDDO
242
243	ENDIF
244	c
245
246	IF(leapf) THEN
247	c CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
248	c CALL SCOPY ( ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
249	c CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
250	ijb=ij_begin
251	ije=ij_end
252	ucovm1(ijb:ije,l)=uscr(ijb:ije)
253	tetam1(ijb:ije,l)=hscr(ijb:ije)
254	if (pole_sud) ije=ij_end-iip1
255	vcovm1(ijb:ije,l)=vscr(ijb:ije)
256
257	END IF
258
259	10 CONTINUE
260	c$OMP END DO NOWAIT
261
262	c
263	c ....... integration de q ......
264	c
265	ijb=ij_begin
266	ije=ij_end
267
268	if (planet_type.eq."earth") then
269	! Earth-specific treatment of first 2 tracers (water)
270	c$OMP BARRIER
271	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
272	DO l = 1, llm
273	DO ij = ijb, ije
274	deltap(ij,l) = p(ij,l) - p(ij,l+1)
275	ENDDO
276	ENDDO
277	c$OMP END DO NOWAIT
278	c$OMP BARRIER
279
280	CALL qminimum_p( q, nq, deltap )
281	c
282	c ..... Calcul de la valeur moyenne, unique aux poles pour q .....
283	c
284	c$OMP BARRIER
285	IF (pole_nord) THEN
286
287	DO iq = 1, nq
288
289	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
290	DO l = 1, llm
291
292	DO ij = 1, iim
293	qppn(ij) = aire( ij ) * q( ij ,l,iq)
294	ENDDO
295	qpn = SSUM(iim,qppn,1)/apoln
296
297	DO ij = 1, iip1
298	q( ij ,l,iq) = qpn
299	ENDDO
300
301	ENDDO
302	c$OMP END DO NOWAIT
303
304	ENDDO
305
306	ENDIF
307
308	IF (pole_sud) THEN
309
310	DO iq = 1, nq
311
312	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
313	DO l = 1, llm
314
315	DO ij = 1, iim
316	qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
317	ENDDO
318	qps = SSUM(iim,qpps,1)/apols
319
320	DO ij = 1, iip1
321	q(ij+ip1jm,l,iq) = qps
322	ENDDO
323
324	ENDDO
325	c$OMP END DO NOWAIT
326
327	ENDDO
328
329	ENDIF
330
331	c CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
332
333	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
334	DO l = 1, llm
335	finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)
336	ENDDO
337	c$OMP END DO NOWAIT
338
339	endif ! of if (planet_type.eq."earth")
340
341	c
342	c
343	c ..... FIN de l'integration de q .......
344
345	15 continue
346
347	c$OMP DO SCHEDULE(STATIC)
348	DO ij=ijb,ije
349	ps0(ij)=ps(ij)
350	ENDDO
351	c$OMP END DO NOWAIT
352
353	c .................................................................
354
355
356	IF( leapf ) THEN
357	c CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 )
358	c CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 )
359	c$OMP DO SCHEDULE(STATIC)
360	DO ij=ijb,ije
361	psm1(ij)=pscr(ij)
362	ENDDO
363	c$OMP END DO NOWAIT
364
365	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
366	DO l = 1, llm
367	massem1(ijb:ije,l)=massescr(ijb:ije,l)
368	ENDDO
369	c$OMP END DO NOWAIT
370	END IF
371	c$OMP BARRIER
372	RETURN
373	END

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

Download in other formats:

Original Format