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

Last change on this file since 779 was 779, checked in by rblod, 16 years ago

Agrif improvment for vectorization, see ticket #41
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 19.4 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!CDIR SHORTLOOP
149        do i = 1,nbdim
150C
151          imin(i,k) = max(pttruetab2(i,Agrif_Procrank),
152     &                    pttruetabwhole(i,k))
153          imax(i,k) = min(cetruetab2(i,Agrif_Procrank),
154     &                    cetruetabwhole(i,k))
155C
156          if (imin(i,k) > imax(i,k)) then
157C
158              sendtoproc(k) = .false.
159C
160          endif
161C
162        enddo
163        IF (.NOT.memberoutall(k)) THEN
164           sendtoproc(k) = .FALSE.
165        ENDIF
166C
167      enddo
168
169
170c       IF (.NOT.memberin) sendtoproc = .FALSE.
171
172      IF (memberout) THEN
173      Call Agrif_nbdim_allocation(tempCextend%var,
174     &                 pttruetabwhole(:,Agrif_ProcRank),
175     &                 cetruetabwhole(:,Agrif_ProcRank),nbdim)
176      call Agrif_nbdim_Full_VarEQreal(tempCextend%var,0.,nbdim)
177      ENDIF
178
179      IF (sendtoproc(Agrif_ProcRank)) THEN
180           Call Agrif_nbdim_VarEQvar(tempCextend%var,
181     &                               imin(:,Agrif_Procrank),
182     &                               imax(:,Agrif_Procrank),
183     &                               tempC%var,
184     &                               imin(:,Agrif_Procrank),
185     &                               imax(:,Agrif_Procrank),
186     &                               nbdim)
187      ENDIF
188
189      Call Exchangesamelevel(sendtoproc,nbdim,imin,imax,tempC,
190     &     tempCextend)
191
192      End Subroutine Get_External_Data
193
194       Subroutine ExchangeSameLevel(sendtoproc,nbdim,imin,imax,
195     &          tempC,tempCextend)
196      Implicit None
197      INTEGER :: nbdim
198      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin,imax
199      INTEGER,DIMENSION(nbdim,2,0:Agrif_Nbprocs-1) :: iminmax_temp
200      INTEGER,DIMENSION(nbdim,0:Agrif_Nbprocs-1) :: imin_recv,imax_recv
201      TYPE(Agrif_PVARIABLE) :: tempC,tempCextend
202      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1)       :: sendtoproc
203      LOGICAL,DIMENSION(0:Agrif_Nbprocs-1)       :: recvfromproc
204      LOGICAL                                    :: res
205      TYPE(AGRIF_PVARIABLE), SAVE                      :: temprecv
206
207#include "mpif.h"
208          INTEGER :: i,k
209          INTEGER :: etiquette = 100
210          INTEGER :: code, datasize
211          INTEGER,DIMENSION(MPI_STATUS_SIZE)   :: statut
212
213
214      do k = 0,Agrif_ProcRank-1
215C
216C
217            Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
218     &                    MPI_COMM_WORLD,code)
219C
220            if (sendtoproc(k)) then
221C
222                iminmax_temp(:,1,k) = imin(:,k)
223                iminmax_temp(:,2,k) = imax(:,k)
224
225                Call MPI_SEND(iminmax_temp(:,:,k),
226     &                        2*nbdim,MPI_INTEGER,k,etiquette,
227     &                        MPI_COMM_WORLD,code)
228C
229                datasize = 1
230C
231!CDIR SHORTLOOP
232                do i = 1,nbdim
233C
234                  datasize = datasize * (imax(i,k)-imin(i,k)+1)
235C
236                enddo
237C
238                SELECT CASE(nbdim)
239                CASE(1)
240                   Call MPI_SEND(tempC%var%array1(
241     &                        imin(1,k):imax(1,k)),
242     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
243     &                        MPI_COMM_WORLD,code)
244                CASE(2)
245                   Call MPI_SEND(tempC%var%array2(
246     &                        imin(1,k):imax(1,k),
247     &                        imin(2,k):imax(2,k)),
248     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
249     &                        MPI_COMM_WORLD,code)
250                CASE(3)
251                  Call Agrif_Send_3Darray(tempC%var%array3,
252     &             lbound(tempC%var%array3),imin(:,k),imax(:,k),k)
253                CASE(4)
254                   Call MPI_SEND(tempC%var%array4(
255     &                        imin(1,k):imax(1,k),
256     &                        imin(2,k):imax(2,k),
257     &                        imin(3,k):imax(3,k),
258     &                        imin(4,k):imax(4,k)),
259     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
260     &                        MPI_COMM_WORLD,code)
261                CASE(5)
262                   Call MPI_SEND(tempC%var%array5(
263     &                        imin(1,k):imax(1,k),
264     &                        imin(2,k):imax(2,k),
265     &                        imin(3,k):imax(3,k),
266     &                        imin(4,k):imax(4,k),
267     &                        imin(5,k):imax(5,k)),
268     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
269     &                        MPI_COMM_WORLD,code)
270                CASE(6)
271                   Call MPI_SEND(tempC%var%array6(
272     &                        imin(1,k):imax(1,k),
273     &                        imin(2,k):imax(2,k),
274     &                        imin(3,k):imax(3,k),
275     &                        imin(4,k):imax(4,k),
276     &                        imin(5,k):imax(5,k),
277     &                        imin(6,k):imax(6,k)),
278     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
279     &                        MPI_COMM_WORLD,code)
280                END SELECT
281C
282            endif
283
284C
285      enddo
286C
287C
288C     Reception from others processors of the necessary part of the parent grid
289      do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
290C
291C
292            Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
293     &                    MPI_COMM_WORLD,statut,code)
294C
295            recvfromproc(k) = res
296
297C
298            if (recvfromproc(k)) then
299C
300                Call MPI_RECV(iminmax_temp(:,:,k),
301     &                        2*nbdim,MPI_INTEGER,k,etiquette,
302     &                        MPI_COMM_WORLD,statut,code)
303
304                imin_recv(:,k) = iminmax_temp(:,1,k)
305                imax_recv(:,k) = iminmax_temp(:,2,k)
306
307                datasize = 1
308C
309!CDIR SHORTLOOP
310                do i = 1,nbdim
311C
312                datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
313C
314                enddo
315
316             IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
317             call Agrif_nbdim_allocation(temprecv%var,imin_recv(:,k),
318     &   imax_recv(:,k),nbdim)
319            SELECT CASE(nbdim)
320            CASE(1)
321              Call MPI_RECV(temprecv%var%array1,
322     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
323     &               MPI_COMM_WORLD,statut,code)
324            CASE(2)
325              Call MPI_RECV(temprecv%var%array2,
326     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
327     &               MPI_COMM_WORLD,statut,code)
328            CASE(3)
329              Call MPI_RECV(temprecv%var%array3,
330     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
331     &               MPI_COMM_WORLD,statut,code)
332
333            CASE(4)
334              Call MPI_RECV(temprecv%var%array4,
335     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
336     &               MPI_COMM_WORLD,statut,code)
337            CASE(5)
338              Call MPI_RECV(temprecv%var%array5,
339     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
340     &               MPI_COMM_WORLD,statut,code)
341            CASE(6)
342              Call MPI_RECV(temprecv%var%array6,
343     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
344     &               MPI_COMM_WORLD,statut,code)
345       END SELECT
346                       
347            Call where_valtabtotab_mpi(tempCextend%var,
348     &             temprecv%var,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
349     
350                Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
351C                deallocate(temprecv%var)
352
353            endif
354
355C
356      enddo
357
358C     Reception from others processors of the necessary part of the parent grid
359      do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
360C
361C
362           
363            Call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,
364     &                    MPI_COMM_WORLD,code)
365C
366            if (sendtoproc(k)) then
367C
368                iminmax_temp(:,1,k) = imin(:,k)
369                iminmax_temp(:,2,k) = imax(:,k)
370
371                Call MPI_SEND(iminmax_temp(:,:,k),
372     &                        2*nbdim,MPI_INTEGER,k,etiquette,
373     &                        MPI_COMM_WORLD,code)
374C
375                SELECT CASE(nbdim)
376                CASE(1)
377                datasize=SIZE(tempC%var%array1(
378     &                        imin(1,k):imax(1,k)))
379                   Call MPI_SEND(tempC%var%array1(
380     &                        imin(1,k):imax(1,k)),
381     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
382     &                        MPI_COMM_WORLD,code)
383                CASE(2)
384                datasize=SIZE(tempC%var%array2(
385     &                        imin(1,k):imax(1,k),
386     &                        imin(2,k):imax(2,k)))
387                   Call MPI_SEND(tempC%var%array2(
388     &                        imin(1,k):imax(1,k),
389     &                        imin(2,k):imax(2,k)),
390     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
391     &                        MPI_COMM_WORLD,code)
392                CASE(3)
393                datasize=SIZE(tempC%var%array3(
394     &                        imin(1,k):imax(1,k),
395     &                        imin(2,k):imax(2,k),
396     &                        imin(3,k):imax(3,k)))
397                   Call MPI_SEND(tempC%var%array3(
398     &                        imin(1,k):imax(1,k),
399     &                        imin(2,k):imax(2,k),
400     &                        imin(3,k):imax(3,k)),
401     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
402     &                        MPI_COMM_WORLD,code)
403                CASE(4)
404                datasize=SIZE(tempC%var%array4(
405     &                        imin(1,k):imax(1,k),
406     &                        imin(2,k):imax(2,k),
407     &                        imin(3,k):imax(3,k),
408     &                        imin(4,k):imax(4,k)))
409                   Call MPI_SEND(tempC%var%array4(
410     &                        imin(1,k):imax(1,k),
411     &                        imin(2,k):imax(2,k),
412     &                        imin(3,k):imax(3,k),
413     &                        imin(4,k):imax(4,k)),
414     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
415     &                        MPI_COMM_WORLD,code)
416                CASE(5)
417                datasize=SIZE(tempC%var%array5(
418     &                        imin(1,k):imax(1,k),
419     &                        imin(2,k):imax(2,k),
420     &                        imin(3,k):imax(3,k),
421     &                        imin(4,k):imax(4,k),
422     &                        imin(5,k):imax(5,k)))
423                   Call MPI_SEND(tempC%var%array5(
424     &                        imin(1,k):imax(1,k),
425     &                        imin(2,k):imax(2,k),
426     &                        imin(3,k):imax(3,k),
427     &                        imin(4,k):imax(4,k),
428     &                        imin(5,k):imax(5,k)),
429     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
430     &                        MPI_COMM_WORLD,code)
431                CASE(6)
432                datasize=SIZE(tempC%var%array6(
433     &                        imin(1,k):imax(1,k),
434     &                        imin(2,k):imax(2,k),
435     &                        imin(3,k):imax(3,k),
436     &                        imin(4,k):imax(4,k),
437     &                        imin(5,k):imax(5,k),
438     &                        imin(6,k):imax(6,k)))
439                   Call MPI_SEND(tempC%var%array6(
440     &                        imin(1,k):imax(1,k),
441     &                        imin(2,k):imax(2,k),
442     &                        imin(3,k):imax(3,k),
443     &                        imin(4,k):imax(4,k),
444     &                        imin(5,k):imax(5,k),
445     &                        imin(6,k):imax(6,k)),
446     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
447     &                        MPI_COMM_WORLD,code)
448                END SELECT
449C
450            endif
451
452C
453      enddo
454C
455C
456C     Reception from others processors of the necessary part of the parent grid
457      do k = Agrif_ProcRank-1,0,-1
458C
459C
460            Call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,
461     &                    MPI_COMM_WORLD,statut,code)
462C
463            recvfromproc(k) = res
464
465C
466            if (recvfromproc(k)) then
467C
468                Call MPI_RECV(iminmax_temp(:,:,k),
469     &                        2*nbdim,MPI_INTEGER,k,etiquette,
470     &                        MPI_COMM_WORLD,statut,code)
471
472C                imin_recv(:,k) = iminmax_temp(:,1,k)
473C                imax_recv(:,k) = iminmax_temp(:,2,k)
474
475C                datasize = 1
476C
477C                do i = 1,nbdim
478C
479C                datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
480C
481C                enddo
482             IF (.Not.Associated(temprecv%var)) allocate(temprecv%var)
483             call Agrif_nbdim_allocation(temprecv%var,
484     &   iminmax_temp(:,1,k),iminmax_temp(:,2,k),nbdim)
485            SELECT CASE(nbdim)
486            CASE(1)
487              datasize=SIZE(temprecv%var%array1)
488              Call MPI_RECV(temprecv%var%array1,
489     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
490     &               MPI_COMM_WORLD,statut,code)
491            CASE(2)
492              datasize=SIZE(temprecv%var%array2)
493              Call MPI_RECV(temprecv%var%array2,
494     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
495     &               MPI_COMM_WORLD,statut,code)
496            CASE(3)
497              datasize=SIZE(temprecv%var%array3)
498              Call MPI_RECV(temprecv%var%array3,
499     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
500     &               MPI_COMM_WORLD,statut,code)
501
502            CASE(4)
503              datasize=SIZE(temprecv%var%array4)
504              Call MPI_RECV(temprecv%var%array4,
505     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
506     &               MPI_COMM_WORLD,statut,code)
507            CASE(5)
508              datasize=SIZE(temprecv%var%array5)
509              Call MPI_RECV(temprecv%var%array5,
510     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
511     &               MPI_COMM_WORLD,statut,code)
512            CASE(6)
513              datasize=SIZE(temprecv%var%array6)
514              Call MPI_RECV(temprecv%var%array6,
515     &               datasize,MPI_DOUBLE_PRECISION,k,etiquette,
516     &               MPI_COMM_WORLD,statut,code)
517          END SELECT
518           
519            Call where_valtabtotab_mpi(tempCextend%var,
520     &             temprecv%var,iminmax_temp(:,1,k),iminmax_temp(:,2,k)
521     &            ,0.,nbdim)
522     
523                Call Agrif_nbdim_deallocation(temprecv%var,nbdim)
524C                deallocate(temprecv%var)
525            endif
526
527C
528      enddo
529
530          End Subroutine ExchangeSamelevel
531
532          Subroutine Agrif_Send_3Darray(tab3D,bounds,imin,imax,k)
533          integer, dimension(3) :: bounds, imin, imax
534          real,dimension(bounds(1):,bounds(2):,bounds(3):),target
535     &                             :: tab3D
536          integer :: k
537          integer :: etiquette = 100
538          integer :: datasize, code
539#include "mpif.h"   
540
541          datasize = SIZE(tab3D(
542     &                       imin(1):imax(1),
543     &                        imin(2):imax(2),
544     &                        imin(3):imax(3)))
545       
546                   Call MPI_SEND(tab3D(
547     &                        imin(1):imax(1),
548     &                        imin(2):imax(2),
549     &                        imin(3):imax(3)),
550     &                        datasize,MPI_DOUBLE_PRECISION,k,etiquette,
551     &                        MPI_COMM_WORLD,code)
552     
553         End Subroutine Agrif_Send_3Darray
554
555#else
556      Subroutine Agrif_mpp_empty()
557      End Subroutine Agrif_mpp_empty
558#endif
559
560      End Module Agrif_mpp
Note: See TracBrowser for help on using the repository browser.