/[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/Sources/dyn3d/advtrac.f revision 177 by guez, Wed Feb 24 18:44:07 2016 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 dimens_m, ONLY : iim, jjm, llm, nqmx
15      USE iniadvtrac_m, ONLY : iadv      USE iniadvtrac_m, ONLY : iadv
16        use massbar_m, only: massbar
17        USE paramet_m, ONLY : iip1, iip2, ijmllm, ijp1llm, ip1jm, ip1jmp1, jjp1, &
18             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
# Line 52  contains Line 52  contains
52      REAL qppm(iim*jjp1, llm, nqmx)      REAL qppm(iim*jjp1, llm, nqmx)
53      REAL fluxwppm(iim, jjp1, llm)      REAL fluxwppm(iim, jjp1, llm)
54      REAL apppm(llmp1), bpppm(llmp1)      REAL apppm(llmp1), bpppm(llmp1)
55      LOGICAL:: dum = .TRUE., fill = .TRUE.      LOGICAL:: fill = .TRUE.
56    
57      !-----------------------------------------------------------      !-----------------------------------------------------------
58    
# Line 72  contains Line 72  contains
72      END DO      END DO
73    
74      ! selection de la masse instantannee des mailles avant le transport.      ! selection de la masse instantannee des mailles avant le transport.
75      IF (iadvtr==0) THEN      IF (iadvtr==0) massem = masse
        CALL scopy(ip1jmp1*llm, masse, 1, massem, 1)  
     END IF  
76    
77      iadvtr = iadvtr + 1      iadvtr = iadvtr + 1
78      iapptrac = iadvtr      iapptrac = iadvtr
79    
80      ! Test pour savoir si on advecte a ce pas de temps      ! Test pour savoir si on advecte a ce pas de temps
81      IF (iadvtr==iapp_tracvl) THEN      IF (iadvtr == iapp_tracvl) THEN
82         ! traitement des flux de masse avant advection.         ! traitement des flux de masse avant advection.
83         ! 1. calcul de w         ! 1. calcul de w
84         ! 2. groupement des mailles pres du pole.         ! 2. groupement des mailles pres du pole.
85    
86         CALL groupe(massem, pbaruc, pbarvc, pbarug, pbarvg, wg)         CALL groupe(pbaruc, pbarvc, pbarug, pbarvg, wg)
87    
88         ! test sur l'eventuelle creation de valeurs negatives de la masse         ! test sur l'eventuelle creation de valeurs negatives de la masse
89         DO l = 1, llm - 1         DO l = 1, llm - 1
# Line 107  contains Line 105  contains
105    
106         ! Advection proprement dite         ! Advection proprement dite
107    
108         ! Calcul des moyennes basées sur la masse         ! Calcul des moyennes bas\'ees sur la masse
109         CALL massbar(massem, massebx, masseby)         CALL massbar(massem, massebx, masseby)
110    
111         ! Appel des sous programmes d'advection         ! Appel des sous programmes d'advection
112    
113         DO iq = 1, nqmx         DO iq = 1, nqmx
114            IF (iadv(iq)==0) CYCLE            select case (iadv(iq))
115              case (10)
116            ! Schema de Van Leer I MUSCL               ! Schema de Van Leer I MUSCL
   
           IF (iadv(iq)==10) THEN  
117               CALL vlsplt(q(:, :, iq), 2., massem, wg, pbarug, pbarvg, dtvr)               CALL vlsplt(q(:, :, iq), 2., massem, wg, pbarug, pbarvg, dtvr)
118               ! 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)  
119               ! Schema de Frederic Hourdin               ! Schema de Frederic Hourdin
           ELSE IF (iadv(iq)==12) THEN  
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 135  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, 1)                  CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 1)
128               END DO               END DO
129            ELSE IF (iadv(iq)==13) THEN            case (13)
130               ! Pas de temps adaptatif               ! Pas de temps adaptatif
131               CALL adaptdt(iadv(iq), dtbon, n, pbarug, massem)               CALL adaptdt(dtbon, n, pbarug, massem)
132               IF (n>1) THEN               IF (n>1) THEN
133                  WRITE (*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, &                  WRITE (*, *) 'WARNING horizontal dt=', dtbon, 'dtvr=', dtvr, &
134                       'n=', n                       'n=', n
# Line 145  contains Line 136  contains
136               DO indice = 1, n               DO indice = 1, n
137                  CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 2)                  CALL advn(q(1, 1, iq), massem, wg, pbarug, pbarvg, dtbon, 2)
138               END DO               END DO
139               ! Schema de pente SLOPES           case (14)
140            ELSE IF (iadv(iq)==20) THEN               ! Schema "pseudo amont" + test sur humidite specifique
141               CALL pentes_ini(q(1, 1, iq), wg, massem, pbarug, pbarvg, 0)               ! pour la vapeur d'eau. F. Codron
142               ! Schema de Prather               CALL vlspltqs(q(1, 1, 1), 2., massem, wg, pbarug, pbarvg, dtvr, &
143            ELSE IF (iadv(iq)==30) THEN                    p, pk, teta)
144               ! 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  
145         END DO         END DO
146    
147         ! 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.177
  ViewVC Help
Powered by ViewVC 1.1.21