source: LMDZ.3.3/trunk/libf/dyn3d/tracvl.F @ 3651

Last change on this file since 3651 was 344, checked in by lmdz, 23 years ago

Inclusion des modifs de D. Hauglustaine pour la version 1 de INCA
LF

  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 4.4 KB
Line 
1      SUBROUTINE tracvl(numvanle,
2     *                  iapp_tracvl,
3     *                  nq,
4     *                  pbaru,
5     *                  pbarv,
6     *                  p,
7     *                  masse,
8     *                  q,
9     *                  iapptrac,
10     *                  iadv1,
11     *                  teta,
12#ifdef INCA_CH4
13     *                  flxw,
14     *                  pk,
15     *                  mmt_adj,
16     *                  adv_flg)
17#else
18     *                  pk)
19#endif
20c
21c     Auteur :  F. Hourdin
22c
23c
24ccc   ..   Modif. P. Le Van  ( 20/12/97 )  ...
25c                 F. Codron     (10/99)
26
27c
28      IMPLICIT NONE
29c
30#include "dimensions.h"
31#include "paramet.h"
32#include "comconst.h"
33#include "comvert.h"
34#include "comgeom.h"
35
36c     .... Arguments  ....
37c
38      INTEGER numvanle, nq, iapp_tracvl, iapptrac, iadv1
39      REAL pbaru(ip1jmp1,llm),pbarv(ip1jm,llm)
40      REAL q(ip1jmp1,llm,nq),masse(ip1jmp1,llm)
41      REAL p( ip1jmp1,llmp1 ),teta(ip1jmp1,llm)
42      REAL pk(ip1jmp1,llm)
43#ifdef INCA_CH4
44      INTEGER, PARAMETER :: ntra   = 1
45      INTEGER, PARAMETER :: nprath = 1
46      INTEGER            :: adv_flg(nq)
47      REAL               :: mmt_adj(ip1jmp1,llm,nprath)
48      REAL, SAVE         :: qpente(ip1jmp1,llm,10,nprath)
49      REAL               :: flxw(ip1jmp1,llm)
50#endif
51c     ....  var. locales  .....
52c
53      REAL pbaruc(ip1jmp1,llm),pbarvc(ip1jm,llm)
54      REAL massem(ip1jmp1,llm),zdp(ip1jmp1)
55
56      REAL pbarug(ip1jmp1,llm),pbarvg(ip1jm,llm),wg(ip1jmp1,llm)
57
58
59      INTEGER iadvtr, numvan
60      INTEGER ij,l,iq
61      REAL zdpmin, zdpmax
62      EXTERNAL  minmax
63      SAVE iadvtr, massem, pbaruc, pbarvc, numvan
64      DATA iadvtr/0/
65
66      numvan = numvanle
67
68      IF(iadvtr.EQ.0) THEN
69         CALL initial0(ijp1llm,pbaruc)
70         CALL initial0(ijmllm,pbarvc)
71      ENDIF
72
73c   accumulation des flux de masse horizontaux
74      DO l=1,llm
75         DO ij = 1,ip1jmp1
76            pbaruc(ij,l) = pbaruc(ij,l) + pbaru(ij,l)
77         ENDDO
78         DO ij = 1,ip1jm
79            pbarvc(ij,l) = pbarvc(ij,l) + pbarv(ij,l)
80         ENDDO
81      ENDDO
82
83c   selection de la masse instantannee des mailles avant le transport.
84      IF(iadvtr.EQ.0) THEN
85
86         CALL SCOPY(ip1jmp1*llm,masse,1,massem,1)
87ccc         CALL filtreg ( massem ,jjp1, llm,-2, 2, .TRUE., 1 )
88c
89      ENDIF
90
91      iadvtr   = iadvtr+1
92      iapptrac = iadvtr
93
94
95c   Test pour savoir si on advecte a ce pas de temps
96      IF ( iadvtr.EQ.iapp_tracvl ) THEN
97
98cc   ..  Modif P.Le Van  ( 20/12/97 )  ....
99cc
100
101c   traitement des flux de masse avant advection.
102c     1. calcul de w
103c     2. groupement des mailles pres du pole.
104
105        CALL groupe( massem, pbaruc,pbarvc, pbarug,pbarvg,wg )
106
107#ifdef INCA_CH4
108      ! ... Flux de masse diaganostiques traceurs
109      flxw = wg / FLOAT(iapp_tracvl)
110#endif
111
112c  test sur l'eventuelle creation de valeurs negatives de la masse
113         DO l=1,llm-1
114            DO ij = iip2+1,ip1jm
115              zdp(ij) =    pbarug(ij-1,l)   - pbarug(ij,l)
116     s                  - pbarvg(ij-iip1,l) + pbarvg(ij,l)
117     s                  +       wg(ij,l+1)  - wg(ij,l)
118            ENDDO
119            CALL SCOPY( jjm -1 ,zdp(iip1+iip1),iip1,zdp(iip2),iip1 )
120            DO ij = iip2,ip1jm
121               zdp(ij)= zdp(ij)*dtvr/ massem(ij,l)
122            ENDDO
123
124
125            CALL minmax ( ip1jm-iip1, zdp(iip2), zdpmin,zdpmax )
126
127            IF(MAX(ABS(zdpmin),ABS(zdpmax)).GT.0.5) THEN
128            PRINT*,'WARNING DP/P l=',l,'  MIN:',zdpmin,
129     s        '   MAX:', zdpmax
130            ENDIF
131
132         ENDDO
133
134c   Advection proprement dite.
135c
136c   test sur iadv1 pour le schema de vapeur d'eau
137c
138         IF (numvanle.EQ.1.AND.iadv1.EQ.4) THEN
139           CALL vlspltqs( q(1,1,1), 2., massem, wg ,
140     *                 pbarug,pbarvg,dtvr,p,pk,teta )
141           numvan = 2
142         ENDIF
143
144#ifdef INCA_CH4
145      do iq = 2, 10
146        qpente(:,:,iq,1)=qpente(:,:,iq,1)*mmt_adj(:,:,1)
147      enddo
148#endif
149
150      DO iq = numvan, 2
151#ifdef INCA
152      IF (adv_flg(iq) == 0) CYCLE
153#endif
154      CALL vlsplt(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
155      ENDDO
156
157#ifdef INCA_CH4
158!     CALL prather(q(1,1,3),wg,massem,pbarug,pbarvg,ntra,qpente(1,1,1,1))
159#endif
160
161      DO  iq =3,nq
162#ifdef INCA
163      IF (adv_flg(iq) == 0) CYCLE
164#endif
165      CALL vlsplt(q(1,1,iq),2.,massem,wg,pbarug,pbarvg,dtvr)
166      ENDDO
167
168      iadvtr=0
169
170c   on reinitialise a zero les flux de masse cumules.
171
172      ENDIF ! if iadvtr.EQ.iapp_tracvl
173
174      RETURN
175      END
Note: See TracBrowser for help on using the repository browser.