/[lmdze]/trunk/dyn3d/advtrac.f
ViewVC logotype

Diff of /trunk/dyn3d/advtrac.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/libf/dyn3d/advtrac.f90 revision 44 by guez, Wed Apr 13 12:29:18 2011 UTC trunk/dyn3d/advtrac.f revision 265 by guez, Tue Mar 20 09:35:59 2018 UTC
# Line 9  contains Line 9  contains
9      ! From dyn3d/advtrac.F, version 1.4 2005/04/13 08:58:34      ! From dyn3d/advtrac.F, version 1.4 2005/04/13 08:58:34
10      ! Author: F. Hourdin      ! Author: F. Hourdin
11    
     USE dimens_m, ONLY : iim, jjm, llm, nqmx  
     USE paramet_m, ONLY : iip1, iip2, ijmllm, ijp1llm, ip1jm, ip1jmp1, jjp1, &  
          llmp1  
12      USE comconst, ONLY : dtvr      USE comconst, ONLY : dtvr
13      USE conf_gcm_m, ONLY : iapp_tracvl      USE conf_gcm_m, ONLY : iapp_tracvl
14        USE dimensions, ONLY : jjm, llm, nqmx
15        use groupe_m, only: groupe
16      USE iniadvtrac_m, ONLY : iadv      USE iniadvtrac_m, ONLY : iadv
17        use massbar_m, only: massbar
18        USE paramet_m, ONLY : iip1, iip2, ijmllm, ijp1llm, ip1jm, ip1jmp1, llmp1
19        use vlsplt_m, only: vlsplt
20        use vlspltqs_m, only: vlspltqs
21    
22      ! Arguments      REAL, intent(in):: pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)
   
     INTEGER iapptrac  
     REAL pbaru(ip1jmp1, llm), pbarv(ip1jm, llm)  
     REAL, intent(inout):: q(ip1jmp1, llm, nqmx)  
     real masse(ip1jmp1, llm)  
23      REAL, intent(in):: p(ip1jmp1, llmp1)      REAL, intent(in):: p(ip1jmp1, llmp1)
24        real, intent(in):: masse(ip1jmp1, llm)
25        REAL, intent(inout):: q(ip1jmp1, llm, nqmx)
26        INTEGER, intent(out):: iapptrac
27      real, intent(in):: teta(ip1jmp1, llm)      real, intent(in):: teta(ip1jmp1, llm)
28      REAL pk(ip1jmp1, llm)      REAL, intent(in):: pk(ip1jmp1, llm)
29    
30      ! Variables locales      ! Variables locales
31    
# Line 33  contains Line 34  contains
34      REAL, save:: massem(ip1jmp1, llm)      REAL, save:: massem(ip1jmp1, llm)
35      real zdp(ip1jmp1)      real zdp(ip1jmp1)
36      REAL pbarug(ip1jmp1, llm), pbarvg(ip1jm, llm), wg(ip1jmp1, llm)      REAL pbarug(ip1jmp1, llm), pbarvg(ip1jm, llm), wg(ip1jmp1, llm)
     REAL cpuadv(nqmx)  
37    
38      INTEGER:: iadvtr = 0      INTEGER:: iadvtr = 0
39      INTEGER ij, l, iq      INTEGER ij, l, iq
40      REAL zdpmin, zdpmax      REAL zdpmin, zdpmax
41      EXTERNAL minmax      EXTERNAL minmax
42    
     ! Rajouts pour PPM  
   
43      INTEGER indice, n      INTEGER indice, n
44      ! Pas de temps adaptatif pour que CFL < 1      ! Pas de temps adaptatif pour que CFL < 1
45      REAL dtbon      REAL dtbon
     REAL cflmaxz ! CFL maximum  
     real aaa, bbb  
     REAL psppm(iim, jjp1) ! pression au sol  
     REAL unatppm(iim, jjp1, llm), vnatppm(iim, jjp1, llm)  
     REAL qppm(iim*jjp1, llm, nqmx)  
     REAL fluxwppm(iim, jjp1, llm)  
     REAL apppm(llmp1), bpppm(llmp1)  
     LOGICAL:: dum = .TRUE., fill = .TRUE.  
46    
47      !-----------------------------------------------------------      !-----------------------------------------------------------
48    
# Line 72  contains Line 62  contains
62      END DO      END DO
63    
64      ! selection de la masse instantannee des mailles avant le transport.      ! selection de la masse instantannee des mailles avant le transport.
65      IF (iadvtr==0) THEN      IF (iadvtr==0) massem = masse
        CALL scopy(ip1jmp1*llm, masse, 1, massem, 1)  
     END IF  
66    
67      iadvtr = iadvtr + 1      iadvtr = iadvtr + 1
68      iapptrac = iadvtr      iapptrac = iadvtr
69    
70      ! Test pour savoir si on advecte a ce pas de temps      ! Test pour savoir si on advecte a ce pas de temps
71      IF (iadvtr==iapp_tracvl) THEN      IF (iadvtr == iapp_tracvl) THEN
72         ! traitement des flux de masse avant advection.         ! traitement des flux de masse avant advection.
73         ! 1. calcul de w         ! 1. calcul de w
74         ! 2. groupement des mailles pres du pole.         ! 2. groupement des mailles pres du pole.
75    
76         CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)         CALL groupe(pbaruc, pbarvc, pbarug, pbarvg, wg)
77    
78         ! test sur l'eventuelle creation de valeurs negatives de la masse         ! test sur l'eventuelle creation de valeurs negatives de la masse
79         DO l = 1, llm - 1         DO l = 1, llm - 1
# Line 107  contains Line 95  contains
95    
96         ! Advection proprement dite         ! Advection proprement dite
97    
98         ! Calcul des moyennes basées sur la masse         ! Calcul des moyennes bas\'ees sur la masse
99         CALL massbar(massem, massebx, masseby)         CALL massbar(massem, massebx, masseby)
100    
101         ! Appel des sous programmes d'advection         ! Appel des sous programmes d'advection
102    
103         DO iq = 1, nqmx         DO iq = 1, nqmx
104            IF (iadv(iq)==0) CYCLE            select case (iadv(iq))
105              case (10)
106            ! Schema de Van Leer I MUSCL               ! Schema de Van Leer I MUSCL
   
           IF (iadv(iq)==10) THEN  
107               CALL vlsplt(q(:, :, iq), 2., massem, wg, pbarug, pbarvg, dtvr)               CALL vlsplt(q(:, :, iq), 2., massem, wg, pbarug, pbarvg, dtvr)
108               ! Schema "pseudo amont" + test sur humidite specifique             case (12)
              ! pour la vapeur d'eau. F. Codron  
           ELSE IF (iadv(iq)==14) THEN  
              CALL vlspltqs(q(1, 1, 1), 2., massem, wg, pbarug, pbarvg, dtvr, &  
                   p, pk, teta)  
109               ! Schema de Frederic Hourdin               ! Schema de Frederic Hourdin
           ELSE IF (iadv(iq)==12) THEN  
110               ! Pas de temps adaptatif               ! Pas de temps adaptatif
111               CALL adaptdt(iadv(iq), dtbon, n, pbarug, massem)               CALL adaptdt(dtbon, n, pbarug, massem)
112               IF (n>1) THEN               IF (n>1) THEN
113                  WRITE (*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, &                  WRITE (*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, &
114                       'n=', n                       'n=', n
# Line 135  contains Line 116  contains
116               DO indice = 1, n               DO indice = 1, n
117                  CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 1)                  CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 1)
118               END DO               END DO
119            ELSE IF (iadv(iq)==13) THEN            case (13)
120               ! Pas de temps adaptatif               ! Pas de temps adaptatif
121               CALL adaptdt(iadv(iq), dtbon, n, pbarug, massem)               CALL adaptdt(dtbon, n, pbarug, massem)
122               IF (n>1) THEN               IF (n>1) THEN
123                  WRITE (*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, &                  WRITE (*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, &
124                       'n=', n                       'n=', n
# Line 145  contains Line 126  contains
126               DO indice = 1, n               DO indice = 1, n
127                  CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 2)                  CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 2)
128               END DO               END DO
129               ! Schema de pente SLOPES           case (14)
130            ELSE IF (iadv(iq)==20) THEN               ! Schema "pseudo amont" + test sur humidite specifique
131               CALL pentes_ini(q(1, 1, iq), wg, massem, pbarug, pbarvg, 0)               ! pour la vapeur d'eau. F. Codron
132               ! Schema de Prather               CALL vlspltqs(q(1, 1, 1), 2., massem, wg, pbarug, pbarvg, dtvr, &
133            ELSE IF (iadv(iq)==30) THEN                    p, pk, teta)
134               ! Pas de temps adaptatif            END select
              CALL adaptdt(iadv(iq), dtbon, n, pbarug, massem)  
              IF (n>1) THEN  
                 WRITE (*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, &  
                      'n=', n  
              END IF  
              CALL prather(q(1, 1, iq), wg, massem, pbarug, pbarvg, n, dtbon)  
              ! Schemas PPM Lin et Rood  
           ELSE IF (iadv(iq)==11 .OR. (iadv(iq)>=16 .AND. iadv(iq)<=18)) THEN  
              ! Test sur le flux horizontal  
              ! Pas de temps adaptatif  
              CALL adaptdt(iadv(iq), dtbon, n, pbarug, massem)  
              IF (n>1) THEN  
                 WRITE (*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, &  
                      'n=', n  
              END IF  
              ! Test sur le flux vertical  
              cflmaxz = 0.  
              DO l = 2, llm  
                 DO ij = iip2, ip1jm  
                    aaa = wg(ij, l)*dtvr/massem(ij, l)  
                    cflmaxz = max(cflmaxz, aaa)  
                    bbb = -wg(ij, l)*dtvr/massem(ij, l-1)  
                    cflmaxz = max(cflmaxz, bbb)  
                 END DO  
              END DO  
              IF (cflmaxz>=1) THEN  
                 WRITE (*, *) 'WARNING vertical', 'CFLmaxz=', cflmaxz  
              END IF  
   
              ! Ss-prg interface LMDZ.4->PPM3d  
              CALL interpre(q(1, 1, iq), qppm(1, 1, iq), wg, fluxwppm, massem, &  
                   apppm, bpppm, massebx, masseby, pbarug, pbarvg, unatppm, &  
                   vnatppm, psppm)  
   
              DO indice = 1, n  
                 ! VL (version PPM) horiz. et PPM vert.  
                 IF (iadv(iq)==11) THEN  
                    ! Ss-prg PPM3d de Lin  
                    CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, &  
                         vnatppm, fluxwppm, dtbon, 2, 2, 2, 1, iim, jjp1, 2, &  
                         llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)  
                    ! Monotonic PPM  
                 ELSE IF (iadv(iq)==16) THEN  
                    ! Ss-prg PPM3d de Lin  
                    CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, &  
                         vnatppm, fluxwppm, dtbon, 3, 3, 3, 1, iim, jjp1, 2, &  
                         llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)  
                    ! Semi Monotonic PPM  
                 ELSE IF (iadv(iq)==17) THEN  
                    ! Ss-prg PPM3d de Lin  
                    CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, &  
                         vnatppm, fluxwppm, dtbon, 4, 4, 4, 1, iim, jjp1, 2, &  
                         llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)  
                    ! Positive Definite PPM  
                 ELSE IF (iadv(iq)==18) THEN  
                    ! Ss-prg PPM3d de Lin  
                    CALL ppm3d(1, qppm(1, 1, iq), psppm, psppm, unatppm, &  
                         vnatppm, fluxwppm, dtbon, 5, 5, 5, 1, iim, jjp1, 2, &  
                         llm, apppm, bpppm, 0.01, 6400000, fill, dum, 220.)  
                 END IF  
              END DO  
   
              ! Ss-prg interface PPM3d-LMDZ.4  
              CALL interpost(q(1, 1, iq), qppm(1, 1, iq))  
           END IF  
135         END DO         END DO
136    
137         ! on reinitialise a zero les flux de masse cumules         ! on reinitialise a zero les flux de masse cumules
Legend:
Removed from v.44  
changed lines
  Added in v.265
  ViewVC Help
Powered by ViewVC 1.1.21