source: LMDZ4/branches/V3_test/libf/dyn3dpar/integrd_p.F @ 782

Last change on this file since 782 was 709, checked in by Laurent Fairhead, 18 years ago

Nouvelles versions de la dynamique YM
LF

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