source: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/integrd_p.F @ 1219

Last change on this file since 1219 was 1114, checked in by jghattas, 16 years ago

Creation du module infotrac:

  • contient les variables de advtrac.h
  • contient la subroutine iniadvtrac renommer en infotrac_init
  • le nombre des traceurs est lu dans tracer.def en dynamique (ou par default ou recu par INCA)
  • ce module est utilise dans la dynamique et la physique
  • contient aussi la variable nbtr qui avant etait stockee dans dimphy

Le fichier advtrac.h n'existe plus.
La compilation ne prend plus en compte le nombre de traceur.

/JG
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.3 KB
RevLine 
[630]1!
2! $Header$
3!
4      SUBROUTINE integrd_p
5     $  (  nq,vcovm1,ucovm1,tetam1,psm1,massem1,
[764]6     $     dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps0,masse,phis,finvmaold)
[630]7      USE parallel
8      IMPLICIT NONE
9
10
11c=======================================================================
12c
13c   Auteur:  P. Le Van
14c   -------
15c
16c   objet:
17c   ------
18c
19c   Incrementation des tendances dynamiques
20c
21c=======================================================================
22c-----------------------------------------------------------------------
23c   Declarations:
24c   -------------
25
26#include "dimensions.h"
27#include "paramet.h"
28#include "comconst.h"
29#include "comgeom.h"
30#include "comvert.h"
31#include "logic.h"
32#include "temps.h"
33#include "serre.h"
34
35c   Arguments:
36c   ----------
37
38      INTEGER nq
39
40      REAL vcov(ip1jm,llm),ucov(ip1jmp1,llm),teta(ip1jmp1,llm)
41      REAL q(ip1jmp1,llm,nq)
[764]42      REAL ps0(ip1jmp1),masse(ip1jmp1,llm),phis(ip1jmp1)
[630]43
44      REAL vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm)
45      REAL tetam1(ip1jmp1,llm),psm1(ip1jmp1),massem1(ip1jmp1,llm)
46
47      REAL dv(ip1jm,llm),du(ip1jmp1,llm)
48      REAL dteta(ip1jmp1,llm),dp(ip1jmp1)
49      REAL dq(ip1jmp1,llm,nq), finvmaold(ip1jmp1,llm)
50
51c   Local:
52c   ------
53
54      REAL vscr( ip1jm ),uscr( ip1jmp1 ),hscr( ip1jmp1 ),pscr(ip1jmp1)
55      REAL massescr( ip1jmp1,llm ), finvmasse(ip1jmp1,llm)
[764]56      REAL,SAVE :: p(ip1jmp1,llmp1)
[630]57      REAL tpn,tps,tppn(iim),tpps(iim)
58      REAL qpn,qps,qppn(iim),qpps(iim)
[985]59      REAL,SAVE :: deltap( ip1jmp1,llm )
[630]60
61      INTEGER  l,ij,iq
62
63      REAL SSUM
64      EXTERNAL SSUM
65      INTEGER ijb,ije,jjb,jje
[764]66      REAL,SAVE :: ps(ip1jmp1)
[985]67      LOGICAL :: checksum
68      INTEGER :: stop_it
[630]69c-----------------------------------------------------------------------
[985]70c$OMP BARRIER     
[630]71      if (pole_nord) THEN
[764]72c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]73        DO  l = 1,llm
74          DO  ij = 1,iip1
75           ucov(    ij    , l) = 0.
76           uscr(     ij      ) = 0.
77           ENDDO
78        ENDDO
[764]79c$OMP END DO NOWAIT       
[630]80      ENDIF
81
82      if (pole_sud) THEN
[764]83c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
[630]84        DO  l = 1,llm
85          DO  ij = 1,iip1
86           ucov( ij +ip1jm, l) = 0.
87           uscr( ij +ip1jm   ) = 0.
88          ENDDO
89        ENDDO
[764]90c$OMP END DO NOWAIT     
[630]91      ENDIF
92
93c    ............    integration  de       ps         ..............
94
95c      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
96
97      ijb=ij_begin
98      ije=ij_end
[764]99c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
100      DO  l = 1,llm
101        massescr(ijb:ije,l)=masse(ijb:ije,l)
102      ENDDO
103c$OMP END DO NOWAIT
104
[985]105c$OMP DO SCHEDULE(STATIC)
[630]106      DO 2 ij = ijb,ije
[764]107       pscr (ij)    = ps0(ij)
[630]108       ps (ij)      = psm1(ij) + dt * dp(ij)
109   2  CONTINUE
[985]110c$OMP END DO 
111c$OMP BARRIER
112c --> ici synchro OPENMP pour ps
113       
114      checksum=.TRUE.
115      stop_it=0
116
117c$OMP DO SCHEDULE(STATIC)
[630]118      DO ij = ijb,ije
[985]119         IF( ps(ij).LT.0. ) THEN
120           IF (checksum) stop_it=ij
121           checksum=.FALSE.
122         ENDIF
123       ENDDO
124c$OMP END DO NOWAIT
125       
126        IF( .NOT. checksum ) THEN
127         PRINT*,' Au point ij = ',stop_it, ' , pression sol neg. '
128     &         , ps(stop_it)
[630]129         STOP' dans integrd'
130        ENDIF
[985]131
[630]132c
[985]133C$OMP MASTER
[630]134      if (pole_nord) THEN
135     
136        DO  ij    = 1, iim
137         tppn(ij) = aire(   ij   ) * ps(  ij    )
138        ENDDO
139         tpn      = SSUM(iim,tppn,1)/apoln
140        DO ij   = 1, iip1
141         ps(   ij   )  = tpn
142        ENDDO
143     
144      ENDIF
145     
146      if (pole_sud) THEN
147     
148        DO  ij    = 1, iim
149         tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
150        ENDDO
151         tps      = SSUM(iim,tpps,1)/apols
152        DO ij   = 1, iip1
153         ps(ij+ip1jm)  = tps
154        ENDDO
155     
156      ENDIF
[764]157c$OMP END MASTER
158c$OMP BARRIER
[630]159c
160c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
161c
[764]162
[630]163      CALL pression_p ( ip1jmp1, ap, bp, ps, p )
[764]164c$OMP BARRIER
[630]165      CALL massdair_p (     p  , masse         )
166
167c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
168      ijb=ij_begin
169      ije=ij_end
[764]170     
171c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
172      DO  l = 1,llm
173        finvmasse(ijb:ije,l)=masse(ijb:ije,l)
174      ENDDO
175c$OMP END DO NOWAIT
[630]176
177      jjb=jj_begin
178      jje=jj_end
179      CALL filtreg_p( finvmasse,jjb,jje, jjp1, llm, -2, 2, .TRUE., 1  )
180c
181
182c    ............   integration  de  ucov, vcov,  h     ..............
183
[764]184c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]185      DO 10 l = 1,llm
186     
187      ijb=ij_begin
188      ije=ij_end
189      if (pole_nord) ijb=ij_begin+iip1
190      if (pole_sud)  ije=ij_end-iip1
191     
192      DO 4 ij = ijb,ije
193      uscr( ij )   =  ucov( ij,l )
194      ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
195   4  CONTINUE
196
197      ijb=ij_begin
198      ije=ij_end
199      if (pole_sud)  ije=ij_end-iip1
200     
201      DO 5 ij = ijb,ije
202      vscr( ij )   =  vcov( ij,l )
203      vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
204   5  CONTINUE
205     
206      ijb=ij_begin
207      ije=ij_end
208     
209      DO 6 ij = ijb,ije
210      hscr( ij )    =  teta(ij,l)
211      teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l)
212     $                + dt * dteta(ij,l) / masse(ij,l)
213   6  CONTINUE
214
215c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
216c
217c
218      IF (pole_nord) THEN
219       
220        DO  ij   = 1, iim
221          tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
222        ENDDO
223          tpn      = SSUM(iim,tppn,1)/apoln
224
225        DO ij   = 1, iip1
226          teta(   ij   ,l)  = tpn
227        ENDDO
228     
229      ENDIF
230     
231      IF (pole_sud) THEN
232       
233        DO  ij   = 1, iim
234          tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
235        ENDDO
236          tps      = SSUM(iim,tpps,1)/apols
237
238        DO ij   = 1, iip1
239          teta(ij+ip1jm,l)  = tps
240        ENDDO
241     
242      ENDIF
243c
244
245      IF(leapf)  THEN
246c         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
247c         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
248c         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
249        ijb=ij_begin
250        ije=ij_end
251        ucovm1(ijb:ije,l)=uscr(ijb:ije)
252        tetam1(ijb:ije,l)=hscr(ijb:ije)
253        if (pole_sud) ije=ij_end-iip1
254        vcovm1(ijb:ije,l)=vscr(ijb:ije)
255     
256      END IF
257
258  10  CONTINUE
[764]259c$OMP END DO NOWAIT
[630]260
261c
262c   .......  integration de   q   ......
263c
264      ijb=ij_begin
265      ije=ij_end
266     
[985]267c$OMP BARRIER
268c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]269         DO l = 1, llm
270          DO ij = ijb, ije
271           deltap(ij,l) =  p(ij,l) - p(ij,l+1)
272          ENDDO
273         ENDDO
[985]274c$OMP END DO NOWAIT
275c$OMP BARRIER
[630]276
277         CALL qminimum_p( q, nq, deltap )
278c
279c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
280c
[985]281c$OMP BARRIER
[630]282      IF (pole_nord) THEN
283     
284        DO iq = 1, nq
[985]285       
286c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]287          DO l = 1, llm
288 
289             DO ij = 1, iim
290               qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
291             ENDDO
292               qpn  =  SSUM(iim,qppn,1)/apoln
293     
294             DO ij = 1, iip1
295               q(   ij   ,l,iq)  = qpn
296             ENDDO   
297 
298          ENDDO
[985]299c$OMP END DO NOWAIT
300
[630]301        ENDDO
302     
303      ENDIF
304
305      IF (pole_sud) THEN
306     
307        DO iq = 1, nq
[985]308
309c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
[630]310          DO l = 1, llm
311 
312             DO ij = 1, iim
313               qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
314             ENDDO
315               qps  =  SSUM(iim,qpps,1)/apols
316 
317             DO ij = 1, iip1
318               q(ij+ip1jm,l,iq)  = qps
319             ENDDO   
320 
321          ENDDO
[985]322c$OMP END DO NOWAIT
323
[630]324        ENDDO
325     
326      ENDIF
[764]327     
[630]328c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
[764]329
330c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
331      DO l = 1, llm     
332        finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)       
333      ENDDO
334c$OMP END DO NOWAIT
[630]335c
336c
337c     .....   FIN  de l'integration  de   q    .......
338
33915    continue
340
[985]341c$OMP DO SCHEDULE(STATIC)
342      DO ij=ijb,ije 
343        ps0(ij)=ps(ij)
344      ENDDO
345c$OMP END DO NOWAIT
346
[630]347c    .................................................................
348
349
350      IF( leapf )  THEN
351c       CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
352c       CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
[985]353c$OMP DO SCHEDULE(STATIC)
354      DO ij=ijb,ije 
355        psm1(ij)=pscr(ij)
356      ENDDO
357c$OMP END DO NOWAIT
[764]358
359c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
360          DO l = 1, llm
361            massem1(ijb:ije,l)=massescr(ijb:ije,l)
362          ENDDO
363c$OMP END DO NOWAIT       
[630]364      END IF
[985]365c$OMP BARRIER
[630]366      RETURN
367      END
Note: See TracBrowser for help on using the repository browser.