source: LMDZ4/branches/LMDZ4_AR5/libf/dyn3dpar/parallel.F90 @ 1959

Last change on this file since 1959 was 1717, checked in by Ehouarn Millour, 12 years ago

Added "arch" files for Ada (using dynamic libraries for NetCDF, you must have
export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:/smplocal/pub/NetCDF/4.1.3/lib:/smplocal/pub/HDF5/1.8.9/seq/lib
in your .bashrc or .bash_login or in your job to run).
Also updated some sources so that gcm bench runs in "debug" mode (note that all these changes are minor and have already been implemented in LMDZ5 trunk).
EM

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 13.9 KB
Line 
1!
2! $Id: parallel.F90 1717 2013-01-25 08:26:03Z fhourdin $
3!
4  module parallel
5  USE mod_const_mpi
6   
7    LOGICAL,SAVE :: using_mpi=.TRUE.
8    LOGICAL,SAVE :: using_omp
9   
10    integer, save :: mpi_size
11    integer, save :: mpi_rank
12    integer, save :: jj_begin
13    integer, save :: jj_end
14    integer, save :: jj_nb
15    integer, save :: ij_begin
16    integer, save :: ij_end
17    logical, save :: pole_nord
18    logical, save :: pole_sud
19   
20    integer, allocatable, save, dimension(:) :: jj_begin_para
21    integer, allocatable, save, dimension(:) :: jj_end_para
22    integer, allocatable, save, dimension(:) :: jj_nb_para
23    integer, save :: OMP_CHUNK
24    integer, save :: omp_rank
25    integer, save :: omp_size 
26!$OMP THREADPRIVATE(omp_rank)
27
28 contains
29 
30    subroutine init_parallel
31    USE vampir
32    implicit none
33#ifdef CPP_MPI
34      include 'mpif.h'
35#endif
36#include "dimensions.h"
37#include "paramet.h"
38#include "iniprint.h"
39
40      integer :: ierr
41      integer :: i,j
42      integer :: type_size
43      integer, dimension(3) :: blocklen,type
44      integer :: comp_id
45
46#ifdef CPP_OMP   
47      INTEGER :: OMP_GET_NUM_THREADS
48      EXTERNAL OMP_GET_NUM_THREADS
49      INTEGER :: OMP_GET_THREAD_NUM
50      EXTERNAL OMP_GET_THREAD_NUM
51#endif 
52
53#ifdef CPP_MPI
54       using_mpi=.TRUE.
55#else
56       using_mpi=.FALSE.
57#endif
58     
59
60#ifdef CPP_OMP
61       using_OMP=.TRUE.
62#else
63       using_OMP=.FALSE.
64#endif
65     
66      call InitVampir
67     
68      IF (using_mpi) THEN
69#ifdef CPP_MPI
70        call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr)
71        call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr)
72#endif
73      ELSE
74        mpi_size=1
75        mpi_rank=0
76      ENDIF
77 
78     
79      allocate(jj_begin_para(0:mpi_size-1))
80      allocate(jj_end_para(0:mpi_size-1))
81      allocate(jj_nb_para(0:mpi_size-1))
82     
83      do i=0,mpi_size-1
84        jj_nb_para(i)=(jjm+1)/mpi_size
85        if ( i < MOD((jjm+1),mpi_size) ) jj_nb_para(i)=jj_nb_para(i)+1
86       
87        if (jj_nb_para(i) <= 2 ) then
88         
89         write(lunout,*)"Arret : le nombre de bande de lattitude par process est trop faible (<2)."
90         write(lunout,*)" ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
91         
92#ifdef CPP_MPI
93          IF (using_mpi) call MPI_ABORT(COMM_LMDZ,-1, ierr)
94#endif         
95        endif
96       
97      enddo
98     
99!      jj_nb_para(0)=11
100!      jj_nb_para(1)=25
101!      jj_nb_para(2)=25
102!      jj_nb_para(3)=12     
103
104      j=1
105     
106      do i=0,mpi_size-1
107       
108        jj_begin_para(i)=j
109        jj_end_para(i)=j+jj_Nb_para(i)-1
110        j=j+jj_Nb_para(i)
111     
112      enddo
113     
114      jj_begin = jj_begin_para(mpi_rank)
115      jj_end   = jj_end_para(mpi_rank)
116      jj_nb    = jj_nb_para(mpi_rank)
117     
118      ij_begin=(jj_begin-1)*iip1+1
119      ij_end=jj_end*iip1
120     
121      if (mpi_rank.eq.0) then
122        pole_nord=.TRUE.
123      else
124        pole_nord=.FALSE.
125      endif
126     
127      if (mpi_rank.eq.mpi_size-1) then
128        pole_sud=.TRUE.
129      else
130        pole_sud=.FALSE.
131      endif
132       
133      write(lunout,*)"init_parallel: jj_begin",jj_begin
134      write(lunout,*)"init_parallel: jj_end",jj_end
135      write(lunout,*)"init_parallel: ij_begin",ij_begin
136      write(lunout,*)"init_parallel: ij_end",ij_end
137
138!$OMP PARALLEL
139
140#ifdef CPP_OMP
141!$OMP MASTER
142        omp_size=OMP_GET_NUM_THREADS()
143!$OMP END MASTER
144        omp_rank=OMP_GET_THREAD_NUM()   
145#else   
146        omp_size=1
147        omp_rank=0
148#endif
149!$OMP END PARALLEL         
150   
151    end subroutine init_parallel
152
153   
154    subroutine SetDistrib(jj_Nb_New)
155    implicit none
156
157#include "dimensions.h"
158#include "paramet.h"
159
160      INTEGER,dimension(0:MPI_Size-1) :: jj_Nb_New
161      INTEGER :: i 
162 
163      jj_Nb_Para=jj_Nb_New
164     
165      jj_begin_para(0)=1
166      jj_end_para(0)=jj_Nb_Para(0)
167     
168      do i=1,mpi_size-1
169       
170        jj_begin_para(i)=jj_end_para(i-1)+1
171        jj_end_para(i)=jj_begin_para(i)+jj_Nb_para(i)-1
172     
173      enddo
174     
175      jj_begin = jj_begin_para(mpi_rank)
176      jj_end   = jj_end_para(mpi_rank)
177      jj_nb    = jj_nb_para(mpi_rank)
178     
179      ij_begin=(jj_begin-1)*iip1+1
180      ij_end=jj_end*iip1
181
182    end subroutine SetDistrib
183
184
185
186   
187    subroutine Finalize_parallel
188#ifdef CPP_COUPLE
189    use mod_prism_proto
190#endif
191#ifdef CPP_EARTH
192! Ehouarn: surface_data module is in 'phylmd' ...
193      use surface_data, only : type_ocean
194      implicit none
195#else
196      implicit none
197! without the surface_data module, we declare (and set) a dummy 'type_ocean'
198      character(len=6),parameter :: type_ocean="dummy"
199#endif
200! #endif of #ifdef CPP_EARTH
201
202      include "dimensions.h"
203      include "paramet.h"
204#ifdef CPP_MPI
205      include 'mpif.h'
206#endif     
207
208      integer :: ierr
209      integer :: i
210
211      if (allocated(jj_begin_para)) deallocate(jj_begin_para)
212      if (allocated(jj_end_para))   deallocate(jj_end_para)
213      if (allocated(jj_nb_para))    deallocate(jj_nb_para)
214
215      if (type_ocean == 'couple') then
216#ifdef CPP_COUPLE
217         call prism_terminate_proto(ierr)
218         IF (ierr .ne. PRISM_Ok) THEN
219            call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
220         endif
221#endif
222      else
223#ifdef CPP_MPI
224         IF (using_mpi) call MPI_FINALIZE(ierr)
225#endif
226      end if
227     
228    end subroutine Finalize_parallel
229       
230    subroutine Pack_Data(Field,ij,ll,row,Buffer)
231    implicit none
232
233#include "dimensions.h"
234#include "paramet.h"
235
236      integer, intent(in) :: ij,ll,row
237      real,dimension(ij,ll),intent(in) ::Field
238      real,dimension(ll*iip1*row), intent(out) :: Buffer
239           
240      integer :: Pos
241      integer :: i,l
242     
243      Pos=0
244      do l=1,ll
245        do i=1,row*iip1
246          Pos=Pos+1
247          Buffer(Pos)=Field(i,l)
248        enddo
249      enddo
250     
251    end subroutine Pack_data
252     
253    subroutine Unpack_Data(Field,ij,ll,row,Buffer)
254    implicit none
255
256#include "dimensions.h"
257#include "paramet.h"
258
259      integer, intent(in) :: ij,ll,row
260      real,dimension(ij,ll),intent(out) ::Field
261      real,dimension(ll*iip1*row), intent(in) :: Buffer
262           
263      integer :: Pos
264      integer :: i,l
265     
266      Pos=0
267     
268      do l=1,ll
269        do i=1,row*iip1
270          Pos=Pos+1
271          Field(i,l)=Buffer(Pos)
272        enddo
273      enddo
274     
275    end subroutine UnPack_data
276
277   
278    SUBROUTINE barrier
279    IMPLICIT NONE
280#ifdef CPP_MPI
281    INCLUDE 'mpif.h'
282#endif
283    INTEGER :: ierr
284   
285!$OMP CRITICAL (MPI)     
286#ifdef CPP_MPI
287      IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr)
288#endif
289!$OMP END CRITICAL (MPI)
290   
291    END SUBROUTINE barrier
292       
293     
294    subroutine exchange_hallo(Field,ij,ll,up,down)
295    USE Vampir
296    implicit none
297#include "dimensions.h"
298#include "paramet.h"   
299#ifdef CPP_MPI
300    include 'mpif.h'
301#endif   
302      INTEGER :: ij,ll
303      REAL, dimension(ij,ll) :: Field
304      INTEGER :: up,down
305     
306      INTEGER :: ierr
307      LOGICAL :: SendUp,SendDown
308      LOGICAL :: RecvUp,RecvDown
309      INTEGER, DIMENSION(4) :: Request
310#ifdef CPP_MPI
311      INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status
312#else
313      INTEGER, DIMENSION(1,4) :: Status
314#endif
315      INTEGER :: NbRequest
316      REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
317      REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down
318      INTEGER :: Buffer_size     
319
320      IF (using_mpi) THEN
321
322        CALL barrier
323     
324        call VTb(VThallo)
325     
326        SendUp=.TRUE.
327        SendDown=.TRUE.
328        RecvUp=.TRUE.
329        RecvDown=.TRUE.
330         
331        IF (pole_nord) THEN
332          SendUp=.FALSE.
333          RecvUp=.FALSE.
334        ENDIF
335   
336        IF (pole_sud) THEN
337          SendDown=.FALSE.
338          RecvDown=.FALSE.
339        ENDIF
340       
341        if (up.eq.0) then
342          SendDown=.FALSE.
343          RecvUp=.FALSE.
344        endif
345     
346        if (down.eq.0) then
347          SendUp=.FALSE.
348          RecvDown=.FALSE.
349        endif
350     
351        NbRequest=0
352 
353        IF (SendUp) THEN
354          NbRequest=NbRequest+1
355          buffer_size=down*iip1*ll
356          allocate(Buffer_Send_up(Buffer_size))
357          call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
358!$OMP CRITICAL (MPI)
359#ifdef CPP_MPI
360          call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1,     &
361                          COMM_LMDZ,Request(NbRequest),ierr)
362#endif
363!$OMP END CRITICAL (MPI)
364        ENDIF
365 
366        IF (SendDown) THEN
367          NbRequest=NbRequest+1
368           
369          buffer_size=up*iip1*ll
370          allocate(Buffer_Send_down(Buffer_size))
371          call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
372       
373!$OMP CRITICAL (MPI)
374#ifdef CPP_MPI
375          call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1,     &
376                          COMM_LMDZ,Request(NbRequest),ierr)
377#endif
378!$OMP END CRITICAL (MPI)
379        ENDIF
380   
381 
382        IF (RecvUp) THEN
383          NbRequest=NbRequest+1
384          buffer_size=up*iip1*ll
385          allocate(Buffer_recv_up(Buffer_size))
386             
387!$OMP CRITICAL (MPI)
388#ifdef CPP_MPI
389          call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1,  &
390                          COMM_LMDZ,Request(NbRequest),ierr)
391#endif
392!$OMP END CRITICAL (MPI)
393     
394       
395        ENDIF
396 
397        IF (RecvDown) THEN
398          NbRequest=NbRequest+1
399          buffer_size=down*iip1*ll
400          allocate(Buffer_recv_down(Buffer_size))
401       
402!$OMP CRITICAL (MPI)
403#ifdef CPP_MPI
404          call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1,     &
405                          COMM_LMDZ,Request(NbRequest),ierr)
406#endif
407!$OMP END CRITICAL (MPI)
408       
409        ENDIF
410 
411#ifdef CPP_MPI
412        if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
413#endif
414        IF (RecvUp)  call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
415        IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down) 
416
417        call VTe(VThallo)
418        call barrier
419     
420      ENDIF  ! using_mpi
421     
422      RETURN
423     
424    end subroutine exchange_Hallo
425   
426
427    subroutine Gather_Field(Field,ij,ll,rank)
428    implicit none
429#include "dimensions.h"
430#include "paramet.h"
431#include "iniprint.h"
432#ifdef CPP_MPI
433    include 'mpif.h'
434#endif   
435      INTEGER :: ij,ll,rank
436      REAL, dimension(ij,ll) :: Field
437      REAL, dimension(:),allocatable :: Buffer_send   
438      REAL, dimension(:),allocatable :: Buffer_Recv
439      INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ
440      INTEGER :: ierr
441      INTEGER ::i
442     
443      IF (using_mpi) THEN
444
445        if (ij==ip1jmp1) then
446           allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1)))
447           call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
448        else if (ij==ip1jm) then
449           allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1)))
450           call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
451        else
452           write(lunout,*)ij 
453        stop 'erreur dans Gather_Field'
454        endif
455       
456        if (MPI_Rank==rank) then
457          allocate(Buffer_Recv(ij*ll))
458
459!CDIR NOVECTOR
460          do i=0,MPI_Size-1
461             
462            if (ij==ip1jmp1) then
463              Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1
464            else if (ij==ip1jm) then
465              Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1
466            else
467              stop 'erreur dans Gather_Field'
468            endif
469                   
470            if (i==0) then
471              displ(i)=0
472            else
473              displ(i)=displ(i-1)+Recv_count(i-1)
474            endif
475           
476          enddo
477         
478        else
479          ! Ehouarn: When in debug mode, ifort complains (for call MPI_GATHERV
480          !          below) about Buffer_Recv() being not allocated.
481          !          So make a dummy allocation.
482          allocate(Buffer_Recv(1))
483        endif ! of if (MPI_Rank==rank)
484 
485!$OMP CRITICAL (MPI)
486#ifdef CPP_MPI
487        call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8,   &
488                          Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
489#endif
490!$OMP END CRITICAL (MPI)
491     
492        if (MPI_Rank==rank) then                 
493     
494          if (ij==ip1jmp1) then
495            do i=0,MPI_Size-1
496              call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                 &
497                               jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
498            enddo
499          else if (ij==ip1jm) then
500            do i=0,MPI_Size-1
501               call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                       &
502                               min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
503            enddo
504          endif
505        endif
506      ENDIF ! using_mpi
507     
508    end subroutine Gather_Field
509
510
511    subroutine AllGather_Field(Field,ij,ll)
512    implicit none
513#include "dimensions.h"
514#include "paramet.h"   
515#ifdef CPP_MPI
516    include 'mpif.h'
517#endif   
518      INTEGER :: ij,ll
519      REAL, dimension(ij,ll) :: Field
520      INTEGER :: ierr
521     
522      IF (using_mpi) THEN
523        call Gather_Field(Field,ij,ll,0)
524!$OMP CRITICAL (MPI)
525#ifdef CPP_MPI
526      call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
527#endif
528!$OMP END CRITICAL (MPI)
529      ENDIF
530     
531    end subroutine AllGather_Field
532   
533   subroutine Broadcast_Field(Field,ij,ll,rank)
534    implicit none
535#include "dimensions.h"
536#include "paramet.h"   
537#ifdef CPP_MPI
538    include 'mpif.h'
539#endif   
540      INTEGER :: ij,ll
541      REAL, dimension(ij,ll) :: Field
542      INTEGER :: rank
543      INTEGER :: ierr
544     
545      IF (using_mpi) THEN
546     
547!$OMP CRITICAL (MPI)
548#ifdef CPP_MPI
549      call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
550#endif
551!$OMP END CRITICAL (MPI)
552     
553      ENDIF
554    end subroutine Broadcast_Field
555       
556   
557    /* 
558  Subroutine verif_hallo(Field,ij,ll,up,down)
559    implicit none
560#include "dimensions.h"
561#include "paramet.h"   
562    include 'mpif.h'
563   
564      INTEGER :: ij,ll
565      REAL, dimension(ij,ll) :: Field
566      INTEGER :: up,down
567     
568      REAL,dimension(ij,ll): NewField
569     
570      NewField=0
571     
572      ijb=ij_begin
573      ije=ij_end
574      if (pole_nord)
575      NewField(ij_be       
576*/
577  end module parallel
Note: See TracBrowser for help on using the repository browser.