Context Navigation

integrd_p.F @ 1

Last change on this file since 1 was 1, checked in by emillour, 14 years ago
Import initial LMDZ5
File size: 8.5 KB

Line
1	!
2	! $Id: integrd_p.F 1403 2010-07-01 09:02:53Z fairhead $
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
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	endif ! of if (planet_type.eq."earth")
282	c
283	c ..... Calcul de la valeur moyenne, unique aux poles pour q .....
284	c
285	c$OMP BARRIER
286	IF (pole_nord) THEN
287
288	DO iq = 1, nq
289
290	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
291	DO l = 1, llm
292
293	DO ij = 1, iim
294	qppn(ij) = aire( ij ) * q( ij ,l,iq)
295	ENDDO
296	qpn = SSUM(iim,qppn,1)/apoln
297
298	DO ij = 1, iip1
299	q( ij ,l,iq) = qpn
300	ENDDO
301
302	ENDDO
303	c$OMP END DO NOWAIT
304
305	ENDDO
306
307	ENDIF
308
309	IF (pole_sud) THEN
310
311	DO iq = 1, nq
312
313	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
314	DO l = 1, llm
315
316	DO ij = 1, iim
317	qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
318	ENDDO
319	qps = SSUM(iim,qpps,1)/apols
320
321	DO ij = 1, iip1
322	q(ij+ip1jm,l,iq) = qps
323	ENDDO
324
325	ENDDO
326	c$OMP END DO NOWAIT
327
328	ENDDO
329
330	ENDIF
331
332	c CALL SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
333
334	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
335	DO l = 1, llm
336	finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)
337	ENDDO
338	c$OMP END DO NOWAIT
339	c
340	c
341	c ..... FIN de l'integration de q .......
342
343	15 continue
344
345	c$OMP DO SCHEDULE(STATIC)
346	DO ij=ijb,ije
347	ps0(ij)=ps(ij)
348	ENDDO
349	c$OMP END DO NOWAIT
350
351	c .................................................................
352
353
354	IF( leapf ) THEN
355	c CALL SCOPY ( ip1jmp1 , pscr , 1, psm1 , 1 )
356	c CALL SCOPY ( ip1jmp1*llm, massescr, 1, massem1, 1 )
357	c$OMP DO SCHEDULE(STATIC)
358	DO ij=ijb,ije
359	psm1(ij)=pscr(ij)
360	ENDDO
361	c$OMP END DO NOWAIT
362
363	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
364	DO l = 1, llm
365	massem1(ijb:ije,l)=massescr(ijb:ije,l)
366	ENDDO
367	c$OMP END DO NOWAIT
368	END IF
369	c$OMP BARRIER
370	RETURN
371	END

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

Download in other formats:

Original Format