Line data Source code
1 : !!****m* ABINIT/m_wffile
2 : !! NAME
3 : !! m_wffile
4 : !!
5 : !! FUNCTION
6 : !! This module provides the definition of the wffile_type used to WF file data.
7 : !! As the type contains MPI-dependent fields, it has to be declared in a MPI-managed directory.
8 : !!
9 : !! COPYRIGHT
10 : !! Copyright (C) 2009-2026 ABINIT group (MT,MB,MVer,ZL,MD)
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 : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
15 : !!
16 : !! NOTES
17 : !! wffile_type: a handler for dealing with the IO of a wavefunction file
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_wffile
28 :
29 : use defs_basis
30 : use m_errors
31 : use m_abicore
32 : USE_MPI
33 : use m_xmpi
34 : use m_nctk
35 : use netcdf
36 :
37 : use defs_abitypes, only : MPI_Type
38 : use m_io_tools, only : mvrecord, open_file
39 : use m_fstrings, only : toupper, endswith, sjoin
40 : use iso_c_binding
41 :
42 : implicit none
43 :
44 : private
45 :
46 : #ifdef HAVE_MPI1
47 : include 'mpif.h'
48 : #endif
49 :
50 : #define DEV_DEBUG_THIS 0
51 :
52 : !public procedures.
53 : public :: WffOpen
54 : public :: wffclose
55 : public :: wffdelete
56 : public :: wffkg
57 : public :: wffoffset
58 : public :: wffreaddatarec ! Generic subroutines to read data in one record of a wavefunction file
59 : public :: wffreadnpwrec
60 : public :: wffreadskiprec
61 : public :: wffreadwrite_mpio
62 : public :: wffwritedatarec ! Generic subroutines to write data in one record of a wavefunction file
63 : public :: wffwritenpwrec
64 : public :: xderiveread ! Generic subroutines to read wf files.
65 : public :: xmpi_read_int2d
66 : public :: xderivewrite
67 :
68 : public :: getRecordMarkerLength_wffile
69 : public :: xnullifyOff
70 : public :: xmoveOff
71 : public :: xderiveWRecEnd
72 : public :: xderiveWRecInit
73 : public :: xderiveRRecEnd
74 : public :: xderiveRRecInit
75 : #if defined HAVE_MPI_IO
76 : public :: rwRecordMarker
77 : #endif
78 : public :: clsopn
79 : public :: wff_usef90
80 : public :: xdefineOff
81 : !!***
82 :
83 : !Generic interface of the routines wffreaddatarec
84 : interface wffreaddatarec
85 : module procedure WffReadDataRec_dp1d
86 : module procedure WffReadDataRec_dp2d
87 : end interface wffreaddatarec
88 :
89 : !Generic interface of the routines wffwritedatarec
90 : interface wffwritedatarec
91 : module procedure WffWriteDataRec_int2d
92 : module procedure WffWriteDataRec_dp1d
93 : module procedure WffWriteDataRec_dp2d
94 : end interface
95 :
96 : !Generic interface of the routines xderiveread
97 : interface xderiveread
98 : module procedure xderiveRead_int ! read integer value
99 : module procedure xderiveRead_int1d ! read integer array 1d
100 : module procedure xderiveRead_int2d ! read integer array 2d
101 : module procedure xderiveRead_dp ! read double precision value
102 : module procedure xderiveRead_dp1d ! read double precision array 1d
103 : module procedure xderiveRead_dp2d ! read double precision array 2d
104 : module procedure xderiveRead_int2d_displ ! read integer array 2d non-contiguous
105 : module procedure xderiveRead_dp2d_displ ! read double precision array 2d non-contiguous
106 : module procedure xderiveReadVal_char ! read character string
107 : module procedure xmpi_read_int2d
108 : end interface xderiveread
109 :
110 : !Generic interface of the routines xderivewrite
111 : interface xderivewrite
112 : module procedure xderiveWrite_int ! write integer value
113 : module procedure xderiveWrite_int1d ! write integer array 1d
114 : module procedure xderiveWrite_int2d ! write integer array 2d
115 : module procedure xderiveWrite_dp ! write double precision value
116 : module procedure xderiveWrite_dp1d ! write double precision array 1d
117 : module procedure xderiveWrite_dp2d ! write double precision array 2d
118 : module procedure xderiveWrite_dp2d_seq ! write double precision array 2d in sequential
119 : module procedure xderiveWrite_int2d_displ ! write integer array 2d non contiguous
120 : module procedure xderiveWrite_dp2d_displ ! write double precision array 2d non contiguous
121 : module procedure xderiveWrite_char ! write character string
122 : end interface xderivewrite
123 :
124 : !!****t* m_wffile/wffile_type
125 : !! NAME
126 : !! wffile_type
127 : !!
128 : !! FUNCTION
129 : !! This structure datatype is a handler for dealing with the IO of a
130 : !! wavefunction file.
131 : !! It contains, among other things, the method of access to the file
132 : !! (standard F90 read/write, or NetCDF call, or MPI IO), the unit number
133 : !! if applicable, the filename, the information on the
134 : !! parallelism, etc ...
135 : !!
136 : !! SOURCE
137 :
138 : type, public :: wffile_type
139 :
140 : ! WARNING : if you modify this datatype, please check there there is no creation/destruction/copy routine,
141 : ! declared in another part of ABINIT, that might need to take into account your modification.
142 :
143 : ! Integer scalar
144 : integer :: unwff
145 : ! unwff unit number of unformatted wavefunction disk file
146 :
147 : integer :: iomode
148 : ! Method to access the wavefunction file
149 : ! IO_MODE_FORTRAN for usual Fortran IO routines
150 : ! IO_MODE_FORTRAN_MASTER if usual Fortran IO routines, but only the master node in the parallel case
151 : ! IO_MODE_MPI if MPI/IO routines (this access method is only available in parallel)
152 : ! IO_MODE_NETCDF if NetCDF routines (obsolete, do not use)
153 : ! IO_MODE_ETSF, NetCDF format read via etsf-io.
154 :
155 : integer :: formwff
156 : ! formwff=format of the eigenvalues
157 : ! -1 => not used
158 : ! 0 => vector of eigenvalues
159 : ! 1 => hermitian matrix of eigenvalues
160 :
161 : integer :: headform
162 : ! headform=format of the header
163 :
164 : integer :: kgwff
165 : ! kgwff if 1 , read or write kg_k ; if 0, do not care about kg_k
166 :
167 : ! Character
168 : character(len=fnlen) :: fname
169 : ! filename (if available)
170 :
171 : ! In case of MPI parallel use
172 : integer :: master
173 : ! index of the processor master of the IO procedure when the WffOpen call is issued
174 :
175 : integer :: me
176 : ! index of my processor in the spaceComm communicator
177 :
178 : integer :: me_mpiio
179 : ! index of my processor in the spaceComm_mpiio communicator
180 :
181 : integer :: nproc
182 : ! number of processors that will have access to the file
183 :
184 : integer :: spaceComm
185 : ! space communicator for the standard FORTRAN access to the file
186 :
187 : integer :: spaceComm_mpiio
188 : ! space communicator for the MPI/IO access to the file
189 :
190 : ! In case of MPI/IO : additional information
191 : integer :: fhwff
192 : ! file handle used to access the file with MPI/IO.
193 :
194 : integer(kind=XMPI_OFFSET_KIND) :: nbOct_int,nbOct_dp,nbOct_ch
195 : ! nbOct_int byte number of int value
196 : ! nbOct_dp byte number of dp value
197 : ! nbOct_ch byte number of character value
198 :
199 : integer(kind=XMPI_OFFSET_KIND) :: nbOct_recMarker
200 : ! byte number of Fortran file record markers
201 :
202 : integer(kind=XMPI_OFFSET_KIND) :: lght_recs
203 : ! length of record
204 :
205 : integer :: marker_mpi_type
206 : ! MPI Datatype for Fortran record markers
207 :
208 : integer(kind=XMPI_OFFSET_KIND) :: offwff,off_recs
209 : ! offwff offset position of unformatted wavefunction disk file
210 : ! off_recs offset position of start record
211 : ! (used in parallel MPI-IO)
212 :
213 : integer :: offset_mpi_type
214 : ! MPI Datatype for INTEGER(kind=MPI_OFFSET_KIND)
215 :
216 : end type wffile_type
217 :
218 :
219 : CONTAINS
220 : !!***
221 :
222 : !----------------------------------------------------------------------
223 :
224 : !!****f* m_wffile/getRecordMarkerLength_wffile
225 : !! NAME
226 : !! getRecordMarkerLength_wffile
227 : !!
228 : !! FUNCTION
229 : !! Get the record marker length of the FORTRAN header of a file to access it in MPI/IO.
230 : !! This routine assumes that the header has been written (and flushed) in the file.
231 : !!
232 : !! SIDE EFFECTS
233 : !! wff=<type(wffile_type)>=structured info for reading/writing the wavefunctions
234 : !! only%nbOct_recMarker is changed
235 : !!
236 : !! SOURCE
237 :
238 0 : subroutine getRecordMarkerLength_wffile(wff)
239 :
240 : !Arguments ------------------------------------
241 : !scalars
242 : type(wffile_type),intent(inout) :: wff
243 :
244 : !Local variables-------------------------------
245 : #if defined HAVE_MPI_IO
246 : !scalars
247 : integer :: ierr,ii,iimax
248 : integer(kind=MPI_OFFSET_KIND) :: posit,rml
249 : character(len=500) :: msg
250 : !arrays
251 : integer :: headform(1),statux(MPI_STATUS_SIZE)
252 : integer(kind=MPI_OFFSET_KIND) :: off(1)
253 : #endif
254 :
255 : !************************************************************************
256 :
257 : #ifdef DEV_DEBUG_THIS
258 : return
259 : ! Already done in WffOpen
260 : #endif
261 :
262 : #if defined HAVE_MPI_IO
263 :
264 : if (wff%nbOct_recMarker>0) return
265 :
266 : !wff%nbOct_recMarker=4;return
267 : !call flush(wff%unwff)
268 : !call MPI_FILE_SYNC(wff%fhwff,ierr)
269 :
270 : !Only master do that
271 : ierr=0
272 : if (wff%master==wff%me) then
273 :
274 : ! Define number of INTEGER types to be tested
275 : #if defined HAVE_FC_INT_QUAD
276 : iimax=4
277 : #else
278 : iimax=3
279 : #endif
280 :
281 : ! Try to read headform
282 : rml=-1;ii=0
283 : do while (wff%nbOct_recMarker<=0.and.ii<iimax)
284 : ii=ii+1
285 : if (ii==1) rml=4
286 : if (ii==2) rml=8
287 : if (ii==3) rml=2
288 : if (ii==4) rml=16
289 : posit=rml+6*wff%nbOct_ch
290 : call MPI_FILE_READ_AT(wff%fhwff,posit,headform,1,MPI_INTEGER,statux,ierr)
291 : if (ierr==MPI_SUCCESS) then
292 : if (headform(1)==wff%headform) wff%nbOct_recMarker=rml
293 : end if
294 : end do
295 :
296 : if (ierr/=MPI_SUCCESS) then
297 : ABI_BUG("Header problem")
298 : end if
299 :
300 : if (ii==iimax.and.wff%nbOct_recMarker<=0) then
301 : ! if (iimax>=4) then
302 : ! write(msg,'(3a)') &
303 : ! & ' Your architecture is not able to handle 16, 8, 4 or 2-bytes FORTRAN file record markers !',ch10,&
304 : ! & ' You cannot use ABINIT and MPI/IO.'
305 : ! else
306 : ! write(msg,'(3a)') &
307 : ! & ' Your architecture is not able to handle 8, 4 or 2-bytes FORTRAN file record markers !',ch10,&
308 : ! & ' You cannot use ABINIT and MPI/IO.'
309 : ! end if
310 : write(msg,'(13a)') &
311 : & ' Error during FORTRAN file record marker detection:',ch10,&
312 : & ' It was not possible to read/write a small file!',ch10,&
313 : & ' ACTION: check your access permissions to the file system.',ch10,&
314 : & ' Common sources of this problem:',ch10,&
315 : & ' - Quota limit exceeded,',ch10,&
316 : & ' - R/W incorrect permissions,',ch10,&
317 : & ' - WFK file requested as input (irdwfk=1/getwfk=1) but not existing ...'
318 : ABI_ERROR(msg)
319 : else
320 : write(msg,'(a,i0)') &
321 : & ' MPI/IO accessing FORTRAN file header: detected record mark length=',wff%nbOct_recMarker
322 : ABI_COMMENT(msg)
323 : end if
324 :
325 : end if ! me=master
326 :
327 : !Broadcast record marker length
328 : if (wff%spaceComm/=MPI_COMM_SELF) then
329 : off(1)=wff%nbOct_recMarker
330 : call MPI_BCAST(off,1,wff%offset_mpi_type,wff%master,wff%spaceComm,ierr)
331 : wff%nbOct_recMarker=off(1)
332 : end if
333 :
334 : !Select MPI datatype for markers
335 : if (wff%nbOct_recMarker==4) then
336 : wff%marker_mpi_type=MPI_INTEGER4
337 : else if (wff%nbOct_recMarker==8) then
338 : wff%marker_mpi_type=MPI_INTEGER8
339 : #if defined HAVE_FC_INT_QUAD && defined HAVE_MPI_INTEGER16
340 : else if (wff%nbOct_recMarker==16) then
341 : wff%marker_mpi_type=MPI_INTEGER16
342 : #endif
343 : else if (wff%nbOct_recMarker==2) then
344 : wff%marker_mpi_type=MPI_INTEGER2
345 : end if
346 :
347 : #endif
348 :
349 : RETURN
350 : ABI_UNUSED(wff%me)
351 :
352 : end subroutine getRecordMarkerLength_wffile
353 : !!***
354 :
355 : !----------------------------------------------------------------------
356 :
357 : !!****f* m_wffile/rwRecordMarker
358 : !! NAME
359 : !! rwRecordMarker
360 : !!
361 : !! FUNCTION
362 : !! Read/Write a record marker in a FORTRAN file at a given file pointer position.
363 : !! This is needed to access data in a FORTRAN file with MPI/IO.
364 : !!
365 : !! INPUTS
366 : !! option=1 for reading by current proc
367 : !! 2 for writing by current proc
368 : !! 3 for reading by all procs
369 : !! 4 for writing by all procs
370 : !! posit= position of the MPI/IO file pointer
371 : !! wff=<type(wffile_type)>=structured info for reading/writing
372 : !! Use here only:
373 : !! wff%fhwff= handle of the MPI/IO file
374 : !! wff%nbOct_recMarker= length of Fortran record markers
375 : !!
376 : !! OUTPUT
377 : !! ierr= error code
378 : !!
379 : !! SIDE EFFECTS
380 : !! posit= position of the MPI/IO file pointer
381 : !! updated after the reading (with the length of the record)
382 : !! recordmarker= content of the record marker
383 : !!
384 : !! SOURCE
385 :
386 : #if defined HAVE_MPI_IO
387 :
388 370 : subroutine rwRecordMarker(option,posit,recordmarker,wff,ierr)
389 :
390 : !Arguments ------------------------------------
391 : !scalars
392 : integer,intent(in) :: option
393 : integer(kind=MPI_OFFSET_KIND),intent(inout) :: posit,recordmarker
394 : integer,intent(out) :: ierr
395 : type(wffile_type),intent(inout) :: wff
396 :
397 : !Local variables-------------------------------
398 : !scalars
399 : integer(kind=2) :: delim_record2(1)
400 : integer(kind=4) :: delim_record4(1)
401 : integer(kind=8) :: delim_record8(1)
402 : #if defined HAVE_FC_INT_QUAD
403 : integer(kind=16) :: delim_record16(1)
404 : #endif
405 : !character(len=500) :: msg
406 : !arrays
407 : integer :: statux(MPI_STATUS_SIZE)
408 :
409 : !************************************************************************
410 :
411 370 : ierr=0
412 :
413 370 : if (option==1) then
414 235 : if (wff%nbOct_recMarker==4) then
415 235 : call MPI_FILE_READ_AT(wff%fhwff,posit,delim_record4,1,wff%marker_mpi_type,statux,ierr)
416 235 : recordmarker = delim_record4(1)
417 0 : else if (wff%nbOct_recMarker==8) then
418 0 : call MPI_FILE_READ_AT(wff%fhwff,posit,delim_record8,1,wff%marker_mpi_type,statux,ierr)
419 0 : recordmarker = delim_record8(1)
420 : #if defined HAVE_FC_INT_QUAD
421 0 : else if (wff%nbOct_recMarker==16) then
422 0 : call MPI_FILE_READ_AT(wff%fhwff,posit,delim_record16,1,wff%marker_mpi_type,statux,ierr)
423 0 : recordmarker = delim_record16(1)
424 : #endif
425 0 : else if (wff%nbOct_recMarker==2) then
426 0 : call MPI_FILE_READ_AT(wff%fhwff,posit,delim_record2,1,wff%marker_mpi_type,statux,ierr)
427 0 : recordmarker = delim_record2(1)
428 : else
429 0 : ABI_BUG('Wrong record marker length!')
430 : end if
431 :
432 135 : else if (option==2) then
433 135 : if (wff%nbOct_recMarker==4) then
434 135 : delim_record4(1) = recordmarker
435 135 : call MPI_FILE_WRITE_AT(wff%fhwff,posit,delim_record4,1,wff%marker_mpi_type,statux,ierr)
436 0 : else if (wff%nbOct_recMarker==8) then
437 0 : delim_record8(1) = recordmarker
438 0 : call MPI_FILE_WRITE_AT(wff%fhwff,posit,delim_record8,1,wff%marker_mpi_type,statux,ierr)
439 : #if defined HAVE_FC_INT_QUAD
440 0 : else if (wff%nbOct_recMarker==16) then
441 0 : delim_record16(1) = recordmarker
442 0 : call MPI_FILE_WRITE_AT(wff%fhwff,posit,delim_record16,1,wff%marker_mpi_type,statux,ierr)
443 : #endif
444 0 : else if (wff%nbOct_recMarker==2) then
445 0 : delim_record2(1) = recordmarker
446 0 : call MPI_FILE_WRITE_AT(wff%fhwff,posit,delim_record2,1,wff%marker_mpi_type,statux,ierr)
447 : else
448 0 : ABI_BUG('Wrong record marker length!')
449 : end if
450 :
451 0 : else if (option==3) then
452 0 : if (wff%nbOct_recMarker==4) then
453 0 : call MPI_FILE_READ_AT_ALL(wff%fhwff,posit,delim_record4,1,wff%marker_mpi_type,statux,ierr)
454 0 : recordmarker = delim_record4(1)
455 0 : else if (wff%nbOct_recMarker==8) then
456 0 : call MPI_FILE_READ_AT_ALL(wff%fhwff,posit,delim_record8,1,wff%marker_mpi_type,statux,ierr)
457 0 : recordmarker = delim_record8(1)
458 : #if defined HAVE_FC_INT_QUAD
459 0 : else if (wff%nbOct_recMarker==16) then
460 0 : call MPI_FILE_READ_AT_ALL(wff%fhwff,posit,delim_record16,1,wff%marker_mpi_type,statux,ierr)
461 0 : recordmarker = delim_record16(1)
462 : #endif
463 0 : else if (wff%nbOct_recMarker==2) then
464 0 : call MPI_FILE_READ_AT_ALL(wff%fhwff,posit,delim_record2,1,wff%marker_mpi_type,statux,ierr)
465 0 : recordmarker = delim_record2(1)
466 : else
467 0 : ABI_BUG('Wrong record marker length !')
468 : end if
469 :
470 0 : else if (option==4) then
471 0 : if (wff%nbOct_recMarker==4) then
472 0 : delim_record4(1) = recordmarker
473 0 : call MPI_FILE_WRITE_AT_ALL(wff%fhwff,posit,delim_record4,1,wff%marker_mpi_type,statux,ierr)
474 0 : else if (wff%nbOct_recMarker==8) then
475 0 : delim_record8(1) = recordmarker
476 0 : call MPI_FILE_WRITE_AT_ALL(wff%fhwff,posit,delim_record8,1,wff%marker_mpi_type,statux,ierr)
477 : #if defined HAVE_FC_INT_QUAD
478 0 : else if (wff%nbOct_recMarker==16) then
479 0 : delim_record16(1) = recordmarker
480 0 : call MPI_FILE_WRITE_AT_ALL(wff%fhwff,posit,delim_record16,1,wff%marker_mpi_type,statux,ierr)
481 : #endif
482 0 : else if (wff%nbOct_recMarker==2) then
483 0 : delim_record2(1) = recordmarker
484 0 : call MPI_FILE_WRITE_AT_ALL(wff%fhwff,posit,delim_record2,1,wff%marker_mpi_type,statux,ierr)
485 : else
486 0 : ABI_BUG('Wrong record marker length!')
487 : end if
488 :
489 : else
490 0 : ABI_BUG('Wrong value for option!')
491 : end if
492 :
493 370 : posit = posit + recordmarker + 2*wff%nbOct_recMarker
494 :
495 370 : end subroutine rwRecordMarker
496 : #endif
497 : !!***
498 :
499 : !------------------------------------------------------------------------------------
500 :
501 : !!****f* m_wffile/xnullifyOff
502 : !! NAME
503 : !! xnullifyOff
504 : !!
505 : !! FUNCTION
506 : !! In case of MPI I/O, nullify the offset of a WF file
507 : !!
508 : !! INPUTS
509 : !!
510 : !! OUTPUT
511 : !!
512 : !! SIDE EFFECTS
513 : !! wff=<type(wffile_type)>=structured info for reading/writing
514 : !!
515 : !! SOURCE
516 :
517 0 : subroutine xnullifyOff(wff)
518 :
519 : !Arguments ------------------------------------
520 : type(wffile_type),intent(inout) :: wff
521 :
522 : ! *************************************************************************
523 :
524 : #if defined HAVE_MPI_IO
525 0 : wff%offwff = 0
526 0 : wff%off_recs = 0
527 0 : wff%lght_recs = 0
528 : #endif
529 :
530 : RETURN
531 : ABI_UNUSED(wff%me)
532 :
533 : end subroutine xnullifyOff
534 : !!***
535 :
536 : !------------------------------------------------------------------------------------
537 :
538 : !!****f* m_wffile/xmoveOff
539 : !! NAME
540 : !! xmoveOff
541 : !!
542 : !! FUNCTION
543 : !! In case of MPI I/O, move the offset of a WF file
544 : !!
545 : !! INPUTS
546 : !! [n_int] = number if integers to skip
547 : !! [n_dp] = number if double precision reals to skip
548 : !! [n_ch] = number if characters to skip
549 : !! [n_mark]= number if record markers to skip
550 : !!
551 : !! OUTPUT
552 : !!
553 : !! SIDE EFFECTS
554 : !! wff=<type(wffile_type)>=structured info for reading/writing
555 : !!
556 : !! SOURCE
557 :
558 0 : subroutine xmoveOff(wff,n_int,n_dp,n_ch,n_mark)
559 :
560 : !Arguments ------------------------------------
561 : integer,intent(in),optional :: n_int,n_dp,n_ch,n_mark
562 : type(wffile_type),intent(inout) :: wff
563 :
564 : ! *************************************************************************
565 :
566 : #if defined HAVE_MPI_IO
567 0 : if (present(n_int) ) wff%offwff=wff%offwff+n_int *wff%nbOct_int
568 0 : if (present(n_dp) ) wff%offwff=wff%offwff+n_dp *wff%nbOct_dp
569 0 : if (present(n_ch) ) wff%offwff=wff%offwff+n_ch *wff%nbOct_ch
570 0 : if (present(n_mark)) wff%offwff=wff%offwff+n_mark*wff%nbOct_recMarker
571 : #else
572 : !This section should not be used...
573 : if (present(n_int) .and.(.false.)) write(std_out,*) n_int
574 : if (present(n_dp) .and.(.false.)) write(std_out,*) n_dp
575 : if (present(n_ch) .and.(.false.)) write(std_out,*) n_ch
576 : if (present(n_mark).and.(.false.)) write(std_out,*) n_mark
577 : #endif
578 :
579 0 : end subroutine xmoveOff
580 : !!***
581 :
582 : !------------------------------------------------------------------------------------
583 :
584 : !!****f* m_wffile/xderiveWRecEnd
585 : !! NAME
586 : !! xderiveWRecEnd
587 : !!
588 : !! FUNCTION
589 : !! Writes the first and last wavefunction block marker using MPI/IO
590 : !!
591 : !! INPUTS
592 : !! me_proc= (optional argument) index of current proc
593 : !!
594 : !! OUTPUT
595 : !! ierr= exit status, a non-zero value meaning there is an error
596 : !!
597 : !! SIDE EFFECTS
598 : !! wff= structured info for reading/writing the wavefunctions
599 : !!
600 : !! NOTES
601 : !! We assume that:
602 : !! wff%offwff contains the position of the end of the record
603 : !! wff%off_recs contains the position of the beginning of the record
604 : !!
605 : !! SOURCE
606 :
607 82 : subroutine xderiveWRecEnd(wff,ierr,me_proc)
608 :
609 : !Arguments ------------------------------------
610 : type(wffile_type),intent(inout) :: wff
611 : integer,intent(in),optional :: me_proc
612 : integer,intent(out) :: ierr
613 :
614 : !Local variables-------------------------------
615 : #if defined HAVE_MPI_IO
616 : !scalars
617 : integer :: me
618 : integer(kind=MPI_OFFSET_KIND) :: delim_record,posit
619 : !arrays
620 : #endif
621 :
622 : ! *************************************************************************
623 :
624 82 : ierr=0
625 :
626 : #if defined HAVE_MPI_IO
627 82 : me=-1;if (present(me_proc)) me=me_proc
628 52 : if (me==-1.or.me==0) then
629 :
630 45 : delim_record=wff%offwff-wff%off_recs-wff%nbOct_recMarker
631 :
632 : ! Write the first word of the record
633 45 : posit=wff%off_recs
634 45 : call rwRecordMarker(2,posit,delim_record,wff,ierr)
635 :
636 : ! Write the last word of the record
637 45 : posit=wff%offwff
638 45 : call rwRecordMarker(2,posit,delim_record,wff,ierr)
639 :
640 : end if
641 :
642 82 : wff%offwff = wff%offwff + wff%nbOct_recMarker
643 : #endif
644 :
645 82 : RETURN
646 : ABI_UNUSED((/wff%me,me_proc/))
647 :
648 : end subroutine xderiveWRecEnd
649 : !!***
650 :
651 : !------------------------------------------------------------------------------
652 :
653 : !!****f* m_wffile/xderiveWRecInit
654 : !! NAME
655 : !! xderiveWRecInit
656 : !!
657 : !! FUNCTION
658 : !! Writes the first wavefunction block marker using MPI/IO.
659 : !!
660 : !! INPUTS
661 : !! me_proc= (optional argument) index of current proc
662 : !!
663 : !! OUTPUT
664 : !! ierr= exit status, a non-zero value meaning there is an error
665 : !!
666 : !! SIDE EFFECTS
667 : !! wff= structured info for reading/writing the wavefunctions
668 : !!
669 : !! NOTES
670 : !! We assume that:
671 : !! wff%offwff contains the position of the beginning of the record
672 : !!
673 : !! SOURCE
674 :
675 82 : subroutine xderiveWRecInit(wff,ierr,me_proc)
676 :
677 : !Arguments ------------------------------------
678 : type(wffile_type),intent(inout) :: wff
679 : integer,intent(in),optional :: me_proc
680 : integer,intent(out) :: ierr
681 :
682 : !Local variables-------------------------------
683 : #if defined HAVE_MPI_IO
684 : !scalars
685 : integer :: me
686 : integer(kind=MPI_OFFSET_KIND) :: delim_record,posit
687 : !arrays
688 : #endif
689 :
690 : ! *************************************************************************
691 :
692 82 : ierr=0
693 :
694 : #if defined HAVE_MPI_IO
695 82 : me=-1;if (present(me_proc)) me=me_proc
696 52 : if (me==-1.or.me==0) then
697 :
698 : ! Write the first word of the record
699 45 : posit=wff%offwff;delim_record=0
700 45 : call rwRecordMarker(2,posit,delim_record,wff,ierr)
701 :
702 : end if
703 :
704 82 : wff%off_recs = wff%offwff
705 82 : wff%offwff = wff%offwff + wff%nbOct_recMarker
706 : #endif
707 :
708 82 : RETURN
709 : ABI_UNUSED((/wff%me,me_proc/))
710 :
711 : end subroutine xderiveWRecInit
712 : !!***
713 :
714 : !---------------------------------------------------------------------------------
715 :
716 : !!****f* m_wffile/xderiveRRecEnd
717 : !! NAME
718 : !! xderiveRRecEnd
719 : !!
720 : !! FUNCTION
721 : !! Initializes the end-of-record offset for MPI/IO.
722 : !!
723 : !! INPUTS
724 : !! me_proc= (optional argument) index of current proc
725 : !!
726 : !! OUTPUT
727 : !! ierr= exit status, a non-zero value meaning there is an error
728 : !!
729 : !! SIDE EFFECTS
730 : !! wff= structured info for reading/writing the wavefunctions
731 : !!
732 : !! NOTES
733 : !! We assume that:
734 : !! wff%off_recs contains the position of the beginning of the record
735 : !!
736 : !! SOURCE
737 :
738 32 : subroutine xderiveRRecEnd(wff,ierr)
739 :
740 : !Arguments ------------------------------------
741 : integer,intent(out) :: ierr
742 : type(wffile_type),intent(inout) :: wff
743 :
744 : ! *************************************************************************
745 :
746 32 : ierr=0
747 : #if defined HAVE_MPI_IO
748 : !Define offset end of record
749 32 : wff%offwff = wff%off_recs + wff%lght_recs + 2*wff%nbOct_recMarker
750 : #endif
751 :
752 : RETURN
753 : ABI_UNUSED(wff%me)
754 :
755 : end subroutine xderiveRRecEnd
756 : !!***
757 :
758 : !-------------------------------------------------------------------------------
759 :
760 : !!****f* m_wffile/xderiveRRecInit
761 : !! NAME
762 : !! xderiveRRecInit
763 : !!
764 : !! FUNCTION
765 : !! Initializes the record length for MPI/IO.
766 : !!
767 : !! INPUTS
768 : !! me_proc= (optional argument) index of current proc
769 : !!
770 : !! OUTPUT
771 : !! ierr= exit status, a non-zero value meaning there is an error
772 : !!
773 : !! SIDE EFFECTS
774 : !! wff= structured info for reading/writing the wavefunctions
775 : !!
776 : !! NOTES
777 : !! We assume that:
778 : !! wff%offwff contains the position of the beginning of the record
779 : !!
780 : !! SOURCE
781 :
782 32 : subroutine xderiveRRecInit(wff,ierr)
783 :
784 : !Arguments ------------------------------------
785 : type(wffile_type),intent(inout) :: wff
786 : integer,intent(out) :: ierr
787 :
788 : !Local variables-------------------------------
789 : #if defined HAVE_MPI_IO
790 : integer(kind=MPI_OFFSET_KIND) :: delim_record,posit
791 : #endif
792 :
793 : ! *************************************************************************
794 :
795 : ierr=0
796 :
797 : #if defined HAVE_MPI_IO
798 32 : wff%off_recs = wff%offwff
799 :
800 : !Read the length of the record
801 32 : posit=wff%off_recs
802 32 : call rwRecordMarker(1,posit,delim_record,wff,ierr)
803 :
804 32 : wff%lght_recs = delim_record
805 32 : wff%offwff = wff%offwff + wff%nbOct_recMarker
806 : #endif
807 :
808 32 : RETURN
809 : ABI_UNUSED(wff%me)
810 :
811 : end subroutine xderiveRRecInit
812 : !!***
813 :
814 : !----------------------------------------------------------------------
815 :
816 : !!****f* m_wffile/clsopn
817 : !! NAME
818 : !! clsopn
819 : !!
820 : !! FUNCTION
821 : !! Close wavefunction file (provided its access is standard F90 IO), then reopen the same.
822 : !! Uses fortran inquire statement to reopen with same characteristics.
823 : !!
824 : !! INPUTS
825 : !! wff=number of unit to which on which file is already opened.
826 : !!
827 : !! SIDE EFFECTS
828 : !!
829 : !! SOURCE
830 :
831 0 : subroutine clsopn(wff)
832 :
833 : !Arguments ------------------------------------
834 : !scalars
835 : type(wffile_type),intent(inout) :: wff
836 :
837 : !Local variables-------------------------------
838 : !scalars
839 : integer :: ios,unit
840 : logical :: nmd,od
841 : character(len=11) :: fm
842 : character(len=500) :: message
843 : character(len=fnlen) :: filnam
844 :
845 : ! *************************************************************************
846 :
847 0 : if ( ANY(wff%iomode==(/IO_MODE_FORTRAN_MASTER,IO_MODE_FORTRAN/) ))then
848 :
849 0 : unit=wff%unwff
850 0 : inquire (unit=unit,iostat=ios,opened=od,name=filnam,form=fm,named=nmd)
851 :
852 : ! ios is a status specifier. If an error condition exists,
853 : ! ios is assigned a processor-dependent value > 0.
854 0 : if (ios/=0) then
855 : write(message, '(/,a,/,a,i8,a,i8,/,a,/,a,/,a)' ) &
856 0 : & ' clsopn : ERROR -',&
857 0 : & ' Attempt to inquire about unit=',unit,&
858 0 : & ' indicates error condition iostat=',ios,&
859 0 : & ' May be due to temporary problem with file, disks or network.',&
860 0 : & ' Action: check whether there might be some external problem,',&
861 0 : & ' then resubmit.'
862 0 : ABI_ERROR(message)
863 :
864 : ! od is a logical variable which is set to true if the specified
865 : ! unit is connected to a file; otherwise it is set to false.
866 0 : else if (.not.od) then
867 : write(message, '(/,a,/,a,i8,/,a,/,a,/,a,/,a)' ) &
868 0 : & ' clsopn : ERROR -',&
869 0 : & ' Tried to inquire about unit',unit,&
870 0 : & ' and found it not connected to a file.',&
871 0 : & ' May be due to temporary problem with file, disks or network.',&
872 0 : & ' Action: check whether there might be some external problem,',&
873 0 : & ' then resubmit.'
874 0 : ABI_ERROR(message)
875 :
876 : ! nmd is a logical variable assigned the value true if the file
877 : ! has a name; otherwise false. A scratch file is not named.
878 0 : else if (.not.nmd) then
879 :
880 : ! No action for the time being. Possibility to debug.
881 :
882 : else
883 :
884 : ! May now close the file and then reopen it
885 : ! (file is already opened according to above checks)
886 0 : close (unit=unit)
887 0 : open (unit=unit,file=filnam,form=fm,status='old') !VALGRIND complains filnam is just a few thousand bytes inside a block of 8300
888 :
889 : end if
890 :
891 0 : else if (wff%iomode == IO_MODE_MPI) then
892 0 : call xnullifyOff(wff)
893 : else if (wff%iomode == IO_MODE_ETSF) then
894 : ! We do nothing, ETSF access already not being sequential.
895 : end if
896 :
897 0 : end subroutine clsopn
898 : !!***
899 :
900 : !----------------------------------------------------------------------
901 :
902 : !!****f* m_wffile/wff_usef90
903 : !! NAME
904 : !! wff_usef90
905 : !!
906 : !! FUNCTION
907 : !! 1 if a Fortran file is going to be read by this node, 0 otherwise.
908 : !!
909 : !! INPUTS
910 : !!
911 : !! SOURCE
912 :
913 0 : function wff_usef90(wff)
914 :
915 : !Arguments ------------------------------------
916 : !scalars
917 : integer :: wff_usef90
918 : type(wffile_type),intent(in) :: wff
919 :
920 : ! *************************************************************************
921 :
922 0 : wff_usef90=0
923 0 : if (wff%iomode==IO_MODE_FORTRAN.or.(wff%iomode ==IO_MODE_FORTRAN_MASTER.and.wff%master==wff%me)) wff_usef90=1
924 :
925 0 : end function wff_usef90
926 : !!***
927 :
928 : !----------------------------------------------------------------------
929 :
930 : !!****f* m_wffile/wff_ireadf90
931 : !! NAME
932 : !! wff_ireadf90
933 : !!
934 : !! FUNCTION
935 : !! 1 if a Fortran file is going to be read by this node, 0 otherwise.
936 : !!
937 : !! INPUTS
938 : !!
939 : !! SOURCE
940 :
941 : function wff_ireadf90(wff)
942 :
943 : !Arguments ------------------------------------
944 : !scalars
945 : integer :: wff_ireadf90
946 : type(wffile_type),intent(in) :: wff
947 :
948 : ! *************************************************************************
949 :
950 : wff_ireadf90=0
951 : if (wff%iomode==IO_MODE_FORTRAN.or.(wff%iomode==IO_MODE_FORTRAN_MASTER.and.wff%master==wff%me)) wff_ireadf90=1
952 :
953 : end function wff_ireadf90
954 : !!***
955 :
956 : !----------------------------------------------------------------------
957 :
958 : !!****f* m_wffile/WffOpen
959 : !! NAME
960 : !! WffOpen
961 : !!
962 : !! FUNCTION
963 : !! This subroutine opens a Wf file. It might be accessed
964 : !! by different mechanisms (usual F90 IO routines,
965 : !! MPI I/O, or, in the future, NetCDF). The routine
966 : !! provides a file handler, wff (a data structure containing
967 : !! all needed information).
968 : !!
969 : !! INPUTS
970 : !! iomode=access mode (0 means all procs access using usual F90
971 : !! routines ; -1 means only the master proc access, using usual
972 : !! F90 routines ; 1 means MPI I/O; 2 means netcdf I/O)
973 : !! filename=name of the file
974 : !! master=the number of the master proc (only needed in parallel)
975 : !! me=my number (only needed in parallel)
976 : !! spaceComm= the space communicator handler (only needed in MPI parallel I/O)
977 : !! spaceWorld= the space communicator for the whole set of procs
978 : !! unwff=the file unit number
979 : !!
980 : !! OUTPUT
981 : !! ier=error code
982 : !! wff= structured info about the wavefunction file
983 : !!
984 : !! SOURCE
985 :
986 2412 : subroutine WffOpen(iomode,spaceComm,filename,ier,wff,master,me,unwff,&
987 : & spaceComm_mpiio) ! optional argument
988 :
989 : !Arguments ------------------------------------
990 : integer, intent(in) :: iomode,spaceComm,master,me,unwff
991 : integer, intent(in),optional :: spaceComm_mpiio
992 : integer, intent(out) :: ier
993 : character(len=fnlen), intent(in) :: filename
994 : type(wffile_type), intent(inout) :: wff !vz_i
995 :
996 : !Local variables-------------------------------
997 : character(len=500) :: message
998 : character(len=fnlen) :: fildata
999 : #ifdef HAVE_MPI_IO
1000 : integer :: isize
1001 : #endif
1002 :
1003 : ! *************************************************************************
1004 :
1005 : !Initialize the mandatory data of the wff datastructure
1006 2412 : wff%unwff =unwff
1007 2412 : wff%iomode =iomode; if (endswith(filename, ".nc")) wff%iomode = IO_MODE_ETSF
1008 2412 : if (filename/=wff%fname) wff%fname=filename
1009 :
1010 : !Initialize info useful for parallel use
1011 2412 : wff%nproc =1
1012 2412 : wff%master =master
1013 2412 : wff%me =me
1014 2412 : wff%me_mpiio =0
1015 2412 : wff%spaceComm=spaceComm
1016 2412 : wff%spaceComm_mpiio=xmpi_comm_self
1017 :
1018 : #if defined HAVE_MPI
1019 : ! This case occurs when wff is connected to a DENSITY file
1020 : ! abinit_comm_output is generally equal to MPI_COMM_WORLD (except if paral. over images)
1021 2412 : if (spaceComm==MPI_COMM_SELF) wff%spaceComm=abinit_comm_output
1022 : ! if (spaceComm==MPI_COMM_SELF) wff%spaceComm=MPI_COMM_WORLD
1023 2412 : call MPI_COMM_SIZE(wff%spaceComm,wff%nproc,ier)
1024 : ! Redefine the default MPIIO communicator if MPI, although MPIIO features should not be used unless
1025 : ! present(spaceComm_mpiio).and.wff%iomode==1
1026 2412 : wff%spaceComm_mpiio=wff%spaceComm
1027 2412 : wff%me_mpiio=wff%me
1028 : #endif
1029 :
1030 2412 : if (present(spaceComm_mpiio).and.any(wff%iomode==[IO_MODE_MPI, IO_MODE_ETSF])) wff%spaceComm_mpiio=spaceComm_mpiio
1031 : #if defined HAVE_MPI
1032 2412 : call MPI_COMM_RANK(wff%spaceComm_mpiio,wff%me_mpiio,ier)
1033 : #endif
1034 :
1035 2412 : ier=0
1036 2412 : if (wff%iomode==IO_MODE_FORTRAN) then ! All processors see a local file
1037 0 : if (open_file(filename, message, unit=unwff, form="unformatted") /= 0) then
1038 0 : ABI_ERROR(message)
1039 : end if
1040 0 : rewind(unwff)
1041 :
1042 2412 : else if (wff%iomode==IO_MODE_FORTRAN_MASTER) then ! Only the master processor see a local file
1043 132 : if(master==me)then
1044 112 : if (open_file(filename, message, unit=unwff, form="unformatted") /= 0) then
1045 0 : ABI_ERROR(message)
1046 : end if
1047 112 : rewind(unwff)
1048 : end if
1049 :
1050 : #if defined HAVE_MPI_IO
1051 2280 : else if (wff%iomode==IO_MODE_MPI)then ! In the parallel case, only the master open filename file
1052 32 : if(master==me)then
1053 27 : if (open_file(filename, message, unit=unwff, form="unformatted") /= 0) then
1054 0 : ABI_ERROR(message)
1055 : end if
1056 27 : rewind(unwff)
1057 : end if
1058 : ! MG: Great! These barriers lead to a deadlock if prtded hence MPI_FILE_OPEN is not called by all the processors!
1059 : !call xmpi_barrier(wff%spaceComm)
1060 : !call xmpi_barrier(wff%spaceComm_mpiio)
1061 :
1062 32 : call MPI_FILE_OPEN(wff%spaceComm,filename,MPI_MODE_CREATE + MPI_MODE_RDWR,MPI_INFO_NULL,wff%fhwff,ier)
1063 32 : ABI_CHECK_MPI(ier,sjoin("WffOpen:", filename))
1064 :
1065 : ! Define all type values
1066 32 : call MPI_Type_size(MPI_INTEGER,isize,ier)
1067 32 : wff%nbOct_int=isize
1068 32 : call MPI_Type_size(MPI_DOUBLE_PRECISION,isize,ier)
1069 32 : wff%nbOct_dp=isize
1070 32 : call MPI_Type_size(MPI_CHARACTER,isize,ier)
1071 32 : wff%nbOct_ch=isize
1072 32 : wff%nbOct_recMarker=-1;wff%kgwff=-1;wff%formwff=-1
1073 32 : wff%offwff=0;wff%off_recs=0;wff%lght_recs=0
1074 : wff%marker_mpi_type=MPI_INTEGER ! Default value
1075 :
1076 : #ifdef DEV_DEBUG_THIS
1077 32 : wff%nbOct_recMarker=xmpio_bsize_frm
1078 32 : wff%marker_mpi_type=xmpio_mpi_type_frm
1079 : #endif
1080 :
1081 : if (MPI_OFFSET_KIND==4) then
1082 : wff%offset_mpi_type=MPI_INTEGER4
1083 : else if (MPI_OFFSET_KIND==8) then
1084 32 : wff%offset_mpi_type=MPI_INTEGER8
1085 : #if defined HAVE_FC_INT_QUAD && defined HAVE_MPI_INTEGER16
1086 : else if (MPI_OFFSET_KIND==16) then
1087 : wff%offset_mpi_type=MPI_INTEGER16
1088 : #endif
1089 : else if (MPI_OFFSET_KIND==2) then
1090 : wff%offset_mpi_type=MPI_INTEGER2
1091 : end if
1092 : #endif
1093 :
1094 2248 : else if (wff%iomode==IO_MODE_ETSF)then
1095 2248 : fildata = nctk_ncify(filename)
1096 2248 : NCF_CHECK(nctk_open_modify(wff%unwff, fildata, xmpi_comm_self))
1097 2248 : wff%fname = fildata
1098 : !write(message,'(3A,I0)')'WffOpen: opening ', trim(wff%fname)," on unit ", wff%unwff
1099 : !call wrtout(std_out, message, 'COLL')
1100 : else
1101 : write(message, '(7a,i0,3a)' )&
1102 0 : & 'For the time being the input variable iomode is restricted ',ch10,&
1103 0 : & 'to 0 (all cases), 1 (in case MPI is enabled),',ch10,&
1104 0 : & 'or 3 (only sequential, and if the NetCDF and ETSF_IO libraries have been enabled).',ch10,&
1105 0 : & 'Its value is iomode= ',wff%iomode,'.',ch10,&
1106 0 : & 'Action: change iomode or use ABINIT in parallel or enable NetCDF and/or ETSF_IO.'
1107 0 : ABI_ERROR(message)
1108 : end if
1109 :
1110 2412 : end subroutine WffOpen
1111 : !!***
1112 :
1113 : !----------------------------------------------------------------------
1114 :
1115 : !!****f* m_wffile/WffClose
1116 : !! NAME
1117 : !! WffClose
1118 : !!
1119 : !! FUNCTION
1120 : !! This subroutine closes a Wf file.
1121 : !!
1122 : !! INPUTS
1123 : !! wff= structured info about the wavefunction file
1124 : !!
1125 : !! OUTPUT
1126 : !! ierr=error code
1127 : !!
1128 : !! SOURCE
1129 :
1130 2412 : subroutine WffClose(wff,ier)
1131 :
1132 : !Arguments ------------------------------------
1133 : type(wffile_type), intent(inout) :: wff
1134 : integer, intent(out) :: ier
1135 :
1136 : ! *************************************************************************
1137 :
1138 2412 : ier=0
1139 2412 : if(wff%iomode==IO_MODE_FORTRAN) then ! All processors see a local file
1140 0 : close(unit=wff%unwff)
1141 :
1142 2412 : else if(wff%iomode == IO_MODE_ETSF)then
1143 2248 : NCF_CHECK(nf90_close(wff%unwff))
1144 :
1145 164 : else if(wff%iomode==IO_MODE_FORTRAN_MASTER)then ! Only the master processor see a local file
1146 132 : if(wff%master==wff%me) close (unit=wff%unwff) ! VALGRIND complains buf points to uninitialized bytes
1147 :
1148 : #if defined HAVE_MPI_IO
1149 32 : else if(wff%iomode==IO_MODE_MPI)then
1150 32 : call MPI_FILE_CLOSE(wff%fhwff,ier)
1151 32 : if (wff%master==wff%me ) close(unit=wff%unwff)
1152 32 : wff%offwff=0;wff%off_recs=0;wff%lght_recs=0
1153 32 : wff%nbOct_recMarker=-1
1154 32 : wff%kgwff=-1
1155 : #endif
1156 :
1157 : end if
1158 :
1159 2412 : end subroutine WffClose
1160 : !!***
1161 :
1162 : !----------------------------------------------------------------------
1163 :
1164 : !!****f* m_wffile/WffDelete
1165 : !! NAME
1166 : !! WffDelete
1167 : !!
1168 : !! FUNCTION
1169 : !! This subroutine closes a Wf file, and delete it.
1170 : !!
1171 : !! INPUTS
1172 : !! wff= structured info about the wavefunction file
1173 : !!
1174 : !! OUTPUT
1175 : !! ierr=error code
1176 : !!
1177 : !! SOURCE
1178 :
1179 0 : subroutine WffDelete(wff,ier)
1180 :
1181 : !Arguments ------------------------------------
1182 : type(wffile_type),intent(inout) :: wff
1183 : integer, intent(out) :: ier
1184 :
1185 : ! *************************************************************************
1186 :
1187 0 : ier=0
1188 0 : if (wff%iomode==IO_MODE_FORTRAN) then ! All processors see a local file
1189 0 : close(unit=wff%unwff,status='delete')
1190 :
1191 0 : else if (wff%iomode==IO_MODE_FORTRAN_MASTER)then ! Only the master processor see a local file
1192 0 : if (wff%master==wff%me) close (unit=wff%unwff,status='delete')
1193 :
1194 :
1195 0 : else if (wff%iomode==IO_MODE_MPI)then
1196 : #if defined HAVE_MPI_IO
1197 0 : if ( wff%fhwff /= -1 )then
1198 0 : call MPI_FILE_CLOSE(wff%fhwff,ier)
1199 : end if
1200 0 : if (wff%master==wff%me ) then
1201 0 : close(unit=wff%unwff,status='delete')
1202 0 : wff%fhwff = -1
1203 : end if
1204 0 : wff%offwff=0;wff%off_recs=0;wff%lght_recs=0
1205 0 : wff%nbOct_recMarker=-1
1206 0 : wff%kgwff=-1
1207 : #endif
1208 : end if
1209 :
1210 0 : end subroutine WffDelete
1211 : !!***
1212 :
1213 : !----------------------------------------------------------------------
1214 :
1215 : !!****f* m_wffile/WffKg
1216 : !! NAME
1217 : !! WffKg
1218 : !!
1219 : !! FUNCTION
1220 : !! Check kgwff to manage WF file in the MPI/IO case
1221 : !!
1222 : !! INPUTS
1223 : !! wff <type(wffile_type)> = structured info about the wavefunction file
1224 : !! optkg= if 1 , read or write kg_k ; if 0,do not care about kg_k in rwwf
1225 : !!
1226 : !! OUTPUT
1227 : !!
1228 : !! SOURCE
1229 :
1230 160 : subroutine WffKg(wff,optkg)
1231 :
1232 : !Arguments ------------------------------------
1233 : type(wffile_type),intent(inout) :: wff
1234 : integer,intent(in) :: optkg
1235 :
1236 : ! *********************************************************************
1237 :
1238 : #if defined HAVE_MPI_IO
1239 160 : if (wff%iomode == IO_MODE_MPI) wff%kgwff=optkg
1240 : #else
1241 : ABI_UNUSED((/wff%iomode,optkg/))
1242 : #endif
1243 :
1244 160 : end subroutine WffKg
1245 : !!***
1246 :
1247 : !----------------------------------------------------------------------
1248 :
1249 : !!****f* ABINIT/WffOffset
1250 : !! NAME
1251 : !! WffOffset
1252 : !!
1253 : !! FUNCTION
1254 : !! Tool to manage WF file in the MPI/IO case : broadcast the offset of
1255 : !! the first k-point data block
1256 : !!
1257 : !! INPUTS
1258 : !! wff <type(wffile_type)> = structured info about the wavefunction file
1259 : !! sender = id of the sender
1260 : !! spaceComm = id of the space communicator handler
1261 : !!
1262 : !! OUTPUT
1263 : !! ier = error code returned by the MPI call
1264 : !!
1265 : !! SOURCE
1266 :
1267 592 : subroutine WffOffset(wff,sender,spaceComm,ier)
1268 :
1269 : !Arguments ------------------------------------
1270 : type(wffile_type),intent(inout) :: wff
1271 : integer ,intent(inout) :: sender
1272 : integer ,intent(in) :: spaceComm
1273 : integer ,intent(out) :: ier
1274 :
1275 : !Local variables ------------------------------
1276 : #if defined HAVE_MPI_IO
1277 : integer :: icom
1278 : integer(kind=MPI_OFFSET_KIND) :: off(1)
1279 : #endif
1280 :
1281 : ! *********************************************************************
1282 :
1283 : #if defined HAVE_MPI_IO
1284 592 : if (wff%iomode == IO_MODE_MPI) then
1285 60 : call xmpi_max(sender,icom,spaceComm,ier)
1286 60 : if (icom>=0)then
1287 60 : off(1)=wff%offwff
1288 60 : call MPI_BCAST(off,1,wff%offset_mpi_type,icom,spaceComm,ier)
1289 60 : wff%offwff=off(1)
1290 : end if
1291 : end if ! iomode
1292 : #else
1293 : ier = 0
1294 : ABI_UNUSED((/wff%iomode,sender,spaceComm/))
1295 : #endif
1296 :
1297 592 : end subroutine WffOffset
1298 : !!***
1299 :
1300 : !----------------------------------------------------------------------
1301 :
1302 : !!****f* m_wffile/WffReadDataRec_dp1d
1303 : !! NAME
1304 : !! WffReadDataRec_dp1d
1305 : !!
1306 : !! FUNCTION
1307 : !! Subroutine to read data in one record of a wavefunction file
1308 : !! Handles double precision 1D arrays
1309 : !!
1310 : !! INPUTS
1311 : !! ndp=size of the double precision array to be read
1312 : !! wff= structured info about the wavefunction file
1313 : !!
1314 : !! OUTPUT
1315 : !! dparray=array of double precision numbers
1316 : !! ierr=error code
1317 : !!
1318 : !! SIDE EFFECTS
1319 : !!
1320 : !! SOURCE
1321 :
1322 0 : subroutine WffReadDataRec_dp1d(dparray,ierr,ndp,wff)
1323 :
1324 : !Arguments ------------------------------------
1325 : type(wffile_type),intent(inout) :: wff
1326 : integer,intent(in) :: ndp
1327 : integer,intent(out) :: ierr
1328 : real(dp),intent(out) :: dparray(ndp)
1329 :
1330 : !Local variables-------------------------------
1331 : character(len=500) :: msg
1332 :
1333 : ! *************************************************************************
1334 :
1335 0 : ierr=0
1336 0 : if (wff%iomode==IO_MODE_FORTRAN.or.(wff%iomode==IO_MODE_FORTRAN_MASTER.and.wff%master==wff%me)) then
1337 0 : read (wff%unwff,iostat=ierr) dparray(1:ndp)
1338 :
1339 0 : else if(wff%iomode==IO_MODE_MPI)then
1340 : #if defined HAVE_MPI_IO
1341 0 : call xderiveRRecInit(wff,ierr)
1342 0 : call xderiveRead(wff,dparray,ndp,MPI_COMM_SELF,ierr)
1343 0 : call xderiveRRecEnd(wff,ierr)
1344 : #endif
1345 : else
1346 0 : write(msg,'(a,i0)')"Wrong iomode: ",wff%iomode
1347 0 : ABI_ERROR(msg)
1348 : end if
1349 :
1350 0 : end subroutine WffReadDataRec_dp1d
1351 : !!***
1352 :
1353 : !----------------------------------------------------------------------
1354 :
1355 :
1356 : !!****f* m_wffile/WffReadDataRec_dp2d
1357 : !! NAME
1358 : !! WffReadDataRec_dp2d
1359 : !!
1360 : !! FUNCTION
1361 : !! Subroutine to read data in one record of a wavefunction file
1362 : !! Handles double precision 2D arrays
1363 : !!
1364 : !! INPUTS
1365 : !! n1,n2=sizes of the double precision array to be read
1366 : !! wff= structured info about the wavefunction file
1367 : !!
1368 : !! OUTPUT
1369 : !! dparray=array of double precision numbers
1370 : !! ierr=error code
1371 : !!
1372 : !! SIDE EFFECTS
1373 : !!
1374 : !! SOURCE
1375 :
1376 0 : subroutine WffReadDataRec_dp2d(dparray,ierr,n1,n2,wff)
1377 :
1378 : !Arguments ------------------------------------
1379 : type(wffile_type),intent(inout) :: wff
1380 : integer,intent(in) :: n1,n2
1381 : integer,intent(out) :: ierr
1382 : real(dp),intent(out) :: dparray(n1,n2)
1383 :
1384 : !Local variables-------------------------------
1385 : character(len=500) :: msg
1386 :
1387 : ! *************************************************************************
1388 :
1389 0 : ierr=0
1390 0 : if (wff%iomode==IO_MODE_FORTRAN.or.(wff%iomode==IO_MODE_FORTRAN_MASTER.and.wff%master==wff%me)) then
1391 0 : read (wff%unwff,iostat=ierr) dparray(1:n1,1:n2)
1392 :
1393 0 : else if(wff%iomode==IO_MODE_MPI)then
1394 : #if defined HAVE_MPI_IO
1395 0 : call xderiveRRecInit(wff,ierr)
1396 0 : call xderiveRead(wff,dparray,n1,n2,MPI_COMM_SELF,ierr)
1397 0 : call xderiveRRecEnd(wff,ierr)
1398 : #endif
1399 : else
1400 0 : write(msg,'(a,i0)')"Wrong iomode: ",wff%iomode
1401 0 : ABI_ERROR(msg)
1402 : end if
1403 :
1404 0 : end subroutine WffReadDataRec_dp2d
1405 : !!***
1406 :
1407 : !----------------------------------------------------------------------
1408 :
1409 : !!****f* m_wffile/WffReadNpwRec
1410 : !! NAME
1411 : !! WffReadNpwRec
1412 : !!
1413 : !! FUNCTION
1414 : !! This subroutine read the npw record of a wavefunction file
1415 : !!
1416 : !! INPUTS
1417 : !! wff= structured info about the wavefunction file
1418 : !! wff%access == -1 and wf%master == Wff%me:
1419 : !! read binary data
1420 : !! wff%iomode == 0:
1421 : !! read binary data
1422 : !! wff%iomode == 1:
1423 : !! use MPI/IO routines (MPIO defined)
1424 : !! wff%iomode == 2:
1425 : !! read netcdf format (NETCDF defined)
1426 : !! ikpt= the i-th kpoint.
1427 : !! isppol= the given spin polarisation element.
1428 : !!
1429 : !! OUTPUT
1430 : !! ierr=error code (iostat integer from read statement)
1431 : !! nband_disk=number of bands
1432 : !! npw=number of plane waves
1433 : !! nspinor=number of spinorial components of the wavefunctions
1434 : !!
1435 : !! SIDE EFFECTS
1436 : !!
1437 : !! SOURCE
1438 :
1439 63806 : subroutine WffReadNpwRec(ierr,ikpt,isppol,nband_disk,npw,nspinor,wff)
1440 :
1441 : !Arguments ------------------------------------
1442 : type(wffile_type),intent(inout) :: wff
1443 : integer,intent(in) :: ikpt, isppol
1444 : integer,intent(out) :: ierr,nband_disk,npw,nspinor
1445 :
1446 : !Local variables-------------------------------
1447 : !character(len=500) :: msg
1448 : integer :: vid
1449 : ! *************************************************************************
1450 :
1451 63806 : ierr=0
1452 :
1453 63806 : if (wff%iomode == IO_MODE_FORTRAN.or.(wff%iomode==IO_MODE_FORTRAN_MASTER.and.wff%master==wff%me) ) then
1454 0 : read (wff%unwff,iostat=ierr) npw,nspinor,nband_disk
1455 :
1456 63806 : else if(wff%iomode==IO_MODE_MPI)then
1457 : #if defined HAVE_MPI_IO
1458 16 : call xderiveRRecInit(wff,ierr)
1459 16 : call xderiveRead(wff,npw,ierr)
1460 16 : call xderiveRead(wff,nspinor,ierr)
1461 16 : call xderiveRead(wff,nband_disk,ierr)
1462 16 : call xderiveRRecEnd(wff,ierr)
1463 : #endif
1464 :
1465 63790 : else if (wff%iomode == IO_MODE_ETSF) then
1466 :
1467 : !write(std_out,*)"readnpwrec: ikpt, spin", ikpt, spin
1468 63790 : NCF_CHECK(nctk_get_dim(wff%unwff, "number_of_spinor_components", nspinor))
1469 63790 : vid = nctk_idname(wff%unwff, "number_of_coefficients")
1470 127580 : NCF_CHECK(nf90_get_var(wff%unwff, vid, npw, start=[ikpt]))
1471 63790 : vid = nctk_idname(wff%unwff, "number_of_states")
1472 191370 : NCF_CHECK(nf90_get_var(wff%unwff, vid, nband_disk, start=[ikpt, isppol]))
1473 :
1474 : else
1475 : ! MG: I don't understand why we have to use this ugly code!!!!!!!!
1476 : ! Only master knows npw,nspinor,nband_disk in IO_MODE_FORTRAN_MASTE mode
1477 : ! To the person who wrote this stuff:
1478 : ! Have you ever heard about the "IF" statement of Fortran and the typical construct
1479 : !
1480 : ! if (rank==master) call mpifoo_seq()
1481 :
1482 0 : ABI_WARNING("Skipping read in WffReadNpwRec. Keep fingers crossed")
1483 : ! MG: Must initialze these values somehow to avoid overflows.
1484 0 : npw = 0; nspinor = 0; nband_disk = 0
1485 : end if
1486 :
1487 : !write(std_out,*)"nband_disk,npw,nspinor",nband_disk,npw,nspinor
1488 63806 : ABI_CHECK(ierr==0,"ierr!=0")
1489 :
1490 63806 : end subroutine WffReadNpwRec
1491 : !!***
1492 :
1493 : !----------------------------------------------------------------------
1494 :
1495 : !!****f* m_wffile/WffReadSkipRec
1496 : !! NAME
1497 : !! WffReadSkipRec
1498 : !!
1499 : !! FUNCTION
1500 : !! This subroutine move forward or backward in a Wf file by nrec records.
1501 : !!
1502 : !! INPUTS
1503 : !! nrec=number of records
1504 : !! wff= structured info about the wavefunction file
1505 : !!
1506 : !! OUTPUT
1507 : !! ierr=error code
1508 : !!
1509 : !! TODO
1510 : !! For the future : one should treat the possible errors of backspace
1511 : !!
1512 : !! SOURCE
1513 :
1514 :
1515 63878 : subroutine WffReadSkipRec(ierr,nrec,wff)
1516 :
1517 : !Arguments ------------------------------------
1518 : integer,intent(in) :: nrec
1519 : integer,intent(out) :: ierr
1520 : type(wffile_type),intent(inout) :: wff
1521 :
1522 : !Local variables-------------------------------
1523 : #if defined HAVE_MPI_IO
1524 : integer :: irec
1525 : integer(kind=MPI_OFFSET_KIND) :: delim_record,offset
1526 : #endif
1527 :
1528 : ! *************************************************************************
1529 :
1530 63878 : ierr=0
1531 63878 : if( wff%iomode==IO_MODE_FORTRAN.or.(wff%iomode==IO_MODE_FORTRAN_MASTER.and.wff%master==wff%me)) then
1532 :
1533 0 : call mvrecord(wff%unwff,nrec,ierr)
1534 0 : ABI_CHECK(ierr==0,"error in mvrecord")
1535 :
1536 :
1537 63878 : else if(wff%iomode==IO_MODE_MPI)then
1538 : #if defined HAVE_MPI_IO
1539 16 : if (nrec>0) then ! Move forward nrec records
1540 32 : do irec=1,nrec
1541 16 : wff%off_recs = wff%offwff
1542 16 : call rwRecordMarker(1,wff%offwff,delim_record,wff,ierr)
1543 32 : wff%lght_recs = delim_record
1544 : end do
1545 : else ! Move backward -nrec records
1546 0 : do irec=1,-nrec
1547 0 : offset = wff%offwff-wff%nbOct_recMarker
1548 0 : call rwRecordMarker(1,offset,delim_record,wff,ierr)
1549 0 : wff%lght_recs = delim_record
1550 0 : wff%offwff = wff%offwff - delim_record - 2*wff%nbOct_recMarker
1551 0 : wff%off_recs = wff%offwff
1552 : end do
1553 : end if
1554 : #endif
1555 : end if ! wff%iomode==0,1 or -1
1556 :
1557 63878 : end subroutine WffReadSkipRec
1558 : !!***
1559 :
1560 : !----------------------------------------------------------------------
1561 :
1562 : !!****f* m_wffile/WffReadWrite_mpio
1563 : !! NAME
1564 : !! WffReadWrite_mpio
1565 : !!
1566 : !! FUNCTION
1567 : !! This procedure read or write cg in the file _WFK using MPI_IO
1568 : !! when cg are dispatched amoung commcart communicator
1569 : !!
1570 : !! INPUTS
1571 : !! wff=struct info for wavefunction
1572 : !! nband_disk=number of bands on disk files to be write
1573 : !! icg=shift to be given to the location of the cg array
1574 : !! mcg=second dimention of cg
1575 : !! mpi_enreg=information about parallelisation
1576 : !! depl_mpi_to_seq=for each proc, index of cg in sequential mode
1577 : !! npwso=npw*nspinor number of plane waves treated by this node.
1578 : !! npwsotot=npwtot*nspinor Total number of planewaves Used to calculate the size of data to be written.
1579 : !! rdwr=1 if reading, 2 if writing
1580 : !!
1581 : !! OUTPUT
1582 : !! ierr=error status
1583 : !!
1584 : !! SIDE EFFECTS
1585 : !! cg(2,mcg)=planewave coefficients of wavefunctions,
1586 : !!
1587 : !! NOTES
1588 : !! cg is written like the following:
1589 : !! BeginMarker cg ( iband = 1 ) EndMarker
1590 : !! BeginMarker cg ( iband = 2 ) EndMarker
1591 : !! ...
1592 : !! BeginMarker cg( iband = nband_disk ) EndMarker
1593 : !!
1594 : !! BeginMarker and EndMarker give the value of the total length of cg for one band
1595 : !!
1596 : !! For MPI-IO library the performance is improved by the use a "view" of the file for each proc.
1597 :
1598 : !! SOURCE
1599 :
1600 68 : subroutine WffReadWrite_mpio(wff,rdwr,cg,mcg,icg,nband_disk,npwso,npwsotot,depl_mpi_to_seq,ierr)
1601 :
1602 : !Arguments ------------------------------------
1603 : !scalars
1604 : integer,intent(in) :: icg,mcg,nband_disk,npwso,npwsotot,rdwr
1605 : integer,intent(out) :: ierr
1606 : type(wffile_type),intent(inout) :: wff
1607 : !arrays
1608 : integer,intent(in) :: depl_mpi_to_seq(npwso)
1609 : real(dp),intent(inout) :: cg(2,mcg)
1610 :
1611 : !Local variables-------------------------------
1612 : !scalars
1613 : #if defined HAVE_MPI_IO
1614 : integer,parameter :: MAXBAND=500, check_markers=1
1615 : integer :: filetype,iband,ibandmax,ibandmin,iblock,ii,iloc,ipw,jerr,jj
1616 : integer :: nb,nband_block,step,totsize1bandcg,wfftempo
1617 : integer(kind=MPI_OFFSET_KIND) :: delim_record,loc_depl_band,offset,totsize1bandByte
1618 : character(len=500) :: msg
1619 : !arrays
1620 68 : integer,allocatable :: BlockLength(:),BlockType(:),map(:),tempo_map(:)
1621 68 : integer(kind=MPI_OFFSET_KIND),allocatable :: BlockDepl(:)
1622 68 : integer(kind=2),allocatable :: bufdelim2(:)
1623 68 : integer(kind=4),allocatable :: bufdelim4(:)
1624 68 : integer(kind=8),allocatable :: bufdelim8(:)
1625 68 : real(dp),allocatable :: buf(:),tempo_buf(:)
1626 : #if defined HAVE_FC_INT_QUAD
1627 68 : integer(kind=16),allocatable :: bufdelim16(:)
1628 : #endif
1629 : #endif
1630 :
1631 : ! *********************************************************************
1632 :
1633 68 : ierr=0
1634 :
1635 : #if defined HAVE_MPI_IO
1636 : !----------------------------------------------
1637 : !! Prepare WF data
1638 : !----------------------------------------------
1639 : !Init offset of record
1640 68 : wff%off_recs = wff%offwff
1641 :
1642 : !Total size to be written (in number of bands and in bytes)
1643 68 : totsize1bandcg=2*npwsotot
1644 : !call xmpi_sum(totsize1bandcg,wff%spaceComm_mpiio,ierr)
1645 :
1646 68 : totsize1bandByte=totsize1bandcg*wff%nbOct_dp+2*wff%nbOct_recMarker
1647 :
1648 : !Check file size
1649 68 : offset=wff%offwff+nband_disk*totsize1bandByte
1650 : if (offset>Huge(offset)) then
1651 : msg='File is too large for MPI-IO specifications !'
1652 : ABI_ERROR(msg)
1653 : end if
1654 :
1655 : !Open file
1656 68 : call MPI_FILE_OPEN(wff%spaceComm_mpiio,wff%fname,MPI_MODE_RDWR,MPI_INFO_NULL,wfftempo,ierr)
1657 68 : ABI_CHECK_MPI(ierr, sjoin("MPI_FILE_OPEN:", wff%fname))
1658 :
1659 : !----------------------------------------------------------
1660 : !Loop blocks of bands (to decrease offsets inside the file)
1661 : !----------------------------------------------------------
1662 68 : ibandmax=0;ibandmin=1
1663 68 : ii=huge(check_markers)/totsize1bandByte;step=min(ii,MAXBAND,nband_disk)
1664 68 : do iblock=1,nband_disk/step+1
1665 68 : ibandmax=min(ibandmin+step-1,nband_disk)
1666 68 : nband_block=ibandmax-ibandmin+1
1667 68 : offset=wff%offwff+(ibandmin-1)*totsize1bandByte
1668 :
1669 : ! ----------------------------------------------
1670 : ! Read/Write bands
1671 : ! ----------------------------------------------
1672 :
1673 : ! Build map; for better performance, map must be in increasing order
1674 204 : ABI_MALLOC_OR_DIE(map,(2*npwso*nband_block), ierr)
1675 :
1676 204 : ABI_STAT_MALLOC(buf,(2*npwso*nband_block), ierr)
1677 68 : ABI_CHECK(ierr==0, "out of memory in wavefunction buffer. Try to decrease MAXBAND in WffReadWrite_mpio")
1678 :
1679 68 : if (rdwr==1) then
1680 : ! If reading, only build map
1681 16 : nb=0;loc_depl_band=0
1682 48 : ABI_MALLOC(tempo_map,(2*npwso))
1683 816 : do iband=ibandmin,ibandmax
1684 131200 : tempo_map(1:2*npwso)=-1
1685 66000 : jj=1;ipw=(iband-1)*npwso+icg
1686 66000 : do ii=1,npwso
1687 65200 : iloc=loc_depl_band+wff%nbOct_recMarker+2*(depl_mpi_to_seq(ii)-1)*wff%nbOct_dp
1688 65200 : tempo_map(jj )=iloc ! Real part
1689 65200 : tempo_map(jj+1)=iloc+wff%nbOct_dp ! Imag part
1690 66000 : jj=jj+2
1691 : end do
1692 131200 : do ii=1,2*npwso ! Now, elimate holes
1693 131200 : if (tempo_map(ii)/=-1) then
1694 130400 : nb=nb+1
1695 130400 : map(nb)=tempo_map(ii)
1696 : end if
1697 : end do
1698 816 : loc_depl_band=loc_depl_band+totsize1bandByte ! Location in bytes
1699 : end do
1700 52 : else if (rdwr==2) then
1701 : ! If writing, build map and store cg in a buffer
1702 52 : nb=0;loc_depl_band=0
1703 156 : ABI_MALLOC(tempo_map,(2*npwso))
1704 156 : ABI_MALLOC(tempo_buf,(2*npwso))
1705 1572 : do iband=ibandmin,ibandmax
1706 622384 : tempo_map(1:2*npwso)=-1
1707 1520 : jj=1;ipw=(iband-1)*npwso+icg
1708 311952 : do ii=1,npwso
1709 310432 : iloc=loc_depl_band+wff%nbOct_recMarker+2*(depl_mpi_to_seq(ii)-1)*wff%nbOct_dp
1710 310432 : tempo_map(jj )=iloc ! Real part
1711 310432 : tempo_map(jj+1)=iloc+wff%nbOct_dp ! Imag part
1712 931296 : tempo_buf(jj:jj+1)=cg(1:2,ipw+ii)
1713 311952 : jj=jj+2
1714 : end do
1715 622384 : do ii=1,2*npwso ! Now, elimate holes
1716 622384 : if (tempo_map(ii)/=-1) then
1717 620864 : nb=nb+1
1718 620864 : map(nb)=tempo_map(ii)
1719 620864 : buf(nb)=tempo_buf(ii)
1720 : end if
1721 : end do
1722 1572 : loc_depl_band=loc_depl_band+totsize1bandByte ! Location in bytes
1723 : end do
1724 52 : ABI_FREE(tempo_map)
1725 52 : ABI_FREE(tempo_buf)
1726 : end if ! rdwr
1727 :
1728 : ! Build and commit MPI datatype
1729 204 : ABI_MALLOC(BlockLength,(nb+2))
1730 204 : ABI_MALLOC(BlockDepl,(nb+2))
1731 136 : ABI_MALLOC(BlockType,(nb+2))
1732 68 : BlockLength(1)=1;BlockDepl(1)=0;BlockType(1)=MPI_LB
1733 751332 : do ii=2,nb+1
1734 751264 : BlockLength(ii)=1
1735 751264 : BlockDepl(ii)=map(ii-1)
1736 751332 : BlockType(ii)=MPI_DOUBLE_PRECISION
1737 : end do
1738 68 : BlockLength(nb+2)=1;BlockDepl(nb+2)=totsize1bandByte*nband_block;BlockType(nb+2)=MPI_UB
1739 68 : call xmpio_type_struct(nb+2,BlockLength,BlockDepl,BlockType,filetype,ierr)
1740 68 : call MPI_TYPE_COMMIT(filetype,ierr)
1741 68 : ABI_FREE(BlockLength)
1742 68 : ABI_FREE(BlockDepl)
1743 68 : ABI_FREE(BlockType)
1744 :
1745 : ! Read/Write data on disk
1746 68 : call MPI_FILE_SET_VIEW(wfftempo,offset,MPI_BYTE,filetype,"native",MPI_INFO_NULL,ierr)
1747 68 : if (rdwr==1) then
1748 16 : call MPI_FILE_READ_ALL (wfftempo,buf,nb,MPI_DOUBLE_PRECISION,MPI_STATUS_IGNORE,ierr)
1749 : else
1750 52 : call MPI_FILE_WRITE_ALL(wfftempo,buf,nb,MPI_DOUBLE_PRECISION,MPI_STATUS_IGNORE,ierr)
1751 : end if
1752 :
1753 : ! In case of reading, retrieve cg
1754 68 : if (rdwr==1) then
1755 16 : nb=0;loc_depl_band=0
1756 48 : ABI_MALLOC(tempo_buf,(2*npwso))
1757 816 : do iband=ibandmin,ibandmax
1758 131200 : do ii=1,2*npwso ! Now, elimate holes
1759 131200 : if (tempo_map(ii)/=-1) then
1760 130400 : nb=nb+1;tempo_buf(ii)=buf(nb)
1761 : end if
1762 : end do
1763 800 : jj=1;ipw=(iband-1)*npwso+icg
1764 66000 : do ii=1,npwso
1765 65200 : iloc=loc_depl_band+wff%nbOct_recMarker+2*(depl_mpi_to_seq(ii)-1)*wff%nbOct_dp
1766 195600 : cg(1:2,ipw+ii)=tempo_buf(jj:jj+1)
1767 66000 : jj=jj+2
1768 : end do
1769 816 : loc_depl_band=loc_depl_band+totsize1bandByte ! Location in bytes
1770 : end do
1771 16 : ABI_FREE(tempo_map)
1772 16 : ABI_FREE(tempo_buf)
1773 : end if ! rdwr
1774 :
1775 : ! Free memory
1776 68 : ABI_FREE(map)
1777 68 : ABI_FREE(buf)
1778 68 : call MPI_TYPE_FREE(filetype,ierr)
1779 :
1780 : ! ----------------------------------------------
1781 : ! Check/Write record markers (only master proc)
1782 : ! ----------------------------------------------
1783 68 : if ((rdwr==1.and.check_markers==1).or.(rdwr==2)) then
1784 :
1785 : ! Define view for the file
1786 68 : nb=2*nband_block
1787 204 : ABI_MALLOC(BlockLength,(nb+2))
1788 204 : ABI_MALLOC(BlockDepl,(nb+2))
1789 136 : ABI_MALLOC(BlockType,(nb+2))
1790 68 : BlockLength(1)=1;BlockDepl(1)=0;BlockType(1)=MPI_LB
1791 68 : jj=2
1792 2388 : do ii=1,nband_block
1793 6960 : BlockType(jj:jj+1) =wff%marker_mpi_type
1794 6960 : BlockLength(jj:jj+1)=1
1795 2320 : BlockDepl(jj )=(ii-1)*totsize1bandByte
1796 2320 : BlockDepl(jj+1)= ii *totsize1bandByte-wff%nbOct_recMarker
1797 2388 : jj=jj+2
1798 : end do
1799 68 : BlockLength(nb+2)=1;BlockDepl(nb+2)=nband_block*totsize1bandByte;BlockType(nb+2)=MPI_UB
1800 68 : call xmpio_type_struct(nb+2,BlockLength,BlockDepl,BlockType,filetype,ierr)
1801 68 : call MPI_TYPE_COMMIT(filetype,ierr)
1802 68 : call MPI_FILE_SET_VIEW(wfftempo,offset,MPI_BYTE,filetype,"native",MPI_INFO_NULL,ierr)
1803 68 : ABI_FREE(BlockLength)
1804 68 : ABI_FREE(BlockDepl)
1805 68 : ABI_FREE(BlockType)
1806 :
1807 : ! Read/Write all markers (depend on Fortran marker MPI type)
1808 68 : if (wff%me_mpiio==0) then
1809 19 : jerr=0;delim_record=totsize1bandByte-2*wff%nbOct_recMarker
1810 19 : if (wff%nbOct_recMarker==4) then
1811 57 : ABI_MALLOC(bufdelim4,(nb))
1812 979 : if (rdwr==2) bufdelim4(:)=delim_record
1813 19 : if (rdwr==1) then
1814 4 : call MPI_FILE_READ (wfftempo,bufdelim4,2*nband_block,wff%marker_mpi_type,MPI_STATUS_IGNORE,ierr)
1815 404 : if (any(bufdelim4(:)/=delim_record)) jerr=1
1816 : else
1817 15 : call MPI_FILE_WRITE(wfftempo,bufdelim4,2*nband_block,wff%marker_mpi_type,MPI_STATUS_IGNORE,ierr)
1818 : end if
1819 19 : ABI_FREE(bufdelim4)
1820 0 : else if (wff%nbOct_recMarker==8) then
1821 0 : ABI_MALLOC(bufdelim8,(nb))
1822 0 : if (rdwr==2) bufdelim8(:)=delim_record
1823 0 : if (rdwr==1) then
1824 0 : call MPI_FILE_READ (wfftempo,bufdelim8,2*nband_block,wff%marker_mpi_type,MPI_STATUS_IGNORE,ierr)
1825 0 : if (any(bufdelim8(:)/=delim_record)) jerr=1
1826 : else
1827 0 : call MPI_FILE_WRITE(wfftempo,bufdelim8,2*nband_block,wff%marker_mpi_type,MPI_STATUS_IGNORE,ierr)
1828 : end if
1829 0 : ABI_FREE(bufdelim8)
1830 : #if defined HAVE_FC_INT_QUAD
1831 0 : else if (wff%nbOct_recMarker==16) then
1832 0 : ABI_MALLOC(bufdelim16,(nb))
1833 0 : if (rdwr==2) bufdelim16(:)=delim_record
1834 0 : if (rdwr==1) then
1835 0 : call MPI_FILE_READ (wfftempo,bufdelim16,2*nband_block,wff%marker_mpi_type,MPI_STATUS_IGNORE,ierr)
1836 0 : if (any(bufdelim16(:)/=delim_record)) jerr=1
1837 : else
1838 0 : call MPI_FILE_WRITE(wfftempo,bufdelim16,2*nband_block,wff%marker_mpi_type,MPI_STATUS_IGNORE,ierr)
1839 : end if
1840 0 : ABI_FREE(bufdelim16)
1841 : #endif
1842 0 : else if (wff%nbOct_recMarker==2) then
1843 0 : ABI_MALLOC(bufdelim2,(nb))
1844 0 : if (rdwr==2) bufdelim2(:)=delim_record
1845 0 : if (rdwr==1) then
1846 0 : call MPI_FILE_READ (wfftempo,bufdelim2,2*nband_block,wff%marker_mpi_type,MPI_STATUS_IGNORE,ierr)
1847 0 : if (any(bufdelim2(:)/=delim_record)) jerr=1
1848 : else
1849 0 : call MPI_FILE_WRITE(wfftempo,bufdelim2,2*nband_block,wff%marker_mpi_type,MPI_STATUS_IGNORE,ierr)
1850 : end if
1851 0 : ABI_FREE(bufdelim2)
1852 : end if
1853 19 : if (rdwr==1.and.jerr==1) then
1854 0 : write(unit=msg,fmt='(2a)') 'Error when reading record markers of file ',trim(wff%fname)
1855 0 : ABI_ERROR(msg)
1856 : end if
1857 : end if ! me_mpiio=0
1858 :
1859 : ! Free memory
1860 68 : call MPI_TYPE_FREE(filetype,ierr)
1861 :
1862 : end if ! rdwr
1863 :
1864 : ! -----------------------------------------
1865 : ! End loop on blocks of bands
1866 : ! -----------------------------------------
1867 68 : if (ibandmax>=nband_disk) exit
1868 68 : ibandmin=ibandmax+1
1869 : end do
1870 :
1871 : !-----------------------------------------
1872 : !End statements
1873 : !-----------------------------------------
1874 : !Close file
1875 68 : call MPI_FILE_CLOSE(wfftempo,ierr)
1876 :
1877 : !Update offset
1878 68 : wff%offwff=wff%offwff+totsize1bandByte*nband_disk
1879 : #endif
1880 :
1881 : #if !defined HAVE_MPI_IO
1882 : !Dummy check to avoid warning from compilers.
1883 : ABI_UNUSED((/wff%iomode,rdwr,size(cg),mcg,icg,nband_disk,npwso,depl_mpi_to_seq(1),npwsotot/))
1884 : #endif
1885 :
1886 68 : end subroutine WffReadWrite_mpio
1887 : !!***
1888 :
1889 : !----------------------------------------------------------------------
1890 :
1891 : !!****f* m_wffile/WffWriteDataRec_int2d
1892 : !! NAME
1893 : !! WffWriteDataRec_int2d
1894 : !!
1895 : !! FUNCTION
1896 : !! Subroutine to write data in one record of a wavefunction file
1897 : !! Handles integer 2D arrays
1898 : !!
1899 : !! INPUTS
1900 : !! intarray=array of integer numbers
1901 : !! n1,n2=sizes of the integer array to be written
1902 : !! wff= structured info about the wavefunction file
1903 : !!
1904 : !! OUTPUT
1905 : !! ierr=error code
1906 : !!
1907 : !! SIDE EFFECTS
1908 : !!
1909 : !! SOURCE
1910 :
1911 0 : subroutine WffWriteDataRec_int2d(intarray,ierr,n1,n2,wff)
1912 :
1913 : !Arguments ------------------------------------
1914 : type(wffile_type),intent(inout) :: wff
1915 : integer,intent(in) :: n1,n2
1916 : integer,intent(out) :: ierr
1917 : integer,intent(in) :: intarray(n1,n2)
1918 :
1919 : !Local variables-------------------------------
1920 : character(len=500) :: msg
1921 :
1922 : ! *************************************************************************
1923 :
1924 0 : ierr=0
1925 0 : if (wff%iomode==IO_MODE_FORTRAN.or.(wff%iomode==IO_MODE_FORTRAN_MASTER.and.wff%master==wff%me)) then
1926 0 : write(wff%unwff,iostat=ierr) intarray(1:n1,1:n2)
1927 :
1928 0 : else if(wff%iomode==IO_MODE_MPI)then
1929 : #if defined HAVE_MPI_IO
1930 0 : call xderiveWRecInit(wff,ierr)
1931 0 : call xderiveWrite(wff,intarray,n1,n2,MPI_COMM_SELF,ierr)
1932 0 : call xderiveWRecEnd(wff,ierr)
1933 : #endif
1934 : else
1935 0 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
1936 0 : ABI_WARNING(msg)
1937 : end if
1938 :
1939 0 : end subroutine WffWriteDataRec_int2d
1940 : !!***
1941 :
1942 : !----------------------------------------------------------------------
1943 :
1944 :
1945 : !!****f* m_wffile/WffWriteDataRec_dp1d
1946 : !! NAME
1947 : !! WffWriteDataRec_dp1d
1948 : !!
1949 : !! FUNCTION
1950 : !! Subroutine to write data in one record of a wavefunction file
1951 : !! Handles double precision 1D arrays
1952 : !!
1953 : !! INPUTS
1954 : !! dparray=array of double precision numbers
1955 : !! ndp=size of the double precision array to be written
1956 : !! wff= structured info about the wavefunction file
1957 : !!
1958 : !! OUTPUT
1959 : !! ierr=error code
1960 : !!
1961 : !! SIDE EFFECTS
1962 : !!
1963 : !! SOURCE
1964 :
1965 0 : subroutine WffWriteDataRec_dp1d(dparray,ierr,ndp,wff)
1966 :
1967 : !Arguments ------------------------------------
1968 : type(wffile_type),intent(inout) :: wff
1969 : integer,intent(in) :: ndp
1970 : integer,intent(out) :: ierr
1971 : real(dp),intent(in) :: dparray(ndp)
1972 :
1973 : !Local variables-------------------------------
1974 : character(len=500) :: msg
1975 :
1976 : ! *************************************************************************
1977 :
1978 0 : ierr=0
1979 0 : if (wff%iomode==IO_MODE_FORTRAN.or.(wff%iomode==IO_MODE_FORTRAN_MASTER.and.wff%master==wff%me)) then
1980 0 : write(wff%unwff,iostat=ierr) dparray(1:ndp)
1981 :
1982 0 : else if(wff%iomode==IO_MODE_MPI)then
1983 : #if defined HAVE_MPI_IO
1984 0 : call xderiveWRecInit(wff,ierr)
1985 0 : call xderiveWrite(wff,dparray,ndp,MPI_COMM_SELF,ierr)
1986 0 : call xderiveWRecEnd(wff,ierr)
1987 : #endif
1988 : else
1989 0 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
1990 0 : ABI_WARNING(msg)
1991 : end if
1992 :
1993 0 : end subroutine WffWriteDataRec_dp1d
1994 : !!***
1995 :
1996 : !----------------------------------------------------------------------
1997 :
1998 :
1999 : !!****f* m_wffile/WffWriteDataRec_dp2d
2000 : !! NAME
2001 : !! WffWriteDataRec_dp2d
2002 : !!
2003 : !! FUNCTION
2004 : !! Subroutine to write data in one record of a wavefunction file
2005 : !! Handles double precision 2D arrays
2006 : !!
2007 : !! INPUTS
2008 : !! dparray=array of double precision numbers
2009 : !! n1,n2=sizes of the double precision array to be written
2010 : !! wff= structured info about the wavefunction file
2011 : !!
2012 : !! OUTPUT
2013 : !! ierr=error code
2014 : !!
2015 : !! SIDE EFFECTS
2016 : !!
2017 : !! SOURCE
2018 :
2019 :
2020 0 : subroutine WffWriteDataRec_dp2d(dparray,ierr,n1,n2,wff)
2021 :
2022 : !Arguments ------------------------------------
2023 : type(wffile_type),intent(inout) :: wff
2024 : integer,intent(in) :: n1,n2
2025 : integer,intent(out) :: ierr
2026 : real(dp),intent(in) :: dparray(n1,n2)
2027 :
2028 : !Local variables-------------------------------
2029 : character(len=500) :: msg
2030 :
2031 : ! *************************************************************************
2032 :
2033 0 : ierr=0
2034 0 : if (wff%iomode==IO_MODE_FORTRAN.or.(wff%iomode==IO_MODE_FORTRAN_MASTER.and.wff%master==wff%me)) then
2035 0 : write(wff%unwff,iostat=ierr) dparray(1:n1,1:n2)
2036 :
2037 0 : else if(wff%iomode==IO_MODE_MPI)then
2038 : #if defined HAVE_MPI_IO
2039 0 : call xderiveWRecInit(wff,ierr)
2040 0 : call xderiveWrite(wff,dparray,n1,n2,MPI_COMM_SELF,ierr)
2041 0 : call xderiveWRecEnd(wff,ierr)
2042 : #endif
2043 : else
2044 0 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
2045 0 : ABI_WARNING(msg)
2046 : end if
2047 :
2048 0 : end subroutine WffWriteDataRec_dp2d
2049 : !!***
2050 :
2051 : !----------------------------------------------------------------------
2052 :
2053 :
2054 : !!****f* m_wffile/WffWriteNpwRec
2055 : !! NAME
2056 : !! WffWriteNpwRec
2057 : !!
2058 : !! FUNCTION
2059 : !! This subroutine writes the npw record of a wavefunction file
2060 : !!
2061 : !! INPUTS
2062 : !! wff= structured info about the wavefunction file
2063 : !! nband_disk=number of bands
2064 : !! npw=number of plane waves
2065 : !! nspinor=number of spinorial components of the wavefunctions
2066 : !! opt_paral=(optional argument, default=1, only used for MPI-IO)
2067 : !! 1: all procs in the communicator write the data
2068 : !! 2: only master in the communicator writes the data
2069 : !!
2070 : !! OUTPUT
2071 : !! ierr=error code
2072 : !!
2073 : !! SIDE EFFECTS
2074 : !!
2075 : !! SOURCE
2076 :
2077 :
2078 416 : subroutine WffWriteNpwRec(ierr,nband_disk,npw,nspinor,wff,&
2079 : & opt_paral) ! optional argument
2080 :
2081 : !Arguments ------------------------------------
2082 : type(wffile_type),intent(inout) :: wff
2083 : integer,intent(in) :: nband_disk,npw,nspinor
2084 : integer,intent(in),optional :: opt_paral
2085 : integer,intent(out) :: ierr
2086 :
2087 : !Local variables-------------------------------
2088 : integer :: opt_paral_
2089 : character(len=500) :: msg
2090 : #if defined HAVE_MPI_IO
2091 : integer :: me
2092 : integer(kind=MPI_OFFSET_KIND) :: off(1)
2093 : #endif
2094 :
2095 : ! *************************************************************************
2096 :
2097 416 : ierr=0
2098 416 : opt_paral_=1;if (present(opt_paral)) opt_paral_=opt_paral
2099 :
2100 416 : if (wff%iomode==IO_MODE_FORTRAN.or.(wff%iomode ==IO_MODE_FORTRAN_MASTER.and.wff%master==wff%me)) then
2101 364 : write(wff%unwff,iostat=ierr) npw,nspinor,nband_disk
2102 :
2103 52 : else if(wff%iomode==IO_MODE_MPI)then
2104 : #if defined HAVE_MPI_IO
2105 52 : me=-1;if (opt_paral_==2) me=wff%me_mpiio
2106 52 : if ((me==-1.and.opt_paral_==1).or.(me==0.and.opt_paral_==2)) then
2107 15 : call xderiveWRecInit(wff,ierr)
2108 15 : call xderiveWrite(wff,npw,ierr)
2109 15 : call xderiveWrite(wff,nspinor,ierr)
2110 15 : call xderiveWrite(wff,nband_disk,ierr)
2111 15 : call xderiveWRecEnd(wff,ierr)
2112 : end if
2113 52 : if (opt_paral_==2.and.wff%spaceComm_mpiio/=MPI_COMM_SELF) then
2114 52 : call xmpi_barrier(wff%spaceComm_mpiio)
2115 52 : off(1)=wff%offwff
2116 52 : call MPI_BCAST(off,1,wff%offset_mpi_type,0,wff%spaceComm_mpiio,ierr)
2117 52 : wff%offwff=off(1)
2118 : end if
2119 : #endif
2120 : else
2121 0 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
2122 0 : ABI_WARNING(msg)
2123 : end if
2124 :
2125 416 : end subroutine WffWriteNpwRec
2126 : !!***
2127 :
2128 : !!****f* m_wffile/xderiveRead_int
2129 : !! NAME
2130 : !! xderiveRead_int
2131 : !!
2132 : !! FUNCTION
2133 : !! Generic routine to read/write wf files with MPI I/O.
2134 : !! Target: integer scalar.
2135 : !!
2136 : !! INPUTS
2137 : !! (none)
2138 : !!
2139 : !! OUTPUT
2140 : !! xval= data buffer
2141 : !! ierr= exit status, a non-zero value meaning there is an error
2142 : !!
2143 : !! SIDE EFFECTS
2144 : !! wff= structured info for reading/writing the wavefunctions
2145 : !!
2146 : !! SOURCE
2147 :
2148 48 : subroutine xderiveRead_int(wff,xval,ierr)
2149 :
2150 : !Arguments ------------------------------------
2151 : type(wffile_type),intent(inout) :: wff
2152 : integer,intent(out) :: xval
2153 : integer,intent(out) :: ierr
2154 :
2155 : !Local variables-------------------------------
2156 : #if defined HAVE_MPI_IO
2157 : integer :: arr_xval(1),statux(MPI_STATUS_SIZE)
2158 : #endif
2159 : character(len=500) :: msg
2160 :
2161 : ! *********************************************************************
2162 :
2163 48 : xval=0; ierr=0
2164 :
2165 : #if defined HAVE_MPI_IO
2166 48 : call MPI_FILE_READ_AT(wff%fhwff,wff%offwff,arr_xval,1,MPI_INTEGER,statux,ierr)
2167 48 : xval=arr_xval(1)
2168 48 : wff%offwff = wff%offwff + wff%nbOct_int
2169 48 : RETURN
2170 : #endif
2171 :
2172 : ABI_UNUSED(wff%me)
2173 :
2174 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
2175 : ABI_WARNING(msg)
2176 :
2177 : end subroutine xderiveRead_int
2178 : !!***
2179 :
2180 : !----------------------------------------------------------------------
2181 :
2182 :
2183 : !!****f* m_wffile/xderiveRead_int1d
2184 : !! NAME
2185 : !! xderiveRead_int1d
2186 : !!
2187 : !! FUNCTION
2188 : !! Generic routine to read/write wf files with MPI I/O.
2189 : !! Target: one-dimensional integer arrays.
2190 : !!
2191 : !! INPUTS
2192 : !! n1= first dimension of the array
2193 : !! spaceComm= MPI communicator
2194 : !!
2195 : !! OUTPUT
2196 : !! xval= data buffer array
2197 : !! ierr= exit status, a non-zero value meaning there is an error
2198 : !!
2199 : !! SIDE EFFECTS
2200 : !! wff= structured info for reading/writing the wavefunctions
2201 : !!
2202 : !! SOURCE
2203 :
2204 0 : subroutine xderiveRead_int1d(wff,xval,n1,spaceComm,ierr)
2205 :
2206 : !Arguments ------------------------------------
2207 : type(wffile_type),intent(inout) :: wff
2208 : integer,intent(out) :: xval(:)
2209 : integer,intent(in) :: n1,spaceComm
2210 : integer,intent(out) :: ierr
2211 :
2212 : !Local variables-------------------------------
2213 : #if defined HAVE_MPI_IO
2214 : integer(kind=MPI_OFFSET_KIND) :: delim_record,nboct,dispoct(1),posit,totoct
2215 : integer :: statux(MPI_STATUS_SIZE)
2216 : #endif
2217 : character(len=500) :: msg
2218 :
2219 : ! *********************************************************************
2220 :
2221 0 : xval(:)=0 ; ierr=0 ! Initialization, for the compiler
2222 : if(.false.)write(std_out,*)wff%me,n1,spaceComm
2223 :
2224 : #if defined HAVE_MPI_IO
2225 0 : nboct = wff%nbOct_int * n1
2226 0 : posit = wff%offwff
2227 0 : delim_record = posit - wff%off_recs + wff%lght_recs - wff%nbOct_recMarker
2228 :
2229 0 : if (delim_record >= nboct) then
2230 : ! Compute offset for local part
2231 : ! dispoct = sum (nboct, rank=0..me)
2232 0 : if (spaceComm/=MPI_COMM_SELF) then
2233 0 : call MPI_SCAN([nboct],dispoct,1,wff%offset_mpi_type,MPI_SUM,spaceComm,ierr)
2234 0 : posit = posit + dispoct(1) - nboct
2235 : end if
2236 0 : call MPI_FILE_READ_AT(wff%fhwff,posit,xval,n1,MPI_INTEGER,statux,ierr)
2237 :
2238 : ! get the total number of bits wrote by processors
2239 0 : if (spaceComm/=MPI_COMM_SELF) then
2240 0 : call xmpi_max(dispoct(1),totoct,spaceComm,ierr)
2241 : !call MPI_ALLREDUCE(dispoct,totoct,1,wff%offset_mpi_type,MPI_MAX,spaceComm,ierr)
2242 : else
2243 0 : totoct=nboct
2244 : end if
2245 : else
2246 0 : ierr = 1
2247 0 : nboct = 0
2248 0 : totoct = 0
2249 : end if
2250 :
2251 : !new offset
2252 0 : wff%offwff = wff%offwff + totoct
2253 0 : return
2254 : #endif
2255 :
2256 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
2257 : ABI_WARNING(msg)
2258 :
2259 : end subroutine xderiveRead_int1d
2260 : !!***
2261 :
2262 : !----------------------------------------------------------------------
2263 :
2264 :
2265 : !!****f* m_wffile/xderiveRead_int2d
2266 : !! NAME
2267 : !! xderiveRead_int2d
2268 : !!
2269 : !! FUNCTION
2270 : !! Generic routine to read/write wf files with MPI I/O.
2271 : !! Target: two-dimensional integer arrays.
2272 : !!
2273 : !! INPUTS
2274 : !! n1= first dimension of the array
2275 : !! n2= second dimension of the array
2276 : !! spaceComm= MPI communicator
2277 : !!
2278 : !! OUTPUT
2279 : !! xval= data buffer array
2280 : !! ierr= exit status, a non-zero value meaning there is an error
2281 : !!
2282 : !! SIDE EFFECTS
2283 : !! wff= structured info for reading/writing the wavefunctions
2284 : !!
2285 : !! SOURCE
2286 :
2287 0 : subroutine xderiveRead_int2d(wff,xval,n1,n2,spaceComm,ierr)
2288 :
2289 : !Arguments ------------------------------------
2290 : type(wffile_type),intent(inout) :: wff
2291 : integer,intent(out) :: xval(:,:)
2292 : integer,intent(in) :: n1,n2,spaceComm
2293 : integer,intent(out) :: ierr
2294 :
2295 : !Local variables-------------------------------
2296 : #if defined HAVE_MPI_IO
2297 : integer(kind=MPI_OFFSET_KIND) :: delim_record,nboct,dispoct(1),posit,totoct
2298 : integer :: statux(MPI_STATUS_SIZE)
2299 : #endif
2300 : character(len=500) :: msg
2301 :
2302 : ! *********************************************************************
2303 :
2304 0 : xval(:,:)=0 ; ierr=0 ! Initialization, for the compiler
2305 : if(.false.)write(std_out,*)wff%me,n1,n2,spaceComm
2306 :
2307 : #if defined HAVE_MPI_IO
2308 0 : nboct = wff%nbOct_int * n1 * n2
2309 0 : posit = wff%offwff
2310 0 : delim_record = posit - wff%off_recs + wff%lght_recs - wff%nbOct_recMarker
2311 :
2312 0 : if (delim_record >= nboct) then
2313 : ! Compute offset for local part
2314 : ! dispoct = sum (nboct, rank=0..me)
2315 0 : if (spaceComm/=MPI_COMM_SELF) then
2316 0 : call MPI_SCAN([nboct],dispoct,1,wff%offset_mpi_type,MPI_SUM,spaceComm,ierr)
2317 0 : posit = posit + dispoct(1) - nboct
2318 : end if
2319 0 : call MPI_FILE_READ_AT(wff%fhwff,posit,xval,n1*n2,MPI_INTEGER,statux,ierr)
2320 :
2321 : ! get the total number of bits wrote by processors
2322 0 : if (spaceComm/=MPI_COMM_SELF) then
2323 0 : call xmpi_max(dispoct(1),totoct,spaceComm,ierr)
2324 : !call MPI_ALLREDUCE(dispoct,totoct,1,wff%offset_mpi_type,MPI_MAX,spaceComm,ierr)
2325 : else
2326 0 : totoct=nboct
2327 : end if
2328 : else
2329 0 : ierr = 1
2330 0 : nboct = 0
2331 0 : totoct = 0
2332 : end if
2333 :
2334 : !new offset
2335 0 : wff%offwff=wff%offwff + totoct
2336 0 : return
2337 : #endif
2338 :
2339 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
2340 : ABI_WARNING(msg)
2341 :
2342 : end subroutine xderiveRead_int2d
2343 : !!***
2344 :
2345 : !----------------------------------------------------------------------
2346 :
2347 :
2348 : !!****f* m_wffile/xderiveRead_dp
2349 : !! NAME
2350 : !! xderiveRead_dp
2351 : !!
2352 : !! FUNCTION
2353 : !! Generic routine to read/write wf files with MPI I/O.
2354 : !! Target: double precision scalar.
2355 : !!
2356 : !! INPUTS
2357 : !! (none)
2358 : !!
2359 : !! OUTPUT
2360 : !! xval= data buffer
2361 : !! ierr= exit status, a non-zero value meaning there is an error
2362 : !!
2363 : !! SIDE EFFECTS
2364 : !! wff= structured info for reading/writing the wavefunctions
2365 : !!
2366 : !! SOURCE
2367 :
2368 0 : subroutine xderiveRead_dp(wff,xval,ierr)
2369 :
2370 : !Arguments ------------------------------------
2371 : type(wffile_type),intent(inout) :: wff
2372 : integer,intent(out) :: ierr
2373 : real(dp),intent(out) :: xval
2374 :
2375 : !Local variables-------------------------------
2376 : #if defined HAVE_MPI_IO
2377 : integer :: statux(MPI_STATUS_SIZE)
2378 : real(dp) :: arr_xval(1)
2379 : #endif
2380 : character(len=500) :: msg
2381 :
2382 : ! *********************************************************************
2383 :
2384 0 : xval=zero ; ierr=0
2385 : if(.false.)write(std_out,*)wff%me
2386 : #if defined HAVE_MPI_IO
2387 0 : call MPI_FILE_READ_AT(wff%fhwff,wff%offwff,arr_xval,1,MPI_DOUBLE_PRECISION,statux,ierr)
2388 0 : xval=arr_xval(1)
2389 0 : wff%offwff = wff%offwff + wff%nbOct_dp
2390 0 : return
2391 : #endif
2392 :
2393 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
2394 : ABI_WARNING(msg)
2395 :
2396 : end subroutine xderiveRead_dp
2397 : !!***
2398 :
2399 : !----------------------------------------------------------------------
2400 :
2401 :
2402 : !!****f* ABINIT/xderiveRead_dp1d
2403 : !! NAME
2404 : !! xderiveRead_dp1d
2405 : !!
2406 : !! FUNCTION
2407 : !! Generic routine to read/write wf files with MPI I/O.
2408 : !! Target: one-dimensional double precision arrays.
2409 : !!
2410 : !! INPUTS
2411 : !! n1= first dimension of the array
2412 : !! spaceComm= MPI communicator
2413 : !!
2414 : !! OUTPUT
2415 : !! ierr= exit status, a non-zero value meaning there is an error
2416 : !! xval= data buffer array
2417 : !!
2418 : !! SIDE EFFECTS
2419 : !! wff= structured info for reading/writing the wavefunctions
2420 : !!
2421 : !! SOURCE
2422 :
2423 16 : subroutine xderiveRead_dp1d(wff,xval,n1,spaceComm,ierr)
2424 :
2425 : !Arguments ------------------------------------
2426 : type(wffile_type),intent(inout) :: wff
2427 : integer,intent(in) :: n1,spaceComm
2428 : integer,intent(out) :: ierr
2429 : real(dp),intent(out) :: xval(:)
2430 :
2431 : !Local variables-------------------------------
2432 : #if defined HAVE_MPI_IO
2433 : integer(kind=MPI_OFFSET_KIND) :: delim_record,nboct,dispoct(1),posit,totoct
2434 : integer :: statux(MPI_STATUS_SIZE)
2435 : #endif
2436 : character(len=500) :: msg
2437 :
2438 : !*********************************************************************
2439 :
2440 816 : xval(:)=zero ; ierr=0 ! Initialization, for the compiler
2441 : if(.false.)write(std_out,*)wff%me,n1,spaceComm
2442 :
2443 : #if defined HAVE_MPI_IO
2444 16 : nboct = wff%nbOct_dp * n1
2445 16 : posit = wff%offwff
2446 16 : delim_record = posit - wff%off_recs + wff%lght_recs - wff%nbOct_recMarker
2447 :
2448 16 : if (delim_record >= nboct) then
2449 : ! Compute offset for local part
2450 : ! dispoct = sum (nboct, rank=0..me)
2451 16 : if (spaceComm/=MPI_COMM_SELF) then
2452 0 : call MPI_SCAN([nboct],dispoct,1,wff%offset_mpi_type,MPI_SUM,spaceComm,ierr)
2453 0 : posit = posit + dispoct(1) - nboct
2454 : end if
2455 :
2456 16 : call MPI_FILE_READ_AT(wff%fhwff,posit,xval,n1,MPI_DOUBLE_PRECISION,statux,ierr)
2457 :
2458 : ! get the total number of bits wrote by processors
2459 16 : if (spaceComm/=MPI_COMM_SELF) then
2460 0 : call xmpi_max(dispoct(1),totoct,spaceComm,ierr)
2461 : !call MPI_ALLREDUCE(dispoct,totoct,1,wff%offset_mpi_type,MPI_MAX,spaceComm,ierr)
2462 : else
2463 16 : totoct=nboct
2464 : end if
2465 : else
2466 0 : ierr = 1
2467 0 : nboct = 0
2468 0 : totoct = 0
2469 : end if
2470 :
2471 : !new offset
2472 16 : wff%offwff=wff%offwff + totoct
2473 16 : return
2474 : #endif
2475 :
2476 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
2477 : ABI_WARNING(msg)
2478 :
2479 : end subroutine xderiveRead_dp1d
2480 : !!***
2481 :
2482 : !----------------------------------------------------------------------
2483 :
2484 : !!****f* m_wffile/xderiveRead_dp2d
2485 : !! NAME
2486 : !! xderiveRead_dp2d
2487 : !!
2488 : !! FUNCTION
2489 : !! Generic routine to read/write wf files with MPI I/O.
2490 : !! Target: double precision two-dimensional arrays.
2491 : !!
2492 : !! INPUTS
2493 : !! n1= first dimension of the array
2494 : !! n2= second dimension of the array
2495 : !! spaceComm= MPI communicator
2496 : !!
2497 : !! OUTPUT
2498 : !! ierr= exit status, a non-zero value meaning there is an error
2499 : !! xval= data buffer array
2500 : !!
2501 : !! SIDE EFFECTS
2502 : !! wff= structured info for reading/writing the wavefunctions
2503 : !!
2504 : !! SOURCE
2505 :
2506 0 : subroutine xderiveRead_dp2d(wff,xval,n1,n2,spaceComm,ierr)
2507 :
2508 : !Arguments ------------------------------------
2509 : type(wffile_type),intent(inout) :: wff
2510 : integer,intent(in) :: n1,n2,spaceComm
2511 : integer,intent(out) :: ierr
2512 : real(dp),intent(out) :: xval(:,:)
2513 :
2514 : !Local variables-------------------------------
2515 : #if defined HAVE_MPI_IO
2516 : integer(kind=MPI_OFFSET_KIND) :: delim_record,nboct,dispoct(1),posit,totoct
2517 : integer :: statux(MPI_STATUS_SIZE)
2518 : #endif
2519 : character(len=500) :: msg
2520 :
2521 : ! *********************************************************************
2522 :
2523 0 : xval(:,:)=zero ; ierr=0 ! Initialization, for the compiler
2524 : if(.false.)write(std_out,*)wff%me,n1,n2,spaceComm
2525 :
2526 : #if defined HAVE_MPI_IO
2527 0 : nboct = wff%nbOct_dp * n1 *n2
2528 0 : posit = wff%offwff
2529 0 : delim_record = posit - wff%off_recs + wff%lght_recs - wff%nbOct_recMarker
2530 :
2531 0 : if (delim_record >= nboct) then
2532 : ! Compute offset for local part
2533 : ! dispoct = sum (nboct, rank=0..me)
2534 0 : if (spaceComm/=MPI_COMM_SELF) then
2535 0 : call MPI_SCAN([nboct],dispoct,1,wff%offset_mpi_type,MPI_SUM,spaceComm,ierr)
2536 0 : posit = posit + dispoct(1) - nboct
2537 : end if
2538 0 : call MPI_FILE_READ_AT(wff%fhwff,posit,xval,n1*n2,MPI_DOUBLE_PRECISION,statux,ierr)
2539 :
2540 : ! get the total number of bits wrote by processors
2541 0 : if (spaceComm/=MPI_COMM_SELF) then
2542 0 : call xmpi_max(dispoct(1),totoct,spaceComm,ierr)
2543 : !call MPI_ALLREDUCE(dispoct,totoct,1,wff%offset_mpi_type,MPI_MAX,spaceComm,ierr)
2544 : else
2545 0 : totoct=nboct
2546 : end if
2547 : else
2548 0 : ierr = 1
2549 0 : nboct = 0
2550 0 : totoct = 0
2551 : end if
2552 :
2553 : !new offset
2554 0 : wff%offwff=wff%offwff + totoct
2555 0 : return
2556 : #endif
2557 :
2558 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
2559 : ABI_WARNING(msg)
2560 :
2561 : end subroutine xderiveRead_dp2d
2562 : !!***
2563 :
2564 : !----------------------------------------------------------------------
2565 :
2566 :
2567 : !!****f* m_wffile/xderiveRead_int2d_displ
2568 : !! NAME
2569 : !! xderiveRead_int2d_displ
2570 : !!
2571 : !! FUNCTION
2572 : !! Generic routine to read/write wf files with MPI I/O.
2573 : !! Target: two-dimensional integer arrays.
2574 : !!
2575 : !! INPUTS
2576 : !! n1= first dimension of the array
2577 : !! n2= second dimension of the array
2578 : !! spaceComm= MPI communicator
2579 : !! displace= number of elements for the offset
2580 : !!
2581 : !! OUTPUT
2582 : !! ierr= exit status, a non-zero value meaning there is an error
2583 : !! xval= data buffer array
2584 : !!
2585 : !! SIDE EFFECTS
2586 : !! wff= structured info for reading/writing the wavefunctions
2587 : !!
2588 : !! SOURCE
2589 :
2590 0 : subroutine xderiveRead_int2d_displ(wff,xval,n1,n2,spaceComm,displace,ierr)
2591 :
2592 : !Arguments ------------------------------------
2593 : type(wffile_type),intent(inout) :: wff
2594 : integer,intent(in) :: n1,n2,spaceComm
2595 : integer,intent(out) :: ierr
2596 : integer,intent(out):: xval(:,:)
2597 : integer,intent(in):: displace(:)
2598 :
2599 : !Local variables-------------------------------
2600 : #if defined HAVE_MPI_IO
2601 : !scalars
2602 : integer :: filetype,i1,i2,ipos,nb,nbval,totsize,wfftempo
2603 : !arrays
2604 : integer :: statux(MPI_STATUS_SIZE)
2605 0 : integer,allocatable :: buf_val(:),length1(:),type1(:),val(:)
2606 0 : integer(kind=MPI_OFFSET_KIND),allocatable :: depl(:),depl1(:),depl_val(:)
2607 : #endif
2608 : character(len=500) :: msg
2609 :
2610 : ! *********************************************************************
2611 :
2612 0 : xval(:,:)=0 ; ierr=0
2613 : if(.false.)write(std_out,*)wff%me,n1,n2,spaceComm,displace
2614 :
2615 : #if defined HAVE_MPI_IO
2616 0 : nb=n1*n2
2617 0 : call xmpi_sum(nb,totsize,spaceComm,ierr)
2618 0 : ABI_MALLOC(depl_val,(0:totsize-1))
2619 0 : ABI_MALLOC(depl,(nb))
2620 0 : ABI_MALLOC(buf_val,(0:totsize-1))
2621 0 : ABI_MALLOC(val,(nb))
2622 :
2623 : !Map displacements
2624 0 : depl_val(0:totsize-1)=-1
2625 0 : do i2=1,n2
2626 0 : do i1=1,n1
2627 0 : ipos=(displace(i2)-1)*n1 + i1-1
2628 0 : depl_val(ipos)=ipos
2629 : end do
2630 : end do
2631 : !To save time, the location described by array map must be in increasing order
2632 0 : nbval=0
2633 0 : do i1=0,totsize-1
2634 0 : if (depl_val(i1)/=-1) then
2635 0 : nbval=nbval+1
2636 0 : depl(nbval)=depl_val(i1)
2637 : end if
2638 : end do
2639 :
2640 : !Build MPI datatype for view
2641 0 : ABI_MALLOC(length1,(nbval+2))
2642 0 : ABI_MALLOC(depl1,(nbval+2))
2643 0 : ABI_MALLOC(type1,(nbval+2))
2644 0 : length1(1)=1;depl1(1)=0;type1(1)=MPI_LB
2645 0 : do i1=2,nbval+1
2646 0 : length1(i1) = 1
2647 0 : depl1(i1)= depl(i1-1)*wff%nbOct_int
2648 0 : type1(i1)= MPI_INTEGER
2649 : end do
2650 0 : length1(nbval+2)=1;depl1(nbval+2)=totsize*wff%nbOct_int;type1(nbval+2)=MPI_UB
2651 0 : call xmpio_type_struct(nbval+2,length1,depl1,type1,filetype,ierr)
2652 0 : call MPI_TYPE_COMMIT(filetype,ierr)
2653 0 : ABI_FREE(length1)
2654 0 : ABI_FREE(depl1)
2655 0 : ABI_FREE(type1)
2656 :
2657 : !Write data
2658 0 : call MPI_FILE_OPEN(spaceComm,wff%fname,MPI_MODE_RDWR,MPI_INFO_NULL,wfftempo,ierr)
2659 0 : ABI_CHECK_MPI(ierr, sjoin("MPI_FILE_OPEN:", wff%fname))
2660 0 : call MPI_FILE_SET_VIEW(wfftempo,wff%offwff,MPI_BYTE,filetype,"native",MPI_INFO_NULL,ierr)
2661 0 : call MPI_FILE_READ_ALL(wfftempo,val,nbval,MPI_INTEGER,statux,ierr)
2662 0 : call MPI_FILE_CLOSE(wfftempo,ierr)
2663 :
2664 : !Retrieve xval
2665 0 : nbval=0
2666 0 : do i1=0,totsize-1
2667 0 : if (depl_val(i1)/=-1) then
2668 0 : nbval=nbval+1
2669 0 : buf_val(i1)=val(nbval)
2670 : end if
2671 : end do
2672 0 : do i2=1,n2
2673 0 : do i1=1,n1
2674 0 : ipos=(displace(i2)-1)*n1 + i1-1
2675 0 : xval(i1,i2)=buf_val(ipos)
2676 : end do
2677 : end do
2678 :
2679 : !Update offset
2680 0 : wff%offwff = wff%offwff + totsize*wff%nbOct_int
2681 :
2682 : !Free memory
2683 0 : call MPI_TYPE_FREE(filetype,ierr)
2684 0 : ABI_FREE(depl)
2685 0 : ABI_FREE(depl_val)
2686 0 : ABI_FREE(buf_val)
2687 0 : ABI_FREE(val)
2688 : return
2689 : #endif
2690 :
2691 : write(msg,'(a,i0,a)')' The value of wff%iomode=',wff%iomode,' is not allowed.'
2692 : ABI_WARNING(msg)
2693 :
2694 :
2695 0 : end subroutine xderiveRead_int2d_displ
2696 : !!***
2697 :
2698 : !----------------------------------------------------------------------
2699 :
2700 : !!****f* m_wffile/xderiveRead_dp2d_displ
2701 : !! NAME
2702 : !! xderiveRead_dp2d_displ
2703 : !!
2704 : !! FUNCTION
2705 : !! Generic routine to read/write wf files with MPI I/O.
2706 : !! Target: double precision two-dimensional arrays.
2707 : !!
2708 : !! INPUTS
2709 : !! n1= first dimension of the array
2710 : !! n2= second dimension of the array
2711 : !! spaceComm= MPI communicator
2712 : !! displace= number of elements for the offset
2713 : !!
2714 : !! OUTPUT
2715 : !! ierr= exit status, a non-zero value meaning there is an error
2716 : !! xval= data buffer array
2717 : !!
2718 : !! SIDE EFFECTS
2719 : !! wff= structured info for reading/writing the wavefunctions
2720 : !!
2721 : !! SOURCE
2722 :
2723 0 : subroutine xderiveRead_dp2d_displ(wff,xval,n1,n2,spaceComm,displace,ierr)
2724 :
2725 : !Arguments ------------------------------------
2726 : type(wffile_type),intent(inout) :: wff
2727 : integer,intent(in) :: n1,n2,spaceComm
2728 : integer,intent(out) :: ierr
2729 : real(dp),intent(out):: xval(:,:)
2730 : integer,intent(in):: displace(:)
2731 :
2732 : !Local variables-------------------------------
2733 : #if defined HAVE_MPI_IO
2734 : !scalars
2735 : integer :: filetype,i1,i2,ipos,nb,nbval,totsize,wfftempo
2736 : !arrays
2737 : integer :: statux(MPI_STATUS_SIZE)
2738 0 : integer,allocatable :: length1(:),type1(:)
2739 0 : integer(kind=MPI_OFFSET_KIND),allocatable :: depl(:),depl1(:),depl_val(:)
2740 0 : real(dp), allocatable :: buf_val(:),val(:)
2741 : #endif
2742 :
2743 : ! *********************************************************************
2744 :
2745 0 : xval(:,:)=zero ; ierr=0
2746 : if(.false.)write(std_out,*)wff%me,n1,n2,displace,spaceComm
2747 :
2748 : #if defined HAVE_MPI_IO
2749 0 : nb=n1*n2
2750 0 : call xmpi_sum(nb,totsize,spaceComm,ierr)
2751 0 : ABI_MALLOC(depl_val,(0:totsize-1))
2752 0 : ABI_MALLOC(depl,(nb))
2753 0 : ABI_MALLOC(buf_val,(0:totsize-1))
2754 0 : ABI_MALLOC(val,(nb))
2755 :
2756 : !Map displacements
2757 0 : depl_val(0:totsize-1)=-1
2758 0 : do i2=1,n2
2759 0 : do i1=1,n1
2760 0 : ipos=(displace(i2)-1)*n1 + i1-1
2761 0 : depl_val(ipos)=ipos
2762 : end do
2763 : end do
2764 : !To save time, the location describe by array map must be in increasing order
2765 0 : nbval=0
2766 0 : do i1=0,totsize-1
2767 0 : if (depl_val(i1)/=-1) then
2768 0 : nbval=nbval+1
2769 0 : depl(nbval)=depl_val(i1)
2770 : end if
2771 : end do
2772 :
2773 : !Build MPI datatype for view
2774 0 : ABI_MALLOC(length1,(nbval+2))
2775 0 : ABI_MALLOC(depl1,(nbval+2))
2776 0 : ABI_MALLOC(type1,(nbval+2))
2777 0 : length1(1)=1;depl1(1)=0;type1(1)=MPI_LB
2778 0 : do i1=2,nbval+1
2779 0 : length1(i1) = 1
2780 0 : depl1(i1)= depl(i1-1)*wff%nbOct_dp
2781 0 : type1(i1)= MPI_DOUBLE_PRECISION
2782 : end do
2783 0 : length1(nbval+2)=1;depl1(nbval+2)=totsize*wff%nbOct_dp;type1(nbval+2)=MPI_UB
2784 0 : call xmpio_type_struct(nbval+2,length1,depl1,type1,filetype,ierr)
2785 0 : call MPI_TYPE_COMMIT(filetype,ierr)
2786 0 : ABI_FREE(length1)
2787 0 : ABI_FREE(depl1)
2788 0 : ABI_FREE(type1)
2789 :
2790 : !Write data
2791 0 : call MPI_FILE_OPEN(spaceComm,wff%fname,MPI_MODE_RDWR,MPI_INFO_NULL,wfftempo,ierr)
2792 0 : ABI_CHECK_MPI(ierr, sjoin("MPI_FILE_OPEN:", wff%fname))
2793 0 : call MPI_FILE_SET_VIEW(wfftempo,wff%offwff,MPI_BYTE,filetype,"native",MPI_INFO_NULL,ierr)
2794 0 : call MPI_FILE_READ_ALL(wfftempo,val,nbval,MPI_DOUBLE_PRECISION,statux,ierr)
2795 0 : call MPI_FILE_CLOSE(wfftempo,ierr)
2796 :
2797 : !Retrieve xval
2798 0 : nbval=0
2799 0 : do i1=0,totsize-1
2800 0 : if (depl_val(i1)/=-1) then
2801 0 : nbval=nbval+1
2802 0 : buf_val(i1)=val(nbval)
2803 : end if
2804 : end do
2805 0 : do i2=1,n2
2806 0 : do i1=1,n1
2807 0 : ipos=(displace(i2)-1)*n1 + i1-1
2808 0 : xval(i1,i2)=buf_val(ipos)
2809 : end do
2810 : end do
2811 :
2812 : !Update offset
2813 0 : wff%offwff = wff%offwff + totsize*wff%nbOct_dp
2814 :
2815 : !Free memory
2816 0 : call MPI_TYPE_FREE(filetype,ierr)
2817 0 : ABI_FREE(depl)
2818 0 : ABI_FREE(depl_val)
2819 0 : ABI_FREE(buf_val)
2820 0 : ABI_FREE(val)
2821 : #endif
2822 :
2823 0 : end subroutine xderiveRead_dp2d_displ
2824 : !!***
2825 :
2826 : !----------------------------------------------------------------------
2827 :
2828 : !!****f* m_wffile/xderiveReadVal_char
2829 : !! NAME
2830 : !! xderiveReadVal_char
2831 : !!
2832 : !! FUNCTION
2833 : !! Generic routine to read/write wf files with MPI I/O.
2834 : !! Target: character string.
2835 : !!
2836 : !! INPUTS
2837 : !! n= number of elements in the array
2838 : !!
2839 : !! OUTPUT
2840 : !! xval= data buffer array
2841 : !! ierr= exit status, a non-zero value meaning there is an error
2842 : !!
2843 : !! SIDE EFFECTS
2844 : !! wff= structured info for reading/writing the wavefunctions
2845 : !!
2846 : !! SOURCE
2847 :
2848 0 : subroutine xderiveReadVal_char(wff,xval,n,ierr)
2849 :
2850 : !Arguments ------------------------------------
2851 : type(wffile_type),intent(inout) :: wff
2852 : integer,intent(in) :: n
2853 : integer,intent(out) :: ierr
2854 : character(len=*),intent(out),target :: xval
2855 :
2856 : !Local variables-------------------------------
2857 : #if defined HAVE_MPI_IO
2858 : integer :: statux(MPI_STATUS_SIZE)
2859 : character,pointer :: arr_xval(:)
2860 : type(c_ptr) :: cptr
2861 : #endif
2862 :
2863 : ! *********************************************************************
2864 :
2865 0 : xval=' ' ; ierr=0
2866 : if(.false.)write(std_out,*)wff%me,n
2867 :
2868 : #if defined HAVE_MPI_IO
2869 0 : cptr=c_loc(xval) ; call c_f_pointer(cptr,arr_xval,[n])
2870 0 : call MPI_FILE_READ_AT(wff%fhwff,wff%offwff,arr_xval,n,MPI_CHARACTER,statux,ierr)
2871 0 : wff%offwff = wff%offwff + wff%nbOct_ch * n
2872 : #endif
2873 :
2874 0 : end subroutine xderiveReadVal_char
2875 : !!***
2876 :
2877 : !----------------------------------------------------------------------
2878 :
2879 : !!****f* m_wffile/xmpi_read_int2d
2880 : !! NAME
2881 : !! xmpi_read_int2d
2882 : !!
2883 : !! FUNCTION
2884 : !! Generic routine to read arrays with MPI I/O.
2885 : !! Target: integer two-dimensional arrays.
2886 : !!
2887 : !! INPUTS
2888 : !! sc_mode=
2889 : !! xmpio_single ==> Local reading.
2890 : !! xmpio_collective ==> Collective reading.
2891 : !! spaceComm= MPI communicator
2892 : !!
2893 : !! OUTPUT
2894 : !! xval= data buffer array
2895 : !! ierr= exit status, a non-zero value meaning there is an error
2896 : !!
2897 : !! SIDE EFFECTS
2898 : !! wff= structured info for reading/writing the wavefunctions
2899 : !!
2900 : !! SOURCE
2901 :
2902 0 : subroutine xmpi_read_int2d(wff,xval,spaceComm,sc_mode,ierr)
2903 :
2904 : !Arguments ------------------------------------
2905 : !scalars
2906 : integer,intent(in) :: spaceComm,sc_mode
2907 : integer,intent(out) :: ierr
2908 : type(wffile_type),intent(inout) :: wff
2909 : !array
2910 : integer,intent(out) :: xval(:,:)
2911 :
2912 : !Local variables-------------------------------
2913 : integer :: n1,n2
2914 : #ifdef HAVE_MPI_IO
2915 : integer(kind=MPI_OFFSET_KIND) :: delim_record,nboct,posit,totoct
2916 : character(len=500) :: msg
2917 : !arrays
2918 : integer :: statux(MPI_STATUS_SIZE)
2919 : #endif
2920 :
2921 : ! *********************************************************************
2922 :
2923 0 : ierr=0
2924 0 : n1 = SIZE(xval,DIM=1)
2925 0 : n2 = SIZE(xval,DIM=2)
2926 :
2927 : #ifdef HAVE_MPI_IO
2928 0 : nboct = wff%nbOct_int * n1 *n2
2929 0 : posit = wff%offwff
2930 0 : delim_record = posit - wff%off_recs + wff%lght_recs - wff%nbOct_recMarker
2931 :
2932 0 : if (delim_record >= nboct) then
2933 :
2934 0 : select case (sc_mode)
2935 : case (xmpio_single)
2936 0 : call MPI_FILE_READ_AT(wff%fhwff,posit,xval,n1*n2,MPI_INTEGER,statux,ierr)
2937 :
2938 : case (xmpio_collective)
2939 0 : call MPI_FILE_READ_AT_ALL(wff%fhwff,posit,xval,n1*n2,MPI_INTEGER,statux,ierr)
2940 :
2941 : case default
2942 0 : write(msg,('(a,i0)'))" Wrong value for sc_mode: ",sc_mode
2943 0 : ABI_ERROR(msg)
2944 : end select
2945 :
2946 : totoct=nboct
2947 : else
2948 0 : write(msg,('(a,2(i0,1x))'))" delim_record < nboct: ",delim_record,nboct
2949 0 : ABI_WARNING(msg)
2950 0 : ierr=MPI_ERR_UNKNOWN
2951 0 : totoct=0
2952 : end if
2953 : !
2954 : !Increment the offset.
2955 0 : wff%offwff=wff%offwff + totoct
2956 : #endif
2957 :
2958 0 : RETURN
2959 : ABI_UNUSED(xval(1,1))
2960 : ABI_UNUSED((/wff%me,spaceComm,sc_mode/))
2961 :
2962 : end subroutine xmpi_read_int2d
2963 : !!***
2964 :
2965 : !----------------------------------------------------------------------
2966 :
2967 : !!****f* m_wffile/xderiveWrite_int
2968 : !! NAME
2969 : !! xderiveWrite_int
2970 : !!
2971 : !! FUNCTION
2972 : !! Generic routine to read/write wf files with MPI I/O.
2973 : !! Target: integer scalar.
2974 : !!
2975 : !! INPUTS
2976 : !! xval= data buffer
2977 : !!
2978 : !! OUTPUT
2979 : !! ierr= exit status, a non-zero value meaning there is an error
2980 : !!
2981 : !! SIDE EFFECTS
2982 : !! wff= structured info for reading/writing the wavefunctions
2983 : !!
2984 : !! SOURCE
2985 :
2986 45 : subroutine xderiveWrite_int(wff,xval,ierr)
2987 :
2988 : !Arguments ------------------------------------
2989 : integer,intent(out) :: ierr
2990 : integer,intent(in):: xval
2991 : type(wffile_type),intent(inout) :: wff
2992 :
2993 : !Local variables-------------------------------
2994 : #if defined HAVE_MPI_IO
2995 : integer :: statux(MPI_STATUS_SIZE),arr_xval(1)
2996 : #endif
2997 : ! *********************************************************************
2998 :
2999 45 : ierr=0
3000 : if(.false.)write(std_out,*)wff%me,xval
3001 : #if defined HAVE_MPI_IO
3002 45 : arr_xval(1) = xval
3003 45 : call MPI_FILE_WRITE_AT(wff%fhwff,wff%offwff,arr_xval,1,MPI_INTEGER,statux,ierr)
3004 45 : wff%offwff = wff%offwff+wff%nbOct_int
3005 : #endif
3006 :
3007 45 : end subroutine xderiveWrite_int
3008 : !!***
3009 :
3010 : !----------------------------------------------------------------------
3011 :
3012 :
3013 : !!****f* m_wffile/xderiveWrite_int1d
3014 : !! NAME
3015 : !! xderiveWrite_int1d
3016 : !!
3017 : !! FUNCTION
3018 : !! Generic routine to read/write wf files with MPI I/O.
3019 : !! Target: one-dimensional integer arrays.
3020 : !!
3021 : !! INPUTS
3022 : !! n1= first dimension of the array
3023 : !! spaceComm= MPI communicator
3024 : !! xval= data buffer array
3025 : !!
3026 : !! OUTPUT
3027 : !! ierr= exit status, a non-zero value meaning there is an error
3028 : !!
3029 : !! SIDE EFFECTS
3030 : !! wff= structured info for reading/writing the wavefunctions
3031 : !!
3032 : !! SOURCE
3033 :
3034 0 : subroutine xderiveWrite_int1d(wff,xval,n1,spaceComm,ierr)
3035 :
3036 : !Arguments ------------------------------------
3037 : integer,intent(in) :: n1,spaceComm
3038 : integer,intent(out) :: ierr
3039 : integer,intent(in):: xval(:)
3040 : type(wffile_type),intent(inout) :: wff
3041 :
3042 : !Local variables-------------------------------
3043 : #if defined HAVE_MPI_IO
3044 : integer(kind=MPI_OFFSET_KIND) :: nboct,dispoct(1),posit,totoct
3045 : integer :: statux(MPI_STATUS_SIZE)
3046 : #endif
3047 : ! *********************************************************************
3048 :
3049 0 : ierr=0
3050 : if(.false.)write(std_out,*)wff%me,n1,spaceComm,xval
3051 : #if defined HAVE_MPI_IO
3052 0 : nboct = n1*wff%nbOct_int
3053 0 : posit = wff%offwff
3054 :
3055 : !dispoct = sum (nboct, rank=0..me)
3056 0 : if (spaceComm/=MPI_COMM_SELF) then
3057 0 : call MPI_SCAN([nboct],dispoct,1,wff%offset_mpi_type,MPI_SUM,spaceComm,ierr)
3058 0 : posit = posit + dispoct(1) - nboct
3059 : end if
3060 0 : call MPI_FILE_WRITE_AT(wff%fhwff,posit,xval,n1,MPI_INTEGER,statux,ierr)
3061 : !gather the bigest offset
3062 :
3063 0 : if (spaceComm/=MPI_COMM_SELF) then
3064 0 : call xmpi_max(dispoct(1),totoct,spaceComm,ierr)
3065 : !call MPI_ALLREDUCE(dispoct,totoct,1,wff%offset_mpi_type,MPI_MAX,spaceComm,ierr)
3066 : else
3067 0 : totoct=nboct
3068 : end if
3069 0 : wff%offwff = wff%offwff + totoct
3070 :
3071 : !Disable old code
3072 : #endif
3073 :
3074 0 : end subroutine xderiveWrite_int1d
3075 : !!***
3076 :
3077 : !----------------------------------------------------------------------
3078 :
3079 : !!****f* m_wffile/xderiveWrite_int2d
3080 : !! NAME
3081 : !! xderiveWrite_int2d
3082 : !!
3083 : !! FUNCTION
3084 : !! Generic routine to read/write wf files with MPI I/O.
3085 : !! Target: two-dimensional integer arrays.
3086 : !!
3087 : !! INPUTS
3088 : !! n1= first dimension of the array
3089 : !! n2= second dimension of the array
3090 : !! spaceComm= MPI communicator
3091 : !! xval= data buffer array
3092 : !!
3093 : !! OUTPUT
3094 : !! ierr= exit status, a non-zero value meaning there is an error
3095 : !!
3096 : !! SIDE EFFECTS
3097 : !! wff= structured info for reading/writing the wavefunctions
3098 : !!
3099 : !! SOURCE
3100 :
3101 0 : subroutine xderiveWrite_int2d(wff,xval,n1,n2,spaceComm,ierr)
3102 :
3103 : !Arguments ------------------------------------
3104 : integer,intent(in) :: n1,n2,spaceComm
3105 : integer,intent(out) :: ierr
3106 : integer,intent(in):: xval(:,:)
3107 : type(wffile_type),intent(inout) :: wff
3108 :
3109 : !Local variables-------------------------------
3110 : #if defined HAVE_MPI_IO
3111 : integer(kind=MPI_OFFSET_KIND) :: nboct,dispoct(1),posit,totoct
3112 : integer :: statux(MPI_STATUS_SIZE)
3113 : #endif
3114 :
3115 : ! *********************************************************************
3116 :
3117 0 : ierr=0
3118 : if(.false.)write(std_out,*)wff%me,n1,n2,spaceComm,xval
3119 : #if defined HAVE_MPI_IO
3120 0 : nboct = n1*n2*wff%nbOct_int
3121 0 : posit = wff%offwff
3122 :
3123 : !dispoct = sum(nboct, rank=0..me)
3124 0 : if (spaceComm/=MPI_COMM_SELF) then
3125 0 : call MPI_SCAN([nboct],dispoct,1,wff%offset_mpi_type,MPI_SUM,spaceComm,ierr)
3126 0 : posit = posit + dispoct(1) - nboct
3127 : end if
3128 0 : call MPI_FILE_WRITE_AT(wff%fhwff,posit,xval,n1*n2,MPI_INTEGER,statux,ierr)
3129 : !gather the biggest offset
3130 0 : if (spaceComm/=MPI_COMM_SELF) then
3131 0 : call xmpi_max(dispoct(1),totoct,spaceComm,ierr)
3132 : !call MPI_ALLREDUCE(dispoct,totoct,1,wff%offset_mpi_type,MPI_MAX,spaceComm,ierr)
3133 : else
3134 0 : totoct=nboct
3135 : end if
3136 0 : wff%offwff = wff%offwff + totoct
3137 : #endif
3138 :
3139 0 : end subroutine xderiveWrite_int2d
3140 : !!***
3141 :
3142 : !----------------------------------------------------------------------
3143 :
3144 :
3145 : !!****f* m_wffile/xderiveWrite_dp
3146 : !! NAME
3147 : !! xderiveWrite_dp
3148 : !!
3149 : !! FUNCTION
3150 : !! Generic routine to read/write wf files with MPI I/O.
3151 : !! Target: double precision scalar.
3152 : !!
3153 : !! INPUTS
3154 : !! xval= data buffer
3155 : !!
3156 : !! OUTPUT
3157 : !! ierr= exit status, a non-zero value meaning there is an error
3158 : !!
3159 : !! SIDE EFFECTS
3160 : !! wff= structured info for reading/writing the wavefunctions
3161 : !!
3162 : !! SOURCE
3163 :
3164 0 : subroutine xderiveWrite_dp(wff,xval,ierr)
3165 :
3166 : !Arguments ------------------------------------
3167 : integer,intent(out) :: ierr
3168 : real(dp),intent(in):: xval
3169 : type(wffile_type),intent(inout) :: wff
3170 :
3171 : !Local variables-------------------------------
3172 : #if defined HAVE_MPI_IO
3173 : integer :: statux(MPI_STATUS_SIZE)
3174 : #endif
3175 : ! *********************************************************************
3176 :
3177 0 : ierr=0
3178 : if(.false.)write(std_out,*)wff%me,xval
3179 : #if defined HAVE_MPI_IO
3180 0 : call MPI_FILE_WRITE_AT(wff%fhwff,wff%offwff,[xval],1,MPI_DOUBLE_PRECISION,statux,ierr)
3181 0 : wff%offwff = wff%offwff+wff%nbOct_dp
3182 : #endif
3183 :
3184 0 : end subroutine xderiveWrite_dp
3185 : !!***
3186 :
3187 : !----------------------------------------------------------------------
3188 :
3189 :
3190 : !!****f* m_wffile/xderiveWrite_dp1d
3191 : !! NAME
3192 : !! xderiveWrite_dp1d
3193 : !!
3194 : !! FUNCTION
3195 : !! Generic routine to read/write wf files with MPI I/O.
3196 : !! Target: one-dimensional double precision arrays.
3197 : !!
3198 : !! INPUTS
3199 : !! n1= first dimension of the array
3200 : !! spaceComm= MPI communicator
3201 : !! xval= data buffer array
3202 : !!
3203 : !! OUTPUT
3204 : !! ierr= exit status, a non-zero value meaning there is an error
3205 : !!
3206 : !! SIDE EFFECTS
3207 : !! wff= structured info for reading/writing the wavefunctions
3208 : !!
3209 : !! SOURCE
3210 :
3211 30 : subroutine xderiveWrite_dp1d(wff,xval,n1,spaceComm,ierr)
3212 :
3213 : !Arguments ------------------------------------
3214 : integer,intent(in) :: n1,spaceComm
3215 : integer,intent(out) :: ierr
3216 : real(dp),intent(in):: xval(:)
3217 : type(wffile_type),intent(inout) :: wff
3218 :
3219 : !Local variables-------------------------------
3220 : #if defined HAVE_MPI_IO
3221 : integer(kind=MPI_OFFSET_KIND) :: nboct,dispoct(1),posit,totoct
3222 : integer :: statux(MPI_STATUS_SIZE)
3223 : #endif
3224 :
3225 : ! *********************************************************************
3226 :
3227 30 : ierr=0
3228 : if(.false.)write(std_out,*)wff%me,n1,spaceComm,xval
3229 : #if defined HAVE_MPI_IO
3230 30 : nboct = n1*wff%nbOct_dp
3231 30 : posit = wff%offwff
3232 : !dispoct = sum (nboct, rank = 0..me)
3233 30 : if (spaceComm/=MPI_COMM_SELF) then
3234 0 : call MPI_SCAN([nboct],dispoct,1,wff%offset_mpi_type,MPI_SUM,spaceComm,ierr)
3235 0 : posit = posit + dispoct(1) - nboct
3236 : end if
3237 30 : call MPI_FILE_WRITE_AT(wff%fhwff,posit,xval,n1,MPI_DOUBLE_PRECISION,statux,ierr)
3238 : !Gather the biggest offset
3239 30 : if (spaceComm/=MPI_COMM_SELF) then
3240 0 : call xmpi_max(dispoct(1),totoct,spaceComm,ierr)
3241 : !call MPI_ALLREDUCE(dispoct,totoct,1,wff%offset_mpi_type,MPI_MAX,spaceComm,ierr)
3242 : else
3243 30 : totoct=nboct
3244 : end if
3245 30 : wff%offwff = wff%offwff + totoct
3246 : #endif
3247 :
3248 30 : end subroutine xderiveWrite_dp1d
3249 : !!***
3250 :
3251 : !----------------------------------------------------------------------
3252 :
3253 : !!****f* m_wffile/xderiveWrite_dp2d
3254 : !! NAME
3255 : !! xderiveWrite_dp2d
3256 : !!
3257 : !! FUNCTION
3258 : !! Generic routine to read/write wf files with MPI I/O.
3259 : !! Target: double precision two-dimensional arrays.
3260 : !!
3261 : !! INPUTS
3262 : !! n1= first dimension of the array
3263 : !! n2= second dimension of the array
3264 : !! spaceComm= MPI communicator
3265 : !! xval= data buffer array
3266 : !!
3267 : !! OUTPUT
3268 : !! ierr= exit status, a non-zero value meaning there is an error
3269 : !!
3270 : !! SIDE EFFECTS
3271 : !! wff= structured info for reading/writing the wavefunctions
3272 : !!
3273 : !! SOURCE
3274 :
3275 0 : subroutine xderiveWrite_dp2d(wff,xval,n1,n2,spaceComm,ierr)
3276 :
3277 : !Arguments ------------------------------------
3278 : integer,intent(in) :: n1,n2,spaceComm
3279 : integer,intent(out) :: ierr
3280 : real(dp),intent(in):: xval(:,:)
3281 : type(wffile_type),intent(inout) :: wff
3282 :
3283 : !Local variables-------------------------------
3284 : #if defined HAVE_MPI_IO
3285 : integer(kind=MPI_OFFSET_KIND) :: nboct,dispoct(1),posit,totoct
3286 : integer :: statux(MPI_STATUS_SIZE)
3287 : #endif
3288 :
3289 : ! *********************************************************************
3290 :
3291 0 : ierr=0
3292 : if(.false.)write(std_out,*)wff%me,xval,n1,n2,spaceComm
3293 :
3294 : #if defined HAVE_MPI_IO
3295 0 : nboct = n1*n2*wff%nbOct_dp
3296 0 : posit = wff%offwff
3297 : !dispoct = sum(nboct, rank=0..me)
3298 0 : if (spaceComm/=MPI_COMM_SELF) then
3299 0 : call MPI_SCAN([nboct],dispoct,1,wff%offset_mpi_type,MPI_SUM,spaceComm,ierr)
3300 0 : posit = posit + dispoct(1) - nboct
3301 : end if
3302 0 : call MPI_FILE_WRITE_AT(wff%fhwff,posit,xval,n1*n2,MPI_DOUBLE_PRECISION,statux,ierr)
3303 0 : posit = posit + nboct
3304 : !gather the biggest offset
3305 0 : if (spaceComm/=MPI_COMM_SELF) then
3306 0 : call xmpi_max(dispoct(1),totoct,spaceComm,ierr)
3307 : !call MPI_ALLREDUCE(dispoct,totoct,1,wff%offset_mpi_type,MPI_MAX,spaceComm,ierr)
3308 : else
3309 0 : totoct=nboct
3310 : end if
3311 0 : wff%offwff = wff%offwff + totoct
3312 : #endif
3313 :
3314 0 : end subroutine xderiveWrite_dp2d
3315 : !!***
3316 :
3317 : !----------------------------------------------------------------------
3318 :
3319 : !!****f* m_wffile/xderiveWrite_dp2d_seq
3320 : !! NAME
3321 : !! xderiveWrite_dp2d_seq
3322 : !!
3323 : !! FUNCTION
3324 : !! Generic routine to read/write wf files with MPI I/O.
3325 : !! Target: double precision two-dimensional arrays.
3326 : !!
3327 : !! INPUTS
3328 : !! xval= data buffer array
3329 : !!
3330 : !! OUTPUT
3331 : !! ierr= exit status, a non-zero value meaning there is an error
3332 : !!
3333 : !! SIDE EFFECTS
3334 : !! wff= structured info for reading/writing the wavefunctions
3335 : !!
3336 : !! SOURCE
3337 :
3338 0 : subroutine xderiveWrite_dp2d_seq(wff,xval,ierr)
3339 :
3340 : !Arguments ------------------------------------
3341 : integer,intent(out) :: ierr
3342 : real(dp),intent(in):: xval(:,:)
3343 : type(wffile_type),intent(inout) :: wff
3344 :
3345 : !Local variables-------------------------------
3346 : #if defined HAVE_MPI_IO
3347 : integer :: n1,n2
3348 : integer :: statux(MPI_STATUS_SIZE)
3349 : #endif
3350 : ! *********************************************************************
3351 :
3352 0 : ierr=0
3353 : if(.false.)write(std_out,*)wff%me,xval
3354 : #if defined HAVE_MPI_IO
3355 0 : n1=size(xval,1);n2=size(xval,2)
3356 0 : call MPI_FILE_WRITE_AT(wff%fhwff,wff%offwff,xval,n1*n2,MPI_DOUBLE_PRECISION,statux,ierr)
3357 0 : wff%offwff = wff%offwff+wff%nbOct_dp*n1*n2
3358 : #endif
3359 :
3360 0 : end subroutine xderiveWrite_dp2d_seq
3361 : !!***
3362 :
3363 : !----------------------------------------------------------------------
3364 :
3365 :
3366 : !!****f* m_wffile/xderiveWrite_int2d_displ
3367 : !! NAME
3368 : !! xderiveWrite_int2d_displ
3369 : !!
3370 : !! FUNCTION
3371 : !! Generic routine to read/write wf files with MPI I/O.
3372 : !! Target: two-dimensional integer arrays.
3373 : !!
3374 : !! INPUTS
3375 : !! n1= first dimension of the array
3376 : !! n2= second dimension of the array
3377 : !! spaceComm= MPI communicator
3378 : !! xval= data buffer array
3379 : !! displace= number of elements for the offset
3380 : !!
3381 : !! OUTPUT
3382 : !! ierr= exit status, a non-zero value meaning there is an error
3383 : !!
3384 : !! SIDE EFFECTS
3385 : !! wff= structured info for reading/writing the wavefunctions
3386 : !!
3387 : !! SOURCE
3388 :
3389 38 : subroutine xderiveWrite_int2d_displ(wff,xval,n1,n2,spaceComm,displace,ierr)
3390 :
3391 : !Arguments ------------------------------------
3392 : integer,intent(in) :: n1,n2,spaceComm
3393 : integer,intent(out) :: ierr
3394 : integer,intent(in):: displace(:),xval(:,:)
3395 : type(wffile_type),intent(inout) :: wff
3396 :
3397 : !Local variables-------------------------------
3398 : #if defined HAVE_MPI_IO
3399 : !scalars
3400 : integer :: filetype,i1,i2,ipos,nb,nbval,totsize,wfftempo
3401 : !arrays
3402 : integer :: statux(MPI_STATUS_SIZE)
3403 38 : integer, allocatable :: buf_val(:),length1(:),type1(:),val(:)
3404 38 : integer(kind=MPI_OFFSET_KIND),allocatable :: depl(:),depl1(:),depl_val(:)
3405 : #endif
3406 :
3407 : ! *********************************************************************
3408 :
3409 : ierr=0
3410 : if(.false.)write(std_out,*)wff%me,xval,n1,n2,spaceComm,displace
3411 :
3412 : #if defined HAVE_MPI_IO
3413 38 : nb = n1*n2
3414 38 : call xmpi_sum(nb,totsize,spaceComm,ierr)
3415 114 : ABI_MALLOC(depl_val,(0:totsize-1))
3416 114 : ABI_MALLOC(depl,(nb))
3417 114 : ABI_MALLOC(buf_val,(0:totsize-1))
3418 114 : ABI_MALLOC(val,(nb))
3419 :
3420 : !Map displacements
3421 : !Put xval in a buffer at its position
3422 50648 : depl_val(0:totsize-1)=-1
3423 7613 : do i2=1,n2
3424 30338 : do i1=1,n1
3425 : ! ipos location of xval(i1,i2) in the array associated with record to be written
3426 22725 : ipos=(displace(i2)-1)*n1 + i1-1
3427 22725 : buf_val(ipos) = xval(i1,i2)
3428 30300 : depl_val(ipos) = ipos
3429 : end do
3430 : end do
3431 : !To save time, the location describe by array map must be in increasing order
3432 38 : nbval=0
3433 50648 : do i1=0,totsize-1
3434 50648 : if (depl_val(i1)/=-1) then
3435 22725 : nbval=nbval+1
3436 22725 : val(nbval)=buf_val(i1)
3437 22725 : depl(nbval)=depl_val(i1)
3438 : end if
3439 : end do
3440 :
3441 : !Build MPI datatype for view
3442 114 : ABI_MALLOC(length1,(nbval+2))
3443 114 : ABI_MALLOC(depl1,(nbval+2))
3444 76 : ABI_MALLOC(type1,(nbval+2))
3445 38 : length1(1)=1;depl1(1)=0;type1(1)=MPI_LB
3446 22763 : do i1=2,nbval+1
3447 22725 : length1(i1) = 1
3448 22725 : depl1(i1)= depl(i1-1)*wff%nbOct_int
3449 22763 : type1(i1)= MPI_INTEGER
3450 : end do
3451 38 : length1(nbval+2)=1;depl1(nbval+2)=totsize*wff%nbOct_int;type1(nbval+2)=MPI_UB
3452 38 : call xmpio_type_struct(nbval+2,length1,depl1,type1,filetype,ierr)
3453 38 : call MPI_TYPE_COMMIT(filetype,ierr)
3454 38 : ABI_FREE(length1)
3455 38 : ABI_FREE(depl1)
3456 38 : ABI_FREE(type1)
3457 :
3458 : !Write data
3459 38 : call MPI_FILE_OPEN(spaceComm,wff%fname,MPI_MODE_RDWR,MPI_INFO_NULL,wfftempo,ierr)
3460 38 : ABI_CHECK_MPI(ierr, sjoin("MPI_FILE_OPEN:", wff%fname))
3461 38 : call MPI_FILE_SET_VIEW(wfftempo,wff%offwff,MPI_BYTE,filetype,"native",MPI_INFO_NULL,ierr)
3462 38 : call MPI_FILE_WRITE_ALL(wfftempo,val,nbval,MPI_INTEGER,statux,ierr)
3463 38 : call MPI_FILE_CLOSE(wfftempo,ierr)
3464 :
3465 : !Update offset
3466 38 : wff%offwff = wff%offwff + totsize*wff%nbOct_int
3467 :
3468 : !Free memory
3469 38 : call MPI_TYPE_FREE(filetype,ierr)
3470 38 : ABI_FREE(depl)
3471 38 : ABI_FREE(depl_val)
3472 38 : ABI_FREE(buf_val)
3473 38 : ABI_FREE(val)
3474 : #endif
3475 :
3476 38 : end subroutine xderiveWrite_int2d_displ
3477 : !!***
3478 :
3479 : !----------------------------------------------------------------------
3480 :
3481 : !!****f* m_wffile/xderiveWrite_dp2d_displ
3482 : !! NAME
3483 : !! xderiveWrite_dp2d_displ
3484 : !!
3485 : !! FUNCTION
3486 : !! Generic routine to read/write wf files with MPI I/O.
3487 : !! Target: two-dimensional double precision arrays.
3488 : !!
3489 : !! INPUTS
3490 : !! n1= first dimension of the array
3491 : !! n2= second dimension of the array
3492 : !! spaceComm= MPI communicator
3493 : !! xval= data buffer array
3494 : !! displace= number of elements for the offset
3495 : !!
3496 : !! OUTPUT
3497 : !! ierr= exit status, a non-zero value meaning there is an error
3498 : !!
3499 : !! SIDE EFFECTS
3500 : !! wff= structured info for reading/writing the wavefunctions
3501 : !!
3502 : !! SOURCE
3503 :
3504 0 : subroutine xderiveWrite_dp2d_displ(wff,xval,n1,n2,spaceComm,displace,ierr)
3505 :
3506 : !Arguments ------------------------------------
3507 : integer,intent(in) :: n1,n2,spaceComm
3508 : integer,intent(out) :: ierr
3509 : integer,intent(in):: displace(:)
3510 : real(dp),intent(in) :: xval(:,:)
3511 : type(wffile_type),intent(inout) :: wff
3512 :
3513 : !Local variables-------------------------------
3514 : #if defined HAVE_MPI_IO
3515 : !scalars
3516 : integer :: filetype,i1,i2,ipos,nb,nbval,totsize,wfftempo
3517 : !arrays
3518 : integer :: statux(MPI_STATUS_SIZE)
3519 0 : integer, allocatable :: length1(:),type1(:)
3520 0 : integer(kind=XMPI_ADDRESS_KIND),allocatable :: depl(:),depl1(:),depl_val(:)
3521 0 : real(dp),allocatable :: buf_val(:),val(:)
3522 : #endif
3523 :
3524 : ! *********************************************************************
3525 :
3526 : ierr=0
3527 : if(.false.)write(std_out,*)wff%me,xval,n1,n2,spaceComm,displace
3528 :
3529 : #if defined HAVE_MPI_IO
3530 0 : nb = n1*n2
3531 0 : call xmpi_sum(nb,totsize,spaceComm,ierr)
3532 0 : ABI_MALLOC(depl_val,(0:totsize-1))
3533 0 : ABI_MALLOC(depl,(nb))
3534 0 : ABI_MALLOC(buf_val,(0:totsize-1))
3535 0 : ABI_MALLOC(val,(nb))
3536 :
3537 : !Map displacements
3538 : !Put xval in a buffer at its position
3539 0 : depl_val(0:totsize-1)=-1
3540 0 : do i2=1,n2
3541 0 : do i1=1,n1
3542 : ! ipos location of xval(i1,i2) in the array associated with record to be written
3543 0 : ipos=(displace(i2)-1)*n1 + i1-1
3544 0 : buf_val(ipos) = xval(i1,i2)
3545 0 : depl_val(ipos) = ipos
3546 : end do
3547 : end do
3548 : !To save time, the location describe by array map must be in increasing order
3549 0 : nbval=0
3550 0 : do i1=0,totsize-1
3551 0 : if (depl_val(i1)/=-1) then
3552 0 : nbval=nbval+1
3553 0 : val(nbval)=buf_val(i1)
3554 0 : depl(nbval)=depl_val(i1)
3555 : end if
3556 : end do
3557 :
3558 : !Build MPI datatype for view
3559 0 : ABI_MALLOC(length1,(nbval+2))
3560 0 : ABI_MALLOC(depl1,(nbval+2))
3561 0 : ABI_MALLOC(type1,(nbval+2))
3562 0 : length1(1)=1;depl1(1)=0;type1(1)=MPI_LB
3563 0 : do i1=2,nbval+1
3564 0 : length1(i1) = 1
3565 0 : depl1(i1)= depl(i1-1)*wff%nbOct_dp
3566 0 : type1(i1)= MPI_DOUBLE_PRECISION
3567 : end do
3568 0 : length1(nbval+2)=1;depl1(nbval+2)=totsize*wff%nbOct_dp;type1(nbval+2)=MPI_UB
3569 0 : call xmpio_type_struct(nbval+2,length1,depl1,type1,filetype,ierr)
3570 0 : call MPI_TYPE_COMMIT(filetype,ierr)
3571 0 : ABI_FREE(length1)
3572 0 : ABI_FREE(depl1)
3573 0 : ABI_FREE(type1)
3574 :
3575 : !Write data
3576 0 : call MPI_FILE_OPEN(spaceComm,wff%fname,MPI_MODE_RDWR,MPI_INFO_NULL,wfftempo,ierr)
3577 0 : ABI_CHECK_MPI(ierr, sjoin("MPI_FILE_OPEN:", wff%fname))
3578 0 : call MPI_FILE_SET_VIEW(wfftempo,wff%offwff,MPI_BYTE,filetype,"native",MPI_INFO_NULL,ierr)
3579 0 : call MPI_FILE_WRITE_ALL(wfftempo,val,nbval,MPI_DOUBLE_PRECISION,statux,ierr)
3580 0 : call MPI_FILE_CLOSE(wfftempo,ierr)
3581 :
3582 0 : wff%offwff = wff%offwff + totsize*wff%nbOct_dp
3583 :
3584 : !Free memory
3585 0 : call MPI_TYPE_FREE(filetype,ierr)
3586 0 : ABI_FREE(depl)
3587 0 : ABI_FREE(depl_val)
3588 0 : ABI_FREE(buf_val)
3589 0 : ABI_FREE(val)
3590 : #endif
3591 :
3592 0 : end subroutine xderiveWrite_dp2d_displ
3593 : !!***
3594 :
3595 : !----------------------------------------------------------------------
3596 :
3597 :
3598 : !!****f* m_wffile/xderiveWrite_char
3599 : !! NAME
3600 : !! xderiveWrite_char
3601 : !!
3602 : !! FUNCTION
3603 : !! Generic routine to read/write wf files with MPI I/O.
3604 : !! Target: character string.
3605 : !!
3606 : !! INPUTS
3607 : !! xval= data buffer array
3608 : !! n= number of elements in the string
3609 : !!
3610 : !! OUTPUT
3611 : !! ierr= exit status, a non-zero value meaning there is an error
3612 : !!
3613 : !! SIDE EFFECTS
3614 : !! wff= structured info for reading/writing the wavefunctions
3615 : !!
3616 : !! SOURCE
3617 :
3618 0 : subroutine xderiveWrite_char(wff,xval,n,ierr)
3619 :
3620 : !Arguments ------------------------------------
3621 : type(wffile_type),intent(inout) :: wff
3622 : integer,intent(in) :: n
3623 : integer,intent(out) :: ierr
3624 : character(len=*),intent(in),target :: xval
3625 :
3626 : !Local variables-------------------------------
3627 : #if defined HAVE_MPI_IO
3628 : integer :: statux(MPI_STATUS_SIZE)
3629 : character,pointer :: buf(:)
3630 : type(c_ptr) :: cptr
3631 : #endif
3632 : ! *********************************************************************
3633 :
3634 0 : ierr=0
3635 : if(.false.)write(std_out,*)wff%me,xval,n
3636 :
3637 : #if defined HAVE_MPI_IO
3638 0 : cptr=c_loc(xval) ; call c_f_pointer(cptr,buf,[n])
3639 0 : call MPI_FILE_WRITE_AT(wff%fhwff,wff%offwff,buf,n,MPI_CHARACTER,statux,ierr)
3640 0 : wff%offwff = wff%offwff + wff%nbOct_ch * n
3641 : #endif
3642 :
3643 0 : end subroutine xderiveWrite_char
3644 : !!***
3645 :
3646 : !!****f* m_wffile/xdefineOff
3647 : !! NAME
3648 : !! xdefineOff
3649 : !!
3650 : !! FUNCTION
3651 : !! In case of MPI I/O, defines the offset for each processor
3652 : !!
3653 : !! INPUTS
3654 : !! formeig option (format of the eigenvalues and occupations) :
3655 : !! 0 => ground-state format (initialisation of eigenvectors with
3656 : !! random numbers, vector of eigenvalues, occupations are present)
3657 : !! 1 => respfn format (initialisation of eigenvectors with 0 s,
3658 : !! hermitian matrix of eigenvalues)
3659 : !! nkpt = number of k points
3660 : !! nspinor = total number of spinorial components of the wavefunctions
3661 : !! nsppol = number of channels for spin-polarization (1 or 2)
3662 : !! nband(nkpt*nsppol) = number of bands at each k point, for each polarization
3663 : !! npwarr(nkpt) = number of planewaves at each k point
3664 : !! mpi_enreg <type(MPI_type)> = information about MPI parallelization
3665 : !!
3666 : !! OUTPUT
3667 : !! (no output)
3668 : !!
3669 : !! SIDE EFFECTS
3670 : !! wff <type(wffile_type)> =
3671 : !!
3672 : !! SOURCE
3673 :
3674 0 : subroutine xdefineOff(formeig,wff,mpi_enreg,nband,npwarr,nspinor,nsppol,nkpt)
3675 :
3676 : !Arguments ------------------------------------
3677 : integer, intent(in) :: nsppol,nkpt,nspinor,formeig
3678 : integer, intent(in) :: nband(nkpt*nsppol),npwarr(nkpt)
3679 : type(wffile_type),intent(inout) :: wff
3680 : type(MPI_type),intent(in) :: mpi_enreg
3681 :
3682 : !Local variables-------------------------------
3683 : #if defined HAVE_MPI_IO
3684 : !scalars
3685 : integer :: comm,iproc
3686 : integer :: nband_k,npw_k,nproc,me,ipp
3687 : integer :: nbrec,isppol,ikpt,nbint,nbreal,nbd,ippband
3688 : integer :: nrecnpw,nreckg
3689 : integer(kind=XMPI_OFFSET_KIND) :: pos_start
3690 : !arrays
3691 0 : integer(kind=XMPI_OFFSET_KIND),allocatable :: offproc(:)
3692 : #endif
3693 :
3694 : ! *************************************************************************
3695 : !nbOct_int octet number of int value
3696 : !nbOct_dp octet number of dp value
3697 : !nbOct_ch octet number of character value
3698 : !lght_recs length of record
3699 :
3700 : if(.false.)write(std_out,*)wff%me,mpi_enreg%nproc,formeig,nband,npwarr,nspinor,nkpt
3701 : #if defined HAVE_MPI_IO
3702 0 : if(wff%iomode==IO_MODE_MPI)then
3703 :
3704 0 : comm=mpi_enreg%comm_cell
3705 0 : me=xmpi_comm_rank(comm)
3706 0 : nproc=xmpi_comm_size(comm)
3707 0 : pos_start=wff%offwff
3708 :
3709 0 : ABI_MALLOC(offproc,(0:nproc))
3710 0 : offproc = 0
3711 : nbrec =2
3712 : nrecnpw=3+nbrec
3713 :
3714 0 : do isppol=1,nsppol
3715 0 : do ikpt=1,nkpt
3716 0 : nband_k=nband(ikpt+(isppol-1)*nkpt)
3717 0 : npw_k=npwarr(ikpt)
3718 0 : iproc=mpi_enreg%proc_distrb(ikpt,1,isppol)
3719 : if (mpi_enreg%paralbd==1) iproc=mpi_enreg%proc_distrb(ikpt,1,isppol)
3720 : ! record kg
3721 0 : nreckg=nbrec+ wff%kgwff*3*npw_k
3722 :
3723 : ! Record npw,nspinor,nband, Record kg
3724 0 : offproc(iproc) = offproc(iproc) + wff%nbOct_int*(nrecnpw+nreckg)
3725 :
3726 0 : if (formeig == 0) then
3727 : ! Records eigen,occ
3728 0 : nbint=nbrec
3729 0 : nbreal = 2 *nband_k
3730 0 : offproc(iproc) = offproc(iproc) + (wff%nbOct_int*nbint+wff%nbOct_dp*nbreal)
3731 :
3732 : ! Records cg
3733 : offproc(iproc) = offproc(iproc) &
3734 0 : & + (wff%nbOct_int*nbrec+wff%nbOct_dp*2*npw_k*nspinor)*nband_k
3735 :
3736 0 : ippband=iproc
3737 0 : do nbd=1,nband_k
3738 0 : ipp=mpi_enreg%proc_distrb(ikpt,nbd,isppol)
3739 0 : if (ipp /= ippband ) then
3740 0 : ippband=ipp
3741 0 : offproc(ippband)=offproc(ippband)+ wff%nbOct_int*(nrecnpw+nreckg)
3742 : offproc(ippband) = offproc(ippband) + (wff%nbOct_int*nbint &
3743 0 : & +wff%nbOct_dp*nbreal)
3744 : offproc(ippband) = offproc(ippband) + (wff%nbOct_int*nbrec &
3745 0 : & + wff%nbOct_dp*2*npw_k*nspinor)*nband_k
3746 : end if
3747 : end do
3748 0 : else if (formeig == 1) then
3749 : ! record eigen
3750 : offproc(iproc) = offproc(iproc) + (wff%nbOct_int*2*nbrec &
3751 : & + wff%nbOct_dp*2*npw_k*nspinor &
3752 0 : & + wff%nbOct_dp*2*nband_k)*nband_k
3753 0 : ippband=iproc
3754 0 : do nbd=1,nband_k
3755 0 : ipp=mpi_enreg%proc_distrb(ikpt,nbd,isppol)
3756 0 : if (ipp /= ippband) then
3757 0 : ippband=ipp
3758 0 : offproc(ippband)=offproc(ippband)+ wff%nbOct_int*(nrecnpw+nreckg)
3759 : offproc(ippband) = offproc(ippband) + (wff%nbOct_int*2*nbrec &
3760 : & + wff%nbOct_dp*2*npw_k*nspinor &
3761 0 : & + wff%nbOct_dp*2*nband_k)*nband_k
3762 : end if
3763 : end do
3764 : end if ! formeig
3765 : end do ! ikpt
3766 :
3767 : end do ! isppol
3768 :
3769 : ! pos_start=wff%offwff
3770 : ! wff%offwff = pos_start
3771 :
3772 0 : if (me/=0)then
3773 0 : do iproc=0,me-1
3774 0 : wff%offwff=wff%offwff+offproc(iproc)
3775 : end do
3776 : end if
3777 0 : ABI_FREE(offproc)
3778 :
3779 : end if ! iomode
3780 : #endif
3781 :
3782 0 : end subroutine xdefineOff
3783 : !!***
3784 :
3785 0 : END MODULE m_wffile
3786 : !!***
|
