Context Navigation

vlspltgen_loc.F @ 4056

Last change on this file since 4056 was 4056, checked in by dcugnet, 2 years ago

Most of the changes are intended to help to eventually remove the constraints about the tracers assumptions, in particular water tracers.

Remove index tables itr_indice and niadv, replaced by tracers(:)%isAdvected and tracers(:)%isH2OFamily. Most of the loops are now from 1 to nqtot:
- DO iq=nqo+1,nqtot loops are replaced with: DO iq=1,nqtot

IF(tracers(iq)%isH2Ofamily) CYCLE

DO it=1,nbtr; iq=niadv(it+nqo)

and DO it=1,nqtottr; iq=itr_indice(it) loops are replaced with:

it = 0
DO iq = 1, nqtot

IF(.NOT.tracers(iq)%isAdvected .OR. tracers(iq)%isH2Ofamily) CYCLE
it = it+1

Move some StratAer? related code from infotrac to infotrac_phy
Remove "nqperes" variable:

DO iq=1,nqpere loops are replaced with:
DO iq=1,nqtot

IF(tracers(iq)%parent/='air') CYCLE

Cosmetic changes (justification, SELECT CASE instead of multiple IF...) mostly in advtrac* routines.

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.0 KB

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

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

Download in other formats:

Original Format