source: LMDZ5/trunk/libf/dyn3d/advtrac.F90 @ 4514

Last change on this file since 4514 was 2622, checked in by Ehouarn Millour, 8 years ago

Some code tidying: turn ener.h into ener_mod.F90
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
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 14.7 KB
Line 
1! $Id: advtrac.F90 2622 2016-09-04 06:12:02Z oboucher $
2
3SUBROUTINE advtrac(pbaru,pbarv , p,  masse,q,iapptrac,teta, flxw, pk)
4  !     Auteur :  F. Hourdin
5  !
6  !     Modif. P. Le Van     (20/12/97)
7  !            F. Codron     (10/99)
8  !            D. Le Croller (07/2001)
9  !            M.A Filiberti (04/2002)
10  !
11  USE infotrac, ONLY: nqtot, iadv,nqperes,ok_iso_verif
12  USE control_mod, ONLY: iapp_tracvl, day_step
13  USE comconst_mod, ONLY: dtvr
14
15  IMPLICIT NONE
16  !
17  include "dimensions.h"
18  include "paramet.h"
19  include "comdissip.h"
20  include "comgeom2.h"
21  include "description.h"
22  include "iniprint.h"
23
24  !-------------------------------------------------------------------
25  !     Arguments
26  !-------------------------------------------------------------------
27  INTEGER,INTENT(OUT) :: iapptrac
28  REAL,INTENT(IN) :: pbaru(ip1jmp1,llm)
29  REAL,INTENT(IN) :: pbarv(ip1jm,llm)
30  REAL,INTENT(INOUT) :: q(ip1jmp1,llm,nqtot)
31  REAL,INTENT(IN) :: masse(ip1jmp1,llm)
32  REAL,INTENT(IN) :: p( ip1jmp1,llmp1 )
33  REAL,INTENT(IN) :: teta(ip1jmp1,llm)
34  REAL,INTENT(IN) :: pk(ip1jmp1,llm)
35  REAL,INTENT(OUT) :: flxw(ip1jmp1,llm)
36  !-------------------------------------------------------------------
37  !     Ajout PPM
38  !--------------------------------------------------------
39  REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm)
40  !-------------------------------------------------------------
41  !     Variables locales
42  !-------------------------------------------------------------
43
44  REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
45  REAL massem(ip1jmp1,llm),zdp(ip1jmp1)
46  REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm)
47  REAL (kind=kind(1.d0)) :: t_initial, t_final, tps_cpu
48  INTEGER iadvtr
49  INTEGER ij,l,iq,iiq
50  REAL zdpmin, zdpmax
51  EXTERNAL  minmax
52  SAVE iadvtr, massem, pbaruc, pbarvc
53  DATA iadvtr/0/
54  !----------------------------------------------------------
55  !     Rajouts pour PPM
56  !----------------------------------------------------------
57  INTEGER indice,n
58  REAL dtbon ! Pas de temps adaptatif pour que CFL<1
59  REAL CFLmaxz,aaa,bbb ! CFL maximum
60  REAL psppm(iim,jjp1) ! pression  au sol
61  REAL unatppm(iim,jjp1,llm),vnatppm(iim,jjp1,llm)
62  REAL qppm(iim*jjp1,llm,nqtot)
63  REAL fluxwppm(iim,jjp1,llm)
64  REAL apppm(llmp1), bpppm(llmp1)
65  LOGICAL dum,fill
66  DATA fill/.true./
67  DATA dum/.true./
68
69  integer,save :: countcfl=0
70  real cflx(ip1jmp1,llm)
71  real cfly(ip1jm,llm)
72  real cflz(ip1jmp1,llm)
73  real, save :: cflxmax(llm),cflymax(llm),cflzmax(llm)
74
75  IF(iadvtr.EQ.0) THEN
76     pbaruc(:,:)=0
77     pbarvc(:,:)=0
78  ENDIF
79
80  !   accumulation des flux de masse horizontaux
81  DO l=1,llm
82     DO ij = 1,ip1jmp1
83        pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
84     ENDDO
85     DO ij = 1,ip1jm
86        pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
87     ENDDO
88  ENDDO
89
90  !   selection de la masse instantannee des mailles avant le transport.
91  IF(iadvtr.EQ.0) THEN
92
93     CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
94     !cc         CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
95     !
96  ENDIF
97
98  iadvtr   = iadvtr+1
99  iapptrac = iadvtr
100
101
102  !   Test pour savoir si on advecte a ce pas de temps
103  IF ( iadvtr.EQ.iapp_tracvl ) THEN
104
105     !c   ..  Modif P.Le Van  ( 20/12/97 )  ....
106     !c
107
108     !   traitement des flux de masse avant advection.
109     !     1. calcul de w
110     !     2. groupement des mailles pres du pole.
111
112     CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
113
114     ! ... Flux de masse diaganostiques traceurs
115     flxw = wg / REAL(iapp_tracvl)
116
117     !  test sur l'eventuelle creation de valeurs negatives de la masse
118     DO l=1,llm-1
119        DO ij = iip2+1,ip1jm
120           zdp(ij) =    pbarug(ij-1,l)   - pbarug(ij,l) &
121                - pbarvg(ij-iip1,l) + pbarvg(ij,l) &
122                +       wg(ij,l+1)  - wg(ij,l)
123        ENDDO
124        CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
125        DO ij = iip2,ip1jm
126           zdp(ij)= zdp(ij)*dtvr/ massem(ij,l)
127        ENDDO
128
129
130        CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
131
132        IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN
133           PRINT*,'WARNING DP/P l=',l,'  MIN:',zdpmin, &
134                '   MAX:', zdpmax
135        ENDIF
136
137     ENDDO
138
139
140     !-------------------------------------------------------------------
141     ! Calcul des criteres CFL en X, Y et Z
142     !-------------------------------------------------------------------
143
144     if (countcfl == 0. ) then
145        cflxmax(:)=0.
146        cflymax(:)=0.
147        cflzmax(:)=0.
148     endif
149
150     countcfl=countcfl+iapp_tracvl
151     cflx(:,:)=0.
152     cfly(:,:)=0.
153     cflz(:,:)=0.
154     do l=1,llm
155        do ij=iip2,ip1jm-1
156           if (pbarug(ij,l)>=0.) then
157              cflx(ij,l)=pbarug(ij,l)*dtvr/masse(ij,l)
158           else
159              cflx(ij,l)=-pbarug(ij,l)*dtvr/masse(ij+1,l)
160           endif
161        enddo
162     enddo
163     do l=1,llm
164        do ij=iip2,ip1jm-1,iip1
165           cflx(ij+iip1,l)=cflx(ij,l)
166        enddo
167     enddo
168
169     do l=1,llm
170        do ij=1,ip1jm
171           if (pbarvg(ij,l)>=0.) then
172              cfly(ij,l)=pbarvg(ij,l)*dtvr/masse(ij,l)
173           else
174              cfly(ij,l)=-pbarvg(ij,l)*dtvr/masse(ij+iip1,l)
175           endif
176        enddo
177     enddo
178
179     do l=2,llm
180        do ij=1,ip1jm
181           if (wg(ij,l)>=0.) then
182              cflz(ij,l)=wg(ij,l)*dtvr/masse(ij,l)
183           else
184              cflz(ij,l)=-wg(ij,l)*dtvr/masse(ij,l-1)
185           endif
186        enddo
187     enddo
188
189     do l=1,llm
190        cflxmax(l)=max(cflxmax(l),maxval(cflx(:,l)))
191        cflymax(l)=max(cflymax(l),maxval(cfly(:,l)))
192        cflzmax(l)=max(cflzmax(l),maxval(cflz(:,l)))
193     enddo
194
195!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
196     ! Par defaut, on sort le diagnostic des CFL tous les jours.
197     ! Si on veut le sortir a chaque pas d'advection en cas de plantage
198     !     if (countcfl==iapp_tracvl) then
199!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
200     if (countcfl==day_step) then
201        do l=1,llm
202           write(lunout,*) 'L, CFL[xyz]max:', l, cflxmax(l), cflymax(l), &
203                cflzmax(l)
204        enddo
205        countcfl=0
206     endif
207
208     !-------------------------------------------------------------------
209     !   Advection proprement dite (Modification Le Croller (07/2001)
210     !-------------------------------------------------------------------
211
212     !----------------------------------------------------
213     !        Calcul des moyennes basées sur la masse
214     !----------------------------------------------------
215     call massbar(massem,massebx,masseby)         
216
217     !-----------------------------------------------------------
218     !     Appel des sous programmes d'advection
219     !-----------------------------------------------------------
220
221     if (ok_iso_verif) then
222           write(*,*) 'advtrac 227'
223           call check_isotopes_seq(q,ip1jmp1,'advtrac 162')
224     endif !if (ok_iso_verif) then
225
226     do iq=1,nqperes
227        !        call clock(t_initial)
228        if(iadv(iq) == 0) cycle
229        !   ----------------------------------------------------------------
230        !   Schema de Van Leer I MUSCL
231        !   ----------------------------------------------------------------
232        if(iadv(iq).eq.10) THEN
233           ! CRisi: on fait passer tout q pour avoir acces aux fils
234           
235           !write(*,*) 'advtrac 239: iq,q(1721,19,:)=',iq,q(1721,19,:)     
236           call vlsplt(q,2.,massem,wg,pbarug,pbarvg,dtvr,iq)
237           
238           !   ----------------------------------------------------------------
239           !   Schema "pseudo amont" + test sur humidite specifique
240           !    pour la vapeur d'eau. F. Codron
241           !   ----------------------------------------------------------------
242        else if(iadv(iq).eq.14) then
243           !
244           !write(*,*) 'advtrac 248: iq,q(1721,19,:)=',iq,q(1721,19,:)
245           CALL vlspltqs( q, 2., massem, wg , &
246                pbarug,pbarvg,dtvr,p,pk,teta,iq)
247           
248           !   ----------------------------------------------------------------
249           !   Schema de Frederic Hourdin
250           !   ----------------------------------------------------------------
251        else if(iadv(iq).eq.12) then
252           !            Pas de temps adaptatif
253           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
254           if (n.GT.1) then
255              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
256                   dtvr,'n=',n
257           endif
258           do indice=1,n
259              call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
260           end do
261        else if(iadv(iq).eq.13) then
262           !            Pas de temps adaptatif
263           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
264           if (n.GT.1) then
265              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
266                   dtvr,'n=',n
267           endif
268           do indice=1,n
269              call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,2)
270           end do
271           !   ----------------------------------------------------------------
272           !   Schema de pente SLOPES
273           !   ----------------------------------------------------------------
274        else if (iadv(iq).eq.20) then
275           call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
276
277           !   ----------------------------------------------------------------
278           !   Schema de Prather
279           !   ----------------------------------------------------------------
280        else if (iadv(iq).eq.30) then
281           !            Pas de temps adaptatif
282           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
283           if (n.GT.1) then
284              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
285                   dtvr,'n=',n
286           endif
287           call  prather(q(1,1,iq),wg,massem,pbarug,pbarvg, &
288                n,dtbon)
289
290           !   ----------------------------------------------------------------
291           !   Schemas PPM Lin et Rood
292           !   ----------------------------------------------------------------
293        else if (iadv(iq).eq.11.OR.(iadv(iq).GE.16.AND. &
294             iadv(iq).LE.18)) then
295
296           !        Test sur le flux horizontal
297           !        Pas de temps adaptatif
298           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
299           if (n.GT.1) then
300              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
301                   dtvr,'n=',n
302           endif
303           !        Test sur le flux vertical
304           CFLmaxz=0.
305           do l=2,llm
306              do ij=iip2,ip1jm
307                 aaa=wg(ij,l)*dtvr/massem(ij,l)
308                 CFLmaxz=max(CFLmaxz,aaa)
309                 bbb=-wg(ij,l)*dtvr/massem(ij,l-1)
310                 CFLmaxz=max(CFLmaxz,bbb)
311              enddo
312           enddo
313           if (CFLmaxz.GE.1) then
314              write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
315           endif
316
317           !-----------------------------------------------------------
318           !        Ss-prg interface LMDZ.4->PPM3d
319           !-----------------------------------------------------------
320
321           call interpre(q(1,1,iq),qppm(1,1,iq),wg,fluxwppm,massem, &
322                apppm,bpppm,massebx,masseby,pbarug,pbarvg, &
323                unatppm,vnatppm,psppm)
324
325           do indice=1,n
326              !----------------------------------------------------------------
327              !                         VL (version PPM) horiz. et PPM vert.
328              !----------------------------------------------------------------
329              if (iadv(iq).eq.11) then
330                 !                  Ss-prg PPM3d de Lin
331                 call ppm3d(1,qppm(1,1,iq), &
332                      psppm,psppm, &
333                      unatppm,vnatppm,fluxwppm,dtbon,2,2,2,1, &
334                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
335                      fill,dum,220.)
336
337                 !-------------------------------------------------------------
338                 !                           Monotonic PPM
339                 !-------------------------------------------------------------
340              else if (iadv(iq).eq.16) then
341                 !                  Ss-prg PPM3d de Lin
342                 call ppm3d(1,qppm(1,1,iq), &
343                      psppm,psppm, &
344                      unatppm,vnatppm,fluxwppm,dtbon,3,3,3,1, &
345                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
346                      fill,dum,220.)
347                 !-------------------------------------------------------------
348
349                 !-------------------------------------------------------------
350                 !                           Semi Monotonic PPM
351                 !-------------------------------------------------------------
352              else if (iadv(iq).eq.17) then
353                 !                  Ss-prg PPM3d de Lin
354                 call ppm3d(1,qppm(1,1,iq), &
355                      psppm,psppm, &
356                      unatppm,vnatppm,fluxwppm,dtbon,4,4,4,1, &
357                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
358                      fill,dum,220.)
359                 !-------------------------------------------------------------
360
361                 !-------------------------------------------------------------
362                 !                         Positive Definite PPM
363                 !-------------------------------------------------------------
364              else if (iadv(iq).eq.18) then
365                 !                  Ss-prg PPM3d de Lin
366                 call ppm3d(1,qppm(1,1,iq), &
367                      psppm,psppm, &
368                      unatppm,vnatppm,fluxwppm,dtbon,5,5,5,1, &
369                      iim,jjp1,2,llm,apppm,bpppm,0.01,6400000, &
370                      fill,dum,220.)
371                 !-------------------------------------------------------------
372              endif
373           enddo
374           !-----------------------------------------------------------------
375           !               Ss-prg interface PPM3d-LMDZ.4
376           !-----------------------------------------------------------------
377           call interpost(q(1,1,iq),qppm(1,1,iq))
378        endif
379        !----------------------------------------------------------------------
380
381        !-----------------------------------------------------------------
382        ! On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1
383        ! et Nord j=1
384        !-----------------------------------------------------------------
385
386        !                  call traceurpole(q(1,1,iq),massem)
387
388        ! calcul du temps cpu pour un schema donne
389
390        !                  call clock(t_final)
391        !ym                  tps_cpu=t_final-t_initial
392        !ym                  cpuadv(iq)=cpuadv(iq)+tps_cpu
393
394     end DO
395
396     if (ok_iso_verif) then
397           write(*,*) 'advtrac 402'
398           call check_isotopes_seq(q,ip1jmp1,'advtrac 397')
399     endif !if (ok_iso_verif) then
400
401     !------------------------------------------------------------------
402     !   on reinitialise a zero les flux de masse cumules
403     !---------------------------------------------------
404     iadvtr=0
405
406  ENDIF ! if iadvtr.EQ.iapp_tracvl
407
408END SUBROUTINE advtrac
Note: See TracBrowser for help on using the repository browser.