Context Navigation

integrd_p.F @ 1119

Last change on this file since 1119 was 985, checked in by Laurent Fairhead, 16 years ago
Mise a jour de dyn3dpar par rapport a dyn3d, inclusion OpenMP et filtre FFT YM LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 8.3 KB

Line
1	!
2	! $Header$
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	IMPLICIT NONE
9
10
11	c=======================================================================
12	c
13	c Auteur: P. Le Van
14	c -------
15	c
16	c objet:
17	c ------
18	c
19	c Incrementation des tendances dynamiques
20	c
21	c=======================================================================
22	c-----------------------------------------------------------------------
23	c Declarations:
24	c -------------
25
26	#include "dimensions.h"
27	#include "paramet.h"
28	#include "comconst.h"
29	#include "comgeom.h"
30	#include "comvert.h"
31	#include "logic.h"
32	#include "temps.h"
33	#include "serre.h"
34	#include "advtrac.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	c$OMP BARRIER
269	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
270	DO l = 1, llm
271	DO ij = ijb, ije
272	deltap(ij,l) = p(ij,l) - p(ij,l+1)
273	ENDDO
274	ENDDO
275	c$OMP END DO NOWAIT
276	c$OMP BARRIER
277
278	CALL qminimum_p( q, nq, deltap )
279	c
280	c ..... Calcul de la valeur moyenne, unique aux poles pour q .....
281	c
282	c$OMP BARRIER
283	IF (pole_nord) THEN
284
285	DO iq = 1, nq
286
287	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
288	DO l = 1, llm
289
290	DO ij = 1, iim
291	qppn(ij) = aire( ij ) * q( ij ,l,iq)
292	ENDDO
293	qpn = SSUM(iim,qppn,1)/apoln
294
295	DO ij = 1, iip1
296	q( ij ,l,iq) = qpn
297	ENDDO
298
299	ENDDO
300	c$OMP END DO NOWAIT
301
302	ENDDO
303
304	ENDIF
305
306	IF (pole_sud) THEN
307
308	DO iq = 1, nq
309
310	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
311	DO l = 1, llm
312
313	DO ij = 1, iim
314	qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
315	ENDDO
316	qps = SSUM(iim,qpps,1)/apols
317
318	DO ij = 1, iip1
319	q(ij+ip1jm,l,iq) = qps
320	ENDDO
321
322	ENDDO
323	c$OMP END DO NOWAIT
324
325	ENDDO
326
327	ENDIF
328
329	c CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
330
331	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
332	DO l = 1, llm
333	finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)
334	ENDDO
335	c$OMP END DO NOWAIT
336	c
337	c
338	c ..... FIN de l'integration de q .......
339
340	15 continue
341
342	c$OMP DO SCHEDULE(STATIC)
343	DO ij=ijb,ije
344	ps0(ij)=ps(ij)
345	ENDDO
346	c$OMP END DO NOWAIT
347
348	c .................................................................
349
350
351	IF( leapf ) THEN
352	c CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 )
353	c CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 )
354	c$OMP DO SCHEDULE(STATIC)
355	DO ij=ijb,ije
356	psm1(ij)=pscr(ij)
357	ENDDO
358	c$OMP END DO NOWAIT
359
360	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
361	DO l = 1, llm
362	massem1(ijb:ije,l)=massescr(ijb:ije,l)
363	ENDDO
364	c$OMP END DO NOWAIT
365	END IF
366	c$OMP BARRIER
367	RETURN
368	END

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

Download in other formats:

Original Format