LCOV - code coverage report
Current view: top level - src/mpiwrap - message_passing.F (source / functions) Hit Total Coverage
Test: CP2K Regtests (git:37c9bd6) Lines: 663 1088 60.9 %
Date: 2023-03-30 11:55:16 Functions: 66 137 48.2 %

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

Generated by: LCOV version 1.15