New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 532 for trunk/NEMO/OPA_SRC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2006-10-20T08:36:42+02:00 (18 years ago)
Author:
opalod
Message:

nemo_v1_update_76 : CT : add OASIS[3-4] interfaces to build coupled configurations

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/NEMO/OPA_SRC/lib_mpp.F90

    r524 r532  
    4545   !!        !  04  (R. Bourdalle Badie)  isend option in mpi 
    4646   !!        !  05  (G. Madec, S. Masson)  npolj=5,6 F-point & ice cases 
     47   !!        !  05  (R. Redler) Replacement of MPI_COMM_WORLD except for MPI_Abort 
    4748   !!---------------------------------------------------------------------- 
    4849   !!  OPA 9.0 , LOCEAN-IPSL (2005)  
    … …  
    6061   PUBLIC  mpp_lbc_north_e, mpp_minloc, mpp_maxloc, mpp_lnk_3d, mpp_lnk_2d, mpp_lnk_3d_gather, mpp_lnk_2d_e, mpplnks 
    6162   PUBLIC  mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync 
     63#if defined key_oasis3 || defined key_oasis4 
     64   PUBLIC  size, rank 
     65#endif 
    6266 
    6367   !! * Interfaces 
    … …  
    107111   INTEGER ::   & 
    108112      size,     &  ! number of process 
    109       rank         ! process number  [ 0 - size-1 ] 
     113      rank,     &  ! process number  [ 0 - size-1 ] 
     114      mpi_comm_opa ! opa local communicator 
    110115 
    111116   ! variables used in case of north fold condition in mpp_mpi with jpni > 1 
    … …  
    117122      njmppmax             ! value of njmpp for the processors of the northern line 
    118123   INTEGER ::      &       ! 
    119       north_root           ! number (in the comm_world) of proc 0 in the northern comm 
     124      north_root           ! number (in the comm_opa) of proc 0 in the northern comm 
    120125   INTEGER, DIMENSION(:), ALLOCATABLE ::   & 
    121126      nrank_north          ! dimension ndim_rank_north, number of the procs belonging to ncomm_north 
    … …  
    272277CONTAINS 
    273278 
    274    FUNCTION mynode() 
     279   FUNCTION mynode(localComm) 
    275280      !!---------------------------------------------------------------------- 
    276281      !!                  ***  routine mynode  *** 
    … …  
    281286#if defined key_mpp_mpi 
    282287      !! * Local variables   (MPI version) 
    283       INTEGER ::   mynode, ierr 
     288      INTEGER ::   mynode, ierr, code 
     289      LOGICAL ::   mpi_was_called 
     290      INTEGER,OPTIONAL ::   localComm 
    284291      NAMELIST/nam_mpp/ c_mpi_send 
    285292      !!---------------------------------------------------------------------- 
    … …  
    300307      IF( Agrif_Root() ) THEN 
    301308#endif 
    302          SELECT CASE ( c_mpi_send ) 
    303          CASE ( 'S' )                ! Standard mpi send (blocking) 
    304             WRITE(numout,*) '           Standard blocking mpi send (send)' 
    305             CALL mpi_init( ierr ) 
    306          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    307             WRITE(numout,*) '           Buffer blocking mpi send (bsend)' 
    308             CALL mpi_init_opa( ierr ) 
    309          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    310             WRITE(numout,*) '           Immediate non-blocking send (isend)' 
    311             l_isend = .TRUE. 
    312             CALL mpi_init( ierr ) 
    313          CASE DEFAULT 
    314             WRITE(numout,cform_err) 
    315             WRITE(numout,*) '           bad value for c_mpi_send = ', c_mpi_send 
    316             nstop = nstop + 1 
    317          END SELECT 
    318  
     309         CALL mpi_initialized ( mpi_was_called, code ) 
     310         IF( code /= MPI_SUCCESS ) THEN 
     311            CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' ) 
     312            CALL mpi_abort( mpi_comm_world, code, ierr ) 
     313         ENDIF 
     314 
     315         IF( PRESENT(localComm) .and. mpi_was_called ) THEN 
     316            mpi_comm_opa = localComm 
     317            SELECT CASE ( c_mpi_send ) 
     318            CASE ( 'S' )                ! Standard mpi send (blocking) 
     319               WRITE(numout,*) '           Standard blocking mpi send (send)' 
     320            CASE ( 'B' )                ! Buffer mpi send (blocking) 
     321               WRITE(numout,*) '           Buffer blocking mpi send (bsend)' 
     322               CALL mpi_init_opa( ierr ) 
     323            CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
     324               WRITE(numout,*) '           Immediate non-blocking send (isend)' 
     325               l_isend = .TRUE. 
     326            CASE DEFAULT 
     327               WRITE(numout,cform_err) 
     328               WRITE(numout,*) '           bad value for c_mpi_send = ', c_mpi_send 
     329               nstop = nstop + 1 
     330            END SELECT 
     331         ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 
     332            WRITE(numout,*) ' lib_mpp: You cannot provide a local communicator ' 
     333            WRITE(numout,*) '          without calling MPI_Init before ! ' 
     334         ELSE 
     335            SELECT CASE ( c_mpi_send ) 
     336            CASE ( 'S' )                ! Standard mpi send (blocking) 
     337               WRITE(numout,*) '           Standard blocking mpi send (send)' 
     338               CALL mpi_init( ierr ) 
     339            CASE ( 'B' )                ! Buffer mpi send (blocking) 
     340               WRITE(numout,*) '           Buffer blocking mpi send (bsend)' 
     341               CALL mpi_init_opa( ierr ) 
     342            CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
     343               WRITE(numout,*) '           Immediate non-blocking send (isend)' 
     344               l_isend = .TRUE. 
     345               CALL mpi_init( ierr ) 
     346            CASE DEFAULT 
     347               WRITE(ctmp1,*) '           bad value for c_mpi_send = ', c_mpi_send 
     348               CALL ctl_stop( ctmp1 ) 
     349            END SELECT 
     350 
     351            CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 
     352            IF( code /= MPI_SUCCESS ) THEN 
     353               CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' ) 
     354               CALL mpi_abort( mpi_comm_world, code, ierr ) 
     355            ENDIF 
     356            ! 
     357         ENDIF 
    319358#if defined key_agrif 
    320      ELSE 
     359      ELSE 
    321360         SELECT CASE ( c_mpi_send ) 
    322361         CASE ( 'S' )                ! Standard mpi send (blocking) 
    … …  
    335374#endif 
    336375 
    337       CALL mpi_comm_rank( mpi_comm_world, rank, ierr ) 
    338       CALL mpi_comm_size( mpi_comm_world, size, ierr ) 
     376      CALL mpi_comm_rank( mpi_comm_opa, rank, ierr ) 
     377      CALL mpi_comm_size( mpi_comm_opa, size, ierr ) 
    339378      mynode = rank 
    340379#else 
    … …  
    27952834      CASE ( 'S' )                ! Standard mpi send (blocking) 
    27962835         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest, ktyp,   & 
    2797             &                          mpi_comm_world, iflag ) 
     2836            &                          mpi_comm_opa, iflag ) 
    27982837      CASE ( 'B' )                ! Buffer mpi send (blocking) 
    27992838         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest, ktyp,   & 
    2800             &                          mpi_comm_world, iflag ) 
     2839            &                          mpi_comm_opa, iflag ) 
    28012840      CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    28022841         ! Be carefull, one more argument here : the mpi request identifier.. 
    28032842         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest, ktyp,   & 
    2804             &                          mpi_comm_world, md_req, iflag ) 
     2843            &                          mpi_comm_opa, md_req, iflag ) 
    28052844      END SELECT 
    28062845#endif 
    … …  
    28302869 
    28312870      CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp,   & 
    2832          &                          mpi_comm_world, istatus, iflag ) 
     2871         &                          mpi_comm_opa, istatus, iflag ) 
    28332872#endif 
    28342873 
    … …  
    28642903      itaille=jpi*jpj 
    28652904      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille,   & 
    2866          &                            mpi_double_precision, kp , mpi_comm_world, ierror )  
     2905         &                            mpi_double_precision, kp , mpi_comm_opa, ierror )  
    28672906#endif 
    28682907 
    … …  
    28982937 
    28992938      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille,   & 
    2900          &                            mpi_double_precision, kp, mpi_comm_world, ierror ) 
     2939         &                            mpi_double_precision, kp, mpi_comm_opa, ierror ) 
    29012940#endif 
    29022941 
    … …  
    29592998      CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror ) 
    29602999      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer   & 
    2961            , mpi_isl, mpi_comm_world, ierror ) 
     3000           , mpi_isl, mpi_comm_opa, ierror ) 
    29623001      ktab(:) = iwork(:) 
    29633002#endif 
    … …  
    30133052      CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror) 
    30143053      CALL mpi_allreduce(ktab, iwork, 1,mpi_integer   & 
    3015            ,mpi_isl,mpi_comm_world,ierror) 
     3054           ,mpi_isl,mpi_comm_opa,ierror) 
    30163055      ktab = iwork 
    30173056#endif 
    … …  
    30643103   
    30653104      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer,   & 
    3066            &                mpi_min, mpi_comm_world, ierror ) 
     3105           &                mpi_min, mpi_comm_opa, ierror ) 
    30673106   
    30683107      ktab(:) = iwork(:) 
    … …  
    31123151   
    31133152      CALL mpi_allreduce(ktab,iwork, 1,mpi_integer   & 
    3114            &              ,mpi_min,mpi_comm_world,ierror) 
     3153           &              ,mpi_min,mpi_comm_opa,ierror) 
    31153154   
    31163155      ktab = iwork 
    … …  
    31663205   
    31673206      CALL mpi_allreduce(ktab, iwork,kdim,mpi_integer   & 
    3168            ,mpi_sum,mpi_comm_world,ierror) 
     3207           ,mpi_sum,mpi_comm_opa,ierror) 
    31693208   
    31703209      ktab(:) = iwork(:) 
    … …  
    32093248 
    32103249    CALL mpi_allreduce(ktab,iwork, 1,mpi_integer   & 
    3211          ,mpi_sum,mpi_comm_world,ierror) 
     3250         ,mpi_sum,mpi_comm_opa,ierror) 
    32123251 
    32133252    ktab = iwork 
    … …  
    32773316    CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror) 
    32783317    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3279          ,mpi_isl,mpi_comm_world,ierror) 
     3318         ,mpi_isl,mpi_comm_opa,ierror) 
    32803319    ptab(:) = zwork(:) 
    32813320 
    … …  
    33353374      CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror ) 
    33363375      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision,   & 
    3337          &                                mpi_isl  , mpi_comm_world, ierror ) 
     3376         &                                mpi_isl  , mpi_comm_opa, ierror ) 
    33383377      ptab = zwork 
    33393378 
    … …  
    34013440 
    34023441    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3403          ,mpi_max,mpi_comm_world,ierror) 
     3442         ,mpi_max,mpi_comm_opa,ierror) 
    34043443    ptab(:) = zwork(:) 
    34053444 
    … …  
    34453484 
    34463485    CALL mpi_allreduce( ptab, zwork  , 1             , mpi_double_precision,   & 
    3447        &                      mpi_max, mpi_comm_world, ierror     ) 
     3486       &                      mpi_max, mpi_comm_opa, ierror     ) 
    34483487    ptab = zwork 
    34493488 
    … …  
    34983537 
    34993538    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3500          ,mpi_min,mpi_comm_world,ierror) 
     3539         ,mpi_min,mpi_comm_opa,ierror) 
    35013540    ptab(:) = zwork(:) 
    35023541 
    … …  
    35433582 
    35443583    CALL mpi_allreduce( ptab, zwork, 1,mpi_double_precision   & 
    3545          &               ,mpi_min,mpi_comm_world,ierror) 
     3584         &               ,mpi_min,mpi_comm_opa,ierror) 
    35463585    ptab = zwork 
    35473586 
    … …  
    35963635 
    35973636    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3598          &              ,mpi_sum,mpi_comm_world,ierror) 
     3637         &              ,mpi_sum,mpi_comm_opa,ierror) 
    35993638    ptab(:) = zwork(:) 
    36003639 
    … …  
    36403679 
    36413680    CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision   & 
    3642          &              ,mpi_sum,mpi_comm_world,ierror) 
     3681         &              ,mpi_sum,mpi_comm_opa,ierror) 
    36433682    ptab = zwork 
    36443683 
    … …  
    36873726    zain(2,:)=ki+10000.*kj 
    36883727 
    3689     CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,ierror) 
     3728    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 
    36903729 
    36913730    pmin=zaout(1,1) 
    … …  
    37383777    zain(2,:)=ki+10000.*kj+100000000.*kk 
    37393778 
    3740     CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,ierror) 
     3779    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 
    37413780 
    37423781    pmin=zaout(1,1) 
    … …  
    37893828    zain(2,:)=ki+10000.*kj 
    37903829 
    3791     CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,ierror) 
     3830    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 
    37923831 
    37933832    pmax=zaout(1,1) 
    … …  
    38393878    zain(2,:)=ki+10000.*kj+100000000.*kk 
    38403879 
    3841     CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,ierror) 
     3880    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 
    38423881 
    38433882    pmax=zaout(1,1) 
    … …  
    38673906    INTEGER :: ierror 
    38683907 
    3869     CALL mpi_barrier(mpi_comm_world,ierror) 
     3908    CALL mpi_barrier(mpi_comm_opa,ierror) 
    38703909 
    38713910#endif 
    … …  
    42014240    ! create the world group 
    42024241    ! 
    4203     CALL MPI_COMM_GROUP(mpi_comm_world,ngrp_world,ierr) 
     4242    CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr) 
    42044243    ! 
    42054244    ! Create the North group from the world group 
    … …  
    42084247    ! Create the North communicator , ie the pool of procs in the north group 
    42094248    ! 
    4210     CALL MPI_COMM_CREATE(mpi_comm_world,ngrp_north,ncomm_north,ierr) 
     4249    CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_north,ncomm_north,ierr) 
    42114250 
    42124251 
    … …  
    49965035!$AGRIF_END_DO_NOT_TREAT 
    49975036 
    4998       INTEGER                                 :: code,rang 
     5037      INTEGER                                 :: code,rang,ierr 
     5038      LOGICAL                                 :: mpi_was_called 
    49995039  
    50005040      ! La valeur suivante doit etre au moins egale a la taille 
    … …  
    50075047  
    50085048      ! Le point d'entree dans la bibliotheque MPI elle-meme 
    5009       CALL mpi_init(code) 
    5010  
     5049      CALL mpi_initialized(mpi_was_called, code) 
     5050      IF ( code /= MPI_SUCCESS ) THEN 
     5051        CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' ) 
     5052        CALL mpi_abort( mpi_comm_world, code, ierr ) 
     5053      ENDIF 
     5054 
     5055      IF ( .NOT. mpi_was_called ) THEN 
     5056         CALL mpi_init(code) 
     5057         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 
     5058         IF ( code /= MPI_SUCCESS ) THEN 
     5059            CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' ) 
     5060            CALL mpi_abort( mpi_comm_world, code, ierr ) 
     5061         ENDIF 
     5062      ENDIF 
    50115063      ! La definition de la zone tampon pour les futurs envois 
    50125064      ! par MPI_BSEND (on alloue une fois pour toute cette zone 
    … …  
    50345086      ! "data" soit 7 segments, c.-a -d. 1750/8 = 210 Mo 
    50355087      IF (taille_tampon > 210000000) THEN 
    5036          PRINT *,'Attention la valeur BUFFER_LENGTH doit etre <= 210000000' 
     5088         CALL ctl_stop( ' lib_mpp: Attention la valeur BUFFER_LENGTH doit etre <= 210000000' ) 
    50375089         CALL mpi_abort(MPI_COMM_WORLD,2,code) 
    50385090      END IF 
    50395091 
    5040       CALL mpi_comm_rank(MPI_COMM_WORLD,rang,code) 
     5092      CALL mpi_comm_rank(MPI_COMM_OPA,rang,code) 
    50415093      IF (rang == 0 ) PRINT *,'Taille du buffer alloue : ',taille_tampon 
    50425094 
    … …  
    50785130CONTAINS 
    50795131 
    5080    FUNCTION mynode() RESULT (function_value) 
     5132   FUNCTION mynode(localComm) RESULT (function_value) 
     5133      INTEGER, OPTIONAL :: localComm 
    50815134      function_value = 0 
    50825135   END FUNCTION mynode 
Note: See TracChangeset for help on using the changeset viewer.