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