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 on Ticket #105 – Attachment – NEMO

Ticket #105: modmpp.F

File modmpp.F, 20.2 KB (added by nemo_user, 16 years ago)
Line 
1!
2! $Id: modmpp.F 662 2007-05-25 15:58:52Z opalod $
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! FD old debug
252!                    Call MPI_SEND(tempC%var%array3(
253!     &                        imin(1,k):imax(1,k),
254!     &                        imin(2,k):imax(2,k),
255!     &                        imin(3,k):imax(3,k)),
256!     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
257!     &                        MPI_COMM_WORLD,code)
258                CASE(4)
259                   Call MPI_SEND(tempC%var%array4(
260     &                        imin(1,k):imax(1,k),
261     &                        imin(2,k):imax(2,k),
262     &                        imin(3,k):imax(3,k),
263     &                        imin(4,k):imax(4,k)),
264     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
265     &                        MPI_COMM_WORLD,code)
266                CASE(5)
267                   Call MPI_SEND(tempC%var%array5(
268     &                        imin(1,k):imax(1,k),
269     &                        imin(2,k):imax(2,k),
270     &                        imin(3,k):imax(3,k),
271     &                        imin(4,k):imax(4,k),
272     &                        imin(5,k):imax(5,k)),
273     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
274     &                        MPI_COMM_WORLD,code)
275                CASE(6)
276                   Call MPI_SEND(tempC%var%array6(
277     &                        imin(1,k):imax(1,k),
278     &                        imin(2,k):imax(2,k),
279     &                        imin(3,k):imax(3,k),
280     &                        imin(4,k):imax(4,k),
281     &                        imin(5,k):imax(5,k),
282     &                        imin(6,k):imax(6,k)),
283     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
284     &                        MPI_COMM_WORLD,code)
285                END SELECT
286C
287            endif
288
289C
290      enddo
291C
292C
293C     Reception from others processors of the necessary part of the parent grid
294      do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
295C
296C
297            Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
298     &                    MPI_COMM_WORLD,statut,code)
299C
300            recvfromproc(k) = res
301
302C
303            if (recvfromproc(k)) then
304C
305                Call MPI_RECV(iminmax_temp(:,:,k),
306     &                        2*nbdim,MPI_INTEGER,k,etiquette,
307     &                        MPI_COMM_WORLD,statut,code)
308
309                imin_recv(:,k) = iminmax_temp(:,1,k)
310                imax_recv(:,k) = iminmax_temp(:,2,k)
311
312                datasize = 1
313C
314                do i = 1,nbdim
315C
316                datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
317C
318                enddo
319
320             IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
321             call Agrif_nbdim_allocation(temprecv%var,imin_recv(:,k),
322     &   imax_recv(:,k),nbdim)
323            SELECT CASE(nbdim)
324            CASE(1)
325              Call MPI_RECV(temprecv%var%array1,
326     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
327     &               MPI_COMM_WORLD,statut,code)
328            CASE(2)
329              Call MPI_RECV(temprecv%var%array2,
330     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
331     &               MPI_COMM_WORLD,statut,code)
332            CASE(3)
333              Call MPI_RECV(temprecv%var%array3,
334     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
335     &               MPI_COMM_WORLD,statut,code)
336
337            CASE(4)
338              Call MPI_RECV(temprecv%var%array4,
339     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
340     &               MPI_COMM_WORLD,statut,code)
341            CASE(5)
342              Call MPI_RECV(temprecv%var%array5,
343     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
344     &               MPI_COMM_WORLD,statut,code)
345            CASE(6)
346              Call MPI_RECV(temprecv%var%array6,
347     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
348     &               MPI_COMM_WORLD,statut,code)
349       END SELECT
350           
351            Call where_valtabtotab_mpi(tempCextend%var,
352     &             temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
353     
354                Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
355! FD old debug                deallocate(temprecv%var)
356
357            endif
358
359C
360      enddo
361
362
363      do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
364           
365            Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
366     &                    MPI_COMM_WORLD,code)
367C
368            if (sendtoproc(k)) then
369C
370                iminmax_temp(:,1,k) = imin(:,k)
371                iminmax_temp(:,2,k) = imax(:,k)
372
373                Call MPI_SEND(iminmax_temp(:,:,k),
374     &                        2*nbdim,MPI_INTEGER,k,etiquette,
375     &                        MPI_COMM_WORLD,code)
376C
377                datasize = 1
378C
379                do i = 1,nbdim
380C
381                  datasize = datasize * (imax(i,k)-imin(i,k)+1)
382C
383                enddo
384C
385                SELECT CASE(nbdim)
386                CASE(1)
387                datasize=SIZE(tempC%var%array1(
388     &                        imin(1,k):imax(1,k)))
389                   Call MPI_SEND(tempC%var%array1(
390     &                        imin(1,k):imax(1,k)),
391     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
392     &                        MPI_COMM_WORLD,code)
393                CASE(2)
394                datasize=SIZE(tempC%var%array2(
395     &                        imin(1,k):imax(1,k),
396     &                        imin(2,k):imax(2,k)))
397                   Call MPI_SEND(tempC%var%array2(
398     &                        imin(1,k):imax(1,k),
399     &                        imin(2,k):imax(2,k)),
400     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
401     &                        MPI_COMM_WORLD,code)
402                CASE(3)
403                datasize=SIZE(tempC%var%array3(
404     &                        imin(1,k):imax(1,k),
405     &                        imin(2,k):imax(2,k),
406     &                        imin(3,k):imax(3,k)))
407                   Call MPI_SEND(tempC%var%array3(
408     &                        imin(1,k):imax(1,k),
409     &                        imin(2,k):imax(2,k),
410     &                        imin(3,k):imax(3,k)),
411     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
412     &                        MPI_COMM_WORLD,code)
413                CASE(4)
414                datasize=SIZE(tempC%var%array4(
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                   Call MPI_SEND(tempC%var%array4(
420     &                        imin(1,k):imax(1,k),
421     &                        imin(2,k):imax(2,k),
422     &                        imin(3,k):imax(3,k),
423     &                        imin(4,k):imax(4,k)),
424     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
425     &                        MPI_COMM_WORLD,code)
426                CASE(5)
427                datasize=SIZE(tempC%var%array5(
428     &                        imin(1,k):imax(1,k),
429     &                        imin(2,k):imax(2,k),
430     &                        imin(3,k):imax(3,k),
431     &                        imin(4,k):imax(4,k),
432     &                        imin(5,k):imax(5,k)))
433                   Call MPI_SEND(tempC%var%array5(
434     &                        imin(1,k):imax(1,k),
435     &                        imin(2,k):imax(2,k),
436     &                        imin(3,k):imax(3,k),
437     &                        imin(4,k):imax(4,k),
438     &                        imin(5,k):imax(5,k)),
439     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
440     &                        MPI_COMM_WORLD,code)
441                CASE(6)
442                datasize=SIZE(tempC%var%array6(
443     &                        imin(1,k):imax(1,k),
444     &                        imin(2,k):imax(2,k),
445     &                        imin(3,k):imax(3,k),
446     &                        imin(4,k):imax(4,k),
447     &                        imin(5,k):imax(5,k),
448     &                        imin(6,k):imax(6,k)))
449                   Call MPI_SEND(tempC%var%array6(
450     &                        imin(1,k):imax(1,k),
451     &                        imin(2,k):imax(2,k),
452     &                        imin(3,k):imax(3,k),
453     &                        imin(4,k):imax(4,k),
454     &                        imin(5,k):imax(5,k),
455     &                        imin(6,k):imax(6,k)),
456     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
457     &                        MPI_COMM_WORLD,code)
458                END SELECT
459C
460            endif           
461           
462! FD            if (recvfromproc(k)) then
463! FD                       
464! FD            Call where_valtabtotab_mpi(tempCextend%var,
465! FD     &             temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
466! FD     
467! FD                Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
468! FDC                deallocate(temprecv%var)
469! FD
470! FD            endif
471
472C
473      enddo
474
475C
476C
477C     Reception from others processors of the necessary part of the parent grid
478      do k = Agrif_ProcRank-1,0,-1
479C
480C
481            Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
482     &                    MPI_COMM_WORLD,statut,code)
483C
484            recvfromproc(k) = res
485
486C
487            if (recvfromproc(k)) then
488C
489                Call MPI_RECV(iminmax_temp(:,:,k),
490     &                        2*nbdim,MPI_INTEGER,k,etiquette,
491     &                        MPI_COMM_WORLD,statut,code)
492
493                imin_recv(:,k) = iminmax_temp(:,1,k)
494                imax_recv(:,k) = iminmax_temp(:,2,k)
495
496                datasize = 1
497
498                do i = 1,nbdim
499
500                datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
501
502                enddo
503
504             IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
505             call Agrif_nbdim_allocation(temprecv%var,
506     &   iminmax_temp(:,1,k),iminmax_temp(:,2,k),nbdim)
507            SELECT CASE(nbdim)
508            CASE(1)
509              datasize=SIZE(temprecv%var%array1)
510              Call MPI_RECV(temprecv%var%array1,
511     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
512     &               MPI_COMM_WORLD,statut,code)
513            CASE(2)
514              datasize=SIZE(temprecv%var%array2)
515              Call MPI_RECV(temprecv%var%array2,
516     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
517     &               MPI_COMM_WORLD,statut,code)
518            CASE(3)
519              datasize=SIZE(temprecv%var%array3)
520              Call MPI_RECV(temprecv%var%array3,
521     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
522     &               MPI_COMM_WORLD,statut,code)
523
524            CASE(4)
525              datasize=SIZE(temprecv%var%array4)
526              Call MPI_RECV(temprecv%var%array4,
527     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
528     &               MPI_COMM_WORLD,statut,code)
529            CASE(5)
530              datasize=SIZE(temprecv%var%array5)
531              Call MPI_RECV(temprecv%var%array5,
532     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
533     &               MPI_COMM_WORLD,statut,code)
534            CASE(6)
535              datasize=SIZE(temprecv%var%array6)
536              Call MPI_RECV(temprecv%var%array6,
537     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
538     &               MPI_COMM_WORLD,statut,code)
539          END SELECT
540           
541            Call where_valtabtotab_mpi(tempCextend%var,
542     &             temprecv%var,iminmax_temp(:,1,k),iminmax_temp(:,2,k)
543     &            ,0.,nbdim)
544     
545                Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
546C                deallocate(temprecv%var)
547            endif
548
549C
550      enddo
551
552          End Subroutine ExchangeSamelevel
553
554          Subroutine Agrif_Send_3Darray(tab3D,bounds,imin,imax,k)
555          integer, dimension(3) :: bounds, imin, imax
556          real,dimension(bounds(1):,bounds(2):,bounds(3):),target
557     &                             :: tab3D
558          integer :: k
559          integer :: etiquette = 100
560          integer :: datasize, code
561#include "mpif.h"   
562
563          datasize = SIZE(tab3D(
564     &                       imin(1):imax(1),
565     &                        imin(2):imax(2),
566     &                        imin(3):imax(3)))
567       
568                   Call MPI_SEND(tab3D(
569     &                        imin(1):imax(1),
570     &                        imin(2):imax(2),
571     &                        imin(3):imax(3)),
572     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
573     &                        MPI_COMM_WORLD,code)
574     
575         End Subroutine Agrif_Send_3Darray
576
577#else
578      Subroutine Agrif_mpp_empty()
579      End Subroutine Agrif_mpp_empty
580#endif
581
582      End Module Agrif_mpp