Line data Source code
1 : !!****m* ABINIT/m_wfk
2 : !! NAME
3 : !! m_wfk
4 : !!
5 : !! FUNCTION
6 : !! This module defines the wfk_t object providing a high-level API
7 : !! to perform common IO operations on the WFK file produced by ABINIT.
8 : !! The API wraps thee different formats/io-libraries:
9 : !!
10 : !! 1) binary Fortran files with sequential Fortran IO (read, write)
11 : !! 2) binary Fortran files with MPI-IO primitives (C-steam + Fortran records)
12 : !! 3) Netcdf files with parallel IO a.k.a HDF5
13 : !!
14 : !! and emulate random access when binary Fortran files are used in *read-only* mode.
15 : !! See notes below for more info.
16 : !!
17 : !! COPYRIGHT
18 : !! Copyright (C) 2009-2026 ABINIT group (MG)
19 : !! This file is distributed under the terms of the
20 : !! GNU General Public License, see ~abinit/COPYING
21 : !! or http://www.gnu.org/copyleft/gpl.txt .
22 : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
23 : !!
24 : !! NOTES
25 : !! 1) The wfk_t object supports random access also when plain Fortran-IO is used.
26 : !! One can easily *read* the block of wavefunctions with a given (kpt,spin)
27 : !! by simply passing the appropriate indices (ik_ibz,spin) to the wfk_read_ routines.
28 : !! Note however that the same feature is not available in write mode when Fortran IO
29 : !! is used. In this case indeed one should access the block of wavefunctions
30 : !! according to their (kpt,spin) indices in order to write the correct record markers
31 : !! MPI-IO and NETCDF do not have such limitation.
32 : !!
33 : !! 2) MPI-IO read operations are done with file views even for contiguous data of the same type.
34 : !! I found, indeed, that mixing views with explicit offset calls causes
35 : !! wrong results unless the file is closed and re-open! Very strange since, according to
36 : !! the documentation, the two APIs do not interfere and can be mixed. Calls to MPI_FILE_SEEK
37 : !! to reset the pointer to the start of the file do not solve the problem. Don't know if it's
38 : !! a feature or a bug (the problem showed up with MPICH2, I haven't tested other MPI libraries)
39 : !!
40 : !! SOURCE
41 :
42 : #if defined HAVE_CONFIG_H
43 : #include "config.h"
44 : #endif
45 :
46 : #include "abi_common.h"
47 :
48 : #define DEBUG_MODE
49 :
50 : module m_wfk
51 :
52 : use defs_basis
53 : use m_abicore
54 : use m_errors
55 : use m_dtset
56 : USE_MPI
57 : use m_xmpi
58 : use m_mpiotk
59 : use m_hdr
60 : use m_sort
61 : use m_crystal
62 : use m_pawtab
63 : use m_ebands
64 : use m_pawrhoij
65 : use m_wffile
66 : use m_nctk
67 : use netcdf
68 : use m_clib
69 : use m_symkpt
70 :
71 : use defs_abitypes, only : MPI_type
72 : use defs_datatypes, only : pseudopotential_type
73 : use defs_wvltypes, only : wvl_internal_type
74 : use m_build_info, only : abinit_version
75 : use m_geometry, only : metric
76 : use m_time, only : cwtime, cwtime_report, asctime
77 : use m_fstrings, only : sjoin, strcat, endswith, itoa, ktoa, ftoa
78 : use m_io_tools, only : get_unit, mvrecord, iomode_from_fname, iomode2str, open_file, close_unit, delete_file, file_exists
79 : use m_numeric_tools,only : mask2blocks, stats_t, stats_eval, wrap2_pmhalf
80 : use m_cgtk, only : cgtk_rotate, cgtk_rotate_symrec
81 : use m_fftcore, only : get_kg, ngfft_seq
82 : use m_mpinfo, only : destroy_mpi_enreg, initmpi_seq
83 : use m_rwwf, only : rwwf
84 : use m_kpts, only : listkk, kpts_timrev_from_kptopt
85 :
86 : implicit none
87 :
88 : private
89 :
90 : #ifdef HAVE_MPI1
91 : include 'mpif.h'
92 : #endif
93 :
94 : integer,private,parameter :: WFK_NOMODE = 0
95 : integer,private,parameter :: WFK_READMODE = 1
96 : integer,private,parameter :: WFK_WRITEMODE = 2
97 : !!***
98 :
99 : !----------------------------------------------------------------------
100 :
101 : !!****t* m_wfk/wfk_t
102 : !! NAME
103 : !! wfk_t
104 : !!
105 : !! FUNCTION
106 : !! File handler for the WFK file.
107 : !!
108 : !! SOURCE
109 :
110 : type,public :: wfk_t
111 :
112 : integer :: fh
113 : ! unit number if IO_MODE_FORTRAN
114 : ! MPI file handler if IO_MODE_MPI
115 : ! Netcdf file handler if IO_MODE_ETSF
116 :
117 : integer :: iomode
118 : ! Method used to access the WFK file:
119 : ! IO_MODE_FORTRAN for usual Fortran IO routines
120 : ! IO_MODE_MPI if MPI/IO routines.
121 : ! IO_MODE_ETSF, NetCDF format read/written via etsf-io.
122 :
123 : integer :: mband
124 : ! Max number of bands stored on file (MAX(Hdr%nband))
125 :
126 : integer :: nkpt
127 : ! Number of k-points.
128 :
129 : integer :: nsppol
130 : ! Number of spins
131 :
132 : integer :: nspinor
133 : ! Number of spinor components.
134 :
135 : integer :: formeig
136 : ! format of the eigenvalues
137 : ! 0 => vector of eigenvalues (GS case)
138 : ! 1 => Hermitian matrix of eigenvalues (DFPT case)
139 : ! TODO: this should be reported somewhere in the WFK file, at present is passed to wfk_open
140 :
141 : integer :: fform
142 : ! File type format of the header
143 :
144 : integer :: rw_mode = WFK_NOMODE
145 : ! (Read|Write) mode
146 :
147 : character(len=fnlen) :: fname = ABI_NOFILE
148 : ! File name
149 :
150 : integer :: master
151 : ! master node of the IO procedure
152 :
153 : integer :: my_rank
154 : ! index of my processor in the MPI communicator comm
155 :
156 : integer :: nproc
157 : ! number of processors in comm
158 :
159 : integer :: comm
160 : ! MPI communicator
161 :
162 : integer :: recn_eof
163 : ! EOF record number (used for Fortran IO)
164 :
165 : integer(XMPI_OFFSET_KIND) :: offset_eof
166 : ! EOF offset (used for MPI-IO access)
167 :
168 : logical :: debug = .FALSE.
169 : !logical :: debug=.TRUE.
170 :
171 : type(hdr_type) :: Hdr
172 : ! Abinit header.
173 :
174 : integer,allocatable :: nband(:,:)
175 : ! nband(nkpt,nsppol) = Number of bands at each (k,s)
176 :
177 : integer :: f90_fptr(3) = [0,0,0]
178 : ! The position of the file pointer used for sequential access with Fortran-IO.
179 : ! f90_fprt(1) = Index of the k-point associated to the block.
180 : ! f90_fprt(2) = the spin associated to the block.
181 : ! f90_fprt(3) = Record Type (see REC_* variables).
182 : ! [0,0,0] corresponds to the beginning of the file.
183 : ! FPTR_EOF signals the end of file
184 :
185 : integer,allocatable :: recn_ks(:,:,:)
186 : ! recn_ks(k,s,1) : record number of (npw, nspinor, nband_disk)
187 : ! recn_ks(k,s,2) : record number of the (k+G) vectors.
188 : ! recn_ks(k,s,3) : record number of the eigenvalues.
189 : ! recn_ks(k,s,4) : record number of the first wavefunction in the wf coefficients block.
190 :
191 : integer(XMPI_OFFSET_KIND),allocatable :: offset_ks(:,:,:)
192 : ! offset_ks(k,s,1) : offset of the record: npw, nspinor, nband_disk.
193 : ! offset_ks(k,s,2) : offset of the Second record: (k+G) vectors.
194 : ! offset_ks(k,s,3) : offset of the third record eigenvalues.
195 : ! offset_ks(k,s,4) : offset of the fourth record (wavefunction coefficients).
196 : !
197 : ! **********************************************************************
198 : ! NB: The offset point to the Fortran record marker and not to the data
199 : ! **********************************************************************
200 :
201 : integer(XMPI_OFFSET_KIND) :: hdr_offset
202 : ! offset of the header
203 : ! TODO this should be the output of a hdr method!
204 :
205 : integer(XMPI_OFFSET_KIND) :: chunk_bsize
206 : ! IO is performed in chunks of max size chunk_bsize [bytes]
207 :
208 : contains
209 :
210 : procedure :: open_write => wfk_open_write
211 : ! Open the WFK file in write mode.
212 :
213 : procedure :: open_read => wfk_open_read
214 : ! Open the WFK file in read mode.
215 :
216 : procedure :: close => wfk_close
217 : ! Close the WFK file and release the memory allocated in wfk_t.
218 :
219 : procedure :: print => wfk_print
220 : ! Print info on the wfk_t object
221 :
222 : procedure :: findk => wfk_findk
223 : ! Returns the index of the k-point in the WFK file.
224 :
225 : procedure :: compare => wfk_compare
226 : ! Test two wfk_t objects for consistency.
227 :
228 : procedure :: read_band_block => wfk_read_band_block
229 : ! Read a contiguous block of bands for a given (kpoint, spin)
230 :
231 : procedure :: read_bks => wfk_read_bks
232 : ! Read the wavefunction and the eigenvalues for a given (band, k-point, spin)
233 :
234 : procedure :: write_band_block => wfk_write_band_block
235 : ! Write a contiguous block of bands for a given (kpoint, spin)
236 :
237 : procedure :: read_bmask => wfk_read_bmask
238 : ! Read a scattered set of bands for a given (kpoint, spin).
239 :
240 : procedure :: read_eigk => wfk_read_eigk
241 : ! Read the eigenvalues at a given (kpoint,spin).
242 :
243 : procedure :: write_h1mat => wfk_write_h1mat
244 : ! Write all the H1 matrix elements.
245 : end type wfk_t
246 :
247 : public :: wfk_to_bz ! Generate a new WFK file with wavefunctions in the full BZ and istwfk==1
248 : ! Mainly used to interface ABINIT with other codes that
249 : ! cannot handle symmetries e.g. lobster
250 : public :: wfk_nc2fort ! Convert a netcdf WFK file to a Fortran WFK file.
251 : public :: wfk_ncdef_dims_vars ! Define basic dimensions for netcdf file format.
252 : public :: wfk_read_ebands ! Read the GS eigenvalues and return ebands_t object.
253 : public :: wfk_read_eigenvalues ! Read all the GS eigenvalues stored in the WFK file.
254 : public :: wfk_read_h1mat ! Read all the H1 matrix elements.
255 : public :: wfk_read_my_kptbands ! Read in all of my bands and k, depending on a distribution flag array
256 : public :: wfk_write_my_kptbands ! Write all of my bands and k to a file, depending on a distribution flag array
257 : public :: wfk_klist2mesh ! Generate a full WFK file with k in the IBZ from a file with a subset of k-points
258 : ! Mainly used in the transport part when the kerange trick is employed.
259 :
260 : ! Profiling tools
261 : public :: wfk_prof ! Profiling tool.
262 :
263 : ! Unit tests
264 : public :: wfk_diff ! Compare two WFK file for binary equality.
265 : public :: wfk_create_wfkfile ! Create a FAKE WFK file.
266 : public :: wfk_check_wfkfile ! Read a FAKE WFK file and perform basic tests.
267 : public :: wfk_check_symtab
268 :
269 : !!***
270 :
271 : ! Indices associated to the start of the different records of the WFK file.
272 : integer,private,parameter :: REC_HDR=0
273 : integer,private,parameter :: REC_NPW=1
274 : integer,private,parameter :: REC_KG =2
275 : integer,private,parameter :: REC_EIG=3
276 : integer,private,parameter :: REC_CG =4
277 : integer,private,parameter :: REC_NUM=REC_CG
278 :
279 : integer,private,parameter :: FPTR_EOF(3) = [-1,-1,-1]
280 :
281 : integer(XMPI_OFFSET_KIND),private,parameter :: WFK_CHUNK_BSIZE = 1000 * (1024.0_dp**2)
282 : ! Maximum size (in bytes) of the block of wavefunctions that are (read|written)
283 : ! in a single MPI-IO call. (Some MPI-IO implementation crashes if we try to
284 : ! (read|write) a big chunk of data with a single call.
285 :
286 : !----------------------------------------------------------------------
287 :
288 : !!****t* m_wfk/kvars_t
289 : !! NAME
290 : !!
291 : !! FUNCTION
292 : !!
293 : !! SOURCE
294 :
295 : type,public :: kvars_t
296 : integer,allocatable :: kg_k(:,:)
297 : real(dp),pointer :: occ_k(:) => null()
298 : real(dp),pointer :: eig_k(:) => null()
299 : end type kvars_t
300 :
301 : CONTAINS
302 : !!***
303 :
304 : !----------------------------------------------------------------------
305 :
306 : !!****f* m_wfk/wfk_open_read
307 : !! NAME
308 : !! wfk_open_read
309 : !!
310 : !! FUNCTION
311 : !! Open the WFK file in read mode.
312 : !!
313 : !! INPUTS
314 : !! fname = Name of the file
315 : !! formeig = 0 for GS wavefunctions, 1 for RF wavefunctions.
316 : !! iomode = access mode
317 : !! funt = Fortran unit numer. Only used if iomode == IO_MODE_FORTRAN
318 : !! comm = MPI communicator (used for collective parallel IO)
319 : !!
320 : !! OUTPUT
321 : !! Wfk<class(wfk_t)> = WFK handler initialized and set in read mode
322 : !! [Hdr_out]=Copy of the abinit header
323 : !!
324 : !! NOTES TODO
325 : !! it would be better if formeig and iomode could be determined from the file itself!
326 : !! e.g iomode from the file extension, and formeig from whether it is WFK or 1WF
327 : !!
328 : !! SOURCE
329 :
330 9080 : subroutine wfk_open_read(Wfk, fname, formeig, iomode, funt, comm, Hdr_out)
331 :
332 : !Arguments ------------------------------------
333 : !scalars
334 : class(wfk_t),intent(inout) :: Wfk
335 : integer,intent(in) :: iomode,comm,formeig,funt
336 : character(len=*),intent(in) :: fname
337 : type(hdr_type),optional,intent(inout) :: Hdr_out ! should be intent(out), but psc miscompiles the call!
338 :
339 : !Local variables-------------------------------
340 : !scalars
341 : integer :: ierr,mpierr
342 : character(len=500) :: msg
343 : #ifdef HAVE_MPI_IO
344 : integer :: fform, nfrec !,ncerr
345 : integer(XMPI_OFFSET_KIND) :: offset
346 9080 : integer(XMPI_OFFSET_KIND),allocatable :: bsize_frecords(:)
347 : #endif
348 : !************************************************************************
349 :
350 : DBG_ENTER("COLL")
351 :
352 9080 : Wfk%comm = comm
353 9080 : Wfk%master = 0
354 18160 : Wfk%my_rank = xmpi_comm_rank(comm)
355 9080 : Wfk%nproc = xmpi_comm_size(comm)
356 :
357 : !Initialize the mandatory data of the Wfk datastructure
358 : !@wfk_t
359 9080 : Wfk%rw_mode = WFK_READMODE
360 9080 : Wfk%chunk_bsize = WFK_CHUNK_BSIZE
361 9080 : Wfk%fname = fname
362 :
363 : ! Master checks the existence of data file
364 9080 : if (wfk%my_rank == wfk%master) then
365 9048 : if (.not. file_exists(fname)) then
366 : ! Trick needed to run Abinit test suite in netcdf mode.
367 0 : if (file_exists(nctk_ncify(fname))) then
368 0 : write(std_out,"(3a)")"- File: ",trim(fname)," does not exist but found netcdf file with similar name."
369 0 : Wfk%fname = nctk_ncify(fname)
370 : end if
371 0 : if (.not. file_exists(Wfk%fname)) then
372 0 : ABI_ERROR('Missing data file: '//TRIM(Wfk%fname))
373 : end if
374 : end if
375 : end if
376 9080 : call xmpi_bcast(wfk%fname, wfk%master, comm, ierr)
377 :
378 : !TODO: owfk%get_mem_mb()
379 :
380 9080 : Wfk%formeig = formeig
381 9080 : Wfk%iomode = iomode
382 9080 : if (endswith(fname, ".nc")) wfk%iomode = IO_MODE_ETSF
383 : ! This to test the different versions.
384 : !wfk%iomode = IO_MODE_MPI
385 : !if (.not. endswith(fname, ".nc") .and. xmpi_comm_size == 1) wfk%iomode == IO_MODE_FORTRAN
386 :
387 : ! Reads fform and the Header.
388 9080 : call wfk%Hdr%from_fname(fname, wfk%fform,comm)
389 9080 : ABI_CHECK(Wfk%fform /= 0, "fform == 0")
390 :
391 9080 : if (Wfk%debug) call Wfk%Hdr%echo(Wfk%fform, 4, unit=std_out)
392 :
393 : ! Copy the header if required.
394 9080 : if (present(Hdr_out)) call Wfk%Hdr%copy(Hdr_out)
395 :
396 : ! Useful dimensions
397 432837 : Wfk%mband = MAXVAL(Wfk%Hdr%nband)
398 9080 : Wfk%nkpt = Wfk%Hdr%nkpt
399 9080 : Wfk%nsppol = Wfk%Hdr%nsppol
400 9080 : Wfk%nspinor = Wfk%Hdr%nspinor
401 :
402 36320 : ABI_MALLOC(Wfk%nband, (Wfk%nkpt,Wfk%nsppol))
403 470468 : Wfk%nband = RESHAPE(Wfk%Hdr%nband, (/Wfk%nkpt,Wfk%nsppol/))
404 :
405 9080 : ierr=0
406 9080 : select case (wfk%iomode)
407 : case (IO_MODE_FORTRAN)
408 : ! All processors see a local Fortran binary file.
409 : ! Each node opens the file, skip the header and set f90_fptr.
410 0 : Wfk%fh = funt
411 0 : if (open_file(Wfk%fname,msg,unit=Wfk%fh,form="unformatted", status="old", action="read") /= 0) then
412 0 : ABI_ERROR(msg)
413 : end if
414 :
415 : ! Precompute number of records for Fortran IO.
416 0 : call wfk_compute_offsets(Wfk)
417 :
418 0 : call hdr_skip(Wfk%fh,ierr)
419 0 : ABI_CHECK(ierr==0, "hdr_skip returned ierr! /= 0")
420 0 : Wfk%f90_fptr = [1,1,REC_NPW]
421 :
422 : #ifdef HAVE_MPI_IO
423 : case (IO_MODE_MPI)
424 0 : call MPI_FILE_OPEN(Wfk%comm, Wfk%fname, MPI_MODE_RDONLY, xmpio_info, Wfk%fh, mpierr)
425 0 : ABI_CHECK_MPI(mpierr, "MPI_FILE_OPEN")
426 : !call MPI_FILE_SET_VIEW(Wfk%fh,origin,MPI_BYTE,MPI_BYTE,'native',xmpio_info,mpierr)
427 :
428 0 : call hdr_mpio_skip(Wfk%fh,fform,Wfk%hdr_offset)
429 : ! Precompute offsets for MPI-IO access
430 0 : if (Wfk%hdr_offset > 0) then
431 0 : call wfk_compute_offsets(Wfk)
432 : else
433 0 : ABI_ERROR("hdr_offset <=0")
434 : end if
435 0 : if (Wfk%debug) then
436 : !print *, 'checking offsets upon open_read : ', trim(Wfk%fname)
437 0 : offset = Wfk%hdr_offset
438 0 : call hdr_bsize_frecords(Wfk%Hdr,Wfk%formeig,nfrec,bsize_frecords)
439 0 : call xmpio_check_frmarkers(Wfk%fh,offset,xmpio_collective,nfrec,bsize_frecords,ierr)
440 : end if
441 : #endif
442 :
443 : case (IO_MODE_ETSF)
444 9080 : NCF_CHECK(nctk_open_read(wfk%fh, wfk%fname, wfk%comm))
445 :
446 : case default
447 9080 : ABI_ERROR(sjoin('Wrong or unsupported iomode:', itoa(wfk%iomode)))
448 : end select
449 :
450 : DBG_EXIT("COLL")
451 :
452 27240 : end subroutine wfk_open_read
453 : !!***
454 :
455 : !----------------------------------------------------------------------
456 :
457 : !!****f* m_wfk/wfk_open_write
458 : !! NAME
459 : !! wfk_open_write
460 : !!
461 : !! FUNCTION
462 : !! Open the WFK file in write mode.
463 : !!
464 : !! INPUTS
465 : !! fname = Name of the file
466 : !! formeig = 0 for GS wavefunctions, 1 for RF wavefunctions.
467 : !! iomode = access mode
468 : !! funt = Fortran unit numer for Only used if iomode == IO_MODE_FORTRAN
469 : !! comm = MPI communicator (used for MPI-IO)
470 : !! [write_hdr]=True if the header should be written (default)
471 : !! [write_frm]=True if the fortran record markers should be written (default). Only if Fortran binary file.
472 : !!
473 : !! OUTPUT
474 : !! Wfk<class(wfk_t)> = WFK handler initialized and set in write mode
475 : !!
476 : !! SOURCE
477 :
478 1886 : subroutine wfk_open_write(Wfk, Hdr, fname, formeig, iomode, funt, comm, &
479 : write_hdr, write_frm) ! optional
480 :
481 : !Arguments ------------------------------------
482 : !scalars
483 : class(wfk_t),intent(out) :: Wfk
484 : type(hdr_type),intent(in) :: Hdr
485 : character(len=*),intent(in) :: fname
486 : integer,intent(in) :: iomode,comm,formeig,funt
487 : logical,optional,intent(in) :: write_hdr,write_frm
488 :
489 : !Local variables-------------------------------
490 : !scalars
491 : integer :: mpierr,ierr, hdroffset(1)
492 : real(dp) :: cpu,wall,gflops
493 : logical :: do_write_frm,do_write_hdr
494 : character(len=500) :: msg
495 : #ifdef HAVE_MPI_IO
496 : integer :: fform,nfrec,sc_mode
497 : integer(XMPI_OFFSET_KIND) :: offset
498 1886 : integer(XMPI_OFFSET_KIND),allocatable :: bsize_frecords(:)
499 : #endif
500 : integer :: ncerr
501 : !************************************************************************
502 :
503 : DBG_ENTER("COLL")
504 :
505 1886 : do_write_hdr = .TRUE.; if (present(write_hdr)) do_write_hdr = write_hdr
506 1886 : do_write_frm = .TRUE.; if (present(write_frm)) do_write_frm = write_frm
507 :
508 : !Initialize mandatory data of the Wfk datastructure
509 1886 : Wfk%rw_mode = WFK_WRITEMODE
510 1886 : Wfk%chunk_bsize = WFK_CHUNK_BSIZE
511 :
512 1886 : Wfk%fname = fname
513 1886 : Wfk%formeig = formeig
514 1886 : Wfk%iomode = iomode; if (endswith(fname, ".nc")) wfk%iomode = IO_MODE_ETSF
515 : ! This to test the different versions.
516 : !wfk%iomode = IO_MODE_MPI; if (.not. endswith(fname, ".nc") .and. xmpi_comm_size == 1) wfk%iomode == IO_MODE_FORTRAN
517 :
518 1886 : Wfk%comm = comm
519 1886 : Wfk%master = 0
520 1886 : Wfk%my_rank = xmpi_comm_rank(comm)
521 1886 : Wfk%nproc = xmpi_comm_size(comm)
522 1886 : Wfk%fform = 2
523 :
524 : ! Copy the header
525 1886 : call Hdr%copy(Wfk%Hdr)
526 :
527 : ! Master writes fform and the Header (write it afterwards if IO_MODE_ETSF)
528 1886 : if (Wfk%my_rank==Wfk%master .and. do_write_hdr .and. iomode /= IO_MODE_ETSF) then
529 5 : call Wfk%Hdr%write_to_fname(Wfk%fname, Wfk%fform)
530 5 : if (Wfk%debug) call Wfk%Hdr%echo(Wfk%fform, 4, unit=std_out)
531 : end if
532 1886 : call xmpi_barrier(Wfk%comm)
533 :
534 : ! Useful dimensions
535 118627 : Wfk%mband = MAXVAL(Wfk%Hdr%nband)
536 1886 : Wfk%nkpt = Wfk%Hdr%nkpt
537 1886 : Wfk%nsppol = Wfk%Hdr%nsppol
538 1886 : Wfk%nspinor = Wfk%Hdr%nspinor
539 :
540 7544 : ABI_MALLOC(Wfk%nband, (Wfk%nkpt,Wfk%nsppol))
541 126333 : Wfk%nband = RESHAPE(Wfk%Hdr%nband, [Wfk%nkpt, Wfk%nsppol])
542 :
543 1886 : ierr = 0
544 :
545 1886 : select case (wfk%iomode)
546 : case (IO_MODE_FORTRAN)
547 0 : ABI_CHECK(wfk%nproc == 1, "Cannot use Fortran-IO to write WFK file with nprocs > 1")
548 0 : Wfk%fh = funt
549 0 : if (open_file(Wfk%fname,msg,unit=Wfk%fh,form="unformatted", status="unknown", action="readwrite") /= 0) then
550 0 : ABI_ERROR(msg)
551 : end if
552 :
553 : ! Precompute number of records for Fortran IO.
554 0 : call wfk_compute_offsets(Wfk)
555 :
556 0 : call hdr_skip(Wfk%fh,ierr)
557 0 : Wfk%f90_fptr = [1, 1, REC_NPW]
558 :
559 : #ifdef HAVE_MPI_IO
560 : case (IO_MODE_MPI)
561 5 : call cwtime(cpu, wall, gflops, "start")
562 :
563 : ! FIXME: mode flags should be rationalized
564 : !call MPI_FILE_OPEN(Wfk%comm, Wfk%fname, MPI_MODE_CREATE + MPI_MODE_WRONLY, xmpio_info, Wfk%fh, mpierr)
565 : !call MPI_FILE_OPEN(Wfk%comm, Wfk%fname, MPI_MODE_CREATE + MPI_MODE_RDWR, xmpio_info, Wfk%fh, mpierr)
566 5 : call MPI_FILE_OPEN(Wfk%comm, Wfk%fname, MPI_MODE_RDWR, xmpio_info, Wfk%fh, mpierr)
567 5 : ABI_CHECK_MPI(mpierr, "MPI_FILE_OPEN")
568 :
569 : !call MPI_FILE_SET_VIEW(Wfk%fh,origin,MPI_BYTE,MPI_BYTE,'native',xmpio_info,mpierr)
570 : ! TODO
571 : !%% call MPI_File_set_size(Wfk%fh, MPI_Offset size, mpierr)
572 : !ABI_CHECK_MPI(mpierr, "MPI_FILE_SET_SIZE")
573 :
574 10 : hdroffset = -1
575 5 : if (Wfk%my_rank==Wfk%master) then
576 5 : call hdr_mpio_skip(Wfk%fh,fform,Wfk%hdr_offset)
577 5 : ABI_CHECK(fform == Wfk%fform,"fform != Wfk%fform")
578 : !call wfk%Hdr%echo(wfk%fform, 4, unit=std_out)
579 10 : hdroffset = Wfk%hdr_offset
580 : end if
581 5 : call xmpi_bcast(hdroffset, Wfk%master, Wfk%comm, ierr)
582 5 : Wfk%hdr_offset = hdroffset(1)
583 :
584 : ! Precompute offsets for MPI-IO access
585 5 : if (Wfk%hdr_offset > 0) then
586 5 : call wfk_compute_offsets(Wfk)
587 : else
588 0 : ABI_ERROR("hdr_offset <=0")
589 : end if
590 5 : call cwtime_report(" FILE_OPEN", cpu, wall, gflops)
591 :
592 : ! Write Fortran record markers.
593 5 : if (do_write_frm) then
594 5 : call cwtime(cpu, wall, gflops, "start")
595 5 : call hdr_bsize_frecords(Wfk%Hdr,Wfk%formeig,nfrec,bsize_frecords)
596 :
597 5 : sc_mode = xmpio_collective
598 5 : offset = Wfk%hdr_offset
599 :
600 5 : if (sc_mode == xmpio_collective) then
601 5 : call xmpio_write_frmarkers(Wfk%fh,offset,sc_mode,nfrec,bsize_frecords,ierr)
602 : else
603 : ierr = 0
604 : if (Wfk%my_rank == Wfk%master) then
605 : call xmpio_write_frmarkers(Wfk%fh,offset,xmpio_single,nfrec,bsize_frecords,ierr)
606 : end if
607 : end if
608 5 : ABI_CHECK(ierr == 0, "xmpio_write_frmarkers returned ierr!=0")
609 :
610 : !call MPI_FILE_SYNC(Wfk%fh,mpierr)
611 : !ABI_CHECK_MPI(mpierr, "FILE_SYNC")
612 :
613 5 : if (Wfk%debug) then
614 0 : call xmpio_check_frmarkers(Wfk%fh,offset,sc_mode,nfrec,bsize_frecords,ierr)
615 0 : ABI_CHECK(ierr == 0, "xmpio_check_frmarkers returned ierr!=0")
616 : end if
617 :
618 5 : ABI_FREE(bsize_frecords)
619 5 : call cwtime_report(" write_frmarkers", cpu, wall, gflops)
620 : end if
621 : #endif
622 :
623 : CASE (IO_MODE_ETSF)
624 : !NCF_CHECK(nctk_open_modify(wfk%fh, wfk%fname, wfk%comm))
625 :
626 1881 : if (nctk_has_mpiio) then
627 : #ifdef HAVE_NETCDF_MPI
628 : ncerr = nf90_create(wfk%fname, cmode=ior(ior(nf90_netcdf4, nf90_mpiio), nf90_write), &
629 1881 : comm=wfk%comm, info=xmpio_info, ncid=wfk%fh)
630 1881 : NCF_CHECK_MSG(ncerr, sjoin("nf90_create: ", wfk%fname))
631 : #else
632 : ABI_ERROR("You should not be here")
633 : #endif
634 : else
635 0 : if (wfk%nproc > 1) then
636 0 : ABI_ERROR("Your netcdf library does not support MPI-IO. Cannot write WFK file with nprocs > 1")
637 : end if
638 :
639 0 : ncerr = nf90_create(wfk%fname, nf90_write, wfk%fh)
640 0 : NCF_CHECK_MSG(ncerr, sjoin("nf90_create: ", wfk%fname))
641 : end if
642 :
643 1881 : call wfk_ncdef_dims_vars(wfk%fh, hdr, wfk%fform, write_hdr=.True.)
644 1881 : NCF_CHECK(nctk_def_basedims(wfk%fh))
645 :
646 : ! Switch to data mode.
647 1881 : NCF_CHECK(nctk_set_datamode(wfk%fh))
648 :
649 : case default
650 1891 : ABI_ERROR(sjoin('Wrong/unsupported iomode: ', itoa(wfk%iomode)))
651 : end select
652 :
653 : DBG_EXIT("COLL")
654 :
655 3772 : end subroutine wfk_open_write
656 : !!***
657 :
658 : !----------------------------------------------------------------------
659 :
660 : !!****f* m_wfk/wfk_close
661 : !! NAME
662 : !! wfk_close
663 : !!
664 : !! FUNCTION
665 : !! Close the wavefunction file handler and release the memory allocated
666 : !! Delete the file if `delete` is True. Default: False
667 : !!
668 : !! SOURCE
669 :
670 12406 : subroutine wfk_close(Wfk, delete)
671 :
672 : !Arguments ------------------------------------
673 : !scalars
674 : class(wfk_t),intent(inout) :: Wfk
675 : logical,optional,intent(in) :: delete
676 :
677 : !Local variables-------------------------------
678 : !scalars
679 : integer :: ierr
680 : !character(len=500) :: msg
681 : #ifdef HAVE_MPI_IO
682 : integer :: mpierr, nfrec
683 12406 : integer(XMPI_OFFSET_KIND),allocatable :: bsize_frecords(:)
684 : #endif
685 : ! *************************************************************************
686 :
687 : DBG_ENTER("COLL")
688 :
689 : ! Close the file only if it was open.
690 12406 : if (wfk%rw_mode /= WFK_NOMODE) then
691 10966 : Wfk%rw_mode = WFK_NOMODE
692 :
693 10966 : select case (Wfk%iomode)
694 : case (IO_MODE_FORTRAN)
695 0 : close(wfk%fh)
696 :
697 : #ifdef HAVE_MPI_IO
698 : case (IO_MODE_MPI)
699 5 : call MPI_FILE_CLOSE(Wfk%fh, mpierr)
700 5 : ABI_CHECK_MPI(mpierr, "FILE_CLOSE!")
701 :
702 5 : if (Wfk%debug .and. Wfk%my_rank == Wfk%master) then
703 : ! Check the fortran records.
704 0 : call MPI_FILE_OPEN(xmpi_comm_self, Wfk%fname, MPI_MODE_RDONLY, xmpio_info, Wfk%fh, mpierr)
705 0 : ABI_CHECK_MPI(mpierr, "MPI_FILE_OPEN")
706 0 : call hdr_bsize_frecords(Wfk%Hdr,Wfk%formeig,nfrec,bsize_frecords)
707 0 : call xmpio_check_frmarkers(Wfk%fh,Wfk%hdr_offset,xmpio_single,nfrec,bsize_frecords,ierr)
708 0 : ABI_CHECK(ierr==0,"xmpio_check_frmarkers returned ierr!=0")
709 0 : ABI_FREE(bsize_frecords)
710 0 : call MPI_FILE_CLOSE(Wfk%fh,mpierr)
711 0 : ABI_CHECK_MPI(mpierr, "FILE_CLOSE!")
712 : end if
713 : #endif
714 :
715 : case (IO_MODE_ETSF)
716 : !NCF_CHECK(nf90_sync(wfk%fh))
717 10961 : NCF_CHECK(nf90_close(wfk%fh))
718 :
719 : case default
720 10966 : ABI_ERROR(sjoin('Wrong/unsupported value of iomode: ', itoa(Wfk%iomode)))
721 : end select
722 : end if
723 :
724 : ! Free memory.
725 12406 : call Wfk%Hdr%free()
726 :
727 12406 : ABI_SFREE(Wfk%nband)
728 12406 : ABI_SFREE(Wfk%recn_ks)
729 12406 : ABI_SFREE(Wfk%offset_ks)
730 :
731 12406 : if (present(delete)) then
732 0 : if (delete) call delete_file(wfk%fname, ierr)
733 : end if
734 :
735 : DBG_EXIT("COLL")
736 :
737 12406 : end subroutine wfk_close
738 : !!***
739 :
740 : !----------------------------------------------------------------------
741 :
742 : !!****f* m_wfk/wfk_print
743 : !! NAME
744 : !! wfk_print
745 : !!
746 : !! FUNCTION
747 : !! Print information on the object.
748 : !!
749 : !! INPUTS
750 : !! wfk<class(wfk_t)> = WFK handler
751 : !! [header]=String to be printed as header for additional info.
752 : !! [unit]=Unit number for output. Defaults to std_out
753 : !! [prtvol]=Verbosity level
754 : !!
755 : !! SOURCE
756 :
757 0 : subroutine wfk_print(wfk,unit,header,prtvol)
758 :
759 : !Arguments ------------------------------------
760 : !scalars
761 : class(wfk_t),intent(inout) :: wfk
762 : integer,optional,intent(in) :: unit,prtvol
763 : character(len=*),optional,intent(in) :: header
764 :
765 : !Local variables-------------------------------
766 : integer,parameter :: rdwr4=4
767 : integer :: my_unt,my_prtvol
768 : character(len=500) :: msg
769 : ! *************************************************************************
770 :
771 0 : my_unt = std_out; if (present(unit)) my_unt = unit
772 0 : my_prtvol = 0; if (present(prtvol)) my_prtvol = prtvol
773 :
774 0 : msg=' ==== Info on the wfk_t object ==== '
775 0 : if (present(header)) msg=' ==== '//trim(adjustl(header))//' ==== '
776 0 : call wrtout(my_unt,msg)
777 0 : call wrtout(my_unt, sjoin(" iomode = ",itoa(wfk%iomode)))
778 :
779 0 : call wfk%hdr%echo(wfk%fform, rdwr4 ,unit=my_unt)
780 :
781 0 : end subroutine wfk_print
782 : !!***
783 :
784 : !----------------------------------------------------------------------
785 :
786 : !!****f* m_wfk/wfk_validate_ks
787 : !! NAME
788 : !! wfk_validate_ks
789 : !!
790 : !! FUNCTION
791 : !! Validate the k-point, the spin index and, optionally, the band index.
792 : !! Return non-zero value if error.
793 : !!
794 : !! INPUTS
795 : !! wfk<class(wfk_t)> = WFK handler
796 : !! ik_ibz=k-point index.
797 : !! spin=Spin index.
798 : !! [band]=Band index.
799 : !!
800 : !! SOURCE
801 :
802 2148130 : integer function wfk_validate_ks(wfk, ik_ibz, spin, band) result(ierr)
803 :
804 : !Arguments ------------------------------------
805 : !scalars
806 : integer,intent(in) :: ik_ibz, spin
807 : integer,optional,intent(in) :: band
808 : class(wfk_t),intent(in) :: wfk
809 :
810 : !Local variables-------------------------------
811 : !scalars
812 : character(len=500) :: msg
813 : ! *************************************************************************
814 2148130 : ierr = 0
815 :
816 2148130 : if (ik_ibz <= 0 .or. ik_ibz > wfk%nkpt) then
817 0 : ierr = ierr + 1
818 0 : write(msg, '(2(a,i0))')'ik_ibz = ',ik_ibz,' whereas it should be between 1 and ',wfk%nkpt
819 0 : ABI_WARNING(msg)
820 : end if
821 :
822 2148130 : if (spin <= 0 .or. spin > wfk%nsppol) then
823 0 : ierr = ierr + 1
824 0 : write(msg, '(2(a,i0))')'spin = ',spin,' whereas it should be between 1 and ',wfk%nsppol
825 0 : ABI_WARNING(msg)
826 : end if
827 :
828 2148130 : if (present(band)) then
829 1091555 : if (band <=0) then
830 0 : ierr = ierr + 1
831 0 : ABI_WARNING(sjoin('Negative band index: band = ',itoa(band)))
832 : end if
833 :
834 : ! Don't touch nband array if wrong indices.
835 1091555 : if (spin > 0 .and. spin <= wfk%nsppol .and. ik_ibz > 0 .and. ik_ibz <= wfk%nkpt) then
836 1091555 : if (band > wfk%nband(ik_ibz, spin)) then
837 0 : ierr = ierr + 1
838 0 : write(msg, '(2(a,i0))')'band = ',band,' whereas it should be between 1 and ',wfk%nband(ik_ibz,spin)
839 0 : ABI_WARNING(msg)
840 : end if
841 : end if
842 : end if
843 :
844 : !if (ierr /= 0) then
845 : ! ABI_ERROR("Wrong (ik_ibz, spin) args, Aborting now")
846 : !end if
847 :
848 2148130 : end function wfk_validate_ks
849 : !!***
850 :
851 : !----------------------------------------------------------------------
852 :
853 : !!****f* m_wfk/wfk_findk
854 : !! NAME
855 : !! wfk_findk
856 : !!
857 : !! FUNCTION
858 : !! Find the index of the k-point in the WKF file. umklapp vectors are not allowed.
859 : !! Return -1 if not found.
860 : !!
861 : !! INPUTS
862 : !! wfk<class(wfk_t)> = WFK handler initialized and set in read mode
863 : !! kpt(3)=k-point in reduced coordinates.
864 : !! [ktol]=Optional tolerance for k-point comparison.
865 : !! For each reduced direction the absolute difference between the coordinates must be less that ktol
866 : !!
867 : !! SOURCE
868 :
869 568487 : integer pure function wfk_findk(wfk, kpt, ktol) result(ikpt)
870 :
871 : !Arguments ------------------------------------
872 : !scalars
873 : real(dp),optional,intent(in) :: ktol
874 : class(wfk_t),intent(in) :: wfk
875 : !arrays
876 : real(dp),intent(in) :: kpt(3)
877 :
878 : !Local variables-------------------------------
879 : !scalars
880 : integer :: ik
881 : real(dp) :: my_ktol
882 : ! *************************************************************************
883 :
884 568487 : my_ktol = 0.0001_dp; if (present(ktol)) my_ktol = ktol
885 :
886 : !TODO: replace with krank type and routines, probably save mapping on init of the wfk object
887 568487 : ikpt = -1
888 71146059 : do ik=1,wfk%hdr%nkpt
889 81191462 : if (all(abs(wfk%hdr%kptns(:, ik) - kpt) < my_ktol)) then
890 : ikpt = ik; exit
891 : end if
892 : end do
893 :
894 568487 : end function wfk_findk
895 : !!***
896 :
897 : !----------------------------------------------------------------------
898 :
899 : !!****f* m_wfk/wfk_ncdef_dims_vars
900 : !! NAME
901 : !! wfk_ncdef_dims_vars
902 : !!
903 : !! FUNCTION
904 : !! Write the heeder, fform as well as the etsf-io dimensions and variables.
905 : !!
906 : !! INPUTS
907 : !! ncid=netcdf file handler.
908 : !! hdr<hdr_tyep>=Abinit header
909 : !! fform=File type format of the header
910 : !! [write_hdr]=True if the header should be written (default)
911 : !! [iskss]=True if this is a KSS file (activate kdependent=No)
912 : !!
913 : !! SOURCE
914 :
915 4561 : subroutine wfk_ncdef_dims_vars(ncid, hdr, fform, write_hdr, iskss)
916 :
917 : !Arguments ------------------------------------
918 : !scalars
919 : integer,intent(in) :: ncid,fform
920 : type(hdr_type),intent(in) :: hdr
921 : logical,optional,intent(in) :: write_hdr,iskss
922 :
923 : !Local variables-------------------------------
924 : !scalars
925 : character(len=500) :: title,history
926 : logical :: do_write_hdr,my_iskss
927 : integer :: ivar,mpw,ncerr
928 : ! *************************************************************************
929 :
930 4561 : do_write_hdr = .True.; if (present(write_hdr)) do_write_hdr = write_hdr
931 4561 : my_iskss = .False.; if (present(iskss)) my_iskss = iskss
932 4561 : if (do_write_hdr) then
933 4561 : NCF_CHECK(hdr%ncwrite(ncid, fform, nc_define=.True.))
934 : end if
935 :
936 : ! Add the etsf header.
937 4561 : title = sjoin("WFK file generated by Abinit, version: ", abinit_version)
938 4561 : if (my_iskss) title = sjoin("KSS file generated by Abinit, version: ", abinit_version)
939 4561 : history = sjoin("Generated on: ", asctime())
940 4561 : NCF_CHECK(nctk_add_etsf_header(ncid, title=title, history=history))
941 :
942 152942 : mpw = MAXVAL(hdr%npwarr)
943 : ncerr = nctk_def_dims(ncid, [&
944 13683 : nctkdim_t("real_or_complex_coefficients", 2), nctkdim_t("max_number_of_coefficients", mpw)])
945 4561 : NCF_CHECK(ncerr)
946 :
947 : ! Define kg_k
948 : ncerr = nctk_def_arrays(ncid, [&
949 : nctkarr_t("reduced_coordinates_of_plane_waves", "int", &
950 : "number_of_reduced_dimensions, max_number_of_coefficients, number_of_kpoints")&
951 9122 : ])
952 4561 : NCF_CHECK(ncerr)
953 :
954 4561 : NCF_CHECK(nf90_inq_varid(ncid, "reduced_coordinates_of_plane_waves", ivar))
955 4561 : if (my_iskss) then
956 3 : NCF_CHECK(nf90_put_att(ncid, ivar, "k_dependent", "no"))
957 : else
958 4558 : NCF_CHECK(nf90_put_att(ncid, ivar, "k_dependent", "yes"))
959 : end if
960 :
961 : ncerr = nctk_def_arrays(ncid, [&
962 : nctkarr_t("eigenvalues", "dp", "max_number_of_states, number_of_kpoints, number_of_spins") &
963 9122 : ])
964 4561 : NCF_CHECK(ncerr)
965 4561 : NCF_CHECK(nctk_set_atomic_units(ncid, "eigenvalues"))
966 :
967 : ncerr = nctk_def_arrays(ncid, [&
968 : nctkarr_t("h1_matrix_elements", "dp", "two, max_number_of_states, max_number_of_states, number_of_kpoints, number_of_spins") &
969 9122 : ])
970 4561 : NCF_CHECK(ncerr)
971 4561 : NCF_CHECK(nctk_set_atomic_units(ncid, "h1_matrix_elements"))
972 :
973 : ncerr = nctk_def_arrays(ncid, nctkarr_t("coefficients_of_wavefunctions", "dp", &
974 : "real_or_complex_coefficients, max_number_of_coefficients, number_of_spinor_components, &
975 4561 : &max_number_of_states, number_of_kpoints, number_of_spins"))
976 4561 : NCF_CHECK(ncerr)
977 :
978 : !NF90_DEF_VAR_FILL(INTEGER NCID, INTEGER VARID, INTEGER NO_FILL, FILL_VALUE)
979 : !NCF_CHECK(nf90_inq_varid(ncid, "coefficients_of_wavefunctions", ivar))
980 : !NCF_CHECK(nf90_def_var_fill(ncid, ivar, 0, -one))
981 :
982 4561 : end subroutine wfk_ncdef_dims_vars
983 : !!***
984 :
985 : !----------------------------------------------------------------------
986 :
987 : !!****f* m_wfk/wfk_compare
988 : !! NAME
989 : !! wfk_compare
990 : !!
991 : !! FUNCTION
992 : !! Test two wfk_t objects for consistency. Return non-zero value if test fails.
993 : !!
994 : !! INPUTS
995 : !! wfk1, wfk2 <class(wfk_t)> = WFK handlers to be compared
996 : !!
997 : !! OUTPUT
998 : !! ierr
999 : !!
1000 : !! SOURCE
1001 :
1002 20 : integer function wfk_compare(wfk1, wfk2) result(ierr)
1003 :
1004 : !Arguments ------------------------------------
1005 : !scalars
1006 : class(wfk_t),intent(in) :: wfk1, wfk2
1007 :
1008 : !Local variables-------------------------------
1009 : !scalars
1010 : integer :: restart,restartpaw
1011 : !character(len=500) :: msg
1012 : !************************************************************************
1013 :
1014 20 : ierr = 0
1015 :
1016 20 : ierr=wfk1%hdr%compare(wfk2%hdr)
1017 :
1018 : ! Test basic dimensions
1019 : !if (wfk1%hdr%nsppol /= wfk2%hdr%nsppol) then
1020 : ! ierr = ierr + 1; ABI_WARNING("Different nsppol")
1021 : !end if
1022 : !if (wfk1%hdr%nspinor /= wfk2%hdr%nspinor) then
1023 : ! ierr = ierr + 1; ABI_WARNING("Different nspinor")
1024 : !end if
1025 : !if (wfk1%hdr%nspden /= wfk2%hdr%nspden) then
1026 : ! ierr = ierr + 1; ABI_WARNING("Different nspden")
1027 : !end if
1028 : !if (wfk1%hdr%nkpt /= wfk2%hdr%nkpt) then
1029 : ! ierr = ierr + 1; ABI_WARNING("Different nkpt")
1030 : !end if
1031 20 : if (wfk1%formeig /= wfk2%formeig) then
1032 0 : ierr = ierr + 1; ABI_WARNING("Different formeig")
1033 : end if
1034 : !if (wfk1%hdr%usepaw /= wfk2%hdr%usepaw) then
1035 : ! ierr = ierr + 1; ABI_WARNING("Different usepaw")
1036 : !end if
1037 : !if (wfk1%hdr%ntypat /= wfk2%hdr%ntypat) then
1038 : ! ierr = ierr + 1; ABI_WARNING("Different ntypat")
1039 : !end if
1040 : !if (wfk1%hdr%natom /= wfk2%hdr%natom) then
1041 : ! ierr = ierr + 1; ABI_WARNING("Different natom")
1042 : !end if
1043 : !if (wfk1%hdr%fform /= wfk2%hdr%fform) then
1044 : ! ierr = ierr + 1; ABI_WARNING("Different fform")
1045 : !end if
1046 :
1047 : ! Return immediately if important dimensions are not equal.
1048 20 : if (ierr /= 0) return
1049 :
1050 : ! Test important arrays (rprimd is not tested)
1051 : !if (any(wfk1%hdr%typat /= wfk2%hdr%typat)) then
1052 : ! ierr = ierr + 1; ABI_WARNING("Different typat")
1053 : !end if
1054 : !if (any(wfk1%hdr%npwarr /= wfk2%hdr%npwarr)) then
1055 : ! ierr = ierr + 1; ABI_WARNING("Different npwarr array")
1056 : !end if
1057 1694 : if (any(wfk1%nband /= wfk2%nband)) then
1058 0 : ierr = ierr + 1; ABI_WARNING("Different nband array")
1059 : end if
1060 : !if (any(abs(wfk1%hdr%kptns - wfk2%hdr%kptns) > tol6)) then
1061 : ! ierr = ierr + 1; ABI_WARNING("Different kptns array")
1062 : !end if
1063 :
1064 : ! Call hdr_check to get a nice diff of the header but don't check restart and restartpaw.
1065 20 : call hdr_check(wfk1%fform,wfk2%fform,wfk1%hdr,wfk2%hdr,"PERS",restart,restartpaw)
1066 :
1067 20 : end function wfk_compare
1068 : !!***
1069 : !----------------------------------------------------------------------
1070 :
1071 : !!****f* m_wfk/wfk_read_band_block
1072 : !! NAME
1073 : !! wfk_read_band_block
1074 : !!
1075 : !! FUNCTION
1076 : !! Read a block of contiguous bands at a given (k-point, spin)
1077 : !!
1078 : !! INPUTS
1079 : !! Wfk<class(wfk_t)>= WFK file handler object.
1080 : !! band_block(2)=Initial and final band index.
1081 : !! ik_ibz=Index of the k-point in the IBZ.
1082 : !! spin=Spin index
1083 : !! sc_mode= MPI-IO option
1084 : !! xmpio_single ==> for reading by current proc.
1085 : !! xmpio_collective ==> for collective reading in wfk%comm (use it wisely!)
1086 : !!
1087 : !! OUTPUTS
1088 : !! [kg_k=(:,:)] = G-vectors
1089 : !! [eig_k(:)] = Eigenvectors
1090 : !! [cg_k(:,:)] = Fourier coefficients
1091 : !!
1092 : !! NOTES
1093 : !! The output arrays eig_k and occ_k contain the *full* set of eigenvalues and occupation
1094 : !! factors stored in the file and are dimensioned with wfk%mband.
1095 : !!
1096 : !! SOURCE
1097 :
1098 1056575 : subroutine wfk_read_band_block(Wfk, band_block, ik_ibz, spin, sc_mode, &
1099 1145811 : kg_k, cg_k, eig_k, occ_k) ! Optional
1100 :
1101 : !Arguments ------------------------------------
1102 : !scalars
1103 : integer,intent(in) :: ik_ibz,spin,sc_mode
1104 : class(wfk_t),intent(inout) :: Wfk
1105 : !arrays
1106 : integer,intent(in) :: band_block(2)
1107 : integer,intent(out), DEV_CONTARRD optional :: kg_k(:,:) ! (3,npw_k)
1108 : real(dp),intent(out), DEV_CONTARRD optional :: cg_k(:,:) ! (2,npw_k*nspinor*nband)
1109 : real(dp),intent(inout),optional :: eig_k((2*Wfk%mband)**Wfk%formeig*Wfk%mband)
1110 : real(dp),intent(out),optional :: occ_k(Wfk%mband)
1111 :
1112 : !Local variables-------------------------------
1113 : !scalars
1114 : integer :: ierr,npw_disk,nspinor_disk,nband_disk,band
1115 : integer :: nband_disk_keep
1116 : integer :: ipw,my_bcount,npwso,npw_tot_disk,nb_block,base
1117 : integer :: npw_read,nspinor_read,nband_read
1118 : character(len=500) :: msg,errmsg
1119 : !arrays
1120 1056575 : real(dp),contiguous, pointer :: tmp_eigk(:),tmp_occk(:)
1121 : #ifdef HAVE_MPI_IO
1122 : integer :: mpierr,bufsz,gkk_type,cgblock_type
1123 : integer(XMPI_OFFSET_KIND) :: my_offset,my_offpad
1124 : integer :: sizes(2),subsizes(2),starts(2),types(2)
1125 : #endif
1126 : integer :: kg_varid,eig_varid,occ_varid,cg_varid,ncerr,h1_varid,idx,ib1,ib2
1127 1056575 : real(dp),allocatable :: h1mat(:,:,:)
1128 : !************************************************************************
1129 :
1130 : DBG_ENTER("COLL")
1131 :
1132 0 : ABI_CHECK_IEQ(Wfk%rw_mode, WFK_READMODE, "Wfk must be in READMODE")
1133 :
1134 1056575 : if (wfk_validate_ks(wfk, ik_ibz, spin) /= 0) then
1135 0 : ABI_ERROR("Wrong (ik_ibz, spin) args, Aborting now")
1136 : end if
1137 :
1138 : ! Look before you leap.
1139 1056575 : npw_disk = Wfk%Hdr%npwarr(ik_ibz)
1140 1056575 : nspinor_disk = Wfk%nspinor
1141 :
1142 1056575 : nband_disk = Wfk%nband(ik_ibz,spin)
1143 : ! there are several cases here, reading in fewer than mband bands,
1144 : ! or possibly more than you have allocated, and truncating
1145 : ! nband_disk_keep could be used to distinguish these cases
1146 1056575 : nband_disk_keep = nband_disk
1147 1056575 : if (present(occ_k)) then
1148 89236 : nband_disk_keep = min(nband_disk, size(occ_k))
1149 : end if
1150 1056575 : if (present(eig_k)) then
1151 214379 : if (Wfk%formeig == 0) then
1152 105383 : nband_disk_keep = min(nband_disk_keep, size(eig_k))
1153 108996 : else if (Wfk%formeig == 1) then
1154 108996 : nband_disk_keep = min(nband_disk_keep, int(sqrt(size(eig_k)/two)))
1155 : end if
1156 : end if
1157 :
1158 1056575 : nb_block = (band_block(2) - band_block(1) + 1)
1159 1056575 : ABI_CHECK(nb_block > 0, "nband <=0")
1160 1056575 : npw_tot_disk = npw_disk * nspinor_disk * nb_block
1161 :
1162 1056575 : if (present(kg_k)) then
1163 93004 : ABI_CHECK(SIZE(kg_k,DIM=2) >= npw_disk,"kg_k too small")
1164 72356188 : kg_k = zero
1165 : end if
1166 1056575 : if (present(cg_k)) then
1167 1010769 : ABI_CHECK(SIZE(cg_k, DIM=2) >= npw_tot_disk,"cg_k too small")
1168 1049908716 : cg_k = zero
1169 : end if
1170 :
1171 1056575 : if (present(eig_k)) then
1172 214379 : if (Wfk%formeig==0) then
1173 105383 : ABI_CHECK(SIZE(eig_k) >= nband_disk, "GS eig_k too small")
1174 108996 : else if (Wfk%formeig==1) then
1175 108996 : ABI_CHECK(SIZE(eig_k) >= 2*nband_disk**2, "DFPT eig_k too small")
1176 : else
1177 0 : ABI_ERROR("formeig != [0,1]")
1178 : end if
1179 : end if
1180 :
1181 1056575 : if (present(occ_k)) then
1182 : !ABI_CHECK(SIZE(occ_k) <= nband_disk, "GS occ_k too large, not enough data on disk")
1183 89236 : if (Wfk%formeig==1) then
1184 0 : ABI_ERROR("occ_k cannot be used when formeig ==1")
1185 : end if
1186 : end if
1187 :
1188 1056575 : select case (Wfk%iomode)
1189 : case (IO_MODE_FORTRAN)
1190 :
1191 : ! Rewind the file to have the correct (k,s) block (if needed)
1192 0 : call wfk_seek(Wfk,ik_ibz,spin)
1193 : !
1194 : ! Read the first record: npw, nspinor, nband_disk
1195 0 : read(Wfk%fh, err=10, iomsg=errmsg) npw_read, nspinor_read, nband_read
1196 :
1197 0 : if (any( [npw_read, nspinor_read, nband_read] /= [npw_disk, nspinor_disk, nband_disk])) then
1198 0 : write(msg,"(a,6(i0,2x))")"Mismatch between (npw, nspinor, nband) read from WFK and those found in HDR ",&
1199 0 : npw_read, nspinor_read, nband_read, npw_disk, nspinor_disk, nband_disk
1200 0 : ABI_ERROR(msg)
1201 : end if
1202 :
1203 : ! The second record: (k+G) vectors
1204 0 : if (present(kg_k)) then
1205 0 : read(Wfk%fh, err=10, iomsg=errmsg) kg_k(1:3,1:npw_disk)
1206 : else
1207 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! kg_k(1:3,1:npw_disk)
1208 : end if
1209 :
1210 0 : select case (Wfk%formeig)
1211 : case (0)
1212 : ! The third record: eigenvalues and occupation factors.
1213 : ! write(unitwf) (eigen(iband),iband=1,nband_disk),(occ(iband),iband=1,nband_disk)
1214 0 : if (present(eig_k) .or. present(occ_k)) then
1215 0 : ABI_MALLOC(tmp_eigk, (nband_disk))
1216 0 : ABI_MALLOC(tmp_occk, (nband_disk))
1217 :
1218 0 : read(Wfk%fh, err=10, iomsg=errmsg) tmp_eigk, tmp_occk
1219 :
1220 0 : if (present(eig_k)) then
1221 0 : eig_k = zero
1222 0 : eig_k(1:nband_disk_keep) = tmp_eigk(1:nband_disk_keep)
1223 : end if
1224 0 : if (present(occ_k)) then
1225 0 : occ_k = zero
1226 0 : occ_k(1:nband_disk_keep) = tmp_occk(1:nband_disk_keep)
1227 : end if
1228 :
1229 0 : ABI_FREE(tmp_eigk)
1230 0 : ABI_FREE(tmp_occk)
1231 :
1232 : else
1233 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! eig_k(1:nband_disk), occ_k(1:nband_k)
1234 : end if
1235 :
1236 : ! Fourth record with the wave-functions.
1237 0 : if (present(cg_k)) then
1238 : npwso = npw_disk*nspinor_disk
1239 : my_bcount = 0
1240 0 : do band=1,nband_disk
1241 0 : if (band >= band_block(1) .and. band <= band_block(2)) then
1242 0 : ipw = my_bcount * npwso
1243 0 : my_bcount = my_bcount + 1
1244 0 : read(Wfk%fh, err=10, iomsg=errmsg) cg_k(1:2,ipw+1:ipw+npwso)
1245 : else
1246 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! cg_k(1:2,ipw+1:ipw+npwso)
1247 : end if
1248 : end do
1249 :
1250 : else
1251 0 : do band=1,nband_disk
1252 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! cg_k(1:2,ipw+1:ipw+npwso)
1253 : end do
1254 : end if
1255 :
1256 : case (1)
1257 : ! formeig 1 for DFPT WF file
1258 : npwso = npw_disk*nspinor_disk
1259 : my_bcount = 0
1260 0 : do band=1,nband_disk
1261 :
1262 0 : if (present(eig_k)) then
1263 : ! Read column matrix of size (2*nband_k)
1264 0 : base = 2*(band-1)*nband_disk
1265 0 : read(Wfk%fh, err=10, iomsg=errmsg) eig_k(base+1:base+2*nband_disk)
1266 : else
1267 0 : read(Wfk%fh, err=10, iomsg=errmsg ) ! eig_k(2*nband_disk)
1268 : end if
1269 :
1270 0 : if (present(cg_k) .and. (band >= band_block(1) .and. band <= band_block(2)) ) then
1271 0 : ipw = my_bcount * npwso
1272 0 : my_bcount = my_bcount + 1
1273 0 : read(Wfk%fh, err=10, iomsg=errmsg) cg_k(1:2,ipw+1:ipw+npwso)
1274 : else
1275 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! cg_k(1:2,ipw+1:ipw+npwso)
1276 : end if
1277 : end do
1278 :
1279 : case default
1280 0 : ABI_ERROR("formeig != [0,1]")
1281 : end select
1282 :
1283 : ! Reached the end of the (k,s) block. Update f90_fptr
1284 0 : if (ik_ibz < Wfk%nkpt) then
1285 0 : Wfk%f90_fptr = [ik_ibz+1,spin,REC_NPW]
1286 : else
1287 0 : ABI_CHECK(ik_ibz == wfk%nkpt, "ik_ibz != nkpt")
1288 0 : if (spin==Wfk%nsppol) then
1289 0 : Wfk%f90_fptr = FPTR_EOF ! EOF condition
1290 : else
1291 0 : Wfk%f90_fptr = [1,spin+1,REC_NPW]
1292 : end if
1293 : end if
1294 :
1295 : #ifdef HAVE_MPI_IO
1296 : case (IO_MODE_MPI)
1297 0 : if (present(kg_k)) then
1298 0 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_KG) + xmpio_bsize_frm
1299 :
1300 0 : call mpio_read_kg_k(Wfk%fh,my_offset,npw_disk,sc_mode,kg_k,mpierr)
1301 0 : ABI_CHECK_MPI(mpierr, "reading kg")
1302 : end if
1303 :
1304 : ! formeig=0 => Read both eig and occ in tmp_eigk
1305 : ! formeig=1 => Read (nband_k,nband_k) matrix of complex numbers.
1306 1056575 : select case (Wfk%formeig)
1307 : case (0)
1308 0 : if (present(eig_k) .or. present(occ_k)) then
1309 0 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_EIG) + xmpio_bsize_frm
1310 :
1311 0 : call mpio_read_eigocc_k(Wfk%fh,my_offset,nband_disk,Wfk%formeig,sc_mode,tmp_eigk,mpierr)
1312 0 : ABI_CHECK_MPI(mpierr, "reading eigocc")
1313 :
1314 0 : if (present(eig_k)) then
1315 0 : eig_k(1:nband_disk_keep) = tmp_eigk(1:nband_disk_keep)
1316 : end if
1317 0 : if (present(occ_k)) then
1318 0 : occ_k(1:nband_disk_keep) = tmp_eigk(nband_disk+1:nband_disk+nband_disk_keep)
1319 : end if
1320 :
1321 0 : ABI_FREE(tmp_eigk)
1322 : end if
1323 :
1324 0 : if (present(cg_k)) then
1325 0 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_CG)
1326 0 : sizes = [npw_disk*nspinor_disk, nband_disk]
1327 0 : subsizes = [npw_disk*nspinor_disk, band_block(2)-band_block(1)+1]
1328 0 : bufsz = 2 * npw_disk * nspinor_disk * nb_block
1329 0 : starts = [1, band_block(1)]
1330 :
1331 : call mpiotk_read_fsuba_dp2D(Wfk%fh,my_offset,sizes,subsizes,starts,bufsz,cg_k,&
1332 0 : wfk%chunk_bsize,sc_mode,Wfk%comm,ierr)
1333 0 : ABI_CHECK(ierr==0,"Fortran record too big")
1334 : end if
1335 :
1336 : case (1)
1337 0 : if (present(eig_k)) then
1338 0 : sizes = [nband_disk, npw_disk*nspinor_disk]
1339 0 : types = [MPI_DOUBLE_COMPLEX, MPI_DOUBLE_COMPLEX]
1340 :
1341 0 : call xmpio_create_fstripes(nband_disk,sizes,types,gkk_type,my_offpad,mpierr)
1342 0 : ABI_CHECK_MPI(mpierr, "xmpio_create_fstripes")
1343 :
1344 0 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_EIG) + my_offpad
1345 :
1346 0 : call MPI_FILE_SET_VIEW(Wfk%fh,my_offset,MPI_BYTE,gkk_type,'native',xmpio_info,mpierr)
1347 0 : ABI_CHECK_MPI(mpierr, "SET_VIEW")
1348 0 : call MPI_TYPE_FREE(gkk_type,mpierr)
1349 0 : ABI_CHECK_MPI(mpierr, "TYPE_FREE")
1350 :
1351 0 : bufsz = nband_disk**2
1352 :
1353 0 : if (sc_mode==xmpio_collective) then
1354 0 : call MPI_FILE_READ_ALL(Wfk%fh,eig_k,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1355 0 : else if (sc_mode==xmpio_single) then
1356 0 : call MPI_FILE_READ(Wfk%fh,eig_k,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1357 : else
1358 0 : ABI_ERROR("Wrong sc_mode")
1359 : end if
1360 0 : ABI_CHECK_MPI(mpierr, "FILE_READ")
1361 : end if
1362 :
1363 0 : if (present(cg_k)) then
1364 0 : types = [MPI_DOUBLE_COMPLEX, MPI_DOUBLE_COMPLEX]
1365 0 : sizes = [npw_disk*nspinor_disk, nband_disk]
1366 :
1367 0 : call xmpio_create_fstripes(nb_block,sizes,types,cgblock_type,my_offpad,mpierr)
1368 0 : ABI_CHECK_MPI(mpierr, "xmpio_create_fstripes")
1369 :
1370 : ! Increment my_offset to account for previous eigen and cg records if band_block(1) != 1
1371 0 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_CG) + my_offpad
1372 : my_offset = my_offset + (band_block(1) - 1) * ( &
1373 : (2*npw_disk*wfk%nspinor*xmpi_bsize_dp + 2*xmpio_bsize_frm) + &
1374 0 : (2*nband_disk*xmpi_bsize_dp + 2*xmpio_bsize_frm) )
1375 :
1376 0 : call MPI_FILE_SET_VIEW(Wfk%fh,my_offset,MPI_BYTE,cgblock_type,'native',xmpio_info,mpierr)
1377 0 : ABI_CHECK_MPI(mpierr, "SET_VIEW")
1378 :
1379 0 : call MPI_TYPE_FREE(cgblock_type,mpierr)
1380 0 : ABI_CHECK_MPI(mpierr, "TYPE_FREE")
1381 :
1382 0 : bufsz = npw_disk * nspinor_disk * nb_block
1383 :
1384 0 : if (sc_mode==xmpio_collective) then
1385 0 : call MPI_FILE_READ_ALL(Wfk%fh,cg_k,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1386 0 : else if (sc_mode==xmpio_single) then
1387 0 : call MPI_FILE_READ(Wfk%fh,cg_k,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1388 : else
1389 0 : ABI_ERROR("Wrong sc_mode")
1390 : end if
1391 0 : ABI_CHECK_MPI(mpierr, "FILE_READ")
1392 : end if
1393 :
1394 : case default
1395 0 : ABI_ERROR("formeig != [0,1]")
1396 : end select
1397 : #endif
1398 :
1399 : case (IO_MODE_ETSF)
1400 1056575 : if (present(kg_k)) then
1401 : ! Read the reduced_coordinates_of_plane_waves for this k point.
1402 93004 : NCF_CHECK(nf90_inq_varid(wfk%fh, "reduced_coordinates_of_plane_waves", kg_varid))
1403 93004 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
1404 0 : NCF_CHECK(nctk_set_collective(wfk%fh, kg_varid))
1405 : end if
1406 651028 : ncerr = nf90_get_var(wfk%fh, kg_varid, kg_k, start=[1,1,ik_ibz], count=[3,npw_disk,1])
1407 93004 : NCF_CHECK(ncerr)
1408 : end if
1409 :
1410 1056575 : if (Wfk%formeig==0) then
1411 : ! Read eigenvalues and occupations.
1412 105400 : if (present(eig_k)) then
1413 105383 : NCF_CHECK(nf90_inq_varid(wfk%fh, "eigenvalues", eig_varid))
1414 105383 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
1415 0 : NCF_CHECK(nctk_set_collective(wfk%fh, eig_varid))
1416 : end if
1417 737681 : ncerr = nf90_get_var(wfk%fh, eig_varid, eig_k, start=[1,ik_ibz,spin], count=[nband_disk_keep,1,1])
1418 105383 : NCF_CHECK(ncerr)
1419 : end if
1420 :
1421 105400 : if (present(occ_k)) then
1422 89236 : NCF_CHECK(nf90_inq_varid(wfk%fh, "occupations", occ_varid))
1423 89236 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
1424 0 : NCF_CHECK(nctk_set_collective(wfk%fh, occ_varid))
1425 : end if
1426 624652 : ncerr = nf90_get_var(wfk%fh, occ_varid, occ_k, start=[1,ik_ibz,spin], count=[nband_disk,1,1])
1427 89236 : NCF_CHECK_MSG(ncerr, "getting occ_k")
1428 : end if
1429 :
1430 : else ! formeig == 1
1431 :
1432 951175 : if (present(eig_k)) then
1433 : ! Read h1 matrix elements. The netcdf array has shape:
1434 : ! [complex, max_number_of_states, max_number_of_states, number_of_kpoints, number_of_spins]
1435 435984 : ABI_MALLOC(h1mat, (2, wfk%mband, wfk%mband))
1436 108996 : NCF_CHECK(nf90_inq_varid(wfk%fh, "h1_matrix_elements", h1_varid))
1437 108996 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
1438 0 : NCF_CHECK(nctk_set_collective(wfk%fh, h1_varid))
1439 : end if
1440 : ncerr = nf90_get_var(wfk%fh, h1_varid, h1mat, start=[1,1,1,ik_ibz,spin], &
1441 1198956 : count=[2, wfk%mband, wfk%mband, 1, 1])
1442 108996 : NCF_CHECK_MSG(ncerr, "getting h1mat_k")
1443 :
1444 : ! For legacy reasons, I have to pack nband_k**2 elements in the first positions in eig_k
1445 : ! This is important only if nband(:) depends on k i.e. mband != nband_k
1446 : idx=1
1447 611695 : do ib2=1,nband_disk
1448 4316244 : do ib1=1,nband_disk
1449 11113647 : eig_k(idx:idx+1) = h1mat(:2,ib1,ib2)
1450 4207248 : idx=idx+2
1451 : end do
1452 : end do
1453 108996 : ABI_FREE(h1mat)
1454 : end if
1455 : end if
1456 :
1457 1056575 : if (present(cg_k)) then
1458 : ! Read the nb_block bands starting from band_block(1)
1459 : ! The coefficients_of_wavefunctions on file have shape [cplex, mpw, nspinor, mband, nkpt, nsppol]
1460 1010769 : NCF_CHECK(nf90_inq_varid(wfk%fh, "coefficients_of_wavefunctions", cg_varid))
1461 1010769 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
1462 0 : NCF_CHECK(nctk_set_collective(wfk%fh, cg_varid))
1463 : end if
1464 :
1465 : ncerr = nf90_get_var(wfk%fh, cg_varid, cg_k, start=[1,1,1,band_block(1),ik_ibz,spin], &
1466 13139997 : count=[2,npw_disk,wfk%nspinor,nb_block,1,1])
1467 1010769 : NCF_CHECK_MSG(ncerr, "getting cg_k")
1468 : end if
1469 :
1470 : case default
1471 1056575 : ABI_ERROR(sjoin('Wrong/unsupported iomode: ', itoa(Wfk%iomode)))
1472 : end select
1473 :
1474 : DBG_EXIT("COLL")
1475 :
1476 1056575 : return
1477 :
1478 : ! Handle Fortran IO error
1479 : 10 continue
1480 0 : ABI_ERROR(errmsg)
1481 :
1482 3258961 : end subroutine wfk_read_band_block
1483 : !!***
1484 :
1485 : !----------------------------------------------------------------------
1486 :
1487 : !!****f* m_wfk/wfk_read_bks
1488 : !! NAME
1489 : !! wfk_read_bks
1490 : !!
1491 : !! FUNCTION
1492 : !! Read the wavefunction and, optionally, the *DFPT* matrix elements
1493 : !! for a given (band, k-point, spin).
1494 : !!
1495 : !! INPUTS
1496 : !! Wfk<class(wfk_t)>=WFK file handler.
1497 : !! band=Band index
1498 : !! ik_ibz=Index of the k-point in the IBZ.
1499 : !! spin=Spin index
1500 : !! sc_mode= MPI-IO option
1501 : !! xmpio_single ==> for reading by current proc.
1502 : !! xmpio_collective ==> for collective reading.
1503 : !!
1504 : !! OUTPUTS
1505 : !! cg_bks(2,npw_k*nspinor) = Fourier coefficients of the wavefunction
1506 : !! [eig1_bks(2*wfk%mband)] = Matrix elements of the DFPT H1 Hamiltonian at the specified (k, spin).
1507 : !!
1508 : !! SOURCE
1509 :
1510 1091555 : subroutine wfk_read_bks(wfk, band, ik_ibz, spin, sc_mode, cg_bks, eig1_bks)
1511 :
1512 : !Arguments ------------------------------------
1513 : !scalars
1514 : integer,intent(in) :: band,ik_ibz,spin,sc_mode
1515 : class(wfk_t),intent(inout) :: wfk
1516 : !arrays
1517 : real(dp),DEV_CONTARRD intent(out) :: cg_bks(:,:)
1518 : real(dp),optional,intent(inout) :: eig1_bks(2*wfk%mband)
1519 :
1520 : !Local variables-------------------------------
1521 : !scalars
1522 : integer :: start,ib1,nspinor_disk,npw_disk,nband_disk !ierr,
1523 : #ifdef HAVE_MPI_IO
1524 : integer :: mpierr,bufsz,gkk_type !,cg_type
1525 : integer(XMPI_OFFSET_KIND) :: my_offset,my_offpad
1526 : integer :: sizes(2),types(2)
1527 : #endif
1528 : integer :: h1_varid,cg_varid,ncerr
1529 : character(len=500) :: errmsg
1530 : !arrays
1531 1091555 : real(dp),allocatable :: all_eigk(:)
1532 : !************************************************************************
1533 :
1534 1091555 : if (wfk_validate_ks(wfk, ik_ibz, spin, band=band) /= 0) then
1535 0 : ABI_ERROR("Wrong (ik_ibz, spin, band) args, Aborting now")
1536 : end if
1537 1091555 : npw_disk = wfk%Hdr%npwarr(ik_ibz)
1538 1091555 : nband_disk = wfk%nband(ik_ibz, spin)
1539 1091555 : nspinor_disk = wfk%nspinor
1540 : !cg_bks = one; if (present(eig1_bks)) eig1_bks = zero ; return
1541 :
1542 1091555 : if (.not. present(eig1_bks)) then
1543 2512569 : call wfk%read_band_block([band, band], ik_ibz, spin, sc_mode, cg_k=cg_bks)
1544 837523 : return
1545 :
1546 : else
1547 254032 : ABI_CHECK(wfk%formeig==1, "formeig must be 1 if eig1_bks is present")
1548 254032 : ABI_CHECK(size(cg_bks, dim=2) >= npw_disk*wfk%nspinor,"cg_bks too small")
1549 254032 : ABI_CHECK(size(eig1_bks) >= 2*nband_disk, "eig1_bks too small")
1550 :
1551 : if (.False.) then
1552 : !if (.True.) then
1553 : ! Due to the API of wfk_read_band_block, we have to read the full set of eigenvalues
1554 : ! and then extract the relevant band
1555 : ! TODO: Should write another routine to avoid doing that.
1556 : ABI_MALLOC(all_eigk, (2*wfk%mband**2))
1557 : call wfk%read_band_block([band, band], ik_ibz, spin, sc_mode, cg_k=cg_bks, eig_k=all_eigk)
1558 :
1559 : ! Find the index of the slice.
1560 : ! Remember that data in all_eigk does not have a constant stride if nband_disk != mband
1561 : start = (band-1)*2*nband_disk
1562 :
1563 : !write(std_out,*)size(eig1_bks), nband_disk
1564 : eig1_bks(1:2*nband_disk) = all_eigk(start+1:start+2*nband_disk)
1565 : ABI_FREE(all_eigk)
1566 :
1567 : else
1568 : ! Improved version
1569 254032 : select case (wfk%iomode)
1570 : case (IO_MODE_FORTRAN)
1571 : ! This code is not optimal because I'm rewinding the (k, s) block
1572 : ! at each call but I'm not gonna spend time on this because I should
1573 : ! refactor a lot of stuff. Use MPI-IO or HDF5!
1574 0 : call wfk_seek(wfk,ik_ibz,spin)
1575 :
1576 : ! Read the first record: npw, nspinor, nband_disk
1577 0 : read(Wfk%fh, err=10, iomsg=errmsg) !npw_read, nspinor_read, nband_read
1578 : ! The second record: (k+G) vectors
1579 0 : read(wfk%fh, err=10, iomsg=errmsg) ! kg_k(1:3,1:npw_disk)
1580 :
1581 0 : do ib1=1,nband_disk
1582 0 : if (ib1 /= band) then
1583 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! eig_k(base+1:base+2*nband_disk)
1584 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! cg_k(1:2,ipw+1:ipw+npwso)
1585 : else
1586 : if (present(eig1_bks)) then
1587 0 : read(wfk%fh, err=10, iomsg=errmsg) eig1_bks(1:2*nband_disk)
1588 : else
1589 : read(wfk%fh, err=10, iomsg=errmsg)
1590 : end if
1591 0 : read(wfk%fh, err=10, iomsg=errmsg) cg_bks(:,:npw_disk*wfk%nspinor)
1592 : end if
1593 : end do
1594 :
1595 : ! Reached the end of the (k,s) block. Update f90_fptr
1596 0 : call wfk_update_f90ptr(wfk, ik_ibz, spin)
1597 :
1598 : #ifdef HAVE_MPI_IO
1599 : case (IO_MODE_MPI)
1600 : ! MPI-IO operations are done with file views even for contiguous data of the same type.
1601 : ! See NOTES at the beginning of this module.
1602 :
1603 0 : sizes = [nband_disk, npw_disk*nspinor_disk]
1604 0 : types = [MPI_DOUBLE_COMPLEX, MPI_DOUBLE_COMPLEX]
1605 :
1606 0 : call xmpio_create_fstripes(1,sizes,types,gkk_type,my_offpad,mpierr)
1607 0 : ABI_CHECK_MPI(mpierr, "xmpio_create_fstripes")
1608 :
1609 : !call MPI_TYPE_CONTIGUOUS(nband_disk,MPI_DOUBLE_COMPLEX,gkk_type,mpierr)
1610 : !ABI_CHECK_MPI(mpierr, "type_contigous")
1611 : !call MPI_TYPE_COMMIT(gkk_type,mpierr)
1612 : !ABI_CHECK_MPI(mpierr, "mpi_commit")
1613 : !my_offpad = 0
1614 :
1615 : ! Increment my_offset to account for previous (iband -1) bands.
1616 0 : my_offset = wfk%offset_ks(ik_ibz,spin,REC_EIG) + my_offpad
1617 : my_offset = my_offset + (band - 1) * ( &
1618 : (2*npw_disk*wfk%nspinor*xmpi_bsize_dp + 2*xmpio_bsize_frm) + &
1619 0 : (2*nband_disk*xmpi_bsize_dp + 2*xmpio_bsize_frm) )
1620 :
1621 : #if 1
1622 0 : bufsz = nband_disk
1623 0 : if (sc_mode==xmpio_collective) then
1624 0 : call MPI_FILE_READ_AT_ALL(wfk%fh,my_offset,eig1_bks,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1625 : else
1626 0 : call MPI_FILE_READ_AT(wfk%fh,my_offset,eig1_bks,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1627 : end if
1628 :
1629 : ! Read the cg_ks(G)
1630 : ! Increment my_offset to account for the previous eigen and cg records of (iband-1) bands.
1631 0 : my_offset = wfk%offset_ks(ik_ibz,spin,REC_CG) + xmpio_bsize_frm
1632 : my_offset = my_offset + (band - 1) * ( &
1633 : (2*npw_disk*wfk%nspinor*xmpi_bsize_dp + 2*xmpio_bsize_frm) + &
1634 0 : (2*nband_disk*xmpi_bsize_dp + 2*xmpio_bsize_frm) )
1635 :
1636 0 : bufsz = npw_disk * nspinor_disk
1637 0 : if (sc_mode==xmpio_collective) then
1638 0 : call MPI_FILE_READ_AT_ALL(wfk%fh,my_offset,cg_bks,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1639 : else
1640 0 : call MPI_FILE_READ_AT(wfk%fh,my_offset,cg_bks,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1641 : end if
1642 :
1643 : #else
1644 : call MPI_FILE_SET_VIEW(wfk%fh,my_offset,MPI_BYTE,gkk_type,'native',xmpio_info,mpierr)
1645 : ABI_CHECK_MPI(mpierr, "SET_VIEW")
1646 : call MPI_TYPE_FREE(gkk_type, mpierr)
1647 : ABI_CHECK_MPI(mpierr, "TYPE_FREE")
1648 :
1649 : bufsz = nband_disk
1650 : if (sc_mode==xmpio_collective) then
1651 : call MPI_FILE_READ_ALL(wfk%fh,eig1_bks,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1652 : else if (sc_mode==xmpio_single) then
1653 : call MPI_FILE_READ(wfk%fh,eig1_bks,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1654 : else
1655 : ABI_ERROR("Wrong sc_mode")
1656 : end if
1657 : ABI_CHECK_MPI(mpierr, "FILE_READ")
1658 :
1659 : ! Read the cg_ks(G)
1660 : ! Increment my_offset to account for the previous eigen and cg records of (iband-1) bands.
1661 : my_offset = wfk%offset_ks(ik_ibz,spin,REC_CG) + xmpio_bsize_frm
1662 : my_offset = my_offset + (band - 1) * ( &
1663 : (2*npw_disk*wfk%nspinor*xmpi_bsize_dp + 2*xmpio_bsize_frm) + &
1664 : (2*nband_disk*xmpi_bsize_dp + 2*xmpio_bsize_frm) )
1665 :
1666 : call MPI_TYPE_CONTIGUOUS(npw_disk*nspinor_disk,MPI_DOUBLE_COMPLEX,cg_type,mpierr)
1667 : ABI_CHECK_MPI(mpierr, "type_contigous")
1668 : call MPI_TYPE_COMMIT(cg_type,mpierr)
1669 : ABI_CHECK_MPI(mpierr, "mpi_commit")
1670 :
1671 : call MPI_FILE_SET_VIEW(wfk%fh,my_offset,MPI_BYTE,cg_type,'native',xmpio_info,mpierr)
1672 : ABI_CHECK_MPI(mpierr, "SET_VIEW")
1673 : call MPI_TYPE_FREE(cg_type, mpierr)
1674 : ABI_CHECK_MPI(mpierr, "MPI_TYPE_FREE")
1675 :
1676 : bufsz = npw_disk * nspinor_disk
1677 : if (sc_mode==xmpio_collective) then
1678 : call MPI_FILE_READ_ALL(wfk%fh,cg_bks,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1679 : else if (sc_mode==xmpio_single) then
1680 : call MPI_FILE_READ(wfk%fh,cg_bks,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
1681 : else
1682 : ABI_ERROR("Wrong sc_mode")
1683 : end if
1684 : ABI_CHECK_MPI(mpierr, "FILE_READ")
1685 : #endif
1686 : #endif
1687 :
1688 : case (IO_MODE_ETSF)
1689 : ! Read h1 matrix elements. The netcdf array has shape:
1690 : ! [complex, max_number_of_states, max_number_of_states, number_of_kpoints, number_of_spins]
1691 254032 : NCF_CHECK(nf90_inq_varid(wfk%fh, "h1_matrix_elements", h1_varid))
1692 254032 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
1693 0 : NCF_CHECK(nctk_set_collective(wfk%fh, h1_varid))
1694 : end if
1695 2794352 : ncerr = nf90_get_var(wfk%fh, h1_varid, eig1_bks, start=[1,1,band,ik_ibz,spin], count=[2, nband_disk, 1, 1, 1])
1696 254032 : NCF_CHECK_MSG(ncerr, "getting h1mat_k")
1697 :
1698 : ! Read the wavefunction. The coefficients_of_wavefunctions on file have shape:
1699 : ! [cplex, mpw, nspinor, mband, nkpt, nsppol]
1700 254032 : NCF_CHECK(nf90_inq_varid(wfk%fh, "coefficients_of_wavefunctions", cg_varid))
1701 254032 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
1702 0 : NCF_CHECK(nctk_set_collective(wfk%fh, cg_varid))
1703 : end if
1704 :
1705 : ncerr = nf90_get_var(wfk%fh, cg_varid, cg_bks, start=[1,1,1,band,ik_ibz,spin], &
1706 3302416 : count=[2,npw_disk,wfk%nspinor,1,1,1])
1707 254032 : NCF_CHECK_MSG(ncerr, "getting cg_k")
1708 :
1709 : case default
1710 254032 : ABI_ERROR(sjoin('Wrong value for iomode:', itoa(Wfk%iomode)))
1711 : end select
1712 : end if
1713 :
1714 : end if
1715 :
1716 : return
1717 :
1718 : ! Handle Fortran IO error
1719 : 10 continue
1720 0 : ABI_ERROR(errmsg)
1721 :
1722 1091555 : end subroutine wfk_read_bks
1723 : !!***
1724 :
1725 : !!****f* m_wfk/wfk_write_band_block
1726 : !! NAME
1727 : !! wfk_write_band_block
1728 : !!
1729 : !! FUNCTION
1730 : !! Write a block of contigous bands.
1731 : !!
1732 : !! INPUTS
1733 : !! Wfk<class(wfk_t)>=
1734 : !! band_block(2)=Initial and final band index.
1735 : !! ik_ibz=Index of the k-point in the IBZ.
1736 : !! spin=Spin index
1737 : !! sc_mode= MPI-IO option
1738 : !! xmpio_single ==> for writing by current proc.
1739 : !! xmpio_collective ==> for collective writing.
1740 : !! [kg_k=(:,:)] = G-vectors
1741 : !! [cg_k(:,:)] = Fourier coefficients
1742 : !! [eig_k(:)] = Eigenvalues (dimensioned with wfk%mband, see below)
1743 : !! [occ_k(:)] = Occupancies ((dimensioned with wfk%mband, see below)
1744 : !!
1745 : !! SOURCE
1746 :
1747 350223 : subroutine wfk_write_band_block(Wfk, band_block, ik_ibz, spin, sc_mode, &
1748 234070 : kg_k, cg_k, eig_k, occ_k) ! Optional
1749 :
1750 : !Arguments ------------------------------------
1751 : !scalars
1752 : class(wfk_t),intent(inout) :: Wfk
1753 : integer,intent(in) :: ik_ibz,spin,sc_mode
1754 : !arrays
1755 : integer,intent(in) :: band_block(2)
1756 : integer,intent(in),optional :: kg_k(:,:) ! (3, npw_k)
1757 : real(dp),intent(in),optional :: cg_k(:,:) ! (2, npw_k*nspinor*nband)
1758 : real(dp),intent(in),optional :: eig_k((2*Wfk%mband)**Wfk%formeig*Wfk%mband)
1759 : real(dp),intent(in),optional :: occ_k(Wfk%mband)
1760 :
1761 : !Local variables-------------------------------
1762 : !scalars
1763 : integer :: npw_disk,nspinor_disk,nband_disk,band
1764 : integer :: ipw,my_bcount,npwso,npw_tot,nb_block,base
1765 : character(len=500) :: errmsg !msg,
1766 : real(dp) :: cpu, wall, gflops
1767 : !arrays
1768 116741 : real(dp),contiguous, pointer :: tmp_eigk(:)
1769 : !real(dp), allocatable :: eig_buffer(:), cg_buffer(:,:)
1770 : #ifdef HAVE_MPI_IO
1771 : integer :: mpierr,bufsz,recnpw_type,gkk_type,cgblock_type
1772 : integer(XMPI_OFFSET_KIND) :: my_offset,my_offpad
1773 : integer :: sizes(2),subsizes(2),starts(2),dims(3),types(2)
1774 : !integer(XMPI_OFFSET_KIND),allocatable :: bsize_frecords(:)
1775 : #endif
1776 : integer :: kg_varid,eig_varid,occ_varid,cg_varid,ncerr,h1_varid
1777 : !************************************************************************
1778 :
1779 : DBG_ENTER("COLL")
1780 0 : ABI_CHECK_IEQ(Wfk%rw_mode, WFK_WRITEMODE, "Wfk must be in WRITEMODE")
1781 :
1782 116741 : call cwtime(cpu, wall, gflops, "start")
1783 :
1784 : ! Look before you leap.
1785 116741 : npw_disk = Wfk%Hdr%npwarr(ik_ibz)
1786 116741 : nspinor_disk = Wfk%nspinor
1787 116741 : nband_disk = Wfk%nband(ik_ibz,spin)
1788 116741 : nb_block = (band_block(2) - band_block(1) + 1)
1789 116741 : npw_tot = npw_disk * nspinor_disk * nb_block
1790 :
1791 : ! MG: We don't need to allocate memory if we want to skip records.
1792 : ! Plain read without variable will do the job.
1793 : !ABI_MALLOC (eig_buffer, (2*nband_disk))
1794 : !ABI_MALLOC (cg_buffer, (2,npw_disk*nspinor_disk))
1795 :
1796 116741 : if (PRESENT(kg_k)) then
1797 116741 : ABI_CHECK_IGEQ(SIZE(kg_k, DIM=2), npw_disk, "kg_k too small")
1798 : end if
1799 :
1800 116741 : if (PRESENT(cg_k)) then
1801 116741 : ABI_CHECK_IGEQ(SIZE(cg_k, DIM=2), npw_tot, "cg_k too small")
1802 : end if
1803 :
1804 116741 : if (PRESENT(eig_k)) then
1805 116741 : if (Wfk%formeig == 0) then
1806 588 : ABI_CHECK_IGEQ(SIZE(eig_k), nband_disk, "GS eig_k too small")
1807 588 : ABI_CHECK(PRESENT(occ_k), "both eig_k and occ_k must be present")
1808 116153 : else if (Wfk%formeig == 1) then
1809 116153 : ABI_CHECK_IGEQ(SIZE(eig_k), 2*nband_disk**2, "DFPT eig_k too small")
1810 : else
1811 0 : ABI_ERROR("formeig != [0,1]")
1812 : end if
1813 : end if
1814 :
1815 116153 : if (PRESENT(occ_k)) then
1816 588 : ABI_CHECK_IGEQ(SIZE(occ_k), nband_disk, "GS eig_k too small")
1817 588 : ABI_CHECK(PRESENT(eig_k), "both eig_k and occ_k must be present")
1818 588 : ABI_CHECK(Wfk%formeig == 0, "formeig /=0 with occ_k in input!")
1819 : end if
1820 :
1821 116741 : select case (Wfk%iomode)
1822 : case (IO_MODE_FORTRAN)
1823 :
1824 : ! Rewind the file to have the correct (k,s) block (if needed)
1825 0 : call wfk_seek(Wfk,ik_ibz,spin)
1826 :
1827 : ! Write the first record: npw, nspinor, nband_disk
1828 0 : write(Wfk%fh, err=10, iomsg=errmsg) npw_disk, nspinor_disk, nband_disk
1829 :
1830 : ! The second record: (k+G) vectors
1831 0 : if (PRESENT(kg_k)) then
1832 0 : write(Wfk%fh, err=10, iomsg=errmsg) kg_k(1:3,1:npw_disk)
1833 : else
1834 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! kg_k(1:3,1:npw_disk)
1835 : end if
1836 :
1837 : ! The third record: eigenvalues occupation factors and wavefunctions.
1838 0 : select case (Wfk%formeig)
1839 : case (0)
1840 : !write(unitwf) (eigen(iband),iband=1,nband_disk),(occ(iband),iband=1,nband_disk)
1841 :
1842 0 : if (present(eig_k) .and. present(occ_k)) then
1843 0 : write(Wfk%fh, err=10, iomsg=errmsg) eig_k(1:nband_disk), occ_k(1:nband_disk)
1844 : else
1845 0 : ABI_ERROR("Not coded")
1846 0 : write(Wfk%fh, err=10, iomsg=errmsg) ! eig_k(1:nband_disk), occ_k(1:nband_disk)
1847 : end if
1848 :
1849 : ! The wave-functions.
1850 0 : if (present(cg_k)) then
1851 0 : npwso = npw_disk*nspinor_disk
1852 : ! fast forward the bands which are not mine
1853 : ! could do in a single read, but need to check if cg_k is big enough as a buffer
1854 : ! e.g. for band_block(1)=100 and band_block(2)=105
1855 0 : do band=1,band_block(1)-1
1856 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! cg_buffer(1:2,1:npwso)
1857 : end do
1858 :
1859 : ! MJV 2021/02: I think my coding is correct - the previous one would only accept band_block(:) = 1,nband_disk
1860 0 : my_bcount = 0
1861 0 : do band=band_block(1), band_block(2)
1862 0 : ipw = my_bcount * npwso
1863 0 : my_bcount = my_bcount + 1
1864 0 : write(Wfk%fh, err=10, iomsg=errmsg) cg_k(1:2,ipw+1:ipw+npwso)
1865 : end do
1866 :
1867 : else
1868 0 : ABI_ERROR("cg_k must be present!")
1869 0 : do band=1,nband_disk
1870 0 : write(Wfk%fh, err=10, iomsg=errmsg) ! cg_k(1:2,ipw+1:ipw+npwso)
1871 : end do
1872 : end if
1873 :
1874 : case (1)
1875 : ! Write column of matrix of total size (2*nband_k**2)
1876 : ! And the wave-functions.
1877 0 : npwso = npw_disk*nspinor_disk
1878 :
1879 : ! fast forward the bands which are not mine
1880 : ! could do in a single read, but need to check if cg_k is big enough as a buffer
1881 : ! e.g. for band_block(1)=100 and band_block(2)=105
1882 0 : do band=1, band_block(1)-1
1883 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! eig_buffer(1:2*nband_disk)
1884 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! cg_buffer(1:2,1:npwso)
1885 : end do
1886 :
1887 0 : my_bcount = 0
1888 0 : do band=band_block(1),band_block(2)
1889 0 : base = 2*(band-1)*nband_disk
1890 : !NB: interleaves the arrays eig_k and cg_k in the RF case with formeig 1
1891 0 : write(Wfk%fh, err=10, iomsg=errmsg) eig_k(base+1:base+2*nband_disk)
1892 : ! MJV 2021/02: I think my coding is correct - the previous one would only accept band_block(:) = 1,nband_disk
1893 0 : ipw = my_bcount * npwso
1894 0 : my_bcount = my_bcount + 1
1895 0 : write(Wfk%fh, err=10, iomsg=errmsg) cg_k(1:2,ipw+1:ipw+npwso)
1896 : end do
1897 :
1898 : case default
1899 0 : ABI_ERROR("formeig != [0,1]")
1900 : end select
1901 :
1902 : ! Reached the end of the (k,s) block. Update f90_fptr
1903 0 : call wfk_update_f90ptr(wfk, ik_ibz, spin)
1904 :
1905 : #ifdef HAVE_MPI_IO
1906 : case (IO_MODE_MPI)
1907 : ! record 1 npw, nspinor, nband of length 3
1908 30 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_NPW)
1909 :
1910 : ! bsize_rec(1) = 3 * xmpi_bsize_int
1911 : ! call xmpio_write_frmarkers(Wfk%fh,my_offset,sc_mode,1,bsize_rec,mpierr)
1912 : ! ABI_CHECK(mpierr==0,"mpierr!=0")
1913 :
1914 30 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_NPW) + xmpio_bsize_frm
1915 :
1916 30 : call MPI_TYPE_CONTIGUOUS(3, MPI_INTEGER, recnpw_type, mpierr)
1917 30 : ABI_CHECK_MPI(mpierr, "writing REC_NPW")
1918 :
1919 30 : call MPI_TYPE_COMMIT(recnpw_type, mpierr)
1920 30 : ABI_CHECK_MPI(mpierr, "writing REC_NPW")
1921 :
1922 : ! NB: This is a collection operation so all proch in wfk%comm must call the routine.
1923 30 : call MPI_FILE_SET_VIEW(Wfk%fh, my_offset, MPI_BYTE, recnpw_type, 'native', xmpio_info, mpierr)
1924 30 : ABI_CHECK_MPI(mpierr, "writing REC_NPW")
1925 :
1926 30 : call MPI_TYPE_FREE(recnpw_type, mpierr)
1927 30 : ABI_CHECK_MPI(mpierr, "writing REC_NPW")
1928 :
1929 120 : dims = [npw_disk, nspinor_disk, nband_disk]
1930 :
1931 30 : if (sc_mode == xmpio_collective) then
1932 0 : call MPI_FILE_WRITE_ALL(Wfk%fh, dims, SIZE(dims), MPI_INTEGER, MPI_STATUS_IGNORE, mpierr)
1933 30 : else if (sc_mode == xmpio_single) then
1934 30 : call MPI_FILE_WRITE(Wfk%fh, dims, SIZE(dims), MPI_INTEGER, MPI_STATUS_IGNORE, mpierr)
1935 : else
1936 0 : ABI_ERROR("Wrong sc_mode")
1937 : end if
1938 30 : ABI_CHECK_MPI(mpierr, "writing REC_NPW")
1939 :
1940 : !----------------------------------------------------------------------------
1941 : ! record 2 kg
1942 30 : if (present(kg_k)) then
1943 30 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_KG)
1944 :
1945 : ! bsize_rec(1) = 3 * npw_disk * xmpi_bsize_int
1946 : ! call xmpio_write_frmarkers(Wfk%fh,my_offset,sc_mode,1,bsize_rec,mpierr)
1947 30 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_KG) + xmpio_bsize_frm
1948 :
1949 30 : call mpio_write_kg_k(Wfk%fh, my_offset, npw_disk, sc_mode, kg_k, mpierr)
1950 30 : ABI_CHECK_MPI(mpierr, "mpio_write_kg_k")
1951 : end if
1952 :
1953 30 : if (Wfk%formeig==0) then
1954 : !----------------------------------------------------------------------------
1955 : ! record 3 eigk occk
1956 30 : if (present(eig_k) .and. present(occ_k)) then
1957 30 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_EIG)
1958 :
1959 : ! bsize_rec(1) = 2 * nband_disk * xmpi_bsize_dp
1960 : ! call xmpio_write_frmarkers(Wfk%fh,my_offset,sc_mode,1,bsize_rec,mpierr)
1961 :
1962 : !TODO: check if we need 2*bsize_frm here
1963 30 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_EIG) + xmpio_bsize_frm
1964 : !
1965 : ! Write both eig and occ in tmp_eigk
1966 30 : bufsz = 2*nband_disk
1967 90 : ABI_MALLOC(tmp_eigk, (bufsz))
1968 :
1969 270 : tmp_eigk(1:nband_disk) = eig_k(1:nband_disk)
1970 270 : tmp_eigk(nband_disk+1:) = occ_k(1:nband_disk)
1971 :
1972 30 : call mpio_write_eigocc_k(Wfk%fh, my_offset, nband_disk, Wfk%formeig, sc_mode, tmp_eigk, mpierr)
1973 30 : ABI_CHECK_MPI(mpierr, "mpio_write_eigocc_k")
1974 :
1975 60 : ABI_FREE(tmp_eigk)
1976 : end if
1977 :
1978 : !----------------------------------------------------------------------------
1979 : ! record 4 cg
1980 30 : if (present(cg_k)) then
1981 : !TODO: in principle these markers are written when the file is opened, no need here.
1982 : !ABI_MALLOC(bsize_frecords, (nb_block))
1983 : !bsize_frecords = 2 * npw_disk * nspinor_disk * xmpi_bsize_dp
1984 : !! TODO: why 2*frm size here? Each band cg is a single record!
1985 : !my_offset = Wfk%offset_ks(ik_ibz,spin,REC_CG) + (band_block(1)-1) * (bsize_frecords(1) + 2*xmpio_bsize_frm)
1986 : !call xmpio_write_frmarkers(Wfk%fh,my_offset,sc_mode,nb_block,bsize_frecords,mpierr)
1987 : !ABI_CHECK(mpierr==0,"mpierr!=0")
1988 : !ABI_FREE(bsize_frecords)
1989 : !print *, "Writing cg"
1990 :
1991 30 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_CG)
1992 90 : sizes = [npw_disk*nspinor_disk, nband_disk]
1993 90 : subsizes = [npw_disk*nspinor_disk, band_block(2)-band_block(1)+1]
1994 30 : bufsz = 2 * npw_disk * nspinor_disk * nb_block
1995 90 : starts = [1, band_block(1)]
1996 :
1997 30 : call mpiotk_write_fsuba_dp2D(Wfk%fh,my_offset,sizes,subsizes,starts,bufsz,cg_k,Wfk%chunk_bsize,sc_mode,Wfk%comm,mpierr)
1998 30 : ABI_CHECK(mpierr == 0, "mpierr != 0")
1999 : end if
2000 :
2001 0 : else if (Wfk%formeig == 1) then
2002 :
2003 : !----------------------------------------------------------------------------
2004 : ! record 3 eigk occk
2005 0 : if (present(eig_k)) then
2006 0 : types = [MPI_DOUBLE_COMPLEX, MPI_DOUBLE_COMPLEX]
2007 0 : sizes = [nband_disk, npw_disk*nspinor_disk]
2008 :
2009 0 : call xmpio_create_fstripes(nband_disk,sizes,types,gkk_type,my_offpad,mpierr)
2010 0 : ABI_CHECK_MPI(mpierr, "xmpio_create_fstripes")
2011 :
2012 0 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_EIG) + my_offpad
2013 :
2014 0 : call MPI_FILE_SET_VIEW(Wfk%fh,my_offset,MPI_BYTE,gkk_type,'native',xmpio_info,mpierr)
2015 0 : ABI_CHECK_MPI(mpierr, "SET_VIEW")
2016 :
2017 0 : call MPI_TYPE_FREE(gkk_type,mpierr)
2018 0 : ABI_CHECK_MPI(mpierr, "TYPE_FREE")
2019 :
2020 : ! NB: bufsz is not 2*nband**2 because we use COMPLEX below
2021 0 : bufsz = nband_disk**2
2022 :
2023 0 : if (sc_mode == xmpio_collective) then
2024 0 : call MPI_FILE_WRITE_ALL(Wfk%fh,eig_k,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
2025 0 : else if (sc_mode == xmpio_single) then
2026 0 : call MPI_FILE_WRITE(Wfk%fh,eig_k,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
2027 : else
2028 0 : ABI_ERROR("Wrong sc_mode")
2029 : end if
2030 :
2031 0 : ABI_CHECK_MPI(mpierr, "FILE_WRITE")
2032 : end if
2033 :
2034 : !----------------------------------------------------------------------------
2035 : ! record 4 cg
2036 0 : if (present(cg_k)) then
2037 : !ABI_CHECK(band_block(1)==1,"band_block(1) !=1 not coded")
2038 :
2039 0 : types = [MPI_DOUBLE_COMPLEX, MPI_DOUBLE_COMPLEX]
2040 : !sizes = [npw_disk*nspinor_disk, band_block(2)-band_block(1)]
2041 0 : sizes = [npw_disk*nspinor_disk, nband_disk]
2042 :
2043 0 : call xmpio_create_fstripes(nb_block,sizes,types,cgblock_type,my_offpad,mpierr)
2044 0 : ABI_CHECK_MPI(mpierr, "xmpio_create_fstripes")
2045 :
2046 : ! TODO: check that the following offset is correct
2047 : ! check that the 4 * xmpio_bsize_frm is correct: 1 record marker for eigen and 1 for cg in principle!
2048 : ! even if the cg is followed by 2 frm, and eig 1, then it should be 3, not 4
2049 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_CG) + my_offpad &
2050 : + (band_block(1)-1) * (2 * nband_disk * xmpi_bsize_dp &
2051 : + 2 * npw_disk * nspinor_disk * xmpi_bsize_dp &
2052 0 : + 4 * xmpio_bsize_frm)
2053 :
2054 0 : call MPI_FILE_SET_VIEW(Wfk%fh,my_offset,MPI_BYTE,cgblock_type,'native',xmpio_info,mpierr)
2055 0 : ABI_CHECK_MPI(mpierr, "SET_VIEW")
2056 :
2057 0 : call MPI_TYPE_FREE(cgblock_type,mpierr)
2058 0 : ABI_CHECK_MPI(mpierr, "TYPE_FREE")
2059 :
2060 0 : bufsz = npw_disk * nspinor_disk * nb_block
2061 0 : if (sc_mode == xmpio_collective) then
2062 0 : call MPI_FILE_WRITE_ALL(Wfk%fh,cg_k,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
2063 0 : else if (sc_mode == xmpio_single) then
2064 0 : call MPI_FILE_WRITE (Wfk%fh,cg_k,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
2065 : else
2066 0 : ABI_ERROR("Wrong sc_mode")
2067 : end if
2068 0 : ABI_CHECK_MPI(mpierr, "FILE_WRITE")
2069 : end if
2070 :
2071 : else
2072 0 : ABI_ERROR("formeig not in [0,1]")
2073 : end if
2074 : #endif
2075 :
2076 : case (IO_MODE_ETSF)
2077 116711 : if (present(kg_k)) then
2078 : ! Write the reduced_coordinates_of_plane_waves for this k point.
2079 116711 : NCF_CHECK(nf90_inq_varid(wfk%fh, "reduced_coordinates_of_plane_waves", kg_varid))
2080 116711 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
2081 34096 : NCF_CHECK(nctk_set_collective(wfk%fh, kg_varid))
2082 : end if
2083 816977 : ncerr = nf90_put_var(wfk%fh, kg_varid, kg_k, start=[1,1,ik_ibz], count=[3,npw_disk,1])
2084 116711 : NCF_CHECK_MSG(ncerr, "putting kg_k")
2085 : !NCF_CHECK(nf90_sync(wfk%fh))
2086 : end if
2087 :
2088 : ! Write eigenvalues and occupation factors.
2089 116711 : if (Wfk%formeig == 0) then
2090 :
2091 558 : if (present(eig_k)) then
2092 558 : NCF_CHECK(nf90_inq_varid(wfk%fh, "eigenvalues", eig_varid))
2093 558 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
2094 0 : NCF_CHECK(nctk_set_collective(wfk%fh, eig_varid))
2095 : end if
2096 : !print *, "Putting eigenvalues for ik_ibz,spin, nband_disk", ik_ibz,spin, nband_disk
2097 3906 : ncerr = nf90_put_var(wfk%fh, eig_varid, eig_k, start=[1,ik_ibz,spin], count=[nband_disk,1,1])
2098 558 : NCF_CHECK_MSG(ncerr, "putting eig_k")
2099 : !NCF_CHECK(nf90_sync(wfk%fh))
2100 : end if
2101 :
2102 558 : if (present(occ_k)) then
2103 558 : NCF_CHECK(nf90_inq_varid(wfk%fh, "occupations", occ_varid))
2104 558 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
2105 0 : NCF_CHECK(nctk_set_collective(wfk%fh, occ_varid))
2106 : end if
2107 3906 : ncerr = nf90_put_var(wfk%fh, occ_varid, occ_k, start=[1,ik_ibz,spin], count=[nband_disk,1,1])
2108 558 : NCF_CHECK_MSG(ncerr, "putting occ_k")
2109 : end if
2110 :
2111 116153 : else if (Wfk%formeig == 1) then
2112 116153 : if (present(occ_k)) then
2113 0 : ABI_ERROR("Don't pass occ_k when formeig==1 and ETSF-IO")
2114 : end if
2115 116153 : if (present(eig_k)) then
2116 : !ABI_WARNING("Don't pass eig_k when formeig==1 and ETSF-IO")
2117 116153 : NCF_CHECK(nf90_inq_varid(wfk%fh, "h1_matrix_elements", h1_varid))
2118 116153 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
2119 34096 : NCF_CHECK(nctk_set_collective(wfk%fh, h1_varid))
2120 : end if
2121 1277683 : ncerr = nf90_put_var(wfk%fh, h1_varid, eig_k, start=[1,1,1,ik_ibz,spin], count=[2, nband_disk, nband_disk, 1, 1])
2122 116153 : NCF_CHECK_MSG(ncerr, "puting h1mat_k")
2123 : end if
2124 :
2125 : else
2126 0 : ABI_ERROR("formeig != [0,1]")
2127 : end if
2128 :
2129 116711 : if (present(cg_k)) then
2130 : ! Write the nb_block bands starting from band_block(1)
2131 : ! The coefficients_of_wavefunctions on file have shape [cplex, mpw, nspinor, mband, nkpt, nsppol]
2132 116711 : NCF_CHECK(nf90_inq_varid(wfk%fh, "coefficients_of_wavefunctions", cg_varid))
2133 116711 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
2134 34096 : NCF_CHECK(nctk_set_collective(wfk%fh, cg_varid))
2135 : end if
2136 :
2137 : ncerr = nf90_put_var(wfk%fh, cg_varid, cg_k, start=[1,1,1,band_block(1),ik_ibz,spin], &
2138 1517243 : count=[2, npw_disk, wfk%nspinor, nb_block, 1, 1])
2139 116711 : NCF_CHECK_MSG(ncerr, "putting cg_k")
2140 : end if
2141 :
2142 : case default
2143 116741 : ABI_ERROR(sjoin('Wrong value of iomode:', itoa(Wfk%iomode)))
2144 : end select
2145 :
2146 : !ABI_FREE(eig_buffer)
2147 : !ABI_FREE(cg_buffer)
2148 :
2149 116741 : call cwtime_report(" wfk_write_band_block", cpu, wall, gflops)
2150 : DBG_EXIT("COLL")
2151 :
2152 116741 : return
2153 :
2154 : ! Handle Fortran IO error
2155 : 10 continue
2156 0 : ABI_ERROR(errmsg)
2157 :
2158 234070 : end subroutine wfk_write_band_block
2159 : !!***
2160 :
2161 : !----------------------------------------------------------------------
2162 :
2163 : !!****f* m_wfk/wfk_read_bmask
2164 : !! NAME
2165 : !! wfk_read_bmask
2166 : !!
2167 : !! FUNCTION
2168 : !! Read a set of bands at a given k-point, spin. The bands to be read
2169 : !! are specified by the logical mask `bmask`.
2170 : !!
2171 : !! INPUTS
2172 : !! Wfk<class(wfk_t)>=
2173 : !! ik_ibz=Index of the k-point in the IBZ.
2174 : !! spin=Spin index
2175 : !! sc_mode= MPI-IO option
2176 : !! xmpio_single ==> for reading by current proc.
2177 : !! xmpio_collective ==> for collective reading.
2178 : !!
2179 : !! OUTPUTS
2180 : !! [kg_k=(:,:)] = G-vectors
2181 : !! [cg_k(:,:)] = Fourier coefficients
2182 : !! [eig_k(:)] = Eigenvectors
2183 : !! [occ_k(:)] = Occupation
2184 : !!
2185 : !! NOTES
2186 : !! The output arrays eig_k and occ_k contain the *full* set of eigenvalues and occupation
2187 : !! factors stored in the file and are dimensioned with wfk%mband.
2188 : !!
2189 : !! SOURCE
2190 :
2191 0 : subroutine wfk_read_bmask(Wfk, bmask, ik_ibz, spin, sc_mode, kg_k, cg_k, eig_k, occ_k)
2192 :
2193 : !Arguments ------------------------------------
2194 : !scalars
2195 : integer,intent(in) :: ik_ibz,spin,sc_mode
2196 : class(wfk_t),intent(inout) :: Wfk
2197 : !arrays
2198 : logical,intent(in) :: bmask(Wfk%mband)
2199 : integer,intent(out), DEV_CONTARRD optional :: kg_k(:,:) !(3,npw_k)
2200 : real(dp),intent(out), DEV_CONTARRD optional :: cg_k(:,:) !(2,npw_k*nspinor*nband)
2201 : real(dp),intent(out),optional :: eig_k((2*Wfk%mband)**Wfk%formeig*Wfk%mband)
2202 : real(dp),intent(out),optional :: occ_k(Wfk%mband)
2203 :
2204 : !Local variables-------------------------------
2205 : !scalars
2206 : integer :: npw_disk,nspinor_disk,nband_disk,ipw,my_bcount,cnt,npwso,npw_tot,pt1,pt2,band
2207 : integer :: npw_read,nspinor_read,nband_read,nb_tot,ncount,my_bcnt,my_maxb,base,nb, ierr
2208 : character(len=500) :: msg,errmsg
2209 : !arrays
2210 0 : real(dp),contiguous, pointer :: tmp_eigk(:),tmp_occk(:)
2211 : integer :: mpierr,cgscatter_type,cg_type,method,block,nblocks,nbxblock
2212 : integer :: bstart,bstop,bufsz,ugsz,brest,max_nband
2213 : integer(XMPI_OFFSET_KIND) :: my_offset,base_ofs,my_offpad
2214 : integer :: band_block(2),sizes(2),subsizes(2),starts(2),types(2)
2215 0 : integer,allocatable :: block_length(:),block_type(:)
2216 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
2217 0 : real(dp),allocatable :: buffer(:,:)
2218 : integer :: kg_varid,eig_varid,occ_varid,cg_varid,ncerr
2219 0 : integer,allocatable :: blocks(:,:)
2220 : !************************************************************************
2221 :
2222 : DBG_ENTER("COLL")
2223 :
2224 0 : ABI_CHECK_IEQ(Wfk%rw_mode, WFK_READMODE, "Wfk must be in READMODE")
2225 :
2226 : !do band=1,wfk%mband
2227 : ! if (.not. bmask(band)) continue
2228 : ! if (wfk_validate_ks(wfk, ik_ibz, spin, band=band) /= 0) then
2229 : ! ABI_ERROR("Wrong (ik_ibz, spin, band) args, Aborting now")
2230 : ! end if
2231 : !end if
2232 :
2233 : ! Look before you leap.
2234 0 : npw_disk = Wfk%Hdr%npwarr(ik_ibz)
2235 0 : nspinor_disk = Wfk%nspinor
2236 0 : nband_disk = Wfk%nband(ik_ibz,spin)
2237 0 : nb_tot = COUNT(bmask)
2238 0 : npw_tot = npw_disk * nspinor_disk * nb_tot
2239 :
2240 0 : if (present(kg_k)) then
2241 0 : ABI_CHECK((SIZE(kg_k,DIM=2) >= npw_disk),"kg_k too small")
2242 : end if
2243 :
2244 0 : if (present(cg_k)) then
2245 0 : ABI_CHECK(SIZE(cg_k, DIM=2) >= npw_tot, "Too small cg_k")
2246 : end if
2247 :
2248 0 : if (present(eig_k)) then
2249 0 : if (Wfk%formeig==0) then
2250 0 : ABI_CHECK(SIZE(eig_k) >= nband_disk, "GS eig_k too small")
2251 0 : else if (Wfk%formeig==1) then
2252 0 : ABI_CHECK(SIZE(eig_k) >= 2*nband_disk**2, "DFPT eig_k too small")
2253 : else
2254 0 : ABI_ERROR("formeig != [0,1]")
2255 : end if
2256 : end if
2257 :
2258 0 : if (present(occ_k)) then
2259 0 : ABI_CHECK(Wfk%formeig==0,"occ_k with formeig != 0")
2260 0 : ABI_CHECK(SIZE(occ_k) >= nband_disk, "GS eig_k too small")
2261 : end if
2262 :
2263 0 : select case (Wfk%iomode)
2264 : case (IO_MODE_FORTRAN)
2265 :
2266 : ! Rewind the file to have the correct (k,s) block (if needed)
2267 0 : call wfk_seek(Wfk, ik_ibz, spin)
2268 :
2269 : ! Read the first record: npw, nspinor, nband_disk
2270 0 : read(Wfk%fh, err=10, iomsg=errmsg) npw_read, nspinor_read, nband_read
2271 :
2272 0 : if (any([npw_read, nspinor_read, nband_read] /= [npw_disk, nspinor_disk, nband_disk])) then
2273 0 : write(msg,"(a,6(i0,2x))")"Mismatch between (npw, nspinor, nband) read from WFK and those found in HDR ",&
2274 0 : npw_read, nspinor_read, nband_read, npw_disk, nspinor_disk, nband_disk
2275 0 : ABI_ERROR(msg)
2276 : end if
2277 :
2278 : ! The second record: (k+G) vectors
2279 0 : if (present(kg_k)) then
2280 0 : read(Wfk%fh, err=10, iomsg=errmsg) kg_k(1:3,1:npw_disk)
2281 : else
2282 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! kg_k(1:3,1:npw_disk)
2283 : end if
2284 :
2285 : ! The third record: eigenvalues and occupation factors.
2286 0 : if (Wfk%formeig == 0) then
2287 :
2288 0 : if (present(eig_k) .or. present(occ_k)) then
2289 0 : ABI_MALLOC(tmp_eigk, (nband_disk))
2290 0 : ABI_MALLOC(tmp_occk, (nband_disk))
2291 :
2292 0 : read(Wfk%fh, err=10, iomsg=errmsg) tmp_eigk, tmp_occk
2293 :
2294 0 : if (present(eig_k)) eig_k = tmp_eigk
2295 0 : if (present(occ_k)) occ_k = tmp_occk
2296 0 : ABI_FREE(tmp_eigk)
2297 0 : ABI_FREE(tmp_occk)
2298 :
2299 : else
2300 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! eig_k(1:nband_disk)
2301 : end if
2302 :
2303 : ! The wave-functions.
2304 0 : if (present(cg_k)) then
2305 : npwso = npw_disk*nspinor_disk
2306 : my_bcount = 0
2307 0 : do band=1,nband_disk
2308 0 : if (bmask(band)) then
2309 0 : ipw = my_bcount * npwso
2310 0 : my_bcount = my_bcount + 1
2311 0 : read(Wfk%fh, err=10, iomsg=errmsg) cg_k(1:2,ipw+1:ipw+npwso)
2312 : else
2313 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! cg_k(1:2,ipw+1:ipw+npwso)
2314 : end if
2315 : end do
2316 :
2317 : else
2318 0 : do band=1,nband_disk
2319 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! cg_k(1:2,ipw+1:ipw+npwso)
2320 : end do
2321 : end if
2322 :
2323 0 : else if (Wfk%formeig == 1) then
2324 : ! Read matrix of size (2*nband_k**2)
2325 : npwso = npw_disk*nspinor_disk
2326 : my_bcount = 0
2327 :
2328 0 : do band=1,nband_disk
2329 0 : base = 2*(band-1)*nband_disk
2330 0 : if (present(eig_k)) then
2331 0 : read(Wfk%fh, err=10, iomsg=errmsg) eig_k(base+1:base+2*nband_disk)
2332 : else
2333 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! eig_k(base+1:base+2*nband_disk)
2334 : end if
2335 :
2336 0 : if (bmask(band) .and. present(cg_k)) then
2337 0 : ipw = my_bcount * npwso
2338 0 : my_bcount = my_bcount + 1
2339 0 : read(Wfk%fh, err=10, iomsg=errmsg) cg_k(1:2,ipw+1:ipw+npwso)
2340 : else
2341 0 : read(Wfk%fh, err=10, iomsg=errmsg) ! cg_k(1:2,ipw+1:ipw+npwso)
2342 : end if
2343 : end do
2344 :
2345 : else
2346 0 : ABI_ERROR("formeig != [0,1]")
2347 : end if
2348 :
2349 : ! Reached the end of the (k,s) block. Update f90_fptr
2350 0 : call wfk_update_f90ptr(wfk, ik_ibz, spin)
2351 :
2352 : #ifdef HAVE_MPI_IO
2353 : case (IO_MODE_MPI)
2354 0 : if (present(kg_k)) then
2355 0 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_KG) + xmpio_bsize_frm
2356 :
2357 0 : call mpio_read_kg_k(Wfk%fh,my_offset,npw_disk,sc_mode,kg_k,mpierr)
2358 0 : ABI_CHECK_MPI(mpierr, "mpio_read_kg_k")
2359 : end if
2360 :
2361 : ! The third record: eigenvalues and occupation factors.
2362 0 : if (present(eig_k) .or. present(occ_k)) then
2363 0 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_EIG) + xmpio_bsize_frm
2364 : !
2365 : ! formeig=0 => Read both eig and occ in tmp_eigk.
2366 : ! formeig=1 => Read (nband_k,nband_k) matrix of complex numbers.
2367 : !
2368 0 : call mpio_read_eigocc_k(Wfk%fh,my_offset,nband_disk,Wfk%formeig,sc_mode,tmp_eigk,mpierr)
2369 0 : ABI_CHECK_MPI(mpierr, "mpio_read_eigocc")
2370 :
2371 0 : if (Wfk%formeig == 0) then
2372 0 : if (present(eig_k)) eig_k(1:nband_disk) = tmp_eigk(1:nband_disk)
2373 0 : if (present(occ_k)) occ_k(1:nband_disk) = tmp_eigk(nband_disk+1:)
2374 0 : else if (Wfk%formeig == 1) then
2375 0 : if (present(eig_k)) eig_k(1:2*nband_disk**2) = tmp_eigk(1:2*nband_disk**2)
2376 : else
2377 0 : ABI_ERROR("formeig not in [0,1]")
2378 : end if
2379 :
2380 0 : ABI_FREE(tmp_eigk)
2381 : end if
2382 :
2383 0 : if (present(cg_k)) then
2384 0 : method = 0
2385 :
2386 0 : select case (method)
2387 : case (0)
2388 : ! DATA SIEVING:
2389 : ! read max_nband states in chuncks of nbxblock, then extract my states according to bmask.
2390 : !
2391 : ! MAX number of bands read by the procs in the communicator
2392 0 : my_maxb = nband_disk
2393 0 : do band=nband_disk,1,-1
2394 0 : if (bmask(band)) then
2395 0 : my_maxb = band
2396 0 : EXIT
2397 : end if
2398 : end do
2399 0 : call xmpi_max(my_maxb, max_nband, Wfk%comm, mpierr)
2400 : !max_nband = nband_disk
2401 : !
2402 : ! MPI-IO crashes if we try to read a large number of bands in a single call.
2403 0 : nbxblock = max_nband
2404 0 : if ((two * npw_disk *nspinor_disk * nbxblock * xmpi_bsize_dp) > Wfk%chunk_bsize) then
2405 0 : nbxblock = Wfk%chunk_bsize / (2*npw_disk*nspinor_disk*xmpi_bsize_dp)
2406 0 : if (nbxblock == 0) nbxblock = 50
2407 : end if
2408 : !nbxblock = 2
2409 :
2410 0 : nblocks = max_nband / nbxblock
2411 0 : brest = MOD(max_nband, nbxblock)
2412 0 : if (brest /= 0) nblocks = nblocks + 1
2413 :
2414 : !write(std_out, *) "full_size:", 2 * npw_disk *nspinor_disk *nbxblock * xmpi_bsize_dp, Wfk%chunk_bsize
2415 : !write(std_out,*)"in buffered bmask with nblocks:", nblocks, ", nbxblock: ", nbxblock
2416 :
2417 0 : base_ofs = Wfk%offset_ks(ik_ibz, spin, REC_CG)
2418 0 : sizes = [npw_disk * nspinor_disk, nband_disk]
2419 :
2420 0 : my_bcnt = 0 ! index of my band in cg_k
2421 0 : do block=1,nblocks
2422 0 : bstart = 1 + (block-1) * nbxblock
2423 0 : bstop = bstart + nbxblock - 1
2424 0 : if (bstop > max_nband) bstop = max_nband
2425 0 : nb = bstop - bstart + 1
2426 :
2427 : ! Allocate and read the buffer
2428 : ! Note that in the API calls we mix real and complex.
2429 : ! bufsz is the size in terms of complex numbers.
2430 0 : band_block = [bstart, bstop]
2431 0 : ugsz = npw_disk*nspinor_disk
2432 0 : bufsz = ugsz * (bstop - bstart + 1)
2433 : !write(std_out,*)" bstart, bstop:", band_block
2434 0 : ABI_MALLOC_OR_DIE(buffer, (2, bufsz), ierr)
2435 :
2436 : ! Read the cg_ks(G). different versions depending on formeig
2437 0 : if (wfk%formeig == 0) then
2438 0 : subsizes = [npw_disk*nspinor_disk, band_block(2)-band_block(1)+1]
2439 0 : starts = [1, bstart]
2440 :
2441 : call mpiotk_read_fsuba_dp2D(Wfk%fh,base_ofs,sizes,subsizes,starts,&
2442 0 : 2 * bufsz,buffer,Wfk%chunk_bsize,sc_mode,Wfk%comm,mpierr)
2443 0 : ABI_CHECK(mpierr == 0, "Fortran record too big")
2444 :
2445 : ! New version based: master reads and broadcasts the buffer.
2446 : !if (wfk%my_rank == 0) then
2447 : ! call mpiotk_read_fsuba_dp2D(Wfk%fh,base_ofs,sizes,subsizes,starts,&
2448 : ! 2 * bufsz,buffer,Wfk%chunk_bsize,xmpio_single,wfk%comm,mpierr)
2449 : ! ABI_CHECK(mpierr == 0, "Fortran record too big")
2450 : !end if
2451 : !call xmpi_bcast(buffer, 0, wfk%comm, ierr)
2452 :
2453 0 : else if (wfk%formeig == 1) then
2454 :
2455 : ! Increment my_offset to account for the previous eigen and cg records of (iband-1) bands.
2456 0 : my_offset = wfk%offset_ks(ik_ibz,spin,REC_CG) + xmpio_bsize_frm
2457 : my_offset = my_offset + (bstart - 1) * ( &
2458 : (2*npw_disk*wfk%nspinor*xmpi_bsize_dp + 2*xmpio_bsize_frm) + &
2459 0 : (2*nband_disk*xmpi_bsize_dp + 2*xmpio_bsize_frm) )
2460 :
2461 0 : sizes = [npw_disk*nspinor_disk, nband_disk]
2462 0 : types = [MPI_DOUBLE_COMPLEX, MPI_DOUBLE_COMPLEX]
2463 :
2464 0 : call xmpio_create_fstripes(nb,sizes,types,cg_type,my_offpad,mpierr)
2465 0 : ABI_CHECK_MPI(mpierr, "xmpio_create_fstripes")
2466 :
2467 0 : call MPI_FILE_SET_VIEW(wfk%fh,my_offset,MPI_BYTE,cg_type,'native',xmpio_info,mpierr)
2468 0 : ABI_CHECK_MPI(mpierr, "SET_VIEW")
2469 0 : call MPI_TYPE_FREE(cg_type,mpierr)
2470 0 : ABI_CHECK_MPI(mpierr, "TYPE_FREE")
2471 :
2472 0 : if (sc_mode == xmpio_collective) then
2473 0 : call MPI_FILE_READ_ALL(wfk%fh,buffer,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
2474 0 : else if (sc_mode == xmpio_single) then
2475 0 : call MPI_FILE_READ(wfk%fh,buffer,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
2476 : else
2477 0 : ABI_ERROR("Wrong sc_mode")
2478 : end if
2479 0 : ABI_CHECK_MPI(mpierr, "FILE_READ")
2480 : end if
2481 :
2482 : ! Extract my bands from buffer.
2483 0 : do band=bstart,bstop
2484 0 : if (bmask(band)) then
2485 0 : my_bcnt = my_bcnt + 1
2486 0 : pt1 = 1 + (my_bcnt - 1) * ugsz
2487 0 : pt2 = 1 + (band - bstart) * ugsz
2488 0 : cg_k(:,pt1:pt1+ugsz-1) = buffer(:,pt2:pt2+ugsz-1)
2489 : end if
2490 : end do
2491 :
2492 0 : ABI_FREE(buffer)
2493 : end do
2494 :
2495 : case (1, 2)
2496 : ABI_CHECK(wfk%formeig == 0, "formeig == 1 not coded")
2497 : call MPI_TYPE_CONTIGUOUS(npw_disk*nspinor_disk,MPI_DOUBLE_COMPLEX,cg_type,mpierr)
2498 : ABI_CHECK_MPI(mpierr, "type_contigous")
2499 :
2500 : if (method == 1) then
2501 : ncount = nb_tot
2502 : ABI_MALLOC(block_length, (ncount+2))
2503 : ABI_MALLOC(block_type, (ncount+2))
2504 : ABI_MALLOC(block_displ, (ncount+2))
2505 :
2506 : block_length(1)=1
2507 : block_displ (1)=0
2508 : block_type (1)=MPI_LB
2509 :
2510 : my_bcount = 1
2511 : do band=1,Wfk%mband
2512 : if (bmask(band)) then
2513 : my_bcount = my_bcount + 1
2514 : block_length(my_bcount) = 1
2515 : block_type(my_bcount) = cg_type
2516 : block_displ(my_bcount) = xmpio_bsize_frm + &
2517 : (band-1) * (2*npw_disk*nspinor_disk*xmpi_bsize_dp + 2*xmpio_bsize_frm)
2518 : end if
2519 : end do
2520 :
2521 : block_length(ncount+2) = 1
2522 : block_displ (ncount+2) = block_displ(my_bcount)
2523 : block_type (ncount+2) = MPI_UB
2524 :
2525 : else if (method == 2) then
2526 : ! this file view is not efficient but it's similar to the
2527 : ! one used in wff_readwrite. Let's see if MPI-IO likes it!
2528 : ncount = nb_tot* nspinor_disk * npw_disk
2529 :
2530 : ABI_MALLOC(block_length, (ncount+2))
2531 : ABI_MALLOC(block_type, (ncount+2))
2532 : ABI_MALLOC(block_displ, (ncount+2))
2533 :
2534 : block_length(1)=1
2535 : block_displ (1)=0
2536 : block_type (1)=MPI_LB
2537 : !
2538 : ! The view starts at REC_CG
2539 : cnt = 1
2540 : do band=1,Wfk%mband
2541 : if (bmask(band)) then
2542 : base_ofs = xmpio_bsize_frm + &
2543 : (band-1) * (2*npw_disk*nspinor_disk*xmpi_bsize_dp + 2*xmpio_bsize_frm)
2544 : do ipw=1,npw_disk*nspinor_disk
2545 : cnt = cnt + 1
2546 : block_length(cnt) = 1
2547 : block_type(cnt) = MPI_DOUBLE_COMPLEX
2548 : block_displ(cnt) = base_ofs + 2*(ipw-1)*xmpi_bsize_dp
2549 : end do
2550 : end if
2551 : end do
2552 :
2553 : block_length(ncount+2) = 1
2554 : block_displ (ncount+2) = block_displ(cnt)
2555 : block_type (ncount+2) = MPI_UB
2556 : end if
2557 :
2558 : call xmpio_type_struct(ncount+2,block_length,block_displ,block_type,cgscatter_type,mpierr)
2559 : ABI_CHECK_MPI(mpierr, "type_struct")
2560 :
2561 : ABI_FREE(block_length)
2562 : ABI_FREE(block_type)
2563 : ABI_FREE(block_displ)
2564 :
2565 : call MPI_TYPE_FREE(cg_type, mpierr)
2566 : ABI_CHECK_MPI(mpierr, "MPI_TYPE_FREE")
2567 :
2568 : my_offset = Wfk%offset_ks(ik_ibz,spin,REC_CG)
2569 :
2570 : call MPI_FILE_SET_VIEW(Wfk%fh, my_offset, MPI_BYTE, cgscatter_type, 'native', xmpio_info, mpierr)
2571 : ABI_CHECK_MPI(mpierr, "SET_VIEW")
2572 :
2573 : call MPI_TYPE_FREE(cgscatter_type, mpierr)
2574 : ABI_CHECK_MPI(mpierr, "MPI_TYPE_FREE")
2575 :
2576 : call MPI_FILE_READ_ALL(Wfk%fh, cg_k, npw_tot, MPI_DOUBLE_COMPLEX, MPI_STATUS_IGNORE, mpierr)
2577 : ABI_CHECK_MPI(mpierr, "FILE_READ_ALL")
2578 :
2579 : case default
2580 0 : ABI_ERROR("Wrong method")
2581 : end select
2582 : end if
2583 : #endif
2584 :
2585 : case (IO_MODE_ETSF)
2586 0 : ABI_CHECK(wfk%formeig == 0, "formeig != 0 not coded")
2587 : !write(std_out,*)"bmask: ",bmask
2588 :
2589 : ! TODO: extract routines (see other similar calls)
2590 0 : if (present(kg_k)) then
2591 : ! Read the reduced_coordinates_of_plane_waves for this k point.
2592 0 : NCF_CHECK(nf90_inq_varid(wfk%fh, "reduced_coordinates_of_plane_waves", kg_varid))
2593 0 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
2594 0 : NCF_CHECK(nctk_set_collective(wfk%fh, kg_varid))
2595 : end if
2596 :
2597 0 : ncerr = nf90_get_var(wfk%fh, kg_varid, kg_k, start=[1,1,ik_ibz], count=[3,npw_disk,1])
2598 0 : NCF_CHECK(ncerr)
2599 : end if
2600 :
2601 : ! Read eigenvalues and occupations.
2602 0 : if (Wfk%formeig==0) then
2603 0 : if (present(eig_k)) then
2604 0 : NCF_CHECK(nf90_inq_varid(wfk%fh, "eigenvalues", eig_varid))
2605 0 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
2606 0 : NCF_CHECK(nctk_set_collective(wfk%fh, eig_varid))
2607 : end if
2608 :
2609 0 : ncerr = nf90_get_var(wfk%fh, eig_varid, eig_k, start=[1,ik_ibz,spin], count=[nband_disk,1,1])
2610 0 : NCF_CHECK(ncerr)
2611 : end if
2612 :
2613 0 : if (present(occ_k)) then
2614 0 : NCF_CHECK(nf90_inq_varid(wfk%fh, "occupations", occ_varid))
2615 0 : if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
2616 0 : NCF_CHECK(nctk_set_collective(wfk%fh, occ_varid))
2617 : end if
2618 :
2619 0 : ncerr = nf90_get_var(wfk%fh, occ_varid, occ_k, start=[1,ik_ibz,spin], count=[nband_disk,1,1])
2620 0 : NCF_CHECK_MSG(ncerr, "getting occ_k")
2621 : end if
2622 : else
2623 0 : ABI_ERROR("formeig !=0 not compatible with ETSF-IO")
2624 : end if
2625 :
2626 0 : if (present(cg_k)) then
2627 : ! The coefficients_of_wavefunctions on file have shape [cplex, mpw, nspinor, mband, nkpt, nsppol]
2628 0 : NCF_CHECK(nf90_inq_varid(wfk%fh, "coefficients_of_wavefunctions", cg_varid))
2629 : ! TODO: Collective
2630 : !if (sc_mode == xmpio_collective .and. wfk%nproc > 1) then
2631 : ! NCF_CHECK(nctk_set_collective(wfk%fh, cg_varid))
2632 : !end if
2633 : #if 0
2634 : ! Simple and very inefficient version for debugging.
2635 : ipw = 1
2636 : do band=1,wfk%mband
2637 : if (.not. bmask(band)) cycle
2638 : ncerr = nf90_get_var(wfk%fh, cg_varid, cg_k(:,ipw:), start=[1,1,1,band,ik_ibz,spin], &
2639 : count=[2,npw_disk,wfk%nspinor,1,1,1])
2640 : NCF_CHECK_MSG(ncerr, "getting cg_k block")
2641 : ipw = ipw + wfk%nspinor * npw_disk
2642 : end do
2643 : #else
2644 : ! Read bands in blocks defined by bmask.
2645 : ! be careful when in collective mode because processors may call the routine with nblocks==0
2646 : ! The coefficients_of_wavefunctions on file have shape [cplex, mpw, nspinor, mband, nkpt, nsppol]
2647 0 : call mask2blocks(bmask, nblocks, blocks)
2648 : !ABI_CHECK(nblocks /= 0, "nblocks==0")
2649 :
2650 0 : ipw = 1
2651 0 : do block=1,nblocks
2652 0 : band_block = blocks(:,block)
2653 0 : nb = band_block(2) - band_block(1) + 1
2654 : ncerr = nf90_get_var(wfk%fh, cg_varid, cg_k(:,ipw:), start=[1,1,1,band_block(1),ik_ibz,spin], &
2655 0 : count=[2,npw_disk,wfk%nspinor,nb,1,1])
2656 0 : NCF_CHECK_MSG(ncerr, "getting cg_k block")
2657 0 : ipw = ipw + wfk%nspinor * npw_disk * nb
2658 : end do
2659 0 : ABI_FREE(blocks)
2660 : #endif
2661 :
2662 : ! Prototype for collective version.
2663 : !min_band = lfind(bmask); if min_
2664 : !max_band = lfind(bmask, back=.True.) ! n+1
2665 : !! TODO: xmpi_min_max
2666 : !call xmpi_max(my_min_band, min_band, comm_cell, ierr)
2667 : !call xmpi_min(my_min_band, max_band, comm_cell, ierr)
2668 : !nb = max_band - min_band + 1
2669 : !ncalls = nb /
2670 :
2671 : !NCF_CHECK(nf90_var_par_access(ncid, cg_varid, nf90_collective))
2672 : !do block=1,nblocks
2673 : ! ! The coefficients_of_wavefunctions on file have shape [cplex, mpw, nspinor, mband, nkpt, nsppol]
2674 : ! ncerr = nf90_get_var(wfk%fh, cg_varid, cg_k, start=[1,1,1,band_block(1),ik_ibz,spin], &
2675 : ! count=[2,npw_disk,wfk%nspinor,band_block(2)-band_block(1)+1,1,1])
2676 : ! NCF_CHECK_MSG(ncerr, "getting cg_k block")
2677 : ! do band=band_start,band_end
2678 : ! if (.not. bmask(band)) cycle
2679 : ! cg_k(:,:) =
2680 : ! end do
2681 : !end do
2682 : end if
2683 :
2684 : case default
2685 0 : ABI_ERROR(sjoin('Wrong/unsupported value of iomode: ', itoa(wfk%iomode)))
2686 : end select
2687 :
2688 : DBG_EXIT("COLL")
2689 :
2690 0 : return
2691 :
2692 : ! Handle Fortran IO error
2693 : 10 continue
2694 0 : ABI_ERROR(errmsg)
2695 :
2696 0 : end subroutine wfk_read_bmask
2697 : !!***
2698 :
2699 : !----------------------------------------------------------------------
2700 :
2701 : !!****f* m_wfk/wfk_read_ebands
2702 : !! NAME
2703 : !! wfk_read_ebands
2704 : !!
2705 : !! FUNCTION
2706 : !! Read the GS eigenvalues and return ebands_t object.
2707 : !!
2708 : !! INPUTS
2709 : !! path=WFK file name
2710 : !! comm=MPI communicator
2711 : !!
2712 : !! OUTPUTS
2713 : !! ebands<ebands_t>=GS band-structure.
2714 : !! [out_hdr]=Abinit header.
2715 : !!
2716 : !! SOURCE
2717 :
2718 113 : type(ebands_t) function wfk_read_ebands(path, comm, out_hdr) result(ebands)
2719 :
2720 : !Arguments ------------------------------------
2721 : !scalars
2722 : character(len=*),intent(in) :: path
2723 : integer,intent(in) :: comm
2724 : type(hdr_type),optional,intent(inout) :: out_hdr ! ifort and others are buggy for optional intent(out) structured types
2725 :
2726 : !Local variables-------------------------------
2727 : !scalars
2728 113 : type(hdr_type) :: hdr
2729 : !arrays
2730 113 : real(dp),pointer :: eigen(:,:,:)
2731 : !************************************************************************
2732 :
2733 113 : call wfk_read_eigenvalues(path, eigen, hdr, comm)
2734 8338 : call ebands%from_hdr(hdr, maxval(hdr%nband), eigen)
2735 113 : if (present(out_hdr)) call hdr%copy(out_hdr)
2736 :
2737 113 : ABI_FREE(eigen)
2738 113 : call hdr%free()
2739 :
2740 226 : end function wfk_read_ebands
2741 : !!***
2742 :
2743 : !----------------------------------------------------------------------
2744 :
2745 : !!****f* m_wfk/wfk_read_eigk
2746 : !! NAME
2747 : !! wfk_read_eigk
2748 : !!
2749 : !! FUNCTION
2750 : !! Helper function to read all the eigenvalues for a given (k-point,spin)
2751 : !!
2752 : !! INPUTS
2753 : !! Wfk<class(wfk_t)>= WFK file handler
2754 : !! ik_ibz=Index of the k-point in the IBZ.
2755 : !! spin=spin index
2756 : !! sc_mode= MPI-IO option
2757 : !! xmpio_single ==> for reading by current proc.
2758 : !! xmpio_collective ==> for collective reading.
2759 : !!
2760 : !! OUTPUTS
2761 : !! eig_k(1:nband_k) = GS Eigenvalues for the given (k,s)
2762 : !! occ_k(1:nband_k) = Occupation factors for the given (k,s)
2763 : !!
2764 : !! NOTES
2765 : !! The buffers eig_k and occ_k are dimensions with wfk%mband. The routine
2766 : !! will fill the first nband_k positions with data read from file where
2767 : !! nband_k is the number of bands on file i.e. wfk%nband(ik_ibz,spin)
2768 : !!
2769 : !! SOURCE
2770 :
2771 15678 : subroutine wfk_read_eigk(Wfk,ik_ibz,spin,sc_mode,eig_k,occ_k)
2772 :
2773 : !Arguments ------------------------------------
2774 : !scalars
2775 : integer,intent(in) :: ik_ibz,spin,sc_mode
2776 : class(wfk_t),intent(inout) :: Wfk
2777 : !arrays
2778 : real(dp),intent(out) :: eig_k((2*Wfk%mband)**Wfk%formeig*Wfk%mband)
2779 : real(dp),optional,intent(out) :: occ_k(Wfk%mband)
2780 :
2781 : !Local variables-------------------------------
2782 : !scalars
2783 : integer,parameter :: band_block00(2) = [0, 0]
2784 : !************************************************************************
2785 :
2786 15678 : if (present(occ_k)) then
2787 0 : ABI_CHECK(Wfk%formeig == 0, "formeig !=0")
2788 0 : call wfk%read_band_block(band_block00,ik_ibz,spin,sc_mode,eig_k=eig_k,occ_k=occ_k)
2789 : else
2790 15678 : call wfk%read_band_block(band_block00,ik_ibz,spin,sc_mode,eig_k=eig_k)
2791 : end if
2792 :
2793 15678 : end subroutine wfk_read_eigk
2794 : !!***
2795 :
2796 : !----------------------------------------------------------------------
2797 :
2798 : !!****f* m_wfk/wfk_read_eigenvalues
2799 : !! NAME
2800 : !! wfk_read_eigenvalues
2801 : !!
2802 : !! FUNCTION
2803 : !! Read all the GS eigenvalues stored in the WFK file fname.
2804 : !!
2805 : !! INPUTS
2806 : !! fname=Name of the file
2807 : !! comm=MPI communicator.
2808 : !!
2809 : !! OUTPUTS
2810 : !! eigen = In input: nullified pointer
2811 : !! In output: eigen(mband,nkpt,nsppol) contains the GS eigevalues.
2812 : !! Hdr_out<hdr_type>=The header of the file
2813 : !!
2814 : !! SOURCE
2815 :
2816 510 : subroutine wfk_read_eigenvalues(fname, eigen, Hdr_out, comm, occ)
2817 :
2818 : !Arguments ------------------------------------
2819 : !scalars
2820 : integer,intent(in) :: comm
2821 : character(len=*),intent(in) :: fname
2822 : type(hdr_type),intent(out) :: Hdr_out
2823 : !arrays
2824 : !TODO: Replace pointers with allocatable.
2825 : real(dp),pointer :: eigen(:,:,:)
2826 : real(dp),pointer,optional :: occ(:,:,:)
2827 :
2828 : !Local variables-------------------------------
2829 : !scalars
2830 : integer,parameter :: master = 0, formeig0 = 0
2831 : integer :: ik_ibz,spin,my_rank,ierr,iomode,funt,sc_mode,mband
2832 : real(dp) :: cpu, wall, gflops, cpu_io, wall_io, gflops_io
2833 2040 : type(wfk_t) :: Wfk
2834 : !************************************************************************
2835 :
2836 510 : call cwtime(cpu, wall, gflops, "start")
2837 510 : my_rank = xmpi_comm_rank(comm)
2838 510 : iomode = iomode_from_fname(fname)
2839 :
2840 : ! Should not do this but it seems that read_eigk with IO_MODE_MPI is very inefficient when
2841 : ! we read files with lots of k-points.
2842 510 : if (iomode == IO_MODE_MPI) iomode = IO_MODE_FORTRAN
2843 :
2844 510 : call wrtout(std_out, sjoin(" Reading eigenvalues from:", fname, ", with iomode:", iomode2str(iomode)))
2845 :
2846 510 : if (my_rank == master) then
2847 : ! Master reads and broadcasts
2848 450 : call cwtime(cpu_io, wall_io, gflops_io, "start")
2849 :
2850 : ! Open the file.
2851 450 : sc_mode = xmpio_single
2852 450 : funt = get_unit()
2853 450 : call wfk%open_read(fname, formeig0, iomode, funt, xmpi_comm_self, Hdr_out=Hdr_out)
2854 :
2855 : ! Read the eigenvalues and optionally the occupation factors.
2856 2250 : ABI_MALLOC(eigen, (Wfk%mband, Wfk%nkpt, Wfk%nsppol))
2857 192540 : eigen = HUGE(zero)
2858 450 : if (present(occ)) then
2859 0 : ABI_MALLOC(occ, (Wfk%mband, Wfk%nkpt, Wfk%nsppol))
2860 0 : occ = HUGE(zero)
2861 : end if
2862 :
2863 907 : do spin=1,Wfk%nsppol
2864 12015 : do ik_ibz=1,Wfk%nkpt
2865 11565 : if (present(occ)) then
2866 0 : call wfk%read_eigk(ik_ibz, spin, sc_mode, eigen(:,ik_ibz,spin), occ_k=occ(:,ik_ibz,spin))
2867 : else
2868 11108 : call wfk%read_eigk(ik_ibz, spin, sc_mode, eigen(:,ik_ibz,spin))
2869 : end if
2870 : end do
2871 : end do
2872 :
2873 : ! Close the file.
2874 450 : call wfk%close()
2875 900 : call cwtime_report(" wfk_read_eigenvalues_io", cpu_io, wall_io, gflops_io)
2876 : end if
2877 :
2878 : ! Broadcast data
2879 510 : if (xmpi_comm_size(comm) > 1) then
2880 90 : call Hdr_out%bcast(master, my_rank, comm)
2881 1086 : mband = MAXVAL(Hdr_out%nband)
2882 90 : if (my_rank /= master) then
2883 300 : ABI_MALLOC(eigen, (mband, Hdr_out%nkpt, Hdr_out%nsppol))
2884 60 : if (present(occ)) then
2885 0 : ABI_MALLOC(occ, (mband, Hdr_out%nkpt, Hdr_out%nsppol))
2886 : end if
2887 : end if
2888 90 : call xmpi_bcast(eigen, master, comm, ierr)
2889 90 : if (present(occ)) call xmpi_bcast(occ, master, comm, ierr)
2890 : end if
2891 :
2892 510 : call cwtime_report(" wfk_read_eigenvalues", cpu, wall, gflops)
2893 :
2894 510 : end subroutine wfk_read_eigenvalues
2895 : !!***
2896 :
2897 : !----------------------------------------------------------------------
2898 :
2899 : !!****f* m_wfk/wfk_read_my_kptbands
2900 : !! NAME
2901 : !! wfk_read_my_kptbands
2902 : !!
2903 : !! FUNCTION
2904 : !! Fill a cg (kg, eigen, occ) array with wavefunctions in a given BZ
2905 : !! based on a distribution of k, b, s attributed to present processor
2906 : !!
2907 : !! INPUTS
2908 : !! inpath_ = file name
2909 : !! distrb_flags = logical mask for band, k, spins on this processor
2910 : !! comm = mpi communicator
2911 : !! formeig = flag for GS or response function format of eigenvalues
2912 : !! istwfk_in = reciprocal space storage (reduced PW sphere or not)
2913 : !! kptns_in = requested k points, to be extracted from file or completed
2914 : !! nkpt_in = number of requested k
2915 : !! npwarr = array of number of plane waves at each k
2916 : !! istwfk_in = storage flag for plane waves
2917 : !! mcg = max size of cg array
2918 : !! mband_in = max number of bands over all k
2919 : !! mband_mem_in = max number of bands stored on each processor
2920 : !! nkpt_in = total number of k-points
2921 : !! nspinor_in = number of spinor components 1 or 2
2922 : !! nsppol_in = number of spin polarization channels
2923 : !! usepaw_in = enable PAW or not? (1/0)
2924 : !!
2925 : !! OUTPUT
2926 : !! cg = plane wave coefficients
2927 : !! kg = plane wave coordinates
2928 : !! eigen = eigenvectors at all bands and my k
2929 : !! occ = occupations of all bands at my k
2930 : !! pawrhoij = PAW matrix elements in projectors
2931 : !!
2932 : !! SOURCE
2933 :
2934 7782 : subroutine wfk_read_my_kptbands(inpath_, distrb_flags, comm, ecut_eff_in, &
2935 3891 : formeig, istwfk_in, kptns_in, mcg, mband_in, mband_mem_in, mkmem_in, mpw_in, &
2936 3891 : natom_in, nkpt_in, npwarr, nspinor_in, nsppol_in, usepaw_in, &
2937 7161 : cg, kg, eigen, occ, pawrhoij, ask_accurate_)
2938 :
2939 : !Arguments ------------------------------------
2940 : !scalars
2941 : integer, intent(in) :: comm, nkpt_in, formeig
2942 : integer, intent(in) :: mcg, mpw_in, mkmem_in
2943 : integer, intent(in) :: mband_in, mband_mem_in, natom_in, nspinor_in, nsppol_in, usepaw_in
2944 : real(dp), intent(in) :: ecut_eff_in
2945 : !=dtset%ecut*(dtset%dilatmx)**2 ! ecut * dilatmx**2
2946 : !arrays
2947 : integer, intent(in) :: istwfk_in(nkpt_in)
2948 : integer, intent(in) :: npwarr(nkpt_in)
2949 : character(len=fnlen), intent(in) :: inpath_
2950 : logical, intent(in) :: distrb_flags(nkpt_in,mband_in,nsppol_in)
2951 : real(dp), intent(in),target :: kptns_in(3,nkpt_in)
2952 : real(dp), intent(out) :: cg(2,mcg)
2953 : integer, intent(out), optional :: kg(3,mpw_in*mkmem_in)
2954 : real(dp), intent(out), optional :: eigen(mband_in*(2*mband_in)**formeig*nkpt_in*nsppol_in)
2955 : real(dp), intent(out), optional :: occ(mband_in*nkpt_in*nsppol_in)
2956 : type(pawrhoij_type),intent(inout),optional,target :: pawrhoij(natom_in)
2957 : integer, intent(in), optional :: ask_accurate_
2958 :
2959 : !Local variables-------------------------------
2960 : !scalars
2961 : integer,parameter :: formeig0 = 0, master = 0
2962 : integer :: spin,ikf,ik_disk,nband_k,mpw_disk,mband,nspinor
2963 : integer :: iomode,nsppol,isym,itimrev
2964 : integer :: npw_disk,npw_kf,istwf_disk,istwf_kf
2965 : integer :: ikpt,ii,jj,kk,ll,iqst,nqst
2966 : integer :: ibdoff, ierr, my_rank
2967 : integer :: wfk_unt, iband, nband_me, nband_me_disk
2968 : integer :: nband_me_saved, iband_saved
2969 : integer :: spin_saved, spin_sym
2970 : integer :: mpierr
2971 : integer :: ask_accurate, sppoldbl
2972 : real(dp) :: cpu, wall, gflops
2973 : real(dp) :: ecut_eff_disk
2974 : real(dp) :: dksqmax
2975 : character(len=fnlen) :: inpath
2976 : logical :: isirred_kf
2977 : logical :: needthisk
2978 : logical :: convnsppol1to2
2979 15564 : type(wfk_t),target :: wfk_disk
2980 202332 : type(crystal_t) :: cryst
2981 : !arrays
2982 : integer :: g0(3),work_ngfft(18),gmax_disk(3),gmax_kf(3),gmax(3)
2983 3891 : integer,allocatable :: kg_kf(:,:), icg(:,:), ikg(:), ibdeig(:,:), ibdocc(:,:)
2984 3891 : integer,allocatable :: symrelT(:,:,:)
2985 3891 : integer,allocatable :: rbz2disk(:,:),kg_disk(:,:),iperm(:),rbz2disk_sort(:)
2986 : real(dp) :: kf(3),k_disk(3), ksym(3)
2987 7782 : real(dp),allocatable :: cg_disk(:,:),eig_disk(:),occ_disk(:),work(:,:,:,:)
2988 : ! *************************************************************************
2989 :
2990 3891 : call cwtime(cpu, wall, gflops, "start")
2991 :
2992 3891 : my_rank = xmpi_comm_rank(comm)
2993 :
2994 : ! Master checks the existence of data file
2995 3891 : if (my_rank == master) then
2996 3401 : inpath = inpath_
2997 3401 : if (.not. file_exists(inpath)) then
2998 : ! Trick needed to run Abinit test suite in netcdf mode.
2999 3401 : if (file_exists(nctk_ncify(inpath))) then
3000 3401 : write(std_out,"(3a)")"- File: ",trim(inpath)," does not exist but found netcdf file with similar name."
3001 6802 : inpath = nctk_ncify(inpath)
3002 : end if
3003 3401 : if (.not. file_exists(inpath)) then
3004 0 : ABI_ERROR('Missing data file: '//TRIM(inpath))
3005 : end if
3006 : end if
3007 : end if
3008 :
3009 3891 : call xmpi_bcast(inpath, master, comm, ierr)
3010 3891 : call wrtout(std_out, sjoin(" About to read wavefunctions from:", inpath))
3011 :
3012 : ! now attack the cg reading
3013 3891 : iomode = iomode_from_fname(inpath)
3014 3891 : wfk_unt = get_unit()
3015 :
3016 : ! TODO: this still does not read in parallel properly:
3017 : ! if I use xmpi_comm_self only the mother thread gets eigen and cg
3018 : ! if I use comm and MPIO_stuff then it hangs on this call
3019 : ! if I impose FORTRAN_IO and xmpio_single it complains the file is already opened by another proc
3020 : ABI_UNUSED(comm)
3021 3891 : call wfk_disk%open_read(inpath, formeig, iomode, wfk_unt, xmpi_comm_self)
3022 :
3023 1705546 : if(present(eigen)) eigen = zero
3024 1277293 : if(present(occ)) occ = zero
3025 3891 : if(present(kg)) kg = 0
3026 :
3027 : ! this initialization is needed in case we read a file with fewer bands and only fill part of cg
3028 865814151 : cg = zero
3029 :
3030 : ! ABI_CHECK(wfk_disk%mband >= mband_in, "input mband too large for this file")
3031 3891 : mband = wfk_disk%mband;
3032 3891 : ABI_CHECK(wfk_disk%nspinor == nspinor_in, "input nspinor does not agree with file")
3033 3891 : nspinor = wfk_disk%nspinor
3034 : !checks: impose each individual nband conserved wrt disk?
3035 :
3036 3891 : ABI_CHECK(wfk_disk%nsppol <= nsppol_in, "nsppol can not decrease when reading from disk")
3037 : !ABI_CHECK(wfk_disk%nsppol == nsppol_in, "nsppol does not agree with file")
3038 3891 : nsppol = nsppol_in;
3039 3891 : convnsppol1to2=.false.
3040 3891 : if (wfk_disk%nsppol < nsppol_in) convnsppol1to2 = .true.
3041 :
3042 : ! NB: npw can differ as can istwfk
3043 99545 : mpw_disk = maxval(wfk_disk%Hdr%npwarr)
3044 3891 : ecut_eff_disk = wfk_disk%hdr%ecut_eff ! ecut * dilatmx**2
3045 :
3046 11673 : ABI_MALLOC(kg_disk, (3, mpw_disk))
3047 11673 : ABI_MALLOC(cg_disk, (2, mpw_disk*nspinor*mband_mem_in))
3048 11673 : ABI_MALLOC(eig_disk, ((2*mband)**wfk_disk%formeig*mband) )
3049 11673 : ABI_MALLOC(occ_disk, (mband))
3050 :
3051 3891 : itimrev = kpts_timrev_from_kptopt(wfk_disk%hdr%kptopt)
3052 3891 : cryst = wfk_disk%hdr%get_crystal(itimrev + 1)
3053 :
3054 3891 : sppoldbl = 1
3055 11673 : ABI_MALLOC (rbz2disk, (sppoldbl*nkpt_in, 6))
3056 :
3057 11673 : ABI_MALLOC (symrelT, (3,3,cryst%nsym))
3058 : ! TODO: from Matteo, this should be symrel straight, not transposed. Perhaps the logic in mapkptsets is transposed?
3059 79704 : do isym=1,cryst%nsym
3060 989460 : symrelT(:,:,isym) = transpose(cryst%symrel(:,:,isym))
3061 : end do
3062 :
3063 3891 : ask_accurate=1
3064 3891 : if (present(ask_accurate_)) ask_accurate=ask_accurate_
3065 :
3066 : ! Use listkk instead of rank-based routines since in DFPT we may receive a k+q mesh
3067 : ! with q along a path --> max_linear_density in krank becomes large e.g. 1440
3068 : ! and the computation of the rank overflows.
3069 : ! Note also that ctgk_rotate assumes use_symrec=False and symrel in input.
3070 : call listkk(dksqmax, cryst%gmet, rbz2disk, wfk_disk%hdr%kptns, kptns_in, wfk_disk%hdr%nkpt, nkpt_in, cryst%nsym, &
3071 3891 : sppoldbl, cryst%symafm, cryst%symrel, cryst%timrev-1, xmpi_comm_self, use_symrec=.False.)
3072 :
3073 : !call xmpi_barrier(comm)
3074 3891 : if (ask_accurate == 1) then
3075 3874 : ABI_CHECK(dksqmax < tol8, sjoin("WFK file read but k-points too far from requested set, dksqmax:", ftoa(dksqmax)))
3076 : end if
3077 :
3078 : ! More efficienct algorithm based on random access IO:
3079 : ! For each point in the irred disk set:
3080 : ! - Read wavefunctions from wfk_disk
3081 : ! - For each k-point in the star of kpt_disk:
3082 : ! - Rotate wavefunctions in G-space to get the k-point in the requested BZ.
3083 : ! - save kbz data.
3084 :
3085 : ! Construct sorted mapping RBZ --> irred kdisk set, to speedup qbz search below.
3086 11673 : ABI_MALLOC(iperm, (nkpt_in))
3087 7782 : ABI_MALLOC(rbz2disk_sort, (nkpt_in))
3088 845166 : iperm = [(ii, ii=1,nkpt_in)]
3089 286910 : rbz2disk_sort = rbz2disk(:,1)
3090 3891 : call sort_int(nkpt_in, rbz2disk_sort, iperm)
3091 :
3092 : ! prepare offsets for k-points, which could arrive in a random order from the irred k
3093 : ! these are valid in the output arrays, not in the disk file
3094 : !TODO: if nband_me is not constant over the k-points, this becomes a huge pain to predict...
3095 15564 : ABI_MALLOC(icg, (nkpt_in,nsppol))
3096 7782 : ABI_MALLOC(ikg, (nkpt_in))
3097 11673 : ABI_MALLOC(ibdeig, (nkpt_in,nsppol))
3098 11673 : ABI_MALLOC(ibdocc, (nkpt_in,nsppol))
3099 290030 : icg = 0
3100 283019 : ikg = 0
3101 290030 : ibdeig = 0
3102 290030 : ibdocc = 0
3103 3891 : ii = 0
3104 3891 : kk = 0
3105 3891 : ll = 0
3106 8028 : do spin=1,nsppol
3107 : jj = 0
3108 290030 : do ikpt=1,nkpt_in
3109 282002 : ik_disk = rbz2disk(ikpt,1)
3110 :
3111 : ! conversion of single spin AFM wfk file to full 2 component one in memory
3112 282002 : spin_sym=spin
3113 282002 : if (convnsppol1to2) spin_sym=1
3114 : ! this allows for reading fewer bands from disk than the disk version of nband
3115 282002 : nband_k = min(wfk_disk%nband(ik_disk,spin_sym), mband_in)
3116 282002 : ibdeig(ikpt,spin) = kk
3117 282002 : ibdocc(ikpt,spin) = ll
3118 282002 : kk = kk+nband_k*(2*nband_k)**formeig
3119 282002 : ll = ll+nband_k
3120 :
3121 576786 : if (.not. any(distrb_flags(ikpt,:,spin))) cycle
3122 : ! TODO: this does not take into account variable nband(ik)
3123 225778 : icg(ikpt,spin) = ii
3124 225778 : ikg(ikpt) = jj
3125 : ! this allows for variable nband_k < mband_mem
3126 225778 : ii = ii+min(nband_k,mband_mem_in)*npwarr(ikpt)*nspinor_in
3127 286139 : jj = jj+npwarr(ikpt)
3128 : end do
3129 : end do
3130 :
3131 : ! main loop reading in wfk and spinning them out to all kptns_in which need them
3132 :
3133 : ! MG TODO: I believe this is not the most efficient way to implement the IO algorithm
3134 : ! One might have only the master proc reading all the (ik_ibz, spin, mband) states
3135 : ! perhaps blocking on the band dimension to reduce memory and then broadcast the block of bands.
3136 : ! At this point, each proc rotates the wavefunctions and store it in memory if these states are needed.
3137 :
3138 8026 : do spin=1,nsppol
3139 : ! for nsppol=1 input and nsppol=2 run, no need to continue the spin loop
3140 4137 : if (convnsppol1to2 .and. spin > 1) exit
3141 :
3142 106474 : do ik_disk=1,wfk_disk%hdr%nkpt
3143 393792 : k_disk = wfk_disk%hdr%kptns(:, ik_disk)
3144 :
3145 : ! this allows for reading fewer bands from disk than the maximum
3146 98448 : nband_k = min(wfk_disk%nband(ik_disk,spin), mband_in)
3147 98448 : istwf_disk = wfk_disk%hdr%istwfk(ik_disk)
3148 98448 : npw_disk = wfk_disk%hdr%npwarr(ik_disk)
3149 :
3150 : ! Find number of symmetric k-points associated to ik_disk
3151 98448 : nqst = 0
3152 98448 : needthisk=.false.
3153 : iqst = 0
3154 : ! scan to the first point which uses this kdisk
3155 11107313 : do iqst = 1, nkpt_in
3156 11107313 : if (rbz2disk_sort(iqst) == ik_disk) exit
3157 : end do
3158 : ! how many equivalent k? Could be 0, and we will not necessarily use them all if their bands are on other cpus
3159 380448 : do ii=iqst, nkpt_in
3160 371459 : if (rbz2disk_sort(ii) /= ik_disk) exit
3161 282000 : nqst = nqst + 1
3162 576784 : if (any(distrb_flags(iperm(ii),:,spin))) needthisk=.true.
3163 675232 : if (convnsppol1to2 .and. any(distrb_flags(iperm(ii),:,nsppol+1-spin))) needthisk=.true.
3164 : end do ! loop over equivalent k
3165 :
3166 : ! do we need the present kdisk, or one of its images?
3167 : ! TODO: check if the eigenvalues are correct all the same
3168 98448 : if (.not. needthisk) cycle
3169 :
3170 89331 : ABI_CHECK(nqst > 0 .and. rbz2disk_sort(iqst) == ik_disk, "Wrong iqst")
3171 :
3172 : ! loop over equivalent images found in rbz set for current k_disk point
3173 : iband_saved = -1
3174 : nband_me_saved = -1
3175 370800 : do jj=0,nqst-1
3176 277334 : ikf = iperm(iqst+jj)
3177 277334 : ABI_CHECK(ik_disk == rbz2disk(ikf,1), "ik_disk !/ ind qq(1)")
3178 :
3179 1109336 : kf = kptns_in(:,ikf)
3180 277334 : istwf_kf = istwfk_in(ikf)
3181 277334 : npw_kf = npwarr(ikf)
3182 :
3183 658826 : do spin_sym = 1, nsppol
3184 283044 : if (.not. convnsppol1to2 .and. spin_sym /= spin) cycle
3185 :
3186 : ! how many bands in memory for this cpu_
3187 1859319 : nband_me = count(distrb_flags(ikf,:,spin_sym))
3188 : ! no need to put wfk at this k for this processor into memory
3189 277336 : if (nband_me == 0) cycle
3190 :
3191 : ! find starting band index
3192 226066 : do iband = 1, nband_k
3193 226066 : if (distrb_flags(ikf,iband,spin_sym)) exit
3194 : end do
3195 : ! check bands are contiguous in distrb_flags for this ikf and find first band needed, iband
3196 225778 : if (.not. distrb_flags(ikf,iband+nband_me-1,spin_sym)) then
3197 0 : ABI_ERROR("wfk_read_my_kptbands: bands not contiguous in distrb_flags")
3198 : end if
3199 :
3200 : ! if nband_me goes beyond the end of the bands on disk, just read those we have
3201 225778 : nband_me_disk = min(nband_k,nband_me)
3202 :
3203 : ! In parallel, iband+nband_me-1 could be larger than mband_disk
3204 : ! we want to limit nband_me_disk in that case too, just for the last band procs
3205 225778 : if (iband+nband_me-1 > nband_k) then
3206 9 : nband_me_disk = nband_k+1-iband
3207 : end if
3208 :
3209 : ! may need to re-read if for a different equivalent k if I need other bands
3210 225778 : if (iband /= iband_saved .or. nband_me_disk /= nband_me_saved .or. spin /= spin_saved) then
3211 89331 : if (formeig > 0) then
3212 : call wfk_disk%read_band_block([iband,iband+nband_me_disk-1],ik_disk,spin,xmpio_single,&
3213 483 : kg_k=kg_disk,cg_k=cg_disk,eig_k=eig_disk)
3214 : else
3215 : call wfk_disk%read_band_block([iband,iband+nband_me_disk-1],ik_disk,spin,xmpio_single,&
3216 267510 : kg_k=kg_disk,cg_k=cg_disk,eig_k=eig_disk,occ_k=occ_disk)
3217 : end if
3218 : ! in nsppol=1 nspden=2 case the occupations are doubled
3219 89331 : if (convnsppol1to2) then
3220 4 : occ_disk = half * occ_disk
3221 : end if
3222 : iband_saved = iband
3223 : nband_me_saved = nband_me_disk
3224 : spin_saved = spin
3225 : end if
3226 :
3227 : ! reset isym for each spin_sym
3228 225778 : isym = rbz2disk(ikf,2)
3229 : ! there is a first time reversal possible from the irred set found above to the kptns in input.
3230 : ! a second possible time reversal if the irred k is not explicitly in the disk file, but only it's time reversed image
3231 225778 : itimrev = rbz2disk(ikf,6)
3232 903112 : g0 = rbz2disk(ikf,3:5) ! IS(k_disk) + g0 = k_bz
3233 :
3234 : ! complete the spin down wfk with an AFM symop
3235 225778 : if (spin_sym /= spin) then
3236 : ! try next symop to find afm operation to get the spin component we want
3237 4 : do isym = 1, cryst%nsym
3238 4 : if (cryst%symafm(isym) == 1) cycle
3239 50 : ksym = matmul(symrelT(:,:,isym), k_disk)
3240 8 : if (sum(abs(ksym-kf)) < tol8) exit
3241 : end do
3242 2 : ABI_CHECK(isym <= cryst%nsym, "did not find the AFM symop I need to get isppol=2 wave functions from disk")
3243 : end if
3244 :
3245 756350 : isirred_kf = (isym == 1 .and. itimrev == 0 .and. all(g0 == 0) .and. cryst%symafm(isym) == 1)
3246 225778 : if (present(eigen)) then
3247 225778 : ibdoff = ibdeig(ikf,spin_sym)+(iband-1)*(2*nband_k)**formeig
3248 : eigen(ibdoff+1:ibdoff+nband_me_disk*(2*nband_k)**formeig) = &
3249 1571165 : eig_disk((iband-1)*(2*nband_k)**formeig+1:(iband-1+nband_me_disk)*(2*nband_k)**formeig)
3250 : end if
3251 225778 : if (present(occ)) then
3252 181067 : ibdoff = ibdocc(ikf,spin_sym)+(iband-1)
3253 1224541 : occ(ibdoff+1:ibdoff+nband_me_disk) = occ_disk(iband:iband-1+nband_me_disk)
3254 : end if
3255 :
3256 : ! The test on npwarr is needed because we may change istwfk e.g. gamma.
3257 503112 : if (isirred_kf .and. wfk_disk%hdr%npwarr(ik_disk) == npwarr(ikf)) then
3258 80300 : if (present(kg)) then
3259 0 : kg(:,ikg(ikf)+1:ikg(ikf)+npw_kf) = kg_disk (:,1:npw_kf)
3260 : end if
3261 : cg(:,icg(ikf,spin_sym)+1:icg(ikf,spin_sym)+npw_kf*nband_me_disk*nspinor_in) = &
3262 458112293 : cg_disk(:,1:npw_kf*nband_me_disk*nspinor_in)
3263 : else
3264 : ! Compute G-sphere centered on kf
3265 145478 : call get_kg(kf,istwf_kf,ecut_eff_in,cryst%gmet,npw_kf,kg_kf)
3266 : ! npw found for the present sphere must be equal to size of array for output
3267 145478 : ABI_CHECK(npw_kf == npwarr(ikf), "Wrong npw_kf")
3268 :
3269 145478 : if (present(kg)) then
3270 0 : kg(:,ikg(ikf)+1:ikg(ikf)+npw_kf) = kg_kf (:,1:npw_kf)
3271 : end if
3272 :
3273 : ! FFT box must enclose the two spheres centered on kdisk and kf
3274 73320410 : gmax_disk = maxval(abs(kg_disk(:,1:npw_disk)), dim=2)
3275 75708090 : gmax_kf = maxval(abs(kg_kf), dim=2)
3276 581912 : do ii=1,3
3277 581912 : gmax(ii) = max(gmax_disk(ii), gmax_kf(ii))
3278 : end do
3279 581912 : gmax = 2*gmax + 1
3280 145478 : call ngfft_seq(work_ngfft, gmax)
3281 207740390 : ABI_CALLOC(work, (2, work_ngfft(4),work_ngfft(5),work_ngfft(6)))
3282 :
3283 : ! Rotate nband_k wavefunctions (output in cg)
3284 : call cgtk_rotate(cryst,k_disk,isym,itimrev,g0,nspinor,nband_me_disk,&
3285 : npw_disk,kg_disk,npw_kf,kg_kf,istwf_disk,istwf_kf,cg_disk,&
3286 : cg(:,icg(ikf,spin_sym)+1:icg(ikf,spin_sym)+npw_kf*nband_me_disk*nspinor_in),&
3287 145478 : work_ngfft,work)
3288 :
3289 145478 : ABI_FREE(work)
3290 145478 : ABI_FREE(kg_kf)
3291 : end if
3292 : end do ! spin_sym
3293 : end do ! equiv kpt jj
3294 : end do ! kpt disk
3295 : end do ! sppol
3296 :
3297 : ! this sums over the whole kpt communicator, so also the band procs.
3298 : ! need to 0 out bands which are not mine
3299 3891 : if(present(eigen)) call xmpi_sum(eigen,comm,mpierr)
3300 3891 : if(present(occ)) call xmpi_sum(occ,comm,mpierr)
3301 3891 : if(present(kg)) call xmpi_sum(kg,comm,mpierr)
3302 :
3303 3891 : if(present(pawrhoij) .and. usepaw_in==1) call pawrhoij_copy(wfk_disk%hdr%pawrhoij,pawrhoij)
3304 :
3305 3891 : ABI_FREE(icg)
3306 3891 : ABI_FREE(ikg)
3307 3891 : ABI_FREE(ibdeig)
3308 3891 : ABI_FREE(ibdocc)
3309 3891 : ABI_FREE(symrelT)
3310 3891 : ABI_FREE(iperm)
3311 3891 : ABI_FREE(rbz2disk_sort)
3312 3891 : ABI_FREE(rbz2disk)
3313 3891 : ABI_FREE(kg_disk)
3314 3891 : ABI_FREE(cg_disk)
3315 3891 : ABI_FREE(eig_disk)
3316 3891 : ABI_FREE(occ_disk)
3317 :
3318 3891 : call cryst%free()
3319 3891 : call wfk_disk%close()
3320 :
3321 3891 : call cwtime_report(" wfk_read_my_kptbands:", cpu, wall, gflops)
3322 :
3323 18722 : end subroutine wfk_read_my_kptbands
3324 : !!***
3325 :
3326 : !----------------------------------------------------------------------
3327 :
3328 : !!****f* m_wfk/wfk_write_my_kptbands
3329 : !! NAME
3330 : !! wfk_write_my_kptbands
3331 : !!
3332 : !! FUNCTION
3333 : !! From a cg (kg, eigen, occ) array write the corresponding file
3334 : !! distributed bands on all procs, not just k-points
3335 : !!
3336 : !! INPUTS
3337 : !! outpath_ = file name
3338 : !! distrb_flags = logical mask for band, k, spins on this processor
3339 : !! comm = mpi communicator
3340 : !! formeig = flag for GS or response function format of eigenvalues
3341 : !! kptns_in = requested k points, to be extracted from file or completed
3342 : !! nkpt_in = number of requested k
3343 : !! npwarr = array of number of plane waves at each k
3344 : !! cg = plane wave coefficients
3345 : !! kg = plane wave coordinates
3346 : !! eigen = eigenvectors at all bands and my k
3347 : !! occ = occupations of all bands at my k
3348 : !!
3349 : !! OUTPUT
3350 : !! writes to file
3351 : !!
3352 : !! SOURCE
3353 :
3354 1876 : subroutine wfk_write_my_kptbands(outpath_, distrb_flags, comm, formeig, hdr,&
3355 : iomode_, mband_in, mband_mem_in, mkmem_in, mpw_in, nkpt_in, nspinor_in, nsppol_in, &
3356 1876 : cg_in, kg_in, eigen, occ)
3357 :
3358 : !Arguments ------------------------------------
3359 : !scalars
3360 : integer, intent(in) :: comm, nkpt_in, formeig, iomode_
3361 : integer, intent(in) :: mband_in,mband_mem_in,mpw_in, nspinor_in, nsppol_in
3362 : integer, intent(in) :: mkmem_in
3363 : type(hdr_type),intent(in) :: hdr
3364 : !arrays
3365 : character(len=fnlen), intent(in) :: outpath_
3366 : logical, intent(in) :: distrb_flags(nkpt_in,mband_in,nsppol_in)
3367 :
3368 : real(dp), intent(in), target :: cg_in(2,mpw_in*nspinor_in*mband_mem_in*mkmem_in*nsppol_in)
3369 : integer, intent(in), target :: kg_in(3,mpw_in*mkmem_in)
3370 : real(dp), intent(in) :: eigen((mband_in*(2*mband_in)**formeig)*nkpt_in*nsppol_in)
3371 : real(dp), intent(in),optional :: occ(mband_in*nkpt_in*nsppol_in)
3372 :
3373 : !Local variables-------------------------------
3374 : !scalars
3375 : integer :: spin,ik_rbz,nband_k, npw_k, iomode, wfk_unt, iband, nband_me, ii,jj,kk,ll
3376 1876 : integer, allocatable :: icg(:,:), ikg(:), ibdeig(:,:), ibdocc(:,:)
3377 1876 : integer, contiguous, pointer :: kg(:,:)
3378 : character(len=fnlen) :: outpath
3379 : real(dp) :: cpu, wall, gflops
3380 1876 : real(dp), contiguous, pointer :: cg(:,:)
3381 7504 : type(wfk_t),target :: wfk_disk
3382 : ! *************************************************************************
3383 :
3384 1876 : call cwtime(cpu, wall, gflops, "start")
3385 :
3386 : ! if iomode ncdf check that outpath has the correct termination
3387 1876 : outpath = outpath_
3388 1876 : iomode = iomode_
3389 1876 : if (iomode==IO_MODE_ETSF .and. .not. endswith(outpath, ".nc")) then
3390 1876 : outpath = nctk_ncify(outpath)
3391 : else
3392 : ! adjust for mpiio if needed
3393 0 : iomode = iomode_from_fname(outpath)
3394 : end if
3395 :
3396 1876 : wfk_unt = get_unit()
3397 1876 : wfk_disk%debug = .true.
3398 1876 : call wfk_disk%open_write(hdr,outpath,formeig,iomode,wfk_unt,comm) !xmpi_comm_self)
3399 :
3400 : ! no kpt on this proc, make local dummies for cg and kg
3401 1876 : if (mkmem_in == 0) then
3402 0 : ABI_MALLOC(cg, (2,mpw_in))
3403 0 : ABI_MALLOC(kg, (3,mpw_in))
3404 : else
3405 1876 : cg => cg_in
3406 1876 : kg => kg_in
3407 : end if
3408 :
3409 7504 : ABI_MALLOC(icg, (nkpt_in,nsppol_in))
3410 5628 : ABI_MALLOC(ikg, (nkpt_in))
3411 5628 : ABI_MALLOC(ibdeig, (nkpt_in,nsppol_in))
3412 5628 : ABI_MALLOC(ibdocc, (nkpt_in,nsppol_in))
3413 120067 : icg = 0
3414 116377 : ikg = 0
3415 120067 : ibdeig = 0
3416 120067 : ibdocc = 0
3417 1876 : ii = 0
3418 1876 : kk = 0
3419 1876 : ll = 0
3420 3914 : do spin=1,nsppol_in
3421 2038 : jj = 0
3422 120067 : do ik_rbz=1,nkpt_in
3423 : ! this allows for reading fewer bands from disk than the disk version of nband
3424 116153 : nband_k = hdr%nband(ik_rbz+(spin-1)*hdr%nkpt)
3425 116153 : ibdeig(ik_rbz,spin) = kk
3426 116153 : ibdocc(ik_rbz,spin) = ll
3427 116153 : kk = kk+nband_k*(2*nband_k)**formeig
3428 116153 : ll = ll+nband_k
3429 :
3430 240049 : if (.not. any(distrb_flags(ik_rbz,:,spin))) cycle
3431 : ! TODO: this does not take into account variable nband(ik)
3432 92449 : icg(ik_rbz,spin) = ii
3433 92449 : ikg(ik_rbz) = jj
3434 : ! this allows for variable nband_k < mband_mem
3435 92449 : ii = ii+min(nband_k,mband_mem_in)*hdr%npwarr(ik_rbz)*nspinor_in
3436 118191 : jj = jj+hdr%npwarr(ik_rbz)
3437 : end do
3438 : end do
3439 :
3440 3914 : do spin=1,nsppol_in
3441 120067 : do ik_rbz=1,nkpt_in
3442 :
3443 116153 : nband_k = hdr%nband(ik_rbz+(spin-1)*hdr%nkpt)
3444 116153 : npw_k = hdr%npwarr(ik_rbz)
3445 :
3446 : ! even if I do not have any bands to run, go through the mpio calls to avoid deadlocks
3447 : ! if (.not. any(distrb_flags(ik_rbz,:,spin))) then
3448 : ! ibdeig = ibdeig + nband_k*(2*nband_k)**formeig
3449 : ! ibdocc = ibdocc + nband_k
3450 : ! cycle
3451 : ! end if
3452 :
3453 : ! in case nband is not constant with k this creates chaos in the file writing
3454 : ! as distrb_flags is allocated for mband, and true
3455 749363 : nband_me = min(count(distrb_flags(ik_rbz,:,spin)), nband_k)
3456 116153 : if (nband_me == 0) then
3457 : iband = 1 ! does write_band_block accept the range [1,0]?
3458 : else
3459 92665 : do iband = 1, nband_k
3460 92665 : if (distrb_flags(ik_rbz,iband,spin)) exit
3461 : end do
3462 : !TODO: check all nband_me entries in distrib_flags - the distribution could be random but with iband+nband_me-1 .true.
3463 92449 : if (.not. distrb_flags(ik_rbz,iband+nband_me-1,spin)) then
3464 0 : ABI_ERROR("wfk_write_my_kptbands: bands not contiguous in distrb_flags")
3465 : end if
3466 : end if
3467 :
3468 118191 : if (present(occ)) then
3469 : call wfk_disk%write_band_block([iband,iband+nband_me-1],ik_rbz,spin,xmpio_collective,&
3470 : kg_k=kg(:,ikg(ik_rbz)+1:ikg(ik_rbz)+npw_k), &
3471 : cg_k=cg(:,icg(ik_rbz,spin)+1:icg(ik_rbz,spin)+npw_k*nband_me*nspinor_in),&
3472 : eig_k=eigen(ibdeig(ik_rbz,spin)+1:ibdeig(ik_rbz,spin)+nband_k*(2*nband_k)**formeig), &
3473 0 : occ_k=occ(ibdocc(ik_rbz,spin)+1:ibdocc(ik_rbz,spin)+nband_k))
3474 : else
3475 : call wfk_disk%write_band_block([iband,iband+nband_me-1],ik_rbz,spin,xmpio_collective,&
3476 : kg_k=kg(:,ikg(ik_rbz)+1:ikg(ik_rbz)+npw_k), &
3477 : cg_k=cg(:,icg(ik_rbz,spin)+1:icg(ik_rbz,spin)+npw_k*nband_me*nspinor_in),&
3478 348459 : eig_k=eigen(ibdeig(ik_rbz,spin)+1:ibdeig(ik_rbz,spin)+nband_k*(2*nband_k)**formeig))
3479 : end if
3480 :
3481 : end do ! kpt
3482 : end do ! sppol
3483 :
3484 1876 : call wfk_disk%close()
3485 :
3486 1876 : call cwtime_report(" wfk_write_my_kptbands. ", cpu, wall, gflops)
3487 :
3488 1876 : ABI_FREE(icg)
3489 1876 : ABI_FREE(ikg)
3490 1876 : ABI_FREE(ibdeig)
3491 1876 : ABI_FREE(ibdocc)
3492 1876 : if (mkmem_in == 0) then
3493 0 : ABI_FREE(cg)
3494 0 : ABI_FREE(kg)
3495 : end if
3496 :
3497 7504 : end subroutine wfk_write_my_kptbands
3498 : !!***
3499 :
3500 : !----------------------------------------------------------------------
3501 :
3502 : !!****f* m_wfk/wfk_write_h1mat
3503 : !! NAME
3504 : !! wfk_write_h1mat
3505 : !!
3506 : !! FUNCTION
3507 : !! Write all H1 matrix elements in the WFK file fname.
3508 : !!
3509 : !! INPUTS
3510 : !!
3511 : !! OUTPUTS
3512 : !!
3513 : !! SOURCE
3514 :
3515 0 : subroutine wfk_write_h1mat(Wfk,sc_mode,eigen)
3516 :
3517 : !Arguments ------------------------------------
3518 : !scalars
3519 : integer,intent(in) :: sc_mode
3520 : class(wfk_t),intent(inout) :: Wfk
3521 : !arrays
3522 : real(dp),intent(in) :: eigen(2*Wfk%mband**2*Wfk%nkpt*Wfk%nsppol)
3523 :
3524 : !Local variables-------------------------------
3525 : !scalars
3526 : integer :: spin,ik_ibz,nband_k,ptr
3527 : !arrays
3528 : integer,parameter :: band_block00(2)=[0,0]
3529 : !************************************************************************
3530 :
3531 0 : ptr=1
3532 0 : do spin=1,Wfk%nsppol
3533 0 : do ik_ibz=1,Wfk%nkpt
3534 0 : nband_k = Wfk%nband(ik_ibz,spin)
3535 0 : call wfk%write_band_block(band_block00,ik_ibz,spin,sc_mode,eig_k=eigen(ptr:))
3536 0 : ptr = ptr + 2*nband_k**2
3537 : end do
3538 : end do
3539 :
3540 0 : end subroutine wfk_write_h1mat
3541 : !!***
3542 :
3543 : !----------------------------------------------------------------------
3544 :
3545 : !!****f* m_wfk/wfk_read_h1mat
3546 : !! NAME
3547 : !! wfk_read_h1mat
3548 : !!
3549 : !! FUNCTION
3550 : !! Read all H1 matrix elements in the WFK file fname inside the MPI communicator comm.
3551 : !!
3552 : !! INPUTS
3553 : !! path=File name
3554 : !! comm=MPI communicator.
3555 : !!
3556 : !! OUTPUTS
3557 : !! eigen(2*hdr_out%mband**2*hdr_out%nkpt*hdr_out%nsppol)=Array with the matrix elements of H1
3558 : !! packed in the first positions. The array is allocated by the procedure.
3559 : !!
3560 : !! Hdr_out<hdr_type>=The header of the file
3561 : !!
3562 : !! SOURCE
3563 :
3564 0 : subroutine wfk_read_h1mat(fname, eigen, hdr_out, comm)
3565 :
3566 : !Arguments ------------------------------------
3567 : !scalars
3568 : character(len=*),intent(in) :: fname
3569 : integer,intent(in) :: comm
3570 : type(hdr_type),intent(out) :: Hdr_out
3571 : !arrays
3572 : real(dp),allocatable,intent(out) :: eigen(:)
3573 :
3574 : !Local variables-------------------------------
3575 : !scalars
3576 : integer,parameter :: master=0,formeig1=1
3577 : integer :: spin,ik_ibz,nband_k,ptr,ierr,iomode,mband,my_rank
3578 0 : type(wfk_t) :: wfk
3579 : !arrays
3580 : integer,parameter :: band_block00(2)=[0,0]
3581 : !************************************************************************
3582 :
3583 0 : my_rank = xmpi_comm_rank(comm)
3584 :
3585 0 : if (my_rank==master) then
3586 : ! Open the file.
3587 0 : iomode = iomode_from_fname(fname)
3588 0 : call wfk%open_read(fname, formeig1, iomode, get_unit(), xmpi_comm_self, hdr_out=hdr_out)
3589 :
3590 : ! Read h1 mat and pack them in the first positions.
3591 0 : ABI_MALLOC(eigen, (2*wfk%mband**2*wfk%nkpt*wfk%nsppol))
3592 :
3593 0 : ptr=1
3594 0 : do spin=1,wfk%nsppol
3595 0 : do ik_ibz=1,wfk%nkpt
3596 0 : nband_k = wfk%nband(ik_ibz,spin)
3597 0 : call wfk_read_band_block(wfk, band_block00, ik_ibz, spin, xmpio_single, eig_k=eigen(ptr:))
3598 0 : ptr = ptr + 2*nband_k**2
3599 : end do
3600 : end do
3601 :
3602 0 : call wfk%close()
3603 : end if
3604 :
3605 : ! Broadcast data
3606 0 : if (xmpi_comm_size(comm) > 1) then
3607 0 : call hdr_out%bcast(master, my_rank, comm)
3608 :
3609 0 : mband = maxval(Hdr_out%nband)
3610 0 : if (my_rank/=master) then
3611 0 : ABI_MALLOC(eigen, (2*mband**2*hdr_out%nkpt*hdr_out%nsppol))
3612 : end if
3613 0 : call xmpi_bcast(eigen,master,comm,ierr)
3614 : end if
3615 :
3616 0 : end subroutine wfk_read_h1mat
3617 : !!***
3618 :
3619 : !----------------------------------------------------------------------
3620 :
3621 : !!****f* m_wfk/wfk_rewind
3622 : !! NAME
3623 : !! wfk_rewind
3624 : !!
3625 : !! FUNCTION
3626 : !! Rewind the file, skip the header and modifies Wfk%f90_fptr $
3627 : !! Mainly used for debugging purposes when IO_MODE_FORTRAN is used.
3628 : !!
3629 : !! SOURCE
3630 :
3631 : subroutine wfk_rewind(wfk)
3632 :
3633 : !Arguments ------------------------------------
3634 : class(wfk_t),intent(inout) :: wfk
3635 :
3636 : !Local variables-------------------------------
3637 : integer :: ierr
3638 : ! *************************************************************************
3639 :
3640 : select case (wfk%iomode)
3641 : case (IO_MODE_FORTRAN)
3642 : rewind(wfk%fh)
3643 : call hdr_skip(wfk%fh,ierr)
3644 : ABI_CHECK(ierr==0, "hdr_skip returned ierr! /= 0")
3645 : wfk%f90_fptr = [1,1,REC_NPW]
3646 :
3647 : case default
3648 : ABI_ERROR("should not be called when wfk%iomode /= IO_MODE_FORTRAN")
3649 : end select
3650 :
3651 : end subroutine wfk_rewind
3652 : !!***
3653 :
3654 : !----------------------------------------------------------------------
3655 :
3656 : !!****f* m_wfk/wfk_seek
3657 : !! NAME
3658 : !! wfk_seek
3659 : !!
3660 : !! FUNCTION
3661 : !! Move the internal file pointer so that it points to the
3662 : !! block (ik_ibz, spin). Needed only if iomode==IO_MODE_FORTRAN
3663 : !!
3664 : !! INPUTS
3665 : !! ik_ibz,spin = (k-point,spin) indices
3666 : !!
3667 : !! SIDE EFFECTS
3668 : !! Wfk<class(wfk_t)> : modifies Wfk%f90_fptr and the internal F90 file pointer.
3669 : !!
3670 : !! SOURCE
3671 :
3672 0 : subroutine wfk_seek(Wfk,ik_ibz,spin)
3673 :
3674 : !Arguments ------------------------------------
3675 : integer,intent(in) :: ik_ibz,spin
3676 : class(wfk_t),intent(inout) :: Wfk
3677 :
3678 : !Local variables-------------------------------
3679 : integer :: ierr,ik_fpt,spin_fpt,recn_wanted,recn_fpt,rec_type
3680 : character(len=500) :: msg
3681 : ! *************************************************************************
3682 :
3683 0 : select case (Wfk%iomode)
3684 : case (IO_MODE_FORTRAN)
3685 : !
3686 : ! Find the position inside the file.
3687 0 : if (ALL(Wfk%f90_fptr==FPTR_EOF)) then ! handle the EOF condition
3688 0 : if (Wfk%debug) call wrtout(std_out,"EOF condition","PERS")
3689 0 : recn_fpt = Wfk%recn_eof
3690 : else
3691 0 : ik_fpt = Wfk%f90_fptr(1)
3692 0 : spin_fpt = Wfk%f90_fptr(2)
3693 0 : rec_type = Wfk%f90_fptr(3)
3694 0 : recn_fpt = Wfk%recn_ks(ik_fpt,spin_fpt, rec_type)
3695 : end if
3696 0 : recn_wanted = Wfk%recn_ks(ik_ibz,spin, REC_NPW)
3697 :
3698 0 : if (Wfk%debug) then
3699 0 : write(msg,'(a,3(i0,2x))')"seeking ik_ibz, spin, recn_wanted-recn_fpt: ",ik_ibz,spin,recn_wanted - recn_fpt
3700 0 : call wrtout(std_out,msg,"PERS")
3701 : end if
3702 :
3703 0 : call mvrecord(Wfk%fh, (recn_wanted - recn_fpt) ,ierr)
3704 0 : ABI_CHECK(ierr == 0, "error in mvrecord")
3705 :
3706 0 : Wfk%f90_fptr = [ik_ibz, spin, REC_NPW]
3707 :
3708 : case default
3709 0 : ABI_ERROR("should not be called when Wfk%iomode /= IO_MODE_FORTRAN")
3710 : end select
3711 :
3712 0 : end subroutine wfk_seek
3713 : !!***
3714 :
3715 : !----------------------------------------------------------------------
3716 :
3717 : !!****f* m_wfk/wfk_update_f90ptr
3718 : !! NAME
3719 : !! wfk_update_f90ptr
3720 : !!
3721 : !! FUNCTION
3722 : !! Update wfk%f90_ptr. Used if wfk%iomode == IO_MODE_FORTRAN.
3723 : !!
3724 : !! INPUTS
3725 : !! ik_ibz=K-point index,
3726 : !! spin=Spin index.
3727 : !!
3728 : !! SOURCE
3729 :
3730 0 : subroutine wfk_update_f90ptr(wfk, ik_ibz, spin)
3731 :
3732 : !Arguments ------------------------------------
3733 : class(wfk_t),intent(inout) :: wfk
3734 : integer,intent(in) :: ik_ibz,spin
3735 : ! *************************************************************************
3736 :
3737 0 : if (ik_ibz < wfk%nkpt) then
3738 0 : wfk%f90_fptr = [ik_ibz+1,spin,REC_NPW]
3739 : else
3740 0 : ABI_CHECK(ik_ibz == wfk%nkpt, "ik_ibz != nkpt")
3741 0 : if (spin == wfk%nsppol) then
3742 0 : wfk%f90_fptr = FPTR_EOF ! EOF condition
3743 : else
3744 0 : wfk%f90_fptr = [1,spin+1,REC_NPW]
3745 : end if
3746 : end if
3747 :
3748 0 : end subroutine wfk_update_f90ptr
3749 : !!***
3750 :
3751 : !----------------------------------------------------------------------
3752 :
3753 : !!****f* m_wfkfile/wfk_compute_offsets
3754 : !! NAME
3755 : !! wfk_compute_offsets
3756 : !!
3757 : !! FUNCTION
3758 : !! Compute the offsets corresponding to the different sections of the file (G-vectors, eigenvalues, u(G).
3759 : !! Needed only for Fortran-IO or MPI-IO.
3760 : !!
3761 : !! SOURCE
3762 :
3763 5 : subroutine wfk_compute_offsets(Wfk)
3764 :
3765 : !Arguments ------------------------------------
3766 : class(wfk_t),intent(inout) :: Wfk
3767 :
3768 : !Local variables-------------------------------
3769 : !scalars
3770 : integer :: spin,ik_ibz,npw_k,nband_k,bsize_frm,mpi_type_frm,base !,band
3771 : integer(XMPI_OFFSET_KIND) :: offset
3772 : ! this variable is needed to force arithmetic in the right kind
3773 : ! and avoid integer overflows with large nband npw.
3774 : ! TODO: check if same is needed elsewhere for offsets
3775 : integer(XMPI_OFFSET_KIND) :: increment
3776 : ! *************************************************************************
3777 :
3778 5 : select case (Wfk%iomode)
3779 : case (IO_MODE_FORTRAN)
3780 : ! Compute record number for Fortran IO
3781 0 : ABI_MALLOC(Wfk%recn_ks, (Wfk%nkpt,Wfk%nsppol,REC_NUM))
3782 :
3783 : ! We start to count the number of Fortran records from the end of the Header
3784 : ! Hence recn gives the relative position from the header, it's not an absolute position.
3785 0 : base = 0
3786 0 : do spin=1,Wfk%nsppol
3787 0 : do ik_ibz=1,Wfk%nkpt
3788 0 : nband_k = Wfk%nband(ik_ibz,spin)
3789 0 : Wfk%recn_ks(ik_ibz,spin, REC_NPW) = base + 1
3790 0 : Wfk%recn_ks(ik_ibz,spin, REC_KG) = base + 2
3791 0 : Wfk%recn_ks(ik_ibz,spin, REC_EIG) = base + 3
3792 0 : Wfk%recn_ks(ik_ibz,spin, REC_CG) = base + 4
3793 0 : base = Wfk%recn_ks(ik_ibz,spin,REC_CG)
3794 0 : if (Wfk%formeig==0) then
3795 : ! add records for each cg (iband), and account for offset of 1 added for REC_NPW
3796 : !TODO check if variable nband(k) works here
3797 0 : base = base + nband_k - 1
3798 0 : else if (Wfk%formeig==1) then
3799 : ! add records for each eig1(:,iband) and cg (iband), and account for offset of 1 added for REC_NPW
3800 0 : base = base + 2*(nband_k-1)
3801 : else
3802 0 : ABI_ERROR("formeig != [0,1]")
3803 : end if
3804 : end do
3805 : end do
3806 :
3807 : ! Save EOF position
3808 0 : Wfk%recn_eof = base + 1
3809 :
3810 : case (IO_MODE_MPI)
3811 : ! Compute offsets for MPI-IO.
3812 25 : ABI_MALLOC(Wfk%offset_ks, (Wfk%nkpt,Wfk%nsppol,REC_NUM))
3813 :
3814 5 : bsize_frm = xmpio_bsize_frm ! Byte length of the Fortran record marker.
3815 5 : mpi_type_frm = xmpio_mpi_type_frm ! MPI type of the record marker.
3816 :
3817 : ! The offset of the Header. TODO
3818 : ! hdr_offset(Hdr)
3819 5 : offset = Wfk%hdr_offset
3820 :
3821 10 : do spin=1,Wfk%nsppol
3822 40 : do ik_ibz=1,Wfk%nkpt
3823 30 : npw_k = Wfk%Hdr%npwarr(ik_ibz)
3824 30 : nband_k = Wfk%nband(ik_ibz,spin)
3825 : !---------------------------------------------------------------------------
3826 : ! First record: npw, nspinor, nband_disk
3827 : !---------------------------------------------------------------------------
3828 30 : Wfk%offset_ks(ik_ibz,spin,REC_NPW) = offset
3829 :
3830 30 : if (Wfk%Hdr%headform>=40) then
3831 : ! npw, nspinor, nband_disk
3832 30 : offset = offset + 3*xmpi_bsize_int + 2*bsize_frm
3833 : else
3834 0 : ABI_ERROR("Old headforms < 40 are not supported")
3835 : end if
3836 30 : Wfk%offset_ks(ik_ibz,spin,REC_KG) = offset
3837 :
3838 : !---------------------------------------------------------------------------
3839 : ! Second record: (k+G) vectors
3840 : ! kg_k(1:3,1:npw_k)
3841 : !---------------------------------------------------------------------------
3842 30 : offset = offset + 3*npw_k*xmpi_bsize_int + 2*bsize_frm
3843 30 : Wfk%offset_ks(ik_ibz,spin,REC_EIG) = offset
3844 : !
3845 : !---------------------------------------------------------------------------
3846 : ! Third record: eigenvalues
3847 : !---------------------------------------------------------------------------
3848 35 : if (Wfk%formeig==0) then
3849 : ! eigen(1:nband_k), occ(1:nband_k)
3850 : !offset = offset + 2*Wfk%mband*xmpi_bsize_dp + 2*bsize_frm
3851 30 : offset = offset + 2*nband_k*xmpi_bsize_dp + 2*bsize_frm
3852 30 : Wfk%offset_ks(ik_ibz,spin,REC_CG) = offset
3853 :
3854 : !---------------------------------------------------------------------------
3855 : ! Fourth record: Wavefunction coefficients
3856 : !---------------------------------------------------------------------------
3857 : ! do band=1,nband_k; write(unitwf) cg_k(1:2,npw_k*nspinor); end do
3858 : !offset = offset + Wfk%mband * (2*npw_k*Wfk%nspinor*xmpi_bsize_dp + 2*bsize_frm)
3859 30 : increment = 2*npw_k*Wfk%nspinor*xmpi_bsize_dp + 2*bsize_frm
3860 30 : increment = nband_k * increment
3861 30 : offset = offset + increment
3862 : !offset = offset + nband_k * (2*npw_k*Wfk%nspinor*xmpi_bsize_dp + 2*bsize_frm)
3863 :
3864 0 : else if (Wfk%formeig==1) then
3865 : ! read(unitwf) eigen(2*nband_k)
3866 : !Wfk%offset_ks(ik_ibz,spin,REC_CG) = offset + 2*Wfk%mband*xmpi_bsize_dp + 2*bsize_frm
3867 0 : Wfk%offset_ks(ik_ibz,spin,REC_CG) = offset + 2*nband_k*xmpi_bsize_dp + 2*bsize_frm
3868 :
3869 : !---------------------------------------------------------------------------
3870 : ! Fourth record: Wavefunction coefficients
3871 : !---------------------------------------------------------------------------
3872 : increment = (2*npw_k*Wfk%nspinor*xmpi_bsize_dp + 2*bsize_frm) + &
3873 0 : (2*nband_k*xmpi_bsize_dp + 2*bsize_frm)
3874 : !Wfk%mband * (2*npw_k*Wfk%nspinor*xmpi_bsize_dp + 2*bsize_frm) + &
3875 : !Wfk%mband * (2*Wfk%mband*xmpi_bsize_dp + 2*bsize_frm)
3876 0 : increment = nband_k * increment
3877 0 : offset = offset + increment
3878 :
3879 : else
3880 0 : ABI_ERROR("Wrong formeig")
3881 : end if
3882 :
3883 : end do ! ik_ibz
3884 : end do ! spin
3885 :
3886 : ! Save EOF offset
3887 5 : Wfk%offset_eof = offset
3888 :
3889 : ! Check for possible wraparound errors.
3890 170 : if (ANY(Wfk%offset_ks <= 0) .or. Wfk%offset_eof < 0) then
3891 0 : ABI_ERROR("Found negative offset. File too large for MPI-IO!!!")
3892 : end if
3893 : end select
3894 :
3895 5 : if (Wfk%debug) call wfk_show_offsets(Wfk)
3896 :
3897 5 : end subroutine wfk_compute_offsets
3898 : !!***
3899 :
3900 : !----------------------------------------------------------------------
3901 :
3902 : !!****f* m_wfkfile/wfk_show_offsets
3903 : !! NAME
3904 : !! wfk_show_offsets
3905 : !!
3906 : !! FUNCTION
3907 : !! Print the offsets.
3908 : !!
3909 : !! SOURCE
3910 :
3911 0 : subroutine wfk_show_offsets(Wfk)
3912 :
3913 : !Arguments ------------------------------------
3914 : class(wfk_t),intent(inout) :: Wfk
3915 :
3916 : !Local variables-------------------------------
3917 : !scalars
3918 : integer :: spin,ik_ibz
3919 : ! *************************************************************************
3920 :
3921 0 : select case (Wfk%iomode)
3922 :
3923 : case (IO_MODE_FORTRAN)
3924 0 : write(std_out,*)"Record number relative to the header."
3925 0 : do spin=1,Wfk%nsppol
3926 0 : do ik_ibz=1,Wfk%nkpt
3927 : write(std_out,"(a,2(i0,2x),a,4(a,i0,a))") &
3928 0 : "(ik_ibz, spin) ",ik_ibz,spin,ch10, &
3929 0 : " recn(REC_NPW): ",Wfk%recn_ks(ik_ibz,spin,REC_NPW),ch10,&
3930 0 : " recn(REC_KG) : ",Wfk%recn_ks(ik_ibz,spin,REC_KG), ch10,&
3931 0 : " recn(REC_EIG): ",Wfk%recn_ks(ik_ibz,spin,REC_EIG),ch10,&
3932 0 : " recn(REC_CG) : ",Wfk%recn_ks(ik_ibz,spin,REC_CG),ch10
3933 : end do
3934 : end do
3935 :
3936 0 : write(std_out,"(a,i0)")"EOS position: ",Wfk%recn_eof
3937 :
3938 : case (IO_MODE_MPI)
3939 0 : write(std_out,"(a,i0)")"hdr_offset ",Wfk%hdr_offset
3940 :
3941 0 : do spin=1,Wfk%nsppol
3942 0 : do ik_ibz=1,Wfk%nkpt
3943 : write(std_out,"(a,2(i0,2x),a,4(a,i0,a))") &
3944 0 : "(ik_ibz, spin) ",ik_ibz,spin,ch10, &
3945 0 : " offset(REC_NPW): ",Wfk%offset_ks(ik_ibz,spin,REC_NPW),ch10,&
3946 0 : " offset(REC_KG) : ",Wfk%offset_ks(ik_ibz,spin,REC_KG), ch10,&
3947 0 : " offset(REC_EIG): ",Wfk%offset_ks(ik_ibz,spin,REC_EIG),ch10,&
3948 0 : " offset(REC_CG) : ",Wfk%offset_ks(ik_ibz,spin,REC_CG),ch10
3949 : end do ! ik_ibz
3950 : end do ! spin
3951 : !
3952 : ! Write EOF position
3953 0 : write(std_out,"(a,i0)")"offset_eof ",Wfk%offset_eof
3954 : end select
3955 :
3956 0 : end subroutine wfk_show_offsets
3957 : !!***
3958 :
3959 : !----------------------------------------------------------------------
3960 :
3961 : !!****f* m_wfk/mpio_read_kg_k
3962 : !! NAME
3963 : !! mpio_read_kg_k
3964 : !!
3965 : !! FUNCTION
3966 : !! Helper functions to read the G-vectors with MPI-IO
3967 : !!
3968 : !! INPUTS
3969 : !! sc_mode= MPI-IO option
3970 : !! xmpio_single ==> for reading by current proc.
3971 : !! xmpio_collective ==> for collective reading.
3972 : !!
3973 : !! OUTPUTS
3974 : !! kg_k=(3,npw_disk) = G-vectors
3975 : !! mpierr=MPI error status (error check is delegated to the caller)
3976 : !!
3977 : !! SOURCE
3978 :
3979 : #ifdef HAVE_MPI_IO
3980 :
3981 0 : subroutine mpio_read_kg_k(fh,offset,npw_disk,sc_mode,kg_k,mpierr)
3982 :
3983 : !Arguments ------------------------------------
3984 : !scalars
3985 : integer,intent(in) :: fh,npw_disk,sc_mode
3986 : integer(XMPI_OFFSET_KIND),intent(in) :: offset
3987 : integer,intent(out) :: mpierr
3988 : !arrays
3989 : integer,intent(out) :: kg_k(3,npw_disk)
3990 :
3991 : !Local variables-------------------------------
3992 : !scalars
3993 : integer :: kg_k_type,ncount,myfh
3994 : integer(XMPI_OFFSET_KIND) :: my_offset
3995 : !************************************************************************
3996 :
3997 : ! Workarounds for XLF
3998 0 : myfh = fh
3999 0 : ncount = 3*npw_disk
4000 0 : my_offset = offset
4001 :
4002 0 : call MPI_TYPE_CONTIGUOUS(ncount, MPI_INTEGER, kg_k_type, mpierr)
4003 0 : ABI_HANDLE_MPIERR(mpierr)
4004 :
4005 0 : call MPI_TYPE_COMMIT(kg_k_type,mpierr)
4006 0 : ABI_HANDLE_MPIERR(mpierr)
4007 :
4008 0 : call MPI_FILE_SET_VIEW(myfh,my_offset,MPI_BYTE,kg_k_type,'native',xmpio_info,mpierr)
4009 0 : ABI_HANDLE_MPIERR(mpierr)
4010 :
4011 0 : if (sc_mode==xmpio_collective) then
4012 0 : call MPI_FILE_READ_ALL(myfh,kg_k,ncount,MPI_INTEGER,MPI_STATUS_IGNORE,mpierr)
4013 0 : else if (sc_mode==xmpio_single) then
4014 : !call MPI_File_seek(myfh, 0, MPI_SEEK_SET,mpierr)
4015 0 : call MPI_FILE_READ(myfh,kg_k,ncount,MPI_INTEGER, MPI_STATUS_IGNORE,mpierr)
4016 : else
4017 0 : ABI_ERROR("Wrong sc_mode")
4018 : end if
4019 :
4020 0 : ABI_HANDLE_MPIERR(mpierr)
4021 :
4022 0 : call MPI_TYPE_FREE(kg_k_type,mpierr)
4023 0 : ABI_HANDLE_MPIERR(mpierr)
4024 :
4025 : end subroutine mpio_read_kg_k
4026 : #endif
4027 : !!***
4028 :
4029 : !----------------------------------------------------------------------
4030 :
4031 : !!****f* m_wfk/mpio_write_kg_k
4032 : !! NAME
4033 : !! mpio_write_kg_k
4034 : !!
4035 : !! FUNCTION
4036 : !! Helper function to write the G-vectors with MPI-IO
4037 : !!
4038 : !! INPUTS
4039 : !! sc_mode= MPI-IO option
4040 : !! xmpio_single ==> for writing by current proc.
4041 : !! xmpio_collective ==> for collective write.
4042 : !! kg_k=(3,npw_disk) = G-vectors
4043 : !!
4044 : !! OUTPUTS
4045 : !! mpierr=MPI error status (error check is delegated to the caller)
4046 : !!
4047 : !! SOURCE
4048 :
4049 : #ifdef HAVE_MPI_IO
4050 :
4051 30 : subroutine mpio_write_kg_k(fh,offset,npw_disk,sc_mode,kg_k,mpierr)
4052 :
4053 : !Arguments ------------------------------------
4054 : !scalars
4055 : integer,intent(in) :: fh,npw_disk,sc_mode
4056 : integer(XMPI_OFFSET_KIND),intent(in) :: offset
4057 : integer,intent(out) :: mpierr
4058 : !arrays
4059 : integer,intent(in) :: kg_k(3,npw_disk)
4060 :
4061 : !Local variables-------------------------------
4062 : !scalars
4063 : integer :: myfh,kg_k_type,ncount
4064 : integer(XMPI_OFFSET_KIND) :: my_offset
4065 : !************************************************************************
4066 :
4067 : DBG_ENTER("COLL")
4068 :
4069 : ! Workarounds for XLF
4070 30 : myfh = fh
4071 30 : ncount = 3*npw_disk
4072 30 : my_offset = offset
4073 :
4074 30 : call MPI_TYPE_CONTIGUOUS(ncount, MPI_INTEGER, kg_k_type, mpierr)
4075 30 : ABI_HANDLE_MPIERR(mpierr)
4076 :
4077 30 : call MPI_TYPE_COMMIT(kg_k_type,mpierr)
4078 30 : ABI_HANDLE_MPIERR(mpierr)
4079 :
4080 30 : call MPI_FILE_SET_VIEW(myfh,my_offset,MPI_BYTE,kg_k_type,'native',xmpio_info,mpierr)
4081 30 : ABI_HANDLE_MPIERR(mpierr)
4082 :
4083 30 : call MPI_TYPE_FREE(kg_k_type,mpierr)
4084 30 : ABI_HANDLE_MPIERR(mpierr)
4085 :
4086 30 : if (sc_mode==xmpio_collective) then
4087 0 : call MPI_FILE_WRITE_ALL(myfh,kg_k,ncount,MPI_INTEGER,MPI_STATUS_IGNORE,mpierr)
4088 30 : else if (sc_mode==xmpio_single) then
4089 30 : call MPI_FILE_WRITE(myfh,kg_k,ncount,MPI_INTEGER,MPI_STATUS_IGNORE,mpierr)
4090 : else
4091 0 : ABI_ERROR("Wrong sc_mode")
4092 : end if
4093 :
4094 30 : ABI_HANDLE_MPIERR(mpierr)
4095 :
4096 : DBG_EXIT("COLL")
4097 :
4098 : end subroutine mpio_write_kg_k
4099 : #endif
4100 : !!***
4101 :
4102 : !----------------------------------------------------------------------
4103 :
4104 : !!****f* m_wfk/mpio_read_eigocc_k
4105 : !! NAME
4106 : !! mpio_read_eigocc_k
4107 : !!
4108 : !! FUNCTION
4109 : !! Helper functions to read the eigenvalues and the occupations with MPI-IO
4110 : !!
4111 : !! INPUTS
4112 : !! fh
4113 : !! offset
4114 : !! nband_disk
4115 : !! formeig
4116 : !! sc_mode= MPI-IO option
4117 : !! xmpio_single ==> for reading by current proc.
4118 : !! xmpio_collective ==> for collective reading.
4119 : !!
4120 : !! OUTPUTS
4121 : !! buffer(:)
4122 : !! mpierr=MPI error status.
4123 : !!
4124 : !! SOURCE
4125 :
4126 : #ifdef HAVE_MPI_IO
4127 :
4128 0 : subroutine mpio_read_eigocc_k(fh,offset,nband_disk,formeig,sc_mode,buffer,mpierr)
4129 :
4130 : !Arguments ------------------------------------
4131 : !scalars
4132 : integer,intent(in) :: fh,nband_disk,formeig,sc_mode
4133 : integer(XMPI_OFFSET_KIND),intent(in) :: offset
4134 : integer,intent(out) :: mpierr
4135 : !arrays
4136 : real(dp),contiguous, pointer :: buffer(:)
4137 :
4138 : !Local variables-------------------------------
4139 : !scalars
4140 : integer :: myfh,bufsz,gkk_type,eneocc_type
4141 : integer(XMPI_OFFSET_KIND) :: my_offset,my_offpad !,fmarker
4142 : !arrays
4143 : integer :: sizes(2),subsizes(2),starts(2)
4144 : !************************************************************************
4145 :
4146 : ! Workaround for XLF
4147 0 : myfh = fh
4148 :
4149 0 : SELECT CASE (formeig)
4150 : CASE (0)
4151 : !
4152 : ! Read both eig and occ in buffer
4153 0 : bufsz = 2*nband_disk
4154 0 : my_offset = offset
4155 0 : ABI_MALLOC(buffer, (bufsz))
4156 :
4157 0 : call MPI_TYPE_CONTIGUOUS(bufsz, MPI_DOUBLE_PRECISION, eneocc_type, mpierr)
4158 0 : ABI_HANDLE_MPIERR(mpierr)
4159 :
4160 0 : call MPI_TYPE_COMMIT(eneocc_type,mpierr)
4161 0 : ABI_HANDLE_MPIERR(mpierr)
4162 :
4163 0 : call MPI_FILE_SET_VIEW(myfh, my_offset, MPI_BYTE, eneocc_type, 'native', xmpio_info, mpierr)
4164 0 : ABI_HANDLE_MPIERR(mpierr)
4165 :
4166 0 : call MPI_TYPE_FREE(eneocc_type,mpierr)
4167 0 : ABI_HANDLE_MPIERR(mpierr)
4168 :
4169 0 : if (sc_mode==xmpio_collective) then
4170 0 : call MPI_FILE_READ_ALL(myfh,buffer,bufsz,MPI_DOUBLE_PRECISION,MPI_STATUS_IGNORE,mpierr)
4171 0 : else if (sc_mode==xmpio_single) then
4172 0 : call MPI_FILE_READ(myfh,buffer,bufsz,MPI_DOUBLE_PRECISION,MPI_STATUS_IGNORE,mpierr)
4173 : else
4174 0 : ABI_ERROR("Wrong sc_mode")
4175 : end if
4176 0 : ABI_HANDLE_MPIERR(mpierr)
4177 :
4178 : CASE (1)
4179 : ! Read the (nband_k,nband_k) matrix with the (complex) GKK matrix elements.
4180 0 : bufsz = (nband_disk**2)
4181 0 : sizes = [nband_disk, nband_disk]
4182 0 : subsizes = [nband_disk, nband_disk]
4183 0 : starts = [1, 1]
4184 :
4185 0 : ABI_MALLOC(buffer, (2*bufsz))
4186 :
4187 : !my_offset = offset - xmpio_bsize_frm
4188 : !call xmpio_read_dp(myfh,my_offset,sc_mode,2*nband_disk,buffer,fmarker,mpierr)
4189 : !write(std_out,*)buffer(1:2*nband_disk)
4190 : !ABI_ERROR("Done")
4191 :
4192 0 : call xmpio_create_fsubarray_2D(sizes,subsizes,starts,MPI_DOUBLE_COMPLEX,gkk_type,my_offpad,mpierr)
4193 0 : ABI_HANDLE_MPIERR(mpierr)
4194 :
4195 : ! TODO: Rationalize the offsets
4196 0 : my_offset = offset + my_offpad - xmpio_bsize_frm
4197 :
4198 0 : call MPI_FILE_SET_VIEW(myfh,my_offset,MPI_BYTE,gkk_type,'native',xmpio_info,mpierr)
4199 0 : ABI_HANDLE_MPIERR(mpierr)
4200 :
4201 0 : call MPI_TYPE_FREE(gkk_type, mpierr)
4202 0 : ABI_HANDLE_MPIERR(mpierr)
4203 :
4204 0 : if (sc_mode==xmpio_collective) then
4205 0 : call MPI_FILE_READ_ALL(myfh,buffer,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
4206 0 : else if (sc_mode==xmpio_single) then
4207 0 : call MPI_FILE_READ(myfh,buffer,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
4208 : else
4209 0 : ABI_ERROR("Wrong sc_mode")
4210 : end if
4211 0 : ABI_HANDLE_MPIERR(mpierr)
4212 :
4213 : CASE DEFAULT
4214 0 : ABI_ERROR("formeig not in [0,1]")
4215 : END SELECT
4216 :
4217 : end subroutine mpio_read_eigocc_k
4218 : #endif
4219 : !!***
4220 :
4221 : !----------------------------------------------------------------------
4222 :
4223 : !!****f* m_wfk/mpio_write_eigocc_k
4224 : !! NAME
4225 : !! mpio_write_eigocc_k
4226 : !!
4227 : !! FUNCTION
4228 : !! Helper functions to write the eigenvalues and the occupations with MPI-IO
4229 : !!
4230 : !! INPUTS
4231 : !! fh
4232 : !! offset
4233 : !! nband_disk
4234 : !! formeig
4235 : !! sc_mode= MPI-IO option
4236 : !! xmpio_single ==> for writing by current proc.
4237 : !! xmpio_collective ==> for collective write.
4238 : !!
4239 : !! OUTPUTS
4240 : !! buffer(:)
4241 : !! mpierr=MPI error status.
4242 : !!
4243 : !! SOURCE
4244 :
4245 : #ifdef HAVE_MPI_IO
4246 :
4247 30 : subroutine mpio_write_eigocc_k(fh,offset,nband_disk,formeig,sc_mode,buffer,mpierr)
4248 :
4249 : !Arguments ------------------------------------
4250 : !scalars
4251 : integer,intent(in) :: fh,nband_disk,formeig,sc_mode
4252 : integer(XMPI_OFFSET_KIND),intent(in) :: offset
4253 : integer,intent(out) :: mpierr
4254 : !arrays
4255 : real(dp),intent(in) :: buffer(:)
4256 :
4257 : !Local variables-------------------------------
4258 : !scalars
4259 : integer :: bufsz,gkk_type,eneocc_type,myfh
4260 : integer(XMPI_OFFSET_KIND) :: my_offset,my_offpad
4261 : !arrays
4262 : integer :: sizes(2),subsizes(2),starts(2)
4263 : !************************************************************************
4264 :
4265 : ! Workaround for XLF
4266 30 : myfh = fh
4267 :
4268 60 : SELECT CASE (formeig)
4269 : CASE (0)
4270 : !
4271 : ! write both eig and occ in buffer
4272 30 : my_offset = offset
4273 :
4274 30 : bufsz = 2*nband_disk
4275 30 : ABI_CHECK(SIZE(buffer) >= bufsz, "buffer too small")
4276 :
4277 30 : call MPI_TYPE_CONTIGUOUS(bufsz, MPI_DOUBLE_PRECISION, eneocc_type, mpierr)
4278 30 : ABI_HANDLE_MPIERR(mpierr)
4279 :
4280 30 : call MPI_TYPE_COMMIT(eneocc_type,mpierr)
4281 30 : ABI_HANDLE_MPIERR(mpierr)
4282 :
4283 30 : call MPI_FILE_SET_VIEW(myfh,my_offset,MPI_BYTE,eneocc_type,'native',xmpio_info,mpierr)
4284 30 : ABI_HANDLE_MPIERR(mpierr)
4285 :
4286 30 : call MPI_TYPE_FREE(eneocc_type,mpierr)
4287 30 : ABI_HANDLE_MPIERR(mpierr)
4288 :
4289 30 : if (sc_mode==xmpio_collective) then
4290 0 : call MPI_FILE_WRITE_ALL(myfh,buffer,bufsz,MPI_DOUBLE_PRECISION,MPI_STATUS_IGNORE,mpierr)
4291 30 : else if (sc_mode==xmpio_single) then
4292 30 : call MPI_FILE_WRITE(myfh,buffer,bufsz,MPI_DOUBLE_PRECISION,MPI_STATUS_IGNORE,mpierr)
4293 : else
4294 0 : ABI_ERROR("Wrong sc_mode")
4295 : end if
4296 30 : ABI_HANDLE_MPIERR(mpierr)
4297 :
4298 : CASE (1)
4299 : !ABI_ERROR("formeig ==1 with MPI-IO not tested")
4300 : ! write the (nband_k,nband_k) matrix with the (complex) GKK matrix elements.
4301 0 : bufsz = (nband_disk**2)
4302 0 : sizes = [nband_disk, nband_disk]
4303 0 : subsizes = [nband_disk, nband_disk]
4304 0 : starts = [1, 1]
4305 :
4306 0 : ABI_CHECK(SIZE(buffer) >= bufsz, "buffer too small")
4307 :
4308 0 : call xmpio_create_fsubarray_2D(sizes,subsizes,starts,MPI_DOUBLE_COMPLEX,gkk_type,my_offpad,mpierr)
4309 0 : ABI_HANDLE_MPIERR(mpierr)
4310 :
4311 : ! TODO: Rationalize the offsets
4312 0 : my_offset = offset + my_offpad - xmpio_bsize_frm
4313 :
4314 0 : call MPI_FILE_SET_VIEW(myfh,my_offset,MPI_BYTE,gkk_type,'native',xmpio_info,mpierr)
4315 0 : ABI_HANDLE_MPIERR(mpierr)
4316 :
4317 0 : call MPI_TYPE_FREE(gkk_type, mpierr)
4318 0 : ABI_HANDLE_MPIERR(mpierr)
4319 :
4320 0 : if (sc_mode==xmpio_collective) then
4321 0 : call MPI_FILE_WRITE_ALL(myfh,buffer,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
4322 0 : else if (sc_mode==xmpio_single) then
4323 0 : call MPI_FILE_WRITE(myfh,buffer,bufsz,MPI_DOUBLE_COMPLEX,MPI_STATUS_IGNORE,mpierr)
4324 : else
4325 0 : ABI_ERROR("Wrong sc_mode")
4326 : end if
4327 0 : ABI_HANDLE_MPIERR(mpierr)
4328 :
4329 : CASE DEFAULT
4330 30 : ABI_ERROR("formeig not in [0,1]")
4331 : END SELECT
4332 :
4333 : end subroutine mpio_write_eigocc_k
4334 : !!***
4335 : #endif
4336 :
4337 : !----------------------------------------------------------------------
4338 :
4339 : !!****f* m_wfk/wfk_to_bz
4340 : !! NAME
4341 : !! wfk_to_bz
4342 : !!
4343 : !! FUNCTION
4344 : !! Generate a new WFK file with wavefunctions in the full BZ and istwfk==1
4345 : !! Mainly used to interface ABINIT with other codes that cannot handle symmetries e.g. lobster
4346 : !!
4347 : !! INPUTS
4348 : !! in_path = Input WFK file
4349 : !! dtset <dataset_type>=all input variables for this dataset
4350 : !! psps <pseudopotential_type>=all the information about psps
4351 : !! pawtab(ntypat*usepaw) <type(pawtab_type)>=paw tabulated starting data
4352 : !! out_path = Output WFK file.
4353 : !!
4354 : !! OUTPUT
4355 : !! Output is written to file out_path
4356 : !! hdr_bz: header of the WFK file in the full BZ
4357 : !! ebands_bz: Electron energies in the full BZ
4358 : !!
4359 : !! NOTES
4360 : !! - This routine should be called by a single processor.
4361 : !! - Only GS WFK files are supported (formeig==0)
4362 : !!
4363 : !! SOURCE
4364 :
4365 3 : subroutine wfk_to_bz(in_path, dtset, psps, pawtab, out_path, hdr_bz, ebands_bz)
4366 :
4367 : !Arguments ------------------------------------
4368 : !scalars
4369 : character(len=*),intent(in) :: in_path,out_path
4370 : type(pseudopotential_type),intent(in) :: psps
4371 : type(dataset_type),intent(in) :: dtset
4372 : type(hdr_type),intent(out) :: hdr_bz
4373 : type(ebands_t),target,intent(out) :: ebands_bz
4374 : !arrays
4375 : type(pawtab_type),intent(in) :: pawtab(dtset%ntypat*psps%usepaw)
4376 :
4377 : !Local variables-------------------------------
4378 : !scalars
4379 : integer,parameter :: formeig0=0,kptopt3=3
4380 : integer :: spin,ikf,ik_ibz,nband_k,mpw_ki,mpw_kf,mband,nspinor,nkfull
4381 : integer :: in_iomode,nsppol,nkibz,out_iomode,isym,itimrev
4382 : integer :: npw_ki,npw_kf,istwf_ki,istwf_kf,ii,jj,iqst,nqst
4383 : real(dp) :: ecut_eff,dksqmax,cpu,wall,gflops
4384 : character(len=500) :: msg
4385 : character(len=fnlen) :: my_inpath
4386 : logical :: isirred_kf
4387 : logical,parameter :: force_istwfk1=.True.
4388 12 : type(wfk_t),target :: iwfk
4389 12 : type(wfk_t) :: owfk
4390 156 : type(crystal_t) :: cryst
4391 : type(hdr_type),pointer :: ihdr
4392 3 : type(ebands_t) :: ebands_ibz
4393 3 : type(wvl_internal_type) :: dummy_wvl
4394 : !arrays
4395 : integer :: g0(3),work_ngfft(18),gmax_ki(3),gmax_kf(3),gmax(3)
4396 9 : integer,allocatable :: bz2ibz(:,:),kg_ki(:,:),kg_kf(:,:),iperm(:),bz2ibz_sort(:)
4397 : real(dp) :: kf(3),kibz(3)
4398 6 : real(dp),allocatable :: cg_ki(:,:),cg_kf(:,:),eig_ki(:),occ_ki(:),work(:,:,:,:)
4399 3 : real(dp), contiguous, pointer :: kfull(:,:)
4400 : ! *************************************************************************
4401 :
4402 3 : if (all(dtset%kptrlatt == 0)) then
4403 : write(msg,"(5a)")&
4404 0 : "Cannot produce full WFK file because kptrlatt == 0",ch10, &
4405 0 : "Please use nkgpt and shiftk to define a homogeneous k-mesh.",ch10,&
4406 0 : "Returning to caller"
4407 0 : ABI_WARNING(msg)
4408 0 : return
4409 : end if
4410 :
4411 3 : call cwtime(cpu, wall, gflops, "start")
4412 3 : my_inpath = in_path
4413 :
4414 3 : if (nctk_try_fort_or_ncfile(my_inpath, msg) /= 0) then
4415 0 : ABI_ERROR(msg)
4416 : end if
4417 3 : call wrtout(std_out, sjoin(" Converting:", my_inpath, "to full BZ", out_path))
4418 :
4419 3 : in_iomode = iomode_from_fname(my_inpath)
4420 3 : ebands_ibz = wfk_read_ebands(my_inpath, xmpi_comm_self)
4421 :
4422 : ! Open input file, extract dimensions and allocate workspace arrays.
4423 3 : call iwfk%open_read(my_inpath, formeig0, in_iomode, get_unit(), xmpi_comm_self)
4424 3 : ihdr => iwfk%hdr
4425 :
4426 29 : mband = iwfk%mband; mpw_ki = maxval(iwfk%Hdr%npwarr); nkibz = iwfk%nkpt
4427 3 : nsppol = iwfk%nsppol; nspinor = iwfk%nspinor
4428 3 : ecut_eff = iwfk%hdr%ecut_eff ! ecut * dilatmx**2
4429 :
4430 9 : ABI_MALLOC(kg_ki, (3, mpw_ki))
4431 9 : ABI_MALLOC(cg_ki, (2, mpw_ki*nspinor*mband))
4432 9 : ABI_MALLOC(eig_ki, ((2*mband)**iwfk%formeig*mband) )
4433 9 : ABI_MALLOC(occ_ki, (mband))
4434 :
4435 3 : cryst = iwfk%hdr%get_crystal()
4436 :
4437 : ! Build new header for owfk. This is the most delicate part since all the arrays in hdr_full
4438 : ! that depend on k-points must be consistent with kfull and nkfull.
4439 3 : call ebands_ibz%expandk(cryst, ecut_eff, force_istwfk1, dksqmax, bz2ibz, ebands_bz)
4440 :
4441 3 : if (dksqmax > tol12) then
4442 : write(msg, '(3a,es16.6,4a)' )&
4443 0 : 'At least one of the k points could not be generated from a symmetrical one.',ch10,&
4444 0 : 'dksqmax=',dksqmax,ch10,&
4445 0 : 'Action: check your WFK file and k-point input variables',ch10,&
4446 0 : ' (e.g. kptopt or shiftk might be wrong in the present dataset or the preparatory one.'
4447 0 : ABI_ERROR(msg)
4448 : end if
4449 :
4450 3 : nkfull = ebands_bz%nkpt
4451 3 : kfull => ebands_bz%kptns
4452 :
4453 : ! Build new header and update pawrhoij.
4454 : call hdr_bz%init_lowlvl(ebands_bz,psps,pawtab,dummy_wvl,abinit_version,&
4455 : ihdr%pertcase,ihdr%natom,ihdr%nsym,ihdr%nspden,ihdr%ecut,dtset%pawecutdg,ihdr%ecutsm,dtset%dilatmx,&
4456 : ihdr%intxc,ihdr%ixc,ihdr%stmbias,ihdr%usewvl,dtset%pawcpxocc,dtset%pawspnorb,dtset%ngfft,dtset%ngfftdg,ihdr%so_psp,&
4457 : ihdr%qptn,cryst%rprimd,cryst%xred,ihdr%symrel,ihdr%tnons,ihdr%symafm,ihdr%typat,ihdr%amu,ihdr%icoulomb,&
4458 : kptopt3,dtset%nelect,dtset%ne_qFD,dtset%nh_qFD,dtset%ivalence,dtset%cellcharge(1),&
4459 : dtset%kptrlatt_orig,dtset%kptrlatt,&
4460 3 : dtset%nshiftk_orig,dtset%nshiftk,dtset%shiftk_orig,dtset%shiftk)
4461 :
4462 3 : if (psps%usepaw == 1) call pawrhoij_copy(iwfk%hdr%pawrhoij, hdr_bz%pawrhoij)
4463 :
4464 3 : out_iomode = iomode_from_fname(out_path)
4465 3 : call owfk%open_write(hdr_bz, out_path, iwfk%formeig, out_iomode, get_unit(), xmpi_comm_self)
4466 :
4467 : ! workspace array for BZ wavefunction block.
4468 387 : mpw_kf = maxval(ebands_bz%npwarr)
4469 9 : ABI_MALLOC(cg_kf, (2,mpw_kf*nspinor*mband))
4470 :
4471 3 : if (out_iomode == IO_MODE_FORTRAN) then
4472 0 : call wrtout(std_out,"Using (slow) Fortran IO version to generate full WFK file", do_flush=.True.)
4473 :
4474 : ! Fortran IO does not support random access hence the external loop is on the k-points in the full BZ.
4475 : !
4476 : ! For each point in the BZ:
4477 : ! - Find symmetric k-point in the IBZ and read IBZ wavefunctions from iwfk
4478 : ! - Rotate wavefunctions in G-space and write kbz data
4479 : !
4480 : ! Inefficient since we are reading the same IBZ block several times.
4481 0 : do spin=1,nsppol
4482 0 : do ikf=1,nkfull
4483 0 : ik_ibz = bz2ibz(ikf,1); isym = bz2ibz(ikf,2); itimrev = bz2ibz(ikf,6); g0 = bz2ibz(ikf,3:5) ! IS(k_ibz) + g0 = k_bz
4484 0 : isirred_kf = (isym == 1 .and. itimrev == 0 .and. all(g0 == 0))
4485 :
4486 0 : nband_k = iwfk%nband(ik_ibz,spin)
4487 0 : kf = kfull(:,ikf)
4488 0 : kibz = ebands_ibz%kptns(:,ik_ibz)
4489 :
4490 0 : istwf_ki = iwfk%hdr%istwfk(ik_ibz)
4491 0 : istwf_kf = owfk%hdr%istwfk(ikf)
4492 0 : npw_ki = iwfk%hdr%npwarr(ik_ibz)
4493 :
4494 : ! Read IBZ data.
4495 : call iwfk%read_band_block([1,nband_k],ik_ibz,spin,xmpio_single,&
4496 0 : kg_k=kg_ki,cg_k=cg_ki,eig_k=eig_ki,occ_k=occ_ki)
4497 :
4498 : ! The test on npwarr is needed because we may change istwfk e.g. gamma.
4499 0 : if (isirred_kf .and. iwfk%hdr%npwarr(ik_ibz) == owfk%hdr%npwarr(ikf)) then
4500 :
4501 : call owfk%write_band_block([1,nband_k],ikf,spin,xmpio_single,&
4502 0 : kg_k=kg_ki,cg_k=cg_ki,eig_k=eig_ki,occ_k=occ_ki)
4503 :
4504 : else
4505 : ! Compute G-sphere centered on kf
4506 0 : call get_kg(kf,istwf_kf,ecut_eff,cryst%gmet,npw_kf,kg_kf)
4507 0 : ABI_CHECK(npw_kf == owfk%hdr%npwarr(ikf), "Wrong npw_kf")
4508 :
4509 : ! FFT box must enclose the two spheres centered on ki and kf
4510 0 : gmax_ki = maxval(abs(kg_ki(:,1:npw_ki)), dim=2)
4511 0 : gmax_kf = maxval(abs(kg_kf), dim=2)
4512 0 : do ii=1,3
4513 0 : gmax(ii) = max(gmax_ki(ii), gmax_kf(ii))
4514 : end do
4515 0 : gmax = 2*gmax + 1
4516 0 : call ngfft_seq(work_ngfft, gmax)
4517 0 : ABI_CALLOC(work, (2, work_ngfft(4),work_ngfft(5),work_ngfft(6)))
4518 :
4519 : ! Rotate nband_k wavefunctions (output in cg_kf)
4520 : call cgtk_rotate(cryst,kibz,isym,itimrev,g0,nspinor,nband_k,&
4521 0 : npw_ki,kg_ki,npw_kf,kg_kf,istwf_ki,istwf_kf,cg_ki,cg_kf,work_ngfft,work)
4522 :
4523 0 : ABI_FREE(work)
4524 :
4525 : ! Write data
4526 : call owfk%write_band_block([1,nband_k],ikf,spin,xmpio_single,&
4527 0 : kg_k=kg_kf,cg_k=cg_kf,eig_k=eig_ki,occ_k=occ_ki)
4528 :
4529 0 : ABI_FREE(kg_kf)
4530 : end if
4531 : end do
4532 : end do
4533 :
4534 : else
4535 : !
4536 : ! More efficienct algorithm based on random access IO:
4537 : ! For each point in the IBZ:
4538 : ! - Read wavefunctions from iwfk
4539 : ! - For each k-point in the star of kpt_ibz:
4540 : ! - Rotate wavefunctions in G-space to get the k-point in the full BZ.
4541 : ! - Write kbz data to file.
4542 3 : if (out_iomode == IO_MODE_MPI) call wrtout(std_out," Using MPI-IO to generate full WFK file", do_flush=.True.)
4543 3 : if (out_iomode == IO_MODE_ETSF) call wrtout(std_out, "Using Netcdf-IO to generate full WFK file", do_flush=.True.)
4544 :
4545 : ! Construct sorted mapping BZ --> IBZ to speedup qbz search below.
4546 9 : ABI_MALLOC(iperm, (nkfull))
4547 6 : ABI_MALLOC(bz2ibz_sort, (nkfull))
4548 1158 : iperm = [(ii, ii=1,nkfull)]
4549 390 : bz2ibz_sort = bz2ibz(:,1)
4550 3 : call sort_int(nkfull, bz2ibz_sort, iperm)
4551 :
4552 6 : do spin=1,nsppol
4553 3 : iqst = 0
4554 32 : do ik_ibz=1,iwfk%nkpt
4555 26 : nband_k = iwfk%nband(ik_ibz,spin)
4556 104 : kibz = ebands_ibz%kptns(:,ik_ibz)
4557 26 : istwf_ki = iwfk%hdr%istwfk(ik_ibz)
4558 26 : npw_ki = iwfk%hdr%npwarr(ik_ibz)
4559 :
4560 : call iwfk%read_band_block([1,nband_k],ik_ibz,spin,xmpio_single,&
4561 78 : kg_k=kg_ki,cg_k=cg_ki,eig_k=eig_ki,occ_k=occ_ki)
4562 :
4563 : ! Find number of symmetric q-points associated to ik_ibz
4564 26 : nqst = 0
4565 410 : do ii=iqst+1,nkfull
4566 407 : if (bz2ibz_sort(ii) /= ik_ibz) exit
4567 410 : nqst = nqst + 1
4568 : end do
4569 26 : ABI_CHECK(nqst > 0 .and. bz2ibz_sort(iqst+1) == ik_ibz, "Wrong iqst")
4570 :
4571 413 : do jj=1,nqst
4572 384 : iqst = iqst + 1
4573 384 : ikf = iperm(iqst)
4574 384 : ABI_CHECK(ik_ibz == bz2ibz(ikf,1), "ik_ibz !/ ind qq(1)")
4575 :
4576 1536 : isym = bz2ibz(ikf,2); itimrev = bz2ibz(ikf,6); g0 = bz2ibz(ikf,3:5) ! IS(k_ibz) + g0 = k_bz
4577 1260 : isirred_kf = (isym == 1 .and. itimrev == 0 .and. all(g0 == 0))
4578 :
4579 1536 : kf = kfull(:,ikf)
4580 384 : istwf_kf = owfk%hdr%istwfk(ikf)
4581 :
4582 : ! The test on npwarr is needed because we may change istwfk e.g. gamma.
4583 410 : if (isirred_kf .and. iwfk%hdr%npwarr(ik_ibz) == owfk%hdr%npwarr(ikf)) then
4584 :
4585 : call owfk%write_band_block([1,nband_k],ikf,spin,xmpio_single,&
4586 60 : kg_k=kg_ki,cg_k=cg_ki,eig_k=eig_ki,occ_k=occ_ki)
4587 :
4588 : else
4589 : ! Compute G-sphere centered on kf
4590 364 : call get_kg(kf,istwf_kf,ecut_eff,cryst%gmet,npw_kf,kg_kf)
4591 364 : ABI_CHECK(npw_kf == owfk%hdr%npwarr(ikf), "Wrong npw_kf")
4592 :
4593 : ! FFT box must enclose the two spheres centered on ki and kf
4594 361036 : gmax_ki = maxval(abs(kg_ki(:,1:npw_ki)), dim=2)
4595 366868 : gmax_kf = maxval(abs(kg_kf), dim=2)
4596 1456 : do ii=1,3
4597 1456 : gmax(ii) = max(gmax_ki(ii), gmax_kf(ii))
4598 : end do
4599 1456 : gmax = 2*gmax + 1
4600 364 : call ngfft_seq(work_ngfft, gmax)
4601 897504 : ABI_CALLOC(work, (2, work_ngfft(4),work_ngfft(5),work_ngfft(6)))
4602 :
4603 : ! Rotate nband_k wavefunctions (output in cg_kf)
4604 : call cgtk_rotate(cryst,kibz,isym,itimrev,g0,nspinor,nband_k,&
4605 364 : npw_ki,kg_ki,npw_kf,kg_kf,istwf_ki,istwf_kf,cg_ki,cg_kf,work_ngfft,work)
4606 :
4607 364 : ABI_FREE(work)
4608 :
4609 : ! Write data
4610 : call owfk%write_band_block([1,nband_k],ikf,spin,xmpio_single,&
4611 1092 : kg_k=kg_kf,cg_k=cg_kf,eig_k=eig_ki,occ_k=occ_ki)
4612 :
4613 364 : ABI_FREE(kg_kf)
4614 : end if
4615 : end do
4616 : end do
4617 : end do
4618 :
4619 3 : ABI_FREE(iperm)
4620 3 : ABI_FREE(bz2ibz_sort)
4621 : end if
4622 :
4623 3 : call cwtime_report(sjoin(" FULL_WFK written to: ", out_path), cpu, wall, gflops)
4624 :
4625 3 : ABI_FREE(kg_ki)
4626 3 : ABI_FREE(cg_ki)
4627 3 : ABI_FREE(eig_ki)
4628 3 : ABI_FREE(occ_ki)
4629 3 : ABI_FREE(bz2ibz)
4630 3 : ABI_FREE(cg_kf)
4631 :
4632 3 : call cryst%free()
4633 3 : call ebands_ibz%free()
4634 3 : call iwfk%close()
4635 3 : call owfk%close()
4636 :
4637 12 : end subroutine wfk_to_bz
4638 : !!***
4639 :
4640 : !----------------------------------------------------------------------
4641 :
4642 : !!****f* m_wfk/wfk_nc2fort
4643 : !! NAME
4644 : !! wfk_nc2fort
4645 : !!
4646 : !! FUNCTION
4647 : !! Convert a netcdf WFK file (nc_path) to a Fortran WFK file (fort_path).
4648 : !!
4649 : !! NOTES
4650 : !! - This routine should be called by a single processor.
4651 : !! - Only GS WFK files are supported (formeig==0)
4652 : !!
4653 : !! SOURCE
4654 :
4655 0 : subroutine wfk_nc2fort(nc_path, fort_path)
4656 :
4657 : !Arguments ------------------------------------
4658 : !scalars
4659 : character(len=*),intent(in) :: nc_path,fort_path
4660 :
4661 : !Local variables-------------------------------
4662 : !scalars
4663 : integer :: ik,spin,mband,mpw,nband_k
4664 0 : type(wfk_t) :: iwfk,owfk
4665 : !arrays
4666 : integer,parameter :: formeig0=0
4667 : integer,allocatable :: kg_k(:,:)
4668 0 : real(dp),allocatable :: cg_k(:,:),eig_k(:),occ_k(:)
4669 : ! *************************************************************************
4670 :
4671 0 : call wrtout(std_out, sjoin("Converting:", nc_path, "to", fort_path))
4672 :
4673 : ! Open input file, extract dimensions and allocate workspace arrays.
4674 0 : call iwfk%open_read(nc_path, formeig0, IO_MODE_ETSF, get_unit(), xmpi_comm_self)
4675 :
4676 0 : mpw = maxval(iwfk%hdr%npwarr); mband = iwfk%mband
4677 0 : ABI_MALLOC(kg_k, (3, mpw))
4678 0 : ABI_MALLOC(cg_k, (2, mpw*iwfk%nspinor*mband))
4679 0 : ABI_MALLOC(eig_k, ((2*mband)**iwfk%formeig*mband) )
4680 0 : ABI_MALLOC(occ_k, (mband))
4681 :
4682 : ! Open output file.
4683 0 : call owfk%open_write(iwfk%hdr,fort_path,formeig0,IO_MODE_FORTRAN,get_unit(),xmpi_comm_self)
4684 :
4685 0 : do spin=1,iwfk%nsppol
4686 0 : do ik=1,iwfk%nkpt
4687 0 : nband_k = iwfk%nband(ik,spin)
4688 :
4689 : call iwfk%read_band_block([1,nband_k],ik,spin,xmpio_single,&
4690 0 : kg_k=kg_k,cg_k=cg_k,eig_k=eig_k,occ_k=occ_k)
4691 :
4692 : call owfk%write_band_block([1,nband_k],ik,spin,xmpio_single,&
4693 0 : kg_k=kg_k,cg_k=cg_k,eig_k=eig_k,occ_k=occ_k)
4694 : end do
4695 : end do
4696 :
4697 0 : ABI_FREE(kg_k)
4698 0 : ABI_FREE(cg_k)
4699 0 : ABI_FREE(eig_k)
4700 0 : ABI_FREE(occ_k)
4701 :
4702 0 : call iwfk%close()
4703 0 : call owfk%close()
4704 :
4705 0 : end subroutine wfk_nc2fort
4706 : !!***
4707 :
4708 : !----------------------------------------------------------------------
4709 :
4710 : !!****f* m_wfk/wfk_prof
4711 : !! NAME
4712 : !! wfk_prof
4713 : !!
4714 : !! FUNCTION
4715 : !! Profiling tool for IO routines
4716 : !!
4717 : !! INPUTS
4718 : !! wfk_fname=Filename
4719 : !! formeig=0 for GS file, 1 for DFPT file
4720 : !! nband=Number of bands to read.
4721 : !! comm=MPI communicator
4722 : !!
4723 : !! SOURCE
4724 :
4725 0 : subroutine wfk_prof(wfk_fname, formeig, nband, comm)
4726 :
4727 : !Arguments ------------------------------------
4728 : integer,intent(in) :: nband,formeig,comm
4729 : character(len=*),intent(in) :: wfk_fname
4730 :
4731 : !Local variables-------------------------------
4732 : !scalars
4733 : integer,parameter :: rdwr1=1,master=0,optkg1=1,option1=1,tim_rwwf0=0,icg0=0,headform0=0
4734 : integer :: iomode,wfk_unt,ik_ibz,spin,ierr,ii,option,mband
4735 : integer :: npw_disk,nband_disk,mcg,fform,nband_read,sc_mode,my_rank,nproc
4736 : real(dp) :: cpu,wall,gflops
4737 : character(len=500) :: msg
4738 0 : type(hdr_type) :: Hdr
4739 0 : type(wfk_t) :: Wfk
4740 : type(wffile_type) :: wff
4741 0 : type(MPI_type) :: MPI_enreg_seq
4742 : !arrays
4743 : !integer,parameter :: io_modes(2) = (/IO_MODE_FORTRAN, IO_MODE_MPI/)
4744 : integer,parameter :: io_modes(1) = (/IO_MODE_MPI/)
4745 : integer :: ngfft(18)
4746 0 : logical,allocatable :: my_bmask(:)
4747 0 : integer,allocatable :: kg_k(:,:)
4748 0 : real(dp),allocatable :: eig_k(:),cg_k(:,:),occ_k(:)
4749 : ! *************************************************************************
4750 :
4751 0 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
4752 0 : sc_mode = xmpio_collective
4753 :
4754 0 : call hdr%from_fname(wfk_fname, fform, comm)
4755 :
4756 : ! nband_read is the max number of bands we can read from this file.
4757 0 : nband_read = nband
4758 0 : if (nband_read <= 0) then
4759 0 : nband_read = minval(hdr%nband)
4760 0 : call wrtout(std_out, sjoin("nband == 0 --> Setting nband_read to:",itoa(nband_read)))
4761 : end if
4762 0 : if (nband_read > minval(hdr%nband)) then
4763 0 : nband_read = minval(hdr%nband)
4764 0 : call wrtout(std_out, sjoin("nband > hdr%nband --> Setting nband_read to:",itoa(nband_read)))
4765 : end if
4766 :
4767 0 : wfk_unt = get_unit()
4768 :
4769 0 : do ii=1,SIZE(io_modes)
4770 0 : iomode = io_modes(ii)
4771 : !do option=1,3
4772 0 : do option=1,3,2
4773 0 : write(std_out,*)"iomode, option",iomode,option
4774 0 : call cwtime(cpu,wall,gflops,"start")
4775 :
4776 0 : select case (option)
4777 : case (1)
4778 0 : call wfk%open_read(wfk_fname, formeig, iomode, wfk_unt, comm)
4779 :
4780 0 : do spin=1,Hdr%nsppol
4781 0 : do ik_ibz=1,Hdr%nkpt
4782 0 : npw_disk = Hdr%npwarr(ik_ibz)
4783 0 : nband_disk = Wfk%nband(ik_ibz,spin)
4784 :
4785 0 : mcg = npw_disk*Hdr%nspinor*nband_read
4786 :
4787 0 : ABI_MALLOC(eig_k,((2*Wfk%mband)**formeig*Wfk%mband))
4788 0 : ABI_MALLOC(occ_k,(Wfk%mband))
4789 :
4790 0 : ABI_MALLOC(kg_k,(3,npw_disk))
4791 0 : ABI_MALLOC_OR_DIE(cg_k,(2,mcg), ierr)
4792 :
4793 : ! Read the block of bands for this (k,s).
4794 : call wfk%read_band_block([1,nband_read],ik_ibz,spin,xmpio_collective,&
4795 0 : kg_k=kg_k,cg_k=cg_k,eig_k=eig_k,occ_k=occ_k)
4796 :
4797 0 : ABI_FREE(eig_k)
4798 0 : ABI_FREE(occ_k)
4799 0 : ABI_FREE(kg_k)
4800 0 : ABI_FREE(cg_k)
4801 : end do !ik_ibz
4802 : end do !spin
4803 :
4804 0 : call wfk%close()
4805 :
4806 : case (2)
4807 0 : call wfk%open_read(wfk_fname, formeig, iomode, wfk_unt, comm)
4808 :
4809 0 : do spin=1,Hdr%nsppol
4810 0 : do ik_ibz=1,Hdr%nkpt
4811 0 : npw_disk = Hdr%npwarr(ik_ibz)
4812 0 : nband_disk = Hdr%nband(ik_ibz+(spin-1)*Hdr%nkpt)
4813 :
4814 0 : ABI_MALLOC(my_bmask,(MAXVAL(Hdr%nband)))
4815 0 : my_bmask=.False.; my_bmask(1:nband_read) = .True.
4816 :
4817 0 : ABI_MALLOC(eig_k,((2*nband_disk)**formeig*nband_disk))
4818 0 : ABI_MALLOC(kg_k,(3,npw_disk))
4819 0 : ABI_MALLOC(occ_k,(nband_disk))
4820 :
4821 0 : mcg = npw_disk*Hdr%nspinor*COUNT(my_bmask)
4822 0 : ABI_MALLOC_OR_DIE(cg_k,(2,mcg), ierr)
4823 :
4824 0 : call wfk%read_bmask(my_bmask,ik_ibz,spin,sc_mode,kg_k=kg_k,cg_k=cg_k,eig_k=eig_k,occ_k=occ_k)
4825 : !call wfk%read_band_block((/1,nband_read/),ik_ibz,spin,sc_mode,kg_k=kg_k,cg_k=cg_k,eig_k=eig_k,occ_k=occ_k)
4826 :
4827 0 : ABI_FREE(my_bmask)
4828 0 : ABI_FREE(eig_k)
4829 0 : ABI_FREE(occ_k)
4830 0 : ABI_FREE(kg_k)
4831 0 : ABI_FREE(cg_k)
4832 : end do !ik_ibz
4833 : end do !spin
4834 :
4835 0 : call wfk%close()
4836 :
4837 : case (3)
4838 : !Fake MPI_type for the sequential part.
4839 0 : ngfft(1:6) = (/12,12,12,13,13,13/)
4840 0 : call initmpi_seq(MPI_enreg_seq)
4841 0 : call MPI_enreg_seq%distribfft%init_seq('c',ngfft(2),ngfft(3),'all')
4842 0 : call MPI_enreg_seq%distribfft%init_seq('f',ngfft(2),ngfft(3),'all')
4843 :
4844 0 : call WffOpen(iomode,comm,wfk_fname,ierr,wff,master,my_rank,wfk_unt) !,spaceComm_mpiio) ! optional argument
4845 0 : ABI_CHECK(ierr==0,"ierr!=0")
4846 :
4847 0 : call Hdr%free()
4848 0 : call hdr_io(fform,Hdr,1,wff)
4849 0 : call WffKg(wff,optkg1)
4850 :
4851 0 : do spin=1,Hdr%nsppol
4852 0 : do ik_ibz=1,Hdr%nkpt
4853 :
4854 0 : npw_disk = Hdr%npwarr(ik_ibz)
4855 0 : nband_disk = Hdr%nband(ik_ibz+(spin-1)*Hdr%nkpt)
4856 :
4857 0 : mband = MAXVAL(Hdr%nband)
4858 0 : mcg = npw_disk*Hdr%nspinor*nband_read
4859 :
4860 0 : ABI_MALLOC(eig_k,((2*mband)**formeig*mband))
4861 0 : ABI_MALLOC(occ_k,(mband))
4862 :
4863 0 : ABI_MALLOC(kg_k,(3,optkg1*npw_disk))
4864 0 : ABI_MALLOC_OR_DIE(cg_k,(2,mcg), ierr)
4865 : !
4866 : ! Read the block of bands for this (k,s).
4867 : call rwwf(cg_k,eig_k,formeig,headform0,icg0,ik_ibz,spin,kg_k,mband,mcg,MPI_enreg_seq,nband_read,&
4868 0 : nband_disk,npw_disk,Hdr%nspinor,occ_k,option1,optkg1,tim_rwwf0,Wff)
4869 :
4870 0 : ABI_FREE(eig_k)
4871 0 : ABI_FREE(occ_k)
4872 0 : ABI_FREE(kg_k)
4873 0 : ABI_FREE(cg_k)
4874 :
4875 : end do !ik_ibz
4876 : end do !spin
4877 :
4878 0 : call WffClose(wff,ierr)
4879 0 : call destroy_mpi_enreg(MPI_enreg_seq)
4880 :
4881 : case default
4882 0 : ABI_ERROR("Wrong method")
4883 : end select
4884 :
4885 0 : call cwtime(cpu,wall,gflops,"stop")
4886 : write(msg,'(3(a,i2),2(a,f8.2))')&
4887 0 : " iomode: ",iomode,", nproc: ",nproc,", option: ",option,", cpu: ",cpu,", wall:",wall
4888 0 : call wrtout(std_out, msg)
4889 : !call cwtime_report(" FULL_WFK written to file. ", cpu, wall, gflops)
4890 : end do
4891 : end do
4892 :
4893 0 : call Hdr%free()
4894 :
4895 0 : end subroutine wfk_prof
4896 : !!***
4897 :
4898 : !----------------------------------------------------------------------
4899 :
4900 : !!****f* m_wfk/wfk_create_wfkfile
4901 : !! NAME
4902 : !! wfk_create_wfkfile
4903 : !!
4904 : !! FUNCTION
4905 : !!
4906 : !! INPUTS
4907 : !!
4908 : !! SOURCE
4909 :
4910 0 : subroutine wfk_create_wfkfile(wfk_fname, Hdr, iomode, formeig, Kvars, cwtimes, comm)
4911 :
4912 : !Arguments ------------------------------------
4913 : !scalars
4914 : integer,intent(in) :: iomode,formeig,comm
4915 : character(len=*),intent(in) :: wfk_fname
4916 : !arrays
4917 : real(dp),intent(out) :: cwtimes(2)
4918 : type(hdr_type),intent(in) :: Hdr
4919 : type(kvars_t),target,intent(out) :: Kvars(Hdr%nkpt)
4920 :
4921 : !Local variables-------------------------------
4922 : !scalars
4923 : integer :: nkpt,nsppol,nspinor,ierr,sc_mode
4924 : integer :: ik_ibz,spin,funt,nband_k,npw_k,istwfk_k
4925 : real(dp) :: cpu,wall,gflops,ucvol
4926 0 : type(wfk_t) :: Wfk
4927 : !arrays
4928 0 : integer :: nband(Hdr%nkpt,Hdr%nsppol)
4929 0 : integer,contiguous, pointer :: kg_k(:,:)
4930 : real(dp) :: kpoint(3),gmet(3,3),gprimd(3,3),rmet(3,3)
4931 0 : real(dp),allocatable :: cg_k(:,:),eig_k(:),occ_k(:)
4932 : !************************************************************************
4933 :
4934 0 : cwtimes = zero
4935 :
4936 0 : nband = RESHAPE(Hdr%nband, [Hdr%nkpt, Hdr%nsppol])
4937 0 : nkpt = Hdr%nkpt
4938 0 : nsppol = Hdr%nsppol
4939 0 : nspinor = Hdr%nspinor
4940 :
4941 0 : call metric(gmet,gprimd,dev_null,rmet,Hdr%rprimd,ucvol)
4942 :
4943 : ! Generate the G-vectors from input Hdr%ecut.
4944 0 : do ik_ibz=1,nkpt
4945 0 : kpoint = Hdr%kptns(:,ik_ibz)
4946 0 : istwfk_k = Hdr%istwfk(ik_ibz)
4947 0 : call get_kg(kpoint,istwfk_k,Hdr%ecut,gmet,npw_k,Kvars(ik_ibz)%kg_k)
4948 0 : ABI_CHECK(npw_k == Hdr%npwarr(ik_ibz),"npw_k != Hdr%npwarr(ik)")
4949 : end do
4950 :
4951 : ! Open the file for writing.
4952 0 : sc_mode = xmpio_collective
4953 :
4954 0 : call cwtime(cpu,wall,gflops,"start")
4955 0 : funt = get_unit()
4956 :
4957 0 : call wfk%open_write(Hdr,wfk_fname,formeig,iomode,funt,comm,write_frm=.TRUE.)
4958 :
4959 0 : call cwtime(cpu,wall,gflops,"stop")
4960 0 : cwtimes = cwtimes + [cpu, wall]
4961 :
4962 0 : do spin=1,nsppol
4963 0 : do ik_ibz=1,nkpt
4964 0 : nband_k = nband(ik_ibz,spin)
4965 0 : npw_k = Hdr%npwarr(ik_ibz)
4966 0 : ABI_MALLOC(cg_k, (2,npw_k*nspinor*nband_k))
4967 0 : ABI_MALLOC(eig_k, ((2*Wfk%mband)**formeig*Wfk%mband) )
4968 0 : ABI_MALLOC(occ_k, (Wfk%mband))
4969 :
4970 0 : kg_k => Kvars(ik_ibz)%kg_k
4971 : !
4972 : ! Fill cg_k, eig_k, occ_k using a deterministic algorithm so that
4973 : ! we can check the correctness of the reading.
4974 0 : call fill_or_check("fill",Hdr,Kvars(ik_ibz),ik_ibz,spin,formeig,kg_k,cg_k,eig_k,occ_k,ierr)
4975 0 : ABI_CHECK_IEQ(ierr, 0, "filling_or_check")
4976 :
4977 0 : call cwtime(cpu,wall,gflops,"start")
4978 :
4979 0 : call wfk%write_band_block([1,nband_k],ik_ibz,spin,sc_mode,kg_k=kg_k,cg_k=cg_k,eig_k=eig_k,occ_k=occ_k)
4980 :
4981 0 : call cwtime(cpu,wall,gflops,"stop")
4982 0 : cwtimes = cwtimes + [cpu, wall]
4983 :
4984 0 : ABI_FREE(cg_k)
4985 0 : ABI_FREE(eig_k)
4986 0 : ABI_FREE(occ_k)
4987 : end do
4988 : end do
4989 :
4990 : ! Close the file
4991 0 : call wfk%close()
4992 :
4993 0 : end subroutine wfk_create_wfkfile
4994 : !!***
4995 :
4996 : !----------------------------------------------------------------------
4997 :
4998 : !!****f* m_wfk/wfk_check_wfkfile
4999 : !! NAME
5000 : !! wfk_check_wfkfile
5001 : !!
5002 : !! FUNCTION
5003 : !!
5004 : !! INPUTS
5005 : !!
5006 : !! SOURCE
5007 :
5008 0 : subroutine wfk_check_wfkfile(wfk_fname,Hdr,iomode,method,formeig,Kvars,cwtimes,comm,ierr)
5009 :
5010 : !Arguments ------------------------------------
5011 : !scalars
5012 : integer,intent(in) :: iomode,formeig,comm,method
5013 : integer,intent(out) :: ierr
5014 : character(len=*),intent(in) :: wfk_fname
5015 : !arrays
5016 : real(dp),intent(out) :: cwtimes(2)
5017 : type(hdr_type),intent(in) :: Hdr
5018 : type(kvars_t),intent(in) :: Kvars(Hdr%nkpt)
5019 :
5020 : !Local variables-------------------------------
5021 : !scalars
5022 : integer :: nkpt,nsppol,nspinor,ik_ibz,spin,funt,nband_k,npw_k,sc_mode
5023 : integer :: my_ierr,restart,restartpaw,is,ik,ntests,test,mband
5024 : real(dp) :: cpu,wall,gflops
5025 : character(len=500) :: msg
5026 0 : type(wfk_t) :: Wfk
5027 : !arrays
5028 0 : integer :: nband(Hdr%nkpt,Hdr%nsppol),spins(Hdr%nsppol),kindices(Hdr%nkpt)
5029 0 : integer,allocatable :: kg_k(:,:)
5030 0 : real(dp),allocatable :: cg_k(:,:),eig_k(:),occ_k(:)
5031 0 : logical,allocatable :: bmask(:)
5032 : !************************************************************************
5033 :
5034 : !write(msg,"(3a,i2)")"Checking file: ",TRIM(wfk_fname),", with iomode = ",iomode
5035 : !call wrtout(std_out,msg,"COLL")
5036 :
5037 0 : ierr = 0
5038 0 : cwtimes = zero
5039 :
5040 0 : nband = RESHAPE(Hdr%nband, (/Hdr%nkpt,Hdr%nsppol/) )
5041 0 : nkpt = Hdr%nkpt
5042 0 : nsppol = Hdr%nsppol
5043 0 : nspinor = Hdr%nspinor
5044 :
5045 : ! Open the file for writing.
5046 0 : call cwtime(cpu,wall,gflops,"start")
5047 0 : funt = get_unit()
5048 :
5049 0 : call wfk%open_read(wfk_fname, formeig, iomode, funt, comm)
5050 0 : mband = Wfk%mband
5051 :
5052 0 : call cwtime(cpu,wall,gflops,"stop")
5053 0 : cwtimes = cwtimes + (/cpu,wall/)
5054 :
5055 0 : ntests = 2
5056 :
5057 0 : do test=1,ntests
5058 0 : spins = (/(spin, spin=1,Hdr%nsppol)/)
5059 0 : kindices = (/(ik_ibz, ik_ibz=1,Hdr%nkpt)/)
5060 :
5061 0 : if (test==2) then ! Reverse the indices
5062 0 : spins = [(spin, spin=Hdr%nsppol,1,-1)]
5063 0 : kindices = [(ik_ibz, ik_ibz=Hdr%nkpt,1,-1)]
5064 : end if
5065 : !
5066 0 : do is=1,SIZE(spins)
5067 0 : spin = spins(is)
5068 0 : do ik=1,SIZE(kindices)
5069 0 : ik_ibz = kindices(ik)
5070 0 : if (Wfk%debug) call hdr_check(Wfk%fform,Wfk%fform,Hdr,Wfk%Hdr,"COLL",restart,restartpaw)
5071 :
5072 0 : nband_k = nband(ik_ibz,spin)
5073 0 : npw_k = Hdr%npwarr(ik_ibz)
5074 :
5075 0 : ABI_MALLOC(kg_k, (3,npw_k))
5076 0 : ABI_MALLOC(cg_k, (2,npw_k*nspinor*nband_k))
5077 0 : ABI_MALLOC(eig_k, ((2*mband)**Wfk%formeig*mband) )
5078 0 : ABI_MALLOC(occ_k, (mband))
5079 : !
5080 : !sc_mode = xmpio_collective
5081 0 : sc_mode = xmpio_single
5082 0 : ABI_MALLOC(bmask, (mband))
5083 0 : bmask = .FALSE.
5084 0 : bmask(1:nband_k) = .TRUE.
5085 :
5086 0 : call cwtime(cpu,wall,gflops,"start")
5087 :
5088 0 : if (method==0) then
5089 0 : call wfk%read_band_block((/1,nband_k/),ik_ibz,spin,sc_mode,kg_k=kg_k,cg_k=cg_k,eig_k=eig_k,occ_k=occ_k)
5090 0 : else if (method==1) then
5091 0 : call wfk%read_bmask(bmask,ik_ibz,spin,sc_mode,kg_k=kg_k,cg_k=cg_k,eig_k=eig_k,occ_k=occ_k)
5092 : else
5093 0 : ABI_ERROR("Wrong method")
5094 : end if
5095 :
5096 : !call wfk%read_eigk(ik_ibz,spin,sc_mode,eig_k)
5097 : !write(std_out,*)"eig_k",eig_k
5098 :
5099 0 : call cwtime(cpu,wall,gflops,"stop")
5100 0 : cwtimes = cwtimes + (/cpu,wall/)
5101 :
5102 : ! Check the correctness of the reading.
5103 0 : call fill_or_check("check",Hdr,Kvars(ik_ibz),ik_ibz,spin,formeig,kg_k,cg_k,eig_k,occ_k,my_ierr)
5104 :
5105 0 : if (my_ierr /= 0) then
5106 0 : write(msg,"(a,i0)")"fill_or_check returned my_ierr: ",my_ierr
5107 0 : ierr = my_ierr
5108 0 : ABI_WARNING(msg)
5109 : end if
5110 :
5111 0 : ABI_FREE(kg_k)
5112 0 : ABI_FREE(cg_k)
5113 0 : ABI_FREE(eig_k)
5114 0 : ABI_FREE(occ_k)
5115 0 : ABI_FREE(bmask)
5116 : end do
5117 : end do
5118 : end do ! test
5119 :
5120 : ! Close the file
5121 0 : call wfk%close()
5122 :
5123 0 : end subroutine wfk_check_wfkfile
5124 : !!***
5125 :
5126 : !----------------------------------------------------------------------
5127 :
5128 : !!****f* m_wfk/fill_or_check
5129 : !! NAME
5130 : !! fill_or_check
5131 : !!
5132 : !! FUNCTION
5133 : !!
5134 : !! INPUTS
5135 : !!
5136 : !! SOURCE
5137 :
5138 0 : subroutine fill_or_check(task,Hdr,Kvars,ik_ibz,spin,formeig,kg_k,cg_k,eig_k,occ_k,ierr)
5139 :
5140 : !Arguments ------------------------------------
5141 : !scalars
5142 : integer,intent(in) :: ik_ibz,spin,formeig
5143 : integer,intent(out) :: ierr
5144 : character(len=*),intent(in) :: task
5145 : !arrays
5146 : integer,intent(in) :: kg_k(:,:)
5147 : real(dp),intent(inout) :: cg_k(:,:),eig_k(:),occ_k(:)
5148 : type(hdr_type),intent(in) :: Hdr
5149 : type(kvars_t),intent(in) :: Kvars
5150 :
5151 : !Local variables-------------------------------
5152 : !scalars
5153 : integer :: nkpt,nsppol,nspinor,nband_k,npw_k,band,ipw,kspad,ii,base,idx,mpw,eigsz
5154 : character(len=500) :: msg
5155 : !arrays
5156 0 : integer,allocatable :: ref_kg_k(:,:)
5157 0 : real(dp),allocatable :: ref_eig_k(:),ref_occ_k(:),ref_cg_k(:,:)
5158 : !************************************************************************
5159 :
5160 0 : ierr = 0
5161 0 : nkpt = Hdr%nkpt
5162 0 : nsppol = Hdr%nsppol
5163 0 : nspinor = Hdr%nspinor
5164 0 : nband_k = Hdr%nband(ik_ibz + (spin-1)*nkpt)
5165 0 : npw_k = Hdr%npwarr(ik_ibz)
5166 :
5167 0 : ABI_MALLOC(ref_kg_k,(3,npw_k))
5168 0 : ABI_MALLOC(ref_eig_k,((2*nband_k)**formeig*nband_k))
5169 0 : ABI_MALLOC(ref_occ_k,(nband_k))
5170 0 : ABI_MALLOC(ref_cg_k,(2,npw_k*nspinor*nband_k))
5171 :
5172 0 : ref_kg_k = Kvars%kg_k
5173 :
5174 : ! Pad values according to (k,s).
5175 0 : kspad = (spin-1)*nkpt + (ik_ibz-1) * nband_k
5176 :
5177 0 : if (formeig==0) then
5178 0 : eigsz = nband_k
5179 0 : do band=1,nband_k
5180 0 : ref_eig_k(band) = half * (kspad + band)
5181 0 : ref_occ_k(band) = two * (kspad + band)
5182 : end do
5183 0 : else if (formeig==1) then
5184 0 : eigsz = 2*nband_k**2
5185 0 : base=0
5186 0 : do band=1,nband_k
5187 0 : do ii=1,2*nband_k
5188 0 : idx = base + ii
5189 0 : ref_eig_k(idx) = ii*(kspad + band)
5190 : end do
5191 0 : base = base + 2*nband_k
5192 : end do
5193 : end if
5194 :
5195 0 : mpw = npw_k*nspinor*nband_k
5196 0 : do ipw=1,mpw
5197 0 : ref_cg_k(1,ipw) = ipw + kspad
5198 0 : ref_cg_k(2,ipw) = -ipw + kspad
5199 : end do
5200 :
5201 : SELECT CASE (task)
5202 : CASE ("fill")
5203 0 : cg_k(:,1:mpw) = ref_cg_k(:,1:mpw)
5204 0 : if (formeig==0) then
5205 0 : eig_k(1:nband_k) = ref_eig_k
5206 0 : occ_k(1:nband_k) = ref_occ_k
5207 : else
5208 0 : eig_k(1:2*nband_k**2) = ref_eig_k
5209 : end if
5210 :
5211 : CASE ("check")
5212 :
5213 0 : if (ANY( ABS(cg_k(:,1:mpw) - ref_cg_k) > zero)) then
5214 0 : ierr = ierr + 1
5215 0 : ABI_WARNING("Difference in cg_k")
5216 : end if
5217 :
5218 0 : if (ANY( ABS(kg_k - ref_kg_k) > zero)) then
5219 0 : ierr = ierr + 2
5220 0 : ABI_WARNING("Difference in kg_k")
5221 : !write(std_out,*)"ref_kg_k",ref_kg_k
5222 : !write(std_out,*)"kg_k",kg_k
5223 : end if
5224 :
5225 0 : if (ANY( ABS(eig_k(1:eigsz) - ref_eig_k) > zero)) then
5226 0 : ierr = ierr + 4
5227 0 : ABI_WARNING("Difference in eig_k")
5228 : !write(std_out,*)"ref_eig_k",ref_eig_k
5229 : !write(std_out,*)"eig_k",eig_k
5230 : end if
5231 :
5232 0 : if (formeig==0) then
5233 0 : if (ANY( ABS(occ_k(1:nband_k) - ref_occ_k) > zero)) then
5234 0 : ierr = ierr + 8
5235 0 : ABI_WARNING("occ_k")
5236 : !write(std_out,*)"ref_occ_k",ref_occ_k
5237 : !write(std_out,*)"occ_k",occ_k
5238 : end if
5239 : end if
5240 :
5241 0 : write(msg,"(a,3(i0,2x))")" (ik_ibz, spin, ierr) ",ik_ibz,spin,ierr
5242 0 : if (ierr/=0) then
5243 0 : ABI_WARNING(TRIM(msg)//": FAILED")
5244 : else
5245 0 : call wrtout(std_out,TRIM(msg)//": OK")
5246 : end if
5247 :
5248 : CASE DEFAULT
5249 0 : ABI_ERROR("Wrong task")
5250 : END SELECT
5251 :
5252 0 : ABI_FREE(ref_kg_k)
5253 0 : ABI_FREE(ref_eig_k)
5254 0 : ABI_FREE(ref_occ_k)
5255 0 : ABI_FREE(ref_cg_k)
5256 :
5257 0 : end subroutine fill_or_check
5258 : !!***
5259 :
5260 : !----------------------------------------------------------------------
5261 :
5262 : !!****f* m_wfk/wfk_diff
5263 : !! NAME
5264 : !! wfk_diff
5265 : !!
5266 : !! FUNCTION
5267 : !! Compare two WFK file for binary equality
5268 : !!
5269 : !! INPUTS
5270 : !!
5271 : !! SOURCE
5272 :
5273 0 : subroutine wfk_diff(fname1,fname2,formeig,comm,ierr)
5274 :
5275 : !Arguments ------------------------------------
5276 : integer,intent(in) :: formeig,comm
5277 : integer,intent(out) :: ierr
5278 : character(len=*),intent(in) :: fname1,fname2
5279 :
5280 : !Local variables-------------------------------
5281 : !scalars
5282 : integer,parameter :: master=0
5283 : integer :: iomode1,iomode2,ik_ibz,spin,mband,nband_k
5284 : integer :: npw_k,mcg,fform1,fform2,sc_mode,my_rank,nproc
5285 : character(len=500) :: msg
5286 0 : type(hdr_type) :: Hdr1,Hdr2
5287 0 : type(wfk_t) :: Wfk1,Wfk2
5288 : !arrays
5289 0 : integer,allocatable :: kg1_k(:,:),kg2_k(:,:)
5290 0 : real(dp),allocatable :: eig1_k(:),cg1_k(:,:),occ1_k(:)
5291 0 : real(dp),allocatable :: eig2_k(:),cg2_k(:,:),occ2_k(:)
5292 : ! *************************************************************************
5293 :
5294 0 : call wrtout(std_out, "wfk_diff: comparing "//TRIM(fname1)//" "//TRIM(fname2))
5295 :
5296 0 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
5297 0 : sc_mode = xmpio_collective
5298 :
5299 0 : call hdr1%from_fname(fname1,fform1,comm)
5300 0 : call hdr2%from_fname(fname2,fform2,comm)
5301 :
5302 0 : ABI_CHECK(fform1==fform2,"fform1 != fform2")
5303 0 : ABI_CHECK(Hdr1%nsppol==Hdr2%nsppol,"nsppol1 != nsppol2")
5304 0 : ABI_CHECK(Hdr1%nspinor==Hdr2%nspinor,"nspinor1 != nspinor2")
5305 0 : ABI_CHECK(Hdr1%nkpt==Hdr2%nkpt,"nkpt1 != nkpt2")
5306 : !call hdr_check(fform,fform0,hdr1,hdr2,"COLL",restart,restartpaw)
5307 :
5308 0 : iomode1 = iomode_from_fname(fname1)
5309 0 : iomode2 = iomode_from_fname(fname1)
5310 0 : ABI_CHECK(iomode1==iomode2,"iomode1 != iomode2")
5311 : !iomode1 = IO_MODE_FORTRAN
5312 : !iomode2 = IO_MODE_MPI
5313 :
5314 0 : call wfk1%open_read(fname1, formeig, iomode1, get_unit(), comm)
5315 0 : call wfk2%open_read(fname2, formeig, iomode2, get_unit(), comm)
5316 :
5317 0 : if (wfk1%compare(wfk2) /= 0) then
5318 0 : ABI_ERROR("WFK files are not consistent. See above messages")
5319 : end if
5320 :
5321 0 : mband = Wfk1%mband
5322 0 : ABI_CHECK(mband==Wfk2%mband,"different mband")
5323 0 : ABI_CHECK(all(Wfk1%nband==Wfk2%nband),"different nband")
5324 0 : ABI_CHECK(all(Wfk1%hdr%npwarr==Wfk2%hdr%npwarr),"different npwarr")
5325 :
5326 0 : ierr = 0
5327 0 : do spin=1,Wfk1%nsppol
5328 0 : do ik_ibz=1,Wfk1%nkpt
5329 0 : npw_k = Wfk1%Hdr%npwarr(ik_ibz)
5330 0 : nband_k = Wfk1%nband(ik_ibz,spin)
5331 0 : ABI_CHECK(npw_k ==Wfk2%Hdr%npwarr(ik_ibz),"different npw_k")
5332 0 : ABI_CHECK(nband_k==Wfk2%nband(ik_ibz,spin),"different nband_k")
5333 :
5334 0 : mcg = npw_k*Hdr1%nspinor*nband_k
5335 :
5336 0 : ABI_MALLOC(eig1_k,((2*mband)**formeig*mband))
5337 0 : ABI_MALLOC(occ1_k,(mband))
5338 0 : ABI_MALLOC(kg1_k,(3,npw_k))
5339 0 : ABI_MALLOC_OR_DIE(cg1_k,(2,mcg), ierr)
5340 :
5341 0 : ABI_MALLOC(eig2_k,((2*mband)**formeig*mband))
5342 0 : ABI_MALLOC(occ2_k,(mband))
5343 0 : ABI_MALLOC(kg2_k,(3,npw_k))
5344 0 : ABI_MALLOC_OR_DIE(cg2_k,(2,mcg), ierr)
5345 :
5346 : ! Read the block of bands for this (k,s).
5347 0 : call wfk1%read_band_block([1, nband_k],ik_ibz,spin,sc_mode,kg_k=kg1_k,eig_k=eig1_k,occ_k=occ1_k) !, cg_k=cg1_k,
5348 0 : call wfk2%read_band_block([1, nband_k],ik_ibz,spin,sc_mode,kg_k=kg2_k,eig_k=eig2_k,occ_k=occ2_k) !, cg_k=cg2_k,
5349 :
5350 0 : if (ANY( ABS(kg1_k - kg2_k) > zero)) then
5351 0 : ierr = ierr + 2
5352 0 : ABI_WARNING("Difference in kg_k")
5353 : !write(std_out,*)"kg1_k",kg1_k
5354 : !write(std_out,*)"kg2_k",kg2_k
5355 : end if
5356 :
5357 0 : if (ANY( ABS(eig1_k - eig2_k) > zero)) then
5358 0 : ierr = ierr + 4
5359 0 : ABI_WARNING("Difference in eig_k")
5360 : !write(std_out,*)"eig1_k",eig1_k
5361 : !write(std_out,*)"eig2_k",eig2_k
5362 : end if
5363 :
5364 0 : if (formeig==0) then
5365 0 : if (ANY( ABS(occ1_k - occ2_k) > zero)) then
5366 0 : ierr = ierr + 8
5367 0 : ABI_WARNING("occ_k")
5368 0 : write(std_out,*)"occ1_k",occ1_k
5369 0 : write(std_out,*)"occ2_k",occ2_k
5370 : end if
5371 : end if
5372 :
5373 0 : if (ANY( ABS(cg1_k - cg2_k) > zero)) then
5374 0 : ierr = ierr + 1
5375 0 : ABI_WARNING("Difference in cg_k")
5376 : end if
5377 :
5378 0 : write(msg,"(a,3(i0,2x))")" (ik_ibz, spin, ierr) ",ik_ibz,spin,ierr
5379 0 : if (ierr/=0) then
5380 0 : ABI_WARNING(TRIM(msg)//": FAILED")
5381 : else
5382 0 : call wrtout(std_out,TRIM(msg)//": OK")
5383 : end if
5384 :
5385 0 : ABI_FREE(eig1_k)
5386 0 : ABI_FREE(occ1_k)
5387 0 : ABI_FREE(kg1_k)
5388 0 : ABI_FREE(cg1_k)
5389 :
5390 0 : ABI_FREE(eig2_k)
5391 0 : ABI_FREE(occ2_k)
5392 0 : ABI_FREE(kg2_k)
5393 0 : ABI_FREE(cg2_k)
5394 : end do !ik_ibz
5395 : end do !spin
5396 :
5397 0 : call wfk1%close()
5398 0 : call wfk2%close()
5399 :
5400 0 : call Hdr1%free()
5401 0 : call Hdr2%free()
5402 :
5403 0 : end subroutine wfk_diff
5404 : !!***
5405 :
5406 : !----------------------------------------------------------------------
5407 :
5408 : !!****f* m_wfk/wfk_klist2mesh
5409 : !! NAME
5410 : !! wfk_klist2mesh
5411 : !!
5412 : !! FUNCTION
5413 : !! This routine receives a WFK file with u_k(G) given on a subset of k-points belonging to a k-mesh and
5414 : !! generates a new WFK file with the complete list of k-points in the IBZ by filling the missing k-points with
5415 : !! npw_k =1 and u(G=0) = zero.
5416 : !!
5417 : !! This routine is mainly used to prepare the computation of electron mobilities
5418 : !! whose convergence with the k-point sampling is notoriously slow.
5419 : !! Since only the electron/hole states close to the band edges contribute (say ~0.# eV),
5420 : !! one can reduce significantly the computational cost of the NSCF run by computing
5421 : !! a WFK file with kptopt == 0 and the explicit list of k-points located inside the pockets
5422 : !! instead of computing all the k-points of the dense IBZ.
5423 : !! Unfortunately, the EPH code expects a WFK on a k-mesh so we need to "convert" the initial WFK
5424 : !! with the list of k-points to a new WFK file with k-points on the dense kmesh.
5425 : !!
5426 : !! INPUTS
5427 : !! in_wfkpath = Input WFK file with k-point list.
5428 : !! kerange_path = path to KERANGE.nc file.
5429 : !! dtset <dataset_type>=all input variables for this dataset
5430 : !! out_wfkpath = Output WFK file.
5431 : !! comm = MPI communicator.
5432 : !!
5433 : !! OUTPUT
5434 : !! Output is written to file out_wfkpath.
5435 : !!
5436 : !! NOTES
5437 : !! Only GS WFK files are supported (formeig==0)
5438 : !!
5439 : !! SOURCE
5440 :
5441 2 : subroutine wfk_klist2mesh(in_wfkpath, kerange_path, dtset, comm)
5442 :
5443 : !Arguments ------------------------------------
5444 : !scalars
5445 : character(len=*),intent(in) :: in_wfkpath, kerange_path
5446 : type(dataset_type),intent(in) :: dtset
5447 : integer,intent(in) :: comm
5448 : !arrays
5449 :
5450 : !Local variables-------------------------------
5451 : !scalars
5452 : integer,parameter :: formeig0 = 0, master = 0
5453 : integer :: spin, ikf, ikin, nband_k, mpw, mband, nspinor, ierr, fine_mband
5454 : integer :: nsppol, iomode, npw_k, ii, my_rank, ncid, fform, fform_kerange
5455 : real(dp) :: cpu, wall, gflops, mae_meV, merr
5456 : character(len=500) :: msg
5457 : character(len=fnlen) :: my_inpath, out_wfkpath
5458 8 : type(wfk_t),target :: iwfk
5459 8 : type(wfk_t) :: owfk
5460 104 : type(crystal_t) :: cryst
5461 2 : type(hdr_type) :: fine_hdr
5462 : type(hdr_type),pointer :: ihdr
5463 4 : type(ebands_t) :: iwfk_ebands, fine_ebands
5464 : !arrays
5465 2 : integer,allocatable :: kf2kin(:), kg_k(:,:) !, kshe_mask(:,:,:)
5466 4 : real(dp),allocatable :: cg_k(:,:), eig_k(:), occ_k(:), fine_eigen(:,:,:)
5467 : ! *************************************************************************
5468 :
5469 2 : call cwtime(cpu, wall, gflops, "start")
5470 :
5471 : ! IO section are executed by master only, all other procs wait for the new WFK before returning.
5472 2 : my_rank = xmpi_comm_rank(comm); if (my_rank /= master) goto 100
5473 :
5474 : ! Read interpolated ebands and kshe_mask from KERANGE file and build fine_ebands object.
5475 : ! NOTE: KERANGE is written by sigtk_kpts_in_erange in m_sigtk module.
5476 2 : NCF_CHECK(nctk_open_read(ncid, kerange_path, xmpi_comm_self))
5477 : ! Read header associated to the fine k-mesh
5478 2 : call fine_hdr%ncread(ncid, fform)
5479 2 : fform_kerange = fform_from_ext("KERANGE.nc")
5480 2 : ABI_CHECK(fform == fform_kerange, sjoin("Wrong fform. Got: ", itoa(fform), ", Expecting: ", itoa(fform_kerange)))
5481 : ! Read eigenvalues and kmask
5482 176 : fine_mband = maxval(fine_hdr%nband)
5483 10 : ABI_MALLOC(fine_eigen, (fine_mband, fine_hdr%nkpt, fine_hdr%nsppol))
5484 2 : NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "eigenvalues"), fine_eigen))
5485 : !NCF_CHECK(nctk_get_dim(ncid, "nkpt_inerange", nkpt_inerage))
5486 : !ABI_MALLOC(kshe_mask, (fine_hdr%nkpt, fine_hdr%nsppol, 2))
5487 : !NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "kshe_mask"), kshe_mask))
5488 : !ABI_MALLOC(krange2ibz, (nkpt_inerange))
5489 : !NCF_CHECK(nf90_get_var(ncid, nctk_idname(ncid, "krange2ibz"), krange2ibz))
5490 : !ABI_FREE(krange2ibz)
5491 2 : NCF_CHECK(nf90_close(ncid))
5492 : ! Build fine_ebands
5493 2 : call fine_ebands%from_hdr(fine_hdr, fine_mband, fine_eigen)
5494 : !call fine_ebands%print([std_out], header="SKW interpolated energies", prtvol=dtset%prtvol)
5495 2 : ABI_FREE(fine_eigen)
5496 :
5497 : if (my_rank == master) then
5498 2 : write(std_out, "(2a)")ch10, repeat("=", 92)
5499 : !call wrtout([std_out, ab_out], msg)
5500 2 : write(std_out, "(a)")" Generating new WKF file with dense k-mesh:"
5501 2 : write(std_out, "(2a)")" Taking ab-initio wavefunctions with k-point list from WFK file: ", trim(in_wfkpath)
5502 2 : write(std_out, "(a)")" When the routine returns, this file will be replaced by a new one with the dense k-mesh"
5503 2 : write(std_out, "(2a)")" Taking eigenvalues and k-point tables from KERANGE file: ", trim(kerange_path)
5504 2 : write(std_out, "(a, 9(i0, 1x))")" fine_kptrlatt: ", fine_hdr%kptrlatt
5505 4 : do ii=1,fine_hdr%nshiftk
5506 4 : write(std_out, "(a, 3(f5.2, 1x))")" fine_shiftk: ", fine_hdr%shiftk(:, ii)
5507 : end do
5508 2 : write(std_out, "(2a)")repeat("=", 92), ch10
5509 : end if
5510 :
5511 : ! Open WFK file with k-point list, extract dimensions and allocate workspace arrays.
5512 2 : my_inpath = in_wfkpath
5513 2 : if (nctk_try_fort_or_ncfile(my_inpath, msg) /= 0) then
5514 0 : ABI_ERROR(msg)
5515 : end if
5516 2 : iwfk_ebands = wfk_read_ebands(my_inpath, xmpi_comm_self)
5517 : !call iwfk_ebands%print([std_out], header="iwfk_ebands", prtvol=dtset%prtvol)
5518 :
5519 2 : iomode = iomode_from_fname(my_inpath)
5520 2 : call iwfk%open_read(my_inpath, formeig0, iomode, get_unit(), xmpi_comm_self)
5521 :
5522 2 : if (my_rank == master .and. dtset%prtvol > 0) then
5523 0 : fform = 0
5524 0 : call iwfk%hdr%echo(fform, 3, unit=std_out, header="Header of iwfk file")
5525 0 : call fine_hdr%echo(fform, 3, unit=std_out, header="Header of fine_hdr")
5526 : end if
5527 :
5528 2 : ihdr => iwfk%hdr
5529 2 : mband = iwfk%mband; nsppol = iwfk%nsppol; nspinor = iwfk%nspinor
5530 :
5531 2 : cryst = iwfk%hdr%get_crystal()
5532 :
5533 : ! Find correspondence fine kmesh --> input WFK and handle possible mismatch
5534 : !TODO: Write specialized routine wrapping listkk to find mapping without O(N2) scaling.
5535 6 : ABI_MALLOC(kf2kin, (fine_ebands%nkpt))
5536 176 : kf2kin = -1
5537 : !call kpts_map(iwfk_ebands%nkpt, iwfk_ebands%kptns, fine_ebands%nkpt, fine_ebands%kptns, kf2kin, xmpi_comm_self)
5538 176 : do ikf=1,fine_ebands%nkpt
5539 1746 : do ii=1,iwfk_ebands%nkpt
5540 1957 : if (all(abs(fine_ebands%kptns(:, ikf) - iwfk_ebands%kptns(:, ii)) < tol12)) then
5541 17 : kf2kin(ikf) = ii; exit
5542 : end if
5543 : end do
5544 : end do
5545 :
5546 176 : if (count(kf2kin /= -1) /= iwfk_ebands%nkpt) then
5547 0 : write(msg, "(2a, 2(a,i0))")"Something wrong in the computation of fine_mesh --> input_mesh table.",ch10, &
5548 0 : "Expecting: ", iwfk_ebands%nkpt, " matches, found: ", count(kf2kin /= -1)
5549 0 : ABI_ERROR(msg)
5550 : end if
5551 :
5552 : ! Check weights (the list of k-points should be a subset of the kmesh specified by sigma_ngkpt).
5553 2 : ierr = 0
5554 176 : do ikf=1,fine_ebands%nkpt
5555 174 : ikin = kf2kin(ikf)
5556 174 : if (ikin == -1) cycle
5557 19 : if (abs(ihdr%wtk(ikin) - fine_ebands%wtk(ikf)) > tol12) then
5558 0 : ierr = ierr + 1
5559 0 : if (ierr <= 10) write(std_out, *) "ihdr%wtk:", ihdr%wtk(ikin), "fine_ebands%wtk", fine_ebands%wtk(ikf)
5560 : end if
5561 : end do
5562 2 : if (ierr /= 0) then
5563 : write(msg, "(3a)") &
5564 0 : "Mismatch between input k-weights and weigths associated to the fine mesh. ", ch10, &
5565 0 : "Possible inconsistency between k-mesh defined by sigma_nshiftk and the list of k-points found in file."
5566 0 : ABI_ERROR(msg)
5567 : end if
5568 :
5569 : ! TODO
5570 : !fine_hdr%fermie ! EVOLVING variable
5571 : !fine_hdr%residm ! EVOLVING variable
5572 :
5573 : ! Build new header for output WFK. This is the most delicate part since all the arrays in fine_hdr
5574 : ! that depend on k-points must be consistent with the fine k-mesh.
5575 2 : mae_meV = zero
5576 176 : do ikf=1,fine_ebands%nkpt
5577 174 : ikin = kf2kin(ikf)
5578 :
5579 176 : if (ikin == -1) then
5580 : ! Set npwarr to 1 if k-point is not in input set to reduce file size.
5581 157 : fine_ebands%npwarr(ikf) = 1
5582 157 : fine_hdr%npwarr(ikf) = 1
5583 : else
5584 17 : fine_ebands%npwarr(ikf) = iwfk_ebands%npwarr(ikin)
5585 17 : fine_hdr%npwarr(ikf) = iwfk_ebands%npwarr(ikin)
5586 :
5587 : ! Insert ab-initio eigenvalues in the SKW-interpolated fine k-mesh.
5588 34 : do spin=1,nsppol
5589 17 : nband_k = iwfk_ebands%nband(ikin + (spin - 1) * iwfk_ebands%nkpt)
5590 304 : merr = Ha_meV * maxval(abs(fine_ebands%eig(1:nband_k, ikf, spin) - iwfk_ebands%eig(1:nband_k, ikin, spin)))
5591 17 : write(std_out, "(a, es12.4,a)")" MERR: ", merr, " (meV)"
5592 : !if merr >
5593 : !write(std_out, *)fine_ebands%eig(1:nband_k, ikf, spin) * Ha_eV
5594 : !write(std_out, *)iwfk_ebands%eig(1:nband_k, ikin, spin) * Ha_eV
5595 : !write(std_out, *) Ha_meV * (fine_ebands%eig(1:nband_k, ikf, spin) - iwfk_ebands%eig(1:nband_k, ikin, spin))
5596 : !end if
5597 17 : mae_meV = max(mae_meV, merr)
5598 287 : fine_ebands%eig(1:nband_k, ikf, spin) = iwfk_ebands%eig(1:nband_k, ikin, spin)
5599 304 : fine_ebands%occ(1:nband_k, ikf, spin) = iwfk_ebands%occ(1:nband_k, ikin, spin)
5600 : end do
5601 : end if
5602 :
5603 : end do
5604 :
5605 : write(std_out, "(a, es12.4,a)") &
5606 2 : " Max error between SKW interpolated energies and ab-initio quantities:", mae_meV, " (meV)"
5607 :
5608 : !if (mae_meV > ten) then
5609 : ! write(msg,"(2a,2(a,es12.4),a)") &
5610 : ! "Large error in SKW interpolation!",ch10," MARE: ",mare, ", MAE: ", mae_meV, " (meV)"
5611 : ! call wrtout(ab_out, msg)
5612 : ! ABI_WARNING(msg)
5613 : !end if
5614 :
5615 2 : call fine_ebands%update_occ(dtset%spinmagntarget, prtvol=dtset%prtvol)
5616 : !call pack_eneocc(nkpt, nsppol, mband, nband, bantot, array3d, vect)
5617 : !fine_hdr%occ = reshape(fine_ebands%occ, fine_ebands%mband (1:nband_k, ikin, spin)
5618 4 : call fine_ebands%print([std_out], header="fine_ebands", prtvol=dtset%prtvol)
5619 :
5620 2 : out_wfkpath = strcat(in_wfkpath, ".tmp")
5621 2 : if (iomode == IO_MODE_ETSF) out_wfkpath = strcat(out_wfkpath, ".nc")
5622 2 : call owfk%open_write(fine_hdr, out_wfkpath, iwfk%formeig, iomode, get_unit(), xmpi_comm_self)
5623 :
5624 2 : if (iomode == IO_MODE_ETSF) then
5625 : ! Add crystal structure and ebands if netcdf output.
5626 2 : NCF_CHECK(cryst%ncwrite(owfk%fh))
5627 2 : NCF_CHECK(fine_ebands%ncwrite(owfk%fh))
5628 : end if
5629 :
5630 2 : call fine_hdr%free()
5631 :
5632 : ! Allocate workspace arrays for wavefunction block.
5633 176 : mpw = maxval(fine_ebands%npwarr)
5634 6 : ABI_MALLOC(kg_k, (3, mpw))
5635 6 : ABI_MALLOC(cg_k, (2, mpw * nspinor * mband))
5636 6 : ABI_MALLOC(eig_k, ((2*mband)**iwfk%formeig * mband) )
5637 6 : ABI_MALLOC(occ_k, (mband))
5638 :
5639 4 : do spin=1,nsppol
5640 178 : do ikf=1,fine_ebands%nkpt
5641 174 : ikin = kf2kin(ikf)
5642 174 : nband_k = owfk%nband(ikf, spin)
5643 174 : npw_k = owfk%hdr%npwarr(ikf)
5644 :
5645 : !cg_k = zero
5646 174 : if (ikin /= -1) then
5647 :
5648 : ! Consistency check
5649 17 : if (nband_k /= iwfk%nband(ikin, spin)) then
5650 0 : ABI_ERROR(sjoin("Mismatch in nband_k", itoa(nband_k), "/=", itoa(iwfk%nband(ikin, spin))))
5651 : end if
5652 17 : if (npw_k /= iwfk%hdr%npwarr(ikin)) then
5653 0 : ABI_ERROR(sjoin("Mismatch in npw_k", itoa(npw_k), "/=", itoa(iwfk%hdr%npwarr(ikin))))
5654 : end if
5655 17 : if (owfk%hdr%istwfk(ikf) /= iwfk%hdr%istwfk(ikin)) then
5656 0 : ABI_ERROR(sjoin("Mismatch in istwfk_k", itoa(owfk%hdr%istwfk(ikf)), "/=", itoa(iwfk%hdr%istwfk(ikin))))
5657 : end if
5658 :
5659 : ! Read wavefunctions from input WFK file.
5660 51 : call iwfk%read_band_block([1, nband_k], ikin, spin, xmpio_single, kg_k=kg_k, cg_k=cg_k) !, eig_k=eig_k, occ_k=occ_k)
5661 : else
5662 : ! Fill wavefunctions with fake data (npw_k == 1)
5663 289365 : kg_k = 0
5664 3578617 : cg_k = zero
5665 : end if
5666 :
5667 : ! Write (kpt, spin) block
5668 3364 : eig_k(1:nband_k) = fine_ebands%eig(1:nband_k, ikf, spin)
5669 3364 : occ_k(1:nband_k) = fine_ebands%occ(1:nband_k, ikf, spin)
5670 :
5671 524 : call owfk%write_band_block([1, nband_k], ikf, spin, xmpio_single, kg_k=kg_k, cg_k=cg_k, eig_k=eig_k, occ_k=occ_k)
5672 : end do
5673 : end do
5674 :
5675 : ! Free memory
5676 2 : ABI_FREE(kg_k)
5677 2 : ABI_FREE(cg_k)
5678 2 : ABI_FREE(eig_k)
5679 2 : ABI_FREE(occ_k)
5680 2 : ABI_FREE(kf2kin)
5681 : !ABI_FREE(kshe_mask)
5682 :
5683 2 : call cryst%free()
5684 2 : call iwfk_ebands%free()
5685 2 : call fine_ebands%free()
5686 2 : call iwfk%close()
5687 2 : call owfk%close()
5688 :
5689 : ! Rename files, keep backup copy of input WFK file.
5690 2 : call delete_file(my_inpath, ierr)
5691 2 : ABI_CHECK(ierr == 0, sjoin("Cannot remove OLD file:", my_inpath))
5692 : !ABI_CHECK(clib_rename(my_inpath, strcat(my_inpath, ".bkp")) == 0, "Failed to rename input WFK file.")
5693 2 : ABI_CHECK(clib_rename(out_wfkpath, my_inpath) == 0, "Failed to rename output WFK file.")
5694 :
5695 0 : call cwtime_report(" WFK with fine k-mesh written to file.", cpu, wall, gflops)
5696 :
5697 : ! All procs wait here.
5698 2 : 100 call xmpi_barrier(comm)
5699 :
5700 10 : end subroutine wfk_klist2mesh
5701 : !!***
5702 :
5703 : !----------------------------------------------------------------------
5704 :
5705 : !!****f* m_wfk/wfk_check_symtab
5706 : !! NAME
5707 : !! wfk_check_symtab
5708 : !!
5709 : !! FUNCTION
5710 : !!
5711 : !! INPUTS
5712 : !! in_wfkpath = Input WFK file generated with kptopt 3
5713 : !! Only GS WFK files supported (formeig==0)
5714 : !!
5715 : !! SOURCE
5716 :
5717 0 : subroutine wfk_check_symtab(in_wfkpath, comm)
5718 :
5719 : use m_krank, only : krank_t, get_ibz2bz, star_from_ibz_idx
5720 : use m_kpts, only : kpts_ibz_from_kptrlatt, kpts_timrev_from_kptopt, kpts_map, kpts_map_print, kpts_pack_in_stars
5721 : use m_cgtools, only : fxphas_and_cmp
5722 :
5723 : !Arguments ------------------------------------
5724 : !scalars
5725 : character(len=*),intent(in) :: in_wfkpath
5726 : integer,intent(in) :: comm
5727 :
5728 : !Local variables-------------------------------
5729 : !scalars
5730 : integer,parameter :: formeig0 = 0, master = 0, kptopt1 = 1
5731 : integer :: spin, nband_k, mpw, mband, nspinor, ik_ibz, ik_bz !, ierr, ikf
5732 : integer :: nsppol, iomode, npw_kf, npw_ki, istwf_kf, istwf_ki, ii, my_rank, nkibz, nkbz, isym_k, trev_k, g0_k(3)
5733 : logical :: isirr_k
5734 : character(len=500) :: msg
5735 : character(len=fnlen) :: my_inpath
5736 0 : type(wfk_t) :: wfk
5737 0 : type(crystal_t) :: cryst
5738 0 : type(krank_t) :: krank_ibz
5739 0 : type(ebands_t) :: ks_ebands
5740 : !arrays
5741 : integer :: work_ngfft(18), gmax(3), gmax_kf(3), gmax_ki(3)
5742 0 : integer,allocatable :: symrec_kbz2ibz(:,:), symrel_kbz2ibz(:,:), symrec_ibz2bz(:), symrel_ibz2bz(:), kg_kf(:,:), kg_ki(:,:)
5743 : real(dp) :: ki(3), kf(3)
5744 0 : real(dp),allocatable :: kibz(:,:), kbz(:,:), wtk(:), cg_kf(:,:), cg_ki(:,:), cg_symrel(:,:), cg_symrec(:,:), work(:,:,:,:)
5745 : ! *************************************************************************
5746 :
5747 0 : my_rank = xmpi_comm_rank(comm); if (my_rank /= master) return
5748 :
5749 0 : call wrtout(std_out, " In wfk_check_symtab")
5750 :
5751 : ! Open WFK file with k-point list, extract dimensions and allocate workspace arrays.
5752 0 : my_inpath = in_wfkpath
5753 0 : if (nctk_try_fort_or_ncfile(my_inpath, msg) /= 0) then
5754 0 : ABI_ERROR(msg)
5755 : end if
5756 0 : ks_ebands = wfk_read_ebands(my_inpath, xmpi_comm_self)
5757 0 : ABI_CHECK_IEQ(ks_ebands%kptopt, 3, "kptopt should be 3")
5758 :
5759 0 : iomode = iomode_from_fname(my_inpath)
5760 0 : call wfk%open_read(my_inpath, formeig0, iomode, get_unit(), xmpi_comm_self)
5761 0 : mband = wfk%mband; nsppol = wfk%nsppol; nspinor = wfk%nspinor
5762 :
5763 0 : cryst = wfk%hdr%get_crystal()
5764 :
5765 : ! Get IBZ with kptopt1 ! ks_ebands%kptopt
5766 : call kpts_ibz_from_kptrlatt(cryst, ks_ebands%kptrlatt, kptopt1, ks_ebands%nshiftk, ks_ebands%shiftk, &
5767 0 : nkibz, kibz, wtk, nkbz, kbz) !, bz2ibz=bz2ibz)
5768 :
5769 0 : ABI_CHECK(all(abs(ks_ebands%kptns - kbz) < tol12), "Wrong kbz!")
5770 :
5771 0 : call krank_ibz%from_kptrlatt(nkibz, kibz, ks_ebands%kptrlatt, compute_invrank=.False.)
5772 :
5773 : ! Build symmetry tables using the two conventions.
5774 :
5775 0 : ABI_MALLOC(symrec_kbz2ibz, (6, nkbz))
5776 0 : if (kpts_map("symrec", kptopt1, cryst, krank_ibz, nkbz, kbz, symrec_kbz2ibz) /= 0) then
5777 0 : ABI_ERROR("Cannot map kBZ to IBZ!")
5778 : end if
5779 : ! Index of IBZ k-point in the full BZ (used to access IBZ in the WFK)
5780 0 : ABI_MALLOC(symrec_ibz2bz, (nkibz))
5781 0 : do ik_bz=1,nkbz
5782 0 : ik_ibz = symrec_kbz2ibz(1,ik_bz); isym_k = symrec_kbz2ibz(2,ik_bz)
5783 0 : trev_k = symrec_kbz2ibz(6,ik_bz); g0_k = symrec_kbz2ibz(3:5,ik_bz)
5784 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
5785 0 : if (isirr_k) then
5786 : !print *, "ik_bz, ik_ibz", ik_bz, ik_ibz
5787 0 : symrec_ibz2bz(ik_ibz) = ik_bz
5788 : end if
5789 : end do
5790 :
5791 0 : ABI_MALLOC(symrel_kbz2ibz, (6, nkbz))
5792 0 : if (kpts_map("symrel", kptopt1, cryst, krank_ibz, nkbz, kbz, symrel_kbz2ibz) /= 0) then
5793 0 : ABI_ERROR("Cannot map kBZ to IBZ!")
5794 : end if
5795 : ! Index of IBZ k-point in the full BZ (used to access IBZ in the WFK)
5796 0 : ABI_MALLOC(symrel_ibz2bz, (nkibz))
5797 0 : do ik_bz=1,nkbz
5798 0 : ik_ibz = symrel_kbz2ibz(1,ik_bz); isym_k = symrel_kbz2ibz(2,ik_bz)
5799 0 : trev_k = symrel_kbz2ibz(6,ik_bz); g0_k = symrel_kbz2ibz(3:5,ik_bz)
5800 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
5801 0 : if (isirr_k) symrel_ibz2bz(ik_ibz) = ik_bz
5802 : end do
5803 :
5804 : ! Allocate workspace arrays for wavefunction block.
5805 0 : mpw = maxval(ks_ebands%npwarr)
5806 0 : ABI_MALLOC(kg_kf, (3, mpw))
5807 0 : ABI_MALLOC(kg_ki, (3, mpw))
5808 0 : ABI_MALLOC(cg_kf, (2, mpw * nspinor * mband))
5809 0 : ABI_MALLOC(cg_ki, (2, mpw * nspinor * mband))
5810 0 : ABI_MALLOC(cg_symrel, (2, mpw * nspinor * mband))
5811 0 : ABI_MALLOC(cg_symrec, (2, mpw * nspinor * mband))
5812 : !ABI_MALLOC(eig_k, ((2*mband)**wfk%formeig * mband) )
5813 : !ABI_MALLOC(occ_k, (mband))
5814 :
5815 0 : do spin=1,nsppol
5816 : ! Note how we loop over the full BZ as this is what we have in the WFK file.
5817 0 : do ik_bz=1,nkbz
5818 :
5819 0 : nband_k = wfk%nband(ik_bz, spin)
5820 0 : nband_k = min(4, nband_k)
5821 :
5822 : ! Read wavefunctions at full k.
5823 0 : npw_kf = wfk%hdr%npwarr(ik_bz)
5824 0 : istwf_kf = wfk%hdr%istwfk(ik_bz)
5825 0 : kf = ks_ebands%kptns(:, ik_bz)
5826 0 : call wfk%read_band_block([1, nband_k], ik_bz, spin, xmpio_single, cg_k=cg_kf, kg_k=kg_kf)
5827 :
5828 : ! -----------------------------------------------
5829 : ! Build ik_bz from ik_ibz using symrel convention
5830 : ! -----------------------------------------------
5831 :
5832 0 : ik_ibz = symrel_kbz2ibz(1,ik_bz); isym_k = symrel_kbz2ibz(2,ik_bz)
5833 0 : trev_k = symrel_kbz2ibz(6,ik_bz); g0_k = symrel_kbz2ibz(3:5,ik_bz)
5834 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
5835 :
5836 : if (isirr_k) cycle
5837 :
5838 0 : ii = symrel_ibz2bz(ik_ibz)
5839 0 : ki = ks_ebands%kptns(:, ii)
5840 0 : npw_ki = wfk%hdr%npwarr(ii)
5841 0 : istwf_ki = wfk%hdr%istwfk(ii)
5842 : !write(std_out, *), "kf: ", trim(ktoa(kf)), "istwf_kf:", istwf_kf
5843 : !write(std_out, *), "ki: ", trim(ktoa(ki)), "istwf_ki:", istwf_ki
5844 : !ABI_CHECK_IEQ(istwf_ki, istwf_kf, "istwf_ki /= istwf_kf")
5845 :
5846 0 : call wfk%read_band_block([1, nband_k], ii, spin, xmpio_single, cg_k=cg_ki, kg_k=kg_ki)
5847 :
5848 : ! FFT box must enclose the two spheres centered on kdisk and kf
5849 0 : gmax_kf = maxval(abs(kg_kf(:, 1:npw_kf)), dim=2)
5850 0 : gmax_ki = maxval(abs(kg_ki(:, 1:npw_ki)), dim=2)
5851 0 : do ii=1,3
5852 0 : gmax(ii) = max(gmax_kf(ii), gmax_ki(ii))
5853 : end do
5854 0 : gmax = 2 * gmax + 1
5855 0 : call ngfft_seq(work_ngfft, gmax)
5856 0 : ABI_CALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
5857 :
5858 : call cgtk_rotate(cryst, ki, isym_k, trev_k, g0_k, nspinor, nband_k, &
5859 0 : npw_ki, kg_ki, npw_kf, kg_kf, istwf_ki, istwf_kf, cg_ki, cg_symrel, work_ngfft, work)
5860 :
5861 : ! Compare cg_kf with cg_symrel taking into account a possible gauge.
5862 0 : if (.not. fxphas_and_cmp(npw_kf, nspinor, nband_k, istwf_kf, cg_kf, cg_symrel, ks_ebands%eig(:, ik_bz, spin), msg)) then
5863 0 : call wrtout(std_out, msg)
5864 : end if
5865 :
5866 : ! -----------------------------------------------
5867 : ! Build ik_bz from ik_ibz using symrec convention
5868 : ! -----------------------------------------------
5869 0 : ik_ibz = symrec_kbz2ibz(1,ik_bz); isym_k = symrec_kbz2ibz(2,ik_bz)
5870 0 : trev_k = symrec_kbz2ibz(6,ik_bz); g0_k = symrec_kbz2ibz(3:5,ik_bz)
5871 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
5872 :
5873 0 : ii = symrec_ibz2bz(ik_ibz)
5874 0 : ki = ks_ebands%kptns(:, ii)
5875 0 : npw_ki = wfk%hdr%npwarr(ii)
5876 0 : istwf_ki = wfk%hdr%istwfk(ii)
5877 : !write(std_out, *), "kf: ", trim(ktoa(kf)), "istwf_kf:", istwf_kf
5878 : !write(std_out, *), "ki: ", trim(ktoa(ki)), "istwf_ki:", istwf_ki
5879 : !ABI_CHECK_IEQ(istwf_ki, istwf_kf, "istwf_ki /= istwf_kf")
5880 :
5881 0 : call wfk%read_band_block([1, nband_k], ii, spin, xmpio_single, cg_k=cg_ki, kg_k=kg_ki)
5882 :
5883 : !call cgtk_rotate_symrec(cryst, ki, isym_k, trev_k, g0_k, nspinor, nband_k, &
5884 : ! npw_ki, kg_ki, npw_kf, kg_kf, istwf_ki, istwf_kf, cg_ki, cg_symrec, work_ngfft, work)
5885 :
5886 : ! Compare cg_kf with cg_symrel taking into account a possible gauge.
5887 : !if (.not. fxphas_and_cmp(npw_kf, nspinor, nband_k, istwf_kf, cg_kf, cg_symrec, ks_ebands%eig(:, ik_bz, spin), msg)) then
5888 : ! call wrtout(std_out, msg)
5889 : !end if
5890 :
5891 0 : ABI_FREE(work)
5892 : end do
5893 : end do
5894 :
5895 : ! Free memory
5896 0 : ABI_FREE(symrec_kbz2ibz)
5897 0 : ABI_FREE(symrel_kbz2ibz)
5898 0 : ABI_FREE(symrec_ibz2bz)
5899 0 : ABI_FREE(symrel_ibz2bz)
5900 0 : ABI_FREE(kibz)
5901 0 : ABI_FREE(kbz)
5902 0 : ABI_FREE(wtk)
5903 0 : call krank_ibz%free()
5904 :
5905 0 : ABI_FREE(kg_kf)
5906 0 : ABI_FREE(cg_kf)
5907 0 : ABI_FREE(kg_ki)
5908 0 : ABI_FREE(cg_ki)
5909 0 : ABI_FREE(cg_symrel)
5910 0 : ABI_FREE(cg_symrec)
5911 : ABI_SFREE(work)
5912 : !ABI_FREE(eig_k)
5913 : !ABI_FREE(occ_k)
5914 :
5915 0 : call cryst%free()
5916 0 : call ks_ebands%free()
5917 0 : call wfk%close()
5918 :
5919 0 : end subroutine wfk_check_symtab
5920 : !!***
5921 :
5922 : !----------------------------------------------------------------------
5923 :
5924 3774 : end module m_wfk
5925 : !!***
|
