Ignore:
Timestamp:
Oct 6, 2008, 10:43:22 AM (16 years ago)
Author:
Laurent Fairhead
Message:
  • Modifs sur le parallelisme: masquage dans la physique
  • Inclusion strato
  • mise en coherence etat0
  • le mode offline fonctionne maintenant en parallele,
  • les fichiers de la dynamiques sont correctement sortis et peuvent etre reconstruit avec rebuild
  • la version parallele de la dynamique peut s'executer sans MPI (sur 1 proc)
  • L'OPENMP fonctionne maintenant sans la parallelisation MPI.

YM
LF

File:
1 edited

Legend:

Unmodified
Added
Removed

  • LMDZ4/trunk/libf/dyn3dpar/parallel.F90

    r995 r1000  
    11  module parallel
    22  USE mod_const_mpi
    3    
     3   
     4    LOGICAL,SAVE :: using_mpi
     5    LOGICAL,SAVE :: using_omp
     6   
    47    integer, save :: mpi_size
    58    integer, save :: mpi_rank
    … …  
    2528    USE vampir
    2629    implicit none
     30#ifdef CPP_MPI
     31      include 'mpif.h'
     32#endif
     33#include "dimensions.h"
     34#include "paramet.h"
    2735   
    2836      integer :: ierr
    … …  
    3139      integer, dimension(3) :: blocklen,type
    3240      integer :: comp_id
    33 #ifdef _OPENMP   
     41
     42#ifdef CPP_OMP   
    3443      INTEGER :: OMP_GET_NUM_THREADS
    3544      EXTERNAL OMP_GET_NUM_THREADS
    … …  
    3746      EXTERNAL OMP_GET_THREAD_NUM
    3847#endif 
    39       include 'mpif.h'
    40 #include "dimensions.h"
    41 #include "paramet.h"
    42 
     48
     49#ifdef CPP_MPI
     50       using_mpi=.TRUE.
     51#else
     52       using_mpi=.FALSE.
     53#endif
     54     
    4355      call InitVampir
    44       call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr)
    45       call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr)
     56     
     57      IF (using_mpi) THEN
     58#ifdef CPP_MPI
     59        call MPI_COMM_SIZE(COMM_LMDZ,mpi_size,ierr)
     60        call MPI_COMM_RANK(COMM_LMDZ,mpi_rank,ierr)
     61#endif
     62      ELSE
     63        mpi_size=1
     64        mpi_rank=0
     65      ENDIF
    4666 
    4767     
    … …  
    5777         
    5878         print *,"Arret : le nombre de bande de lattitude par process est trop faible (<2)."
    59           print *," ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
     79         print *," ---> diminuez le nombre de CPU ou augmentez la taille en lattitude"
    6080         
    61           call MPI_ABORT(COMM_LMDZ,-1, ierr)
    62          
     81#ifdef CPP_MPI
     82          IF (using_mpi) call MPI_ABORT(COMM_LMDZ,-1, ierr)
     83#endif         
    6384        endif
    6485       
    … …  
    106127!$OMP PARALLEL
    107128
    108 #ifdef _OPENMP
     129#ifdef CPP_OMP
    109130!$OMP MASTER
    110131        omp_size=OMP_GET_NUM_THREADS()
    … …  
    162183      include "dimensions.h"
    163184      include "paramet.h"
     185#ifdef CPP_MPI
     186      include 'mpif.h'
     187#endif     
     188
    164189      integer :: ierr
    165190      integer :: i
    166       include 'mpif.h'
    167      
    168191      deallocate(jj_begin_para)
    169192      deallocate(jj_end_para)
    … …  
    178201#endif
    179202      else
    180          call MPI_FINALIZE(ierr)
     203#ifdef CPP_MPI
     204         IF (using_mpi) call MPI_FINALIZE(ierr)
     205#endif
    181206      end if
    182207     
    … …  
    229254     
    230255    end subroutine UnPack_data
     256
     257   
     258    SUBROUTINE barrier
     259    IMPLICIT NONE
     260#ifdef CPP_MPI
     261    INCLUDE 'mpif.h'
     262#endif
     263    INTEGER :: ierr
     264   
     265!$OMP CRITICAL (MPI)     
     266#ifdef CPP_MPI
     267      IF (using_mpi) CALL MPI_Barrier(COMM_LMDZ,ierr)
     268#endif
     269!$OMP END CRITICAL (MPI)
     270   
     271    END SUBROUTINE barrier
     272       
    231273     
    232274    subroutine exchange_hallo(Field,ij,ll,up,down)
    … …  
    235277#include "dimensions.h"
    236278#include "paramet.h"   
     279#ifdef CPP_MPI
    237280    include 'mpif.h'
    238    
     281#endif   
    239282      INTEGER :: ij,ll
    240283      REAL, dimension(ij,ll) :: Field
    … …  
    245288      LOGICAL :: RecvUp,RecvDown
    246289      INTEGER, DIMENSION(4) :: Request
     290#ifdef CPP_MPI
    247291      INTEGER, DIMENSION(MPI_STATUS_SIZE,4) :: Status
     292#else
     293      INTEGER, DIMENSION(1,4) :: Status
     294#endif
    248295      INTEGER :: NbRequest
    249296      REAL, dimension(:),allocatable :: Buffer_Send_up,Buffer_Send_down
    … …  
    251298      INTEGER :: Buffer_size     
    252299
    253 !$OMP CRITICAL (MPI)     
    254       call MPI_Barrier(COMM_LMDZ,ierr)
    255 !$OMP END CRITICAL (MPI)
    256       call VTb(VThallo)
    257      
    258       SendUp=.TRUE.
    259       SendDown=.TRUE.
    260       RecvUp=.TRUE.
    261       RecvDown=.TRUE.
    262        
    263       IF (pole_nord) THEN
    264         SendUp=.FALSE.
    265         RecvUp=.FALSE.
    266       ENDIF
    267  
    268       IF (pole_sud) THEN
    269         SendDown=.FALSE.
    270         RecvDown=.FALSE.
    271       ENDIF
    272      
    273       if (up.eq.0) then
    274         SendDown=.FALSE.
    275         RecvUp=.FALSE.
    276       endif
    277      
    278       if (down.eq.0) then
    279         SendUp=.FALSE.
    280         RecvDown=.FALSE.
    281       endif
    282      
    283       NbRequest=0
    284  
    285       IF (SendUp) THEN
    286         NbRequest=NbRequest+1
    287         buffer_size=down*iip1*ll
    288         allocate(Buffer_Send_up(Buffer_size))
    289         call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
    290 !$OMP CRITICAL (MPI)
    291         call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1,     &
    292                         COMM_LMDZ,Request(NbRequest),ierr)
    293 !$OMP END CRITICAL (MPI)
    294       ENDIF
    295  
    296       IF (SendDown) THEN
    297         NbRequest=NbRequest+1
    298        
    299         buffer_size=up*iip1*ll
    300         allocate(Buffer_Send_down(Buffer_size))
    301         call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
    302        
    303 !$OMP CRITICAL (MPI)
    304         call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1,     &
    305                         COMM_LMDZ,Request(NbRequest),ierr)
    306 !$OMP END CRITICAL (MPI)
    307       ENDIF
    308    
    309  
    310       IF (RecvUp) THEN
    311         NbRequest=NbRequest+1
    312         buffer_size=up*iip1*ll
    313         allocate(Buffer_recv_up(Buffer_size))
     300      IF (using_mpi) THEN
     301
     302        CALL barrier
     303     
     304        call VTb(VThallo)
     305     
     306        SendUp=.TRUE.
     307        SendDown=.TRUE.
     308        RecvUp=.TRUE.
     309        RecvDown=.TRUE.
     310         
     311        IF (pole_nord) THEN
     312          SendUp=.FALSE.
     313          RecvUp=.FALSE.
     314        ENDIF
     315   
     316        IF (pole_sud) THEN
     317          SendDown=.FALSE.
     318          RecvDown=.FALSE.
     319        ENDIF
     320       
     321        if (up.eq.0) then
     322          SendDown=.FALSE.
     323          RecvUp=.FALSE.
     324        endif
     325     
     326        if (down.eq.0) then
     327          SendUp=.FALSE.
     328          RecvDown=.FALSE.
     329        endif
     330     
     331        NbRequest=0
     332 
     333        IF (SendUp) THEN
     334          NbRequest=NbRequest+1
     335          buffer_size=down*iip1*ll
     336          allocate(Buffer_Send_up(Buffer_size))
     337          call PACK_Data(Field(ij_begin,1),ij,ll,down,Buffer_Send_up)
     338!$OMP CRITICAL (MPI)
     339#ifdef CPP_MPI
     340          call MPI_ISSEND(Buffer_send_up,Buffer_Size,MPI_REAL8,MPI_Rank-1,1,     &
     341                          COMM_LMDZ,Request(NbRequest),ierr)
     342#endif
     343!$OMP END CRITICAL (MPI)
     344        ENDIF
     345 
     346        IF (SendDown) THEN
     347          NbRequest=NbRequest+1
     348           
     349          buffer_size=up*iip1*ll
     350          allocate(Buffer_Send_down(Buffer_size))
     351          call PACK_Data(Field(ij_end+1-up*iip1,1),ij,ll,up,Buffer_send_down)
     352       
     353!$OMP CRITICAL (MPI)
     354#ifdef CPP_MPI
     355          call MPI_ISSEND(Buffer_send_down,Buffer_Size,MPI_REAL8,MPI_Rank+1,1,     &
     356                          COMM_LMDZ,Request(NbRequest),ierr)
     357#endif
     358!$OMP END CRITICAL (MPI)
     359        ENDIF
     360   
     361 
     362        IF (RecvUp) THEN
     363          NbRequest=NbRequest+1
     364          buffer_size=up*iip1*ll
     365          allocate(Buffer_recv_up(Buffer_size))
    314366             
    315367!$OMP CRITICAL (MPI)
    316         call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1,  &
    317                         COMM_LMDZ,Request(NbRequest),ierr)
     368#ifdef CPP_MPI
     369          call MPI_IRECV(Buffer_recv_up,Buffer_size,MPI_REAL8,MPI_Rank-1,1,  &
     370                          COMM_LMDZ,Request(NbRequest),ierr)
     371#endif
    318372!$OMP END CRITICAL (MPI)
    319373     
    320374       
    321       ENDIF
    322  
    323       IF (RecvDown) THEN
    324         NbRequest=NbRequest+1
    325         buffer_size=down*iip1*ll
    326         allocate(Buffer_recv_down(Buffer_size))
    327        
    328 !$OMP CRITICAL (MPI)
    329         call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1,     &
    330                         COMM_LMDZ,Request(NbRequest),ierr)
    331 !$OMP END CRITICAL (MPI)
    332      
    333        
    334       ENDIF
    335  
    336       if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
    337       IF (RecvUp)  call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
    338       IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down) 
    339 
    340       call VTe(VThallo)
    341 !$OMP CRITICAL (MPI)
    342       call MPI_Barrier(COMM_LMDZ,ierr)
    343 !$OMP END CRITICAL (MPI)
    344 
     375        ENDIF
     376 
     377        IF (RecvDown) THEN
     378          NbRequest=NbRequest+1
     379          buffer_size=down*iip1*ll
     380          allocate(Buffer_recv_down(Buffer_size))
     381       
     382!$OMP CRITICAL (MPI)
     383#ifdef CPP_MPI
     384          call MPI_IRECV(Buffer_recv_down,Buffer_size,MPI_REAL8,MPI_Rank+1,1,     &
     385                          COMM_LMDZ,Request(NbRequest),ierr)
     386#endif
     387!$OMP END CRITICAL (MPI)
     388       
     389        ENDIF
     390 
     391#ifdef CPP_MPI
     392        if (NbRequest > 0) call MPI_WAITALL(NbRequest,Request,Status,ierr)
     393#endif
     394        IF (RecvUp)  call Unpack_Data(Field(ij_begin-up*iip1,1),ij,ll,up,Buffer_Recv_up)
     395        IF (RecvDown) call Unpack_Data(Field(ij_end+1,1),ij,ll,down,Buffer_Recv_down) 
     396
     397        call VTe(VThallo)
     398        call barrier
     399     
     400      ENDIF  ! using_mpi
     401     
    345402      RETURN
    346403     
    … …  
    352409#include "dimensions.h"
    353410#include "paramet.h"   
     411#ifdef CPP_MPI
    354412    include 'mpif.h'
    355    
     413#endif   
    356414      INTEGER :: ij,ll,rank
    357415      REAL, dimension(ij,ll) :: Field
    … …  
    362420      INTEGER ::i
    363421     
    364       if (ij==ip1jmp1) then
    365          allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1)))
    366          call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
    367       else if (ij==ip1jm) then
    368          allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1)))
    369          call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
    370       else
    371          print *,ij
    372          stop 'erreur dans Gather_Field'
    373       endif
    374      
    375       if (MPI_Rank==rank) then
    376         allocate(Buffer_Recv(ij*ll))
     422      IF (using_mpi) THEN
     423
     424        if (ij==ip1jmp1) then
     425           allocate(Buffer_send(iip1*ll*(jj_end-jj_begin+1)))
     426           call Pack_Data(Field(ij_begin,1),ij,ll,jj_end-jj_begin+1,Buffer_send)
     427        else if (ij==ip1jm) then
     428           allocate(Buffer_send(iip1*ll*(min(jj_end,jjm)-jj_begin+1)))
     429           call Pack_Data(Field(ij_begin,1),ij,ll,min(jj_end,jjm)-jj_begin+1,Buffer_send)
     430        else
     431           print *,ij 
     432        stop 'erreur dans Gather_Field'
     433        endif
     434       
     435        if (MPI_Rank==rank) then
     436          allocate(Buffer_Recv(ij*ll))
    377437
    378438!CDIR NOVECTOR
    379         do i=0,MPI_Size-1
    380            
     439          do i=0,MPI_Size-1
     440             
     441            if (ij==ip1jmp1) then
     442              Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1
     443            else if (ij==ip1jm) then
     444              Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1
     445            else
     446              stop 'erreur dans Gather_Field'
     447            endif
     448                   
     449            if (i==0) then
     450              displ(i)=0
     451            else
     452              displ(i)=displ(i-1)+Recv_count(i-1)
     453            endif
     454           
     455          enddo
     456         
     457        endif
     458 
     459!$OMP CRITICAL (MPI)
     460#ifdef CPP_MPI
     461        call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8,   &
     462                          Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
     463#endif
     464!$OMP END CRITICAL (MPI)
     465     
     466        if (MPI_Rank==rank) then                 
     467     
    381468          if (ij==ip1jmp1) then
    382             Recv_count(i)=(jj_end_para(i)-jj_begin_para(i)+1)*ll*iip1
     469            do i=0,MPI_Size-1
     470              call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                 &
     471                               jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
     472            enddo
    383473          else if (ij==ip1jm) then
    384             Recv_count(i)=(min(jj_end_para(i),jjm)-jj_begin_para(i)+1)*ll*iip1
    385           else
    386             stop 'erreur dans Gather_Field'
     474            do i=0,MPI_Size-1
     475               call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                       &
     476                               min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
     477            enddo
    387478          endif
    388                  
    389           if (i==0) then
    390             displ(i)=0
    391           else
    392             displ(i)=displ(i-1)+Recv_count(i-1)
    393           endif
    394          
    395         enddo
    396        
    397       endif
    398  
    399 !$OMP CRITICAL (MPI)
    400       call MPI_GATHERV(Buffer_send,(min(ij_end,ij)-ij_begin+1)*ll,MPI_REAL8,   &
    401                         Buffer_Recv,Recv_count,displ,MPI_REAL8,rank,COMM_LMDZ,ierr)
    402 !$OMP END CRITICAL (MPI)
    403      
    404       if (MPI_Rank==rank) then                 
    405      
    406         if (ij==ip1jmp1) then
    407           do i=0,MPI_Size-1
    408             call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                 &
    409                              jj_end_para(i)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
    410           enddo
    411         else if (ij==ip1jm) then
    412           do i=0,MPI_Size-1
    413              call Unpack_Data(Field((jj_begin_para(i)-1)*iip1+1,1),ij,ll,                       &
    414                              min(jj_end_para(i),jjm)-jj_begin_para(i)+1,Buffer_Recv(displ(i)+1))
    415           enddo
    416         endif
    417      
    418       endif
    419      
     479        endif
     480      ENDIF ! using_mpi
     481     
    420482    end subroutine Gather_Field
    421483
    … …  
    425487#include "dimensions.h"
    426488#include "paramet.h"   
     489#ifdef CPP_MPI
    427490    include 'mpif.h'
    428    
     491#endif   
    429492      INTEGER :: ij,ll
    430493      REAL, dimension(ij,ll) :: Field
    431494      INTEGER :: ierr
    432495     
    433       call Gather_Field(Field,ij,ll,0)
    434 !$OMP CRITICAL (MPI)
     496      IF (using_mpi) THEN
     497        call Gather_Field(Field,ij,ll,0)
     498!$OMP CRITICAL (MPI)
     499#ifdef CPP_MPI
    435500      call MPI_BCAST(Field,ij*ll,MPI_REAL8,0,COMM_LMDZ,ierr)
    436 !$OMP END CRITICAL (MPI)
     501#endif
     502!$OMP END CRITICAL (MPI)
     503      ENDIF
    437504     
    438505    end subroutine AllGather_Field
    … …  
    442509#include "dimensions.h"
    443510#include "paramet.h"   
     511#ifdef CPP_MPI
    444512    include 'mpif.h'
    445    
     513#endif   
    446514      INTEGER :: ij,ll
    447515      REAL, dimension(ij,ll) :: Field
    … …  
    449517      INTEGER :: ierr
    450518     
    451 !$OMP CRITICAL (MPI)
     519      IF (using_mpi) THEN
     520     
     521!$OMP CRITICAL (MPI)
     522#ifdef CPP_MPI
    452523      call MPI_BCAST(Field,ij*ll,MPI_REAL8,rank,COMM_LMDZ,ierr)
    453 !$OMP END CRITICAL (MPI)
    454      
     524#endif
     525!$OMP END CRITICAL (MPI)
     526     
     527      ENDIF
    455528    end subroutine Broadcast_Field
    456529       
Note: See TracChangeset for help on using the changeset viewer.