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 : !!***
|
