source: LMDZ5/branches/testing/libf/dyn3dmem/parallel.F90 @ 1856

Last change on this file since 1856 was 1707, checked in by Laurent Fairhead, 12 years ago

Version testing basée sur la r1706


Testing release based on r1706

File size: 18.7 KB
Line 
1!
2! $Id$
3!
4  module parallel
5  USE mod_const_mpi
6   
7    INTEGER,PARAMETER :: halo_max=3
8   
9    LOGICAL,SAVE :: using_mpi
10    LOGICAL,SAVE :: using_omp
11   
12    integer, save :: mpi_size
13    integer, save :: mpi_rank
14    integer, save :: jj_begin
15    integer, save :: jj_end
16    integer, save :: jj_nb
17    integer, save :: ij_begin
18    integer, save :: ij_end
19    logical, save :: pole_nord
20    logical, save :: pole_sud
21
22    integer,save  :: jjb_u
23    integer,save  :: jje_u
24    integer,save  :: jjnb_u
25    integer,save  :: jjb_v
26    integer,save  :: jje_v
27    integer,save  :: jjnb_v   
28
29    integer,save  :: ijb_u
30    integer,save  :: ije_u
31    integer,save  :: ijnb_u   
32   
33    integer,save  :: ijb_v
34    integer,save  :: ije_v
35    integer,save  :: ijnb_v   
36     
37   
38    integer, allocatable, save, dimension(:) :: jj_begin_para
39    integer, allocatable, save, dimension(:) :: jj_end_para
40    integer, allocatable, save, dimension(:) :: jj_nb_para
41    integer, save :: OMP_CHUNK
42    integer, save :: omp_rank
43    integer, save :: omp_size 
44!$OMP THREADPRIVATE(omp_rank)
45
46    TYPE distrib
47      integer :: jj_begin
48      integer :: jj_end
49      integer :: jj_nb
50      integer :: ij_begin
51      integer :: ij_end
52
53      integer  :: jjb_u
54      integer  :: jje_u
55      integer  :: jjnb_u
56      integer  :: jjb_v
57      integer  :: jje_v
58      integer  :: jjnb_v   
59 
60      integer  :: ijb_u
61      integer  :: ije_u
62      integer  :: ijnb_u   
63   
64      integer  :: ijb_v
65      integer  :: ije_v
66      integer  :: ijnb_v   
67     
68   
69      integer, pointer :: jj_begin_para(:) => NULL()
70      integer, pointer :: jj_end_para(:) => NULL()
71      integer, pointer :: jj_nb_para(:) => NULL()
72    END TYPE distrib 
73   
74    INTERFACE ASSIGNMENT (=)
75      MODULE PROCEDURE copy_distrib
76    END INTERFACE
77    TYPE(distrib),SAVE :: current_dist
78   
79 contains
80 
81    subroutine init_parallel
82    USE vampir
83    implicit none
84#ifdef CPP_MPI
85      include 'mpif.h'
86#endif
87#include "dimensions.h"
88#include "paramet.h"
89#include "iniprint.h"
90
91      integer :: ierr
92      integer :: i,j
93      integer :: type_size
94      integer, dimension(3) :: blocklen,type
95      integer :: comp_id
96      character(len=4)  :: num
97      character(len=20) :: filename
98 
99#ifdef CPP_OMP   
100      INTEGER :: OMP_GET_NUM_THREADS
101      EXTERNAL OMP_GET_NUM_THREADS
102      INTEGER :: OMP_GET_THREAD_NUM
103      EXTERNAL OMP_GET_THREAD_NUM
104#endif 
105
106#ifdef CPP_MPI
107       using_mpi=.TRUE.
108#else
109       using_mpi=.FALSE.
110#endif
111     
112
113#ifdef CPP_OMP
114       using_OMP=.TRUE.
115#else
116       using_OMP=.FALSE.
117#endif
118     
119      call InitVampir
120     
121      IF (using_mpi) THEN
122#ifdef CPP_MPI
123        call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr)
124        call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr)
125#endif
126      ELSE
127        mpi_size=1
128        mpi_rank=0
129      ENDIF
130
131
132! Open text output file with mpi_rank in suffix of file name
133      IF (lunout /= 5 .and. lunout /= 6) THEN
134         WRITE(num,'(I4.4)') mpi_rank
135         filename='lmdz.out_'//num
136         IF (mpi_rank .NE. 0) THEN
137            OPEN(UNIT=lunout,FILE=TRIM(filename),ACTION='write', &
138               STATUS='unknown',FORM='formatted',IOSTAT=ierr)
139         ENDIF
140      ENDIF
141
142     
143      allocate(jj_begin_para(0:mpi_size-1))
144      allocate(jj_end_para(0:mpi_size-1))
145      allocate(jj_nb_para(0:mpi_size-1))
146     
147      do i=0,mpi_size-1
148        jj_nb_para(i)=(jjm+1)/mpi_size
149        if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1
150       
151        if (jj_nb_para(i) <= 2 ) then
152         
153         write(lunout,*)"Arret : le nombre de bande de lattitude par process est trop faible (<2)."
154         write(lunout,*)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
155         
156#ifdef CPP_MPI
157          IF (using_mpi) call MPI_ABORT(COMM_LMDZ,-1, ierr)
158#endif         
159        endif
160       
161      enddo
162     
163!      jj_nb_para(0)=11
164!      jj_nb_para(1)=25
165!      jj_nb_para(2)=25
166!      jj_nb_para(3)=12     
167
168      j=1
169     
170      do i=0,mpi_size-1
171       
172        jj_begin_para(i)=j
173        jj_end_para(i)=j+jj_Nb_para(i)-1
174        j=j+jj_Nb_para(i)
175     
176      enddo
177     
178      jj_begin = jj_begin_para(mpi_rank)
179      jj_end   = jj_end_para(mpi_rank)
180      jj_nb    = jj_nb_para(mpi_rank)
181     
182      ij_begin=(jj_begin-1)*iip1+1
183      ij_end=jj_end*iip1
184     
185      if (mpi_rank.eq.0) then
186        pole_nord=.TRUE.
187      else
188        pole_nord=.FALSE.
189      endif
190     
191      if (mpi_rank.eq.mpi_size-1) then
192        pole_sud=.TRUE.
193      else
194        pole_sud=.FALSE.
195      endif
196       
197      write(lunout,*)"init_parallel: jj_begin",jj_begin
198      write(lunout,*)"init_parallel: jj_end",jj_end
199      write(lunout,*)"init_parallel: ij_begin",ij_begin
200      write(lunout,*)"init_parallel: ij_end",ij_end
201      jjb_u=MAX(jj_begin-halo_max,1)
202      jje_u=MIN(jj_end+halo_max,jjp1)
203      jjnb_u=jje_u-jjb_u+1
204
205      jjb_v=MAX(jj_begin-halo_max,1)
206      jje_v=MIN(jj_end+halo_max,jjm)
207      jjnb_v=jje_v-jjb_v+1
208
209      ijb_u=MAX(ij_begin-halo_max*iip1,1)
210      ije_u=MIN(ij_end+halo_max*iip1,ip1jmp1)
211      ijnb_u=ije_u-ijb_u+1
212
213      ijb_v=MAX(ij_begin-halo_max*iip1,1)
214      ije_v=MIN(ij_end+halo_max*iip1,ip1jm)
215      ijnb_v=ije_v-ijb_v+1
216     
217!$OMP PARALLEL
218
219#ifdef CPP_OMP
220!$OMP MASTER
221        omp_size=OMP_GET_NUM_THREADS()
222!$OMP END MASTER
223        omp_rank=OMP_GET_THREAD_NUM()   
224#else   
225        omp_size=1
226        omp_rank=0
227#endif
228!$OMP END PARALLEL         
229      CALL create_distrib(jj_nb_para,current_dist)
230     
231    end subroutine init_parallel
232
233    SUBROUTINE create_distrib(jj_nb_new,d)
234    IMPLICIT NONE
235      INCLUDE "dimensions.h"
236      INCLUDE "paramet.h"
237     
238      INTEGER,INTENT(IN) :: jj_Nb_New(0:MPI_Size-1)
239      TYPE(distrib),INTENT(INOUT) :: d
240      INTEGER :: i 
241 
242      IF (.NOT. ASSOCIATED(d%jj_nb_para)) ALLOCATE(d%jj_nb_para(0:MPI_Size-1))
243      IF (.NOT. ASSOCIATED(d%jj_begin_para)) ALLOCATE(d%jj_begin_para(0:MPI_Size-1))
244      IF (.NOT. ASSOCIATED(d%jj_end_para)) ALLOCATE(d%jj_end_para(0:MPI_Size-1))
245     
246      d%jj_Nb_Para=jj_Nb_New
247     
248      d%jj_begin_para(0)=1
249      d%jj_end_para(0)=d%jj_Nb_Para(0)
250     
251      do i=1,mpi_size-1
252       
253        d%jj_begin_para(i)=d%jj_end_para(i-1)+1
254        d%jj_end_para(i)=d%jj_begin_para(i)+d%jj_Nb_para(i)-1
255     
256      enddo
257     
258      d%jj_begin = d%jj_begin_para(mpi_rank)
259      d%jj_end   = d%jj_end_para(mpi_rank)
260      d%jj_nb    = d%jj_nb_para(mpi_rank)
261     
262      d%ij_begin=(d%jj_begin-1)*iip1+1
263      d%ij_end=d%jj_end*iip1
264
265      d%jjb_u=MAX(d%jj_begin-halo_max,1)
266      d%jje_u=MIN(d%jj_end+halo_max,jjp1)
267      d%jjnb_u=d%jje_u-d%jjb_u+1
268
269      d%jjb_v=MAX(d%jj_begin-halo_max,1)
270      d%jje_v=MIN(d%jj_end+halo_max,jjm)
271      d%jjnb_v=d%jje_v-d%jjb_v+1
272
273      d%ijb_u=MAX(d%ij_begin-halo_max*iip1,1)
274      d%ije_u=MIN(d%ij_end+halo_max*iip1,ip1jmp1)
275      d%ijnb_u=d%ije_u-d%ijb_u+1
276
277      d%ijb_v=MAX(d%ij_begin-halo_max*iip1,1)
278      d%ije_v=MIN(d%ij_end+halo_max*iip1,ip1jm)
279      d%ijnb_v=d%ije_v-d%ijb_v+1     
280
281    END SUBROUTINE create_distrib
282
283     
284    SUBROUTINE Set_Distrib(d)
285    IMPLICIT NONE
286
287    INCLUDE "dimensions.h"
288    INCLUDE "paramet.h"
289    TYPE(distrib),INTENT(IN) :: d
290
291      jj_begin = d%jj_begin
292      jj_end = d%jj_end
293      jj_nb = d%jj_nb
294      ij_begin = d%ij_begin
295      ij_end = d%ij_end
296
297      jjb_u = d%jjb_u
298      jje_u = d%jje_u
299      jjnb_u = d%jjnb_u
300      jjb_v = d%jjb_v
301      jje_v = d%jje_v
302      jjnb_v = d%jjnb_v
303 
304      ijb_u = d%ijb_u
305      ije_u = d%ije_u
306      ijnb_u = d%ijnb_u
307   
308      ijb_v = d%ijb_v
309      ije_v = d%ije_v
310      ijnb_v = d%ijnb_v
311     
312   
313      jj_begin_para(:) = d%jj_begin_para(:)
314      jj_end_para(:) = d%jj_end_para(:)
315      jj_nb_para(:) = d%jj_nb_para(:)
316      current_dist=d
317
318    END SUBROUTINE Set_Distrib
319
320    SUBROUTINE copy_distrib(dist,new_dist)
321    IMPLICIT NONE
322
323    INCLUDE "dimensions.h"
324    INCLUDE "paramet.h"
325    TYPE(distrib),INTENT(INOUT) :: dist
326    TYPE(distrib),INTENT(IN) :: new_dist
327
328     dist%jj_begin = new_dist%jj_begin
329     dist%jj_end = new_dist%jj_end
330     dist%jj_nb = new_dist%jj_nb
331     dist%ij_begin = new_dist%ij_begin
332     dist%ij_end = new_dist%ij_end
333
334     dist%jjb_u = new_dist%jjb_u
335     dist%jje_u = new_dist%jje_u
336     dist%jjnb_u = new_dist%jjnb_u
337     dist%jjb_v = new_dist%jjb_v
338     dist%jje_v = new_dist%jje_v
339     dist%jjnb_v = new_dist%jjnb_v
340   
341     dist%ijb_u = new_dist%ijb_u
342     dist%ije_u = new_dist%ije_u
343     dist%ijnb_u = new_dist%ijnb_u
344     
345     dist%ijb_v = new_dist%ijb_v
346     dist%ije_v = new_dist%ije_v
347     dist%ijnb_v = new_dist%ijnb_v
348         
349     
350     dist%jj_begin_para(:) = new_dist%jj_begin_para(:)
351     dist%jj_end_para(:) = new_dist%jj_end_para(:)
352     dist%jj_nb_para(:) = new_dist%jj_nb_para(:)
353 
354    END SUBROUTINE copy_distrib
355   
356   
357    SUBROUTINE get_current_distrib(d)
358    IMPLICIT NONE
359
360    INCLUDE "dimensions.h"
361    INCLUDE "paramet.h"
362    TYPE(distrib),INTENT(OUT) :: d
363
364     d=current_dist
365
366    END SUBROUTINE get_current_distrib
367   
368    subroutine Finalize_parallel
369#ifdef CPP_COUPLE
370    use mod_prism_proto
371#endif
372#ifdef CPP_EARTH
373! Ehouarn: surface_data module is in 'phylmd' ...
374      use surface_data, only : type_ocean
375      implicit none
376#else
377      implicit none
378! without the surface_data module, we declare (and set) a dummy 'type_ocean'
379      character(len=6),parameter :: type_ocean="dummy"
380#endif
381! #endif of #ifdef CPP_EARTH
382
383      include "dimensions.h"
384      include "paramet.h"
385#ifdef CPP_MPI
386      include 'mpif.h'
387#endif     
388
389      integer :: ierr
390      integer :: i
391
392      if (allocated(jj_begin_para)) deallocate(jj_begin_para)
393      if (allocated(jj_end_para))   deallocate(jj_end_para)
394      if (allocated(jj_nb_para))    deallocate(jj_nb_para)
395
396      if (type_ocean == 'couple') then
397#ifdef CPP_COUPLE
398         call prism_terminate_proto(ierr)
399         IF (ierr .ne. PRISM_Ok) THEN
400            call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
401         endif
402#endif
403      else
404#ifdef CPP_MPI
405         IF (using_mpi) call MPI_FINALIZE(ierr)
406#endif
407      end if
408     
409    end subroutine Finalize_parallel
410       
411    subroutine Pack_Data(Field,ij,ll,row,Buffer)
412    implicit none
413
414#include "dimensions.h"
415#include "paramet.h"
416
417      integer, intent(in) :: ij,ll,row
418      real,dimension(ij,ll),intent(in) ::Field
419      real,dimension(ll*iip1*row), intent(out) :: Buffer
420           
421      integer :: Pos
422      integer :: i,l
423     
424      Pos=0
425      do l=1,ll
426        do i=1,row*iip1
427          Pos=Pos+1
428          Buffer(Pos)=Field(i,l)
429        enddo
430      enddo
431     
432    end subroutine Pack_data
433     
434    subroutine Unpack_Data(Field,ij,ll,row,Buffer)
435    implicit none
436
437#include "dimensions.h"
438#include "paramet.h"
439
440      integer, intent(in) :: ij,ll,row
441      real,dimension(ij,ll),intent(out) ::Field
442      real,dimension(ll*iip1*row), intent(in) :: Buffer
443           
444      integer :: Pos
445      integer :: i,l
446     
447      Pos=0
448     
449      do l=1,ll
450        do i=1,row*iip1
451          Pos=Pos+1
452          Field(i,l)=Buffer(Pos)
453        enddo
454      enddo
455     
456    end subroutine UnPack_data
457
458   
459    SUBROUTINE barrier
460    IMPLICIT NONE
461#ifdef CPP_MPI
462    INCLUDE 'mpif.h'
463#endif
464    INTEGER :: ierr
465   
466!$OMP CRITICAL (MPI)     
467#ifdef CPP_MPI
468      IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr)
469#endif
470!$OMP END CRITICAL (MPI)
471   
472    END SUBROUTINE barrier
473       
474     
475    subroutine exchange_hallo(Field,ij,ll,up,down)
476    USE Vampir
477    implicit none
478#include "dimensions.h"
479#include "paramet.h"   
480#ifdef CPP_MPI
481    include 'mpif.h'
482#endif   
483      INTEGER :: ij,ll
484      REAL, dimension(ij,ll) :: Field
485      INTEGER :: up,down
486     
487      INTEGER :: ierr
488      LOGICAL :: SendUp,SendDown
489      LOGICAL :: RecvUp,RecvDown
490      INTEGER, DIMENSION(4) :: Request
491#ifdef CPP_MPI
492      INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status
493#else
494      INTEGER, DIMENSION(1,4) :: Status
495#endif
496      INTEGER :: NbRequest
497      REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
498      REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down
499      INTEGER :: Buffer_size     
500
501      IF (using_mpi) THEN
502
503        CALL barrier
504     
505        call VTb(VThallo)
506     
507        SendUp=.TRUE.
508        SendDown=.TRUE.
509        RecvUp=.TRUE.
510        RecvDown=.TRUE.
511         
512        IF (pole_nord) THEN
513          SendUp=.FALSE.
514          RecvUp=.FALSE.
515        ENDIF
516   
517        IF (pole_sud) THEN
518          SendDown=.FALSE.
519          RecvDown=.FALSE.
520        ENDIF
521       
522        if (up.eq.0) then
523          SendDown=.FALSE.
524          RecvUp=.FALSE.
525        endif
526     
527        if (down.eq.0) then
528          SendUp=.FALSE.
529          RecvDown=.FALSE.
530        endif
531     
532        NbRequest=0
533 
534        IF (SendUp) THEN
535          NbRequest=NbRequest+1
536          buffer_size=down*iip1*ll
537          allocate(Buffer_Send_up(Buffer_size))
538          call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
539!$OMP CRITICAL (MPI)
540#ifdef CPP_MPI
541          call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1,     &
542                          COMM_LMDZ,Request(NbRequest),ierr)
543#endif
544!$OMP END CRITICAL (MPI)
545        ENDIF
546 
547        IF (SendDown) THEN
548          NbRequest=NbRequest+1
549           
550          buffer_size=up*iip1*ll
551          allocate(Buffer_Send_down(Buffer_size))
552          call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
553       
554!$OMP CRITICAL (MPI)
555#ifdef CPP_MPI
556          call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1,     &
557                          COMM_LMDZ,Request(NbRequest),ierr)
558#endif
559!$OMP END CRITICAL (MPI)
560        ENDIF
561   
562 
563        IF (RecvUp) THEN
564          NbRequest=NbRequest+1
565          buffer_size=up*iip1*ll
566          allocate(Buffer_recv_up(Buffer_size))
567             
568!$OMP CRITICAL (MPI)
569#ifdef CPP_MPI
570          call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1,  &
571                          COMM_LMDZ,Request(NbRequest),ierr)
572#endif
573!$OMP END CRITICAL (MPI)
574     
575       
576        ENDIF
577 
578        IF (RecvDown) THEN
579          NbRequest=NbRequest+1
580          buffer_size=down*iip1*ll
581          allocate(Buffer_recv_down(Buffer_size))
582       
583!$OMP CRITICAL (MPI)
584#ifdef CPP_MPI
585          call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1,     &
586                          COMM_LMDZ,Request(NbRequest),ierr)
587#endif
588!$OMP END CRITICAL (MPI)
589       
590        ENDIF
591 
592#ifdef CPP_MPI
593        if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
594#endif
595        IF (RecvUp)  call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
596        IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down) 
597
598        call VTe(VThallo)
599        call barrier
600     
601      ENDIF  ! using_mpi
602     
603      RETURN
604     
605    end subroutine exchange_Hallo
606   
607
608    subroutine Gather_Field(Field,ij,ll,rank)
609    implicit none
610#include "dimensions.h"
611#include "paramet.h"
612#include "iniprint.h"
613#ifdef CPP_MPI
614    include 'mpif.h'
615#endif   
616      INTEGER :: ij,ll,rank
617      REAL, dimension(ij,ll) :: Field
618      REAL, dimension(:),allocatable :: Buffer_send   
619      REAL, dimension(:),allocatable :: Buffer_Recv
620      INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ
621      INTEGER :: ierr
622      INTEGER ::i
623     
624      IF (using_mpi) THEN
625
626        if (ij==ip1jmp1) then
627           allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1)))
628           call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
629        else if (ij==ip1jm) then
630           allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1)))
631           call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
632        else
633           write(lunout,*)ij 
634        stop 'erreur dans Gather_Field'
635        endif
636       
637        if (MPI_Rank==rank) then
638          allocate(Buffer_Recv(ij*ll))
639
640!CDIR NOVECTOR
641          do i=0,MPI_Size-1
642             
643            if (ij==ip1jmp1) then
644              Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1
645            else if (ij==ip1jm) then
646              Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1
647            else
648              stop 'erreur dans Gather_Field'
649            endif
650                   
651            if (i==0) then
652              displ(i)=0
653            else
654              displ(i)=displ(i-1)+Recv_count(i-1)
655            endif
656           
657          enddo
658         
659        else
660          ! Ehouarn: When in debug mode, ifort complains (for call MPI_GATHERV
661          !          below) about Buffer_Recv() being not allocated.
662          !          So make a dummy allocation.
663          allocate(Buffer_Recv(1))
664        endif ! of if (MPI_Rank==rank)
665 
666!$OMP CRITICAL (MPI)
667#ifdef CPP_MPI
668        call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8,   &
669                          Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
670#endif
671!$OMP END CRITICAL (MPI)
672     
673        if (MPI_Rank==rank) then                 
674     
675          if (ij==ip1jmp1) then
676            do i=0,MPI_Size-1
677              call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                 &
678                               jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
679            enddo
680          else if (ij==ip1jm) then
681            do i=0,MPI_Size-1
682               call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                       &
683                               min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
684            enddo
685          endif
686        endif
687      ENDIF ! using_mpi
688     
689    end subroutine Gather_Field
690
691
692    subroutine AllGather_Field(Field,ij,ll)
693    implicit none
694#include "dimensions.h"
695#include "paramet.h"   
696#ifdef CPP_MPI
697    include 'mpif.h'
698#endif   
699      INTEGER :: ij,ll
700      REAL, dimension(ij,ll) :: Field
701      INTEGER :: ierr
702     
703      IF (using_mpi) THEN
704        call Gather_Field(Field,ij,ll,0)
705!$OMP CRITICAL (MPI)
706#ifdef CPP_MPI
707      call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
708#endif
709!$OMP END CRITICAL (MPI)
710      ENDIF
711     
712    end subroutine AllGather_Field
713   
714   subroutine Broadcast_Field(Field,ij,ll,rank)
715    implicit none
716#include "dimensions.h"
717#include "paramet.h"   
718#ifdef CPP_MPI
719    include 'mpif.h'
720#endif   
721      INTEGER :: ij,ll
722      REAL, dimension(ij,ll) :: Field
723      INTEGER :: rank
724      INTEGER :: ierr
725     
726      IF (using_mpi) THEN
727     
728!$OMP CRITICAL (MPI)
729#ifdef CPP_MPI
730      call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
731#endif
732!$OMP END CRITICAL (MPI)
733     
734      ENDIF
735    end subroutine Broadcast_Field
736       
737   
738!  Subroutine verif_hallo(Field,ij,ll,up,down)
739!    implicit none
740!#include "dimensions.h"
741!#include "paramet.h"   
742!    include 'mpif.h'
743!   
744!      INTEGER :: ij,ll
745!      REAL, dimension(ij,ll) :: Field
746!      INTEGER :: up,down
747!     
748!      REAL,dimension(ij,ll): NewField
749!     
750!      NewField=0
751!     
752!      ijb=ij_begin
753!      ije=ij_end
754!      if (pole_nord)
755!      NewField(ij_be       
756
757  end module parallel
Note: See TracBrowser for help on using the repository browser.