New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
modmpp.F in trunk/AGRIF/AGRIF_FILES – NEMO

source: trunk/AGRIF/AGRIF_FILES/modmpp.F @ 662

Last change on this file since 662 was 662, checked in by opalod, 17 years ago

RB: update Agrif internal routines with a new update scheme and performance improvment
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.3 KB
Line 
1!
2! $Id$
3!
4C     AGRIF (Adaptive Grid Refinement In Fortran)
5C
6C     Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
7C                        Christophe Vouland (Christophe.Vouland@imag.fr)
8C
9C     This program is free software; you can redistribute it and/or modify
10C     it under the terms of the GNU General Public License as published by
11C     the Free Software Foundation; either version 2 of the License, or
12C     (at your option) any later version.
13C
14C     This program is distributed in the hope that it will be useful,
15C     but WITHOUT ANY WARRANTY; without even the implied warranty of
16C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17C     GNU General Public License for more details.
18C
19C     You should have received a copy of the GNU General Public License
20C     along with this program; if not, write to the Free Software
21C     Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
22C
23C
24C
25CCC   Module Agrif_mpp
26C
27      Module Agrif_mpp
28      Use Agrif_Types
29      Use Agrif_Arrays
30
31      Contains
32#ifdef AGRIF_MPI
33C
34      Subroutine Get_External_Data(tempC,tempCextend,pttruetab,
35     &   cetruetab,pttruetabwhole,cetruetabwhole,nbdim,memberin,
36     &   memberout,memberoutall1)
37
38      IMPLICIT NONE
39#include "mpif.h"
40      INTEGER :: nbdim
41      TYPE(Agrif_PVariable) :: tempC, tempCextend
42      INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1)    :: pttruetab,
43     &                                                 cetruetab
44      INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1)    :: pttruetabwhole,
45     &                                                 cetruetabwhole
46      INTEGER :: k,i,k2
47      LOGICAL :: sendtoproc(0:Agrif_Nbprocs-1)
48      INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1)    :: imin,imax
49      LOGICAL :: memberin, memberout
50      INTEGER :: imintmp, imaxtmp,j,i1
51      INTEGER :: imin1,imax1
52      LOGICAL :: tochange,tochangebis
53      INTEGER,DIMENSION(nbdim,0:Agrif_NbProcs-1)    :: pttruetab2,
54     &                                                 cetruetab2
55      LOGICAL :: memberout1(1),memberoutall(0:Agrif_Nbprocs-1)
56      LOGICAL, OPTIONAL :: memberoutall1(0:Agrif_Nbprocs-1)
57      INTEGER :: code
58
59C pttruetab2 and cetruetab2 are modified arraysin order to always
60C send the most inner points
61
62       
63        IF (present(memberoutall1)) THEN
64        memberoutall = memberoutall1
65        ELSE
66         memberout1(1) = memberout
67
68         CALL MPI_ALLGATHER(memberout1,1,MPI_LOGICAL,memberoutall,
69     &                  1,MPI_LOGICAL,MPI_COMM_WORLD,code)
70        ENDIF
71         pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank)
72         cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank)
73         do k2=0,Agrif_Nbprocs-1
74            do i=1,nbdim
75
76           tochangebis=.TRUE.
77           DO i1=1,nbdim
78            IF (i .NE. i1) THEN
79              IF ((pttruetab(i1,Agrif_Procrank).NE.pttruetab(i1,k2)).OR.
80     &          (cetruetab(i1,Agrif_Procrank).NE.cetruetab(i1,k2))) THEN
81                   tochangebis = .FALSE.
82               EXIT
83              ENDIF
84             ENDIF
85           ENDDO
86
87           IF (tochangebis) THEN
88
89
90          imin1 = max(pttruetab(i,Agrif_Procrank),
91     &                    pttruetab(i,k2))
92          imax1 = min(cetruetab(i,Agrif_Procrank),
93     &                    cetruetab(i,k2))
94
95C Always send the most interior points
96
97           tochange = .false.
98           IF (cetruetab(i,Agrif_Procrank)> cetruetab(i,k2)) THEN
99
100           DO j=imin1,imax1
101             IF ((cetruetab(i,k2)-j) >
102     &             (j-pttruetab(i,Agrif_Procrank))) THEN
103             imintmp = j+1
104             tochange = .TRUE.
105             ELSE
106              EXIT
107             ENDIF
108          ENDDO
109          ENDIF
110
111           if (tochange) then
112C
113              pttruetab2(i,Agrif_Procrank) = imintmp
114C
115          endif
116
117           tochange = .FALSE.
118           imaxtmp=0
119           IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k2)) THEN
120          DO j=imax1,imin1,-1
121            IF ((j-pttruetab(i,k2)) >
122     &             (cetruetab(i,Agrif_Procrank)-j)) THEN
123             imaxtmp = j-1
124             tochange = .TRUE.
125            ELSE
126             EXIT
127            ENDIF
128          ENDDO
129
130          ENDIF
131
132                    if (tochange) then
133C
134              cetruetab2(i,Agrif_Procrank) = imaxtmp
135C
136          endif
137C
138
139          ENDIF
140           enddo
141         enddo
142
143
144       do k = 0,Agrif_NbProcs-1
145C
146        sendtoproc(k) = .true.
147C
148        do i = 1,nbdim
149C
150          imin(i,k) = max(pttruetab2(i,Agrif_Procrank),
151     &                    pttruetabwhole(i,k))
152          imax(i,k) = min(cetruetab2(i,Agrif_Procrank),
153     &                    cetruetabwhole(i,k))
154C
155          if (imin(i,k) > imax(i,k)) then
156C
157              sendtoproc(k) = .false.
158C
159          endif
160C
161        enddo
162        IF (.NOT.memberoutall(k)) THEN
163           sendtoproc(k) = .FALSE.
164        ENDIF
165C
166      enddo
167
168
169c       IF (.NOT.memberin) sendtoproc = .FALSE.
170
171      IF (memberout) THEN
172      Call Agrif_nbdim_allocation(tempCextend%var,
173     &                 pttruetabwhole(:,Agrif_ProcRank),
174     &                 cetruetabwhole(:,Agrif_ProcRank),nbdim)
175      call Agrif_nbdim_Full_VarEQreal(tempCextend%var,0.,nbdim)
176      ENDIF
177
178      IF (sendtoproc(Agrif_ProcRank)) THEN
179           Call Agrif_nbdim_VarEQvar(tempCextend%var,
180     &                               imin(:,Agrif_Procrank),
181     &                               imax(:,Agrif_Procrank),
182     &                               tempC%var,
183     &                               imin(:,Agrif_Procrank),
184     &                               imax(:,Agrif_Procrank),
185     &                               nbdim)
186      ENDIF
187
188      Call Exchangesamelevel(sendtoproc,nbdim,imin,imax,tempC,
189     &     tempCextend)
190
191      End Subroutine Get_External_Data
192
193       Subroutine ExchangeSameLevel(sendtoproc,nbdim,imin,imax,
194     &          tempC,tempCextend)
195      Implicit None
196      INTEGER :: nbdim
197      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin,imax
198      INTEGER,DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: iminmax_temp
199      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin_recv,imax_recv
200      TYPE(Agrif_PVARIABLE) :: tempC,tempCextend
201      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1)       :: sendtoproc
202      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1)       :: recvfromproc
203      LOGICAL                                    :: res
204      TYPE(AGRIF_PVARIABLE), SAVE                      :: temprecv
205
206#include "mpif.h"
207          INTEGER :: i,k
208          INTEGER :: etiquette = 100
209          INTEGER :: code, datasize
210          INTEGER,DIMENSION(MPI_STATUS_SIZE)   :: statut
211
212
213      do k = 0,Agrif_ProcRank-1
214C
215C
216            Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
217     &                    MPI_COMM_WORLD,code)
218C
219            if (sendtoproc(k)) then
220C
221                iminmax_temp(:,1,k) = imin(:,k)
222                iminmax_temp(:,2,k) = imax(:,k)
223
224                Call MPI_SEND(iminmax_temp(:,:,k),
225     &                        2*nbdim,MPI_INTEGER,k,etiquette,
226     &                        MPI_COMM_WORLD,code)
227C
228                datasize = 1
229C
230                do i = 1,nbdim
231C
232                  datasize = datasize * (imax(i,k)-imin(i,k)+1)
233C
234                enddo
235C
236                SELECT CASE(nbdim)
237                CASE(1)
238                   Call MPI_SEND(tempC%var%array1(
239     &                        imin(1,k):imax(1,k)),
240     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
241     &                        MPI_COMM_WORLD,code)
242                CASE(2)
243                   Call MPI_SEND(tempC%var%array2(
244     &                        imin(1,k):imax(1,k),
245     &                        imin(2,k):imax(2,k)),
246     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
247     &                        MPI_COMM_WORLD,code)
248                CASE(3)
249                  Call Agrif_Send_3Darray(tempC%var%array3,
250     &             lbound(tempC%var%array3),imin(:,k),imax(:,k),k)
251                CASE(4)
252                   Call MPI_SEND(tempC%var%array4(
253     &                        imin(1,k):imax(1,k),
254     &                        imin(2,k):imax(2,k),
255     &                        imin(3,k):imax(3,k),
256     &                        imin(4,k):imax(4,k)),
257     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
258     &                        MPI_COMM_WORLD,code)
259                CASE(5)
260                   Call MPI_SEND(tempC%var%array5(
261     &                        imin(1,k):imax(1,k),
262     &                        imin(2,k):imax(2,k),
263     &                        imin(3,k):imax(3,k),
264     &                        imin(4,k):imax(4,k),
265     &                        imin(5,k):imax(5,k)),
266     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
267     &                        MPI_COMM_WORLD,code)
268                CASE(6)
269                   Call MPI_SEND(tempC%var%array6(
270     &                        imin(1,k):imax(1,k),
271     &                        imin(2,k):imax(2,k),
272     &                        imin(3,k):imax(3,k),
273     &                        imin(4,k):imax(4,k),
274     &                        imin(5,k):imax(5,k),
275     &                        imin(6,k):imax(6,k)),
276     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
277     &                        MPI_COMM_WORLD,code)
278                END SELECT
279C
280            endif
281
282C
283      enddo
284C
285C
286C     Reception from others processors of the necessary part of the parent grid
287      do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
288C
289C
290            Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
291     &                    MPI_COMM_WORLD,statut,code)
292C
293            recvfromproc(k) = res
294
295C
296            if (recvfromproc(k)) then
297C
298                Call MPI_RECV(iminmax_temp(:,:,k),
299     &                        2*nbdim,MPI_INTEGER,k,etiquette,
300     &                        MPI_COMM_WORLD,statut,code)
301
302                imin_recv(:,k) = iminmax_temp(:,1,k)
303                imax_recv(:,k) = iminmax_temp(:,2,k)
304
305                datasize = 1
306C
307                do i = 1,nbdim
308C
309                datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
310C
311                enddo
312
313             IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
314             call Agrif_nbdim_allocation(temprecv%var,imin_recv(:,k),
315     &   imax_recv(:,k),nbdim)
316            SELECT CASE(nbdim)
317            CASE(1)
318              Call MPI_RECV(temprecv%var%array1,
319     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
320     &               MPI_COMM_WORLD,statut,code)
321            CASE(2)
322              Call MPI_RECV(temprecv%var%array2,
323     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
324     &               MPI_COMM_WORLD,statut,code)
325            CASE(3)
326              Call MPI_RECV(temprecv%var%array3,
327     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
328     &               MPI_COMM_WORLD,statut,code)
329
330            CASE(4)
331              Call MPI_RECV(temprecv%var%array4,
332     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
333     &               MPI_COMM_WORLD,statut,code)
334            CASE(5)
335              Call MPI_RECV(temprecv%var%array5,
336     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
337     &               MPI_COMM_WORLD,statut,code)
338            CASE(6)
339              Call MPI_RECV(temprecv%var%array6,
340     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
341     &               MPI_COMM_WORLD,statut,code)
342       END SELECT
343            endif
344           
345            Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
346     &                    MPI_COMM_WORLD,code)
347C
348            if (sendtoproc(k)) then
349C
350                iminmax_temp(:,1,k) = imin(:,k)
351                iminmax_temp(:,2,k) = imax(:,k)
352
353                Call MPI_SEND(iminmax_temp(:,:,k),
354     &                        2*nbdim,MPI_INTEGER,k,etiquette,
355     &                        MPI_COMM_WORLD,code)
356C
357                SELECT CASE(nbdim)
358                CASE(1)
359                datasize=SIZE(tempC%var%array1(
360     &                        imin(1,k):imax(1,k)))
361                   Call MPI_SEND(tempC%var%array1(
362     &                        imin(1,k):imax(1,k)),
363     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
364     &                        MPI_COMM_WORLD,code)
365                CASE(2)
366                datasize=SIZE(tempC%var%array2(
367     &                        imin(1,k):imax(1,k),
368     &                        imin(2,k):imax(2,k)))
369                   Call MPI_SEND(tempC%var%array2(
370     &                        imin(1,k):imax(1,k),
371     &                        imin(2,k):imax(2,k)),
372     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
373     &                        MPI_COMM_WORLD,code)
374                CASE(3)
375                datasize=SIZE(tempC%var%array3(
376     &                        imin(1,k):imax(1,k),
377     &                        imin(2,k):imax(2,k),
378     &                        imin(3,k):imax(3,k)))
379                   Call MPI_SEND(tempC%var%array3(
380     &                        imin(1,k):imax(1,k),
381     &                        imin(2,k):imax(2,k),
382     &                        imin(3,k):imax(3,k)),
383     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
384     &                        MPI_COMM_WORLD,code)
385                CASE(4)
386                datasize=SIZE(tempC%var%array4(
387     &                        imin(1,k):imax(1,k),
388     &                        imin(2,k):imax(2,k),
389     &                        imin(3,k):imax(3,k),
390     &                        imin(4,k):imax(4,k)))
391                   Call MPI_SEND(tempC%var%array4(
392     &                        imin(1,k):imax(1,k),
393     &                        imin(2,k):imax(2,k),
394     &                        imin(3,k):imax(3,k),
395     &                        imin(4,k):imax(4,k)),
396     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
397     &                        MPI_COMM_WORLD,code)
398                CASE(5)
399                datasize=SIZE(tempC%var%array5(
400     &                        imin(1,k):imax(1,k),
401     &                        imin(2,k):imax(2,k),
402     &                        imin(3,k):imax(3,k),
403     &                        imin(4,k):imax(4,k),
404     &                        imin(5,k):imax(5,k)))
405                   Call MPI_SEND(tempC%var%array5(
406     &                        imin(1,k):imax(1,k),
407     &                        imin(2,k):imax(2,k),
408     &                        imin(3,k):imax(3,k),
409     &                        imin(4,k):imax(4,k),
410     &                        imin(5,k):imax(5,k)),
411     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
412     &                        MPI_COMM_WORLD,code)
413                CASE(6)
414                datasize=SIZE(tempC%var%array6(
415     &                        imin(1,k):imax(1,k),
416     &                        imin(2,k):imax(2,k),
417     &                        imin(3,k):imax(3,k),
418     &                        imin(4,k):imax(4,k),
419     &                        imin(5,k):imax(5,k),
420     &                        imin(6,k):imax(6,k)))
421                   Call MPI_SEND(tempC%var%array6(
422     &                        imin(1,k):imax(1,k),
423     &                        imin(2,k):imax(2,k),
424     &                        imin(3,k):imax(3,k),
425     &                        imin(4,k):imax(4,k),
426     &                        imin(5,k):imax(5,k),
427     &                        imin(6,k):imax(6,k)),
428     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
429     &                        MPI_COMM_WORLD,code)
430                END SELECT
431C
432            endif           
433           
434            if (recvfromproc(k)) then
435                       
436            Call where_valtabtotab_mpi(tempCextend%var,
437     &             temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
438     
439                Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
440C                deallocate(temprecv%var)
441
442            endif
443
444C
445      enddo
446
447C
448C
449C     Reception from others processors of the necessary part of the parent grid
450      do k = Agrif_ProcRank-1,0,-1
451C
452C
453            Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
454     &                    MPI_COMM_WORLD,statut,code)
455C
456            recvfromproc(k) = res
457
458C
459            if (recvfromproc(k)) then
460C
461                Call MPI_RECV(iminmax_temp(:,:,k),
462     &                        2*nbdim,MPI_INTEGER,k,etiquette,
463     &                        MPI_COMM_WORLD,statut,code)
464
465C                imin_recv(:,k) = iminmax_temp(:,1,k)
466C                imax_recv(:,k) = iminmax_temp(:,2,k)
467
468C                datasize = 1
469C
470C                do i = 1,nbdim
471C
472C                datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
473C
474C                enddo
475             IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
476             call Agrif_nbdim_allocation(temprecv%var,
477     &   iminmax_temp(:,1,k),iminmax_temp(:,2,k),nbdim)
478            SELECT CASE(nbdim)
479            CASE(1)
480              datasize=SIZE(temprecv%var%array1)
481              Call MPI_RECV(temprecv%var%array1,
482     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
483     &               MPI_COMM_WORLD,statut,code)
484            CASE(2)
485              datasize=SIZE(temprecv%var%array2)
486              Call MPI_RECV(temprecv%var%array2,
487     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
488     &               MPI_COMM_WORLD,statut,code)
489            CASE(3)
490              datasize=SIZE(temprecv%var%array3)
491              Call MPI_RECV(temprecv%var%array3,
492     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
493     &               MPI_COMM_WORLD,statut,code)
494
495            CASE(4)
496              datasize=SIZE(temprecv%var%array4)
497              Call MPI_RECV(temprecv%var%array4,
498     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
499     &               MPI_COMM_WORLD,statut,code)
500            CASE(5)
501              datasize=SIZE(temprecv%var%array5)
502              Call MPI_RECV(temprecv%var%array5,
503     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
504     &               MPI_COMM_WORLD,statut,code)
505            CASE(6)
506              datasize=SIZE(temprecv%var%array6)
507              Call MPI_RECV(temprecv%var%array6,
508     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
509     &               MPI_COMM_WORLD,statut,code)
510          END SELECT
511           
512            Call where_valtabtotab_mpi(tempCextend%var,
513     &             temprecv%var,iminmax_temp(:,1,k),iminmax_temp(:,2,k)
514     &            ,0.,nbdim)
515     
516                Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
517C                deallocate(temprecv%var)
518            endif
519
520C
521      enddo
522
523          End Subroutine ExchangeSamelevel
524
525          Subroutine Agrif_Send_3Darray(tab3D,bounds,imin,imax,k)
526          integer, dimension(3) :: bounds, imin, imax
527          real,dimension(bounds(1):,bounds(2):,bounds(3):),target
528     &                             :: tab3D
529          integer :: k
530          integer :: etiquette = 100
531          integer :: datasize, code
532#include "mpif.h"   
533
534          datasize = SIZE(tab3D(
535     &                       imin(1):imax(1),
536     &                        imin(2):imax(2),
537     &                        imin(3):imax(3)))
538       
539                   Call MPI_SEND(tab3D(
540     &                        imin(1):imax(1),
541     &                        imin(2):imax(2),
542     &                        imin(3):imax(3)),
543     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
544     &                        MPI_COMM_WORLD,code)
545     
546         End Subroutine Agrif_Send_3Darray
547
548#else
549      Subroutine Agrif_mpp_empty()
550      End Subroutine Agrif_mpp_empty
551#endif
552
553      End Module Agrif_mpp
Note: See TracBrowser for help on using the repository browser.