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 1920 – NEMO

Changeset 1920


Ignore:
Timestamp:
2010-06-07T13:45:58+02:00 (14 years ago)
Author:
rblod
Message:

Add modifications for mpp reproducibility, see ticket #677

Location:
branches/DEV_1879_mpp_rep
Files:
19 edited

Legend:

Unmodified
Added
Removed

  • branches/DEV_1879_mpp_rep/CONFIG/GYRE/EXP00/namelist

    r1741 r1920  
    627627   nn_bench    =    0      !  Bench mode (1/0): CAUTION use zero except for bench 
    628628                           !     (no physical validity of the results) 
    629    nn_bit_cmp  =    0      !  bit comparison mode (1/0): CAUTION use zero except for test 
    630                            !     of comparison between single and multiple processor runs 
    631629/ 
    632630 

  • branches/DEV_1879_mpp_rep/CONFIG/GYRE_LOBSTER/EXP00/namelist

    r1741 r1920  
    627627   nn_bench    =    0      !  Bench mode (1/0): CAUTION use zero except for bench 
    628628                           !     (no physical validity of the results) 
    629    nn_bit_cmp  =    0      !  bit comparison mode (1/0): CAUTION use zero except for test 
    630                            !     of comparison between single and multiple processor runs 
    631629/ 
    632630 

  • branches/DEV_1879_mpp_rep/CONFIG/ORCA2_LIM/EXP00/1_namelist

    r1741 r1920  
    626626   nn_bench    =    0      !  Bench mode (1/0): CAUTION use zero except for bench 
    627627                           !     (no physical validity of the results) 
    628    nn_bit_cmp  =    0      !  bit comparison mode (1/0): CAUTION use zero except for test 
    629                            !     of comparison between single and multiple processor runs 
    630628/ 
    631629 

  • branches/DEV_1879_mpp_rep/CONFIG/ORCA2_LIM/EXP00/namelist

    r1759 r1920  
    654654   nn_bench    =    0      !  Bench mode (1/0): CAUTION use zero except for bench 
    655655                           !     (no physical validity of the results) 
    656    nn_bit_cmp  =    0      !  bit comparison mode (1/0): CAUTION use zero except for test 
    657                            !     of comparison between single and multiple processor runs 
    658656/ 
    659657 

  • branches/DEV_1879_mpp_rep/CONFIG/ORCA2_LIM_PISCES/EXP00/namelist

    r1759 r1920  
    654654   nn_bench    =    0      !  Bench mode (1/0): CAUTION use zero except for bench 
    655655                           !     (no physical validity of the results) 
    656    nn_bit_cmp  =    0      !  bit comparison mode (1/0): CAUTION use zero except for test 
    657                            !     of comparison between single and multiple processor runs 
    658656/ 
    659657 

  • branches/DEV_1879_mpp_rep/CONFIG/POMME/EXP00/namelist

    r1875 r1920  
    651651   nn_bench    =    0      !  Bench mode (1/0): CAUTION use zero except for bench 
    652652                           !     (no physical validity of the results) 
    653    nn_bit_cmp  =    0      !  bit comparison mode (1/0): CAUTION use zero except for test 
    654                            !     of comparison between single and multiple processor runs 
    655653/ 
    656654 

  • branches/DEV_1879_mpp_rep/NEMO/LIM_SRC_2/limdyn_2.F90

    r1694 r1920  
    8383         ! --------------------------------------------------- 
    8484          
    85          IF( lk_mpp .OR. nbit_cmp == 1 ) THEN                    ! mpp: compute over the whole domain 
     85         IF( lk_mpp .OR. lk_mpp_rep ) THEN                    ! mpp: compute over the whole domain 
    8686            i_j1 = 1    
    8787            i_jpj = jpj 

  • branches/DEV_1879_mpp_rep/NEMO/LIM_SRC_3/limdyn.F90

    r1470 r1920  
    9393         ! --------------------------------------------------- 
    9494 
    95          IF( lk_mpp .OR. nbit_cmp == 1 ) THEN                    ! mpp: compute over the whole domain 
     95         IF( lk_mpp .OR. lk_mpp_rep ) THEN                    ! mpp: compute over the whole domain 
    9696            i_j1 = 1 
    9797            i_jpj = jpj 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/DOM/dom_oce.F90

    r1876 r1920  
    221221#endif 
    222222 
     223   !!---------------------------------------------------------------------- 
     224   !! mpp reproducibility 
     225   !!---------------------------------------------------------------------- 
     226#if defined key_mpp_rep1 || defined key_mpp_re2 
     227   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp_rep = .TRUE.    !: agrif flag 
     228#else 
     229   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp_rep = .FALSE.   !: agrif flag 
     230#endif 
    223231   !!====================================================================== 
    224232END MODULE dom_oce 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/DOM/domain.F90

    r1792 r1920  
    166166      ENDIF 
    167167 
     168#if defined key_agrif 
    168169      IF( Agrif_Root() ) THEN 
    169          SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
    170          CASE (  1 )  
    171             CALL ioconf_calendar('gregorian') 
    172             IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "gregorian", i.e. leap year' 
    173          CASE (  0 ) 
    174             CALL ioconf_calendar('noleap') 
    175             IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "noleap", i.e. no leap year' 
    176          CASE ( 30 ) 
    177             CALL ioconf_calendar('360d') 
    178             IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "360d", i.e. 360 days in a year' 
    179          END SELECT 
    180       ENDIF 
     170#endif 
     171      SELECT CASE ( nleapy )        ! Choose calendar for IOIPSL 
     172      CASE (  1 )  
     173         CALL ioconf_calendar('gregorian') 
     174         IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "gregorian", i.e. leap year' 
     175      CASE (  0 ) 
     176         CALL ioconf_calendar('noleap') 
     177         IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "noleap", i.e. no leap year' 
     178      CASE ( 30 ) 
     179         CALL ioconf_calendar('360d') 
     180         IF(lwp) WRITE(numout,*) '   The IOIPSL calendar is "360d", i.e. 360 days in a year' 
     181      END SELECT 
     182#if defined key_agrif 
     183      ENDIF 
     184#endif 
    181185 
    182186      REWIND( numnam )             ! Namelist namdom : space & time domain (bathymetry, mesh, timestep) 
    … …  
    226230      n_cla = nn_cla                ! conversion DOCTOR names into model names (this should disappear soon) 
    227231 
    228       IF( nbit_cmp == 1 .AND. n_cla /= 0 )   CALL ctl_stop( ' Reproductibility tests (nbit_cmp=1) require n_cla = 0' ) 
     232      IF( lk_mpp_rep .AND. n_cla /= 0 )   CALL ctl_stop( ' Reproductibility tests (nbit_cmp=1) require n_cla = 0' ) 
    229233      ! 
    230234   END SUBROUTINE dom_nam 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/DYN/dynspg_flt.F90

    r1876 r1920  
    4747   USE iom 
    4848   USE restart         ! only for lrst_oce 
     49   USE lib_fortran 
    4950 
    5051   IMPLICIT NONE 
    … …  
    186187 
    187188#if defined key_obc 
    188       IF( lk_obc )   CALL obc_dyn( kt )   ! Update velocities on each open boundary with the radiation algorithm 
    189       IF( lk_obc )   CALL obc_vol( kt )   ! Correction of the barotropic componant velocity to control the volume of the system 
     189      CALL obc_dyn( kt )      ! Update velocities on each open boundary with the radiation algorithm 
     190      CALL obc_vol( kt )      ! Correction of the barotropic componant velocity to control the volume of the system 
    190191#endif 
    191192#if defined key_bdy 
    … …  
    281282      ! ------------------ 
    282283      rnorme =0.e0 
    283       rnorme = SUM( gcb(1:jpi,1:jpj) * gcdmat(1:jpi,1:jpj) * gcb(1:jpi,1:jpj) * bmask(:,:) ) 
    284       IF( lk_mpp )   CALL mpp_sum( rnorme )   ! sum over the global domain 
     284      rnorme = GLOB_SUM( gcb(1:jpi,1:jpj) * gcdmat(1:jpi,1:jpj) * gcb(1:jpi,1:jpj) * bmask(:,:) ) 
    285285 
    286286      epsr = eps * eps * rnorme 
    … …  
    315315#if defined key_obc 
    316316            ! caution : grad D = 0 along open boundaries 
    317             IF( Agrif_Root() ) THEN 
    318                spgu(ji,jj) = z2dt * ztdgu * obcumask(ji,jj) 
    319                spgv(ji,jj) = z2dt * ztdgv * obcvmask(ji,jj) 
    320             ELSE 
    321                spgu(ji,jj) = z2dt * ztdgu 
    322                spgv(ji,jj) = z2dt * ztdgv 
    323             ENDIF 
     317            spgu(ji,jj) = z2dt * ztdgu * obcumask(ji,jj) 
     318            spgv(ji,jj) = z2dt * ztdgv * obcvmask(ji,jj) 
    324319#elif defined key_bdy 
    325320            ! caution : grad D = 0 along open boundaries 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/IOM/in_out_manager.F90

    r1770 r1920  
    8080 
    8181   !                                              !: OLD namelist names 
    82    INTEGER ::   nprint, nictls, nictle, njctls, njctle, isplt, jsplt, nbench, nbit_cmp    
     82   INTEGER ::   nprint, nictls, nictle, njctls, njctle, isplt, jsplt, nbench 
    8383 
    8484   INTEGER            ::   ijsplt     =    1      !: nb of local domain = nb of processors 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/SBC/sbcana.F90

    r1732 r1920  
    207207 
    208208      ! Compute the emp flux such as its integration on the whole domain at each time is zero 
    209       IF( nbench /= 1 .AND. nbit_cmp /= 1 ) THEN 
     209      IF( nbench /= 1 ) THEN 
    210210         zsumemp = 0.e0   ;   zsurf = 0.e0 
    211211         DO jj = 1, jpj 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/SBC/sbcfwb.F90

    r1822 r1920  
    2323   USE lib_mpp         ! distribued memory computing library 
    2424   USE lbclnk          ! ocean lateral boundary conditions 
     25   USE lib_fortran 
    2526 
    2627   IMPLICIT NONE 
    … …  
    6566      INTEGER  ::   inum                  ! temporary logical unit 
    6667      INTEGER  ::   ikty, iyear           !  
    67       REAL(wp) ::   z_emp, z_emp_nsrf, zsum_emp, zsum_erp       ! temporary scalars 
     68      REAL(wp) ::   z_emp, z_emp_nsrf       ! temporary scalars 
    6869      REAL(wp) ::   zsurf_neg, zsurf_pos, zsurf_tospread 
    6970      REAL(wp), DIMENSION(jpi,jpj) ::   ztmsk_neg, ztmsk_pos, ztmsk_tospread 
    … …  
    8788         ! 
    8889         e1e2_i(:,:) = e1t(:,:) * e2t(:,:) * tmask_i(:,:) 
    89          area = SUM( e1e2_i(:,:) ) 
    90          IF( lk_mpp )   CALL  mpp_sum( area    )   ! sum over the global domain 
     90         area = glob_sum( e1e2_i(:,:) )   ! sum over the global domain 
    9191         ! 
    9292      ENDIF 
    … …  
    103103      CASE ( 1 )                               ! global mean emp set to zero 
    104104         IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN 
    105             z_emp = SUM( e1e2_i(:,:) * emp(:,:) ) / area 
    106             IF( lk_mpp )   CALL  mpp_sum( z_emp    )   ! sum over the global domain 
     105            z_emp = glob_sum( e1e2_i(:,:) * emp(:,:) ) / area   ! sum over the global domain 
    107106            emp (:,:) = emp (:,:) - z_emp 
    108107            emps(:,:) = emps(:,:) - z_emp 
    … …  
    128127         IF( MOD( kt, ikty ) == 0 ) THEN 
    129128            a_fwb_b = a_fwb 
    130             a_fwb   = SUM( e1e2_i(:,:) * sshn(:,:) ) 
    131             IF( lk_mpp )   CALL  mpp_sum( a_fwb    )   ! sum over the global domain 
     129            a_fwb   = glob_sum( e1e2_i(:,:) * sshn(:,:) )   ! sum over the global domain 
    132130            a_fwb   = a_fwb * 1.e+3 / ( area * 86400. * 365. )     ! convert in Kg/m3/s = mm/s 
    133131!!gm        !                                                      !!bug 365d year  
    … …  
    162160         
    163161            ! emp global mean  
    164             z_emp = SUM( e1e2_i(:,:) * emp(:,:) ) / area 
     162            z_emp = glob_sum( e1e2_i(:,:) * emp(:,:) ) / area 
    165163            ! 
    166             IF( lk_mpp )   CALL  mpp_sum( z_emp ) 
    167             IF( lk_mpp )   CALL  mpp_sum( zsurf_neg ) 
    168             IF( lk_mpp )   CALL  mpp_sum( zsurf_pos ) 
    169164             
    170165            IF( z_emp < 0.e0 ) THEN 
    … …  
    179174 
    180175            ! emp global mean over <0 or >0 erp area 
    181             zsum_emp = SUM( e1e2_i(:,:) * z_emp ) 
    182             IF( lk_mpp )   CALL  mpp_sum( zsum_emp ) 
    183             z_emp_nsrf =  zsum_emp / ( zsurf_tospread + rsmall ) 
     176            z_emp_nsrf = SUM( e1e2_i(:,:) * z_emp ) / ( zsurf_tospread + rsmall ) 
    184177            ! weight to respect erp field 2D structure  
    185             zsum_erp = SUM( ztmsk_tospread(:,:) * erp(:,:) * e1e2_i(:,:) ) 
    186             IF( lk_mpp )   CALL  mpp_sum( zsum_erp ) 
    187             z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( zsum_erp + rsmall ) 
    188  
     178            z_wgt(:,:) = ztmsk_tospread(:,:) * erp(:,:) / ( SUM( ztmsk_tospread(:,:) * erp(:,:) * e1e2_i(:,:) ) + rsmall ) 
    189179            ! final correction term to apply 
    190180            zerp_cor(:,:) = -1. * z_emp_nsrf * zsurf_tospread * z_wgt(:,:) 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/SOL/solpcg.F90

    r1601 r1920  
    1414   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
    1515   USE in_out_manager  ! I/O manager 
     16   USE lib_fortran 
    1617 
    1718   IMPLICIT NONE 
    … …  
    9596      ! Initialization of the algorithm with standard PCG 
    9697      ! ------------------------------------------------- 
     98      zgcr = 0.e0  
     99      gcr  = 0.e0  
    97100 
    98101      CALL lbc_lnk( gcx, c_solver_pt, 1. )   ! lateral boundary condition 
    … …  
    100103      ! gcr   = gcb-a.gcx 
    101104      ! gcdes = gcr 
    102  
    103105      DO jj = 2, jpjm1 
    104106         DO ji = fs_2, fs_jpim1   ! vector opt. 
    … …  
    114116 
    115117      ! rnorme = (gcr,gcr) 
    116       rnorme = SUM(  gcr(:,:) * gcdmat(:,:) * gcr(:,:)  ) 
    117       IF( lk_mpp )   CALL mpp_sum( rnorme )   ! sum over the global domain 
     118      rnorme = glob_sum(  gcr(:,:) * gcdmat(:,:) * gcr(:,:)  ) 
    118119 
    119120      CALL lbc_lnk( gcdes, c_solver_pt, 1. )   ! lateral boundary condition 
    … …  
    129130 
    130131      ! alph = (gcr,gcr)/(gcdes,gccd) 
    131       radd = SUM(  gcdes(:,:) * gcdmat(:,:) * gccd(:,:)  ) 
    132       IF( lk_mpp )   CALL mpp_sum( radd )   ! sum over the global domain 
     132      radd = glob_sum(  gcdes(:,:) * gcdmat(:,:) * gccd(:,:)  ) 
    133133      alph = rnorme /radd 
    134134 
    … …  
    162162         ! rnorme = (gcr,gcr) 
    163163         rr = rnorme 
    164          zsum(1) = SUM(  gcr(:,:) * gcdmat(:,:) * gcr(:,:)  ) 
    165164 
    166165         ! zgcad = (zgcr,gcr)  
    167          zsum(2) = SUM( gcr(2:jpim1,2:jpjm1) * gcdmat(2:jpim1,2:jpjm1) * zgcr(2:jpim1,2:jpjm1) ) 
    168  
    169          IF( lk_mpp )   CALL mpp_sum( zsum, 2 )   ! sum over the global domain 
     166         zsum(1) = glob_sum(gcr(:,:) * gcdmat(:,:) * gcr(:,:)) 
     167         zsum(2) = glob_sum(gcr(:,:) * gcdmat(:,:) * zgcr(:,:) * bmask(:,:)) 
     168 
     169         !!RB we should gather the 2 glob_sum 
    170170         rnorme = zsum(1)   
    171171         zgcad  = zsum(2) 
    172  
    173172         ! test of convergence 
    174173         IF( rnorme < epsr .OR. jn == nn_nmax ) THEN 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/SOL/solsor.F90

    r1601 r1920  
    2222   USE lib_mpp         ! distributed memory computing 
    2323   USE lbclnk          ! ocean lateral boundary conditions (or mpp link) 
     24   USE lib_fortran 
    2425 
    2526   IMPLICIT NONE 
    … …  
    6465      INTEGER  ::   ijmppodd, ijmppeven, ijpr2d 
    6566      REAL(wp) ::   ztmp, zres, zres2 
     67      REAL(wp), DIMENSION(jpi,jpj) ::ztab 
    6668      !!---------------------------------------------------------------------- 
    6769       
    … …  
    131133               ENDIF 
    132134            CASE ( 1 )                 ! relative precision 
    133                rnorme = SUM( gcr(2:nlci-1,2:nlcj-1) ) 
    134                IF( lk_mpp )   CALL mpp_sum( rnorme )   ! sum over the global domain 
     135               ztab = 0. 
     136               ztab(:,:) = gcr(2:nlci-1,2:nlcj-1) 
     137               rnorme = glob_sum( ztab)    ! sum over the global domain 
    135138               ! test of convergence 
    136139               IF( rnorme < epsr .OR. jn == nn_nmax ) THEN 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/SOL/solver.F90

    r1601 r1920  
    102102      END SELECT 
    103103      ! 
    104       IF( nbit_cmp == 1 ) THEN            ! reproductibility test SOR required 
    105          IF( nn_solv /= 2 ) THEN 
    106             CALL ctl_stop( ' Reproductibility tests (nbit_cmp=1) require the SOR solver: nn_solv = 2' ) 
    107          ELSE IF( MAX( jpr2di, jpr2dj ) > 0 ) THEN 
    108             CALL ctl_stop( ' Reproductibility tests (nbit_cmp=1) require jpr2di = jpr2dj = 0' ) 
    109          END IF  
    110       END IF 
    111104 
    112105      !                             !* Grid-point at which the solver is applied 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/lib_mpp.F90

    r1874 r1920  
    7575#endif 
    7676 
     77# if defined key_mpp_rep1 
     78   PUBLIC mpp_allgatherv 
     79# endif 
     80 
    7781   !! * Interfaces 
    7882   !! define generic interface for these routine as they are called sometimes 
    … …  
    8690   END INTERFACE 
    8791   INTERFACE mpp_sum 
     92# if defined key_mpp_rep2 
     93      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 
     94                       mppsum_realdd, mppsum_a_realdd 
     95# else 
    8896      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real 
     97# endif 
    8998   END INTERFACE 
    9099   INTERFACE mpp_lbc_north 
    … …  
    97106      MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 
    98107   END INTERFACE 
    99  
     108    
     109# if defined key_mpp_rep1 
     110   INTERFACE mpp_allgatherv 
     111      MODULE PROCEDURE mpp_allgatherv_real, mpp_allgatherv_int 
     112   END INTERFACE 
     113# endif 
    100114 
    101115   !! ========================= !! 
    … …  
    112126   INTEGER ::   mppsize        ! number of process 
    113127   INTEGER ::   mpprank        ! process number  [ 0 - size-1 ] 
    114 !$AGRIF_DO_NOT_TREAT 
    115    INTEGER, PUBLIC ::   mpi_comm_opa   ! opa local communicator 
    116 !$AGRIF_END_DO_NOT_TREAT 
     128   INTEGER ::   mpi_comm_opa   ! opa local communicator 
     129 
     130   INTEGER, PUBLIC :: MPI_SUMDD 
    117131 
    118132   ! variables used in case of sea-ice 
    … …  
    193207      WRITE(ldtxt(6),*) '      size in bytes of exported buffer   nn_buffer   = ', nn_buffer 
    194208 
    195       CALL mpi_initialized ( mpi_was_called, code ) 
    196       IF( code /= MPI_SUCCESS ) THEN 
    197          WRITE(*, cform_err) 
    198          WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 
    199          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    200       ENDIF 
    201  
    202       IF( mpi_was_called ) THEN 
    203          ! 
     209#if defined key_agrif 
     210      IF( Agrif_Root() ) THEN 
     211#endif 
     212         !!bug RB : should be clean to use Agrif in coupled mode 
     213#if ! defined key_agrif 
     214         CALL mpi_initialized ( mpi_was_called, code ) 
     215         IF( code /= MPI_SUCCESS ) THEN 
     216            WRITE(*, cform_err) 
     217            WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 
     218            CALL mpi_abort( mpi_comm_world, code, ierr ) 
     219         ENDIF 
     220 
     221         IF( PRESENT(localComm) .and. mpi_was_called ) THEN 
     222            mpi_comm_opa = localComm 
     223            SELECT CASE ( cn_mpi_send ) 
     224            CASE ( 'S' )                ! Standard mpi send (blocking) 
     225               WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)' 
     226            CASE ( 'B' )                ! Buffer mpi send (blocking) 
     227               WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)' 
     228               CALL mpi_init_opa( ierr )  
     229            CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
     230               WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)' 
     231               l_isend = .TRUE. 
     232            CASE DEFAULT 
     233               WRITE(ldtxt(7),cform_err) 
     234               WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send 
     235               nstop = nstop + 1 
     236            END SELECT 
     237         ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 
     238            WRITE(ldtxt(7),*) ' lib_mpp: You cannot provide a local communicator ' 
     239            WRITE(ldtxt(8),*) '          without calling MPI_Init before ! ' 
     240            nstop = nstop + 1 
     241         ELSE 
     242#endif 
     243            SELECT CASE ( cn_mpi_send ) 
     244            CASE ( 'S' )                ! Standard mpi send (blocking) 
     245               WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)' 
     246               CALL mpi_init( ierr ) 
     247            CASE ( 'B' )                ! Buffer mpi send (blocking) 
     248               WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)' 
     249               CALL mpi_init_opa( ierr ) 
     250            CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
     251               WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)' 
     252               l_isend = .TRUE. 
     253               CALL mpi_init( ierr ) 
     254            CASE DEFAULT 
     255               WRITE(ldtxt(7),cform_err) 
     256               WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send 
     257               nstop = nstop + 1 
     258            END SELECT 
     259 
     260#if ! defined key_agrif 
     261            CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 
     262            IF( code /= MPI_SUCCESS ) THEN 
     263               WRITE(*, cform_err) 
     264               WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
     265               CALL mpi_abort( mpi_comm_world, code, ierr ) 
     266            ENDIF 
     267            ! 
     268         ENDIF 
     269#endif 
     270#if defined key_agrif 
     271      ELSE 
    204272         SELECT CASE ( cn_mpi_send ) 
    205273         CASE ( 'S' )                ! Standard mpi send (blocking) 
    … …  
    207275         CASE ( 'B' )                ! Buffer mpi send (blocking) 
    208276            WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)' 
    209             CALL mpi_init_opa( ierr )  
    210277         CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    211278            WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)' 
    … …  
    216283            nstop = nstop + 1 
    217284         END SELECT 
    218       ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 
    219          WRITE(ldtxt(7),*) ' lib_mpp: You cannot provide a local communicator ' 
    220          WRITE(ldtxt(8),*) '          without calling MPI_Init before ! ' 
    221          nstop = nstop + 1 
    222       ELSE 
    223          SELECT CASE ( cn_mpi_send ) 
    224          CASE ( 'S' )                ! Standard mpi send (blocking) 
    225             WRITE(ldtxt(7),*) '           Standard blocking mpi send (send)' 
    226             CALL mpi_init( ierr ) 
    227          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    228             WRITE(ldtxt(7),*) '           Buffer blocking mpi send (bsend)' 
    229             CALL mpi_init_opa( ierr ) 
    230          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    231             WRITE(ldtxt(7),*) '           Immediate non-blocking send (isend)' 
    232             l_isend = .TRUE. 
    233             CALL mpi_init( ierr ) 
    234          CASE DEFAULT 
    235             WRITE(ldtxt(7),cform_err) 
    236             WRITE(ldtxt(8),*) '           bad value for cn_mpi_send = ', cn_mpi_send 
    237             nstop = nstop + 1 
    238          END SELECT 
    239          ! 
    240285      ENDIF 
    241286 
    242       IF( PRESENT(localComm) ) THEN  
    243          IF( Agrif_Root() ) THEN 
    244             mpi_comm_opa = localComm 
    245          ENDIF 
    246       ELSE 
    247          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 
    248          IF( code /= MPI_SUCCESS ) THEN 
    249             WRITE(*, cform_err) 
    250             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    251             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    252          ENDIF 
    253       ENDIF  
    254  
     287      mpi_comm_opa = mpi_comm_world 
     288#endif 
    255289      CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 
    256290      CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 
    257291      mynode = mpprank 
     292      ! 
     293#if defined key_mpp_rep2 
     294      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 
     295#endif 
    258296      ! 
    259297   END FUNCTION mynode 
    … …  
    13941432   END SUBROUTINE mppsum_real 
    13951433 
    1396  
     1434# if defined key_mpp_rep2 
     1435   SUBROUTINE mppsum_realdd( ytab, kcom ) 
     1436      !!---------------------------------------------------------------------- 
     1437      !!                  ***  routine mppsum_realdd *** 
     1438      !! 
     1439      !! ** Purpose :   global sum in Massively Parallel Processing 
     1440      !!                SCALAR argument case for double-double precision 
     1441      !! 
     1442      !!----------------------------------------------------------------------- 
     1443      COMPLEX(wp), INTENT(inout)         :: ytab    ! input scalar 
     1444      INTEGER , INTENT( in  ), OPTIONAL :: kcom 
     1445 
     1446      !! * Local variables   (MPI version) 
     1447      INTEGER  ::    ierror 
     1448      INTEGER  ::   localcomm 
     1449      COMPLEX(wp) :: zwork 
     1450 
     1451      localcomm = mpi_comm_opa 
     1452      IF( PRESENT(kcom) ) localcomm = kcom 
     1453 
     1454      ! reduce local sums into global sum 
     1455      CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, & 
     1456                       MPI_SUMDD,localcomm,ierror) 
     1457      ytab = zwork 
     1458 
     1459   END SUBROUTINE mppsum_realdd 
     1460   
     1461   
     1462   SUBROUTINE mppsum_a_realdd( ytab, kdim, kcom ) 
     1463      !!---------------------------------------------------------------------- 
     1464      !!                  ***  routine mppsum_a_realdd  *** 
     1465      !! 
     1466      !! ** Purpose :   global sum in Massively Parallel Processing 
     1467      !!                COMPLEX ARRAY case for double-double precision 
     1468      !! 
     1469      !!----------------------------------------------------------------------- 
     1470      INTEGER , INTENT( in )                        ::   kdim      ! size of ytab 
     1471      COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) ::   ytab      ! input array 
     1472      INTEGER , INTENT( in  ), OPTIONAL :: kcom 
     1473 
     1474      !! * Local variables   (MPI version) 
     1475      INTEGER                      :: ierror    ! temporary integer 
     1476      INTEGER                      ::   localcomm 
     1477      COMPLEX(wp), DIMENSION(kdim) :: zwork     ! temporary workspace 
     1478 
     1479      localcomm = mpi_comm_opa 
     1480      IF( PRESENT(kcom) ) localcomm = kcom 
     1481 
     1482      CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, & 
     1483                       MPI_SUMDD,localcomm,ierror) 
     1484      ytab(:) = zwork(:) 
     1485 
     1486   END SUBROUTINE mppsum_a_realdd 
     1487# endif    
     1488    
    13971489   SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) 
    13981490      !!------------------------------------------------------------------------ 
    … …  
    20492141      ijpj   = 4 
    20502142      ijpjm1 = 3 
    2051       ztab(:,:,:) = 0.e0 
    20522143      ! 
    20532144      DO jj = nlcj - ijpj +1, nlcj          ! put in znorthloc the last 4 jlines of pt3d 
    … …  
    21152206      ijpj   = 4 
    21162207      ijpjm1 = 3 
    2117       ztab(:,:) = 0.e0 
    21182208      ! 
    21192209      DO jj = nlcj-ijpj+1, nlcj             ! put in znorthloc the last 4 jlines of pt2d 
    … …  
    21812271      ! 
    21822272      ijpj=4 
    2183       ztab(:,:) = 0.e0 
    21842273 
    21852274      ij=0 
    … …  
    22652354   END SUBROUTINE mpi_init_opa 
    22662355 
     2356#if defined key_mpp_rep1 
     2357   SUBROUTINE mpp_allgatherv_real( pvalsin, knoin, pvalsout, ksizeout, & 
     2358      &                            knoout, kstartout ) 
     2359      !!---------------------------------------------------------------------- 
     2360      !!               ***  ROUTINE mpp_allgatherv_real *** 
     2361      !!           
     2362      !! ** Purpose : Gather a real array on all processors 
     2363      !! 
     2364      !! ** Method  : MPI all gatherv 
     2365      !! 
     2366      !! ** Action  : This does only work for MPI.  
     2367      !!              It does not work for SHMEM. 
     2368      !! 
     2369      !! References : http://www.mpi-forum.org 
     2370      !! 
     2371      !! History : 
     2372      !!        !  08-08  (K. Mogensen)  Original code 
     2373      !!---------------------------------------------------------------------- 
     2374 
     2375      !! * Arguments 
     2376      INTEGER, INTENT(IN) :: & 
     2377         & knoin,     & 
     2378         & ksizeout 
     2379      REAL(wp), DIMENSION(knoin), INTENT(IN) :: & 
     2380         & pvalsin 
     2381      REAL(wp), DIMENSION(ksizeout), INTENT(OUT) :: & 
     2382         & pvalsout 
     2383      INTEGER, DIMENSION(jpnij), INTENT(OUT) :: & 
     2384         & kstartout, & 
     2385         & knoout 
     2386       
     2387      !! * Local declarations 
     2388      INTEGER :: & 
     2389         & ierr 
     2390      INTEGER :: & 
     2391         & ji 
     2392      !----------------------------------------------------------------------- 
     2393      ! Call the MPI library to get number of data per processor 
     2394      !----------------------------------------------------------------------- 
     2395      CALL mpi_allgather( knoin,  1, mpi_integer, & 
     2396         &                knoout, 1, mpi_integer, & 
     2397         &                mpi_comm_opa, ierr ) 
     2398      !----------------------------------------------------------------------- 
     2399      ! Compute starts of each processors contribution 
     2400      !----------------------------------------------------------------------- 
     2401      kstartout(1) = 0 
     2402      DO ji = 2, jpnij 
     2403         kstartout(ji) = kstartout(ji-1) + knoout(ji-1)  
     2404      ENDDO 
     2405      !----------------------------------------------------------------------- 
     2406      ! Call the MPI library to do the gathering of the data 
     2407      !----------------------------------------------------------------------- 
     2408      CALL mpi_allgatherv( pvalsin,  knoin,  MPI_DOUBLE_PRECISION,            & 
     2409         &                 pvalsout, knoout, kstartout, MPI_DOUBLE_PRECISION, & 
     2410         &                 mpi_comm_opa, ierr ) 
     2411      
     2412   END SUBROUTINE mpp_allgatherv_real 
     2413 
     2414   SUBROUTINE mpp_allgatherv_int( kvalsin, knoin, kvalsout, ksizeout, & 
     2415      &                               knoout, kstartout ) 
     2416      !!---------------------------------------------------------------------- 
     2417      !!               ***  ROUTINE mpp_allgatherv *** 
     2418      !!           
     2419      !! ** Purpose : Gather an integer array on all processors 
     2420      !! 
     2421      !! ** Method  : MPI all gatherv 
     2422      !! 
     2423      !! ** Action  : This does only work for MPI.  
     2424      !!              It does not work for SHMEM. 
     2425      !! 
     2426      !! References : http://www.mpi-forum.org 
     2427      !! 
     2428      !! History : 
     2429      !!        !  06-07  (K. Mogensen)  Original code 
     2430      !!---------------------------------------------------------------------- 
     2431 
     2432      !! * Arguments 
     2433      INTEGER, INTENT(IN) :: & 
     2434         & knoin,     & 
     2435         & ksizeout 
     2436      INTEGER, DIMENSION(knoin), INTENT(IN) :: & 
     2437         & kvalsin 
     2438      INTEGER, DIMENSION(ksizeout), INTENT(OUT) :: & 
     2439         & kvalsout 
     2440      INTEGER, DIMENSION(jpnij), INTENT(OUT) :: & 
     2441         & kstartout, & 
     2442         & knoout 
     2443       
     2444      !! * Local declarations 
     2445      INTEGER :: & 
     2446         & ierr 
     2447      INTEGER :: & 
     2448         & ji 
     2449      !----------------------------------------------------------------------- 
     2450      ! Call the MPI library to get number of data per processor 
     2451      !----------------------------------------------------------------------- 
     2452      CALL mpi_allgather( knoin,  1, mpi_integer, & 
     2453         &                knoout, 1, mpi_integer, & 
     2454         &                mpi_comm_opa, ierr ) 
     2455      !----------------------------------------------------------------------- 
     2456      ! Compute starts of each processors contribution 
     2457      !----------------------------------------------------------------------- 
     2458      kstartout(1) = 0 
     2459      DO ji = 2, jpnij 
     2460         kstartout(ji) = kstartout(ji-1) + knoout(ji-1) 
     2461      ENDDO 
     2462      !----------------------------------------------------------------------- 
     2463      ! Call the MPI library to do the gathering of the data 
     2464      !----------------------------------------------------------------------- 
     2465      CALL mpi_allgatherv( kvalsin,  knoin,  mpi_integer,            & 
     2466         &                 kvalsout, knoout, kstartout, mpi_integer, & 
     2467         &                 mpi_comm_opa, ierr ) 
     2468       
     2469   END SUBROUTINE mpp_allgatherv_int 
     2470#endif 
     2471 
     2472#if defined key_mpp_rep2 
     2473   SUBROUTINE DDPDD_MPI (ydda, yddb, ilen, itype) 
     2474      !!--------------------------------------------------------------------- 
     2475      !!   Routine DDPDD_MPI: used by reduction operator MPI_SUMDD 
     2476      !! 
     2477      !!   Modification of original codes written by David H. Bailey 
     2478      !!   This subroutine computes yddb(i) = ydda(i)+yddb(i) 
     2479      !!--------------------------------------------------------------------- 
     2480      INTEGER, INTENT(in)                         :: ilen, itype 
     2481      COMPLEX(wp), DIMENSION(ilen), INTENT(in)     :: ydda 
     2482      COMPLEX(wp), DIMENSION(ilen), INTENT(inout)  :: yddb 
     2483      ! 
     2484      REAL(wp) :: zerr, zt1, zt2    ! local work variables 
     2485      INTEGER :: ji, ztmp           ! local scalar 
     2486 
     2487      ztmp = itype   ! avoid compilation warning 
     2488 
     2489      DO ji=1,ilen 
     2490      ! Compute ydda + yddb using Knuth's trick. 
     2491         zt1  = real(ydda(ji)) + real(yddb(ji)) 
     2492         zerr = zt1 - real(ydda(ji)) 
     2493         zt2  = ((real(yddb(ji)) - zerr) + (real(ydda(ji)) - (zt1 - zerr))) & 
     2494                + aimag(ydda(ji)) + aimag(yddb(ji)) 
     2495 
     2496         ! The result is zt1 + zt2, after normalization. 
     2497         yddb(ji) = cmplx ( zt1 + zt2, zt2 - ((zt1 + zt2) - zt1),wp ) 
     2498      END DO 
     2499 
     2500   END SUBROUTINE DDPDD_MPI 
     2501#endif 
     2502 
    22672503#else 
    22682504   !!---------------------------------------------------------------------- 
    22692505   !!   Default case:            Dummy module        share memory computing 
    22702506   !!---------------------------------------------------------------------- 
     2507# if defined key_mpp_rep1 
     2508   USE par_kind 
     2509   USE par_oce 
     2510 
     2511   PUBLIC mpp_allgatherv 
     2512# endif 
     2513 
    22712514   INTERFACE mpp_sum 
    2272       MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i 
     2515      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i,  & 
     2516             &         mpp_sum_c, mpp_sum_ac  
    22732517   END INTERFACE 
    22742518   INTERFACE mpp_max 
    … …  
    22882532   END INTERFACE 
    22892533 
     2534# if defined key_mpp_rep1 
     2535   INTERFACE mpp_allgatherv 
     2536      MODULE PROCEDURE mpp_allgatherv_real, mpp_allgatherv_int 
     2537   END INTERFACE 
     2538# endif 
     2539 
    22902540 
    22912541   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
    … …  
    23252575   END SUBROUTINE mpp_sum_ai 
    23262576 
     2577   SUBROUTINE mpp_sum_ac( yarr, kdim, kcom )      ! Dummy routine 
     2578      COMPLEX, DIMENSION(:) :: yarr 
     2579      INTEGER               :: kdim 
     2580      INTEGER, OPTIONAL     :: kcom  
     2581      WRITE(*,*) 'mpp_sum_ac: You should not have seen this print! error?', kdim, yarr(1), kcom 
     2582   END SUBROUTINE mpp_sum_ac 
     2583 
    23272584   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine 
    23282585      REAL                  :: psca 
    … …  
    23302587      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 
    23312588   END SUBROUTINE mpp_sum_s 
    2332  
     2589  
    23332590   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine 
    23342591      integer               :: kint 
    2335       INTEGER, OPTIONAL     :: kcom  
     2592      INTEGER, OPTIONAL     :: kcom 
    23362593      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 
    23372594   END SUBROUTINE mpp_sum_i 
     2595 
     2596   SUBROUTINE mpp_sum_c( ysca, kcom )            ! Dummy routine 
     2597      COMPLEX               :: ysca 
     2598      INTEGER, OPTIONAL     :: kcom  
     2599      WRITE(*,*) 'mpp_sum_c: You should not have seen this print! error?', ysca, kcom 
     2600   END SUBROUTINE mpp_sum_c 
    23382601 
    23392602   SUBROUTINE mppmax_a_real( parr, kdim, kcom ) 
    … …  
    24592722   END SUBROUTINE mpp_comm_free 
    24602723 
     2724# if defined key_mpp_rep1  
     2725   SUBROUTINE mpp_allgatherv_real( pvalsin, knoin, pvalsout, ksizeout, & 
     2726      &                            knoout, kstartout ) 
     2727      INTEGER, INTENT(IN) :: & 
     2728         & knoin,     & 
     2729         & ksizeout 
     2730      REAL(wp), DIMENSION(knoin), INTENT(IN) :: & 
     2731         & pvalsin 
     2732      REAL(wp), DIMENSION(ksizeout), INTENT(OUT) :: & 
     2733         & pvalsout 
     2734      INTEGER, DIMENSION(jpnij), INTENT(OUT) :: & 
     2735         & kstartout, & 
     2736         & knoout 
     2737      pvalsout(1:knoin) = pvalsin(1:knoin) 
     2738      kstartout(1) = 0 
     2739      knoout(1) = knoin           
     2740   END SUBROUTINE mpp_allgatherv_real 
     2741 
     2742   SUBROUTINE mpp_allgatherv_int( kvalsin, knoin, kvalsout, ksizeout, & 
     2743      &                               knoout, kstartout ) 
     2744      INTEGER, INTENT(IN) :: & 
     2745         & knoin,     & 
     2746         & ksizeout 
     2747      INTEGER, DIMENSION(knoin), INTENT(IN) :: & 
     2748         & kvalsin 
     2749      INTEGER, DIMENSION(ksizeout), INTENT(OUT) :: & 
     2750         & kvalsout 
     2751      INTEGER, DIMENSION(jpnij), INTENT(OUT) :: & 
     2752         & kstartout, & 
     2753         & knoout 
     2754       
     2755      kvalsout(1:knoin) = kvalsin(1:knoin) 
     2756      kstartout(1) = 0 
     2757      knoout(1) = knoin             
     2758   END SUBROUTINE mpp_allgatherv_int 
     2759# endif 
     2760 
    24612761#endif 
    24622762   !!---------------------------------------------------------------------- 

  • branches/DEV_1879_mpp_rep/NEMO/OPA_SRC/opa.F90

    r1793 r1920  
    156156      CALL opa_closefile 
    157157#if defined key_oasis3 || defined key_oasis4 
    158       IF( Agrif_Root() ) THEN 
    159          CALL cpl_prism_finalize           ! end coupling and mpp communications with OASIS 
    160      ENDIF  
     158      CALL cpl_prism_finalize           ! end coupling and mpp communications with OASIS 
    161159#else 
    162160      IF( lk_mpp )   CALL mppstop       ! end mpp communications 
    … …  
    180178      !! 
    181179      NAMELIST/namctl/ ln_ctl  , nn_print, nn_ictls, nn_ictle,   & 
    182          &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle, nn_bench, nn_bit_cmp 
     180         &             nn_isplt, nn_jsplt, nn_jctls, nn_jctle, nn_bench 
    183181      !!---------------------------------------------------------------------- 
    184182      ! 
    … …  
    193191#if defined key_iomput 
    194192# if defined key_oasis3 || defined key_oasis4 
    195       IF( Agrif_Root() ) THEN 
    196          CALL cpl_prism_init( ilocal_comm )      ! nemo local communicator given by oasis 
    197          CALL init_ioclient()                    ! io_server will get its communicators (if needed) from oasis (we don't see it) 
    198       ENDIF 
     193      CALL cpl_prism_init( ilocal_comm )      ! nemo local communicator given by oasis 
     194      CALL init_ioclient()                    ! io_server will get its communicators (if needed) from oasis (we don't see it) 
    199195# else 
    200       IF( Agrif_Root() ) THEN 
    201          CALL init_ioclient( ilocal_comm )       ! nemo local communicator (used or not) given by the io_server 
    202       ENDIF 
     196      CALL init_ioclient( ilocal_comm )       ! nemo local communicator (used or not) given by the io_server 
    203197# endif 
    204198      narea = mynode( cltxt, ilocal_comm )    ! Nodes selection 
    … …  
    206200#else 
    207201# if defined key_oasis3 || defined key_oasis4 
    208       IF( Agrif_Root() ) THEN 
    209          CALL cpl_prism_init( ilocal_comm )      ! nemo local communicator given by oasis 
    210       ENDIF 
     202      CALL cpl_prism_init( ilocal_comm )      ! nemo local communicator given by oasis 
    211203      narea = mynode( cltxt, ilocal_comm )    ! Nodes selection (control print return in cltxt) 
    212204# else 
    … …  
    312304         WRITE(numout,*) '      number of proc. following j     nn_jsplt   = ', nn_jsplt 
    313305         WRITE(numout,*) '      benchmark parameter (0/1)       nn_bench   = ', nn_bench 
    314          WRITE(numout,*) '      bit comparison mode (0/1)       nn_bit_cmp = ', nn_bit_cmp 
    315306      ENDIF 
    316307 
    … …  
    323314      jsplt     = nn_jsplt 
    324315      nbench    = nn_bench 
    325       nbit_cmp  = nn_bit_cmp 
    326316 
    327317      !                           ! Parameter control 
    … …  
    372362      ENDIF 
    373363 
    374       IF( nbit_cmp == 1 )   THEN          ! Bit compare 
    375          CALL ctl_warn( ' Bit comparison enabled. Single and multiple processor results must bit compare', & 
    376               &         ' WARNING: RESULTS ARE NOT PHYSICAL.' ) 
    377       ENDIF 
    378  
    379364      REWIND( numnam )              ! Read Namelist namdyn_hpg : ln_dynhpg_imp must be read at the initialisation phase 
    380365      READ  ( numnam, namdyn_hpg ) 
Note: See TracChangeset for help on using the changeset viewer.