source: LMDZ5/trunk/libf/dyn3dmem/integrd_loc.F @ 1632

Last change on this file since 1632 was 1632, checked in by Laurent Fairhead, 12 years ago

Import initial du répertoire dyn3dmem

Attention! ceci n'est qu'une version préliminaire du code "basse mémoire":
le code contenu dans ce répertoire est basé sur la r1320 et a donc besoin
d'être mis à jour par rapport à la dynamique parallèle d'aujourd'hui.
Ce code est toutefois mis à disposition pour circonvenir à des problèmes
de mémoire que certaines configurations du modèle pourraient rencontrer.
Dans l'état, il compile et tourne sur vargas et au CCRT

Initial import of dyn3dmem

Warning! this is just a preliminary version of the memory light code:
it is based on r1320 of the code and thus needs to be updated before
it can replace the present dyn3dpar code. It is nevertheless put at your
disposal to circumvent some memory problems some LMDZ configurations may
encounter. In its present state, it will compile and run on vargas and CCRT

File size: 9.8 KB
Line 
1!
2! $Id: integrd_p.F 1299 2010-01-20 14:27:21Z fairhead $
3!
4      SUBROUTINE integrd_loc
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      USE control_mod
9      USE mod_filtreg_p
10      USE write_field_loc
11      USE write_field
12      USE integrd_mod
13      IMPLICIT NONE
14
15
16c=======================================================================
17c
18c   Auteur:  P. Le Van
19c   -------
20c
21c   objet:
22c   ------
23c
24c   Incrementation des tendances dynamiques
25c
26c=======================================================================
27c-----------------------------------------------------------------------
28c   Declarations:
29c   -------------
30
31#include "dimensions.h"
32#include "paramet.h"
33#include "comconst.h"
34#include "comgeom.h"
35#include "comvert.h"
36#include "logic.h"
37#include "temps.h"
38#include "serre.h"
39      include 'mpif.h'
40
41c   Arguments:
42c   ----------
43
44      INTEGER nq
45
46      REAL vcov(ijb_v:ije_v,llm),ucov(ijb_u:ije_u,llm)
47      REAL teta(ijb_u:ije_u,llm)
48      REAL q(ijb_u:ije_u,llm,nq)
49      REAL ps0(ijb_u:ije_u),masse(ijb_u:ije_u,llm),phis(ijb_u:ije_u)
50
51      REAL vcovm1(ijb_v:ije_v,llm),ucovm1(ijb_u:ije_u,llm)
52      REAL tetam1(ijb_u:ije_u,llm),psm1(ijb_u:ije_u)
53      REAL massem1(ijb_u:ije_u,llm)
54
55      REAL dv(ijb_v:ije_v,llm),du(ijb_u:ije_u,llm)
56      REAL dteta(ijb_u:ije_u,llm),dp(ijb_u:ije_u)
57      REAL dq(ijb_u:ije_u,llm,nq), finvmaold(ijb_u:ije_u,llm)
58
59c   Local:
60c   ------
61
62      REAL vscr( ijb_v:ije_v ),uscr( ijb_u:ije_u )
63      REAL hscr( ijb_u:ije_u ),pscr(ijb_u:ije_u)
64      REAL massescr( ijb_u:ije_u,llm ), finvmasse(ijb_u:ije_u,llm)
65      REAL tpn,tps,tppn(iim),tpps(iim)
66      REAL qpn,qps,qppn(iim),qpps(iim)
67
68      INTEGER  l,ij,iq
69
70      REAL SSUM
71      EXTERNAL SSUM
72      INTEGER ijb,ije,jjb,jje
73      LOGICAL :: checksum
74      LOGICAL,SAVE :: checksum_all=.TRUE.
75      INTEGER :: stop_it
76      INTEGER :: ierr,j
77
78c-----------------------------------------------------------------------
79c$OMP BARRIER     
80      if (pole_nord) THEN
81c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
82        DO  l = 1,llm
83          DO  ij = 1,iip1
84           ucov(    ij    , l) = 0.
85           uscr(     ij      ) = 0.
86           ENDDO
87        ENDDO
88c$OMP END DO NOWAIT       
89      ENDIF
90
91      if (pole_sud) THEN
92c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
93        DO  l = 1,llm
94          DO  ij = 1,iip1
95           ucov( ij +ip1jm, l) = 0.
96           uscr( ij +ip1jm   ) = 0.
97          ENDDO
98        ENDDO
99c$OMP END DO NOWAIT     
100      ENDIF
101
102c    ............    integration  de       ps         ..............
103
104c      CALL SCOPY(ip1jmp1*llm, masse, 1, massescr, 1)
105
106      ijb=ij_begin
107      ije=ij_end
108c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
109      DO  l = 1,llm
110        massescr(ijb:ije,l)=masse(ijb:ije,l)
111      ENDDO
112c$OMP END DO NOWAIT
113
114c$OMP DO SCHEDULE(STATIC)
115      DO 2 ij = ijb,ije
116       pscr (ij)    = ps0(ij)
117       ps (ij)      = psm1(ij) + dt * dp(ij)
118   2  CONTINUE
119c$OMP END DO 
120c$OMP BARRIER
121c --> ici synchro OPENMP pour ps
122       
123      checksum=.TRUE.
124      stop_it=0
125
126c$OMP MASTER
127!c$OMP DO SCHEDULE(STATIC)
128      DO ij = ijb,ije
129         IF( ps(ij).LT.0. ) THEN
130           IF (checksum) stop_it=ij
131           checksum=.FALSE.
132         ENDIF
133       ENDDO
134!c$OMP END DO NOWAIT
135       
136!      CALL MPI_ALLREDUCE(checksum,checksum_all,1,
137!     &                   MPI_LOGICAL,MPI_LOR,COMM_LMDZ,ierr)
138      IF( .NOT. checksum ) THEN
139         PRINT*,' Au point ij = ',stop_it, ' , pression sol neg. '
140     &         , ps(stop_it)
141         STOP' dans integrd'
142      ENDIF
143c$OMP END MASTER
144c$OMP BARRIER
145      IF (.NOT. Checksum_all) THEN
146        call WriteField_v('int_vcov',vcov)
147        call WriteField_u('int_ucov',ucov)
148        call WriteField_u('int_teta',teta)
149        call WriteField_u('int_ps0',ps0)
150        call WriteField_u('int_masse',masse)
151        call WriteField_u('int_phis',phis)
152        call WriteField_v('int_vcovm1',vcovm1)
153        call WriteField_u('int_ucovm1',ucovm1)
154        call WriteField_u('int_tetam1',tetam1)
155        call WriteField_u('int_psm1',psm1)
156        call WriteField_u('int_massem1',massem1)
157
158        call WriteField_v('int_dv',dv)
159        call WriteField_u('int_du',du)
160        call WriteField_u('int_dteta',dteta)
161        call WriteField_u('int_dp',dp)
162        call WriteField_u('int_finvmaold',finvmaold)
163        do j=1,nq
164          call WriteField_u('int_q'//trim(int2str(j)),
165     .                q(:,:,j))
166          call WriteField_u('int_dq'//trim(int2str(j)),
167     .                dq(:,:,j))
168        enddo
169      STOP
170      ENDIF
171   
172       
173c
174C$OMP MASTER
175      if (pole_nord) THEN
176     
177        DO  ij    = 1, iim
178         tppn(ij) = aire(   ij   ) * ps(  ij    )
179        ENDDO
180         tpn      = SSUM(iim,tppn,1)/apoln
181        DO ij   = 1, iip1
182         ps(   ij   )  = tpn
183        ENDDO
184     
185      ENDIF
186     
187      if (pole_sud) THEN
188     
189        DO  ij    = 1, iim
190         tpps(ij) = aire(ij+ip1jm) * ps(ij+ip1jm)
191        ENDDO
192         tps      = SSUM(iim,tpps,1)/apols
193        DO ij   = 1, iip1
194         ps(ij+ip1jm)  = tps
195        ENDDO
196     
197      ENDIF
198c$OMP END MASTER
199c$OMP BARRIER
200c
201c  ... Calcul  de la nouvelle masse d'air au dernier temps integre t+1 ...
202c
203
204      CALL pression_loc ( ip1jmp1, ap, bp, ps, p )
205c$OMP BARRIER
206      CALL massdair_loc (     p  , masse         )
207
208c      CALL   SCOPY( ijp1llm  , masse, 1, finvmasse,  1      )
209      ijb=ij_begin
210      ije=ij_end
211     
212c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
213      DO  l = 1,llm
214        finvmasse(ijb:ije,l)=masse(ijb:ije,l)
215      ENDDO
216c$OMP END DO NOWAIT
217
218      jjb=jj_begin
219      jje=jj_end
220      CALL filtreg_p( finvmasse,jjb_u,jje_u,jjb,jje, jjp1, llm,
221     &                -2, 2, .TRUE., 1  )
222c
223
224c    ............   integration  de  ucov, vcov,  h     ..............
225
226c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
227      DO 10 l = 1,llm
228     
229      ijb=ij_begin
230      ije=ij_end
231      if (pole_nord) ijb=ij_begin+iip1
232      if (pole_sud)  ije=ij_end-iip1
233     
234      DO 4 ij = ijb,ije
235      uscr( ij )   =  ucov( ij,l )
236      ucov( ij,l ) = ucovm1( ij,l ) + dt * du( ij,l )
237   4  CONTINUE
238
239      ijb=ij_begin
240      ije=ij_end
241      if (pole_sud)  ije=ij_end-iip1
242     
243      DO 5 ij = ijb,ije
244      vscr( ij )   =  vcov( ij,l )
245      vcov( ij,l ) = vcovm1( ij,l ) + dt * dv( ij,l )
246   5  CONTINUE
247     
248      ijb=ij_begin
249      ije=ij_end
250     
251      DO 6 ij = ijb,ije
252      hscr( ij )    =  teta(ij,l)
253      teta ( ij,l ) = tetam1(ij,l) *  massem1(ij,l) / masse(ij,l)
254     $                + dt * dteta(ij,l) / masse(ij,l)
255   6  CONTINUE
256
257c   ....  Calcul de la valeur moyenne, unique  aux poles pour  teta    ......
258c
259c
260      IF (pole_nord) THEN
261       
262        DO  ij   = 1, iim
263          tppn(ij) = aire(   ij   ) * teta(  ij    ,l)
264        ENDDO
265          tpn      = SSUM(iim,tppn,1)/apoln
266
267        DO ij   = 1, iip1
268          teta(   ij   ,l)  = tpn
269        ENDDO
270     
271      ENDIF
272     
273      IF (pole_sud) THEN
274       
275        DO  ij   = 1, iim
276          tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l)
277        ENDDO
278          tps      = SSUM(iim,tpps,1)/apols
279
280        DO ij   = 1, iip1
281          teta(ij+ip1jm,l)  = tps
282        ENDDO
283     
284      ENDIF
285c
286
287      IF(leapf)  THEN
288c         CALL SCOPY ( ip1jmp1, uscr(1), 1, ucovm1(1, l), 1 )
289c         CALL SCOPY (   ip1jm, vscr(1), 1, vcovm1(1, l), 1 )
290c         CALL SCOPY ( ip1jmp1, hscr(1), 1, tetam1(1, l), 1 )
291        ijb=ij_begin
292        ije=ij_end
293        ucovm1(ijb:ije,l)=uscr(ijb:ije)
294        tetam1(ijb:ije,l)=hscr(ijb:ije)
295        if (pole_sud) ije=ij_end-iip1
296        vcovm1(ijb:ije,l)=vscr(ijb:ije)
297     
298      END IF
299
300  10  CONTINUE
301c$OMP END DO NOWAIT
302
303c
304c   .......  integration de   q   ......
305c
306      ijb=ij_begin
307      ije=ij_end
308
309         if (planet_type.eq."earth") then
310! Earth-specific treatment of first 2 tracers (water)
311c$OMP BARRIER
312c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
313          DO l = 1, llm
314           DO ij = ijb, ije
315            deltap(ij,l) =  p(ij,l) - p(ij,l+1)
316           ENDDO
317          ENDDO
318c$OMP END DO NOWAIT
319c$OMP BARRIER
320
321          CALL qminimum_loc( q, nq, deltap )
322         endif ! of if (planet_type.eq."earth")
323c
324c    .....  Calcul de la valeur moyenne, unique  aux poles pour  q .....
325c
326c$OMP BARRIER
327      IF (pole_nord) THEN
328     
329        DO iq = 1, nq
330       
331c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
332          DO l = 1, llm
333 
334             DO ij = 1, iim
335               qppn(ij) = aire(   ij   ) * q(   ij   ,l,iq)
336             ENDDO
337               qpn  =  SSUM(iim,qppn,1)/apoln
338     
339             DO ij = 1, iip1
340               q(   ij   ,l,iq)  = qpn
341             ENDDO   
342 
343          ENDDO
344c$OMP END DO NOWAIT
345
346        ENDDO
347     
348      ENDIF
349
350      IF (pole_sud) THEN
351     
352        DO iq = 1, nq
353
354c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
355          DO l = 1, llm
356 
357             DO ij = 1, iim
358               qpps(ij) = aire(ij+ip1jm) * q(ij+ip1jm,l,iq)
359             ENDDO
360               qps  =  SSUM(iim,qpps,1)/apols
361 
362             DO ij = 1, iip1
363               q(ij+ip1jm,l,iq)  = qps
364             ENDDO   
365 
366          ENDDO
367c$OMP END DO NOWAIT
368
369        ENDDO
370     
371      ENDIF
372     
373c         CALL  SCOPY( ijp1llm , finvmasse, 1, finvmaold, 1 )
374
375c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
376      DO l = 1, llm     
377        finvmaold(ijb:ije,l)=finvmasse(ijb:ije,l)       
378      ENDDO
379c$OMP END DO NOWAIT
380c
381c
382c     .....   FIN  de l'integration  de   q    .......
383
38415    continue
385
386c$OMP DO SCHEDULE(STATIC)
387      DO ij=ijb,ije 
388        ps0(ij)=ps(ij)
389      ENDDO
390c$OMP END DO NOWAIT
391
392c    .................................................................
393
394
395      IF( leapf )  THEN
396c       CALL SCOPY (    ip1jmp1 ,  pscr   , 1,   psm1  , 1 )
397c       CALL SCOPY ( ip1jmp1*llm, massescr, 1,  massem1, 1 )
398c$OMP DO SCHEDULE(STATIC)
399      DO ij=ijb,ije 
400        psm1(ij)=pscr(ij)
401      ENDDO
402c$OMP END DO NOWAIT
403
404c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
405          DO l = 1, llm
406            massem1(ijb:ije,l)=massescr(ijb:ije,l)
407          ENDDO
408c$OMP END DO NOWAIT       
409      END IF
410c$OMP BARRIER
411      RETURN
412      END
Note: See TracBrowser for help on using the repository browser.