Context Navigation

vlspltgen_loc.F @ 2597

Last change on this file since 2597 was 2597, checked in by Ehouarn Millour, 8 years ago
Cleanup in the dynamics: get rid of comconst.h, make it a module comconst_mod. EM
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory
File size: 15.2 KB

Line
1	!
2	! $Header$
3	!
4	SUBROUTINE vlspltgen_loc( q,iadv,pente_max,masse,w,pbaru,pbarv,
5	& pdt, p,pk,teta )
6
7	c
8	c Auteurs: P.Le Van, F.Hourdin, F.Forget, F.Codron
9	c
10	c ********************************************************************
11	c Shema d'advection " pseudo amont " .
12	c + test sur humidite specifique: Q advecte< Qsat aval
13	c (F. Codron, 10/99)
14	c ********************************************************************
15	c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg ....
16	c
17	c pente_max facteur de limitation des pentes: 2 en general
18	c 0 pour un schema amont
19	c pbaru,pbarv,w flux de masse en u ,v ,w
20	c pdt pas de temps
21	c
22	c teta temperature potentielle, p pression aux interfaces,
23	c pk exner au milieu des couches necessaire pour calculer Qsat
24	c --------------------------------------------------------------------
25	USE parallel_lmdz
26	USE mod_hallo
27	USE Write_Field_loc
28	USE VAMPIR
29	! CRisi: on rajoute variables utiles d'infotrac
30	USE infotrac, ONLY : nqtot,nqperes,nqdesc,nqfils,iqfils,
31	& ok_iso_verif
32	USE vlspltgen_mod
33	USE comconst_mod, ONLY: cpp
34	IMPLICIT NONE
35
36	c
37	include "dimensions.h"
38	include "paramet.h"
39	include "logic.h"
40	include "comvert.h"
41
42	c
43	c Arguments:
44	c ----------
45	INTEGER iadv(nqtot)
46	REAL masse(ijb_u:ije_u,llm),pente_max
47	REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
48	REAL q(ijb_u:ije_u,llm,nqtot)
49	REAL w(ijb_u:ije_u,llm),pdt
50	REAL p(ijb_u:ije_u,llmp1),teta(ijb_u:ije_u,llm)
51	REAL pk(ijb_u:ije_u,llm)
52	c
53	c Local
54	c ---------
55	c
56	INTEGER ij,l
57	c
58	REAL zzpbar, zzw
59
60	REAL qmin,qmax
61	DATA qmin,qmax/0.,1.e33/
62
63	c--pour rapport de melange saturant--
64
65	REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
66	REAL ptarg,pdelarg,foeew,zdelta
67	REAL tempe(ijb_u:ije_u)
68	INTEGER ijb,ije,iq,iq2,ifils
69	LOGICAL, SAVE :: firstcall=.TRUE.
70	!$OMP THREADPRIVATE(firstcall)
71	type(request),SAVE :: MyRequest1
72	!$OMP THREADPRIVATE(MyRequest1)
73	type(request),SAVE :: MyRequest2
74	!$OMP THREADPRIVATE(MyRequest2)
75	c fonction psat(T)
76
77	FOEEW ( PTARG,PDELARG ) = EXP (
78	* (R3LES(1.-PDELARG)+R3IESPDELARG) * (PTARG-RTT)
79	* / (PTARG-(R4LES(1.-PDELARG)+R4IESPDELARG)) )
80
81	r2es = 380.11733
82	r3les = 17.269
83	r3ies = 21.875
84	r4les = 35.86
85	r4ies = 7.66
86	retv = 0.6077667
87	rtt = 273.16
88
89	c Allocate variables depending on dynamic variable nqtot
90
91	IF (firstcall) THEN
92	firstcall=.FALSE.
93	END IF
94	c-- Calcul de Qsat en chaque point
95	c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
96	c pour eviter une exponentielle.
97
98	call SetTag(MyRequest1,100)
99	call SetTag(MyRequest2,101)
100
101
102	ijb=ij_begin-iip1
103	ije=ij_end+iip1
104	if (pole_nord) ijb=ij_begin
105	if (pole_sud) ije=ij_end
106
107	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
108	DO l = 1, llm
109	DO ij = ijb, ije
110	tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
111	ENDDO
112	DO ij = ijb, ije
113	zdelta = MAX( 0., SIGN(1., rtt - tempe(ij)) )
114	play = 0.5*(p(ij,l)+p(ij,l+1))
115	qsat(ij,l) = MIN(0.5, r2es* FOEEW(tempe(ij),zdelta) / play )
116	qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
117	ENDDO
118	ENDDO
119	c$OMP END DO NOWAIT
120	c PRINT*,'Debut vlsplt version debug sans vlyqs'
121
122	zzpbar = 0.5 * pdt
123	zzw = pdt
124
125	ijb=ij_begin
126	ije=ij_end
127	if (pole_nord) ijb=ijb+iip1
128	if (pole_sud) ije=ije-iip1
129
130	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
131	DO l=1,llm
132	DO ij = ijb,ije
133	mu(ij,l)=pbaru(ij,l) * zzpbar
134	ENDDO
135	ENDDO
136	c$OMP END DO NOWAIT
137
138	ijb=ij_begin-iip1
139	ije=ij_end
140	if (pole_nord) ijb=ij_begin
141	if (pole_sud) ije=ij_end-iip1
142
143	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
144	DO l=1,llm
145	DO ij=ijb,ije
146	mv(ij,l)=pbarv(ij,l) * zzpbar
147	ENDDO
148	ENDDO
149	c$OMP END DO NOWAIT
150
151	ijb=ij_begin
152	ije=ij_end
153
154	DO iq=1,nqtot
155	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
156	DO l=1,llm
157	DO ij=ijb,ije
158	mw(ij,l,iq)=w(ij,l) * zzw
159	ENDDO
160	ENDDO
161	c$OMP END DO NOWAIT
162	ENDDO
163
164	DO iq=1,nqtot
165	c$OMP MASTER
166	DO ij=ijb,ije
167	mw(ij,llm+1,iq)=0.
168	ENDDO
169	c$OMP END MASTER
170	ENDDO
171
172	c CALL SCOPY(ijp1llm,q,1,zq,1)
173	c CALL SCOPY(ijp1llm,masse,1,zm,1)
174
175	ijb=ij_begin
176	ije=ij_end
177
178	DO iq=1,nqtot
179	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
180	DO l=1,llm
181	zq(ijb:ije,l,iq)=q(ijb:ije,l,iq)
182	zm(ijb:ije,l,iq)=masse(ijb:ije,l)
183	ENDDO
184	c$OMP END DO NOWAIT
185	ENDDO
186
187	#ifdef DEBUG_IO
188	CALL WriteField_u('mu',mu)
189	CALL WriteField_v('mv',mv)
190	CALL WriteField_u('mw',mw)
191	CALL WriteField_u('qsat',qsat)
192	#endif
193
194	! verif temporaire
195	ijb=ij_begin
196	ije=ij_end
197	if (ok_iso_verif) then
198	call check_isotopes(zq,ijb,ije,'vlspltgen_loc 191')
199	endif !if (ok_iso_verif) then
200
201	c$OMP BARRIER
202	! DO iq=1,nqtot
203	DO iq=1,nqperes ! CRisi: on ne boucle que sur les pères= ceux qui sont transportés directement par l'air
204	!write(,) 'vlspltgen 192: iq,iadv=',iq,iadv(iq)
205	#ifdef DEBUG_IO
206	CALL WriteField_u('zq',zq(:,:,iq))
207	CALL WriteField_u('zm',zm(:,:,iq))
208	#endif
209	if(iadv(iq) == 0) then
210
211	cycle
212
213	else if (iadv(iq)==10) then
214
215	#ifdef _ADV_HALO
216	! CRisi: on ajoute les nombres de fils et tableaux des fils
217	! On suppose qu'on ne peut advecter les fils que par le schéma 10.
218	call vlx_loc(zq,pente_max,zm,mu,
219	& ij_begin,ij_begin+2*iip1-1,iq)
220	call vlx_loc(zq,pente_max,zm,mu,
221	& ij_end-2*iip1+1,ij_end,iq)
222	#else
223	call vlx_loc(zq,pente_max,zm,mu,
224	& ij_begin,ij_end,iq)
225	#endif
226
227	c$OMP MASTER
228	call VTb(VTHallo)
229	c$OMP END MASTER
230	call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
231	call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
232	! CRisi
233	do ifils=1,nqdesc(iq)
234	iq2=iqfils(ifils,iq)
235	call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
236	call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
237	enddo
238
239	c$OMP MASTER
240	call VTe(VTHallo)
241	c$OMP END MASTER
242	else if (iadv(iq)==14) then
243
244	#ifdef _ADV_HALO
245	call vlxqs_loc(zq,pente_max,zm,mu,
246	& qsat,ij_begin,ij_begin+2*iip1-1,iq)
247	call vlxqs_loc(zq,pente_max,zm,mu,
248	& qsat,ij_end-2*iip1+1,ij_end,iq)
249	#else
250	call vlxqs_loc(zq,pente_max,zm,mu,
251	& qsat,ij_begin,ij_end,iq)
252	#endif
253
254	c$OMP MASTER
255	call VTb(VTHallo)
256	c$OMP END MASTER
257
258	call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
259	call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
260	do ifils=1,nqdesc(iq)
261	iq2=iqfils(ifils,iq)
262	call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
263	call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
264	enddo
265
266	c$OMP MASTER
267	call VTe(VTHallo)
268	c$OMP END MASTER
269	else
270
271	stop 'vlspltgen_p : schema non parallelise'
272
273	endif
274
275	enddo !DO iq=1,nqperes
276
277
278	c$OMP BARRIER
279	c$OMP MASTER
280	call VTb(VTHallo)
281	c$OMP END MASTER
282
283	call SendRequest(MyRequest1)
284
285	c$OMP MASTER
286	call VTe(VTHallo)
287	c$OMP END MASTER
288	c$OMP BARRIER
289
290	! verif temporaire
291	ijb=ij_begin-2*iip1
292	ije=ij_end+2*iip1
293	if (pole_nord) ijb=ij_begin
294	if (pole_sud) ije=ij_end
295	if (ok_iso_verif) then
296	call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 280')
297	endif !if (ok_iso_verif) then
298
299	do iq=1,nqperes
300	!write(,) 'vlspltgen 279: iq=',iq
301
302	if(iadv(iq) == 0) then
303
304	cycle
305
306	else if (iadv(iq)==10) then
307
308	#ifdef _ADV_HALLO
309	call vlx_loc(zq,pente_max,zm,mu,
310	& ij_begin+2iip1,ij_end-2iip1,iq)
311	#endif
312	else if (iadv(iq)==14) then
313	#ifdef _ADV_HALLO
314	call vlxqs_loc(zq,pente_max,zm,mu,
315	& qsat,ij_begin+2iip1,ij_end-2iip1,iq)
316	#endif
317	else
318
319	stop 'vlspltgen_p : schema non parallelise'
320
321	endif
322
323	enddo
324	c$OMP BARRIER
325	c$OMP MASTER
326	call VTb(VTHallo)
327	c$OMP END MASTER
328
329	! call WaitRecvRequest(MyRequest1)
330	! call WaitSendRequest(MyRequest1)
331	c$OMP BARRIER
332	call WaitRequest(MyRequest1)
333
334
335	c$OMP MASTER
336	call VTe(VTHallo)
337	c$OMP END MASTER
338	c$OMP BARRIER
339
340
341	if (ok_iso_verif) then
342	call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 326')
343	endif !if (ok_iso_verif) then
344	if (ok_iso_verif) then
345	ijb=ij_begin-2*iip1
346	ije=ij_end+2*iip1
347	if (pole_nord) ijb=ij_begin
348	if (pole_sud) ije=ij_end
349	call check_isotopes(zq,ijb,ije,'vlspltgen_loc 336')
350	endif !if (ok_iso_verif) then
351
352	do iq=1,nqperes
353	!write(,) 'vlspltgen 321: iq=',iq
354	#ifdef DEBUG_IO
355	CALL WriteField_u('zq',zq(:,:,iq))
356	CALL WriteField_u('zm',zm(:,:,iq))
357	#endif
358
359	if(iadv(iq) == 0) then
360
361	cycle
362
363	else if (iadv(iq)==10) then
364
365	call vly_loc(zq,pente_max,zm,mv,iq)
366
367	else if (iadv(iq)==14) then
368
369	call vlyqs_loc(zq,pente_max,zm,mv,
370	& qsat,iq)
371
372	else
373
374	stop 'vlspltgen_p : schema non parallelise'
375
376	endif
377
378	enddo
379
380	if (ok_iso_verif) then
381	call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 357')
382	endif !if (ok_iso_verif) then
383
384	do iq=1,nqperes
385	!write(,) 'vlspltgen 349: iq=',iq
386	#ifdef DEBUG_IO
387	CALL WriteField_u('zq',zq(:,:,iq))
388	CALL WriteField_u('zm',zm(:,:,iq))
389	#endif
390	if(iadv(iq) == 0) then
391
392	cycle
393
394	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
395
396	c$OMP BARRIER
397	#ifdef _ADV_HALLO
398	call vlz_loc(zq,pente_max,zm,mw,
399	& ij_begin,ij_begin+2*iip1-1,iq)
400	call vlz_loc(zq,pente_max,zm,mw,
401	& ij_end-2*iip1+1,ij_end,iq)
402	#else
403	call vlz_loc(zq,pente_max,zm,mw,
404	& ij_begin,ij_end,iq)
405	#endif
406	c$OMP BARRIER
407
408	c$OMP MASTER
409	call VTb(VTHallo)
410	c$OMP END MASTER
411
412	call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
413	call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
414	! CRisi
415	do ifils=1,nqdesc(iq)
416	iq2=iqfils(ifils,iq)
417	call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest2)
418	call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest2)
419	enddo
420	c$OMP MASTER
421	call VTe(VTHallo)
422	c$OMP END MASTER
423	c$OMP BARRIER
424	else
425
426	stop 'vlspltgen_p : schema non parallelise'
427
428	endif
429
430	enddo
431	c$OMP BARRIER
432
433	c$OMP MASTER
434	call VTb(VTHallo)
435	c$OMP END MASTER
436
437	call SendRequest(MyRequest2)
438
439	c$OMP MASTER
440	call VTe(VTHallo)
441	c$OMP END MASTER
442
443
444	if (ok_iso_verif) then
445	call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 429')
446	endif !if (ok_iso_verif) then
447
448	c$OMP BARRIER
449	do iq=1,nqperes
450	!write(,) 'vlspltgen 409: iq=',iq
451
452	if(iadv(iq) == 0) then
453
454	cycle
455
456	else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
457	c$OMP BARRIER
458
459	#ifdef _ADV_HALLO
460	call vlz_loc(zq,pente_max,zm,mw,
461	& ij_begin+2iip1,ij_end-2iip1,iq)
462	#endif
463
464	c$OMP BARRIER
465	else
466
467	stop 'vlspltgen_p : schema non parallelise'
468
469	endif
470
471	enddo
472	!write(,) 'vlspltgen_loc 476'
473
474	c$OMP BARRIER
475	!write(,) 'vlspltgen_loc 477'
476	c$OMP MASTER
477	call VTb(VTHallo)
478	c$OMP END MASTER
479
480	! call WaitRecvRequest(MyRequest2)
481	! call WaitSendRequest(MyRequest2)
482	c$OMP BARRIER
483	CALL WaitRequest(MyRequest2)
484
485	c$OMP MASTER
486	call VTe(VTHallo)
487	c$OMP END MASTER
488	c$OMP BARRIER
489
490
491	!write(,) 'vlspltgen_loc 494'
492	if (ok_iso_verif) then
493	call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 461')
494	endif !if (ok_iso_verif) then
495
496	do iq=1,nqperes
497	!write(,) 'vlspltgen 449: iq=',iq
498	#ifdef DEBUG_IO
499	CALL WriteField_u('zq',zq(:,:,iq))
500	CALL WriteField_u('zm',zm(:,:,iq))
501	#endif
502	if(iadv(iq) == 0) then
503
504	cycle
505
506	else if (iadv(iq)==10) then
507
508	call vly_loc(zq,pente_max,zm,mv,iq)
509
510	else if (iadv(iq)==14) then
511
512	call vlyqs_loc(zq,pente_max,zm,mv,
513	& qsat,iq)
514
515	else
516
517	stop 'vlspltgen_p : schema non parallelise'
518
519	endif
520
521	enddo !do iq=1,nqperes
522
523	if (ok_iso_verif) then
524	call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 493')
525	endif !if (ok_iso_verif) then
526
527	do iq=1,nqperes
528	!write(,) 'vlspltgen 477: iq=',iq
529	#ifdef DEBUG_IO
530	CALL WriteField_u('zq',zq(:,:,iq))
531	CALL WriteField_u('zm',zm(:,:,iq))
532	#endif
533	if(iadv(iq) == 0) then
534
535	cycle
536
537	else if (iadv(iq)==10) then
538
539	call vlx_loc(zq,pente_max,zm,mu,
540	& ij_begin,ij_end,iq)
541
542	else if (iadv(iq)==14) then
543
544	call vlxqs_loc(zq,pente_max,zm,mu,
545	& qsat, ij_begin,ij_end,iq)
546
547	else
548
549	stop 'vlspltgen_p : schema non parallelise'
550
551	endif
552
553	enddo !do iq=1,nqperes
554
555	!write(,) 'vlspltgen 550: apres derniere serie de call vlx'
556	if (ok_iso_verif) then
557	call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 521')
558	endif !if (ok_iso_verif) then
559
560	ijb=ij_begin
561	ije=ij_end
562	!write(,) 'vlspltgen_loc 557'
563	c$OMP BARRIER
564
565	!write(,) 'vlspltgen_loc 559'
566	DO iq=1,nqtot
567	!write(,) 'vlspltgen_loc 561, iq=',iq
568	#ifdef DEBUG_IO
569	CALL WriteField_u('zq',zq(:,:,iq))
570	CALL WriteField_u('zm',zm(:,:,iq))
571	#endif
572	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
573	DO l=1,llm
574	DO ij=ijb,ije
575	c print *,'zq-->',ij,l,iq,zq(ij,l,iq)
576	c print *,'q-->',ij,l,iq,q(ij,l,iq)
577	q(ij,l,iq)=zq(ij,l,iq)
578	ENDDO
579	ENDDO
580	c$OMP END DO NOWAIT
581	!write(,) 'vlspltgen_loc 575'
582
583	c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
584	DO l=1,llm
585	DO ij=ijb,ije-iip1+1,iip1
586	q(ij+iim,l,iq)=q(ij,l,iq)
587	ENDDO
588	ENDDO
589	c$OMP END DO NOWAIT
590	!write(,) 'vlspltgen_loc 583'
591	ENDDO !DO iq=1,nqtot
592
593	if (ok_iso_verif) then
594	call check_isotopes(q,ij_begin,ij_end,'vlspltgen_loc 557')
595	endif !if (ok_iso_verif) then
596
597	c$OMP BARRIER
598
599	cc$OMP MASTER
600	c call WaitSendRequest(MyRequest1)
601	c call WaitSendRequest(MyRequest2)
602	cc$OMP END MASTER
603	cc$OMP BARRIER
604
605	!write(,) 'vlspltgen 597: sortie'
606	RETURN
607	END

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

Download in other formats:

Original Format