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 13 for trunk/NEMO/OPA_SRC/lib_mpp.F90 – NEMO

Ignore:
Timestamp:
2004-02-17T08:14:05+01:00 (20 years ago)
Author:
opalod
Message:

CT : BUGFIX001 : Compilation error is solved

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/NEMO/OPA_SRC/lib_mpp.F90

    r3 r13  
    11MODULE lib_mpp 
    2   !!====================================================================== 
    3   !!                       ***  MODULE  lib_mpp  *** 
    4   !! Ocean numerics:  massively parallel processing librairy 
    5   !!===================================================================== 
    6 #if defined key_mpp 
    7   !!---------------------------------------------------------------------- 
    8   !!   'key_mpp'                     massively parallel processing library 
    9   !!---------------------------------------------------------------------- 
    10   !!   mynode 
    11   !!   mpparent 
    12   !!   mppspawn 
    13   !!   mppshmem 
    14   !!   mpp_lnk     : generic interface (defined in lbclnk) for : 
    15   !!                 mpp_lnk_2d, mpp_lnk_3d 
    16   !!   mpplnks 
    17   !!   mpprecv 
    18   !!   mppsend 
    19   !!   mppscatter 
    20   !!   mppgather 
    21   !!   mpp_isl    : generic inteface  for : 
    22   !!                mppisl_int , mppisl_a_int , mppisl_real, mppisl_a_real 
    23   !!   mpp_min    : generic interface for :  
    24   !!                mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real 
    25   !!   mpp_max    : generic interface for : 
    26   !!                mppmax_real, mppmax_a_real 
    27   !!   mpp_sum    : generic interface for : 
    28   !!                mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real 
    29   !!   mppsync 
    30   !!   mppstop 
    31   !!   mppobc     : variant of mpp_lnk for open boundaries 
    32   !!   mpp_ini_north 
    33   !!   mpp_lbc_north 
    34   !!---------------------------------------------------------------------- 
    35   !! History : 
    36   !!        !  94 (M. Guyon, J. Escobar, M. Imbard)  Original code 
    37   !!        !  97  (A.M. Treguier)  SHMEM additions 
    38   !!        !  98  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI 
    39   !!   9.0  !  03  (J.-M. Molines, G. Madec)  F90, free form 
    40   !!---------------------------------------------------------------------- 
    41   !!  OPA 9.0 , LODYC-IPSL (2003) 
    42   !!--------------------------------------------------------------------- 
    43   !! * Modules used 
    44   USE dom_oce         ! ocean space and time domain  
    45   USE in_out_manager  ! I/O manager 
    46  
    47   IMPLICIT NONE 
    48  
    49   !! * Interfaces 
    50   !! define generic interface for these routine as they are called sometimes 
    51   !!        with scalar arguments instead of array arguments, which causes problems 
    52   !!        for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ 
    53  
    54   INTERFACE mpp_isl 
    55      MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real 
    56   END INTERFACE 
    57   INTERFACE mpp_min 
    58      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
    59   END INTERFACE 
    60   INTERFACE mpp_max 
    61      MODULE PROCEDURE mppmax_a_real, mppmax_real 
    62   END INTERFACE 
    63   INTERFACE mpp_sum 
    64      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real 
    65   END INTERFACE 
    66   INTERFACE mpp_lbc_north 
    67      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d  
    68   END INTERFACE 
    69  
    70   !! * Module parameters 
     2   !!====================================================================== 
     3   !!                       ***  MODULE  lib_mpp  *** 
     4   !! Ocean numerics:  massively parallel processing librairy 
     5   !!===================================================================== 
     6#if   defined key_mpp_mpi   ||   defined key_mpp_shmem 
     7   !!---------------------------------------------------------------------- 
     8   !!   'key_mpp_mpi'     OR      MPI massively parallel processing library 
     9   !!   'key_mpp_shmem'         SHMEM massively parallel processing library 
     10   !!---------------------------------------------------------------------- 
     11   !!   mynode 
     12   !!   mpparent 
     13   !!   mppshmem 
     14   !!   mpp_lnk     : generic interface (defined in lbclnk) for : 
     15   !!                 mpp_lnk_2d, mpp_lnk_3d 
     16   !!   mpplnks 
     17   !!   mpprecv 
     18   !!   mppsend 
     19   !!   mppscatter 
     20   !!   mppgather 
     21   !!   mpp_isl    : generic inteface  for : 
     22   !!                mppisl_int , mppisl_a_int , mppisl_real, mppisl_a_real 
     23   !!   mpp_min    : generic interface for :  
     24   !!                mppmin_int , mppmin_a_int , mppmin_real, mppmin_a_real 
     25   !!   mpp_max    : generic interface for : 
     26   !!                mppmax_real, mppmax_a_real 
     27   !!   mpp_sum    : generic interface for : 
     28   !!                mppsum_int , mppsum_a_int , mppsum_real, mppsum_a_real 
     29   !!   mppsync 
     30   !!   mppstop 
     31   !!   mppobc     : variant of mpp_lnk for open boundaries 
     32   !!   mpp_ini_north 
     33   !!   mpp_lbc_north 
     34   !!---------------------------------------------------------------------- 
     35   !! History : 
     36   !!        !  94 (M. Guyon, J. Escobar, M. Imbard)  Original code 
     37   !!        !  97  (A.M. Treguier)  SHMEM additions 
     38   !!        !  98  (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI 
     39   !!   9.0  !  03  (J.-M. Molines, G. Madec)  F90, free form 
     40   !!---------------------------------------------------------------------- 
     41   !!  OPA 9.0 , LODYC-IPSL (2003) 
     42   !!--------------------------------------------------------------------- 
     43   !! * Modules used 
     44   USE dom_oce         ! ocean space and time domain  
     45   USE in_out_manager  ! I/O manager 
     46 
     47   IMPLICIT NONE 
     48 
     49   !! * Interfaces 
     50   !! define generic interface for these routine as they are called sometimes 
     51   !!        with scalar arguments instead of array arguments, which causes problems 
     52   !!        for the compilation on AIX system as well as NEC and SGI. Ok on COMPACQ 
     53 
     54   INTERFACE mpp_isl 
     55      MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real 
     56   END INTERFACE 
     57   INTERFACE mpp_min 
     58      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
     59   END INTERFACE 
     60   INTERFACE mpp_max 
     61      MODULE PROCEDURE mppmax_a_real, mppmax_real 
     62   END INTERFACE 
     63   INTERFACE mpp_sum 
     64      MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real 
     65   END INTERFACE 
     66   INTERFACE mpp_lbc_north 
     67      MODULE PROCEDURE mpp_lbc_north_3d, mpp_lbc_north_2d  
     68   END INTERFACE 
     69 
     70   !! * Module parameters 
     71   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .TRUE.       !: mpp flag 
     72 
    7173  !! The processor number is a required power of two : 
    7274  !!                       1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024,... 
    … …  
    7678       ndim_mpp = jpnij        ! dimension for this simulation 
    7779 
    78 #if defined key_mpp_mpi 
    7980  !! No MPI variable definition 
    80 #else 
     81# if defined key_mpp_shmem 
    8182  !! * PVM and SHMEM version 
    8283  CHARACTER (len=80), PARAMETER ::   simfile    = 'pvm3_ndim'   ! file name 
    8384  CHARACTER (len=47), PARAMETER ::   executable = 'opa'         ! executable name 
    84 # if defined key_mpp_shmem 
    8585  CHARACTER, PARAMETER ::            opaall     = ""            ! group name (old def opaall*(*)) 
    86 # else 
    87   CHARACTER, PARAMETER ::            opaall     = "opaall"      ! group name 
    88 # endif 
    8986 
    9087  !! PVM control 
    … …  
    10198 
    10299  !! Variable definition 
    103 # if defined key_mpp_pvm 
    104   INTEGER, PARAMETER ::   & !!! PVM case 
    105        jpvmreal = 6,        &  ! specific pvm3 code for real4 and real8 
    106        !                       ! ( real4 = 4, real8 = 6 ) 
    107   jpvmint  = 3            ! specific pvm3 code for integer4 and integer8 
    108   !                       ! ( integer4 = 3, integer8 = 21 : ext Cray) 
    109 # else 
    110100  INTEGER, PARAMETER ::     &   
    111101       jpvmreal = 6,        &  ! ??? 
    112102       jpvmint = 21            ! ??? 
    113 # endif 
    114  
    115 # if defined key_mpp_shmem 
     103 
    116104  ! Maximum  dimension of array to sum on the processors 
    117105  INTEGER, PARAMETER ::   & !!! SHMEM case 
    … …  
    121109  !                       ! ??? 
    122110# endif 
    123 #endif 
    124111 
    125112 
    … …  
    133120       size,     &  ! number of process 
    134121       rank         ! process number  [ 0 - size-1 ] 
    135 #else 
    136   !! * PVM and SHMEM version 
     122#elif defined key_mpp_shmem 
     123  !! * SHMEM version 
    137124#  include  <fpvm3.h> 
    138125 
    … …  
    156143       nt3d_tids       ! tids array [ 0 - nproc-1 ] 
    157144 
    158 # if defined key_mpp_shmem 
    159145  !! * SHMEM version 
    160146#  include <mpp/shmem.fh> 
    … …  
    227213       niltab_shmem 
    228214 
    229 # endif 
    230215#endif 
    231216#if defined  key_mpp_mpi 
    … …  
    279264    mynode = rank 
    280265#else 
    281     !! * Local variables   (PVM or SHMEM version) 
     266    !! * Local variables   (SHMEM version) 
    282267    INTEGER ::   mynode 
    283268    INTEGER ::   & 
    … …  
    322307          ! ------------------------- 
    323308          IF( npvm_nproc > 1 ) THEN 
    324              CALL mppspawn(executable,pvmdefault,'*'   & 
    325                   ,npvm_nproc-1,npvm_tids(1),info) 
    326              IF(info /= npvm_nproc-1 ) THEN 
    327                 WRITE(nummpp,*) 'mynode, problem in spawn '   & 
    328                      ,' info=', info,' executable=',executable 
    329                 STOP 
    330              ENDIF 
     309             DO ji = 1, npvm_nproc-1 
     310                npvm_tids(ji) = nt3d_tids(ji) 
     311             END DO 
     312             info=npvm_nproc-1 
     313 
    331314             IF(mynode_print /= 0 ) THEN 
    332315                WRITE(nummpp,*) 'mynode, npvm_mytid=',npvm_mytid,   & 
    … …  
    408391    !!                  ***  routine mpparent  *** 
    409392    !! 
    410     !! ** Purpose :   If key_mpp_pvm then call pvmfparent fonction  
    411     !!    else use an pvmfparent routine for T3E 
    412     !!   (default key or key_mpp_shmem) 
    413     !!    or  only RETURN -1 (key_mpp_mpi) 
     393    !! ** Purpose :   use an pvmfparent routine for T3E (key_mpp_shmem) 
     394    !!              or  only RETURN -1 (key_mpp_mpi) 
    414395    !!---------------------------------------------------------------------- 
    415396    !! * Arguments 
    416     INTEGER, INTENT(inout) ::   & 
    417          kparent_tid      ! ??? 
    418  
    419 #if defined key_mpp_pvm 
    420     !! * PVM version 
    421  
    422     CALL pvmfparent(kparent_tid) 
    423  
    424 #elif defined key_mpp_mpi 
     397    INTEGER, INTENT(inout) ::   kparent_tid      ! ??? 
     398 
     399#if defined key_mpp_mpi 
    425400    !! * Local variables   (MPI version) 
    426401 
    … …  
    428403 
    429404#else 
    430     !! * Local variables   (SHMEN or PVM onto T3E version) 
     405    !! * Local variables   (SHMEN onto T3E version) 
    431406    INTEGER ::   & 
    432407         it3d_my_pe, LEADZ, ji, info 
    … …  
    483458  END SUBROUTINE mpparent 
    484459 
    485   SUBROUTINE mppspawn( cdexec, kmod, cdwhere, kproc, ktids, kinfo ) 
    486     !!---------------------------------------------------------------------- 
    487     !!                  ***  routine mppspawn  *** 
    488     !! 
    489     !! ** Purpose :   If key_mpp_pvm then call pvmfspawn fonction  
    490     !!    else use an pvmfspawn routine for T3E 
    491     !!   (default key or key_mpp_shmem) 
    492     !!    or  only RETURN -1 (key_mpp_mpi) 
    493     !!---------------------------------------------------------------------- 
    494     !! * Arguments 
    495     CHARACTER(LEN=*) ::   cdexec,cdwhere 
    496     INTEGER ,DIMENSION(:) ::  ktids 
    497     INTEGER               ::  kmod,kproc,kinfo 
    498  
    499 #if defined key_mpp_pvm 
    500     !! * PVM version 
    501  
    502     CALL pvmfspawn( cdexec, kmod, cdwhere, kproc, ktids, kinfo ) 
    503  
    504 #  elif defined key_mpp_mpi 
    505     !! * MPI version 
    506  
    507     kinfo=-1 
    508  
    509 #else 
    510     !! * Lovcal variables   (SHMEM or PVM onto T3E version) 
    511     INTEGER :: ji 
    512  
    513     DO ji = 1, kproc 
    514        ktids(ji) = nt3d_tids(ji) 
    515     END DO 
    516     kinfo=kproc 
    517 #endif 
    518  
    519   END SUBROUTINE mppspawn 
    520  
    521460#if defined key_mpp_shmem 
    522461 
    … …  
    701640    END SELECT 
    702641 
    703 #  else 
    704     !! * Local variables   (PVM version) 
    705  
    706     imigr=jpreci*jpj*jpk*jpbyt 
    707  
    708     SELECT CASE ( nbondi ) 
    709  
    710     CASE ( -1 ) 
    711        CALL mppsend(2,t3we(1,1,1,1),imigr,noea,0) 
    712        CALL mpprecv(1,t3ew(1,1,1,2),imigr) 
    713  
    714     CASE ( 0 ) 
    715        CALL mppsend(1,t3ew(1,1,1,1),imigr,nowe,0) 
    716        CALL mppsend(2,t3we(1,1,1,1),imigr,noea,0) 
    717        CALL mpprecv(1,t3ew(1,1,1,2),imigr) 
    718        CALL mpprecv(2,t3we(1,1,1,2),imigr) 
    719  
    720     CASE ( 1 ) 
    721        CALL mppsend(1,t3ew(1,1,1,1),imigr,nowe,0) 
    722        CALL mpprecv(2,t3we(1,1,1,2),imigr) 
    723     END SELECT 
    724  
    725642#endif 
    726643 
    … …  
    803720 
    804721    CASE ( 1 )  
    805        CALL mppsend(3,t3ns(1,1,1,1),imigr,noso,0) 
    806        CALL mpprecv(4,t3sn(1,1,1,2),imigr) 
    807     END SELECT 
    808  
    809 #else 
    810     !! * Local variables   (PVM version) 
    811  
    812     imigr=jprecj*jpi*jpk*jpbyt 
    813  
    814     SELECT CASE ( nbondj ) 
    815  
    816     CASE ( -1 )  
    817        CALL mppsend(4,t3sn(1,1,1,1),imigr,nono,0) 
    818        CALL mpprecv(3,t3ns(1,1,1,2),imigr) 
    819  
    820     CASE ( 0 ) 
    821        CALL mppsend(3,t3ns(1,1,1,1),imigr,noso,0) 
    822        CALL mppsend(4,t3sn(1,1,1,1),imigr,nono,0) 
    823        CALL mpprecv(3,t3ns(1,1,1,2),imigr) 
    824        CALL mpprecv(4,t3sn(1,1,1,2),imigr) 
    825  
    826     CASE ( 1 ) 
    827722       CALL mppsend(3,t3ns(1,1,1,1),imigr,noso,0) 
    828723       CALL mpprecv(4,t3sn(1,1,1,2),imigr) 
    … …  
    1038933       END SELECT 
    1039934 
    1040 #else 
    1041        !! * PVM version 
    1042  
    1043        imigr=jpreci*jpj*jpk*jpbyt 
    1044  
    1045        SELECT CASE ( nbondi ) 
    1046  
    1047        CASE ( -1 ) 
    1048           CALL mppsend(2,t3we(1,1,1,1),imigr,noea,0) 
    1049           CALL mpprecv(1,t3ew(1,1,1,2),imigr) 
    1050  
    1051        CASE ( 0 ) 
    1052           CALL mppsend(1,t3ew(1,1,1,1),imigr,nowe,0) 
    1053           CALL mppsend(2,t3we(1,1,1,1),imigr,noea,0) 
    1054           CALL mpprecv(1,t3ew(1,1,1,2),imigr) 
    1055           CALL mpprecv(2,t3we(1,1,1,2),imigr) 
    1056  
    1057        CASE ( 1 ) 
    1058           CALL mppsend(1,t3ew(1,1,1,1),imigr,nowe,0) 
    1059           CALL mpprecv(2,t3we(1,1,1,2),imigr) 
    1060        END SELECT 
    1061  
    1062935#endif 
    1063936 
    … …  
    1114987    !             !  = S : T-point, north fold treatment 
    1115988    !             !  = G : F-point, north fold treatment 
     989    !             !  = I : sea-ice velocity at F-point with index shift 
    1116990    REAL(wp), INTENT( in ) ::   & 
    1117991         psgn          ! control of the sign change 
    … …  
    11351009    !                                        ! ==================== 
    11361010 
    1137     IF( nbondi == 2.AND.(nperio == 1 .OR. nperio == 4 .OR. nperio == 6)) THEN 
     1011    IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 
    11381012       ! ... cyclic 
    11391013       pt2d( 1 ,:) = pt2d(jpim1,:) 
    … …  
    12461120    END SELECT 
    12471121 
    1248 #else 
    1249     !! * PVM version 
    1250  
    1251     imigr=jpreci*jpj*jpbyt 
    1252  
    1253     SELECT CASE ( nbondi ) 
    1254  
    1255     CASE ( -1 ) 
    1256        CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 
    1257        CALL mpprecv(1,t2ew(1,1,2),imigr) 
    1258  
    1259     CASE ( 0 ) 
    1260        CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 
    1261        CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 
    1262        CALL mpprecv(1,t2ew(1,1,2),imigr) 
    1263        CALL mpprecv(2,t2we(1,1,2),imigr) 
    1264  
    1265     CASE ( 1 ) 
    1266        CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 
    1267        CALL mpprecv(2,t2we(1,1,2),imigr) 
    1268     END SELECT  
    1269  
    12701122#endif 
    12711123 
    … …  
    13521204    END SELECT 
    13531205 
    1354 #else 
    1355     !! * PVM version 
    1356  
    1357     imigr=jprecj*jpi*jpbyt 
    1358  
    1359     SELECT CASE ( nbondj )  
    1360  
    1361     CASE ( -1 ) 
    1362        CALL mppsend(4,t2sn(1,1,1),imigr,nono,0) 
    1363        CALL mpprecv(3,t2ns(1,1,2),imigr) 
    1364  
    1365     CASE ( 0 ) 
    1366        CALL mppsend(3,t2ns(1,1,1),imigr,noso,0) 
    1367        CALL mppsend(4,t2sn(1,1,1),imigr,nono,0) 
    1368        CALL mpprecv(3,t2ns(1,1,2),imigr) 
    1369        CALL mpprecv(4,t2sn(1,1,2),imigr) 
    1370  
    1371     CASE ( 1 ) 
    1372        CALL mppsend(3,t2ns(1,1,1),imigr,noso,0) 
    1373        CALL mpprecv(4,t2sn(1,1,2),imigr) 
    1374     END SELECT 
    1375  
    13761206#endif 
    13771207 
    … …  
    15681398       SELECT CASE ( nbondi ) 
    15691399 
    1570        CASE ( -1 ) 
    1571           CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 
    1572           CALL mpprecv(1,t2ew(1,1,2),imigr) 
    1573  
    1574        CASE ( 0 ) 
    1575           CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 
    1576           CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 
    1577           CALL mpprecv(1,t2ew(1,1,2),imigr) 
    1578           CALL mpprecv(2,t2we(1,1,2),imigr) 
    1579  
    1580        CASE ( 1 ) 
    1581           CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 
    1582           CALL mpprecv(2,t2we(1,1,2),imigr) 
    1583        END SELECT  
    1584  
    1585 #else 
    1586        !! * PVM version 
    1587  
    1588        imigr=jpreci*jpj*jpbyt 
    1589  
    1590        SELECT CASE ( nbondi ) 
    1591   
    15921400       CASE ( -1 ) 
    15931401          CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 
    … …  
    16581466 
    16591467    !! * Local variables 
    1660     INTEGER ::   ji, jj, jl     ! dummy loop indices 
     1468    INTEGER ::   ji, jl           ! dummy loop indices 
    16611469    INTEGER ::   & 
    16621470         imigr, iihom, ijhom      ! temporary integers 
    … …  
    17031511       CALL mpprecv(3,t2p1(1,1,2),imigr) 
    17041512 
    1705 #  else 
    1706        !! * PVM version 
    1707  
    1708        imigr=jprecj*jpi*jpbyt 
    1709  
    1710        CALL mppsend(3,t2p1(1,1,1),imigr,nono,0) 
    1711        CALL mpprecv(3,t2p1(1,1,2),imigr) 
    1712  
    17131513#endif       
    17141514 
    … …  
    17351535 
    17361536       imigr=jprecj*jpi 
    1737  
    1738        CALL mppsend(3,t2p1(1,1,1),imigr,nono,0) 
    1739        CALL mpprecv(3,t2p1(1,1,2),imigr) 
    1740  
    1741 #  else 
    1742        !! * PVM version 
    1743  
    1744        imigr=jprecj*jpi*jpbyt 
    17451537 
    17461538       CALL mppsend(3,t2p1(1,1,1),imigr,nono,0) 
    … …  
    18211613    END SELECT 
    18221614 
    1823 #  else 
    1824     !! * PVM version 
    1825  
    1826     imigr=jpreci*jpj*jpbyt 
    1827  
    1828     SELECT CASE ( nbondi ) 
    1829  
    1830     CASE ( -1 ) 
    1831        CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 
    1832        CALL mpprecv(1,t2ew(1,1,2),imigr) 
    1833  
    1834     CASE ( 0 ) 
    1835        CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 
    1836        CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 
    1837        CALL mpprecv(1,t2ew(1,1,2),imigr) 
    1838        CALL mpprecv(2,t2we(1,1,2),imigr) 
    1839  
    1840     CASE ( 1 ) 
    1841        CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 
    1842        CALL mpprecv(2,t2we(1,1,2),imigr) 
    1843  
    1844     END SELECT 
    1845  
    18461615#endif 
    18471616 
    … …  
    19331702    END SELECT 
    19341703 
    1935 #  else 
    1936     !! * PVM version 
    1937  
    1938     imigr=jprecj*jpi*jpbyt 
    1939  
    1940     SELECT CASE ( nbondj ) 
    1941   
    1942     CASE ( -1 ) 
    1943        CALL mppsend(4,t2sn(1,1,1),imigr,nono,0) 
    1944        CALL mpprecv(3,t2ns(1,1,2),imigr) 
    1945  
    1946     CASE ( 0 ) 
    1947        CALL mppsend(3,t2ns(1,1,1),imigr,noso,0) 
    1948        CALL mppsend(4,t2sn(1,1,1),imigr,nono,0) 
    1949        CALL mpprecv(3,t2ns(1,1,2),imigr) 
    1950        CALL mpprecv(4,t2sn(1,1,2),imigr) 
    1951  
    1952     CASE ( 1 ) 
    1953        CALL mppsend(3,t2ns(1,1,1),imigr,noso,0) 
    1954        CALL mpprecv(4,t2sn(1,1,2),imigr) 
    1955     END SELECT 
    19561704#endif 
    19571705 
    … …  
    20121760    CALL mpi_send(pmess,kbytes,mpi_real8,kdest,ktyp,   & 
    20131761         mpi_comm_world,iflag) 
    2014  
    2015 #  else 
    2016     !! * Local variables   ( PVM version) 
    2017     INTEGER :: iflag 
    2018     INTEGER :: itid_dest,info 
    2019  
    2020     itid_dest = npvm_tids(kdest) 
    2021     IF( mppsend_print /= 0 ) THEN 
    2022        WRITE(nummpp,*) 'mytid=',npvm_mytid, ' ========== mppsend ========== ' 
    2023        WRITE(nummpp,*) 'mytid=',npvm_mytid, ' kbytes=',kbytes,' kdest=',kdest   & 
    2024             ,' ktyp=',ktyp,' iflag=',iflag 
    2025     ENDIF 
    2026  
    2027     CALL pvmfinitsend(pvmdataraw, info) 
    2028     CALL pvmfpack( byte1, pmess, kbytes, 1, info ) 
    2029  
    2030     IF( info < 0 ) STOP ' mppsend : problem in pvmfpack ' 
    2031     CALL pvmfsend  ( itid_dest , ktyp , iflag ) 
    2032     IF( iflag < 0 ) STOP ' mppsend : problem in pvmfsend ' 
    2033     IF(mppsend_print /= 0 ) THEN 
    2034        WRITE(nummpp,*) 'mytid=',npvm_mytid,' after:itid_dest=' ,itid_dest,' iflag=',iflag 
    2035     ENDIF 
    2036 #endif 
     1762#endif 
     1763 
    20371764  END SUBROUTINE mppsend 
    20381765 
    … …  
    20611788         mpi_comm_world, istatus, iflag ) 
    20621789 
    2063 #  else 
    2064     !! * Local variables   ( PVM version) 
    2065     INTEGER ::   itid_kexp, info, ibufid 
    2066  
    2067     itid_kexp = -1 
    2068     IF( mpprecv_print /= 0 ) THEN 
    2069        WRITE(nummpp,*) 'mytid=',npvm_mytid, ' ============= mpprecv ============' 
    2070        WRITE(nummpp,*) 'mytid=',npvm_mytid, ' mpprecv, pvmfrecv, itid_kexp=',itid_kexp 
    2071     ENDIF 
    2072     CALL pvmfrecv  ( itid_kexp , ktyp , ibufid ) 
    2073     IF( mpprecv_print /= 0 ) THEN 
    2074        WRITE(nummpp,*) 'mytid=',npvm_mytid,' mpprecv,END pvmfrecv'   & 
    2075             ,'ibufid=',ibufid,' npvm_me=',npvm_me 
    2076     ENDIF 
    2077     CALL pvmfunpack( byte1, pmess, kbytes, 1, info ) 
    2078     IF( info < 0 ) kbytes = info 
    20791790#endif 
    20801791 
    … …  
    20841795  SUBROUTINE mppgather( ptab, kk, kp, pio ) 
    20851796    !!---------------------------------------------------------------------- 
    2086     !!                       routine mppgather 
    2087     !!                     ********************* 
    2088     !! ** Purpose : 
    2089     !!     Transfert between a local subdomain array and a work array  
    2090     !!     which is distributed following the vertical level. 
    2091     !! 
    2092     !! ** Method : 
    2093     !! 
    2094     !!   Input : 
    2095     !!      argument 
    2096     !!           ptab   : subdomain array input 
    2097     !!           kk     : vertical level 
    2098     !!           kp     : record length 
    2099     !! 
    2100     !!   Output : 
    2101     !!      argument  
    2102     !!           pio    : output array 
     1797    !!                   ***  routine mppgather  *** 
     1798    !!                    
     1799    !! ** Purpose :   Transfert between a local subdomain array and a work  
     1800    !!     array which is distributed following the vertical level. 
     1801    !! 
     1802    !! ** Method  : 
    21031803    !! 
    21041804    !!---------------------------------------------------------------------- 
    … …  
    21261826    CALL mpi_gather(ptab,itaille,mpi_real8,pio,itaille   & 
    21271827         ,mpi_real8,kp,mpi_comm_world,ierror)  
    2128 #else 
    2129     !! * Local variables   (PVM version) 
    2130  
    2131     INTEGER :: imess,ic 
    2132     INTEGER :: ji,jj 
    2133     INTEGER :: ii 
    2134  
    2135     IF(jpnij == 1 ) THEN 
    2136        DO jj = 1, jpj 
    2137           DO ji = 1, jpi 
    2138              pio(ji,jj,1) = ptab(ji,jj) 
    2139           END DO 
    2140        END DO 
    2141        RETURN 
    2142     ENDIF 
    2143     CALL mppsync 
    2144     IF( npvm_me /= kp ) THEN  
    2145  
    2146        !     send data to the root member 
    2147  
    2148        imess=kk+ 100000*npvm_me 
    2149        CALL  mppsend(imess,ptab,jpi*jpj*jpbyt,kp,0) 
    2150     ELSE  
    2151  
    2152        !     receive message form other member 
    2153        !     of the group 
    2154  
    2155        DO ji=0,npvm_nproc-1 
    2156           IF  (ji == npvm_me ) THEN  
    2157              pio(:,:,ji+1) = ptab(:,:) 
    2158           ELSE  
    2159              imess=kk+ 100000*ji 
    2160              CALL mpprecv(imess,pio(1,1,ji+1),jpi*jpj*jpbyt) 
    2161           ENDIF 
    2162        END DO 
    2163     ENDIF 
    2164     CALL  mppsync 
    21651828#endif 
    21661829 
    … …  
    22091872         mpi_real8,kp,mpi_comm_world,ierror) 
    22101873 
    2211 #  else 
    2212     !! * Local variables (PVM version) 
    2213     INTEGER :: imess,ic 
    2214     INTEGER :: ji,jj 
    2215  
    2216     IF(jpnij == 1 ) THEN 
    2217        DO jj = 1, jpj 
    2218           DO ji = 1, jpi 
    2219              ptab(ji,jj) = pio(ji,jj,1) 
    2220           END DO 
    2221        END DO 
    2222        RETURN 
    2223     ENDIF 
    2224     CALL  mppsync 
    2225     imess=kk 
    2226     CALL pvmfscatter(ptab,pio,jpi*jpj,jpvmreal,imess,opaall,kp,ic) 
    2227     IF(ic /= 0 ) THEN 
    2228        WRITE(nummpp,*) "problem pvmfscatter  kk=", kk, " kp=", kp 
    2229     ENDIF 
    2230     CALL  mppsync 
    22311874#endif 
    22321875 
    … …  
    22841927 
    22851928#  elif defined key_mpp_mpi 
     1929 
    22861930    !! * Local variables   (MPI version) 
    22871931    LOGICAL  :: lcommute 
    … …  
    22951939    ktab(:) = iwork(:) 
    22961940 
    2297 #  else 
    2298     !! * Local variables   (PVM version) 
    2299     INTEGER :: ityd 
    2300     INTEGER :: info,itype,ibuf,iroot 
    2301     EXTERNAL PvmIsl2 
    2302  
    2303     itype= 100 
    2304     iroot=0 
    2305     ityd=npvm_tids(npvm_me) 
    2306     IF(jpnij == 1) RETURN 
    2307     IF(mppisl_print /= 0 ) THEN 
    2308        WRITE(nummpp,*) 'mppisl_a_int me=',npvm_me,' ityd=',ityd 
    2309     ENDIF 
    2310     CALL pvmfreduce(PvmIsl2, ktab, kdim, jpvmint,   & 
    2311          itype, opaall, iroot,info) 
    2312     IF(iroot == npvm_me ) THEN 
    2313        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    2314        CALL pvmfpack(jpvmint,ktab,kdim,1,info) 
    2315        IF(info /= 0 ) THEN 
    2316           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    2317           STOP 'mppisl_a_int' 
    2318        ENDIF 
    2319        CALL pvmfbcast(opaall,itype+1,info) 
    2320        IF(info /= 0 ) THEN 
    2321           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    2322           STOP 'mppisl_a_int' 
    2323        ENDIF 
    2324     ELSE 
    2325        CALL pvmfrecv(iroot,itype+1,ibuf) 
    2326        CALL pvmfunpack(jpvmint,ktab,kdim,1,info) 
    2327        IF(info /= 0 ) THEN 
    2328           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    2329           STOP 'mppisl_a_int' 
    2330        ENDIF 
    2331     ENDIF 
    2332     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    23331941#endif 
    23341942 
    … …  
    23741982 
    23751983#  elif defined key_mpp_mpi 
     1984 
    23761985    !! * Local variables   (MPI version) 
    23771986    LOGICAL :: lcommute 
    … …  
    23851994    ktab = iwork 
    23861995 
    2387 #  else 
    2388     !! * Local variables   (PVM version) 
    2389     INTEGER :: ityd 
    2390     INTEGER :: info,itype,ibuf,iroot 
    2391     EXTERNAL PvmIsl2 
    2392  
    2393     itype= 100 
    2394     iroot=0 
    2395     ityd=npvm_tids(npvm_me) 
    2396     IF(jpnij == 1) RETURN 
    2397     IF(mppisl_print /= 0 ) THEN 
    2398        WRITE(nummpp,*) 'mppisl_int me=',npvm_me,' ityd=',ityd 
    2399     ENDIF 
    2400     CALL pvmfreduce(PvmIsl2, ktab, 1, jpvmint,   & 
    2401          itype, opaall, iroot,info) 
    2402     IF(iroot == npvm_me ) THEN 
    2403        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    2404        CALL pvmfpack(jpvmint,ktab, 1,1,info) 
    2405        IF(info /= 0 ) THEN 
    2406           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    2407           STOP 'mppisl_int' 
    2408        ENDIF 
    2409        CALL pvmfbcast(opaall,itype+1,info) 
    2410        IF(info /= 0 ) THEN 
    2411           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    2412           STOP 'mppisl_int' 
    2413        ENDIF 
    2414     ELSE 
    2415        CALL pvmfrecv(iroot,itype+1,ibuf) 
    2416        CALL pvmfunpack(jpvmint,ktab, 1,1,info) 
    2417        IF(info /= 0 ) THEN 
    2418           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    2419           STOP 'mppisl_int' 
    2420        ENDIF 
    2421     ENDIF 
    2422     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    24231996#endif 
    24241997 
    24251998  END SUBROUTINE mppisl_int 
    2426  
    2427   SUBROUTINE PvmIsl2( kdtatyp, kx, ky, kdim, knfo ) 
    2428     INTEGER , INTENT( in    ) ::   kdim        ! size of others arguments 
    2429     INTEGER , DIMENSION(kdim), INTENT( inout ) ::   & 
    2430          kx,            & 
    2431          ky 
    2432     INTEGER :: knfo,kdtatyp,ji 
    2433     DO ji = 1, kdim 
    2434        IF(ky(ji) /= 0) kx(ji) = ky(ji) 
    2435     END DO 
    2436   END SUBROUTINE PvmIsl2 
    24371999 
    24382000 
    … …  
    24782040 
    24792041#  elif defined key_mpp_mpi 
     2042 
    24802043    !! * Local variables   (MPI version) 
    24812044    INTEGER :: ierror 
    … …  
    24872050    ktab(:) = iwork(:) 
    24882051 
    2489 #  else 
    2490     !! * Local variables   (PVM version) 
    2491     INTEGER :: ityd 
    2492     INTEGER :: info,itype,ibuf,iroot 
    2493     EXTERNAL PvmMin 
    2494  
    2495     itype= 100 
    2496     iroot=0 
    2497     ityd=npvm_tids(npvm_me) 
    2498     IF(jpnij == 1) RETURN 
    2499     IF(mppmin_print /= 0 ) THEN 
    2500        WRITE(nummpp,*) 'mppmin_a_int me=',npvm_me,' ityd=',ityd 
    2501     ENDIF 
    2502     CALL pvmfreduce(PvmMin,ktab, kdim, jpvmint,   & 
    2503          itype, opaall, iroot, info) 
    2504     IF(iroot == npvm_me ) THEN 
    2505        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    2506        CALL pvmfpack(jpvmint,ktab,kdim,1,info) 
    2507        IF(info /= 0 ) THEN 
    2508           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    2509           STOP 'mppmin_a_int' 
    2510        ENDIF 
    2511        CALL pvmfbcast(opaall,itype+1,info) 
    2512        IF(info /= 0 ) THEN 
    2513           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    2514           STOP 'mppmin_a_int' 
    2515        ENDIF 
    2516     ELSE 
    2517        CALL pvmfrecv(iroot,itype+1,ibuf) 
    2518        CALL pvmfunpack(jpvmint,ktab,kdim,1,info) 
    2519        IF(info /= 0 ) THEN 
    2520           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    2521           STOP 'mppmin_a_int' 
    2522        ENDIF 
    2523     ENDIF 
    2524     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    25252052#endif 
    25262053 
    25272054  END SUBROUTINE mppmin_a_int 
     2055 
    25282056 
    25292057  SUBROUTINE mppmin_int( ktab ) 
    … …  
    25422070 
    25432071#if defined key_mpp_shmem 
     2072 
    25442073    !! * Local variables   (SHMEM version) 
    25452074    INTEGER :: ji 
    … …  
    25612090 
    25622091#  elif defined key_mpp_mpi 
     2092 
    25632093    !! * Local variables   (MPI version) 
    25642094    INTEGER ::  ierror, iwork 
    … …  
    25692099    ktab = iwork 
    25702100 
    2571 #  else 
    2572     !! * Local variables   (PVM version) 
    2573     INTEGER :: ityd 
    2574     INTEGER :: info,itype,ibuf,iroot 
    2575     EXTERNAL PvmMin 
    2576  
    2577     itype= 100 
    2578     iroot=0 
    2579     ityd=npvm_tids(npvm_me) 
    2580     IF(jpnij == 1) RETURN 
    2581     IF(mppmin_print /= 0 ) THEN 
    2582        WRITE(nummpp,*) 'mppmin_int me=',npvm_me,' ityd=',ityd 
    2583     ENDIF 
    2584     CALL pvmfreduce(PvmMin,ktab,  1, jpvmint,   & 
    2585          itype, opaall, iroot, info) 
    2586     IF(iroot == npvm_me ) THEN 
    2587        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    2588        CALL pvmfpack(jpvmint,ktab, 1,1,info) 
    2589        IF(info /= 0 ) THEN 
    2590           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    2591           STOP 'mppmin_int' 
    2592        ENDIF 
    2593        CALL pvmfbcast(opaall,itype+1,info) 
    2594        IF(info /= 0 ) THEN 
    2595           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    2596           STOP 'mppmin_int' 
    2597        ENDIF 
    2598     ELSE 
    2599        CALL pvmfrecv(iroot,itype+1,ibuf) 
    2600        CALL pvmfunpack(jpvmint,ktab, 1,1,info) 
    2601        IF(info /= 0 ) THEN 
    2602           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    2603           STOP 'mppmin_int' 
    2604        ENDIF 
    2605     ENDIF 
    2606     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    26072101#endif 
    26082102 
    26092103  END SUBROUTINE mppmin_int 
     2104 
    26102105 
    26112106  SUBROUTINE mppsum_a_int( ktab, kdim ) 
    … …  
    26212116    INTEGER, INTENT(inout), DIMENSION (kdim) ::   ktab      ! ??? 
    26222117 
    2623  
    26242118#if defined key_mpp_shmem 
     2119 
    26252120    !! * Local variables   (SHMEM version) 
    26262121    INTEGER :: ji 
    … …  
    26522147 
    26532148#  elif defined key_mpp_mpi 
     2149 
    26542150    !! * Local variables   (MPI version) 
    26552151    INTEGER :: ierror 
    … …  
    26612157    ktab(:) = iwork(:) 
    26622158 
    2663 #  else 
    2664     !! * Local variables   (PVM version) 
    2665     INTEGER :: ityd 
    2666     INTEGER :: info,itype,ibuf,iroot 
    2667     EXTERNAL PvmSum 
    2668  
    2669     itype= 100 
    2670     iroot=0 
    2671     ityd=npvm_tids(npvm_me) 
    2672     IF(jpnij == 1) RETURN 
    2673     IF(mppsum_print /= 0 ) THEN 
    2674        WRITE(nummpp,*) 'mppsum_a_int me=',npvm_me,' ityd=',ityd 
    2675     ENDIF 
    2676     CALL pvmfreduce(PvmSum, ktab, kdim, jpvmint,   & 
    2677          itype, opaall, iroot, info) 
    2678     IF(iroot == npvm_me ) THEN 
    2679        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    2680        CALL pvmfpack(jpvmint,ktab,kdim,1,info) 
    2681        IF(info /= 0 ) THEN 
    2682           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    2683           STOP 'mppsum_a_int' 
    2684        ENDIF 
    2685        CALL pvmfbcast(opaall,itype+1,info) 
    2686        IF(info /= 0 ) THEN 
    2687           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    2688           STOP 'mppsum_a_int' 
    2689        ENDIF 
    2690     ELSE 
    2691        CALL pvmfrecv(iroot,itype+1,ibuf) 
    2692        CALL pvmfunpack(jpvmint,ktab,kdim,1,info) 
    2693        IF(info /= 0 ) THEN 
    2694           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    2695           STOP 'mppsum_a_int' 
    2696        ENDIF 
    2697     ENDIF 
    2698     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    2699  
    27002159#endif 
    27012160 
    27022161  END SUBROUTINE mppsum_a_int 
     2162 
    27032163 
    27042164  SUBROUTINE mppsum_int( ktab ) 
    … …  
    27132173 
    27142174#if defined key_mpp_shmem 
     2175 
    27152176    !! * Local variables   (SHMEM version) 
    27162177    INTEGER, SAVE :: ibool=0 
    … …  
    27292190    ibool=MOD( ibool,2) 
    27302191    ktab = nistab_shmem(1) 
    2731     !  
     2192 
    27322193#  elif defined key_mpp_mpi 
     2194 
    27332195    !! * Local variables   (MPI version) 
    27342196    INTEGER :: ierror, iwork 
    … …  
    27382200 
    27392201    ktab = iwork 
    2740  
    2741 #  else 
    2742     !! * Local variables   (PVM version) 
    2743     INTEGER :: ityd 
    2744     INTEGER :: info,itype,ibuf,iroot 
    2745     EXTERNAL PvmSum 
    2746  
    2747     itype= 100 
    2748     iroot=0 
    2749     ityd=npvm_tids(npvm_me) 
    2750     IF(jpnij == 1) RETURN 
    2751     IF(mppsum_print /= 0 ) THEN 
    2752        WRITE(nummpp,*) 'mppsum_int me=',npvm_me,' ityd=',ityd 
    2753     ENDIF 
    2754     CALL pvmfreduce(PvmSum, ktab,  1, jpvmint,   & 
    2755          itype, opaall, iroot, info) 
    2756     IF(iroot == npvm_me ) THEN 
    2757        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    2758        CALL pvmfpack(jpvmint,ktab, 1,1,info) 
    2759        IF(info /= 0 ) THEN 
    2760           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    2761           STOP 'mppsum_int' 
    2762        ENDIF 
    2763        CALL pvmfbcast(opaall,itype+1,info) 
    2764        IF(info /= 0 ) THEN 
    2765           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    2766           STOP 'mppsum_int' 
    2767        ENDIF 
    2768     ELSE 
    2769        CALL pvmfrecv(iroot,itype+1,ibuf) 
    2770        CALL pvmfunpack(jpvmint,ktab, 1,1,info) 
    2771        IF(info /= 0 ) THEN 
    2772           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    2773           STOP 'mppsum_int' 
    2774        ENDIF 
    2775     ENDIF 
    2776     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    27772202 
    27782203#endif 
    … …  
    27972222 
    27982223#if defined key_mpp_shmem 
     2224 
    27992225    !! * Local variables   (SHMEM version) 
    28002226    INTEGER :: ji 
    … …  
    28342260 
    28352261#  elif defined key_mpp_mpi 
     2262 
    28362263    !! * Local variables   (MPI version) 
    28372264    LOGICAL ::   lcommute = .TRUE. 
    … …  
    28442271    ptab(:) = zwork(:) 
    28452272 
    2846 #  else 
    2847     !! * Local variables   (PVM version) 
    2848     INTEGER :: ityd 
    2849     INTEGER :: info,itype,ibuf,iroot 
    2850     EXTERNAL PvmIsl 
    2851  
    2852     itype= 100 
    2853     iroot=0 
    2854     ityd=npvm_tids(npvm_me) 
    2855     IF(jpnij == 1) RETURN 
    2856     IF(mppisl_print /= 0 ) THEN 
    2857        WRITE(nummpp,*) 'mppisl_a_real me=',npvm_me,' ityd=',ityd 
    2858     ENDIF 
    2859     CALL pvmfreduce(PvmIsl, ptab, kdim, jpvmreal,   & 
    2860          itype, opaall, iroot,info) 
    2861     IF(iroot == npvm_me ) THEN 
    2862        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    2863        CALL pvmfpack(jpvmreal,ptab,kdim,1,info) 
    2864        IF(info /= 0 ) THEN 
    2865           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    2866           STOP 'mppisl_a_real' 
    2867        ENDIF 
    2868        CALL pvmfbcast(opaall,itype+1,info) 
    2869        IF(info /= 0 ) THEN 
    2870           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    2871           STOP 'mppisl_a_real' 
    2872        ENDIF 
    2873     ELSE 
    2874        CALL pvmfrecv(iroot,itype+1,ibuf) 
    2875        CALL pvmfunpack(jpvmreal,ptab,kdim,1,info) 
    2876        IF(info /= 0 ) THEN 
    2877           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    2878           STOP 'mppisl_a_real' 
    2879        ENDIF 
    2880     ENDIF 
    2881     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    28822273#endif 
    28832274 
    28842275  END SUBROUTINE mppisl_a_real 
    28852276 
    2886   SUBROUTINE mppisl_real( ptab ) 
    2887     !!---------------------------------------------------------------------- 
    2888     !!                  ***  routine mppisl_real  *** 
    2889     !!                   
    2890     !! ** Purpose :   Massively parallel processors 
    2891     !!     Find the  non zero island barotropic stream function value 
    2892     !! 
    2893     !!   Modifications: 
    2894     !!        !  93-09 (M. Imbard) 
    2895     !!        !  96-05 (j. Escobar) 
    2896     !!        !  98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI  
    2897     !!---------------------------------------------------------------------- 
    2898     REAL(wp), INTENT(inout) ::   ptab 
     2277 
     2278   SUBROUTINE mppisl_real( ptab ) 
     2279      !!---------------------------------------------------------------------- 
     2280      !!                  ***  routine mppisl_real  *** 
     2281      !!                   
     2282      !! ** Purpose :   Massively parallel processors 
     2283      !!       Find the  non zero island barotropic stream function value 
     2284      !! 
     2285      !!     Modifications: 
     2286      !!        !  93-09 (M. Imbard) 
     2287      !!        !  96-05 (j. Escobar) 
     2288      !!        !  98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI  
     2289      !!---------------------------------------------------------------------- 
     2290      REAL(wp), INTENT(inout) ::   ptab 
    28992291 
    29002292#if defined key_mpp_shmem 
    2901     !! * Local variables   (SHMEM version) 
    2902     INTEGER, SAVE :: ibool=0 
    2903  
    2904     wiltab_shmem(1) = ptab 
    2905     CALL  barrier() 
    2906     IF(ibool == 0 ) THEN  
    2907        CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0   & 
     2293 
     2294      !! * Local variables   (SHMEM version) 
     2295      INTEGER, SAVE :: ibool=0 
     2296 
     2297      wiltab_shmem(1) = ptab 
     2298      CALL  barrier() 
     2299      IF(ibool == 0 ) THEN  
     2300         CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0   & 
    29082301            ,0,N$PES,wi11wrk_shmem,ni11sync_shmem) 
    2909        CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0   & 
     2302         CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0   & 
    29102303            ,0,N$PES,wi12wrk_shmem,ni12sync_shmem) 
    2911     ELSE 
    2912        CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0   & 
     2304      ELSE 
     2305         CALL shmem_real8_min_to_all (wi1tab_shmem,wiltab_shmem, 1,0   & 
    29132306            ,0,N$PES,wi21wrk_shmem,ni21sync_shmem) 
    2914        CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0   & 
     2307         CALL shmem_real8_max_to_all (wi2tab_shmem,wiltab_shmem, 1,0   & 
    29152308            ,0,N$PES,wi22wrk_shmem,ni22sync_shmem) 
    2916     ENDIF 
    2917     CALL  barrier() 
    2918     ibool=ibool+1 
    2919     ibool=MOD( ibool,2) 
    2920     IF(wi1tab_shmem(1) /= 0. ) THEN 
    2921        ptab = wi1tab_shmem(1) 
    2922     ELSE 
    2923        ptab = wi2tab_shmem(1) 
    2924     ENDIF 
     2309      ENDIF 
     2310      CALL  barrier() 
     2311      ibool=ibool+1 
     2312      ibool=MOD( ibool,2) 
     2313      IF(wi1tab_shmem(1) /= 0. ) THEN 
     2314         ptab = wi1tab_shmem(1) 
     2315      ELSE 
     2316         ptab = wi2tab_shmem(1) 
     2317      ENDIF 
    29252318 
    29262319#  elif defined key_mpp_mpi 
    2927     !! * Local variables   (MPI version) 
    2928     LOGICAL  ::   lcommute = .TRUE. 
    2929     INTEGER  ::   mpi_isl, ierror 
    2930     REAL(wp) ::   zwork 
    2931  
    2932     CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror) 
    2933     CALL mpi_allreduce(ptab, zwork, 1,mpi_real8   & 
     2320 
     2321      !! * Local variables   (MPI version) 
     2322      LOGICAL  ::   lcommute = .TRUE. 
     2323      INTEGER  ::   mpi_isl, ierror 
     2324      REAL(wp) ::   zwork 
     2325 
     2326      CALL mpi_op_create(lc_isl,lcommute,mpi_isl,ierror) 
     2327      CALL mpi_allreduce(ptab, zwork, 1,mpi_real8   & 
    29342328         &               ,mpi_isl,mpi_comm_world,ierror) 
    2935     ptab = zwork 
    2936  
    2937 #  else 
    2938     !! * Local variables   (PVM version) 
    2939     INTEGER :: ityd 
    2940     INTEGER :: info,itype,ibuf,iroot 
    2941     EXTERNAL PvmIsl 
    2942  
    2943     itype= 100 
    2944     iroot=0 
    2945     ityd=npvm_tids(npvm_me) 
    2946     IF(jpnij == 1) RETURN 
    2947     IF(mppisl_print /= 0 ) THEN 
    2948        WRITE(nummpp,*) 'mppisl_real me=',npvm_me,' ityd=',ityd 
    2949     ENDIF 
    2950     CALL pvmfreduce(PvmIsl, ptab,  1, jpvmreal,   & 
    2951          itype, opaall, iroot,info) 
    2952     IF(iroot == npvm_me ) THEN 
    2953        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    2954        CALL pvmfpack(jpvmreal,ptab, 1,1,info) 
    2955        IF(info /= 0 ) THEN 
    2956           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    2957           STOP 'mppisl_real' 
    2958        ENDIF 
    2959        CALL pvmfbcast(opaall,itype+1,info) 
    2960        IF(info /= 0 ) THEN 
    2961           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    2962           STOP 'mppisl_real' 
    2963        ENDIF 
    2964     ELSE 
    2965        CALL pvmfrecv(iroot,itype+1,ibuf) 
    2966        CALL pvmfunpack(jpvmreal,ptab, 1,1,info) 
    2967        IF(info /= 0 ) THEN 
    2968           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    2969           STOP 'mppisl_real' 
    2970        ENDIF 
    2971     ENDIF 
    2972     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    2973 #endif 
    2974  
    2975   END SUBROUTINE mppisl_real 
    2976   !CCMPPJM end 
    2977  
    2978   SUBROUTINE PvmIsl( kdtatyp, px, py, kdim, knfo ) 
    2979     INTEGER :: kdim 
    2980     REAL(wp),DIMENSION(kdim) ::  px,py 
    2981     INTEGER :: knfo,kdtatyp,ji 
    2982     DO ji = 1, kdim 
    2983        IF(py(ji) /= 0.) px(ji) = py(ji) 
    2984     END DO 
    2985   END SUBROUTINE PvmIsl 
     2329      ptab = zwork 
     2330 
     2331#endif 
     2332 
     2333   END SUBROUTINE mppisl_real 
    29862334 
    29872335 
    29882336  FUNCTION lc_isl( py, px, kdim, kdtatyp ) 
    29892337    INTEGER :: kdim 
    2990     REAL(wp),DIMENSION(kdim) ::  px,py 
    2991     INTEGER :: kdtatyp,ji 
     2338    REAL(wp), DIMENSION(kdim) ::  px, py 
     2339    INTEGER :: kdtatyp, ji 
    29922340    INTEGER :: lc_isl 
    29932341    DO ji = 1, kdim 
    2994        IF(py(ji) /= 0.) px(ji) = py(ji) 
     2342       IF( py(ji) /= 0. )  px(ji) = py(ji) 
    29952343    END DO 
    29962344    lc_isl=0 
    … …  
    30112359 
    30122360#if defined key_mpp_shmem 
     2361 
    30132362    !! * Local variables   (SHMEM version) 
    30142363    INTEGER :: ji 
    … …  
    30402389 
    30412390#  elif defined key_mpp_mpi 
     2391 
    30422392    !! * Local variables   (MPI version) 
    30432393    INTEGER :: ierror 
    … …  
    30482398    ptab(:) = zwork(:) 
    30492399 
    3050 #  else 
    3051     !! * Local variables   (PVM version) 
    3052     INTEGER :: ityd 
    3053     INTEGER :: info,itype,ibuf,iroot 
    3054     EXTERNAL PvmMax 
    3055  
    3056     itype= 100 
    3057     iroot=0 
    3058     ityd=npvm_tids(npvm_me) 
    3059     IF(jpnij  ==  1) RETURN 
    3060     IF(mppmax_print /= 0 ) THEN 
    3061        WRITE(nummpp,*) 'mppmax_a_real me=',npvm_me,' ityd=',ityd 
    3062     ENDIF 
    3063     CALL pvmfreduce(PvmMax, ptab, kdim, jpvmreal,   & 
    3064          itype, opaall, iroot, info) 
    3065     IF(iroot  ==  npvm_me ) THEN 
    3066        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    3067        CALL pvmfpack(jpvmreal,ptab,kdim,1,info) 
    3068        IF(info /= 0 ) THEN 
    3069           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    3070           STOP 'mppmax_a_real' 
    3071        ENDIF 
    3072        CALL pvmfbcast(opaall,itype+1,info) 
    3073        IF(info /= 0 ) THEN 
    3074           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    3075           STOP 'mppmax_a_real' 
    3076        ENDIF 
    3077     ELSE 
    3078        CALL pvmfrecv(iroot,itype+1,ibuf) 
    3079        CALL pvmfunpack(jpvmreal,ptab, 1,1,info) 
    3080        IF(info /= 0 ) THEN 
    3081           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    3082           STOP 'mppmax_a_real' 
    3083        ENDIF 
    3084     ENDIF 
    3085     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    3086  
    30872400#endif 
    30882401 
    30892402  END SUBROUTINE mppmax_a_real 
     2403 
    30902404 
    30912405  SUBROUTINE mppmax_real( ptab ) 
    … …  
    31002414 
    31012415#if defined key_mpp_shmem 
     2416 
    31022417    !! * Local variables   (SHMEM version) 
    31032418    INTEGER, SAVE :: ibool=0 
    … …  
    31182433 
    31192434#  elif defined key_mpp_mpi 
     2435 
    31202436    !! * Local variables   (MPI version) 
    31212437    INTEGER  ::   ierror 
    … …  
    31252441         ,mpi_max,mpi_comm_world,ierror) 
    31262442    ptab = zwork 
    3127  
    3128 #  else 
    3129     !! * Local variables   (PVM version) 
    3130     INTEGER :: ityd 
    3131     INTEGER :: info,itype,ibuf,iroot 
    3132     EXTERNAL PvmMax 
    3133  
    3134     itype= 100 
    3135     iroot=0 
    3136     ityd=npvm_tids(npvm_me) 
    3137     IF(jpnij  ==  1) RETURN 
    3138     IF(mppmax_print /= 0 ) THEN 
    3139        WRITE(nummpp,*) 'mppmax_real me=',npvm_me,' ityd=',ityd 
    3140     ENDIF 
    3141     CALL pvmfreduce(PvmMax, ptab,  1, jpvmreal,   & 
    3142          itype, opaall, iroot, info) 
    3143     IF(iroot  ==  npvm_me ) THEN 
    3144        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    3145        CALL pvmfpack(jpvmreal,ptab, 1,1,info) 
    3146        IF(info /= 0 ) THEN 
    3147           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    3148           STOP 'mppmax_real' 
    3149        ENDIF 
    3150        CALL pvmfbcast(opaall,itype+1,info) 
    3151        IF(info /= 0 ) THEN 
    3152           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    3153           STOP 'mppmax_real' 
    3154        ENDIF 
    3155     ELSE 
    3156        CALL pvmfrecv(iroot,itype+1,ibuf) 
    3157        CALL pvmfunpack(jpvmreal,ptab, 1,1,info) 
    3158        IF(info /= 0 ) THEN 
    3159           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    3160           STOP 'mppmax_real' 
    3161        ENDIF 
    3162     ENDIF 
    3163     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    31642443 
    31652444#endif 
    … …  
    31802459 
    31812460#if defined key_mpp_shmem 
     2461 
    31822462    !! * Local variables   (SHMEM version) 
    31832463    INTEGER :: ji 
    … …  
    32092489 
    32102490#  elif defined key_mpp_mpi 
     2491 
    32112492    !! * Local variables   (MPI version) 
    32122493    INTEGER :: ierror 
    … …  
    32162497         ,mpi_min,mpi_comm_world,ierror) 
    32172498    ptab(:) = zwork(:) 
    3218  
    3219 #  else 
    3220     !! * Local variables   (PVM version) 
    3221     INTEGER :: ityd 
    3222     INTEGER :: info,itype,ibuf,iroot 
    3223     EXTERNAL PvmMin 
    3224  
    3225     itype= 100 
    3226     iroot=0 
    3227     ityd=npvm_tids(npvm_me) 
    3228     IF(jpnij  ==  1) RETURN 
    3229     IF(mppmin_print /= 0 ) THEN 
    3230        WRITE(nummpp,*) 'mpprmin me=',npvm_me,' ityd=',ityd 
    3231     ENDIF 
    3232     CALL pvmfreduce(PvmMin, ptab, kdim, jpvmreal,   & 
    3233          itype, opaall, iroot, info) 
    3234     IF(iroot  ==  npvm_me ) THEN 
    3235        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    3236        CALL pvmfpack(jpvmreal,ptab,kdim,1,info) 
    3237        IF(info /= 0 ) THEN 
    3238           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    3239           STOP 'mpprmin' 
    3240        ENDIF 
    3241        CALL pvmfbcast(opaall,itype+1,info) 
    3242        IF(info /= 0 ) THEN 
    3243           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    3244           STOP 'mpprmin' 
    3245        ENDIF 
    3246     ELSE 
    3247        CALL pvmfrecv(iroot,itype+1,ibuf) 
    3248        CALL pvmfunpack(jpvmreal,ptab,kdim,1,info) 
    3249        IF(info /= 0 ) THEN 
    3250           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    3251           STOP 'mpprmin' 
    3252        ENDIF 
    3253     ENDIF 
    3254     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    32552499 
    32562500#endif 
    … …  
    32712515 
    32722516#if defined key_mpp_shmem 
     2517 
    32732518    !! * Local variables   (SHMEM version) 
    32742519    INTEGER, SAVE :: ibool=0 
    … …  
    32892534 
    32902535#  elif defined key_mpp_mpi 
     2536 
    32912537    !! * Local variables   (MPI version) 
    32922538    INTEGER  ::   ierror 
    … …  
    32962542         &               ,mpi_min,mpi_comm_world,ierror) 
    32972543    ptab = zwork 
    3298  
    3299 #  else 
    3300     !! * Local variables   (PVM version) 
    3301     INTEGER :: ityd 
    3302     INTEGER :: info,itype,ibuf,iroot 
    3303     EXTERNAL PvmMin 
    3304  
    3305     itype= 100 
    3306     iroot=0 
    3307     ityd=npvm_tids(npvm_me) 
    3308     IF(jpnij  ==  1) RETURN 
    3309     IF(mppmin_print /= 0 ) THEN 
    3310        WRITE(nummpp,*) 'mpprmin me=',npvm_me,' ityd=',ityd 
    3311     ENDIF 
    3312     CALL pvmfreduce(PvmMin, ptab,  1, jpvmreal,   & 
    3313          itype, opaall, iroot, info) 
    3314     IF(iroot  ==  npvm_me ) THEN 
    3315        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    3316        CALL pvmfpack(jpvmreal,ptab, 1,1,info) 
    3317        IF(info /= 0 ) THEN 
    3318           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    3319           STOP 'mpprmin' 
    3320        ENDIF 
    3321        CALL pvmfbcast(opaall,itype+1,info) 
    3322        IF(info /= 0 ) THEN 
    3323           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    3324           STOP 'mpprmin' 
    3325        ENDIF 
    3326     ELSE 
    3327        CALL pvmfrecv(iroot,itype+1,ibuf) 
    3328        CALL pvmfunpack(jpvmreal,ptab, 1,1,info) 
    3329        IF(info /= 0 ) THEN 
    3330           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    3331           STOP 'mpprmin' 
    3332        ENDIF 
    3333     ENDIF 
    3334     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    33352544 
    33362545#endif 
    … …  
    33512560 
    33522561#if defined key_mpp_shmem 
     2562 
    33532563    !! * Local variables   (SHMEM version) 
    33542564    INTEGER :: ji 
    … …  
    33802590 
    33812591#  elif defined key_mpp_mpi 
     2592 
    33822593    !! * Local variables   (MPI version) 
    33832594    INTEGER                   ::   ierror    ! temporary integer 
    … …  
    33872598         &              ,mpi_sum,mpi_comm_world,ierror) 
    33882599    ptab(:) = zwork(:) 
    3389  
    3390 #  else 
    3391     !! * Local variables   (PVM version) 
    3392     INTEGER :: ityd 
    3393     INTEGER :: info,itype,ibuf,iroot 
    3394     EXTERNAL PvmSum 
    3395  
    3396     itype= 100 
    3397     iroot=0 
    3398     ityd=npvm_tids(npvm_me) 
    3399     IF(jpnij == 1) RETURN 
    3400     IF(mppsum_print /= 0 ) THEN 
    3401        WRITE(nummpp,*) 'mppsum_a_real me=',npvm_me,' ityd=',ityd 
    3402     ENDIF 
    3403     CALL pvmfreduce(PvmSum, ptab, kdim, jpvmreal,   & 
    3404          itype, opaall, iroot, info) 
    3405     IF(iroot == npvm_me ) THEN 
    3406        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    3407        CALL pvmfpack(jpvmreal,ptab,kdim,1,info) 
    3408        IF(info /= 0 ) THEN 
    3409           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    3410           STOP 'mppsum_a_real' 
    3411        ENDIF 
    3412        CALL pvmfbcast(opaall,itype+1,info) 
    3413        IF(info /= 0 ) THEN 
    3414           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    3415           STOP 'mppsum_a_real' 
    3416        ENDIF 
    3417     ELSE 
    3418        CALL pvmfrecv(iroot,itype+1,ibuf) 
    3419        CALL pvmfunpack(jpvmreal,ptab,kdim,1,info) 
    3420        IF(info /= 0 ) THEN 
    3421           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    3422           STOP 'mppsum_a_real' 
    3423        ENDIF 
    3424     ENDIF 
    3425     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    34262600 
    34272601#endif 
    … …  
    34412615 
    34422616#if defined key_mpp_shmem 
     2617 
    34432618    !! * Local variables   (SHMEM version) 
    34442619    INTEGER, SAVE :: ibool=0 
    … …  
    34592634 
    34602635#  elif defined key_mpp_mpi 
     2636 
    34612637    !! * Local variables   (MPI version) 
    34622638    INTEGER  ::   ierror 
    … …  
    34672643    ptab = zwork 
    34682644 
    3469 #  else 
    3470     !! * Local variables   (PVM version) 
    3471     INTEGER :: ityd 
    3472     INTEGER :: info,itype,ibuf,iroot 
    3473     EXTERNAL PvmSum 
    3474  
    3475     itype= 100 
    3476     iroot=0 
    3477     ityd=npvm_tids(npvm_me) 
    3478     IF(jpnij == 1) RETURN 
    3479     IF(mppsum_print /= 0 ) THEN 
    3480        WRITE(nummpp,*) 'mppsum_real me=',npvm_me,' ityd=',ityd 
    3481     ENDIF 
    3482     CALL pvmfreduce(PvmSum, ptab, 1, jpvmreal,   & 
    3483          itype, opaall, iroot, info) 
    3484     IF(iroot == npvm_me ) THEN 
    3485        CALL pvmfinitsend(pvmdataraw, ibuf ) 
    3486        CALL pvmfpack(jpvmreal,ptab,1,1,info) 
    3487        IF(info /= 0 ) THEN 
    3488           WRITE(nummpp,*) 'me=',npvm_me,' pvmfpack problem' 
    3489           STOP 'mppsum_real' 
    3490        ENDIF 
    3491        CALL pvmfbcast(opaall,itype+1,info) 
    3492        IF(info /= 0 ) THEN 
    3493           WRITE(nummpp,*) 'me=',npvm_me,' pvmfbcast problem' 
    3494           STOP 'mppsum_real' 
    3495        ENDIF 
    3496     ELSE 
    3497        CALL pvmfrecv(iroot,itype+1,ibuf) 
    3498        CALL pvmfunpack(jpvmreal,ptab, 1,1,info) 
    3499        IF(info /= 0 ) THEN 
    3500           WRITE(nummpp,*) 'me=',npvm_me,' pvmfunpack problem' 
    3501           STOP 'mppsum_real' 
    3502        ENDIF 
    3503     ENDIF 
    3504     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    3505  
    35062645#endif 
    35072646 
    … …  
    35182657 
    35192658#if defined key_mpp_shmem 
     2659 
    35202660    !! * Local variables   (SHMEM version) 
    35212661    CALL barrier() 
    35222662 
    35232663#  elif defined key_mpp_mpi 
     2664 
    35242665    !! * Local variables   (MPI version) 
    35252666    INTEGER :: ierror 
    … …  
    35272668    CALL mpi_barrier(mpi_comm_world,ierror) 
    35282669 
    3529 #  else 
    3530     !! * Local variables   (PVM version) 
    3531     INTEGER :: info 
    3532  
    3533     IF(jpnij == 1) RETURN 
    3534     IF(mppsync_print /= 0 ) THEN 
    3535        WRITE(nummpp,*) 'mppsync me=',npvm_me 
    3536     ENDIF 
    3537     CALL pvmfbarrier(opaall,npvm_nproc,info) 
    3538     IF(info /= 0 ) THEN 
    3539        WRITE(nummpp,*) 'me=',npvm_me,' barrier problem' 
    3540        STOP 'mppsync' 
    3541     ENDIF 
    35422670#endif 
    35432671 
    … …  
    35522680    !! 
    35532681    !!---------------------------------------------------------------------- 
     2682    !! * Modules used 
     2683    USE cpl_oce        ! ??? 
     2684    USE dtatem         ! ??? 
     2685    USE dtasal         ! ??? 
     2686    USE dtasst         ! ??? 
     2687 
    35542688    !! * Local declarations 
    35552689    INTEGER :: info 
    … …  
    35872721    CLOSE( numwri ) 
    35882722    CALL mppsync 
    3589 #    if defined key_mpp_mpi 
     2723#if defined key_mpp_mpi 
    35902724    CALL mpi_finalize(info) 
    3591 #      else 
    3592     CALL pvmfexit( info ) 
    3593 #    endif 
     2725#endif 
    35942726 
    35952727  END SUBROUTINE mppstop 
    … …  
    36322764    INTEGER  ::   ji, jj, jk, jl   ! dummy loop indices 
    36332765    INTEGER  ::   & 
    3634          iipt0, iipt1, ii, ilpt1, &  ! temporary integers 
    3635          ijpt0, ijpt1, ij,        &  !    "          " 
     2766         iipt0, iipt1, ilpt1,    &  ! temporary integers 
     2767         ijpt0, ijpt1,            &  !    "          " 
    36362768         imigr, iihom, ijhom         !    "          " 
    36372769    REAL(wp), DIMENSION(jpi,jpj) ::   & 
    … …  
    37262858          CALL mpprecv(2,t2we(1,1,2),imigr) 
    37272859       ENDIF 
    3728  
    3729 # else 
    3730        !! *  (PVM version) 
    3731  
    3732        imigr=jpreci*jpj*jpbyt 
    3733  
    3734        IF( nbondi == -1 ) THEN 
    3735           CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 
    3736           CALL mpprecv(1,t2ew(1,1,2),imigr) 
    3737        ELSEIF( nbondi == 0 ) THEN 
    3738           CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 
    3739           CALL mppsend(2,t2we(1,1,1),imigr,noea,0) 
    3740           CALL mpprecv(1,t2ew(1,1,2),imigr) 
    3741           CALL mpprecv(2,t2we(1,1,2),imigr) 
    3742        ELSEIF( nbondi == 1 ) THEN 
    3743           CALL mppsend(1,t2ew(1,1,1),imigr,nowe,0) 
    3744           CALL mpprecv(2,t2we(1,1,2),imigr) 
    3745        ENDIF 
    3746  
    37472860#endif 
    37482861 
    … …  
    38132926       ENDIF 
    38142927 
    3815 #else 
    3816        !! * (PVM version) 
    3817  
    3818        imigr=jprecj*jpi*jpbyt 
    3819  
    3820        IF( nbondj == -1 ) THEN 
    3821           CALL mppsend( 4, t2sn(1,1,1), imigr, nono, 0 ) 
    3822           CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
    3823        ELSEIF( nbondj == 0 ) THEN 
    3824           CALL mppsend( 3, t2ns(1,1,1), imigr, noso, 0 ) 
    3825           CALL mppsend( 4, t2sn(1,1,1), imigr, nono, 0 ) 
    3826           CALL mpprecv( 3, t2ns(1,1,2), imigr ) 
    3827           CALL mpprecv( 4, t2sn(1,1,2), imigr ) 
    3828        ELSEIF( nbondj == 1 ) THEN 
    3829           CALL mppsend( 3, t2ns(1,1,1), imigr, noso, 0 ) 
    3830           CALL mpprecv( 4, t2sn(1,1,2), imigr ) 
    3831        ENDIF 
    3832  
    38332928#endif 
    38342929 
    … …  
    38682963  END SUBROUTINE mppobc 
    38692964 
     2965 
    38702966  SUBROUTINE mpp_ini_north 
    38712967    !!---------------------------------------------------------------------- 
    38722968    !!               ***  routine mpp_ini_north  *** 
    38732969 
    3874     !! ** Purpose : 
    3875     !!      Initialize special communicator for north folding condition 
    3876     !!      together with global variables needed in the mpp folding 
    3877     !! 
    3878     !! ** Method : 
    3879     !!       Look for northern processors 
    3880     !!       Put their number in nrank_north 
    3881     !!       Create groups for the world processors and the north processors 
    3882     !!       Create a communicator for northern processors 
    3883     !! 
    3884     !! ** input 
    3885     !!      none 
    3886     !!  
     2970    !! ** Purpose :   Initialize special communicator for north folding  
     2971    !!      condition together with global variables needed in the mpp folding 
     2972    !! 
     2973    !! ** Method  : - Look for northern processors 
     2974    !!              - Put their number in nrank_north 
     2975    !!              - Create groups for the world processors and the north processors 
     2976    !!              - Create a communicator for northern processors 
     2977    !! 
    38872978    !! ** output 
    38882979    !!      njmppmax = njmpp for northern procs 
    … …  
    38972988    !!        !  03-09 (J.M. Molines, MPI only ) 
    38982989    !!---------------------------------------------------------------------- 
    3899  
    39002990#ifdef key_mpp_shmem 
    39012991    IF (lwp) THEN 
    … …  
    39072997    INTEGER :: jproc 
    39082998    INTEGER :: ii,ji 
    3909  
     2999    !!---------------------------------------------------------------------- 
    39103000 
    39113001    njmppmax=MAXVAL(njmppt) 
    … …  
    39293019    ! 
    39303020    ii=0 
    3931     DO ji=1,jpnij 
     3021    DO ji = 1, jpnij 
    39323022       IF ( njmppt(ji) == njmppmax   ) THEN 
    39333023          ii=ii+1 
    … …  
    39493039    ! find proc number in the world of proc 0 in the north 
    39503040    CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_north,1,0,ngrp_world,north_root,ierr) 
    3951  
    3952 # else 
    3953     ! PVM 
    3954     IF (lwp) THEN 
    3955        WRITE(numout,*) ' mpp_ini_north not available in PVM' 
    3956        STOP 
    3957     ENDIF 
    3958 #endif 
     3041#endif 
     3042 
    39593043  END SUBROUTINE mpp_ini_north 
    39603044 
    … …  
    40223106 
    40233107 
    4024  
    40253108    IF (npolj /= 0 ) THEN 
    40263109       ! Build in proc 0 of ncomm_north the znorthgloio 
    … …  
    40323115       itaille=jpi*jpk*ijpj 
    40333116       CALL MPI_GATHER(znorthloc,itaille,MPI_REAL8,znorthgloio,itaille,MPI_REAL8,0,ncomm_north,ierr) 
    4034 #else 
    4035        not done : compiler error 
    40363117#endif 
    40373118 
    … …  
    41963277       CALL MPI_SCATTER(znorthgloio,itaille,MPI_REAL8,znorthloc,itaille,MPI_REAL8,0,ncomm_north,ierr) 
    41973278    ENDIF 
    4198 #else 
    4199     not done yet in PVM 
    42003279#endif 
    42013280 
    … …  
    42833362       itaille=jpi*ijpj 
    42843363       CALL MPI_GATHER(znorthloc,itaille,MPI_REAL8,znorthgloio,itaille,MPI_REAL8,0,ncomm_north,ierr) 
    4285 #else 
    4286        not done : compiler error 
    42873364#endif 
    42883365 
    … …  
    44043481       CASE DEFAULT                           ! *  closed : the code probably never go through 
    44053482 
    4406           SELECT CASE ( cd_type)  
    4407  
    4408           CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
    4409              ztab(:, 1 ) = 0.e0 
    4410              ztab(:,ijpj) = 0.e0 
    4411  
    4412           CASE ( 'F' )                               ! F-point 
    4413              ztab(:,ijpj) = 0.e0 
    4414  
    4415           CASE ( 'I' )                                  ! ice U-V point 
    4416              ztab(:, 1 ) = 0.e0 
    4417              ztab(:,ijpj) = 0.e0 
    4418  
    4419           END SELECT 
    4420  
    4421        END SELECT 
    4422  
    4423        !     End of slab 
    4424        !     =========== 
    4425  
    4426        !! Scatter back to pt2d 
    4427        DO jr = 1, ndim_rank_north 
    4428           jproc=nrank_north(jr)+1 
    4429           ildi=nldit (jproc) 
    4430           ilei=nleit (jproc) 
    4431           iilb=nimppt(jproc) 
    4432           DO jj=1,ijpj 
    4433              DO ji=ildi,ilei 
    4434                 znorthgloio(ji,jj,jr)=ztab(ji+iilb-1,jj) 
    4435              END DO 
    4436           END DO 
    4437        END DO 
    4438  
    4439     ENDIF      ! only done on proc 0 of ncomm_north 
     3483            SELECT CASE ( cd_type)  
     3484   
     3485            CASE ( 'T' , 'U' , 'V' , 'W' )             ! T-, U-, V-, W-points 
     3486               ztab(:, 1 ) = 0.e0 
     3487               ztab(:,ijpj) = 0.e0 
     3488 
     3489            CASE ( 'F' )                               ! F-point 
     3490               ztab(:,ijpj) = 0.e0 
     3491 
     3492            CASE ( 'I' )                                  ! ice U-V point 
     3493               ztab(:, 1 ) = 0.e0 
     3494               ztab(:,ijpj) = 0.e0 
     3495 
     3496            END SELECT 
     3497 
     3498         END SELECT 
     3499 
     3500         !     End of slab 
     3501         !     =========== 
     3502 
     3503         !! Scatter back to pt2d 
     3504         DO jr = 1, ndim_rank_north 
     3505            jproc=nrank_north(jr)+1 
     3506            ildi=nldit (jproc) 
     3507            ilei=nleit (jproc) 
     3508            iilb=nimppt(jproc) 
     3509            DO jj=1,ijpj 
     3510               DO ji=ildi,ilei 
     3511                  znorthgloio(ji,jj,jr)=ztab(ji+iilb-1,jj) 
     3512               END DO 
     3513            END DO 
     3514         END DO 
     3515 
     3516      ENDIF      ! only done on proc 0 of ncomm_north 
    44403517 
    44413518#ifdef key_mpp_shmem 
    4442     not done yet in shmem : compiler error 
     3519      not done yet in shmem : compiler error 
    44433520#elif key_mpp_mpi 
    4444     IF ( npolj /= 0 ) THEN 
    4445        itaille=jpi*ijpj 
    4446        CALL MPI_SCATTER(znorthgloio,itaille,MPI_REAL8,znorthloc,itaille,MPI_REAL8,0,ncomm_north,ierr) 
    4447     ENDIF 
     3521      IF ( npolj /= 0 ) THEN 
     3522         itaille=jpi*ijpj 
     3523         CALL MPI_SCATTER(znorthgloio,itaille,MPI_REAL8,znorthloc,itaille,MPI_REAL8,0,ncomm_north,ierr) 
     3524      ENDIF 
     3525#endif 
     3526 
     3527      ! put in the last ijpj jlines of pt2d znorthloc 
     3528      DO jj = nlcj - ijpj + 1 , nlcj 
     3529         ij = jj - nlcj + ijpj 
     3530         pt2d(:,jj)= znorthloc(:,ij) 
     3531      END DO 
     3532 
     3533   END SUBROUTINE mpp_lbc_north_2d 
     3534 
     3535 
     3536   !!!!! 
     3537 
     3538 
     3539   !!  
     3540   !!    This is valid on IBM machine ONLY.  
     3541   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -*- Mode: F90 -*- !!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     3542   !! mpi_init_opa.f90 : Redefinition du point d'entree MPI_INIT de la bibliotheque 
     3543   !!                MPI afin de faire, en plus de l'initialisation de 
     3544   !!                l'environnement MPI, l'allocation d'une zone tampon 
     3545   !!                qui sera ulterieurement utilisee automatiquement lors 
     3546   !!                de tous les envois de messages par MPI_BSEND 
     3547   !! 
     3548   !! Auteur : CNRS/IDRIS 
     3549   !! Date   : Tue Nov 13 12:02:14 2001 
     3550   !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
     3551 
     3552   SUBROUTINE mpi_init_opa(code) 
     3553      IMPLICIT NONE 
     3554#     include <mpif.h> 
     3555 
     3556      INTEGER                                 :: code,rang 
     3557  
     3558      ! La valeur suivante doit etre au moins egale a la taille 
     3559      ! du plus grand message qui sera transfere dans le programme 
     3560      ! (de toute facon, il y aura un message d'erreur si cette 
     3561      ! valeur s'avere trop petite) 
     3562      INTEGER                                 :: taille_tampon 
     3563      CHARACTER(len=9)                        :: taille_tampon_alphanum 
     3564      REAL(kind=8), ALLOCATABLE, DIMENSION(:) :: tampon 
     3565  
     3566      ! Le point d'entree dans la bibliotheque MPI elle-meme 
     3567      CALL mpi_init(code) 
     3568 
     3569      ! La definition de la zone tampon pour les futurs envois 
     3570      ! par MPI_BSEND (on alloue une fois pour toute cette zone 
     3571      ! tampon, qui sera automatiquement utilisee lors de chaque 
     3572      ! appel  a MPI_BSEND). 
     3573      ! La desallocation sera implicite quand on sortira de 
     3574      ! l'environnement MPI. 
     3575 
     3576      ! Recuperation de la valeur de la variable d'environnement 
     3577      ! BUFFER_LENGTH 
     3578      ! qui, si elle est definie, doit contenir une valeur superieure 
     3579      ! a  la taille en octets du plus gros message 
     3580      CALL getenv('BUFFER_LENGTH',taille_tampon_alphanum) 
     3581   
     3582      ! Si la variable BUFFER_LENGTH n'est pas positionnee, on lui met par 
     3583      ! defaut la plus grande valeur de la variable MP_EAGER_LIMIT, soit 
     3584      ! 65 536 octets 
     3585      IF (taille_tampon_alphanum == ' ') THEN 
     3586         taille_tampon = 65536 
     3587      ELSE 
     3588         READ(taille_tampon_alphanum,'(i9)') taille_tampon 
     3589      END IF 
     3590 
     3591      ! On est limite en mode d'adressage 32 bits a  1750 Mo pour la zone 
     3592      ! "data" soit 7 segments, c.-a -d. 1750/8 = 210 Mo 
     3593      IF (taille_tampon > 210000000) THEN 
     3594         PRINT *,'Attention la valeur BUFFER_LENGTH doit etre <= 210000000' 
     3595         CALL mpi_abort(MPI_COMM_WORLD,2,code) 
     3596      END IF 
     3597 
     3598      CALL mpi_comm_rank(MPI_COMM_WORLD,rang,code) 
     3599      IF (rang == 0 ) PRINT *,'Taille du buffer alloue : ',taille_tampon 
     3600 
     3601      ! Allocation du tampon et attachement 
     3602      ALLOCATE(tampon(taille_tampon)) 
     3603      CALL mpi_buffer_attach(tampon,taille_tampon,code) 
     3604 
     3605   END SUBROUTINE mpi_init_opa 
     3606 
     3607 
    44483608#else 
    4449     not done yet in PVM 
    4450 #endif 
    4451  
    4452     ! put in the last ijpj jlines of pt2d znorthloc 
    4453     DO jj = nlcj - ijpj + 1 , nlcj 
    4454        ij = jj - nlcj + ijpj 
    4455        pt2d(:,jj)= znorthloc(:,ij) 
    4456     END DO 
    4457  
    4458   END SUBROUTINE mpp_lbc_north_2d 
    4459  
    4460  
    4461 !!!!! 
    4462  
    4463  
    4464   !!  
    4465   !!    This is valid on IBM machine ONLY.  
    4466 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -*- Mode: F90 -*- !!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    4467   !! mpi_init_opa.f90 : Redefinition du point d'entree MPI_INIT de la bibliotheque 
    4468   !!                MPI afin de faire, en plus de l'initialisation de 
    4469   !!                l'environnement MPI, l'allocation d'une zone tampon 
    4470   !!                qui sera ulterieurement utilisee automatiquement lors 
    4471   !!                de tous les envois de messages par MPI_BSEND 
    4472   !! 
    4473   !! Auteur : CNRS/IDRIS 
    4474   !! Date   : Tue Nov 13 12:02:14 2001 
    4475 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
    4476  
    4477   SUBROUTINE mpi_init_opa(code) 
    4478     IMPLICIT NONE 
    4479 #include <mpif.h> 
    4480  
    4481     INTEGER                                 :: code,rang 
    4482  
    4483     ! La valeur suivante doit etre au moins egale a la taille 
    4484     ! du plus grand message qui sera transfere dans le programme 
    4485     ! (de toute facon, il y aura un message d'erreur si cette 
    4486     ! valeur s'avere trop petite) 
    4487     INTEGER                                 :: taille_tampon 
    4488     CHARACTER(len=9)                        :: taille_tampon_alphanum 
    4489     REAL(kind=8), ALLOCATABLE, DIMENSION(:) :: tampon 
    4490  
    4491     ! Le point d'entree dans la bibliotheque MPI elle-meme 
    4492     CALL mpi_init(code) 
    4493  
    4494     ! La definition de la zone tampon pour les futurs envois 
    4495     ! par MPI_BSEND (on alloue une fois pour toute cette zone 
    4496     ! tampon, qui sera automatiquement utilisee lors de chaque 
    4497     ! appel  a MPI_BSEND). 
    4498     ! La desallocation sera implicite quand on sortira de 
    4499     ! l'environnement MPI. 
    4500  
    4501     ! Recuperation de la valeur de la variable d'environnement 
    4502     ! BUFFER_LENGTH 
    4503     ! qui, si elle est definie, doit contenir une valeur superieure 
    4504     ! a  la taille en octets du plus gros message 
    4505     CALL getenv('BUFFER_LENGTH',taille_tampon_alphanum) 
    4506  
    4507     ! Si la variable BUFFER_LENGTH n'est pas positionnee, on lui met par 
    4508     ! defaut la plus grande valeur de la variable MP_EAGER_LIMIT, soit 
    4509     ! 65 536 octets 
    4510     IF (taille_tampon_alphanum == ' ') THEN 
    4511        taille_tampon = 65536 
    4512     ELSE 
    4513        READ(taille_tampon_alphanum,'(i9)') taille_tampon 
    4514     END IF 
    4515  
    4516     ! On est limite en mode d'adressage 32 bits a  1750 Mo pour la zone 
    4517     ! "data" soit 7 segments, c.-a -d. 1750/8 = 210 Mo 
    4518     IF (taille_tampon > 210000000) THEN 
    4519        PRINT *,'Attention la valeur BUFFER_LENGTH doit etre <= 210000000' 
    4520        CALL mpi_abort(MPI_COMM_WORLD,2,code) 
    4521     END IF 
    4522  
    4523     CALL mpi_comm_rank(MPI_COMM_WORLD,rang,code) 
    4524     IF (rang == 0 ) PRINT *,'Taille du buffer alloue : ',taille_tampon 
    4525  
    4526     ! Allocation du tampon et attachement 
    4527     ALLOCATE(tampon(taille_tampon)) 
    4528     CALL mpi_buffer_attach(tampon,taille_tampon,code) 
    4529  
    4530   END SUBROUTINE mpi_init_opa 
    4531  
    4532  
    4533 #else 
    4534   !!---------------------------------------------------------------------- 
    4535   !!   Default case                                 share memory computing 
    4536   !!---------------------------------------------------------------------- 
    4537  
    4538   IMPLICIT NONE 
    4539   PRIVATE 
    4540  
    4541   !! * Routine accessibility 
    4542   PUBLIC mynode 
     3609   !!---------------------------------------------------------------------- 
     3610   !!   Default case:            Dummy module        share memory computing 
     3611   !!---------------------------------------------------------------------- 
     3612   INTERFACE mpp_sum 
     3613      MODULE PROCEDURE mpp_sum_a2s, mpp_sum_as, mpp_sum_ai, mpp_sum_s, mpp_sum_i 
     3614   END INTERFACE 
     3615   INTERFACE mpp_max 
     3616      MODULE PROCEDURE mppmax_a_real, mppmax_real 
     3617   END INTERFACE 
     3618   INTERFACE mpp_min 
     3619      MODULE PROCEDURE mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real 
     3620   END INTERFACE 
     3621   INTERFACE mpp_isl 
     3622      MODULE PROCEDURE mppisl_a_int, mppisl_int, mppisl_a_real, mppisl_real 
     3623   END INTERFACE 
     3624   INTERFACE mppobc 
     3625      MODULE PROCEDURE mppobc_1d, mppobc_2d, mppobc_3d, mppobc_4d 
     3626   END INTERFACE 
     3627 
     3628   LOGICAL, PUBLIC, PARAMETER ::   lk_mpp = .FALSE.      !: mpp flag 
    45433629 
    45443630CONTAINS 
    45453631 
    4546   FUNCTION mynode() RESULT (function_value) 
    4547     !!---------------------------------------------------------------------- 
    4548     !!                  ***  routine mynode  *** 
    4549     !!                     
    4550     !! ** Purpose :   Find processor unit 
    4551     !! 
    4552     !! ** Method  :   share memory computing, return 0 as unit 
    4553     !! 
    4554     !!---------------------------------------------------------------------- 
    4555     !! * Local variables 
    4556     INTEGER :: function_value 
    4557     !!---------------------------------------------------------------------- 
    4558     function_value = 0 
    4559   END FUNCTION mynode 
    4560  
    4561 #endif 
    4562   !!---------------------------------------------------------------------- 
     3632   FUNCTION mynode() RESULT (function_value) 
     3633      function_value = 0 
     3634   END FUNCTION mynode 
     3635 
     3636   SUBROUTINE mppsync                       ! Dummy routine 
     3637   END SUBROUTINE mppsync 
     3638 
     3639   SUBROUTINE mpp_sum_as( parr, kdim )      ! Dummy routine 
     3640      REAL   , DIMENSION(:) :: parr 
     3641      INTEGER               :: kdim 
     3642      WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1) 
     3643   END SUBROUTINE mpp_sum_as 
     3644 
     3645   SUBROUTINE mpp_sum_a2s( parr, kdim )      ! Dummy routine 
     3646      REAL   , DIMENSION(:,:) :: parr 
     3647      INTEGER               :: kdim 
     3648      WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1) 
     3649   END SUBROUTINE mpp_sum_a2s 
     3650 
     3651   SUBROUTINE mpp_sum_ai( karr, kdim )      ! Dummy routine 
     3652      INTEGER, DIMENSION(:) :: karr 
     3653      INTEGER               :: kdim 
     3654      WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1) 
     3655   END SUBROUTINE mpp_sum_ai 
     3656 
     3657   SUBROUTINE mpp_sum_s( psca )            ! Dummy routine 
     3658      REAL                  :: psca 
     3659      WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca 
     3660   END SUBROUTINE mpp_sum_s 
     3661 
     3662   SUBROUTINE mpp_sum_i( kint )            ! Dummy routine 
     3663      integer               :: kint 
     3664      WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint 
     3665   END SUBROUTINE mpp_sum_i 
     3666 
     3667   SUBROUTINE mppmax_a_real( parr, kdim ) 
     3668      REAL   , DIMENSION(:) :: parr 
     3669      INTEGER               :: kdim 
     3670      WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1) 
     3671   END SUBROUTINE mppmax_a_real 
     3672 
     3673   SUBROUTINE mppmax_real( psca ) 
     3674      REAL                  :: psca 
     3675      WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca 
     3676   END SUBROUTINE mppmax_real 
     3677 
     3678   SUBROUTINE mppmin_a_real( parr, kdim ) 
     3679      REAL   , DIMENSION(:) :: parr 
     3680      INTEGER               :: kdim 
     3681      WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1) 
     3682   END SUBROUTINE mppmin_a_real 
     3683 
     3684   SUBROUTINE mppmin_real( psca ) 
     3685      REAL                  :: psca 
     3686      WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca 
     3687   END SUBROUTINE mppmin_real 
     3688 
     3689   SUBROUTINE mppmin_a_int( karr, kdim ) 
     3690      INTEGER, DIMENSION(:) :: karr 
     3691      INTEGER               :: kdim 
     3692      WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1) 
     3693   END SUBROUTINE mppmin_a_int 
     3694 
     3695   SUBROUTINE mppmin_int( kint ) 
     3696      INTEGER               :: kint 
     3697      WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint 
     3698   END SUBROUTINE mppmin_int 
     3699 
     3700   SUBROUTINE mppobc_1d( parr, kd1, kd2, kl, kk, ktype, kij ) 
     3701    INTEGER  ::   kd1, kd2, kl , kk, ktype, kij 
     3702    REAL, DIMENSION(:) ::   parr           ! variable array 
     3703      WRITE(*,*) 'mppobc: You should not have seen this print! error?',   & 
     3704         &        parr(1), kd1, kd2, kl, kk, ktype, kij 
     3705   END SUBROUTINE mppobc_1d 
     3706 
     3707   SUBROUTINE mppobc_2d( parr, kd1, kd2, kl, kk, ktype, kij ) 
     3708    INTEGER  ::   kd1, kd2, kl , kk, ktype, kij 
     3709    REAL, DIMENSION(:,:) ::   parr           ! variable array 
     3710      WRITE(*,*) 'mppobc: You should not have seen this print! error?',   & 
     3711         &        parr(1,1), kd1, kd2, kl, kk, ktype, kij 
     3712   END SUBROUTINE mppobc_2d 
     3713 
     3714   SUBROUTINE mppobc_3d( parr, kd1, kd2, kl, kk, ktype, kij ) 
     3715    INTEGER  ::   kd1, kd2, kl , kk, ktype, kij 
     3716    REAL, DIMENSION(:,:,:) ::   parr           ! variable array 
     3717      WRITE(*,*) 'mppobc: You should not have seen this print! error?',   & 
     3718         &        parr(1,1,1), kd1, kd2, kl, kk, ktype, kij 
     3719   END SUBROUTINE mppobc_3d 
     3720 
     3721   SUBROUTINE mppobc_4d( parr, kd1, kd2, kl, kk, ktype, kij ) 
     3722    INTEGER  ::   kd1, kd2, kl , kk, ktype, kij 
     3723    REAL, DIMENSION(:,:,:,:) ::   parr           ! variable array 
     3724      WRITE(*,*) 'mppobc: You should not have seen this print! error?',   & 
     3725         &        parr(1,1,1,1), kd1, kd2, kl, kk, ktype, kij 
     3726   END SUBROUTINE mppobc_4d 
     3727 
     3728 
     3729   SUBROUTINE mpplnks( karr )            ! Dummy routine 
     3730      INTEGER, DIMENSION(:,:) :: karr 
     3731      WRITE(*,*) 'mpplnks: You should not have seen this print! error?', karr(1,1) 
     3732   END SUBROUTINE mpplnks 
     3733 
     3734   SUBROUTINE mppisl_a_int( karr, kdim ) 
     3735      INTEGER, DIMENSION(:) :: karr 
     3736      INTEGER               :: kdim 
     3737      WRITE(*,*) 'mppisl_a_int: You should not have seen this print! error?', kdim, karr(1) 
     3738   END SUBROUTINE mppisl_a_int 
     3739 
     3740   SUBROUTINE mppisl_int( kint ) 
     3741      INTEGER               :: kint 
     3742      WRITE(*,*) 'mppisl_int: You should not have seen this print! error?', kint 
     3743   END SUBROUTINE mppisl_int 
     3744 
     3745   SUBROUTINE mppisl_a_real( parr, kdim ) 
     3746      REAL   , DIMENSION(:) :: parr 
     3747      INTEGER               :: kdim 
     3748      WRITE(*,*) 'mppisl_a_real: You should not have seen this print! error?', kdim, parr(1) 
     3749   END SUBROUTINE mppisl_a_real 
     3750 
     3751   SUBROUTINE mppisl_real( psca ) 
     3752      REAL                  :: psca 
     3753      WRITE(*,*) 'mppisl_real: You should not have seen this print! error?', psca 
     3754   END SUBROUTINE mppisl_real 
     3755#endif 
     3756   !!---------------------------------------------------------------------- 
    45633757END MODULE lib_mpp 
Note: See TracChangeset for help on using the changeset viewer.