source: LMDZ6/trunk/libf/dyn3dmem/vlspltgen_loc.F @ 4050

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

Second commit for new tracers.

  • include most of the keys in the tracers descriptor vector "tracers(:)".
  • fix in phylmdiso/cv3_routines: fq_* variables were used where their fxt_* counterparts were expected.
  • multiple IF(nqdesc(iq)>0) and IF(nqfils(iq)>0) tests suppressed, because they are not needed: "do ... enddo" loops with 0 upper bound are not executed.
  • remove French accents from comments (encoding problem) in phylmdiso/cv3_routines and phylmdiso/cv30_routines.
  • modifications in "isotopes_verif_mod", where the call to function "iso_verif_tag17_q_deltad_chn" in "iso_verif_tag17_q_deltad_chn" was not detected at linking stage, although defined in the same module (?).
  • 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: 14.7 KB
Line 
1!
2! $Header$
3!
4       SUBROUTINE vlspltgen_loc( q,pente_max,masse,w,pbaru,pbarv,
5     &                           pdt, p,pk,teta                 )
6     
7c
8c     Auteurs:   P.Le Van, F.Hourdin, F.Forget, F.Codron
9c
10c    ********************************************************************
11c          Shema  d'advection " pseudo amont " .
12c      + test sur humidite specifique: Q advecte< Qsat aval
13c                   (F. Codron, 10/99)
14c    ********************************************************************
15c     q,pbaru,pbarv,w sont des arguments d'entree  pour le s-pg ....
16c
17c     pente_max facteur de limitation des pentes: 2 en general
18c                                                0 pour un schema amont
19c     pbaru,pbarv,w flux de masse en u ,v ,w
20c     pdt pas de temps
21c
22c     teta temperature potentielle, p pression aux interfaces,
23c     pk exner au milieu des couches necessaire pour calculer Qsat
24c   --------------------------------------------------------------------
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, tracers,ok_iso_verif
31      USE vlspltgen_mod
32      USE comconst_mod, ONLY: cpp
33      IMPLICIT NONE
34
35c
36      include "dimensions.h"
37      include "paramet.h"
38
39c
40c   Arguments:
41c   ----------
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)
48c
49c      Local
50c   ---------
51c
52      INTEGER ij,l
53c
54      REAL zzpbar, zzw
55
56      REAL qmin,qmax
57      DATA qmin,qmax/0.,1.e33/
58
59c--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)
71c    fonction psat(T)
72
73       FOEEW ( PTARG,PDELARG ) = EXP (
74     *          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)
75     * / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
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
85c Allocate variables depending on dynamic variable nqtot
86
87         IF (firstcall) THEN
88            firstcall=.FALSE.
89         END IF
90c-- Calcul de Qsat en chaque point
91c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
92c   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       
103c$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
115c$OMP END DO NOWAIT
116c      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
126c$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
132c$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
139c$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
145c$OMP END DO NOWAIT
146
147      ijb=ij_begin
148      ije=ij_end
149
150      DO iq=1,nqtot
151c$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
157c$OMP END DO NOWAIT
158      ENDDO
159
160      DO iq=1,nqtot 
161c$OMP MASTER
162      DO ij=ijb,ije
163         mw(ij,llm+1,iq)=0.
164      ENDDO
165c$OMP END MASTER
166      ENDDO
167
168c      CALL SCOPY(ijp1llm,q,1,zq,1)
169c      CALL SCOPY(ijp1llm,masse,1,zm,1)
170
171       ijb=ij_begin
172       ije=ij_end
173
174      DO iq=1,nqtot       
175c$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
180c$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
197c$OMP BARRIER           
198!      DO iq=1,nqtot
199      DO iq=1,nqperes ! CRisi: on ne boucle que sur les pères= ceux qui sont transportés directement par l'air
200       !write(*,*) 'vlspltgen 192: iq,iadv=',iq,tracers(iq)%iadv
201#ifdef DEBUG_IO   
202       CALL WriteField_u('zq',zq(:,:,iq))
203       CALL WriteField_u('zm',zm(:,:,iq))
204#endif
205        SELECT CASE(tracers(iq)%iadv)
206          CASE(0); CYCLE
207          CASE(10)
208#ifdef _ADV_HALO       
209! CRisi: on ajoute les nombres de fils et tableaux des fils
210! On suppose qu'on ne peut advecter les fils que par le schéma 10. 
211          call vlx_loc(zq,pente_max,zm,mu,
212     &                     ij_begin,ij_begin+2*iip1-1,iq)
213          call vlx_loc(zq,pente_max,zm,mu,
214     &               ij_end-2*iip1+1,ij_end,iq)
215#else
216          call vlx_loc(zq,pente_max,zm,mu,
217     &                     ij_begin,ij_end,iq)
218#endif
219
220c$OMP MASTER
221          call VTb(VTHallo)
222c$OMP END MASTER
223          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
224          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
225! CRisi
226          do ifils=1,tracers(iq)%nqDescen
227            iq2=tracers(iq)%iqDescen(ifils)
228            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
229            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
230          enddo
231
232c$OMP MASTER
233          call VTe(VTHallo)
234c$OMP END MASTER
235          CASE(14)
236#ifdef _ADV_HALO           
237          call vlxqs_loc(zq,pente_max,zm,mu,
238     &                   qsat,ij_begin,ij_begin+2*iip1-1,iq)
239          call vlxqs_loc(zq,pente_max,zm,mu,
240     &                   qsat,ij_end-2*iip1+1,ij_end,iq)
241#else
242          call vlxqs_loc(zq,pente_max,zm,mu,
243     &                   qsat,ij_begin,ij_end,iq)
244#endif
245
246c$OMP MASTER
247          call VTb(VTHallo)
248c$OMP END MASTER
249
250          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest1)
251          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest1)
252          do ifils=1,tracers(iq)%nqDescen
253            iq2=tracers(iq)%iqDescen(ifils)
254            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest1)
255            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest1)
256          enddo
257
258c$OMP MASTER
259          call VTe(VTHallo)
260c$OMP END MASTER
261          CASE DEFAULT
262          stop 'vlspltgen_p : schema non parallelise'
263     
264        END SELECT
265     
266      enddo !DO iq=1,nqperes
267     
268     
269c$OMP BARRIER     
270c$OMP MASTER     
271      call VTb(VTHallo)
272c$OMP END MASTER
273
274      call SendRequest(MyRequest1)
275
276c$OMP MASTER
277      call VTe(VTHallo)
278c$OMP END MASTER       
279c$OMP BARRIER
280
281      ! verif temporaire
282      ijb=ij_begin-2*iip1
283      ije=ij_end+2*iip1 
284      if (pole_nord) ijb=ij_begin
285      if (pole_sud)  ije=ij_end 
286      if (ok_iso_verif) then
287           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 280')
288      endif !if (ok_iso_verif) then
289
290      do iq=1,nqperes
291        !write(*,*) 'vlspltgen 279: iq=',iq
292
293        SELECT CASE(tracers(iq)%iadv)
294          CASE(0); CYCLE
295          CASE(10)
296#ifdef _ADV_HALLO
297          call vlx_loc(zq,pente_max,zm,mu,
298     &                 ij_begin+2*iip1,ij_end-2*iip1,iq)
299#endif       
300          CASE(14)
301#ifdef _ADV_HALLO
302          call vlxqs_loc(zq,pente_max,zm,mu,
303     &                    qsat,ij_begin+2*iip1,ij_end-2*iip1,iq)
304#endif   
305          CASE DEFAULT
306          stop 'vlspltgen_p : schema non parallelise'
307     
308        END SELECT
309     
310      enddo
311c$OMP BARRIER     
312c$OMP MASTER
313      call VTb(VTHallo)
314c$OMP END MASTER
315
316!      call WaitRecvRequest(MyRequest1)
317!      call WaitSendRequest(MyRequest1)
318c$OMP BARRIER
319       call WaitRequest(MyRequest1)
320
321
322c$OMP MASTER
323      call VTe(VTHallo)
324c$OMP END MASTER
325c$OMP BARRIER
326
327     
328      if (ok_iso_verif) then
329           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 326')
330      endif !if (ok_iso_verif) then       
331      if (ok_iso_verif) then
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,nqperes
340       !write(*,*) 'vlspltgen 321: iq=',iq
341#ifdef DEBUG_IO   
342       CALL WriteField_u('zq',zq(:,:,iq))
343       CALL WriteField_u('zm',zm(:,:,iq))
344#endif
345
346        SELECT CASE(tracers(iq)%iadv)
347          CASE(0); CYCLE
348          CASE(10); call vly_loc(zq,pente_max,zm,mv,iq)
349          CASE(14); call vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
350          CASE DEFAULT
351          stop 'vlspltgen_p : schema non parallelise'
352        END SELECT
353       
354       enddo
355
356      if (ok_iso_verif) then
357           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 357')
358      endif !if (ok_iso_verif) then
359
360      do iq=1,nqperes
361      !write(*,*) 'vlspltgen 349: iq=',iq
362#ifdef DEBUG_IO   
363       CALL WriteField_u('zq',zq(:,:,iq))
364       CALL WriteField_u('zm',zm(:,:,iq))
365#endif
366        SELECT CASE(tracers(iq)%iadv)
367          CASE(0); CYCLE
368          CASE(10,14)
369c$OMP BARRIER       
370#ifdef _ADV_HALLO
371          call vlz_loc(zq,pente_max,zm,mw,
372     &               ij_begin,ij_begin+2*iip1-1,iq)
373          call vlz_loc(zq,pente_max,zm,mw,
374     &               ij_end-2*iip1+1,ij_end,iq)
375#else
376          call vlz_loc(zq,pente_max,zm,mw,
377     &               ij_begin,ij_end,iq)
378#endif
379c$OMP BARRIER
380
381c$OMP MASTER
382          call VTb(VTHallo)
383c$OMP END MASTER
384
385          call Register_Hallo_u(zq(:,:,iq),llm,2,2,2,2,MyRequest2)
386          call Register_Hallo_u(zm(:,:,iq),llm,1,1,1,1,MyRequest2)
387          ! CRisi
388          do ifils=1,tracers(iq)%nqDescen
389            iq2=tracers(iq)%iqDescen(ifils)
390            call Register_Hallo_u(zq(:,:,iq2),llm,2,2,2,2,MyRequest2)
391            call Register_Hallo_u(zm(:,:,iq2),llm,1,1,1,1,MyRequest2)
392          enddo     
393c$OMP MASTER
394          call VTe(VTHallo)
395c$OMP END MASTER       
396c$OMP BARRIER
397          CASE DEFAULT
398          stop 'vlspltgen_p : schema non parallelise'
399     
400        END SELECT
401     
402      enddo
403c$OMP BARRIER     
404
405c$OMP MASTER       
406      call VTb(VTHallo)
407c$OMP END MASTER
408
409      call SendRequest(MyRequest2)
410
411c$OMP MASTER
412      call VTe(VTHallo)
413c$OMP END MASTER       
414
415
416      if (ok_iso_verif) then
417           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 429')
418      endif !if (ok_iso_verif) then
419
420c$OMP BARRIER
421      do iq=1,nqperes
422      !write(*,*) 'vlspltgen 409: iq=',iq
423
424        SELECT CASE(tracers(iq)%iadv)
425          CASE(0); CYCLE
426          CASE(10,14)
427c$OMP BARRIER       
428
429#ifdef _ADV_HALLO
430          call vlz_loc(zq,pente_max,zm,mw,
431     &               ij_begin+2*iip1,ij_end-2*iip1,iq)
432#endif
433
434c$OMP BARRIER       
435          CASE DEFAULT
436          stop 'vlspltgen_p : schema non parallelise'
437        END SELECT
438     
439      enddo
440      !write(*,*) 'vlspltgen_loc 476'
441
442c$OMP BARRIER
443      !write(*,*) 'vlspltgen_loc 477'
444c$OMP MASTER
445      call VTb(VTHallo)
446c$OMP END MASTER
447
448!      call WaitRecvRequest(MyRequest2)
449!      call WaitSendRequest(MyRequest2)
450c$OMP BARRIER
451       CALL WaitRequest(MyRequest2)
452
453c$OMP MASTER
454      call VTe(VTHallo)
455c$OMP END MASTER
456c$OMP BARRIER
457
458
459      !write(*,*) 'vlspltgen_loc 494'
460      if (ok_iso_verif) then
461           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 461')
462      endif !if (ok_iso_verif) then
463
464      do iq=1,nqperes
465      !write(*,*) 'vlspltgen 449: iq=',iq
466#ifdef DEBUG_IO   
467       CALL WriteField_u('zq',zq(:,:,iq))
468       CALL WriteField_u('zm',zm(:,:,iq))
469#endif
470        SELECT CASE(tracers(iq)%iadv)
471          CASE(0); CYCLE
472          CASE(10); call   vly_loc(zq,pente_max,zm,mv,     iq)
473          CASE(14); call vlyqs_loc(zq,pente_max,zm,mv,qsat,iq)
474          CASE DEFAULT; stop 'vlspltgen_p : schema non parallelise'
475        END SELECT
476       
477       enddo !do iq=1,nqperes
478
479      if (ok_iso_verif) then
480           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 493')
481      endif !if (ok_iso_verif) then
482
483      do iq=1,nqperes
484      !write(*,*) 'vlspltgen 477: iq=',iq
485#ifdef DEBUG_IO   
486       CALL WriteField_u('zq',zq(:,:,iq))
487       CALL WriteField_u('zm',zm(:,:,iq))
488#endif
489        SELECT CASE(tracers(iq)%iadv)
490          CASE(0); CYCLE
491          CASE(10); call   vlx_loc(zq,pente_max,zm,mu,
492     &               ij_begin,ij_end,iq)
493          CASE(14); call vlxqs_loc(zq,pente_max,zm,mu,
494     &                 qsat, ij_begin,ij_end,iq)
495          CASE DEFAULT; stop 'vlspltgen_p : schema non parallelise'
496        END SELECT
497       
498       enddo !do iq=1,nqperes
499
500      !write(*,*) 'vlspltgen 550: apres derniere serie de call vlx'
501      if (ok_iso_verif) then
502           call check_isotopes(zq,ij_begin,ij_end,'vlspltgen_loc 521')
503      endif !if (ok_iso_verif) then
504     
505      ijb=ij_begin
506      ije=ij_end
507      !write(*,*) 'vlspltgen_loc 557'
508c$OMP BARRIER     
509
510      !write(*,*) 'vlspltgen_loc 559' 
511      DO iq=1,nqtot
512       !write(*,*) 'vlspltgen_loc 561, iq=',iq 
513#ifdef DEBUG_IO   
514       CALL WriteField_u('zq',zq(:,:,iq))
515       CALL WriteField_u('zm',zm(:,:,iq))
516#endif
517c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)         
518        DO l=1,llm
519           DO ij=ijb,ije
520c             print *,'zq-->',ij,l,iq,zq(ij,l,iq)
521c             print *,'q-->',ij,l,iq,q(ij,l,iq)
522             q(ij,l,iq)=zq(ij,l,iq)
523           ENDDO
524        ENDDO
525c$OMP END DO NOWAIT   
526      !write(*,*) 'vlspltgen_loc 575'     
527
528c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
529        DO l=1,llm
530           DO ij=ijb,ije-iip1+1,iip1
531              q(ij+iim,l,iq)=q(ij,l,iq)
532           ENDDO
533        ENDDO
534c$OMP END DO NOWAIT 
535      !write(*,*) 'vlspltgen_loc 583' 
536      ENDDO !DO iq=1,nqtot
537       
538      if (ok_iso_verif) then
539           call check_isotopes(q,ij_begin,ij_end,'vlspltgen_loc 557')
540      endif !if (ok_iso_verif) then
541
542c$OMP BARRIER
543
544cc$OMP MASTER     
545c      call WaitSendRequest(MyRequest1)
546c      call WaitSendRequest(MyRequest2)
547cc$OMP END MASTER
548cc$OMP BARRIER
549
550      !write(*,*) 'vlspltgen 597: sortie' 
551      RETURN
552      END
Note: See TracBrowser for help on using the repository browser.