source: LMDZ5/trunk/libf/dyn3dpar/parallel_lmdz.F90 @ 2194

Last change on this file since 2194 was 2054, checked in by acaubel, 10 years ago

Modifications to run LMDZ in coupled mode with both OASIS-MCT and XIOS.

  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 15.3 KB
RevLine 
[1823]1!
2! $Id: parallel.F90 1810 2013-07-24 08:06:39Z emillour $
3!
4  MODULE parallel_lmdz
5  USE mod_const_mpi
[1860]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   
[1823]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
[1860]163!$OMP BARRIER
[1823]164        omp_rank=OMP_GET_THREAD_NUM()   
[1860]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       
[1823]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
[1852]222#ifdef CPP_XIOS
223    ! ug Pour les sorties XIOS
224        USE wxios
225#endif
[1823]226#ifdef CPP_COUPLE
[1965]227! Use of Oasis-MCT coupler
228#if defined CPP_OMCT
229    use mod_prism
230#else
[1823]231    use mod_prism_proto
[1965]232#endif
[1823]233! Ehouarn: surface_data module is in 'phylmd' ...
234      use surface_data, only : type_ocean
235      implicit none
236#else
237      implicit none
238! without the surface_data module, we declare (and set) a dummy 'type_ocean'
239      character(len=6),parameter :: type_ocean="dummy"
240#endif
241! #endif of #ifdef CPP_EARTH
242
243      include "dimensions.h"
244      include "paramet.h"
245#ifdef CPP_MPI
246      include 'mpif.h'
247#endif     
248
249      integer :: ierr
250      integer :: i
251
252      if (allocated(jj_begin_para)) deallocate(jj_begin_para)
253      if (allocated(jj_end_para))   deallocate(jj_end_para)
254      if (allocated(jj_nb_para))    deallocate(jj_nb_para)
255
256      if (type_ocean == 'couple') then
[2054]257#ifdef CPP_XIOS
258    !Fermeture propre de XIOS
259      CALL wxios_close()
260#else
[1823]261#ifdef CPP_COUPLE
262         call prism_terminate_proto(ierr)
263         IF (ierr .ne. PRISM_Ok) THEN
264            call abort_gcm('Finalize_parallel',' Probleme dans prism_terminate_proto ',1)
265         endif
266#endif
[2054]267#endif
[1823]268      else
[1852]269#ifdef CPP_XIOS
270    !Fermeture propre de XIOS
271      CALL wxios_close()
272#endif
[1823]273#ifdef CPP_MPI
274         IF (using_mpi) call MPI_FINALIZE(ierr)
275#endif
276      end if
277     
278    end subroutine Finalize_parallel
279       
280    subroutine Pack_Data(Field,ij,ll,row,Buffer)
281    implicit none
282
283#include "dimensions.h"
284#include "paramet.h"
285
286      integer, intent(in) :: ij,ll,row
287      real,dimension(ij,ll),intent(in) ::Field
288      real,dimension(ll*iip1*row), intent(out) :: Buffer
289           
290      integer :: Pos
291      integer :: i,l
292     
293      Pos=0
294      do l=1,ll
295        do i=1,row*iip1
296          Pos=Pos+1
297          Buffer(Pos)=Field(i,l)
298        enddo
299      enddo
300     
301    end subroutine Pack_data
302     
303    subroutine Unpack_Data(Field,ij,ll,row,Buffer)
304    implicit none
305
306#include "dimensions.h"
307#include "paramet.h"
308
309      integer, intent(in) :: ij,ll,row
310      real,dimension(ij,ll),intent(out) ::Field
311      real,dimension(ll*iip1*row), intent(in) :: Buffer
312           
313      integer :: Pos
314      integer :: i,l
315     
316      Pos=0
317     
318      do l=1,ll
319        do i=1,row*iip1
320          Pos=Pos+1
321          Field(i,l)=Buffer(Pos)
322        enddo
323      enddo
324     
325    end subroutine UnPack_data
326
327   
328    SUBROUTINE barrier
329    IMPLICIT NONE
330#ifdef CPP_MPI
331    INCLUDE 'mpif.h'
332#endif
333    INTEGER :: ierr
334   
335!$OMP CRITICAL (MPI)     
336#ifdef CPP_MPI
337      IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr)
338#endif
339!$OMP END CRITICAL (MPI)
340   
341    END SUBROUTINE barrier
342       
343     
344    subroutine exchange_hallo(Field,ij,ll,up,down)
345    USE Vampir
346    implicit none
347#include "dimensions.h"
348#include "paramet.h"   
349#ifdef CPP_MPI
350    include 'mpif.h'
351#endif   
352      INTEGER :: ij,ll
353      REAL, dimension(ij,ll) :: Field
354      INTEGER :: up,down
355     
356      INTEGER :: ierr
357      LOGICAL :: SendUp,SendDown
358      LOGICAL :: RecvUp,RecvDown
359      INTEGER, DIMENSION(4) :: Request
360#ifdef CPP_MPI
361      INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status
362#else
363      INTEGER, DIMENSION(1,4) :: Status
364#endif
365      INTEGER :: NbRequest
366      REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
367      REAL, dimension(:),allocatable :: Buffer_Recv_up,Buffer_Recv_down
368      INTEGER :: Buffer_size     
369
370      IF (using_mpi) THEN
371
372        CALL barrier
373     
374        call VTb(VThallo)
375     
376        SendUp=.TRUE.
377        SendDown=.TRUE.
378        RecvUp=.TRUE.
379        RecvDown=.TRUE.
380         
381        IF (pole_nord) THEN
382          SendUp=.FALSE.
383          RecvUp=.FALSE.
384        ENDIF
385   
386        IF (pole_sud) THEN
387          SendDown=.FALSE.
388          RecvDown=.FALSE.
389        ENDIF
390       
391        if (up.eq.0) then
392          SendDown=.FALSE.
393          RecvUp=.FALSE.
394        endif
395     
396        if (down.eq.0) then
397          SendUp=.FALSE.
398          RecvDown=.FALSE.
399        endif
400     
401        NbRequest=0
402 
403        IF (SendUp) THEN
404          NbRequest=NbRequest+1
405          buffer_size=down*iip1*ll
406          allocate(Buffer_Send_up(Buffer_size))
407          call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
408!$OMP CRITICAL (MPI)
409#ifdef CPP_MPI
410          call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1,     &
411                          COMM_LMDZ,Request(NbRequest),ierr)
412#endif
413!$OMP END CRITICAL (MPI)
414        ENDIF
415 
416        IF (SendDown) THEN
417          NbRequest=NbRequest+1
418           
419          buffer_size=up*iip1*ll
420          allocate(Buffer_Send_down(Buffer_size))
421          call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
422       
423!$OMP CRITICAL (MPI)
424#ifdef CPP_MPI
425          call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1,     &
426                          COMM_LMDZ,Request(NbRequest),ierr)
427#endif
428!$OMP END CRITICAL (MPI)
429        ENDIF
430   
431 
432        IF (RecvUp) THEN
433          NbRequest=NbRequest+1
434          buffer_size=up*iip1*ll
435          allocate(Buffer_recv_up(Buffer_size))
436             
437!$OMP CRITICAL (MPI)
438#ifdef CPP_MPI
439          call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1,  &
440                          COMM_LMDZ,Request(NbRequest),ierr)
441#endif
442!$OMP END CRITICAL (MPI)
443     
444       
445        ENDIF
446 
447        IF (RecvDown) THEN
448          NbRequest=NbRequest+1
449          buffer_size=down*iip1*ll
450          allocate(Buffer_recv_down(Buffer_size))
451       
452!$OMP CRITICAL (MPI)
453#ifdef CPP_MPI
454          call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1,     &
455                          COMM_LMDZ,Request(NbRequest),ierr)
456#endif
457!$OMP END CRITICAL (MPI)
458       
459        ENDIF
460 
461#ifdef CPP_MPI
462        if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
463#endif
464        IF (RecvUp)  call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
465        IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down) 
466
467        call VTe(VThallo)
468        call barrier
469     
470      ENDIF  ! using_mpi
471     
472      RETURN
473     
474    end subroutine exchange_Hallo
475   
476
477    subroutine Gather_Field(Field,ij,ll,rank)
478    implicit none
479#include "dimensions.h"
480#include "paramet.h"
481#include "iniprint.h"
482#ifdef CPP_MPI
483    include 'mpif.h'
484#endif   
485      INTEGER :: ij,ll,rank
486      REAL, dimension(ij,ll) :: Field
487      REAL, dimension(:),allocatable :: Buffer_send   
488      REAL, dimension(:),allocatable :: Buffer_Recv
489      INTEGER, dimension(0:MPI_Size-1) :: Recv_count, displ
490      INTEGER :: ierr
491      INTEGER ::i
492     
493      IF (using_mpi) THEN
494
495        if (ij==ip1jmp1) then
496           allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1)))
497           call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
498        else if (ij==ip1jm) then
499           allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1)))
500           call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
501        else
502           write(lunout,*)ij 
503        stop 'erreur dans Gather_Field'
504        endif
505       
506        if (MPI_Rank==rank) then
507          allocate(Buffer_Recv(ij*ll))
508
509!CDIR NOVECTOR
510          do i=0,MPI_Size-1
511             
512            if (ij==ip1jmp1) then
513              Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1
514            else if (ij==ip1jm) then
515              Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1
516            else
517              stop 'erreur dans Gather_Field'
518            endif
519                   
520            if (i==0) then
521              displ(i)=0
522            else
523              displ(i)=displ(i-1)+Recv_count(i-1)
524            endif
525           
526          enddo
527         
528        else
529          ! Ehouarn: When in debug mode, ifort complains (for call MPI_GATHERV
530          !          below) about Buffer_Recv() being not allocated.
531          !          So make a dummy allocation.
532          allocate(Buffer_Recv(1))
533        endif ! of if (MPI_Rank==rank)
534 
535!$OMP CRITICAL (MPI)
536#ifdef CPP_MPI
537        call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8,   &
538                          Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
539#endif
540!$OMP END CRITICAL (MPI)
541     
542        if (MPI_Rank==rank) then                 
543     
544          if (ij==ip1jmp1) then
545            do i=0,MPI_Size-1
546              call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                 &
547                               jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
548            enddo
549          else if (ij==ip1jm) then
550            do i=0,MPI_Size-1
551               call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                       &
552                               min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
553            enddo
554          endif
555        endif
556      ENDIF ! using_mpi
557     
558    end subroutine Gather_Field
559
560
561    subroutine AllGather_Field(Field,ij,ll)
562    implicit none
563#include "dimensions.h"
564#include "paramet.h"   
565#ifdef CPP_MPI
566    include 'mpif.h'
567#endif   
568      INTEGER :: ij,ll
569      REAL, dimension(ij,ll) :: Field
570      INTEGER :: ierr
571     
572      IF (using_mpi) THEN
573        call Gather_Field(Field,ij,ll,0)
574!$OMP CRITICAL (MPI)
575#ifdef CPP_MPI
576      call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
577#endif
578!$OMP END CRITICAL (MPI)
579      ENDIF
580     
581    end subroutine AllGather_Field
582   
583   subroutine Broadcast_Field(Field,ij,ll,rank)
584    implicit none
585#include "dimensions.h"
586#include "paramet.h"   
587#ifdef CPP_MPI
588    include 'mpif.h'
589#endif   
590      INTEGER :: ij,ll
591      REAL, dimension(ij,ll) :: Field
592      INTEGER :: rank
593      INTEGER :: ierr
594     
595      IF (using_mpi) THEN
596     
597!$OMP CRITICAL (MPI)
598#ifdef CPP_MPI
599      call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
600#endif
601!$OMP END CRITICAL (MPI)
602     
603      ENDIF
604    end subroutine Broadcast_Field
605       
606   
607!  Subroutine verif_hallo(Field,ij,ll,up,down)
608!    implicit none
609!#include "dimensions.h"
610!#include "paramet.h"   
611!    include 'mpif.h'
612!   
613!      INTEGER :: ij,ll
614!      REAL, dimension(ij,ll) :: Field
615!      INTEGER :: up,down
616!     
617!      REAL,dimension(ij,ll): NewField
618!     
619!      NewField=0
620!     
621!      ijb=ij_begin
622!      ije=ij_end
623!      if (pole_nord)
624!      NewField(ij_be       
625
626  end MODULE parallel_lmdz
Note: See TracBrowser for help on using the repository browser.