source: LMDZ5/branches/LF-private/libf/dyn3dpar/parallel_lmdz.F90 @ 3069

Last change on this file since 3069 was 1860, checked in by Ehouarn Millour, 11 years ago

Implement in dyn3dpar the modifications that were made in the dyn3dmem dynamics (r1858-1859) about setting size of omp_chunk.
EM

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