Branch data Line data Source code
1 : : !!****m* ABINIT/m_xmpi
2 : : !! NAME
3 : : !! m_xmpi
4 : : !!
5 : : !! FUNCTION
6 : : !! This module provides MPI named constants, tools for inquiring the MPI environment
7 : : !! and a set of generic interfaces wrapping the most commonly used MPI primitives.
8 : : !!
9 : : !! COPYRIGHT
10 : : !! Copyright (C) 2009-2026 ABINIT group (MG, MB, XG, YP, MT)
11 : : !! This file is distributed under the terms of the
12 : : !! GNU General Public License, see ~abinit/COPYING
13 : : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : : !!
15 : : !! TODO
16 : : !! Get rid of xmpi_paral. Sequential code is the **exception**. Developers should code parallel
17 : : !! code or code that is compatible both with MPI and seq (thanks to the wrappers provided by this module)
18 : : !!
19 : : !! SOURCE
20 : :
21 : : #if defined HAVE_CONFIG_H
22 : : #include "config.h"
23 : : #endif
24 : :
25 : : #include "abi_common.h"
26 : :
27 : : module m_xmpi
28 : :
29 : : use, intrinsic :: iso_c_binding
30 : : #ifdef HAVE_FC_ISO_FORTRAN_2008
31 : : use ISO_FORTRAN_ENV, only : int16, int32, int64
32 : : #endif
33 : : USE_MPI
34 : : use defs_basis
35 : : use m_profiling_abi
36 : : #ifdef FC_NAG
37 : : use f90_unix_proc
38 : : #endif
39 : : use m_clib
40 : :
41 : : implicit none
42 : :
43 : : private
44 : : !!***
45 : :
46 : : #ifdef HAVE_MPI1
47 : : include 'mpif.h'
48 : : #endif
49 : :
50 : : #ifndef HAVE_FC_ISO_FORTRAN_2008
51 : : integer,parameter :: int16=2,int32=4,int64=8
52 : : #endif
53 : :
54 : : #ifdef HAVE_MPI
55 : : ! MPI constants used in abinit. Make sure that a corresponding fake value is provided for the sequential version.
56 : : integer,public,parameter :: xmpi_paral = 1
57 : : integer,public,parameter :: xmpi_world = MPI_COMM_WORLD
58 : : integer,public,parameter :: xmpi_comm_self = MPI_COMM_SELF
59 : : integer,public,parameter :: xmpi_undefined = MPI_UNDEFINED
60 : : integer,public,parameter :: xmpi_undefined_rank = MPI_UNDEFINED ! MPI_UNDEFINED_RANK is not portable.
61 : : integer,public,parameter :: xmpi_comm_null = MPI_COMM_NULL
62 : : integer,public,parameter :: xmpi_group_null = MPI_GROUP_NULL
63 : : integer,public,parameter :: xmpi_any_source = MPI_ANY_SOURCE
64 : : integer,public,parameter :: xmpi_request_null = MPI_REQUEST_NULL
65 : : integer,public,parameter :: xmpi_msg_len = MPI_MAX_ERROR_STRING ! Length of fortran string used to store MPI error strings.
66 : : integer,public,parameter :: xmpi_info_null = MPI_INFO_NULL
67 : : integer,public,parameter :: xmpi_success = MPI_SUCCESS
68 : : integer,public,parameter :: xmpi_max_processor_name = MPI_MAX_PROCESSOR_NAME
69 : : integer,public,parameter :: XMPI_MODE_NOPRECEDE = MPI_MODE_NOPRECEDE
70 : : integer,public,parameter :: XMPI_MODE_NOSTORE = MPI_MODE_NOSTORE
71 : : integer,public,parameter :: XMPI_MODE_NOPUT = MPI_MODE_NOPUT
72 : : integer,public,parameter :: XMPI_MODE_NOSUCCEED = MPI_MODE_NOSUCCEED
73 : :
74 : : #else
75 : : ! Fake replacements for the sequential version. Values are taken from
76 : : ! http://www.mit.edu/course/13/13.715/sun-hpc-ct-8.2.1/Linux/sun/include/mpif-common.h
77 : : ! Please use these conventions when adding new replacements in order to avoid collisions between values.
78 : : integer,public,parameter :: xmpi_paral = 0
79 : : integer,public,parameter :: xmpi_world = 0
80 : : integer,public,parameter :: xmpi_comm_self = 1
81 : : integer,public,parameter :: xmpi_undefined =-32766
82 : : integer,public,parameter :: xmpi_undefined_rank =-32766
83 : : integer,public,parameter :: xmpi_comm_null = 2
84 : : integer,public,parameter :: xmpi_group_null = 0
85 : : integer,public,parameter :: xmpi_any_source = -1
86 : : integer,public,parameter :: xmpi_request_null = 0
87 : : integer,public,parameter :: xmpi_msg_len = 1000
88 : : integer,public,parameter :: xmpi_info_null = 0
89 : : integer,public,parameter :: xmpi_success = 0
90 : : integer,public,parameter :: xmpi_max_processor_name = 128
91 : : integer,public,parameter :: XMPI_MODE_NOPRECEDE = 1
92 : : integer,public,parameter :: XMPI_MODE_NOSTORE = 2
93 : : integer,public,parameter :: XMPI_MODE_NOPUT = 8
94 : : integer,public,parameter :: XMPI_MODE_NOSUCCEED = 32
95 : : #endif
96 : :
97 : : #ifdef HAVE_MPI
98 : : integer,save,private :: xmpi_tag_ub=32767
99 : : ! The tag upper bound value must be at least 32767. An MPI implementation is free to make
100 : : ! the value of MPI_TAG_UB larger than this hence xmpi_tag_ub is redefined when MPI is init in xmpi_init.
101 : : #endif
102 : :
103 : : ! Size in bytes of the entries used in MPI datatypes.
104 : : integer,save, public ABI_PROTECTED:: xmpi_bsize_ch = 0
105 : : integer,save, public ABI_PROTECTED:: xmpi_bsize_int = 0
106 : : integer,save, public ABI_PROTECTED:: xmpi_bsize_sp = 0
107 : : integer,save, public ABI_PROTECTED:: xmpi_bsize_dp = 0
108 : : integer,save, public ABI_PROTECTED:: xmpi_bsize_spc = 0
109 : : integer,save, public ABI_PROTECTED:: xmpi_bsize_dpc = 0
110 : :
111 : : ! kind of the offset used for MPI-IO.
112 : : #ifdef HAVE_MPI_IO
113 : : integer,public,parameter :: xmpi_offset_kind = MPI_OFFSET_KIND
114 : : integer,public,parameter :: xmpi_address_kind = MPI_ADDRESS_KIND
115 : : integer,public,parameter :: xmpi_mpiio = 1
116 : : #else
117 : : integer,public,parameter :: xmpi_offset_kind = i8b
118 : : integer,public,parameter :: xmpi_address_kind = i8b
119 : : integer,public,parameter :: xmpi_mpiio = 0
120 : : #endif
121 : :
122 : : ! The byte size and the MPI type of the Fortran record marker.
123 : : ! These quantities are compiler-dependent and are initalized here
124 : : ! for selected compilers or in xmpio_get_info_frm that is called by xmpi_init (only if MPI-IO is on).
125 : : #if defined HAVE_MPI && (defined FC_INTEL || defined FC_GNU || defined FC_IBM)
126 : : integer,save,public ABI_PROTECTED :: xmpio_bsize_frm = 4
127 : : integer,save,public ABI_PROTECTED :: xmpio_mpi_type_frm= MPI_INTEGER4
128 : : #else
129 : : integer,save,public ABI_PROTECTED :: xmpio_bsize_frm = 0
130 : : integer,save,public ABI_PROTECTED :: xmpio_mpi_type_frm = 0
131 : : #endif
132 : :
133 : : integer,save, public ABI_PROTECTED :: xmpio_info = xmpi_info_null
134 : : ! Global variable used to pass hints to the MPI-IO routines.
135 : :
136 : : integer(XMPI_OFFSET_KIND),public,parameter :: xmpio_chunk_bsize = 2000 * (1024.0_dp**2)
137 : : ! Defines the chunk size (in bytes) used to (read|write) data in a single MPI-IO call.
138 : : ! MPI-IO, indeed, crashes if we try to do the IO of a large array with a single call.
139 : : ! We use a value <= 2 Gb to avoid wraparound errors with standard integers.
140 : :
141 : : ! Options used for the MPI-IO wrappers used in abinit.
142 : : integer,public,parameter :: xmpio_single = 1 ! Individual IO.
143 : : integer,public,parameter :: xmpio_collective = 2 ! Collective IO.
144 : :
145 : : integer,save, public ABI_PROTECTED :: xmpi_count_requests = 0
146 : : ! Count number of requests (+1 for each call to non-blocking API, -1 for each call to xmpi_wait)
147 : : ! This counter should be zero at the end of the run if all requests have been released.
148 : :
149 : : integer,save, public ABI_PROTECTED :: xmpi_count_wins = 0
150 : : ! Count number of windows created
151 : : ! This counter should be zero at the end of the run if all windows have been released.
152 : :
153 : : logical,save, private :: xmpi_use_inplace_operations = .True.
154 : : ! Enable/disable usage of MPI_IN_PLACE in e.g. xmpi_sum
155 : :
156 : : ! For MPI < v4, collective communication routines accept only a 32bit integer as data count.
157 : : ! To exchange more than 2^32 data we need to create specific user-defined datatypes
158 : : ! For this, we need some parameters:
159 : : integer(KIND=int32),public,parameter :: xmpi_maxint32 = huge(0_int32)
160 : : integer(KIND=int64),public,parameter :: xmpi_maxint32_64 = int(xmpi_maxint32,kind=int64)
161 : : ! Max. integer that can be represented with 32 bits
162 : : integer(KIND=int64),public,save :: xmpi_largetype_size = 0
163 : : ! Number of data to be used in user-defined operations related to user-defined "largetype" type
164 : : !!***
165 : :
166 : : !----------------------------------------------------------------------
167 : :
168 : : !!****t* m_xmpi/xcomm_t
169 : : !! NAME
170 : : !! xcomm_t
171 : : !!
172 : : !! FUNCTION
173 : : !! A small object storing the MPI communicator, the rank of the process and the size of the communicator.
174 : : !! Provides helper functions to perform typical operations and parallelize loops.
175 : : !! The datatype is initialized with xmpi_comm_self.
176 : : !!
177 : : !! SOURCE
178 : :
179 : : type, public :: xcomm_t
180 : : integer :: value = xmpi_comm_self
181 : : integer :: nproc = 1
182 : : integer :: me = 0
183 : : integer,private :: can_use_shmem__ = -1
184 : : ! -1 --> unitialized, 0 if ranks do not belong to a shared memory region else 1
185 : :
186 : : contains
187 : : procedure :: skip => xcomm_skip ! Skip iteration according to rank
188 : : procedure :: set_to_null => xcomm_set_to_null ! Init object using xmpi_comm_null.
189 : : procedure :: set_to_self => xcomm_set_to_self ! Init object using xmpi_comm_self.
190 : : procedure :: free => xcomm_free ! Free the communicator.
191 : : procedure :: from_cart_sub => xcomm_from_cart_sub ! Build sub-communicators in a Cartesian grid.
192 : : procedure :: split_type => xcomm_split_type ! Creates new communicators based on split types and keys
193 : : procedure :: prep_gatherv => xcomm_prep_gatherv ! Prepare a typical gatherv operation.
194 : : procedure :: print_names => xcomm_print_names
195 : : procedure :: can_use_shmem => xcomm_can_use_shmem ! true if communicator can use shared memory.
196 : : procedure :: allocate_shared_master => xcomm_allocate_shared_master ! Allocate MPI shared memory
197 : : end type xcomm_t
198 : :
199 : : public :: xcomm_from_mpi_int
200 : : !!***
201 : :
202 : : !----------------------------------------------------------------------
203 : :
204 : : !!****t* m_xmpi/xmpi_pool2d_t
205 : : !! NAME
206 : : !! xmpi_pool2d_t
207 : : !!
208 : : !! FUNCTION
209 : : !! Pool of MPI processors operating on a 2D problem of shape (n1, n2).
210 : : !! Each item in the (n1, n2) matrix is assigned to a single pool.
211 : : !! Note that differerent pools do not necessarily have the same number of procs,
212 : : !! thus a pool is more flexibile than a Cartesian grid although inter-pool communication becomes more complex.
213 : : !!
214 : : !! SOURCE
215 : :
216 : : type, public :: xmpi_pool2d_t
217 : :
218 : : integer :: n1 = -1, n2 = -1
219 : : ! Dimensions of the 2d problem
220 : :
221 : : type(xcomm_t) :: comm
222 : : ! MPI communicator.
223 : :
224 : : logical,allocatable :: treats(:,:)
225 : : ! (n1, n2)
226 : : ! True if this pool treats (i1, i2)
227 : :
228 : : contains
229 : : procedure :: from_dims => pool2d_from_dims ! Init pool from problem dims.
230 : : procedure :: free => pool2d_free ! Free memory.
231 : : end type xmpi_pool2d_t
232 : : !!***
233 : :
234 : : ! Public procedures.
235 : : public :: xmpi_init ! Initialize the MPI environment.
236 : : public :: xmpi_set_inplace_operations! Set internal flag to use MPI_IN_PLACE whenever possible.
237 : : public :: xmpi_end ! Terminate the MPI environment.
238 : : public :: xmpi_abort ! Hides MPI_ABORT from MPI library.
239 : : public :: xmpi_show_info ! Printout of the basic variables stored in this module (useful for debugging).
240 : : public :: xmpi_group_free ! Hides MPI_GROUP_FREE from MPI library.
241 : : public :: xmpi_group_incl ! Hides MPI_GROUP_INCL from MPI library.
242 : : public :: xmpi_group_translate_ranks ! Hides MPI_GROUP_TRANSLATE_RANKS from MPI library.
243 : : public :: xmpi_comm_create ! Hides MPI_COMM_CREATE from MPI library.
244 : : public :: xmpi_comm_rank ! Hides MPI_COMM_RANK from MPI library.
245 : : public :: xmpi_comm_size ! Hides MPI_COMM_SIZE from MPI library.
246 : : public :: xmpi_comm_free ! Hides MPI_COMM_FREE from MPI library.
247 : : public :: xmpi_comm_dup ! Hides MPI_COMM_DUP from MPI library.
248 : : public :: xmpi_comm_group ! Hides MPI_COMM_GROUP from MPI library.
249 : : public :: xmpi_comm_translate_ranks ! Hides MPI_GROUP_TRANSLATE_RANKS from MPI library.
250 : : public :: xmpi_comm_translate_rank ! Translate one rank
251 : : public :: xmpi_comm_split ! Hides MPI_COMM_SPLIT from MPI library.
252 : : public :: xmpi_subcomm ! Creates a sub-communicator from an input communicator.
253 : : public :: xmpi_comm_multiple_of ! Creates sub-communicator with number of procs multiple of a certain number.
254 : : public :: xmpi_barrier ! Hides MPI_BARRIER from MPI library.
255 : : public :: xmpi_name ! Hides MPI_NAME from MPI library.
256 : : public :: xmpi_iprobe ! Hides MPI_IPROBE from MPI library.
257 : : public :: xmpi_wait ! Hides MPI_WAIT from MPI library.
258 : : public :: xmpi_waitall ! Hides MPI_WAITALL from MPI library.
259 : : public :: xmpi_request_free ! Hides MPI_REQUEST_FREE from MPI library.
260 : : public :: xmpi_requests_add ! Increase/decrement xmpi_count_requests internal counter
261 : : public :: xmpi_comm_set_errhandler ! Hides MPI_COMM_SET_ERRHANDLER from MPI library.
262 : : public :: xmpi_error_string ! Return a string describing the error from ierr.
263 : : public :: xmpi_split_work ! Splits tasks inside communicator using blocks
264 : : public :: xmpi_split_block ! Splits tasks inside communicator using block distribution.
265 : : public :: xmpi_split_cyclic ! Splits tasks inside communicator using cyclic distribution.
266 : : public :: xmpi_split_list ! Splits list of indices inside communicator using block distribution.
267 : : public :: xmpi_distab ! Fill table defining the distribution of the tasks according to the # of processors
268 : : public :: xmpi_distrib_with_replicas ! Distribute tasks among MPI ranks (replicas are allowed)
269 : : public :: xmpi_distrib_2d ! Try to optimally distribute nprocs in a 2d grid of shape (n1, n2)
270 : : public :: xmpi_split_nsppol ! Distribute spins. Also create and return indirect mapping to spin index.
271 : :
272 : : ! Private procedures.
273 : : private :: xmpi_largetype_create ! Build a large-count contiguous datatype (to handle a very large # of data)
274 : : private :: xmpi_largetype_free ! Release a large-count contiguous datatype
275 : :
276 : : interface xmpi_comm_free
277 : : module procedure xmpi_comm_free_0D
278 : : module procedure xmpi_comm_free_1D
279 : : module procedure xmpi_comm_free_2D
280 : : module procedure xmpi_comm_free_3D
281 : : end interface xmpi_comm_free
282 : :
283 : : interface xmpi_waitall
284 : : module procedure xmpi_waitall_1d
285 : : module procedure xmpi_waitall_2d
286 : : end interface xmpi_waitall
287 : :
288 : : interface xmpi_split_work
289 : : module procedure xmpi_split_work_i4b
290 : : end interface xmpi_split_work
291 : :
292 : : public :: xmpi_split_work2_i4b
293 : : public :: xmpi_split_work2_i8b
294 : : !public :: xmpi_split_work2
295 : : !
296 : : ! g95@green v0.93 is not able to resolve the interface.
297 : : ! For the time being, this generic interface has been disabled.
298 : : !interface xmpi_split_work2
299 : : ! module procedure xmpi_split_work2_i4b
300 : : ! module procedure xmpi_split_work2_i8b
301 : : !end interface xmpi_split_work2
302 : :
303 : : interface xmpi_distab
304 : : module procedure xmpi_distab_4D
305 : : end interface xmpi_distab
306 : :
307 : : ! MPI generic interfaces.
308 : : public :: xmpi_allgather
309 : : public :: xmpi_iallgather
310 : : public :: xmpi_allgatherv
311 : : public :: xmpi_alltoall
312 : : public :: xmpi_ialltoall
313 : : public :: xmpi_alltoallv
314 : : public :: xmpi_ialltoallv
315 : : public :: xmpi_bcast
316 : : public :: xmpi_ibcast
317 : : public :: xmpi_exch
318 : : public :: xmpi_gather
319 : : public :: xmpi_gatherv
320 : : public :: xmpi_max
321 : : public :: xmpi_max_ip
322 : : public :: xmpi_min ! Out-of-place version
323 : : public :: xmpi_min_ip ! In-place version
324 : : public :: xmpi_recv
325 : : public :: xmpi_irecv
326 : : public :: xmpi_scatterv
327 : : public :: xmpi_send
328 : : public :: xmpi_isend
329 : : public :: xmpi_sum_master
330 : : public :: xmpi_sum
331 : : public :: xmpi_isum
332 : : public :: xmpi_isum_ip
333 : : public :: xmpi_land ! allreduce with MPI_LAND
334 : : public :: xmpi_lor ! allreduce with MPI_LOR
335 : :
336 : : public :: xmpi_win_fence
337 : : public :: xmpi_win_free
338 : :
339 : : #ifdef HAVE_MPI_IO
340 : : public :: xmpio_max_address ! Returns .TRUE. if offset cannot be stored in integer(kind=XMPI_ADDRESS_KIND).
341 : : public :: xmpio_type_struct
342 : : public :: xmpio_get_info_frm
343 : : public :: xmpio_check_frmarkers
344 : : public :: xmpio_read_frm
345 : : public :: xmpio_read_int
346 : : public :: xmpio_read_dp
347 : : public :: xmpio_write_frm
348 : : public :: xmpio_write_frmarkers
349 : :
350 : : public :: xmpio_create_fstripes
351 : : public :: xmpio_create_fsubarray_2D
352 : : public :: xmpio_create_fsubarray_3D
353 : : public :: xmpio_create_fsubarray_4D
354 : : public :: xmpio_create_fherm_packed
355 : : public :: xmpio_create_coldistr_from_fpacked
356 : : public :: xmpio_create_coldistr_from_fp3blocks
357 : : #endif
358 : :
359 : : !----------------------------------------------------------------------
360 : :
361 : : interface xmpi_allgather
362 : : module procedure xmpi_allgather_int
363 : : module procedure xmpi_allgather_char
364 : : module procedure xmpi_allgather_int1d_1b
365 : : module procedure xmpi_allgather_int1d
366 : : module procedure xmpi_allgather_int2d
367 : : module procedure xmpi_allgather_dp1d
368 : : module procedure xmpi_allgather_dp2d
369 : : module procedure xmpi_allgather_dp3d
370 : : module procedure xmpi_allgather_dp4d
371 : : end interface xmpi_allgather
372 : :
373 : : !----------------------------------------------------------------------
374 : :
375 : : ! non-blocking version (requires MPI3)
376 : : ! Prototype:
377 : : !
378 : : ! call xmpi_iallgather(SENDBUF, SENDCOUNT, SENDTYPE, RECVBUF, RECVCOUNT, RECVTYPE, COMM, REQUEST, IERROR)
379 : : !
380 : : ! If the MPI library does not provide ialltoall, we call the blocking version and
381 : : ! we return xmpi_request_null (see xmpi_iallgather.finc)
382 : : ! Client code should always test/wait the request so that code semantics is preserved.
383 : :
384 : : interface xmpi_iallgather
385 : : module procedure xmpi_iallgather_dp4d
386 : : end interface xmpi_iallgather
387 : :
388 : : interface xmpi_allgatherv
389 : : module procedure xmpi_allgatherv_int2d
390 : : module procedure xmpi_allgatherv_int
391 : : module procedure xmpi_allgatherv_int1_dp1
392 : : module procedure xmpi_allgatherv_dp
393 : : module procedure xmpi_allgatherv_dp2d
394 : : module procedure xmpi_allgatherv_dp3d
395 : : module procedure xmpi_allgatherv_dp4d
396 : : module procedure xmpi_allgatherv_dp5d
397 : : module procedure xmpi_allgatherv_dp6d
398 : : module procedure xmpi_allgatherv_coeff2d
399 : : module procedure xmpi_allgatherv_coeff2d_indx
400 : : module procedure xmpi_allgatherv_dc
401 : : end interface xmpi_allgatherv
402 : :
403 : : !----------------------------------------------------------------------
404 : :
405 : : ! blocking
406 : : interface xmpi_alltoall
407 : : module procedure xmpi_alltoall_int
408 : : module procedure xmpi_alltoall_dp2d
409 : : module procedure xmpi_alltoall_dp4d
410 : : end interface xmpi_alltoall
411 : :
412 : : ! non-blocking version (requires MPI3)
413 : : ! Prototype:
414 : : !
415 : : ! call xmpi_ialltoall(xval, sendsize, recvbuf, recvsize, comm, request)
416 : : !
417 : : ! If the MPI library does not provide ialltoall, we call the blocking version and
418 : : ! we return xmpi_request_null (see xmpi_ialltoall.finc)
419 : : ! Client code should always test/wait the request so that code semantics is preserved.
420 : :
421 : : interface xmpi_ialltoall
422 : : module procedure xmpi_ialltoall_dp4d
423 : : end interface xmpi_ialltoall
424 : :
425 : : !----------------------------------------------------------------------
426 : :
427 : : interface xmpi_alltoallv
428 : : module procedure xmpi_alltoallv_dp2d
429 : : module procedure xmpi_alltoallv_int2d
430 : : module procedure xmpi_alltoallv_dp1d
431 : : module procedure xmpi_alltoallv_dp1d2
432 : : end interface xmpi_alltoallv
433 : :
434 : : !----------------------------------------------------------------------
435 : :
436 : : ! non-blocking version (requires MPI3)
437 : : ! Prototype:
438 : : !
439 : : ! call xmpi_ialltoallv(xval, sendcnts, sdispls, recvbuf, recvcnts, rdispls, comm, request)
440 : : !
441 : : ! If the MPI library does not provide ialltoallv, we call the blocking version and
442 : : ! we return xmpi_request_null (see xmpi_ialltoallv.finc)
443 : : ! Client code should always test/wait the request so that code semantics is preserved.
444 : :
445 : : interface xmpi_ialltoallv
446 : : module procedure xmpi_ialltoallv_dp2d
447 : : module procedure xmpi_ialltoallv_int2d
448 : : module procedure xmpi_ialltoallv_dp1d2
449 : : end interface xmpi_ialltoallv
450 : :
451 : : !----------------------------------------------------------------------
452 : :
453 : : interface xmpi_bcast
454 : : module procedure xmpi_bcast_intv
455 : : module procedure xmpi_bcast_int1d
456 : : module procedure xmpi_bcast_int2d
457 : : module procedure xmpi_bcast_int3d
458 : : module procedure xmpi_bcast_int4d
459 : : module procedure xmpi_bcast_dpv
460 : : module procedure xmpi_bcast_dp1d
461 : : module procedure xmpi_bcast_dp2d
462 : : module procedure xmpi_bcast_dp3d
463 : : module procedure xmpi_bcast_dp4d
464 : : module procedure xmpi_bcast_dp5d
465 : : module procedure xmpi_bcast_dp6d
466 : : module procedure xmpi_bcast_spv
467 : : module procedure xmpi_bcast_sp1d
468 : : module procedure xmpi_bcast_sp2d
469 : : module procedure xmpi_bcast_sp3d
470 : : module procedure xmpi_bcast_sp4d
471 : : module procedure xmpi_bcast_cplxv
472 : : module procedure xmpi_bcast_cplx1d
473 : : module procedure xmpi_bcast_cplx2d
474 : : module procedure xmpi_bcast_cplx3d
475 : : module procedure xmpi_bcast_cplx4d
476 : : module procedure xmpi_bcast_dcv
477 : : module procedure xmpi_bcast_dc1d
478 : : module procedure xmpi_bcast_dc2d
479 : : module procedure xmpi_bcast_dc3d
480 : : module procedure xmpi_bcast_dc4d
481 : : module procedure xmpi_bcast_ch0d
482 : : module procedure xmpi_bcast_ch1d
483 : : module procedure xmpi_bcast_log0d
484 : : module procedure xmpi_bcast_coeffi2_1d
485 : : module procedure xmpi_bcast_coeff2_1d
486 : : end interface xmpi_bcast
487 : :
488 : : !----------------------------------------------------------------------
489 : :
490 : : interface xmpi_ibcast
491 : : module procedure xmpi_ibcast_int1d
492 : : module procedure xmpi_ibcast_int4d
493 : : module procedure xmpi_ibcast_dp1d
494 : : module procedure xmpi_ibcast_dp2d
495 : : module procedure xmpi_ibcast_dp3d
496 : : module procedure xmpi_ibcast_dp4d
497 : : module procedure xmpi_ibcast_dpc2d
498 : : module procedure xmpi_ibcast_spc2d
499 : : end interface xmpi_ibcast
500 : :
501 : : !----------------------------------------------------------------------
502 : :
503 : : interface xmpi_exch
504 : : module procedure xmpi_exch_int1d
505 : : module procedure xmpi_exch_int2d
506 : : module procedure xmpi_exch_dp1d
507 : : module procedure xmpi_exch_dp2d
508 : : module procedure xmpi_exch_dp3d
509 : : module procedure xmpi_exch_dp4d
510 : : module procedure xmpi_exch_dp5d
511 : : module procedure xmpi_exch_spc1d
512 : : module procedure xmpi_exch_dpc1d
513 : : module procedure xmpi_exch_dpc2d
514 : : end interface xmpi_exch
515 : :
516 : : !----------------------------------------------------------------------
517 : :
518 : : interface xmpi_gather
519 : : module procedure xmpi_gather_int
520 : : module procedure xmpi_gather_int2d
521 : : module procedure xmpi_gather_dp
522 : : module procedure xmpi_gather_dp2d
523 : : module procedure xmpi_gather_dp3d
524 : : module procedure xmpi_gather_dp4d
525 : : end interface xmpi_gather
526 : :
527 : : !----------------------------------------------------------------------
528 : :
529 : : interface xmpi_gatherv
530 : : module procedure xmpi_gatherv_int
531 : : module procedure xmpi_gatherv_int1_dp1
532 : : module procedure xmpi_gatherv_int2d
533 : : module procedure xmpi_gatherv_dp
534 : : module procedure xmpi_gatherv_dp2d
535 : : module procedure xmpi_gatherv_dp3d
536 : : module procedure xmpi_gatherv_dp4d
537 : : module procedure xmpi_gatherv_dp5d
538 : : module procedure xmpi_gatherv_dp6d
539 : : module procedure xmpi_gatherv_dc
540 : : end interface xmpi_gatherv
541 : :
542 : : !----------------------------------------------------------------------
543 : :
544 : : interface xmpi_max
545 : : module procedure xmpi_max_int0d_i4b
546 : : module procedure xmpi_max_int0d_i8b
547 : : module procedure xmpi_max_int
548 : : module procedure xmpi_max_dpv
549 : : module procedure xmpi_max_dp0d_ip
550 : : module procedure xmpi_max_dp1d_ip
551 : : end interface xmpi_max
552 : :
553 : : interface xmpi_max_ip
554 : : module procedure xmpi_max_int0d_ip
555 : : module procedure xmpi_max_int1d_ip
556 : : module procedure xmpi_max_dp0d_ip
557 : : module procedure xmpi_max_dp1d_ip
558 : : end interface xmpi_max_ip
559 : :
560 : : !----------------------------------------------------------------------
561 : :
562 : : interface xmpi_min
563 : : module procedure xmpi_min_intv
564 : : module procedure xmpi_min_dpv
565 : : module procedure xmpi_min_dp
566 : : end interface xmpi_min
567 : :
568 : : ! In-place version of xmpi_min
569 : : interface xmpi_min_ip
570 : : module procedure xmpi_min_int1d
571 : : module procedure xmpi_min_dp
572 : : end interface xmpi_min_ip
573 : :
574 : : !----------------------------------------------------------------------
575 : :
576 : : !interface xmpi_min_max
577 : : ! module procedure xmpi_min_max_int0d_i4b
578 : : !end interface xmpi_min_max
579 : :
580 : : !----------------------------------------------------------------------
581 : :
582 : : interface xmpi_recv
583 : : module procedure xmpi_recv_char
584 : : module procedure xmpi_recv_intv
585 : : module procedure xmpi_recv_int1d
586 : : module procedure xmpi_recv_int2d
587 : : module procedure xmpi_recv_int3d
588 : : module procedure xmpi_recv_dp
589 : : module procedure xmpi_recv_dp1d
590 : : module procedure xmpi_recv_dp2d
591 : : module procedure xmpi_recv_dp3d
592 : : module procedure xmpi_recv_dp4d
593 : : end interface xmpi_recv
594 : :
595 : : !----------------------------------------------------------------------
596 : :
597 : : interface xmpi_irecv
598 : : module procedure xmpi_irecv_intv
599 : : module procedure xmpi_irecv_int1d
600 : : module procedure xmpi_irecv_dp1d
601 : : module procedure xmpi_irecv_dp2d
602 : : module procedure xmpi_irecv_dp3d
603 : : module procedure xmpi_irecv_dp3d_cpu_only
604 : : end interface xmpi_irecv
605 : :
606 : : !----------------------------------------------------------------------
607 : :
608 : : interface xmpi_scatterv
609 : : module procedure xmpi_scatterv_int
610 : : module procedure xmpi_scatterv_int2d
611 : : module procedure xmpi_scatterv_dp
612 : : module procedure xmpi_scatterv_dp2d
613 : : module procedure xmpi_scatterv_dp3d
614 : : module procedure xmpi_scatterv_dp4d
615 : : end interface xmpi_scatterv
616 : :
617 : : !----------------------------------------------------------------------
618 : :
619 : : interface xmpi_isend
620 : : module procedure xmpi_isend_int1d
621 : : module procedure xmpi_isend_dp1d
622 : : module procedure xmpi_isend_dp2d
623 : : module procedure xmpi_isend_dp3d
624 : : module procedure xmpi_isend_dp3d_cpu_only
625 : : end interface xmpi_isend
626 : :
627 : : !----------------------------------------------------------------------
628 : :
629 : : interface xmpi_send
630 : : module procedure xmpi_send_char
631 : : module procedure xmpi_send_intv
632 : : module procedure xmpi_send_int1d
633 : : module procedure xmpi_send_int2d
634 : : module procedure xmpi_send_int3d
635 : : module procedure xmpi_send_dp
636 : : module procedure xmpi_send_dp1d
637 : : module procedure xmpi_send_dp2d
638 : : module procedure xmpi_send_dp3d
639 : : module procedure xmpi_send_dp4d
640 : : end interface xmpi_send
641 : :
642 : : !----------------------------------------------------------------------
643 : :
644 : : interface xmpi_sum_master
645 : : module procedure xmpi_sum_master_int
646 : : module procedure xmpi_sum_master_int2d
647 : : module procedure xmpi_sum_master_int4d
648 : : module procedure xmpi_sum_master_dp
649 : : module procedure xmpi_sum_master_dp1d
650 : : module procedure xmpi_sum_master_dp2d
651 : : module procedure xmpi_sum_master_dp3d
652 : : module procedure xmpi_sum_master_dp4d
653 : : module procedure xmpi_sum_master_dp5d
654 : : module procedure xmpi_sum_master_dp6d
655 : : module procedure xmpi_sum_master_dp7d
656 : : module procedure xmpi_sum_master_c1cplx
657 : : module procedure xmpi_sum_master_c2cplx
658 : : module procedure xmpi_sum_master_c3cplx
659 : : module procedure xmpi_sum_master_c4cplx
660 : : module procedure xmpi_sum_master_c5cplx
661 : : module procedure xmpi_sum_master_c1dpc
662 : : module procedure xmpi_sum_master_c2dpc
663 : : module procedure xmpi_sum_master_c3dpc
664 : : module procedure xmpi_sum_master_c4dpc
665 : : module procedure xmpi_sum_master_c5dpc
666 : : end interface xmpi_sum_master
667 : :
668 : : !----------------------------------------------------------------------
669 : :
670 : : !MG:TODO procedure marked with !? are considered obsolete.
671 : : ! and will be removed in future versions.
672 : : ! Please use interfaces where array dimensions are not passed explicitly.
673 : : ! Rationale: The array descriptor is already passed to the routine
674 : : ! so it does not make sense to pass the dimension explicitly.
675 : :
676 : : interface xmpi_sum
677 : : module procedure xmpi_sum_int
678 : : module procedure xmpi_sum_intv
679 : : module procedure xmpi_sum_intv2
680 : : module procedure xmpi_sum_intn !?
681 : : module procedure xmpi_sum_int2t !?
682 : : module procedure xmpi_sum_int2d
683 : : module procedure xmpi_sum_int3d
684 : : module procedure xmpi_sum_int4d
685 : : module procedure xmpi_sum_dp
686 : : module procedure xmpi_sum_dpvt
687 : : module procedure xmpi_sum_dpv
688 : : module procedure xmpi_sum_dpn !?
689 : : module procedure xmpi_sum_sp2d
690 : : module procedure xmpi_sum_sp3d
691 : : module procedure xmpi_sum_sp4d
692 : : module procedure xmpi_sum_sp5d
693 : : module procedure xmpi_sum_sp6d
694 : : module procedure xmpi_sum_sp7d
695 : : module procedure xmpi_sum_dp2d
696 : : module procedure xmpi_sum_dp3d
697 : : module procedure xmpi_sum_dp4d
698 : : module procedure xmpi_sum_dp5d
699 : : module procedure xmpi_sum_dp6d
700 : : module procedure xmpi_sum_dp7d
701 : : module procedure xmpi_sum_dp2t !?
702 : : module procedure xmpi_sum_dp2d2t
703 : : module procedure xmpi_sum_dp3d2t !?
704 : : module procedure xmpi_sum_dp4d2t !?
705 : : module procedure xmpi_sum_c0dc
706 : : module procedure xmpi_sum_c0sc
707 : : module procedure xmpi_sum_c1dc
708 : : module procedure xmpi_sum_c2dc
709 : : module procedure xmpi_sum_c3dc
710 : : module procedure xmpi_sum_c4dc
711 : : module procedure xmpi_sum_c5dc
712 : : module procedure xmpi_sum_c6dc
713 : : module procedure xmpi_sum_c7dc
714 : : module procedure xmpi_sum_c1cplx
715 : : module procedure xmpi_sum_c2cplx
716 : : module procedure xmpi_sum_c3cplx
717 : : module procedure xmpi_sum_c4cplx
718 : : module procedure xmpi_sum_c5cplx
719 : : module procedure xmpi_sum_c6cplx
720 : : module procedure xmpi_sum_coeff5d1
721 : : end interface xmpi_sum
722 : : !!***
723 : :
724 : : ! Non-blocking version
725 : : interface xmpi_isum
726 : : module procedure xmpi_isum_int0d
727 : : end interface xmpi_isum
728 : : !!***
729 : :
730 : : ! Non-blocking in-place version
731 : : interface xmpi_isum_ip
732 : : module procedure xmpi_isum_ip_dp2d
733 : : module procedure xmpi_isum_ip_dp3d
734 : : module procedure xmpi_isum_ip_dp4d
735 : : module procedure xmpi_isum_ip_spc1d
736 : : module procedure xmpi_isum_ip_dpc1d
737 : : module procedure xmpi_isum_ip_spc2d
738 : : module procedure xmpi_isum_ip_dpc2d
739 : : module procedure xmpi_isum_ip_spc3d
740 : : module procedure xmpi_isum_ip_dpc3d
741 : : end interface xmpi_isum_ip
742 : : !!***
743 : :
744 : : interface xmpi_land
745 : : module procedure xmpi_land_log0d
746 : : module procedure xmpi_land_log1d
747 : : end interface xmpi_land
748 : : !!***
749 : :
750 : : interface xmpi_lor
751 : : module procedure xmpi_lor_log1d
752 : : module procedure xmpi_lor_log2d
753 : : module procedure xmpi_lor_log3d
754 : : end interface xmpi_lor
755 : : !!!***
756 : :
757 : : !----------------------------------------------------------------------
758 : :
759 : : CONTAINS !===========================================================
760 : : !!***
761 : :
762 : : !!****f* m_xmpi/xmpi_init
763 : : !! NAME
764 : : !! xmpi_init
765 : : !!
766 : : !! FUNCTION
767 : : !! Hides MPI_INIT from MPI library. Perform the initialization of some basic variables
768 : : !! used by the MPI routines employed in abinit.
769 : : !!
770 : : !! SOURCE
771 : :
772 : 3592 : subroutine xmpi_init()
773 : :
774 : : !Local variables-------------------
775 : : integer :: mpierr, ierr, unt
776 : : integer(c_long) :: rlim_cur, rlim_max
777 : : logical :: exists
778 : : #ifdef HAVE_MPI
779 : : integer :: attribute_val
780 : : logical :: lflag
781 : : #ifdef HAVE_OPENMP
782 : : integer :: required,provided
783 : : #endif
784 : : #endif
785 : : ! *************************************************************************
786 : :
787 : : call set_num_threads_if_undef()
788 : :
789 : 1796 : mpierr=0
790 : : #ifdef HAVE_MPI
791 : :
792 : : #ifndef HAVE_OPENMP
793 : 1796 : call MPI_INIT(mpierr)
794 : : #else
795 : : required = MPI_THREAD_SINGLE
796 : : !required = MPI_THREAD_FUNNELED
797 : : !required = MPI_THREAD_SERIALIZED
798 : : !required = MPI_THREAD_MULTIPLE
799 : : call MPI_INIT_THREAD(required,provided,mpierr)
800 : : if (provided /= required) call xmpi_abort(msg="MPI_INIT_THREADS: provided /= required")
801 : : #endif
802 : :
803 : : !%comm_world = xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
804 : : !%call xmpi_comm_set_errhandler(comm_world, MPI_ERRORS_RETURN, err_handler_sav, mpierr)
805 : :
806 : : ! Deprecated in MPI2 but not all MPI2 implementations provide MPI_Comm_get_attr !
807 : 1796 : call MPI_ATTR_GET(xmpi_world, MPI_TAG_UB, attribute_val, lflag, mpierr)
808 : : !call MPI_Comm_get_attr(xmpi_world, MPI_TAG_UB, attribute_val, lflag, mpierr)
809 : :
810 [ + - ]: 1796 : if (lflag) xmpi_tag_ub = attribute_val
811 : :
812 : : ! Define type values.
813 : 1796 : call MPI_TYPE_SIZE(MPI_CHARACTER, xmpi_bsize_ch, mpierr)
814 : 1796 : call MPI_TYPE_SIZE(MPI_INTEGER, xmpi_bsize_int, mpierr)
815 : 1796 : call MPI_TYPE_SIZE(MPI_REAL, xmpi_bsize_sp, mpierr)
816 : 1796 : call MPI_TYPE_SIZE(MPI_DOUBLE_PRECISION, xmpi_bsize_dp, mpierr)
817 : 1796 : call MPI_TYPE_SIZE(MPI_COMPLEX, xmpi_bsize_spc, mpierr)
818 : 1796 : call MPI_TYPE_SIZE(MPI_DOUBLE_COMPLEX, xmpi_bsize_dpc, mpierr)
819 : :
820 : : ! Find the byte size of Fortran record marker used in MPI-IO routines.
821 [ - + ]: 1796 : if (xmpio_bsize_frm == 0) call xmpio_get_info_frm(xmpio_bsize_frm, xmpio_mpi_type_frm, xmpi_world)
822 : : #endif
823 : :
824 : : ! Try to increase stack size.
825 : 1796 : call clib_ulimit_stack(rlim_cur, rlim_max, ierr)
826 : :
827 [ + + ]: 1796 : if (xmpi_comm_rank(xmpi_world) == 0) then
828 : :
829 [ - + ]: 1491 : if (ierr /= 0) then
830 : 0 : write(std_out, "(a)")" WARNING: cannot increase stack size limit. "
831 : : end if
832 : : ! rlim_cur/rlim_max are in bytes; -1 means RLIM_INFINITY (unlimited). Printed
833 : : ! unconditionally, not just when ierr /= 0: clib_ulimit_stack's fallback to
834 : : ! "soft = current hard limit" (see rlimit.c) can succeed (ierr == 0) at a
835 : : ! hard limit far below what a large automatic/local array actually needs,
836 : : ! which then only ever surfaces later as an unexplained OOM-kill rather
837 : : ! than this warning.
838 : : !write(std_out, "(2(a,i0),a)") &
839 : : ! "- clib_ulimit_stack: rlim_cur= ", rlim_cur, " bytes, rlim_max= ", rlim_max, " bytes (-1 = RLIM_INFINITY)"
840 : :
841 : : ! Master Removes the ABI_MPIABORTFILE if present so that we start with a clean environment.
842 : 1491 : inquire(file=ABI_MPIABORTFILE, exist=exists)
843 [ - + ]: 1491 : if (exists) then
844 : : ! Get free unit (emulate F2008 newunit for portability reasons)
845 : 0 : unt = xmpi_get_unit()
846 [ # # ]: 0 : if (unt == -1) call xmpi_abort(msg="Cannot find free unit!!")
847 : 0 : open(unit=unt, file=trim(ABI_MPIABORTFILE), status="old", iostat=ierr)
848 [ # # ]: 0 : if (ierr == 0) close(unit=unt, status="delete", iostat=ierr)
849 [ # # ]: 0 : if (ierr /= 0) call xmpi_abort(msg="Cannot remove ABI_MPIABORTFILE")
850 : : end if
851 : :
852 : : ! If MPI interfaces are buggy, MPI_IN_PLACE is not allowed
853 : : #if defined HAVE_MPI2_INPLACE && defined HAVE_MPI_BUGGY_INTERFACES
854 : : write(std_out, "(a)")"ERROR: Cannot use MPI_IN_PLACE with this buggy MPI version!"
855 : : write(ab_out , "(a)")"ERROR: Cannot use MPI_IN_PLACE with this buggy MPI version!"
856 : : call xmpi_abort(msg="Stopping here!")
857 : : #endif
858 : :
859 : : end if
860 : :
861 : 1796 : end subroutine xmpi_init
862 : : !!***
863 : :
864 : : !----------------------------------------------------------------------
865 : :
866 : : !!****f* m_xmpi/set_num_threads_if_undef
867 : : !! NAME
868 : : !! set_num_threads_if_undef
869 : : !!
870 : : !! FUNCTION
871 : : !! sets OMP_NUM_THREADS to 1 is the env variable is undefined.
872 : : !!
873 : : !! SOURCE
874 : :
875 : : subroutine set_num_threads_if_undef()
876 : :
877 : : #ifdef HAVE_OPENMP
878 : : !Local variables-------------------
879 : : integer :: ierr
880 : : character(len=100) :: omp_num_threads
881 : : ! *************************************************************************
882 : :
883 : : ! Get the value of OMP_NUM_THREADS environment variable
884 : : call get_environment_variable('OMP_NUM_THREADS', omp_num_threads, status=ierr)
885 : :
886 : : ! If OMP_NUM_THREADS is not defined (ierr != 0), set it to 1
887 : : if (ierr /= 0) then
888 : : ierr = clib_setenv('OMP_NUM_THREADS', '1', 1)
889 : : if (ierr == 0) then
890 : : write(std_out,"(a)")'- OMP_NUM_THREADS was not defined. It has been set to 1.'
891 : : else
892 : : write(std_out,"(a)")'- WARNING: Failed to set OMP_NUM_THREADS.'
893 : : end if
894 : : else
895 : : !write(std_out,*)'- OMP_NUM_THREADS is already set to: ', trim(omp_num_threads)
896 : : end if
897 : : #endif
898 : :
899 : : end subroutine set_num_threads_if_undef
900 : : !!***
901 : :
902 : : !----------------------------------------------------------------------
903 : :
904 : : !!****f* m_xmpi/xmpi_set_inplace_operations
905 : : !! NAME
906 : : !! xmpi_set_inplace_operations
907 : : !!
908 : : !! FUNCTION
909 : : !! Set internal flag to use MPI_IN_PLACE whenever possible.
910 : : !!
911 : : !! SOURCE
912 : :
913 : 0 : subroutine xmpi_set_inplace_operations(bool)
914 : :
915 : : !Local variables-------------------
916 : : logical,intent(in) :: bool
917 : : ! *************************************************************************
918 : :
919 : 0 : xmpi_use_inplace_operations = bool
920 : :
921 : 0 : end subroutine xmpi_set_inplace_operations
922 : : !!***
923 : :
924 : : !----------------------------------------------------------------------
925 : :
926 : : !!****f* m_xmpi/xmpi_get_unit
927 : : !! NAME
928 : : !! xmpi_get_unit
929 : : !!
930 : : !! FUNCTION
931 : : !! Get free unit (emulate F2008 newunit for portability reasons)
932 : : !! Return -1 if no unit is found.
933 : : !!
934 : : !! SOURCE
935 : :
936 : 0 : integer function xmpi_get_unit() result(unt)
937 : :
938 : : !Local variables-------------------
939 : : logical :: isopen
940 : : ! *************************************************************************
941 : :
942 [ # # ]: 0 : do unt=1024,-1,-1
943 : 0 : inquire(unit=unt, opened=isopen)
944 [ # # ]: 0 : if (.not.isopen) exit
945 : : end do
946 : :
947 : 0 : end function xmpi_get_unit
948 : : !!***
949 : :
950 : : !----------------------------------------------------------------------
951 : :
952 : : !!****f* m_xmpi/xmpi_end
953 : : !! NAME
954 : : !! xmpi_end
955 : : !!
956 : : !! FUNCTION
957 : : !! Hides MPI_FINALIZE from MPI library.
958 : : !!
959 : : !! SOURCE
960 : :
961 : 1780 : subroutine xmpi_end()
962 : :
963 : : !Local variables-------------------
964 : : integer :: mpierr
965 : : ! *************************************************************************
966 : :
967 : 1780 : mpierr=0
968 : : #ifdef HAVE_MPI
969 : 1780 : call MPI_BARRIER(MPI_COMM_WORLD,mpierr) ! Needed by some HPC architectures (MT, 20110315)
970 : 1780 : call MPI_FINALIZE(mpierr)
971 : : #endif
972 : :
973 : : #ifndef FC_IBM
974 : : ! IBM8 returns 260. 320 ...
975 : : call sys_exit(0)
976 : : #endif
977 : :
978 : : end subroutine xmpi_end
979 : : !!***
980 : :
981 : : !----------------------------------------------------------------------
982 : :
983 : : !!****f* m_xmpi/xmpi_abort
984 : : !! NAME
985 : : !! xmpi_abort
986 : : !!
987 : : !! FUNCTION
988 : : !! Hides MPI_ABORT from MPI library.
989 : : !!
990 : : !! INPUTS
991 : : !! [comm]=communicator of tasks to abort.
992 : : !! [mpierr]=Error code to return to invoking environment.
993 : : !! [msg]=User message
994 : : !! [exit_status]=optional, shell return code, default 1
995 : : !!
996 : : !! SOURCE
997 : :
998 : 16 : subroutine xmpi_abort(comm, mpierr, msg, exit_status)
999 : :
1000 : : !Arguments-------------------------
1001 : : integer,optional,intent(in) :: comm,mpierr,exit_status
1002 : : character(len=*),optional,intent(in) :: msg
1003 : :
1004 : : !Local variables-------------------
1005 : : integer :: ierr,my_comm,my_errorcode,ilen,ierr2
1006 : : logical :: testopen
1007 : : character(len=xmpi_msg_len) :: mpi_msg_error
1008 : : ! *************************************************************************
1009 : :
1010 : 16 : ierr=0
1011 [ - + ]: 16 : my_comm = xmpi_world; if (PRESENT(comm)) my_comm = comm
1012 : :
1013 [ - + ]: 16 : if (PRESENT(msg)) then
1014 : 0 : write(std_out,'(2a)')"User message: ",TRIM(msg)
1015 : : end if
1016 : :
1017 : : ! Close std_out and ab_out and flush units.
1018 : : ! Note that flush does not guarantee that the data is committed to disk.
1019 : : ! This is rather annoying because we may end up with incomplete log files
1020 : : ! that cannot be parsed by Abipy
1021 : : ! For a possible approach based on fsync, see
1022 : : ! https://gcc.gnu.org/onlinedocs/gcc-4.7.4/gfortran/FLUSH.html
1023 : :
1024 : 16 : inquire(std_out, opened=testopen)
1025 [ + - ]: 16 : if (testopen) then
1026 : : #if defined HAVE_FC_FLUSH
1027 : 16 : call flush(std_out)
1028 : : #endif
1029 : 16 : close(std_out)
1030 : : end if
1031 : :
1032 : 16 : inquire(ab_out,opened=testopen)
1033 [ + - ]: 16 : if (testopen) then
1034 : : #if defined HAVE_FC_FLUSH
1035 : 16 : call flush(ab_out)
1036 : : #endif
1037 : 16 : close(ab_out)
1038 : : end if
1039 : :
1040 : : ! exit_status=0 signals a deliberate, non-error termination (e.g. testkgrid
1041 : : ! stopping after dumping k-grids for prtkpt/=0), not a real abort. MPI_ABORT
1042 : : ! never returns, so it would discard exit_status: under some MPI/job-scheduler
1043 : : ! combinations (e.g. Slurm srun) the step then gets reported as killed by
1044 : : ! SIGKILL (retcode 137) instead of exiting 0. This code path is reached
1045 : : ! identically by every rank, so exiting the calling process directly is safe.
1046 [ + + ]: 16 : if (present(exit_status)) then
1047 [ + - ]: 14 : if (exit_status == 0) call sys_exit(0)
1048 : : end if
1049 : :
1050 : : #ifdef HAVE_MPI
1051 [ - + ]: 2 : my_errorcode=MPI_ERR_UNKNOWN; if (PRESENT(mpierr)) my_errorcode=mpierr
1052 : :
1053 : 2 : call MPI_ERROR_STRING(my_errorcode, mpi_msg_error, ilen, ierr2)
1054 : :
1055 : : !if (ilen>xmpi_msg_len) write(std_out,*)" WARNING: MPI message has been truncated!"
1056 : : !if (ierr2/=MPI_SUCCESS) then
1057 : : ! write(std_out,'(a,i0)')" WARNING: MPI_ERROR_STRING returned ierr2= ",ierr2
1058 : : !else
1059 : : ! write(std_out,'(2a)')" MPI_ERROR_STRING: ",TRIM(mpi_msg_error)
1060 : : !end if
1061 : :
1062 : 2 : call MPI_ABORT(my_comm, my_errorcode, ierr)
1063 : : #endif
1064 : :
1065 [ # # ]: 0 : if (present(exit_status)) then
1066 : : call sys_exit(exit_status)
1067 : : else
1068 : : call sys_exit(1)
1069 : : end if
1070 : :
1071 : : end subroutine xmpi_abort
1072 : : !!***
1073 : :
1074 : : !----------------------------------------------------------------------
1075 : :
1076 : : !!****f* m_xmpi/sys_exit
1077 : : !! NAME
1078 : : !! sys_exit
1079 : : !!
1080 : : !! FUNCTION
1081 : : !! Routine for clean exit of f90 code by one processor
1082 : : !!
1083 : : !! INPUTS
1084 : : !! exit_status: return code.
1085 : : !!
1086 : : !! NOTES
1087 : : !! By default, it uses "call exit(1)", that is not completely portable.
1088 : : !!
1089 : : !! SOURCE
1090 : :
1091 : 1794 : subroutine sys_exit(exit_status)
1092 : :
1093 : : !Arguments ------------------------------------
1094 : : !scalars
1095 : : integer,intent(in) :: exit_status
1096 : : ! **********************************************************************
1097 : :
1098 : : #if defined FC_NAG
1099 : : call exit(exit_status)
1100 : : #elif defined HAVE_FC_EXIT
1101 : 14 : call exit(exit_status)
1102 : : #else
1103 : : ! stop with exit_status
1104 : : ! MT 06-2013:stop function only accept parameters!
1105 : : if (exit_status== 0) stop "0"
1106 : : if (exit_status== 1) stop "1"
1107 : : if (exit_status==-1) stop "-1"
1108 : : #endif
1109 : : stop 1
1110 : :
1111 : : end subroutine sys_exit
1112 : : !!***
1113 : :
1114 : : !----------------------------------------------------------------------
1115 : :
1116 : : !!****f* m_xmpi/xmpi_show_info
1117 : : !! NAME
1118 : : !! xmpi_show_info
1119 : : !!
1120 : : !! FUNCTION
1121 : : !! Printout of the most important variables stored in this module (useful for debugging).
1122 : : !!
1123 : : !! INPUTS
1124 : : !! unt=Unit number for formatted output.
1125 : : !!
1126 : : !! SOURCE
1127 : :
1128 : 1153 : subroutine xmpi_show_info(unit)
1129 : :
1130 : : !Arguments-------------------------
1131 : : integer,optional,intent(in) :: unit
1132 : :
1133 : : !Local variables-------------------
1134 : : integer :: my_unt
1135 : : ! *************************************************************************
1136 : :
1137 [ + - ]: 1153 : my_unt = std_out; if (PRESENT(unit)) my_unt=unit
1138 : :
1139 : : #ifdef HAVE_MPI1
1140 : : write(my_unt,*)" ==== Using MPI-1 specifications ==== "
1141 : : #endif
1142 : : #ifdef HAVE_MPI2
1143 : 1153 : write(my_unt,*)" ==== Using MPI-2 specifications ==== "
1144 : : #endif
1145 : :
1146 : : #ifdef HAVE_MPI_IO
1147 : 1153 : write(my_unt,*)" MPI-IO support is ON"
1148 : : #else
1149 : : write(my_unt,*)" MPI-IO support is OFF"
1150 : : #endif
1151 : :
1152 : : #ifdef HAVE_MPI
1153 : 1153 : write(my_unt,*)" xmpi_tag_ub ................ ",xmpi_tag_ub
1154 : 1153 : write(my_unt,*)" xmpi_bsize_ch .............. ",xmpi_bsize_ch
1155 : 1153 : write(my_unt,*)" xmpi_bsize_int ............. ",xmpi_bsize_int
1156 : 1153 : write(my_unt,*)" xmpi_bsize_sp .............. ",xmpi_bsize_sp
1157 : 1153 : write(my_unt,*)" xmpi_bsize_dp .............. ",xmpi_bsize_dp
1158 : 1153 : write(my_unt,*)" xmpi_bsize_spc ............. ",xmpi_bsize_spc
1159 : 1153 : write(my_unt,*)" xmpi_bsize_dpc ............. ",xmpi_bsize_dpc
1160 : 1153 : write(my_unt,*)" xmpio_bsize_frm ............ ",xmpio_bsize_frm
1161 : 1153 : write(my_unt,*)" xmpi_address_kind .......... ",xmpi_address_kind
1162 : 1153 : write(my_unt,*)" xmpi_offset_kind ........... ",xmpi_offset_kind
1163 : 1153 : write(my_unt,*)" MPI_WTICK .................. ",MPI_WTICK()
1164 : : #endif
1165 : :
1166 : 1153 : end subroutine xmpi_show_info
1167 : : !!***
1168 : :
1169 : : !----------------------------------------------------------------------
1170 : :
1171 : : !!****f* m_xmpi/xmpi_comm_rank
1172 : : !! NAME
1173 : : !! xmpi_comm_rank
1174 : : !!
1175 : : !! FUNCTION
1176 : : !! Hides MPI_COMM_RANK from MPI library.
1177 : : !!
1178 : : !! INPUTS
1179 : : !! comm=MPI communicator.
1180 : : !!
1181 : : !! OUTPUT
1182 : : !! xmpi_comm_rank=The rank of the node inside comm
1183 : : !!
1184 : : !! SOURCE
1185 : :
1186 : 10288344 : integer function xmpi_comm_rank(comm)
1187 : :
1188 : : !Arguments-------------------------
1189 : : integer,intent(in) :: comm
1190 : :
1191 : : !Local variables-------------------
1192 : : integer :: mpierr
1193 : : ! *************************************************************************
1194 : :
1195 : 10288344 : mpierr=0
1196 : : #ifdef HAVE_MPI
1197 : 10288344 : xmpi_comm_rank=-1 ! Return non-sense value if the proc does not belong to the comm
1198 [ + - ]: 10288344 : if (comm/=xmpi_comm_null) then
1199 : 10288344 : call MPI_COMM_RANK(comm,xmpi_comm_rank,mpierr)
1200 : : end if
1201 : : #else
1202 : : xmpi_comm_rank=0
1203 : : #endif
1204 : :
1205 : 10288344 : end function xmpi_comm_rank
1206 : : !!***
1207 : :
1208 : : !----------------------------------------------------------------------
1209 : :
1210 : : !!****f* m_xmpi/xmpi_comm_size
1211 : : !! NAME
1212 : : !! xmpi_comm_size
1213 : : !!
1214 : : !! FUNCTION
1215 : : !! Hides MPI_COMM_SIZE from MPI library.
1216 : : !!
1217 : : !! INPUTS
1218 : : !! comm=MPI communicator.
1219 : : !!
1220 : : !! OUTPUT
1221 : : !! xmpi_comm_size=The number of processors inside comm. Return 0 if comm = xmpi_comm_null
1222 : : !!
1223 : : !! SOURCE
1224 : :
1225 : 213783804 : integer function xmpi_comm_size(comm)
1226 : :
1227 : : !Arguments-------------------------
1228 : : integer,intent(in) :: comm
1229 : :
1230 : : !Local variables-------------------------------
1231 : : integer :: mpierr
1232 : : ! *************************************************************************
1233 : :
1234 : 213783804 : mpierr=0; xmpi_comm_size=1
1235 : : #ifdef HAVE_MPI
1236 : 213783804 : xmpi_comm_size = 0
1237 [ + + ]: 213783804 : if (comm /= xmpi_comm_null) call MPI_COMM_SIZE(comm,xmpi_comm_size,mpierr)
1238 : : #endif
1239 : :
1240 : 213783804 : end function xmpi_comm_size
1241 : : !!***
1242 : :
1243 : : !----------------------------------------------------------------------
1244 : :
1245 : : !!****f* m_xmpi/xmpi_comm_free_0D
1246 : : !! NAME
1247 : : !! xmpi_comm_free_0D
1248 : : !!
1249 : : !! FUNCTION
1250 : : !! Hides MPI_COMM_FREE from MPI library.
1251 : : !! Does not abort MPI in case of an invalid communicator
1252 : : !!
1253 : : !! INPUTS
1254 : : !! comm=MPI communicator.
1255 : : !!
1256 : : !! SOURCE
1257 : :
1258 : 79952 : subroutine xmpi_comm_free_0D(comm)
1259 : :
1260 : : !Arguments-------------------------
1261 : : integer,intent(inout) :: comm
1262 : :
1263 : : !Local variables-------------------------------
1264 : : #ifdef HAVE_MPI
1265 : : integer :: comm_world,err_handler_dum,err_handler_sav,ierr,mpierr,mpierr_class
1266 : : ! *************************************************************************
1267 : :
1268 [ + + + + ]: 79952 : if (comm/=xmpi_comm_null.and.comm/=xmpi_world.and.comm/=xmpi_comm_self) then
1269 : :
1270 : 7866 : comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
1271 : 7866 : call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,ierr)
1272 : 7866 : call MPI_COMM_FREE(comm,mpierr)
1273 : 7866 : call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,ierr)
1274 : :
1275 [ + + ]: 7866 : if (mpierr/=MPI_SUCCESS) then
1276 : 396 : call MPI_ERROR_CLASS(mpierr,mpierr_class,ierr)
1277 [ - + ]: 396 : if (mpierr_class/=MPI_ERR_COMM) then
1278 : 0 : write(std_out,*)" WARNING: MPI_COMM_FREE returned ierr= ",mpierr
1279 : : end if
1280 : : end if
1281 : :
1282 : : end if
1283 : :
1284 : : #else
1285 : : if (.false.) write(std_out,*) comm
1286 : : #endif
1287 : :
1288 : 79952 : end subroutine xmpi_comm_free_0D
1289 : : !!***
1290 : :
1291 : : !----------------------------------------------------------------------
1292 : :
1293 : : !!****f* m_xmpi/xmpi_comm_free_1D
1294 : : !! NAME
1295 : : !! xmpi_comm_free_1D
1296 : : !!
1297 : : !! FUNCTION
1298 : : !! Hides MPI_COMM_FREE from MPI library. Target 1D arrays
1299 : : !! Does not abort MPI in case of an invalid communicator
1300 : : !!
1301 : : !! INPUTS
1302 : : !! comms(:)=MPI communicators
1303 : : !!
1304 : : !! SOURCE
1305 : :
1306 [ - + ]: 24 : subroutine xmpi_comm_free_1D(comms)
1307 : :
1308 : : !Arguments-------------------------
1309 : : integer,intent(inout) :: comms(:)
1310 : :
1311 : : !Local variables-------------------------------
1312 : : !scalars
1313 : : #ifdef HAVE_MPI
1314 : : integer :: comm_world,err_handler_dum,err_handler_sav,ii,mpierr
1315 : : ! *************************************************************************
1316 : :
1317 : 24 : comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
1318 : 24 : call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,mpierr)
1319 : :
1320 [ + - + + ]: 72 : do ii=LBOUND(comms,DIM=1),UBOUND(comms,DIM=1)
1321 [ + - + - ]: 48 : if (comms(ii)/=xmpi_comm_null.and.comms(ii)/=xmpi_world.and.comms(ii)/=xmpi_comm_self) then
1322 : 24 : call MPI_COMM_FREE(comms(ii),mpierr)
1323 : : end if
1324 : : end do
1325 : :
1326 : 24 : call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,mpierr)
1327 : :
1328 : : #else
1329 : : if (.false.) write(std_out,*) comms(1)
1330 : : #endif
1331 : :
1332 : 24 : end subroutine xmpi_comm_free_1D
1333 : : !!***
1334 : :
1335 : : !----------------------------------------------------------------------
1336 : :
1337 : : !!****f* m_xmpi/xmpi_comm_free_2D
1338 : : !! NAME
1339 : : !! xmpi_comm_free_2D
1340 : : !!
1341 : : !! FUNCTION
1342 : : !! Hides MPI_COMM_FREE from MPI library. Target 2D arrays
1343 : : !! Does not abort MPI in case of an invalid communicator
1344 : : !!
1345 : : !! INPUTS
1346 : : !! comms=MPI communicator.
1347 : : !!
1348 : : !! SOURCE
1349 : :
1350 [ # # ]: 0 : subroutine xmpi_comm_free_2D(comms)
1351 : :
1352 : : !Arguments-------------------------
1353 : : integer,intent(inout) :: comms(:,:)
1354 : :
1355 : : !Local variables-------------------------------
1356 : : !scalars
1357 : : #ifdef HAVE_MPI
1358 : : integer :: comm_world,err_handler_dum,err_handler_sav,ii,jj,mpierr
1359 : : ! *************************************************************************
1360 : :
1361 : 0 : comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
1362 : 0 : call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,mpierr)
1363 : :
1364 [ # # # # ]: 0 : do jj=LBOUND(comms,DIM=2),UBOUND(comms,DIM=2)
1365 [ # # # # ]: 0 : do ii=LBOUND(comms,DIM=1),UBOUND(comms,DIM=1)
1366 [ # # # # ]: 0 : if (comms(ii,jj)/=xmpi_comm_null.and.comms(ii,jj)/=xmpi_world.and. comms(ii,jj)/=xmpi_comm_self) then
1367 : 0 : call MPI_COMM_FREE(comms(ii,jj),mpierr)
1368 : : end if
1369 : : end do
1370 : : end do
1371 : :
1372 : 0 : call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,mpierr)
1373 : :
1374 : : #else
1375 : : if (.false.) write(std_out,*) comms(1,1)
1376 : : #endif
1377 : :
1378 : 0 : end subroutine xmpi_comm_free_2D
1379 : : !!***
1380 : :
1381 : : !----------------------------------------------------------------------
1382 : :
1383 : : !!****f* m_xmpi/xmpi_comm_free_3D
1384 : : !! NAME
1385 : : !! xmpi_comm_free_3D
1386 : : !!
1387 : : !! FUNCTION
1388 : : !! Hides MPI_COMM_FREE from MPI library. Target 3D arrays
1389 : : !! Does not abort MPI in case of an invalid communicator
1390 : : !!
1391 : : !! INPUTS
1392 : : !! comms=MPI communicator.
1393 : : !!
1394 : : !! SOURCE
1395 : :
1396 [ # # ]: 0 : subroutine xmpi_comm_free_3D(comms)
1397 : :
1398 : : !Arguments-------------------------
1399 : : integer,intent(inout) :: comms(:,:,:)
1400 : :
1401 : : !Local variables-------------------------------
1402 : : !scalars
1403 : : #ifdef HAVE_MPI
1404 : : integer :: comm_world,err_handler_dum,err_handler_sav,ii,jj,kk,mpierr
1405 : : ! *************************************************************************
1406 : :
1407 : 0 : comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
1408 : 0 : call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,mpierr)
1409 : :
1410 [ # # # # ]: 0 : do kk=LBOUND(comms,DIM=3),UBOUND(comms,DIM=3)
1411 [ # # # # ]: 0 : do jj=LBOUND(comms,DIM=2),UBOUND(comms,DIM=2)
1412 [ # # # # ]: 0 : do ii=LBOUND(comms,DIM=1),UBOUND(comms,DIM=1)
1413 [ # # # # ]: 0 : if (comms(ii,jj,kk)/=xmpi_comm_null.and.comms(ii,jj,kk)/=xmpi_world.and. comms(ii,jj,kk)/=xmpi_comm_self) then
1414 : 0 : call MPI_COMM_FREE(comms(ii,jj,kk),mpierr)
1415 : : end if
1416 : : end do
1417 : : end do
1418 : : end do
1419 : :
1420 : 0 : call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,mpierr)
1421 : :
1422 : : #else
1423 : : if (.false.) write(std_out,*) comms(1,1,1)
1424 : : #endif
1425 : :
1426 : 0 : end subroutine xmpi_comm_free_3D
1427 : : !!***
1428 : :
1429 : : !----------------------------------------------------------------------
1430 : :
1431 : : !!****f* m_xmpi/xmpi_group_free
1432 : : !! NAME
1433 : : !! xmpi_group_free
1434 : : !!
1435 : : !! FUNCTION
1436 : : !! Hides MPI_GROUP_FREE from MPI library.
1437 : : !! Does not abort MPI in case of an invalid group
1438 : : !!
1439 : : !! INPUTS
1440 : : !! spaceGroup=MPI group
1441 : : !!
1442 : : !! SOURCE
1443 : :
1444 : 1166 : subroutine xmpi_group_free(spaceGroup)
1445 : :
1446 : : !Arguments-------------------------
1447 : : integer,intent(inout) :: spaceGroup
1448 : :
1449 : : !Local variables-------------------------------
1450 : : !scalars
1451 : : #ifdef HAVE_MPI
1452 : : integer :: comm_world,err_handler_dum,err_handler_sav,ierr,mpierr,mpierr_class
1453 : : ! *************************************************************************
1454 : :
1455 [ + - ]: 1166 : if (spaceGroup/=xmpi_group_null) then
1456 : :
1457 : 1166 : comm_world=xmpi_world ! Needed to bypass a bug in some OMPI implementations (intent(inout))
1458 : 1166 : call xmpi_comm_set_errhandler(comm_world,MPI_ERRORS_RETURN,err_handler_sav,ierr)
1459 : 1166 : call MPI_GROUP_FREE(spaceGroup,mpierr)
1460 : 1166 : call xmpi_comm_set_errhandler(comm_world,err_handler_sav,err_handler_dum,ierr)
1461 : :
1462 [ - + ]: 1166 : if (mpierr/=MPI_SUCCESS) then
1463 : 0 : call MPI_ERROR_CLASS(mpierr,mpierr_class,ierr)
1464 [ # # ]: 0 : if (mpierr_class/=MPI_ERR_GROUP) write(std_out,*)" WARNING: MPI_GROUP_FREE returned ierr= ",mpierr
1465 : : end if
1466 : :
1467 : : end if
1468 : :
1469 : : #else
1470 : : if (.false.) write(std_out,*) spaceGroup
1471 : : #endif
1472 : :
1473 : 1166 : end subroutine xmpi_group_free
1474 : : !!***
1475 : :
1476 : : !----------------------------------------------------------------------
1477 : :
1478 : : !!****f* m_xmpi/xmpi_group_incl
1479 : : !! NAME
1480 : : !! xmpi_group_incl
1481 : : !!
1482 : : !! FUNCTION
1483 : : !! Hides MPI_GROUP_INCL from MPI library.
1484 : : !!
1485 : : !! INPUTS
1486 : : !! group=input group
1487 : : !! nrank=number of elements in array ranks (size of newgroup)
1488 : : !! ranks=ranks of processes in group to appear in newgroup
1489 : : !!
1490 : : !! OUTPUT
1491 : : !! newgroup= new group derived from above, in the order defined by ranks
1492 : : !!
1493 : : !! SOURCE
1494 : :
1495 : 0 : subroutine xmpi_group_incl(group,nranks,ranks,newgroup,mpierr)
1496 : :
1497 : : !Arguments-------------------------
1498 : : !scalars
1499 : : integer,intent(in) :: group,nranks
1500 : : integer,intent(out) :: mpierr
1501 : : integer,intent(inout) :: newgroup
1502 : : !arrays
1503 : : integer,intent(in) :: ranks(nranks)
1504 : : ! *************************************************************************
1505 : :
1506 : 0 : mpierr=0 ; newgroup=xmpi_group_null
1507 : : #ifdef HAVE_MPI
1508 [ # # ]: 0 : if (group/=xmpi_group_null) then
1509 : 0 : call MPI_GROUP_INCL(group,nranks,ranks,newgroup,mpierr)
1510 : : end if
1511 : : #endif
1512 : :
1513 : 0 : end subroutine xmpi_group_incl
1514 : : !!***
1515 : :
1516 : : !----------------------------------------------------------------------
1517 : :
1518 : : !!****f* m_xmpi/xmpi_comm_create
1519 : : !! NAME
1520 : : !! xmpi_comm_create
1521 : : !!
1522 : : !! FUNCTION
1523 : : !! Hides MPI_COMM_CREATE from MPI library.
1524 : : !!
1525 : : !! INPUTS
1526 : : !! comm=communicator
1527 : : !! group=group, which is a subset of the group of comm
1528 : : !!
1529 : : !! OUTPUT
1530 : : !! newcomm=new communicator
1531 : : !!
1532 : : !! SOURCE
1533 : :
1534 : 0 : subroutine xmpi_comm_create(comm,group,newcomm,mpierr)
1535 : :
1536 : : !Arguments-------------------------
1537 : : !scalars
1538 : : integer,intent(in) :: comm,group
1539 : : integer,intent(out) :: mpierr
1540 : : integer,intent(inout) :: newcomm
1541 : : ! *************************************************************************
1542 : :
1543 : 0 : mpierr=0
1544 : : #ifdef HAVE_MPI
1545 [ # # ]: 0 : if (group/=xmpi_group_null) then
1546 : 0 : call MPI_comm_create(comm,group,newcomm,mpierr)
1547 : : else
1548 : 0 : newcomm=xmpi_comm_null
1549 : : end if
1550 : : #else
1551 : : newcomm=xmpi_comm_self
1552 : : #endif
1553 : :
1554 : 0 : end subroutine xmpi_comm_create
1555 : : !!***
1556 : :
1557 : : !----------------------------------------------------------------------
1558 : :
1559 : : !!****f* m_xmpi/xmpi_subcomm
1560 : : !! NAME
1561 : : !! xmpi_subcomm
1562 : : !!
1563 : : !! FUNCTION
1564 : : !! Return a sub-communicator from an input communicator and a given proc. ranks set.
1565 : : !! (hides subgroup creation/destruction)
1566 : : !!
1567 : : !! INPUTS
1568 : : !! comm=input communicator
1569 : : !! nrank=number of elements in array ranks (size of subcomm)
1570 : : !! ranks=ranks of processes in group to appear in subcomm
1571 : : !!
1572 : : !! OUTPUT
1573 : : !! [my_rank_in_group]=optional: my rank in the group of new sub-communicator
1574 : : !! xmpi_subcomm=new (sub-)communicator
1575 : : !!
1576 : : !! SOURCE
1577 : :
1578 : 160 : integer function xmpi_subcomm(comm,nranks,ranks,my_rank_in_group)
1579 : :
1580 : : !Arguments-------------------------
1581 : : !scalars
1582 : : integer,intent(in) :: comm,nranks
1583 : : integer,intent(out),optional :: my_rank_in_group
1584 : : !arrays
1585 : : integer,intent(in) :: ranks(nranks)
1586 : :
1587 : : !Local variables-------------------------------
1588 : : #ifdef HAVE_MPI
1589 : : integer :: group,ierr,subgroup
1590 : : #endif
1591 : : ! *************************************************************************
1592 : :
1593 : 160 : xmpi_subcomm=xmpi_comm_null
1594 [ + + ]: 160 : if (present(my_rank_in_group)) my_rank_in_group=xmpi_undefined
1595 : :
1596 : : #ifdef HAVE_MPI
1597 [ + - + - ]: 160 : if (comm/=xmpi_comm_null.and.nranks>=0) then
1598 : 160 : call MPI_COMM_GROUP(comm,group,ierr)
1599 : 160 : call MPI_GROUP_INCL(group,nranks,ranks,subgroup,ierr)
1600 : 160 : call MPI_COMM_CREATE(comm,subgroup,xmpi_subcomm,ierr)
1601 [ - + ]: 160 : if ( nranks == 0 )xmpi_subcomm=xmpi_comm_self
1602 [ + + ]: 160 : if (present(my_rank_in_group)) then
1603 : 36 : call MPI_Group_rank(subgroup,my_rank_in_group,ierr)
1604 : : end if
1605 : 160 : call MPI_GROUP_FREE(subgroup,ierr)
1606 : 160 : call MPI_GROUP_FREE(group,ierr)
1607 : : end if
1608 : : #else
1609 : : if (nranks>0) then
1610 : : if (ranks(1)==0) then
1611 : : xmpi_subcomm=xmpi_comm_self
1612 : : if (present(my_rank_in_group)) my_rank_in_group=0
1613 : : end if
1614 : : end if
1615 : : #endif
1616 : :
1617 : 160 : end function xmpi_subcomm
1618 : : !!***
1619 : :
1620 : : !----------------------------------------------------------------------
1621 : :
1622 : : !!****f* m_xmpi/xmpi_comm_multiple
1623 : : !! NAME
1624 : : !! xmpi_comm_multiple
1625 : : !!
1626 : : !! FUNCTION
1627 : : !! Given an input communicator `input_comm`, create a new communicator
1628 : : !! with number of procs multiple of a certain number `ntasks`.
1629 : : !! Use all procs if ntasks >= input_nprocs.
1630 : : !!
1631 : : !! INPUTS
1632 : : !! ntasks=Number of tasks.
1633 : : !! comm=input communicator
1634 : : !!
1635 : : !! OUTPUT
1636 : : !! idle_proc=True if this proc is idle. In this case, output_comm contains all the idle procs.
1637 : : !! output_comm=Output communicator
1638 : : !!
1639 : : !! SOURCE
1640 : :
1641 : 0 : subroutine xmpi_comm_multiple_of(ntasks, input_comm, idle_proc, output_comm)
1642 : :
1643 : : !Arguments-------------------------
1644 : : !scalars
1645 : : integer,intent(in) :: ntasks, input_comm
1646 : : integer,intent(out) :: output_comm
1647 : : logical,intent(out) :: idle_proc
1648 : :
1649 : : !Local variables-------------------------------
1650 : : integer :: color, my_rank, ierr, input_nproc
1651 : : ! *************************************************************************
1652 : :
1653 : 0 : my_rank = xmpi_comm_rank(input_comm)
1654 : 0 : input_nproc = xmpi_comm_size(input_comm)
1655 : :
1656 [ # # ]: 0 : if (input_nproc <= ntasks) then
1657 : : ! Use all procs in input comm.
1658 : 0 : idle_proc = .False.; output_comm = input_comm
1659 : : #ifdef HAVE_MPI
1660 : 0 : call MPI_Comm_dup(input_comm, output_comm, ierr)
1661 : : #endif
1662 : : else
1663 [ # # ]: 0 : color = merge(0, 1, my_rank + 1 <= (ntasks / input_nproc) * input_nproc)
1664 : 0 : idle_proc = color == 1
1665 : 0 : call xmpi_comm_split(input_comm, color, my_rank, output_comm, ierr)
1666 : : end if
1667 : :
1668 : 0 : end subroutine xmpi_comm_multiple_of
1669 : : !!***
1670 : :
1671 : : !----------------------------------------------------------------------
1672 : :
1673 : : !!****f* m_xmpi/xmpi_comm_dup
1674 : : !! NAME
1675 : : !! xmpi_comm_dup
1676 : : !!
1677 : : !! FUNCTION
1678 : : !! Hides MPI_COMM_DUP from MPI library.
1679 : : !!
1680 : : !! INPUTS
1681 : : !! in_comm=input MPI communicator.
1682 : : !!
1683 : : !! OUTPUT
1684 : : !! out_comm=Output MPI communicator.
1685 : : !! mpierr=error code returned
1686 : : !!
1687 : : !! SOURCE
1688 : :
1689 : 0 : subroutine xmpi_comm_dup(in_comm, out_comm, mpierr)
1690 : :
1691 : : !Arguments-------------------------
1692 : : integer,intent(in) :: in_comm
1693 : : integer,intent(out) :: out_comm, mpierr
1694 : :
1695 : : !----------------------------------------------------------------------
1696 : :
1697 : : #ifdef HAVE_MPI
1698 : 0 : call MPI_Comm_dup(in_comm, out_comm, mpierr)
1699 : : #else
1700 : : out_comm = in_comm
1701 : : #endif
1702 : :
1703 : 0 : end subroutine xmpi_comm_dup
1704 : : !!***
1705 : :
1706 : : !----------------------------------------------------------------------
1707 : :
1708 : : !!****f* m_xmpi/xmpi_comm_group
1709 : : !! NAME
1710 : : !! xmpi_comm_group
1711 : : !!
1712 : : !! FUNCTION
1713 : : !! Hides MPI_COMM_GROUP from MPI library.
1714 : : !!
1715 : : !! INPUTS
1716 : : !! comm=MPI communicator.
1717 : : !!
1718 : : !! OUTPUT
1719 : : !! spaceGroup=The group associated to comm.
1720 : : !! mpierr=error code returned
1721 : : !!
1722 : : !! SOURCE
1723 : :
1724 : 1166 : subroutine xmpi_comm_group(comm,spaceGroup,mpierr)
1725 : :
1726 : : !Arguments-------------------------
1727 : : integer,intent(in) :: comm
1728 : : integer,intent(out) :: mpierr,spaceGroup
1729 : : ! *************************************************************************
1730 : :
1731 : 1166 : mpierr=0; spaceGroup=xmpi_group_null
1732 : : #ifdef HAVE_MPI
1733 [ + - ]: 1166 : if (comm/=xmpi_comm_null) then
1734 : 1166 : call MPI_COMM_GROUP(comm,spaceGroup,mpierr)
1735 : : end if
1736 : : #endif
1737 : :
1738 : 1166 : end subroutine xmpi_comm_group
1739 : : !!***
1740 : :
1741 : : !----------------------------------------------------------------------
1742 : :
1743 : : !!****f* m_xmpi/xmpi_comm_split
1744 : : !! NAME
1745 : : !! xmpi_comm_split
1746 : : !!
1747 : : !! FUNCTION
1748 : : !! Hides MPI_COMM_SPLIT from MPI library.
1749 : : !!
1750 : : !! INPUTS
1751 : : !! input_comm=Input MPI communicator (to be splitted)
1752 : : !! color=Control of subset assignment (nonnegative integer).
1753 : : !! Processes with the same color are in the same new communicator
1754 : : !! key=Control of rank assigment (integer)
1755 : : !!
1756 : : !! OUTPUT
1757 : : !! mpierr=error code returned
1758 : : !! output_comm=new splitted communicator
1759 : : !!
1760 : : !! SOURCE
1761 : :
1762 : 713 : subroutine xmpi_comm_split(input_comm, color, key, output_comm, mpierr)
1763 : :
1764 : : !Arguments-------------------------
1765 : : integer,intent(in) :: color,input_comm,key
1766 : : integer,intent(out) :: mpierr,output_comm
1767 : : ! *************************************************************************
1768 : :
1769 : 713 : mpierr=0; output_comm=input_comm
1770 : : #ifdef HAVE_MPI
1771 [ + + ]: 713 : if (input_comm/=xmpi_comm_null.and.input_comm/=xmpi_comm_self) then
1772 : 702 : call MPI_COMM_SPLIT(input_comm,color,key,output_comm,mpierr)
1773 : : end if
1774 : : #endif
1775 : :
1776 : 713 : end subroutine xmpi_comm_split
1777 : : !!***
1778 : :
1779 : : !----------------------------------------------------------------------
1780 : :
1781 : : !!****f* m_xmpi/xmpi_group_translate_ranks
1782 : : !! NAME
1783 : : !! xmpi_group_translate_ranks
1784 : : !!
1785 : : !! FUNCTION
1786 : : !! Hides MPI_GROUP_TRANSLATE_RANKS from MPI library.
1787 : : !!
1788 : : !! INPUTS
1789 : : !! nrank=number of ranks in ranks1 and ranks2 arrays
1790 : : !! ranks1(nrank)=array of zero or more valid ranks in group1
1791 : : !! spaceGroup1=group1
1792 : : !! spaceGroup2=group2
1793 : : !!
1794 : : !! OUTPUT
1795 : : !! mpierr=error code returned
1796 : : !! ranks2(nrank)=array of corresponding ranks in group2,
1797 : : !! xmpi_undefined when no correspondence exists
1798 : : !!
1799 : : !! SOURCE
1800 : :
1801 : 583 : subroutine xmpi_group_translate_ranks(spaceGroup1,nrank,ranks1,&
1802 : 583 : & spaceGroup2,ranks2,mpierr)
1803 : :
1804 : : !Arguments-------------------------
1805 : : !scalars
1806 : : integer,intent(in) :: nrank,spaceGroup1,spaceGroup2
1807 : : integer,intent(out) :: mpierr
1808 : : !arrays
1809 : : integer,intent(in) :: ranks1(nrank)
1810 : : integer,intent(out) :: ranks2(nrank)
1811 : : ! *************************************************************************
1812 : :
1813 [ + + ]: 1173 : mpierr=0; ranks2(:)=xmpi_undefined
1814 : : #ifdef HAVE_MPI
1815 [ + - + - ]: 583 : if (spaceGroup1/=xmpi_group_null.and.spaceGroup2/=xmpi_group_null) then
1816 : 583 : call MPI_GROUP_TRANSLATE_RANKS(spaceGroup1,nrank,ranks1, spaceGroup2,ranks2,mpierr)
1817 : : end if
1818 : : #else
1819 : : ranks2(1)=0
1820 : : #endif
1821 : :
1822 : 583 : end subroutine xmpi_group_translate_ranks
1823 : : !!***
1824 : :
1825 : : !----------------------------------------------------------------------
1826 : :
1827 : : !!****f* m_xmpi/xmpi_comm_translate_ranks
1828 : : !! NAME
1829 : : !! xmpi_comm_translate_ranks
1830 : : !!
1831 : : !! FUNCTION
1832 : : !! Helper function that translate the ranks from a communicator to another one.
1833 : : !! Wraps xmpi_group_translate_ranks but provides a more user-friendly interface
1834 : : !!
1835 : : !! INPUTS
1836 : : !! from_comm=MPI communicator where from_ranks are defined.
1837 : : !! nrank=number of ranks in from_ranks and to_ranks arrays
1838 : : !! from_ranks(nrank)=array of zero or more valid ranks in from_comm
1839 : : !!
1840 : : !! OUTPUT
1841 : : !! to_ranks(nrank)=array of corresponding ranks in to_comm
1842 : : !! xmpi_undefined when no correspondence exists
1843 : : !!
1844 : : !! SOURCE
1845 : :
1846 : 75 : subroutine xmpi_comm_translate_ranks(from_comm, nrank, from_ranks, to_comm, to_ranks)
1847 : :
1848 : : !Arguments-------------------------
1849 : : !scalars
1850 : : integer,intent(in) :: nrank,from_comm,to_comm
1851 : : !arrays
1852 : : integer,intent(in) :: from_ranks(nrank)
1853 : : integer,intent(out) :: to_ranks(nrank)
1854 : :
1855 : : !Local variables-------------------------------
1856 : : !scalars
1857 : : integer :: ierr,from_group,to_group
1858 : : ! *************************************************************************
1859 : :
1860 : : ! Get the groups
1861 : 25 : call xmpi_comm_group(from_comm,from_group,ierr)
1862 : 25 : call xmpi_comm_group(to_comm,to_group,ierr)
1863 : :
1864 : 25 : call xmpi_group_translate_ranks(from_group,nrank,from_ranks,to_group,to_ranks,ierr)
1865 : :
1866 : : ! Release the groups
1867 : 25 : call xmpi_group_free(from_group)
1868 : 25 : call xmpi_group_free(to_group)
1869 : :
1870 : 25 : end subroutine xmpi_comm_translate_ranks
1871 : : !!***
1872 : :
1873 : : !----------------------------------------------------------------------
1874 : :
1875 : : !!****f* m_xmpi/xmpi_comm_translate_rank
1876 : : !! NAME
1877 : : !! xmpi_comm_translate_rank
1878 : : !!
1879 : : !! FUNCTION
1880 : : !! Helper function to translate a single rank `from_rank` in communicator `from_rank` to
1881 : : !! the rank in communicator `to_comm`.
1882 : :
1883 : 0 : integer function xmpi_comm_translate_rank(from_comm, from_rank, to_comm) result(to_rank)
1884 : :
1885 : : !Arguments ------------------------------------
1886 : : integer,intent(in) :: from_comm, from_rank, to_comm
1887 : :
1888 : : !Local variables-------------------------------
1889 : : integer :: from_ranks(1), to_ranks(1)
1890 : : ! *************************************************************************
1891 : :
1892 : 0 : from_ranks(1) = from_rank
1893 : 0 : call xmpi_comm_translate_ranks(from_comm, 1, from_ranks, to_comm, to_ranks)
1894 : 0 : to_rank = to_ranks(1)
1895 : :
1896 : 0 : end function xmpi_comm_translate_rank
1897 : : !!***
1898 : :
1899 : : !----------------------------------------------------------------------
1900 : :
1901 : : !!****f* m_xmpi/xmpi_barrier
1902 : : !! NAME
1903 : : !! xmpi_barrier
1904 : : !!
1905 : : !! FUNCTION
1906 : : !! Hides MPI_BARRIER from MPI library.
1907 : : !!
1908 : : !! INPUTS
1909 : : !! comm=MPI communicator
1910 : : !!
1911 : : !! SOURCE
1912 : :
1913 : 104330 : subroutine xmpi_barrier(comm)
1914 : :
1915 : : !Arguments-------------------------
1916 : : integer,intent(in) :: comm
1917 : :
1918 : : !Local variables-------------------
1919 : : integer :: ier
1920 : : #ifdef HAVE_MPI
1921 : : integer :: nprocs
1922 : : #endif
1923 : : ! *************************************************************************
1924 : :
1925 : 104330 : ier = 0
1926 : : #ifdef HAVE_MPI
1927 [ + - ]: 104330 : if (comm/=xmpi_comm_null) then
1928 : 104330 : call MPI_COMM_SIZE(comm,nprocs,ier)
1929 [ + + ]: 104330 : if(nprocs>1) call MPI_BARRIER(comm,ier)
1930 : : end if
1931 : : #endif
1932 : :
1933 : 104330 : end subroutine xmpi_barrier
1934 : : !!***
1935 : :
1936 : : !----------------------------------------------------------------------
1937 : :
1938 : : !!****f* m_xmpi/xmpi_name
1939 : : !! NAME
1940 : : !! xmpi_name
1941 : : !!
1942 : : !! FUNCTION
1943 : : !! Returns the name of the processor
1944 : : !! Hides MPI_GET_PROCESSOR_NAME from MPI library.
1945 : : !!
1946 : : !! For the MPI standard:
1947 : : !! The name returned should identify a particular piece of hardware; the exact format is implementation defined.
1948 : : !! This name may or may not be the same as might be returned by gethostname, uname, or sysinfo.
1949 : : !!
1950 : : !! SOURCE
1951 : :
1952 : 0 : subroutine xmpi_name(name_ch, ierr)
1953 : :
1954 : : !Arguments-------------------------
1955 : : character(xmpi_max_processor_name),intent(out) :: name_ch
1956 : : integer,intent(out) :: ierr
1957 : :
1958 : : !Local variables-------------------
1959 : : integer :: len
1960 : : ! *************************************************************************
1961 : :
1962 : : ! Get the name of this processor (usually the hostname)
1963 : 0 : ierr = 0
1964 : : #ifdef HAVE_MPI
1965 : 0 : call MPI_GET_PROCESSOR_NAME(name_ch, len, ierr)
1966 [ # # ]: 0 : name_ch = trim(name_ch(1:len))
1967 : :
1968 : : #else
1969 : : name_ch = '0'
1970 : : #endif
1971 : :
1972 : 0 : end subroutine xmpi_name
1973 : : !!***
1974 : :
1975 : : !----------------------------------------------------------------------
1976 : :
1977 : : !!****f* m_xmpi/xmpi_iprobe
1978 : : !! NAME
1979 : : !! xmpi_iprobe
1980 : : !!
1981 : : !! FUNCTION
1982 : : !! Hides MPI_IPROBE from MPI library.
1983 : : !! Nonblocking test for a message.
1984 : : !!
1985 : : !! INPUTS
1986 : : !! source= source processes
1987 : : !! tag= tag value
1988 : : !! mpicomm= communicator
1989 : : !!
1990 : : !! OUTPUT
1991 : : !! flag= True if a message with the specified source, tag, and communicator is available
1992 : : !! mpierr= status error
1993 : : !!
1994 : : !! SOURCE
1995 : :
1996 : 5494 : subroutine xmpi_iprobe(source,tag,mpicomm,flag,mpierr)
1997 : :
1998 : : !Arguments-------------------------
1999 : : integer,intent(in) :: mpicomm,source,tag
2000 : : integer,intent(out) :: mpierr
2001 : : logical,intent(out) :: flag
2002 : :
2003 : : !Local variables-------------------
2004 : : #ifdef HAVE_MPI
2005 : : integer :: ier,status(MPI_STATUS_SIZE)
2006 : : #endif
2007 : : ! *************************************************************************
2008 : :
2009 : 5494 : mpierr = 0
2010 : : #ifdef HAVE_MPI
2011 : 5494 : call MPI_IPROBE(source,tag,mpicomm,flag,status,ier)
2012 : 5494 : mpierr=ier
2013 : : #endif
2014 : :
2015 : 5494 : end subroutine xmpi_iprobe
2016 : : !!***
2017 : :
2018 : : !----------------------------------------------------------------------
2019 : :
2020 : : !!****f* m_xmpi/xmpi_wait
2021 : : !! NAME
2022 : : !! xmpi_wait
2023 : : !!
2024 : : !! FUNCTION
2025 : : !! Hides MPI_WAIT from MPI library.
2026 : : !! Waits for an MPI request to complete.
2027 : : !!
2028 : : !! INPUTS
2029 : : !! request= MPI request handle to wait for
2030 : : !!
2031 : : !! OUTPUT
2032 : : !! mpierr= status error
2033 : : !!
2034 : : !! SOURCE
2035 : :
2036 : 1594056 : subroutine xmpi_wait(request, mpierr)
2037 : :
2038 : : !Arguments-------------------------
2039 : : integer,intent(inout) :: request
2040 : : integer,intent(out) :: mpierr
2041 : :
2042 : : !Local variables-------------------
2043 : : #ifdef HAVE_MPI
2044 : : integer :: ier,status(MPI_STATUS_SIZE)
2045 : : #endif
2046 : : ! *************************************************************************
2047 : :
2048 : 1594056 : mpierr = 0
2049 : : #ifdef HAVE_MPI
2050 [ + + ]: 1594056 : if (request /= xmpi_request_null) xmpi_count_requests = xmpi_count_requests - 1
2051 : 1594056 : call MPI_WAIT(request,status,ier)
2052 : 1594056 : mpierr=ier
2053 : : #endif
2054 : :
2055 : 1594056 : end subroutine xmpi_wait
2056 : : !!***
2057 : :
2058 : : !----------------------------------------------------------------------
2059 : :
2060 : : !!****f* m_xmpi/xmpi_waitall_1d
2061 : : !! NAME
2062 : : !! xmpi_waitall_1d
2063 : : !!
2064 : : !! FUNCTION
2065 : : !! Hides MPI_WAITALL from MPI library.
2066 : : !! Waits for all given MPI Requests to complete.
2067 : : !!
2068 : : !! INPUTS
2069 : : !! array_of_requests= array of request handles
2070 : : !!
2071 : : !! OUTPUT
2072 : : !! mpierr= status error
2073 : : !!
2074 : : !! SOURCE
2075 : :
2076 [ - + ]: 9016 : subroutine xmpi_waitall_1d(array_of_requests, mpierr)
2077 : :
2078 : : !Arguments-------------------------
2079 : : integer,intent(inout) :: array_of_requests(:)
2080 : : integer,intent(out) :: mpierr
2081 : :
2082 : : !Local variables-------------------
2083 : : #ifdef HAVE_MPI
2084 : 18032 : integer :: ier,status(MPI_STATUS_SIZE,size(array_of_requests))
2085 : : #endif
2086 : : ! *************************************************************************
2087 : :
2088 : 9016 : mpierr = 0
2089 : : #ifdef HAVE_MPI
2090 [ + + + + ]: 42442 : xmpi_count_requests = xmpi_count_requests - count(array_of_requests /= xmpi_request_null)
2091 [ - + - - : 9016 : call MPI_WAITALL(size(array_of_requests), array_of_requests, status, ier)
- - - + -
- ]
2092 : 9016 : mpierr=ier
2093 : : #endif
2094 : :
2095 : 9016 : end subroutine xmpi_waitall_1d
2096 : : !!***
2097 : :
2098 : : !----------------------------------------------------------------------
2099 : :
2100 : : !!****f* m_xmpi/xmpi_waitall_2d
2101 : : !! NAME
2102 : : !! xmpi_waitall_2d
2103 : : !!
2104 : : !! FUNCTION
2105 : : !! Hides MPI_WAITALL from MPI library.
2106 : : !! Waits for all given MPI Requests to complete.
2107 : : !!
2108 : : !! INPUTS
2109 : : !! array_of_requests= array of request handles
2110 : : !!
2111 : : !! OUTPUT
2112 : : !! mpierr= status error
2113 : : !!
2114 : : !! SOURCE
2115 : :
2116 [ - + ]: 2050 : subroutine xmpi_waitall_2d(array_of_requests, mpierr)
2117 : :
2118 : : !Arguments-------------------------
2119 : : integer,intent(inout) :: array_of_requests(:,:)
2120 : : integer,intent(out) :: mpierr
2121 : :
2122 : : !Local variables-------------------
2123 [ + + ]: 6150 : integer :: flat_requests(product(shape(array_of_requests)))
2124 : : ! *************************************************************************
2125 : :
2126 : : ! MPI_WAITALL is a Fortran interface so cannot pass count and base address a la C
2127 : : ! so flat 2d array and copy in-out. See https://github.com/open-mpi/ompi/issues/587
2128 : 2050 : flat_requests = pack(array_of_requests, mask=.True.)
2129 : 2050 : call xmpi_waitall_1d(flat_requests, mpierr)
2130 [ + + ]: 6150 : array_of_requests = reshape(flat_requests, shape(array_of_requests))
2131 : :
2132 : 2050 : end subroutine xmpi_waitall_2d
2133 : : !!***
2134 : :
2135 : : !----------------------------------------------------------------------
2136 : :
2137 : : !!****f* m_xmpi/xmpi_request_free
2138 : : !! NAME
2139 : : !! xmpi_request_free
2140 : : !!
2141 : : !! FUNCTION
2142 : : !! Hides MPI_REQUEST_FREE from MPI library.
2143 : : !! Frees an array of communication request objects.
2144 : : !!
2145 : : !! INPUTS
2146 : : !! requests(:)= communication request array (array of handles)
2147 : : !!
2148 : : !! OUTPUT
2149 : : !! mpierr= status error
2150 : : !!
2151 : : !! SOURCE
2152 : :
2153 [ # # ]: 0 : subroutine xmpi_request_free(requests,mpierr)
2154 : :
2155 : : !Arguments-------------------------
2156 : : integer,intent(inout) :: requests(:)
2157 : : integer,intent(out) :: mpierr
2158 : :
2159 : : !Local variables-------------------
2160 : : #ifdef HAVE_MPI
2161 : : integer :: ier,ii
2162 : : #endif
2163 : : ! *************************************************************************
2164 : :
2165 : 0 : mpierr = 0
2166 : : #ifdef HAVE_MPI
2167 [ # # ]: 0 : do ii=1,size(requests)
2168 [ # # ]: 0 : if (requests(ii) /= xmpi_request_null) xmpi_count_requests = xmpi_count_requests - 1
2169 : 0 : call MPI_REQUEST_FREE(requests(ii),ier)
2170 : : end do
2171 : 0 : mpierr=ier
2172 : : #endif
2173 : :
2174 : 0 : end subroutine xmpi_request_free
2175 : : !!***
2176 : :
2177 : : !!****f* m_xmpi/xmpi_requests_add
2178 : : !! NAME
2179 : : !! xmpi_requests_add
2180 : : !!
2181 : : !! FUNCTION
2182 : : !! Increase/decrement xmpi_count_requests internal counter
2183 : : !!
2184 : : !! SOURCE
2185 : :
2186 : 0 : subroutine xmpi_requests_add(count)
2187 : :
2188 : : !Arguments-------------------------
2189 : : integer,intent(in) :: count
2190 : : ! *************************************************************************
2191 : :
2192 : 0 : xmpi_count_requests = xmpi_count_requests + count
2193 : :
2194 : 0 : end subroutine xmpi_requests_add
2195 : : !!***
2196 : :
2197 : : !----------------------------------------------------------------------
2198 : :
2199 : : !!****f* m_xmpi/xmpi_error_string
2200 : : !! NAME
2201 : : !! xmpi_error_string
2202 : : !!
2203 : : !! FUNCTION
2204 : : !! Hides MPI_ERROR_STRING from MPI library.
2205 : : !!
2206 : : !! INPUTS
2207 : : !!
2208 : : !! OUTPUT
2209 : : !!
2210 : : !! SOURCE
2211 : :
2212 : 0 : subroutine xmpi_error_string(mpierr,err_string,ilen,ierror)
2213 : :
2214 : : !Arguments-------------------------
2215 : : integer,intent(in) :: mpierr
2216 : : integer,intent(out) :: ilen,ierror
2217 : : character(len=*),intent(out) :: err_string
2218 : : ! *************************************************************************
2219 : :
2220 : 0 : ilen=0
2221 : : #ifdef HAVE_MPI
2222 : 0 : call MPI_Error_string(mpierr,err_string,ilen,ierror)
2223 : : #else
2224 : : ierror=1
2225 : : err_string="Sorry, no MPI_Error_string routine is available to interpret the error message"
2226 : : #endif
2227 : :
2228 : 0 : end subroutine xmpi_error_string
2229 : : !!***
2230 : :
2231 : : !----------------------------------------------------------------------
2232 : :
2233 : : !!****f* m_xmpi/xmpi_comm_set_errhandler
2234 : : !! NAME
2235 : : !! xmpi_set_errhandler
2236 : : !!
2237 : : !! FUNCTION
2238 : : !! Hides MPI_COMM_SET_ERRHANDLER from MPI library.
2239 : : !!
2240 : : !! INPUTS
2241 : : !! new_err_handler= new error handler
2242 : : !!
2243 : : !! OUTPUT
2244 : : !! ierror=error code
2245 : : !! old_err_handler= old error handler
2246 : : !!
2247 : : !! SIZE EFFECTS
2248 : : !! comm= communicator (should be intent(in) but is intent(inout) in some
2249 : : !! OMPI implementation ; known as a bug)
2250 : : !!
2251 : : !! SOURCE
2252 : :
2253 : 18112 : subroutine xmpi_comm_set_errhandler(comm,new_err_handler,old_err_handler,ierror)
2254 : :
2255 : : !Arguments-------------------------
2256 : : integer,intent(in) :: new_err_handler
2257 : : integer,intent(in) :: comm
2258 : : integer,intent(out) :: ierror,old_err_handler
2259 : :
2260 : : !Local variables-------------------------
2261 : : integer :: mpierr1,mpierr2,my_comm
2262 : : ! *************************************************************************
2263 : :
2264 : 18112 : ierror=0
2265 : 18112 : my_comm = comm !should be intent(in) but is intent(inout) in some OMPI implementation ; known as a bug)
2266 : :
2267 : : #if defined HAVE_MPI
2268 : :
2269 : 18112 : mpierr1=MPI_SUCCESS; mpierr2=MPI_SUCCESS
2270 : :
2271 : : #if defined HAVE_MPI1
2272 : : call MPI_Errhandler_get(my_comm,old_err_handler,mpierr1)
2273 : : call MPI_Errhandler_set(my_comm,new_err_handler,mpierr2)
2274 : : #endif
2275 : : #if defined HAVE_MPI2
2276 : 18112 : call MPI_comm_get_Errhandler(my_comm,old_err_handler,mpierr1)
2277 : 18112 : call MPI_comm_set_Errhandler(my_comm,new_err_handler,mpierr2)
2278 : : #endif
2279 : :
2280 : 18112 : ierror=MPI_SUCCESS
2281 [ - + ]: 18112 : if (mpierr1/=MPI_SUCCESS) then
2282 : 0 : ierror=mpierr1
2283 [ - + ]: 18112 : else if (mpierr2/=MPI_SUCCESS) then
2284 : 0 : ierror=mpierr2
2285 : : end if
2286 : : #endif
2287 : :
2288 : 18112 : end subroutine xmpi_comm_set_errhandler
2289 : : !!***
2290 : :
2291 : : !----------------------------------------------------------------------
2292 : :
2293 : : !!****f* m_xmpi/xmpi_split_work_i4b
2294 : : !! NAME
2295 : : !! xmpi_split_work_i4b
2296 : : !!
2297 : : !! FUNCTION
2298 : : !! Splits the number of tasks, ntasks, among nprocs processors.
2299 : : !! Used for the MPI parallelization of simple loops.
2300 : : !!
2301 : : !! INPUTS
2302 : : !! ntasks=number of tasks
2303 : : !! comm=MPI communicator.
2304 : : !!
2305 : : !! OUTPUT
2306 : : !! my_start,my_stop= indices defining the initial and final task for this processor
2307 : : !!
2308 : : !! NOTES
2309 : : !! If nprocs > ntasks then:
2310 : : !!
2311 : : !! my_start = ntasks + 1
2312 : : !! my_stop = ntask
2313 : : !!
2314 : : !! In this particular case, loops of the form
2315 : : !!
2316 : : !! do ii=my_start,my_stop
2317 : : !! ...
2318 : : !! end do
2319 : : !!
2320 : : !! are not executed. Moreover allocation such as foo(my_start:my_stop) will generate a zero-sized array.
2321 : : !!
2322 : : !! SOURCE
2323 : :
2324 : 10548 : subroutine xmpi_split_work_i4b(ntasks, comm, my_start, my_stop)
2325 : :
2326 : : !Arguments ------------------------------------
2327 : : integer,intent(in) :: ntasks,comm
2328 : : integer,intent(out) :: my_start, my_stop
2329 : :
2330 : : !Local variables-------------------------------
2331 : : integer :: res,nprocs,my_rank,block_p1,block
2332 : : ! *************************************************************************
2333 : :
2334 : 10548 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
2335 : :
2336 : 10548 : block = ntasks / nprocs
2337 : 10548 : res = MOD(ntasks, nprocs)
2338 : 10548 : block_p1= block + 1
2339 : :
2340 [ + + ]: 10548 : if (my_rank < res) then
2341 : 60 : my_start = my_rank *block_p1+1
2342 : 60 : my_stop = (my_rank+1)*block_p1
2343 : : else
2344 : 10488 : my_start = res*block_p1 + (my_rank-res )*block + 1
2345 : 10488 : my_stop = res*block_p1 + (my_rank-res+1)*block
2346 : : end if
2347 : :
2348 : 10548 : end subroutine xmpi_split_work_i4b
2349 : : !!***
2350 : :
2351 : : !----------------------------------------------------------------------
2352 : :
2353 : : !!****f* m_xmpi/xmpi_split_block
2354 : : !! NAME
2355 : : !! xmpi_split_block
2356 : : !!
2357 : : !! FUNCTION
2358 : : !! Splits tasks inside communicator using block distribution. Used for the MPI parallelization of simple loops.
2359 : : !!
2360 : : !! INPUTS
2361 : : !! ntasks: number of tasks
2362 : : !! comm: MPI communicator.
2363 : : !!
2364 : : !! OUTPUT
2365 : : !! my_ntasks: Number of tasks received by this rank. May be zero if ntasks > nprocs.
2366 : : !! my_inds(my_ntasks): List of tasks treated by this rank. Allocated by the routine. May be zero-sized.
2367 : : !!
2368 : : !! SOURCE
2369 : :
2370 : 96 : subroutine xmpi_split_block(ntasks, comm, my_ntasks, my_inds)
2371 : :
2372 : : !Arguments ------------------------------------
2373 : : integer,intent(in) :: ntasks, comm
2374 : : integer,intent(out) :: my_ntasks
2375 : : integer,allocatable,intent(out) :: my_inds(:)
2376 : :
2377 : : !Local variables-------------------------------
2378 : : integer :: ii, istart, istop
2379 : : ! *************************************************************************
2380 : :
2381 : 96 : call xmpi_split_work(ntasks, comm, istart, istop)
2382 : 96 : my_ntasks = istop - istart + 1
2383 [ - + + - : 288 : ABI_MALLOC(my_inds, (my_ntasks))
+ - + - -
+ - + -
+ ]
2384 [ + - + - : 12507 : if (my_ntasks > 0) my_inds = [(istart + (ii - 1), ii=1, my_ntasks)]
+ + + - +
+ + - - +
- - + + ]
2385 : :
2386 : 96 : end subroutine xmpi_split_block
2387 : : !!***
2388 : :
2389 : : !----------------------------------------------------------------------
2390 : :
2391 : : !!****f* m_xmpi/xmpi_split_cyclic
2392 : : !! NAME
2393 : : !! xmpi_split_cyclic
2394 : : !!
2395 : : !! FUNCTION
2396 : : !! Splits tasks inside communicator using cyclic distribution.
2397 : : !! Used for the MPI parallelization of simple loops.
2398 : : !!
2399 : : !! INPUTS
2400 : : !! ntasks: number of tasks
2401 : : !! comm: MPI communicator.
2402 : : !!
2403 : : !! OUTPUT
2404 : : !! my_ntasks: Number of tasks received by this rank. May be zero if ntasks > nprocs.
2405 : : !! my_inds(my_ntasks): List of tasks treated by this rank. Allocated by the routine. May be zero-sized.
2406 : : !!
2407 : : !! SOURCE
2408 : :
2409 : 68 : subroutine xmpi_split_cyclic(ntasks, comm, my_ntasks, my_inds)
2410 : :
2411 : : !Arguments ------------------------------------
2412 : : integer,intent(in) :: ntasks, comm
2413 : : integer,intent(out) :: my_ntasks
2414 : : integer,allocatable,intent(out) :: my_inds(:)
2415 : :
2416 : : !Local variables-------------------------------
2417 : : integer :: ii, cnt, itask, my_rank, nprocs
2418 : : ! *************************************************************************
2419 : :
2420 : 68 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
2421 : :
2422 [ + + ]: 204 : do ii=1,2
2423 [ + + ]: 136 : if (ii == 2) then
2424 [ - + + - : 204 : ABI_MALLOC(my_inds, (my_ntasks))
+ - + - -
+ - + -
+ ]
2425 : : end if
2426 : 136 : cnt = 0
2427 [ + + ]: 632 : do itask=1,ntasks
2428 [ + - ]: 632 : if (mod(itask, nprocs) == my_rank) then
2429 : 496 : cnt = cnt + 1
2430 [ + + ]: 496 : if (ii == 2) my_inds(cnt) = itask
2431 : : end if
2432 : : end do
2433 [ + + ]: 204 : if (ii == 1) my_ntasks = cnt
2434 : : end do
2435 : :
2436 : 68 : end subroutine xmpi_split_cyclic
2437 : : !!***
2438 : :
2439 : : !----------------------------------------------------------------------
2440 : :
2441 : : !!****f* m_xmpi/xmpi_split_list
2442 : : !! NAME
2443 : : !! xmpi_split_list
2444 : : !!
2445 : : !! FUNCTION
2446 : : !! Splits list of items inside communicator using block distribution.
2447 : : !! Used for the MPI parallelization of simple loops.
2448 : : !!
2449 : : !! INPUTS
2450 : : !! ntasks:Number of items in list (global)
2451 : : !! list(ntasks): List of indices
2452 : : !! comm: MPI communicator.
2453 : : !!
2454 : : !! OUTPUT
2455 : : !! my_ntasks: Number of tasks received by this rank. May be zero if ntasks > nprocs.
2456 : : !! my_inds(my_ntasks): List of tasks treated by this rank. Allocated by the routine. May be zero-sized.
2457 : : !!
2458 : : !! SOURCE
2459 : :
2460 : 61 : subroutine xmpi_split_list(ntasks, list, comm, my_ntasks, my_inds)
2461 : :
2462 : : !Arguments ------------------------------------
2463 : : integer,intent(in) :: ntasks, comm
2464 : : integer,intent(out) :: my_ntasks
2465 : : integer,intent(in) :: list(ntasks)
2466 : : integer,allocatable,intent(out) :: my_inds(:)
2467 : :
2468 : : !Local variables-------------------------------
2469 : : integer :: my_start, my_stop
2470 : : ! *************************************************************************
2471 : :
2472 : 61 : call xmpi_split_work(ntasks, comm, my_start, my_stop)
2473 : :
2474 : 61 : my_ntasks = my_stop - my_start + 1
2475 : :
2476 [ + - ]: 61 : if (my_stop >= my_start) then
2477 [ - + + - : 183 : ABI_MALLOC(my_inds, (my_ntasks))
+ - + - -
+ - + -
+ ]
2478 [ + - - + : 6326 : my_inds = list(my_start:my_stop)
- - + + ]
2479 : : else
2480 : 0 : my_ntasks = 0
2481 [ # # # # ]: 0 : ABI_MALLOC(my_inds, (0))
2482 : : end if
2483 : :
2484 : 61 : end subroutine xmpi_split_list
2485 : : !!***
2486 : :
2487 : : !----------------------------------------------------------------------
2488 : :
2489 : : !!****f* m_xmpi/xmpi_split_work2_i4b
2490 : : !! NAME
2491 : : !! xmpi_split_work2_i4b
2492 : : !!
2493 : : !! FUNCTION
2494 : : !! Splits a number of tasks, ntasks, among nprocs processors.
2495 : : !! The output arrays istart(1:nprocs) and istop(1:nprocs)
2496 : : !! report the starting and final task index for each CPU.
2497 : : !! Namely CPU with rank ii has to perform all the tasks between
2498 : : !! istart(ii+1) and istop(ii+1). Note the Fortran convention of using 1 as first index of the array.
2499 : : !! Note, moreover, that if a proc has rank > ntasks then:
2500 : : !!
2501 : : !! istart(rank+1)=ntasks+1
2502 : : !! istop(rank+1)=ntask
2503 : : !!
2504 : : !! In this particular case, loops of the form
2505 : : !!
2506 : : !! do ii=istart(rank),istop(rank)
2507 : : !! ...
2508 : : !! end do
2509 : : !!
2510 : : !! are not executed. Moreover allocation such as foo(istart(rank):istop(rank))
2511 : : !! will generate a zero-sized array
2512 : : !!
2513 : : !! INPUTS
2514 : : !! ntasks= number of tasks
2515 : : !! nprocs=Number of processors.
2516 : : !!
2517 : : !! OUTPUT
2518 : : !! istart(nprocs),istop(nprocs)= indices defining the initial and final task for each processor
2519 : : !!
2520 : : !! SOURCE
2521 : :
2522 : 480 : subroutine xmpi_split_work2_i4b(ntasks, nprocs, istart, istop)
2523 : :
2524 : : !Arguments ------------------------------------
2525 : : integer,intent(in) :: ntasks,nprocs
2526 : : integer,intent(inout) :: istart(nprocs), istop(nprocs)
2527 : :
2528 : : !Local variables-------------------------------
2529 : : integer :: res,irank,block,block_tmp
2530 : : ! *************************************************************************
2531 : :
2532 : 480 : block_tmp = ntasks/nprocs
2533 : 480 : res = MOD(ntasks,nprocs)
2534 : 480 : block = block_tmp+1
2535 : :
2536 [ + + ]: 1618 : do irank=0,nprocs-1
2537 [ + + ]: 1618 : if (irank<res) then
2538 : 380 : istart(irank+1) = irank *block+1
2539 : 380 : istop (irank+1) = (irank+1)*block
2540 : : else
2541 : 758 : istart(irank+1) = res*block + (irank-res )*block_tmp+1
2542 : 758 : istop (irank+1) = res*block + (irank-res+1)*block_tmp
2543 : : end if
2544 : : end do
2545 : :
2546 : 480 : end subroutine xmpi_split_work2_i4b
2547 : : !!***
2548 : :
2549 : : !----------------------------------------------------------------------
2550 : :
2551 : : !!****f* m_xmpi/xmpi_split_work2_i8b
2552 : : !! NAME
2553 : : !! xmpi_split_work2_i8b
2554 : : !!
2555 : : !! FUNCTION
2556 : : !! Same as xmpi_split_work2_i8b but accepts 8 bytes integer.
2557 : : !!
2558 : : !! INPUTS
2559 : : !! ntasks= number of tasks
2560 : : !! nprocs=Number of processors.
2561 : : !!
2562 : : !! OUTPUT
2563 : : !! istart(nprocs),istop(nprocs)= indices defining the initial and final task for each processor
2564 : : !!
2565 : : !! SOURCE
2566 : :
2567 : 24 : subroutine xmpi_split_work2_i8b(ntasks,nprocs,istart,istop)
2568 : :
2569 : : !Arguments ------------------------------------
2570 : : integer,intent(in) :: nprocs
2571 : : integer(i8b),intent(in) :: ntasks
2572 : : integer(i8b),intent(inout) :: istart(nprocs),istop(nprocs)
2573 : :
2574 : : !Local variables-------------------------------
2575 : : integer(i8b) :: res,irank,block,block_tmp
2576 : : ! *************************************************************************
2577 : :
2578 : 24 : block_tmp = ntasks/nprocs
2579 : 24 : res = MOD(ntasks,INT(nprocs,KIND=i8b))
2580 : 24 : block = block_tmp+1
2581 : :
2582 [ + + ]: 62 : do irank=0,nprocs-1
2583 [ - + ]: 62 : if (irank<res) then
2584 : 0 : istart(irank+1)= irank *block+1
2585 : 0 : istop (irank+1)=(irank+1)*block
2586 : : else
2587 : 38 : istart(irank+1)=res*block+(irank-res )*block_tmp+1
2588 : 38 : istop (irank+1)=res*block+(irank-res+1)*block_tmp
2589 : : end if
2590 : : end do
2591 : :
2592 : 24 : end subroutine xmpi_split_work2_i8b
2593 : : !!***
2594 : :
2595 : : !----------------------------------------------------------------------
2596 : :
2597 : : !!****f* m_xmpi/xmpi_distab_4D
2598 : : !! NAME
2599 : : !! xmpi_distab_4D
2600 : : !!
2601 : : !! FUNCTION
2602 : : !! Fill table defining the distribution of the tasks according to the number of processors involved in the
2603 : : !! calculation. For each set of indices, the table contains the rank of the node in the MPI communicator.
2604 : : !!
2605 : : !! INPUTS
2606 : : !! nprocs=The number of processors performing the calculation in parallel.
2607 : : !!
2608 : : !! OUTPUT
2609 : : !! task_distrib(:,:,:,:) = Contains the rank of the node that is taking care of this particular set of loop indices.
2610 : : !! Tasks are distributed across the nodes in column-major order.
2611 : : !!
2612 : : !! SOURCE
2613 : :
2614 [ - + ]: 27 : subroutine xmpi_distab_4D(nprocs, task_distrib)
2615 : :
2616 : : !Arguments ------------------------------------
2617 : : integer,intent(in) :: nprocs
2618 : : !arrays
2619 : : integer,intent(inout) :: task_distrib(:,:,:,:)
2620 : :
2621 : : !Local variables ------------------------------
2622 : : !scalars
2623 : : integer :: ii,jj,n1,n2,n3,n4,ntasks,irank,remainder,ntpblock
2624 : : integer,allocatable :: list(:)
2625 : : !************************************************************************
2626 : :
2627 : 27 : n1= SIZE(task_distrib,DIM=1)
2628 : 27 : n2= SIZE(task_distrib,DIM=2)
2629 : 27 : n3= SIZE(task_distrib,DIM=3)
2630 : 27 : n4= SIZE(task_distrib,DIM=4)
2631 : 27 : ntasks = n1*n2*n3*n4
2632 : :
2633 [ - + + - : 81 : ABI_MALLOC(list, (ntasks))
+ - + - -
+ - + ]
2634 [ + + ]: 29915 : list=-999
2635 : :
2636 : 27 : ntpblock = ntasks/nprocs
2637 : 27 : remainder = MOD(ntasks,nprocs)
2638 : :
2639 [ - + ]: 27 : if (ntpblock==0) then ! nprocs > ntasks
2640 [ # # ]: 0 : do ii=1,ntasks
2641 : 0 : list(ii) = ii-1
2642 : : end do
2643 : : else
2644 : 27 : ii=1
2645 [ + + ]: 68 : do irank=nprocs-1,0,-1 ! If remainder/=0, master will get less tasks.
2646 : 41 : jj = ii+ntpblock-1
2647 [ - + ]: 41 : if (remainder>0) then
2648 : 0 : jj=jj+1
2649 : 0 : remainder = remainder-1
2650 : : end if
2651 [ + + ]: 29929 : list(ii:jj)=irank
2652 : 68 : ii=jj+1
2653 : : end do
2654 : : end if
2655 : :
2656 [ + + ]: 135 : task_distrib = RESHAPE(list, [n1,n2,n3,n4])
2657 : :
2658 [ + + + + : 35893 : if (ANY(task_distrib==-999)) call xmpi_abort(msg="task_distrib == -999")
+ + + + +
- - + ]
2659 : :
2660 [ - + ]: 27 : ABI_FREE(list)
2661 : :
2662 : 27 : end subroutine xmpi_distab_4D
2663 : : !!***
2664 : :
2665 : : !----------------------------------------------------------------------
2666 : :
2667 : : !!****f* m_xmpi/xmpi_distrib_with_replicas
2668 : : !! NAME
2669 : : !! xmpi_distrib_with_replicas
2670 : : !!
2671 : : !! FUNCTION
2672 : : !! This function distributes the i-th task `itask` among `nprocs` inside a MPI communicator.
2673 : : !! If nprocs > ntasks, multiple MPI ranks will be assigned to a given task.
2674 : : !!
2675 : : !! INPUTS
2676 : : !! itask=Index of the task (must be <= ntasks)
2677 : : !! ntasks= number of tasks
2678 : : !! rank=MPI Rank of this processor in the MPI communicator.
2679 : : !! nprocs=Number of processors in the MPI communicator.
2680 : : !!
2681 : : !! OUTPUT
2682 : : !! True if this node will treat itask (replicas are possible if nprocs > ntasks)
2683 : : !!
2684 : : !! SOURCE
2685 : :
2686 : 5081 : pure logical function xmpi_distrib_with_replicas(itask, ntasks, rank, nprocs) result(bool)
2687 : :
2688 : : !Arguments ------------------------------------
2689 : : integer,intent(in) :: itask,rank,nprocs,ntasks
2690 : :
2691 : : !Local variables-------------------------------
2692 : : integer :: ii,mnp_pool,rk_base
2693 : : ! *************************************************************************
2694 : :
2695 : : ! If the number of processors is less than ntasks, we have max one processor per task
2696 : : ! else we replicate the tasks inside a pool of max size mnp_pool
2697 [ + - ]: 5081 : if (nprocs <= ntasks) then
2698 : 5081 : bool = modulo(itask - 1, nprocs) == rank
2699 : : else
2700 : 0 : mnp_pool = (nprocs / ntasks)
2701 : : !write(std_out,*)"Will duplicate itask, mnp_pool", mnp_pool, "nprocs, ntasks", nprocs, ntasks
2702 : :
2703 : 0 : rk_base = modulo(itask - 1, nprocs)
2704 : 0 : bool = .False.
2705 [ # # ]: 0 : do ii=1,mnp_pool+1
2706 [ # # ]: 0 : if (rank == rk_base + (ii - 1) * ntasks) then
2707 : : bool = .True.; exit
2708 : : end if
2709 : : end do
2710 : : end if
2711 : :
2712 : 5081 : end function xmpi_distrib_with_replicas
2713 : : !!***
2714 : :
2715 : : !----------------------------------------------------------------------
2716 : :
2717 : : !!****f* m_xmpi/xmpi_largetype_create
2718 : : !! NAME
2719 : : !! xmpi_largetype_create
2720 : : !!
2721 : : !! FUNCTION
2722 : : !! This function builds a large-count contiguous datatype made of "small" adjacent
2723 : : !! chunks (of same original type). The new type can then be used in MPI
2724 : : !! routines when the number of elements to communicate exceeds a 32bit integer.
2725 : : !!
2726 : : !! INPUTS
2727 : : !! largecount= total number of elements expressed as a 64bit integer
2728 : : !! inputtype= (INTEGER) input type (typically INTEGER, REAL(dp), ...)
2729 : : !! op_type= type of operation that will be applied during collective comms
2730 : : !! At present, MPI_SUM, MPI_LOR, MPI_LAND are implemented
2731 : : !!
2732 : : !! OUTPUT
2733 : : !! largetype= (INTEGER) new MPI type made of a serie of adjacent chunks
2734 : : !! largetype_op= (INTEGER) MPI user-defined operation associated to largetype type
2735 : : !!
2736 : : !! NOTE
2737 : : !! This routine is partially inspired by https://github.com/jeffhammond/BigMPI
2738 : : !! See: J.R. Hammond. A. Schafer, R. Latham,
2739 : : !! "ToINT_MAX. . . and beyond. Exploring large-count support in MPI",
2740 : : !! 2014 Workshop on Exascale MPI at Supercomputing Conference
2741 : : !! MIT License (MIT)
2742 : : !! Permission is hereby granted, free of charge, to any person obtaining a copy
2743 : : !! of this software and associated documentation files (the "Software"), to deal
2744 : : !! in the Software without restriction, including without limitation the rights
2745 : : !! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
2746 : : !! copies of the Software, and to permit persons to whom the Software is
2747 : : !! furnished to do so.
2748 : : !!
2749 : : !! From MPI4 specification, this routine is useless as large-count MPI communications
2750 : : !! can be called with the use of the MPI_count datatype (instead of INTEGER).
2751 : : !!
2752 : : !! SOURCE
2753 : :
2754 : 0 : subroutine xmpi_largetype_create(largecount,inputtype,largetype,largetype_op,op_type)
2755 : :
2756 : : !Arguments ------------------------------------
2757 : : !scalars
2758 : : integer(KIND=int64),intent(in) :: largecount
2759 : : integer,intent(in) :: inputtype,op_type
2760 : : integer,intent(out) :: largetype,largetype_op
2761 : :
2762 : : !Local variables-------------------------------
2763 : : #ifdef HAVE_MPI
2764 : : !scalars
2765 : : integer,parameter :: INT_MAX=max(1,xmpi_maxint32/2)
2766 : : integer(KIND=int32) :: cc,rr,ierr
2767 : : integer(KIND=XMPI_ADDRESS_KIND) :: extent,lb,remdisp
2768 : : integer :: chunks,remainder
2769 : : !arrays
2770 : : integer(KIND=int32) :: blklens(2)
2771 : : integer(KIND=XMPI_ADDRESS_KIND) :: disps(2)
2772 : : integer :: types(2)
2773 : : #endif
2774 : : ! *************************************************************************
2775 : :
2776 : : #ifdef HAVE_MPI
2777 : : if (XMPI_ADDRESS_KIND<int64) call xmpi_abort(msg="Too much data to communicate for this architecture!")
2778 : :
2779 : : !Divide data in chunks
2780 : 0 : cc=int(largecount/INT_MAX,kind=int32)
2781 : 0 : rr=int(largecount-cc*INT_MAX,kind=int32)
2782 : :
2783 : : !Create user-defined datatype
2784 [ # # ]: 0 : if (rr==0) then
2785 : 0 : call MPI_TYPE_VECTOR(cc,INT_MAX,INT_MAX,inputtype,largetype,ierr)
2786 [ # # ]: 0 : if (ierr==0) call MPI_TYPE_COMMIT(largetype,ierr)
2787 : : else
2788 : 0 : call MPI_TYPE_VECTOR(cc,INT_MAX,INT_MAX,inputtype,chunks,ierr)
2789 : 0 : call MPI_TYPE_CONTIGUOUS(rr,inputtype,remainder,ierr)
2790 [ # # ]: 0 : if (ierr==0) then
2791 : 0 : call MPI_TYPE_GET_EXTENT(inputtype,lb,extent,ierr)
2792 : 0 : remdisp=cc*INT_MAX*extent
2793 [ # # ]: 0 : blklens(1:2)=1
2794 : 0 : disps(1)=0;disps(2)=remdisp
2795 : 0 : types(1)=chunks;types(2)=remainder
2796 : : #ifdef HAVE_MPI_TYPE_CREATE_STRUCT
2797 : 0 : call MPI_TYPE_CREATE_STRUCT(2,blklens,disps,types,largetype,ierr)
2798 : : #else
2799 : : call MPI_TYPE_STRUCT(2,blklens,disps,types,largetype,ierr)
2800 : : #endif
2801 [ # # ]: 0 : if (ierr==0) then
2802 : 0 : call MPI_TYPE_COMMIT(largetype,ierr)
2803 : 0 : call MPI_TYPE_FREE(chunks,ierr)
2804 : 0 : call MPI_TYPE_FREE(remainder,ierr)
2805 : : end if
2806 : : end if
2807 : : end if
2808 [ # # ]: 0 : if (ierr/=0) call xmpi_abort(msg="Cannot remove ABI_MPIABORTFILE")
2809 : :
2810 : : !Associate user-defined MPI operation
2811 : 0 : xmpi_largetype_size=largecount ; largetype_op=-1111
2812 [ # # ]: 0 : if (op_type==MPI_SUM) then
2813 : 0 : select case(inputtype)
2814 : : case(MPI_INTEGER)
2815 : 0 : call MPI_OP_CREATE(largetype_sum_int ,.true.,largetype_op,ierr)
2816 : : case(MPI_REAL)
2817 : 0 : call MPI_OP_CREATE(largetype_sum_real ,.true.,largetype_op,ierr)
2818 : : case(MPI_DOUBLE_PRECISION)
2819 : 0 : call MPI_OP_CREATE(largetype_sum_dble ,.true.,largetype_op,ierr)
2820 : : case(MPI_COMPLEX)
2821 : 0 : call MPI_OP_CREATE(largetype_sum_cplx ,.true.,largetype_op,ierr)
2822 : : case(MPI_DOUBLE_COMPLEX)
2823 [ # # # # : 0 : call MPI_OP_CREATE(largetype_sum_dcplx,.true.,largetype_op,ierr)
# # ]
2824 : : end select
2825 [ # # ]: 0 : else if (op_type==MPI_LOR) then
2826 : 0 : select case(inputtype)
2827 : : case(MPI_LOGICAL)
2828 [ # # ]: 0 : call MPI_OP_CREATE(largetype_lor_log,.true.,largetype_op,ierr)
2829 : : end select
2830 [ # # ]: 0 : else if (op_type==MPI_LAND) then
2831 : 0 : select case(inputtype)
2832 : : case(MPI_LOGICAL)
2833 [ # # ]: 0 : call MPI_OP_CREATE(largetype_land_log,.true.,largetype_op,ierr)
2834 : : end select
2835 : : else if (op_type==MPI_OP_NULL) then
2836 : : largetype_op=-1111
2837 : : end if
2838 : : #else
2839 : : ABI_UNUSED(largecount)
2840 : : ABI_UNUSED(inputtype)
2841 : : ABI_UNUSED(largetype)
2842 : : ABI_UNUSED(largetype_op)
2843 : : ABI_UNUSED(op_type)
2844 : : #endif
2845 : :
2846 : 0 : end subroutine xmpi_largetype_create
2847 : : !!***
2848 : :
2849 : : !--------------------------------------
2850 : :
2851 : : !!****f* m_xmpi/largetype_sum_int
2852 : : !! NAME
2853 : : !! largetype_sum_int
2854 : : !!
2855 : : !! FUNCTION
2856 : : !! Routine used to overload MPI_SUM for integers
2857 : :
2858 : 0 : subroutine largetype_sum_int(invec,inoutvec,len,datatype)
2859 : : integer :: len,datatype
2860 : : integer :: invec(len*xmpi_largetype_size),inoutvec(len*xmpi_largetype_size)
2861 : : integer(KIND=int64) :: ii,jj,kk
2862 : 0 : kk=0
2863 [ # # ]: 0 : do ii=1,len
2864 [ # # ]: 0 : do jj=1,xmpi_largetype_size
2865 : 0 : kk=kk+1
2866 : 0 : inoutvec(kk)=inoutvec(kk)+invec(kk)
2867 : : end do
2868 : : end do
2869 : : ! this macro is being used befor m_errors is compiled, so work around it
2870 : : ! ABI_UNUSED(datatype)
2871 : : if (.FALSE.) write(std_out,*) datatype
2872 : 0 : end subroutine largetype_sum_int
2873 : : !!***
2874 : :
2875 : : !--------------------------------------
2876 : :
2877 : : !!****f* m_xmpi/largetype_sum_real
2878 : : !! NAME
2879 : : !! largetype_sum_real
2880 : : !!
2881 : : !! FUNCTION
2882 : : !! Routine used to overload MPI_SUM for reals
2883 : :
2884 : 0 : subroutine largetype_sum_real(invec,inoutvec,len,datatype)
2885 : : integer :: len,datatype
2886 : : real(sp) :: invec(len*xmpi_largetype_size),inoutvec(len*xmpi_largetype_size)
2887 : : integer(KIND=int64) :: ii,jj,kk
2888 : 0 : kk=0
2889 [ # # ]: 0 : do ii=1,len
2890 [ # # ]: 0 : do jj=1,xmpi_largetype_size
2891 : 0 : kk=kk+1
2892 : 0 : inoutvec(kk)=inoutvec(kk)+invec(kk)
2893 : : end do
2894 : : end do
2895 : : ! this macro is being used befor m_errors is compiled, so work around it
2896 : : ! ABI_UNUSED(datatype)
2897 : : if (.FALSE.) write(std_out,*) datatype
2898 : 0 : end subroutine largetype_sum_real
2899 : : !!***
2900 : :
2901 : : !--------------------------------------
2902 : :
2903 : : !!****f* m_xmpi/largetype_sum_dble
2904 : : !! NAME
2905 : : !! largetype_sum_dble
2906 : : !!
2907 : : !! FUNCTION
2908 : : !! Routine used to overload MPI_SUM for double precision reals
2909 : :
2910 : 0 : subroutine largetype_sum_dble(invec,inoutvec,len,datatype)
2911 : : integer :: len,datatype
2912 : : real(dp) :: invec(len*xmpi_largetype_size),inoutvec(len*xmpi_largetype_size)
2913 : : integer(KIND=int64) :: ii,jj,kk
2914 : 0 : kk=0
2915 [ # # ]: 0 : do ii=1,len
2916 [ # # ]: 0 : do jj=1,xmpi_largetype_size
2917 : 0 : kk=kk+1
2918 : 0 : inoutvec(kk)=inoutvec(kk)+invec(kk)
2919 : : end do
2920 : : end do
2921 : : ! this macro is being used befor m_errors is compiled, so work around it
2922 : : ! ABI_UNUSED(datatype)
2923 : : if (.FALSE.) write(std_out,*) datatype
2924 : 0 : end subroutine largetype_sum_dble
2925 : : !!***
2926 : :
2927 : : !--------------------------------------
2928 : :
2929 : : !!****f* m_xmpi/largetype_sum_cplx
2930 : : !! NAME
2931 : : !! largetype_sum_cplx
2932 : : !!
2933 : : !! FUNCTION
2934 : : !! Routine used to overload MPI_SUM for complex
2935 : :
2936 : 0 : subroutine largetype_sum_cplx(invec,inoutvec,len,datatype)
2937 : : integer :: len,datatype
2938 : : complex(sp) :: invec(len*xmpi_largetype_size),inoutvec(len*xmpi_largetype_size)
2939 : : integer(KIND=int64) :: ii,jj,kk
2940 : 0 : kk=0
2941 [ # # ]: 0 : do ii=1,len
2942 [ # # ]: 0 : do jj=1,xmpi_largetype_size
2943 : 0 : kk=kk+1
2944 : 0 : inoutvec(kk)=inoutvec(kk)+invec(kk)
2945 : : end do
2946 : : end do
2947 : : ! this macro is being used befor m_errors is compiled, so work around it
2948 : : ! ABI_UNUSED(datatype)
2949 : : if (.FALSE.) write(std_out,*) datatype
2950 : 0 : end subroutine largetype_sum_cplx
2951 : : !!***
2952 : :
2953 : : !--------------------------------------
2954 : :
2955 : : !!****f* m_xmpi/largetype_sum_dcplx
2956 : : !! NAME
2957 : : !! largetype_sum_dcplx
2958 : : !!
2959 : : !! FUNCTION
2960 : : !! Routine used to overload MPI_SUM for double complex
2961 : :
2962 : 0 : subroutine largetype_sum_dcplx(invec,inoutvec,len,datatype)
2963 : : integer :: len,datatype
2964 : : complex(dp) :: invec(len*xmpi_largetype_size),inoutvec(len*xmpi_largetype_size)
2965 : : integer(KIND=int64) :: ii,jj,kk
2966 : 0 : kk=0
2967 [ # # ]: 0 : do ii=1,len
2968 [ # # ]: 0 : do jj=1,xmpi_largetype_size
2969 : 0 : kk=kk+1
2970 : 0 : inoutvec(kk)=inoutvec(kk)+invec(kk)
2971 : : end do
2972 : : end do
2973 : : ! this macro is being used befor m_errors is compiled, so work around it
2974 : : ! ABI_UNUSED(datatype)
2975 : : if (.FALSE.) write(std_out,*) datatype
2976 : 0 : end subroutine largetype_sum_dcplx
2977 : : !!***
2978 : :
2979 : : !--------------------------------------
2980 : :
2981 : : !!****f* m_xmpi/largetype_lor_log
2982 : : !! NAME
2983 : : !! largetype_lor_log
2984 : : !!
2985 : : !! FUNCTION
2986 : : !! Routine used to overload MPI_LOR for logicals
2987 : :
2988 : 0 : subroutine largetype_lor_log(invec,inoutvec,len,datatype)
2989 : : integer :: len,datatype
2990 : : logical :: invec(len*xmpi_largetype_size),inoutvec(len*xmpi_largetype_size)
2991 : : integer(KIND=int64) :: ii,jj,kk
2992 : 0 : kk=0
2993 [ # # ]: 0 : do ii=1,len
2994 [ # # ]: 0 : do jj=1,xmpi_largetype_size
2995 : 0 : kk=kk+1
2996 [ # # # # ]: 0 : inoutvec(kk)=inoutvec(kk).or.invec(kk)
2997 : : end do
2998 : : end do
2999 : : ! this macro is being used befor m_errors is compiled, so work around it
3000 : : ! ABI_UNUSED(datatype)
3001 : : if (.FALSE.) write(std_out,*) datatype
3002 : 0 : end subroutine largetype_lor_log
3003 : : !!***
3004 : :
3005 : : !--------------------------------------
3006 : :
3007 : : !!****f* m_xmpi/largetype_land_log
3008 : : !! NAME
3009 : : !! largetype_land_log
3010 : : !!
3011 : : !! FUNCTION
3012 : : !! Routine used to overload MPI_LANG for logicals
3013 : :
3014 : 0 : subroutine largetype_land_log(invec,inoutvec,len,datatype)
3015 : : integer :: len,datatype
3016 : : logical :: invec(len*xmpi_largetype_size),inoutvec(len*xmpi_largetype_size)
3017 : : integer(KIND=int64) :: ii,jj,kk
3018 : 0 : kk=0
3019 [ # # ]: 0 : do ii=1,len
3020 [ # # ]: 0 : do jj=1,xmpi_largetype_size
3021 : 0 : kk=kk+1
3022 [ # # # # ]: 0 : inoutvec(kk)=inoutvec(kk).and.invec(kk)
3023 : : end do
3024 : : end do
3025 : : ! this macro is being used befor m_errors is compiled, so work around it
3026 : : ! ABI_UNUSED(datatype)
3027 : : if (.FALSE.) write(std_out,*) datatype
3028 : 0 : end subroutine largetype_land_log
3029 : : !!***
3030 : :
3031 : : !----------------------------------------------------------------------
3032 : :
3033 : : !!****f* m_xmpi/xmpi_largetype_free
3034 : : !! NAME
3035 : : !! xmpi_largetype_free
3036 : : !!
3037 : : !! FUNCTION
3038 : : !! This function release a large-count contiguous datatype.
3039 : : !!
3040 : : !! SIDE EFFECTS
3041 : : !! largetype= (INTEGER) MPI type to release
3042 : : !! largetype_op= (INTEGER) MPI user-defined operation associated to largetype type
3043 : : !!
3044 : : !! SOURCE
3045 : :
3046 : 0 : subroutine xmpi_largetype_free(largetype,largetype_op)
3047 : :
3048 : : !Arguments ------------------------------------
3049 : : !scalars
3050 : : integer,intent(inout) :: largetype,largetype_op
3051 : : !Local variables-------------------------------
3052 : : #ifdef HAVE_MPI
3053 : : integer :: ierr
3054 : : #endif
3055 : : ! *************************************************************************
3056 : :
3057 : : #ifdef HAVE_MPI
3058 : 0 : xmpi_largetype_size=0
3059 [ # # ]: 0 : if (largetype_op/=-1111) call MPI_OP_FREE(largetype_op,ierr)
3060 : 0 : call MPI_TYPE_FREE(largetype,ierr)
3061 : : #else
3062 : : ABI_UNUSED(largetype)
3063 : : ABI_UNUSED(largetype_op)
3064 : : #endif
3065 : :
3066 : 0 : end subroutine xmpi_largetype_free
3067 : : !!***
3068 : :
3069 : : !----------------------------------------------------------------------
3070 : :
3071 : : ! Include files providing wrappers for some of the most commonly used MPI primitives.
3072 : :
3073 : : #include "xmpi_iallgather.finc"
3074 : : #include "xmpi_allgather.finc"
3075 : : #include "xmpi_allgatherv.finc"
3076 : : #include "xmpi_alltoall.finc"
3077 : : #include "xmpi_ialltoall.finc"
3078 : : #include "xmpi_alltoallv.finc"
3079 : : #include "xmpi_ialltoallv.finc"
3080 : : #include "xmpi_bcast.finc"
3081 : : #include "xmpi_ibcast.finc"
3082 : : #include "xmpi_exch.finc"
3083 : : #include "xmpi_gather.finc"
3084 : : #include "xmpi_gatherv.finc"
3085 : : #include "xmpi_max.finc"
3086 : : #include "xmpi_min.finc"
3087 : : #include "xmpi_recv.finc"
3088 : : #include "xmpi_irecv.finc"
3089 : : #include "xmpi_scatterv.finc"
3090 : : #include "xmpi_send.finc"
3091 : : #include "xmpi_isend.finc"
3092 : : #include "xmpi_sum_master.finc"
3093 : : #include "xmpi_sum.finc"
3094 : : #include "xmpi_isum.finc"
3095 : : #include "xmpi_land_lor.finc"
3096 : :
3097 : : !------------------------------------------------------------------------------------
3098 : :
3099 : : !!****f* m_xmpi/xmpio_type_struct
3100 : : !! NAME
3101 : : !! xmpio_type_struct
3102 : : !!
3103 : : !! FUNCTION
3104 : : !! Some highly non-standard MPI implementations support MPI-IO without
3105 : : !! implementing the full set of MPI-2 extensions.
3106 : : !! This wrapper will call the obsolete MPI_TYPE_STRUCT if MPI_TYPE_CREATE_STRUCT
3107 : : !! is not supported. Note that MPI_TYPE_STRUCT requires the displacement arrays
3108 : : !! to be an array of default integers whereas the argument block_displ is an array of kind XMPI_ADDRESS_KIND.
3109 : : !! The routine will abort if the displacement cannot be represented with a default integer.
3110 : : !!
3111 : : !! INPUTS
3112 : : !! ncount= number of blocks (integer) --- also number of entries in arrays
3113 : : !! array_of_types, array_of_displacements and array_of_blocklengths
3114 : : !! array_of_blocklength(ncount)=number of elements in each block (array of integer)
3115 : : !! array_of_displacements(ncount)=byte displacement of each block (array of integer)
3116 : : !! array_of_types(ncount)=type of elements in each block (array of handles to datatype objects)
3117 : : !!
3118 : : !! OUTPUT
3119 : : !! new_type=new datatype (handle)
3120 : : !! mpierr=MPI status error
3121 : : !!
3122 : : !! SOURCE
3123 : :
3124 : : #ifdef HAVE_MPI_IO
3125 : :
3126 : 179 : subroutine xmpio_type_struct(ncount, block_length, block_displ, block_type, new_type, mpierr)
3127 : :
3128 : : !Arguments ------------------------------------
3129 : : !scalars
3130 : : integer,intent(in) :: ncount
3131 : : integer,intent(out) :: new_type,mpierr
3132 : : !arrays
3133 : : integer,intent(in) :: block_length(ncount),block_type(ncount)
3134 : : integer(XMPI_ADDRESS_KIND),intent(in) :: block_displ(ncount)
3135 : :
3136 : : !Local variables-------------------
3137 : : #ifndef HAVE_MPI_TYPE_CREATE_STRUCT
3138 : : integer,allocatable :: tmp_displ(:)
3139 : : #endif
3140 : : !************************************************************************
3141 : :
3142 : : #ifdef HAVE_MPI_TYPE_CREATE_STRUCT
3143 : 174 : call MPI_TYPE_CREATE_STRUCT(ncount,block_length,block_displ,block_type,new_type,mpierr)
3144 : : #else
3145 : :
3146 : : ABI_MALLOC(tmp_displ,(ncount))
3147 : : tmp_displ = block_displ
3148 : : if (ANY(block_displ > HUGE(tmp_displ(1)) ))then
3149 : : call xmpi_abort(msg=" byte displacement cannot be represented with a default integer")
3150 : : end if
3151 : :
3152 : : call MPI_TYPE_STRUCT(ncount,block_length,block_displ,block_type,new_type,mpierr)
3153 : : ABI_FREE(tmp_displ)
3154 : : #endif
3155 : :
3156 : 174 : end subroutine xmpio_type_struct
3157 : : !!***
3158 : :
3159 : : #endif
3160 : :
3161 : : !----------------------------------------------------------------------
3162 : :
3163 : : !!****f* m_xmpi/xmpio_get_info_frm
3164 : : !! NAME
3165 : : !! xmpio_marker_info
3166 : : !!
3167 : : !! FUNCTION
3168 : : !! Return the byte size of the Fortran record and its corresponding MPI_type (compiler-dependent).
3169 : : !! These two values are needed to access sequential binary Fortran files with MPI/IO routines where
3170 : : !! C-streams are used.
3171 : : !!
3172 : : !! INPUTS
3173 : : !! comm=MPI communicator. Only master will find the values for the record marker. The results
3174 : : !! are then broadcast to all the other nodes in comm.
3175 : : !!
3176 : : !! OUTPUT
3177 : : !! bsize_frm=Byte size of the Fortran record marker.
3178 : : !! mpi_type_frm=MPI type of the marker.
3179 : : !!
3180 : : !! SOURCE
3181 : :
3182 : 0 : subroutine xmpio_get_info_frm(bsize_frm, mpi_type_frm, comm)
3183 : :
3184 : : !Arguments ------------------------------------
3185 : : !scalars
3186 : : integer,intent(in) :: comm
3187 : : integer,intent(out) :: mpi_type_frm,bsize_frm
3188 : :
3189 : : !Local variables-------------------------------
3190 : : integer :: my_rank
3191 : : #ifdef HAVE_MPI_IO
3192 : : !scalars
3193 : : integer,parameter :: master=0
3194 : : integer :: spt,ept,ii
3195 : : integer :: f90_unt,iimax,mpio_fh,bsize_int,mpierr
3196 : : integer(XMPI_OFFSET_KIND) :: offset,rml
3197 : : character(len=fnlen) :: fname
3198 : : character(len=500) :: errmsg
3199 : : logical :: file_exists
3200 : : !arrays
3201 : : integer :: xvals(2),ivals(100),read_5ivals(5),ref_5ivals(5)
3202 : : integer :: rm_lengths(4)=(/4,8,2,16/)
3203 : : integer :: statux(MPI_STATUS_SIZE)
3204 : : real(dp) :: xrand(fnlen)
3205 : : #endif
3206 : : !************************************************************************
3207 : :
3208 : 0 : bsize_frm=0; mpi_type_frm=0
3209 : :
3210 : 0 : my_rank = xmpi_comm_rank(comm) !; RETURN
3211 : :
3212 : : #ifdef HAVE_MPI_IO
3213 [ # # ]: 0 : if ( my_rank == master ) then
3214 : : ! Fortran scratch files cannot have a name so have to generate a random one.
3215 : : ! cannot use pick_aname since it is higher level.
3216 : 0 : fname = "__MPI_IO_FRM__"
3217 : 0 : spt=LEN(trim(fname))+1; ept=spt
3218 : :
3219 : 0 : inquire(file=trim(fname),exist=file_exists)
3220 : :
3221 [ # # ]: 0 : do while (file_exists)
3222 : 0 : call RANDOM_NUMBER(xrand(spt:ept))
3223 [ # # ]: 0 : xrand(spt:ept) = 64+xrand(spt:ept)*26
3224 [ # # ]: 0 : do ii=spt,ept
3225 : 0 : fname(ii:ii) = ACHAR(NINT(xrand(ii)))
3226 : : end do
3227 : 0 : ept = MIN(ept+1,fnlen)
3228 : 0 : inquire(file=trim(fname),exist=file_exists)
3229 : : end do
3230 : : !
3231 : : ! Write five integers on the binary file open in Fortran mode, then try
3232 : : ! to reread the values with MPI-IO using different offsets for the record marker.
3233 : : !
3234 : 0 : f90_unt = xmpi_get_unit()
3235 [ # # ]: 0 : if (f90_unt == -1) call xmpi_abort(msg="Cannot find free unit!!")
3236 : : ! MT dec 2013: suppress the new attribute: often cause unwanted errors
3237 : : ! and theoretically useless because of the previous inquire
3238 [ # # ]: 0 : open(unit=f90_unt,file=trim(fname),form="unformatted",err=10, iomsg=errmsg)
3239 : :
3240 : 0 : ref_5ivals = (/(ii, ii=5,9)/)
3241 [ # # # # ]: 0 : ivals = HUGE(1); ivals(5:9)=ref_5ivals
3242 [ # # ]: 0 : write(f90_unt, err=10, iomsg=errmsg) ivals
3243 [ # # ]: 0 : close(f90_unt, err=10, iomsg=errmsg)
3244 : :
3245 [ # # ]: 0 : call MPI_FILE_OPEN(xmpi_comm_self, trim(fname), MPI_MODE_RDONLY, MPI_INFO_NULL, mpio_fh,mpierr)
3246 : :
3247 : : iimax=3 ! Define number of INTEGER types to be tested
3248 : : #ifdef HAVE_FC_INT_QUAD
3249 : 0 : iimax=4
3250 : : #endif
3251 : : !
3252 : : ! Try to read ivals(5:9) from file.
3253 : 0 : ii=0; bsize_frm=-1
3254 : 0 : call MPI_TYPE_SIZE(MPI_INTEGER,bsize_int,mpierr)
3255 : :
3256 [ # # # # ]: 0 : do while (bsize_frm<=0 .and. ii<iimax)
3257 : 0 : ii=ii+1
3258 : 0 : rml = rm_lengths(ii)
3259 : 0 : offset = rml + 4 * bsize_int
3260 : 0 : call MPI_FILE_READ_AT(mpio_fh,offset,read_5ivals,5,MPI_INTEGER,statux,mpierr)
3261 : : !write(std_out,*)read_5ivals
3262 [ # # # # : 0 : if (mpierr==MPI_SUCCESS .and. ALL(read_5ivals==ref_5ivals) ) bsize_frm=rml
# # # # ]
3263 : : end do
3264 : :
3265 [ # # # # ]: 0 : if (ii==iimax.and.bsize_frm<=0) then
3266 : : write(std_out,'(7a)') &
3267 : 0 : 'Error during FORTRAN file record marker detection:',ch10,&
3268 : 0 : 'It was not possible to read/write a small file!',ch10,&
3269 : 0 : 'ACTION: check your access permissions to the file system.',ch10,&
3270 : 0 : 'Common sources of this problem: quota limit exceeded, R/W incorrect permissions, ...'
3271 : 0 : call xmpi_abort()
3272 : : else
3273 : : !write(std_out,'(a,i0)')' Detected FORTRAN record mark length: ',bsize_frm
3274 : : end if
3275 : :
3276 : 0 : call MPI_FILE_CLOSE(mpio_fh, mpierr)
3277 : : !
3278 : : ! Select MPI datatype corresponding to the Fortran marker.
3279 : 0 : SELECT CASE (bsize_frm)
3280 : : CASE (4)
3281 : 0 : mpi_type_frm=MPI_INTEGER4
3282 : : CASE (8)
3283 : 0 : mpi_type_frm=MPI_INTEGER8
3284 : : #if defined HAVE_FC_INT_QUAD && defined HAVE_MPI_INTEGER16
3285 : : CASE (16)
3286 : 0 : mpi_type_frm=MPI_INTEGER16
3287 : : #endif
3288 : : CASE (2)
3289 : 0 : mpi_type_frm=MPI_INTEGER2
3290 : : CASE DEFAULT
3291 : 0 : write(std_out,'(a,i0)')" Wrong bsize_frm: ",bsize_frm
3292 [ # # # # : 0 : call xmpi_abort()
# ]
3293 : : END SELECT
3294 : :
3295 [ # # ]: 0 : open(unit=f90_unt,file=trim(fname), err=10, iomsg=errmsg)
3296 [ # # ]: 0 : close(f90_unt,status="delete", err=10, iomsg=errmsg)
3297 : : end if
3298 : : !
3299 : : ! Broadcast data.
3300 [ # # ]: 0 : xvals = (/bsize_frm,mpi_type_frm/)
3301 : 0 : call xmpi_bcast(xvals,master,comm,mpierr)
3302 : :
3303 : 0 : bsize_frm = xvals(1)
3304 : 0 : mpi_type_frm = xvals(2)
3305 : :
3306 : 0 : return
3307 : :
3308 : : !HANDLE IO ERROR
3309 : : 10 continue
3310 : 0 : call xmpi_abort(msg=errmsg)
3311 : : #endif
3312 : :
3313 : : end subroutine xmpio_get_info_frm
3314 : : !!***
3315 : :
3316 : : !----------------------------------------------------------------------
3317 : :
3318 : : !!****f* m_wffile/xmpio_read_frm
3319 : : !! NAME
3320 : : !! xmpio_read_frm
3321 : : !!
3322 : : !! FUNCTION
3323 : : !! Read the content of a single record marker in a FORTRAN file at a given offset using MPI-IO.
3324 : : !! the file pointer is modified according to the value of advance.
3325 : : !!
3326 : : !! INPUTS
3327 : : !! fh=MPI-IO file handler.
3328 : : !! sc_mode=
3329 : : !! xmpio_single ==> for reading by current proc.
3330 : : !! xmpio_collective ==> for collective reading.
3331 : : !! offset=MPI/IO file pointer
3332 : : !! [advance]=By default the routine will move the file pointer to the next record.
3333 : : !! advance=.FALSE. can be used so that the next read will continue picking information
3334 : : !! off of the currect record.
3335 : : !!
3336 : : !! OUTPUT
3337 : : !! fmarker=Content of the Fortran record marker.
3338 : : !! mpierr= MPI error code
3339 : : !!
3340 : : !! SIDE EFFECTS
3341 : : !! offset=
3342 : : !! input: file pointer used to access the Fortran marker.
3343 : : !! output: new offset updated after the reading, depending on advance.
3344 : : !!
3345 : : !! SOURCE
3346 : :
3347 : : #ifdef HAVE_MPI_IO
3348 : :
3349 : 1042 : subroutine xmpio_read_frm(fh, offset, sc_mode, fmarker, mpierr, advance)
3350 : :
3351 : : !Arguments ------------------------------------
3352 : : !scalars
3353 : : integer,intent(in) :: fh,sc_mode
3354 : : integer(XMPI_OFFSET_KIND),intent(inout) :: offset
3355 : : integer(XMPI_OFFSET_KIND),intent(out) :: fmarker
3356 : : integer,intent(out) :: mpierr
3357 : : logical,optional,intent(in) :: advance
3358 : :
3359 : : !Local variables-------------------------------
3360 : : !scalars
3361 : : integer :: bsize_frm,mpi_type_frm,myfh
3362 : : integer(kind=int16) :: delim_record2(1)
3363 : : integer(kind=int32) :: delim_record4(1)
3364 : : integer(kind=int64) :: delim_record8(1)
3365 : : #if defined HAVE_FC_INT_QUAD
3366 : : integer*16 :: delim_record16(1)
3367 : : #endif
3368 : : character(len=500) :: msg
3369 : : !arrays
3370 : : integer :: statux(MPI_STATUS_SIZE)
3371 : : !************************************************************************
3372 : :
3373 : : !Workaround for XLF.
3374 : 1042 : myfh = fh
3375 : :
3376 : 1042 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
3377 : 1042 : mpi_type_frm = xmpio_mpi_type_frm ! MPI type of the record marker.
3378 : :
3379 : 2084 : SELECT CASE (sc_mode)
3380 : :
3381 : : CASE (xmpio_single)
3382 : :
3383 [ + - ]: 1042 : if (bsize_frm==4) then
3384 : 1042 : call MPI_FILE_READ_AT(myfh,offset,delim_record4,1,mpi_type_frm,statux,mpierr)
3385 : 1042 : fmarker = delim_record4(1)
3386 [ # # ]: 0 : else if (bsize_frm==8) then
3387 : 0 : call MPI_FILE_READ_AT(myfh,offset,delim_record8,1,mpi_type_frm,statux,mpierr)
3388 : 0 : fmarker = delim_record8(1)
3389 : : #if defined HAVE_FC_INT_QUAD
3390 [ # # ]: 0 : else if (bsize_frm==16) then
3391 : 0 : call MPI_FILE_READ_AT(myfh,offset,delim_record16,1,mpi_type_frm,statux,mpierr)
3392 : 0 : fmarker = delim_record16(1)
3393 : : #endif
3394 [ # # ]: 0 : else if (bsize_frm==2) then
3395 : 0 : call MPI_FILE_READ_AT(myfh,offset,delim_record2,1,mpi_type_frm,statux,mpierr)
3396 : 0 : fmarker = delim_record2(1)
3397 : : else
3398 : 0 : call xmpi_abort(msg='Wrong record marker length!')
3399 : : end if
3400 : :
3401 : : CASE (xmpio_collective)
3402 : :
3403 [ # # ]: 0 : if (bsize_frm==4) then
3404 : 0 : call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record4,1,mpi_type_frm,statux,mpierr)
3405 : 0 : fmarker = delim_record4(1)
3406 [ # # ]: 0 : else if (bsize_frm==8) then
3407 : 0 : call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record8,1,mpi_type_frm,statux,mpierr)
3408 : 0 : fmarker = delim_record8(1)
3409 : : #if defined HAVE_FC_INT_QUAD
3410 [ # # ]: 0 : else if (bsize_frm==16) then
3411 : 0 : call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record16,1,mpi_type_frm,statux,mpierr)
3412 : 0 : fmarker = delim_record16(1)
3413 : : #endif
3414 [ # # ]: 0 : else if (bsize_frm==2) then
3415 : 0 : call MPI_FILE_READ_AT_ALL(myfh,offset,delim_record2,1,mpi_type_frm,statux,mpierr)
3416 : 0 : fmarker = delim_record2(1)
3417 : : else
3418 : 0 : call xmpi_abort(msg='Wrong record marker length!')
3419 : : end if
3420 : :
3421 : : CASE DEFAULT
3422 : 0 : write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode
3423 [ + - - ]: 1042 : call xmpi_abort(msg=msg)
3424 : : END SELECT
3425 : :
3426 [ - + ]: 1042 : if (PRESENT(advance)) then
3427 [ # # ]: 0 : if (advance) then
3428 : 0 : offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record.
3429 : : else
3430 : 0 : offset = offset + bsize_frm ! Move the pointer after the marker.
3431 : : end if
3432 : : else
3433 : 1042 : offset = offset + fmarker + 2*bsize_frm
3434 : : end if
3435 : :
3436 : 1042 : end subroutine xmpio_read_frm
3437 : : !!***
3438 : :
3439 : : #endif
3440 : :
3441 : : !------------------------------------------------------------------------------------
3442 : :
3443 : : !!****f* m_wffile/xmpio_write_frm
3444 : : !! NAME
3445 : : !! xmpio_write_frm
3446 : : !!
3447 : : !! FUNCTION
3448 : : !! Write a single record marker in a FORTRAN file at a given offset using MPI-IO.
3449 : : !! The file pointer is modified according to the value of advance.
3450 : : !!
3451 : : !! INPUTS
3452 : : !! fh=MPI-IO file handler.
3453 : : !! sc_mode=
3454 : : !! xmpio_single ==> for reading by current proc.
3455 : : !! xmpio_collective ==> for collective reading.
3456 : : !! fmarker=The content of the Fortran marker i.e. the size of the record in bytes.
3457 : : !! [advance]=By default the routine will move the file pointer to the next record.
3458 : : !! advance=.FALSE. can be used so that the next write will continue writing data
3459 : : !! on the currect record.
3460 : : !!
3461 : : !! OUTPUT
3462 : : !! mpierr= error code
3463 : : !!
3464 : : !! SIDE EFFECTS
3465 : : !! offset=
3466 : : !! input: offset of the Fortran marker.
3467 : : !! output: new offset updated after the writing, depending on advance.
3468 : : !!
3469 : : !! SOURCE
3470 : :
3471 : : #ifdef HAVE_MPI_IO
3472 : :
3473 : 111 : subroutine xmpio_write_frm(fh, offset, sc_mode, fmarker, mpierr, advance)
3474 : :
3475 : : !Arguments ------------------------------------
3476 : : !scalars
3477 : : integer,intent(in) :: fh,sc_mode
3478 : : integer(XMPI_OFFSET_KIND),intent(in) :: fmarker
3479 : : integer(XMPI_OFFSET_KIND),intent(inout) :: offset
3480 : : integer,intent(out) :: mpierr
3481 : : logical,optional,intent(in) :: advance
3482 : :
3483 : : !Local variables-------------------------------
3484 : : !scalars
3485 : : integer :: myfh,bsize_frm,mpi_type_frm
3486 : : integer(XMPI_OFFSET_KIND) :: last
3487 : : integer(kind=int16) :: delim_record2
3488 : : integer(kind=int32) :: delim_record4
3489 : : integer(kind=int64) :: delim_record8
3490 : : #if defined HAVE_FC_INT_QUAD
3491 : : integer*16 :: delim_record16
3492 : : #endif
3493 : : character(len=500) :: msg
3494 : : !arrays
3495 : : integer :: statux(MPI_STATUS_SIZE)
3496 : : !************************************************************************
3497 : :
3498 : : ! Workaround for XLF
3499 : 111 : myfh = fh
3500 : :
3501 : 111 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
3502 : 111 : mpi_type_frm = xmpio_mpi_type_frm ! MPI type of the record marker.
3503 : 111 : last = offset + bsize_frm + fmarker ! position of the end marker
3504 : :
3505 : 222 : SELECT CASE (sc_mode)
3506 : :
3507 : : CASE (xmpio_single)
3508 [ + - ]: 111 : if (bsize_frm==4) then
3509 : 111 : delim_record4 = fmarker
3510 [ + + ]: 222 : call MPI_FILE_WRITE_AT(myfh,offset,[delim_record4],1,mpi_type_frm,statux,mpierr)
3511 [ + + ]: 222 : call MPI_FILE_WRITE_AT(myfh,last,[delim_record4],1,mpi_type_frm,statux,mpierr)
3512 : :
3513 [ # # ]: 0 : else if (bsize_frm==8) then
3514 : 0 : delim_record8 = fmarker
3515 [ # # ]: 0 : call MPI_FILE_WRITE_AT(myfh,offset,[delim_record8],1,mpi_type_frm,statux,mpierr)
3516 [ # # ]: 0 : call MPI_FILE_WRITE_AT(myfh,last,[delim_record8],1,mpi_type_frm,statux,mpierr)
3517 : : #if defined HAVE_FC_INT_QUAD
3518 [ # # ]: 0 : else if (bsize_frm==16) then
3519 : 0 : delim_record16 = fmarker
3520 [ # # ]: 0 : call MPI_FILE_WRITE_AT(myfh,offset,[delim_record16],1,mpi_type_frm,statux,mpierr)
3521 [ # # ]: 0 : call MPI_FILE_WRITE_AT(myfh,last,[delim_record16],1,mpi_type_frm,statux,mpierr)
3522 : : #endif
3523 [ # # ]: 0 : else if (bsize_frm==2) then
3524 : 0 : delim_record2 = fmarker
3525 [ # # ]: 0 : call MPI_FILE_WRITE_AT(myfh,offset,[delim_record2], 1,mpi_type_frm,statux,mpierr)
3526 [ # # ]: 0 : call MPI_FILE_WRITE_AT(myfh,last,[delim_record2],1,mpi_type_frm,statux,mpierr)
3527 : : else
3528 : 0 : call xmpi_abort(msg='Wrong record marker length!')
3529 : : end if
3530 : :
3531 : : CASE (xmpio_collective)
3532 [ # # ]: 0 : if (bsize_frm==4) then
3533 : 0 : delim_record4 = fmarker
3534 [ # # ]: 0 : call MPI_FILE_WRITE_AT_ALL(myfh,offset,[delim_record4],1,mpi_type_frm,statux,mpierr)
3535 [ # # ]: 0 : call MPI_FILE_WRITE_AT_ALL(myfh,last,[delim_record4],1,mpi_type_frm,statux,mpierr)
3536 [ # # ]: 0 : else if (bsize_frm==8) then
3537 : 0 : delim_record8 = fmarker
3538 [ # # ]: 0 : call MPI_FILE_WRITE_AT_ALL(myfh,offset,[delim_record8],1,mpi_type_frm,statux,mpierr)
3539 [ # # ]: 0 : call MPI_FILE_WRITE_AT_ALL(myfh,last,[delim_record8],1,mpi_type_frm,statux,mpierr)
3540 : : #if defined HAVE_FC_INT_QUAD
3541 [ # # ]: 0 : else if (bsize_frm==16) then
3542 : 0 : delim_record16 = fmarker
3543 [ # # ]: 0 : call MPI_FILE_WRITE_AT_ALL(myfh,offset,[delim_record16],1,mpi_type_frm,statux,mpierr)
3544 [ # # ]: 0 : call MPI_FILE_WRITE_AT_ALL(myfh,last,[delim_record16],1,mpi_type_frm,statux,mpierr)
3545 : : #endif
3546 [ # # ]: 0 : else if (bsize_frm==2) then
3547 : 0 : delim_record2 = fmarker
3548 [ # # ]: 0 : call MPI_FILE_WRITE_AT_ALL(myfh,offset,[delim_record2],1,mpi_type_frm,statux,mpierr)
3549 [ # # ]: 0 : call MPI_FILE_WRITE_AT_ALL(myfh,last,[delim_record2],1,mpi_type_frm,statux,mpierr)
3550 : : else
3551 : 0 : call xmpi_abort(msg='Wrong record marker length!')
3552 : : end if
3553 : :
3554 : : CASE DEFAULT
3555 : 0 : write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode
3556 [ + - - ]: 111 : call xmpi_abort(msg=msg)
3557 : : END SELECT
3558 : :
3559 [ - + ]: 111 : if (PRESENT(advance)) then
3560 [ # # ]: 0 : if (advance) then
3561 : 0 : offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record.
3562 : : else
3563 : 0 : offset = offset + bsize_frm ! Move the pointer after the marker.
3564 : : end if
3565 : : else
3566 : 111 : offset = offset + fmarker + 2*bsize_frm
3567 : : end if
3568 : :
3569 : 111 : end subroutine xmpio_write_frm
3570 : : !!***
3571 : : #endif
3572 : :
3573 : : !------------------------------------------------------------------------------------
3574 : :
3575 : : !!****f* m_xmpi/xmpio_create_fstripes
3576 : : !! NAME
3577 : : !! xmpio_create_fstripes
3578 : : !!
3579 : : !! FUNCTION
3580 : : !! Return a MPI type that can be used to (read|write) a set of interleaved Fortran records.
3581 : : !!
3582 : : !! <FRM> type(1), type(1), ... <FRM> ! size(1) elements
3583 : : !! <FRM> type(2), type(2), ... <FRM> ! size(2) elements
3584 : : !! <FRM> type(1), type(1), ... <FRM> ! size(1) elements
3585 : : !! ....
3586 : : !!
3587 : : !! INPUTS
3588 : : !! ncount = Number of records with elements of type types(1) to (read|write)
3589 : : !! sizes(1:2) = Number of elements of each type in the two sets of record
3590 : : !! type(1:2) = MPI Type of the elements in the first and in the second record.
3591 : : !!
3592 : : !! OUTPUT
3593 : : !! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
3594 : : !! marker individuating the beginning of the matrix. (lets call it "base").
3595 : : !! Each node should (read|write) using my_offset = base + my_offpad.
3596 : : !! my_offpad is used so that one can safely change the way the fileview is generated (for example
3597 : : !! to make it more efficient) without having to change the client code.
3598 : : !! new_type=New MPI type.
3599 : : !! mpierr= MPI error code
3600 : : !!
3601 : : !! SOURCE
3602 : :
3603 : : #ifdef HAVE_MPI_IO
3604 : :
3605 : 0 : subroutine xmpio_create_fstripes(ncount, sizes, types, new_type, my_offpad, mpierr)
3606 : :
3607 : : !Arguments ------------------------------------
3608 : : !scalars
3609 : : integer,intent(in) :: ncount
3610 : : integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
3611 : : integer,intent(out) :: new_type,mpierr
3612 : : !arrays
3613 : : integer,intent(in) :: types(2),sizes(2)
3614 : :
3615 : : !Local variables-------------------------------
3616 : : !scalars
3617 : : integer :: type_x,type_y,bsize_frm,bsize_x,bsize_y,nx,ny,column_type
3618 : : integer(MPI_ADDRESS_KIND) :: stride
3619 : : !************************************************************************
3620 : :
3621 : : ! Byte size of the Fortran record marker.
3622 : 0 : bsize_frm = xmpio_bsize_frm
3623 : :
3624 : : ! Number of elements in the two stripes.
3625 : 0 : nx = sizes(1)
3626 : 0 : ny = sizes(2)
3627 : :
3628 : 0 : type_x = types(1)
3629 : 0 : type_y = types(2)
3630 : :
3631 : : ! Byte size of type_x and type_y
3632 : 0 : call MPI_TYPE_SIZE(type_x,bsize_x,mpierr)
3633 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3634 : :
3635 : 0 : call MPI_TYPE_SIZE(type_y,bsize_y,mpierr)
3636 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3637 : :
3638 : : ! The view starts at the first element of the first stripe.
3639 : 0 : my_offpad = xmpio_bsize_frm
3640 : :
3641 : 0 : call MPI_Type_contiguous(nx,type_x,column_type,mpierr)
3642 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3643 : :
3644 : : ! Byte size of the Fortran record + the two markers.
3645 : 0 : stride = nx*bsize_x + 2*bsize_frm + ny*bsize_y + 2*bsize_frm
3646 : :
3647 : : ! ncount colum_type separated by stride bytes
3648 [ # # ]: 0 : if (ncount>0) then
3649 : 0 : call MPI_Type_create_hvector(ncount,1,stride,column_type,new_type,mpierr)
3650 : : else
3651 : 0 : call MPI_Type_create_hvector(1,1,stride,column_type,new_type,mpierr)
3652 : : end if
3653 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3654 : :
3655 : 0 : call MPI_TYPE_COMMIT(new_type,mpierr)
3656 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3657 : :
3658 : 0 : call MPI_TYPE_FREE(column_type,mpierr)
3659 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3660 : :
3661 : : end subroutine xmpio_create_fstripes
3662 : : !!***
3663 : : #endif
3664 : :
3665 : : !------------------------------------------------------------------------------------
3666 : :
3667 : : !!****f* m_xmpi/xmpio_create_fsubarray_2D
3668 : : !! NAME
3669 : : !! xmpio_create_fsubarray_2D
3670 : : !!
3671 : : !! FUNCTION
3672 : : !! Return a MPI type that can be used to (read|write) a 2D matrix of elements of type old_type stored in a Fortran file.
3673 : : !!
3674 : : !! INPUTS
3675 : : !! sizes(2)=number of elements of type old_type in each dimension of the full array (array of positive integers)
3676 : : !! subsizes(2)=number of elements of type old_type in each dimension of the subarray (array of positive integers)
3677 : : !! array_of_starts(2)=starting coordinates of the subarray in each dimension (array of nonnegative integers >=1, <=sizes)
3678 : : !! old_type=Old MPI type.
3679 : : !!
3680 : : !! OUTPUT
3681 : : !! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
3682 : : !! marker individuating the beginning of the matrix. (lets call it "base").
3683 : : !! Each node should (read|write) using my_offset = base + my_offpad.
3684 : : !! my_offpad is used so that one can safely change the way the fileview is generated (for example
3685 : : !! to make it more efficient) without having to change the client code.
3686 : : !! new_type=New MPI type.
3687 : : !! mpierr= MPI error code
3688 : : !!
3689 : : !! SOURCE
3690 : :
3691 : : #ifdef HAVE_MPI_IO
3692 : :
3693 : 30 : subroutine xmpio_create_fsubarray_2D(sizes, subsizes, array_of_starts, old_type, new_type, my_offpad, mpierr)
3694 : :
3695 : : !Arguments ------------------------------------
3696 : : !scalars
3697 : : integer,intent(in) :: old_type
3698 : : integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
3699 : : integer,intent(out) :: mpierr,new_type
3700 : : !arrays
3701 : : integer,intent(in) :: sizes(2),subsizes(2),array_of_starts(2)
3702 : : !Local variables-------------------------------
3703 : : !scalars
3704 : : integer :: bsize_frm,bsize_old,nx,ny,column_type,ldx
3705 : : integer(XMPI_OFFSET_KIND) :: st_x,st_y
3706 : : integer(MPI_ADDRESS_KIND) :: stride_x
3707 : : !character(len=500) :: msg
3708 : : !************************************************************************
3709 : :
3710 : : ! Byte size of the Fortran record marker.
3711 : 30 : bsize_frm = xmpio_bsize_frm
3712 : :
3713 : : ! Byte size of old_type.
3714 : 30 : call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
3715 [ + - ]: 30 : ABI_HANDLE_MPIERR(mpierr)
3716 : : !
3717 : : ! Number of columns and rows of the submatrix.
3718 : 30 : nx = subsizes(1)
3719 : 30 : ny = subsizes(2)
3720 : :
3721 : 30 : ldx = sizes(1)
3722 : 30 : st_x = array_of_starts(1)
3723 : 30 : st_y = array_of_starts(2)
3724 : :
3725 : : ! The view starts at the first element of the submatrix.
3726 : 30 : my_offpad = (st_x-1)*bsize_old + (st_y-1)*(ldx*bsize_old+2*xmpio_bsize_frm) + xmpio_bsize_frm
3727 : :
3728 : : ! Byte size of the Fortran record + the two markers.
3729 : 30 : stride_x = ldx*bsize_old + 2*bsize_frm
3730 : :
3731 : 30 : call MPI_Type_contiguous(nx,old_type,column_type,mpierr)
3732 [ + - ]: 30 : ABI_HANDLE_MPIERR(mpierr)
3733 : :
3734 : 30 : call MPI_Type_create_hvector(ny,1,stride_x,column_type,new_type,mpierr)
3735 [ + - ]: 30 : ABI_HANDLE_MPIERR(mpierr)
3736 : :
3737 : 30 : call MPI_TYPE_COMMIT(new_type,mpierr)
3738 [ + - ]: 30 : ABI_HANDLE_MPIERR(mpierr)
3739 : :
3740 : 30 : call MPI_TYPE_FREE(column_type, mpierr)
3741 [ + - ]: 30 : ABI_HANDLE_MPIERR(mpierr)
3742 : :
3743 : : end subroutine xmpio_create_fsubarray_2D
3744 : : !!***
3745 : : #endif
3746 : :
3747 : : !------------------------------------------------------------------------------------
3748 : :
3749 : : !!****f* m_xmpi/xmpio_create_fsubarray_3D
3750 : : !! NAME
3751 : : !! xmpio_create_fsubarray_3D
3752 : : !!
3753 : : !! FUNCTION
3754 : : !! Return a MPI type that can be used to (read|write) a 3D matrix of elements of type old_type stored in a Fortran file.
3755 : : !!
3756 : : !! INPUTS
3757 : : !! sizes(3)=number of elements of type old_type in each dimension of the full array (array of positive integers)
3758 : : !! subsizes(3)=number of elements of type old_type in each dimension of the subarray (array of positive integers)
3759 : : !! array_of_starts(3)=starting coordinates of the subarray in each dimension (array of nonnegative integers >=1, <=sizes)
3760 : : !! old_type=Old MPI type.
3761 : : !!
3762 : : !! OUTPUT
3763 : : !! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
3764 : : !! marker individuating the beginning of the matrix. (lets call it "base").
3765 : : !! Each node should (read|write) using my_offset = base + my_offpad.
3766 : : !! my_offpad is used so that one can safely change the way the fileview is generated (for example
3767 : : !! to make it more efficient) without having to change the client code.
3768 : : !! new_type=New MPI type.
3769 : : !! mpierr= MPI error code
3770 : : !!
3771 : : !! SOURCE
3772 : :
3773 : : #ifdef HAVE_MPI_IO
3774 : :
3775 : 0 : subroutine xmpio_create_fsubarray_3D(sizes, subsizes, array_of_starts, old_type, new_type, my_offpad, mpierr)
3776 : :
3777 : : !Arguments ------------------------------------
3778 : : !scalars
3779 : : integer,intent(in) :: old_type
3780 : : integer,intent(out) :: mpierr,new_type
3781 : : integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
3782 : : !arrays
3783 : : integer,intent(in) :: sizes(3),subsizes(3),array_of_starts(3)
3784 : : !Local variables-------------------------------
3785 : : !scalars
3786 : : integer :: bsize_frm,bsize_old,nx,ny,nz
3787 : : integer :: column_type,plane_type,ldx,ldy,ldz
3788 : : integer(XMPI_OFFSET_KIND) :: st_x,st_y,st_z
3789 : : integer(MPI_ADDRESS_KIND) :: stride_x
3790 : : !character(len=500) :: msg
3791 : : !************************************************************************
3792 : :
3793 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
3794 : :
3795 : : ! Byte size of old_type.
3796 : 0 : call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
3797 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3798 : : !
3799 : : ! Number of columns and rows of the submatrix.
3800 : 0 : nx = subsizes(1)
3801 : 0 : ny = subsizes(2)
3802 : 0 : nz = subsizes(3)
3803 : :
3804 : 0 : ldx = sizes(1)
3805 : 0 : ldy = sizes(2)
3806 : 0 : ldz = sizes(3)
3807 : :
3808 : 0 : st_x = array_of_starts(1)
3809 : 0 : st_y = array_of_starts(2)
3810 : 0 : st_z = array_of_starts(3)
3811 : :
3812 : : ! The view starts at the first element of the submatrix.
3813 : : my_offpad = (st_x-1)*bsize_old + &
3814 : : (st_y-1)* (ldx*bsize_old+2*xmpio_bsize_frm) + &
3815 : : (st_z-1)*ldy*(ldx*bsize_old+2*xmpio_bsize_frm) + &
3816 : 0 : xmpio_bsize_frm
3817 : :
3818 : : ! Byte size of the Fortran record + the two markers.
3819 : 0 : stride_x = ldx*bsize_old + 2*bsize_frm
3820 : :
3821 : 0 : call MPI_Type_contiguous(nx,old_type,column_type,mpierr)
3822 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3823 : :
3824 : 0 : call MPI_Type_create_hvector(ny,1,stride_x,column_type,plane_type,mpierr)
3825 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3826 : :
3827 : 0 : call MPI_Type_create_hvector(nz,1,ldy*stride_x,plane_type,new_type,mpierr)
3828 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3829 : :
3830 : : ! Commit the datatype
3831 : 0 : call MPI_TYPE_COMMIT(new_type,mpierr)
3832 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3833 : :
3834 : : ! Free memory
3835 : 0 : call MPI_TYPE_FREE(plane_type, mpierr)
3836 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3837 : :
3838 : : end subroutine xmpio_create_fsubarray_3D
3839 : : !!***
3840 : : #endif
3841 : :
3842 : : !------------------------------------------------------------------------------------
3843 : :
3844 : : !!****f* m_xmpi/xmpio_create_fsubarray_4D
3845 : : !! NAME
3846 : : !! xmpio_create_fsubarray_4D
3847 : : !!
3848 : : !! FUNCTION
3849 : : !! Return a MPI type that can be used to (read|write) a 2D matrix of elements of type old_type stored in a Fortran file.
3850 : : !!
3851 : : !! INPUTS
3852 : : !! sizes(4)=number of elements of type old_type in each dimension of the full array (array of positive integers)
3853 : : !! subsizes(4)=number of elements of type old_type in each dimension of the subarray (array of positive integers)
3854 : : !! array_of_starts(4)=starting coordinates of the subarray in each dimension (array of nonnegative integers >=1, <=sizes)
3855 : : !! old_type=Old MPI type.
3856 : : !!
3857 : : !! OUTPUT
3858 : : !! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
3859 : : !! marker individuating the beginning of the matrix. (lets call it "base").
3860 : : !! Each node should (read|write) using my_offset = base + my_offpad.
3861 : : !! my_offpad is used so that one can safely change the way the fileview is generated (for example
3862 : : !! to make it more efficient) without having to change the client code.
3863 : : !! new_type=New MPI type.
3864 : : !! mpierr= MPI error code
3865 : : !!
3866 : : !! SOURCE
3867 : :
3868 : : #ifdef HAVE_MPI_IO
3869 : :
3870 : 0 : subroutine xmpio_create_fsubarray_4D(sizes, subsizes, array_of_starts, old_type, new_type, my_offpad, mpierr)
3871 : :
3872 : : !Arguments ------------------------------------
3873 : : !scalars
3874 : : integer,intent(in) :: old_type
3875 : : integer,intent(out) :: mpierr,new_type
3876 : : integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
3877 : : !arrays
3878 : : integer,intent(in) :: sizes(4),subsizes(4),array_of_starts(4)
3879 : :
3880 : : !Local variables-------------------------------
3881 : : !scalars
3882 : : integer :: bsize_frm,bsize_old,nx,ny,nz,na
3883 : : integer :: column_type,plane_type,ldx,ldy,ldz,lda,vol_type
3884 : : integer(XMPI_OFFSET_KIND) :: st_x,st_y,st_z,st_a
3885 : : integer(MPI_ADDRESS_KIND) :: stride_x
3886 : : !************************************************************************
3887 : :
3888 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
3889 : :
3890 : : ! Byte size of old_type.
3891 : 0 : call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
3892 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3893 : : !
3894 : : ! Number of columns and rows of the submatrix.
3895 : 0 : nx = subsizes(1)
3896 : 0 : ny = subsizes(2)
3897 : 0 : nz = subsizes(3)
3898 : 0 : na = subsizes(4)
3899 : :
3900 : 0 : ldx = sizes(1)
3901 : 0 : ldy = sizes(2)
3902 : 0 : ldz = sizes(3)
3903 : 0 : lda = sizes(4)
3904 : :
3905 : 0 : st_x = array_of_starts(1)
3906 : 0 : st_y = array_of_starts(2)
3907 : 0 : st_z = array_of_starts(3)
3908 : 0 : st_a = array_of_starts(4)
3909 : :
3910 : : ! The view starts at the first element of the submatrix.
3911 : : my_offpad = (st_x-1)*bsize_old + &
3912 : : (st_y-1)* (ldx*bsize_old+2*xmpio_bsize_frm) + &
3913 : : (st_z-1)*ldy* (ldx*bsize_old+2*xmpio_bsize_frm) + &
3914 : : (st_a-1)*lda*ldy*(ldx*bsize_old+2*xmpio_bsize_frm) + &
3915 : 0 : xmpio_bsize_frm
3916 : :
3917 : : ! Byte size of the Fortran record + the two markers.
3918 : 0 : stride_x = ldx*bsize_old + 2*bsize_frm
3919 : :
3920 : 0 : call MPI_Type_contiguous(nx,old_type,column_type,mpierr)
3921 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3922 : :
3923 : 0 : call MPI_Type_create_hvector(ny,1,stride_x,column_type,plane_type,mpierr)
3924 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3925 : :
3926 : 0 : call MPI_Type_create_hvector(nz,1,ldy*stride_x,plane_type,vol_type,mpierr)
3927 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3928 : :
3929 : 0 : call MPI_Type_create_hvector(na,1,ldz*ldy*stride_x,vol_type,new_type,mpierr)
3930 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3931 : :
3932 : : ! Commit the datatype
3933 : 0 : call MPI_TYPE_COMMIT(new_type,mpierr)
3934 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3935 : :
3936 : : ! Free memory
3937 : 0 : call MPI_TYPE_FREE(column_type, mpierr)
3938 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3939 : :
3940 : 0 : call MPI_TYPE_FREE(plane_type, mpierr)
3941 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3942 : :
3943 : 0 : call MPI_TYPE_FREE(vol_type, mpierr)
3944 [ # # ]: 0 : ABI_HANDLE_MPIERR(mpierr)
3945 : :
3946 : : end subroutine xmpio_create_fsubarray_4D
3947 : : !!***
3948 : : #endif
3949 : :
3950 : : !------------------------------------------------------------------------------------
3951 : :
3952 : : !!****f* m_xmpi/xmpio_check_frmarkers
3953 : : !! NAME
3954 : : !! xmpio_check_frmarkers
3955 : : !!
3956 : : !! FUNCTION
3957 : : !! Check a set of Fortran record markers starting at a given offset using MPI-IO.
3958 : : !!
3959 : : !! INPUTS
3960 : : !! fh=MPI-IO file handler.
3961 : : !! offset=MPI-IO file pointer
3962 : : !! sc_mode=Option for individual or collective reading.
3963 : : !! nfrec=Number of Fortran records to be checked.
3964 : : !! bsize_frecord(nfrec)=Byte size of the Fortran records (markers are NOT included)
3965 : : !! These values will be compared with the markers reported in the file.
3966 : : !!
3967 : : !! OUTPUT
3968 : : !! ierr=A non-zero error code signals failure.
3969 : : !!
3970 : : !! SOURCE
3971 : :
3972 : : #ifdef HAVE_MPI_IO
3973 : :
3974 : 0 : subroutine xmpio_check_frmarkers(fh, offset, sc_mode, nfrec, bsize_frecord, ierr)
3975 : :
3976 : : !Arguments ------------------------------------
3977 : : !scalars
3978 : : integer,intent(in) :: fh,nfrec,sc_mode
3979 : : integer(XMPI_OFFSET_KIND),intent(in) :: offset
3980 : : integer,intent(out) :: ierr
3981 : : !arrays
3982 : : integer(XMPI_OFFSET_KIND),intent(in) :: bsize_frecord(nfrec)
3983 : :
3984 : : !Local variables-------------------------------
3985 : : !scalars
3986 : : integer :: nb,irec,frmarkers_type,jj,bsize_frm,mpi_type_frm,mpierr,myfh
3987 : : integer(XMPI_OFFSET_KIND) :: displ
3988 : : !arrays
3989 : 0 : integer(kind=int16),allocatable :: bufdelim2(:)
3990 : 0 : integer(kind=int32),allocatable :: bufdelim4(:)
3991 : 0 : integer(kind=int64),allocatable :: bufdelim8(:)
3992 : : #ifdef HAVE_FC_INT_QUAD
3993 : 0 : integer*16,allocatable :: bufdelim16(:)
3994 : : #endif
3995 : : !integer :: statux(MPI_STATUS_SIZE)
3996 : 0 : integer,allocatable :: block_length(:),block_type(:)
3997 : 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
3998 : 0 : integer(XMPI_OFFSET_KIND),allocatable :: delim_record(:)
3999 : : !************************************************************************
4000 : :
4001 : : ! Workaround for XLF
4002 : 0 : myfh = fh
4003 : 0 : ierr=0
4004 : :
4005 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
4006 : 0 : mpi_type_frm = xmpio_mpi_type_frm ! MPI type of the record marker.
4007 : :
4008 : : ! Define the view for the file.
4009 : 0 : nb=2*nfrec
4010 [ # # # # : 0 : ABI_MALLOC(block_length,(nb+2))
# # # # #
# # # #
# ]
4011 [ # # # # : 0 : ABI_MALLOC(block_displ,(nb+2))
# # # # #
# # # ]
4012 [ # # # # : 0 : ABI_MALLOC(block_type,(nb+2))
# # # # ]
4013 : 0 : block_length(1)=1
4014 : 0 : block_displ (1)=0
4015 : 0 : block_type (1)=MPI_LB
4016 : :
4017 : 0 : jj=2; displ=0
4018 [ # # ]: 0 : do irec=1,nfrec
4019 [ # # ]: 0 : block_type (jj:jj+1) =mpi_type_frm
4020 [ # # ]: 0 : block_length(jj:jj+1)=1
4021 : 0 : block_displ(jj ) = displ
4022 : 0 : block_displ(jj+1) = bsize_frm + displ + bsize_frecord(irec)
4023 : 0 : jj=jj+2
4024 : 0 : displ = displ + bsize_frecord(irec) + 2*bsize_frm ! Move to the beginning of the next column.
4025 : 0 : if (xmpio_max_address(displ)) ierr=-1 ! Check for wraparound.
4026 : : end do
4027 : :
4028 : 0 : block_length(nb+2)=1
4029 : 0 : block_displ (nb+2)=displ
4030 : 0 : block_type (nb+2)=MPI_UB
4031 : :
4032 : 0 : call xmpio_type_struct(nb+2,block_length,block_displ,block_type,frmarkers_type,mpierr)
4033 : 0 : ABI_FREE(block_length)
4034 : 0 : ABI_FREE(block_displ)
4035 : 0 : ABI_FREE(block_type)
4036 : :
4037 : 0 : call MPI_TYPE_COMMIT(frmarkers_type,mpierr)
4038 : 0 : call MPI_FILE_SET_VIEW(myfh,offset,MPI_BYTE,frmarkers_type,"native",MPI_INFO_NULL,mpierr)
4039 : :
4040 : 0 : jj=1
4041 [ # # # # : 0 : ABI_MALLOC(delim_record,(nb))
# # # # #
# # # ]
4042 [ # # ]: 0 : do irec=1,nfrec
4043 [ # # ]: 0 : delim_record(jj:jj+1)=bsize_frecord(irec)
4044 : 0 : jj=jj+2
4045 : : end do
4046 : :
4047 : : ! Read markers according to the MPI type of the Fortran marker.
4048 : 0 : SELECT CASE (bsize_frm)
4049 : :
4050 : : CASE (4)
4051 [ # # # # : 0 : ABI_MALLOC(bufdelim4,(nb))
# # # # #
# # # ]
4052 [ # # ]: 0 : if (sc_mode==xmpio_single) then
4053 : 0 : call MPI_FILE_READ (myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4054 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
4055 : 0 : call MPI_FILE_READ_ALL(myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4056 : : else
4057 : 0 : ierr=2
4058 : : end if
4059 [ # # # # : 0 : if (ANY(bufdelim4/=delim_record)) ierr=1
# # ]
4060 [ # # ]: 0 : if (ierr==1) then
4061 [ # # ]: 0 : do irec=1,2*nfrec
4062 : 0 : write(std_out,*)"irec, bufdelim4, delim_record: ",irec,bufdelim4(irec),delim_record(irec)
4063 : : end do
4064 : : end if
4065 [ # # ]: 0 : ABI_FREE(bufdelim4)
4066 : :
4067 : : CASE (8)
4068 [ # # # # : 0 : ABI_MALLOC(bufdelim8,(nb))
# # # # ]
4069 [ # # ]: 0 : if (sc_mode==xmpio_single) then
4070 : 0 : call MPI_FILE_READ (myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4071 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
4072 : 0 : call MPI_FILE_READ_ALL(myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4073 : : else
4074 : 0 : ierr=2
4075 : : end if
4076 [ # # # # : 0 : if (ANY(bufdelim8/=delim_record)) ierr=1
# # ]
4077 [ # # ]: 0 : ABI_FREE(bufdelim8)
4078 : :
4079 : : #ifdef HAVE_FC_INT_QUAD
4080 : : CASE (16)
4081 [ # # # # : 0 : ABI_MALLOC(bufdelim16,(nb))
# # # # #
# # # ]
4082 [ # # ]: 0 : if (sc_mode==xmpio_single) then
4083 : 0 : call MPI_FILE_READ (myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4084 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
4085 : 0 : call MPI_FILE_READ_ALL(myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4086 : : else
4087 : 0 : ierr=2
4088 : : end if
4089 [ # # # # : 0 : if (ANY(bufdelim16/=delim_record)) ierr=1
# # ]
4090 [ # # ]: 0 : ABI_FREE(bufdelim16)
4091 : : #endif
4092 : :
4093 : : CASE (2)
4094 [ # # # # : 0 : ABI_MALLOC(bufdelim2,(nb))
# # # # #
# ]
4095 [ # # ]: 0 : if (sc_mode==xmpio_single) then
4096 : 0 : call MPI_FILE_READ (myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4097 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
4098 : 0 : call MPI_FILE_READ_ALL(myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4099 : : else
4100 : 0 : ierr=2
4101 : : end if
4102 [ # # # # : 0 : if (ANY(bufdelim2/=delim_record)) ierr=1
# # ]
4103 [ # # ]: 0 : ABI_FREE(bufdelim2)
4104 : :
4105 : : CASE DEFAULT
4106 [ # # # # : 0 : ierr=-2
# ]
4107 : : END SELECT
4108 : :
4109 : : ! Free memory
4110 : 0 : call MPI_TYPE_FREE(frmarkers_type,mpierr)
4111 [ # # ]: 0 : ABI_FREE(delim_record)
4112 : :
4113 : 0 : end subroutine xmpio_check_frmarkers
4114 : : !!***
4115 : : #endif
4116 : :
4117 : : !----------------------------------------------------------------------
4118 : :
4119 : : !!****f* m_xmpi/xmpio_read_int
4120 : : !! NAME
4121 : : !! xmpio_read_int
4122 : : !!
4123 : : !! FUNCTION
4124 : : !! Read the content of a single record marker in a FORTRAN file at a given offset using MPI-IO.
4125 : : !! the file pointer is modified according to the value of advance.
4126 : : !! target: integer array
4127 : : !!
4128 : : !! INPUTS
4129 : : !! fh=MPI-IO file handler.
4130 : : !! offset=MPI-IO file pointer
4131 : : !! sc_mode=
4132 : : !! xmpio_single ==> for reading by current proc.
4133 : : !! xmpio_collective ==> for collective reading.
4134 : : !! ncount=Number of elements in the buffer
4135 : : !! [advance]=By default the routine will move the file pointer to the next record.
4136 : : !! advance=.FALSE. can be used so that the next read will continue picking information
4137 : : !! off of the currect record.
4138 : : !!
4139 : : !! OUTPUT
4140 : : !! buf(ncount)=array with the values read from file
4141 : : !! fmarker=Content of the Fortran record marker.
4142 : : !! mpierr= MPI error code
4143 : : !!
4144 : : !! SIDE EFFECTS
4145 : : !! offset=
4146 : : !! input: file pointer used to access the Fortran marker.
4147 : : !! output: new offset updated after the reading, depending on advance.
4148 : : !!
4149 : : !! SOURCE
4150 : :
4151 : : #ifdef HAVE_MPI_IO
4152 : :
4153 : 0 : subroutine xmpio_read_int(fh, offset, sc_mode, ncount, buf, fmarker, mpierr, advance)
4154 : :
4155 : : !Arguments ------------------------------------
4156 : : !scalars
4157 : : integer,intent(in) :: fh,sc_mode,ncount
4158 : : integer(XMPI_OFFSET_KIND),intent(inout) :: offset
4159 : : integer(XMPI_OFFSET_KIND),intent(out) :: fmarker
4160 : : integer,intent(out) :: mpierr
4161 : : logical,optional,intent(in) :: advance
4162 : : !arrays
4163 : : integer,intent(out) :: buf(ncount)
4164 : :
4165 : : !Local variables-------------------------------
4166 : : !scalars
4167 : : integer :: myfh,bsize_frm
4168 : : integer(XMPI_OFFSET_KIND) :: my_offset
4169 : : character(len=500) :: msg
4170 : : !arrays
4171 : : integer :: statux(MPI_STATUS_SIZE)
4172 : : !************************************************************************
4173 : :
4174 : : ! Workaround for XLF
4175 : 0 : myfh = fh
4176 : :
4177 : 0 : my_offset = offset
4178 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
4179 : :
4180 : 0 : call xmpio_read_frm(myfh,my_offset,sc_mode,fmarker,mpierr,advance=.FALSE.)
4181 : :
4182 : 0 : SELECT CASE (sc_mode)
4183 : : CASE (xmpio_single)
4184 : 0 : call MPI_FILE_READ_AT(myfh, my_offset, buf, ncount, MPI_INTEGER, statux, mpierr)
4185 : :
4186 : : CASE (xmpio_collective)
4187 : 0 : call MPI_FILE_READ_AT_ALL(myfh, my_offset, buf, ncount, MPI_INTEGER, statux, mpierr)
4188 : :
4189 : : CASE DEFAULT
4190 : 0 : write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode
4191 [ # # # ]: 0 : call xmpi_abort(msg=msg)
4192 : : END SELECT
4193 : :
4194 [ # # ]: 0 : if (PRESENT(advance)) then
4195 [ # # ]: 0 : if (advance) then
4196 : 0 : offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record.
4197 : : else
4198 : 0 : offset = offset + bsize_frm ! Move the pointer after the marker.
4199 : : end if
4200 : : else
4201 : 0 : offset = offset + fmarker + 2*bsize_frm
4202 : : end if
4203 : :
4204 : 0 : end subroutine xmpio_read_int
4205 : : !!***
4206 : : #endif
4207 : :
4208 : : !----------------------------------------------------------------------
4209 : :
4210 : : !!****f* m_xmpi/xmpio_read_dp
4211 : : !! NAME
4212 : : !! xmpio_read_dp
4213 : : !!
4214 : : !! FUNCTION
4215 : : !! Read the content of a single record marker in a FORTRAN file at a given offset using MPI-IO.
4216 : : !! the file pointer is modified according to the value of advance.
4217 : : !! targer: double precision real array
4218 : : !!
4219 : : !! INPUTS
4220 : : !! fh=MPI-IO file handler.
4221 : : !! offset=MPI-IO file pointer
4222 : : !! sc_mode=
4223 : : !! xmpio_single ==> for reading by current proc.
4224 : : !! xmpio_collective ==> for collective reading.
4225 : : !! ncount=Number of elements in the buffer
4226 : : !! [advance]=By default the routine will move the file pointer to the next record.
4227 : : !! advance=.FALSE. can be used so that the next read will continue picking information
4228 : : !! off of the currect record.
4229 : : !!
4230 : : !! OUTPUT
4231 : : !! buf(ncount)=array with the values read from file
4232 : : !! fmarker=Content of the Fortran record marker.
4233 : : !! mpierr= MPI error code
4234 : : !!
4235 : : !! SIDE EFFECTS
4236 : : !! offset=
4237 : : !! input: file pointer used to access the Fortran marker.
4238 : : !! output: new offset updated after the reading, depending on advance.
4239 : : !!
4240 : : !! SOURCE
4241 : :
4242 : : #ifdef HAVE_MPI_IO
4243 : :
4244 : 0 : subroutine xmpio_read_dp(fh, offset, sc_mode, ncount, buf, fmarker, mpierr, advance)
4245 : :
4246 : : !Arguments ------------------------------------
4247 : : !scalars
4248 : : integer,intent(in) :: fh,sc_mode,ncount
4249 : : integer(XMPI_OFFSET_KIND),intent(inout) :: offset
4250 : : integer(XMPI_OFFSET_KIND),intent(out) :: fmarker
4251 : : integer,intent(out) :: mpierr
4252 : : logical,optional,intent(in) :: advance
4253 : : !arrays
4254 : : real(dp),intent(out) :: buf(ncount)
4255 : :
4256 : : !Local variables-------------------------------
4257 : : !scalars
4258 : : integer :: bsize_frm,myfh
4259 : : integer(XMPI_OFFSET_KIND) :: my_offset
4260 : : character(len=500) :: msg
4261 : : !arrays
4262 : : integer :: statux(MPI_STATUS_SIZE)
4263 : : !************************************************************************
4264 : :
4265 : : ! Workaround for XLF
4266 : 0 : myfh = fh
4267 : :
4268 : 0 : my_offset = offset
4269 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
4270 : :
4271 : 0 : call xmpio_read_frm(myfh,my_offset,sc_mode,fmarker,mpierr,advance=.FALSE.)
4272 : :
4273 : 0 : SELECT CASE (sc_mode)
4274 : : CASE (xmpio_single)
4275 : 0 : call MPI_FILE_READ_AT(myfh, my_offset, buf, ncount, MPI_DOUBLE_PRECISION, statux, mpierr)
4276 : :
4277 : : CASE (xmpio_collective)
4278 : 0 : call MPI_FILE_READ_AT_ALL(myfh, my_offset, buf, ncount, MPI_DOUBLE_PRECISION, statux, mpierr)
4279 : :
4280 : : CASE DEFAULT
4281 : 0 : write(msg,"(a,i0)")" Wrong value for sc_mode: ",sc_mode
4282 [ # # # ]: 0 : call xmpi_abort(msg=msg)
4283 : : END SELECT
4284 : :
4285 [ # # ]: 0 : if (PRESENT(advance)) then
4286 [ # # ]: 0 : if (advance) then
4287 : 0 : offset = offset + fmarker + 2*bsize_frm ! Move the file pointer to the next record.
4288 : : else
4289 : 0 : offset = offset + bsize_frm ! Move the pointer after the marker.
4290 : : end if
4291 : : else
4292 : 0 : offset = offset + fmarker + 2*bsize_frm
4293 : : end if
4294 : :
4295 : 0 : end subroutine xmpio_read_dp
4296 : : !!***
4297 : : #endif
4298 : :
4299 : : !------------------------------------------------------------------------------------
4300 : :
4301 : : !!****f* m_xmpi/xmpio_max_address
4302 : : !! NAME
4303 : : !! xmpio_max_address
4304 : : !!
4305 : : !! FUNCTION
4306 : : !! Returns .TRUE. if offset cannot be stored in a Fortran integer of kind XMPI_ADDRESS_KIND.
4307 : : !!
4308 : : !! SOURCE
4309 : :
4310 : : #ifdef HAVE_MPI_IO
4311 : :
4312 : 0 : function xmpio_max_address(offset)
4313 : :
4314 : : !Arguments ------------------------------------
4315 : : !scalars
4316 : : logical :: xmpio_max_address
4317 : : integer(XMPI_OFFSET_KIND),intent(in) :: offset
4318 : : !arrays
4319 : :
4320 : : !Local variables-------------------------------
4321 : : !scalars
4322 : : integer(XMPI_ADDRESS_KIND) :: address
4323 : : integer(XMPI_OFFSET_KIND),parameter :: max_address=HUGE(address)-100
4324 : : !************************************************************************
4325 : :
4326 [ # # ]: 0 : xmpio_max_address = (offset >= max_address)
4327 : :
4328 : 0 : end function xmpio_max_address
4329 : : !!***
4330 : : #endif
4331 : :
4332 : : !------------------------------------------------------------------------------------
4333 : :
4334 : : !!****f* m_xmpi/xmpio_write_frmarkers
4335 : : !! NAME
4336 : : !! xmpio_write_frmarkers
4337 : : !!
4338 : : !! FUNCTION
4339 : : !! Write a set of Fortran record markers starting at a given offset using MPI-IO.
4340 : : !!
4341 : : !! INPUTS
4342 : : !! fh=MPI-IO file handler.
4343 : : !! offset=MPI-IO file pointer
4344 : : !! sc_mode=Option for individual or collective reading.
4345 : : !! nfrec=Number of Fortran records to be written.
4346 : : !! bsize_frecord(nfrec)=Byte size of the Fortran records to be written (markers are NOT included in the size)
4347 : : !!
4348 : : !! OUTPUT
4349 : : !! ierr=A non-zero error code signals failure.
4350 : : !!
4351 : : !! SOURCE
4352 : :
4353 : : #ifdef HAVE_MPI_IO
4354 : :
4355 : 5 : subroutine xmpio_write_frmarkers(fh, offset, sc_mode, nfrec, bsize_frecord, ierr)
4356 : :
4357 : : !Arguments ------------------------------------
4358 : : !scalars
4359 : : integer,intent(in) :: fh,nfrec,sc_mode
4360 : : integer(XMPI_OFFSET_KIND),intent(in) :: offset
4361 : : integer,intent(out) :: ierr
4362 : : !arrays
4363 : : integer(XMPI_OFFSET_KIND),intent(in) :: bsize_frecord(nfrec)
4364 : :
4365 : : !Local variables-------------------------------
4366 : : !scalars
4367 : : integer :: nb,irec,frmarkers_type,jj,bsize_frm,mpi_type_frm,mpierr,myfh
4368 : : integer(XMPI_OFFSET_KIND) :: displ
4369 : : !integer(XMPI_OFFSET_KIND) :: my_offset
4370 : : !character(len=500) :: msg
4371 : : !arrays
4372 : 5 : integer(kind=int16),allocatable :: bufdelim2(:)
4373 : 5 : integer(kind=int32),allocatable :: bufdelim4(:)
4374 : 5 : integer(kind=int64),allocatable :: bufdelim8(:)
4375 : : #ifdef HAVE_FC_INT_QUAD
4376 : 5 : integer*16,allocatable :: bufdelim16(:)
4377 : : #endif
4378 : : !integer :: statux(MPI_STATUS_SIZE)
4379 : 5 : integer,allocatable :: block_length(:),block_type(:)
4380 : 5 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
4381 : 5 : integer(XMPI_OFFSET_KIND),allocatable :: delim_record(:)
4382 : : !************************************************************************
4383 : :
4384 : : ! Workaround for XLF
4385 : 5 : myfh = fh; ierr=0
4386 : :
4387 : : !my_offset = offset
4388 : : !do irec=1,nfrec
4389 : : ! call xmpio_write_frm(myfh,my_offset,sc_mode,bsize_frecord(irec),mpierr)
4390 : : !end do
4391 : : !return
4392 : :
4393 : : ! FIXME: This is buggy
4394 : 5 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
4395 : 5 : mpi_type_frm = xmpio_mpi_type_frm ! MPI type of the record marker.
4396 : :
4397 : : ! Define the view for the file
4398 : 5 : nb=2*nfrec
4399 [ + - - + : 15 : ABI_MALLOC(block_length,(nb+2))
+ - + - +
- - + -
+ ]
4400 [ - + + - : 15 : ABI_MALLOC(block_displ,(nb+2))
+ - + - -
+ - + ]
4401 [ - + + - : 10 : ABI_MALLOC(block_type,(nb+2))
- + - + ]
4402 : 5 : block_length(1)=1
4403 : 5 : block_displ (1)=0
4404 : 5 : block_type (1)=MPI_LB
4405 : :
4406 : 5 : jj=2; displ=0
4407 [ + + ]: 335 : do irec=1,nfrec
4408 [ + + ]: 990 : block_type (jj:jj+1) = mpi_type_frm
4409 [ + + ]: 990 : block_length(jj:jj+1) = 1
4410 : 330 : block_displ(jj ) = displ
4411 : 330 : block_displ(jj+1) = displ + bsize_frm + bsize_frecord(irec)
4412 : 330 : jj=jj+2
4413 : 330 : displ = displ + bsize_frecord(irec) + 2*bsize_frm ! Move to the beginning of the next column.
4414 [ - + ]: 335 : if (xmpio_max_address(displ)) then ! Check for wraparound.
4415 : 0 : ierr = -1; return
4416 : : end if
4417 : : end do
4418 : :
4419 : 5 : block_length(nb+2) = 1
4420 : 5 : block_displ (nb+2) = displ
4421 : 5 : block_type (nb+2) = MPI_UB
4422 : :
4423 : 5 : call xmpio_type_struct(nb+2,block_length,block_displ,block_type,frmarkers_type,mpierr)
4424 : :
4425 : 5 : ABI_FREE(block_length)
4426 : 5 : ABI_FREE(block_displ)
4427 : 5 : ABI_FREE(block_type)
4428 : :
4429 : 5 : call MPI_TYPE_COMMIT(frmarkers_type,mpierr)
4430 : 5 : call MPI_FILE_SET_VIEW(myfh,offset,MPI_BYTE,frmarkers_type,"native",MPI_INFO_NULL,mpierr)
4431 : :
4432 : 5 : jj=1
4433 [ - + + - : 15 : ABI_MALLOC(delim_record,(nb))
+ - + - -
+ - + ]
4434 [ + + ]: 335 : do irec=1,nfrec
4435 [ + + ]: 990 : delim_record(jj:jj+1)=bsize_frecord(irec)
4436 : 335 : jj=jj+2
4437 : : end do
4438 : :
4439 : : ! Write all markers according to the MPI type of the Fortran marker.
4440 : 5 : SELECT CASE (bsize_frm)
4441 : :
4442 : : CASE (4)
4443 [ - + + - : 15 : ABI_MALLOC(bufdelim4,(nb))
+ - + - -
+ - + ]
4444 [ - + + + ]: 670 : bufdelim4=delim_record
4445 [ - + ]: 5 : if (sc_mode==xmpio_single) then
4446 : 0 : call MPI_FILE_WRITE (myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4447 [ + - ]: 5 : else if (sc_mode==xmpio_collective) then
4448 : 5 : call MPI_FILE_WRITE_ALL(myfh,bufdelim4,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4449 : : else
4450 : 0 : ierr=2
4451 : : end if
4452 [ - + ]: 5 : ABI_FREE(bufdelim4)
4453 : :
4454 : : CASE (8)
4455 [ # # # # : 0 : ABI_MALLOC(bufdelim8,(nb))
# # # # ]
4456 [ # # # # ]: 0 : bufdelim8=delim_record
4457 [ # # ]: 0 : if (sc_mode==xmpio_single) then
4458 : 0 : call MPI_FILE_WRITE (myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4459 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
4460 : 0 : call MPI_FILE_WRITE_ALL(myfh,bufdelim8,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4461 : : else
4462 : 0 : ierr=2
4463 : : end if
4464 [ # # ]: 0 : ABI_FREE(bufdelim8)
4465 : :
4466 : : #ifdef HAVE_FC_INT_QUAD
4467 : : CASE (16)
4468 [ # # # # : 0 : ABI_MALLOC(bufdelim16,(nb))
# # # # #
# # # ]
4469 [ # # # # ]: 0 : bufdelim16=delim_record
4470 [ # # ]: 0 : if (sc_mode==xmpio_single) then
4471 : 0 : call MPI_FILE_WRITE (myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4472 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
4473 : 0 : call MPI_FILE_WRITE_ALL(myfh,bufdelim16,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4474 : : else
4475 : 0 : ierr=2
4476 : : end if
4477 [ # # ]: 0 : ABI_FREE(bufdelim16)
4478 : : #endif
4479 : :
4480 : : CASE (2)
4481 [ # # # # : 0 : ABI_MALLOC(bufdelim2,(nb))
# # # # #
# ]
4482 [ # # # # ]: 0 : bufdelim2=delim_record
4483 [ # # ]: 0 : if (sc_mode==xmpio_single) then
4484 : 0 : call MPI_FILE_WRITE (myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4485 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
4486 : 0 : call MPI_FILE_WRITE_ALL(myfh,bufdelim2,2*nfrec,mpi_type_frm,MPI_STATUS_IGNORE,mpierr)
4487 : : else
4488 : 0 : ierr=2
4489 : : end if
4490 [ # # ]: 0 : ABI_FREE(bufdelim2)
4491 : :
4492 : : CASE DEFAULT
4493 [ + - - - : 5 : ierr=-2
- ]
4494 : : END SELECT
4495 : :
4496 : : ! Free memory
4497 : 5 : call MPI_TYPE_FREE(frmarkers_type,mpierr)
4498 [ - + ]: 5 : ABI_FREE(delim_record)
4499 : :
4500 [ - + - + : 5 : end subroutine xmpio_write_frmarkers
- + ]
4501 : : #endif
4502 : : !!***
4503 : :
4504 : : !------------------------------------------------------------------------------------
4505 : :
4506 : : !!****f* m_xmpi/xmpio_create_fherm_packed
4507 : : !! NAME
4508 : : !! xmpio_create_fherm_packed
4509 : : !!
4510 : : !! FUNCTION
4511 : : !! Returns an MPI datatype that can be used to (read|write) with MPI-IO the columns of an
4512 : : !! Hermitian matrix whose upper triangle is written on a Fortran binary file.
4513 : : !! Note that the view assumes that the file pointer used to create the MPI-IO view
4514 : : !! points to the first element of the first column. In other words,the first Fortran record marker
4515 : : !! (if any) is not taken into account in the calculation of the displacements.
4516 : : !!
4517 : : !! INPUTS
4518 : : !! array_of_starts(2)=starting coordinates in the global Hermitian matrix
4519 : : !! (array of positive integers with jj>=ii, Fortran convention)
4520 : : !! array_of_ends(2)=final coordinates in the global Hermitian matrix
4521 : : !! (array of positive integers, jj>=ii, Fortran convention)
4522 : : !! is_fortran_file=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files.
4523 : : !! old_type=MPI datatype of the elements of the matrix.
4524 : : !!
4525 : : !! OUTPUT
4526 : : !! my_offset=Offset relative to the beginning of the matrix in the file.
4527 : : !! hmat_type=New MPI type.
4528 : : !! offset_err= error code
4529 : : !!
4530 : : !! NOTES
4531 : : !! The matrix on file is written in the following FORTRAN format (let us assume a 3x3 matrix for simplicity)
4532 : : !!
4533 : : !! m (1,1) m
4534 : : !! m (1,2) (2,2) m
4535 : : !! m (1,3) (2,3) (3,3) m
4536 : : !!
4537 : : !! each Fortran record stores a column of the packed Hermitian matrix, "m" denotes the Fortran
4538 : : !! record marker that introduces holes in the MPI-IO file view.
4539 : : !! To read the columns from (1,2) up to (2,2) one should use array_of_starts=(1,2) and array_of_ends=(2,2).
4540 : : !! The MPI-IO file view should be created by moving the file pointer so that it points to the elements (1,2).
4541 : : !!
4542 : : !! File views for C-streams is not optimal since one can use a single slice of contigous data.
4543 : : !!
4544 : : !! SOURCE
4545 : :
4546 : : #ifdef HAVE_MPI_IO
4547 : :
4548 : 0 : subroutine xmpio_create_fherm_packed(array_of_starts,array_of_ends,is_fortran_file,my_offset,old_type,hmat_type,offset_err)
4549 : :
4550 : : !Arguments ------------------------------------
4551 : : !scalars
4552 : : integer,intent(in) :: old_type
4553 : : integer,intent(out) :: offset_err,hmat_type
4554 : : integer(XMPI_OFFSET_KIND),intent(out) :: my_offset
4555 : : logical,intent(in) :: is_fortran_file
4556 : : !arrays
4557 : : integer,intent(in) :: array_of_starts(2),array_of_ends(2)
4558 : :
4559 : : !Local variables-------------------------------
4560 : : !scalars
4561 : : integer :: nrow,my_ncol,ii,bsize_old,col,jj_glob,bsize_frm,prev_col,mpierr
4562 : : integer(XMPI_OFFSET_KIND) :: col_displ
4563 : : !arrays
4564 : 0 : integer,allocatable :: col_type(:),block_length(:),block_type(:)
4565 : 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
4566 : : !************************************************************************
4567 : :
4568 : 0 : offset_err=0
4569 : :
4570 : : ! Byte size of old_type.
4571 : 0 : call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
4572 : :
4573 [ # # ]: 0 : bsize_frm=0; if (is_fortran_file) bsize_frm = xmpio_bsize_frm
4574 : :
4575 : 0 : my_ncol = array_of_ends(2) - array_of_starts(2) + 1
4576 : : !
4577 : : ! Calculate my offset relative to the beginning of the matrix in the file.
4578 : 0 : prev_col = array_of_starts(2)-1
4579 : 0 : my_offset = (prev_col*(prev_col+1)/2)*bsize_old + (array_of_starts(1)-1)*bsize_old + 2*prev_col*bsize_frm + bsize_frm
4580 : : !
4581 : : ! col_type(col) describes the col-th column of the packed matrix.
4582 : : ! block_displ(col+1) stores its displacement taking into account the Fortran marker.
4583 [ # # # # : 0 : ABI_MALLOC(col_type,(my_ncol))
# # # # #
# # # ]
4584 [ # # # # : 0 : ABI_MALLOC(block_displ,(my_ncol+2))
# # # # #
# # # #
# ]
4585 : :
4586 [ # # ]: 0 : if (my_ncol>1) then
4587 : : col_displ=0
4588 [ # # ]: 0 : do col=1,my_ncol
4589 : 0 : jj_glob = (col-1) + array_of_starts(2)
4590 : 0 : nrow = jj_glob
4591 [ # # ]: 0 : if (jj_glob==array_of_starts(2)) nrow = jj_glob - array_of_starts(1) + 1 ! First column treated by me.
4592 [ # # ]: 0 : if (jj_glob==array_of_ends(2)) nrow = array_of_ends(1) ! Last column treated by me.
4593 : 0 : call MPI_Type_contiguous(nrow,old_type,col_type(col),mpierr)
4594 : : !
4595 [ # # ]: 0 : if (xmpio_max_address(col_displ)) offset_err=1 ! Test for wraparounds
4596 : 0 : block_displ(col+1) = col_displ
4597 : 0 : col_displ = col_displ + nrow * bsize_old + 2 * bsize_frm ! Move to the next column.
4598 : : end do
4599 : :
4600 [ # # ]: 0 : else if (my_ncol==1) then ! The case of a single column is treated separately.
4601 : 0 : block_displ(2) = 0
4602 : 0 : nrow = array_of_ends(1) - array_of_starts(1) + 1
4603 : 0 : call MPI_Type_contiguous(nrow,old_type,col_type(2),mpierr)
4604 : 0 : col_displ= nrow*bsize_old
4605 : 0 : if (xmpio_max_address(col_displ)) offset_err=1 ! Test for wraparounds
4606 : : else
4607 : 0 : call xmpi_abort(msg="my_ncol cannot be negative!")
4608 : : end if
4609 : :
4610 [ # # # # : 0 : ABI_MALLOC(block_length,(my_ncol+2))
# # # # #
# ]
4611 [ # # # # : 0 : ABI_MALLOC(block_type,(my_ncol+2))
# # # # ]
4612 : :
4613 : 0 : block_length(1)=1
4614 : 0 : block_displ (1)=0
4615 : 0 : block_type (1)=MPI_LB
4616 : :
4617 [ # # ]: 0 : do ii=2,my_ncol+1
4618 : 0 : block_length(ii)=1
4619 : 0 : block_type(ii) =col_type(ii-1)
4620 : : !write(std_out,*)" ii-1, depl, length, type: ",ii-1,block_displ(ii),block_length(ii),block_type(ii)
4621 : : end do
4622 : :
4623 : 0 : block_length(my_ncol+2)= 1
4624 : 0 : block_displ (my_ncol+2)= col_displ
4625 : 0 : block_type (my_ncol+2)= MPI_UB
4626 : :
4627 : 0 : call xmpio_type_struct(my_ncol+2,block_length,block_displ,block_type,hmat_type,mpierr)
4628 : :
4629 : 0 : call MPI_TYPE_COMMIT(hmat_type,mpierr)
4630 : :
4631 : 0 : ABI_FREE(block_length)
4632 : 0 : ABI_FREE(block_displ)
4633 : 0 : ABI_FREE(block_type)
4634 : :
4635 [ # # ]: 0 : do col=1,my_ncol
4636 : 0 : call MPI_TYPE_FREE(col_type(col),mpierr)
4637 : : end do
4638 : :
4639 [ # # ]: 0 : ABI_FREE(col_type)
4640 : :
4641 : 0 : end subroutine xmpio_create_fherm_packed
4642 : : !!***
4643 : : #endif
4644 : :
4645 : : !------------------------------------------------------------------------------------
4646 : :
4647 : : !!****f* m_xmpi/xmpio_create_coldistr_from_fpacked
4648 : : !! NAME
4649 : : !! xmpio_create_coldistr_from_fpacked
4650 : : !!
4651 : : !! FUNCTION
4652 : : !! Returns an MPI datatype that can be used to MPI-IO (read|write) the columns of an
4653 : : !! (Hermitian|Symmetric) matrix whose upper triangle is written on a Fortran binary file.
4654 : : !! Note that the view assumes that the file pointer used to instanciate the MPI-IO view
4655 : : !! points to the first element of the first column. In other words,the first Fortran record marker
4656 : : !! (if any) is not taken into account in the calculation of the displacements.
4657 : : !!
4658 : : !! INPUTS
4659 : : !! sizes(2)=Number of elements of type old_type in each dimension of the full array (array of positive integers)
4660 : : !! my_cols(2)=initial and final column to (read|write). Array of positive integers, Fortran convention.
4661 : : !! old_type=MPI datatype of the elements of the matrix.
4662 : : !!
4663 : : !! OUTPUT
4664 : : !! new_type=New MPI type that can be used to instanciate the MPI-IO view for the Fortran file.
4665 : : !! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
4666 : : !! marker (lets call it "base"). Each node should (read|write) using my_offset = base + my_offpad.
4667 : : !! my_offpad is used so that one can safely change the way the fileview is generated (for example
4668 : : !! to make it more efficient) without having to change the client code.
4669 : : !! offset_err=Error code. A non-zero returned value signals that the global matrix is tool large
4670 : : !! for a single MPI-IO access (see notes below).
4671 : : !!
4672 : : !! NOTES
4673 : : !! 1) The matrix on file is written in the following FORTRAN format (let us assume a 3x3 matrix for simplicity)
4674 : : !!
4675 : : !! m (1,1) m
4676 : : !! m (1,2) (2,2) m
4677 : : !! m (1,3) (2,3) (3,3) m
4678 : : !!
4679 : : !! each Fortran record stores a column of the packed matrix, "m" denotes the Fortran
4680 : : !! record marker that introduces holes in the file view.
4681 : : !!
4682 : : !! 2) With (signed) Fortran integers, the maximum size of the file that
4683 : : !! that can be read in one-shot is around 2Gb when etype is set to byte.
4684 : : !! Using a larger etype might create portability problems (real data on machines using
4685 : : !! integer*16 for the marker) since etype must be a multiple of the Fortran record marker
4686 : : !! Due to the above reason, block_displ is given in bytes but it has to be defined as Fortran
4687 : : !! integer. If the displacement cannot be stored in a Fortran integer, the routine returns
4688 : : !! offset_err=1 so that the caller will know that several MPI-IO reads are nedded to
4689 : : !! read the file.
4690 : : !!
4691 : : !! SOURCE
4692 : :
4693 : : #ifdef HAVE_MPI_IO
4694 : :
4695 : 0 : subroutine xmpio_create_coldistr_from_fpacked(sizes,my_cols,old_type,new_type,my_offpad,offset_err)
4696 : :
4697 : : !Arguments ------------------------------------
4698 : : !scalars
4699 : : integer,intent(in) :: old_type
4700 : : integer,intent(out) :: new_type,offset_err
4701 : : integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
4702 : : !arrays
4703 : : integer,intent(in) :: sizes(2),my_cols(2)
4704 : :
4705 : : !Local variables-------------------------------
4706 : : !scalars
4707 : : integer :: my_ncol,bsize_old,my_col
4708 : : integer :: my_nels,my_el,row_glob,ii_hpk,jj_hpk,col_glob,bsize_frm,mpierr
4709 : : integer(XMPI_OFFSET_KIND) :: my_offset,ijp_glob
4710 : : !character(len=500) :: msg
4711 : : !arrays
4712 : 0 : integer,allocatable :: block_length(:),block_type(:)
4713 : 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
4714 : : !************************************************************************
4715 : :
4716 : : ! Byte size of the Fortran record marker.
4717 : 0 : bsize_frm = xmpio_bsize_frm
4718 : :
4719 : : ! Byte size of old_type.
4720 : 0 : call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
4721 : :
4722 : : ! my number of columns and total numer of elements to be read.
4723 : 0 : my_ncol = my_cols(2) - my_cols(1) + 1
4724 : 0 : my_nels = my_ncol*sizes(1)
4725 : : !
4726 : : ! block_displ(el+1) stores the displacement of the local element el taking into account the Fortran marker.
4727 [ # # # # : 0 : ABI_MALLOC(block_displ,(my_nels+2))
# # # # #
# # # #
# ]
4728 [ # # # # : 0 : ABI_MALLOC(block_length,(my_nels+2))
# # # # #
# # # ]
4729 [ # # # # : 0 : ABI_MALLOC(block_type,(my_nels+2))
# # # # ]
4730 : :
4731 : 0 : block_length(1)=1
4732 : 0 : block_displ (1)=0
4733 : 0 : block_type (1)=MPI_LB
4734 : : !
4735 : : ! * the view assumes that the file pointer used to instanciate the MPI-IO view
4736 : : ! points to the first element of the first column. In other words,the first Fortran record marker
4737 : : ! is not taken into account in the calculation of the displacements.
4738 : 0 : my_offpad=xmpio_bsize_frm
4739 : :
4740 : : ! * Some matrix elements are read twice. This part has to be tested.
4741 : 0 : offset_err=0; my_el=0
4742 [ # # ]: 0 : do my_col=1,my_ncol
4743 : 0 : col_glob = (my_col-1) + my_cols(1)
4744 [ # # ]: 0 : do row_glob=1,sizes(1)
4745 [ # # ]: 0 : if (col_glob>=row_glob) then
4746 : 0 : ii_hpk = row_glob
4747 : 0 : jj_hpk = col_glob
4748 : 0 : ijp_glob = row_glob + col_glob*(col_glob-1)/2 ! Index for packed form
4749 : : else ! Exchange the indices as (jj,ii) will be read.
4750 : 0 : ii_hpk = col_glob
4751 : 0 : jj_hpk = row_glob
4752 : 0 : ijp_glob = col_glob + row_glob*(row_glob-1)/2 ! Index for packed form
4753 : : end if
4754 : 0 : my_el = my_el+1
4755 : 0 : my_offset = (ijp_glob-1)* bsize_old + (jj_hpk-1)*2*bsize_frm
4756 : 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! Check for wraparounds.
4757 : 0 : block_displ (my_el+1)=my_offset
4758 : 0 : block_length(my_el+1)=1
4759 : 0 : block_type (my_el+1)=old_type
4760 : : !write(std_out,*)" my_el, displ: ",my_el,block_displ(my_el+1)
4761 : : end do
4762 : : end do
4763 : :
4764 : 0 : block_length(my_nels+2)=1
4765 : 0 : block_displ (my_nels+2)=my_offset
4766 : 0 : block_type (my_nels+2)=MPI_UB
4767 : :
4768 : 0 : call xmpio_type_struct(my_nels+2,block_length,block_displ,block_type,new_type,mpierr)
4769 : :
4770 : 0 : call MPI_TYPE_COMMIT(new_type,mpierr)
4771 : :
4772 : 0 : ABI_FREE(block_length)
4773 : 0 : ABI_FREE(block_displ)
4774 : 0 : ABI_FREE(block_type)
4775 : :
4776 : 0 : end subroutine xmpio_create_coldistr_from_fpacked
4777 : : !!***
4778 : : #endif
4779 : :
4780 : : !------------------------------------------------------------------------------------
4781 : :
4782 : : !!****f* m_xmpi/xmpio_create_coldistr_from_fp3blocks
4783 : : !! NAME
4784 : : !! xmpio_create_coldistr_from_fp3blocks
4785 : : !!
4786 : : !! FUNCTION
4787 : : !! Returns an MPI datatype that can be used to MPI-IO (read|write) the columns of a
4788 : : !! matrix of the form M = (S1 F3)
4789 : : !! (F3^H S2)
4790 : : !! where S1 and S2 are square (symmetric|Hermitian) matrices whose upper triangle is stored on file
4791 : : !! while F3 is a generic matrix (not necessarily square) stored in full mode.
4792 : : !! The Fortran file contains the blocks in the following order.
4793 : : !! upper(S1)
4794 : : !! upper(S2)
4795 : : !! F3
4796 : : !! INPUTS
4797 : : !! sizes(2)=Number of elements of type old_type in each dimension of the full array M (array of positive integers)
4798 : : !! my_cols(2)=initial and final column to (read|write). Array of positive integers, Fortran convention.
4799 : : !! block_sizes(2,3)=The sizes of S1, S2, F.
4800 : : !! old_type=MPI datatype of the elements of the matrix.
4801 : : !!
4802 : : !! OUTPUT
4803 : : !! new_type=New MPI type that can be used to instanciate the MPI-IO view for the Fortran file.
4804 : : !! my_offpad=Offset to be added to the file pointer giving the position of the first Fortran record
4805 : : !! marker (lets call it "base"). Each node should (read|write) using my_offset = base + my_offpad.
4806 : : !! my_offpad is used so that one can safely change the way the fileview is generated (for example
4807 : : !! to make it more efficient) without having to change the client code.
4808 : : !! offset_err=Error code. A non-zero returned value signals that the global matrix is tool large
4809 : : !! for a single MPI-IO access (see notes below).
4810 : : !!
4811 : : !! NOTES
4812 : : !! 1) block_displ is given in bytes due to the presence of the marker.
4813 : : !! If the displacement of an element is too large, the routine returns
4814 : : !! offset_err=1 so that the caller knows that several MPI-IO reads are required to (read| write) the file.
4815 : : !!
4816 : : !! SOURCE
4817 : :
4818 : : #ifdef HAVE_MPI_IO
4819 : :
4820 : 0 : subroutine xmpio_create_coldistr_from_fp3blocks(sizes,block_sizes,my_cols,old_type,new_type,my_offpad,offset_err)
4821 : :
4822 : : !Arguments ------------------------------------
4823 : : !scalars
4824 : : integer,intent(in) :: old_type
4825 : : integer,intent(out) :: new_type,offset_err
4826 : : integer(XMPI_OFFSET_KIND),intent(out) :: my_offpad
4827 : : !arrays
4828 : : integer,intent(in) :: sizes(2),my_cols(2),block_sizes(2,3)
4829 : :
4830 : : !Local variables-------------------------------
4831 : : !scalars
4832 : : integer :: my_ncol,bsize_old,my_col,which_block,uplo,swap
4833 : : integer :: my_nels,my_el,row_glob,ii_hpk,jj_hpk,ii,jj
4834 : : integer :: col_glob,bsize_frm,mpierr,row_shift,col_shift,n1,n2
4835 : : integer(XMPI_OFFSET_KIND) :: my_offset,ijp,bsize_tot,max_displ,min_displ
4836 : : integer(XMPI_ADDRESS_KIND) :: address
4837 : : !arrays
4838 : 0 : integer,allocatable :: block_length(:),block_type(:)
4839 : 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
4840 : : integer(XMPI_OFFSET_KIND) :: bsize_mat(2)
4841 : : !************************************************************************
4842 : :
4843 [ # # # # : 0 : if (sizes(1) /= SUM(block_sizes(1,1:2)) .or. &
# # # # ]
4844 : : sizes(2) /= SUM(block_sizes(2,1:2)) ) then
4845 : 0 : write(std_out,*)" xmpio_create_coldistr_from_fp3blocks: Inconsistency between block_sizes ans sizes "
4846 : 0 : call xmpi_abort()
4847 : : end if
4848 : :
4849 [ # # # # ]: 0 : if (block_sizes(1,1) /= block_sizes(2,1) .or.&
4850 : : block_sizes(1,2) /= block_sizes(2,2) ) then
4851 : 0 : write(std_out,*)" xmpio_create_coldistr_from_fp3blocks: first two blocks must be square"
4852 : 0 : call xmpi_abort()
4853 : : end if
4854 : :
4855 [ # # # # ]: 0 : if (block_sizes(2,3) /= block_sizes(2,2) .or.&
4856 : : block_sizes(1,3) /= block_sizes(1,1) ) then
4857 : 0 : write(std_out,*)" xmpio_create_coldistr_from_fp3blocks: Full matrix must be square"
4858 : 0 : call xmpi_abort()
4859 : : end if
4860 : :
4861 : 0 : write(std_out,*)" xmpio_create_coldistr_from_fp3blocks is still under testing"
4862 : : !call xmpi_abort()
4863 : :
4864 : : ! Byte size of the Fortran record marker.
4865 : 0 : bsize_frm = xmpio_bsize_frm
4866 : :
4867 : : ! Byte size of old_type.
4868 : 0 : call MPI_TYPE_SIZE(old_type,bsize_old,mpierr)
4869 : :
4870 : : ! my number of columns and total numer of elements to be read.
4871 : 0 : my_ncol = my_cols(2) - my_cols(1) + 1
4872 : 0 : my_nels = sizes(1)*my_ncol
4873 : : !
4874 : : ! block_displ(el+1) stores the displacement of the local element el taking into account the Fortran marker.
4875 [ # # # # : 0 : ABI_MALLOC(block_displ,(my_nels+2))
# # # # #
# # # #
# ]
4876 [ # # # # : 0 : ABI_MALLOC(block_length,(my_nels+2))
# # # # #
# # # ]
4877 [ # # # # : 0 : ABI_MALLOC(block_type,(my_nels+2))
# # # # ]
4878 : : !
4879 : : ! * the view assumes that the file pointer used to instanciate the MPI-IO view
4880 : : ! points to the first element of the first column. In other words,the first Fortran record marker
4881 : : ! is not taken into account in the calculation of the displacements.
4882 : 0 : my_offpad=xmpio_bsize_frm
4883 : : !
4884 : : ! Byte size of the first two blocks including the markers.
4885 : 0 : n1=block_sizes(1,1)
4886 : 0 : bsize_mat(1) = (n1*(n1+1)/2)*bsize_old + 2*n1*bsize_frm
4887 : :
4888 : 0 : n2=block_sizes(1,2)
4889 : 0 : bsize_mat(2) = (n2*(n2+1)/2)*bsize_old + 2*n2*bsize_frm
4890 : :
4891 [ # # # # ]: 0 : bsize_tot=SUM(bsize_mat) + PRODUCT(block_sizes(:,3))*bsize_old + block_sizes(2,3)*2*bsize_frm - bsize_frm
4892 : 0 : write(std_out,*)"bsize_mat",bsize_mat,"bsize_tot",bsize_tot
4893 : : !
4894 : : ! * Some matrix elements are read twice. This part has to be tested.
4895 : 0 : offset_err=0; my_el=0; max_displ=0; min_displ=HUGE(address)
4896 [ # # ]: 0 : do my_col=1,my_ncol
4897 : 0 : col_glob = (my_col-1) + my_cols(1)
4898 [ # # ]: 0 : do row_glob=1,sizes(1)
4899 : : !
4900 : 0 : which_block=3
4901 [ # # # # ]: 0 : if (row_glob<=block_sizes(1,1).and.col_glob<=block_sizes(2,1)) which_block=1
4902 [ # # # # ]: 0 : if (row_glob >block_sizes(1,1).and.col_glob >block_sizes(2,1)) which_block=2
4903 : :
4904 [ # # ]: 0 : if ( ANY(which_block == (/1,2/)) ) then ! S1 or S2
4905 : : !
4906 : 0 : row_shift=(which_block-1)*block_sizes(1,1)
4907 : 0 : col_shift=(which_block-1)*block_sizes(2,1)
4908 : :
4909 : 0 : ii_hpk = row_glob - row_shift
4910 : 0 : jj_hpk = col_glob - col_shift
4911 [ # # ]: 0 : if (jj_hpk<ii_hpk) then ! Exchange the indices so that the symmetric is read.
4912 : 0 : swap = jj_hpk
4913 : 0 : jj_hpk = ii_hpk
4914 : 0 : ii_hpk = swap
4915 : : end if
4916 : 0 : ijp = ii_hpk + jj_hpk*(jj_hpk-1)/2 ! Index for packed form
4917 : 0 : my_offset = (ijp-1)*bsize_old + (jj_hpk-1)*2*bsize_frm
4918 [ # # ]: 0 : if (which_block==2) my_offset=my_offset+bsize_mat(1) ! Shift the offset to account for S1.
4919 : : !my_offset=4
4920 : : !
4921 : : else
4922 : : ! The element belongs either to F3 of F3^H.
4923 : : ! Now find whether it is the upper or the lower block since only F3 is stored on file.
4924 [ # # ]: 0 : uplo=1; if (row_glob>block_sizes(1,1)) uplo=2
4925 : :
4926 : : if (uplo==1) then
4927 : 0 : row_shift=0
4928 : 0 : col_shift=block_sizes(2,1)
4929 : : else
4930 : : row_shift=block_sizes(1,1)
4931 : : col_shift=0
4932 : : end if
4933 : 0 : ii = row_glob - row_shift
4934 : 0 : jj = col_glob - col_shift
4935 : :
4936 [ # # ]: 0 : if (uplo==2) then ! Exchange the indices since the symmetric element will be read.
4937 : 0 : swap=jj
4938 : 0 : jj =ii
4939 : 0 : ii =swap
4940 : : end if
4941 : :
4942 : 0 : my_offset = (ii-1)*bsize_old + (jj-1)*block_sizes(1,3)*bsize_old + (jj-1)*2*bsize_frm
4943 [ # # ]: 0 : my_offset = my_offset + SUM(bsize_mat)
4944 : : !if (uplo==1) my_offset=my_offset + bsize_mat(1)
4945 : : !my_offset=0
4946 : : !if (ii==1.and.jj==1) write(std_out,*)" (1,1) offset = ",my_offset
4947 : : !if (ii==block_sizes(1,3).and.jj==block_sizes(2,3)) write(std_out,*)" (n,n) offset =", my_offset
4948 [ # # ]: 0 : if (my_offset>=bsize_tot-1*bsize_old) then
4949 : 0 : write(std_out,*)"WARNING (my_offset>bsize_tot-bsize_old),",ii,jj,my_offset,bsize_tot
4950 : : end if
4951 : : end if
4952 : :
4953 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! Check for wraparounds.
4954 : 0 : my_el = my_el+1
4955 : 0 : block_displ (my_el+1)=my_offset
4956 : 0 : block_length(my_el+1)=1
4957 : 0 : block_type (my_el+1)=old_type
4958 : 0 : max_displ = MAX(max_displ,my_offset)
4959 : 0 : min_displ = MIN(min_displ,my_offset)
4960 : : !if (which_block==3) write(std_out,*)" my_el, which, displ: ",my_el,which_block,block_displ(my_el+1)
4961 : : end do
4962 : : end do
4963 : :
4964 : : !write(std_out,*)" MAX displ = ",max_displ," my_nels = ",my_nels
4965 : : !write(std_out,*)" MIN displ = ",MINVAL(block_displ(2:my_nels+1))
4966 : :
4967 : : !block_displ (1)=max_displ ! Do not change this value.
4968 : : !if (min_displ>0) block_displ (1)=min_displ ! Do not change this value.
4969 : :
4970 : : block_displ (1)=min_displ
4971 : 0 : block_displ (1)=0
4972 : 0 : block_length(1)=0
4973 : 0 : block_type (1)=MPI_LB
4974 : :
4975 : 0 : block_length(my_nels+2)=0
4976 : : !block_displ (my_nels+2)=bsize_tot
4977 : 0 : block_displ (my_nels+2)=max_displ
4978 : 0 : block_type (my_nels+2)=MPI_UB
4979 : :
4980 : 0 : call xmpio_type_struct(my_nels+2,block_length,block_displ,block_type,new_type,mpierr)
4981 : : !call xmpio_type_struct(my_nels,block_length(2:),block_displ(2:),block_type(2:),new_type,mpierr)
4982 : :
4983 : : !call MPI_TYPE_CREATE_INDEXED_BLOCK(my_nels, block_length(2:), block_displ(2:), old_type, new_type, mpierr)
4984 : :
4985 : 0 : call MPI_TYPE_COMMIT(new_type,mpierr)
4986 : :
4987 : 0 : ABI_FREE(block_length)
4988 : 0 : ABI_FREE(block_displ)
4989 : 0 : ABI_FREE(block_type)
4990 : :
4991 : 0 : end subroutine xmpio_create_coldistr_from_fp3blocks
4992 : : !!***
4993 : : #endif
4994 : :
4995 : : !!****f* m_xmpi/xmpi_distrib_2d
4996 : : !! NAME
4997 : : !! xmpi_distrib_2d
4998 : : !!
4999 : : !! FUNCTION
5000 : : !! Try to optimally distribute nprocs in a 2d grid of shape (n1, n2) given a problem of dimension (size1, size2).
5001 : : !! Use order string to define priorities:
5002 : : !! "12" or "21" if both dimensions should be optimized (if not possibile the first one gets optimized).
5003 : : !! "1" or "2" to optimize only one dimension.
5004 : : !! Return: exit status in ierr.
5005 : : !!
5006 : : !! SOURCE
5007 : :
5008 : 26 : subroutine xmpi_distrib_2d(nprocs, order, size1, size2, n1, n2, ierr)
5009 : :
5010 : : !Arguments ------------------------------------
5011 : : integer,intent(in) :: nprocs, size1, size2
5012 : : character(len=*),intent(in) :: order
5013 : : integer,intent(out) :: n1, n2, ierr
5014 : :
5015 : : !Local variables-------------------------------
5016 : : integer :: ii
5017 : : !----------------------------------------------------------------------
5018 : :
5019 : 26 : ierr = 1; n1 = -1; n2 = -1
5020 : :
5021 : 40 : select case (order)
5022 : : case ("12")
5023 : 14 : call balance_12()
5024 [ - + ]: 14 : if (ierr /= 0) call balance_1()
5025 : : case ("21")
5026 : 3 : call balance_21()
5027 [ - + ]: 3 : if (ierr /= 0) call balance_2()
5028 : : case ("1")
5029 : 9 : call balance_1()
5030 : : case ("2")
5031 : 0 : call balance_2()
5032 : : case default
5033 : : ! Wrong order
5034 [ + + + - : 26 : ierr = -1
- ]
5035 : : end select
5036 : :
5037 : : contains
5038 : :
5039 : 14 : subroutine balance_12()
5040 : : ! Try to find n1 x n2 = nprocs so that (size1, size2) are multiple of (n1, n2)
5041 [ + - ]: 14 : do ii=nprocs,1,-1
5042 [ + - + - : 14 : if (mod(size1, ii) == 0 .and. mod(nprocs, ii) == 0 .and. mod(size2, nprocs / ii) == 0) then
+ - ]
5043 : 14 : n1 = ii; n2 = nprocs / ii; ierr = 0; exit
5044 : : end if
5045 : : end do
5046 : :
5047 : 14 : end subroutine balance_12
5048 : :
5049 : 3 : subroutine balance_21()
5050 : : ! Try to find n1 x n2 = nprocs so that (size1, size2) are multiple of (n1, n2)
5051 [ + - ]: 3 : do ii=nprocs,1,-1
5052 [ + - + - : 3 : if (mod(size2, ii) == 0 .and. mod(nprocs, ii) == 0 .and. mod(size1, nprocs / ii) == 0) then
+ - ]
5053 : 3 : n2 = ii; n1 = nprocs / ii; ierr = 0; exit
5054 : : end if
5055 : : end do
5056 : 3 : end subroutine balance_21
5057 : :
5058 : 9 : subroutine balance_1()
5059 : : integer :: imod1
5060 : : ! Try to find n1 x n2 = nprocs so that only size1 is multiple of n1. Allow for some load imbalance.
5061 [ + - ]: 9 : do ii=nprocs,1,-1
5062 : 9 : imod1 = mod(size1, ii)
5063 [ - + - - : 9 : if ((imod1 == 0 .or. imod1 >= nprocs / 2) .and. mod(nprocs, ii) == 0 .and. size2 >= (nprocs/ii)) then
+ - + - ]
5064 : 9 : n1 = ii; n2 = nprocs / ii; ierr = 0; exit
5065 : : end if
5066 : : end do
5067 : :
5068 [ - + - - ]: 9 : if (ierr /= 0 .and. nprocs <= size1) then
5069 : 0 : n1 = nprocs; n2 = 1; ierr = 0; return
5070 : : end if
5071 : : end subroutine balance_1
5072 : :
5073 : 0 : subroutine balance_2()
5074 : : integer :: imod2
5075 : : ! Try to find n1 x n2 = nprocs so that only size2 is multiple of n2. Allow for some load imbalance.
5076 [ # # ]: 0 : do ii=nprocs,1,-1
5077 : 0 : imod2 = mod(size2, ii)
5078 [ # # # # : 0 : if ((imod2 == 0 .or. imod2 >= nprocs / 2) .and. mod(nprocs, ii) == 0 .and. size1 >= (nprocs/ii)) then
# # # # ]
5079 : 0 : n2 = ii; n1 = nprocs / ii; ierr = 0; exit
5080 : : end if
5081 : : end do
5082 : :
5083 [ # # # # ]: 0 : if (ierr /= 0 .and. nprocs <= size2) then
5084 : 0 : n2 = nprocs; n1 = 1; ierr = 0; return
5085 : : end if
5086 : : end subroutine balance_2
5087 : :
5088 : : end subroutine xmpi_distrib_2d
5089 : : !!***
5090 : :
5091 : : !----------------------------------------------------------------------
5092 : :
5093 : : !!****f* m_xmpi/xmpi_split_nsppol
5094 : : !! NAME
5095 : : !! xmpi_split_nsppol
5096 : : !!
5097 : : !! FUNCTION
5098 : : !! Distribute collinear spins. Also create and return indirect mapping to spin index and init %brange_spin
5099 : : !!
5100 : : !! INPUTS
5101 : : !! in_comm=Input communicator
5102 : : !! nsppol=Number of spins
5103 : : !!
5104 : : !! OUTPUT
5105 : : !! my_nspins=Number of spins treated by this MPI proc
5106 : : !! my_spins(my_nspins)=Spin index
5107 : : !! comm_my_is(my_nspins)=Spin communicator for each spin treated by this MPI proc.
5108 : : !!
5109 : : !! SOURCE
5110 : :
5111 : 2 : subroutine xmpi_split_nsppol(in_comm, nsppol, my_nspins, my_spins, comm_my_is)
5112 : :
5113 : : !Arguments ------------------------------------
5114 : : !scalars
5115 : : integer,intent(in) :: in_comm, nsppol
5116 : : integer,intent(out) :: my_nspins
5117 : : integer,allocatable,intent(out) :: my_spins(:)
5118 : : type(xcomm_t),allocatable,intent(out) :: comm_my_is(:)
5119 : :
5120 : : !Local variables-------------------------------
5121 : : !scalars
5122 : : integer :: spin, my_rank, ierr, color, all_nprocs
5123 : : !arrays
5124 : 4 : integer :: buff_spin(nsppol), comm_spin(nsppol)
5125 : : !----------------------------------------------------------------------
5126 : :
5127 : 2 : all_nprocs = xmpi_comm_size(in_comm); my_rank = xmpi_comm_rank(in_comm)
5128 : :
5129 : 2 : my_nspins = 0
5130 [ + + ]: 4 : do spin=1,nsppol
5131 : : ! NB: If MPI_UNDEFINED is passed as the colour value, the subgroup in which the calling MPI process will be placed is MPI_COMM_NULL
5132 : 2 : color = 1
5133 [ - + - - ]: 2 : if (nsppol == 2 .and. all_nprocs > 1) then
5134 : 0 : color = xmpi_undefined
5135 [ # # # # ]: 0 : if (spin == 1 .and. my_rank <= (all_nprocs - 1) / 2) color = 1
5136 [ # # # # ]: 0 : if (spin == 2 .and. my_rank > (all_nprocs - 1) / 2) color = 1
5137 : : end if
5138 : :
5139 : 2 : call xmpi_comm_split(in_comm, color, my_rank, comm_spin(spin), ierr)
5140 [ + - ]: 4 : if (comm_spin(spin) /= xmpi_comm_null) then
5141 : 2 : my_nspins = my_nspins + 1
5142 : 2 : buff_spin(my_nspins) = spin
5143 : : end if
5144 : : end do
5145 : :
5146 [ - + + - : 8 : ABI_MALLOC(comm_my_is, (my_nspins))
+ - + - -
+ - + - +
+ + ]
5147 : 2 : my_nspins = 0
5148 [ + + ]: 4 : do spin=1,nsppol
5149 [ + - ]: 4 : if (comm_spin(spin) /= xmpi_comm_null) then
5150 : 2 : my_nspins = my_nspins + 1
5151 : 2 : comm_my_is(my_nspins) = xcomm_from_mpi_int(comm_spin(spin), free=.True.)
5152 : : end if
5153 : : end do
5154 : :
5155 [ - + + - : 6 : ABI_MALLOC(my_spins, (my_nspins))
+ - + - -
+ - + -
+ ]
5156 [ - + + + ]: 6 : my_spins = buff_spin(1:my_nspins)
5157 : :
5158 : 2 : end subroutine xmpi_split_nsppol
5159 : : !!***
5160 : :
5161 : : ! Init xcomm_t instance from MPI integer. Relase comm_int if optional argument free is set to .True.
5162 : : ! [root]: Rank of the proc treating iteration `iter`
5163 : :
5164 : 86 : type(xcomm_t) function xcomm_from_mpi_int(comm_int, free) result(new)
5165 : :
5166 : : !Arguments ------------------------------------
5167 : : integer,intent(inout) :: comm_int
5168 : : integer :: new_comm, ierr
5169 : : logical,optional,intent(in) :: free
5170 : : !----------------------------------------------------------------------
5171 : :
5172 : 86 : new%value = comm_int; new%me = 0; new%nproc = 1
5173 : : #ifdef HAVE_MPI
5174 : 86 : call MPI_Comm_dup(comm_int, new_comm, ierr)
5175 : 86 : new%value = new_comm
5176 : 86 : new%nproc = xmpi_comm_size(new_comm)
5177 : 86 : new%me = xmpi_comm_rank(new_comm)
5178 [ + + ]: 86 : if (present(free)) then
5179 [ + - ]: 32 : if (free) call xmpi_comm_free(comm_int)
5180 : : end if
5181 : : #endif
5182 : 86 : end function xcomm_from_mpi_int
5183 : :
5184 : : ! Skip iteration `iter` according to rank in xcomm.
5185 : : ! [root]: Rank of the proc treating iteration `iter`
5186 : :
5187 : 428171 : logical function xcomm_skip(xcomm, iter, root)
5188 : :
5189 : : !Arguments ------------------------------------
5190 : : class(xcomm_t),intent(in) :: xcomm
5191 : : integer,intent(in) :: iter
5192 : : integer,optional,intent(out) :: root
5193 : :
5194 : : !Local variables-------------------------------
5195 : : integer :: root__
5196 : : !----------------------------------------------------------------------
5197 : :
5198 : 428171 : root__ = mod(iter, xcomm%nproc)
5199 : 428171 : xcomm_skip = root__ /= xcomm%me
5200 [ + + ]: 428171 : if (present(root)) root = root__
5201 : 428171 : end function xcomm_skip
5202 : :
5203 : 177 : subroutine xcomm_set_to_self(xcomm)
5204 : : class(xcomm_t),intent(inout) :: xcomm
5205 : 177 : call xcomm%free()
5206 : 177 : xcomm%value = xmpi_comm_self; xcomm%me = 0; xcomm%nproc = 1
5207 : 177 : end subroutine xcomm_set_to_self
5208 : :
5209 : 58 : subroutine xcomm_set_to_null(xcomm)
5210 : : !Arguments ------------------------------------
5211 : : class(xcomm_t),intent(inout) :: xcomm
5212 : : !----------------------------------------------------------------------
5213 : :
5214 : 58 : call xcomm%free()
5215 : 58 : xcomm%value = xmpi_comm_null
5216 : 58 : end subroutine xcomm_set_to_null
5217 : :
5218 : 1830 : subroutine xcomm_free(xcomm)
5219 : : !Arguments ------------------------------------
5220 : : class(xcomm_t),intent(inout) :: xcomm
5221 : : !----------------------------------------------------------------------
5222 : 1830 : call xmpi_comm_free(xcomm%value)
5223 : 1830 : xcomm%me = -1; xcomm%nproc = 0
5224 : 1830 : end subroutine xcomm_free
5225 : :
5226 : : ! Build sub-communicators in a Cartesian grid.
5227 [ - + - + ]: 652 : subroutine xcomm_from_cart_sub(xcomm, comm_cart, keepdim)
5228 : :
5229 : : !Arguments ------------------------------------
5230 : : class(xcomm_t),intent(out) :: xcomm
5231 : : integer,intent(in) :: comm_cart
5232 : : logical,intent(in) :: keepdim(:)
5233 : :
5234 : : !Local variables-------------------------------
5235 : : integer :: ierr
5236 : : !----------------------------------------------------------------------
5237 : :
5238 : : #ifdef HAVE_MPI
5239 [ - + - - : 652 : call MPI_CART_SUB(comm_cart, keepdim, xcomm%value, ierr)
- - - + -
- ]
5240 : : #endif
5241 : 652 : xcomm%me = xmpi_comm_rank(xcomm%value)
5242 : 652 : xcomm%nproc = xmpi_comm_size(xcomm%value)
5243 : :
5244 : 652 : end subroutine xcomm_from_cart_sub
5245 : :
5246 : : ! Creates new communicators based on split types and keys
5247 : :
5248 : 30 : type(xcomm_t) function xcomm_split_type(xcomm, split_type, key) result(out_xcomm)
5249 : :
5250 : : class(xcomm_t),intent(in) :: xcomm
5251 : : integer,intent(in),optional :: split_type, key
5252 : :
5253 : : !Local variables-------------------------------
5254 : : integer :: split_type__, key__, shared_comm, ierr
5255 : : !----------------------------------------------------------------------
5256 : :
5257 : 0 : key__ = 0; if (present(key)) key__ = key
5258 : :
5259 : : #ifdef HAVE_MPI
5260 : : ! Get node-level communicator
5261 [ - + ]: 30 : split_type__ = MPI_COMM_TYPE_SHARED; if (present(split_type)) split_type__ = split_type
5262 : 30 : call MPI_Comm_split_type(xcomm%value, split_type__, key__, MPI_INFO_NULL, shared_comm, ierr)
5263 [ - + ]: 30 : if (ierr /= MPI_SUCCESS) call xmpi_abort(msg="MPI_COMM_SPLIT_TYPE returned ierr /= 0")
5264 : 30 : out_xcomm = xcomm_from_mpi_int(shared_comm, free=.True.)
5265 : : #else
5266 : : call out_xcomm%set_to_self()
5267 : : #endif
5268 : :
5269 [ - + ]: 30 : end function xcomm_split_type
5270 : :
5271 : : ! Prepare a typical gatherv operation in which each MPI rank sends
5272 : : ! `nitems_per_rank(rank+1)` items and each item has length `nelem_per_item`.
5273 : : ! Final results are packed according to the rank of the processor.
5274 : :
5275 : 0 : subroutine xcomm_prep_gatherv(xcomm, nelem_per_item, nitems_per_rank, sendcount, recvcounts, displs)
5276 : :
5277 : : !Arguments ------------------------------------
5278 : : class(xcomm_t),intent(in) :: xcomm
5279 : : integer,intent(in) :: nelem_per_item, nitems_per_rank(xcomm%nproc)
5280 : : integer,intent(out) :: sendcount
5281 : : integer, allocatable, intent(out) :: recvcounts(:), displs(:)
5282 : :
5283 : : !Local variables-------------------
5284 : : integer :: ii
5285 : : !----------------------------------------------------------------------
5286 : :
5287 [ # # # # : 0 : ABI_MALLOC(recvcounts, (xcomm%nproc))
# # # # #
# # # #
# ]
5288 [ # # # # : 0 : ABI_MALLOC(displs, (xcomm%nproc))
# # # # #
# ]
5289 : 0 : sendcount = nelem_per_item * nitems_per_rank(xcomm%me + 1)
5290 : :
5291 [ # # ]: 0 : recvcounts(:) = nelem_per_item * nitems_per_rank
5292 : 0 : displs(1) = 0
5293 [ # # ]: 0 : do ii=2,xcomm%nproc
5294 [ # # ]: 0 : displs(ii) = nelem_per_item * sum(nitems_per_rank(1:ii-1))
5295 : : end do
5296 : 0 : end subroutine xcomm_prep_gatherv
5297 : : !!***
5298 : :
5299 : : ! Debugging tool to print the hostname of the procs in the communicator
5300 : 0 : subroutine xcomm_print_names(xcomm)
5301 : :
5302 : : !Arguments ------------------------------------
5303 : : class(xcomm_t),intent(in) :: xcomm
5304 : :
5305 : : !Local variables-------------------
5306 : : integer :: ip, ierr !, shared_comm
5307 : 0 : character(len=xmpi_max_processor_name) :: my_name, names(xcomm%nproc)
5308 : : !----------------------------------------------------------------------
5309 : :
5310 : 0 : call xmpi_name(my_name, ierr)
5311 : : ! FIXME
5312 : : !call xmpi_allgather(my_name, names, xcomm%value, ierr)
5313 : :
5314 : : ! ! Get node-level communicator.
5315 : : ! shared_comm = xmpi_comm_world
5316 : : !#ifdef HAVE_MPI
5317 : : ! call MPI_Comm_split_type(xcomm%value, MPI_COMM_TYPE_SHARED, 0, MPI_INFO_NULL, shared_comm, ierr)
5318 : : !#endif
5319 : : ! shared_rank = xmpi_comm_rank(shared_comm)
5320 : : ! shared_size = xmpi_comm_size(shared_comm)
5321 : :
5322 [ # # ]: 0 : if (xcomm%me == 0) then
5323 : 0 : write(std_out, "(a5,2x,a20)")"rank", "hostname"
5324 [ # # ]: 0 : do ip=0,xcomm%nproc-1
5325 [ # # ]: 0 : write(std_out, "(i5,2x,a20)")ip, trim(names(ip+1))
5326 : : !write(*,*) 'Global rank', xcomm%me, trim(name(:name_len)), 'Shared rank', shared_rank, 'Shared size', shared_size
5327 : : end do
5328 : : end if
5329 : :
5330 : 0 : end subroutine xcomm_print_names
5331 : : !!***
5332 : :
5333 : : ! True if all procs in xcomm can create a shared memory region. Cache the result.
5334 : 174 : logical function xcomm_can_use_shmem(xcomm) result(ok)
5335 : :
5336 : : !Arguments ------------------------------------
5337 : : class(xcomm_t),intent(inout) :: xcomm
5338 : : !Local variables-------------------
5339 : : integer :: ierr, new_comm
5340 : : !----------------------------------------------------------------------
5341 : :
5342 : 174 : ok = .False.
5343 : : #ifdef HAVE_MPI
5344 [ + + ]: 174 : if (xcomm%can_use_shmem__ == - 1) then
5345 : : ! First call --> cache result
5346 : 126 : call MPI_COMM_SPLIT_TYPE(xcomm%value, MPI_COMM_TYPE_SHARED, xcomm%me, MPI_INFO_NULL, new_comm, ierr)
5347 [ - + ]: 126 : xcomm%can_use_shmem__ = merge(1, 0, xmpi_comm_size(new_comm) == xcomm%nproc)
5348 : 126 : call xmpi_comm_free(new_comm)
5349 : : end if
5350 : 174 : ok = xcomm%can_use_shmem__ == 1
5351 : : #endif
5352 : :
5353 : 174 : end function xcomm_can_use_shmem
5354 : : !!***
5355 : :
5356 : 78 : subroutine xcomm_allocate_shared_master(xcomm, count, kind, info, baseptr, win)
5357 : :
5358 : : !Arguments ------------------------------------
5359 : : class(xcomm_t),intent(inout) :: xcomm
5360 : : integer(kind=XMPI_ADDRESS_KIND), intent(in) :: count
5361 : : integer,intent(in) :: kind, info
5362 : : type(c_ptr),intent(out) :: baseptr
5363 : : integer,intent(out) :: win
5364 : :
5365 : : !Local variables-------------------
5366 : : integer :: disp_unit, ierr
5367 : : integer(kind=XMPI_ADDRESS_KIND) :: my_size
5368 : : !----------------------------------------------------------------------
5369 : :
5370 [ - + ]: 78 : if (.not. xcomm%can_use_shmem()) call xmpi_abort(msg="MPI communicator does not support shared memory allocation!")
5371 : :
5372 : 78 : select case (kind)
5373 : : case (sp)
5374 : 0 : disp_unit = xmpi_bsize_sp
5375 : : case (dp)
5376 : 78 : disp_unit = xmpi_bsize_dp
5377 : : case default
5378 [ - + - ]: 78 : call xmpi_abort(msg="Invalid kind")
5379 : : end select
5380 : :
5381 : : #ifdef HAVE_MPI_ALLOCATE_SHARED_CPTR
5382 : : ! This call is problematic as the API with type(c_ptr) requires mpi_f08 else gcc complains with
5383 : : ! Error: Type mismatch in argument 'baseptr' at (1); passed TYPE(c_ptr) to INTEGER(8)
5384 : : ! See https://github.com/pmodels/mpich/issues/2659
5385 : : ! Converting C_PTR to INTEGER(KIND=MPI_ADDRESS_KIND) with the trick below is not portable:
5386 : : !address = transfer(baseptr, address)
5387 : :
5388 [ + + ]: 78 : my_size = 0; if (xcomm%me == 0) my_size = count * disp_unit
5389 : 78 : call MPI_WIN_ALLOCATE_SHARED(my_size, disp_unit, info, xcomm%value, baseptr, win, ierr)
5390 [ - + ]: 78 : if (ierr /= MPI_SUCCESS) call xmpi_abort(msg="mpi_win_allocated_shared returned ierr /= 0")
5391 : 78 : xmpi_count_wins = xmpi_count_wins + 1
5392 : :
5393 : : ! Synchronize to ensure memory is allocated.
5394 : 78 : call MPI_Barrier(xcomm%value, ierr)
5395 : :
5396 [ + + ]: 78 : if (xcomm%me /= 0) then
5397 : 52 : call MPI_WIN_SHARED_QUERY(win, 0, my_size, disp_unit, baseptr, ierr)
5398 [ - + ]: 52 : if (ierr /= MPI_SUCCESS) call xmpi_abort(msg="mpi_win_shared_query returned ierr /= 0")
5399 : : end if
5400 : :
5401 : : ! No local operations prior to this epoch, so give an assertion
5402 : 78 : call MPI_Win_fence(MPI_MODE_NOPRECEDE, win, ierr)
5403 [ - + ]: 78 : if (ierr /= MPI_SUCCESS) call xmpi_abort(msg="mpi_win_shared_query returned ierr /= 0")
5404 : :
5405 : 78 : call MPI_Barrier(xcomm%value, ierr)
5406 : :
5407 : : #else
5408 : : call xmpi_abort(msg="MPI_WIN_ALLOCATE_SHARED with C_PTR is not supported by your MPI library!")
5409 : : #endif
5410 : :
5411 : 78 : end subroutine xcomm_allocate_shared_master
5412 : : !!***
5413 : :
5414 : : !!****f* m_xmpi/pool2d_from_dims
5415 : : !! NAME
5416 : : !! pool2d_from_dims
5417 : : !!
5418 : : !! FUNCTION
5419 : : !! Build pool of MPI procs to distribute (n1 x n2) tasks.
5420 : : !!
5421 : : !! INPUTS
5422 : : !! n1, n2: dimensions of the problem
5423 : : !! input_comm: Initial MPI communicator
5424 : : !! with_pools: Set it to False to use just one pool.
5425 : : !! [rectangular]: If True, change the number of procs in each pool so that it's possible to
5426 : : !! create a rectangular grid. Useful for Scalapack algorithms in which 1d grid are not efficient.
5427 : : !! Default: False.
5428 : : !!
5429 : : !! SOURCE
5430 : :
5431 : 0 : subroutine pool2d_from_dims(pool, n1, n2, input_comm, with_pools, rectangular)
5432 : :
5433 : : !Arguments-------------------------
5434 : : class(xmpi_pool2d_t),intent(out) :: pool
5435 : : integer,intent(in) :: n1, n2, input_comm
5436 : : logical,intent(in) :: with_pools
5437 : : logical,optional,intent(in) :: rectangular
5438 : :
5439 : : !Local variables-------------------
5440 : : integer :: itask, ntasks, my_rank, nprocs, color, mpierr, jj, i1, i2, my_ntasks, new_comm
5441 : : integer :: grid_dims(2) !, check(n1, n2)
5442 [ # # ]: 0 : integer,allocatable :: my_inds(:)
5443 : : !----------------------------------------------------------------------
5444 : :
5445 : 0 : my_rank = xmpi_comm_rank(input_comm); nprocs = xmpi_comm_size(input_comm)
5446 : :
5447 : 0 : pool%n1 = n1; pool%n2 = n2
5448 [ # # # # : 0 : ABI_MALLOC(pool%treats, (n1, n2))
# # # # #
# # # # #
# # # # ]
5449 [ # # # # ]: 0 : pool%treats = .False.
5450 : :
5451 : 0 : ntasks = n1 * n2; color = ntasks + 1
5452 : :
5453 [ # # ]: 0 : if (.not. with_pools) then
5454 [ # # # # ]: 0 : pool%treats = .True.; color = 1
5455 : :
5456 [ # # ]: 0 : else if (nprocs <= ntasks) then
5457 : 0 : color = my_rank
5458 : 0 : call xmpi_split_block(ntasks, input_comm, my_ntasks, my_inds)
5459 [ # # ]: 0 : do jj=1,size(my_inds)
5460 : 0 : itask = my_inds(jj) ! = i1 + (i2 - 1) * n1
5461 : 0 : i1 = mod(itask - 1, n1) + 1
5462 : 0 : i2 = 1 + (itask - i1) / n1
5463 : 0 : pool%treats(i1, i2) = .True.
5464 : : end do
5465 [ # # ]: 0 : ABI_FREE(my_inds)
5466 : : else
5467 [ # # ]: 0 : i2_loop: do i2=1,n2
5468 [ # # ]: 0 : do i1=1,n1
5469 : 0 : itask = i1 + (i2 - 1) * n1
5470 [ # # ]: 0 : if (xmpi_distrib_with_replicas(itask, ntasks, my_rank, nprocs)) then
5471 : 0 : pool%treats(i1, i2) = .True.; color = itask; exit i2_loop
5472 : : end if
5473 : : end do
5474 : : end do i2_loop
5475 : : end if
5476 : :
5477 : : !DEBUG
5478 : : ! where (pool%treats)
5479 : : ! check = 1
5480 : : ! else where
5481 : : ! check = 0
5482 : : ! end where
5483 : : ! call xmpi_sum(check, input_comm, mpierr)
5484 : : ! if (any(check == 0)) then
5485 : : ! write(std_out, *) check
5486 : : ! call xmpi_abort(msg="Wrong distribution in pool2d_from_dims")
5487 : : ! end if
5488 : : !END_DEBUG
5489 : :
5490 : 0 : call xmpi_comm_split(input_comm, color, my_rank, new_comm, mpierr)
5491 : 0 : pool%comm = xcomm_from_mpi_int(new_comm)
5492 : 0 : call xmpi_comm_free(new_comm)
5493 : :
5494 [ # # # # : 0 : if (present(rectangular)) then
# # ]
5495 [ # # ]: 0 : if (rectangular) then
5496 [ # # # # ]: 0 : if (pool%comm%nproc == 1 .or. is_rectangular_grid(pool%comm%nproc, grid_dims)) return
5497 : :
5498 [ # # ]: 0 : do jj=pool%comm%nproc-1,1,-1
5499 [ # # ]: 0 : if (is_rectangular_grid(jj, grid_dims)) then
5500 [ # # ]: 0 : color = merge(1, 0, pool%comm%me < jj)
5501 : 0 : call xmpi_comm_split(pool%comm%value, color, pool%comm%me, new_comm, mpierr)
5502 : 0 : call pool%comm%free()
5503 : 0 : pool%comm = xcomm_from_mpi_int(new_comm)
5504 : 0 : call xmpi_comm_free(new_comm)
5505 [ # # # # : 0 : if (color == 0) pool%treats = .False.
# # ]
5506 : : exit
5507 : : end if
5508 : : end do
5509 : : end if
5510 : : end if
5511 : :
5512 : : contains
5513 : :
5514 : 0 : logical function is_rectangular_grid(nproc, grid_dims) result (ans)
5515 : : integer,intent(in) :: nproc
5516 : : integer,intent(out) :: grid_dims(2)
5517 : :
5518 : : !----------------------------------------------------------------------
5519 : : integer :: i
5520 : : ! Search for a rectangular grid of processors
5521 : 0 : i = INT(SQRT(float(nproc)))
5522 [ # # ]: 0 : do while (MOD(nproc,i) /= 0)
5523 : 0 : i = i - 1
5524 : : end do
5525 : 0 : i = max(i, 1)
5526 : :
5527 : 0 : grid_dims(1) = i
5528 : 0 : grid_dims(2) = int(nproc / i)
5529 [ # # # # ]: 0 : ans = grid_dims(1) > 1 .and. grid_dims(2) > 1
5530 : :
5531 : 0 : end function is_rectangular_grid
5532 : :
5533 : : end subroutine pool2d_from_dims
5534 : : !!***
5535 : :
5536 : : !!****f* m_xmpi/pool2d_free
5537 : : !! NAME
5538 : : !! pool2d_free
5539 : : !!
5540 : : !! FUNCTION
5541 : : !! Free memory
5542 : :
5543 : 0 : subroutine pool2d_free(pool)
5544 : :
5545 : : !Arguments-------------------------
5546 : : class(xmpi_pool2d_t),intent(inout) :: pool
5547 : : !----------------------------------------------------------------------
5548 : :
5549 [ # # ]: 0 : ABI_SFREE(pool%treats)
5550 : 0 : call pool%comm%free()
5551 : :
5552 : 0 : end subroutine pool2d_free
5553 : : !!***
5554 : :
5555 : 6564 : subroutine xmpi_win_fence(assert, win, ierr)
5556 : :
5557 : : !Arguments ------------------------------------
5558 : : integer,intent(in) :: win, assert
5559 : : integer,intent(out) :: ierr
5560 : : !----------------------------------------------------------------------
5561 : :
5562 : 6564 : ierr = 0
5563 : : #ifdef HAVE_MPI
5564 : 6564 : call MPI_WIN_FENCE(assert, win, ierr)
5565 : : #endif
5566 : :
5567 : 6564 : end subroutine xmpi_win_fence
5568 : :
5569 : 78 : subroutine xmpi_win_free(win, ierr)
5570 : :
5571 : : !Arguments-------------------------
5572 : : integer,intent(inout) :: win
5573 : : integer,intent(out) :: ierr
5574 : : !----------------------------------------------------------------------
5575 : :
5576 : 78 : ierr = 0
5577 : : #ifdef HAVE_MPI
5578 : 78 : call MPI_WIN_FREE(win, ierr)
5579 : 78 : win = xmpi_undefined
5580 : 78 : xmpi_count_wins = xmpi_count_wins - 1
5581 : : #endif
5582 : :
5583 : 78 : end subroutine xmpi_win_free
5584 : : !!***
5585 : :
5586 : : ! Return the number of nodes `num_nodes` in the `in_comm` communicator.
5587 : :
5588 : : subroutine xmpi_get_nodes_in_comm(in_comm, num_nodes, nprocs_per_node)
5589 : :
5590 : : !Arguments-------------------------
5591 : : integer,intent(in) :: in_comm
5592 : : integer,intent(out) :: num_nodes
5593 : : integer,optional,allocatable,intent(out) :: nprocs_per_node(:)
5594 : :
5595 : : !Local variables-------------------
5596 : : integer :: ierr, in_rank, node_comm, node_rank !, masters_comm, color, np
5597 : : !----------------------------------------------------------------------
5598 : :
5599 : : #ifndef HAVE_MPI
5600 : : num_nodes = 1
5601 : : if (present(nprocs_per_node)) then
5602 : : ABI_MALLOC(nprocs_per_node, (num_nodes))
5603 : : nprocs_per_node = 1
5604 : : end if
5605 : :
5606 : : #else
5607 : : in_rank = xmpi_comm_rank(in_comm)
5608 : : call MPI_COMM_SPLIT_TYPE(in_comm, MPI_COMM_TYPE_SHARED, in_rank, MPI_INFO_NULL, node_comm, ierr)
5609 : : node_rank = xmpi_comm_rank(node_comm)
5610 : : num_nodes = merge(1, 0, node_rank == 0)
5611 : : call xmpi_sum(num_nodes, in_comm, ierr)
5612 : :
5613 : : !if (present(nprocs_per_node)) then
5614 : : ! ABI_MALLOC(nprocs_per_node, (num_nodes))
5615 : : ! color = merge(0, 1, node_rank == 0)
5616 : : ! call xmpi_comm_split(in_comm, color, in_rank, masters_comm, ierr)
5617 : : ! if (color == 0) then
5618 : : ! np = xmpi_comm_size(node_comm)
5619 : : ! call MPI_GATHER(np, 1, MPI_INT, nprocs_per_node, 1, MPI_INT, 0, masters_comm, ierr)
5620 : : ! end if
5621 : : ! call xmpi_comm_free(masters_comm)
5622 : : !end if
5623 : :
5624 : : call xmpi_comm_free(node_comm)
5625 : : #endif
5626 : :
5627 : : end subroutine xmpi_get_nodes_in_comm
5628 : : !!***
5629 : :
5630 [ # # # # : 0 : end module m_xmpi
# # # # #
# # # ]
5631 : : !!***
|
