LCOV - code coverage report
Current view: top level - src/mpiwrap - message_passing.F (source / functions) Hit Total Coverage
Test: CP2K Regtests (git:58e3e09) Lines: 663 1084 61.2 %
Date: 2024-03-29 07:50:05 Functions: 67 141 47.5 %

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

Generated by: LCOV version 1.15