LCOV - code coverage report
Current view: top level - src/mpiwrap - message_passing.F (source / functions) Hit Total Coverage
Test: CP2K Regtests (git:9f1e18e) Lines: 876 1268 69.1 %
Date: 2021-09-22 20:58:48 Functions: 57 102 55.9 %

          Line data    Source code
       1             : !--------------------------------------------------------------------------------------------------!
       2             : !   CP2K: A general program to perform molecular dynamics simulations                              !
       3             : !   Copyright 2000-2021 CP2K developers group <https://cp2k.org>                                   !
       4             : !                                                                                                  !
       5             : !   SPDX-License-Identifier: GPL-2.0-or-later                                                      !
       6             : !--------------------------------------------------------------------------------------------------!
       7             : 
       8             : ! **************************************************************************************************
       9             : !> \brief Interface to the message passing library MPI
      10             : !> \par History
      11             : !>      JGH (02-Jan-2001): New error handling
      12             : !>                         Performance tools
      13             : !>      JGH (14-Jan-2001): New routines mp_comm_compare, mp_cart_coords,
      14             : !>                                      mp_rank_compare, mp_alltoall
      15             : !>      JGH (06-Feb-2001): New routines mp_comm_free
      16             : !>      JGH (22-Mar-2001): New routines mp_comm_dup
      17             : !>      fawzi (04-NOV-2004): storable performance info (for f77 interface)
      18             : !>      Wrapper routine for mpi_gatherv added (22.12.2005,MK)
      19             : !>      JGH (13-Feb-2006): Flexible precision
      20             : !>      JGH (15-Feb-2006): single precision mp_alltoall
      21             : !> \author JGH
      22             : ! **************************************************************************************************
      23             : MODULE message_passing
      24             :    USE ISO_C_BINDING, ONLY: C_F_POINTER, &
      25             :                             C_PTR
      26             :    USE kinds, ONLY: &
      27             :       dp, int_4, int_4_size, int_8, int_8_size, real_4, real_4_size, real_8, &
      28             :       real_8_size
      29             :    USE machine, ONLY: m_abort
      30             : 
      31             : #include "../base/base_uses.f90"
      32             : 
      33             : #if defined(__parallel) && !defined(__MPI_VERSION)
      34             : #define __MPI_VERSION 3
      35             : #endif
      36             : 
      37             : #if defined(__parallel)
      38             :    USE mpi
      39             : ! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines (problems with types and ranks explosion),
      40             : !              we do not quite know what is in the module, so we can not include any....
      41             : !              to nevertheless get checking for what is included, we use the mpi module without use clause, getting all there is
      42             : ! USE mpi, ONLY: mpi_allgather, mpi_allgatherv, mpi_alloc_mem, mpi_allreduce, mpi_alltoall, mpi_alltoallv, mpi_bcast,&
      43             : !                mpi_cart_coords, mpi_cart_create, mpi_cart_get, mpi_cart_rank, mpi_cart_sub, mpi_dims_create, mpi_file_close,&
      44             : !                mpi_file_get_size, mpi_file_open, mpi_file_read_at_all, mpi_file_read_at, mpi_file_write_at_all,&
      45             : !                mpi_file_write_at, mpi_free_mem, mpi_gather, mpi_gatherv, mpi_get_address, mpi_group_translate_ranks, mpi_irecv,&
      46             : !                mpi_isend, mpi_recv, mpi_reduce, mpi_reduce_scatter, mpi_rget, mpi_scatter, mpi_send,&
      47             : !                mpi_sendrecv, mpi_sendrecv_replace, mpi_testany, mpi_waitall, mpi_waitany, mpi_win_create
      48             : ! functions
      49             : ! USE mpi, ONLY: mpi_wtime
      50             : ! constants
      51             : ! USE mpi, ONLY: MPI_DOUBLE_PRECISION, MPI_DOUBLE_COMPLEX, MPI_REAL, MPI_COMPLEX, MPI_ANY_TAG,&
      52             : !                MPI_ANY_SOURCE, MPI_COMM_NULL, MPI_REQUEST_NULL, MPI_WIN_NULL, MPI_STATUS_SIZE, MPI_STATUS_IGNORE, MPI_STATUSES_IGNORE, &
      53             : !                MPI_ADDRESS_KIND, MPI_OFFSET_KIND, MPI_MODE_CREATE, MPI_MODE_RDONLY, MPI_MODE_WRONLY,&
      54             : !                MPI_MODE_RDWR, MPI_MODE_EXCL, MPI_COMM_SELF, MPI_COMM_WORLD, MPI_THREAD_SERIALIZED,&
      55             : !                MPI_ERRORS_RETURN, MPI_SUCCESS, MPI_MAX_PROCESSOR_NAME, MPI_MAX_ERROR_STRING, MPI_IDENT,&
      56             : !                MPI_UNEQUAL, MPI_MAX, MPI_SUM, MPI_INFO_NULL, MPI_IN_PLACE, MPI_CONGRUENT, MPI_SIMILAR, MPI_MIN, MPI_SOURCE,&
      57             : !                MPI_TAG, MPI_INTEGER8, MPI_INTEGER, MPI_MAXLOC, MPI_2INTEGER, MPI_MINLOC, MPI_LOGICAL, MPI_2DOUBLE_PRECISION,&
      58             : !                MPI_LOR, MPI_CHARACTER, MPI_BOTTOM, MPI_MODE_NOCHECK, MPI_2REAL
      59             : #endif
      60             : 
      61             :    IMPLICIT NONE
      62             :    PRIVATE
      63             : 
      64             :    ! parameters that might be needed
      65             : #if defined(__parallel)
      66             :    INTEGER, PARAMETER     :: MP_STD_REAL = MPI_DOUBLE_PRECISION
      67             :    INTEGER, PARAMETER     :: MP_STD_COMPLEX = MPI_DOUBLE_COMPLEX
      68             :    INTEGER, PARAMETER     :: MP_STD_HALF_REAL = MPI_REAL
      69             :    INTEGER, PARAMETER     :: MP_STD_HALF_COMPLEX = MPI_COMPLEX
      70             : 
      71             :    LOGICAL, PARAMETER :: cp2k_is_parallel = .TRUE.
      72             :    INTEGER, PARAMETER, PUBLIC :: mp_any_tag = MPI_ANY_TAG
      73             :    INTEGER, PARAMETER, PUBLIC :: mp_any_source = MPI_ANY_SOURCE
      74             :    INTEGER, PARAMETER, PUBLIC :: mp_comm_null = MPI_COMM_NULL
      75             :    INTEGER, PARAMETER, PUBLIC :: mp_comm_self = MPI_COMM_SELF
      76             :    INTEGER, PARAMETER, PUBLIC :: mp_comm_world = MPI_COMM_WORLD
      77             :    INTEGER, PARAMETER, PUBLIC :: mp_request_null = MPI_REQUEST_NULL
      78             :    INTEGER, PARAMETER, PUBLIC :: mp_win_null = MPI_WIN_NULL
      79             :    INTEGER, PARAMETER, PUBLIC :: mp_status_size = MPI_STATUS_SIZE
      80             :    INTEGER, PARAMETER, PUBLIC :: mp_proc_null = MPI_PROC_NULL
      81             :    ! Set max allocatable memory by MPI to 2 GiByte
      82             :    INTEGER(KIND=MPI_ADDRESS_KIND), PARAMETER, PRIVATE :: mp_max_memory_size = HUGE(INT(1, KIND=int_4))
      83             : 
      84             : #if __MPI_VERSION > 2
      85             :    INTEGER, PARAMETER, PUBLIC :: mp_max_library_version_string = MPI_MAX_LIBRARY_VERSION_STRING
      86             : #else
      87             :    INTEGER, PARAMETER, PUBLIC :: mp_max_library_version_string = 1
      88             : #endif
      89             : 
      90             :    INTEGER, PARAMETER, PUBLIC :: file_offset = MPI_OFFSET_KIND
      91             :    INTEGER, PARAMETER, PUBLIC :: address_kind = MPI_ADDRESS_KIND
      92             :    INTEGER, PARAMETER, PUBLIC :: file_amode_create = MPI_MODE_CREATE
      93             :    INTEGER, PARAMETER, PUBLIC :: file_amode_rdonly = MPI_MODE_RDONLY
      94             :    INTEGER, PARAMETER, PUBLIC :: file_amode_wronly = MPI_MODE_WRONLY
      95             :    INTEGER, PARAMETER, PUBLIC :: file_amode_rdwr = MPI_MODE_RDWR
      96             :    INTEGER, PARAMETER, PUBLIC :: file_amode_excl = MPI_MODE_EXCL
      97             :    INTEGER, PARAMETER, PUBLIC :: file_amode_append = MPI_MODE_APPEND
      98             : #else
      99             :    LOGICAL, PARAMETER :: cp2k_is_parallel = .FALSE.
     100             :    INTEGER, PARAMETER, PUBLIC :: mp_any_tag = -1
     101             :    INTEGER, PARAMETER, PUBLIC :: mp_any_source = -2
     102             :    INTEGER, PARAMETER, PUBLIC :: mp_comm_null = -3
     103             :    INTEGER, PARAMETER, PUBLIC :: mp_comm_self = -11
     104             :    INTEGER, PARAMETER, PUBLIC :: mp_comm_world = -12
     105             :    INTEGER, PARAMETER, PUBLIC :: mp_request_null = -4
     106             :    INTEGER, PARAMETER, PUBLIC :: mp_win_null = -5
     107             :    INTEGER, PARAMETER, PUBLIC :: mp_status_size = -6
     108             :    INTEGER, PARAMETER, PUBLIC :: mp_proc_null = -7
     109             :    INTEGER, PARAMETER, PUBLIC :: mp_max_library_version_string = 1
     110             : 
     111             :    INTEGER, PARAMETER, PUBLIC :: file_offset = int_8
     112             :    INTEGER, PARAMETER, PUBLIC :: address_kind = int_8
     113             :    INTEGER, PARAMETER, PUBLIC :: file_amode_create = 1
     114             :    INTEGER, PARAMETER, PUBLIC :: file_amode_rdonly = 2
     115             :    INTEGER, PARAMETER, PUBLIC :: file_amode_wronly = 4
     116             :    INTEGER, PARAMETER, PUBLIC :: file_amode_rdwr = 8
     117             :    INTEGER, PARAMETER, PUBLIC :: file_amode_excl = 64
     118             :    INTEGER, PARAMETER, PUBLIC :: file_amode_append = 128
     119             : 
     120             : #endif
     121             : 
     122             :    ! we need to fix this to a given number (crossing fingers)
     123             :    ! so that the serial code using Fortran stream IO and the MPI have the same sizes.
     124             :    INTEGER, PARAMETER, PUBLIC :: mpi_character_size = 1
     125             :    INTEGER, PARAMETER, PUBLIC :: mpi_integer_size = 4
     126             : 
     127             :    CHARACTER(LEN=*), PARAMETER, PRIVATE :: moduleN = 'message_passing'
     128             : 
     129             : #if defined(__parallel)
     130             :    ! internal reference counter used to debug communicator leaks
     131             :    INTEGER, PRIVATE, SAVE :: debug_comm_count
     132             : #endif
     133             : 
     134             :    ! init and error
     135             :    PUBLIC :: mp_world_init, mp_world_finalize
     136             :    PUBLIC :: mp_abort
     137             : 
     138             :    ! performance gathering
     139             :    PUBLIC :: mp_perf_env_type
     140             :    PUBLIC :: mp_perf_env_retain, mp_perf_env_release
     141             :    PUBLIC :: add_mp_perf_env, rm_mp_perf_env, get_mp_perf_env, describe_mp_perf_env
     142             : 
     143             :    ! informational / generation of sub comms
     144             :    PUBLIC :: mp_environ, mp_comm_compare, mp_cart_coords, mp_rank_compare
     145             :    PUBLIC :: mp_cart_create, mp_dims_create, mp_cart_rank, mp_cart_sub, mp_comm_free
     146             :    PUBLIC :: mp_comm_dup, mp_comm_split, mp_comm_split_direct
     147             :    PUBLIC :: cp2k_is_parallel
     148             :    PUBLIC :: mp_probe
     149             :    PUBLIC :: mp_get_node_global_rank
     150             : 
     151             :    ! message passing
     152             :    PUBLIC :: mp_bcast, mp_sum, mp_sum_partial, mp_max, mp_maxloc, mp_minloc, mp_min, mp_prod, mp_sync
     153             :    PUBLIC :: mp_isync, mp_isum
     154             :    PUBLIC :: mp_gather, mp_alltoall, mp_sendrecv, mp_allgather, mp_iallgather
     155             :    PUBLIC :: mp_isend, mp_irecv, mp_ibcast
     156             :    PUBLIC :: mp_shift, mp_isendrecv, mp_wait, mp_waitall, mp_waitany, mp_testany
     157             :    PUBLIC :: mp_testall, mp_iscatter, mp_test
     158             :    PUBLIC :: mp_gatherv
     159             :    PUBLIC :: mp_send, mp_recv
     160             : 
     161             :    ! Memory management
     162             :    PUBLIC :: mp_allocate, mp_deallocate
     163             : 
     164             :    ! MPI re-ordering
     165             :    PUBLIC :: mp_reordering
     166             : 
     167             :    ! I/O
     168             :    PUBLIC :: mp_file_open, mp_file_close
     169             :    PUBLIC :: mp_file_delete
     170             :    PUBLIC :: mp_file_write_at
     171             :    PUBLIC :: mp_file_write_at_all, mp_file_read_at_all
     172             :    PUBLIC :: mp_file_get_size
     173             :    PUBLIC :: mp_file_get_position
     174             :    PUBLIC :: mp_file_get_amode
     175             : 
     176             :    ! some 'advanced types' currently only used for dbcsr
     177             :    PUBLIC :: mp_type_descriptor_type
     178             :    PUBLIC :: mp_type_make
     179             :    PUBLIC :: mp_type_size
     180             : 
     181             :    ! some benchmarking code
     182             :    PUBLIC :: mpi_perf_test
     183             : 
     184             :    ! one-sided communication
     185             :    PUBLIC :: mp_win_create, mp_win_free, mp_win_lock_all, &
     186             :              mp_win_unlock_all, mp_rget, mp_win_flush_all
     187             : 
     188             :    ! vector types
     189             :    PUBLIC :: mp_type_indexed_make_r, mp_type_indexed_make_d, &
     190             :              mp_type_indexed_make_c, mp_type_indexed_make_z
     191             : 
     192             :    ! More I/O types and routines: variable spaced data using bytes for spacings
     193             :    PUBLIC :: mp_file_descriptor_type
     194             :    PUBLIC :: mp_file_type_free
     195             :    PUBLIC :: mp_file_type_hindexed_make_chv
     196             :    PUBLIC :: mp_file_type_set_view_chv
     197             :    PUBLIC :: mp_file_read_all_chv
     198             :    PUBLIC :: mp_file_write_all_chv
     199             : 
     200             :    PUBLIC :: mp_get_library_version
     201             : 
     202             :    ! assumed to be private
     203             : 
     204             : ! Interface declarations for non-data-oriented subroutines.
     205             : 
     206             :    INTERFACE mp_environ
     207             :       MODULE PROCEDURE mp_environ_l, mp_environ_c, mp_environ_c2
     208             :    END INTERFACE
     209             : 
     210             :    INTERFACE mp_waitall
     211             :       MODULE PROCEDURE mp_waitall_1, mp_waitall_2
     212             :    END INTERFACE
     213             : 
     214             :    INTERFACE mp_testall
     215             :       MODULE PROCEDURE mp_testall_tv
     216             :    END INTERFACE
     217             : 
     218             :    INTERFACE mp_test
     219             :       MODULE PROCEDURE mp_test_1
     220             :    END INTERFACE
     221             : 
     222             :    INTERFACE mp_testany
     223             :       MODULE PROCEDURE mp_testany_1, mp_testany_2
     224             :    END INTERFACE
     225             : 
     226             :    INTERFACE mp_type_free
     227             :       MODULE PROCEDURE mp_type_free_m, mp_type_free_v
     228             :    END INTERFACE
     229             : 
     230             :    !
     231             :    ! interfaces to deal easily with scalars / vectors / matrices / ...
     232             :    ! of the different types (integers, doubles, logicals, characters)
     233             :    !
     234             :    INTERFACE mp_minloc
     235             :       MODULE PROCEDURE mp_minloc_iv, &
     236             :          mp_minloc_lv, &
     237             :          mp_minloc_rv, &
     238             :          mp_minloc_dv
     239             :    END INTERFACE
     240             : 
     241             :    INTERFACE mp_maxloc
     242             :       MODULE PROCEDURE mp_maxloc_iv, &
     243             :          mp_maxloc_lv, &
     244             :          mp_maxloc_rv, &
     245             :          mp_maxloc_dv
     246             :    END INTERFACE
     247             : 
     248             :    INTERFACE mp_shift
     249             :       MODULE PROCEDURE mp_shift_im, mp_shift_i, &
     250             :          mp_shift_lm, mp_shift_l, &
     251             :          mp_shift_rm, mp_shift_r, &
     252             :          mp_shift_dm, mp_shift_d, &
     253             :          mp_shift_cm, mp_shift_c, &
     254             :          mp_shift_zm, mp_shift_z
     255             :    END INTERFACE
     256             : 
     257             :    INTERFACE mp_bcast
     258             :       MODULE PROCEDURE mp_bcast_i, mp_bcast_iv, mp_bcast_im, mp_bcast_i3, &
     259             :          mp_bcast_l, mp_bcast_lv, mp_bcast_lm, mp_bcast_l3, &
     260             :          mp_bcast_r, mp_bcast_rv, mp_bcast_rm, mp_bcast_r3, &
     261             :          mp_bcast_d, mp_bcast_dv, mp_bcast_dm, mp_bcast_d3, &
     262             :          mp_bcast_c, mp_bcast_cv, mp_bcast_cm, mp_bcast_c3, &
     263             :          mp_bcast_z, mp_bcast_zv, mp_bcast_zm, mp_bcast_z3
     264             :       MODULE PROCEDURE mp_bcast_b, mp_bcast_bv
     265             :       MODULE PROCEDURE mp_bcast_av, mp_bcast_am
     266             :    END INTERFACE
     267             : 
     268             :    INTERFACE mp_ibcast
     269             :       MODULE PROCEDURE mp_ibcast_i, mp_ibcast_iv, &
     270             :          mp_ibcast_l, mp_ibcast_lv, &
     271             :          mp_ibcast_r, mp_ibcast_rv, &
     272             :          mp_ibcast_d, mp_ibcast_dv, &
     273             :          mp_ibcast_c, mp_ibcast_cv, &
     274             :          mp_ibcast_z, mp_ibcast_zv
     275             :    END INTERFACE
     276             : 
     277             :    INTERFACE mp_sum
     278             :       MODULE PROCEDURE mp_sum_i, mp_sum_iv, mp_sum_im, mp_sum_im3, mp_sum_im4, &
     279             :          mp_sum_l, mp_sum_lv, mp_sum_lm, mp_sum_lm3, mp_sum_lm4, &
     280             :          mp_sum_r, mp_sum_rv, mp_sum_rm, mp_sum_rm3, mp_sum_rm4, &
     281             :          mp_sum_d, mp_sum_dv, mp_sum_dm, mp_sum_dm3, mp_sum_dm4, &
     282             :          mp_sum_c, mp_sum_cv, mp_sum_cm, mp_sum_cm3, mp_sum_cm4, &
     283             :          mp_sum_z, mp_sum_zv, mp_sum_zm, mp_sum_zm3, mp_sum_zm4, &
     284             :          mp_sum_root_iv, mp_sum_root_im, &
     285             :          mp_sum_root_lv, mp_sum_root_lm, &
     286             :          mp_sum_root_rv, mp_sum_root_rm, &
     287             :          mp_sum_root_dv, mp_sum_root_dm, &
     288             :          mp_sum_root_cv, mp_sum_root_cm, &
     289             :          mp_sum_root_zv, mp_sum_root_zm
     290             :       MODULE PROCEDURE mp_sum_b, mp_sum_bv
     291             :    END INTERFACE
     292             : 
     293             :    INTERFACE mp_isum
     294             :       MODULE PROCEDURE mp_isum_iv, &
     295             :          mp_isum_lv, &
     296             :          mp_isum_rv, &
     297             :          mp_isum_dv, &
     298             :          mp_isum_cv, &
     299             :          mp_isum_zv
     300             :       MODULE PROCEDURE mp_isum_bv
     301             :    END INTERFACE
     302             : 
     303             :    INTERFACE mp_sum_partial
     304             :       MODULE PROCEDURE mp_sum_partial_im, &
     305             :          mp_sum_partial_lm, &
     306             :          mp_sum_partial_rm, &
     307             :          mp_sum_partial_dm, &
     308             :          mp_sum_partial_cm, &
     309             :          mp_sum_partial_zm
     310             :    END INTERFACE
     311             : 
     312             :    INTERFACE mp_max
     313             :       MODULE PROCEDURE mp_max_i, mp_max_iv, &
     314             :          mp_max_l, mp_max_lv, &
     315             :          mp_max_r, mp_max_rv, &
     316             :          mp_max_d, mp_max_dv, &
     317             :          mp_max_c, mp_max_cv, &
     318             :          mp_max_z, mp_max_zv
     319             :    END INTERFACE
     320             : 
     321             :    INTERFACE mp_min
     322             :       MODULE PROCEDURE mp_min_i, mp_min_iv, &
     323             :          mp_min_l, mp_min_lv, &
     324             :          mp_min_r, mp_min_rv, &
     325             :          mp_min_d, mp_min_dv, &
     326             :          mp_min_c, mp_min_cv, &
     327             :          mp_min_z, mp_min_zv
     328             :    END INTERFACE
     329             : 
     330             :    INTERFACE mp_prod
     331             :       MODULE PROCEDURE mp_prod_r, mp_prod_d, mp_prod_c, mp_prod_z
     332             :    END INTERFACE
     333             : 
     334             :    INTERFACE mp_gather
     335             :       MODULE PROCEDURE mp_gather_i, mp_gather_iv, mp_gather_im, &
     336             :          mp_gather_l, mp_gather_lv, mp_gather_lm, &
     337             :          mp_gather_r, mp_gather_rv, mp_gather_rm, &
     338             :          mp_gather_d, mp_gather_dv, mp_gather_dm, &
     339             :          mp_gather_c, mp_gather_cv, mp_gather_cm, &
     340             :          mp_gather_z, mp_gather_zv, mp_gather_zm
     341             :    END INTERFACE
     342             : 
     343             :    INTERFACE mp_gatherv
     344             :       MODULE PROCEDURE mp_gatherv_iv, &
     345             :          mp_gatherv_lv, &
     346             :          mp_gatherv_rv, &
     347             :          mp_gatherv_dv, &
     348             :          mp_gatherv_cv, &
     349             :          mp_gatherv_zv
     350             :    END INTERFACE
     351             : 
     352             :    INTERFACE mp_igatherv
     353             :       MODULE PROCEDURE mp_igatherv_iv, &
     354             :          mp_igatherv_lv, &
     355             :          mp_igatherv_rv, &
     356             :          mp_igatherv_dv, &
     357             :          mp_igatherv_cv, &
     358             :          mp_igatherv_zv
     359             :    END INTERFACE
     360             : 
     361             : !> todo: move allgatherv to a separate declaration
     362             :    INTERFACE mp_allgather
     363             :       MODULE PROCEDURE &
     364             :          mp_allgather_i, mp_allgather_i2, &
     365             :          mp_allgather_i12, mp_allgather_i23, mp_allgather_i34, &
     366             :          mp_allgather_i22, &
     367             :          mp_allgather_l, mp_allgather_l2, &
     368             :          mp_allgather_l12, mp_allgather_l23, mp_allgather_l34, &
     369             :          mp_allgather_l22, &
     370             :          mp_allgather_r, mp_allgather_r2, &
     371             :          mp_allgather_r12, mp_allgather_r23, mp_allgather_r34, &
     372             :          mp_allgather_r22, &
     373             :          mp_allgather_d, mp_allgather_d2, &
     374             :          mp_allgather_d12, mp_allgather_d23, mp_allgather_d34, &
     375             :          mp_allgather_d22, &
     376             :          mp_allgather_c, mp_allgather_c2, &
     377             :          mp_allgather_c12, mp_allgather_c23, mp_allgather_c34, &
     378             :          mp_allgather_c22, &
     379             :          mp_allgather_z, mp_allgather_z2, &
     380             :          mp_allgather_z12, mp_allgather_z23, mp_allgather_z34, &
     381             :          mp_allgather_z22, &
     382             :          mp_allgatherv_iv, &
     383             :          mp_allgatherv_lv, &
     384             :          mp_allgatherv_rv, &
     385             :          mp_allgatherv_dv, &
     386             :          mp_allgatherv_cv, &
     387             :          mp_allgatherv_zv
     388             :    END INTERFACE
     389             : 
     390             :    INTERFACE mp_iallgather
     391             :       MODULE PROCEDURE &
     392             :          mp_iallgather_i, mp_iallgather_l, &
     393             :          mp_iallgather_r, mp_iallgather_d, &
     394             :          mp_iallgather_c, mp_iallgather_z, &
     395             :          mp_iallgather_i11, mp_iallgather_l11, &
     396             :          mp_iallgather_r11, mp_iallgather_d11, &
     397             :          mp_iallgather_c11, mp_iallgather_z11, &
     398             :          mp_iallgather_i13, mp_iallgather_l13, &
     399             :          mp_iallgather_r13, mp_iallgather_d13, &
     400             :          mp_iallgather_c13, mp_iallgather_z13, &
     401             :          mp_iallgather_i22, mp_iallgather_l22, &
     402             :          mp_iallgather_r22, mp_iallgather_d22, &
     403             :          mp_iallgather_c22, mp_iallgather_z22, &
     404             :          mp_iallgather_i24, mp_iallgather_l24, &
     405             :          mp_iallgather_r24, mp_iallgather_d24, &
     406             :          mp_iallgather_c24, mp_iallgather_z24, &
     407             :          mp_iallgather_i33, mp_iallgather_l33, &
     408             :          mp_iallgather_r33, mp_iallgather_d33, &
     409             :          mp_iallgather_c33, mp_iallgather_z33, &
     410             :          mp_iallgatherv_iv, mp_iallgatherv_iv2, &
     411             :          mp_iallgatherv_lv, mp_iallgatherv_lv2, &
     412             :          mp_iallgatherv_rv, mp_iallgatherv_rv2, &
     413             :          mp_iallgatherv_dv, mp_iallgatherv_dv2, &
     414             :          mp_iallgatherv_cv, mp_iallgatherv_cv2, &
     415             :          mp_iallgatherv_zv, mp_iallgatherv_zv2
     416             :    END INTERFACE
     417             : 
     418             :    INTERFACE mp_scatter
     419             :       MODULE PROCEDURE mp_scatter_iv, &
     420             :          mp_scatter_lv, &
     421             :          mp_scatter_rv, &
     422             :          mp_scatter_dv, &
     423             :          mp_scatter_cv, &
     424             :          mp_scatter_zv
     425             :    END INTERFACE
     426             : 
     427             :    INTERFACE mp_iscatter
     428             :       MODULE PROCEDURE mp_iscatter_i, &
     429             :          mp_iscatter_l, &
     430             :          mp_iscatter_r, &
     431             :          mp_iscatter_d, &
     432             :          mp_iscatter_c, &
     433             :          mp_iscatter_z, &
     434             :          mp_iscatter_iv2, &
     435             :          mp_iscatter_lv2, &
     436             :          mp_iscatter_rv2, &
     437             :          mp_iscatter_dv2, &
     438             :          mp_iscatter_cv2, &
     439             :          mp_iscatter_zv2, &
     440             :          mp_iscatterv_iv, &
     441             :          mp_iscatterv_lv, &
     442             :          mp_iscatterv_rv, &
     443             :          mp_iscatterv_dv, &
     444             :          mp_iscatterv_cv, &
     445             :          mp_iscatterv_zv
     446             :    END INTERFACE
     447             : 
     448             :    INTERFACE mp_sum_scatter
     449             :       MODULE PROCEDURE mp_sum_scatter_iv, &
     450             :          mp_sum_scatter_lv, &
     451             :          mp_sum_scatter_rv, &
     452             :          mp_sum_scatter_dv, &
     453             :          mp_sum_scatter_cv, &
     454             :          mp_sum_scatter_zv
     455             :    END INTERFACE
     456             : 
     457             :    INTERFACE mp_alltoall
     458             :       MODULE PROCEDURE mp_alltoall_i, mp_alltoall_i22, mp_alltoall_i33, &
     459             :          mp_alltoall_i44, mp_alltoall_i55, mp_alltoall_i45, mp_alltoall_i34, &
     460             :          mp_alltoall_i11v, mp_alltoall_i22v, mp_alltoall_i54, &
     461             :          mp_alltoall_l, mp_alltoall_l22, mp_alltoall_l33, &
     462             :          mp_alltoall_l44, mp_alltoall_l55, mp_alltoall_l45, mp_alltoall_l34, &
     463             :          mp_alltoall_l11v, mp_alltoall_l22v, mp_alltoall_l54, &
     464             :          mp_alltoall_r, mp_alltoall_r22, mp_alltoall_r33, &
     465             :          mp_alltoall_r44, mp_alltoall_r55, mp_alltoall_r45, mp_alltoall_r34, &
     466             :          mp_alltoall_r11v, mp_alltoall_r22v, mp_alltoall_r54, &
     467             :          mp_alltoall_d, mp_alltoall_d22, mp_alltoall_d33, &
     468             :          mp_alltoall_d44, mp_alltoall_d55, mp_alltoall_d45, mp_alltoall_d34, &
     469             :          mp_alltoall_d11v, mp_alltoall_d22v, mp_alltoall_d54, &
     470             :          mp_alltoall_c, mp_alltoall_c22, mp_alltoall_c33, &
     471             :          mp_alltoall_c44, mp_alltoall_c55, mp_alltoall_c45, mp_alltoall_c34, &
     472             :          mp_alltoall_c11v, mp_alltoall_c22v, mp_alltoall_c54, &
     473             :          mp_alltoall_z, mp_alltoall_z22, mp_alltoall_z33, &
     474             :          mp_alltoall_z44, mp_alltoall_z55, mp_alltoall_z45, mp_alltoall_z34, &
     475             :          mp_alltoall_z11v, mp_alltoall_z22v, mp_alltoall_z54
     476             :    END INTERFACE
     477             : 
     478             :    INTERFACE mp_send
     479             :       MODULE PROCEDURE mp_send_i, mp_send_iv, mp_send_im2, mp_send_im3, &
     480             :          mp_send_l, mp_send_lv, mp_send_lm2, mp_send_lm3, &
     481             :          mp_send_r, mp_send_rv, mp_send_rm2, mp_send_rm3, &
     482             :          mp_send_d, mp_send_dv, mp_send_dm2, mp_send_dm3, &
     483             :          mp_send_c, mp_send_cv, mp_send_cm2, mp_send_cm3, &
     484             :          mp_send_z, mp_send_zv, mp_send_zm2, mp_send_zm3
     485             :    END INTERFACE
     486             : 
     487             :    INTERFACE mp_recv
     488             :       MODULE PROCEDURE mp_recv_i, mp_recv_iv, mp_recv_im2, mp_recv_im3, &
     489             :          mp_recv_l, mp_recv_lv, mp_recv_lm2, mp_recv_lm3, &
     490             :          mp_recv_r, mp_recv_rv, mp_recv_rm2, mp_recv_rm3, &
     491             :          mp_recv_d, mp_recv_dv, mp_recv_dm2, mp_recv_dm3, &
     492             :          mp_recv_c, mp_recv_cv, mp_recv_cm2, mp_recv_cm3, &
     493             :          mp_recv_z, mp_recv_zv, mp_recv_zm2, mp_recv_zm3
     494             :    END INTERFACE
     495             : 
     496             :    INTERFACE mp_sendrecv
     497             :       MODULE PROCEDURE mp_sendrecv_iv, mp_sendrecv_im2, mp_sendrecv_im3, mp_sendrecv_im4, &
     498             :          mp_sendrecv_lv, mp_sendrecv_lm2, mp_sendrecv_lm3, mp_sendrecv_lm4, &
     499             :          mp_sendrecv_rv, mp_sendrecv_rm2, mp_sendrecv_rm3, mp_sendrecv_rm4, &
     500             :          mp_sendrecv_dv, mp_sendrecv_dm2, mp_sendrecv_dm3, mp_sendrecv_dm4, &
     501             :          mp_sendrecv_cv, mp_sendrecv_cm2, mp_sendrecv_cm3, mp_sendrecv_cm4, &
     502             :          mp_sendrecv_zv, mp_sendrecv_zm2, mp_sendrecv_zm3, mp_sendrecv_zm4
     503             :    END INTERFACE
     504             : 
     505             :    INTERFACE mp_isendrecv
     506             :       MODULE PROCEDURE mp_isendrecv_i, mp_isendrecv_iv, &
     507             :          mp_isendrecv_l, mp_isendrecv_lv, &
     508             :          mp_isendrecv_r, mp_isendrecv_rv, &
     509             :          mp_isendrecv_d, mp_isendrecv_dv, &
     510             :          mp_isendrecv_c, mp_isendrecv_cv, &
     511             :          mp_isendrecv_z, mp_isendrecv_zv
     512             :    END INTERFACE
     513             : 
     514             :    INTERFACE mp_isend
     515             :       MODULE PROCEDURE mp_isend_iv, mp_isend_im2, mp_isend_im3, mp_isend_im4, &
     516             :          mp_isend_lv, mp_isend_lm2, mp_isend_lm3, mp_isend_lm4, &
     517             :          mp_isend_rv, mp_isend_rm2, mp_isend_rm3, mp_isend_rm4, &
     518             :          mp_isend_dv, mp_isend_dm2, mp_isend_dm3, mp_isend_dm4, &
     519             :          mp_isend_cv, mp_isend_cm2, mp_isend_cm3, mp_isend_cm4, &
     520             :          mp_isend_zv, mp_isend_zm2, mp_isend_zm3, mp_isend_zm4
     521             :       MODULE PROCEDURE mp_isend_bv, mp_isend_bm3
     522             :       MODULE PROCEDURE mp_isend_custom
     523             :    END INTERFACE
     524             : 
     525             :    INTERFACE mp_irecv
     526             :       MODULE PROCEDURE mp_irecv_iv, mp_irecv_im2, mp_irecv_im3, mp_irecv_im4, &
     527             :          mp_irecv_lv, mp_irecv_lm2, mp_irecv_lm3, mp_irecv_lm4, &
     528             :          mp_irecv_rv, mp_irecv_rm2, mp_irecv_rm3, mp_irecv_rm4, &
     529             :          mp_irecv_dv, mp_irecv_dm2, mp_irecv_dm3, mp_irecv_dm4, &
     530             :          mp_irecv_cv, mp_irecv_cm2, mp_irecv_cm3, mp_irecv_cm4, &
     531             :          mp_irecv_zv, mp_irecv_zm2, mp_irecv_zm3, mp_irecv_zm4
     532             :       MODULE PROCEDURE mp_irecv_bv, mp_irecv_bm3
     533             :       MODULE PROCEDURE mp_irecv_custom
     534             :    END INTERFACE
     535             : 
     536             :    INTERFACE mp_win_create
     537             :       MODULE PROCEDURE mp_win_create_iv, &
     538             :          mp_win_create_lv, &
     539             :          mp_win_create_rv, &
     540             :          mp_win_create_dv, &
     541             :          mp_win_create_cv, &
     542             :          mp_win_create_zv
     543             :    END INTERFACE
     544             : 
     545             :    INTERFACE mp_rget
     546             :       MODULE PROCEDURE mp_rget_iv, &
     547             :          mp_rget_lv, &
     548             :          mp_rget_rv, &
     549             :          mp_rget_dv, &
     550             :          mp_rget_cv, &
     551             :          mp_rget_zv
     552             :    END INTERFACE
     553             : 
     554             :    INTERFACE mp_allocate
     555             :       MODULE PROCEDURE mp_allocate_i, &
     556             :          mp_allocate_l, &
     557             :          mp_allocate_r, &
     558             :          mp_allocate_d, &
     559             :          mp_allocate_c, &
     560             :          mp_allocate_z
     561             :    END INTERFACE
     562             : 
     563             :    INTERFACE mp_deallocate
     564             :       MODULE PROCEDURE mp_deallocate_i, &
     565             :          mp_deallocate_l, &
     566             :          mp_deallocate_r, &
     567             :          mp_deallocate_d, &
     568             :          mp_deallocate_c, &
     569             :          mp_deallocate_z
     570             :    END INTERFACE
     571             : 
     572             :    INTERFACE mp_type_make
     573             :       MODULE PROCEDURE mp_type_make_struct
     574             :       MODULE PROCEDURE mp_type_make_i, mp_type_make_l, &
     575             :          mp_type_make_r, mp_type_make_d, &
     576             :          mp_type_make_c, mp_type_make_z
     577             :    END INTERFACE
     578             : 
     579             :    INTERFACE mp_file_write_at
     580             :       MODULE PROCEDURE mp_file_write_at_ch, mp_file_write_at_chv, &
     581             :          mp_file_write_at_i, mp_file_write_at_iv, &
     582             :          mp_file_write_at_r, mp_file_write_at_rv, &
     583             :          mp_file_write_at_d, mp_file_write_at_dv, &
     584             :          mp_file_write_at_c, mp_file_write_at_cv, &
     585             :          mp_file_write_at_z, mp_file_write_at_zv, &
     586             :          mp_file_write_at_l, mp_file_write_at_lv
     587             :    END INTERFACE
     588             : 
     589             :    INTERFACE mp_file_write_at_all
     590             :       MODULE PROCEDURE mp_file_write_at_all_ch, mp_file_write_at_all_chv, &
     591             :          mp_file_write_at_all_i, mp_file_write_at_all_iv, &
     592             :          mp_file_write_at_all_l, mp_file_write_at_all_lv, &
     593             :          mp_file_write_at_all_r, mp_file_write_at_all_rv, &
     594             :          mp_file_write_at_all_d, mp_file_write_at_all_dv, &
     595             :          mp_file_write_at_all_c, mp_file_write_at_all_cv, &
     596             :          mp_file_write_at_all_z, mp_file_write_at_all_zv
     597             :    END INTERFACE
     598             : 
     599             :    INTERFACE mp_file_read_at
     600             :       MODULE PROCEDURE mp_file_read_at_ch, mp_file_read_at_chv, &
     601             :          mp_file_read_at_i, mp_file_read_at_iv, &
     602             :          mp_file_read_at_r, mp_file_read_at_rv, &
     603             :          mp_file_read_at_d, mp_file_read_at_dv, &
     604             :          mp_file_read_at_c, mp_file_read_at_cv, &
     605             :          mp_file_read_at_z, mp_file_read_at_zv, &
     606             :          mp_file_read_at_l, mp_file_read_at_lv
     607             :    END INTERFACE
     608             : 
     609             :    INTERFACE mp_file_read_at_all
     610             :       MODULE PROCEDURE mp_file_read_at_all_ch, mp_file_read_at_all_chv, &
     611             :          mp_file_read_at_all_i, mp_file_read_at_all_iv, &
     612             :          mp_file_read_at_all_l, mp_file_read_at_all_lv, &
     613             :          mp_file_read_at_all_r, mp_file_read_at_all_rv, &
     614             :          mp_file_read_at_all_d, mp_file_read_at_all_dv, &
     615             :          mp_file_read_at_all_c, mp_file_read_at_all_cv, &
     616             :          mp_file_read_at_all_z, mp_file_read_at_all_zv
     617             :    END INTERFACE
     618             : 
     619             :    INTERFACE mp_alloc_mem
     620             :       MODULE PROCEDURE mp_alloc_mem_i, mp_alloc_mem_l, &
     621             :          mp_alloc_mem_d, mp_alloc_mem_z, &
     622             :          mp_alloc_mem_r, mp_alloc_mem_c
     623             :    END INTERFACE
     624             : 
     625             :    INTERFACE mp_free_mem
     626             :       MODULE PROCEDURE mp_free_mem_i, mp_free_mem_l, &
     627             :          mp_free_mem_d, mp_free_mem_z, &
     628             :          mp_free_mem_r, mp_free_mem_c
     629             :    END INTERFACE
     630             : 
     631             : ! Type declarations
     632             :    TYPE mp_indexing_meta_type
     633             :       INTEGER, DIMENSION(:), POINTER :: index, chunks
     634             :    END TYPE mp_indexing_meta_type
     635             : 
     636             :    TYPE mp_type_descriptor_type
     637             :       INTEGER :: type_handle
     638             :       INTEGER :: length
     639             : #if defined(__parallel)
     640             :       INTEGER(kind=mpi_address_kind) :: base
     641             : #endif
     642             :       INTEGER(kind=int_4), DIMENSION(:), POINTER :: data_i
     643             :       INTEGER(kind=int_8), DIMENSION(:), POINTER :: data_l
     644             :       REAL(kind=real_4), DIMENSION(:), POINTER :: data_r
     645             :       REAL(kind=real_8), DIMENSION(:), POINTER :: data_d
     646             :       COMPLEX(kind=real_4), DIMENSION(:), POINTER :: data_c
     647             :       COMPLEX(kind=real_8), DIMENSION(:), POINTER :: data_z
     648             :       TYPE(mp_type_descriptor_type), DIMENSION(:), POINTER :: subtype
     649             :       INTEGER :: vector_descriptor(2)
     650             :       LOGICAL :: has_indexing
     651             :       TYPE(mp_indexing_meta_type) :: index_descriptor
     652             :    END TYPE mp_type_descriptor_type
     653             : 
     654             :    TYPE mp_file_indexing_meta_type
     655             :       INTEGER, DIMENSION(:), POINTER   :: index
     656             :       INTEGER(kind=file_offset), &
     657             :          DIMENSION(:), POINTER         :: chunks
     658             :    END TYPE mp_file_indexing_meta_type
     659             : 
     660             :    TYPE mp_file_descriptor_type
     661             :       INTEGER                          :: type_handle
     662             :       INTEGER                          :: length
     663             :       LOGICAL                          :: has_indexing = .FALSE.
     664             :       TYPE(mp_file_indexing_meta_type) :: index_descriptor
     665             :    END TYPE
     666             : 
     667             :    ! type internally used to store message passing performance indicators
     668             : ! **************************************************************************************************
     669             :    TYPE mp_perf_type
     670             :       CHARACTER(LEN=20) :: name
     671             :       INTEGER :: count
     672             :       REAL(KIND=dp) :: msg_size
     673             :    END TYPE mp_perf_type
     674             : 
     675             :    INTEGER, PARAMETER :: MAX_PERF = 28
     676             : 
     677             : ! **************************************************************************************************
     678             :    TYPE mp_perf_env_type
     679             :       !private
     680             :       INTEGER :: ref_count, id_nr
     681             :       TYPE(mp_perf_type), DIMENSION(MAX_PERF) :: mp_perfs
     682             :    END TYPE mp_perf_env_type
     683             : 
     684             : ! **************************************************************************************************
     685             :    TYPE mp_perf_env_p_type
     686             :       TYPE(mp_perf_env_type), POINTER         :: mp_perf_env => Null()
     687             :    END TYPE mp_perf_env_p_type
     688             : 
     689             :    ! introduce a stack of mp_perfs, first index is the stack pointer, for convenience is replacing
     690             :    INTEGER, PARAMETER :: max_stack_size = 10
     691             :    INTEGER            :: stack_pointer = 0
     692             :    ! target attribute needed as a hack around ifc 7.1 bug
     693             :    TYPE(mp_perf_env_p_type), DIMENSION(max_stack_size), TARGET, SAVE :: mp_perf_stack
     694             : 
     695             :    CHARACTER(LEN=20), PARAMETER :: sname(MAX_PERF) = &
     696             :                                    (/"MP_Group            ", "MP_Bcast            ", "MP_Allreduce        ", &
     697             :                                      "MP_Gather           ", "MP_Sync             ", "MP_Alltoall         ", &
     698             :                                      "MP_SendRecv         ", "MP_ISendRecv        ", "MP_Wait             ", &
     699             :                                      "MP_comm_split       ", "MP_ISend            ", "MP_IRecv            ", &
     700             :                                      "MP_Send             ", "MP_Recv             ", "MP_Memory           ", &
     701             :                                      "MP_Put              ", "MP_Get              ", "MP_Fence            ", &
     702             :                                      "MP_Win_Lock         ", "MP_Win_Create       ", "MP_Win_Free         ", &
     703             :                                      "MP_IBcast           ", "MP_IAllreduce       ", "MP_IScatter         ", &
     704             :                                      "MP_RGet             ", "MP_Isync            ", "MP_Read_All         ", &
     705             :                                      "MP_Write_All        "/)
     706             : 
     707             :    ! we make some assumptions on the length of INTEGERS, REALS and LOGICALS
     708             :    INTEGER, PARAMETER :: intlen = BIT_SIZE(0)/8
     709             :    INTEGER, PARAMETER :: reallen = 8
     710             :    INTEGER, PARAMETER :: loglen = BIT_SIZE(0)/8
     711             :    INTEGER, PARAMETER :: charlen = 1
     712             :    INTEGER, SAVE, PRIVATE :: last_mp_perf_env_id = 0
     713             : 
     714             :    LOGICAL, PUBLIC, SAVE :: mp_collect_timings = .FALSE.
     715             : 
     716             : CONTAINS
     717             : 
     718             : ! **************************************************************************************************
     719             : !> \brief initializes the system default communicator
     720             : !> \param mp_comm [output] : handle of the default communicator
     721             : !> \par History
     722             : !>      2.2004 created [Joost VandeVondele ]
     723             : !> \note
     724             : !>      should only be called once
     725             : ! **************************************************************************************************
     726        6986 :    SUBROUTINE mp_world_init(mp_comm)
     727             :       INTEGER, INTENT(OUT)                     :: mp_comm
     728             : #if defined(__parallel)
     729             :       INTEGER                                  :: ierr
     730             : !$    INTEGER                                  :: provided_tsl
     731             : !$    LOGICAL                                  :: no_threading_support
     732             : 
     733             : #if defined(__NO_MPI_THREAD_SUPPORT_CHECK)
     734             :       ! Hack that does not request or check MPI thread support level.
     735             :       ! User asserts that the MPI library will work correctly with
     736             :       ! threads.
     737             : !
     738             : !$    no_threading_support = .TRUE.
     739             : #else
     740             :       ! Does the right thing when using OpenMP: requests that the MPI
     741             :       ! library supports serialized mode and verifies that the MPI library
     742             :       ! provides that support.
     743             :       !
     744             :       ! Developers: Only the master thread will ever make calls to the
     745             :       ! MPI library.
     746             : !
     747        6986 : !$    no_threading_support = .FALSE.
     748             : #endif
     749             : !$    IF (no_threading_support) THEN
     750             :          CALL mpi_init(ierr)
     751             :          IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init @ mp_world_init")
     752             : !$    ELSE
     753        6986 : !$OMP MASTER
     754        6986 : !$       CALL mpi_init_thread(MPI_THREAD_SERIALIZED, provided_tsl, ierr)
     755        6986 : !$       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init_thread @ mp_world_init")
     756        6986 : !$       IF (provided_tsl .LT. MPI_THREAD_SERIALIZED) THEN
     757           0 : !$          CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_SERIALIZED).")
     758             : !$       ENDIF
     759             : !$OMP END MASTER
     760             : !$    ENDIF
     761             : #if __MPI_VERSION > 2
     762        6986 :       CALL mpi_comm_set_errhandler(MPI_COMM_WORLD, MPI_ERRORS_RETURN, ierr)
     763             : #else
     764             :       CALL mpi_errhandler_set(MPI_COMM_WORLD, MPI_ERRORS_RETURN, ierr)
     765             : #endif
     766        6986 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_set_errhandler @ mp_world_init")
     767        6986 :       mp_comm = MPI_COMM_WORLD
     768        6986 :       debug_comm_count = 1
     769             : #else
     770             :       mp_comm = 0
     771             : #endif
     772        6986 :       CALL add_mp_perf_env()
     773        6986 :    END SUBROUTINE mp_world_init
     774             : 
     775             : ! **************************************************************************************************
     776             : !> \brief re-create the system default communicator with a different MPI
     777             : !>        rank order
     778             : !> \param mp_comm [output] : handle of the default communicator
     779             : !> \param mp_new_comm ...
     780             : !> \param ranks_order ...
     781             : !> \par History
     782             : !>      1.2012 created [ Christiane Pousa ]
     783             : !> \note
     784             : !>      should only be called once, at very beginning of CP2K run
     785             : ! **************************************************************************************************
     786         560 :    SUBROUTINE mp_reordering(mp_comm, mp_new_comm, ranks_order)
     787             :       INTEGER, INTENT(IN)                      :: mp_comm
     788             :       INTEGER, INTENT(out)                     :: mp_new_comm
     789             :       INTEGER, DIMENSION(:)                    :: ranks_order
     790             : 
     791             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_reordering'
     792             : 
     793             :       INTEGER                                  :: handle, ierr
     794             : #if defined(__parallel)
     795             :       INTEGER                                  :: newcomm, newgroup, oldgroup
     796             : #endif
     797             : 
     798         560 :       CALL mp_timeset(routineN, handle)
     799         560 :       ierr = 0
     800             : #if defined(__parallel)
     801             : 
     802         560 :       CALL mpi_comm_group(mp_comm, oldgroup, ierr)
     803         560 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_reordering")
     804         560 :       CALL mpi_group_incl(oldgroup, SIZE(ranks_order), ranks_order, newgroup, ierr)
     805         560 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_incl @ mp_reordering")
     806             : 
     807         560 :       CALL mpi_comm_create(mp_comm, newgroup, newcomm, ierr)
     808         560 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_create @ mp_reordering")
     809             : 
     810         560 :       CALL mpi_group_free(oldgroup, ierr)
     811         560 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
     812         560 :       CALL mpi_group_free(newgroup, ierr)
     813         560 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
     814             : 
     815             :       ! update the system default communicator
     816         560 :       mp_new_comm = newcomm
     817         560 :       debug_comm_count = debug_comm_count + 1
     818             : 
     819         560 :       CALL add_perf(perf_id=1, count=1)
     820             : #else
     821             :       MARK_USED(ranks_order)
     822             :       mp_new_comm = mp_comm
     823             : #endif
     824         560 :       CALL mp_timestop(handle)
     825         560 :    END SUBROUTINE mp_reordering
     826             : 
     827             : ! **************************************************************************************************
     828             : !> \brief finalizes the system default communicator
     829             : !> \par History
     830             : !>      2.2004 created [Joost VandeVondele]
     831             : ! **************************************************************************************************
     832        6986 :    SUBROUTINE mp_world_finalize()
     833             : 
     834             : #if defined(__parallel)
     835             :       INTEGER                                  :: ierr
     836        6986 :       CALL mpi_barrier(MPI_COMM_WORLD, ierr) ! call mpi directly to avoid 0 stack pointer
     837        6986 :       CALL rm_mp_perf_env()
     838        6986 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_world_finalize")
     839        6986 :       debug_comm_count = debug_comm_count - 1
     840        6986 :       IF (debug_comm_count .NE. 0) THEN
     841             :          ! A bug, we're leaking or double-freeing communicators. Needs to be fixed where the leak happens.
     842             :          ! Memory leak checking might be helpful to locate the culprit
     843           0 :          CPABORT("mp_world_finalize: assert failed:  leaking communicators")
     844             :       ENDIF
     845        6986 :       CALL mpi_finalize(ierr)
     846        6986 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_finalize @ mp_world_finalize")
     847             : #else
     848             :       CALL rm_mp_perf_env()
     849             : #endif
     850             : 
     851        6986 :    END SUBROUTINE mp_world_finalize
     852             : 
     853             : ! all the following routines should work for a given communicator, not MPI_WORLD
     854             : 
     855             : ! **************************************************************************************************
     856             : !> \brief start and stop the performance indicators
     857             : !>      for every call to start there has to be (exactly) one call to stop
     858             : !> \param perf_env ...
     859             : !> \par History
     860             : !>      2.2004 created [Joost VandeVondele]
     861             : !> \note
     862             : !>      can be used to measure performance of a sub-part of a program.
     863             : !>      timings measured here will not show up in the outer start/stops
     864             : !>      Doesn't need a fresh communicator
     865             : ! **************************************************************************************************
     866       94340 :    SUBROUTINE add_mp_perf_env(perf_env)
     867             :       TYPE(mp_perf_env_type), OPTIONAL, POINTER          :: perf_env
     868             : 
     869       94340 :       stack_pointer = stack_pointer + 1
     870       94340 :       IF (stack_pointer > max_stack_size) THEN
     871           0 :          CPABORT("stack_pointer too large : message_passing @ add_mp_perf_env")
     872             :       ENDIF
     873       94340 :       NULLIFY (mp_perf_stack(stack_pointer)%mp_perf_env)
     874       94340 :       IF (PRESENT(perf_env)) THEN
     875       72813 :          mp_perf_stack(stack_pointer)%mp_perf_env => perf_env
     876       72813 :          IF (ASSOCIATED(perf_env)) CALL mp_perf_env_retain(perf_env)
     877             :       END IF
     878       94340 :       IF (.NOT. ASSOCIATED(mp_perf_stack(stack_pointer)%mp_perf_env)) THEN
     879       21527 :          CALL mp_perf_env_create(mp_perf_stack(stack_pointer)%mp_perf_env)
     880             :       END IF
     881       94340 :    END SUBROUTINE add_mp_perf_env
     882             : 
     883             : ! **************************************************************************************************
     884             : !> \brief ...
     885             : !> \param perf_env ...
     886             : ! **************************************************************************************************
     887       21527 :    SUBROUTINE mp_perf_env_create(perf_env)
     888             :       TYPE(mp_perf_env_type), OPTIONAL, POINTER          :: perf_env
     889             : 
     890             :       INTEGER                                            :: i, stat
     891             : 
     892             :       NULLIFY (perf_env)
     893       21527 :       ALLOCATE (perf_env, stat=stat)
     894             :       IF (stat /= 0) THEN
     895           0 :          CPABORT("allocation failed in mp_perf_env_create")
     896             :       ENDIF
     897       21527 :       last_mp_perf_env_id = last_mp_perf_env_id + 1
     898       21527 :       perf_env%id_nr = last_mp_perf_env_id
     899       21527 :       perf_env%ref_count = 1
     900      624283 :       DO i = 1, MAX_PERF
     901      602756 :          perf_env%mp_perfs(i)%name = sname(i)
     902      602756 :          perf_env%mp_perfs(i)%count = 0
     903      624283 :          perf_env%mp_perfs(i)%msg_size = 0.0_dp
     904             :       END DO
     905             : 
     906       21527 :    END SUBROUTINE mp_perf_env_create
     907             : 
     908             : ! **************************************************************************************************
     909             : !> \brief ...
     910             : !> \param perf_env ...
     911             : ! **************************************************************************************************
     912      101397 :    SUBROUTINE mp_perf_env_release(perf_env)
     913             :       TYPE(mp_perf_env_type), POINTER                    :: perf_env
     914             : 
     915      101397 :       IF (ASSOCIATED(perf_env)) THEN
     916      101397 :          IF (perf_env%ref_count < 1) THEN
     917           0 :             CPABORT("invalid ref_count: message_passing @ mp_perf_env_release")
     918             :          END IF
     919      101397 :          perf_env%ref_count = perf_env%ref_count - 1
     920      101397 :          IF (perf_env%ref_count == 0) THEN
     921       21527 :             DEALLOCATE (perf_env)
     922             :          END IF
     923             :       END IF
     924      101397 :       NULLIFY (perf_env)
     925      101397 :    END SUBROUTINE mp_perf_env_release
     926             : 
     927             : ! **************************************************************************************************
     928             : !> \brief ...
     929             : !> \param perf_env ...
     930             : ! **************************************************************************************************
     931       79870 :    SUBROUTINE mp_perf_env_retain(perf_env)
     932             :       TYPE(mp_perf_env_type), POINTER                    :: perf_env
     933             : 
     934       79870 :       IF (.NOT. ASSOCIATED(perf_env)) THEN
     935           0 :          CPABORT("unassociated perf_env: message_passing @ mp_perf_env_retain")
     936             :       END IF
     937       79870 :       IF (perf_env%ref_count < 1) THEN
     938           0 :          CPABORT("invalid ref_count: message_passing @ mp_perf_env_retain")
     939             :       END IF
     940       79870 :       perf_env%ref_count = perf_env%ref_count + 1
     941       79870 :    END SUBROUTINE mp_perf_env_retain
     942             : 
     943             : !.. reports the performance counters for the MPI run
     944             : ! **************************************************************************************************
     945             : !> \brief ...
     946             : !> \param perf_env ...
     947             : !> \param iw ...
     948             : ! **************************************************************************************************
     949        7557 :    SUBROUTINE mp_perf_env_describe(perf_env, iw)
     950             :       TYPE(mp_perf_env_type), POINTER          :: perf_env
     951             :       INTEGER, INTENT(IN)                      :: iw
     952             : 
     953             : #if defined(__parallel)
     954             :       INTEGER                                  :: i
     955             :       REAL(KIND=dp)                            :: vol
     956             : #endif
     957             : 
     958        7557 :       IF (.NOT. ASSOCIATED(perf_env)) THEN
     959           0 :          CPABORT("unassociated perf_env : message_passing @ mp_perf_env_describe")
     960             :       ENDIF
     961        7557 :       IF (perf_env%ref_count < 1) THEN
     962           0 :          CPABORT("invalid perf_env%ref_count : message_passing @ mp_perf_env_describe")
     963             :       ENDIF
     964             : #if defined(__parallel)
     965        7557 :       IF (iw > 0) THEN
     966        3874 :          WRITE (iw, '( /, 1X, 79("-") )')
     967        3874 :          WRITE (iw, '( " -", 77X, "-" )')
     968        3874 :          WRITE (iw, '( " -", 24X, A, 24X, "-" )') ' MESSAGE PASSING PERFORMANCE '
     969        3874 :          WRITE (iw, '( " -", 77X, "-" )')
     970        3874 :          WRITE (iw, '( 1X, 79("-"), / )')
     971        3874 :          WRITE (iw, '( A, A, A )') ' ROUTINE', '             CALLS ', &
     972        7748 :             '     AVE VOLUME [Bytes]'
     973      112346 :          DO i = 1, MAX_PERF
     974             : 
     975      112346 :             IF (perf_env%mp_perfs(i)%count > 0) THEN
     976       21940 :                vol = perf_env%mp_perfs(i)%msg_size/REAL(perf_env%mp_perfs(i)%count, KIND=dp)
     977       21940 :                IF (vol < 1.0_dp) THEN
     978             :                   WRITE (iw, '(1X,A15,T17,I10)') &
     979        8977 :                      ADJUSTL(perf_env%mp_perfs(i)%name), perf_env%mp_perfs(i)%count
     980             :                ELSE
     981             :                   WRITE (iw, '(1X,A15,T17,I10,T40,F11.0)') &
     982       12963 :                      ADJUSTL(perf_env%mp_perfs(i)%name), perf_env%mp_perfs(i)%count, &
     983       25926 :                      vol
     984             :                END IF
     985             :             ENDIF
     986             : 
     987             :          END DO
     988        3874 :          WRITE (iw, '( 1X, 79("-"), / )')
     989             :       END IF
     990             : #else
     991             :       MARK_USED(iw)
     992             : #endif
     993        7557 :    END SUBROUTINE mp_perf_env_describe
     994             : 
     995             : ! **************************************************************************************************
     996             : !> \brief ...
     997             : ! **************************************************************************************************
     998       94340 :    SUBROUTINE rm_mp_perf_env()
     999       94340 :       IF (stack_pointer < 1) THEN
    1000           0 :          CPABORT("no perf_env in the stack : message_passing @ rm_mp_perf_env")
    1001             :       ENDIF
    1002       94340 :       CALL mp_perf_env_release(mp_perf_stack(stack_pointer)%mp_perf_env)
    1003       94340 :       stack_pointer = stack_pointer - 1
    1004       94340 :    END SUBROUTINE rm_mp_perf_env
    1005             : 
    1006             : ! **************************************************************************************************
    1007             : !> \brief ...
    1008             : !> \return ...
    1009             : ! **************************************************************************************************
    1010       87427 :    FUNCTION get_mp_perf_env() RESULT(res)
    1011             :       TYPE(mp_perf_env_type), POINTER                    :: res
    1012             : 
    1013       87427 :       IF (stack_pointer < 1) THEN
    1014           0 :          CPABORT("no perf_env in the stack : message_passing @ get_mp_perf_env")
    1015             :       ENDIF
    1016       87427 :       res => mp_perf_stack(stack_pointer)%mp_perf_env
    1017       87427 :    END FUNCTION get_mp_perf_env
    1018             : 
    1019             : ! **************************************************************************************************
    1020             : !> \brief ...
    1021             : !> \param scr ...
    1022             : ! **************************************************************************************************
    1023        7557 :    SUBROUTINE describe_mp_perf_env(scr)
    1024             :       INTEGER, INTENT(in)                                :: scr
    1025             : 
    1026             :       TYPE(mp_perf_env_type), POINTER                    :: perf_env
    1027             : 
    1028        7557 :       perf_env => get_mp_perf_env()
    1029        7557 :       CALL mp_perf_env_describe(perf_env, scr)
    1030        7557 :    END SUBROUTINE describe_mp_perf_env
    1031             : 
    1032             : ! **************************************************************************************************
    1033             : !> \brief adds the performance informations of one call
    1034             : !> \param perf_id ...
    1035             : !> \param count ...
    1036             : !> \param msg_size ...
    1037             : !> \author fawzi
    1038             : ! **************************************************************************************************
    1039    54996122 :    SUBROUTINE add_perf(perf_id, count, msg_size)
    1040             :       INTEGER, INTENT(in)                      :: perf_id
    1041             :       INTEGER, INTENT(in), OPTIONAL            :: count
    1042             :       INTEGER, INTENT(in), OPTIONAL            :: msg_size
    1043             : 
    1044             : #if defined(__parallel)
    1045             :       TYPE(mp_perf_type), POINTER              :: mp_perf
    1046             : 
    1047    54996122 :       IF (.NOT. ASSOCIATED(mp_perf_stack(stack_pointer)%mp_perf_env)) return
    1048             : 
    1049    54996122 :       mp_perf => mp_perf_stack(stack_pointer)%mp_perf_env%mp_perfs(perf_id)
    1050    54996122 :       IF (PRESENT(count)) THEN
    1051    54996122 :          mp_perf%count = mp_perf%count + count
    1052             :       END IF
    1053    54996122 :       IF (PRESENT(msg_size)) THEN
    1054    52451757 :          mp_perf%msg_size = mp_perf%msg_size + REAL(msg_size, dp)
    1055             :       END IF
    1056             : #else
    1057             :       MARK_USED(perf_id)
    1058             :       MARK_USED(count)
    1059             :       MARK_USED(msg_size)
    1060             : #endif
    1061             : 
    1062             :    END SUBROUTINE add_perf
    1063             : 
    1064             : ! **************************************************************************************************
    1065             : !> \brief globally stops all tasks
    1066             : !>       this is intended to be low level, most of CP2K should call cp_abort()
    1067             : ! **************************************************************************************************
    1068           0 :    SUBROUTINE mp_abort()
    1069             :       INTEGER                                            :: ierr
    1070             : 
    1071           0 :       ierr = 0
    1072             : 
    1073             : #if !defined(__NO_ABORT)
    1074             : #if defined(__parallel)
    1075             :       CALL mpi_abort(MPI_COMM_WORLD, 1, ierr)
    1076             : #else
    1077             :       CALL m_abort()
    1078             : #endif
    1079             : #endif
    1080             :       ! this routine never returns and levels with non-zero exit code
    1081           0 :       STOP 1
    1082             :    END SUBROUTINE mp_abort
    1083             : 
    1084             : ! **************************************************************************************************
    1085             : !> \brief stops *after an mpi error* translating the error code
    1086             : !> \param ierr an error code * returned by an mpi call *
    1087             : !> \param prg_code ...
    1088             : !> \note
    1089             : !>       this function is private to message_passing.F
    1090             : ! **************************************************************************************************
    1091           0 :    SUBROUTINE mp_stop(ierr, prg_code)
    1092             :       INTEGER, INTENT(IN)                      :: ierr
    1093             :       CHARACTER(LEN=*)                         :: prg_code
    1094             : 
    1095             : #if defined(__parallel)
    1096             :       INTEGER                                  :: istat, len
    1097             :       CHARACTER(LEN=MPI_MAX_ERROR_STRING)     :: error_string
    1098             :       CHARACTER(LEN=MPI_MAX_ERROR_STRING + 512)  :: full_error
    1099             : #else
    1100             :       CHARACTER(LEN=512)                       :: full_error
    1101             : #endif
    1102             : 
    1103             : #if defined(__parallel)
    1104           0 :       CALL mpi_error_string(ierr, error_string, len, istat)
    1105           0 :       WRITE (full_error, '(A,I0,A)') ' MPI error ', ierr, ' in '//TRIM(prg_code)//' : '//error_string(1:len)
    1106             : #else
    1107             :       WRITE (full_error, '(A,I0,A)') ' MPI error (!?) ', ierr, ' in '//TRIM(prg_code)
    1108             : #endif
    1109             : 
    1110           0 :       CPABORT(full_error)
    1111             : 
    1112           0 :    END SUBROUTINE mp_stop
    1113             : 
    1114             : ! **************************************************************************************************
    1115             : !> \brief synchronizes with a barrier a given group of mpi tasks
    1116             : !> \param group mpi communicator
    1117             : ! **************************************************************************************************
    1118      450979 :    SUBROUTINE mp_sync(group)
    1119             :       INTEGER, INTENT(IN)                                :: group
    1120             : 
    1121             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_sync'
    1122             : 
    1123             :       INTEGER                                            :: handle, ierr
    1124             : 
    1125      450979 :       ierr = 0
    1126      450979 :       CALL mp_timeset(routineN, handle)
    1127             : 
    1128             : #if defined(__parallel)
    1129      450979 :       CALL mpi_barrier(group, ierr)
    1130      450979 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_sync")
    1131      450979 :       CALL add_perf(perf_id=5, count=1)
    1132             : #else
    1133             :       MARK_USED(group)
    1134             : #endif
    1135      450979 :       CALL mp_timestop(handle)
    1136             : 
    1137      450979 :    END SUBROUTINE mp_sync
    1138             : 
    1139             : ! **************************************************************************************************
    1140             : !> \brief synchronizes with a barrier a given group of mpi tasks
    1141             : !> \param group mpi communicator
    1142             : !> \param request ...
    1143             : ! **************************************************************************************************
    1144           0 :    SUBROUTINE mp_isync(group, request)
    1145             :       INTEGER, INTENT(IN)                                :: group
    1146             :       INTEGER, INTENT(OUT)                               :: request
    1147             : 
    1148             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_isync'
    1149             : 
    1150             :       INTEGER                                            :: handle, ierr
    1151             : 
    1152           0 :       ierr = 0
    1153           0 :       CALL mp_timeset(routineN, handle)
    1154             : 
    1155             : #if defined(__parallel)
    1156             : #if __MPI_VERSION > 2
    1157           0 :       CALL mpi_ibarrier(group, request, ierr)
    1158           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibarrier @ mp_isync")
    1159           0 :       CALL add_perf(perf_id=26, count=1)
    1160             : #else
    1161             :       MARK_USED(group)
    1162             :       MARK_USED(request)
    1163             :       CPABORT("mp_isum requires MPI-3 standard")
    1164             : #endif
    1165             : #else
    1166             :       MARK_USED(group)
    1167             :       request = mp_request_null
    1168             : #endif
    1169           0 :       CALL mp_timestop(handle)
    1170             : 
    1171           0 :    END SUBROUTINE mp_isync
    1172             : 
    1173             : ! **************************************************************************************************
    1174             : !> \brief returns number of tasks and task id for a given mpi group
    1175             : !>       simple and cartesian version.. recursive needed in case of failing mpi_comm_rank.
    1176             : !> \param numtask ...
    1177             : !> \param taskid ...
    1178             : !> \param groupid mpi communicator
    1179             : !> \note
    1180             : !>         ..mp_world_setup is gone, use mp_environ instead (i.e. give a groupid explicitly)
    1181             : ! **************************************************************************************************
    1182     4308183 :    RECURSIVE SUBROUTINE mp_environ_l(numtask, taskid, groupid)
    1183             : 
    1184             :       INTEGER, INTENT(OUT)                               :: numtask, taskid
    1185             :       INTEGER, INTENT(IN)                                :: groupid
    1186             : 
    1187             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_environ_l'
    1188             : 
    1189             :       INTEGER                                            :: handle, ierr
    1190             : 
    1191     4308183 :       ierr = 0
    1192     4308183 :       CALL mp_timeset(routineN, handle)
    1193             : 
    1194     4308183 :       numtask = 1
    1195     4308183 :       taskid = 0
    1196             : #if defined(__parallel)
    1197     4308183 :       CALL mpi_comm_rank(groupid, taskid, ierr)
    1198     4308183 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_environ_l")
    1199             : 
    1200     4308183 :       CALL mpi_comm_size(groupid, numtask, ierr)
    1201     4308183 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_environ_l")
    1202             : #else
    1203             :       MARK_USED(groupid)
    1204             : #endif
    1205     4308183 :       CALL mp_timestop(handle)
    1206             : 
    1207     4308183 :    END SUBROUTINE mp_environ_l
    1208             : 
    1209             : ! **************************************************************************************************
    1210             : !> \brief ...
    1211             : !> \param numtask ...
    1212             : !> \param dims ...
    1213             : !> \param task_coor ...
    1214             : !> \param groupid ...
    1215             : ! **************************************************************************************************
    1216     1425438 :    SUBROUTINE mp_environ_c(numtask, dims, task_coor, groupid)
    1217             : 
    1218             :       INTEGER, INTENT(OUT)                     :: numtask, dims(2), &
    1219             :                                                   task_coor(2)
    1220             :       INTEGER, INTENT(IN)                      :: groupid
    1221             : 
    1222             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_environ_c'
    1223             : 
    1224             :       INTEGER                                  :: handle, ierr
    1225             : #if defined(__parallel)
    1226             :       LOGICAL, DIMENSION(2)                    :: periods
    1227             : #endif
    1228             : 
    1229     1425438 :       ierr = 0
    1230     1425438 :       CALL mp_timeset(routineN, handle)
    1231     1425438 :       numtask = 1
    1232     1425438 :       task_coor = 0
    1233     4276314 :       dims = 1
    1234             : #if defined(__parallel)
    1235     1425438 :       CALL mpi_comm_size(groupid, numtask, ierr)
    1236     1425438 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_environ_c")
    1237             : 
    1238     1425438 :       CALL mpi_cart_get(groupid, 2, dims, periods, task_coor, ierr)
    1239     1425438 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_get @ mp_environ_c")
    1240             : #else
    1241             :       MARK_USED(groupid)
    1242             : #endif
    1243     1425438 :       CALL mp_timestop(handle)
    1244             : 
    1245     1425438 :    END SUBROUTINE mp_environ_c
    1246             : 
    1247             : ! **************************************************************************************************
    1248             : !> \brief ...
    1249             : !> \param comm ...
    1250             : !> \param ndims ...
    1251             : !> \param dims ...
    1252             : !> \param task_coor ...
    1253             : !> \param periods ...
    1254             : ! **************************************************************************************************
    1255         238 :    SUBROUTINE mp_environ_c2(comm, ndims, dims, task_coor, periods)
    1256             : 
    1257             :       INTEGER, INTENT(IN)                                :: comm, ndims
    1258             :       INTEGER, INTENT(OUT)                               :: dims(ndims), task_coor(ndims)
    1259             :       LOGICAL, INTENT(out)                               :: periods(ndims)
    1260             : 
    1261             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_environ_c2'
    1262             : 
    1263             :       INTEGER                                            :: handle, ierr
    1264             : 
    1265         238 :       ierr = 0
    1266         238 :       CALL mp_timeset(routineN, handle)
    1267             : 
    1268         714 :       task_coor = 0
    1269         714 :       dims = 1
    1270         714 :       periods = .FALSE.
    1271             : #if defined(__parallel)
    1272         238 :       CALL mpi_cart_get(comm, ndims, dims, periods, task_coor, ierr)
    1273         238 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_get @ mp_environ_c")
    1274             : #else
    1275             :       MARK_USED(comm)
    1276             : #endif
    1277         238 :       CALL mp_timestop(handle)
    1278             : 
    1279         238 :    END SUBROUTINE mp_environ_c2
    1280             : 
    1281             : !..mp_cart_create
    1282             : ! **************************************************************************************************
    1283             : !> \brief ...
    1284             : !> \param comm_old ...
    1285             : !> \param ndims ...
    1286             : !> \param dims ...
    1287             : !> \param pos ...
    1288             : !> \param comm_cart ...
    1289             : ! **************************************************************************************************
    1290       24623 :    SUBROUTINE mp_cart_create(comm_old, ndims, dims, pos, comm_cart)
    1291             : 
    1292             :       INTEGER, INTENT(IN)                      :: comm_old, ndims
    1293             :       INTEGER, INTENT(INOUT)                   :: dims(:)
    1294             :       INTEGER, INTENT(OUT)                     :: pos(:), comm_cart
    1295             : 
    1296             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_create'
    1297             : 
    1298             :       INTEGER                                  :: handle, ierr, nodes
    1299             : #if defined(__parallel)
    1300       49246 :       LOGICAL, DIMENSION(1:ndims)              :: period
    1301             :       LOGICAL                                  :: reorder
    1302             : #endif
    1303             : 
    1304       24623 :       ierr = 0
    1305       24623 :       CALL mp_timeset(routineN, handle)
    1306             : 
    1307       24623 :       nodes = 0
    1308       73961 :       pos(1:ndims) = -1
    1309       24623 :       comm_cart = comm_old
    1310             : #if defined(__parallel)
    1311             : 
    1312       24623 :       CALL mpi_comm_size(comm_old, nodes, ierr)
    1313       24623 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_cart_create")
    1314             : 
    1315       73907 :       IF (ANY(dims == 0)) CALL mpi_dims_create(nodes, ndims, dims, ierr)
    1316       24623 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_cart_create")
    1317             : 
    1318             :       ! FIX ME.  Quick hack to avoid problems with realspace grids for compilers
    1319             :       ! like IBM that actually reorder the processors when creating the new
    1320             :       ! communicator
    1321       24623 :       reorder = .FALSE.
    1322       73961 :       period = .TRUE.
    1323             :       CALL mpi_cart_create(comm_old, ndims, dims, period, reorder, comm_cart, &
    1324       24623 :                            ierr)
    1325       24623 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_create @ mp_cart_create")
    1326             : 
    1327       24623 :       IF (comm_cart /= MPI_COMM_NULL) THEN
    1328       24623 :          debug_comm_count = debug_comm_count + 1
    1329       24623 :          CALL mpi_cart_get(comm_cart, ndims, dims, period, pos, ierr)
    1330       24623 :          IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_get @ mp_cart_create")
    1331             :       END IF
    1332       24623 :       CALL add_perf(perf_id=1, count=1)
    1333             : #else
    1334             :       pos(1:ndims) = 0
    1335             :       dims = 1
    1336             :       comm_cart = 0
    1337             : #endif
    1338       24623 :       CALL mp_timestop(handle)
    1339             : 
    1340       24623 :    END SUBROUTINE mp_cart_create
    1341             : 
    1342             : !..mp_cart_coords
    1343             : ! **************************************************************************************************
    1344             : !> \brief ...
    1345             : !> \param comm ...
    1346             : !> \param rank ...
    1347             : !> \param coords ...
    1348             : ! **************************************************************************************************
    1349       41816 :    SUBROUTINE mp_cart_coords(comm, rank, coords)
    1350             : 
    1351             :       INTEGER, INTENT(IN)                                :: comm, rank
    1352             :       INTEGER, DIMENSION(:), INTENT(OUT)                 :: coords
    1353             : 
    1354             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_coords'
    1355             : 
    1356             :       INTEGER                                            :: handle, ierr, m
    1357             : 
    1358       41816 :       ierr = 0
    1359       41816 :       CALL mp_timeset(routineN, handle)
    1360             : 
    1361       41816 :       m = SIZE(coords)
    1362             : #if defined(__parallel)
    1363       41816 :       CALL mpi_cart_coords(comm, rank, m, coords, ierr)
    1364       41816 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_coords @ mp_cart_coords")
    1365             : #else
    1366             :       coords = 0
    1367             :       MARK_USED(rank)
    1368             :       MARK_USED(comm)
    1369             : #endif
    1370       41816 :       CALL mp_timestop(handle)
    1371             : 
    1372       41816 :    END SUBROUTINE mp_cart_coords
    1373             : 
    1374             : !..mp_comm_compare
    1375             : ! **************************************************************************************************
    1376             : !> \brief ...
    1377             : !> \param comm1 ...
    1378             : !> \param comm2 ...
    1379             : !> \param res ...
    1380             : ! **************************************************************************************************
    1381     1439882 :    SUBROUTINE mp_comm_compare(comm1, comm2, res)
    1382             : 
    1383             :       INTEGER, INTENT(IN)                                :: comm1, comm2
    1384             :       INTEGER, INTENT(OUT)                               :: res
    1385             : 
    1386             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_compare'
    1387             : 
    1388             :       INTEGER                                            :: handle, ierr, iout
    1389             : 
    1390     1439882 :       ierr = 0
    1391     1439882 :       CALL mp_timeset(routineN, handle)
    1392             : 
    1393     1439882 :       iout = 0
    1394     1439882 :       res = 0
    1395             : #if defined(__parallel)
    1396     1439882 :       CALL mpi_comm_compare(comm1, comm2, iout, ierr)
    1397     1439882 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_compare @ mp_comm_compare")
    1398           0 :       SELECT CASE (iout)
    1399             :       CASE (MPI_IDENT)
    1400           0 :          res = 0
    1401             :       CASE (MPI_CONGRUENT)
    1402     1439882 :          res = 1
    1403             :       CASE (MPI_SIMILAR)
    1404           0 :          res = 2
    1405             :       CASE (MPI_UNEQUAL)
    1406           0 :          res = 3
    1407             :       CASE default
    1408     1439882 :          res = 4
    1409             :       END SELECT
    1410             : #else
    1411             :       MARK_USED(comm1)
    1412             :       MARK_USED(comm2)
    1413             : #endif
    1414     1439882 :       CALL mp_timestop(handle)
    1415             : 
    1416     1439882 :    END SUBROUTINE mp_comm_compare
    1417             : 
    1418             : !..mp_cart_sub
    1419             : ! **************************************************************************************************
    1420             : !> \brief ...
    1421             : !> \param comm ...
    1422             : !> \param rdim ...
    1423             : !> \param sub_comm ...
    1424             : ! **************************************************************************************************
    1425         660 :    SUBROUTINE mp_cart_sub(comm, rdim, sub_comm)
    1426             : 
    1427             :       INTEGER, INTENT(IN)                                :: comm
    1428             :       LOGICAL, DIMENSION(:), INTENT(IN)                  :: rdim
    1429             :       INTEGER, INTENT(OUT)                               :: sub_comm
    1430             : 
    1431             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_sub'
    1432             : 
    1433             :       INTEGER                                            :: handle, ierr
    1434             : 
    1435         660 :       ierr = 0
    1436         660 :       CALL mp_timeset(routineN, handle)
    1437             : 
    1438         660 :       sub_comm = 0
    1439             : #if defined(__parallel)
    1440         660 :       CALL mpi_cart_sub(comm, rdim, sub_comm, ierr)
    1441         660 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_sub @ mp_cart_sub")
    1442         660 :       debug_comm_count = debug_comm_count + 1
    1443             : #else
    1444             :       MARK_USED(comm)
    1445             :       MARK_USED(rdim)
    1446             : #endif
    1447         660 :       CALL mp_timestop(handle)
    1448             : 
    1449         660 :    END SUBROUTINE mp_cart_sub
    1450             : 
    1451             : !..mp_comm_free
    1452             : ! **************************************************************************************************
    1453             : !> \brief ...
    1454             : !> \param comm ...
    1455             : ! **************************************************************************************************
    1456      108914 :    SUBROUTINE mp_comm_free(comm)
    1457             : 
    1458             :       INTEGER, INTENT(INOUT)                             :: comm
    1459             : 
    1460             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_free'
    1461             : 
    1462             :       INTEGER                                            :: handle, ierr
    1463             : 
    1464      108914 :       ierr = 0
    1465      108914 :       CALL mp_timeset(routineN, handle)
    1466             : 
    1467             : #if defined(__parallel)
    1468      108914 :       CALL mpi_comm_free(comm, ierr)
    1469      108914 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_free @ mp_comm_free")
    1470      108914 :       debug_comm_count = debug_comm_count - 1
    1471             : #else
    1472             :       MARK_USED(comm)
    1473             : #endif
    1474      108914 :       CALL mp_timestop(handle)
    1475             : 
    1476      108914 :    END SUBROUTINE mp_comm_free
    1477             : 
    1478             : !..mp_comm_dup
    1479             : ! **************************************************************************************************
    1480             : !> \brief ...
    1481             : !> \param comm1 ...
    1482             : !> \param comm2 ...
    1483             : ! **************************************************************************************************
    1484       79794 :    SUBROUTINE mp_comm_dup(comm1, comm2)
    1485             : 
    1486             :       INTEGER, INTENT(IN)                                :: comm1
    1487             :       INTEGER, INTENT(OUT)                               :: comm2
    1488             : 
    1489             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_dup'
    1490             : 
    1491             :       INTEGER                                            :: handle, ierr
    1492             : 
    1493       79794 :       ierr = 0
    1494       79794 :       CALL mp_timeset(routineN, handle)
    1495             : 
    1496             : #if defined(__parallel)
    1497       79794 :       CALL mpi_comm_dup(comm1, comm2, ierr)
    1498       79794 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_dup @ mp_comm_dup")
    1499       79794 :       debug_comm_count = debug_comm_count + 1
    1500             : #else
    1501             :       comm2 = comm1
    1502             : #endif
    1503       79794 :       CALL mp_timestop(handle)
    1504             : 
    1505       79794 :    END SUBROUTINE mp_comm_dup
    1506             : 
    1507             : !..mp_rank_compare
    1508             : ! **************************************************************************************************
    1509             : !> \brief ...
    1510             : !> \param comm1 ...
    1511             : !> \param comm2 ...
    1512             : !> \param rank ...
    1513             : ! **************************************************************************************************
    1514     1424854 :    SUBROUTINE mp_rank_compare(comm1, comm2, rank)
    1515             : 
    1516             :       INTEGER, INTENT(IN)                      :: comm1, comm2
    1517             :       INTEGER, DIMENSION(:), INTENT(OUT)       :: rank
    1518             : 
    1519             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_rank_compare'
    1520             : 
    1521             :       INTEGER                                  :: handle, ierr
    1522             : #if defined(__parallel)
    1523             :       INTEGER                                  :: g1, g2, i, n, n1, n2
    1524     1424854 :       INTEGER, ALLOCATABLE, DIMENSION(:)       :: rin
    1525             : #endif
    1526             : 
    1527     1424854 :       ierr = 0
    1528     1424854 :       CALL mp_timeset(routineN, handle)
    1529             : 
    1530     4274562 :       rank = 0
    1531             : #if defined(__parallel)
    1532     1424854 :       CALL mpi_comm_size(comm1, n1, ierr)
    1533     1424854 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
    1534     1424854 :       CALL mpi_comm_size(comm2, n2, ierr)
    1535     1424854 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
    1536     1424854 :       n = MAX(n1, n2)
    1537     1424854 :       CALL mpi_comm_group(comm1, g1, ierr)
    1538     1424854 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
    1539     1424854 :       CALL mpi_comm_group(comm2, g2, ierr)
    1540     1424854 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
    1541     4274562 :       ALLOCATE (rin(0:n - 1), STAT=ierr)
    1542     1424854 :       IF (ierr /= 0) &
    1543           0 :          CPABORT("allocate @ mp_rank_compare")
    1544     4274562 :       DO i = 0, n - 1
    1545     4274562 :          rin(i) = i
    1546             :       END DO
    1547     1424854 :       CALL mpi_group_translate_ranks(g1, n, rin, g2, rank, ierr)
    1548     1424854 :       IF (ierr /= 0) CALL mp_stop(ierr, &
    1549           0 :                                   "mpi_group_translate_rank @ mp_rank_compare")
    1550     1424854 :       CALL mpi_group_free(g1, ierr)
    1551     1424854 :       IF (ierr /= 0) &
    1552           0 :          CPABORT("group_free @ mp_rank_compare")
    1553     1424854 :       CALL mpi_group_free(g2, ierr)
    1554     1424854 :       IF (ierr /= 0) &
    1555           0 :          CPABORT("group_free @ mp_rank_compare")
    1556     1424854 :       DEALLOCATE (rin)
    1557             : #else
    1558             :       MARK_USED(comm1)
    1559             :       MARK_USED(comm2)
    1560             : #endif
    1561     1424854 :       CALL mp_timestop(handle)
    1562             : 
    1563     1424854 :    END SUBROUTINE mp_rank_compare
    1564             : 
    1565             : !..mp_dims_create
    1566             : ! **************************************************************************************************
    1567             : !> \brief ...
    1568             : !> \param nodes ...
    1569             : !> \param dims ...
    1570             : ! **************************************************************************************************
    1571          40 :    SUBROUTINE mp_dims_create(nodes, dims)
    1572             : 
    1573             :       INTEGER, INTENT(IN)                                :: nodes
    1574             :       INTEGER, DIMENSION(:), INTENT(INOUT)               :: dims
    1575             : 
    1576             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_dims_create'
    1577             : 
    1578             :       INTEGER                                            :: handle, ierr, ndim
    1579             : 
    1580          40 :       ierr = 0
    1581          40 :       CALL mp_timeset(routineN, handle)
    1582             : 
    1583          40 :       ndim = SIZE(dims)
    1584             : #if defined(__parallel)
    1585          40 :       IF (ANY(dims == 0)) CALL mpi_dims_create(nodes, ndim, dims, ierr)
    1586          40 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_dims_create")
    1587             : #else
    1588             :       dims = 1
    1589             :       MARK_USED(nodes)
    1590             : #endif
    1591          40 :       CALL mp_timestop(handle)
    1592             : 
    1593          40 :    END SUBROUTINE mp_dims_create
    1594             : 
    1595             : !..mp_cart_rank
    1596             : ! **************************************************************************************************
    1597             : !> \brief ...
    1598             : !> \param group ...
    1599             : !> \param pos ...
    1600             : !> \param rank ...
    1601             : ! **************************************************************************************************
    1602      128861 :    SUBROUTINE mp_cart_rank(group, pos, rank)
    1603             :       INTEGER, INTENT(IN)                                :: group
    1604             :       INTEGER, DIMENSION(:), INTENT(IN)                  :: pos
    1605             :       INTEGER, INTENT(OUT)                               :: rank
    1606             : 
    1607             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_rank'
    1608             : 
    1609             :       INTEGER                                            :: handle, ierr
    1610             : 
    1611      128861 :       ierr = 0
    1612      128861 :       CALL mp_timeset(routineN, handle)
    1613             : 
    1614             : #if defined(__parallel)
    1615      128861 :       CALL mpi_cart_rank(group, pos, rank, ierr)
    1616      128861 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_rank @ mp_cart_rank")
    1617             : #else
    1618             :       rank = 0
    1619             :       MARK_USED(group)
    1620             :       MARK_USED(pos)
    1621             : #endif
    1622      128861 :       CALL mp_timestop(handle)
    1623             : 
    1624      128861 :    END SUBROUTINE mp_cart_rank
    1625             : 
    1626             : ! **************************************************************************************************
    1627             : !> \brief waits for completion of the given request
    1628             : !> \param request ...
    1629             : !> \par History
    1630             : !>      08.2003 created [f&j]
    1631             : !> \author joost & fawzi
    1632             : !> \note
    1633             : !>      see isendrecv
    1634             : ! **************************************************************************************************
    1635        2744 :    SUBROUTINE mp_wait(request)
    1636             :       INTEGER, INTENT(inout)                             :: request
    1637             : 
    1638             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_wait'
    1639             : 
    1640             :       INTEGER                                            :: handle, ierr
    1641             : 
    1642        2744 :       ierr = 0
    1643        2744 :       CALL mp_timeset(routineN, handle)
    1644             : 
    1645             : #if defined(__parallel)
    1646             : 
    1647        2744 :       CALL mpi_wait(request, MPI_STATUS_IGNORE, ierr)
    1648        2744 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_wait @ mp_wait")
    1649             : 
    1650        2744 :       CALL add_perf(perf_id=9, count=1)
    1651             : #else
    1652             :       MARK_USED(request)
    1653             : #endif
    1654        2744 :       CALL mp_timestop(handle)
    1655        2744 :    END SUBROUTINE mp_wait
    1656             : 
    1657             : ! **************************************************************************************************
    1658             : !> \brief waits for completion of the given requests
    1659             : !> \param requests ...
    1660             : !> \par History
    1661             : !>      08.2003 created [f&j]
    1662             : !> \author joost & fawzi
    1663             : !> \note
    1664             : !>      see isendrecv
    1665             : ! **************************************************************************************************
    1666     2049726 :    SUBROUTINE mp_waitall_1(requests)
    1667             :       INTEGER, DIMENSION(:), INTENT(inout)     :: requests
    1668             : 
    1669             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_1'
    1670             : 
    1671             :       INTEGER                                  :: handle, ierr
    1672             : #if defined(__parallel)
    1673             :       INTEGER                                  :: count
    1674     2049726 :       INTEGER, ALLOCATABLE, DIMENSION(:, :)    :: status
    1675             : #endif
    1676             : 
    1677     2049726 :       ierr = 0
    1678     2049726 :       CALL mp_timeset(routineN, handle)
    1679             : 
    1680             : #if defined(__parallel)
    1681     2049726 :       count = SIZE(requests)
    1682     6139842 :       ALLOCATE (status(MPI_STATUS_SIZE, count))
    1683     2049726 :       CALL mpi_waitall_internal(count, requests, status, ierr) ! MPI_STATUSES_IGNORE openmpi workaround
    1684     2049726 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_1")
    1685     2049726 :       DEALLOCATE (status)
    1686     2049726 :       CALL add_perf(perf_id=9, count=1)
    1687             : #else
    1688             :       MARK_USED(requests)
    1689             : #endif
    1690     2049726 :       CALL mp_timestop(handle)
    1691     2049726 :    END SUBROUTINE mp_waitall_1
    1692             : 
    1693             : ! **************************************************************************************************
    1694             : !> \brief waits for completion of the given requests
    1695             : !> \param requests ...
    1696             : !> \par History
    1697             : !>      08.2003 created [f&j]
    1698             : !> \author joost & fawzi
    1699             : ! **************************************************************************************************
    1700           0 :    SUBROUTINE mp_waitall_2(requests)
    1701             :       INTEGER, DIMENSION(:, :), INTENT(inout)  :: requests
    1702             : 
    1703             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_2'
    1704             : 
    1705             :       INTEGER                                  :: handle, ierr
    1706             : #if defined(__parallel)
    1707             :       INTEGER                                  :: count
    1708           0 :       INTEGER, ALLOCATABLE, DIMENSION(:, :)    :: status
    1709             : #endif
    1710             : 
    1711           0 :       ierr = 0
    1712           0 :       CALL mp_timeset(routineN, handle)
    1713             : 
    1714             : #if defined(__parallel)
    1715           0 :       count = SIZE(requests)
    1716           0 :       ALLOCATE (status(MPI_STATUS_SIZE, count))
    1717             : 
    1718           0 :       CALL mpi_waitall_internal(count, requests, status, ierr) ! MPI_STATUSES_IGNORE openmpi workaround
    1719           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_2")
    1720           0 :       DEALLOCATE (status)
    1721             : 
    1722           0 :       CALL add_perf(perf_id=9, count=1)
    1723             : #else
    1724             :       MARK_USED(requests)
    1725             : #endif
    1726           0 :       CALL mp_timestop(handle)
    1727           0 :    END SUBROUTINE mp_waitall_2
    1728             : 
    1729             : ! **************************************************************************************************
    1730             : !> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
    1731             : !>        the issue is with the rank or requests
    1732             : !> \param count ...
    1733             : !> \param array_of_requests ...
    1734             : !> \param array_of_statuses ...
    1735             : !> \param ierr ...
    1736             : !> \author Joost VandeVondele
    1737             : ! **************************************************************************************************
    1738             : #if defined(__parallel)
    1739     2049726 :    SUBROUTINE mpi_waitall_internal(count, array_of_requests, array_of_statuses, ierr)
    1740             :       INTEGER, INTENT(in)                                :: count
    1741             :       INTEGER, DIMENSION(count), INTENT(inout)           :: array_of_requests
    1742             :       INTEGER, DIMENSION(MPI_STATUS_SIZE, *), &
    1743             :          INTENT(out)                                     :: array_of_statuses
    1744             :       INTEGER, INTENT(out)                               :: ierr
    1745             : 
    1746     2049726 :       CALL mpi_waitall(count, array_of_requests, array_of_statuses, ierr)
    1747             : 
    1748     2049726 :    END SUBROUTINE mpi_waitall_internal
    1749             : #endif
    1750             : 
    1751             : ! **************************************************************************************************
    1752             : !> \brief waits for completion of any of the given requests
    1753             : !> \param requests ...
    1754             : !> \param completed ...
    1755             : !> \par History
    1756             : !>      09.2008 created
    1757             : !> \author Iain Bethune (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
    1758             : ! **************************************************************************************************
    1759       12456 :    SUBROUTINE mp_waitany(requests, completed)
    1760             :       INTEGER, DIMENSION(:), INTENT(inout)     :: requests
    1761             :       INTEGER, INTENT(out)                     :: completed
    1762             : 
    1763             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitany'
    1764             : 
    1765             :       INTEGER                                  :: handle, ierr
    1766             : #if defined(__parallel)
    1767             :       INTEGER                                  :: count
    1768             : #endif
    1769             : 
    1770       12456 :       ierr = 0
    1771       12456 :       CALL mp_timeset(routineN, handle)
    1772             : 
    1773             : #if defined(__parallel)
    1774       12456 :       count = SIZE(requests)
    1775             : 
    1776       12456 :       CALL mpi_waitany(count, requests, completed, MPI_STATUS_IGNORE, ierr)
    1777       12456 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitany @ mp_waitany")
    1778             : 
    1779       12456 :       CALL add_perf(perf_id=9, count=1)
    1780             : #else
    1781             :       MARK_USED(requests)
    1782             :       completed = 1
    1783             : #endif
    1784       12456 :       CALL mp_timestop(handle)
    1785       12456 :    END SUBROUTINE mp_waitany
    1786             : 
    1787             : ! **************************************************************************************************
    1788             : !> \brief Tests for completion of the given requests.
    1789             : !> \brief We use mpi_test so that we can use a single status.
    1790             : !> \param requests the list of requests to test
    1791             : !> \return logical which determines if requests are complete
    1792             : !> \par History
    1793             : !>      3.2016 adapted to any shape [Nico Holmberg]
    1794             : !> \author Alfio Lazzaro
    1795             : ! **************************************************************************************************
    1796        6400 :    FUNCTION mp_testall_tv(requests) RESULT(flag)
    1797             :       INTEGER, DIMENSION(:)                 :: requests
    1798             :       LOGICAL                               :: flag
    1799             : 
    1800             :       INTEGER                               :: ierr
    1801             : 
    1802             : #if defined(__parallel)
    1803             :       INTEGER                               :: i
    1804        6400 :       LOGICAL, DIMENSION(:), POINTER        :: flags
    1805             : #endif
    1806             : 
    1807        6400 :       ierr = 0
    1808        6400 :       flag = .TRUE.
    1809             : 
    1810             : #if defined(__parallel)
    1811       19200 :       ALLOCATE (flags(SIZE(requests)))
    1812       25600 :       DO i = 1, SIZE(requests)
    1813       19200 :          CALL mpi_test(requests(i), flags(i), MPI_STATUS_IGNORE, ierr)
    1814       19200 :          IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testall @ mp_testall_tv")
    1815       25978 :          flag = flag .AND. flags(i)
    1816             :       END DO
    1817        6400 :       DEALLOCATE (flags)
    1818             : #else
    1819             :       requests = mp_request_null
    1820             : #endif
    1821        6400 :    END FUNCTION mp_testall_tv
    1822             : 
    1823             : ! **************************************************************************************************
    1824             : !> \brief Tests for completion of the given request.
    1825             : !> \param request the request
    1826             : !> \param flag logical which determines if the request is completed
    1827             : !> \par History
    1828             : !>      3.2016 created
    1829             : !> \author Nico Holmberg
    1830             : ! **************************************************************************************************
    1831          24 :    SUBROUTINE mp_test_1(request, flag)
    1832             :       INTEGER, INTENT(inout)                             :: request
    1833             :       LOGICAL, INTENT(out)                               :: flag
    1834             : 
    1835             :       INTEGER                                            :: ierr
    1836             : 
    1837          24 :       ierr = 0
    1838             : 
    1839             : #if defined(__parallel)
    1840          24 :       CALL mpi_test(request, flag, MPI_STATUS_IGNORE, ierr)
    1841          24 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_test @ mp_test_1")
    1842             : #else
    1843             :       MARK_USED(request)
    1844             :       flag = .TRUE.
    1845             : #endif
    1846          24 :    END SUBROUTINE mp_test_1
    1847             : 
    1848             : ! **************************************************************************************************
    1849             : !> \brief tests for completion of the given requests
    1850             : !> \param requests ...
    1851             : !> \param completed ...
    1852             : !> \param flag ...
    1853             : !> \par History
    1854             : !>      08.2011 created
    1855             : !> \author Iain Bethune
    1856             : ! **************************************************************************************************
    1857           0 :    SUBROUTINE mp_testany_1(requests, completed, flag)
    1858             :       INTEGER, DIMENSION(:), INTENT(inout)  :: requests
    1859             :       INTEGER, INTENT(out), OPTIONAL           :: completed
    1860             :       LOGICAL, INTENT(out), OPTIONAL           :: flag
    1861             : 
    1862             :       INTEGER                                  :: ierr
    1863             : #if defined(__parallel)
    1864             :       INTEGER                                  :: completed_l, count
    1865             :       LOGICAL                                  :: flag_l
    1866             : #endif
    1867             : 
    1868           0 :       ierr = 0
    1869             : 
    1870             : #if defined(__parallel)
    1871           0 :       count = SIZE(requests)
    1872             : 
    1873           0 :       CALL mpi_testany_internal(count, requests, completed_l, flag_l, MPI_STATUS_IGNORE, ierr)
    1874           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_1 @ mp_testany")
    1875             : 
    1876           0 :       IF (PRESENT(completed)) completed = completed_l
    1877           0 :       IF (PRESENT(flag)) flag = flag_l
    1878             : #else
    1879             :       MARK_USED(requests)
    1880             :       IF (PRESENT(completed)) completed = 1
    1881             :       IF (PRESENT(flag)) flag = .TRUE.
    1882             : #endif
    1883           0 :    END SUBROUTINE mp_testany_1
    1884             : 
    1885             : ! **************************************************************************************************
    1886             : !> \brief tests for completion of the given requests
    1887             : !> \param requests ...
    1888             : !> \param completed ...
    1889             : !> \param flag ...
    1890             : !> \par History
    1891             : !>      08.2011 created
    1892             : !> \author Iain Bethune
    1893             : ! **************************************************************************************************
    1894           0 :    SUBROUTINE mp_testany_2(requests, completed, flag)
    1895             :       INTEGER, DIMENSION(:, :), INTENT(inout)   :: requests
    1896             :       INTEGER, INTENT(out), OPTIONAL           :: completed
    1897             :       LOGICAL, INTENT(out), OPTIONAL           :: flag
    1898             : 
    1899             :       INTEGER                                  :: ierr
    1900             : #if defined(__parallel)
    1901             :       INTEGER                                  :: completed_l, count
    1902             :       LOGICAL                                  :: flag_l
    1903             : #endif
    1904             : 
    1905           0 :       ierr = 0
    1906             : 
    1907             : #if defined(__parallel)
    1908           0 :       count = SIZE(requests)
    1909             : 
    1910           0 :       CALL mpi_testany_internal(count, requests, completed_l, flag_l, MPI_STATUS_IGNORE, ierr)
    1911           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_2 @ mp_testany")
    1912             : 
    1913           0 :       IF (PRESENT(completed)) completed = completed_l
    1914           0 :       IF (PRESENT(flag)) flag = flag_l
    1915             : #else
    1916             :       MARK_USED(requests)
    1917             :       IF (PRESENT(completed)) completed = 1
    1918             :       IF (PRESENT(flag)) flag = .TRUE.
    1919             : #endif
    1920           0 :    END SUBROUTINE mp_testany_2
    1921             : 
    1922             : ! **************************************************************************************************
    1923             : !> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
    1924             : !>        the issue is with the rank or requests
    1925             : !> \param count ...
    1926             : !> \param array_of_requests ...
    1927             : !> \param index ...
    1928             : !> \param flag ...
    1929             : !> \param status ...
    1930             : !> \param ierr ...
    1931             : !> \author Joost VandeVondele
    1932             : ! **************************************************************************************************
    1933             : #if defined(__parallel)
    1934           0 :    SUBROUTINE mpi_testany_internal(count, array_of_requests, index, flag, status, ierr)
    1935             :       INTEGER, INTENT(in)                                :: count
    1936             :       INTEGER, DIMENSION(count), INTENT(inout)           :: array_of_requests
    1937             :       INTEGER, INTENT(out)                               :: index
    1938             :       LOGICAL, INTENT(out)                               :: flag
    1939             :       INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT(out)   :: status
    1940             :       INTEGER, INTENT(out)                               :: ierr
    1941             : 
    1942           0 :       CALL mpi_testany(count, array_of_requests, index, flag, status, ierr)
    1943             : 
    1944           0 :    END SUBROUTINE mpi_testany_internal
    1945             : #endif
    1946             : 
    1947             : ! **************************************************************************************************
    1948             : !> \brief the direct way to split a communicator each color is a sub_comm,
    1949             : !>        the rank order is according to the order in the orig comm
    1950             : !> \param comm ...
    1951             : !> \param sub_comm ...
    1952             : !> \param color ...
    1953             : !> \param key ...
    1954             : !> \author Joost VandeVondele
    1955             : ! **************************************************************************************************
    1956        3082 :    SUBROUTINE mp_comm_split_direct(comm, sub_comm, color, key)
    1957             :       INTEGER, INTENT(in)                                :: comm
    1958             :       INTEGER, INTENT(OUT)                               :: sub_comm
    1959             :       INTEGER, INTENT(in)                                :: color
    1960             :       INTEGER, INTENT(in), OPTIONAL                      :: key
    1961             : 
    1962             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_split_direct'
    1963             : 
    1964             :       INTEGER                                            :: handle, ierr, my_key
    1965             : 
    1966        3082 :       ierr = 0
    1967        3082 :       CALL mp_timeset(routineN, handle)
    1968             : 
    1969        3082 :       my_key = 0
    1970             : #if defined(__parallel)
    1971        3082 :       IF (PRESENT(key)) my_key = key
    1972        3082 :       CALL mpi_comm_split(comm, color, my_key, sub_comm, ierr)
    1973        3082 :       debug_comm_count = debug_comm_count + 1
    1974        3082 :       IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
    1975        3082 :       CALL add_perf(perf_id=10, count=1)
    1976             : #else
    1977             :       CALL mp_comm_dup(comm, sub_comm)
    1978             :       MARK_USED(color)
    1979             :       MARK_USED(key)
    1980             : #endif
    1981        3082 :       CALL mp_timestop(handle)
    1982             : 
    1983        3082 :    END SUBROUTINE mp_comm_split_direct
    1984             : ! **************************************************************************************************
    1985             : !> \brief splits the given communicator in group in subgroups trying to organize
    1986             : !>      them in a way that the communication within each subgroup is
    1987             : !>      efficient (but not necessarily the communication between subgroups)
    1988             : !> \param comm the mpi communicator that you want to split
    1989             : !> \param sub_comm the communicator for the subgroup (created, needs to be freed later)
    1990             : !> \param ngroups actual number of groups
    1991             : !> \param group_distribution input  : allocated with array with the nprocs entries (0 .. nprocs-1)
    1992             : !> \param subgroup_min_size the minimum size of the subgroup
    1993             : !> \param n_subgroups the number of subgroups wanted
    1994             : !> \param group_partition n_subgroups sized array containing the number of cpus wanted per group.
    1995             : !>                         should match the total number of cpus (only used if present and associated) (0..ngroups-1)
    1996             : !> \param stride create groups using a stride (default=1) through the ranks of the comm to be split.
    1997             : !> \par History
    1998             : !>      10.2003 created [fawzi]
    1999             : !>      02.2004 modified [Joost VandeVondele]
    2000             : !> \author Fawzi Mohamed
    2001             : !> \note
    2002             : !>      at least one of subgroup_min_size and n_subgroups is needed,
    2003             : !>      the other default to the value needed to use most processors.
    2004             : !>      if less cpus are present than needed for subgroup min size, n_subgroups,
    2005             : !>      just one comm is created that contains all cpus
    2006             : ! **************************************************************************************************
    2007         195 :    SUBROUTINE mp_comm_split(comm, sub_comm, ngroups, group_distribution, &
    2008         195 :                             subgroup_min_size, n_subgroups, group_partition, stride)
    2009             :       INTEGER, INTENT(in)                      :: comm
    2010             :       INTEGER, INTENT(out)                     :: sub_comm, ngroups
    2011             :       INTEGER, DIMENSION(0:)                    :: group_distribution
    2012             :       INTEGER, INTENT(in), OPTIONAL            :: subgroup_min_size, n_subgroups
    2013             :       INTEGER, DIMENSION(0:), OPTIONAL          :: group_partition
    2014             :       INTEGER, OPTIONAL                        :: stride
    2015             : 
    2016             :       CHARACTER(LEN=*), PARAMETER :: routineN = 'mp_comm_split', &
    2017             :                                      routineP = moduleN//':'//routineN
    2018             : 
    2019             :       INTEGER                                  :: handle, ierr, mepos, nnodes
    2020             : #if defined(__parallel)
    2021             :       INTEGER                                  :: color, i, j, k, &
    2022             :                                                   my_subgroup_min_size, &
    2023             :                                                   istride, local_stride, irank
    2024         195 :       INTEGER, DIMENSION(:), ALLOCATABLE       :: rank_permutation
    2025             : #endif
    2026             : 
    2027         195 :       ierr = 0
    2028         195 :       CALL mp_timeset(routineN, handle)
    2029             : 
    2030             :       ! actual number of groups
    2031             : 
    2032         195 :       IF (.NOT. PRESENT(subgroup_min_size) .AND. .NOT. PRESENT(n_subgroups)) THEN
    2033           0 :          CPABORT(routineP//" missing arguments")
    2034             :       ENDIF
    2035         195 :       IF (PRESENT(subgroup_min_size) .AND. PRESENT(n_subgroups)) THEN
    2036           0 :          CPABORT(routineP//" too many arguments")
    2037             :       ENDIF
    2038             : 
    2039         195 :       CALL mp_environ(nnodes, mepos, comm)
    2040             : 
    2041         390 :       IF (UBOUND(group_distribution, 1) .NE. nnodes - 1) THEN
    2042           0 :          CPABORT(routineP//" group_distribution wrong bounds")
    2043             :       ENDIF
    2044             : 
    2045             : #if defined(__parallel)
    2046         195 :       IF (PRESENT(subgroup_min_size)) THEN
    2047         142 :          IF (subgroup_min_size < 0 .OR. subgroup_min_size > nnodes) THEN
    2048           0 :             CPABORT(routineP//" subgroup_min_size too small or too large")
    2049             :          ENDIF
    2050         142 :          ngroups = nnodes/subgroup_min_size
    2051         142 :          my_subgroup_min_size = subgroup_min_size
    2052             :       ELSE ! n_subgroups
    2053          53 :          IF (n_subgroups <= 0) THEN
    2054           0 :             CPABORT(routineP//" n_subgroups too small")
    2055             :          ENDIF
    2056          53 :          IF (nnodes/n_subgroups > 0) THEN ! we have a least one cpu per group
    2057          49 :             ngroups = n_subgroups
    2058             :          ELSE ! well, only one group then
    2059           4 :             ngroups = 1
    2060             :          ENDIF
    2061          53 :          my_subgroup_min_size = nnodes/ngroups
    2062             :       ENDIF
    2063             : 
    2064             :       ! rank_permutation: is a permutation of ranks, so that groups are not necessarily continuous in rank of the master group
    2065             :       ! while the order is not critical (we only color ranks), it can e.g. be used to make groups that have just 1 rank per node
    2066             :       ! (by setting stride equal to the number of mpi ranks per node), or by sharing  a node between two groups (stride 2).
    2067         585 :       ALLOCATE (rank_permutation(0:nnodes - 1))
    2068         195 :       local_stride = 1
    2069         195 :       IF (PRESENT(stride)) local_stride = stride
    2070         195 :       k = 0
    2071         390 :       DO istride = 1, local_stride
    2072         390 :          DO irank = istride - 1, nnodes - 1, local_stride
    2073         385 :             rank_permutation(k) = irank
    2074         385 :             k = k + 1
    2075             :          ENDDO
    2076             :       ENDDO
    2077             : 
    2078         580 :       DO i = 0, nnodes - 1
    2079         580 :          group_distribution(rank_permutation(i)) = MIN(i/my_subgroup_min_size, ngroups - 1)
    2080             :       ENDDO
    2081             :       ! even the user gave a partition, see if we can use it to overwrite this choice
    2082         195 :       IF (PRESENT(group_partition)) THEN
    2083         192 :          IF (ALL(group_partition > 0) .AND. (SUM(group_partition) .EQ. nnodes) .AND. (ngroups == SIZE(group_partition))) THEN
    2084          84 :             k = 0
    2085          84 :             DO i = 0, SIZE(group_partition) - 1
    2086         140 :                DO j = 1, group_partition(i)
    2087          56 :                   group_distribution(rank_permutation(k)) = i
    2088         112 :                   k = k + 1
    2089             :                ENDDO
    2090             :             ENDDO
    2091             :          ELSE
    2092             :             ! just ignore silently as we have reasonable defaults. Probably a warning would not be to bad
    2093             :          ENDIF
    2094             :       ENDIF
    2095         195 :       color = group_distribution(mepos)
    2096         195 :       CALL mpi_comm_split(comm, color, 0, sub_comm, ierr)
    2097         195 :       debug_comm_count = debug_comm_count + 1
    2098         195 :       IF (ierr /= mpi_success) CALL mp_stop(ierr, "in "//routineP//" split")
    2099             : 
    2100         195 :       CALL add_perf(perf_id=10, count=1)
    2101             : #else
    2102             :       CALL mp_comm_dup(comm, sub_comm)
    2103             :       group_distribution(0) = 0
    2104             :       ngroups = 1
    2105             :       MARK_USED(stride)
    2106             :       MARK_USED(group_partition)
    2107             : #endif
    2108         195 :       CALL mp_timestop(handle)
    2109             : 
    2110         585 :    END SUBROUTINE mp_comm_split
    2111             : 
    2112             : ! **************************************************************************************************
    2113             : !> \brief Get the local rank on the node according to the global communicator
    2114             : !> \return Node Rank id
    2115             : !> \author Alfio Lazzaro
    2116             : ! **************************************************************************************************
    2117           0 :    FUNCTION mp_get_node_global_rank() &
    2118             :       RESULT(node_rank)
    2119             : 
    2120             :       INTEGER                                            :: node_rank
    2121             : 
    2122             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_get_node_global_rank'
    2123             :       INTEGER                                            :: handle, comm, ierr, rank
    2124             : 
    2125           0 :       ierr = 0
    2126           0 :       rank = 0
    2127           0 :       comm = 0
    2128           0 :       CALL mp_timeset(routineN, handle)
    2129             : 
    2130             : #if defined(__parallel)
    2131             : #if __MPI_VERSION > 2
    2132           0 :       CALL mpi_comm_rank(MPI_COMM_WORLD, rank, ierr)
    2133           0 :       IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
    2134           0 :       CALL mpi_comm_split_type(MPI_COMM_WORLD, MPI_COMM_TYPE_SHARED, rank, MPI_INFO_NULL, comm, ierr)
    2135           0 :       IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
    2136           0 :       CALL mpi_comm_rank(comm, node_rank, ierr)
    2137           0 :       IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
    2138           0 :       CALL mpi_comm_free(comm, ierr)
    2139           0 :       IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
    2140             : #else
    2141             :       CPABORT("mp_get_node_global_rank requires MPI-3 standard")
    2142             : #endif
    2143             : #else
    2144             :       node_rank = 0
    2145             : #endif
    2146           0 :       CALL mp_timestop(handle)
    2147             : 
    2148           0 :    END FUNCTION mp_get_node_global_rank
    2149             : 
    2150             : ! **************************************************************************************************
    2151             : !> \brief probes for an incoming message with any tag
    2152             : !> \param[inout] source the source of the possible incoming message,
    2153             : !>        if MP_ANY_SOURCE it is a blocking one and return value is the source
    2154             : !>        of the next incoming message
    2155             : !>        if source is a different value it is a non-blocking probe retuning
    2156             : !>        MP_ANY_SOURCE if there is no incoming message
    2157             : !> \param[in] comm the communicator
    2158             : !> \param[out] tag the tag of the incoming message
    2159             : !> \author Mandes
    2160             : ! **************************************************************************************************
    2161      515224 :    SUBROUTINE mp_probe(source, comm, tag)
    2162             :       INTEGER                                  :: source
    2163             :       INTEGER, INTENT(IN)                      :: comm
    2164             :       INTEGER, INTENT(OUT)                     :: tag
    2165             : 
    2166             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_probe'
    2167             : 
    2168             :       INTEGER                                  :: handle, ierr
    2169             : #if defined(__parallel)
    2170             :       INTEGER, DIMENSION(mp_status_size)       :: status_single
    2171             :       LOGICAL                                  :: flag
    2172             : #endif
    2173             : 
    2174             : !   ---------------------------------------------------------------------------
    2175             : 
    2176      515224 :       CALL mp_timeset(routineN, handle)
    2177             : 
    2178      515224 :       ierr = 0
    2179             : #if defined(__parallel)
    2180      515224 :       IF (source .EQ. mp_any_source) THEN
    2181          14 :          CALL mpi_probe(mp_any_source, mp_any_tag, comm, status_single, ierr)
    2182          14 :          IF (ierr /= 0) CALL mp_stop(ierr, "mpi_probe @ mp_probe")
    2183          14 :          source = status_single(MPI_SOURCE)
    2184          14 :          tag = status_single(MPI_TAG)
    2185             :       ELSE
    2186      515210 :          flag = .FALSE.
    2187      515210 :          CALL mpi_iprobe(source, mp_any_tag, comm, flag, status_single, ierr)
    2188      515210 :          IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iprobe @ mp_probe")
    2189      515210 :          IF (flag .EQV. .FALSE.) THEN
    2190      511052 :             source = mp_any_source
    2191      511052 :             tag = -1 !status_single(MPI_TAG) ! in case of flag==false status is undefined
    2192             :          ELSE
    2193        4158 :             tag = status_single(MPI_TAG)
    2194             :          END IF
    2195             :       END IF
    2196             : #else
    2197             :       tag = -1
    2198             :       MARK_USED(comm)
    2199             :       MARK_USED(source)
    2200             : #endif
    2201      515224 :       CALL mp_timestop(handle)
    2202      515224 :    END SUBROUTINE mp_probe
    2203             : 
    2204             : ! **************************************************************************************************
    2205             : ! Here come the data routines with none of the standard data types.
    2206             : ! **************************************************************************************************
    2207             : 
    2208             : ! **************************************************************************************************
    2209             : !> \brief ...
    2210             : !> \param msg ...
    2211             : !> \param source ...
    2212             : !> \param gid ...
    2213             : ! **************************************************************************************************
    2214      995399 :    SUBROUTINE mp_bcast_b(msg, source, gid)
    2215             :       LOGICAL                                            :: msg
    2216             :       INTEGER                                            :: source, gid
    2217             : 
    2218             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b'
    2219             : 
    2220             :       INTEGER                                            :: handle, ierr, msglen
    2221             : 
    2222      995399 :       ierr = 0
    2223      995399 :       CALL mp_timeset(routineN, handle)
    2224             : 
    2225      995399 :       msglen = 1
    2226             : #if defined(__parallel)
    2227      995399 :       CALL mpi_bcast(msg, msglen, MPI_LOGICAL, source, gid, ierr)
    2228      995399 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
    2229      995399 :       CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
    2230             : #else
    2231             :       MARK_USED(msg)
    2232             :       MARK_USED(source)
    2233             :       MARK_USED(gid)
    2234             : #endif
    2235      995399 :       CALL mp_timestop(handle)
    2236      995399 :    END SUBROUTINE mp_bcast_b
    2237             : 
    2238             : ! **************************************************************************************************
    2239             : !> \brief ...
    2240             : !> \param msg ...
    2241             : !> \param source ...
    2242             : !> \param gid ...
    2243             : ! **************************************************************************************************
    2244           0 :    SUBROUTINE mp_bcast_bv(msg, source, gid)
    2245             :       LOGICAL                                            :: msg(:)
    2246             :       INTEGER                                            :: source, gid
    2247             : 
    2248             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv'
    2249             : 
    2250             :       INTEGER                                            :: handle, ierr, msglen
    2251             : 
    2252           0 :       ierr = 0
    2253           0 :       CALL mp_timeset(routineN, handle)
    2254             : 
    2255           0 :       msglen = SIZE(msg)
    2256             : #if defined(__parallel)
    2257           0 :       CALL mpi_bcast(msg, msglen, MPI_LOGICAL, source, gid, ierr)
    2258           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
    2259           0 :       CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
    2260             : #else
    2261             :       MARK_USED(source)
    2262             :       MARK_USED(gid)
    2263             : #endif
    2264           0 :       CALL mp_timestop(handle)
    2265           0 :    END SUBROUTINE mp_bcast_bv
    2266             : 
    2267             : ! **************************************************************************************************
    2268             : !> \brief Non-blocking send of logical vector data
    2269             : !> \param msgin the input message
    2270             : !> \param dest the destination processor
    2271             : !> \param comm  the communicator object
    2272             : !> \param request communication request index
    2273             : !> \param tag message tag
    2274             : !> \par History
    2275             : !>      3.2016 added _bv subroutine [Nico Holmberg]
    2276             : !> \author fawzi
    2277             : !> \note see mp_irecv_iv
    2278             : !> \note
    2279             : !>      arrays can be pointers or assumed shape, but they must be contiguous!
    2280             : ! **************************************************************************************************
    2281          16 :    SUBROUTINE mp_isend_bv(msgin, dest, comm, request, tag)
    2282             :       LOGICAL, DIMENSION(:)                    :: msgin
    2283             :       INTEGER, INTENT(IN)                      :: dest, comm
    2284             :       INTEGER, INTENT(out)                     :: request
    2285             :       INTEGER, INTENT(in), OPTIONAL            :: tag
    2286             : 
    2287             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bv'
    2288             : 
    2289             :       INTEGER                                  :: handle, ierr
    2290             : #if defined(__parallel)
    2291             :       INTEGER                                  :: msglen, my_tag
    2292             :       LOGICAL                                  :: foo(1)
    2293             : #endif
    2294             : 
    2295          16 :       ierr = 0
    2296          16 :       CALL mp_timeset(routineN, handle)
    2297             : 
    2298             : #if defined(__parallel)
    2299          16 :       my_tag = 0
    2300          16 :       IF (PRESENT(tag)) my_tag = tag
    2301             : 
    2302          16 :       msglen = SIZE(msgin, 1)
    2303          16 :       IF (msglen > 0) THEN
    2304             :          CALL mpi_isend(msgin(1), msglen, MPI_LOGICAL, dest, my_tag, &
    2305          16 :                         comm, request, ierr)
    2306             :       ELSE
    2307             :          CALL mpi_isend(foo, msglen, MPI_LOGICAL, dest, my_tag, &
    2308           0 :                         comm, request, ierr)
    2309             :       END IF
    2310          16 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
    2311             : 
    2312          16 :       CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
    2313             : #else
    2314             :       CPABORT("mp_isend called in non parallel case")
    2315             :       MARK_USED(msgin)
    2316             :       MARK_USED(dest)
    2317             :       MARK_USED(comm)
    2318             :       MARK_USED(request)
    2319             :       MARK_USED(tag)
    2320             :       request = 0
    2321             : #endif
    2322          16 :       CALL mp_timestop(handle)
    2323          16 :    END SUBROUTINE mp_isend_bv
    2324             : 
    2325             : ! **************************************************************************************************
    2326             : !> \brief Non-blocking receive of logical vector data
    2327             : !> \param msgout the received message
    2328             : !> \param source the source processor
    2329             : !> \param comm  the communicator object
    2330             : !> \param request communication request index
    2331             : !> \param tag message tag
    2332             : !> \par History
    2333             : !>      3.2016 added _bv subroutine [Nico Holmberg]
    2334             : !> \author fawzi
    2335             : !> \note see mp_irecv_iv
    2336             : !> \note
    2337             : !>      arrays can be pointers or assumed shape, but they must be contiguous!
    2338             : ! **************************************************************************************************
    2339          16 :    SUBROUTINE mp_irecv_bv(msgout, source, comm, request, tag)
    2340             :       LOGICAL, DIMENSION(:)                    :: msgout
    2341             :       INTEGER, INTENT(IN)                      :: source, comm
    2342             :       INTEGER, INTENT(out)                     :: request
    2343             :       INTEGER, INTENT(in), OPTIONAL            :: tag
    2344             : 
    2345             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bv'
    2346             : 
    2347             :       INTEGER                                  :: handle, ierr
    2348             : #if defined(__parallel)
    2349             :       INTEGER                                  :: msglen, my_tag
    2350             :       LOGICAL                                  :: foo(1)
    2351             : #endif
    2352             : 
    2353          16 :       ierr = 0
    2354          16 :       CALL mp_timeset(routineN, handle)
    2355             : 
    2356             : #if defined(__parallel)
    2357          16 :       my_tag = 0
    2358          16 :       IF (PRESENT(tag)) my_tag = tag
    2359             : 
    2360          16 :       msglen = SIZE(msgout, 1)
    2361          16 :       IF (msglen > 0) THEN
    2362             :          CALL mpi_irecv(msgout(1), msglen, MPI_LOGICAL, source, my_tag, &
    2363          16 :                         comm, request, ierr)
    2364             :       ELSE
    2365             :          CALL mpi_irecv(foo, msglen, MPI_LOGICAL, source, my_tag, &
    2366           0 :                         comm, request, ierr)
    2367             :       END IF
    2368          16 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routineN)
    2369             : 
    2370          16 :       CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
    2371             : #else
    2372             :       CPABORT("mp_irecv called in non parallel case")
    2373             :       MARK_USED(msgout)
    2374             :       MARK_USED(source)
    2375             :       MARK_USED(comm)
    2376             :       MARK_USED(request)
    2377             :       MARK_USED(tag)
    2378             :       request = 0
    2379             : #endif
    2380          16 :       CALL mp_timestop(handle)
    2381          16 :    END SUBROUTINE mp_irecv_bv
    2382             : 
    2383             : ! **************************************************************************************************
    2384             : !> \brief Non-blocking send of rank-3 logical data
    2385             : !> \param msgin the input message
    2386             : !> \param dest the destination processor
    2387             : !> \param comm  the communicator object
    2388             : !> \param request communication request index
    2389             : !> \param tag message tag
    2390             : !> \par History
    2391             : !>      2.2016 added _bm3 subroutine [Nico Holmberg]
    2392             : !> \author fawzi
    2393             : !> \note see mp_irecv_iv
    2394             : !> \note
    2395             : !>      arrays can be pointers or assumed shape, but they must be contiguous!
    2396             : ! **************************************************************************************************
    2397           0 :    SUBROUTINE mp_isend_bm3(msgin, dest, comm, request, tag)
    2398             :       LOGICAL, DIMENSION(:, :, :)              :: msgin
    2399             :       INTEGER, INTENT(IN)                      :: dest, comm
    2400             :       INTEGER, INTENT(out)                     :: request
    2401             :       INTEGER, INTENT(in), OPTIONAL            :: tag
    2402             : 
    2403             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bm3'
    2404             : 
    2405             :       INTEGER                                  :: handle, ierr
    2406             : #if defined(__parallel)
    2407             :       INTEGER                                  :: msglen, my_tag
    2408             :       LOGICAL                                  :: foo(1)
    2409             : #endif
    2410             : 
    2411           0 :       ierr = 0
    2412           0 :       CALL mp_timeset(routineN, handle)
    2413             : 
    2414             : #if defined(__parallel)
    2415           0 :       my_tag = 0
    2416           0 :       IF (PRESENT(tag)) my_tag = tag
    2417             : 
    2418           0 :       msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
    2419           0 :       IF (msglen > 0) THEN
    2420             :          CALL mpi_isend(msgin(1, 1, 1), msglen, MPI_LOGICAL, dest, my_tag, &
    2421           0 :                         comm, request, ierr)
    2422             :       ELSE
    2423             :          CALL mpi_isend(foo, msglen, MPI_LOGICAL, dest, my_tag, &
    2424           0 :                         comm, request, ierr)
    2425             :       END IF
    2426           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
    2427             : 
    2428           0 :       CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
    2429             : #else
    2430             :       CPABORT("mp_isend called in non parallel case")
    2431             :       MARK_USED(msgin)
    2432             :       MARK_USED(dest)
    2433             :       MARK_USED(comm)
    2434             :       MARK_USED(request)
    2435             :       MARK_USED(tag)
    2436             :       request = 0
    2437             : #endif
    2438           0 :       CALL mp_timestop(handle)
    2439           0 :    END SUBROUTINE mp_isend_bm3
    2440             : 
    2441             : ! **************************************************************************************************
    2442             : !> \brief Non-blocking receive of rank-3 logical data
    2443             : !> \param msgout the received message
    2444             : !> \param source the source processor
    2445             : !> \param comm  the communicator object
    2446             : !> \param request communication request index
    2447             : !> \param tag message tag
    2448             : !> \par History
    2449             : !>      2.2016 added _bm3 subroutine [Nico Holmberg]
    2450             : !> \author fawzi
    2451             : !> \note see mp_irecv_iv
    2452             : !> \note
    2453             : !>      arrays can be pointers or assumed shape, but they must be contiguous!
    2454             : ! **************************************************************************************************
    2455           0 :    SUBROUTINE mp_irecv_bm3(msgout, source, comm, request, tag)
    2456             :       LOGICAL, DIMENSION(:, :, :)              :: msgout
    2457             :       INTEGER, INTENT(IN)                      :: source, comm
    2458             :       INTEGER, INTENT(out)                     :: request
    2459             :       INTEGER, INTENT(in), OPTIONAL            :: tag
    2460             : 
    2461             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bm3'
    2462             : 
    2463             :       INTEGER                                  :: handle, ierr
    2464             : #if defined(__parallel)
    2465             :       INTEGER                                  :: msglen, my_tag
    2466             :       LOGICAL                                  :: foo(1)
    2467             : #endif
    2468             : 
    2469           0 :       ierr = 0
    2470           0 :       CALL mp_timeset(routineN, handle)
    2471             : 
    2472             : #if defined(__parallel)
    2473           0 :       my_tag = 0
    2474           0 :       IF (PRESENT(tag)) my_tag = tag
    2475             : 
    2476           0 :       msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
    2477           0 :       IF (msglen > 0) THEN
    2478             :          CALL mpi_irecv(msgout(1, 1, 1), msglen, MPI_LOGICAL, source, my_tag, &
    2479           0 :                         comm, request, ierr)
    2480             :       ELSE
    2481             :          CALL mpi_irecv(foo, msglen, MPI_LOGICAL, source, my_tag, &
    2482           0 :                         comm, request, ierr)
    2483             :       END IF
    2484           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routineN)
    2485             : 
    2486           0 :       CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
    2487             : #else
    2488             :       CPABORT("mp_irecv called in non parallel case")
    2489             :       MARK_USED(msgout)
    2490             :       MARK_USED(source)
    2491             :       MARK_USED(comm)
    2492             :       MARK_USED(request)
    2493             :       MARK_USED(tag)
    2494             :       request = 0
    2495             : #endif
    2496           0 :       CALL mp_timestop(handle)
    2497           0 :    END SUBROUTINE mp_irecv_bm3
    2498             : 
    2499             : ! **************************************************************************************************
    2500             : !> \brief ...
    2501             : !> \param msg ...
    2502             : !> \param source ...
    2503             : !> \param gid ...
    2504             : ! **************************************************************************************************
    2505     2718689 :    SUBROUTINE mp_bcast_av(msg, source, gid)
    2506             :       CHARACTER(LEN=*)                         :: msg
    2507             :       INTEGER                                  :: source, gid
    2508             : 
    2509             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av'
    2510             : 
    2511             :       INTEGER                                  :: handle, ierr
    2512             : #if defined(__parallel)
    2513             :       INTEGER                                  :: i, msglen, numtask, taskid
    2514     2718689 :       INTEGER, DIMENSION(:), ALLOCATABLE       :: imsg
    2515             : #endif
    2516             : 
    2517     2718689 :       ierr = 0
    2518     2718689 :       CALL mp_timeset(routineN, handle)
    2519             : 
    2520             : #if defined(__parallel)
    2521             : 
    2522     2718689 :       CALL mp_environ(numtask, taskid, gid)
    2523     2718689 :       IF (taskid == source) msglen = LEN_TRIM(msg)
    2524             : 
    2525     2718689 :       CALL mp_bcast(msglen, source, gid)
    2526             :       ! this is a workaround to avoid problems on the T3E
    2527             :       ! at the moment we have a data alignment error when trying to
    2528             :       ! broadcast characters on the T3E (not always!)
    2529             :       ! JH 19/3/99 on galileo
    2530             :       ! CALL mpi_bcast(msg,msglen,MPI_CHARACTER,source,gid,ierr)
    2531     8148510 :       ALLOCATE (imsg(1:msglen))
    2532    53492744 :       DO i = 1, msglen
    2533    53492744 :          imsg(i) = ICHAR(msg(i:i))
    2534             :       END DO
    2535     2718689 :       CALL mpi_bcast(imsg, msglen, MPI_INTEGER, source, gid, ierr)
    2536     2718689 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
    2537     2718689 :       msg = ""
    2538    53492744 :       DO i = 1, msglen
    2539    53492744 :          msg(i:i) = CHAR(imsg(i))
    2540             :       END DO
    2541     2718689 :       DEALLOCATE (imsg)
    2542     2718689 :       CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen)
    2543             : #else
    2544             :       MARK_USED(msg)
    2545             :       MARK_USED(source)
    2546             :       MARK_USED(gid)
    2547             : #endif
    2548     2718689 :       CALL mp_timestop(handle)
    2549     2718689 :    END SUBROUTINE mp_bcast_av
    2550             : 
    2551             : ! **************************************************************************************************
    2552             : !> \brief ...
    2553             : !> \param msg ...
    2554             : !> \param source ...
    2555             : !> \param gid ...
    2556             : ! **************************************************************************************************
    2557       58686 :    SUBROUTINE mp_bcast_am(msg, source, gid)
    2558             :       CHARACTER(LEN=*)                         :: msg(:)
    2559             :       INTEGER                                  :: source, gid
    2560             : 
    2561             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am'
    2562             : 
    2563             :       INTEGER                                  :: handle, ierr
    2564             : #if defined(__parallel)
    2565             :       INTEGER                                  :: i, j, k, msglen, msgsiz, &
    2566             :                                                   numtask, taskid
    2567       58686 :       INTEGER, ALLOCATABLE                     :: imsg(:), imsglen(:)
    2568             : #endif
    2569             : 
    2570       58686 :       ierr = 0
    2571       58686 :       CALL mp_timeset(routineN, handle)
    2572             : 
    2573             : #if defined(__parallel)
    2574       58686 :       CALL mp_environ(numtask, taskid, gid)
    2575       58686 :       msgsiz = SIZE(msg)
    2576             :       ! Determine size of the minimum array of integers to broadcast the string
    2577      176058 :       ALLOCATE (imsglen(1:msgsiz))
    2578    58720446 :       DO j = 1, msgsiz
    2579    58720446 :          IF (taskid == source) imsglen(j) = LEN_TRIM(msg(j))
    2580             :       END DO
    2581       58686 :       CALL mp_bcast(imsglen, source, gid)
    2582    58720446 :       msglen = SUM(imsglen)
    2583             :       ! this is a workaround to avoid problems on the T3E
    2584             :       ! at the moment we have a data alignment error when trying to
    2585             :       ! broadcast characters on the T3E (not always!)
    2586             :       ! JH 19/3/99 on galileo
    2587             :       ! CALL mpi_bcast(msg,msglen,MPI_CHARACTER,source,gid,ierr)
    2588      176058 :       ALLOCATE (imsg(1:msglen))
    2589    58720446 :       k = 0
    2590    58720446 :       DO j = 1, msgsiz
    2591  1748688874 :          DO i = 1, imsglen(j)
    2592  1689968428 :             k = k + 1
    2593  1748630188 :             imsg(k) = ICHAR(msg(j) (i:i))
    2594             :          END DO
    2595             :       END DO
    2596       58686 :       CALL mpi_bcast(imsg, msglen, MPI_INTEGER, source, gid, ierr)
    2597       58686 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
    2598    58720446 :       msg = ""
    2599             :       k = 0
    2600    58720446 :       DO j = 1, msgsiz
    2601  1748688874 :          DO i = 1, imsglen(j)
    2602  1689968428 :             k = k + 1
    2603  1748630188 :             msg(j) (i:i) = CHAR(imsg(k))
    2604             :          END DO
    2605             :       END DO
    2606       58686 :       DEALLOCATE (imsg)
    2607       58686 :       DEALLOCATE (imsglen)
    2608       58686 :       CALL add_perf(perf_id=2, count=1, msg_size=msglen*charlen*msgsiz)
    2609             : #else
    2610             :       MARK_USED(msg)
    2611             :       MARK_USED(source)
    2612             :       MARK_USED(gid)
    2613             : #endif
    2614       58686 :       CALL mp_timestop(handle)
    2615      117372 :    END SUBROUTINE mp_bcast_am
    2616             : 
    2617             : ! **************************************************************************************************
    2618             : !> \brief Finds the location of the minimal element in a vector.
    2619             : !> \param[in,out] msg         Find location of maximum element among these
    2620             : !>                            data (input).
    2621             : !> \param[in] gid             Message passing environment identifier
    2622             : !> \par MPI mapping
    2623             : !>      mpi_allreduce with the MPI_MINLOC reduction function identifier
    2624             : !> \par Invalid data types
    2625             : !>      This routine is invalid for (int_8) data!
    2626             : ! **************************************************************************************************
    2627         294 :    SUBROUTINE mp_minloc_dv(msg, gid)
    2628             :       REAL(kind=real_8), INTENT(INOUT)         :: msg(:)
    2629             :       INTEGER, INTENT(IN)                      :: gid
    2630             : 
    2631             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_dv'
    2632             : 
    2633             :       INTEGER                                  :: handle, ierr
    2634             : #if defined(__parallel)
    2635             :       INTEGER                                  :: msglen
    2636         294 :       REAL(kind=real_8), ALLOCATABLE           :: res(:)
    2637             : #endif
    2638             : 
    2639         294 :       ierr = 0
    2640             :       IF ("d" .EQ. "l" .AND. real_8 .EQ. int_8) THEN
    2641             :          CPABORT("Minimal location not available with long integers @ "//routineN)
    2642             :       ENDIF
    2643         294 :       CALL mp_timeset(routineN, handle)
    2644             : 
    2645             : #if defined(__parallel)
    2646         294 :       msglen = SIZE(msg)
    2647         882 :       ALLOCATE (res(1:msglen), STAT=ierr)
    2648         294 :       IF (ierr /= 0) &
    2649           0 :          CPABORT("allocate @ "//routineN)
    2650         294 :       CALL mpi_allreduce(msg, res, msglen/2, MPI_2DOUBLE_PRECISION, MPI_MINLOC, gid, ierr)
    2651         294 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    2652         882 :       msg = res
    2653         294 :       DEALLOCATE (res)
    2654         294 :       CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
    2655             : #else
    2656             :       MARK_USED(msg)
    2657             :       MARK_USED(gid)
    2658             : #endif
    2659         294 :       CALL mp_timestop(handle)
    2660         294 :    END SUBROUTINE mp_minloc_dv
    2661             : 
    2662             : ! **************************************************************************************************
    2663             : !> \brief Finds the location of the minimal element in a vector.
    2664             : !> \param[in,out] msg         Find location of maximum element among these
    2665             : !>                            data (input).
    2666             : !> \param[in] gid             Message passing environment identifier
    2667             : !> \par MPI mapping
    2668             : !>      mpi_allreduce with the MPI_MINLOC reduction function identifier
    2669             : !> \par Invalid data types
    2670             : !>      This routine is invalid for (int_8) data!
    2671             : ! **************************************************************************************************
    2672           0 :    SUBROUTINE mp_minloc_iv(msg, gid)
    2673             :       INTEGER(KIND=int_4), INTENT(INOUT)       :: msg(:)
    2674             :       INTEGER, INTENT(IN)                      :: gid
    2675             : 
    2676             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_iv'
    2677             : 
    2678             :       INTEGER                                  :: handle, ierr
    2679             : #if defined(__parallel)
    2680             :       INTEGER                                  :: msglen
    2681           0 :       INTEGER(KIND=int_4), ALLOCATABLE         :: res(:)
    2682             : #endif
    2683             : 
    2684           0 :       ierr = 0
    2685             :       IF ("i" .EQ. "l" .AND. int_4 .EQ. int_8) THEN
    2686             :          CPABORT("Minimal location not available with long integers @ "//routineN)
    2687             :       ENDIF
    2688           0 :       CALL mp_timeset(routineN, handle)
    2689             : 
    2690             : #if defined(__parallel)
    2691           0 :       msglen = SIZE(msg)
    2692           0 :       ALLOCATE (res(1:msglen))
    2693           0 :       CALL mpi_allreduce(msg, res, msglen/2, MPI_2INTEGER, MPI_MINLOC, gid, ierr)
    2694           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    2695           0 :       msg = res
    2696           0 :       DEALLOCATE (res)
    2697           0 :       CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
    2698             : #else
    2699             :       MARK_USED(msg)
    2700             :       MARK_USED(gid)
    2701             : #endif
    2702           0 :       CALL mp_timestop(handle)
    2703           0 :    END SUBROUTINE mp_minloc_iv
    2704             : 
    2705             : ! **************************************************************************************************
    2706             : !> \brief Finds the location of the minimal element in a vector.
    2707             : !> \param[in,out] msg         Find location of maximum element among these
    2708             : !>                            data (input).
    2709             : !> \param[in] gid             Message passing environment identifier
    2710             : !> \par MPI mapping
    2711             : !>      mpi_allreduce with the MPI_MINLOC reduction function identifier
    2712             : !> \par Invalid data types
    2713             : !>      This routine is invalid for (int_8) data!
    2714             : ! **************************************************************************************************
    2715           0 :    SUBROUTINE mp_minloc_lv(msg, gid)
    2716             :       INTEGER(KIND=int_8), INTENT(INOUT)       :: msg(:)
    2717             :       INTEGER, INTENT(IN)                      :: gid
    2718             : 
    2719             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_lv'
    2720             : 
    2721             :       INTEGER                                  :: handle, ierr
    2722             : #if defined(__parallel)
    2723             :       INTEGER                                  :: msglen
    2724           0 :       INTEGER(KIND=int_8), ALLOCATABLE         :: res(:)
    2725             : #endif
    2726             : 
    2727           0 :       ierr = 0
    2728             :       IF ("l" .EQ. "l" .AND. int_8 .EQ. int_8) THEN
    2729           0 :          CPABORT("Minimal location not available with long integers @ "//routineN)
    2730             :       ENDIF
    2731           0 :       CALL mp_timeset(routineN, handle)
    2732             : 
    2733             : #if defined(__parallel)
    2734           0 :       msglen = SIZE(msg)
    2735           0 :       ALLOCATE (res(1:msglen))
    2736           0 :       CALL mpi_allreduce(msg, res, msglen/2, MPI_INTEGER8, MPI_MINLOC, gid, ierr)
    2737           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    2738           0 :       msg = res
    2739           0 :       DEALLOCATE (res)
    2740           0 :       CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
    2741             : #else
    2742             :       MARK_USED(msg)
    2743             :       MARK_USED(gid)
    2744             : #endif
    2745           0 :       CALL mp_timestop(handle)
    2746           0 :    END SUBROUTINE mp_minloc_lv
    2747             : 
    2748             : ! **************************************************************************************************
    2749             : !> \brief Finds the location of the minimal element in a vector.
    2750             : !> \param[in,out] msg         Find location of maximum element among these
    2751             : !>                            data (input).
    2752             : !> \param[in] gid             Message passing environment identifier
    2753             : !> \par MPI mapping
    2754             : !>      mpi_allreduce with the MPI_MINLOC reduction function identifier
    2755             : !> \par Invalid data types
    2756             : !>      This routine is invalid for (int_8) data!
    2757             : ! **************************************************************************************************
    2758           0 :    SUBROUTINE mp_minloc_rv(msg, gid)
    2759             :       REAL(kind=real_4), INTENT(INOUT)         :: msg(:)
    2760             :       INTEGER, INTENT(IN)                      :: gid
    2761             : 
    2762             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_rv'
    2763             : 
    2764             :       INTEGER                                  :: handle, ierr
    2765             : #if defined(__parallel)
    2766             :       INTEGER                                  :: msglen
    2767           0 :       REAL(kind=real_4), ALLOCATABLE           :: res(:)
    2768             : #endif
    2769             : 
    2770           0 :       ierr = 0
    2771             :       IF ("r" .EQ. "l" .AND. real_4 .EQ. int_8) THEN
    2772             :          CPABORT("Minimal location not available with long integers @ "//routineN)
    2773             :       ENDIF
    2774           0 :       CALL mp_timeset(routineN, handle)
    2775             : 
    2776             : #if defined(__parallel)
    2777           0 :       msglen = SIZE(msg)
    2778           0 :       ALLOCATE (res(1:msglen))
    2779           0 :       CALL mpi_allreduce(msg, res, msglen/2, MPI_2REAL, MPI_MINLOC, gid, ierr)
    2780           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    2781           0 :       msg = res
    2782           0 :       DEALLOCATE (res)
    2783           0 :       CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
    2784             : #else
    2785             :       MARK_USED(msg)
    2786             :       MARK_USED(gid)
    2787             : #endif
    2788           0 :       CALL mp_timestop(handle)
    2789           0 :    END SUBROUTINE mp_minloc_rv
    2790             : 
    2791             : ! **************************************************************************************************
    2792             : !> \brief Finds the location of the maximal element in a vector.
    2793             : !> \param[in,out] msg         Find location of maximum element among these
    2794             : !>                            data (input).
    2795             : !> \param[in] gid             Message passing environment identifier
    2796             : !> \par MPI mapping
    2797             : !>      mpi_allreduce with the MPI_MAXLOC reduction function identifier
    2798             : !> \par Invalid data types
    2799             : !>      This routine is invalid for (int_8) data!
    2800             : ! **************************************************************************************************
    2801     5424389 :    SUBROUTINE mp_maxloc_dv(msg, gid)
    2802             :       REAL(kind=real_8), INTENT(INOUT)         :: msg(:)
    2803             :       INTEGER, INTENT(IN)                      :: gid
    2804             : 
    2805             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_dv'
    2806             : 
    2807             :       INTEGER                                  :: handle, ierr
    2808             : #if defined(__parallel)
    2809             :       INTEGER                                  :: msglen
    2810     5424389 :       REAL(kind=real_8), ALLOCATABLE           :: res(:)
    2811             : #endif
    2812             : 
    2813     5424389 :       ierr = 0
    2814             :       IF ("d" .EQ. "l" .AND. real_8 .EQ. int_8) THEN
    2815             :          CPABORT("Maximal location not available with long integers @ "//routineN)
    2816             :       ENDIF
    2817     5424389 :       CALL mp_timeset(routineN, handle)
    2818             : 
    2819             : #if defined(__parallel)
    2820     5424389 :       msglen = SIZE(msg)
    2821    16273167 :       ALLOCATE (res(1:msglen))
    2822     5424389 :       CALL mpi_allreduce(msg, res, msglen/2, MPI_2DOUBLE_PRECISION, MPI_MAXLOC, gid, ierr)
    2823     5424389 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    2824    16273167 :       msg = res
    2825     5424389 :       DEALLOCATE (res)
    2826     5424389 :       CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
    2827             : #else
    2828             :       MARK_USED(msg)
    2829             :       MARK_USED(gid)
    2830             : #endif
    2831     5424389 :       CALL mp_timestop(handle)
    2832     5424389 :    END SUBROUTINE mp_maxloc_dv
    2833             : 
    2834             : ! **************************************************************************************************
    2835             : !> \brief Finds the location of the maximal element in a vector.
    2836             : !> \param[in,out] msg         Find location of maximum element among these
    2837             : !>                            data (input).
    2838             : !> \param[in] gid             Message passing environment identifier
    2839             : !> \par MPI mapping
    2840             : !>      mpi_allreduce with the MPI_MAXLOC reduction function identifier
    2841             : !> \par Invalid data types
    2842             : !>      This routine is invalid for (int_8) data!
    2843             : ! **************************************************************************************************
    2844         138 :    SUBROUTINE mp_maxloc_iv(msg, gid)
    2845             :       INTEGER(KIND=int_4), INTENT(INOUT)       :: msg(:)
    2846             :       INTEGER, INTENT(IN)                      :: gid
    2847             : 
    2848             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_iv'
    2849             : 
    2850             :       INTEGER                                  :: handle, ierr
    2851             : #if defined(__parallel)
    2852             :       INTEGER                                  :: msglen
    2853         138 :       INTEGER(KIND=int_4), ALLOCATABLE         :: res(:)
    2854             : #endif
    2855             : 
    2856         138 :       ierr = 0
    2857             :       IF ("i" .EQ. "l" .AND. int_4 .EQ. int_8) THEN
    2858             :          CPABORT("Maximal location not available with long integers @ "//routineN)
    2859             :       ENDIF
    2860         138 :       CALL mp_timeset(routineN, handle)
    2861             : 
    2862             : #if defined(__parallel)
    2863         138 :       msglen = SIZE(msg)
    2864         414 :       ALLOCATE (res(1:msglen))
    2865         138 :       CALL mpi_allreduce(msg, res, msglen/2, MPI_2INTEGER, MPI_MAXLOC, gid, ierr)
    2866         138 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    2867         414 :       msg = res
    2868         138 :       DEALLOCATE (res)
    2869         138 :       CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
    2870             : #else
    2871             :       MARK_USED(msg)
    2872             :       MARK_USED(gid)
    2873             : #endif
    2874         138 :       CALL mp_timestop(handle)
    2875         138 :    END SUBROUTINE mp_maxloc_iv
    2876             : 
    2877             : ! **************************************************************************************************
    2878             : !> \brief Finds the location of the maximal element in a vector.
    2879             : !> \param[in,out] msg         Find location of maximum element among these
    2880             : !>                            data (input).
    2881             : !> \param[in] gid             Message passing environment identifier
    2882             : !> \par MPI mapping
    2883             : !>      mpi_allreduce with the MPI_MAXLOC reduction function identifier
    2884             : !> \par Invalid data types
    2885             : !>      This routine is invalid for (int_8) data!
    2886             : ! **************************************************************************************************
    2887           0 :    SUBROUTINE mp_maxloc_lv(msg, gid)
    2888             :       INTEGER(KIND=int_8), INTENT(INOUT)       :: msg(:)
    2889             :       INTEGER, INTENT(IN)                      :: gid
    2890             : 
    2891             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_lv'
    2892             : 
    2893             :       INTEGER                                  :: handle, ierr
    2894             : #if defined(__parallel)
    2895             :       INTEGER                                  :: msglen
    2896           0 :       INTEGER(KIND=int_8), ALLOCATABLE         :: res(:)
    2897             : #endif
    2898             : 
    2899           0 :       ierr = 0
    2900             :       IF ("l" .EQ. "l" .AND. int_8 .EQ. int_8) THEN
    2901           0 :          CPABORT("Maximal location not available with long integers @ "//routineN)
    2902             :       ENDIF
    2903           0 :       CALL mp_timeset(routineN, handle)
    2904             : 
    2905             : #if defined(__parallel)
    2906           0 :       msglen = SIZE(msg)
    2907           0 :       ALLOCATE (res(1:msglen))
    2908           0 :       CALL mpi_allreduce(msg, res, msglen/2, MPI_INTEGER8, MPI_MAXLOC, gid, ierr)
    2909           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    2910           0 :       msg = res
    2911           0 :       DEALLOCATE (res)
    2912           0 :       CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
    2913             : #else
    2914             :       MARK_USED(msg)
    2915             :       MARK_USED(gid)
    2916             : #endif
    2917           0 :       CALL mp_timestop(handle)
    2918           0 :    END SUBROUTINE mp_maxloc_lv
    2919             : 
    2920             : ! **************************************************************************************************
    2921             : !> \brief Finds the location of the maximal element in a vector.
    2922             : !> \param[in,out] msg         Find location of maximum element among these
    2923             : !>                            data (input).
    2924             : !> \param[in] gid             Message passing environment identifier
    2925             : !> \par MPI mapping
    2926             : !>      mpi_allreduce with the MPI_MAXLOC reduction function identifier
    2927             : !> \par Invalid data types
    2928             : !>      This routine is invalid for (int_8) data!
    2929             : ! **************************************************************************************************
    2930           0 :    SUBROUTINE mp_maxloc_rv(msg, gid)
    2931             :       REAL(kind=real_4), INTENT(INOUT)         :: msg(:)
    2932             :       INTEGER, INTENT(IN)                      :: gid
    2933             : 
    2934             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_rv'
    2935             : 
    2936             :       INTEGER                                  :: handle, ierr
    2937             : #if defined(__parallel)
    2938             :       INTEGER                                  :: msglen
    2939           0 :       REAL(kind=real_4), ALLOCATABLE           :: res(:)
    2940             : #endif
    2941             : 
    2942           0 :       ierr = 0
    2943             :       IF ("r" .EQ. "l" .AND. real_4 .EQ. int_8) THEN
    2944             :          CPABORT("Maximal location not available with long integers @ "//routineN)
    2945             :       ENDIF
    2946           0 :       CALL mp_timeset(routineN, handle)
    2947             : 
    2948             : #if defined(__parallel)
    2949           0 :       msglen = SIZE(msg)
    2950           0 :       ALLOCATE (res(1:msglen))
    2951           0 :       CALL mpi_allreduce(msg, res, msglen/2, MPI_2REAL, MPI_MAXLOC, gid, ierr)
    2952           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    2953           0 :       msg = res
    2954           0 :       DEALLOCATE (res)
    2955           0 :       CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
    2956             : #else
    2957             :       MARK_USED(msg)
    2958             :       MARK_USED(gid)
    2959             : #endif
    2960           0 :       CALL mp_timestop(handle)
    2961           0 :    END SUBROUTINE mp_maxloc_rv
    2962             : 
    2963             : ! **************************************************************************************************
    2964             : !> \brief Logical OR reduction
    2965             : !> \param[in,out] msg         Datum to perform inclusive disjunction (input)
    2966             : !>                            and resultant inclusive disjunction (output)
    2967             : !> \param[in] gid             Message passing environment identifier
    2968             : !> \par MPI mapping
    2969             : !>      mpi_allreduce
    2970             : ! **************************************************************************************************
    2971        1880 :    SUBROUTINE mp_sum_b(msg, gid)
    2972             :       LOGICAL, INTENT(INOUT)                             :: msg
    2973             :       INTEGER, INTENT(IN)                                :: gid
    2974             : 
    2975             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_b'
    2976             : 
    2977             :       INTEGER                                            :: handle, ierr, msglen
    2978             : 
    2979        1880 :       CALL mp_timeset(routineN, handle)
    2980        1880 :       ierr = 0
    2981        1880 :       msglen = 1
    2982             : #if defined(__parallel)
    2983        1880 :       CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, gid, ierr)
    2984        1880 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    2985             : #else
    2986             :       MARK_USED(msg)
    2987             :       MARK_USED(gid)
    2988             : #endif
    2989        1880 :       CALL mp_timestop(handle)
    2990        1880 :    END SUBROUTINE mp_sum_b
    2991             : 
    2992             : ! **************************************************************************************************
    2993             : !> \brief Logical OR reduction
    2994             : !> \param[in,out] msg         Datum to perform inclusive disjunction (input)
    2995             : !>                            and resultant inclusive disjunction (output)
    2996             : !> \param[in] gid             Message passing environment identifier
    2997             : !> \par MPI mapping
    2998             : !>      mpi_allreduce
    2999             : ! **************************************************************************************************
    3000           0 :    SUBROUTINE mp_sum_bv(msg, gid)
    3001             :       LOGICAL, DIMENSION(:), INTENT(INOUT)               :: msg
    3002             :       INTEGER, INTENT(IN)                                :: gid
    3003             : 
    3004             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_bv'
    3005             : 
    3006             :       INTEGER                                            :: handle, ierr, msglen
    3007             : 
    3008           0 :       CALL mp_timeset(routineN, handle)
    3009           0 :       ierr = 0
    3010           0 :       msglen = SIZE(msg)
    3011             : #if defined(__parallel)
    3012           0 :       IF (msglen .GT. 0) THEN
    3013           0 :          CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, gid, ierr)
    3014           0 :          IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    3015             :       ENDIF
    3016             : #else
    3017             :       MARK_USED(msg)
    3018             :       MARK_USED(gid)
    3019             : #endif
    3020           0 :       CALL mp_timestop(handle)
    3021           0 :    END SUBROUTINE mp_sum_bv
    3022             : 
    3023             : ! **************************************************************************************************
    3024             : !> \brief Logical OR reduction
    3025             : !> \param[in,out] msg         Datum to perform inclusive disjunction (input)
    3026             : !>                            and resultant inclusive disjunction (output)
    3027             : !> \param[in] gid             Message passing environment identifier
    3028             : !> \param request ...
    3029             : !> \par MPI mapping
    3030             : !>      mpi_allreduce
    3031             : ! **************************************************************************************************
    3032           0 :    SUBROUTINE mp_isum_bv(msg, gid, request)
    3033             :       LOGICAL, DIMENSION(:), INTENT(INOUT)               :: msg
    3034             :       INTEGER, INTENT(IN)                                :: gid
    3035             :       INTEGER, INTENT(INOUT)                             :: request
    3036             : 
    3037             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_isum_bv'
    3038             : 
    3039             :       INTEGER                                            :: handle, ierr, msglen
    3040             : 
    3041           0 :       CALL mp_timeset(routineN, handle)
    3042           0 :       ierr = 0
    3043           0 :       msglen = SIZE(msg)
    3044             : #if defined(__parallel)
    3045             : #if __MPI_VERSION > 2
    3046           0 :       IF (msglen .GT. 0) THEN
    3047           0 :          CALL mpi_iallreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, gid, request, ierr)
    3048           0 :          IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
    3049             :       ELSE
    3050           0 :          request = mp_request_null
    3051             :       ENDIF
    3052             : #else
    3053             :       MARK_USED(msg)
    3054             :       MARK_USED(gid)
    3055             :       MARK_USED(request)
    3056             :       CPABORT("mp_isum requires MPI-3 standard")
    3057             : #endif
    3058             : #else
    3059             :       MARK_USED(msg)
    3060             :       MARK_USED(gid)
    3061             :       MARK_USED(request)
    3062             : #endif
    3063           0 :       CALL mp_timestop(handle)
    3064           0 :    END SUBROUTINE mp_isum_bv
    3065             : 
    3066             : ! **************************************************************************************************
    3067             : !> \brief Get Version of the MPI Library (MPI 3)
    3068             : !> \param[out] version        Version of the library,
    3069             : !>                            declared as CHARACTER(LEN=mp_max_library_version_string)
    3070             : !> \param[out] resultlen      Length (in printable characters) of
    3071             : !>                            the result returned in version (integer)
    3072             : ! **************************************************************************************************
    3073           0 :    SUBROUTINE mp_get_library_version(version, resultlen)
    3074             :       CHARACTER(len=*), INTENT(OUT)                      :: version
    3075             :       INTEGER, INTENT(OUT)                               :: resultlen
    3076             : 
    3077             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_get_library_version'
    3078             : 
    3079             :       INTEGER                                            :: ierr
    3080             : 
    3081           0 :       ierr = 0
    3082             : 
    3083           0 :       version = ''
    3084             : 
    3085             : #if defined(__parallel)
    3086             : #if __MPI_VERSION > 2
    3087           0 :       CALL mpi_get_library_version(version, resultlen, ierr)
    3088           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_get_library_version @ "//routineN)
    3089             : #else
    3090             :       MARK_USED(version)
    3091             :       MARK_USED(resultlen)
    3092             :       CPABORT("mp_get_library_version requires MPI-3 standard")
    3093             : #endif
    3094             : #else
    3095             :       MARK_USED(version)
    3096             :       resultlen = 0
    3097             : #endif
    3098           0 :    END SUBROUTINE mp_get_library_version
    3099             : 
    3100             : ! **************************************************************************************************
    3101             : !> \brief Opens a file
    3102             : !> \param[in] groupid    message passing environment identifier
    3103             : !> \param[out] fh        file handle (file storage unit)
    3104             : !> \param[in] filepath   path to the file
    3105             : !> \param amode_status   access mode
    3106             : !> \param info ...
    3107             : !> \par MPI-I/O mapping  mpi_file_open
    3108             : !> \par STREAM-I/O mapping  OPEN
    3109             : !>
    3110             : !> \param[in](optional) info   info object
    3111             : !> \par History
    3112             : !>      11.2012 created [Hossein Bani-Hashemian]
    3113             : ! **************************************************************************************************
    3114        1740 :    SUBROUTINE mp_file_open(groupid, fh, filepath, amode_status, info)
    3115             :       INTEGER, INTENT(IN)                      :: groupid
    3116             :       INTEGER, INTENT(OUT)                     :: fh
    3117             :       CHARACTER(len=*), INTENT(IN)             :: filepath
    3118             :       INTEGER, INTENT(IN)                      :: amode_status
    3119             :       INTEGER, INTENT(IN), OPTIONAL            :: info
    3120             : 
    3121             :       INTEGER                                  :: ierr, istat
    3122             : #if defined(__parallel)
    3123             :       INTEGER                                  :: my_info
    3124             : #else
    3125             :       CHARACTER(LEN=10)                        :: fstatus, fposition
    3126             :       INTEGER                                  :: amode
    3127             :       LOGICAL                                  :: exists, is_open
    3128             : #endif
    3129             : 
    3130        1740 :       ierr = 0
    3131        1740 :       istat = 0
    3132             : #if defined(__parallel)
    3133        1740 :       my_info = mpi_info_null
    3134        1740 :       IF (PRESENT(info)) my_info = info
    3135        1740 :       CALL mpi_file_open(groupid, filepath, amode_status, my_info, fh, ierr)
    3136        1740 :       CALL mpi_file_set_errhandler(fh, MPI_ERRORS_RETURN, ierr)
    3137        1740 :       IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_open")
    3138             : #else
    3139             :       MARK_USED(groupid)
    3140             :       MARK_USED(info)
    3141             :       amode = amode_status
    3142             :       IF (amode .GT. file_amode_append) THEN
    3143             :          fposition = "APPEND"
    3144             :          amode = amode - file_amode_append
    3145             :       ELSE
    3146             :          fposition = "REWIND"
    3147             :       END IF
    3148             :       IF ((amode .EQ. file_amode_create) .OR. &
    3149             :           (amode .EQ. file_amode_create + file_amode_wronly) .OR. &
    3150             :           (amode .EQ. file_amode_create + file_amode_wronly + file_amode_excl)) THEN
    3151             :          fstatus = "UNKNOWN"
    3152             :       ELSE
    3153             :          fstatus = "OLD"
    3154             :       END IF
    3155             :       ! Get a new unit number
    3156             :       DO fh = 1, 999
    3157             :          INQUIRE (UNIT=fh, EXIST=exists, OPENED=is_open, IOSTAT=istat)
    3158             :          IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) EXIT
    3159             :       END DO
    3160             :       OPEN (UNIT=fh, FILE=filepath, STATUS=fstatus, ACCESS="STREAM", POSITION=fposition)
    3161             : #endif
    3162        1740 :    END SUBROUTINE mp_file_open
    3163             : 
    3164             : ! **************************************************************************************************
    3165             : !> \brief Deletes a file. Auxiliary routine to emulate 'replace' action for mp_file_open.
    3166             : !>        Only the master processor should call this routine.
    3167             : !> \param[in] filepath   path to the file
    3168             : !> \param[in](optional) info   info object
    3169             : !> \par History
    3170             : !>      11.2017 created [Nico Holmberg]
    3171             : ! **************************************************************************************************
    3172         160 :    SUBROUTINE mp_file_delete(filepath, info)
    3173             :       CHARACTER(len=*), INTENT(IN)             :: filepath
    3174             :       INTEGER, INTENT(IN), OPTIONAL            :: info
    3175             : 
    3176             : #if defined(__parallel)
    3177             :       INTEGER                                  :: ierr
    3178             :       INTEGER                                  :: my_info
    3179             :       LOGICAL                                  :: exists
    3180             : #endif
    3181             : 
    3182             : #if defined(__parallel)
    3183         160 :       ierr = 0
    3184         160 :       my_info = mpi_info_null
    3185         160 :       IF (PRESENT(info)) my_info = info
    3186         160 :       INQUIRE (FILE=filepath, EXIST=exists)
    3187         160 :       IF (exists) CALL mpi_file_delete(filepath, my_info, ierr)
    3188         160 :       IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_delete")
    3189             : #else
    3190             :       MARK_USED(filepath)
    3191             :       MARK_USED(info)
    3192             :       ! Explicit file delete not necessary, handled by subsequent call to open_file with action 'replace'
    3193             : #endif
    3194             : 
    3195         160 :    END SUBROUTINE mp_file_delete
    3196             : 
    3197             : ! **************************************************************************************************
    3198             : !> \brief Closes a file
    3199             : !> \param[in] fh   file handle (file storage unit)
    3200             : !> \par MPI-I/O mapping   mpi_file_close
    3201             : !> \par STREAM-I/O mapping   CLOSE
    3202             : !>
    3203             : !> \par History
    3204             : !>      11.2012 created [Hossein Bani-Hashemian]
    3205             : ! **************************************************************************************************
    3206        1740 :    SUBROUTINE mp_file_close(fh)
    3207             :       INTEGER, INTENT(INOUT)                             :: fh
    3208             : 
    3209             :       INTEGER                                            :: ierr
    3210             : 
    3211        1740 :       ierr = 0
    3212             : #if defined(__parallel)
    3213        1740 :       CALL mpi_file_set_errhandler(fh, MPI_ERRORS_RETURN, ierr)
    3214        1740 :       CALL mpi_file_close(fh, ierr)
    3215        1740 :       IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_close")
    3216             : #else
    3217             :       CLOSE (fh)
    3218             : #endif
    3219        1740 :    END SUBROUTINE mp_file_close
    3220             : 
    3221             : ! **************************************************************************************************
    3222             : !> \brief Returns the file size
    3223             : !> \param[in] fh file handle (file storage unit)
    3224             : !> \param[out] file_size  the file size
    3225             : !> \par MPI-I/O mapping   mpi_file_get_size
    3226             : !> \par STREAM-I/O mapping   INQUIRE
    3227             : !>
    3228             : !> \par History
    3229             : !>      12.2012 created [Hossein Bani-Hashemian]
    3230             : ! **************************************************************************************************
    3231           0 :    SUBROUTINE mp_file_get_size(fh, file_size)
    3232             :       INTEGER, INTENT(IN)                                :: fh
    3233             :       INTEGER(kind=file_offset), INTENT(OUT)             :: file_size
    3234             : 
    3235             :       INTEGER                                            :: ierr
    3236             : 
    3237           0 :       ierr = 0
    3238             : #if defined(__parallel)
    3239           0 :       CALL mpi_file_set_errhandler(fh, MPI_ERRORS_RETURN, ierr)
    3240           0 :       CALL mpi_file_get_size(fh, file_size, ierr)
    3241           0 :       IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_size")
    3242             : #else
    3243             :       INQUIRE (UNIT=fh, SIZE=file_size)
    3244             : #endif
    3245           0 :    END SUBROUTINE mp_file_get_size
    3246             : 
    3247             : ! **************************************************************************************************
    3248             : !> \brief Returns the file position
    3249             : !> \param[in] fh file handle (file storage unit)
    3250             : !> \param[out] file_size  the file position
    3251             : !> \par MPI-I/O mapping   mpi_file_get_position
    3252             : !> \par STREAM-I/O mapping   INQUIRE
    3253             : !>
    3254             : !> \par History
    3255             : !>      11.2017 created [Nico Holmberg]
    3256             : ! **************************************************************************************************
    3257        1702 :    SUBROUTINE mp_file_get_position(fh, pos)
    3258             :       INTEGER, INTENT(IN)                                :: fh
    3259             :       INTEGER(kind=file_offset), INTENT(OUT)             :: pos
    3260             : 
    3261             :       INTEGER                                            :: ierr
    3262             : 
    3263        1702 :       ierr = 0
    3264             : #if defined(__parallel)
    3265        1702 :       CALL mpi_file_set_errhandler(fh, MPI_ERRORS_RETURN, ierr)
    3266        1702 :       CALL mpi_file_get_position(fh, pos, ierr)
    3267        1702 :       IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_position")
    3268             : #else
    3269             :       INQUIRE (UNIT=fh, POS=pos)
    3270             : #endif
    3271        1702 :    END SUBROUTINE mp_file_get_position
    3272             : 
    3273             : ! **************************************************************************************************
    3274             : !> \brief (parallel) Blocking individual file write using explicit offsets
    3275             : !>        (serial) Unformatted stream write
    3276             : !> \param[in] fh     file handle (file storage unit)
    3277             : !> \param[in] offset file offset (position)
    3278             : !> \param[in] msg    data to be written to the file
    3279             : !> \param msglen ...
    3280             : !> \par MPI-I/O mapping   mpi_file_write_at
    3281             : !> \par STREAM-I/O mapping   WRITE
    3282             : !> \param[in](optional) msglen number of the elements of data
    3283             : ! **************************************************************************************************
    3284           0 :    SUBROUTINE mp_file_write_at_chv(fh, offset, msg, msglen)
    3285             :       CHARACTER, INTENT(IN)                      :: msg(:)
    3286             :       INTEGER, INTENT(IN)                        :: fh
    3287             :       INTEGER, INTENT(IN), OPTIONAL              :: msglen
    3288             :       INTEGER(kind=file_offset), INTENT(IN)      :: offset
    3289             : 
    3290             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_write_at_chv'
    3291             : 
    3292             : #if defined(__parallel)
    3293             :       INTEGER                                    :: ierr, msg_len
    3294             : 
    3295           0 :       msg_len = SIZE(msg)
    3296           0 :       IF (PRESENT(msglen)) msg_len = msglen
    3297           0 :       CALL MPI_FILE_WRITE_AT(fh, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
    3298           0 :       IF (ierr .NE. 0) &
    3299           0 :          CPABORT("mpi_file_write_at_chv @ "//routineN)
    3300             : #else
    3301             :       MARK_USED(msglen)
    3302             :       WRITE (UNIT=fh, POS=offset + 1) msg
    3303             : #endif
    3304           0 :    END SUBROUTINE mp_file_write_at_chv
    3305             : 
    3306             : ! **************************************************************************************************
    3307             : !> \brief ...
    3308             : !> \param fh ...
    3309             : !> \param offset ...
    3310             : !> \param msg ...
    3311             : ! **************************************************************************************************
    3312        8217 :    SUBROUTINE mp_file_write_at_ch(fh, offset, msg)
    3313             :       CHARACTER(LEN=*), INTENT(IN)               :: msg
    3314             :       INTEGER, INTENT(IN)                        :: fh
    3315             :       INTEGER(kind=file_offset), INTENT(IN)      :: offset
    3316             : 
    3317             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_write_at_ch'
    3318             : 
    3319             : #if defined(__parallel)
    3320             :       INTEGER                                    :: ierr
    3321             : 
    3322        8217 :       CALL MPI_FILE_WRITE_AT(fh, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
    3323        8217 :       IF (ierr .NE. 0) &
    3324           0 :          CPABORT("mpi_file_write_at_ch @ "//routineN)
    3325             : #else
    3326             :       WRITE (UNIT=fh, POS=offset + 1) msg
    3327             : #endif
    3328        8217 :    END SUBROUTINE mp_file_write_at_ch
    3329             : 
    3330             : ! **************************************************************************************************
    3331             : !> \brief (parallel) Blocking collective file write using explicit offsets
    3332             : !>        (serial) Unformatted stream write
    3333             : !> \param fh ...
    3334             : !> \param offset ...
    3335             : !> \param msg ...
    3336             : !> \param msglen ...
    3337             : !> \par MPI-I/O mapping   mpi_file_write_at_all
    3338             : !> \par STREAM-I/O mapping   WRITE
    3339             : ! **************************************************************************************************
    3340           0 :    SUBROUTINE mp_file_write_at_all_chv(fh, offset, msg, msglen)
    3341             :       CHARACTER, INTENT(IN)                      :: msg(:)
    3342             :       INTEGER, INTENT(IN)                        :: fh
    3343             :       INTEGER, INTENT(IN), OPTIONAL              :: msglen
    3344             :       INTEGER(kind=file_offset), INTENT(IN)      :: offset
    3345             : 
    3346             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_write_at_all_chv'
    3347             : 
    3348             : #if defined(__parallel)
    3349             :       INTEGER                                    :: ierr, msg_len
    3350             : 
    3351           0 :       msg_len = SIZE(msg)
    3352           0 :       IF (PRESENT(msglen)) msg_len = msglen
    3353           0 :       CALL MPI_FILE_WRITE_AT_ALL(fh, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
    3354           0 :       IF (ierr .NE. 0) &
    3355           0 :          CPABORT("mpi_file_write_at_all_chv @ "//routineN)
    3356             : #else
    3357             :       MARK_USED(msglen)
    3358             :       WRITE (UNIT=fh, POS=offset + 1) msg
    3359             : #endif
    3360           0 :    END SUBROUTINE mp_file_write_at_all_chv
    3361             : 
    3362             : ! **************************************************************************************************
    3363             : !> \brief ...
    3364             : !> \param fh ...
    3365             : !> \param offset ...
    3366             : !> \param msg ...
    3367             : ! **************************************************************************************************
    3368           0 :    SUBROUTINE mp_file_write_at_all_ch(fh, offset, msg)
    3369             :       CHARACTER(LEN=*), INTENT(IN)               :: msg
    3370             :       INTEGER, INTENT(IN)                        :: fh
    3371             :       INTEGER(kind=file_offset), INTENT(IN)      :: offset
    3372             : 
    3373             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_write_at_all_ch'
    3374             : 
    3375             : #if defined(__parallel)
    3376             :       INTEGER                                    :: ierr
    3377             : 
    3378           0 :       CALL MPI_FILE_WRITE_AT_ALL(fh, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
    3379           0 :       IF (ierr .NE. 0) &
    3380           0 :          CPABORT("mpi_file_write_at_all_ch @ "//routineN)
    3381             : #else
    3382             :       WRITE (UNIT=fh, POS=offset + 1) msg
    3383             : #endif
    3384           0 :    END SUBROUTINE mp_file_write_at_all_ch
    3385             : 
    3386             : ! **************************************************************************************************
    3387             : !> \brief (parallel) Blocking individual file read using explicit offsets
    3388             : !>        (serial) Unformatted stream read
    3389             : !> \param[in] fh     file handle (file storage unit)
    3390             : !> \param[in] offset file offset (position)
    3391             : !> \param[out] msg   data to be read from the file
    3392             : !> \param msglen ...
    3393             : !> \par MPI-I/O mapping   mpi_file_read_at
    3394             : !> \par STREAM-I/O mapping   READ
    3395             : !> \param[in](optional) msglen  number of elements of data
    3396             : ! **************************************************************************************************
    3397           0 :    SUBROUTINE mp_file_read_at_chv(fh, offset, msg, msglen)
    3398             :       CHARACTER, INTENT(OUT)                     :: msg(:)
    3399             :       INTEGER, INTENT(IN)                        :: fh
    3400             :       INTEGER, INTENT(IN), OPTIONAL              :: msglen
    3401             :       INTEGER(kind=file_offset), INTENT(IN)      :: offset
    3402             : 
    3403             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_read_at_chv'
    3404             : 
    3405             : #if defined(__parallel)
    3406             :       INTEGER                                    :: ierr, msg_len
    3407             : 
    3408           0 :       msg_len = SIZE(msg)
    3409           0 :       IF (PRESENT(msglen)) msg_len = msglen
    3410           0 :       CALL MPI_FILE_READ_AT(fh, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
    3411           0 :       IF (ierr .NE. 0) &
    3412           0 :          CPABORT("mpi_file_read_at_chv @ "//routineN)
    3413             : #else
    3414             :       MARK_USED(msglen)
    3415             :       READ (UNIT=fh, POS=offset + 1) msg
    3416             : #endif
    3417           0 :    END SUBROUTINE mp_file_read_at_chv
    3418             : 
    3419             : ! **************************************************************************************************
    3420             : !> \brief ...
    3421             : !> \param fh ...
    3422             : !> \param offset ...
    3423             : !> \param msg ...
    3424             : ! **************************************************************************************************
    3425           0 :    SUBROUTINE mp_file_read_at_ch(fh, offset, msg)
    3426             :       CHARACTER(LEN=*), INTENT(OUT)              :: msg
    3427             :       INTEGER, INTENT(IN)                        :: fh
    3428             :       INTEGER(kind=file_offset), INTENT(IN)      :: offset
    3429             : 
    3430             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_read_at_ch'
    3431             : 
    3432             : #if defined(__parallel)
    3433             :       INTEGER                                    :: ierr
    3434             : 
    3435           0 :       CALL MPI_FILE_READ_AT(fh, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
    3436           0 :       IF (ierr .NE. 0) &
    3437           0 :          CPABORT("mpi_file_read_at_ch @ "//routineN)
    3438             : #else
    3439             :       READ (UNIT=fh, POS=offset + 1) msg
    3440             : #endif
    3441           0 :    END SUBROUTINE mp_file_read_at_ch
    3442             : 
    3443             : ! **************************************************************************************************
    3444             : !> \brief (parallel) Blocking collective file read using explicit offsets
    3445             : !>        (serial) Unformatted stream read
    3446             : !> \param fh ...
    3447             : !> \param offset ...
    3448             : !> \param msg ...
    3449             : !> \param msglen ...
    3450             : !> \par MPI-I/O mapping    mpi_file_read_at_all
    3451             : !> \par STREAM-I/O mapping   READ
    3452             : ! **************************************************************************************************
    3453           0 :    SUBROUTINE mp_file_read_at_all_chv(fh, offset, msg, msglen)
    3454             :       CHARACTER, INTENT(OUT)                     :: msg(:)
    3455             :       INTEGER, INTENT(IN)                        :: fh
    3456             :       INTEGER, INTENT(IN), OPTIONAL              :: msglen
    3457             :       INTEGER(kind=file_offset), INTENT(IN)      :: offset
    3458             : 
    3459             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_read_at_all_chv'
    3460             : 
    3461             : #if defined(__parallel)
    3462             :       INTEGER                                    :: ierr, msg_len
    3463             : 
    3464           0 :       msg_len = SIZE(msg)
    3465           0 :       IF (PRESENT(msglen)) msg_len = msglen
    3466           0 :       CALL MPI_FILE_READ_AT_ALL(fh, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
    3467           0 :       IF (ierr .NE. 0) &
    3468           0 :          CPABORT("mpi_file_read_at_all_chv @ "//routineN)
    3469             : #else
    3470             :       MARK_USED(msglen)
    3471             :       READ (UNIT=fh, POS=offset + 1) msg
    3472             : #endif
    3473           0 :    END SUBROUTINE mp_file_read_at_all_chv
    3474             : 
    3475             : ! **************************************************************************************************
    3476             : !> \brief ...
    3477             : !> \param fh ...
    3478             : !> \param offset ...
    3479             : !> \param msg ...
    3480             : ! **************************************************************************************************
    3481           0 :    SUBROUTINE mp_file_read_at_all_ch(fh, offset, msg)
    3482             :       CHARACTER(LEN=*), INTENT(OUT)              :: msg
    3483             :       INTEGER, INTENT(IN)                        :: fh
    3484             :       INTEGER(kind=file_offset), INTENT(IN)      :: offset
    3485             : 
    3486             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_read_at_all_ch'
    3487             : 
    3488             : #if defined(__parallel)
    3489             :       INTEGER                                    :: ierr
    3490             : 
    3491           0 :       CALL MPI_FILE_READ_AT_ALL(fh, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
    3492           0 :       IF (ierr .NE. 0) &
    3493           0 :          CPABORT("mpi_file_read_at_all_ch @ "//routineN)
    3494             : #else
    3495             :       READ (UNIT=fh, POS=offset + 1) msg
    3496             : #endif
    3497           0 :    END SUBROUTINE mp_file_read_at_all_ch
    3498             : 
    3499             : ! **************************************************************************************************
    3500             : !> \brief Returns the size of a data type in bytes
    3501             : !> \param[in] type_descriptor  data type
    3502             : !> \param[out] type_size       size of the data type
    3503             : !> \par MPI mapping
    3504             : !>      mpi_type_size
    3505             : !>
    3506             : ! **************************************************************************************************
    3507           0 :    SUBROUTINE mp_type_size(type_descriptor, type_size)
    3508             :       TYPE(mp_type_descriptor_type), INTENT(IN)          :: type_descriptor
    3509             :       INTEGER, INTENT(OUT)                               :: type_size
    3510             : 
    3511             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_type_size'
    3512             : 
    3513             :       INTEGER                                            :: ierr
    3514             : 
    3515           0 :       ierr = 0
    3516             : #if defined(__parallel)
    3517           0 :       CALL MPI_TYPE_SIZE(type_descriptor%type_handle, type_size, ierr)
    3518           0 :       IF (ierr .NE. 0) &
    3519           0 :          CPABORT("mpi_type_size @ "//routineN)
    3520             : #else
    3521             :       SELECT CASE (type_descriptor%type_handle)
    3522             :       CASE (1)
    3523             :          type_size = real_4_size
    3524             :       CASE (3)
    3525             :          type_size = real_8_size
    3526             :       CASE (5)
    3527             :          type_size = 2*real_4_size
    3528             :       CASE (7)
    3529             :          type_size = 2*real_8_size
    3530             :       END SELECT
    3531             : #endif
    3532           0 :    END SUBROUTINE mp_type_size
    3533             : 
    3534             : ! **************************************************************************************************
    3535             : !> \brief ...
    3536             : !> \param subtypes ...
    3537             : !> \param vector_descriptor ...
    3538             : !> \param index_descriptor ...
    3539             : !> \return ...
    3540             : ! **************************************************************************************************
    3541           0 :    FUNCTION mp_type_make_struct(subtypes, &
    3542             :                                 vector_descriptor, index_descriptor) &
    3543             :       RESULT(type_descriptor)
    3544             :       TYPE(mp_type_descriptor_type), &
    3545             :          DIMENSION(:), INTENT(IN)               :: subtypes
    3546             :       INTEGER, DIMENSION(2), INTENT(IN), &
    3547             :          OPTIONAL                               :: vector_descriptor
    3548             :       TYPE(mp_indexing_meta_type), &
    3549             :          INTENT(IN), OPTIONAL                   :: index_descriptor
    3550             :       TYPE(mp_type_descriptor_type)            :: type_descriptor
    3551             : 
    3552             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_type_make_struct'
    3553             : 
    3554             :       INTEGER                                  :: i, ierr, n
    3555             : #if defined(__parallel)
    3556             :       INTEGER(kind=mpi_address_kind), &
    3557           0 :          ALLOCATABLE, DIMENSION(:)              :: displacements
    3558             : #endif
    3559           0 :       INTEGER, ALLOCATABLE, DIMENSION(:)       :: lengths, old_types
    3560             : 
    3561           0 :       ierr = 0
    3562           0 :       n = SIZE(subtypes)
    3563             :       !type_descriptor%mpi_type_handle = MPI_DATATYPE_NULL
    3564           0 :       type_descriptor%length = 1
    3565             : #if defined(__parallel)
    3566           0 :       CALL mpi_get_address(MPI_BOTTOM, type_descriptor%base, ierr)
    3567           0 :       IF (ierr /= 0) &
    3568           0 :          CPABORT("MPI_get_address @ "//routineN)
    3569           0 :       ALLOCATE (displacements(n))
    3570             : #endif
    3571           0 :       type_descriptor%vector_descriptor(1:2) = 1
    3572           0 :       type_descriptor%has_indexing = .FALSE.
    3573           0 :       ALLOCATE (type_descriptor%subtype(n))
    3574           0 :       type_descriptor%subtype(:) = subtypes(:)
    3575           0 :       ALLOCATE (lengths(n), old_types(n))
    3576           0 :       DO i = 1, SIZE(subtypes)
    3577             : #if defined(__parallel)
    3578           0 :          displacements(i) = subtypes(i)%base
    3579             : #endif
    3580           0 :          old_types(i) = subtypes(i)%type_handle
    3581           0 :          lengths(i) = subtypes(i)%length
    3582             :       ENDDO
    3583             : #if defined(__parallel)
    3584             :       CALL MPI_Type_create_struct(n, &
    3585             :                                   lengths, displacements, old_types, &
    3586           0 :                                   type_descriptor%type_handle, ierr)
    3587           0 :       IF (ierr /= 0) &
    3588           0 :          CPABORT("MPI_Type_create_struct @ "//routineN)
    3589           0 :       CALL MPI_Type_commit(type_descriptor%type_handle, ierr)
    3590           0 :       IF (ierr /= 0) &
    3591           0 :          CPABORT("MPI_Type_commit @ "//routineN)
    3592             : #endif
    3593           0 :       IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
    3594           0 :          CPABORT(routineN//" Vectors and indices NYI")
    3595             :       ENDIF
    3596           0 :    END FUNCTION mp_type_make_struct
    3597             : 
    3598             : ! **************************************************************************************************
    3599             : !> \brief ...
    3600             : !> \param type_descriptor ...
    3601             : ! **************************************************************************************************
    3602           0 :    RECURSIVE SUBROUTINE mp_type_free_m(type_descriptor)
    3603             :       TYPE(mp_type_descriptor_type), INTENT(inout)       :: type_descriptor
    3604             : 
    3605             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_type_free_m'
    3606             : 
    3607             :       INTEGER                                            :: handle, i, ierr
    3608             : 
    3609           0 :       CALL mp_timeset(routineN, handle)
    3610           0 :       ierr = 0
    3611             : 
    3612             :       ! If the subtype is associated, then it's a user-defined data type.
    3613             : 
    3614           0 :       IF (ASSOCIATED(type_descriptor%subtype)) THEN
    3615           0 :          DO i = 1, SIZE(type_descriptor%subtype)
    3616           0 :             CALL mp_type_free_m(type_descriptor%subtype(i))
    3617             :          ENDDO
    3618           0 :          DEALLOCATE (type_descriptor%subtype)
    3619             :       ENDIF
    3620             : #if defined(__parallel)
    3621           0 :       CALL MPI_Type_free(type_descriptor%type_handle, ierr)
    3622           0 :       IF (ierr /= 0) &
    3623           0 :          CPABORT("MPI_Type_free @ "//routineN)
    3624             : #endif
    3625             : 
    3626           0 :       CALL mp_timestop(handle)
    3627             : 
    3628           0 :    END SUBROUTINE mp_type_free_m
    3629             : 
    3630             : ! **************************************************************************************************
    3631             : !> \brief ...
    3632             : !> \param type_descriptors ...
    3633             : ! **************************************************************************************************
    3634           0 :    SUBROUTINE mp_type_free_v(type_descriptors)
    3635             :       TYPE(mp_type_descriptor_type), DIMENSION(:), &
    3636             :          INTENT(inout)                                   :: type_descriptors
    3637             : 
    3638             :       INTEGER                                            :: i
    3639             : 
    3640           0 :       DO i = 1, SIZE(type_descriptors)
    3641           0 :          CALL mp_type_free(type_descriptors(i))
    3642             :       ENDDO
    3643             : 
    3644           0 :    END SUBROUTINE mp_type_free_v
    3645             : 
    3646             : ! **************************************************************************************************
    3647             : !> \brief Creates an indexed MPI type for arrays of strings using bytes for spacing (hindexed type)
    3648             : !> \param count   number of array blocks to read
    3649             : !> \param lengths lengths of each array block
    3650             : !> \param displs  byte offsets for array blocks
    3651             : !> \return container holding the created type
    3652             : !> \author Nico Holmberg [05.2017]
    3653             : ! **************************************************************************************************
    3654        1740 :    FUNCTION mp_file_type_hindexed_make_chv(count, lengths, displs) &
    3655             :       RESULT(type_descriptor)
    3656             :       INTEGER, INTENT(IN)                       :: count
    3657             :       INTEGER, DIMENSION(1:count), &
    3658             :          INTENT(IN), TARGET                     :: lengths
    3659             :       INTEGER(kind=file_offset), &
    3660             :          DIMENSION(1:count), INTENT(in), TARGET :: displs
    3661             :       TYPE(mp_file_descriptor_type)             :: type_descriptor
    3662             : 
    3663             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_hindexed_make_chv'
    3664             : 
    3665             :       INTEGER :: ierr, handle
    3666             : 
    3667        1740 :       ierr = 0
    3668        1740 :       CALL mp_timeset(routineN, handle)
    3669        1740 :       type_descriptor%type_handle = 0
    3670             : 
    3671             : #if defined(__parallel)
    3672             :       CALL MPI_Type_create_hindexed(count, lengths, INT(displs, KIND=address_kind), MPI_CHARACTER, &
    3673      513380 :                                     type_descriptor%type_handle, ierr)
    3674        1740 :       IF (ierr /= 0) &
    3675           0 :          CPABORT("MPI_Type_create_hindexed @ "//routineN)
    3676        1740 :       CALL MPI_Type_commit(type_descriptor%type_handle, ierr)
    3677        1740 :       IF (ierr /= 0) &
    3678           0 :          CPABORT("MPI_Type_commit @ "//routineN)
    3679             : #else
    3680             :       type_descriptor%type_handle = 68
    3681             : #endif
    3682        1740 :       type_descriptor%length = count
    3683        1740 :       type_descriptor%has_indexing = .TRUE.
    3684        1740 :       type_descriptor%index_descriptor%index => lengths
    3685        1740 :       type_descriptor%index_descriptor%chunks => displs
    3686             : 
    3687        1740 :       CALL mp_timestop(handle)
    3688             : 
    3689        1740 :    END FUNCTION mp_file_type_hindexed_make_chv
    3690             : 
    3691             : ! **************************************************************************************************
    3692             : !> \brief Uses a previously created indexed MPI character type to tell the MPI processes
    3693             : !>        how to partition (set_view) an opened file
    3694             : !> \param fh      the file handle associated with the input file
    3695             : !> \param offset  global offset determining where the relevant data begins
    3696             : !> \param type_descriptor container for the MPI type
    3697             : !> \author Nico Holmberg [05.2017]
    3698             : ! **************************************************************************************************
    3699        1740 :    SUBROUTINE mp_file_type_set_view_chv(fh, offset, type_descriptor)
    3700             :       INTEGER, INTENT(IN)                      :: fh
    3701             :       INTEGER(kind=file_offset), INTENT(IN)    :: offset
    3702             :       TYPE(mp_file_descriptor_type)            :: type_descriptor
    3703             : 
    3704             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_set_view_chv'
    3705             : 
    3706             :       INTEGER                                   :: ierr, handle
    3707             : 
    3708        1740 :       ierr = 0
    3709        1740 :       CALL mp_timeset(routineN, handle)
    3710             : 
    3711             : #if defined(__parallel)
    3712        1740 :       CALL mpi_file_set_errhandler(fh, MPI_ERRORS_RETURN, ierr)
    3713             :       CALL MPI_File_set_view(fh, offset, MPI_CHARACTER, &
    3714        1740 :                              type_descriptor%type_handle, "native", MPI_INFO_NULL, ierr)
    3715        1740 :       IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_set_view")
    3716             : #else
    3717             :       ! Uses absolute offsets stored in mp_file_descriptor_type
    3718             :       MARK_USED(fh)
    3719             :       MARK_USED(offset)
    3720             :       MARK_USED(type_descriptor)
    3721             : #endif
    3722             : 
    3723        1740 :       CALL mp_timestop(handle)
    3724             : 
    3725        1740 :    END SUBROUTINE mp_file_type_set_view_chv
    3726             : 
    3727             : ! **************************************************************************************************
    3728             : !> \brief (parallel) Collective, blocking read of a character array from a file. File access pattern
    3729             : !                    determined by a previously set file view.
    3730             : !>        (serial)   Unformatted stream read using explicit offsets
    3731             : !> \param fh     the file handle associated with the input file
    3732             : !> \param msglen the message length of an individual vector component
    3733             : !> \param ndims  the number of vector components
    3734             : !> \param buffer the buffer where the data is placed
    3735             : !> \param type_descriptor container for the MPI type
    3736             : !> \author Nico Holmberg [05.2017]
    3737             : ! **************************************************************************************************
    3738          38 :    SUBROUTINE mp_file_read_all_chv(fh, msglen, ndims, buffer, type_descriptor)
    3739             :       INTEGER, INTENT(IN)                       :: fh
    3740             :       INTEGER, INTENT(IN)                       :: msglen
    3741             :       INTEGER, INTENT(IN)                       :: ndims
    3742             :       CHARACTER(LEN=msglen), DIMENSION(ndims)   :: buffer
    3743             :       TYPE(mp_file_descriptor_type), &
    3744             :          INTENT(IN), OPTIONAL                   :: type_descriptor
    3745             : 
    3746             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_read_all_chv'
    3747             : 
    3748             :       INTEGER                                   :: ierr, handle, i
    3749             : 
    3750          38 :       i = 0
    3751          38 :       ierr = 0
    3752          38 :       CALL mp_timeset(routineN, handle)
    3753             : 
    3754             : #if defined(__parallel)
    3755             :       MARK_USED(type_descriptor)
    3756          38 :       CALL MPI_File_read_all(fh, buffer, ndims*msglen, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
    3757          38 :       IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_read_all")
    3758          38 :       CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
    3759             : #else
    3760             :       MARK_USED(msglen)
    3761             :       MARK_USED(ndims)
    3762             :       IF (.NOT. PRESENT(type_descriptor)) &
    3763             :          CALL cp_abort(__LOCATION__, &
    3764             :                        "Container for mp_file_descriptor_type must be present in serial call.")
    3765             :       IF (.NOT. type_descriptor%has_indexing) &
    3766             :          CALL cp_abort(__LOCATION__, &
    3767             :                        "File view has not been set in mp_file_descriptor_type.")
    3768             :       ! Use explicit offsets
    3769             :       DO i = 1, ndims
    3770             :          READ (fh, POS=type_descriptor%index_descriptor%chunks(i)) buffer(i)
    3771             :       END DO
    3772             : #endif
    3773             : 
    3774          38 :       CALL mp_timestop(handle)
    3775             : 
    3776          38 :    END SUBROUTINE mp_file_read_all_chv
    3777             : 
    3778             : ! **************************************************************************************************
    3779             : !> \brief (parallel) Collective, blocking write of a character array to a file. File access pattern
    3780             : !                    determined by a previously set file view.
    3781             : !>        (serial)   Unformatted stream write using explicit offsets
    3782             : !> \param fh     the file handle associated with the output file
    3783             : !> \param msglen the message length of an individual vector component
    3784             : !> \param ndims  the number of vector components
    3785             : !> \param buffer the buffer where the data is placed
    3786             : !> \param type_descriptor container for the MPI type
    3787             : !> \author Nico Holmberg [05.2017]
    3788             : ! **************************************************************************************************
    3789        1702 :    SUBROUTINE mp_file_write_all_chv(fh, msglen, ndims, buffer, type_descriptor)
    3790             :       INTEGER, INTENT(IN)                       :: fh
    3791             :       INTEGER, INTENT(IN)                       :: msglen
    3792             :       INTEGER, INTENT(IN)                       :: ndims
    3793             :       CHARACTER(LEN=msglen), DIMENSION(ndims)   :: buffer
    3794             :       TYPE(mp_file_descriptor_type), &
    3795             :          INTENT(IN), OPTIONAL                   :: type_descriptor
    3796             : 
    3797             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_write_all_chv'
    3798             : 
    3799             :       INTEGER                                   :: ierr, handle, i
    3800             : 
    3801        1702 :       i = 0
    3802        1702 :       ierr = 0
    3803        1702 :       CALL mp_timeset(routineN, handle)
    3804             : 
    3805             : #if defined(__parallel)
    3806             :       MARK_USED(type_descriptor)
    3807        1702 :       CALL mpi_file_set_errhandler(fh, MPI_ERRORS_RETURN, ierr)
    3808        1702 :       CALL MPI_File_write_all(fh, buffer, ndims*msglen, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
    3809        1702 :       IF (ierr .NE. 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_write_all")
    3810        1702 :       CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
    3811             : #else
    3812             :       MARK_USED(msglen)
    3813             :       MARK_USED(ndims)
    3814             :       IF (.NOT. PRESENT(type_descriptor)) &
    3815             :          CALL cp_abort(__LOCATION__, &
    3816             :                        "Container for mp_file_descriptor_type must be present in serial call.")
    3817             :       IF (.NOT. type_descriptor%has_indexing) &
    3818             :          CALL cp_abort(__LOCATION__, &
    3819             :                        "File view has not been set in mp_file_descriptor_type.")
    3820             :       ! Use explicit offsets
    3821             :       DO i = 1, ndims
    3822             :          WRITE (fh, POS=type_descriptor%index_descriptor%chunks(i)) buffer(i)
    3823             :       END DO
    3824             : #endif
    3825             : 
    3826        1702 :       CALL mp_timestop(handle)
    3827             : 
    3828        1702 :    END SUBROUTINE mp_file_write_all_chv
    3829             : 
    3830             : ! **************************************************************************************************
    3831             : !> \brief Releases the type used for MPI I/O
    3832             : !> \param type_descriptor the container for the MPI type
    3833             : !> \author Nico Holmberg [05.2017]
    3834             : ! **************************************************************************************************
    3835        1740 :    SUBROUTINE mp_file_type_free(type_descriptor)
    3836             :       TYPE(mp_file_descriptor_type)             :: type_descriptor
    3837             : 
    3838             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_type_free'
    3839             : 
    3840             :       INTEGER                                   :: ierr, handle
    3841             : 
    3842        1740 :       ierr = 0
    3843        1740 :       CALL mp_timeset(routineN, handle)
    3844             : 
    3845             : #if defined(__parallel)
    3846        1740 :       CALL MPI_Type_free(type_descriptor%type_handle, ierr)
    3847        1740 :       IF (ierr /= 0) &
    3848           0 :          CPABORT("MPI_Type_free @ "//routineN)
    3849             : #endif
    3850        1740 :       type_descriptor%length = -1
    3851        1740 :       type_descriptor%type_handle = -1
    3852        1740 :       IF (type_descriptor%has_indexing) THEN
    3853        1740 :          NULLIFY (type_descriptor%index_descriptor%index)
    3854        1740 :          NULLIFY (type_descriptor%index_descriptor%chunks)
    3855        1740 :          type_descriptor%has_indexing = .FALSE.
    3856             :       END IF
    3857             : 
    3858        1740 :       CALL mp_timestop(handle)
    3859             : 
    3860        1740 :    END SUBROUTINE mp_file_type_free
    3861             : 
    3862             : ! **************************************************************************************************
    3863             : !> \brief (parallel) Utility routine to determine MPI file access mode based on variables
    3864             : !                    that in the serial case would get passed to the intrinsic OPEN
    3865             : !>        (serial)   No action
    3866             : !> \param mpi_io     flag that determines if MPI I/O will actually be used
    3867             : !> \param replace    flag that indicates whether file needs to be deleted prior to opening it
    3868             : !> \param amode      the MPI I/O access mode
    3869             : !> \param form       formatted or unformatted data?
    3870             : !> \param action     the variable that determines what to do with file
    3871             : !> \param status     the status flag:
    3872             : !> \param position   should the file be appended or rewound
    3873             : !> \author Nico Holmberg [11.2017]
    3874             : ! **************************************************************************************************
    3875        1702 :    SUBROUTINE mp_file_get_amode(mpi_io, replace, amode, form, action, status, position)
    3876             :       LOGICAL, INTENT(INOUT)                             :: mpi_io, replace
    3877             :       INTEGER, INTENT(OUT)                               :: amode
    3878             :       CHARACTER(len=*), INTENT(IN)                       :: form, action, status, position
    3879             : 
    3880        1702 :       amode = -1
    3881             : #if defined(__parallel)
    3882             :       ! Disable mpi io for unformatted access
    3883           0 :       SELECT CASE (form)
    3884             :       CASE ("FORMATTED")
    3885             :          ! Do nothing
    3886             :       CASE ("UNFORMATTED")
    3887           0 :          mpi_io = .FALSE.
    3888             :       CASE DEFAULT
    3889        1702 :          CPABORT("Unknown MPI file form requested.")
    3890             :       END SELECT
    3891             :       ! Determine file access mode (limited set of allowed choices)
    3892        1702 :       SELECT CASE (action)
    3893             :       CASE ("WRITE")
    3894        1702 :          amode = file_amode_wronly
    3895           0 :          SELECT CASE (status)
    3896             :          CASE ("NEW")
    3897             :             ! Try to open new file for writing, crash if file already exists
    3898           0 :             amode = amode + file_amode_create + file_amode_excl
    3899             :          CASE ("UNKNOWN")
    3900             :             ! Open file for writing and create it if file does not exist
    3901        1382 :             amode = amode + file_amode_create
    3902          56 :             SELECT CASE (position)
    3903             :             CASE ("APPEND")
    3904             :                ! Append existing file
    3905          56 :                amode = amode + file_amode_append
    3906             :             CASE ("REWIND", "ASIS")
    3907             :                ! Do nothing
    3908             :             CASE DEFAULT
    3909        1382 :                CPABORT("Unknown MPI file position requested.")
    3910             :             END SELECT
    3911             :          CASE ("OLD")
    3912         320 :             SELECT CASE (position)
    3913             :             CASE ("APPEND")
    3914             :                ! Append existing file
    3915           0 :                amode = amode + file_amode_append
    3916             :             CASE ("REWIND", "ASIS")
    3917             :                ! Do nothing
    3918             :             CASE DEFAULT
    3919           0 :                CPABORT("Unknown MPI file position requested.")
    3920             :             END SELECT
    3921             :          CASE ("REPLACE")
    3922             :             ! Overwrite existing file. Must delete existing file first
    3923         320 :             amode = amode + file_amode_create
    3924         320 :             replace = .TRUE.
    3925             :          CASE ("SCRATCH")
    3926             :             ! Disable
    3927           0 :             mpi_io = .FALSE.
    3928             :          CASE DEFAULT
    3929        1702 :             CPABORT("Unknown MPI file status requested.")
    3930             :          END SELECT
    3931             :       CASE ("READ")
    3932           0 :          amode = file_amode_rdonly
    3933           0 :          SELECT CASE (status)
    3934             :          CASE ("NEW")
    3935           0 :             CPABORT("Cannot read from 'NEW' file.")
    3936             :          CASE ("REPLACE")
    3937           0 :             CPABORT("Illegal status 'REPLACE' for read.")
    3938             :          CASE ("UNKNOWN", "OLD")
    3939             :             ! Do nothing
    3940             :          CASE ("SCRATCH")
    3941             :             ! Disable
    3942           0 :             mpi_io = .FALSE.
    3943             :          CASE DEFAULT
    3944           0 :             CPABORT("Unknown MPI file status requested.")
    3945             :          END SELECT
    3946             :       CASE ("READWRITE")
    3947           0 :          amode = file_amode_rdwr
    3948           0 :          SELECT CASE (status)
    3949             :          CASE ("NEW")
    3950             :             ! Try to open new file, crash if file already exists
    3951           0 :             amode = amode + file_amode_create + file_amode_excl
    3952             :          CASE ("UNKNOWN")
    3953             :             ! Open file and create it if file does not exist
    3954           0 :             amode = amode + file_amode_create
    3955           0 :             SELECT CASE (position)
    3956             :             CASE ("APPEND")
    3957             :                ! Append existing file
    3958           0 :                amode = amode + file_amode_append
    3959             :             CASE ("REWIND", "ASIS")
    3960             :                ! Do nothing
    3961             :             CASE DEFAULT
    3962           0 :                CPABORT("Unknown MPI file position requested.")
    3963             :             END SELECT
    3964             :          CASE ("OLD")
    3965           0 :             SELECT CASE (position)
    3966             :             CASE ("APPEND")
    3967             :                ! Append existing file
    3968           0 :                amode = amode + file_amode_append
    3969             :             CASE ("REWIND", "ASIS")
    3970             :                ! Do nothing
    3971             :             CASE DEFAULT
    3972           0 :                CPABORT("Unknown MPI file position requested.")
    3973             :             END SELECT
    3974             :          CASE ("REPLACE")
    3975             :             ! Overwrite existing file. Must delete existing file first
    3976           0 :             amode = amode + file_amode_create
    3977           0 :             replace = .TRUE.
    3978             :          CASE ("SCRATCH")
    3979             :             ! Disable
    3980           0 :             mpi_io = .FALSE.
    3981             :          CASE DEFAULT
    3982           0 :             CPABORT("Unknown MPI file status requested.")
    3983             :          END SELECT
    3984             :       CASE DEFAULT
    3985        1702 :          CPABORT("Unknown MPI file action requested.")
    3986             :       END SELECT
    3987             : #else
    3988             :       MARK_USED(replace)
    3989             :       MARK_USED(form)
    3990             :       MARK_USED(position)
    3991             :       MARK_USED(status)
    3992             :       MARK_USED(action)
    3993             :       mpi_io = .FALSE.
    3994             : #endif
    3995             : 
    3996        1702 :    END SUBROUTINE mp_file_get_amode
    3997             : 
    3998             : ! **************************************************************************************************
    3999             : !> \brief Non-blocking send of custom type
    4000             : !> \param msgin ...
    4001             : !> \param dest ...
    4002             : !> \param comm ...
    4003             : !> \param request ...
    4004             : !> \param tag ...
    4005             : ! **************************************************************************************************
    4006           0 :    SUBROUTINE mp_isend_custom(msgin, dest, comm, request, tag)
    4007             :       TYPE(mp_type_descriptor_type), INTENT(IN)          :: msgin
    4008             :       INTEGER, INTENT(IN)                                :: dest, comm
    4009             :       INTEGER, INTENT(out)                               :: request
    4010             :       INTEGER, INTENT(in), OPTIONAL                      :: tag
    4011             : 
    4012             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_custom'
    4013             : 
    4014             :       INTEGER                                            :: ierr, my_tag
    4015             : 
    4016           0 :       ierr = 0
    4017           0 :       my_tag = 0
    4018             : 
    4019             : #if defined(__parallel)
    4020           0 :       IF (PRESENT(tag)) my_tag = tag
    4021             : 
    4022             :       CALL mpi_isend(MPI_BOTTOM, 1, msgin%type_handle, dest, my_tag, &
    4023           0 :                      comm, request, ierr)
    4024           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
    4025             : #else
    4026             :       MARK_USED(msgin)
    4027             :       MARK_USED(dest)
    4028             :       MARK_USED(comm)
    4029             :       MARK_USED(request)
    4030             :       MARK_USED(tag)
    4031             :       ierr = 1
    4032             :       request = 0
    4033             :       CALL mp_stop(ierr, "mp_isend called in non parallel case")
    4034             : #endif
    4035           0 :    END SUBROUTINE mp_isend_custom
    4036             : 
    4037             : ! **************************************************************************************************
    4038             : !> \brief Non-blocking receive of vector data
    4039             : !> \param msgout ...
    4040             : !> \param source ...
    4041             : !> \param comm ...
    4042             : !> \param request ...
    4043             : !> \param tag ...
    4044             : ! **************************************************************************************************
    4045           0 :    SUBROUTINE mp_irecv_custom(msgout, source, comm, request, tag)
    4046             :       TYPE(mp_type_descriptor_type), INTENT(INOUT)       :: msgout
    4047             :       INTEGER, INTENT(IN)                                :: source, comm
    4048             :       INTEGER, INTENT(out)                               :: request
    4049             :       INTEGER, INTENT(in), OPTIONAL                      :: tag
    4050             : 
    4051             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_custom'
    4052             : 
    4053             :       INTEGER                                            :: ierr, my_tag
    4054             : 
    4055           0 :       ierr = 0
    4056           0 :       my_tag = 0
    4057             : 
    4058             : #if defined(__parallel)
    4059           0 :       IF (PRESENT(tag)) my_tag = tag
    4060             : 
    4061             :       CALL mpi_irecv(MPI_BOTTOM, 1, msgout%type_handle, source, my_tag, &
    4062           0 :                      comm, request, ierr)
    4063           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ "//routineN)
    4064             : #else
    4065             :       MARK_USED(msgout)
    4066             :       MARK_USED(source)
    4067             :       MARK_USED(comm)
    4068             :       MARK_USED(request)
    4069             :       MARK_USED(tag)
    4070             :       ierr = 1
    4071             :       request = 0
    4072             :       CPABORT("mp_irecv called in non parallel case")
    4073             : #endif
    4074           0 :    END SUBROUTINE mp_irecv_custom
    4075             : 
    4076             : ! **************************************************************************************************
    4077             : !> \brief Window free
    4078             : !> \param win ...
    4079             : ! **************************************************************************************************
    4080           0 :    SUBROUTINE mp_win_free(win)
    4081             :       INTEGER, INTENT(INOUT)                             :: win
    4082             : 
    4083             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_free'
    4084             : 
    4085             :       INTEGER                                            :: handle, ierr
    4086             : 
    4087           0 :       ierr = 0
    4088           0 :       CALL mp_timeset(routineN, handle)
    4089             : 
    4090             : #if defined(__parallel)
    4091             : 
    4092           0 :       CALL mpi_win_free(win, ierr)
    4093           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_free @ "//routineN)
    4094             : 
    4095           0 :       CALL add_perf(perf_id=21, count=1)
    4096             : #else
    4097             :       MARK_USED(win)
    4098             :       win = mp_win_null
    4099             : #endif
    4100           0 :       CALL mp_timestop(handle)
    4101           0 :    END SUBROUTINE mp_win_free
    4102             : 
    4103             : ! **************************************************************************************************
    4104             : !> \brief Window flush
    4105             : !> \param win ...
    4106             : ! **************************************************************************************************
    4107           0 :    SUBROUTINE mp_win_flush_all(win)
    4108             :       INTEGER, INTENT(IN)                                :: win
    4109             : 
    4110             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_flush_all'
    4111             : 
    4112             :       INTEGER                                            :: handle, ierr
    4113             : 
    4114           0 :       ierr = 0
    4115           0 :       CALL mp_timeset(routineN, handle)
    4116             : 
    4117             : #if defined(__parallel)
    4118             : #if __MPI_VERSION > 2
    4119           0 :       CALL mpi_win_flush_all(win, ierr)
    4120           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_flush_all @ "//routineN)
    4121             : #else
    4122             :       MARK_USED(win)
    4123             :       CPABORT("mp_win_flush_all requires MPI-3 standard")
    4124             : #endif
    4125             : #else
    4126             :       MARK_USED(win)
    4127             : #endif
    4128           0 :       CALL mp_timestop(handle)
    4129           0 :    END SUBROUTINE mp_win_flush_all
    4130             : 
    4131             : ! **************************************************************************************************
    4132             : !> \brief Window lock
    4133             : !> \param win ...
    4134             : ! **************************************************************************************************
    4135           0 :    SUBROUTINE mp_win_lock_all(win)
    4136             :       INTEGER, INTENT(INOUT)                             :: win
    4137             : 
    4138             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_lock_all'
    4139             : 
    4140             :       INTEGER                                            :: handle, ierr
    4141             : 
    4142           0 :       ierr = 0
    4143           0 :       CALL mp_timeset(routineN, handle)
    4144             : 
    4145             : #if defined(__parallel)
    4146             : 
    4147             : #if __MPI_VERSION > 2
    4148           0 :       CALL mpi_win_lock_all(MPI_MODE_NOCHECK, win, ierr)
    4149             : #else
    4150             :       MARK_USED(win)
    4151             :       CPABORT("mp_win_lock_all requires MPI-3 standard")
    4152             : #endif
    4153           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_lock_all @ "//routineN)
    4154             : 
    4155           0 :       CALL add_perf(perf_id=19, count=1)
    4156             : #else
    4157             :       MARK_USED(win)
    4158             : #endif
    4159           0 :       CALL mp_timestop(handle)
    4160           0 :    END SUBROUTINE mp_win_lock_all
    4161             : 
    4162             : ! **************************************************************************************************
    4163             : !> \brief Window lock
    4164             : !> \param win ...
    4165             : ! **************************************************************************************************
    4166           0 :    SUBROUTINE mp_win_unlock_all(win)
    4167             :       INTEGER, INTENT(INOUT)                             :: win
    4168             : 
    4169             :       CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_unlock_all'
    4170             : 
    4171             :       INTEGER                                            :: handle, ierr
    4172             : 
    4173           0 :       ierr = 0
    4174           0 :       CALL mp_timeset(routineN, handle)
    4175             : 
    4176             : #if defined(__parallel)
    4177             : 
    4178             : #if __MPI_VERSION > 2
    4179           0 :       CALL mpi_win_unlock_all(win, ierr)
    4180             : #else
    4181             :       MARK_USED(win)
    4182             :       CPABORT("mp_win_unlock_all requires MPI-3 standard")
    4183             : #endif
    4184           0 :       IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_unlock_all @ "//routineN)
    4185             : 
    4186           0 :       CALL add_perf(perf_id=19, count=1)
    4187             : #else
    4188             :       MARK_USED(win)
    4189             : #endif
    4190           0 :       CALL mp_timestop(handle)
    4191           0 :    END SUBROUTINE mp_win_unlock_all
    4192             : 
    4193             : #:include 'message_passing.f90'
    4194             : 
    4195             : ! **************************************************************************************************
    4196             : !> \brief Tests the MPI library
    4197             : !> \param comm the relevant, initialized communicator
    4198             : !> \param npow number of sizes to test, 10**1 .. 10**npow
    4199             : !> \param output_unit where to direct output
    4200             : !> \par History
    4201             : !>      JGH  6-Feb-2001 : Test and performance code
    4202             : !> \author JGH  1-JAN-2001
    4203             : !> \note
    4204             : !>      quickly adapted benchmark code, will only work on an even number of CPUs.
    4205             : ! **************************************************************************************************
    4206           2 :    SUBROUTINE mpi_perf_test(comm, npow, output_unit)
    4207             : 
    4208             :       INTEGER, INTENT(IN)                      :: comm, npow, output_unit
    4209             : 
    4210             : #if defined(__parallel)
    4211             : 
    4212             :       INTEGER :: I, ierr, ierror, itask, itests, J, jtask, left, nbufmax, &
    4213             :                  ncount, Ngrid, Nloc, nprocs, Ntot, partner, right, taskid
    4214           2 :       INTEGER, ALLOCATABLE, DIMENSION(:)       :: rcount, rdispl, scount, sdispl
    4215             :       LOGICAL                                  :: ionode
    4216             :       REAL(KIND=dp)                            :: maxdiff, res, res2, res3, t1, &
    4217             :                                                   t2, t3, t4, t5
    4218           2 :       REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: buffer1, buffer2, buffer3, &
    4219           2 :                                                   lgrid, lgrid2, lgrid3
    4220             :       REAL(KIND=dp), ALLOCATABLE, &
    4221           2 :          DIMENSION(:, :)                        :: grid, grid2, grid3, &
    4222           2 :                                                    send_timings, send_timings2
    4223             :       REAL(KIND=dp), PARAMETER :: threshold = 1.0E-8_dp
    4224             : 
    4225             :       ! set system sizes !
    4226           2 :       ngrid = 10**npow
    4227             : 
    4228           2 :       CALL mpi_comm_rank(comm, taskid, ierror)
    4229           2 :       CALL mpi_comm_size(comm, Nprocs, ierror)
    4230           2 :       ionode = (taskid == 0)
    4231           2 :       IF (ionode .AND. output_unit > 0) THEN
    4232           1 :          WRITE (output_unit, *) "Running with ", nprocs
    4233           1 :          WRITE (output_unit, *) "running messages with npow = ", npow
    4234           1 :          WRITE (output_unit, *) "use MPI X in the input for larger (e.g. 6) of smaller (e.g. 3) messages"
    4235           1 :          IF (MODULO(nprocs, 2) .NE. 0) WRITE (output_unit, *) "Testing only with an even number of tasks"
    4236             :       ENDIF
    4237             : 
    4238           2 :       IF (MODULO(nprocs, 2) .NE. 0) RETURN
    4239             : 
    4240             :       ! equal loads
    4241           2 :       Nloc = Ngrid/nprocs
    4242           2 :       Ntot = Nprocs*Nloc
    4243           2 :       nbufmax = 10**npow
    4244             :       !
    4245           6 :       ALLOCATE (rcount(nprocs))
    4246           6 :       ALLOCATE (scount(nprocs))
    4247           6 :       ALLOCATE (sdispl(nprocs))
    4248           6 :       ALLOCATE (rdispl(nprocs))
    4249           6 :       ALLOCATE (buffer1(nbufmax))
    4250           6 :       ALLOCATE (buffer2(nbufmax))
    4251           6 :       ALLOCATE (buffer3(nbufmax))
    4252           8 :       ALLOCATE (grid(Nloc, Nprocs))
    4253           8 :       ALLOCATE (grid2(Nloc, Nprocs))
    4254           8 :       ALLOCATE (grid3(Nloc, Nprocs))
    4255           6 :       ALLOCATE (lgrid(Nloc))
    4256           6 :       ALLOCATE (lgrid2(Nloc))
    4257           6 :       ALLOCATE (lgrid3(Nloc))
    4258           8 :       ALLOCATE (send_timings(0:nprocs - 1, 0:nprocs - 1))
    4259           8 :       ALLOCATE (send_timings2(0:nprocs - 1, 0:nprocs - 1))
    4260       20002 :       buffer1 = 0.0_dp
    4261       20002 :       buffer2 = 0.0_dp
    4262       20002 :       buffer3 = 0.0_dp
    4263             :       ! timings
    4264          14 :       send_timings = 0.0_dp
    4265          14 :       send_timings2 = 0.0_dp
    4266             :       ! -------------------------------------------------------------------------------------------
    4267             :       ! ------------------------------ some in memory tests                   ---------------------
    4268             :       ! -------------------------------------------------------------------------------------------
    4269           2 :       CALL MPI_BARRIER(comm, ierror)
    4270           2 :       IF (ionode .AND. output_unit > 0) THEN
    4271           1 :          WRITE (output_unit, *) "Testing in memory copies just 1 CPU "
    4272           1 :          WRITE (output_unit, *) "  could tell something about the motherboard / cache / compiler "
    4273             :       END IF
    4274          10 :       DO i = 1, npow
    4275           8 :          ncount = 10**i
    4276           8 :          t2 = 0.0E0_dp
    4277           8 :          IF (ncount .GT. nbufmax) CPABORT("")
    4278          88 :          DO j = 1, 3**(npow - i)
    4279          80 :             CALL MPI_BARRIER(comm, ierror)
    4280          80 :             t1 = MPI_WTIME()
    4281       28420 :             buffer2(1:ncount) = buffer1(1:ncount)
    4282          88 :             t2 = t2 + MPI_WTIME() - t1 + threshold
    4283             :          ENDDO
    4284           8 :          CALL MPI_REDUCE(t2, t1, 1, MPI_DOUBLE_PRECISION, MPI_MAX, 0, comm, ierror)
    4285          10 :          IF (ionode .AND. output_unit > 0) THEN
    4286           4 :             WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0E-6_dp/t1, " MB/s"
    4287             :          ENDIF
    4288             :       ENDDO
    4289           2 :       CALL MPI_BARRIER(comm, ierror)
    4290             :       ! -------------------------------------------------------------------------------------------
    4291             :       ! ------------------------------ some in memory tests                   ---------------------
    4292             :       ! -------------------------------------------------------------------------------------------
    4293           2 :       CALL MPI_BARRIER(comm, ierror)
    4294           2 :       IF (ionode .AND. output_unit > 0) THEN
    4295           1 :          WRITE (output_unit, *) "Testing in memory copies all cpus"
    4296           1 :          WRITE (output_unit, *) "  is the memory bandwidth affected on an SMP machine ?"
    4297             :       ENDIF
    4298          10 :       DO i = 1, npow
    4299           8 :          ncount = 10**i
    4300           8 :          t2 = 0.0E0_dp
    4301           8 :          IF (ncount .GT. nbufmax) CPABORT("")
    4302          88 :          DO j = 1, 3**(npow - i)
    4303          80 :             CALL MPI_BARRIER(comm, ierror)
    4304          80 :             t1 = MPI_WTIME()
    4305       28420 :             buffer2(1:ncount) = buffer1(1:ncount)
    4306          88 :             t2 = t2 + MPI_WTIME() - t1 + threshold
    4307             :          ENDDO
    4308           8 :          CALL MPI_REDUCE(t2, t1, 1, MPI_DOUBLE_PRECISION, MPI_MAX, 0, comm, ierror)
    4309          10 :          IF (ionode .AND. output_unit > 0) THEN
    4310           4 :             WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0E-6_dp/t1, " MB/s"
    4311             :          ENDIF
    4312             :       ENDDO
    4313           2 :       CALL MPI_BARRIER(comm, ierror)
    4314             :       ! -------------------------------------------------------------------------------------------
    4315             :       ! ------------------------------ first test point to point communication ---------------------
    4316             :       ! -------------------------------------------------------------------------------------------
    4317           2 :       CALL MPI_BARRIER(comm, ierror)
    4318           2 :       IF (ionode .AND. output_unit > 0) THEN
    4319           1 :          WRITE (output_unit, *) "Testing truly point to point communication (i with j only)"
    4320           1 :          WRITE (output_unit, *) "  is there some different connection between i j (e.g. shared memory comm)"
    4321             :       ENDIF
    4322           2 :       ncount = 10**npow
    4323           2 :       IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "For messages of ", ncount*8, " bytes"
    4324             :       IF (ncount .GT. nbufmax) CPABORT("")
    4325           6 :       DO itask = 0, nprocs - 1
    4326           8 :          DO jtask = itask + 1, nprocs - 1
    4327           2 :             CALL MPI_BARRIER(comm, ierror)
    4328           2 :             t1 = MPI_WTIME()
    4329           2 :             IF (taskid .EQ. itask) THEN
    4330           1 :                CALL MPI_SEND(buffer1, ncount, MPI_DOUBLE_PRECISION, jtask, itask*jtask, comm, ierror)
    4331             :             ENDIF
    4332           2 :             IF (taskid .EQ. jtask) THEN
    4333           1 :                CALL MPI_RECV(buffer1, ncount, MPI_DOUBLE_PRECISION, itask, itask*jtask, comm, MPI_STATUS_IGNORE, ierror)
    4334             :             ENDIF
    4335           6 :             send_timings(itask, jtask) = MPI_WTIME() - t1 + threshold
    4336             :          ENDDO
    4337             :       ENDDO
    4338          14 :       send_timings2(:, :) = send_timings
    4339           2 :       CALL MPI_REDUCE(send_timings2, send_timings, nprocs**2, MPI_DOUBLE_PRECISION, MPI_MAX, 0, comm, ierror)
    4340           2 :       IF (ionode .AND. output_unit > 0) THEN
    4341           3 :          DO itask = 0, nprocs - 1
    4342           4 :             DO jtask = itask + 1, nprocs - 1
    4343           3 :                WRITE (output_unit, '(I4,I4,F12.4,A)') itask, jtask, ncount*8.0E-6_dp/send_timings(itask, jtask), " MB/s"
    4344             :             ENDDO
    4345             :          ENDDO
    4346             :       ENDIF
    4347           2 :       CALL MPI_BARRIER(comm, ierror)
    4348             :       ! -------------------------------------------------------------------------------------------
    4349             :       ! ------------------------------ second test point to point communication -------------------
    4350             :       ! -------------------------------------------------------------------------------------------
    4351           2 :       CALL MPI_BARRIER(comm, ierror)
    4352           2 :       IF (ionode .AND. output_unit > 0) THEN
    4353           1 :          WRITE (output_unit, *) "Testing all nearby point to point communication (0,1)(2,3)..."
    4354           1 :          WRITE (output_unit, *) "    these could / should all be on the same shared memory node "
    4355             :       ENDIF
    4356          10 :       DO i = 1, npow
    4357           8 :          ncount = 10**i
    4358           8 :          t2 = 0.0E0_dp
    4359           8 :          IF (ncount .GT. nbufmax) CPABORT("")
    4360          88 :          DO j = 1, 3**(npow - i)
    4361          80 :             CALL MPI_BARRIER(comm, ierror)
    4362          80 :             t1 = MPI_WTIME()
    4363          80 :             IF (MODULO(taskid, 2) == 0) THEN
    4364          40 :                CALL MPI_SEND(buffer1, ncount, MPI_DOUBLE_PRECISION, taskid + 1, 0, comm, ierror)
    4365             :             ELSE
    4366          40 :                CALL MPI_RECV(buffer1, ncount, MPI_DOUBLE_PRECISION, taskid - 1, 0, comm, MPI_STATUS_IGNORE, ierror)
    4367             :             ENDIF
    4368          88 :             t2 = t2 + MPI_WTIME() - t1 + threshold
    4369             :          ENDDO
    4370           8 :          CALL MPI_REDUCE(t2, t1, 1, MPI_DOUBLE_PRECISION, MPI_MAX, 0, comm, ierror)
    4371          10 :          IF (ionode .AND. output_unit > 0) THEN
    4372           4 :             WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0E-6_dp/t1, " MB/s"
    4373             :          ENDIF
    4374             :       ENDDO
    4375           2 :       CALL MPI_BARRIER(comm, ierror)
    4376             :       ! -------------------------------------------------------------------------------------------
    4377             :       ! ------------------------------ third test point to point communication -------------------
    4378             :       ! -------------------------------------------------------------------------------------------
    4379           2 :       CALL MPI_BARRIER(comm, ierror)
    4380           2 :       IF (ionode .AND. output_unit > 0) THEN
    4381           1 :          WRITE (output_unit, *) "Testing all far point to point communication (0,nprocs/2),(1,nprocs/2+1),.."
    4382           1 :          WRITE (output_unit, *) "    these could all be going over the network, and stress it a lot"
    4383             :       ENDIF
    4384          10 :       DO i = 1, npow
    4385           8 :          ncount = 10**i
    4386           8 :          t2 = 0.0E0_dp
    4387           8 :          IF (ncount .GT. nbufmax) CPABORT("")
    4388          88 :          DO j = 1, 3**(npow - i)
    4389          80 :             CALL MPI_BARRIER(comm, ierror)
    4390          80 :             t1 = MPI_WTIME()
    4391             :             ! first half with partner
    4392          80 :             IF (taskid .LT. nprocs/2) THEN
    4393          40 :                CALL MPI_SEND(buffer1, ncount, MPI_DOUBLE_PRECISION, taskid + nprocs/2, 0, comm, ierror)
    4394             :             ELSE
    4395          40 :                CALL MPI_RECV(buffer1, ncount, MPI_DOUBLE_PRECISION, taskid - nprocs/2, 0, comm, MPI_STATUS_IGNORE, ierror)
    4396             :             ENDIF
    4397          88 :             t2 = t2 + MPI_WTIME() - t1 + threshold
    4398             :          ENDDO
    4399           8 :          CALL MPI_REDUCE(t2, t1, 1, MPI_DOUBLE_PRECISION, MPI_MAX, 0, comm, ierror)
    4400          10 :          IF (ionode .AND. output_unit > 0) THEN
    4401           4 :             WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0E-6_dp/t1, " MB/s"
    4402             :          ENDIF
    4403             :       ENDDO
    4404             :       ! -------------------------------------------------------------------------------------------
    4405             :       ! ------------------------------ test root to all broadcast               -------------------
    4406             :       ! -------------------------------------------------------------------------------------------
    4407           2 :       CALL MPI_BARRIER(comm, ierror)
    4408           2 :       IF (ionode .AND. output_unit > 0) THEN
    4409           1 :          WRITE (output_unit, *) "Testing root to all broadcast "
    4410           1 :          WRITE (output_unit, *) "    using trees at least ? "
    4411             :       ENDIF
    4412          10 :       DO i = 1, npow
    4413           8 :          ncount = 10**i
    4414           8 :          t2 = 0.0E0_dp
    4415           8 :          IF (ncount .GT. nbufmax) CPABORT("")
    4416          88 :          DO j = 1, 3**(npow - i)
    4417          80 :             CALL MPI_BARRIER(comm, ierror)
    4418          80 :             t1 = MPI_WTIME()
    4419          80 :             CALL MPI_BCAST(buffer1, ncount, MPI_DOUBLE_PRECISION, 0, comm, ierror)
    4420          88 :             t2 = t2 + MPI_WTIME() - t1 + threshold
    4421             :          ENDDO
    4422           8 :          CALL MPI_REDUCE(t2, t1, 1, MPI_DOUBLE_PRECISION, MPI_MAX, 0, comm, ierror)
    4423          10 :          IF (ionode .AND. output_unit > 0) THEN
    4424           4 :             WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0E-6_dp/t1, " MB/s"
    4425             :          ENDIF
    4426             :       ENDDO
    4427             :       ! -------------------------------------------------------------------------------------------
    4428             :       ! ------------------------------ test mp_sum like behavior                -------------------
    4429             :       ! -------------------------------------------------------------------------------------------
    4430           2 :       CALL MPI_BARRIER(comm, ierror)
    4431           2 :       IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "Test global summation (mp_sum / mpi_allreduce) "
    4432          10 :       DO i = 1, npow
    4433           8 :          ncount = 10**i
    4434           8 :          t2 = 0.0E0_dp
    4435           8 :          IF (ncount .GT. nbufmax) CPABORT("")
    4436          88 :          DO j = 1, 3**(npow - i)
    4437          80 :             CALL MPI_BARRIER(comm, ierror)
    4438          80 :             t1 = MPI_WTIME()
    4439          80 :             CALL MPI_ALLREDUCE(buffer1, buffer2, ncount, MPI_DOUBLE_PRECISION, MPI_SUM, comm, ierr)
    4440          88 :             t2 = t2 + MPI_WTIME() - t1 + threshold
    4441             :          ENDDO
    4442           8 :          CALL MPI_REDUCE(t2, t1, 1, MPI_DOUBLE_PRECISION, MPI_MAX, 0, comm, ierror)
    4443          10 :          IF (ionode .AND. output_unit > 0) THEN
    4444           4 :             WRITE (output_unit, '(I9,A,F12.4,A)') 8*ncount, " Bytes ", (3**(npow - i))*ncount*8.0E-6_dp/t1, " MB/s"
    4445             :          ENDIF
    4446             :       ENDDO
    4447             :       ! -------------------------------------------------------------------------------------------
    4448             :       ! ------------------------------ test all to all communication            -------------------
    4449             :       ! -------------------------------------------------------------------------------------------
    4450           2 :       CALL MPI_BARRIER(comm, ierror)
    4451           2 :       IF (ionode .AND. output_unit > 0) THEN
    4452           1 :          WRITE (output_unit, *) "Test all to all communication (mpi_alltoallv)"
    4453           1 :          WRITE (output_unit, *) "    mpi/network getting confused ? "
    4454             :       ENDIF
    4455          10 :       DO i = 1, npow
    4456           8 :          ncount = 10**i
    4457           8 :          t2 = 0.0E0_dp
    4458           8 :          IF (ncount .GT. nbufmax) CPABORT("")
    4459          24 :          scount = ncount/nprocs
    4460          24 :          rcount = ncount/nprocs
    4461          24 :          DO j = 1, nprocs
    4462          16 :             sdispl(j) = (j - 1)*(ncount/nprocs)
    4463          24 :             rdispl(j) = (j - 1)*(ncount/nprocs)
    4464             :          ENDDO
    4465          88 :          DO j = 1, 3**(npow - i)
    4466          80 :             CALL MPI_BARRIER(comm, ierror)
    4467          80 :             t1 = MPI_WTIME()
    4468             :             CALL mpi_alltoallv(buffer1, scount, sdispl, MPI_DOUBLE_PRECISION, &
    4469          80 :                                buffer2, rcount, rdispl, MPI_DOUBLE_PRECISION, comm, ierr)
    4470          88 :             t2 = t2 + MPI_WTIME() - t1 + threshold
    4471             :          ENDDO
    4472           8 :          CALL MPI_REDUCE(t2, t1, 1, MPI_DOUBLE_PRECISION, MPI_MAX, 0, comm, ierror)
    4473          10 :          IF (ionode .AND. output_unit > 0) THEN
    4474           4 :             WRITE (output_unit, '(I9,A,F12.4,A)') 8*(ncount/nprocs)*nprocs, " Bytes ", &
    4475           8 :                (3**(npow - i))*(ncount/nprocs)*nprocs*8.0E-6_dp/t1, " MB/s"
    4476             :          ENDIF
    4477             :       ENDDO
    4478             : 
    4479             :       ! -------------------------------------------------------------------------------------------
    4480             :       ! ------------------------------ other stuff                            ---------------------
    4481             :       ! -------------------------------------------------------------------------------------------
    4482           2 :       IF (ionode .AND. output_unit > 0) THEN
    4483           1 :          WRITE (output_unit, *) " Clean tests completed "
    4484           1 :          WRITE (output_unit, *) " Testing MPI_REDUCE scatter"
    4485             :       ENDIF
    4486           6 :       rcount = Nloc
    4487           8 :       DO itests = 1, 3
    4488           6 :          IF (ionode .AND. output_unit > 0) &
    4489           3 :             WRITE (output_unit, *) "------------------------------- test ", itests, " ------------------------"
    4490             :          ! *** reference ***
    4491          18 :          DO j = 1, Nprocs
    4492       60018 :             DO i = 1, Nloc
    4493       60012 :                grid(i, j) = MODULO(i*j*taskid, itests)
    4494             :             ENDDO
    4495             :          ENDDO
    4496           6 :          t1 = MPI_WTIME()
    4497           6 :          CALL MPI_REDUCE_SCATTER(grid, lgrid, rcount, MPI_DOUBLE_PRECISION, MPI_SUM, comm, ierr)
    4498           6 :          t2 = MPI_WTIME() - t1 + threshold
    4499           6 :          CALL mpi_allreduce(t2, res, 1, MPI_DOUBLE_PRECISION, MPI_MAX, comm, ierr)
    4500           6 :          IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "MPI_REDUCE_SCATTER    ", res
    4501             :          ! *** simple shift ***
    4502          18 :          DO j = 1, Nprocs
    4503       60018 :             DO i = 1, Nloc
    4504       60012 :                grid2(i, j) = MODULO(i*j*taskid, itests)
    4505             :             ENDDO
    4506             :          ENDDO
    4507           6 :          left = MODULO(taskid - 1, Nprocs)
    4508           6 :          right = MODULO(taskid + 1, Nprocs)
    4509           6 :          t3 = MPI_WTIME()
    4510       30006 :          lgrid2 = 0.0E0_dp
    4511          12 :          DO i = 1, Nprocs
    4512       60012 :             lgrid2(:) = lgrid2 + grid(:, MODULO(taskid - i, Nprocs) + 1)
    4513          12 :             IF (i .EQ. nprocs) EXIT
    4514          12 :             CALL MPI_SENDRECV_REPLACE(lgrid2, nloc, MPI_DOUBLE_PRECISION, right, 0, left, 0, comm, MPI_STATUS_IGNORE, ierr)
    4515             :          ENDDO
    4516           6 :          t4 = MPI_WTIME() - t3 + threshold
    4517           6 :          CALL mpi_allreduce(t4, res, 1, MPI_DOUBLE_PRECISION, MPI_MAX, comm, ierr)
    4518       30012 :          maxdiff = MAXVAL(ABS(lgrid2 - lgrid))
    4519           6 :          CALL mpi_allreduce(maxdiff, res2, 1, MPI_DOUBLE_PRECISION, MPI_MAX, comm, ierr)
    4520           6 :          IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "MPI_SENDRECV_REPLACE  ", res, res2
    4521             :          ! *** involved shift ****
    4522             :          IF (MODULO(nprocs, 2) /= 0) CPABORT("")
    4523          18 :          DO j = 1, Nprocs
    4524       60018 :             DO i = 1, Nloc
    4525       60012 :                grid3(i, j) = MODULO(i*j*taskid, itests)
    4526             :             ENDDO
    4527             :          ENDDO
    4528           6 :          t3 = MPI_WTIME()
    4529             :          ! first sum the grid in pairs (0,1),(2,3) should be within an LPAR and fast XXXXXXXXX
    4530             :          ! 0 will only need parts 0,2,4,... correctly summed
    4531             :          ! 1 will only need parts 1,3,5,... correctly summed
    4532             :          ! *** could nicely be generalised ****
    4533           6 :          IF (MODULO(taskid, 2) == 0) THEN
    4534           3 :             partner = taskid + 1
    4535           6 :             DO i = 1, Nprocs, 2 ! sum the full grid with the partner
    4536             :                CALL MPI_SENDRECV(grid3(1, i + 1), nloc, MPI_DOUBLE_PRECISION, partner, 17, &
    4537           3 :                                  lgrid3, nloc, MPI_DOUBLE_PRECISION, partner, 19, comm, MPI_STATUS_IGNORE, ierr)
    4538       15006 :                grid3(:, i) = grid3(:, i) + lgrid3(:)
    4539             :             ENDDO
    4540             :          ELSE
    4541           3 :             partner = taskid - 1
    4542           6 :             DO i = 1, Nprocs, 2
    4543             :                CALL MPI_SENDRECV(grid3(1, i), nloc, MPI_DOUBLE_PRECISION, partner, 19, &
    4544           3 :                                  lgrid3, nloc, MPI_DOUBLE_PRECISION, partner, 17, comm, MPI_STATUS_IGNORE, ierr)
    4545       15006 :                grid3(:, i + 1) = grid3(:, i + 1) + lgrid3(:)
    4546             :             ENDDO
    4547             :          ENDIF
    4548           6 :          t4 = MPI_WTIME() - t3 + threshold
    4549             :          ! now send a given buffer from 1 to 3 to 5 .. adding the right part of the data
    4550             :          ! since we've summed an lgrid does only need to pass by even or odd tasks
    4551           6 :          left = MODULO(taskid - 2, Nprocs)
    4552           6 :          right = MODULO(taskid + 2, Nprocs)
    4553           6 :          t3 = MPI_WTIME()
    4554       30006 :          lgrid3 = 0.0E0_dp
    4555           6 :          DO i = 1, Nprocs, 2
    4556       30006 :             lgrid3(:) = lgrid3 + grid3(:, MODULO(taskid - i - 1, Nprocs) + 1)
    4557           6 :             IF (i .EQ. nprocs - 1) EXIT
    4558           6 :             CALL MPI_SENDRECV_REPLACE(lgrid3, nloc, MPI_DOUBLE_PRECISION, right, 0, left, 0, comm, MPI_STATUS_IGNORE, ierr)
    4559             :          ENDDO
    4560           6 :          t5 = MPI_WTIME() - t3 + threshold
    4561           6 :          CALL mpi_allreduce(t4, res, 1, MPI_DOUBLE_PRECISION, MPI_MAX, comm, ierr)
    4562           6 :          CALL mpi_allreduce(t5, res2, 1, MPI_DOUBLE_PRECISION, MPI_MAX, comm, ierr)
    4563       30012 :          maxdiff = MAXVAL(ABS(lgrid3 - lgrid))
    4564           6 :          CALL mpi_allreduce(maxdiff, res3, 1, MPI_DOUBLE_PRECISION, MPI_MAX, comm, ierr)
    4565           8 :        IF (ionode .AND. output_unit > 0) WRITE (output_unit, *) "INVOLVED SHIFT        ", res + res2, "(", res, ",", res2, ")", res3
    4566             :       ENDDO
    4567           2 :       DEALLOCATE (rcount)
    4568           2 :       DEALLOCATE (scount)
    4569           2 :       DEALLOCATE (sdispl)
    4570           2 :       DEALLOCATE (rdispl)
    4571           2 :       DEALLOCATE (buffer1)
    4572           2 :       DEALLOCATE (buffer2)
    4573           2 :       DEALLOCATE (buffer3)
    4574           2 :       DEALLOCATE (grid)
    4575           2 :       DEALLOCATE (grid2)
    4576           2 :       DEALLOCATE (grid3)
    4577           2 :       DEALLOCATE (lgrid)
    4578           2 :       DEALLOCATE (lgrid2)
    4579           2 :       DEALLOCATE (lgrid3)
    4580           2 :       DEALLOCATE (send_timings)
    4581           2 :       DEALLOCATE (send_timings2)
    4582             : #else
    4583             :       MARK_USED(comm)
    4584             :       MARK_USED(npow)
    4585             :       IF (output_unit > 0) WRITE (output_unit, *) "No MPI tests for a serial program"
    4586             : #endif
    4587             :    END SUBROUTINE mpi_perf_test
    4588             : 
    4589             : ! **************************************************************************************************
    4590             : !> \brief Starts a timer region
    4591             : !> \param routineN ...
    4592             : !> \param handle ...
    4593             : ! **************************************************************************************************
    4594    65400702 :    SUBROUTINE mp_timeset(routineN, handle)
    4595             :       CHARACTER(len=*), INTENT(IN)                       :: routineN
    4596             :       INTEGER, INTENT(OUT)                               :: handle
    4597             : 
    4598    65400702 :       IF (mp_collect_timings) &
    4599    65304876 :          CALL timeset(routineN, handle)
    4600    65400702 :    END SUBROUTINE mp_timeset
    4601             : 
    4602             : ! **************************************************************************************************
    4603             : !> \brief Ends a timer region
    4604             : !> \param handle ...
    4605             : ! **************************************************************************************************
    4606    65400702 :    SUBROUTINE mp_timestop(handle)
    4607             :       INTEGER, INTENT(IN)                                :: handle
    4608             : 
    4609    65400702 :       IF (mp_collect_timings) &
    4610    65304876 :          CALL timestop(handle)
    4611    65400702 :    END SUBROUTINE mp_timestop
    4612             : 
    4613           0 : END MODULE message_passing

Generated by: LCOV version 1.15