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 @ 396

Last change on this file since 396 was 396, checked in by opalod, 18 years ago

Initial revision
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 16.8 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)
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      INTEGER :: code
57
58C pttruetab2 and cetruetab2 are modified arraysin order to always
59C send the most inner points
60
61       
62         memberout1(1) = memberout
63
64         CALL MPI_ALLGATHER(memberout1,1,MPI_LOGICAL,memberoutall,
65     &                  1,MPI_LOGICAL,MPI_COMM_WORLD,code)
66
67         pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank)
68         cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank)
69         do k2=0,Agrif_Nbprocs-1
70            do i=1,nbdim
71
72           tochangebis=.TRUE.
73           DO i1=1,nbdim
74            IF (i .NE. i1) THEN
75              IF ((pttruetab(i1,Agrif_Procrank).NE.pttruetab(i1,k2)).OR.
76     &          (cetruetab(i1,Agrif_Procrank).NE.cetruetab(i1,k2))) THEN
77                   tochangebis = .FALSE.
78               EXIT
79              ENDIF
80             ENDIF
81           ENDDO
82
83           IF (tochangebis) THEN
84
85
86          imin1 = max(pttruetab(i,Agrif_Procrank),
87     &                    pttruetab(i,k2))
88          imax1 = min(cetruetab(i,Agrif_Procrank),
89     &                    cetruetab(i,k2))
90
91C Always send the most interior points
92
93           tochange = .false.
94           IF (cetruetab(i,Agrif_Procrank)> cetruetab(i,k2)) THEN
95
96           DO j=imin1,imax1
97             IF ((cetruetab(i,k2)-j) >
98     &             (j-pttruetab(i,Agrif_Procrank))) THEN
99             imintmp = j+1
100             tochange = .TRUE.
101             ELSE
102              EXIT
103             ENDIF
104          ENDDO
105          ENDIF
106
107           if (tochange) then
108C
109              pttruetab2(i,Agrif_Procrank) = imintmp
110C
111          endif
112
113           tochange = .FALSE.
114           imaxtmp=0
115           IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k2)) THEN
116          DO j=imax1,imin1,-1
117            IF ((j-pttruetab(i,k2)) >
118     &             (cetruetab(i,Agrif_Procrank)-j)) THEN
119             imaxtmp = j-1
120             tochange = .TRUE.
121            ELSE
122             EXIT
123            ENDIF
124          ENDDO
125
126          ENDIF
127
128                    if (tochange) then
129C
130              cetruetab2(i,Agrif_Procrank) = imaxtmp
131C
132          endif
133C
134
135          ENDIF
136           enddo
137         enddo
138
139
140       do k = 0,Agrif_NbProcs-1
141C
142        sendtoproc(k) = .true.
143C
144        do i = 1,nbdim
145C
146          imin(i,k) = max(pttruetab2(i,Agrif_Procrank),
147     &                    pttruetabwhole(i,k))
148          imax(i,k) = min(cetruetab2(i,Agrif_Procrank),
149     &                    cetruetabwhole(i,k))
150C
151          if (imin(i,k) > imax(i,k)) then
152C
153              sendtoproc(k) = .false.
154C
155          endif
156C
157        enddo
158        IF (.NOT.memberoutall(k)) THEN
159           sendtoproc(k) = .FALSE.
160        ENDIF
161C
162      enddo
163
164
165c       IF (.NOT.memberin) sendtoproc = .FALSE.
166
167      IF (memberout) THEN
168      Call Agrif_nbdim_allocation(tempCextend%var,
169     &                 pttruetabwhole(:,Agrif_ProcRank),
170     &                 cetruetabwhole(:,Agrif_ProcRank),nbdim)
171      call Agrif_nbdim_Full_VarEQreal(tempCextend%var,0.,nbdim)
172      ENDIF
173
174      IF (sendtoproc(Agrif_ProcRank)) THEN
175           Call Agrif_nbdim_VarEQvar(tempCextend%var,
176     &                               imin(:,Agrif_Procrank),
177     &                               imax(:,Agrif_Procrank),
178     &                               tempC%var,
179     &                               imin(:,Agrif_Procrank),
180     &                               imax(:,Agrif_Procrank),
181     &                               nbdim)
182      ENDIF
183
184      Call Exchangesamelevel(sendtoproc,nbdim,imin,imax,tempC,
185     &     tempCextend)
186
187      End Subroutine Get_External_Data
188
189       Subroutine ExchangeSameLevel(sendtoproc,nbdim,imin,imax,
190     &          tempC,tempCextend)
191      Implicit None
192      INTEGER :: nbdim
193      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin,imax
194      INTEGER,DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: iminmax_temp
195      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin_recv,imax_recv
196      TYPE(Agrif_PVARIABLE) :: tempC,tempCextend
197      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1)       :: sendtoproc
198      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1)       :: recvfromproc
199      LOGICAL                                    :: res
200      TYPE(AGRIF_PVARIABLE)                      :: temprecv
201
202#include "mpif.h"
203          INTEGER :: i,k
204          INTEGER :: etiquette = 100
205          INTEGER :: code, datasize
206          INTEGER,DIMENSION(MPI_STATUS_SIZE)   :: statut
207
208
209      do k = 0,Agrif_ProcRank-1
210C
211C
212            Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
213     &                    MPI_COMM_WORLD,code)
214C
215            if (sendtoproc(k)) then
216C
217                iminmax_temp(:,1,k) = imin(:,k)
218                iminmax_temp(:,2,k) = imax(:,k)
219
220                Call MPI_SEND(iminmax_temp(:,:,k),
221     &                        2*nbdim,MPI_INTEGER,k,etiquette,
222     &                        MPI_COMM_WORLD,code)
223C
224                datasize = 1
225C
226                do i = 1,nbdim
227C
228                  datasize = datasize * (imax(i,k)-imin(i,k)+1)
229C
230                enddo
231C
232                SELECT CASE(nbdim)
233                CASE(1)
234                   Call MPI_SEND(tempC%var%array1(
235     &                        imin(1,k):imax(1,k)),
236     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
237     &                        MPI_COMM_WORLD,code)
238                CASE(2)
239                   Call MPI_SEND(tempC%var%array2(
240     &                        imin(1,k):imax(1,k),
241     &                        imin(2,k):imax(2,k)),
242     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
243     &                        MPI_COMM_WORLD,code)
244                CASE(3)
245                   Call MPI_SEND(tempC%var%array3(
246     &                        imin(1,k):imax(1,k),
247     &                        imin(2,k):imax(2,k),
248     &                        imin(3,k):imax(3,k)),
249     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
250     &                        MPI_COMM_WORLD,code)
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                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           
344            Call where_valtabtotab_mpi(tempCextend%var,
345     &             temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
346     
347                Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
348                deallocate(temprecv%var)
349
350            endif
351
352C
353      enddo
354
355
356      do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
357C
358C
359            Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
360     &                    MPI_COMM_WORLD,code)
361C
362            if (sendtoproc(k)) then
363C
364                iminmax_temp(:,1,k) = imin(:,k)
365                iminmax_temp(:,2,k) = imax(:,k)
366
367                Call MPI_SEND(iminmax_temp(:,:,k),
368     &                        2*nbdim,MPI_INTEGER,k,etiquette,
369     &                        MPI_COMM_WORLD,code)
370C
371                datasize = 1
372C
373                do i = 1,nbdim
374C
375                  datasize = datasize * (imax(i,k)-imin(i,k)+1)
376C
377                enddo
378C
379                SELECT CASE(nbdim)
380                CASE(1)
381                   Call MPI_SEND(tempC%var%array1(
382     &                        imin(1,k):imax(1,k)),
383     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
384     &                        MPI_COMM_WORLD,code)
385                CASE(2)
386                   Call MPI_SEND(tempC%var%array2(
387     &                        imin(1,k):imax(1,k),
388     &                        imin(2,k):imax(2,k)),
389     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
390     &                        MPI_COMM_WORLD,code)
391                CASE(3)
392                   Call MPI_SEND(tempC%var%array3(
393     &                        imin(1,k):imax(1,k),
394     &                        imin(2,k):imax(2,k),
395     &                        imin(3,k):imax(3,k)),
396     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
397     &                        MPI_COMM_WORLD,code)
398                CASE(4)
399                   Call MPI_SEND(tempC%var%array4(
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     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
405     &                        MPI_COMM_WORLD,code)
406                CASE(5)
407                   Call MPI_SEND(tempC%var%array5(
408     &                        imin(1,k):imax(1,k),
409     &                        imin(2,k):imax(2,k),
410     &                        imin(3,k):imax(3,k),
411     &                        imin(4,k):imax(4,k),
412     &                        imin(5,k):imax(5,k)),
413     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
414     &                        MPI_COMM_WORLD,code)
415                CASE(6)
416                   Call MPI_SEND(tempC%var%array6(
417     &                        imin(1,k):imax(1,k),
418     &                        imin(2,k):imax(2,k),
419     &                        imin(3,k):imax(3,k),
420     &                        imin(4,k):imax(4,k),
421     &                        imin(5,k):imax(5,k),
422     &                        imin(6,k):imax(6,k)),
423     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
424     &                        MPI_COMM_WORLD,code)
425                END SELECT
426C
427            endif
428
429C
430      enddo
431
432C
433C
434C     Reception from others processors of the necessary part of the parent grid
435      do k = Agrif_ProcRank-1,0,-1
436C
437C
438            Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
439     &                    MPI_COMM_WORLD,statut,code)
440C
441            recvfromproc(k) = res
442
443C
444            if (recvfromproc(k)) then
445C
446                Call MPI_RECV(iminmax_temp(:,:,k),
447     &                        2*nbdim,MPI_INTEGER,k,etiquette,
448     &                        MPI_COMM_WORLD,statut,code)
449
450                imin_recv(:,k) = iminmax_temp(:,1,k)
451                imax_recv(:,k) = iminmax_temp(:,2,k)
452
453                datasize = 1
454C
455                do i = 1,nbdim
456C
457                datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
458C
459                enddo
460                allocate(temprecv%var)
461             call Agrif_nbdim_allocation(temprecv%var,imin_recv(:,k),
462     &   imax_recv(:,k),nbdim)
463            SELECT CASE(nbdim)
464            CASE(1)
465              Call MPI_RECV(temprecv%var%array1,
466     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
467     &               MPI_COMM_WORLD,statut,code)
468            CASE(2)
469              Call MPI_RECV(temprecv%var%array2,
470     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
471     &               MPI_COMM_WORLD,statut,code)
472            CASE(3)
473              Call MPI_RECV(temprecv%var%array3,
474     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
475     &               MPI_COMM_WORLD,statut,code)
476
477            CASE(4)
478              Call MPI_RECV(temprecv%var%array4,
479     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
480     &               MPI_COMM_WORLD,statut,code)
481            CASE(5)
482              Call MPI_RECV(temprecv%var%array5,
483     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
484     &               MPI_COMM_WORLD,statut,code)
485            CASE(6)
486              Call MPI_RECV(temprecv%var%array6,
487     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
488     &               MPI_COMM_WORLD,statut,code)
489          END SELECT
490           
491            Call where_valtabtotab_mpi(tempCextend%var,
492     &             temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
493     
494                Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
495                deallocate(temprecv%var)
496            endif
497
498C
499      enddo
500
501          End Subroutine ExchangeSamelevel
502
503#else
504      Subroutine Agrif_mpp_empty()
505      End Subroutine Agrif_mpp_empty
506#endif
507
508      End Module Agrif_mpp
Note: See TracBrowser for help on using the repository browser.