source: LMDZ5/branches/testing/libf/dyn3d/advtrac.F90 @ 3046

Last change on this file since 3046 was 2641, checked in by Laurent Fairhead, 8 years ago

Merged trunk changes r2593:2640 into testing branch

  • 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
RevLine 
[1279]1! $Id: advtrac.F90 2641 2016-09-29 21:26:46Z fairhead $
[1146]2
[1549]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  !
[2298]11  USE infotrac, ONLY: nqtot, iadv,nqperes,ok_iso_verif
[1999]12  USE control_mod, ONLY: iapp_tracvl, day_step
[2641]13  USE comconst_mod, ONLY: dtvr
[524]14
[1549]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"
[524]23
[1549]24  !-------------------------------------------------------------------
25  !     Arguments
26  !-------------------------------------------------------------------
[1999]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  !-------------------------------------------------------------------
[1549]37  !     Ajout PPM
38  !--------------------------------------------------------
39  REAL massebx(ip1jmp1,llm),masseby(ip1jm,llm)
40  !-------------------------------------------------------------
41  !     Variables locales
42  !-------------------------------------------------------------
[524]43
[1549]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./
[524]68
[1549]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)
[524]74
[1549]75  IF(iadvtr.EQ.0) THEN
[2298]76     pbaruc(:,:)=0
77     pbarvc(:,:)=0
[1549]78  ENDIF
[524]79
[1549]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
[524]89
[1549]90  !   selection de la masse instantannee des mailles avant le transport.
91  IF(iadvtr.EQ.0) THEN
[524]92
[1549]93     CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
94     !cc         CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
95     !
96  ENDIF
[524]97
[1549]98  iadvtr   = iadvtr+1
99  iapptrac = iadvtr
[524]100
101
[1549]102  !   Test pour savoir si on advecte a ce pas de temps
103  IF ( iadvtr.EQ.iapp_tracvl ) THEN
[524]104
[1549]105     !c   ..  Modif P.Le Van  ( 20/12/97 )  ....
106     !c
[524]107
[1549]108     !   traitement des flux de masse avant advection.
109     !     1. calcul de w
110     !     2. groupement des mailles pres du pole.
[524]111
[1549]112     CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
[524]113
[1549]114     ! ... Flux de masse diaganostiques traceurs
115     flxw = wg / REAL(iapp_tracvl)
[524]116
[1549]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
[524]128
129
[1549]130        CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
[524]131
[1549]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
[1279]136
[1549]137     ENDDO
[1279]138
139
[1549]140     !-------------------------------------------------------------------
141     ! Calcul des criteres CFL en X, Y et Z
142     !-------------------------------------------------------------------
[1279]143
[1549]144     if (countcfl == 0. ) then
145        cflxmax(:)=0.
146        cflymax(:)=0.
147        cflzmax(:)=0.
148     endif
[1279]149
[1549]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
[1279]168
[1549]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
[1279]178
[1549]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
[1279]195!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[1549]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
[1279]199!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[1549]200     if (countcfl==day_step) then
201        do l=1,llm
[1864]202           write(lunout,*) 'L, CFL[xyz]max:', l, cflxmax(l), cflymax(l), &
203                cflzmax(l)
[1549]204        enddo
205        countcfl=0
206     endif
[524]207
[1549]208     !-------------------------------------------------------------------
209     !   Advection proprement dite (Modification Le Croller (07/2001)
210     !-------------------------------------------------------------------
[524]211
[1549]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     !-----------------------------------------------------------
[2298]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
[1549]227        !        call clock(t_initial)
[524]228        if(iadv(iq) == 0) cycle
[1549]229        !   ----------------------------------------------------------------
230        !   Schema de Van Leer I MUSCL
231        !   ----------------------------------------------------------------
[524]232        if(iadv(iq).eq.10) THEN
[2298]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           
[1549]238           !   ----------------------------------------------------------------
239           !   Schema "pseudo amont" + test sur humidite specifique
240           !    pour la vapeur d'eau. F. Codron
241           !   ----------------------------------------------------------------
[524]242        else if(iadv(iq).eq.14) then
[1549]243           !
[2298]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           
[1549]248           !   ----------------------------------------------------------------
249           !   Schema de Frederic Hourdin
250           !   ----------------------------------------------------------------
[524]251        else if(iadv(iq).eq.12) then
[1549]252           !            Pas de temps adaptatif
[524]253           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
254           if (n.GT.1) then
[1549]255              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
256                   dtvr,'n=',n
[524]257           endif
258           do indice=1,n
[1549]259              call advn(q(1,1,iq),massem,wg,pbarug,pbarvg,dtbon,1)
[524]260           end do
261        else if(iadv(iq).eq.13) then
[1549]262           !            Pas de temps adaptatif
[524]263           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
264           if (n.GT.1) then
[1549]265              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
266                   dtvr,'n=',n
[524]267           endif
[1549]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           !   ----------------------------------------------------------------
[524]274        else if (iadv(iq).eq.20) then
[1549]275           call pentes_ini (q(1,1,iq),wg,massem,pbarug,pbarvg,0)
[524]276
[1549]277           !   ----------------------------------------------------------------
278           !   Schema de Prather
279           !   ----------------------------------------------------------------
[524]280        else if (iadv(iq).eq.30) then
[1549]281           !            Pas de temps adaptatif
[524]282           call adaptdt(iadv(iq),dtbon,n,pbarug,massem)
283           if (n.GT.1) then
[1549]284              write(*,*) 'WARNING horizontal dt=',dtbon,'dtvr=', &
285                   dtvr,'n=',n
[524]286           endif
[1549]287           call  prather(q(1,1,iq),wg,massem,pbarug,pbarvg, &
288                n,dtbon)
[960]289
[1549]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
[524]295
[1549]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
[524]312           enddo
[1549]313           if (CFLmaxz.GE.1) then
314              write(*,*) 'WARNING vertical','CFLmaxz=', CFLmaxz
315           endif
[524]316
[1549]317           !-----------------------------------------------------------
318           !        Ss-prg interface LMDZ.4->PPM3d
319           !-----------------------------------------------------------
[524]320
[1549]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)
[524]324
[1549]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.)
[524]336
[1549]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                 !-------------------------------------------------------------
[524]348
[1549]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                 !-------------------------------------------------------------
[524]360
[1549]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        !----------------------------------------------------------------------
[524]380
[1549]381        !-----------------------------------------------------------------
382        ! On impose une seule valeur du traceur au pôle Sud j=jjm+1=jjp1
383        ! et Nord j=1
384        !-----------------------------------------------------------------
[524]385
[1549]386        !                  call traceurpole(q(1,1,iq),massem)
[524]387
[1549]388        ! calcul du temps cpu pour un schema donne
[524]389
[1549]390        !                  call clock(t_final)
391        !ym                  tps_cpu=t_final-t_initial
392        !ym                  cpuadv(iq)=cpuadv(iq)+tps_cpu
[524]393
[1549]394     end DO
[524]395
[2298]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
[524]400
[1549]401     !------------------------------------------------------------------
402     !   on reinitialise a zero les flux de masse cumules
403     !---------------------------------------------------
404     iadvtr=0
[524]405
[1549]406  ENDIF ! if iadvtr.EQ.iapp_tracvl
[524]407
[1549]408END SUBROUTINE advtrac
Note: See TracBrowser for help on using the repository browser.