Branch data Line data Source code
1 : : !!****m* ABINIT/m_mpiotk
2 : : !! NAME
3 : : !! m_mpiotk
4 : : !!
5 : : !! FUNCTION
6 : : !! This module provides helper functions for MPI-IO operations.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2009-2026 ABINIT group (MG)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
14 : : !!
15 : : !! SOURCE
16 : :
17 : : #if defined HAVE_CONFIG_H
18 : : #include "config.h"
19 : : #endif
20 : :
21 : : #include "abi_common.h"
22 : :
23 : : MODULE m_mpiotk
24 : :
25 : : use defs_basis
26 : : use m_abicore
27 : : use m_errors
28 : : use m_xmpi
29 : : USE_MPI
30 : :
31 : : use iso_c_binding
32 : :
33 : : implicit none
34 : :
35 : : #if defined HAVE_MPI1 && defined HAVE_MPI_IO
36 : : include 'mpif.h'
37 : : #endif
38 : :
39 : : private
40 : :
41 : : !public procedures.
42 : : #ifdef HAVE_MPI_IO
43 : : public :: mpiotk_read_fsuba_dp2D ! (individual|collective) read of a 2D sub-matrix
44 : : public :: mpiotk_write_fsuba_dp2D ! (individual|collective) write of a 2D sub-matrix
45 : :
46 : : public :: mpiotk_read_fsuba_dpc3D ! (individual|collective) read of a 3D sub-matrix
47 : : !public :: mpiotk_write_fsuba_dpc3D ! (individual|collective) write of a 3D sub-matrix
48 : :
49 : : public :: mpiotk_read_fsuba_dpc4D ! (individual|collective) read of a 4D sub-matrix
50 : : !public :: mpiotk_write_fsuba_dpc4D ! (individual|collective) write of a 4D sub-matrix
51 : : #else
52 : : public :: no_mpiotk
53 : : #endif
54 : : !!***
55 : :
56 : : CONTAINS
57 : : !!***
58 : :
59 : : #ifndef HAVE_MPI_IO
60 : :
61 : : !----------------------------------------------------------------------
62 : :
63 : : !!****f* m_mpiotk/no_mpiotk
64 : : !! NAME
65 : : !! no_mpiotk
66 : : !!
67 : : !! FUNCTION
68 : : !! Empty placeholder.
69 : : !!
70 : : !! SOURCE
71 : :
72 : : subroutine no_mpiotk()
73 : :
74 : : ! *************************************************************************
75 : :
76 : : end subroutine no_mpiotk
77 : : !!***
78 : :
79 : : #else
80 : :
81 : : !!****f* m_mpiotk/setup_fsuba_dp2D
82 : : !! NAME
83 : : !! setup_fsuba_dp2D
84 : : !!
85 : : !! FUNCTION
86 : : !! Setup tables used in (read|write) a 2D array stored in a Fortran file
87 : : !!
88 : : !! NOTES
89 : : !! The value of ierr should always be checked by the caller
90 : : !!
91 : : !! INPUTS
92 : : !! sizes(2)
93 : : !! subsizes(2)
94 : : !! starts(2)
95 : : !! chunk_bsize =
96 : : !! comm = MPI communicator
97 : : !!
98 : : !! OUTPUTS
99 : : !! my_basead(:)
100 : : !! my_subsizes(:,:)
101 : : !! my_starts(:,:)
102 : : !! ierr=status error. A non zero value indicates that chunk_bsize is smaller that the fortran record
103 : : !! and therefore bufsz has not been read.
104 : : !!
105 : : !! SOURCE
106 : :
107 : 30 : subroutine setup_fsuba_dp2D(sizes,subsizes,starts,chunk_bsize,&
108 : : my_basead,my_subsizes,my_starts,my_ncalls,ncalls,comm,ierr)
109 : :
110 : : !Arguments ------------------------------------
111 : : !scalars
112 : : integer,intent(in) :: comm
113 : : integer,intent(out) :: ncalls,my_ncalls,ierr
114 : : integer(XMPI_OFFSET_KIND),intent(in) :: chunk_bsize
115 : : !arrays
116 : : integer,intent(in) :: sizes(2),subsizes(2),starts(2)
117 : : integer,allocatable,intent(out) :: my_basead(:),my_subsizes(:,:),my_starts(:,:)
118 : :
119 : : !Local variables ------------------------------
120 : : !scalars
121 : : integer :: mpierr,ny2read,ny_chunk,icall,yrest
122 : : integer :: size_x,subs_x,start_x,start_y,stop_y
123 : : !character(len=500) :: msg
124 : :
125 : : !************************************************************************
126 : :
127 : 30 : size_x = sizes(1)
128 : 30 : subs_x = subsizes(1)
129 : 30 : start_x = starts(1)
130 : 30 : start_y = starts(2)
131 : 30 : stop_y = start_y + subsizes(2)-1 ! last column to read
132 : : !
133 : : ! Read rows in blocks of size ny_chunk:
134 : : ! MPI-IO crashes if we try to read data > 2Gb in a single call.
135 : 30 : ny2read = subsizes(2)
136 : 30 : ny_chunk = ny2read
137 [ - + ]: 30 : if ((two*subs_x*ny2read*xmpi_bsize_dp) > chunk_bsize) then
138 : 0 : ny_chunk = chunk_bsize / (2*subs_x*xmpi_bsize_dp)
139 : : !if (ny_chunk == 0) ny_chunk = 50
140 : : end if
141 : :
142 : 30 : call xmpi_min(ny_chunk,ierr,comm,mpierr)
143 [ - + ]: 30 : if (ierr == 0) then
144 : 0 : ierr = 1
145 : 0 : RETURN
146 : : end if
147 : 30 : ierr = 0
148 : : !
149 : : ! my_ncalls : number of read needed to fill my buffer.
150 : : ! ncalls : max number of read in comm (needed for collective operations).
151 : 30 : my_ncalls = ny2read / ny_chunk
152 : 30 : yrest = MOD(ny2read, ny_chunk)
153 [ - + ]: 30 : if (yrest /= 0) my_ncalls = my_ncalls + 1
154 : :
155 : 30 : call xmpi_max(my_ncalls,ncalls,comm,mpierr)
156 : : !
157 : : ! Compute arrays used to define the file view.
158 [ - + + - : 90 : ABI_MALLOC(my_subsizes,(2,ncalls))
+ - + - -
+ - + -
+ ]
159 [ - + + - : 60 : ABI_MALLOC(my_starts,(2,ncalls))
- + - + -
+ ]
160 [ - + + - : 90 : ABI_MALLOC(my_basead,(ncalls))
+ - + - -
+ - + -
+ ]
161 : :
162 [ + + ]: 60 : do icall=1,my_ncalls
163 : :
164 [ + - ]: 60 : if (icall*ny_chunk <= ny2read) then
165 [ + + ]: 90 : my_subsizes(:,icall) = (/subs_x, ny_chunk/)
166 [ + + ]: 90 : my_starts(:,icall) = (/start_x, (icall-1) * ny_chunk + start_y/)
167 : 30 : my_basead(icall) = 1 + 2*(icall-1)*ny_chunk*subs_x ! 2 accounts for real and imag part.
168 : : else
169 : : ! Two cases:
170 : : ! 1) ny2read > ny_chunk and not divisible by ny2read
171 : : ! 2) ny2read < ny_chunk
172 [ # # ]: 0 : my_subsizes(:,icall) = (/subs_x, yrest/)
173 [ # # ]: 0 : if (ny2read >= ny_chunk) then
174 [ # # ]: 0 : my_starts(:,icall) = (/start_x, stop_y-yrest+1/)
175 : 0 : my_basead(icall) = 1 + 2 * (ny2read-yrest) * subs_x ! 2 accounts for real and imag part.
176 : : else
177 [ # # ]: 0 : my_starts(:,icall) = starts
178 : 0 : my_basead(icall) = 1
179 : : end if
180 : : end if
181 : : end do
182 : : !write(std_out,*)" >>>> my_ncalls, ncalls, ny2read, ny_chunk ",my_ncalls,ncalls,ny2read,ny_chunk
183 : :
184 : 60 : end subroutine setup_fsuba_dp2D
185 : : !!***
186 : :
187 : : !----------------------------------------------------------------------
188 : :
189 : : !!****f* m_mpiotk/mpiotk_read_fsuba_dp2D
190 : : !! NAME
191 : : !! mpiotk_read_fsuba_dp2D
192 : : !!
193 : : !! FUNCTION
194 : : !! Read a block of contiguous data stored in a 2D matrix.
195 : : !! Data is placed within Fortran records. Target: complex data stored in a real array.
196 : : !!
197 : : !! NOTES
198 : : !! The value of ierr should always be checked by the caller
199 : : !!
200 : : !! INPUTS
201 : : !! fh = MPI-IO file handler.
202 : : !! offset =
203 : : !! sizes(2)
204 : : !! subsizes(2)
205 : : !! starts(2)
206 : : !! bufsz = dimension of buffer (takes into accout both real and imaginary part)
207 : : !! chunk_bsize =
208 : : !! sc_mode= MPI-IO option
209 : : !! xmpio_single ==> for reading by current proc.
210 : : !! xmpio_collective ==> for collective reading.
211 : : !! comm = MPI communicator
212 : : !!
213 : : !! OUTPUTS
214 : : !! buffer(bufsz)
215 : : !! ierr=status error. A non zero value indicates that chunk_bsize is smaller that the fortran record
216 : : !! and therefore bufsz has not been read.
217 : : !!
218 : : !! SOURCE
219 : :
220 : 0 : subroutine mpiotk_read_fsuba_dp2D(fh,offset,sizes,subsizes,starts,bufsz,buffer,chunk_bsize,sc_mode,comm,ierr)
221 : :
222 : : !Arguments ------------------------------------
223 : : !scalars
224 : : integer,intent(in) :: fh,comm,bufsz,sc_mode
225 : : integer,intent(out) :: ierr
226 : : integer(XMPI_OFFSET_KIND),intent(in) :: offset,chunk_bsize
227 : : !arrays
228 : : integer,intent(in) :: sizes(2),subsizes(2),starts(2)
229 : : real(dp),intent(out),target :: buffer(bufsz)
230 : :
231 : : !Local variables ------------------------------
232 : : !scalars
233 : : integer :: mpierr,ptr,ncount,myfh
234 : : integer :: fsub_type,my_ncalls,icall,ncalls,subs_x
235 : : integer(XMPI_OFFSET_KIND) :: my_offset,my_offpad
236 : : !character(len=500) :: msg
237 : : type(c_ptr) :: cptr
238 : : !arrays
239 : : integer :: call_subsizes(2),call_starts(2)
240 : 0 : integer,allocatable :: my_basead(:),my_subsizes(:,:),my_starts(:,:)
241 : 0 : real(dp),allocatable :: dummy_buf(:,:)
242 : 0 : real(dp),pointer :: buf_ptr(:)
243 : :
244 : : !************************************************************************
245 : :
246 : : ! Workaround for XLF
247 : 0 : myfh = fh
248 : :
249 [ # # # # ]: 0 : if (bufsz < 2 * PRODUCT(subsizes) ) then
250 : 0 : ABI_ERROR("bufsz is too small")
251 : : end if
252 : :
253 [ # # ]: 0 : if (sc_mode==xmpio_single) then
254 : : ! This makes the automatic tests fail (cut3d)
255 : : !ABI_WARNING("comm != xmpi_comm_self")
256 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
257 : : continue
258 : : else
259 : 0 : ABI_ERROR("Wrong sc_mode")
260 : : end if
261 : :
262 : 0 : subs_x = subsizes(1)
263 : :
264 : 0 : call setup_fsuba_dp2D(sizes,subsizes,starts,chunk_bsize,my_basead,my_subsizes,my_starts,my_ncalls,ncalls,comm,ierr)
265 [ # # ]: 0 : if (ierr/=0) RETURN
266 : :
267 [ # # ]: 0 : do icall=1,ncalls
268 : :
269 [ # # ]: 0 : if (icall <= my_ncalls) then
270 [ # # ]: 0 : call_subsizes = my_subsizes(:,icall)
271 [ # # ]: 0 : call_starts = my_starts(:,icall)
272 : 0 : ptr = my_basead(icall)
273 : : else
274 : : ! Fake values needed to call read_all collectively.
275 [ # # ]: 0 : call_subsizes = (/subs_x, 1/)
276 : 0 : call_starts = starts
277 : : end if
278 [ # # ]: 0 : ncount = PRODUCT(call_subsizes)
279 : : !write(std_out,*)" icall,ptr, ncount, ",icall,ptr,ncount
280 : : !write(std_out,*)" call_starts",call_starts
281 : : !write(std_out,*)" call_subsizes",call_subsizes
282 : :
283 : : ! Create subarry file view.
284 : 0 : call xmpio_create_fsubarray_2D(sizes,call_subsizes,call_starts,MPI_DOUBLE_COMPLEX,fsub_type,my_offpad,mpierr)
285 : 0 : ABI_CHECK_MPI(mpierr,"fsubarray_2D")
286 : :
287 : : ! Update the offset.
288 : 0 : my_offset = offset + my_offpad
289 : :
290 : 0 : call MPI_FILE_SET_VIEW(myfh, my_offset, MPI_BYTE, fsub_type, 'native', MPI_INFO_NULL, mpierr)
291 : 0 : ABI_CHECK_MPI(mpierr,"SET_VIEW")
292 : :
293 : 0 : call MPI_TYPE_FREE(fsub_type, mpierr)
294 : 0 : ABI_CHECK_MPI(mpierr,"MPI_TYPE_FREE")
295 : :
296 [ # # ]: 0 : if (sc_mode==xmpio_collective) then
297 : : ! Collective read
298 [ # # ]: 0 : if (icall <= my_ncalls) then
299 [ # # ]: 0 : cptr=c_loc(buffer(ptr)) ; call c_f_pointer(cptr,buf_ptr,[ncount])
300 [ # # ]: 0 : call MPI_FILE_READ_ALL(myfh, buf_ptr, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
301 : : else
302 [ # # # # : 0 : ABI_MALLOC(dummy_buf,(2,subs_x))
# # # # #
# # # ]
303 : 0 : call MPI_FILE_READ_ALL(myfh, dummy_buf, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
304 [ # # ]: 0 : ABI_FREE(dummy_buf)
305 : : end if
306 : 0 : ABI_CHECK_MPI(mpierr,"FILE_READ_ALL")
307 : :
308 : : else
309 : : ! Individual read.
310 [ # # ]: 0 : cptr=c_loc(buffer(ptr)) ; call c_f_pointer(cptr,buf_ptr,[ncount])
311 [ # # ]: 0 : call MPI_FILE_READ(myfh, buf_ptr, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
312 : 0 : ABI_CHECK_MPI(mpierr,"FILE_READ")
313 : : end if
314 : :
315 : : end do
316 : :
317 [ # # ]: 0 : ABI_FREE(my_subsizes)
318 [ # # ]: 0 : ABI_FREE(my_starts)
319 [ # # ]: 0 : ABI_FREE(my_basead)
320 : :
321 [ # # # # : 0 : end subroutine mpiotk_read_fsuba_dp2D
# # ]
322 : : !!***
323 : :
324 : : !----------------------------------------------------------------------
325 : :
326 : : !!****f* m_mpiotk/mpiotk_write_fsuba_dp2D
327 : : !! NAME
328 : : !! mpiotk_write_fsuba_dp2D
329 : : !!
330 : : !! FUNCTION
331 : : !! Write a block of contiguous data stored in a 2D matrix.
332 : : !! Data is placed within Fortran records. Target: complex data stored in a real array.
333 : : !!
334 : : !! NOTES
335 : : !! The value of ierr should always be checked by the caller
336 : : !!
337 : : !! INPUTS
338 : : !! fh = MPI-IO file handler.
339 : : !! offset =
340 : : !! sizes(2)
341 : : !! subsizes(2)
342 : : !! starts(2)
343 : : !! bufsz = dimension of buffer (takes into accout both real and imaginary part)
344 : : !! buffer(bufsz)
345 : : !! chunk_bsize =
346 : : !! sc_mode= MPI-IO option
347 : : !! xmpio_single ==> for reading by current proc.
348 : : !! xmpio_collective ==> for collective reading.
349 : : !! comm = MPI communicator
350 : : !!
351 : : !! OUTPUTS
352 : : !! ierr=status error. A non zero value indicates that chunk_bsize is smaller that the fortran record
353 : : !! and therefore bufsz has not been written.
354 : : !!
355 : : !! SOURCE
356 : :
357 : 30 : subroutine mpiotk_write_fsuba_dp2D(fh,offset,sizes,subsizes,starts,bufsz,buffer,chunk_bsize,sc_mode,comm,ierr)
358 : :
359 : : !Arguments ------------------------------------
360 : : !scalars
361 : : integer,intent(in) :: fh,comm,bufsz,sc_mode
362 : : integer,intent(out) :: ierr
363 : : integer(XMPI_OFFSET_KIND),intent(in) :: offset,chunk_bsize
364 : : !arrays
365 : : integer,intent(in) :: sizes(2),subsizes(2),starts(2)
366 : : real(dp),intent(in),target :: buffer(bufsz)
367 : :
368 : : !Local variables ------------------------------
369 : : !scalars
370 : : integer :: mpierr,ptr,ncount,myfh
371 : : integer :: fsub_type,my_ncalls,icall,ncalls,subs_x
372 : : integer(XMPI_OFFSET_KIND) :: my_offset,my_offpad
373 : : type(c_ptr) :: cptr
374 : : !character(len=500) :: msg
375 : : !arrays
376 : : integer :: call_subsizes(2),call_starts(2)
377 : 30 : integer,allocatable :: my_basead(:),my_subsizes(:,:),my_starts(:,:)
378 : 30 : real(dp),pointer :: buf_ptr(:)
379 : :
380 : : !************************************************************************
381 : :
382 : : DBG_ENTER("COLL")
383 : :
384 : : ! Workaround for XLF
385 : 30 : myfh = fh
386 : :
387 [ + + - + ]: 90 : if (bufsz < 2 * PRODUCT(subsizes) ) then
388 : 0 : ABI_ERROR("bufsz is too small")
389 : : end if
390 : :
391 [ + - ]: 30 : if (sc_mode==xmpio_single) then
392 : 30 : call setup_fsuba_dp2D(sizes,subsizes,starts,chunk_bsize,my_basead,my_subsizes,my_starts,my_ncalls,ncalls,xmpi_comm_self,ierr)
393 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
394 : 0 : call setup_fsuba_dp2D(sizes,subsizes,starts,chunk_bsize,my_basead,my_subsizes,my_starts,my_ncalls,ncalls,comm,ierr)
395 : : else
396 : 0 : ABI_ERROR("Wrong sc_mode")
397 : : end if
398 [ - + ]: 30 : if (ierr/=0) RETURN
399 : :
400 : 30 : subs_x = subsizes(1)
401 [ + + ]: 60 : do icall=1,ncalls
402 : :
403 [ + - ]: 30 : if (icall <= my_ncalls) then
404 [ + + ]: 90 : call_subsizes = my_subsizes(:,icall)
405 [ + + ]: 90 : call_starts = my_starts(:,icall)
406 : 30 : ptr = my_basead(icall)
407 : : else
408 : : ! Fake values needed to call write_all collectively.
409 [ # # ]: 0 : call_subsizes = (/subs_x, 1/)
410 : 0 : call_starts = starts
411 : : end if
412 [ + + ]: 90 : ncount = PRODUCT(call_subsizes)
413 : : !write(std_out,*)" icall,ptr, ncount, ",icall,ptr,ncount
414 : : !write(std_out,*)" call_starts",call_starts
415 : : !write(std_out,*)" call_subsizes",call_subsizes
416 : :
417 : : ! Create subarry file view.
418 : 30 : call xmpio_create_fsubarray_2D(sizes,call_subsizes,call_starts,MPI_DOUBLE_COMPLEX,fsub_type,my_offpad,mpierr)
419 : 30 : ABI_CHECK_MPI(mpierr,"fsubarray_2D")
420 : :
421 : : ! Update the offset.
422 : 30 : my_offset = offset + my_offpad
423 : :
424 : 30 : call MPI_FILE_SET_VIEW(myfh, my_offset, MPI_BYTE, fsub_type, 'native', MPI_INFO_NULL, mpierr)
425 : 30 : ABI_CHECK_MPI(mpierr,"SET_VIEW")
426 : :
427 : 30 : call MPI_TYPE_FREE(fsub_type, mpierr)
428 : 30 : ABI_CHECK_MPI(mpierr,"MPI_TYPE_FREE")
429 : :
430 [ - + ]: 60 : if (sc_mode==xmpio_collective) then
431 : : ! Collective write
432 [ # # ]: 0 : if (icall <= my_ncalls) then
433 [ # # ]: 0 : cptr=c_loc(buffer(ptr)) ; call c_f_pointer(cptr,buf_ptr,[ncount])
434 [ # # ]: 0 : call MPI_FILE_WRITE_ALL(myfh, buf_ptr, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
435 : : else
436 : : ! Re-write my first chunk of data.
437 [ # # ]: 0 : cptr=c_loc(buffer(1)) ; call c_f_pointer(cptr,buf_ptr,[ncount])
438 [ # # ]: 0 : call MPI_FILE_WRITE_ALL(myfh, buf_ptr, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
439 : : end if
440 : 0 : ABI_CHECK_MPI(mpierr,"FILE_WRITE_ALL")
441 : :
442 : : else
443 : : ! Individual write.
444 [ + + ]: 60 : cptr=c_loc(buffer(ptr)) ; call c_f_pointer(cptr,buf_ptr,[ncount])
445 [ - + ]: 30 : call MPI_FILE_WRITE(myfh, buf_ptr, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
446 : 30 : ABI_CHECK_MPI(mpierr,"FILE_WRITE")
447 : : end if
448 : :
449 : : end do
450 : :
451 [ - + ]: 30 : ABI_FREE(my_subsizes)
452 [ - + ]: 30 : ABI_FREE(my_starts)
453 [ - + ]: 30 : ABI_FREE(my_basead)
454 : :
455 : : DBG_EXIT("COLL")
456 : :
457 [ - - - - : 30 : end subroutine mpiotk_write_fsuba_dp2D
- - ]
458 : : !!***
459 : :
460 : : !----------------------------------------------------------------------
461 : :
462 : : !!****f* m_mpiotk/mpiotk_read_fsuba_dpc3D
463 : : !! NAME
464 : : !! mpiotk_read_fsuba_dpc3D
465 : : !!
466 : : !! FUNCTION
467 : : !! Read of a block of contiguous data stored in a 3D matrix.
468 : : !! Data is placed within Fortran records. Target: complex data stored in a complex array.
469 : : !!
470 : : !! NOTES
471 : : !! The value of ierr should always be checked by the caller
472 : : !!
473 : : !! INPUTS
474 : : !! fh = MPI-IO file handler.
475 : : !! offset =
476 : : !! sizes(3)
477 : : !! subsizes(3)
478 : : !! starts(3)
479 : : !! bufsz = dimension of cbuffer
480 : : !! chunk_bsize =
481 : : !! comm = MPI communicator
482 : : !! sc_mode= MPI-IO option
483 : : !! xmpio_single ==> for reading by current proc.
484 : : !! xmpio_collective ==> for collective reading.
485 : : !!
486 : : !! OUTPUTS
487 : : !! cbuffer(bufsz)
488 : : !! ierr=status error. A non zero value indicates that chunk_bsize is smaller that the fortran record
489 : : !! and therefore bufsz has not been read.
490 : : !!
491 : : !! SOURCE
492 : :
493 : 0 : subroutine mpiotk_read_fsuba_dpc3D(fh,offset,sizes,subsizes,starts,bufsz,cbuffer,chunk_bsize,sc_mode,comm,ierr)
494 : :
495 : : !Arguments ------------------------------------
496 : : !scalars
497 : : integer,intent(in) :: fh,comm,bufsz,sc_mode
498 : : integer,intent(out) :: ierr
499 : : integer(XMPI_OFFSET_KIND),intent(in) :: offset,chunk_bsize
500 : : !arrays
501 : : integer,intent(in) :: sizes(3),subsizes(3),starts(3)
502 : : complex(dp),intent(out),target :: cbuffer(bufsz)
503 : :
504 : : !Local variables-------------------------------
505 : : !scalars
506 : : integer :: mpierr,nz2read,nz_chunk,ptr,ncount,myfh
507 : : integer :: fsub_type,my_ncalls,icall,zrest,ncalls
508 : : integer :: size_x,size_y,subs_x,subs_y,subs_xy,start_x,start_y,start_z,stop_z
509 : : integer(XMPI_OFFSET_KIND) :: my_offset,my_offpad
510 : : !character(len=500) :: msg
511 : : type(c_ptr) :: cptr
512 : : !arrays
513 : : integer :: call_subsizes(3),call_starts(3)
514 : 0 : integer,allocatable :: my_basead(:),my_subsizes(:,:),my_starts(:,:)
515 : 0 : complex(dp),allocatable :: dummy_cbuf(:)
516 : 0 : complex(dp),pointer :: buf_ptr(:)
517 : : !************************************************************************
518 : :
519 : : ! Workaround for XLF
520 : 0 : myfh = fh
521 : :
522 [ # # # # ]: 0 : if (bufsz < PRODUCT(subsizes) ) then
523 : 0 : ABI_ERROR("bufsz is too small")
524 : : end if
525 : :
526 [ # # ]: 0 : if (sc_mode==xmpio_single) then
527 [ # # ]: 0 : ABI_CHECK(comm==xmpi_comm_self,"comm != xmpi_comm_self")
528 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
529 : : continue
530 : : else
531 : 0 : ABI_ERROR("Wrong sc_mode")
532 : : end if
533 : :
534 : 0 : size_x = sizes(1)
535 : 0 : size_y = sizes(2)
536 : 0 : subs_x = subsizes(1)
537 : 0 : subs_y = subsizes(2)
538 : 0 : subs_xy = subs_x * subs_y
539 : 0 : start_x = starts(1)
540 : 0 : start_y = starts(2)
541 : 0 : start_z = starts(3)
542 : 0 : stop_z = start_z + subsizes(3)-1 ! last column to read
543 : :
544 : : ! Read rows in blocks of size nz_chunk:
545 : : ! MPI-IO crashes if we try to read data > 2Gb in a single call.
546 : 0 : nz2read = subsizes(3)
547 : 0 : nz_chunk = nz2read
548 [ # # ]: 0 : if ( (one*subs_xy*nz2read*xmpi_bsize_dpc) > chunk_bsize) then
549 : 0 : nz_chunk = chunk_bsize / (subs_xy*xmpi_bsize_dpc)
550 : : !if (nz_chunk == 0) nz_chunk = 50
551 : : end if
552 : :
553 : 0 : call xmpi_min(nz_chunk,ierr,comm,mpierr)
554 [ # # ]: 0 : if (ierr == 0) then
555 : 0 : ierr = 1
556 : : RETURN
557 : : end if
558 : 0 : ierr = 0
559 : :
560 : : ! my_ncalls : number of read needed to fill my cbuffer.
561 : : ! ncalls : max number of read in comm (needed for collective operations).
562 : 0 : my_ncalls = nz2read / nz_chunk
563 : 0 : zrest = MOD(nz2read, nz_chunk)
564 [ # # ]: 0 : if (zrest /= 0) my_ncalls = my_ncalls + 1
565 : :
566 : 0 : call xmpi_max(my_ncalls,ncalls,comm,mpierr)
567 : :
568 : : ! Compute arrays used to define the file view.
569 [ # # # # : 0 : ABI_MALLOC(my_subsizes,(3,ncalls))
# # # # #
# # # ]
570 [ # # # # : 0 : ABI_MALLOC(my_starts,(3,ncalls))
# # # # ]
571 [ # # # # : 0 : ABI_MALLOC(my_basead,(ncalls))
# # # # #
# # # ]
572 : :
573 [ # # ]: 0 : do icall=1,my_ncalls
574 [ # # ]: 0 : if (icall*nz_chunk <= nz2read) then
575 [ # # ]: 0 : my_subsizes(:,icall) = (/subs_x, subs_y, nz_chunk/)
576 [ # # ]: 0 : my_starts(:,icall) = (/start_x, start_y, (icall-1) * nz_chunk + start_z/)
577 : 0 : my_basead(icall) = 1 + (icall-1)*subs_xy*nz_chunk
578 : : else
579 : : ! Two cases:
580 : : ! 1) nz2read > nz_chunk and not divisible by nz2read
581 : : ! 2) nz2read < nz_chunk
582 [ # # ]: 0 : my_subsizes(:,icall) = (/subs_x, subs_y, zrest/)
583 [ # # ]: 0 : if (nz2read >= nz_chunk) then
584 [ # # ]: 0 : my_starts(:,icall) = (/start_x, start_y, stop_z-zrest+1/)
585 : 0 : my_basead(icall) = 1 + (nz2read-zrest) * subs_xy
586 : : else
587 [ # # ]: 0 : my_starts(:,icall) = starts
588 : 0 : my_basead(icall) = 1
589 : : end if
590 : : end if
591 : : end do
592 : : !write(std_out,*)" >>>> my_ncalls, ncalls, nz2read, nz_chunk ",my_ncalls,ncalls,nz2read,nz_chunk
593 : :
594 [ # # ]: 0 : do icall=1,ncalls
595 : :
596 [ # # ]: 0 : if (icall <= my_ncalls) then
597 [ # # ]: 0 : call_subsizes = my_subsizes(:,icall)
598 [ # # ]: 0 : call_starts = my_starts(:,icall)
599 : 0 : ptr = my_basead(icall)
600 : : else
601 : : ! Fake values needed to call read_all collectively.
602 [ # # ]: 0 : call_subsizes = (/subs_x, 1, 1/)
603 : 0 : call_starts = starts
604 : : end if
605 [ # # ]: 0 : ncount = PRODUCT(call_subsizes)
606 : : !write(std_out,*)" icall,ptr, ncount, ",icall,ptr,ncount
607 : : !write(std_out,*)" call_starts",call_starts
608 : : !write(std_out,*)" call_subsizes",call_subsizes
609 : :
610 : : ! Create subarry file view.
611 : : call xmpio_create_fsubarray_3D(sizes,call_subsizes,call_starts,MPI_DOUBLE_COMPLEX,&
612 : 0 : & fsub_type,my_offpad,mpierr)
613 : 0 : ABI_CHECK_MPI(mpierr,"fsubarray_3D")
614 : :
615 : : ! Update the offset.
616 : 0 : my_offset = offset + my_offpad
617 : :
618 : 0 : call MPI_FILE_SET_VIEW(myfh, my_offset, MPI_BYTE, fsub_type, 'native', MPI_INFO_NULL, mpierr)
619 : 0 : ABI_CHECK_MPI(mpierr,"SET_VIEW")
620 : :
621 : 0 : call MPI_TYPE_FREE(fsub_type, mpierr)
622 : 0 : ABI_CHECK_MPI(mpierr,"MPI_TYPE_FREE")
623 : :
624 [ # # ]: 0 : if (sc_mode==xmpio_collective) then
625 : : ! Collective read
626 [ # # ]: 0 : if (icall <= my_ncalls) then
627 [ # # ]: 0 : cptr=c_loc(cbuffer(ptr)) ; call c_f_pointer(cptr,buf_ptr,[ncount])
628 [ # # ]: 0 : call MPI_FILE_READ_ALL(myfh, buf_ptr, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
629 : : else
630 [ # # # # : 0 : ABI_MALLOC(dummy_cbuf,(subs_x))
# # # # #
# # # ]
631 : 0 : call MPI_FILE_READ_ALL(myfh, dummy_cbuf, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
632 [ # # ]: 0 : ABI_FREE(dummy_cbuf)
633 : : end if
634 : 0 : ABI_CHECK_MPI(mpierr,"FILE_READ_ALL")
635 : :
636 : : else
637 : : ! Individual read.
638 [ # # ]: 0 : cptr=c_loc(cbuffer(ptr)) ; call c_f_pointer(cptr,buf_ptr,[ncount])
639 [ # # ]: 0 : call MPI_FILE_READ(myfh, buf_ptr, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
640 : 0 : ABI_CHECK_MPI(mpierr,"FILE_READ")
641 : : end if
642 : :
643 : : end do
644 : :
645 [ # # ]: 0 : ABI_FREE(my_subsizes)
646 [ # # ]: 0 : ABI_FREE(my_starts)
647 [ # # ]: 0 : ABI_FREE(my_basead)
648 : :
649 : 0 : end subroutine mpiotk_read_fsuba_dpc3D
650 : : !!***
651 : :
652 : : !----------------------------------------------------------------------
653 : :
654 : : !!****f* m_mpiotk/mpiotk_read_fsuba_dpc4D
655 : : !! NAME
656 : : !! mpiotk_read_fsuba_dpc4D
657 : : !!
658 : : !! FUNCTION
659 : : !! Reading a block of contiguous data stored in a 4D matrix.
660 : : !! Data is placed within Fortran records. Target: complex data stored in a complex array.
661 : : !!
662 : : !! NOTES
663 : : !! The value of ierr should always be checked by the caller
664 : : !!
665 : : !! INPUTS
666 : : !! fh = MPI-IO file handler.
667 : : !! offset =
668 : : !! sizes(4)
669 : : !! subsizes(4)
670 : : !! starts(4)
671 : : !! bufsz = dimension of cbuffer
672 : : !! chunk_bsize =
673 : : !! comm = MPI communicator
674 : : !! sc_mode= MPI-IO option
675 : : !! xmpio_single ==> for reading by current proc.
676 : : !! xmpio_collective ==> for collective reading.
677 : : !!
678 : : !! OUTPUTS
679 : : !! cbuffer(bufsz)
680 : : !! ierr=status error. A non zero value indicates that chunk_bsize is smaller that the fortran record
681 : : !! and therefore bufsz has not been read.
682 : : !!
683 : : !! SOURCE
684 : :
685 : 0 : subroutine mpiotk_read_fsuba_dpc4D(fh,offset,sizes,subsizes,starts,bufsz,cbuffer,chunk_bsize,sc_mode,comm,ierr)
686 : :
687 : : !Arguments ------------------------------------
688 : : !scalars
689 : : integer,intent(in) :: fh,comm,bufsz,sc_mode
690 : : integer,intent(out) :: ierr
691 : : integer(XMPI_OFFSET_KIND),intent(in) :: offset,chunk_bsize
692 : : !arrays
693 : : integer,intent(in) :: sizes(4),subsizes(4),starts(4)
694 : : complex(dp),intent(out),target :: cbuffer(bufsz)
695 : :
696 : : !Local variables-------------------------------
697 : : !scalars
698 : : integer :: mpierr,na2read,na_chunk,ptr,ncount,myfh
699 : : integer :: fsub_type,my_ncalls,icall,arest,ncalls
700 : : integer :: size_x,size_y,size_z,subs_x,subs_y,subs_z,subs_xyz,start_x,start_y,start_z,start_a,stop_a
701 : : integer(XMPI_OFFSET_KIND) :: my_offset,my_offpad
702 : : !character(len=500) :: msg
703 : : type(c_ptr) :: cptr
704 : : !arrays
705 : : integer :: call_subsizes(4),call_starts(4)
706 : 0 : integer,allocatable :: my_basead(:),my_subsizes(:,:),my_starts(:,:)
707 : 0 : complex(dp),allocatable :: dummy_cbuf(:)
708 : 0 : complex(dp),pointer :: buf_ptr(:)
709 : : !************************************************************************
710 : :
711 : : ! Workaround for XLF
712 : 0 : myfh = fh
713 : :
714 [ # # # # ]: 0 : if (bufsz < PRODUCT(subsizes) ) then
715 : 0 : ABI_ERROR("bufsz is too small")
716 : : end if
717 : :
718 [ # # ]: 0 : if (sc_mode==xmpio_single) then
719 [ # # ]: 0 : ABI_CHECK(comm==xmpi_comm_self,"comm != xmpi_comm_self")
720 [ # # ]: 0 : else if (sc_mode==xmpio_collective) then
721 : : continue
722 : : else
723 : 0 : ABI_ERROR("Wrong sc_mode")
724 : : end if
725 : :
726 : 0 : size_x = sizes(1)
727 : 0 : size_y = sizes(2)
728 : 0 : size_z = sizes(3)
729 : :
730 : 0 : subs_x = subsizes(1)
731 : 0 : subs_y = subsizes(2)
732 : 0 : subs_z = subsizes(3)
733 : 0 : subs_xyz = subs_x * subs_y * subs_z
734 : :
735 : 0 : start_x = starts(1)
736 : 0 : start_y = starts(2)
737 : 0 : start_z = starts(3)
738 : 0 : start_a = starts(4)
739 : 0 : stop_a = start_a + subsizes(4)-1 ! last column to read
740 : :
741 : : ! Read rows in blocks of size na_chunk:
742 : : ! MPI-IO crashes if we try to read data > 2Gb in a single call.
743 : 0 : na2read = subsizes(4)
744 : 0 : na_chunk = na2read
745 [ # # ]: 0 : if ( (one*subs_xyz*na2read*xmpi_bsize_dpc) > chunk_bsize) then
746 : 0 : na_chunk = chunk_bsize / (subs_xyz*xmpi_bsize_dpc)
747 : : end if
748 : :
749 : 0 : call xmpi_min(na_chunk,ierr,comm,mpierr)
750 [ # # ]: 0 : if (ierr == 0) then
751 : 0 : ierr = 1
752 : : RETURN
753 : : end if
754 : 0 : ierr = 0
755 : :
756 : : ! my_ncalls : number of read needed to fill my cbuffer.
757 : : ! ncalls : max number of read in comm (needed for collective operations).
758 : 0 : my_ncalls = na2read / na_chunk
759 : 0 : arest = MOD(na2read, na_chunk)
760 [ # # ]: 0 : if (arest /= 0) my_ncalls = my_ncalls + 1
761 : :
762 : 0 : call xmpi_max(my_ncalls,ncalls,comm,mpierr)
763 : :
764 : : ! Compute arrays used to define the file view.
765 [ # # # # : 0 : ABI_MALLOC(my_subsizes,(4,ncalls))
# # # # #
# # # ]
766 [ # # # # : 0 : ABI_MALLOC(my_starts,(4,ncalls))
# # # # ]
767 [ # # # # : 0 : ABI_MALLOC(my_basead,(ncalls))
# # # # #
# # # ]
768 : :
769 [ # # ]: 0 : do icall=1,my_ncalls
770 : :
771 [ # # ]: 0 : if (icall*na_chunk <= na2read) then
772 [ # # ]: 0 : my_subsizes(:,icall) = (/subs_x, subs_y, subs_z, na_chunk/)
773 [ # # ]: 0 : my_starts(:,icall) = (/start_x, start_y, start_z, (icall-1) * na_chunk + start_a/)
774 : 0 : my_basead(icall) = 1 + (icall-1)*subs_xyz*na_chunk
775 : : else
776 : : ! Two cases:
777 : : ! 1) na2read > na_chunk and not divisible by na2read
778 : : ! 2) na2read < na_chunk
779 [ # # ]: 0 : my_subsizes(:,icall) = (/subs_x, subs_y, subs_z, arest/)
780 [ # # ]: 0 : if (na2read >= na_chunk) then
781 [ # # ]: 0 : my_starts(:,icall) = (/start_x, start_y, start_z, stop_a-arest+1/)
782 : 0 : my_basead(icall) = 1 + (na2read-arest) * subs_xyz
783 : : else
784 [ # # ]: 0 : my_starts(:,icall) = starts
785 : 0 : my_basead(icall) = 1
786 : : end if
787 : : end if
788 : : end do
789 : : !write(std_out,*)" >>>> my_ncalls, ncalls, na2read, na_chunk ",my_ncalls,ncalls,na2read,na_chunk
790 : :
791 [ # # ]: 0 : do icall=1,ncalls
792 : :
793 [ # # ]: 0 : if (icall <= my_ncalls) then
794 [ # # ]: 0 : call_subsizes = my_subsizes(:,icall)
795 [ # # ]: 0 : call_starts = my_starts(:,icall)
796 : 0 : ptr = my_basead(icall)
797 : : else
798 : : ! Fake values needed to call read_all collectively.
799 [ # # ]: 0 : call_subsizes = (/subs_x, 1, 1, 1/)
800 : 0 : call_starts = starts
801 : : end if
802 [ # # ]: 0 : ncount = PRODUCT(call_subsizes)
803 : : !
804 : : !write(std_out,*)" icall,ptr, ncount, ",icall,ptr,ncount
805 : : !write(std_out,*)" call_starts",call_starts
806 : : !write(std_out,*)" call_subsizes",call_subsizes
807 : : !
808 : : ! Create subarry file view.
809 : : call xmpio_create_fsubarray_4D(sizes,call_subsizes,call_starts,MPI_DOUBLE_COMPLEX,&
810 : 0 : & fsub_type,my_offpad,mpierr)
811 : 0 : ABI_CHECK_MPI(mpierr,"fsubarray_4D")
812 : :
813 : : ! Update the offset.
814 : 0 : my_offset = offset + my_offpad
815 : :
816 : 0 : call MPI_FILE_SET_VIEW(myfh, my_offset, MPI_BYTE, fsub_type, 'native', MPI_INFO_NULL, mpierr)
817 : 0 : ABI_CHECK_MPI(mpierr,"SET_VIEW")
818 : :
819 : 0 : call MPI_TYPE_FREE(fsub_type, mpierr)
820 : 0 : ABI_CHECK_MPI(mpierr,"MPI_TYPE_FREE")
821 : :
822 [ # # ]: 0 : if (sc_mode==xmpio_collective) then
823 : : ! Collective read
824 [ # # ]: 0 : if (icall <= my_ncalls) then
825 [ # # ]: 0 : cptr=c_loc(cbuffer(ptr)) ; call c_f_pointer(cptr,buf_ptr,[ncount])
826 : 0 : call MPI_FILE_READ_ALL(myfh, cbuffer(ptr:), ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
827 : : else
828 [ # # # # : 0 : ABI_MALLOC(dummy_cbuf,(subs_x))
# # # # #
# # # ]
829 : 0 : call MPI_FILE_READ_ALL(myfh, dummy_cbuf, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
830 [ # # ]: 0 : ABI_FREE(dummy_cbuf)
831 : : end if
832 : 0 : ABI_CHECK_MPI(mpierr,"FILE_READ_ALL")
833 : : else
834 : : ! Individual read.
835 [ # # ]: 0 : cptr=c_loc(cbuffer(ptr)) ; call c_f_pointer(cptr,buf_ptr,[ncount])
836 [ # # ]: 0 : call MPI_FILE_READ(myfh, buf_ptr, ncount, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
837 : 0 : ABI_CHECK_MPI(mpierr,"FILE_READ")
838 : : end if
839 : :
840 : : end do
841 : :
842 [ # # ]: 0 : ABI_FREE(my_subsizes)
843 [ # # ]: 0 : ABI_FREE(my_starts)
844 [ # # ]: 0 : ABI_FREE(my_basead)
845 : :
846 : 0 : end subroutine mpiotk_read_fsuba_dpc4D
847 : : !!***
848 : : #endif
849 : :
850 : : END MODULE m_mpiotk
851 : : !!***
|
