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.F90 in vendors/AGRIF/CMEMS_2020/AGRIF_FILES – NEMO

source: vendors/AGRIF/CMEMS_2020/AGRIF_FILES/modmpp.F90 @ 10087

Last change on this file since 10087 was 10087, checked in by rblod, 6 years ago

update AGRIF library
  • Property svn:keywords set to Id
File size: 27.4 KB
Line 
1!
2! $Id$
3!
4!     AGRIF (Adaptive Grid Refinement In Fortran)
5!
6!     Copyright (C) 2003 Laurent Debreu (Laurent.Debreu@imag.fr)
7!                        Christophe Vouland (Christophe.Vouland@imag.fr)
8!
9!     This program is free software; you can redistribute it and/or modify
10!     it under the terms of the GNU General Public License as published by
11!     the Free Software Foundation; either version 2 of the License, or
12!     (at your option) any later version.
13!
14!     This program is distributed in the hope that it will be useful,
15!     but WITHOUT ANY WARRANTY; without even the implied warranty of
16!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17!     GNU General Public License for more details.
18!
19!     You should have received a copy of the GNU General Public License
20!     along with this program; if not, write to the Free Software
21!     Foundation, Inc., 59 Temple Place- Suite 330, Boston, MA 02111-1307, USA.
22!
23!
24module Agrif_Mpp
25!
26    use Agrif_Arrays
27    use Agrif_Grids
28!
29    implicit none
30!
31    interface
32        subroutine Agrif_get_proc_info ( imin, imax, jmin, jmax )
33            integer, intent(out) :: imin, imax
34            integer, intent(out) :: jmin, jmax
35        end subroutine Agrif_get_proc_info
36    end interface
37!
38    integer, private :: Agrif_MPI_prec
39!
40    private :: Agrif_get_proc_info
41!
42contains
43!
44#if defined AGRIF_MPI
45!===================================================================================================
46!  subroutine Agrif_MPI_Init
47!---------------------------------------------------------------------------------------------------
48subroutine Agrif_MPI_Init ( comm )
49!---------------------------------------------------------------------------------------------------
50    integer, optional, intent(in) :: comm    !< MPI communicator to be attached to the root grid.
51!
52    include 'mpif.h'
53    integer :: code, ierr
54    logical :: mpi_was_called
55    integer :: current_mpi_prec
56!
57    call MPI_INITIALIZED( mpi_was_called, code )
58    if( code /= MPI_SUCCESS ) then
59        write(*,*) ': Error in routine mpi_initialized'
60        call MPI_ABORT( MPI_COMM_WORLD, code, ierr )
61    endif
62    if( .not. mpi_was_called ) then
63        write(*,*) '### AGRIF Error : you should call Agrif_MPI_Init *after* MPI_Init.'
64        stop
65    endif
66
67    current_mpi_prec = KIND(1.0)
68    if (current_mpi_prec == 4) then
69      Agrif_MPI_prec = MPI_REAL4
70    else
71      Agrif_MPI_prec = MPI_REAL8
72    endif
73!
74    if ( present(comm) ) then
75        call Agrif_MPI_switch_comm(comm)
76    else
77        call Agrif_MPI_switch_comm(MPI_COMM_WORLD)
78    endif
79!
80    Agrif_Mygrid % communicator = Agrif_mpi_comm
81!
82    if ( Agrif_Parallel_sisters ) then
83        call Agrif_Init_ProcList( Agrif_Mygrid % proc_def_list, Agrif_Nbprocs )
84        call Agrif_pl_copy( Agrif_Mygrid % proc_def_list, Agrif_Mygrid % required_proc_list )
85    endif
86!---------------------------------------------------------------------------------------------------
87end subroutine Agrif_MPI_Init
88!===================================================================================================
89!
90!===================================================================================================
91subroutine Agrif_MPI_switch_comm ( comm )
92!---------------------------------------------------------------------------------------------------
93    integer, intent(in) :: comm    !< MPI communicator you want to switch to.
94!
95    include 'mpif.h'
96    integer :: code
97    logical :: mpi_was_called
98!
99    call MPI_INITIALIZED( mpi_was_called, code )
100    if ( .not. mpi_was_called ) return
101!
102    call MPI_COMM_SIZE(comm, Agrif_Nbprocs, code)
103    call MPI_COMM_RANK(comm, Agrif_ProcRank, code)
104    Agrif_mpi_comm = comm
105!---------------------------------------------------------------------------------------------------
106end subroutine Agrif_MPI_switch_comm
107!===================================================================================================
108!
109!===================================================================================================
110function Agrif_MPI_get_grid_comm ( ) result ( comm )
111!---------------------------------------------------------------------------------------------------
112    integer :: comm
113    comm = Agrif_Curgrid % communicator
114!---------------------------------------------------------------------------------------------------
115end function Agrif_MPI_get_grid_comm
116!===================================================================================================
117!
118!===================================================================================================
119subroutine Agrif_MPI_set_grid_comm ( comm )
120!---------------------------------------------------------------------------------------------------
121    integer, intent(in) :: comm
122    Agrif_Curgrid % communicator = comm
123!---------------------------------------------------------------------------------------------------
124end subroutine Agrif_MPI_set_grid_comm
125!===================================================================================================
126!
127!===================================================================================================
128subroutine Agrif_Init_ProcList ( proclist, nbprocs )
129!---------------------------------------------------------------------------------------------------
130    type(Agrif_Proc_List), intent(inout) :: proclist
131    integer,               intent(in)    :: nbprocs
132!
133    include 'mpif.h'
134    type(Agrif_Proc), pointer     :: new_proc
135    integer                       :: p, ierr
136    integer                       :: imin, imax, jmin, jmax
137    integer, dimension(5)         :: local_proc_grid_info
138    integer, dimension(5,nbprocs) :: all_procs_grid_info
139!
140    call Agrif_get_proc_info(imin, imax, jmin, jmax)
141!
142    local_proc_grid_info(:) = (/Agrif_Procrank, imin, jmin, imax, jmax/)
143!
144    call MPI_ALLGATHER(local_proc_grid_info, 5, MPI_INTEGER, &
145                       all_procs_grid_info,  5, MPI_INTEGER, Agrif_mpi_comm, ierr)
146!
147    do p = 1,nbprocs
148!
149        allocate(new_proc)
150        new_proc % pn = all_procs_grid_info(1,p)
151        new_proc % imin(1) = all_procs_grid_info(2,p)
152        new_proc % imin(2) = all_procs_grid_info(3,p)
153        new_proc % imax(1) = all_procs_grid_info(4,p)
154        new_proc % imax(2) = all_procs_grid_info(5,p)
155        call Agrif_pl_append( proclist, new_proc )
156!
157    enddo
158!
159!---------------------------------------------------------------------------------------------------
160end subroutine Agrif_Init_ProcList
161!===================================================================================================
162!
163!===================================================================================================
164!  subroutine Get_External_Data_first
165!---------------------------------------------------------------------------------------------------
166subroutine Get_External_Data_first ( pttruetab, cetruetab, pttruetabwhole, cetruetabwhole,  &
167                                     nbdim, memberoutall, coords, sendtoproc, recvfromproc, &
168                                     imin, imax, imin_recv, imax_recv, bornesmin, bornesmax )
169!---------------------------------------------------------------------------------------------------
170    include 'mpif.h'
171!
172    integer,                                     intent(in)  :: nbdim
173    integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in)  :: pttruetab,     cetruetab
174    integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in)  :: pttruetabwhole,cetruetabwhole
175    logical, dimension(0:Agrif_Nbprocs-1),       intent(in)  :: memberoutall
176    integer, dimension(nbdim),                   intent(in)  :: coords
177    logical, dimension(0:Agrif_Nbprocs-1),       intent(out) :: sendtoproc
178    logical, dimension(0:Agrif_Nbprocs-1),       intent(out) :: recvfromproc
179    integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin,imax
180    integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(out) :: imin_recv,imax_recv
181    integer, dimension(nbdim,0:Agrif_NbProcs-1), intent(in) :: bornesmin, bornesmax
182!
183    integer :: imintmp, imaxtmp, i, j, k, i1
184    integer :: imin1,imax1
185    logical :: tochange,tochangebis
186    integer, dimension(nbdim,0:Agrif_NbProcs-1)    :: pttruetab2,cetruetab2
187!
188! pttruetab2 and cetruetab2 are modified arrays in order to always
189! send the most inner points
190!
191    pttruetab2(:,Agrif_Procrank) = pttruetab(:,Agrif_Procrank)
192    cetruetab2(:,Agrif_Procrank) = cetruetab(:,Agrif_Procrank)
193!
194    do k = 0,Agrif_Nbprocs-1
195    do i = 1,nbdim
196        tochangebis = .TRUE.
197        DO i1 = 1,nbdim
198            IF (i /= i1) THEN
199                IF ( (pttruetab(i1,Agrif_Procrank) /= pttruetab(i1,k))  .OR. &
200                     (cetruetab(i1,Agrif_Procrank) /= cetruetab(i1,k))) THEN
201                    tochangebis = .FALSE.
202                    EXIT
203                ENDIF
204            ENDIF
205        ENDDO
206        IF (tochangebis) THEN
207            imin1 = max(pttruetab(i,Agrif_Procrank), pttruetab(i,k))
208            imax1 = min(cetruetab(i,Agrif_Procrank), cetruetab(i,k))
209! Always send the most interior points
210
211            tochange = .false.
212            IF (cetruetab(i,Agrif_Procrank) > cetruetab(i,k)) THEN
213                DO j=imin1,imax1
214                    IF ((bornesmax(i,k)-j) > (j-bornesmin(i,Agrif_Procrank))) THEN
215                        imintmp = j+1
216                        tochange = .TRUE.
217                    ELSE
218                        EXIT
219                    ENDIF
220                ENDDO
221            ENDIF
222
223            if (tochange) then
224                pttruetab2(i,Agrif_Procrank) = imintmp
225            endif
226
227            tochange = .FALSE.
228            imaxtmp=0
229            IF (pttruetab(i,Agrif_Procrank) < pttruetab(i,k)) THEN
230                DO j=imax1,imin1,-1
231                    IF ((j-bornesmin(i,k)) > (bornesmax(i,Agrif_Procrank)-j)) THEN
232                        imaxtmp = j-1
233                        tochange = .TRUE.
234                    ELSE
235                        EXIT
236                    ENDIF
237                ENDDO
238            ENDIF
239
240            if (tochange) then
241                cetruetab2(i,Agrif_Procrank) = imaxtmp
242            endif
243        ENDIF
244    enddo
245    enddo
246
247    do k = 0,Agrif_NbProcs-1
248!
249        sendtoproc(k) = .true.
250!
251        IF ( .not. memberoutall(k) ) THEN
252            sendtoproc(k) = .false.
253        ELSE
254!CDIR SHORTLOOP
255        do i = 1,nbdim
256            imin(i,k) = max(pttruetab2(i,Agrif_Procrank), pttruetabwhole(i,k))
257            imax(i,k) = min(cetruetab2(i,Agrif_Procrank), cetruetabwhole(i,k))
258!
259            if ( (imin(i,k) > imax(i,k)) .and. (coords(i) /= 0) ) then
260                sendtoproc(k) = .false.
261            endif
262        enddo
263        ENDIF
264    enddo
265!
266    call Exchangesamelevel_first(sendtoproc,nbdim,imin,imax,recvfromproc,imin_recv,imax_recv)
267!---------------------------------------------------------------------------------------------------
268end subroutine Get_External_Data_first
269!===================================================================================================
270!
271!===================================================================================================
272!  subroutine ExchangeSameLevel_first
273!---------------------------------------------------------------------------------------------------
274subroutine ExchangeSameLevel_first ( sendtoproc, nbdim, imin, imax, recvfromproc, &
275                                     imin_recv, imax_recv )
276!---------------------------------------------------------------------------------------------------
277    LOGICAL, DIMENSION(0:Agrif_Nbprocs-1),       intent(in)  :: sendtoproc
278    INTEGER,                                     intent(in)  :: nbdim
279    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in)  :: imin
280    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in)  :: imax
281    LOGICAL, DIMENSION(0:Agrif_Nbprocs-1),       intent(out) :: recvfromproc
282    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(out) :: imin_recv
283    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(out) :: imax_recv
284!
285    include 'mpif.h'
286    INTEGER :: k
287    INTEGER :: etiquette = 100
288    INTEGER :: code
289    LOGICAL :: res
290    INTEGER, DIMENSION(MPI_STATUS_SIZE)   :: statut
291    INTEGER, DIMENSION(nbdim,2,0:Agrif_Nbprocs-1)    :: iminmax_temp
292
293    do k = 0,Agrif_ProcRank-1
294!
295        call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,code)
296!
297        if (sendtoproc(k)) then
298            iminmax_temp(:,1,k) = imin(:,k)
299            iminmax_temp(:,2,k) = imax(:,k)
300            call MPI_SEND(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette,Agrif_mpi_comm,code)
301        endif
302!
303    enddo
304!
305!   Reception from others processors of the necessary part of the parent grid
306    do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
307!
308        call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,statut,code)
309        recvfromproc(k) = res
310!
311        if (recvfromproc(k)) then
312            call MPI_RECV(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette, &
313                    Agrif_mpi_comm,statut,code)
314            imin_recv(:,k) = iminmax_temp(:,1,k)
315            imax_recv(:,k) = iminmax_temp(:,2,k)
316        endif
317!
318    enddo
319
320!   Reception from others processors of the necessary part of the parent grid
321    do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
322!
323        call MPI_SEND(sendtoproc(k),1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,code)
324!
325        if (sendtoproc(k)) then
326!
327            iminmax_temp(:,1,k) = imin(:,k)
328            iminmax_temp(:,2,k) = imax(:,k)
329
330            call MPI_SEND(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette, &
331                    Agrif_mpi_comm,code)
332        endif
333!
334    enddo
335!
336!
337!   Reception from others processors of the necessary part of the parent grid
338    do k = Agrif_ProcRank-1,0,-1
339!
340        call MPI_RECV(res,1,MPI_LOGICAL,k,etiquette,Agrif_mpi_comm,statut,code)
341        recvfromproc(k) = res
342!
343        if (recvfromproc(k)) then
344!
345            call MPI_RECV(iminmax_temp(:,:,k),2*nbdim,MPI_INTEGER,k,etiquette, &
346                    Agrif_mpi_comm,statut,code)
347
348            imin_recv(:,k) = iminmax_temp(:,1,k)
349            imax_recv(:,k) = iminmax_temp(:,2,k)
350        endif
351!
352    enddo
353!---------------------------------------------------------------------------------------------------
354end subroutine ExchangeSamelevel_first
355!===================================================================================================
356!
357!===================================================================================================
358!  subroutine ExchangeSameLevel
359!---------------------------------------------------------------------------------------------------
360subroutine ExchangeSameLevel ( sendtoproc, recvfromproc, nbdim,    &
361                               pttruetabwhole, cetruetabwhole,     &
362                               imin, imax, imin_recv, imax_recv,   &
363                               memberout, tempC, tempCextend )
364!---------------------------------------------------------------------------------------------------
365    LOGICAL, DIMENSION(0:Agrif_Nbprocs-1),       intent(in)    :: sendtoproc
366    LOGICAL, DIMENSION(0:Agrif_Nbprocs-1),       intent(in)    :: recvfromproc
367    INTEGER,                                     intent(in)    :: nbdim
368    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in)    :: pttruetabwhole
369    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in)    :: cetruetabwhole
370    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in)    :: imin,      imax
371    INTEGER, DIMENSION(nbdim,0:Agrif_Nbprocs-1), intent(in)    :: imin_recv, imax_recv
372    LOGICAL,                                     intent(in)    :: memberout
373    TYPE(Agrif_Variable), pointer,               intent(inout) :: tempC, tempCextend
374!
375    include 'mpif.h'
376    INTEGER :: i,k
377    INTEGER :: etiquette = 100
378    INTEGER :: code, datasize
379    INTEGER, DIMENSION(MPI_STATUS_SIZE)   :: statut
380    TYPE(Agrif_Variable), pointer, SAVE   :: temprecv
381!
382    IF (memberout) THEN
383        call Agrif_array_allocate(tempCextend, pttruetabwhole(:,Agrif_ProcRank),  &
384                                               cetruetabwhole(:,Agrif_ProcRank),nbdim)
385        call Agrif_var_set_array_tozero(tempCextend,nbdim)
386    ENDIF
387!
388    IF (sendtoproc(Agrif_ProcRank)) THEN
389        call Agrif_var_copy_array(tempCextend,imin(:,Agrif_Procrank),imax(:,Agrif_Procrank), &
390                                  tempC,      imin(:,Agrif_Procrank),imax(:,Agrif_Procrank), &
391                                  nbdim)
392    ENDIF
393!
394    do k = 0,Agrif_ProcRank-1
395!
396        if (sendtoproc(k)) then
397!
398            datasize = 1
399!
400!CDIR SHORTLOOP
401            do i = 1,nbdim
402                datasize = datasize * (imax(i,k)-imin(i,k)+1)
403            enddo
404!
405            SELECT CASE(nbdim)
406            CASE(1)
407                call MPI_SEND(tempC%array1(imin(1,k):imax(1,k)),    &
408                        datasize,Agrif_MPI_prec,k,etiquette,      &
409                        Agrif_mpi_comm,code)
410            CASE(2)
411                call MPI_SEND(tempC%array2(imin(1,k):imax(1,k),     &
412                                           imin(2,k):imax(2,k)),    &
413                        datasize,Agrif_MPI_prec,k,etiquette,      &
414                        Agrif_mpi_comm,code)
415            CASE(3)
416                call Agrif_Send_3Darray(tempC%array3,lbound(tempC%array3),imin(:,k),imax(:,k),k)
417            CASE(4)
418                call MPI_SEND(tempC%array4(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                        datasize,Agrif_MPI_prec,k,etiquette,      &
423                        Agrif_mpi_comm,code)
424            CASE(5)
425                call MPI_SEND(tempC%array5(imin(1,k):imax(1,k),     &
426                                           imin(2,k):imax(2,k),     &
427                                           imin(3,k):imax(3,k),     &
428                                           imin(4,k):imax(4,k),     &
429                                           imin(5,k):imax(5,k)),    &
430                        datasize,Agrif_MPI_prec,k,etiquette,      &
431                        Agrif_mpi_comm,code)
432            CASE(6)
433                call MPI_SEND(tempC%array6(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                        datasize,Agrif_MPI_prec,k,etiquette,      &
440                        Agrif_mpi_comm,code)
441            END SELECT
442!
443        endif
444    enddo
445!
446!   Reception from others processors of the necessary part of the parent grid
447    do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
448!
449        if (recvfromproc(k)) then
450!
451            datasize = 1
452!
453!CDIR SHORTLOOP
454            do i = 1,nbdim
455                datasize = datasize * (imax_recv(i,k)-imin_recv(i,k)+1)
456            enddo
457
458            if (.not.associated(temprecv)) allocate(temprecv)
459            call Agrif_array_allocate(temprecv,imin_recv(:,k),imax_recv(:,k),nbdim)
460
461            SELECT CASE(nbdim)
462            CASE(1)
463                call MPI_RECV(temprecv%array1,datasize,Agrif_MPI_prec,k,etiquette, &
464                        Agrif_mpi_comm,statut,code)
465            CASE(2)
466                call MPI_RECV(temprecv%array2,datasize,Agrif_MPI_prec,k,etiquette, &
467                        Agrif_mpi_comm,statut,code)
468            CASE(3)
469                call MPI_RECV(temprecv%array3,datasize,Agrif_MPI_prec,k,etiquette, &
470                        Agrif_mpi_comm,statut,code)
471            CASE(4)
472                call MPI_RECV(temprecv%array4,datasize,Agrif_MPI_prec,k,etiquette, &
473                        Agrif_mpi_comm,statut,code)
474            CASE(5)
475                call MPI_RECV(temprecv%array5,datasize,Agrif_MPI_prec,k,etiquette, &
476                        Agrif_mpi_comm,statut,code)
477            CASE(6)
478                call MPI_RECV(temprecv%array6,datasize,Agrif_MPI_prec,k,etiquette, &
479                        Agrif_mpi_comm,statut,code)
480            END SELECT
481
482            call Agrif_var_replace_value(tempCextend,temprecv,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
483            call Agrif_array_deallocate(temprecv,nbdim)
484!
485        endif
486    enddo
487
488!   Reception from others processors of the necessary part of the parent grid
489    do k = Agrif_ProcRank+1,Agrif_Nbprocs-1
490!
491        if (sendtoproc(k)) then
492!
493            SELECT CASE(nbdim)
494            CASE(1)
495                datasize=SIZE(tempC%array1(imin(1,k):imax(1,k)))
496                call MPI_SEND(tempC%array1(imin(1,k):imax(1,k)),    &
497                        datasize,Agrif_MPI_prec,k,etiquette,      &
498                        Agrif_mpi_comm,code)
499            CASE(2)
500                datasize=SIZE(tempC%array2(imin(1,k):imax(1,k),     &
501                                               imin(2,k):imax(2,k)))
502                call MPI_SEND(tempC%array2(imin(1,k):imax(1,k),     &
503                                               imin(2,k):imax(2,k)),    &
504                        datasize,Agrif_MPI_prec,k,etiquette,      &
505                        Agrif_mpi_comm,code)
506            CASE(3)
507                datasize=SIZE(tempC%array3(imin(1,k):imax(1,k),     &
508                                               imin(2,k):imax(2,k),     &
509                                               imin(3,k):imax(3,k)))
510                call MPI_SEND(tempC%array3(imin(1,k):imax(1,k),     &
511                                               imin(2,k):imax(2,k),     &
512                                               imin(3,k):imax(3,k)),    &
513                        datasize,Agrif_MPI_prec,k,etiquette,      &
514                        Agrif_mpi_comm,code)
515            CASE(4)
516                datasize=SIZE(tempC%array4(imin(1,k):imax(1,k),     &
517                                               imin(2,k):imax(2,k),     &
518                                               imin(3,k):imax(3,k),     &
519                                               imin(4,k):imax(4,k)))
520                call MPI_SEND(tempC%array4(imin(1,k):imax(1,k),     &
521                                               imin(2,k):imax(2,k),     &
522                                               imin(3,k):imax(3,k),     &
523                                               imin(4,k):imax(4,k)),    &
524                        datasize,Agrif_MPI_prec,k,etiquette,      &
525                        Agrif_mpi_comm,code)
526            CASE(5)
527                datasize=SIZE(tempC%array5(imin(1,k):imax(1,k),     &
528                                               imin(2,k):imax(2,k),     &
529                                               imin(3,k):imax(3,k),     &
530                                               imin(4,k):imax(4,k),     &
531                                               imin(5,k):imax(5,k)))
532                call MPI_SEND(tempC%array5(imin(1,k):imax(1,k),     &
533                                               imin(2,k):imax(2,k),     &
534                                               imin(3,k):imax(3,k),     &
535                                               imin(4,k):imax(4,k),     &
536                                               imin(5,k):imax(5,k)),    &
537                        datasize,Agrif_MPI_prec,k,etiquette,      &
538                        Agrif_mpi_comm,code)
539            CASE(6)
540                datasize=SIZE(tempC%array6(imin(1,k):imax(1,k),     &
541                                               imin(2,k):imax(2,k),     &
542                                               imin(3,k):imax(3,k),     &
543                                               imin(4,k):imax(4,k),     &
544                                               imin(5,k):imax(5,k),     &
545                                               imin(6,k):imax(6,k)))
546                call MPI_SEND(tempC%array6(imin(1,k):imax(1,k),     &
547                                               imin(2,k):imax(2,k),     &
548                                               imin(3,k):imax(3,k),     &
549                                               imin(4,k):imax(4,k),     &
550                                               imin(5,k):imax(5,k),     &
551                                               imin(6,k):imax(6,k)),    &
552                        datasize,Agrif_MPI_prec,k,etiquette,      &
553                        Agrif_mpi_comm,code)
554            END SELECT
555!
556        endif
557!
558    enddo
559!
560!   Reception from others processors of the necessary part of the parent grid
561    do k = Agrif_ProcRank-1,0,-1
562!
563        if (recvfromproc(k)) then
564!
565            if (.not.associated(temprecv)) allocate(temprecv)
566            call Agrif_array_allocate(temprecv,imin_recv(:,k),imax_recv(:,k),nbdim)
567
568            SELECT CASE(nbdim)
569            CASE(1)
570                datasize=SIZE(temprecv%array1)
571                call MPI_RECV(temprecv%array1,datasize,Agrif_MPI_prec,k,etiquette,&
572                        Agrif_mpi_comm,statut,code)
573            CASE(2)
574                datasize=SIZE(temprecv%array2)
575                call MPI_RECV(temprecv%array2,datasize,Agrif_MPI_prec,k,etiquette,&
576                        Agrif_mpi_comm,statut,code)
577            CASE(3)
578                datasize=SIZE(temprecv%array3)
579                call MPI_RECV(temprecv%array3,datasize,Agrif_MPI_prec,k,etiquette,&
580                        Agrif_mpi_comm,statut,code)
581            CASE(4)
582                datasize=SIZE(temprecv%array4)
583                call MPI_RECV(temprecv%array4,datasize,Agrif_MPI_prec,k,etiquette,&
584                          Agrif_mpi_comm,statut,code)
585            CASE(5)
586                datasize=SIZE(temprecv%array5)
587                call MPI_RECV(temprecv%array5,datasize,Agrif_MPI_prec,k,etiquette,&
588                         Agrif_mpi_comm,statut,code)
589            CASE(6)
590                datasize=SIZE(temprecv%array6)
591                call MPI_RECV(temprecv%array6,datasize,Agrif_MPI_prec,k,etiquette,&
592                        Agrif_mpi_comm,statut,code)
593            END SELECT
594
595            call Agrif_var_replace_value(tempCextend,temprecv,imin_recv(:,k),imax_recv(:,k),0.,nbdim)
596            call Agrif_array_deallocate(temprecv,nbdim)
597!
598        endif
599!
600    enddo
601!---------------------------------------------------------------------------------------------------
602end subroutine ExchangeSamelevel
603!===================================================================================================
604!
605!===================================================================================================
606!  subroutine Agrif_Send_3Darray
607!---------------------------------------------------------------------------------------------------
608subroutine Agrif_Send_3Darray ( tab3D, bounds, imin, imax, k )
609!---------------------------------------------------------------------------------------------------
610    integer, dimension(3),                                     intent(in) :: bounds
611    real, dimension(bounds(1):,bounds(2):,bounds(3):), target, intent(in) :: tab3D
612    integer, dimension(3),                                     intent(in) :: imin, imax
613    integer,                                                   intent(in) :: k
614!
615    integer :: etiquette = 100
616    integer :: datasize, code
617    include 'mpif.h'
618
619    datasize = SIZE(tab3D(imin(1):imax(1),  &
620                          imin(2):imax(2),  &
621                          imin(3):imax(3)))
622
623    call MPI_SEND( tab3D( imin(1):imax(1),  &
624                          imin(2):imax(2),  &
625                          imin(3):imax(3)), &
626                          datasize,Agrif_MPI_prec,k,etiquette,Agrif_mpi_comm,code)
627!---------------------------------------------------------------------------------------------------
628end subroutine Agrif_Send_3Darray
629!===================================================================================================
630!
631#else
632    subroutine dummy_Agrif_Mpp ()
633    end subroutine dummy_Agrif_Mpp
634#endif
635!
636end Module Agrif_Mpp
Note: See TracBrowser for help on using the repository browser.