Context Navigation

integrd_p.F @ 1275

Last change on this file since 1275 was 1146, checked in by Laurent Fairhead, 16 years ago
Réintegration dans le tronc des modifications issues de la branche LMDZ-dev comprises entre la révision 1074 et 1145 Validation: une simulation de 1 jour en séquentiel sur PC donne les mêmes résultats entre la trunk et la dev 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
35	c Arguments:
36	c ----------
37
38	INTEGER nq
39
40	REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
41	REAL q(ip1jmp1,llm,nq)
42	REAL ps0(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1)
43
44	REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
45	REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm)
46
47	REAL dv(ip1jm,llm),du(ip1jmp1,llm)
48	REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
49	REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm)
50
51	c Local:
52	c ------
53
54	REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
55	REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm)
56	REAL,SAVE :: p(ip1jmp1,llmp1)
57	REAL tpn,tps,tppn(iim),tpps(iim)
58	REAL qpn,qps,qppn(iim),qpps(iim)
59	REAL,SAVE :: deltap( ip1jmp1,llm )
60
61	INTEGER l,ij,iq
62
63	REAL SSUM
64	EXTERNAL SSUM
65	INTEGER ijb,ije,jjb,jje
66	REAL,SAVE :: ps(ip1jmp1)
67	LOGICAL :: checksum
68	INTEGER :: stop_it
69	c-----------------------------------------------------------------------
70	c$OMP BARRIER
71	if (pole_nord) THEN
72	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
73	DO l = 1,llm
74	DO ij = 1,iip1
75	ucov( ij , l) = 0.
76	uscr( ij ) = 0.
77	ENDDO
78	ENDDO
79	c$OMP END DO NOWAIT
80	ENDIF
81
82	if (pole_sud) THEN
83	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
84	DO l = 1,llm
85	DO ij = 1,iip1
86	ucov( ij +ip1jm, l) = 0.
87	uscr( ij +ip1jm ) = 0.
88	ENDDO
89	ENDDO
90	c$OMP END DO NOWAIT
91	ENDIF
92
93	c ............ integration de ps ..............
94
95	c CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
96
97	ijb=ij_begin
98	ije=ij_end
99	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
100	DO l = 1,llm
101	massescr(ijb:ije,l)=masse(ijb:ije,l)
102	ENDDO
103	c$OMP END DO NOWAIT
104
105	c$OMP DO SCHEDULE(STATIC)
106	DO 2 ij = ijb,ije
107	pscr (ij) = ps0(ij)
108	ps (ij) = psm1(ij) + dt * dp(ij)
109	2 CONTINUE
110	c$OMP END DO
111	c$OMP BARRIER
112	c --> ici synchro OPENMP pour ps
113
114	checksum=.TRUE.
115	stop_it=0
116
117	c$OMP DO SCHEDULE(STATIC)
118	DO ij = ijb,ije
119	IF( ps(ij).LT.0. ) THEN
120	IF (checksum) stop_it=ij
121	checksum=.FALSE.
122	ENDIF
123	ENDDO
124	c$OMP END DO NOWAIT
125
126	IF( .NOT. checksum ) THEN
127	PRINT*,' Au point ij = ',stop_it, ' , pression sol neg. '
128	& , ps(stop_it)
129	STOP' dans integrd'
130	ENDIF
131
132	c
133	C$OMP MASTER
134	if (pole_nord) THEN
135
136	DO ij = 1, iim
137	tppn(ij) = aire( ij ) * ps( ij )
138	ENDDO
139	tpn = SSUM(iim,tppn,1)/apoln
140	DO ij = 1, iip1
141	ps( ij ) = tpn
142	ENDDO
143
144	ENDIF
145
146	if (pole_sud) THEN
147
148	DO ij = 1, iim
149	tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
150	ENDDO
151	tps = SSUM(iim,tpps,1)/apols
152	DO ij = 1, iip1
153	ps(ij+ip1jm) = tps
154	ENDDO
155
156	ENDIF
157	c$OMP END MASTER
158	c$OMP BARRIER
159	c
160	c ... Calcul de la nouvelle masse d'air au dernier temps integre t+1 ...
161	c
162
163	CALL pression_p ( ip1jmp1, ap, bp, ps, p )
164	c$OMP BARRIER
165	CALL massdair_p ( p , masse )
166
167	c CALL SCOPY( ijp1llm , masse, 1, finvmasse, 1 )
168	ijb=ij_begin
169	ije=ij_end
170
171	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
172	DO l = 1,llm
173	finvmasse(ijb:ije,l)=masse(ijb:ije,l)
174	ENDDO
175	c$OMP END DO NOWAIT
176
177	jjb=jj_begin
178	jje=jj_end
179	CALL filtreg_p( finvmasse,jjb,jje, jjp1, llm, -2, 2, .TRUE., 1 )
180	c
181
182	c ............ integration de ucov, vcov, h ..............
183
184	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
185	DO 10 l = 1,llm
186
187	ijb=ij_begin
188	ije=ij_end
189	if (pole_nord) ijb=ij_begin+iip1
190	if (pole_sud) ije=ij_end-iip1
191
192	DO 4 ij = ijb,ije
193	uscr( ij ) = ucov( ij,l )
194	ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
195	4 CONTINUE
196
197	ijb=ij_begin
198	ije=ij_end
199	if (pole_sud) ije=ij_end-iip1
200
201	DO 5 ij = ijb,ije
202	vscr( ij ) = vcov( ij,l )
203	vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
204	5 CONTINUE
205
206	ijb=ij_begin
207	ije=ij_end
208
209	DO 6 ij = ijb,ije
210	hscr( ij ) = teta(ij,l)
211	teta ( ij,l ) = tetam1(ij,l) * massem1(ij,l) / masse(ij,l)
212	$ + dt * dteta(ij,l) / masse(ij,l)
213	6 CONTINUE
214
215	c .... Calcul de la valeur moyenne, unique aux poles pour teta ......
216	c
217	c
218	IF (pole_nord) THEN
219
220	DO ij = 1, iim
221	tppn(ij) = aire( ij ) * teta( ij ,l)
222	ENDDO
223	tpn = SSUM(iim,tppn,1)/apoln
224
225	DO ij = 1, iip1
226	teta( ij ,l) = tpn
227	ENDDO
228
229	ENDIF
230
231	IF (pole_sud) THEN
232
233	DO ij = 1, iim
234	tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
235	ENDDO
236	tps = SSUM(iim,tpps,1)/apols
237
238	DO ij = 1, iip1
239	teta(ij+ip1jm,l) = tps
240	ENDDO
241
242	ENDIF
243	c
244
245	IF(leapf) THEN
246	c CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
247	c CALL SCOPY ( ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
248	c CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
249	ijb=ij_begin
250	ije=ij_end
251	ucovm1(ijb:ije,l)=uscr(ijb:ije)
252	tetam1(ijb:ije,l)=hscr(ijb:ije)
253	if (pole_sud) ije=ij_end-iip1
254	vcovm1(ijb:ije,l)=vscr(ijb:ije)
255
256	END IF
257
258	10 CONTINUE
259	c$OMP END DO NOWAIT
260
261	c
262	c ....... integration de q ......
263	c
264	ijb=ij_begin
265	ije=ij_end
266
267	c$OMP BARRIER
268	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
269	DO l = 1, llm
270	DO ij = ijb, ije
271	deltap(ij,l) = p(ij,l) - p(ij,l+1)
272	ENDDO
273	ENDDO
274	c$OMP END DO NOWAIT
275	c$OMP BARRIER
276
277	CALL qminimum_p( q, nq, deltap )
278	c
279	c ..... Calcul de la valeur moyenne, unique aux poles pour q .....
280	c
281	c$OMP BARRIER
282	IF (pole_nord) THEN
283
284	DO iq = 1, nq
285
286	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
287	DO l = 1, llm
288
289	DO ij = 1, iim
290	qppn(ij) = aire( ij ) * q( ij ,l,iq)
291	ENDDO
292	qpn = SSUM(iim,qppn,1)/apoln
293
294	DO ij = 1, iip1
295	q( ij ,l,iq) = qpn
296	ENDDO
297
298	ENDDO
299	c$OMP END DO NOWAIT
300
301	ENDDO
302
303	ENDIF
304
305	IF (pole_sud) THEN
306
307	DO iq = 1, nq
308
309	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
310	DO l = 1, llm
311
312	DO ij = 1, iim
313	qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
314	ENDDO
315	qps = SSUM(iim,qpps,1)/apols
316
317	DO ij = 1, iip1
318	q(ij+ip1jm,l,iq) = qps
319	ENDDO
320
321	ENDDO
322	c$OMP END DO NOWAIT
323
324	ENDDO
325
326	ENDIF
327
328	c CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
329
330	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
331	DO l = 1, llm
332	finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)
333	ENDDO
334	c$OMP END DO NOWAIT
335	c
336	c
337	c ..... FIN de l'integration de q .......
338
339	15 continue
340
341	c$OMP DO SCHEDULE(STATIC)
342	DO ij=ijb,ije
343	ps0(ij)=ps(ij)
344	ENDDO
345	c$OMP END DO NOWAIT
346
347	c .................................................................
348
349
350	IF( leapf ) THEN
351	c CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 )
352	c CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 )
353	c$OMP DO SCHEDULE(STATIC)
354	DO ij=ijb,ije
355	psm1(ij)=pscr(ij)
356	ENDDO
357	c$OMP END DO NOWAIT
358
359	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
360	DO l = 1, llm
361	massem1(ijb:ije,l)=massescr(ijb:ije,l)
362	ENDDO
363	c$OMP END DO NOWAIT
364	END IF
365	c$OMP BARRIER
366	RETURN
367	END

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

Download in other formats:

Original Format