Changeset 1324


Ignore:
Timestamp:
2009-02-20T11:00:03+01:00 (12 years ago)
Author:
cetlod
Message:

update IOM and lib_mpp modules, see ticket:348

Location:
trunk/NEMO/OFF_SRC
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • trunk/NEMO/OFF_SRC/IOM/in_out_manager.F90

    r1312 r1324  
    55   !!                 turbulent closure parameterization 
    66   !!===================================================================== 
    7    !! History :   8.5  !  02-06  (G. Madec)  original code 
    8    !!             9.0  !  06-07  (S. Masson)  iom, add ctl_stop, ctl_warn 
     7   !! History :   1.0  !  2002-06  (G. Madec)  original code 
     8   !!             2.0  !  2006-07  (S. Masson)  iom, add ctl_stop, ctl_warn 
     9   !!             3.0  !  2008-06  (G. Madec)  add ctmp4 to ctmp10 
    910   !!---------------------------------------------------------------------- 
    1011 
     
    1213   !!   ctl_stop   : update momentum and tracer Kz from a tke scheme 
    1314   !!   ctl_warn   : initialization, namelist read, and parameters control 
     15   !!   getunit    : give the index of an unused logical unit 
    1416   !!---------------------------------------------------------------------- 
    15    USE par_kind 
    16    USE par_oce 
    17    USE lib_print         ! formated print library 
     17   USE par_kind        ! kind definition 
     18   USE par_oce         ! ocean parameter 
     19   USE lib_print       ! formated print library 
    1820 
    1921   IMPLICIT NONE 
     
    2325   !!                   namrun namelist parameters 
    2426   !!---------------------------------------------------------------------- 
    25    CHARACTER (len=16) ::   cexper     = "exp0"    !: experiment name used for output filename 
    26    LOGICAL            ::   ln_rstart  = .FALSE.   !: start from (F) rest or (T) a restart file 
    27    INTEGER            ::   no         = 0         !: job number 
    28    INTEGER            ::   nrstdt     = 0         !: control of the time step (0, 1 or 2) 
    29    INTEGER            ::   nn_rstssh  = 0         !: hand made initilization of ssh or not (1/0) 
    30    INTEGER            ::   nit000     = 1         !: index of the first time step 
    31    INTEGER            ::   nitend     = 10        !: index of the last time step 
    32    INTEGER            ::   ndate0     = 961115    !: initial calendar date aammjj 
    33    INTEGER            ::   nleapy     = 0         !: Leap year calendar flag (0/1 or 30) 
    34    INTEGER            ::   ninist     = 0         !: initial state output flag (0/1) 
    35    LOGICAL            ::   ln_dimgnnn = .FALSE.   !: type of dimgout. (F): 1 file for all proc 
    36                                                   !:                  (T): 1 file per proc 
    37    LOGICAL            ::   ln_mskland = .FALSE.   !: mask land points in NetCDF outputs (costly: + ~15%) 
     27   CHARACTER(len=16)  ::   cexper        = "exp0"      !: experiment name used for output filename 
     28   CHARACTER(len=32)  ::   cn_ocerst_in  = "restart"   !: suffix of ocean restart name (input) 
     29   CHARACTER(len=32)  ::   cn_ocerst_out = "restart"   !: suffix of ocean restart name (output) 
     30   LOGICAL            ::   ln_rstart     = .FALSE.     !: start from (F) rest or (T) a restart file 
     31   INTEGER            ::   no            = 0           !: job number 
     32   INTEGER            ::   nrstdt        = 0           !: control of the time step (0, 1 or 2) 
     33   INTEGER            ::   nn_rstssh     = 0           !: hand made initilization of ssh or not (1/0) 
     34   INTEGER            ::   nit000        = 1           !: index of the first time step 
     35   INTEGER            ::   nitend        = 10          !: index of the last time step 
     36   INTEGER            ::   ndate0        = 961115      !: initial calendar date aammjj 
     37   INTEGER            ::   nleapy        = 0           !: Leap year calendar flag (0/1 or 30) 
     38   INTEGER            ::   ninist        = 0           !: initial state output flag (0/1) 
     39   LOGICAL            ::   ln_dimgnnn    = .FALSE.     !: type of dimgout. (F): 1 file for all proc 
     40                                                       !:                  (T): 1 file per proc 
     41   LOGICAL            ::   ln_mskland    = .FALSE.     !: mask land points in NetCDF outputs (costly: + ~15%) 
    3842   !!---------------------------------------------------------------------- 
    3943   !! was in restart but moved here because of the OFF line... better solution should be found... 
    4044   !!---------------------------------------------------------------------- 
    4145   INTEGER            ::   nitrst                 !: time step at which restart file should be written 
     46#if defined key_zdftke2 
     47   INTEGER            ::   nitrst_tke2            !: time step at which restart file should be written 
     48#endif 
    4249   !!---------------------------------------------------------------------- 
    4350   !!                    output monitoring 
     
    7885   INTEGER            ::   nstop = 0                !: error flag (=number of reason for a premature stop run) 
    7986   INTEGER            ::   nwarn = 0                !: warning flag (=number of warning found during the run) 
    80    CHARACTER(len=200) ::   ctmp1, ctmp2, ctmp3      !: temporary character 
     87   CHARACTER(len=200) ::   ctmp1, ctmp2, ctmp3      !: temporary characters 1 to 3 
     88   CHARACTER(len=200) ::   ctmp4, ctmp5, ctmp6      !: temporary characters 4 to 6 
     89   CHARACTER(len=200) ::   ctmp7, ctmp8, ctmp9      !: temporary characters 7 to 9 
     90   CHARACTER(len=200) ::   ctmp10                   !: temporary character 10 
    8191   CHARACTER (len=64) ::   cform_err = "(/,' ===>>> : E R R O R',     /,'         ===========',/)"       !: 
    8292   CHARACTER (len=64) ::   cform_war = "(/,' ===>>> : W A R N I N G', /,'         ===============',/)"   !: 
     
    8494   LOGICAL            ::   lsp_area = .TRUE.        !: to make a control print over a specific area 
    8595   !!---------------------------------------------------------------------- 
    86    !!  OPA 9.0 , LOCEAN-IPSL (2005)  
    87    !! $Id$  
     96   !! NEMO/OPA 3.0 , LOCEAN-IPSL (2008)  
     97   !! $Id$ 
    8898   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) 
    8999   !!---------------------------------------------------------------------- 
     
    93103   SUBROUTINE ctl_stop( cd1, cd2, cd3, cd4, cd5,   & 
    94104      &                 cd6, cd7, cd8, cd9, cd10 ) 
    95       !!----------------------------------------------------------------------- 
     105      !!---------------------------------------------------------------------- 
    96106      !!                  ***  ROUTINE  stop_opa  *** 
    97107      !! 
    98       !! ** Purpose : ??? blah blah.... 
    99       !!----------------------------------------------------------------------- 
     108      !! ** Purpose :   print in ocean.outpput file a error message and  
     109      !!                increment the error number (nstop) by one. 
     110      !!---------------------------------------------------------------------- 
    100111      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5 
    101112      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10 
    102       !!----------------------------------------------------------------------- 
     113      !!---------------------------------------------------------------------- 
    103114      ! 
    104115      nstop = nstop + 1  
     
    123134   SUBROUTINE ctl_warn( cd1, cd2, cd3, cd4, cd5,   & 
    124135      &                 cd6, cd7, cd8, cd9, cd10 ) 
    125       !!----------------------------------------------------------------------- 
     136      !!---------------------------------------------------------------------- 
    126137      !!                  ***  ROUTINE  stop_warn  *** 
    127138      !! 
    128       !! ** Purpose : ???  blah blah.... 
    129       !!----------------------------------------------------------------------- 
     139      !! ** Purpose :   print in ocean.outpput file a error message and  
     140      !!                increment the warning number (nwarn) by one. 
     141      !!---------------------------------------------------------------------- 
    130142      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5 
    131143      CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10 
    132       !!----------------------------------------------------------------------- 
     144      !!---------------------------------------------------------------------- 
    133145      !  
    134146      nwarn = nwarn + 1  
     
    152164 
    153165   FUNCTION getunit() 
    154      !!----------------------------------------------------------------------- 
    155      !!                  ***  FUNCTION  getunit  *** 
    156      !! 
    157      !! ** Purpose : ???  blah blah.... 
    158      !!----------------------------------------------------------------------- 
    159      INTEGER :: getunit 
    160      LOGICAL :: llopn  
    161      !--------------------------------------------------------------------- 
    162      getunit = 15   ! choose a unit that is big enough then it is 
    163                     !  not already used in OPA 
    164      llopn = .TRUE. 
    165      DO WHILE( (getunit < 998) .AND. llopn ) 
    166         getunit = getunit + 1 
    167         INQUIRE( unit = getunit, opened = llopn ) 
    168      END DO 
    169      IF( (getunit == 999) .AND. llopn ) THEN 
    170         CALL ctl_stop( 'getunit: All logical units until 999 are used...' ) 
    171         getunit = -1 
    172      ENDIF 
    173  
     166      !!---------------------------------------------------------------------- 
     167      !!                  ***  FUNCTION  getunit  *** 
     168      !! 
     169      !! ** Purpose :   return the index of an unused logical unit 
     170      !!---------------------------------------------------------------------- 
     171      INTEGER :: getunit 
     172      LOGICAL :: llopn  
     173      !!---------------------------------------------------------------------- 
     174      ! 
     175      getunit = 15   ! choose a unit that is big enough then it is not already used in NEMO 
     176      llopn = .TRUE. 
     177      DO WHILE( (getunit < 998) .AND. llopn ) 
     178         getunit = getunit + 1 
     179         INQUIRE( unit = getunit, opened = llopn ) 
     180      END DO 
     181      IF( (getunit == 999) .AND. llopn ) THEN 
     182         CALL ctl_stop( 'getunit: All logical units until 999 are used...' ) 
     183         getunit = -1 
     184      ENDIF 
     185      ! 
    174186   END FUNCTION getunit 
    175187 
  • trunk/NEMO/OFF_SRC/IOM/iom.F90

    r1152 r1324  
    6969      LOGICAL               ::   llok      ! check the existence  
    7070      LOGICAL               ::   llwrt     ! local definition of ldwrt 
     71      LOGICAL               ::   llnoov    ! local definition to read overlap 
    7172      LOGICAL               ::   llstop    ! local definition of ldstop 
    7273      INTEGER               ::   iolib     ! library do we use to open the file 
     
    104105      ELSE                         ;   iolib = jpnf90 
    105106      ENDIF 
     107      ! do we read the overlap  
     108      ! ugly patch SM+JMM+RB to overwrite global definition in some cases 
     109#if ! defined key_agrif 
     110      llnoov = (jpni * jpnj ) == jpnij 
     111#endif 
    106112      ! create the file name by added, if needed, TRIM(Agrif_CFixed()) and TRIM(clsuffix) 
    107113      ! ============= 
    108114      clname   = trim(cdname) 
    109115#if defined key_agrif 
    110       if ( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//'_'//TRIM(clname) 
     116      IF ( .NOT. Agrif_Root() ) THEN 
     117         iln    = INDEX(clname,'/')  
     118         cltmpn = clname(1:iln) 
     119         clname = clname(iln+1:LEN_TRIM(clname)) 
     120         clname=TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) 
     121      ENDIF 
    111122#endif     
    112123      ! which suffix should we use? 
     
    149160! JMM + SM: ugly patch before getting the new version of lib_mpp) 
    150161!         idom = jpdom_local_noovlap   ! default definition 
    151          IF( jpni*jpnj == jpnij ) THEN   ;   idom = jpdom_local_noovlap   ! default definition 
    152          ELSE                            ;   idom = jpdom_local_full      ! default definition 
     162         IF( llnoov ) THEN   ;   idom = jpdom_local_noovlap   ! default definition 
     163         ELSE                ;   idom = jpdom_local_full      ! default definition 
    153164         ENDIF 
    154165         IF( PRESENT(kdom) )   idom = kdom 
     
    212223      !! ** Purpose : close an input file, or all files opened by iom 
    213224      !!-------------------------------------------------------------------- 
    214       INTEGER, INTENT(in), OPTIONAL ::   kiomid   ! iom identifier of the file to be closed 
    215       !                                           ! No argument : all the files opened by iom are closed 
     225      INTEGER, INTENT(inout), OPTIONAL ::   kiomid   ! iom identifier of the file to be closed 
     226      !                                              ! return 0 when file is properly closed 
     227      !                                              ! No argument: all files opened by iom are closed 
    216228 
    217229      INTEGER ::   jf         ! dummy loop indices 
     
    239251                  CALL ctl_stop( TRIM(clinfo)//' accepted IO library are only jpioipsl, jpnf90 and jprstdimg' ) 
    240252               END SELECT 
    241                iom_file(jf)%nfid       = 0   ! free the id  
     253               iom_file(jf)%nfid       = 0          ! free the id  
     254               IF( PRESENT(kiomid) )   kiomid = 0   ! return 0 as id to specify that the file was closed 
    242255               IF(lwp) WRITE(numout,*) TRIM(clinfo)//' close file: '//TRIM(iom_file(jf)%name)//' ok' 
    243256            ELSEIF( PRESENT(kiomid) ) THEN 
     
    409422      INTEGER , DIMENSION(:)     , INTENT(in   ), OPTIONAL ::   kcount     ! number of points to be read in each axis 
    410423      ! 
     424      LOGICAL                        ::   llnoov      ! local definition to read overlap 
    411425      INTEGER                        ::   jl          ! loop on number of dimension  
    412426      INTEGER                        ::   idom        ! type of domain 
     
    435449      ! local definition of the domain ? 
    436450      idom = kdom 
     451      ! do we read the overlap  
     452      ! ugly patch SM+JMM+RB to overwrite global definition in some cases 
     453#if ! defined key_agrif 
     454      llnoov = (jpni * jpnj ) == jpnij 
     455#endif 
    437456      ! check kcount and kstart optionals parameters... 
    438457      IF( PRESENT(kcount) .AND. (.NOT. PRESENT(kstart)) ) CALL ctl_stop(trim(clinfo), 'kcount present needs kstart present') 
     
    518537! JMM + SM: ugly patch before getting the new version of lib_mpp) 
    519538!                  IF( idom /= jpdom_local_noovlap )   istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 
    520                   IF( jpni*jpnj == jpnij .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 
     539                  IF( llnoov .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) 
    521540                  ! we do not read the overlap and the extra-halos -> from nldi to nlei and from nldj to nlej  
    522541! JMM + SM: ugly patch before getting the new version of lib_mpp) 
    523542!                  icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 
    524                   IF( jpni*jpnj == jpnij ) THEN   ;   icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 
    525                   ELSE                            ;   icnt(1:2) = (/ nlci           , nlcj            /) 
     543                  IF( llnoov ) THEN   ;   icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) 
     544                  ELSE                ;   icnt(1:2) = (/ nlci           , nlcj            /) 
    526545                  ENDIF 
    527546                  IF( PRESENT(pv_r3d) ) THEN 
     
    556575! JMM + SM: ugly patch before getting the new version of lib_mpp) 
    557576!               ishape(1:2) = SHAPE(pv_r2d(nldi:nlei,nldj:nlej  ))   ;   ctmp1 = 'd(nldi:nlei,nldj:nlej)' 
    558                IF( jpni*jpnj == jpnij ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej  )) ; ctmp1='d(nldi:nlei,nldj:nlej)' 
    559                ELSE                          ; ishape(1:2)=SHAPE(pv_r2d(1   :nlci,1   :nlcj  )) ; ctmp1='d(1:nlci,1:nlcj)' 
     577               IF( llnoov ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej  )) ; ctmp1='d(nldi:nlei,nldj:nlej)' 
     578               ELSE              ; ishape(1:2)=SHAPE(pv_r2d(1   :nlci,1   :nlcj  )) ; ctmp1='d(1:nlci,1:nlcj)' 
    560579               ENDIF 
    561580            ENDIF 
     
    563582! JMM + SM: ugly patch before getting the new version of lib_mpp) 
    564583!               ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:))   ;   ctmp1 = 'd(nldi:nlei,nldj:nlej,:)' 
    565                IF( jpni*jpnj == jpnij ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)' 
    566                ELSE                          ; ishape(1:3)=SHAPE(pv_r3d(1   :nlci,1   :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)' 
     584               IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)' 
     585               ELSE              ; ishape(1:3)=SHAPE(pv_r3d(1   :nlci,1   :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)' 
    567586               ENDIF 
    568587            ENDIF 
     
    585604!         ELSE                               ;   ix1 = 1      ;   ix2 = icnt(1)   ;   iy1 = 1      ;   iy2 = icnt(2) 
    586605!         ENDIF 
    587          IF( jpni*jpnj == jpnij ) THEN 
     606         IF( llnoov ) THEN 
    588607            IF( idom /= jpdom_unknown ) THEN   ;   ix1 = nldi   ;   ix2 = nlei      ;   iy1 = nldj   ;   iy2 = nlej 
    589608            ELSE                               ;   ix1 = 1      ;   ix2 = icnt(1)   ;   iy1 = 1      ;   iy2 = icnt(2) 
     
    607626 
    608627         IF( istop == nstop ) THEN   ! no additional errors until this point... 
    609             IF(lwp) WRITE(numout,*) '           read '//TRIM(cdvar)//' in '//TRIM(iom_file(kiomid)%name)//' ok' 
    610              
     628            IF(lwp) WRITE(numout,"(10x,' read ',a,' (rec: ',i4,') in ',a,' ok')") TRIM(cdvar), itime, TRIM(iom_file(kiomid)%name) 
     629           
    611630            !--- overlap areas and extra hallows (mpp) 
    612631            IF(     PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN 
  • trunk/NEMO/OFF_SRC/IOM/iom_def.F90

    r1152 r1324  
    4343   INTEGER, PARAMETER, PUBLIC ::   jp_i1    = 204      !: write INTEGER(1) 
    4444 
    45    INTEGER, PARAMETER, PUBLIC ::   jpmax_files  = 20   !: maximum number of simultaneously opened file 
     45   INTEGER, PARAMETER, PUBLIC ::   jpmax_files  = 50   !: maximum number of simultaneously opened file 
    4646   INTEGER, PARAMETER, PUBLIC ::   jpmax_vars   = 360  !: maximum number of variables in one file 
    4747   INTEGER, PARAMETER, PUBLIC ::   jpmax_dims   =  4   !: maximum number of dimensions for one variable 
  • trunk/NEMO/OFF_SRC/IOM/iom_ioipsl.F90

    r1152 r1324  
    287287      !! ** Purpose : read the time axis cdvar in the file  
    288288      !!-------------------------------------------------------------------- 
    289       INTEGER                         , INTENT(in)           ::   kt       ! ocean time-step 
    290       INTEGER                         , INTENT(in)           ::   kwrite   ! writing time-step 
    291       INTEGER                         , INTENT(in)           ::   kiomid   ! Identifier of the file  
    292       CHARACTER(len=*)                , INTENT(in)           ::   cdvar    ! variable name 
    293       INTEGER                         , INTENT(in)           ::   kvid     ! variable id 
    294       INTEGER                         , INTENT(in), OPTIONAL ::   ktype    ! variable type (default R8) 
    295       REAL(wp)                        , INTENT(in), OPTIONAL ::   pv_r0d   ! written Od field 
    296       REAL(wp), DIMENSION(        jpk), INTENT(in), OPTIONAL ::   pv_r1d   ! written 1d field 
    297       REAL(wp), DIMENSION(jpi,jpj    ), INTENT(in), OPTIONAL ::   pv_r2d   ! written 2d field 
    298       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   pv_r3d   ! written 3d field 
     289      INTEGER                     , INTENT(in)           ::   kt       ! ocean time-step 
     290      INTEGER                     , INTENT(in)           ::   kwrite   ! writing time-step 
     291      INTEGER                     , INTENT(in)           ::   kiomid   ! Identifier of the file  
     292      CHARACTER(len=*)            , INTENT(in)           ::   cdvar    ! variable name 
     293      INTEGER                     , INTENT(in)           ::   kvid     ! variable id 
     294      INTEGER                     , INTENT(in), OPTIONAL ::   ktype    ! variable type (default R8) 
     295      REAL(wp)                    , INTENT(in), OPTIONAL ::   pv_r0d   ! written Od field 
     296      REAL(wp), DIMENSION(      :), INTENT(in), OPTIONAL ::   pv_r1d   ! written 1d field 
     297      REAL(wp), DIMENSION(:, :   ), INTENT(in), OPTIONAL ::   pv_r2d   ! written 2d field 
     298      REAL(wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL ::   pv_r3d   ! written 3d field 
    299299      ! 
    300300      INTEGER               :: idims                ! number of dimension 
  • trunk/NEMO/OFF_SRC/IOM/iom_nf90.F90

    r1152 r1324  
    313313      !! ** Purpose : read the time axis cdvar in the file  
    314314      !!-------------------------------------------------------------------- 
    315       INTEGER                         , INTENT(in)           ::   kt       ! ocean time-step 
    316       INTEGER                         , INTENT(in)           ::   kwrite   ! writing time-step 
    317       INTEGER                         , INTENT(in)           ::   kiomid   ! Identifier of the file  
    318       CHARACTER(len=*)                , INTENT(in)           ::   cdvar    ! variable name 
    319       INTEGER                         , INTENT(in)           ::   kvid     ! variable id 
    320       INTEGER                         , INTENT(in), OPTIONAL ::   ktype    ! variable type (default R8) 
    321       REAL(wp)                        , INTENT(in), OPTIONAL ::   pv_r0d   ! written Od field 
    322       REAL(wp), DIMENSION(        jpk), INTENT(in), OPTIONAL ::   pv_r1d   ! written 1d field 
    323       REAL(wp), DIMENSION(jpi,jpj    ), INTENT(in), OPTIONAL ::   pv_r2d   ! written 2d field 
    324       REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL ::   pv_r3d   ! written 3d field 
     315      INTEGER                     , INTENT(in)           ::   kt       ! ocean time-step 
     316      INTEGER                     , INTENT(in)           ::   kwrite   ! writing time-step 
     317      INTEGER                     , INTENT(in)           ::   kiomid   ! Identifier of the file  
     318      CHARACTER(len=*)            , INTENT(in)           ::   cdvar    ! variable name 
     319      INTEGER                     , INTENT(in)           ::   kvid     ! variable id 
     320      INTEGER                     , INTENT(in), OPTIONAL ::   ktype    ! variable type (default R8) 
     321      REAL(wp)                    , INTENT(in), OPTIONAL ::   pv_r0d   ! written Od field 
     322      REAL(wp), DIMENSION(      :), INTENT(in), OPTIONAL ::   pv_r1d   ! written 1d field 
     323      REAL(wp), DIMENSION(:, :   ), INTENT(in), OPTIONAL ::   pv_r2d   ! written 2d field 
     324      REAL(wp), DIMENSION(:, :, :), INTENT(in), OPTIONAL ::   pv_r3d   ! written 3d field 
    325325      ! 
    326326      INTEGER               :: idims                ! number of dimension 
  • trunk/NEMO/OFF_SRC/lib_mpp.F90

    r1152 r1324  
    2626   !!                mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real 
    2727   !!   mpp_max    : generic interface for : 
    28    !!                mppmax_real, mppmax_a_real 
     28   !!                mppmax_int , mppmax_a_int , mppmax_real, mppmax_a_real 
    2929   !!   mpp_sum    : generic interface for : 
    3030   !!                mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real 
     
    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)  
    49    !! $Id$  
     50   !! $Id$ 
    5051   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    5152   !!--------------------------------------------------------------------- 
     
    5960   PUBLIC  mynode, mpparent, mpp_isl, mpp_min, mpp_max, mpp_sum,  mpp_lbc_north 
    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 
    61    PUBLIC  mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync 
     62   PUBLIC  mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync, mpp_ini_ice, mpp_comm_free 
     63#if defined key_oasis3 || defined key_oasis4 
     64   PUBLIC  mppsize, mpprank 
     65#endif 
    6266 
    6367   !! * Interfaces 
     
    7377   END INTERFACE 
    7478   INTERFACE mpp_max 
    75       MODULE PROCEDURE mppmax_a_real, mppmax_real 
     79      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 
    7680   END INTERFACE 
    7781   INTERFACE mpp_sum 
     
    9498   !! The processor number is a required power of two : 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,... 
    9599   INTEGER, PARAMETER ::   & 
    96       nprocmax = 2**10,    &  ! maximun dimension 
    97       ndim_mpp = jpnij        ! dimension for this simulation 
     100      nprocmax = 2**10     ! maximun dimension 
    98101 
    99102#if defined key_mpp_mpi 
     
    106109 
    107110   INTEGER ::   & 
    108       size,     &  ! number of process 
    109       rank         ! process number  [ 0 - size-1 ] 
    110  
     111      mppsize,  &  ! number of process 
     112      mpprank,  &  ! process number  [ 0 - size-1 ] 
     113      mpi_comm_opa ! opa local communicator 
     114 
     115   ! variables used in case of sea-ice 
     116   INTEGER, PUBLIC ::  &       ! 
     117      ngrp_ice,        &       ! group ID for the ice processors (to compute rheology) 
     118      ncomm_ice,       &       ! communicator made by the processors with sea-ice 
     119      ndim_rank_ice,   &       ! number of 'ice' processors 
     120      n_ice_root               ! number (in the comm_ice) of proc 0 in the ice comm 
     121   INTEGER, DIMENSION(:), ALLOCATABLE ::   & 
     122      nrank_ice            ! dimension ndim_rank_north, number of the procs belonging to ncomm_north 
    111123   ! variables used in case of north fold condition in mpp_mpi with jpni > 1 
    112124   INTEGER ::      &       ! 
     
    117129      njmppmax             ! value of njmpp for the processors of the northern line 
    118130   INTEGER ::      &       ! 
    119       north_root           ! number (in the comm_world) of proc 0 in the northern comm 
     131      north_root           ! number (in the comm_opa) of proc 0 in the northern comm 
    120132   INTEGER, DIMENSION(:), ALLOCATABLE ::   & 
    121133      nrank_north          ! dimension ndim_rank_north, number of the procs belonging to ncomm_north 
     
    124136   LOGICAL  ::           & 
    125137      l_isend = .FALSE.    ! isend use indicator (T if c_mpi_send='I') 
    126  
     138   INTEGER ::            & ! size of the buffer in case of mpi_bsend  
     139      nn_buffer = 0 
     140   REAL(kind=wp), ALLOCATABLE, DIMENSION(:) :: tampon  ! buffer in case of bsend 
    127141 
    128142#elif defined key_mpp_shmem 
     
    266280   !!---------------------------------------------------------------------- 
    267281   !!  OPA 9.0 , LOCEAN-IPSL (2005)  
    268    !! $Id$  
     282   !! $Id$ 
    269283   !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt  
    270284   !!--------------------------------------------------------------------- 
     
    272286CONTAINS 
    273287 
    274    FUNCTION mynode() 
     288   FUNCTION mynode(localComm) 
    275289      !!---------------------------------------------------------------------- 
    276290      !!                  ***  routine mynode  *** 
     
    281295#if defined key_mpp_mpi 
    282296      !! * Local variables   (MPI version) 
    283       INTEGER ::   mynode, ierr 
    284       NAMELIST/nammpp/ c_mpi_send 
     297      INTEGER ::   mynode, ierr, code 
     298      LOGICAL ::   mpi_was_called 
     299      INTEGER,OPTIONAL ::   localComm 
     300      NAMELIST/nammpp/ c_mpi_send, nn_buffer 
    285301      !!---------------------------------------------------------------------- 
    286302 
     
    300316      IF( Agrif_Root() ) THEN 
    301317#endif 
     318!!bug RB : should be clean to use Agrif in coupled mode 
     319#if ! defined key_agrif 
     320         CALL mpi_initialized ( mpi_was_called, code ) 
     321         IF( code /= MPI_SUCCESS ) THEN 
     322            CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' ) 
     323            CALL mpi_abort( mpi_comm_world, code, ierr ) 
     324         ENDIF 
     325 
     326         IF( PRESENT(localComm) .and. mpi_was_called ) THEN 
     327            mpi_comm_opa = localComm 
     328            SELECT CASE ( c_mpi_send ) 
     329            CASE ( 'S' )                ! Standard mpi send (blocking) 
     330               WRITE(numout,*) '           Standard blocking mpi send (send)' 
     331            CASE ( 'B' )                ! Buffer mpi send (blocking) 
     332               WRITE(numout,*) '           Buffer blocking mpi send (bsend)' 
     333               CALL mpi_init_opa( ierr )  
     334            CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
     335               WRITE(numout,*) '           Immediate non-blocking send (isend)' 
     336               l_isend = .TRUE. 
     337            CASE DEFAULT 
     338               WRITE(numout,cform_err) 
     339               WRITE(numout,*) '           bad value for c_mpi_send = ', c_mpi_send 
     340               nstop = nstop + 1 
     341            END SELECT 
     342         ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 
     343            WRITE(numout,*) ' lib_mpp: You cannot provide a local communicator ' 
     344            WRITE(numout,*) '          without calling MPI_Init before ! ' 
     345         ELSE 
     346#endif 
     347            SELECT CASE ( c_mpi_send ) 
     348            CASE ( 'S' )                ! Standard mpi send (blocking) 
     349               WRITE(numout,*) '           Standard blocking mpi send (send)' 
     350               CALL mpi_init( ierr ) 
     351            CASE ( 'B' )                ! Buffer mpi send (blocking) 
     352               WRITE(numout,*) '           Buffer blocking mpi send (bsend)' 
     353               CALL mpi_init_opa( ierr ) 
     354            CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
     355               WRITE(numout,*) '           Immediate non-blocking send (isend)' 
     356               l_isend = .TRUE. 
     357               CALL mpi_init( ierr ) 
     358            CASE DEFAULT 
     359               WRITE(ctmp1,*) '           bad value for c_mpi_send = ', c_mpi_send 
     360               CALL ctl_stop( ctmp1 ) 
     361            END SELECT 
     362 
     363#if ! defined key_agrif 
     364            CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 
     365            IF( code /= MPI_SUCCESS ) THEN 
     366               CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' ) 
     367               CALL mpi_abort( mpi_comm_world, code, ierr ) 
     368            ENDIF 
     369            ! 
     370         ENDIF 
     371#endif 
     372#if defined key_agrif 
     373      ELSE 
    302374         SELECT CASE ( c_mpi_send ) 
    303375         CASE ( 'S' )                ! Standard mpi send (blocking) 
    304376            WRITE(numout,*) '           Standard blocking mpi send (send)' 
    305             CALL mpi_init( ierr ) 
    306377         CASE ( 'B' )                ! Buffer mpi send (blocking) 
    307378            WRITE(numout,*) '           Buffer blocking mpi send (bsend)' 
    308             CALL mpi_init_opa( ierr ) 
    309379         CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    310380            WRITE(numout,*) '           Immediate non-blocking send (isend)' 
    311381            l_isend = .TRUE. 
    312             CALL mpi_init( ierr ) 
    313382         CASE DEFAULT 
    314             WRITE(ctmp1,*) '           bad value for c_mpi_send = ', c_mpi_send 
    315             CALL ctl_stop( ctmp1 ) 
     383            WRITE(numout,cform_err) 
     384            WRITE(numout,*) '           bad value for c_mpi_send = ', c_mpi_send 
     385            nstop = nstop + 1 
    316386         END SELECT 
    317  
    318 #if defined key_agrif 
    319387      ENDIF 
    320 #endif 
    321  
    322       CALL mpi_comm_rank( mpi_comm_world, rank, ierr ) 
    323       CALL mpi_comm_size( mpi_comm_world, size, ierr ) 
    324       mynode = rank 
     388 
     389      mpi_comm_opa = mpi_comm_world 
     390#endif 
     391        CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 
     392        CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) 
     393      mynode = mpprank 
    325394#else 
    326395      !! * Local variables   (SHMEM version) 
     
    356425            npvm_tids(0) = npvm_mytid 
    357426            npvm_me = 0 
    358             IF( ndim_mpp > nprocmax ) THEN 
     427            IF( jpnij > nprocmax ) THEN 
    359428               WRITE(ctmp1,*) 'npvm_mytid=', npvm_mytid, ' too great' 
    360429               CALL ctl_stop( ctmp1 ) 
    361430 
    362431            ELSE 
    363                npvm_nproc = ndim_mpp 
     432               npvm_nproc = jpnij 
    364433            ENDIF 
    365434 
     
    476545         ENDIF 
    477546         !          --- END receive dimension --- 
    478          IF( ndim_mpp > nprocmax ) THEN 
     547         IF( jpnij > nprocmax ) THEN 
    479548            WRITE(ctmp1,*) 'mytid=',nt3d_mytid,' too great' 
    480549            CALL ctl_stop( ctmp1 ) 
    481550         ELSE 
    482             nt3d_nproc =  ndim_mpp 
     551            nt3d_nproc =  jpnij 
    483552         ENDIF 
    484553         IF( mpparent_print /= 0 ) THEN 
     
    538607#endif 
    539608 
    540    SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp ) 
     609   SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 
    541610      !!---------------------------------------------------------------------- 
    542611      !!                  ***  routine mpp_lnk_3d  *** 
     
    573642      CHARACTER(len=3), INTENT( in ), OPTIONAL ::    & 
    574643         cd_mpp        ! fill the overlap area only  
     644      REAL(wp)        , INTENT(in   ), OPTIONAL           ::   pval      ! background value (used at closed boundaries) 
    575645 
    576646      !! * Local variables 
    577       INTEGER ::   ji, jk, jl   ! dummy loop indices 
     647      INTEGER ::   ji, jj, jk, jl                        ! dummy loop indices 
    578648      INTEGER ::   imigr, iihom, ijhom, iloc, ijt, iju   ! temporary integers 
    579649      INTEGER ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend 
    580650      INTEGER ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend 
     651      REAL(wp) ::   zland 
    581652      !!---------------------------------------------------------------------- 
    582653 
     
    584655      ! ------------------------------ 
    585656 
     657      IF( PRESENT( pval ) ) THEN      ! set land value (zero by default) 
     658         zland = pval 
     659      ELSE 
     660         zland = 0.e0 
     661      ENDIF 
     662 
    586663      IF( PRESENT( cd_mpp ) ) THEN 
    587          ! only fill extra allows with 1. 
    588          ptab(     1:nlci, nlcj+1:jpj, :) = 1.e0 
    589          ptab(nlci+1:jpi ,       :   , :) = 1.e0 
     664         DO jj = nlcj+1, jpj   ! only fill extra allows last line 
     665            ptab(1:nlci, jj, :) = ptab(1:nlci, nlej, :) 
     666         END DO 
     667         DO ji = nlci+1, jpi   ! only fill extra allows last column 
     668            ptab(ji    , : , :) = ptab(nlei  , :   , :) 
     669         END DO 
    590670      ELSE       
    591671 
     
    600680            SELECT CASE ( cd_type ) 
    601681            CASE ( 'T', 'U', 'V', 'W' ) 
    602                ptab(     1       :jpreci,:,:) = 0.e0 
    603                ptab(nlci-jpreci+1:jpi   ,:,:) = 0.e0 
     682               ptab(     1       :jpreci,:,:) = zland 
     683               ptab(nlci-jpreci+1:jpi   ,:,:) = zland 
    604684            CASE ( 'F' ) 
    605                ptab(nlci-jpreci+1:jpi   ,:,:) = 0.e0 
     685               ptab(nlci-jpreci+1:jpi   ,:,:) = zland 
    606686            END SELECT  
    607687         ENDIF 
     
    611691         SELECT CASE ( cd_type ) 
    612692         CASE ( 'T', 'U', 'V', 'W' ) 
    613             ptab(:,     1       :jprecj,:) = 0.e0 
    614             ptab(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
     693            ptab(:,     1       :jprecj,:) = zland 
     694            ptab(:,nlcj-jprecj+1:jpj   ,:) = zland 
    615695         CASE ( 'F' ) 
    616             ptab(:,nlcj-jprecj+1:jpj   ,:) = 0.e0 
     696            ptab(:,nlcj-jprecj+1:jpj   ,:) = zland 
    617697         END SELECT 
    618698      
     
    791871 
    792872      CASE ( 1 )  ! only one proc along I, no mpp exchange 
    793  
     873        
    794874         SELECT CASE ( npolj ) 
    795875   
     
    810890                  END DO 
    811891               END DO 
    812            
     892 
    813893            CASE ( 'U' ) 
    814894               DO jk = 1, jpk 
     
    9881068 
    9891069 
    990    SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp ) 
     1070   SUBROUTINE mpp_lnk_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 
    9911071      !!---------------------------------------------------------------------- 
    9921072      !!                  ***  routine mpp_lnk_2d  *** 
     
    10221102      CHARACTER(len=3), INTENT( in ), OPTIONAL ::    & 
    10231103         cd_mpp        ! fill the overlap area only  
     1104      REAL(wp)        , INTENT(in   ), OPTIONAL           ::   pval      ! background value (used at closed boundaries) 
    10241105 
    10251106      !! * Local variables 
     
    10301111      INTEGER  ::   ml_req1, ml_req2, ml_err     ! for key_mpi_isend 
    10311112      INTEGER  ::   ml_stat(MPI_STATUS_SIZE)     ! for key_mpi_isend 
     1113      REAL(wp) ::   zland 
    10321114      !!---------------------------------------------------------------------- 
     1115 
     1116      IF( PRESENT( pval ) ) THEN      ! set land value (zero by default) 
     1117         zland = pval 
     1118      ELSE 
     1119         zland = 0.e0 
     1120      ENDIF 
    10331121 
    10341122      ! 1. standard boundary treatment 
    10351123      ! ------------------------------ 
    10361124      IF (PRESENT(cd_mpp)) THEN 
    1037          ! only fill extra allows with 1. 
    1038          pt2d(     1:nlci, nlcj+1:jpj) = 1.e0 
    1039          pt2d(nlci+1:jpi ,       :   ) = 1.e0 
    1040       
     1125         DO jj = nlcj+1, jpj   ! only fill extra allows last line 
     1126            pt2d(1:nlci, jj) = pt2d(1:nlci, nlej) 
     1127         END DO 
     1128         DO ji = nlci+1, jpi   ! only fill extra allows last column 
     1129            pt2d(ji    , : ) = pt2d(nlei  , :   ) 
     1130         END DO      
    10411131      ELSE       
    10421132 
     
    10511141            SELECT CASE ( cd_type ) 
    10521142            CASE ( 'T', 'U', 'V', 'W' , 'I' ) 
    1053                pt2d(     1       :jpreci,:) = 0.e0 
    1054                pt2d(nlci-jpreci+1:jpi   ,:) = 0.e0 
     1143               pt2d(     1       :jpreci,:) = zland 
     1144               pt2d(nlci-jpreci+1:jpi   ,:) = zland 
    10551145            CASE ( 'F' ) 
    1056                pt2d(nlci-jpreci+1:jpi   ,:) = 0.e0 
     1146               pt2d(nlci-jpreci+1:jpi   ,:) = zland 
    10571147            END SELECT 
    10581148         ENDIF 
     
    10621152         SELECT CASE ( cd_type ) 
    10631153         CASE ( 'T', 'U', 'V', 'W' , 'I' ) 
    1064             pt2d(:,     1       :jprecj) = 0.e0 
    1065             pt2d(:,nlcj-jprecj+1:jpj   ) = 0.e0 
     1154            pt2d(:,     1       :jprecj) = zland 
     1155            pt2d(:,nlcj-jprecj+1:jpj   ) = zland 
    10661156         CASE ( 'F' ) 
    1067             pt2d(:,nlcj-jprecj+1:jpj   ) = 0.e0 
     1157            pt2d(:,nlcj-jprecj+1:jpj   ) = zland 
    10681158         END SELECT 
    10691159 
     
    13301420   
    13311421            CASE ( 'I' )                                  ! ice U-V point 
    1332                pt2d( 2 ,nlcj) = 0.e0 
     1422               pt2d( 2 ,nlcj) = zland 
    13331423               DO ji = 2 , nlci-1 
    13341424                  ijt = iloc - ji + 2 
     
    27802870      CASE ( 'S' )                ! Standard mpi send (blocking) 
    27812871         CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest, ktyp,   & 
    2782             &                          mpi_comm_world, iflag ) 
     2872            &                          mpi_comm_opa, iflag ) 
    27832873      CASE ( 'B' )                ! Buffer mpi send (blocking) 
    27842874         CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest, ktyp,   & 
    2785             &                          mpi_comm_world, iflag ) 
     2875            &                          mpi_comm_opa, iflag ) 
    27862876      CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    27872877         ! Be carefull, one more argument here : the mpi request identifier.. 
    27882878         CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest, ktyp,   & 
    2789             &                          mpi_comm_world, md_req, iflag ) 
     2879            &                          mpi_comm_opa, md_req, iflag ) 
    27902880      END SELECT 
    27912881#endif 
     
    28152905 
    28162906      CALL mpi_recv( pmess, kbytes, mpi_double_precision, mpi_any_source, ktyp,   & 
    2817          &                          mpi_comm_world, istatus, iflag ) 
     2907         &                          mpi_comm_opa, istatus, iflag ) 
    28182908#endif 
    28192909 
     
    28492939      itaille=jpi*jpj 
    28502940      CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille,   & 
    2851          &                            mpi_double_precision, kp , mpi_comm_world, ierror )  
     2941         &                            mpi_double_precision, kp , mpi_comm_opa, ierror )  
    28522942#endif 
    28532943 
     
    28832973 
    28842974      CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille,   & 
    2885          &                            mpi_double_precision, kp, mpi_comm_world, ierror ) 
     2975         &                            mpi_double_precision, kp, mpi_comm_opa, ierror ) 
    28862976#endif 
    28872977 
     
    29443034      CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror ) 
    29453035      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer   & 
    2946            , mpi_isl, mpi_comm_world, ierror ) 
     3036           , mpi_isl, mpi_comm_opa, ierror ) 
    29473037      ktab(:) = iwork(:) 
    29483038#endif 
     
    29983088      CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror) 
    29993089      CALL mpi_allreduce(ktab, iwork, 1,mpi_integer   & 
    3000            ,mpi_isl,mpi_comm_world,ierror) 
     3090           ,mpi_isl,mpi_comm_opa,ierror) 
    30013091      ktab = iwork 
    30023092#endif 
     
    30053095 
    30063096 
    3007    SUBROUTINE mppmin_a_int( ktab, kdim ) 
     3097   SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 
     3098      !!---------------------------------------------------------------------- 
     3099      !!                  ***  routine mppmax_a_int  *** 
     3100      !!  
     3101      !! ** Purpose :   Find maximum value in an integer layout array 
     3102      !! 
     3103      !!---------------------------------------------------------------------- 
     3104      !! * Arguments 
     3105      INTEGER , INTENT( in  )                  ::   kdim        ! size of array 
     3106      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array 
     3107      INTEGER , INTENT(in)   , OPTIONAL        ::   kcom   
     3108   
     3109#if defined key_mpp_shmem 
     3110      !! * Local declarations    (SHMEM version) 
     3111      INTEGER :: ji 
     3112      INTEGER, SAVE :: ibool=0 
     3113   
     3114      IF( kdim > jpmppsum ) CALL ctl_stop( 'mppmax_a_int routine : kdim is too big', & 
     3115           &                               'change jpmppsum dimension in mpp.h' ) 
     3116   
     3117      DO ji = 1, kdim 
     3118         niltab_shmem(ji) = ktab(ji) 
     3119      END DO 
     3120      CALL  barrier() 
     3121      IF(ibool == 0 ) THEN  
     3122         CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem,kdim,0,0   & 
     3123              ,N$PES,nil1wrk_shmem,nil1sync_shmem ) 
     3124      ELSE 
     3125         CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem,kdim,0,0   & 
     3126              ,N$PES,nil2wrk_shmem,nil2sync_shmem ) 
     3127      ENDIF 
     3128      CALL  barrier() 
     3129      ibool=ibool+1 
     3130      ibool=MOD( ibool,2) 
     3131      DO ji = 1, kdim 
     3132         ktab(ji) = niltab_shmem(ji) 
     3133      END DO 
     3134   
     3135#  elif defined key_mpp_mpi 
     3136   
     3137      !! * Local variables   (MPI version) 
     3138      INTEGER :: ierror 
     3139      INTEGER :: localcomm 
     3140      INTEGER, DIMENSION(kdim) ::   iwork 
     3141 
     3142      localcomm = mpi_comm_opa 
     3143      IF( PRESENT(kcom) ) localcomm = kcom 
     3144   
     3145      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer,   & 
     3146           &                mpi_max, localcomm, ierror ) 
     3147   
     3148      ktab(:) = iwork(:) 
     3149#endif 
     3150 
     3151   END SUBROUTINE mppmax_a_int 
     3152 
     3153 
     3154   SUBROUTINE mppmax_int( ktab, kcom ) 
     3155      !!---------------------------------------------------------------------- 
     3156      !!                  ***  routine mppmax_int  *** 
     3157      !! 
     3158      !! ** Purpose : 
     3159      !!     Massively parallel processors 
     3160      !!     Find maximum value in an integer layout array 
     3161      !! 
     3162      !!---------------------------------------------------------------------- 
     3163      !! * Arguments 
     3164      INTEGER, INTENT(inout) ::   ktab      ! ??? 
     3165      INTEGER, INTENT(in), OPTIONAL ::   kcom      ! ??? 
     3166   
     3167      !! * Local declarations 
     3168 
     3169#if defined key_mpp_shmem 
     3170 
     3171      !! * Local variables   (SHMEM version) 
     3172      INTEGER :: ji 
     3173      INTEGER, SAVE :: ibool=0 
     3174   
     3175      niltab_shmem(1) = ktab 
     3176      CALL  barrier() 
     3177      IF(ibool == 0 ) THEN  
     3178         CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem, 1,0,0   & 
     3179              ,N$PES,nil1wrk_shmem,nil1sync_shmem ) 
     3180      ELSE 
     3181         CALL shmem_int8_max_to_all (niltab_shmem,niltab_shmem, 1,0,0   & 
     3182              ,N$PES,nil2wrk_shmem,nil2sync_shmem ) 
     3183      ENDIF 
     3184      CALL  barrier() 
     3185      ibool=ibool+1 
     3186      ibool=MOD( ibool,2) 
     3187      ktab = niltab_shmem(1) 
     3188   
     3189#  elif defined key_mpp_mpi 
     3190 
     3191      !! * Local variables   (MPI version) 
     3192      INTEGER ::  ierror, iwork 
     3193      INTEGER :: localcomm 
     3194 
     3195      localcomm = mpi_comm_opa  
     3196      IF( PRESENT(kcom) ) localcomm = kcom 
     3197 
     3198      CALL mpi_allreduce(ktab,iwork, 1,mpi_integer   & 
     3199           &              ,mpi_max,localcomm,ierror) 
     3200   
     3201      ktab = iwork 
     3202#endif 
     3203 
     3204   END SUBROUTINE mppmax_int 
     3205 
     3206 
     3207   SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 
    30083208      !!---------------------------------------------------------------------- 
    30093209      !!                  ***  routine mppmin_a_int  *** 
     
    30153215      INTEGER , INTENT( in  )                  ::   kdim        ! size of array 
    30163216      INTEGER , INTENT(inout), DIMENSION(kdim) ::   ktab        ! input array 
     3217      INTEGER , INTENT( in  ), OPTIONAL        ::   kcom        ! input array 
    30173218   
    30183219#if defined key_mpp_shmem 
     
    30463247      !! * Local variables   (MPI version) 
    30473248      INTEGER :: ierror 
     3249      INTEGER :: localcomm 
    30483250      INTEGER, DIMENSION(kdim) ::   iwork 
    30493251   
     3252      localcomm = mpi_comm_opa 
     3253      IF( PRESENT(kcom) ) localcomm = kcom 
     3254 
    30503255      CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer,   & 
    3051            &                mpi_min, mpi_comm_world, ierror ) 
     3256           &                mpi_min, localcomm, ierror ) 
    30523257   
    30533258      ktab(:) = iwork(:) 
     
    30973302   
    30983303      CALL mpi_allreduce(ktab,iwork, 1,mpi_integer   & 
    3099            &              ,mpi_min,mpi_comm_world,ierror) 
     3304           &              ,mpi_min,mpi_comm_opa,ierror) 
    31003305   
    31013306      ktab = iwork 
     
    31513356   
    31523357      CALL mpi_allreduce(ktab, iwork,kdim,mpi_integer   & 
    3153            ,mpi_sum,mpi_comm_world,ierror) 
     3358           ,mpi_sum,mpi_comm_opa,ierror) 
    31543359   
    31553360      ktab(:) = iwork(:) 
     
    31943399 
    31953400    CALL mpi_allreduce(ktab,iwork, 1,mpi_integer   & 
    3196          ,mpi_sum,mpi_comm_world,ierror) 
     3401         ,mpi_sum,mpi_comm_opa,ierror) 
    31973402 
    31983403    ktab = iwork 
     
    32623467    CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror) 
    32633468    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3264          ,mpi_isl,mpi_comm_world,ierror) 
     3469         ,mpi_isl,mpi_comm_opa,ierror) 
    32653470    ptab(:) = zwork(:) 
    32663471 
     
    33203525      CALL mpi_op_create( lc_isl, lcommute, mpi_isl, ierror ) 
    33213526      CALL mpi_allreduce( ptab, zwork, 1, mpi_double_precision,   & 
    3322          &                                mpi_isl  , mpi_comm_world, ierror ) 
     3527         &                                mpi_isl  , mpi_comm_opa, ierror ) 
    33233528      ptab = zwork 
    33243529 
     
    33283533 
    33293534 
    3330   FUNCTION lc_isl( py, px, kdim, kdtatyp ) 
     3535  FUNCTION lc_isl( py, px, kdim ) 
    33313536    INTEGER :: kdim 
    33323537    REAL(wp), DIMENSION(kdim) ::  px, py 
     
    33413546 
    33423547 
    3343   SUBROUTINE mppmax_a_real( ptab, kdim ) 
     3548  SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 
    33443549    !!---------------------------------------------------------------------- 
    33453550    !!                 ***  routine mppmax_a_real  *** 
     
    33513556    INTEGER , INTENT( in  )                  ::   kdim 
    33523557    REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
     3558    INTEGER , INTENT( in  ), OPTIONAL        ::   kcom 
    33533559 
    33543560#if defined key_mpp_shmem 
     
    33833589    !! * Local variables   (MPI version) 
    33843590    INTEGER :: ierror 
     3591    INTEGER :: localcomm 
    33853592    REAL(wp), DIMENSION(kdim) ::  zwork 
    33863593 
     3594    localcomm = mpi_comm_opa 
     3595    IF( PRESENT(kcom) ) localcomm = kcom 
     3596 
    33873597    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3388          ,mpi_max,mpi_comm_world,ierror) 
     3598         ,mpi_max,localcomm,ierror) 
    33893599    ptab(:) = zwork(:) 
    33903600 
     
    33943604 
    33953605 
    3396   SUBROUTINE mppmax_real( ptab ) 
     3606  SUBROUTINE mppmax_real( ptab, kcom ) 
    33973607    !!---------------------------------------------------------------------- 
    33983608    !!                  ***  routine mppmax_real  *** 
     
    34033613    !! * Arguments 
    34043614    REAL(wp), INTENT(inout) ::   ptab      ! ??? 
     3615    INTEGER , INTENT( in  ), OPTIONAL ::   kcom      ! ??? 
    34053616 
    34063617#if defined key_mpp_shmem 
     
    34273638    !! * Local variables   (MPI version) 
    34283639    INTEGER  ::   ierror 
     3640    INTEGER  ::   localcomm 
    34293641    REAL(wp) ::   zwork 
    34303642 
     3643    localcomm = mpi_comm_opa  
     3644    IF( PRESENT(kcom) ) localcomm = kcom 
     3645 
    34313646    CALL mpi_allreduce( ptab, zwork  , 1             , mpi_double_precision,   & 
    3432        &                      mpi_max, mpi_comm_world, ierror     ) 
     3647       &                      mpi_max, localcomm, ierror     ) 
    34333648    ptab = zwork 
    34343649 
     
    34383653 
    34393654 
    3440   SUBROUTINE mppmin_a_real( ptab, kdim ) 
     3655  SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 
    34413656    !!---------------------------------------------------------------------- 
    34423657    !!                 ***  routine mppmin_a_real  *** 
     
    34483663    INTEGER , INTENT( in  )                  ::   kdim 
    34493664    REAL(wp), INTENT(inout), DIMENSION(kdim) ::   ptab 
     3665    INTEGER , INTENT( in  ), OPTIONAL        ::   kcom 
    34503666 
    34513667#if defined key_mpp_shmem 
     
    34803696    !! * Local variables   (MPI version) 
    34813697    INTEGER :: ierror 
     3698    INTEGER :: localcomm  
    34823699    REAL(wp), DIMENSION(kdim) ::   zwork 
    34833700 
     3701    localcomm = mpi_comm_opa  
     3702    IF( PRESENT(kcom) ) localcomm = kcom 
     3703 
    34843704    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3485          ,mpi_min,mpi_comm_world,ierror) 
     3705         ,mpi_min,localcomm,ierror) 
    34863706    ptab(:) = zwork(:) 
    34873707 
     
    34913711 
    34923712 
    3493   SUBROUTINE mppmin_real( ptab ) 
     3713  SUBROUTINE mppmin_real( ptab, kcom ) 
    34943714    !!---------------------------------------------------------------------- 
    34953715    !!                  ***  routine mppmin_real  *** 
     
    35013721    !! * Arguments 
    35023722    REAL(wp), INTENT( inout ) ::   ptab        !  
     3723    INTEGER , INTENT(  in   ), OPTIONAL :: kcom 
    35033724 
    35043725#if defined key_mpp_shmem 
     
    35263747    INTEGER  ::   ierror 
    35273748    REAL(wp) ::   zwork 
     3749    INTEGER :: localcomm 
     3750 
     3751    localcomm = mpi_comm_opa  
     3752    IF( PRESENT(kcom) ) localcomm = kcom 
    35283753 
    35293754    CALL mpi_allreduce( ptab, zwork, 1,mpi_double_precision   & 
    3530          &               ,mpi_min,mpi_comm_world,ierror) 
     3755         &               ,mpi_min,localcomm,ierror) 
    35313756    ptab = zwork 
    35323757 
     
    35363761 
    35373762 
    3538   SUBROUTINE mppsum_a_real( ptab, kdim ) 
     3763  SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 
    35393764    !!---------------------------------------------------------------------- 
    35403765    !!                  ***  routine mppsum_a_real  *** 
     
    35463771    INTEGER , INTENT( in )                     ::   kdim      ! size of ptab 
    35473772    REAL(wp), DIMENSION(kdim), INTENT( inout ) ::   ptab      ! input array 
     3773    INTEGER , INTENT( in ), OPTIONAL           :: kcom 
    35483774 
    35493775#if defined key_mpp_shmem 
     
    35783804    !! * Local variables   (MPI version) 
    35793805    INTEGER                   ::   ierror    ! temporary integer 
     3806    INTEGER                   ::   localcomm  
    35803807    REAL(wp), DIMENSION(kdim) ::   zwork     ! temporary workspace  
     3808     
     3809 
     3810    localcomm = mpi_comm_opa  
     3811    IF( PRESENT(kcom) ) localcomm = kcom 
    35813812 
    35823813    CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision   & 
    3583          &              ,mpi_sum,mpi_comm_world,ierror) 
     3814         &              ,mpi_sum,localcomm,ierror) 
    35843815    ptab(:) = zwork(:) 
    35853816 
     
    35893820 
    35903821 
    3591   SUBROUTINE mppsum_real( ptab ) 
     3822  SUBROUTINE mppsum_real( ptab, kcom ) 
    35923823    !!---------------------------------------------------------------------- 
    35933824    !!                  ***  routine mppsum_real  *** 
     
    35983829    !!----------------------------------------------------------------------- 
    35993830    REAL(wp), INTENT(inout) ::   ptab        ! input scalar 
     3831    INTEGER , INTENT( in  ), OPTIONAL :: kcom 
    36003832 
    36013833#if defined key_mpp_shmem 
     
    36223854    !! * Local variables   (MPI version) 
    36233855    INTEGER  ::   ierror 
     3856    INTEGER  ::   localcomm  
    36243857    REAL(wp) ::   zwork 
    36253858 
    3626     CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision   & 
    3627          &              ,mpi_sum,mpi_comm_world,ierror) 
     3859   localcomm = mpi_comm_opa  
     3860   IF( PRESENT(kcom) ) localcomm = kcom 
     3861  
     3862   CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision   & 
     3863         &              ,mpi_sum,localcomm,ierror) 
    36283864    ptab = zwork 
    36293865 
     
    36723908    zain(2,:)=ki+10000.*kj 
    36733909 
    3674     CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,ierror) 
     3910    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 
    36753911 
    36763912    pmin=zaout(1,1) 
     
    37233959    zain(2,:)=ki+10000.*kj+100000000.*kk 
    37243960 
    3725     CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_WORLD,ierror) 
     3961    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MINLOC,MPI_COMM_OPA,ierror) 
    37263962 
    37273963    pmin=zaout(1,1) 
     
    37744010    zain(2,:)=ki+10000.*kj 
    37754011 
    3776     CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,ierror) 
     4012    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 
    37774013 
    37784014    pmax=zaout(1,1) 
     
    38244060    zain(2,:)=ki+10000.*kj+100000000.*kk 
    38254061 
    3826     CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_WORLD,ierror) 
     4062    CALL MPI_ALLREDUCE( zain,zaout, 1, MPI_2DOUBLE_PRECISION,MPI_MAXLOC,MPI_COMM_OPA,ierror) 
    38274063 
    38284064    pmax=zaout(1,1) 
     
    38524088    INTEGER :: ierror 
    38534089 
    3854     CALL mpi_barrier(mpi_comm_world,ierror) 
     4090    CALL mpi_barrier(mpi_comm_opa,ierror) 
    38554091 
    38564092#endif 
     
    41254361  END SUBROUTINE mppobc 
    41264362 
     4363  SUBROUTINE mpp_comm_free( kcom) 
     4364 
     4365     INTEGER, INTENT(in) :: kcom 
     4366     INTEGER :: ierr 
     4367 
     4368     CALL MPI_COMM_FREE(kcom, ierr) 
     4369 
     4370  END SUBROUTINE mpp_comm_free 
     4371 
     4372 
     4373  SUBROUTINE mpp_ini_ice(pindic) 
     4374    !!---------------------------------------------------------------------- 
     4375    !!               ***  routine mpp_ini_ice  *** 
     4376    !! 
     4377    !! ** Purpose :   Initialize special communicator for ice areas 
     4378    !!      condition together with global variables needed in the ddmpp folding 
     4379    !! 
     4380    !! ** Method  : - Look for ice processors in ice routines 
     4381    !!              - Put their number in nrank_ice 
     4382    !!              - Create groups for the world processors and the ice processors 
     4383    !!              - Create a communicator for ice processors 
     4384    !! 
     4385    !! ** output 
     4386    !!      njmppmax = njmpp for northern procs 
     4387    !!      ndim_rank_ice = number of processors in the northern line 
     4388    !!      nrank_north (ndim_rank_north) = number  of the northern procs. 
     4389    !!      ngrp_world = group ID for the world processors 
     4390    !!      ngrp_ice = group ID for the ice processors 
     4391    !!      ncomm_ice = communicator for the ice procs. 
     4392    !!      n_ice_root = number (in the world) of proc 0 in the ice comm. 
     4393    !! 
     4394    !! History : 
     4395    !!        !  03-09 (J.M. Molines, MPI only ) 
     4396    !!---------------------------------------------------------------------- 
     4397#ifdef key_mpp_shmem 
     4398    CALL ctl_stop( ' mpp_ini_ice not available in SHMEM' ) 
     4399# elif key_mpp_mpi 
     4400    INTEGER, INTENT(in) :: pindic 
     4401    INTEGER :: ierr 
     4402    INTEGER :: jproc 
     4403    INTEGER :: ii 
     4404    INTEGER, DIMENSION(jpnij) :: kice 
     4405    INTEGER, DIMENSION(jpnij) :: zwork 
     4406    !!---------------------------------------------------------------------- 
     4407 
     4408    ! Look for how many procs with sea-ice 
     4409    ! 
     4410    kice = 0 
     4411    DO jproc=1,jpnij 
     4412       IF(jproc == narea .AND. pindic .GT. 0) THEN 
     4413          kice(jproc) = 1     
     4414       ENDIF         
     4415    END DO 
     4416 
     4417    zwork = 0 
     4418    CALL MPI_ALLREDUCE( kice, zwork,jpnij, mpi_integer,   & 
     4419                       mpi_sum, mpi_comm_opa, ierr ) 
     4420    ndim_rank_ice = sum(zwork)           
     4421 
     4422    ! Allocate the right size to nrank_north 
     4423#if ! defined key_agrif 
     4424    IF(ALLOCATED(nrank_ice)) DEALLOCATE(nrank_ice) 
     4425#else 
     4426    DEALLOCATE(nrank_ice) 
     4427#endif 
     4428 
     4429    ALLOCATE(nrank_ice(ndim_rank_ice)) 
     4430 
     4431    ii = 0      
     4432    nrank_ice = 0 
     4433    DO jproc=1,jpnij 
     4434       IF(zwork(jproc) == 1) THEN 
     4435          ii = ii + 1 
     4436          nrank_ice(ii) = jproc -1  
     4437       ENDIF         
     4438    END DO 
     4439 
     4440    ! Create the world group 
     4441    CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr) 
     4442 
     4443    ! Create the ice group from the world group 
     4444    CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_ice,nrank_ice,ngrp_ice,ierr) 
     4445 
     4446    ! Create the ice communicator , ie the pool of procs with sea-ice 
     4447    CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_ice,ncomm_ice,ierr) 
     4448 
     4449    ! Find proc number in the world of proc 0 in the north 
     4450    ! The following line seems to be useless, we just comment & keep it as reminder 
     4451    ! CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr) 
     4452#endif 
     4453 
     4454  END SUBROUTINE mpp_ini_ice 
     4455 
    41274456 
    41284457  SUBROUTINE mpp_ini_north 
     
    41864515    ! create the world group 
    41874516    ! 
    4188     CALL MPI_COMM_GROUP(mpi_comm_world,ngrp_world,ierr) 
     4517    CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr) 
    41894518    ! 
    41904519    ! Create the North group from the world group 
     
    41934522    ! Create the North communicator , ie the pool of procs in the north group 
    41944523    ! 
    4195     CALL MPI_COMM_CREATE(mpi_comm_world,ngrp_north,ncomm_north,ierr) 
     4524    CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_north,ncomm_north,ierr) 
    41964525 
    41974526 
     
    49575286   END SUBROUTINE mpp_lbc_north_e 
    49585287 
    4959  
    4960    !!!!! 
    4961  
    4962  
    4963    !!  
    4964    !!    This is valid on IBM machine ONLY.  
    4965    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -*- Mode: F90 -*- !!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    4966    !! mpi_init_opa.f90 : Redefinition du point d'entree MPI_INIT de la bibliotheque 
    4967    !!                MPI afin de faire, en plus de l'initialisation de 
    4968    !!                l'environnement MPI, l'allocation d'une zone tampon 
    4969    !!                qui sera ulterieurement utilisee automatiquement lors 
    4970    !!                de tous les envois de messages par MPI_BSEND 
    4971    !! 
    4972    !! Auteur : CNRS/IDRIS 
    4973    !! Date   : Tue Nov 13 12:02:14 2001 
    4974    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    4975  
    49765288   SUBROUTINE mpi_init_opa(code) 
    4977       IMPLICIT NONE 
    4978  
    4979 !$AGRIF_DO_NOT_TREAT 
    4980 #     include <mpif.h> 
    4981 !$AGRIF_END_DO_NOT_TREAT 
    4982  
    4983       INTEGER                                 :: code,rang 
     5289     !!--------------------------------------------------------------------- 
     5290     !!                   ***  routine mpp_init.opa  *** 
     5291     !! 
     5292     !! ** Purpose :: export and attach a MPI buffer for bsend 
     5293     !! 
     5294     !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment 
     5295     !!            but classical mpi_init 
     5296     !!  
     5297     !! History :: 01/11 :: IDRIS initial version for IBM only   
     5298     !!            08/04 :: R. Benshila, generalisation 
     5299     !! 
     5300     !!--------------------------------------------------------------------- 
     5301 
     5302      INTEGER                                 :: code, ierr 
     5303      LOGICAL                                 :: mpi_was_called 
    49845304  
    4985       ! La valeur suivante doit etre au moins egale a la taille 
    4986       ! du plus grand message qui sera transfere dans le programme 
    4987       ! (de toute facon, il y aura un message d'erreur si cette 
    4988       ! valeur s'avere trop petite) 
    4989       INTEGER                                 :: taille_tampon 
    4990       CHARACTER(len=9)                        :: taille_tampon_alphanum 
    4991       REAL(kind=8), ALLOCATABLE, DIMENSION(:) :: tampon 
    4992   
    4993       ! Le point d'entree dans la bibliotheque MPI elle-meme 
    4994       CALL mpi_init(code) 
    4995  
    4996       ! La definition de la zone tampon pour les futurs envois 
    4997       ! par MPI_BSEND (on alloue une fois pour toute cette zone 
    4998       ! tampon, qui sera automatiquement utilisee lors de chaque 
    4999       ! appel  a MPI_BSEND). 
    5000       ! La desallocation sera implicite quand on sortira de 
    5001       ! l'environnement MPI. 
    5002  
    5003       ! Recuperation de la valeur de la variable d'environnement 
    5004       ! BUFFER_LENGTH 
    5005       ! qui, si elle est definie, doit contenir une valeur superieure 
    5006       ! a  la taille en octets du plus gros message 
    5007       CALL getenv('BUFFER_LENGTH',taille_tampon_alphanum) 
    5008    
    5009       ! Si la variable BUFFER_LENGTH n'est pas positionnee, on lui met par 
    5010       ! defaut la plus grande valeur de la variable MP_EAGER_LIMIT, soit 
    5011       ! 65 536 octets 
    5012       IF (taille_tampon_alphanum == ' ') THEN 
    5013          taille_tampon = 65536 
    5014       ELSE 
    5015          READ(taille_tampon_alphanum,'(i9)') taille_tampon 
    5016       END IF 
    5017  
    5018       ! On est limite en mode d'adressage 32 bits a  1750 Mo pour la zone 
    5019       ! "data" soit 7 segments, c.-a -d. 1750/8 = 210 Mo 
    5020       IF (taille_tampon > 210000000) THEN 
    5021          PRINT *,'Attention la valeur BUFFER_LENGTH doit etre <= 210000000' 
    5022          CALL mpi_abort(MPI_COMM_WORLD,2,code) 
    5023       END IF 
    5024  
    5025       CALL mpi_comm_rank(MPI_COMM_WORLD,rang,code) 
    5026       IF (rang == 0 ) PRINT *,'Taille du buffer alloue : ',taille_tampon 
    5027  
    5028       ! Allocation du tampon et attachement 
    5029       ALLOCATE(tampon(taille_tampon)) 
    5030       CALL mpi_buffer_attach(tampon,taille_tampon,code) 
     5305      ! MPI initialization 
     5306      CALL mpi_initialized(mpi_was_called, code) 
     5307      IF ( code /= MPI_SUCCESS ) THEN 
     5308        CALL ctl_stop( ' lib_mpp: Error in routine mpi_initialized' ) 
     5309        CALL mpi_abort( mpi_comm_world, code, ierr ) 
     5310      ENDIF 
     5311 
     5312      IF ( .NOT. mpi_was_called ) THEN 
     5313         CALL mpi_init(code) 
     5314         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_opa, code) 
     5315         IF ( code /= MPI_SUCCESS ) THEN 
     5316            CALL ctl_stop( ' lib_mpp: Error in routine mpi_comm_dup' ) 
     5317            CALL mpi_abort( mpi_comm_world, code, ierr ) 
     5318         ENDIF 
     5319      ENDIF 
     5320 
     5321      IF( nn_buffer > 0 ) THEN 
     5322         IF ( lwp ) WRITE(numout,*) 'mpi_bsend, buffer allocation of  : ', nn_buffer 
     5323 
     5324         ! Buffer allocation and attachment 
     5325         ALLOCATE(tampon(nn_buffer)) 
     5326         CALL mpi_buffer_attach(tampon,nn_buffer,code) 
     5327      ENDIF 
    50315328 
    50325329   END SUBROUTINE mpi_init_opa 
     
    50405337   END INTERFACE 
    50415338   INTERFACE mpp_max 
    5042       MODULE PROCEDURE mppmax_a_real, mppmax_real 
     5339      MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real 
    50435340   END INTERFACE 
    50445341   INTERFACE mpp_min 
     
    50605357 
    50615358   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
     5359   INTEGER :: ncomm_ice 
    50625360 
    50635361CONTAINS 
    50645362 
    5065    FUNCTION mynode() RESULT (function_value) 
     5363   FUNCTION mynode(localComm) RESULT (function_value) 
     5364      INTEGER, OPTIONAL :: localComm 
    50665365      function_value = 0 
    50675366   END FUNCTION mynode 
     
    50705369   END SUBROUTINE mppsync 
    50715370 
    5072    SUBROUTINE mpp_sum_as( parr, kdim )      ! Dummy routine 
     5371   SUBROUTINE mpp_sum_as( parr, kdim, kcom )      ! Dummy routine 
    50735372      REAL   , DIMENSION(:) :: parr 
    50745373      INTEGER               :: kdim 
    5075       WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1) 
     5374      INTEGER, OPTIONAL     :: kcom  
     5375      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom 
    50765376   END SUBROUTINE mpp_sum_as 
    50775377 
    5078    SUBROUTINE mpp_sum_a2s( parr, kdim )      ! Dummy routine 
     5378   SUBROUTINE mpp_sum_a2s( parr, kdim, kcom )      ! Dummy routine 
    50795379      REAL   , DIMENSION(:,:) :: parr 
    50805380      INTEGER               :: kdim 
    5081       WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1) 
     5381      INTEGER, OPTIONAL     :: kcom  
     5382      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom 
    50825383   END SUBROUTINE mpp_sum_a2s 
    50835384 
    5084    SUBROUTINE mpp_sum_ai( karr, kdim )      ! Dummy routine 
     5385   SUBROUTINE mpp_sum_ai( karr, kdim, kcom )      ! Dummy routine 
    50855386      INTEGER, DIMENSION(:) :: karr 
    50865387      INTEGER               :: kdim 
    5087       WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1) 
     5388      INTEGER, OPTIONAL     :: kcom  
     5389      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom 
    50885390   END SUBROUTINE mpp_sum_ai 
    50895391 
    5090    SUBROUTINE mpp_sum_s( psca )            ! Dummy routine 
     5392   SUBROUTINE mpp_sum_s( psca, kcom )            ! Dummy routine 
    50915393      REAL                  :: psca 
    5092       WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca 
     5394      INTEGER, OPTIONAL     :: kcom  
     5395      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 
    50935396   END SUBROUTINE mpp_sum_s 
    50945397 
    5095    SUBROUTINE mpp_sum_i( kint )            ! Dummy routine 
     5398   SUBROUTINE mpp_sum_i( kint, kcom )            ! Dummy routine 
    50965399      integer               :: kint 
    5097       WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint 
     5400      INTEGER, OPTIONAL     :: kcom  
     5401      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 
    50985402   END SUBROUTINE mpp_sum_i 
    50995403 
    5100    SUBROUTINE mppmax_a_real( parr, kdim ) 
     5404   SUBROUTINE mppmax_a_real( parr, kdim, kcom ) 
    51015405      REAL   , DIMENSION(:) :: parr 
    51025406      INTEGER               :: kdim 
    5103       WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1) 
     5407      INTEGER, OPTIONAL     :: kcom  
     5408      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 
    51045409   END SUBROUTINE mppmax_a_real 
    51055410 
    5106    SUBROUTINE mppmax_real( psca ) 
     5411   SUBROUTINE mppmax_real( psca, kcom ) 
    51075412      REAL                  :: psca 
    5108       WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca 
     5413      INTEGER, OPTIONAL     :: kcom  
     5414      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom 
    51095415   END SUBROUTINE mppmax_real 
    51105416 
    5111    SUBROUTINE mppmin_a_real( parr, kdim ) 
     5417   SUBROUTINE mppmin_a_real( parr, kdim, kcom ) 
    51125418      REAL   , DIMENSION(:) :: parr 
    51135419      INTEGER               :: kdim 
    5114       WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1) 
     5420      INTEGER, OPTIONAL     :: kcom  
     5421      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 
    51155422   END SUBROUTINE mppmin_a_real 
    51165423 
    5117    SUBROUTINE mppmin_real( psca ) 
     5424   SUBROUTINE mppmin_real( psca, kcom ) 
    51185425      REAL                  :: psca 
    5119       WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca 
     5426      INTEGER, OPTIONAL     :: kcom  
     5427      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom 
    51205428   END SUBROUTINE mppmin_real 
    51215429 
    5122    SUBROUTINE mppmin_a_int( karr, kdim ) 
     5430   SUBROUTINE mppmax_a_int( karr, kdim ,kcom) 
    51235431      INTEGER, DIMENSION(:) :: karr 
    51245432      INTEGER               :: kdim 
    5125       WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1) 
     5433      INTEGER, OPTIONAL     :: kcom  
     5434      WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 
     5435   END SUBROUTINE mppmax_a_int 
     5436 
     5437   SUBROUTINE mppmax_int( kint, kcom) 
     5438      INTEGER               :: kint 
     5439      INTEGER, OPTIONAL     :: kcom  
     5440      WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom 
     5441   END SUBROUTINE mppmax_int 
     5442 
     5443   SUBROUTINE mppmin_a_int( karr, kdim, kcom ) 
     5444      INTEGER, DIMENSION(:) :: karr 
     5445      INTEGER               :: kdim 
     5446      INTEGER, OPTIONAL     :: kcom  
     5447      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 
    51265448   END SUBROUTINE mppmin_a_int 
    51275449 
    5128    SUBROUTINE mppmin_int( kint ) 
     5450   SUBROUTINE mppmin_int( kint, kcom ) 
    51295451      INTEGER               :: kint 
    5130       WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint 
     5452      INTEGER, OPTIONAL     :: kcom  
     5453      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom 
    51315454   END SUBROUTINE mppmin_int 
    51325455 
     
    52235546   END SUBROUTINE mppstop 
    52245547 
     5548   SUBROUTINE mpp_ini_ice(kcom) 
     5549      INTEGER :: kcom 
     5550      WRITE(*,*) 'mpp_ini_ice: You should not have seen this print! error?',kcom 
     5551   END SUBROUTINE mpp_ini_ice 
     5552 
     5553   SUBROUTINE mpp_comm_free(kcom) 
     5554      INTEGER :: kcom 
     5555      WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?',kcom 
     5556   END SUBROUTINE mpp_comm_free 
     5557 
    52255558#endif 
    52265559   !!---------------------------------------------------------------------- 
Note: See TracChangeset for help on using the changeset viewer.