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