Compilation serial ifort

Submitted by jonlafuente on Fri, 05/26/2017 - 03:04

Forums 

Installation

Dear BerkeleyGW users and developers,

I am trying to compile BGW in my desktop computer using the intel compilers ifort and icc, but I get the following error during the compilation:

ifort -O3 -o Common/printsvninfo.x Common/printsvninfo.o Common/svninfo.o Common/global.o Common/typedefs.o Common/nrtype.o Common/push_pop.o Common/message.o Common/peinfo.o Common/timing.o Common/intrinsics.o Common/scalapack_aux.o
ifort: error #10236: File not found: 'Common/printsvninfo.o'
ifort: error #10236: File not found: 'Common/svninfo.o'
ifort: error #10236: File not found: 'Common/global.o'
ifort: error #10236: File not found: 'Common/typedefs.o'
ifort: error #10236: File not found: 'Common/nrtype.o'
ifort: error #10236: File not found: 'Common/push_pop.o'
ifort: error #10236: File not found: 'Common/message.o'
ifort: error #10236: File not found: 'Common/peinfo.o'
ifort: error #10236: File not found: 'Common/timing.o'
ifort: error #10236: File not found: 'Common/intrinsics.o'
ifort: error #10236: File not found: 'Common/scalapack_aux.o'
ifort: command line error: no files specified; for help type "ifort -help"
Common/common-rules.mk:220: recipe for target 'Common/printsvninfo.x' failed
make[2]: *** [Common/printsvninfo.x] Error 1
make[2]: Leaving directory '/home/jonl/CODES/BerkeleyGW-1.2.0'
Makefile:8: recipe for target 'pre' failed
make[1]: *** [pre] Error 2
make[1]: Leaving directory '/home/jonl/CODES/BerkeleyGW-1.2.0'
Makefile:94: recipe for target 'all' failed
make: *** [all] Error 2

-----------------------------------------------------------------------------------------------------------------------------

Here I attach my arch.mk file:

# arch.mk for BerkeleyGW codes
#
# single processor with ifort, MKL, 32-bit on x86_64, suitable for Tigger
# note that Ubuntu 10.10 is 'unsupported' by Intel
# but it seems to work fine nonetheless
#
# D. Strubbe
# Jan 2011, UCB

COMPFLAG = -DINTEL
MATHFLAG =
# Only uncomment DEBUGFLAG if you need to develop/debug BerkeleyGW.
# The output will be much more verbose, and the code will slow down by ~20%.
DEBUGFLAG = -DDEBUG -DVERBOSE

FCPP = icc -E -C
F90free = ifort -E -free
LINK = ifort
# -warn all can often lead to compiler crashes!
FOPTS = -O3
# -O3 generates correct code, but especially with -warn all takes forever and can crash the compiler
FNOOPTS = -O3
MOD_OPT = -module
INCFLAG = -I

CC_COMP = icc
C_COMP = icc
C_LINK = icc
C_OPTS = -O3
C_DEBUGFLAG =

REMOVE = /bin/rm -f

# Math Libraries
#
FFTWLIB = -L/opt/fftw-3.3.6-pl2/lib -libfftw
FFTWINCLUDE = /opt/fftw-3.3.6-pl2/include
MKLPATH = /opt/intel/compilers_and_libraries_2017.2.174/linux/mkl/lib/intel64
LAPACKLIB = -Wl,--start-group $(MKLPATH)/libmkl_intel_lp64.a $(MKLPATH)/libmkl_sequential.a \
$(MKLPATH)/libmkl_core.a -Wl,--end-group -lpthread

-----------------------------------------------------------------------------------------------------------------------------

It seems that the pre-compilation is failing at some point, but I can not figure out where and how to fix it. Does anyone have any suggestions?

Sorry for the beginner's question, and thanks in advance.

All the best,
Jon

jdeslip's picture

Submitted by jdeslip on Sat, 06/17/2017 - 15:23

Hmm, I'm not really sure how this occurred. Do the files actually exist in the Common directory? If not maybe something earlier failed in the build process. Can you paste your whole output if you still have this issue?

Submitted by jonlafuente on Mon, 06/19/2017 - 06:57

Dear Jack,

Thank you for the response.

I finally avoided the problem by removing the "-E" flag from F90free, and then modifying by hand some subroutines that were not being properly precompiled. For example, removing free spaces that were causing an error in sort.p.f :

Common/sort.p.f(326): error #5145: Invalid blank/tab
if (.not.(AA(ord(jj))-AA(tord)>TOL . or .(AA(ord(jj))-AA(tord)> -TOL . and . GK(ord(jj))>GK(tord)))) exit
------------------------------------------^

Modifying three or four subroutines similarly I finally end up compiling everything and the code works properly.

Anyway, I paste below the whole output I obtained with the -E flag, just in case someone else finds the same problem. The files did not exist in the Common directory, just the .f90 files (for instance printsvninfo.f90 existed but not printsvninfo.o or printsvninfo.x).

Thanks for the help!

All the best,
Jon

-----------------------------------------------------------------------------------------------------------------------------

make pre && make all_
make[1]: Entering directory '/home/jonl/Downloads/BerkeleyGW-1.2.0'
make donkey && make common
make[2]: Entering directory '/home/jonl/Downloads/BerkeleyGW-1.2.0'

..o.
.oxxo.
.oxxxxo...
oxxxxxxo.
.oxxxxxxx.
.ooooooxxo..
.oooooooxo..
.oooooxxo...
.........oxooo......
............................
.................................
....................................
. ..oo. .... .................................oooxxxxxxxo.
.............oxxxx@ox@@@x@x.....................o...........ooooooooooxx.
.o.........oox@x.oo........xxx@@............ooxxxxo..........ooooxxxxxoxo
.x........x@xxo...............o@xxo........oxxx@@@xoooooooooooooooxxxo...
.o......ox@@o..................oox@o.....ooxxx@xoooxxxxxxxoooooooooooo....
o..ooooo@@xoooo....ooo...........x@o.....ooxxxxo .oxxxxxxxxxxooooooo....
. .oooo@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@....ooooox. .oxx@@@@@xxoo........
.ooooxxxxxxxooooooxooooooooooooooxo...oooooxx. ..ox@xxxoo.........
.ooooooxxxx@xoooooooooooooxxoooooooooooxxxxx. .oxxooooooooxxo.
.oooooxxxxx@@@xxxxxxxxxxxxxxxxxxxxxxxxoxxxxo. .oxxxxxxxxo.
....oooxxxxx@@@xo..oxxx@@@@@@xxxxoxxoooooooxx. .oxxxoo..
.....ooxxxx@@xo. ........ .ooooooooxxo
..oooxxxx@@@o .oooooooxoo.
....oxooxxxxx. .ooo..oooo.
.....o.ooxxxxxo. .oooooooxo.
......ooooxxxxxxo. .ooooooxoo..
........ooxxxxxxxo.. .o....oxoo...
.......ooooxxxxxxxo. ........oooo.
.ooooooo..ooxxxxoooo. .........ooo...
..oxo...ooooxxxoooo.. .ooo......oooo...
.ooooo....o. .oxxxoo....ooo....
.oooooo... ...ooooo...ooo..
... .oo.......
....ooo...
__ __
______ [ | [ | ._____ _ _
|_ _ \ | | _ | | / ___ \| | | |
| |_) | .---. _. _.| | / | .---. | | .---. _ _ / / \_|\ \ /\ / /
| __'./ /__\\[ /`\_| '' < / /__\\ | |/ /__\\| \ | | | _____ \ \/ \/ /
_| |__| | \__. | | | |`\ \ | \___. | || \___. \ \/ / \ \.___| | \ /\ /
|_______/ \.__./[_] [__| \_] \.__./[___]\.__./ \ / \.____./ \/ \/
/ /
/_/

************************ Building COMPLEX flavor ************************

make[2]: Leaving directory '/home/jonl/Downloads/BerkeleyGW-1.2.0'
make[2]: Entering directory '/home/jonl/Downloads/BerkeleyGW-1.2.0'
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/nrtype.f90 > Common/nrtype.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/nrtype.p.f -o Common/nrtype.o -module Common/
# 1 "Common/nrtype.p.f"
!>================================================================================
!!
!! Modules:
!!
!! (1) nrtype_m Originally By ? Last Modified 8/22/2010 (gsm)
!!
!! Global constants and parameters.
!!
!!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/nrtype.f90" 2

module nrtype_m

implicit none

public ! only public parameters here

! Below are the version number for each BerkeleyGW file. These numbers should
! be changed whenever the structure of the file is altered and there`s either
! incompatibility with the previous version or a new feature. The version
! should be -1 if that file is not versioned yet, which corresponds to
! the formats used in the Berkeley 1.0.x family.
integer, parameter :: VER_WFN_FORT = -1
integer, parameter :: VER_WFN_HDF5 = 1
integer, parameter :: VER_WFN = VER_WFN_FORT
integer, parameter :: VER_EPS_FORT = -1
integer, parameter :: VER_EPS_HDF5 = 3
integer, parameter :: VER_EPS = VER_EPS_FORT
integer, parameter :: VER_BSE_FORT = 1
integer, parameter :: VER_BSE_HDF5 = 2
integer, parameter :: VER_BSE = VER_BSE_FORT

!> Maximum number of bands supported by the *inread* routines. This sets the
!! size of arrays such as "occupations". These arrays should all be allocated
!! dynamically in the future.
integer, parameter :: MAX_BANDS = 1000000 ! "occupations" array => 7MB
!> Maximum number of {k,q}-points supported by the *inread* routines.
!! The actual number of k-points/q-points in the WFN/bsemat/epsmat files
!! can be larger.
integer, parameter :: MAX_KPTS = 100000 ! "kpt_read" array => 0.8 MB

!> parameters for real-space resolution in cell-truncation schemes
integer, parameter :: n_in_box = 2
integer, parameter :: n_in_wire = 4

!> parameter for construction of Wigner-Seitz cell
integer, parameter :: ncell = 3

!> number of Monte-Carlo integration points
integer, parameter :: nmc_coarse = 250000
integer, parameter :: nmc_fine = 2500000
integer, parameter :: nmc = nmc_fine

!> type definitions following the convention of Numerical Recipes
!! do not ever use single-precision!!
! integer, parameter :: SP = kind(1.0)
integer, parameter :: DP = kind(1.0d0)
! integer, parameter :: SPC = kind((1.0,1.0))
integer, parameter :: DPC = kind((1.0d0,1.0d0))

!> a shift on the grid in order to avoid the singularity for truncation
real(DP), parameter :: trunc_shift(3) = (/0.5d0, 0.5d0, 0.5d0/)

!> physical constants
!!
!! These are the "2010 CODATA recommended values" taken from
!! "The NIST Reference on Constants, Units, and Uncertainty"
!! http://physics.nist.gov/cuu/
!!
!! The following variables are used throughout the package:
!! 'BOHR', 'bohr' is Bohr radius, in Angstrom
!! 'RYD', 'ryd2eV', 'rydberg' is Rydberg constant times hc, in eV
!! 'HARTREE', 'hartree' is Hartree energy, in eV
!! 'LIGHTSPEED' is inverse alpha (fine-structure constant)
!!
!! These variables are defined in the following files:
!! Common/nrtype.f90
!! Common/svninfo.f90
!! Common/wfn_utils.cpp
!! MeanField/EPM/ff2vq.py
!! MeanField/EPM/sysParams.f90
!! MeanField/EPM/vca.py
!! MeanField/ICM/icm.cpp
!! Visual/common.py
!!
real(DP), parameter :: BOHR = 0.52917721092_dp
real(DP), parameter :: RYD = 13.60569253_dp
real(DP), parameter :: LIGHTSPEED = 137.035999074_dp

!> mathematical constants
!! real(SP), parameter :: PI_S = 3.1415926535897932384626433832795_sp
real(DP), parameter :: PI_D = 3.1415926535897932384626433832795_dp
real(DP), parameter :: TOL_Small = 1.0d-6
real(DP), parameter :: TOL_Zero = 1.0d-12
real(DP), parameter :: TOL_Degeneracy = 1.0d-6
real(DP), parameter :: INF = 1.0d12

!> Do direct diagonalization for BSE
integer, parameter :: BSE_ALGO_DIAG = 1
!> Solve BSE with Lanczos alg. by M. Shao and C. Yang.
integer, parameter :: BSE_ALGO_LANCZOS = 2
!> Solve BSE with Haydock scheme. Only works with TDA.
integer, parameter :: BSE_ALGO_HAYDOCK = 3

end module nrtype_m

icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/intrinsics.f90 > Common/intrinsics.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/intrinsics.p.f -o Common/intrinsics.o -module Common/
# 1 "Common/intrinsics.p.f"
!================================================================================
!
! Modules:
!
! (1) intrinsics_m Originally By DAS Created 9/21/2011
!
! Some compiler-dependent module usages and external definitions,
! regarding accessing system calls. There is no actual code here.
! These are preprocessor symbols defined in f_defs.h.
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 14 "Common/Common/intrinsics.f90" 2

module intrinsics_m

use ifport, only : hostnam
use omp_lib

implicit none

public

! note: these are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

interface; integer function iargc(); end function iargc
end interface

interface; integer function ftell(unit); integer, intent(in) :: unit; end function ftell
end interface

end module intrinsics_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/peinfo.f90 > Common/peinfo.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/peinfo.p.f -o Common/peinfo.o -module Common/
# 1 "Common/peinfo.p.f"
!================================================================================
!
! Modules:
!
! (1) peinfo_m Originally by DAS 8/20/2010
!
! Defines type and global instance of object for "processor equivalent" info.
! Use mpi module to define interfaces for MPI calls.
! [For F77, MPI header 'mpif.h' was included.]
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 14 "Common/Common/peinfo.f90" 2

module peinfo_m

use nrtype_m
use intrinsics_m
implicit none

! default must not be private, or else the types defined in mpi module will not be available.

public :: &
peinfo, &
peinfo_init, &
create_mpi_group

!-------------------------------

type peinfo
!> default values for serial
integer :: npes = 1
integer :: npes_freqgrp = 1
integer :: nthreads = 1
integer :: inode = 0
!> Verbosity level, not to be used directly. Use the verbosity flags instead.
integer :: verbosity=1
logical :: verb_medium=.false.
logical :: verb_high=.false.
logical :: verb_log=.false.
logical :: verb_debug=.false.
logical :: verb_max=.false.
!> initialize to zero, then keep track of memory
real(DP) :: mymem = 0d0
real(DP) :: mymaxmem = 0d0
integer :: nckmem
integer :: nkpe !< number of k-points per processor, used in absorption only
!> kernel: total number of block-transitions ( nk^2, (nk*nc)^2 or (nk*nc*nv)^2)
!! Each block-transition has iholdperown
integer :: nck
!> kernel: number of block-transitions that I own
integer :: nckpe
integer :: myown !< Kernel: number of unique (k,kp) pairs I own; BSE: number of blocks I own
integer :: mypown !< in BSE, number of unprimed indices I own for all my blocks
integer :: npown !< in BSE, max number of unprimed indices owned by any proc in my pool
integer :: jobtypeeval
!> BSE: number of blocks I own in the one-dimentional block-cyclic distributed
!! matrices hmtx_a/evecs_r.
integer :: nblocks
!> BSE: size of each block in the one-dimentional block-cyclic distributed
!! matrices hmtx_a/evecs_r = ns*nc_block*nv_block, which varies according to ipar.
integer :: block_sz
!> kernel: (nv,nc,nk,nv,nc,nk) offset in the bse_matrix for the
!! block-transition identified by (ivp,icp,ikp,iv,ic,ik)
integer, pointer :: wown(:,:,:,:,:,:)
integer, pointer :: ciown(:)
integer, pointer :: ik(:,:) !< (inode,j) index of jth k owned by inode
integer, pointer :: ic(:,:) !< (inode,j) index of jth cband owned by inode
integer, pointer :: iv(:,:) !< (inode,j) index of jth vband owned by inode
integer, pointer :: ikp(:,:) !< (inode,j) index of jth kp owned by inode
integer, pointer :: icp(:,:) !< (inode,j) index of jth cpband owned by inode
integer, pointer :: ivp(:,:) !< (inode,j) index of jth vpband owned by inode
integer, pointer :: ib(:,:)
integer, pointer :: ick(:,:)
integer, pointer :: ipe(:)
!> (inode,iv,ik) Maps the global index for valence band (iv) at kpt (ik) to
!! the local list of valence band the proc owns. (ik) is defined in the
!! reducible wedge. ipec is 0 if the proc doesn`t own that band/kpt
integer, pointer :: ipec(:,:,:)
integer, pointer :: ipev(:,:,:) !< See ipec
integer, pointer :: ipek(:,:) !< Same as ipec, but w/o band index
integer, pointer :: ipekq(:,:) !< Local index of valence band k-points only used
!< for finite momemtnum calculations
integer, pointer :: ipecb(:,:)
integer, pointer :: ivckpe(:)
!> (npes) Number of k-points in the full fine grid that each processors owns.
!! This parallelization is only used for the WFN interpolation in BSE, and
!! it has nothing to do with the ikt array used in the hbse_a matrix.
integer, pointer :: ikt(:)
!> (npes) Number of block-columns of the hbse_a matrix each processors owns.
!! Used in BSE only. The size of each block is block_sz.
integer, pointer :: ibt(:)
!> (nblocks) ikb(ib) is the k-point associated to the ib-th block of the
!! distributed BSE Hamiltonian that I own.
integer, pointer :: ikb(:)
!> (nblocks) icb(ib) is the cond band associated to the ib-th block of the
!! distributed BSE Hamiltonian that I own. Used only if ipar==2 or ipar==3.
integer, pointer :: icb(:)
!> (nblocks) ivb(ib) is the val band associated to the ib-th block of the
!! distributed BSE Hamiltonian that I own. Used only if ipar==3.
integer, pointer :: ivb(:)
!> Number of cond bands in each block of the distributed BSE Hamiltonian.
!! This is xct%ncb_fi for ipar<2, and 1 for ipar>=2
integer :: nc_block
!> Number of val bands in each block of the distributed BSE Hamiltonian.
!! This is xct%nvb_fi for ipar<3, and 1 for ipar>=3
integer :: nv_block
integer, pointer :: neig(:)
integer, pointer :: peig(:,:)
integer :: npools !< number of pools for the valence bands in Epsilon or outer bands in sigma
integer :: npes_pool !< number of processors per pool
integer :: pool_group !< mpi_group for pools
integer :: pool_comm !< mpi_comm for pools
integer :: pool_rank !< rank within pool
integer :: my_pool !< what pool this processor is in
integer :: nvownmax !< max. number of valence bands that I can own
integer :: ncownmax !< max. number of conduction bands that I can own
integer :: nvownactual !< (total) number of valence bands that I *really* own
integer :: ncownactual !< (total) number of conduction bands that I *really* own
!> Who owns a particular pair of bands (v,c)?
integer, pointer :: global_pairowner(:,:)
!> (total) number of valence bands that a particular MPI process owns
integer, pointer :: global_nvown(:)
!> (total) number of conduction bands that a particular MPI process owns
integer, pointer :: global_ncown(:)
!> indexv(i) is the local index (in terms of bands that I own) of the ith
!! (global) valence band. It is zero if I don`t own valence band #i.
integer, pointer :: indexv(:)
integer, pointer :: global_indexv(:,:) !< local indices for all processes
integer, pointer :: indexc(:) !< see indexv
!> Given a local band #i that I own, invindexv(i) is the global index of
!! that band. If i>nvownt, the result is zero.
integer, pointer :: invindexv(:)
integer, pointer :: invindexc(:) !< see invindexv
logical, pointer :: doiownv(:) !< do I own a particular valence band?
logical, pointer :: doiownc(:) !< do I own a particular conduction band?
logical, pointer :: does_it_ownc(:,:) !< (band,node) does a particular node own a cond. band?
logical, pointer :: does_it_ownv(:,:) !< (band,node) does a particular node own a val. band?
integer, pointer :: iownwfv(:) !< number of val. WFNs each proc. owns
integer, pointer :: iownwfc(:) !< number of cond WFNs each proc. owns
integer, pointer :: iownwfk(:) !< number of distinct k-points each proc. (partially) owns
integer, pointer :: iownwfkq(:) !< Same as iownwfk, but refers to k+Q point when using finite momentum Q
integer, pointer :: nxqown(:)
integer, pointer :: nxqi(:)
integer :: ndiag_max
integer :: noffdiag_max
integer :: ntband_max
integer :: ntband_node
integer :: nvband_node
integer, pointer :: indext(:)
integer, pointer :: ntband_dist(:)
integer, pointer :: indext_dist(:,:)
integer, pointer :: index_diag(:)
logical, pointer :: flag_diag(:)
integer, pointer :: index_offdiag(:)
logical, pointer :: flag_offdiag(:)
!> Parallel frequencies mpi group variables
!! igroup = your group number
!! rank = your processor number in your group
!! _f = frequency evaluation group
!! _mtxel = matrix element communication group
integer :: igroup_f
integer :: rank_f
integer :: igroup_mtxel
integer :: rank_mtxel
integer :: mtxel_comm !< mtxel group communicator
integer :: freq_comm !< frequency group communicator
integer :: npes_orig !< original number of processors
!! for when nfreq_group does not
!! divide total number of procs
integer :: mtxel_group !< mtxel group handle
integer :: freq_group !< frequency group handle
integer, pointer :: ranks(:) !< ranks of processors to include in mpi group
logical :: check_norms=.true. !< Whether to check norms, .true. unless doing pseudobands
end type peinfo

type(peinfo), save, public :: peinf

contains

!> FHJ: Set verbosity flags, such as peinf%verb_medium, based on peinf%verbosity.
!! Note that verbosity flags are cumulative.
subroutine peinfo_set_verbosity()
character(len=8) :: verb_str(6)
! cannot use push_pop because that module uses this one

if (peinf%verbosity<1) peinf%verbosity = 1
if (peinf%verbosity>6) peinf%verbosity = 6
if (peinf%verbosity>=2) peinf%verb_medium = .true.
if (peinf%verbosity>=3) peinf%verb_high = .true.
if (peinf%verbosity>=4) peinf%verb_log = .true.
if (peinf%verbosity>=5) peinf%verb_debug = .true.
if (peinf%verbosity>=6) peinf%verb_max = .true.
# 211
if (peinf%inode==0) then
verb_str(1) = "default"
verb_str(2) = "medium"
verb_str(3) = "high"
verb_str(4) = "log"
verb_str(5) = "debug"
verb_str(6) = "max"
write(6,'(1x,a,i0,3a/)') 'Running with verbosity level ', &
peinf%verbosity,' (', trim(verb_str(peinf%verbosity)), ').'
if (peinf%verbosity>3) then
write(0,'(/a)') 'WARNING: you are running the calculation with a high level of verbosity.'
write(0,'(a/)') 'This will impact the performance of the code.'
endif
endif

end subroutine peinfo_set_verbosity

subroutine peinfo_init()
! cannot use push_pop because that module uses this one

# 241

# 251

! if serial, default values set in type peinfo above are left alone

return
end subroutine peinfo_init

subroutine create_mpi_group(orig_group,group_size,ranks,group_handle,group_comm)
integer, intent(in) :: orig_group !< Handle for original MPI group, which you are breaking into smaller groups
integer,intent(in) :: group_size !< number of processors in new mpi group
integer,intent(in) :: ranks(:) !< (group_size) array specifying ranks of processors to include in MPI group
integer,intent(out) :: group_handle !< handle for new MPI group
integer,intent(out) :: group_comm !< communicator for new MPI group

# 272
group_handle = -1
group_comm = -1

return
end subroutine create_mpi_group

end module peinfo_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/message.f90 > Common/message.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/message.p.f -o Common/message.o -module Common/
# 1 "Common/message.p.f"
!===================================================================
!
! Modules:
!
! 1. message_m Originally By DAS
!
! die routine "gracefully" kills the computation.
! alloc_check writes warnings and errors for memory allocation problems.
! write_memory_usage provides a memory report at the end of a run.
! open_file opens a file unit, and writes an error if it does not work.
!
!===================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 15 "Common/Common/message.f90" 2

module message_m

use nrtype_m
use peinfo_m

implicit none

private

public :: &
die, &
alloc_check, &
write_memory_usage, &
open_file, &
close_file, &
TRUNC, &
operator(+)

!> these names are as short as practical to avoid lines being too long
integer, public :: alc !< allocation status for safe(de)allocate
integer*8, public :: sz !< size returned from sizeof for safe(de)allocate
!> set to .true. to print array size in bytes, .false. in KB/MB/GB
logical, parameter :: reportsizeexact = .false.

interface operator (+)
module procedure cat
end interface operator (+)

contains

!> remove trailing and leading whitespace from a string
function TRUNC(s)
character(len=*), intent(in) :: s
character(len=len_trim(adjustl(s))) :: TRUNC

TRUNC = trim(adjustl(s))
end function TRUNC

!-----------------------------------------------------------

!> concatenate two strings
function cat(str1, str2)
character(len=*), intent(in) :: str1
character(len=*), intent(in) :: str2

character(len=len(str1) + len(str2)) :: cat
cat = str1//str2

end function cat

!-----------------------------------------------------------

subroutine die(str, only_root_writes)
character (len=*), intent(in) :: str
logical, optional, intent(in) :: only_root_writes

logical :: should_write, should_write_prefix, is_open

should_write = .true.
should_write_prefix = peinf%npes > 1
if(present(only_root_writes)) then
if(only_root_writes) then
should_write = peinf%inode == 0
should_write_prefix = .false.
endif
endif

! There is no good reason why unit 6 would not be open, but ifort 11 -O3 will crash on flush(6)
! with the message "forrtl: severe (707): FLUSH: Unit 6 is not connected", but inclusion of just
! the inquire line is sufficient to avoid the incorrect optimization of this routine. And if we
! are going to inquire, we may as well use the result to decide whether to flush.
inquire(unit = 6, opened = is_open)
if(is_open) then
flush(6)
endif
! FHJ: FLUSH is not really reliable because the OS might cache the stdout.
! Sleeping for 1s is the best solution I found to make the output clean,
! otherwise the error message would show up before regular output.
call sleep(1)
! FHJ: if we are not writing, wait 60s for the root node to get here and
! write the error message. If the root doesn`t get here, we all print the
! error messsage anyways and die.
if (.not.should_write) then
call sleep(60)
endif
write(0,*)
if(should_write_prefix) write(0, '(a, i6, a)', advance='no') "From proc ", peinf%inode, ": "
write(0, '(2a)') "ERROR: ", TRUNC(str)
write(0,*)
flush(0)

! skip MPI calls if we are running in serial, this is needed
! for calling check_FFT_size from MeanField/EPM/epm2bgw and MeanField/Utilities/wfnreduce
if (peinf%npes .gt. 1) then

endif
! return an error code so the system knows this run has failed
! unfortunately, not all compilers will actually give this error code back to the OS
stop 999

return
end subroutine die

!---------------------------------------------------------------------------------------------------
subroutine alloc_check(status, size, name, file, line, flag)
integer, intent(in) :: status
!> on some platforms there is a different return value for sizeof if build is 64-bit
integer*8, intent(in) :: size
character(len=*), intent(in) :: name
character(len=*), intent(in) :: file
integer, intent(in) :: line
logical, intent(in) :: flag

real(DP) :: sizekb,sizemb,sizegb
character(len=16) :: prefix
character(len=32) :: sizestr

sizekb = dble(size) / dble(1024)
sizemb = sizekb / dble(1024)
sizegb = sizemb / dble(1024)
if (sizekb.le.1.0d1.or.reportsizeexact) then
write(sizestr,'(i20,1x,"bytes")')size
elseif (sizemb.le.1.0d1) then
write(sizestr,'(f20.3,1x,"KB")')sizekb
elseif (sizegb.le.1.0d1) then
write(sizestr,'(f20.3,1x,"MB")')sizemb
else
write(sizestr,'(f20.3,1x,"GB")')sizegb
endif

if (flag) then
prefix = "Allocation"
peinf%mymem = peinf%mymem + size
peinf%mymaxmem = max(peinf%mymaxmem, peinf%mymem)
else
prefix = "Deallocation"
peinf%mymem = peinf%mymem - size
endif

if (peinf%verb_debug .and. sizemb>100 .and. peinf%inode==0) then
write(0,347) trim(prefix), trim(name), TRUNC(sizestr), &
trim(file), line
endif

if(size .lt. 0 .and. peinf%inode .eq. 0) then
write(0,345) trim(prefix), trim(name), TRUNC(sizestr), &
trim(file), line
endif

if(status .eq. 0) return

write(0,346) trim(prefix), trim(name), peinf%inode, &
trim(file), line
write(0,348) status, TRUNC(sizestr)
flush(0)

call die('Allocation failure.')

345 format(1x,"WARNING:",1x,a,1x,"of array",1x,a,1x, &
"of size",1x,a,/,3x,"in file",1x,a,1x,"at line",i5, &
1x,"may fail.",/)
346 format(1x,"ERROR:",1x,a,1x,"of array",1x,a,1x, &
"on processor",i5,/,3x,"in file",1x,a,1x, &
"at line",i5,1x,"failed.")
347 format(1x,"NOTICE:",1x,a,1x,"of array",1x,a,1x, &
"of size",1x,a,/,3x,"in file",1x,a,1x,"at line",i5, &
1x,"occurring.",/)
348 format(3x,"Allocation status =",i4,",",1x,"Array size =",1x,a)

end subroutine alloc_check

!---------------------------------------------------------------------------------------------------
subroutine write_memory_usage()

! the memory is not tracked if not in debug mode, so everything would just be zero
# 230

return
end subroutine write_memory_usage

!---------------------------------------------------------------------------------------------------
!> This is a wrapper to the Fortran 'open' statement, to provide clear error-handling.
!> arguments 'status', 'form', 'position' have the same meaning as for 'open'.
!> 'iostat', if provided, will make 'iostat' be passed to 'open', and return its value, rather
!> than writing a message, if there is an error (e.g. status='old' but file does not exist, or
!> status='new' but file does exist).
subroutine open_file(unit, file, status, form, position, iostat)
integer, intent(in) :: unit
character(len=*), intent(in) :: file
character(len=*), intent(in) :: status
character(len=*), optional, intent(in) :: form
character(len=*), optional, intent(in) :: position
integer, optional, intent(out) :: iostat

integer :: ierr, unit_other
character*80 :: form_, position_, name, unit_str, unit_other_str
character*200 :: string
logical :: is_open, does_exist

if(unit == 0) call die("You may not open unit 0, it is reserved for standard error.")
if(unit == 5) call die("You may not open unit 5, it is reserved for standard input.")
if(unit == 6) call die("You may not open unit 6, it is reserved for standard output.")
! Cray Fortran has its own reserved units: http://docs.cray.com/books/S-3695-35/html-S-3695-35/pdollsmg.html
if(unit == 100) call die("You may not open unit 100, it is reserved for standard input (crayftn).")
if(unit == 101) call die("You may not open unit 101, it is reserved for standard output (crayftn).")
if(unit == 102) call die("You may not open unit 102, it is reserved for standard error (crayftn).")

! these issues would be caught below too, but we can give more helpful messages than just an error code
inquire(unit = unit, opened = is_open, name = name)
if(is_open) then
write(string,'(3a,i6,3a)') "Cannot open file '", TRUNC(file), "' on unit ", unit, &
": unit already open for file '", TRUNC(name), "'."
call die(string)
endif

if((trim(status) == 'old' .or. trim(status) == 'OLD') .and. .not. present(iostat)) then
inquire(file = TRUNC(file), exist = does_exist, opened = is_open, number = unit_other)
if(.not. does_exist) call die("Cannot open file '" // TRUNC(file) // "' for reading: does not exist.")
if(is_open) then
write(unit_str,*) unit
write(unit_other_str,*) unit_other
call die("Cannot open file '" // TRUNC(file) // "' for reading on unit " // TRUNC(unit_str) &
// ": already opened on unit " // TRUNC(unit_other_str) // ".")
endif

! From the Fortran 95 standard, Section 9.3.4:
!
! If a file is already connected to a unit, execution of an OPEN
! statement on that file and a different unit is not permitted.
!
! From the Fortran 77 Standard, Section 12.3.2:
!
! A unit must not be connected to more than one file at the same time,
! and a file must not be connected to more than one unit at the same time.

endif

if((trim(status) == 'new' .or. trim(status) == 'NEW') .and. .not. present(iostat)) then
inquire(file = TRUNC(file), exist = does_exist)
if(does_exist) call die("Cannot open file '" // TRUNC(file) // "' for writing as 'new': already exists.")
endif

form_ = 'formatted'
if(present(form )) form_ = form
position_ = 'asis'
if(present(position)) position_ = position

! passing the optionals to 'open' if not given to this routine does not work!
open(unit=unit, file = TRUNC(file), form=trim(form_), position=trim(position_), status=trim(status), iostat=ierr)
if(present(iostat)) then
iostat = ierr
else if(ierr /= 0) then
write(string,'(5a,i4)') "Failed to open file '", TRUNC(file), "' as status ", trim(status), " with error ", ierr
call die(string)
endif

return
end subroutine open_file

!---------------------------------------------------------------------------------------------------
subroutine close_file(unit, delete)
integer, intent(in) :: unit
logical, optional, intent(in) :: delete

character*80 :: string, status
logical :: is_open
integer :: ierr

if(unit == 0) call die("You may not close unit 0, it is reserved for standard error.")
if(unit == 5) call die("You may not close unit 5, it is reserved for standard input.")
if(unit == 6) call die("You may not close unit 6, it is reserved for standard output.")
! Cray Fortran has its own reserved units: http://docs.cray.com/books/S-3695-35/html-S-3695-35/pdollsmg.html
if(unit == 100) call die("You may not close unit 100, it is reserved for standard input (crayftn).")
if(unit == 101) call die("You may not close unit 101, it is reserved for standard output (crayftn).")
if(unit == 102) call die("You may not close unit 102, it is reserved for standard error (crayftn).")

! these issues would be caught below too, but we can give more helpful messages than just an error code
inquire(unit = unit, opened = is_open, iostat = ierr)
if(ierr /= 0) then
write(string,'(a,i6,a,i4)') "inquire in close_file failed for unit ", unit, " with error ", ierr
call die(string)
endif
if(.not. is_open) then
write(string,'(a,i6,a)') "Cannot close unit ", unit, ": not open."
call die(string)
endif

status = 'keep'
if(present(delete)) then
if(delete) status = 'delete'
endif

close(unit=unit, status=trim(status), iostat=ierr)
if(ierr /= 0) then
write(string,'(a,i6,a,i4)') "Failed to close unit ", unit, " with error ", ierr
call die(string)
endif

return
end subroutine close_file

end module message_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/push_pop.f90 > Common/push_pop.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/push_pop.p.f -o Common/push_pop.o -module Common/
# 1 "Common/push_pop.p.f"
!==========================================================================
!
! Module push_pop_m Originally By DAS
!
! Create a stack trace of routines entered and exited, for debugging.
! This only takes effect if the code is compiled with -DDEBUG.
! Enable by setting 'debug_level' below, and recompile:
! 0: no debugging trace
! 1: only node 0 writes trace
! 2: all nodes write trace. Very slow.
! Inspired by Octopus messages.F90 (originally revision 6920)
!
!==========================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 16 "Common/Common/push_pop.f90" 2

module push_pop_m

use message_m
use nrtype_m
use peinfo_m

implicit none

# 209

end module push_pop_m

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/scalapack_aux.f90 > Common/scalapack_aux.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/scalapack_aux.p.f -o Common/scalapack_aux.o -module Common/
# 1 "Common/scalapack_aux.p.f"
!================================================================================
!
! Modules:
!
! (1) scalapack_aux_m Originally by FHJ 07/24/2015
!
! Defines functions associated to matrix distributions. These functions
! were copied from netlib ScaLAPACK (BSD-licensed), and are included here
! as they can be used on builds with and without ScaLAPACK. None of these
! functions require ScaLAPACK.
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 15 "Common/Common/scalapack_aux.f90" 2

module scalapack_aux_m

implicit none

private

public :: &
numroc, &
indxl2g, &
indxg2l, &
indxg2p

contains

! -- ScaLAPACK tools routine (version 1.7) --

INTEGER FUNCTION NUMROC( N, NB, IPROC, ISRCPROC, NPROCS )
integer, intent(in) :: N, NB, IPROC, ISRCPROC, NPROCS

integer :: EXTRABLKS, MYDIST, NBLOCKS
MYDIST = MOD( NPROCS+IPROC-ISRCPROC, NPROCS )
NBLOCKS = N / NB
NUMROC = (NBLOCKS/NPROCS) * NB
EXTRABLKS = MOD( NBLOCKS, NPROCS )
IF( MYDIST.LT.EXTRABLKS ) THEN
NUMROC = NUMROC + NB
ELSE IF( MYDIST.EQ.EXTRABLKS ) THEN
NUMROC = NUMROC + MOD( N, NB )
END IF

END FUNCTION NUMROC

INTEGER FUNCTION INDXL2G( INDXLOC, NB, IPROC, ISRCPROC, NPROCS )
integer, intent(in) :: INDXLOC, IPROC, ISRCPROC, NB, NPROCS

INDXL2G = NPROCS*NB*((INDXLOC-1)/NB) + MOD(INDXLOC-1,NB) + &
MOD(NPROCS+IPROC-ISRCPROC, NPROCS)*NB + 1

END FUNCTION INDXL2G

INTEGER FUNCTION INDXG2L( INDXGLOB, NB, IPROC, ISRCPROC, NPROCS )
integer, intent(in) :: INDXGLOB, IPROC, ISRCPROC, NB, NPROCS

INDXG2L = NB*((INDXGLOB-1)/(NB*NPROCS))+MOD(INDXGLOB-1,NB)+1

END FUNCTION INDXG2L

INTEGER FUNCTION INDXG2P( INDXGLOB, NB, IPROC, ISRCPROC, NPROCS )
integer, intent(in) :: INDXGLOB, IPROC, ISRCPROC, NB, NPROCS

INDXG2P = MOD( ISRCPROC + (INDXGLOB - 1) / NB, NPROCS )

END FUNCTION INDXG2P

end module scalapack_aux_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/timing.f90 > Common/timing.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/timing.p.f -o Common/timing.o -module Common/
# 1 "Common/timing.p.f"
!========================================================================
!
! Routines:
!
! (1) date_time() Originally by ? Last Modified: 5/12/2008 (JRD)
!
! Gets current date and time.
!
! (2) timget() Originally by gsm Last Modified: 4/29/2010 (gsm)
!
! Gets current cpu and wall time.
!
! (3) timacc(n,option,tsec,nslices) Originally by ?
! Last Modified: 6/17/2009 (PWD)
!
! Timing subroutine. Calls machine-dependent subroutine timget
! which returns elapsed cpu and wall clock times in seconds
! Also return the number of times the counter has been called
!
! Depending on value of "option" routine will:
! (0) zero all accumulators
! (1) start with new incremental time slice for accumulator n
! also increase by one the counter for this accumulator
! (2) stop time slice; add time to accumlator n
! (3) report accumulated time for accumulator n
! and number of time that the routine has been called
! (4) report time slice for accumulator n (not full time accumulated)
!
! If, on first entry, subroutine is not being initialized, it
! will automatically initialize as well as rezero accumulator n.
! However, initialization SHOULD be done explicitly by the user
! so that it can be done near the top of his/her main routine.
!
! Input:
! n=index of accumulator (distinguish what is being timed); not used if option=0
! option=see comment above
! Output:
! on option=3:
! tottim(2,n)=accumulated time for accumulator n; otherwise
! tottim is a dummy variable.
! nslices is optional variable that give number of slices collected
!
! (4) logit() Originally By (SIB) Last Modified 6/12/2008 (JRD)
!
! Write out a debugging message with an inputed string and write time.
!
! (5) logitint() Originally By (SIB) Last Modified 6/12/2008 (JRD)
!
! Same as logit but with an integer constant.
!
!========================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 54 "Common/Common/timing.f90" 2

module timing_m

use intrinsics_m
use message_m
use nrtype_m
use peinfo_m
use push_pop_m

implicit none

private

public :: &
date_time, &
timget, &
timacc, &
logit, &
logitint

!> MTIM determines the maximum number of "timing slots" available
integer, parameter, private :: MTIM=100
real(DP), private, save :: acctim(2,MTIM),tzero(2,MTIM)
integer, private, save :: ncount(MTIM)

contains

subroutine date_time(bdate,btime)
character, intent(out) :: bdate*11,btime*14

integer :: lmonth
integer :: idate (8)
character :: day*2,year*4
character :: adate*8,atime*10,azone*5
character :: hour*2,min*2,sec*2
character*3 :: month(12)

DATA month/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', &
'Oct','Nov','Dec'/

call date_and_time(adate,atime,azone,idate)

read(adate,101) year,lmonth,day
101 format(a4,i2,a2)
write(bdate,102) day,month(lmonth),year
102 format(a2,'-',a3,'-',a4)
read(atime,201) hour,min,sec
201 format(a2,a2,a2,a4)
write(btime,202) hour,min,sec,azone
202 format(a2,':',a2,':',a2,1x,a5)

return
end subroutine date_time

!================================================================================

subroutine timget(cpu,wall)
real(DP), intent(out) :: cpu,wall

integer :: values(8)

! no push_sub, called too frequently

cpu=mclock()*1.0d-3

call date_and_time(VALUES=values)
wall=((values(3)*24.0d0+values(5))*60.0d0 &
+values(6))*60.0d0+values(7)+values(8)*1.0d-3

return
end subroutine timget

!================================================================================

subroutine timacc(n,option,tottim,nslices)
integer, intent(in) :: n !< not used for option = 0
integer, intent(in) :: option !< 0, 1, 2, 3, 4
real(DP), intent(out), optional :: tottim(2) !< should be present if option=3 or 4
integer, intent(out), optional :: nslices !< only used if option=3, still optional in that case

real(DP) :: cpu,wall
character*100 :: tmpstr

! no push_sub, called too frequently

! Check that n lies in sensible bounds

if (n .lt. 0 .or. n .gt. MTIM) then
write(tmpstr,'(a,i6,a,i8)') 'timacc: dim MTIM = ', MTIM,' but input n =', n
call die(tmpstr)
end if

if (option==0) then

! Zero out all accumulators of time and init timers

acctim(:,:)=0.0d0
tzero(:,:)=0.0d0
ncount(:)=0

else if (option==1) then

! Initialize timepw for n

call timget(cpu,wall)
tzero(1,n)=cpu
tzero(2,n)=wall

else if (option==2) then

! Accumulate time for n

call timget(cpu,wall)
acctim(1,n)=acctim(1,n)+cpu -tzero(1,n)
acctim(2,n)=acctim(2,n)+wall-tzero(2,n)
ncount(n)=ncount(n)+1

else if (option==3) then

! Return accumulated time for n

if(.not. present(tottim)) call die("timacc requires tottim for option 3.")

tottim(1)=acctim(1,n)
tottim(2)=acctim(2,n)
if(present(nslices)) then
nslices=ncount(n)
end if

else if (option==4) then

! Return elapsed time for n (do not accumulate)

if(.not. present(tottim)) call die("timacc requires tottim for option 4.")

call timget(cpu,wall)
tottim(1)=cpu-tzero(1,n)
tottim(2)=wall-tzero(2,n)

else

write(tmpstr,'(a,i10,a)') 'timacc: input option = ', option, 'not valid.'
call die(tmpstr)

end if

return
end subroutine timacc

!=====================================================================

subroutine logit(str, should_print, iunit)
character (len=*), intent(in) :: str
logical, intent(in), optional :: should_print
integer, intent(in), optional :: iunit

character*15 :: mydate,mytime,tmpstr
logical :: should_print_
integer :: iunit_

if (.not.peinf%verb_log) return

iunit_ = 6
if (present(iunit)) iunit_ = iunit
should_print_ = peinf%inode==0
if (present(should_print)) should_print_ = should_print

if (should_print_) then
call date_and_time(mydate,mytime)
tmpstr = mytime(1:2)//':'//mytime(3:4)//':'//mytime(5:6)//'.'//mytime(8:10)
mytime = tmpstr
write(iunit_,*) '*** LOG: ', TRUNC(str),' time = ', TRUNC(mytime)
endif

end subroutine logit

!=====================================================================

subroutine logitint(str,i)
character (len=*), intent(in) :: str
integer, intent(in) :: i

character*100 :: tmpstr

if (.not.peinf%verb_log) return
write(tmpstr,'(a,i5)') str(1:len_trim(str)),i
call logit(tmpstr)

end subroutine logitint

!=====================================================================

end module timing_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/typedefs.f90 > Common/typedefs.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/typedefs.p.f -o Common/typedefs.o -module Common/
# 1 "Common/typedefs.p.f"
!==========================================================================
!
! Modules:
!
! (1) typedefs Originally By GMR Last Modified 7/8/2008 (JRD)
!
!> Derived types that are used throughout the code.
!
!==========================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/typedefs.f90" 2

module typedefs_m

use nrtype_m

implicit none

public ! only types in this module

!---------------------------

type crystal
real(DP) :: celvol !< cell volume in real space (a.u.)
real(DP) :: recvol !< cell volume in reciprocal space (a.u.)
real(DP) :: alat !< lattice constant in real space (a.u.)
real(DP) :: blat !< lattice constant in reciprocal space (a.u.)
real(DP) :: avec(3,3) !< lattice vectors in real space (alat)
real(DP) :: bvec(3,3) !< lattice vectors in reciprocal space (blat)
real(DP) :: adot(3,3) !< metric tensor in real space (a.u.)
real(DP) :: bdot(3,3) !< metric tensor in reciprocal space (a.u.)
integer :: nat !< number of atoms
integer, pointer :: atyp(:) !< atomic species, atyp(1:nat)
real(DP), pointer :: apos(:,:) !< atomic positions, apos(1:3,1:nat) (alat)
end type crystal

!---------------------------

type kpoints
integer :: nspinor = 1 !< nspinor = 2 if doing two-component spinor calculation; 1 is default
integer :: nspin !< nspin = 1 or 2; nspin = 1 when npsinor = 2
integer :: nrk !< number of k-points
integer :: mnband !< max number of bands
integer :: nvband !< number of valence bands
integer :: ncband !< number of conduction bands
integer :: kgrid(3) !< Monkhorst-Pack number of k-points in each direction
real(DP) :: shift(3) !< Monkhorst-Pack shift of grid
real(DP) :: ecutwfc !< wave-function cutoff, in Ry
integer, pointer :: ngk(:) !< number of g-vectors for each k-point
integer :: ngkmax !< max(ngk(:))
integer, pointer :: ifmin(:,:) !< lowest occupied band (kpoint,spin)
integer, pointer :: ifmax(:,:) !< highest occupied band (kpoint,spin)
real(DP), pointer :: w(:) !< weights (kpoint) (between 0 and 1)
real(DP), pointer :: rk(:,:) !< k-vector (3, kpoint) in crystal coords
real(DP), pointer :: el(:,:,:) !< band energies (band, kpoint, spin)
real(DP), pointer :: elda(:,:,:) !< band energies before eqp correction
real(DP), pointer :: occ(:,:,:) !< occupations (between 0 and 1)
integer, pointer :: degeneracy(:,:,:) !< size of deg. subspace for (band, kpoint, spin)
end type kpoints

!---------------------------

type symmetry
integer :: ntran !< number of operations in full group
integer :: ntranq !< number of operations in small group of q
real(DP) :: rq(3) !< The q-point this ntranq belongs to
integer :: mtrx(3,3,48) !< symmetry matrix
real(DP) :: tnp(3,48) !< fractional translations
integer :: indsub(48) !< symmetry operations in subgroup of q
integer :: kgzero(3,48) !< Umklapp vectors for subgroup symmetry operations
integer :: cell_symmetry !< 0 = cubic, 1 = hexagonal
end type symmetry

!---------------------------

type grid
integer :: nr !< number in reduced zone
integer :: nf !< number in full zone
real(DP) :: sz !< radius of a spherical subzone equivalent to
!! one point in the set f
integer, pointer :: itran(:) !< sym op to go from irrbz to fullbz
integer, pointer :: indr(:) !< irrbz k/q-point mapped to fullbz
integer, pointer :: kg0(:,:) !< Umklapp vectors (for Wigner-Seitz cell)
real(DP), pointer :: r(:,:) !< k/q-points in reduced zone
real(DP), pointer :: f(:,:) !< k/q-points in full zone
end type grid

!-----------------------------------

type gspace
integer :: ng !< number of G-vectors
integer :: nFFTgridpts !< number in FFT grid = product(FFTgrid(1:3))
real(DP) :: ecutrho !< charge-density cutoff, in Ry
integer, pointer :: components(:,:) !< the G-vectors, in units of 2 pi / a
integer :: FFTgrid(3) !< gsm: FFTgrid is the size of the FFT grid, not the maximum G-vector
integer, pointer :: index_vec(:) ! mapping to FFT grid
real(DP), pointer :: ekin(:) !< kinetic energy of G-vectors
end type gspace

!---------------------------
!> Parameters for scissors operators
!> e_cor = e_in + es + edel * (e_in - e0)
!> es and e0 are in eV. edel is a dimensionless slope.
type sub_scissors_t
real(DP) :: es
real(DP) :: edel
real(DP) :: e0
end type sub_scissors_t

type scissors_t
type(sub_scissors_t) :: val
type(sub_scissors_t) :: cond
end type scissors_t

!---------------------------

type wavefunction
integer :: ng
integer :: nband
integer :: nspin
integer :: nspinor = 1 !< nspinor = 2 if doing two-component spinor calculation; 1 is default
integer, pointer :: isort(:)
complex(DPC), pointer :: cg(:,:,:)
end type wavefunction

!---------------------------

!> For Epsilon: this is the wavefunction before unfolding the irr. BZ.
!! For BSE: ??
type int_wavefunction
integer :: nspin
integer :: nspinor = 1 !< nspinor = 2 if doing two-component spinor calculation; 1 is default
integer, pointer :: ng(:) !< (nk)
integer, pointer :: isort(:,:) !< (ngmax, nk)
integer, pointer :: cbi(:)
!> I think this can be decommissioned if we use kp%rk instead
real(DP), pointer :: qk(:,:)
complex(DPC), pointer :: cg(:,:,:)
complex(DPC), pointer :: cgk(:,:,:,:)
end type int_wavefunction

!------------------------------------

!> FHJ: valence WFNs for 1 particular kpt and 1 band
!! It stores all bands in the case of real-space WFNs
type valence_wfns
integer :: nband !< This is indeed the number of valence bands
integer :: ncore_excl
!>This is the number of core states that are not included in the valence in polarizability calculation.
integer :: ngv !< Number of G-vectors
integer :: idx_kp !< Idx of current kpt in kp/kpq structure
integer, pointer :: isort(:)
!> (nband+ncrit,spin). Note: the nband+ncrit index is actually useless!
real(DP), pointer :: ev(:,:)
complex(DPC), pointer :: zv(:,:) !< (ngv,spin)
!> real-space wavefunction for all "local" val. bands (fft1,fft2,fft3,band)
complex(DPC), pointer :: wfn_fft(:,:,:,:)
end type valence_wfns

!-------------------------------

!> FHJ: conduction WFNs for 1 particular kpt and all bands (!) the processor owns
type conduction_wfns
integer :: nband !< This is actually the number of valence+conduction bands!
integer :: ngc !< Number of G-vectors
integer :: idx_kp !< Idx of current kpt in kp structure
integer, pointer :: isort(:)
real(DP), pointer :: ec(:,:) !< (nband,nspin)
complex(DPC), pointer :: zc(:,:) !< (ngc*ncownactual,spin)
!> real-space wavefunction for all "local" cond. bands (fft1,fft2,fft3,band)
complex(DPC), pointer :: wfn_fft(:,:,:,:)
end type conduction_wfns

!----------------------------

!> splines knots and coefficients
type spline_tck
integer :: n !< number of knots
integer :: k !< degree of spline (1=linear, etc.)
real(DP), pointer :: t(:) !< position of knots
real(DP), pointer :: c(:) !< splines coefficient
end type spline_tck

!-------------------------------------

type coulomb_modifier_t

real(DP) :: short_range_frac_fock !< Short range exchange fraction
real(DP) :: long_range_frac_fock !< Long range exchange fraction
real(DP) :: screening_length !< Screening length
!< The above 3 parameters are used
!< only for TDDFT and sigma calculations.

end type coulomb_modifier_t

!----------------------------

type siginfo
integer :: freq_dep !< frequency dependence of the inverse dielectric matrix
integer :: freq_dep_method !< frequency dependence method of the inverse dielectric matrix
integer :: nFreq !< number of frequencies used in full frequency calculation
real(DP) :: dDeltaFreq !< frequency increment (eV) for polarizability energy denominator
real(DP) :: dBrdning !< Lorentzian broadening (eV) for polarizability energy denominator
real(DP), pointer :: dFreqGrid(:) !< Grid of Frequencies for Full Frequency
complex(DPC), pointer :: dFreqBrd(:) !< Corresponding Broadenings for Full Frequency

integer :: nSFreq !< number of frequencies used in spectral functions
real(DP) :: dDeltaSFreq !< frequency increment (eV) for spectral functions
real(DP), pointer :: dSFreqGrid(:) !< Grid of Frequencies for spectral functions

integer :: exact_ch !< compute the exact static CH
integer :: fullConvLog !< logging CH convergence
integer :: iwritecoul !< flag to write vcoul
real(DP) :: tol !< energy tolerance for degeneracy
logical :: use_hdf5 !< with -DHDF5, whether or not we actually use hdf5
logical :: wfn_hdf5 !< with -DHDF5, use HDF5 for WFN files?
logical :: use_xdat !< use saved exchange matrix elements from file x.dat
logical :: use_vxcdat !< use saved exchange-correlation matrix elements from file vxc.dat
logical :: use_vxc2dat !< use saved exchange-correlation matrix elements from file vxc2.dat
integer :: nkn !< number of k-points on which to calculate Sigma (from sigma.inp)
integer :: nfreq_imag
logical :: need_advanced
integer :: cd_int_method !< Integration method for CD calculations
integer :: invalid_gpp_mode !< How to treat invalid GPP modes? See sigma.inp
integer :: nq0, nq1, nq !< Number of q->0 points, q/=0 points, and total number of q-points
logical :: subsample !< whether we perform a subsampling of the voronoi cell of q=0
real(DP), pointer :: subweights(:) !< (nq0) weight for each subsampling q-point
integer :: nvband !< number of bands in bare exchange
integer :: ntband !< number of bands in dynamical sigma summation
integer :: ncore_excl
!> number of core states that are not included in both the bare exchange and dynamical sigma summations
integer :: igamma !< nonzero if Gamma is the only q-point, 0 otherwise
integer :: nspin
integer :: spin_index(2)
integer :: icutv !< icutv encodes presence and type of truncation
integer :: iuseremainder
integer :: qgrid(3)
integer :: iscreen !< what type of screening is present. 0 = semiconductor, 1 = graphene, 2 = metal
integer :: fdf !< finite difference form for numerical derivative of Sigma
integer, pointer :: indkn(:) !< mapping of k-points from sigma.inp to those in kp%rk from WFN files
integer, pointer :: diag(:) !< energy bands for which Sigma diagonal matrix elements are calculated
integer :: ndiag !< number of bands contained in diag(:)
integer :: noffdiag !< offdiag
integer :: loff
integer :: toff
integer :: bmin
integer :: bmax
integer, pointer :: off1(:) !< offdiag
integer, pointer :: off3(:) !< offdiag energy at which to evaluate
integer, pointer :: offmap(:,:) !< sig%off1(ii) = sig%diag(sig%offmap(ii,1))
real(DP) :: dw !< finite difference spacing for numerical derivative of Sigma in eV
real(DP) :: ecutb !< energy cutoff of bare coulomb interaction in Ry
real(DP) :: ecuts !< energy cutoff of screened coulomb interaction in Ry
real(DP) :: xfrac !< fraction of bare exchange
real(DP) :: gamma !< GPP broadening
real(DP) :: sexcut !< GPP SX cutoff
real(DP) :: q0vec(3)
integer :: freq_grid_shift !< How to shift the requency grid. See sigma.inp for more info.
integer :: nfreqeval
real(DP) :: freqevalmin
real(DP) :: freqevalstep
logical :: eqp_corrections !< are we using eqp.dat
logical :: eqp_outer_corrections !< are we using eqp_outer.dat
type(scissors_t) :: scis
type(scissors_t) :: scis_outer
logical :: wfn_outer_present
type(spline_tck) :: spl_tck !< scissors b-spline coefficients
type(spline_tck) :: spl_tck_outer !< scissors b-spline coeffs for WFN_outer
real(DP) :: avgpot
real(DP) :: avgpot_outer
real(DP) :: truncval(3) !< in Bohr (au)
real(DP) :: avgcut !< Cut in which we do cell averages on
real(DP), pointer :: kpt(:,:)
real(DP), pointer :: qpt(:,:) !< (3,nq) q-points in eps0mat+epsmat files, or provided in sigma.inp
integer :: ncrit !< number of partially occupied bands
real(DP) :: efermi !< Fermi level
real(DP) :: efermi_input !< The value to set E_Fermi in the input file, in eV
logical :: rfermi !< Measure the new Fermi level relative to that of the neutral system
complex(DPC), pointer :: vxc(:,:) !< Vxc(G)
complex(DPC), pointer :: vxc2(:,:) !< Vxc(G) for hybrid functional type calculations
complex(DPC) :: wcoul0
logical :: freplacebz
logical :: fwritebz
logical :: degeneracy_check_override
logical :: offdiagsym
logical :: qgridsym
logical :: die_outside_sphere
logical :: averagew
type(coulomb_modifier_t) :: coulomb_mod
logical :: coul_mod_flag !< Flag which tells if the coulomb interaction has been
!! modified (for hybrid functional like calculation in sigma)
logical :: sigma_correction !< if .true., compute only a correction to the QP self energy, ie,
!! don`t subtract vxc and don`t compute the bare exchange.
end type siginfo

!---------------------------
!> Dielectric matrix info using comm_mpi
!! In BLACS terms, we distribute the columns of the epsinv matrix in a
!! 1D-block-cyclic fashion. Currently, the block size nb is 1
!! The following old quantities were removed, as they can be calculated on the fly:
!! epsmpi%igp_owner(igp) = INDXG2P(igp, epsmpi%nb, peinf%pool_rank, 0, peinf%npes_pool)
!! epsmpi%igp_index(igp) = INDXG2L(igp, epsmpi%nb, peinf%pool_rank, 0, peinf%npes_pool)
!! The following array should be removed soon:
!! epsmpi%inv_igp_index(igp_loc) = INDXL2G(igp_loc, epsmpi%nb, peinf%pool_rank, 0, peinf%npes_pool)
type epsmpiinfo
integer :: nb !< block size. Currently set to 1 (round robin)
integer :: ngpown !< number of columns I own. Same as numroc(neps, nb, pool_rank, 0, npes_pool)
integer :: ngpown_max !< number of columns owned by pool_rank==0.
integer, pointer :: isrtq(:,:) !< These 3 arrays have a dimension of (1:gvec%ng,1:(nq+1)) where
integer, pointer :: isrtqi(:,:) !! (nq+1) is the total # of q`s including q0.

integer, pointer :: inv_igp_index(:)
integer, pointer :: nmtx(:) !< dimension of eps(q) for each q
real(DP), pointer :: qk(:,:)
complex(DPC), pointer :: eps(:,:,:) !< eps(1:gvec%ng,1:ngpown,1:(nq+1))

!> dimension of epsR and epsA (1:gvec%ng,1:ngpown,1:sig%nFreq,1:(nq+1))
complex(DPC), pointer :: epsR(:,:,:,:)
complex(DPC), pointer :: epsA(:,:,:,:)
end type epsmpiinfo

!---------------------------

type wfnkqmpiinfo
integer, pointer :: nkptotal(:)
integer, pointer :: isort(:,:)
integer, pointer :: band_index(:,:)
real(DP), pointer :: qk(:,:)
real(DP), pointer :: el(:,:,:)
complex(DPC), pointer :: cg(:,:,:,:)
end type wfnkqmpiinfo

!---------------------------

type wfnkmpiinfo
integer, pointer :: nkptotal(:)
integer, pointer :: isort(:,:)
real(DP), pointer :: qk(:,:)
real(DP), pointer :: el(:,:,:)
real(DP), pointer :: elda(:,:,:)
complex(DPC), pointer :: cg(:,:,:)
end type wfnkmpiinfo

!---------------------------

type wpgen
real(DP) :: wpsq(2) !< square of free el plasma freq for each spin
real(DP) :: nelec(2) !< number of electrons for each spin per cell
complex(DPC), pointer :: rho(:,:) !< density, (ig, ispin)
end type wpgen

!---------------------------

type polarizability
integer :: freq_dep !< frequency dependence of the inverse dielectric matrix
! 0: static calculation 2: full frequency 3: two imaginary frequencies
integer :: freq_dep_method !< full frequency calculation. 0: Adler-Wiser; 1: Shishkin and Kresse 2006
integer :: nFreq !< number of frequencies used in full frequency calculation
integer :: nfreq_imag !< number of imaginary freqs for CD (also 1 for GN GPP)
real(DP) :: dInitFreq !< initial frequency (eV) for polarizability energy denominator
real(DP) :: dDeltaFreq !< frequency increment (eV) for polarizability energy denominator
real(DP) :: dBrdning !< Lorentzian broadening (eV) for polarizability energy denominator
real(DP), pointer :: dFreqGrid(:) !< Grid of Frequencies for Full Frequency
real(DP) :: dFreqStepIncrease
real(DP) :: dFreqCutoff1
real(DP) :: dFreqCutoff2

integer :: nSFreq !< number of frequencies used in spectral function
real(DP) :: dInitSFreq !< initial frequency (eV) for polarizability spectral function
real(DP) :: dDeltaSFreq !< frequency increment (eV) for polarizability spectral function
real(DP), pointer :: dSFreqGrid(:) !< Grid of Frequencies for spectral function
real(DP) :: dSFreqStepIncrease
real(DP) :: dSFreqCutoff1
real(DP) :: dSFreqCutoff2

logical :: has_advanced !< Do we store eps_A or just eps_R?
integer :: matrix_type !< 0 to write epsilon^{-1}, 1 for epsilon, 2 for chi0.
integer :: nmatrix !< has_advanced+1. Multiply by nspin if matrix_type==2
integer :: matrix_flavor !< 2 (=CMPLX), unless we have freq_dep==0 and 2==1.

type(scissors_t) :: scis
logical :: eqp_corrections !< are we using eqp.dat and eqp_q.dat files
complex(DPC), pointer :: dFreqBrd(:) !< Corresponding Broadenings for Full Frequency
integer :: fullConvLog !< logging pol matrix head & tail convergence
integer :: iwritecoul !< flag to write vcoul
integer :: nmtx
integer, pointer :: nmtx_of_q(:)
integer :: qgrid(3)
integer, pointer :: qflags(:)
integer :: nq0, nq1, nq !< Number of q->0 points, q/=0 points, and total number of q-points
logical :: subsample !< whether we have more than one q0 point (used in subsampled calculation)
logical :: non_uniform !< do non-uniform sampling using Voronoi decomposition of BZ
integer :: gcomm
logical :: min_fftgrid !< use the smallest possible fftbox
! FHJ: These flags control some experimental optimizations
integer :: os_opt_ffts !< optimizes calculation/reuse of FFTs (real-space WFNs)
integer :: nfreq_group !< num. of frequencies to calculate in parallel
integer :: nfreq_in_group !< num. of epsilon frequencies held by any processor
integer :: os_nsfreq_para !< num. of spectral frequencies held by any processor
logical :: os_hdf5 !< use parallel IO?
logical :: restart !< are we restarting the calculation? Only ok with HDF5
integer :: stop_after_qpt !< pretend the calculation was prematurely killed after this qpt (-1=don`t kill)
integer :: intraband_flag !< 0=regular calculation, 1=only include intraband, 2=only interband
real(DP) :: intraband_overlap_min !< a transition is intraband if || is larger than this
integer :: num_cond_bands_ignore !< num. of cond bands to ignore. default is 0.
logical :: patched_sampling !< Do we have only a patch in the BZ?
!
integer :: WFN_FFTgrid(3)!< max. size FFTgrid that holds all WFNs
integer :: FFTgrid(3) !< FFT grid to use (RHO or economical one)
!!
logical :: skip_epsilon
logical :: skip_chi
logical :: use_hdf5 !< with -DHDF5, whether or not we actually use hdf5
logical :: need_WFNq !< will we need the WFNq file? (nq0>0.and.valueq0==1.and.iqexactlyzero==0)
integer :: iqexactlyzero !< 1 if the q->0 point is *exactly* zero and will be read from WFN; 0 otherwise
integer :: valueq0 !< 1=semiconductor (read from WFNq); 2=metal (read from WFN)
integer, pointer :: irow(:)
integer, pointer :: isrtx(:)
integer, pointer :: isrtxi(:)
integer :: icutv !< icutv encodes presence and type of truncation
real(DP) :: truncval(3) !< in Bohr (au)
real(DP), pointer :: qpt(:,:)
!> FHJ: gme = , and the indices are:
!! (nmtx, ncownactual, nvownactual, nspin, nrk, nfreq_group)
complex(DPC), pointer :: gme(:,:,:,:,:,:)
complex(DPC), pointer :: chi(:,:,:)
integer :: ncrit
real(DP) :: efermi
real(DP) :: efermi_input
logical :: rfermi
real(DP) :: ecuts !< energy cutoff of screened coulomb interaction in Ry
real(DP) :: ecutsExtra
!> Reference regarding retarded/advanced functions: Catalin`s thesis, Eq. (1.44)
complex(DPC), pointer :: chiRDyn(:,:,:,:) !< Retarded polarizability
complex(DPC), pointer :: chiTDyn(:,:,:,:) !< Spectral function of polarizability

real(DP), pointer :: edenDyn(:,:,:,:,:) !< Dynamic energy denominator
logical :: freplacebz
logical :: fwritebz
logical :: degeneracy_check_override
real(DP) :: lin_denominator !< energy threshold below which to activate lin_denominator
type(cvpair_info), pointer :: lin_edenDyn(:,:,:,:,:) !< energies and
real(DP) :: de_min, de_max
! velocities for calculating linearized denominator in dynamic case
real(DP) :: imaginary_frequency !< purely imaginary frequency used in Godby-Needs GPP
end type polarizability

!--------------------------------

type cvpair_info
real(DP) :: vc(2) !< conduction band velocity
real(DP) :: vv(2) !< valence band velocity
real(DP) :: ec !< conduction band energy
real(DP) :: ev !< valence band energy
integer :: idx_kp !< kpoint index
logical :: vltc !< ev - ec < TOL_Degeneracy
end type cvpair_info

!--------------------------------

type wfnkstates
integer :: nkpt
integer :: ndv
integer, pointer :: isrtk(:)
real(DP) :: k(3)
real(DP), pointer :: ek(:,:)
real(DP), pointer :: elda(:,:)
complex(DPC), pointer :: zk(:,:)
end type wfnkstates

!---------------------------

type wfnkqstates
integer :: nkpt
integer, pointer :: isrtkq(:)
real(DP), pointer :: ekq(:,:)
complex(DPC), pointer :: zkq(:,:)
end type wfnkqstates

!---------------------------------

!> Used in haydock/diag only (see epsdiag.f90)
type epsinfo
integer :: nq !< number of q-vectors stored
real(DP) :: emax !< maximum length of the stored q-vectors
real(DP), pointer :: q(:,:) !< (3, nq) coordinates of q-vectors
real(DP), pointer :: eps(:) !< (nq) head of dielectric matrix at each q-vector
complex(DPC) :: epshead !< head of dielectric matrix at q->0
real(DP) :: q0vec(3) !< coordinates of the q->0 vector
end type epsinfo

!------------------------------------

!> Used in haydock/diag only
!! Note that the bands in eqpv/eqpc are indexed with respect to the Fermi
!! level, i.e., eqpv(1,:,:) is the VBM, eqpv(2,:,:) is VMB-1, etc.
type eqpinfo
type(scissors_t) :: scis
type(spline_tck) :: spl_tck !< scissors spline coefficients
real(DP), pointer :: evqp(:,:,:)
real(DP), pointer :: ecqp(:,:,:)
real(DP), pointer :: evqp_co(:,:,:)
real(DP), pointer :: ecqp_co(:,:,:)
real(DP), pointer :: evqp_co_q(:,:,:)
real(DP), pointer :: ecqp_co_q(:,:,:)
real(DP), pointer :: evlda(:,:,:)
real(DP), pointer :: eclda(:,:,:)
real(DP), pointer :: evlda_co(:,:,:)
real(DP), pointer :: eclda_co(:,:,:)
real(DP), pointer :: evlda_co_q(:,:,:)
real(DP), pointer :: eclda_co_q(:,:,:)
real(DP), pointer :: evshift(:,:,:)
real(DP), pointer :: ecshift(:,:,:)
real(DP), pointer :: evshift_co(:,:,:)
real(DP), pointer :: ecshift_co(:,:,:)
real(DP), pointer :: evshift_co_q(:,:,:)
real(DP), pointer :: ecshift_co_q(:,:,:)
end type eqpinfo

!------------------------------------

!> moments for Haydock
type mmtsinfo
integer :: nmax
integer :: nmaxp
real(DP) :: norm
real(DP) :: vol
real(DP), pointer :: an(:)
real(DP), pointer :: bn(:)
end type mmtsinfo

!------------------------------------

type xctinfo
logical :: is_absorption !< whether we are running the absorption code
integer :: algo !< algorithm to use to solve BSE. See Common/nrtype.f90
logical :: inteqp !< whether we are interpolating
logical :: is_periodic(3) !< which dimensions are periodic
integer :: idimensions !< how many total periodic dimensions
integer :: nkpt_co !< number of kpts in the coarse grid
integer :: nkptq_co !< number of kpts in the q-shifted coarse grid
integer :: nvb_co !< number of valence bands in the coarse grid
integer :: ncb_co !< number of conduction bands in the coarse grid
integer :: n1b_co !< nvb_co for TDA calculations, nvb_co + ncb_co for non-TDA
integer :: n2b_co !< ncb_co for TDA calculations, nvb_co + ncb_co for non-TDA
integer :: nspin
integer :: nspinor = 1 !< nspinor = 2 if doing two-component spinor calculation; 1 is default
integer :: qflag !< =0 for finite Q calculation with arbitrary Q (deprecated)
!< =1 for Q=0 calculation (default)
!< =2 use Q commensurate with WFN_co kgrid (under construction)
logical :: read_kpoints
integer :: ipar
integer :: iscreen !< what type of screening is present. 0 = semiconductor, 1 = graphene, 2 = metal
logical :: renorm_transf !< renormalize the dcc/dvv interpolation transformation?
!> Calculate kernel blocks other than (vc)->(v'c') transitions? This will
!! even include transitions such as (e,e)->(e',e'). In principle, we should
!! always include these blocks if we are interpolating later on, but they
!! are typically not important for semiconductors within TDA.
logical :: extended_kernel
!> If true, we extend the co/fi transf. to WFNs of different characters:
!! |v> = \sum_n` d_vn`|n`>, where |n`> can be |v`> or |c`>
!! If false, we restrict the character of the expansion coefficients:
!! |v> = \sum_v` d_vv`|v`>
logical :: unrestricted_transf
!> Zero out dvc/dcv coefficients
logical :: zero_unrestricted_contrib
logical :: patched_sampling !< simplest case of non-uniform sampling. See absorption.inp.
logical :: patched_sampling_co !< Use non-uniform sampling for coarse grid for Kernel. See absorption.inp.
integer :: zero_q0_element !< Zero q=0 matrix element of BSE Hamiltonian? See absorption.inp
logical :: tda !< use Tamm-Dancoff approximation? (Absorption only)
logical :: zero_coupling_block !< If true, zero hbse_b before calling p*bseig
integer :: iabsorp0 !< 1 means noeh_only, 0 otherwise
integer :: iwriteint = 1 !< = 0 for comm_disk, = 1 for comm_mpi
logical :: eqp_corrections !< do we use eqp.dat and eqp_q.dat
logical :: eqp_co_corrections !< do we use eqp_co.dat
logical :: eqp_co_q_corrections !< do we use eqp_co_q.dat

!> For Coulomb interaction truncation
integer :: iwritecoul
integer :: icutv !< icutv encodes presence and type of truncation
real(DP) :: truncval(3) !< in Bohr (au)
integer :: nint !< number of intervals used in
!! double integral truncated_factor
logical :: use_hdf5 !< with -DHDF5, whether or not we actually use hdf5
logical :: bLowComm !< If this is true, each processor will store the entire epsilon matrix
logical :: delaunay_interp!< use Delaunay interpolation?
integer :: neps !< Number of G vectors to capture the dielectric cutoff
integer :: ilowmem
logical :: skipinterp
integer :: ivpar, icpar
integer :: nn !< PlotXct restrict_kpoints
integer :: ng
integer :: nktotal !< total number of unit cells
!> Number of vertices in co k-grid that are used to expand each k-point in
!! the fine grid for the **kernel** interpolation. This is 1 for the
!! greedy interpolation (previous behaviour of the code), and ndims+1
!! if we are performing Delaunay interpolation.
integer :: npts_intp_kernel
real(DP) :: eta !< energy resolution
real(DP) :: sigma !< (used to calculate the optical spectrum)
real(DP) :: gamma !< (used to calculate the optical spectrum)
real(DP) :: qshift
real(DP) :: shift(3) !< shift vector (this is the small shift,
!< used to generate WFNq_fi, referenced only if xct%read_kpoints)
real(DP) :: finiteq(3) !< center-of-mass momentum of exciton
logical :: energy_loss !< calculate energy loss spectrum
real(DP) :: lpol !< norm of pol
real(DP) :: pol(3) !< light polarization for transition matrix elements
integer :: npol !< number of polarizations we have. Either 1 or 3.
integer :: nmtxmax !< max. number of columns in epsmat or eps0mat
integer :: theory !< theory level in kernel calculation
!< 0 - GW-BSE, 1 - TDDFT
integer :: qgrid(3)
real(DP) :: q0vec(3) ! This is a hack for passing q0vec for
! TDDFT calculations (never used otherwise)
! when there is no epsilon
type(coulomb_modifier_t) :: coulomb_mod
logical :: coul_mod_flag !< Flag which tells if the coulomb interaction has been
!< modified (for TDDFT calculations)
integer, pointer :: indexq(:), indexq_fi(:) !< When exciton has finite center-of-mass momentum,
!< maps between valence states at k+Q and conduction states at k
integer, pointer :: isrtqi(:,:), nmtxa(:)
integer, pointer :: ifmax(:,:), ifmaxq(:,:)
real(DP) :: ecute !< energy cutoff used in dielectric matrix
real(DP) :: scaling !< multiply kernel by arbitrary factor
real(DP) :: ecutg !< energy cutoff used in wavefunctions and interaction
!< kernel, see Rohlfing & Louie, PRB 62(8),p. 4938
!< (must be slightly longer than xct%ecute because of umklapp vectors)
real(DP) :: efermi !< computed efermi
real(DP) :: efermi_input !< as set in input file
logical :: rfermi !< relative or absolute Fermi level
complex(DPC), pointer :: epsdiag(:,:) !< (nmtxmax, nq+1)
type (wpgen) :: wpg !< charge density/fxc for TDDFT
! FHJ: TODO - move the following quantities to a separate derived type,
! ir reuse epsmpi
!> Regular comm: (nmtxmax, ngpown_max, nq+1). The local processor stores row ig
!! and a "local column" igp_l from epsilon in epscol(ig, igp_l, ik).
!! Low comm: (nmtxmax, nmtxmax, nq+1). Each processor stores all eps(0)mat.
!! local column = global epsilon column.
complex(DPC), pointer :: epscol(:,:,:)
integer :: ngpown_max !< max. number of eps columns a PE can have
integer :: ngpown !< number of columns of epsinv I own, for largest matrix
integer :: nb !< block size for column distribution
! The arrays epsown and epsowni were removed, as they can be calculated on the fly:
! iowner = INDXG2P(igp, xct%nb, peinf%inode, 0, peinf%npes)
! xct%epsown(igp) = INDXG2P(igp, xct%nb, peinf%inode, 0, peinf%npes)
! xct%epsowni(igp_loc, iowner+1) = INDXG2L(igp, xct%nb, peinf%inode, 0, peinf%npes)
!> Used for screened_exchange
logical :: screen_exchange !< add background screening to exchange term
complex(DPC), pointer :: epscol_bg(:,:,:) !< stores columns of the substrate dielectric matrix
complex(DPC), pointer :: epsdiag_bg(:,:) !< same as epsdiag for substrate dielectric matrix
integer :: nmtxmax_bg !< max. number of columns in epsmat or eps0mat
integer, pointer :: isrtqi_bg(:,:), nmtxa_bg(:)

!> Used in haydock/diag only
integer :: nkpt_fi !< number of kpts in the fine grid
integer :: nkptq_fi !< number of kpts in the q-shifted fine grid
integer :: nvb_fi !< number of valence bands in the fine grid
integer :: ncb_fi !< number of conduction bands in the fine grid
real(DP) :: avgcut !< Cut in which we do cell averages on
real(DP) :: wplasmon
complex(DPC) :: wcoul0
integer :: vmin,vmax
integer :: rgrid(3) !< regular grid used to calculate qpt_averages (default is kgrid)
logical :: freplacebz
logical :: fwritebz
logical :: degeneracy_check_override
logical :: die_outside_sphere
logical :: averagew
logical :: subsample_line !< during kernel interpolation, replace interpolated matrix
!< elements with matrix elements from a precalculated bsemat file
!< on a subsampled grid
real(DP) :: subsample_cutoff !< use subsampled BSE matrix elements when |q| is less than cutoff
real(DP) :: exchange_fact !< multiplies the BSE exchange term by this factor
real(DP) :: direct_fact !< multiplies the BSE direct term by this factor
real(DP) :: delta_frequency !< Frequency step for absorption spectrum
end type xctinfo

!------------------------------------

type flags

!>
!> Used in haydock, diag, nonlinearoptics
!>
!> Defined flags:
!>
!> bz0 = 0 --> use symmetries to unfold the Brillouin zone in WFN_fi file
!> 1 --> do not unfold the BZ in WFN_fi file (default)
!> bzq = 0 --> use symmetries to unfold the BZ in WFNq_fi file
!> 1 --> do not unfold the BZ in WFNq_fi file (default)
!> bzc = 0 --> use symmetries to unfold the BZ in WFN_co file
!> 1 --> do not unfold the BZ in WFN_co file (default)
!> bzcq = 0 --> use symmetries to unfold the BZ in WFNq_co file
!> 1 --> do not unfold the BZ in WFN_co file (default)
!>
!> read_dtmat = false --> calculate dcc,dvv matrices (default)
!> true --> take dcc,dvv matrices from file dtmat
!>
!> eig = 0 --> do not write eigenvectors (default)
!> < 0 --> write all eigenvectors
!> > 0 --> write the first flag%eig eigenvectors
!>
!> read_epsdiag = false --> read files 'eps0mat'/'epsmat' (default)
!> true --> read file 'epsdiag.dat'
!>
!> krnl = 0 --> spin triplet kernel, direct kernel only (only allow for nspin = 1)
!> 1 --> spin singlet kernel (default)
!> 2 --> local-fields + RPA, exchange kernel only
!> 3 --> spinor kernel
!>
!> opr = 0 --> use velocity operator
!> 1 --> use momentum operator
!> 2 --> use JDOS operator (Haydock only)
!>
!> lor = 0 --> use Lorentzian broadening
!> 1 --> use Gaussian broadening
!> 2 --> use Voigt broadening
!>
!> spec = 0 --> go through the whole exciton calculation (default)
!> 1 --> calculate only absorption spectrum (this option skips
!> all calculation and goes right to the end of the code)
!>
!> vm = 0 --> calculate velocity/momentum matrix elements (default)
!> 1 --> read velocity/momentum matrix elements from file vmtxel
!> 2 --> use vectors from previous iteration (Haydock only!)
!>
!> job = 0 --> ultrafast calculation
!> job = 1 --> two-photon calculation
!>

integer :: bz0
integer :: lor
integer :: bzq
integer :: bzc
integer :: bzcq
logical :: read_dtmat
logical :: read_dtmat_sub
integer :: eig
logical :: read_epsdiag
integer :: krnl
integer :: opr
integer :: spec
integer :: vm
integer :: job
!> Use averaged Gauss quadrature in Lanczos algorithm? Default is true.
logical :: lanczos_gauss_quad
logical :: debug_lanczos
end type flags

!---------------------------------

type otherinfo
integer :: ithreeD
integer :: knx
integer :: kny
integer :: knz
real(DP) :: keta
end type otherinfo

!---------------------------------

type windowinfo
real(DP) :: evalue
real(DP) :: emax
real(DP), pointer :: cstates(:)
real(DP), pointer :: estates(:)
integer, pointer :: istates(:)
integer :: nstates
end type windowinfo

!-----------------------------
!> coarse-grid wavefunctions for diag/haydock
type tdistgwf

integer :: block_sz !< block size for BLACS distribution = ((ngm+npes-1)/(npes))
integer :: ngm !< maximum number of G-vectors = kp*%ngkmax
integer :: ngl !< local number of G-vectors = NUNROC(...). At most block_sz.
integer :: tgl !< local to global translation = block_sz * peinf%inode

!> local to global index translation : ig_g = ig_l + tgl
!> ig_g = 1 ... ng(ik) is the global G-index
!> ig_l = 1 ... ngl is the local G-index

integer :: nk !< number of k-points
integer :: ns !< number of spin components
integer :: nspinor = 1 !< nspinor = 2 if doing two-component spinor calculation; 1 is default
integer :: nv !< number of valence bands
integer :: nc !< number of conduction bands

integer, pointer :: ng(:) !< (nk)
integer, pointer :: isort(:,:) !< (ngl,nk)
complex(DPC), pointer :: zv(:,:,:,:) !< (ngl,nv,ns*nspinor,nk)
complex(DPC), pointer :: zc(:,:,:,:) !< (ngl,nc,ns*nspinor,nk)

end type tdistgwf

!-----------------------------
!> MJ: work arrays - getting rid of save statements

type work_genwf
integer :: ikold = 0
integer :: nb
integer :: ng
integer :: ns
integer :: nspinor = 1 !< nspinor = 2 if doing two-component spinor calculation; 1 is default
complex(DPC), pointer :: cg(:,:,:)
complex(DPC), pointer :: ph(:)
integer, pointer :: ind(:)
integer, pointer :: isort(:)
end type work_genwf

!-----------------------------
!> (gsm) work arrays - getting rid of save statements

type twork_scell
integer :: dNfft(3)
integer :: Nplane
integer :: Nrod
complex(DPC), pointer :: fftbox_1D(:,:)
end type twork_scell

!> FHJ: mean-field header
type mf_header_t
integer :: version
character(len=3) :: sheader
character(len=32) :: sdate
character(len=32) :: stime
integer :: iflavor
type(crystal) :: crys
type(kpoints) :: kp
type(symmetry) :: syms
type(gspace):: gvec
end type mf_header_t

!> FHJ: header information for kernel files (bsedmat, bsexmat, bsemat.h5)
type kernel_header_t

! Mean-field and other general information
type(mf_header_t) :: mf !< mf header containing number of k-points, WFN cutoff, etc.

integer :: version
integer :: iflavor

integer :: iscreen !< screening flag
integer :: icutv !< truncation flag
real(DP) :: ecuts !< epsilon cutoff
real(DP) :: ecutg !< WFN cutoff
real(DP) :: efermi !< Fermi energy found by the code after any shift
integer :: theory !< 0 for GW-BSE, 1 for TD-HF, 2 for TD-DFT
!> How many transitions blocks are there in the kernel matrix?
!! 1 for restricted TDA kernel: vc -> v`c`
!! 2 for restricted non-TDA kernel: {vc,cv} -> {v`c`,c`v`} [not implemented]
!! 4 for extended kernel: {n1,n2} -> {n1`,n2`}
integer :: nblocks
integer :: storage !< 0 if storing full matrix (only option supported now)
integer :: nmat !< number of matrices in the file (1 for bsexmat, 3 for bsedmat)
logical :: energy_loss !< is this an energy-loss calculation?

integer :: nvb !< number of valence bands in the coarse grid
integer :: ncb !< number of conduction bands in the coarse grid
integer :: n1b !< nvb_co if kernel_sz==1; nvb_co + ncb_co if kernel_sz=4
integer :: n2b !< ncb_co if kernel_sz==1; nvb_co + ncb_co if kernel_sz=4
integer :: ns !< number of spins
integer :: nspinor = 1 !< nspinor = 2 if doing two-component spinor calculation; 1 is default
logical :: patched_sampling !< are we doing a calculation on a patch?

! Variables specific to kernel files
integer :: nk !< number of k-points
real(DP), pointer :: kpts(:,:)
integer :: kgrid(3)
!> 0 for finite Q calculation with arbitrary Q (deprecated)
!! 1 for Q=0 calculation (default)
!! 2 use Q commensurate with WFN_co kgrid (under construction)
integer :: qflag
real(DP) :: center_mass_q(3)

end type kernel_header_t

end module typedefs_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/global.f90 > Common/global.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/global.p.f -o Common/global.o -module Common/
# 1 "Common/global.p.f"
!================================================================================
!
! Modules:
!
! (1) global_m Originally By das Last Modified 8/20/2010 (das)
!
! Global module to be used everywhere.
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/global.f90" 2

module global_m

use intrinsics_m
use message_m
use nrtype_m
use peinfo_m
use push_pop_m
use timing_m
use typedefs_m
use scalapack_aux_m

implicit none

end module global_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/bessel.f90 > Common/bessel.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/bessel.p.f -o Common/bessel.o -module Common/
# 1 "Common/bessel.p.f"
!==============================================================================
!
! Module: bessel_m Originally By DAS 1/31/2011
!
! Note that besj0 and besj1 are standard Fortran intrinsics, but the
! modified functions are not available.
!
! Routines:
!
! (1) dbesk0(function) Originally By JRD Last Modified 1/1/2012 (JRD)
!
! Returns the K0 Bessel function. From free software:
! http://www.kurims.kyoto-u.ac.jp/~ooura/bessel.html
!
!==============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 18 "Common/Common/bessel.f90" 2

module bessel_m

use global_m
implicit none

private

public :: &
dbesk0

contains

real(DP) function dbesk0(x) result(k0)
real(DP) :: x,t,y
integer :: i,k
real(DP) :: a(0 : 15), b(0 : 111), c(0 : 134), d(0 : 39)

data (a(i), i = 0, 15) / &
2.4307270476772195953d-12, 4.7091666363785304370d-10, &
6.7816861334344265568d-8, 6.7816840204737508252d-6, &
4.3402777777915334676d-4, 1.5624999999999872796d-2, &
2.5000000000000000448d-1, 9.9999999999999999997d-1, &
6.5878327432224993071d-12, 1.2083308769932888218d-9, &
1.6271062073716412046d-7, 1.4914719278555277887d-5, &
8.4603509071212245667d-4, 2.5248929932162333910d-2, &
2.7898287891460312491d-1, 1.1593151565841244874d-1 /
data (b(i), i = 0, 13) / &
-4.6430702971053162197d-13, 1.0377936059563728230d-11, &
-1.0298475936392057807d-10, 5.3632747492333959219d-10, &
-2.1674628861036068105d-10, -2.3316071545820437669d-8, &
2.2557819578691704059d-7, -9.2325694638587080009d-7, &
-3.3569097781613661759d-6, 8.7355061305812582974d-5, &
-6.8021202111645760475d-4, 2.7434654781323362319d-4, &
1.0031787169953909561d-1, 4.2102443824070833334d-1 /
data (b(i), i = 14, 27) / &
4.1447451117883103686d-12, -3.4026589638576604315d-11, &
9.3398790624638977468d-12, 1.5184181750799852630d-9, &
-1.1364911665083029464d-8, 2.0619457602095915719d-8, &
3.0431018037572243630d-7, -2.9749736264474555510d-6, &
8.0143661611467038568d-6, 8.0937525149549218398d-5, &
-1.0356346549612699886d-3, 2.8534806627578638795d-3, &
9.7369634474060441807d-2, 3.2175066577856452683d-1 /
data (b(i), i = 28, 41) / &
1.1170882570740727520d-13, -8.2865909408297066068d-11, &
9.4656678749191182763d-10, -3.5832019841847883380d-9, &
-9.5017955656904252761d-9, 1.5200595674883329093d-7, &
-3.8663262571356059980d-7, -3.3350340828235103499d-6, &
2.9359886663960844231d-5, -1.1266401822556801563d-5, &
-1.2113572742435576205d-3, 6.3158973673701376253d-3, &
8.8291790250128171341d-2, 2.2833982383240512262d-1 /
data (b(i), i = 42, 55) / &
-3.2880638807053948433d-11, 4.3194884830465283512d-10, &
-1.7455089683104033093d-9, -3.2437330799994764516d-9, &
4.7393655539139519778d-8, -1.1929265603456272466d-8, &
-1.3177845881013419388d-6, 3.3873375636197969526d-6, &
3.2729835880668256625d-5, -1.8367283883002494561d-4, &
-8.2830996454188084408d-4, 9.5512732229514251931d-3, &
7.2233832113719266702d-2, 1.4753187103603405298d-1 /
data (b(i), i = 56, 69) / &
7.9998492614150860098d-11, -7.0257346702686139490d-10, &
7.8898821627084586270d-10, 1.1294796399671507085d-8, &
-1.1360539648638059137d-8, -3.0346309115270564487d-7, &
3.2235585426189451721d-7, 8.3575612102298214948d-6, &
-8.5169628089198208211d-6, -2.5740175232173357342d-4, &
1.2462734014689152770d-4, 1.0683232869192203450d-2, &
5.1515690033637395779d-2, 8.5465862953544883657d-2 /
data (b(i), i = 70, 83) / &
-8.6111506537356531608d-11, 5.1862926131024597823d-10, &
7.5884324949371110022d-10, -6.4011975813006767417d-9, &
-4.1966181325111763156d-8, 9.1306285446881485314d-8, &
1.3573638315827954034d-6, 4.8683213252735694701d-7, &
-3.8805424608710197066d-5, -1.1838986468688980610d-4, &
9.2796213947750964945d-4, 8.9611057737319027776d-3, &
3.1464453915862785606d-2, 4.4267648087536630780d-2 /
data (b(i), i = 84, 97) / &
4.4400123834164610288d-11, -1.1411233140911074336d-10, &
-8.8200670702467059830d-10, -1.9686735373323381456d-9, &
1.9921120728941773855d-8, 1.4543974418584834740d-7, &
1.8238418041265854754d-8, -4.5363700392899066037d-6, &
-2.1688068222527688542d-5, 4.5496062166687034700d-5, &
1.0435238076080528284d-3, 5.8374528996419979931d-3, &
1.6611210710425455850d-2, 2.0756008367065750538d-2 /
data (b(i), i = 98, 111) / &
-6.5166519951106397214d-12, -5.8572182858788539580d-11, &
1.5550375065815375404d-10, 1.9526509484993563229d-9, &
9.2637123346818426594d-9, -1.4136471501812055943d-8, &
-4.3024895710889717172d-7, -2.3235612243330592076d-6, &
4.0380616133862188804d-7, 9.2783767992909743602d-5, &
7.2964887597817095035d-4, 3.1316245282223273413d-3, &
7.8028233022066428316d-3, 9.0014807263791058095d-3 /
data (c(i), i = 0, 14) / &
4.5161032649342790231d-11, -4.2774336988557091369d-11, &
6.0998467173896677777d-10, 1.9845167242599996944d-9, &
1.3097678767280215271d-8, 7.4505822268382641286d-8, &
4.2893920879106814989d-7, 2.3900851955655303104d-6, &
1.2533473009382380357d-5, 5.9693359063879871983d-5, &
2.4775070661087304580d-4, 8.5106703131389516508d-4, &
2.2500105115665788755d-3, 4.0446134454521634600d-3, &
3.6910983340425942762d-3 /
data (c(i), i = 15, 29) / &
3.5732826433251464989d-12, -3.2906649482312266258d-12, &
7.0873811190464760555d-11, 2.9551320580484177120d-10, &
2.2776940472505079894d-9, 1.5175463612815010036d-8, &
9.9462487812170164133d-8, 6.1448757797853901100d-7, &
3.4869531882907360750d-6, 1.7615836644757657443d-5, &
7.6373536037879531886d-5, 2.7098571871205999668d-4, &
7.3399047381788927036d-4, 1.3439197177355085297d-3, &
1.2439943280131230863d-3 /
data (c(i), i = 30, 44) / &
3.6343547836242523646d-13, 9.7997961751276137602d-14, &
1.0184692699811569047d-11, 6.1495184828957652064d-11, &
5.0238328349302602543d-10, 3.7498626376004337661d-9, &
2.6689445483857236307d-8, 1.7591899737346368084d-7, &
1.0486448307010701679d-6, 5.4986458466257148573d-6, &
2.4521456351751345323d-5, 8.8900942259143832228d-5, &
2.4483947714068300190d-4, 4.5418248688489693045d-4, &
4.2479574186923180694d-4 /
data (c(i), i = 45, 59) / &
5.2460389348163395857d-14, 7.4802063026503503540d-14, &
2.0012201610651998417d-12, 1.4887306044735163359d-11, &
1.2946705414232940350d-10, 1.0391628915892803144d-9, &
7.8091180499677328456d-9, 5.3694223626907660084d-8, &
3.3063914804658509029d-7, 1.7776972424421486506d-6, &
8.0833148098458320202d-6, 2.9755556304448817780d-5, &
8.2945928349220642178d-5, 1.5536921180500112883d-4, &
1.4647070522281538711d-4 /
data (c(i), i = 60, 74) / &
9.7531436733955514559d-15, 2.4084291220447154982d-14, &
4.7654956400897494468d-13, 4.0200949504810597783d-12, &
3.6726577109162191533d-11, 3.0939005665422637601d-10, &
2.4122848979784500179d-9, 1.7071884462645525505d-8, &
1.0752238955654933405d-7, 5.8844190041189462347d-7, &
2.7136083303224014597d-6, 1.0102477728604441135d-5, &
2.8420490721532571809d-5, 5.3637016379451944413d-5, &
5.0881312956459247572d-5 /
data (c(i), i = 75, 89) / &
2.1732049868189377260d-15, 7.2720052142815590531d-15, &
1.2803083795536820100d-13, 1.1696825543787717167d-12, &
1.1083298191597132094d-11, 9.6536661252658773139d-11, &
7.7242553835198536397d-10, 5.5798366267110575620d-9, &
3.5721345296543414370d-8, 1.9806931547193682466d-7, &
9.2312964655319555313d-7, 3.4666258590861079959d-6, &
9.8224698307751177077d-6, 1.8648773453825584428d-5, &
1.7780062316167651812d-5 /
data (c(i), i = 90, 104) / &
5.5012463763851934112d-16, 2.2254763392767319419d-15, &
3.7187669817701214965d-14, 3.5819585377733489628d-13, &
3.4866061263191556694d-12, 3.1101633450629652910d-11, &
2.5358235662235617663d-10, 1.8597629779492599046d-9, &
1.2052654739462999992d-8, 6.7501417351172136833d-8, &
3.1720052198654584574d-7, 1.1993651363602981832d-6, &
3.4179130317623363474d-6, 6.5208606745808860158d-6, &
6.2430205476536771454d-6 /
data (c(i), i = 105, 119) / &
1.5225407517829491689d-16, 6.9834820025664405161d-16, &
1.1380182837138781431d-14, 1.1369488761077196511d-13, &
1.1291168681618466716d-12, 1.0250757630526871007d-11, &
8.4765287317253141514d-11, 6.2886627779402596211d-10, &
4.1142865598366029316d-9, 2.3223773435632014408d-8, &
1.0985095234166396934d-7, 4.1766260951820336228d-7, &
1.1958609263543792991d-6, 2.2907574647671878055d-6, &
2.2008253973114914005d-6 /
data (c(i), i = 120, 134) / &
4.4863058691420695911d-17, 2.2437356594371819978d-16, &
3.6107964803015652759d-15, 3.7031193629853392081d-14, &
3.7341552790439784371d-13, 3.4355950129497564468d-12, &
2.8719942600171304499d-11, 2.1499646844509516453d-10, &
1.4171810843455227171d-9, 8.0501118772875784153d-9, &
3.8281889106330295876d-8, 1.4621673458431979989d-7, &
4.2029868696411098586d-7, 8.0785884122023473025d-7, &
7.7845438614204963209d-7 /
data (d(i), i = 0, 7) / &
-7.9737703860537066166d-14, 1.9543834380466766627d-12, &
-4.7230794431646733538d-11, 1.4001773785771252004d-9, &
-5.4864553020583098585d-8, 3.1601984250143742772d-6, &
-3.3708783204090252161d-4, 1.6180215937964160437d-1 /
data (d(i), i = 8, 15) / &
-5.2593898374798632343d-14, 1.7725913926973236457d-12, &
-4.6672234858122387294d-11, 1.3991653503828889207d-9, &
-5.4863400156413929639d-8, 3.1601976099900075541d-6, &
-3.3708783171335864627d-4, 1.6180215937958433760d-1 /
data (d(i), i = 16, 23) / &
-3.6135496189875398132d-14, 1.5466239429618130284d-12, &
-4.5320259146602122624d-11, 1.3945974109459385552d-9, &
-5.4853994841172088787d-8, 3.1601858228022739196d-6, &
-3.3708782339998302320d-4, 1.6180215937704286491d-1 /
data (d(i), i = 24, 31) / &
-2.5640663123518180635d-14, 1.3288079339404032671d-12, &
-4.3368537955908371563d-11, 1.3848103653102203186d-9, &
-5.4824335664256344123d-8, 3.1601315173126153586d-6, &
-3.3708776779035695640d-4, 1.6180215935248373474d-1 /
data (d(i), i = 32, 39) / &
-1.8678321325292127767d-14, 1.1354310934105733311d-12, &
-4.1057197297998608931d-11, 1.3693990961296350970d-9, &
-5.4762428935047089835d-8, 3.1599817092775027963d-6, &
-3.3708756559715893599d-4, 1.6180215923508144240d-1 /

if (x .lt. 0.86d0) then
t = x * x
y = ((((((a(0) * t + a(1)) * t + &
a(2)) * t + a(3)) * t + a(4)) * t + &
a(5)) * t + a(6)) * t + a(7)
y = ((((((a(8) * t + a(9)) * t + &
a(10)) * t + a(11)) * t + a(12)) * t + &
a(13)) * t + a(14)) * t + a(15) - y * log(x)
else if (x .lt. 4.15d0) then
t = x - 5 / x
k = int(t + 5)
t = (k - 4) - t
k = k * 14
y = ((((((((((((b(k) * t + b(k + 1)) * t + &
b(k + 2)) * t + b(k + 3)) * t + b(k + 4)) * t + &
b(k + 5)) * t + b(k + 6)) * t + b(k + 7)) * t + &
b(k + 8)) * t + b(k + 9)) * t + b(k + 10)) * t + &
b(k + 11)) * t + b(k + 12)) * t + b(k + 13)
else if (x .lt. 12.5d0) then
k = int(x)
t = (k + 1) - x
k = 15 * (k - 4)
y = (((((((((((((c(k) * t + c(k + 1)) * t + &
c(k + 2)) * t + c(k + 3)) * t + c(k + 4)) * t + &
c(k + 5)) * t + c(k + 6)) * t + c(k + 7)) * t + &
c(k + 8)) * t + c(k + 9)) * t + c(k + 10)) * t + &
c(k + 11)) * t + c(k + 12)) * t + c(k + 13)) * t + &
c(k + 14)
else
t = 60 / x
k = 8 * (int(t))
y = (((((((d(k) * t + d(k + 1)) * t + &
d(k + 2)) * t + d(k + 3)) * t + d(k + 4)) * t + &
d(k + 5)) * t + d(k + 6)) * t + d(k + 7)) * &
sqrt(t) * exp(-x)
end if
k0 = y
end function dbesk0
!

end module bessel_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/blas.f90 > Common/blas.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/blas.p.f -o Common/blas.o -module Common/
# 1 "Common/blas.p.f"
!================================================================================
!
! Modules:
!
! (1) blas_m Originally By DAS Last Modified 1/13/2011 (das)
!
! Interfaces for BLAS functions, taken from http://www.netlib.org/blas/
! Every BLAS function used in the code should be listed here, and this
! module should be used in every routine containing BLAS calls to ensure
! the argument types are correct.
!
! Note that if any array name from netlib.org is X, the interface will
! be interpreted as a preprocessor macro and cause a compilation failure,
! solved by changed to lower-case x.
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 19 "Common/Common/blas.f90" 2

module blas_m

public ! only interfaces in this module

interface
SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
implicit none
DOUBLE PRECISION ALPHA,BETA
INTEGER K,LDA,LDB,LDC,M,N
CHARACTER TRANSA,TRANSB
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
end subroutine DGEMM
end interface

interface
SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
implicit none
DOUBLE COMPLEX ALPHA,BETA
INTEGER K,LDA,LDB,LDC,M,N
CHARACTER TRANSA,TRANSB
DOUBLE COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
end subroutine ZGEMM
end interface

interface
SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,x,INCX,BETA,Y,INCY)
implicit none
DOUBLE PRECISION ALPHA,BETA
INTEGER INCX,INCY,LDA,M,N
CHARACTER TRANS
DOUBLE PRECISION A(LDA,*),x(*),Y(*)
end SUBROUTINE DGEMV
end interface

interface
SUBROUTINE ZGEMV(TRANS,M,N,ALPHA,A,LDA,x,INCX,BETA,Y,INCY)
implicit none
DOUBLE COMPLEX ALPHA,BETA
INTEGER INCX,INCY,LDA,M,N
CHARACTER TRANS
DOUBLE COMPLEX A(LDA,*),x(*),Y(*)
end SUBROUTINE ZGEMV
end interface

interface
SUBROUTINE ZHEMV(UPLO,N,ALPHA,A,LDA,x,INCX,BETA,Y,INCY)
implicit none
DOUBLE COMPLEX ALPHA,BETA
INTEGER INCX,INCY,LDA,N
CHARACTER UPLO
DOUBLE COMPLEX A(LDA,*),x(*),Y(*)
end SUBROUTINE ZHEMV
end interface

interface
SUBROUTINE ZHPMV(UPLO,N,ALPHA,AP,x,INCX,BETA,Y,INCY)
implicit none
DOUBLE COMPLEX ALPHA,BETA
INTEGER INCX,INCY,N
CHARACTER UPLO
DOUBLE COMPLEX AP(*),x(*),Y(*)
end SUBROUTINE ZHPMV
end interface

interface
SUBROUTINE ZHEMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
implicit none
DOUBLE COMPLEX ALPHA,BETA
INTEGER LDA,LDB,LDC,M,N
CHARACTER SIDE,UPLO
DOUBLE COMPLEX A(LDA,*),B(LDB,*),C(LDC,*)
end SUBROUTINE ZHEMM
end interface

interface blas_dot
DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
implicit none
INTEGER INCX,INCY,N
DOUBLE PRECISION DX(*),DY(*)
end FUNCTION DDOT

DOUBLE COMPLEX FUNCTION ZDOTC(N,ZX,INCX,ZY,INCY)
implicit none
INTEGER INCX,INCY,N
DOUBLE COMPLEX ZX(*),ZY(*)
end FUNCTION ZDOTC
end interface blas_dot

interface
SUBROUTINE DSCAL(N,DA,DX,INCX)
implicit none
DOUBLE PRECISION DA
INTEGER INCX,N
DOUBLE PRECISION DX(*)
end SUBROUTINE DSCAL
end interface

interface
SUBROUTINE ZSCAL(N,ZA,ZX,INCX)
implicit none
DOUBLE COMPLEX ZA
INTEGER INCX,N
DOUBLE COMPLEX ZX(*)
end SUBROUTINE ZSCAL
end interface

interface blas_nrm2
DOUBLE PRECISION FUNCTION DNRM2(N,x,INCX)
implicit none
INTEGER INCX,N
DOUBLE PRECISION x(*)
end FUNCTION DNRM2

DOUBLE PRECISION FUNCTION DZNRM2(N,x,INCX)
implicit none
INTEGER INCX,N
DOUBLE COMPLEX x(*)
end FUNCTION DZNRM2
end interface

end module blas_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/misc.f90 > Common/misc.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/misc.p.f -o Common/misc.o -module Common/
# 1 "Common/misc.p.f"
!>===================================================================
!!
!! Module misc_m
!!
!! Routines:
!!
!! 1. checknorm() Originally By (SIB) Last Modified 5/02/2012 (BAB)
!!
!! Checks normalization of a wavefunction, one spin at a time.
!! By normalization we mean that sum_l { |z(l,m)|^2 } = 1 for each m.
!! It aborts if norm is off by more than TOL_Small from 1.
!!
!! 2. compute_norm() Originally by BAB 5/02/12
!!
!! Computes the norm of an input wavefunction.
!!
!! 3. get_volume() Originally By (SIB) Last Modified 6/12/2008 (JRD)
!!
!! This assumes that b is a symmetric matrix. It sets
!! vol = (2pi)^3 / square_root(|det(b)|)
!! This makes sense if b is the matrix of dot products of the recip
!! lattice vectors, so vol is the real space volume.
!!
!! 4. findvector() Originally By (SIB) Last Modified 6/12/2008 (JRD)
!!
!! Looks for the vector in the list of vectors
!! gvec%components(1:3,1:gvec%ng). If found, iout is its index. Otherwise
!! iout is zero.
!!
!! 5. invert_matrix() Originally By (SIB) Last Modified 6/12/2008 (JRD)
!!
!! Inverts 3x3 matrix.
!!
!! 6. invert_matrix_int() Originally by DAS 12/28/11 Last Modified 8/27/2012 (BAB)
!!
!! Like invert_matrix, but for integer input. Dies if output is not integers.
!!
!! 7. compute_det() Originally By (BAB) Last Modified 8/27/2012 (BAB)
!!
!! Computes determinant of 3x3 matrix.
!!
!! 8. compute_det_int() Originally By (BAB) Last Modified 8/27/2012 (BAB)
!!
!! Like compute_det, but for integer input. Does not die if output not integer
!!
!! 9. compute_cofac() Originally By (BAB) Last Modified 9/4/2012 (BAB)
!!
!! Computes matrix of cofactors for input matrix.
!!
!! 10. compute_cofac_int() Originally By (BAB) Last Modified 9/4/2012 (BAB)
!!
!! Computes matrix of cofactors for input matrix, but for integer input.
!!
!! 11. procmem() Originally By (gsm) Last Modified 4/14/2009 (gsm)
!!
!! Determines the amount of free memory per processor
!! from the proc file system
!!
!! 12. sizeof_scalar() Originally By (DAS) Last Modified 1/25/2011 (DAS)
!!
!! Return the size of the SCALAR type, for memory estimation.
!!
!! 13. voigt() Originally By (gsm) Last Modified 1/31/2011 (gsm)
!!
!! Returns Voigt function (convolution of Gaussian and Lorentzian).
!! Based on the rational approximation to the complex error function
!! from A. K. Hui, B. H. Armstrong and A. A. Wray,
!! "Rapid computation of the Voigt and complex error functions,"
!! Journal of Quantitative Spectroscopy and Radiative Transfer,
!! Volume 19, Issue 5, Pages 509 - 516, Year 1978.
!!
!! 14. k_range() Originally By gsm Last Modified 8/18/2010 (gsm)
!!
!! Translates k-point kpt(1:3) to [0,1) interval. Returns G-vector gpt(1:3)
!! that brings kpt(1:3) to [0,1) interval. The interval is satisfied within
!! a given tolerance, the actual interval is [-tol,1-tol).
!!
!! 15. bse_index() Originally by DAS 4/19/12
!!
!! Defines the mapping of k-point, conduction band, valence band, and spin
!! into a single index (traditionally called 'ikcvs'), as used in BSE codes.
!!
!!===================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 86 "Common/Common/misc.f90" 2

module misc_m

use global_m
use blas_m

implicit none

private

public :: &
checknorm, &
compute_norm, &
get_volume, &
findvector, &
invert_matrix, &
invert_matrix_int, &
compute_det, &
compute_det_int, &
procmem, &
sizeof_scalar, &
voigt, &
k_range, &
bse_index

contains

!> Checking normalization of only one spin component at a time
subroutine checknorm(filename,iband,ik,ng,ispin,nspinor,wfn)
character (len=*), intent(in) :: filename
integer, intent(in) :: iband,ik,ng,ispin,nspinor
complex(DPC), intent(in) :: wfn(:,:) !< (ng,nspin*nspinor)

real(DP) :: xnorm

if (.not.peinf%check_norms) return
call compute_norm(xnorm,ispin,ng,nspinor,wfn)
if(abs(xnorm - 1.0d0) > TOL_Small) then
write(0,555) TRUNC(filename),abs(xnorm-1.0d0),iband,ispin,ik
555 format(1x,'Wavefunction is not normalized in file',1x,a,/,&
3x,'abs(norm - 1) =',f10.7,/,&
3x,'iband =',i6,1x,'ispin =',i2,1x,'ik =',i6,/)
call die("Incorrect normalization.")
endif

return
end subroutine checknorm

!=====================================================================

subroutine compute_norm(xnorm,ispin,ng,nspinor,wfn)
real(DP), intent(out) :: xnorm
integer, intent(in) :: ispin,ng,nspinor
complex(DPC), intent(in) :: wfn(:,:) !< (ng,nspin*nspinor)

integer :: ispinor
real(DP) :: vnorm(nspinor)

do ispinor=1,nspinor
vnorm(ispinor) = blas_nrm2(ng, wfn(:,ispin*ispinor), 1)
enddo
xnorm = sqrt(sum(vnorm(:)**2))

return
end subroutine compute_norm

!=====================================================================

subroutine get_volume(vol,b)
real(DP), intent(out) :: vol
real(DP), intent(in) :: b(3,3)

vol = b(1,1)*(b(2,2)*b(3,3) - b(2,3)**2) &
+ 2*b(1,2)*b(2,3)*b(3,1) &
- b(2,2)*b(1,3)**2 - b(3,3)*b(1,2)**2
vol = sqrt(abs(vol))
vol = ((2.0d0*PI_D)**3)/vol

return
end subroutine get_volume

!=====================================================================

subroutine findvector(iout,kk,gvec)
integer, intent(out) :: iout
integer, intent(in) :: kk(3)
type (gspace), intent(in) :: gvec

! no push/pop since called too frequently

iout=((kk(1)+gvec%FFTgrid(1)/2)*gvec%FFTgrid(2)+kk(2)+gvec%FFTgrid(2)/2)* &
gvec%FFTgrid(3)+kk(3)+gvec%FFTgrid(3)/2+1
if (iout .ge. 1 .and. iout .le. gvec%nFFTgridpts) then
iout=gvec%index_vec(iout)
if (iout .ge. 1 .and. iout .le. gvec%ng) then
if (any(kk(1:3) /= gvec%components(1:3, iout))) iout = 0
else
iout = 0
endif
else
iout = 0
endif

return
end subroutine findvector

!=====================================================================

subroutine invert_matrix(mat, inv)
real(DP), intent(in) :: mat(:,:) !< (3,3)
real(DP), intent(out) :: inv(:,:) !< (3,3)

real(DP) :: aa(3,3), det

call compute_cofac(mat, aa)
call compute_det(mat, det)
if (abs(det) .lt. TOL_Small) call die('Cannot invert singular matrix.')

inv(1:3, 1:3) = aa(1:3, 1:3) / det

return
end subroutine invert_matrix

!================================================================================

subroutine invert_matrix_int(mat, inv)
integer, intent(in) :: mat(:,:) !< (3,3)
integer, intent(out) :: inv(:,:) !< (3,3)

integer :: aa(3,3), det

call compute_cofac_int(mat, aa)
call compute_det_int(mat, det)
if (det == 0) call die('Cannot invert singular matrix.')

inv(1:3, 1:3) = aa(1:3, 1:3) / det

if (any(inv(1:3, 1:3) * det /= aa(1:3, 1:3))) then
write(0,*) 'determinant = ', det
call die('Inverse of this integer matrix is not an integer matrix.')
endif

return
end subroutine invert_matrix_int

!=====================================================================

subroutine compute_det(mat, det)
real(DP), intent(in) :: mat(:,:) !< (3,3)
real(DP), intent(out) :: det

real(DP) :: aa(3,3)

!> Compute matrix of cofactors

call compute_cofac(mat, aa)

!> Compute determinant

det = sum(mat(1, 1:3) * aa(1:3, 1))

return
end subroutine compute_det

!================================================================================

subroutine compute_det_int(mat, det)
integer, intent(in) :: mat(:,:) !< (3,3)
integer, intent(out) :: det

integer :: aa(3,3)

!> Compute matrix of cofactors

call compute_cofac_int(mat, aa)

!> Compute determinant

det = sum(mat(1, 1:3) * aa(1:3, 1))

return
end subroutine compute_det_int

!================================================================================

subroutine compute_cofac(mat, aa)
real(DP), intent(in) :: mat(:,:) !< (3,3)
real(DP), intent(out) :: aa(3,3)

!> Compute matrix of cofactors

aa(1,1) = mat(2,2) * mat(3,3) - mat(2,3) * mat(3,2)
aa(2,1) = -mat(2,1) * mat(3,3) + mat(2,3) * mat(3,1)
aa(3,1) = mat(2,1) * mat(3,2) - mat(2,2) * mat(3,1)
aa(1,2) = -mat(1,2) * mat(3,3) + mat(1,3) * mat(3,2)
aa(2,2) = mat(1,1) * mat(3,3) - mat(1,3) * mat(3,1)
aa(3,2) = -mat(1,1) * mat(3,2) + mat(1,2) * mat(3,1)
aa(1,3) = mat(1,2) * mat(2,3) - mat(1,3) * mat(2,2)
aa(2,3) = -mat(1,1) * mat(2,3) + mat(1,3) * mat(2,1)
aa(3,3) = mat(1,1) * mat(2,2) - mat(1,2) * mat(2,1)

return
end subroutine compute_cofac

!================================================================================

subroutine compute_cofac_int(mat, aa)
integer, intent(in) :: mat(:,:) !< (3,3)
integer, intent(out) :: aa(3,3)

!> Compute matrix of cofactors

aa(1,1) = mat(2,2) * mat(3,3) - mat(2,3) * mat(3,2)
aa(2,1) = -mat(2,1) * mat(3,3) + mat(2,3) * mat(3,1)
aa(3,1) = mat(2,1) * mat(3,2) - mat(2,2) * mat(3,1)
aa(1,2) = -mat(1,2) * mat(3,3) + mat(1,3) * mat(3,2)
aa(2,2) = mat(1,1) * mat(3,3) - mat(1,3) * mat(3,1)
aa(3,2) = -mat(1,1) * mat(3,2) + mat(1,2) * mat(3,1)
aa(1,3) = mat(1,2) * mat(2,3) - mat(1,3) * mat(2,2)
aa(2,3) = -mat(1,1) * mat(2,3) + mat(1,3) * mat(2,1)
aa(3,3) = mat(1,1) * mat(2,2) - mat(1,2) * mat(2,1)

return
end subroutine compute_cofac_int

!================================================================================

subroutine procmem(mem,nmpinode,nfreq_group)
real(DP), intent(out) :: mem
integer, intent(out) :: nmpinode
integer, intent(in), optional :: nfreq_group

integer :: ierr,eof,info,iunit,m,n,p,i,j,pagesize
real(DP) :: x,y,mac_m,mac_n
! integer :: ntot
! real(DP) :: xtot,ytot ! we do not use the total memory actually
character*80 :: s, filename
character*80, allocatable :: a(:)
integer, allocatable :: b(:)

!-----------------------------------------------------
!> determine the amount of free memory per node in kB

m=0
iunit=14
x=0

call open_file(unit=iunit,file='/proc/meminfo',form='formatted',iostat=ierr,status='old')
if (ierr.eq.0) then
eof=0
do while(eof.eq.0)
read(iunit,'(a)',iostat=eof)s
if (s(1:7).eq."MemFree") then
read(s(9:),*)n
m=m+n
endif
! if (s(1:8).eq."MemTotal") then
! read(s(10:),*)ntot
! endif
if (s(1:6).eq."Cached") then
read(s(8:),*)n
m=m+n
endif
enddo
x=dble(m)/dble(peinf%npes)
call close_file(iunit)
endif

if(m == 0) then
!> this is for Mac OS
!! total memory is accessible instead from sysctl -n hw.usermem
write(filename,'(a,i9.9)') 'vm_stat_', peinf%inode
call system("vm_stat > " + TRUNC(filename) + " 2> /dev/null")
!> Fortran 2008 would use execute_command_line instead
!! even if the command failed, still open file in order to delete it
call open_file(unit=iunit,file=TRUNC(filename),form='formatted',iostat=ierr,status='old')
if (ierr.eq.0) then
eof=0
do while(eof.eq.0)
read(iunit,'(a)',iostat=eof)s
if (s(1:45).eq."Mach Virtual Memory Statistics: (page size of") then
read(s(46:),*)pagesize ! in bytes
endif
if (s(1:11).eq."Pages free:") then
read(s(12:),*) mac_n
mac_m = mac_m + mac_n
endif
if (s(1:18).eq."Pages speculative:") then
read(s(19:),*) mac_n
mac_m = mac_m + mac_n
endif
enddo
call close_file(iunit, delete = .true.)
x = mac_m * dble(pagesize) / dble(peinf%npes * 1024) ! to kB
endif
endif

!> === Example output from vm_stat ===
!! Mach Virtual Memory Statistics: (page size of 4096 bytes)
!! Pages free: 2886.
!! Pages active: 139635.
!! Pages inactive: 66906.
!! Pages speculative: 2376.
!! Pages wired down: 50096.
!! "Translation faults": 123564742.
!! Pages copy-on-write: 10525831.
!! Pages zero filled: 53274329.
!! Pages reactivated: 739514.
!! Pageins: 2282166.
!! Pageouts: 306727.
!! Object cache: 25 hits of 522230 lookups (0% hit rate)

if(m == 0 .and. mac_m == 0) then ! BSD
!> http://mario79t.wordpress.com/2008/08/29/memory-usage-on-freebsd/
!! -bash-2.05b$ sysctl vm.stats.vm.v_free_count
!! vm.stats.vm.v_free_count: 29835
!! -bash-2.05b$ sysctl vm.stats.vm.v_page_count
!! vm.stats.vm.v_page_count: 124419
!! -bash-2.05b$ sysctl hw.pagesize
!! hw.pagesize: 4096
write(filename,'(a,i9.9)') 'sysctl_', peinf%inode
call system("sysctl -a > " + TRUNC(filename) + " 2> /dev/null")
!> Fortran 2008 would use execute_command_line instead
!! even if the command failed, still open file in order to delete it
call open_file(unit=iunit,file=TRUNC(filename),form='formatted',iostat=ierr,status='old')
if (ierr.eq.0) then
eof=0
do while(eof.eq.0)
read(iunit,'(a)',iostat=eof)s
if (s(1:12).eq."hw.pagesize:") then
read(s(13:),*)pagesize ! in bytes
endif
if (s(1:25).eq."vm.stats.vm.v_free_count:") then
read(s(26:),*) mac_n
mac_m = mac_m + mac_n
endif
if (s(1:26).eq."vm.stats.vm.v_cache_count:") then
read(s(27:),*) mac_n
mac_m = mac_m + mac_n
endif
enddo
call close_file(iunit, delete = .true.)
x = mac_m * dble(pagesize) / dble(peinf%npes * 1024) ! to kB
endif
endif

! xtot=dble(ntot)/dble(peinf%npes)

y=x
! ytot=xtot

!----------------------------------------------
!> determine the number of processors per node
if(present(nfreq_group)) then
allocate(a (peinf%npes_orig))
else
allocate(a (peinf%npes))
endif
info = hostnam(a(peinf%inode + 1))
! write(a(peinf%inode+1),'(a4,i16.16)') 'HOST', peinf%inode

if (peinf%inode.eq.0) then
allocate(b (peinf%npes))
b(:)=0
do i=1,peinf%npes
do j=1,peinf%npes
if (trim(a(j)).eq.trim(a(i))) b(i)=b(i)+1
enddo
enddo
p=0
do i=1,peinf%npes
if (p.lt.b(i)) p=b(i)
enddo
if(allocated(b))then;deallocate(b);endif
endif
if(allocated(a))then;deallocate(a);endif

!-----------------------------------
!> report the available memory in B

if (p.gt.1) y=y/dble(p)
mem=y*1024.0d0

!-----------------------------------
!> report the number of MPI processes per node

nmpinode=p

!-----------------------------------
!> warn if zero memory

if (mem .lt. TOL_Small .and. peinf%inode .eq. 0) then
write(0,666)
666 format(1x,'WARNING: estimation of memory available is zero, probably failed.',/)
endif

return
end subroutine procmem

!================================================================================

!> for memory estimation, tell what size of complex(DPC) type is
integer function sizeof_scalar()

# 555

complex(DPC) :: dummy
sizeof_scalar = sizeof(dummy)

end function sizeof_scalar

!================================================================================

real(DP) function voigt(x, sigma, gamma)
real(DP), intent(in) :: x, sigma, gamma

real(DP), parameter :: a0 = 122.607931777104326d0
real(DP), parameter :: a1 = 214.382388694706425d0
real(DP), parameter :: a2 = 181.928533092181549d0
real(DP), parameter :: a3 = 93.155580458138441d0
real(DP), parameter :: a4 = 30.180142196210589d0
real(DP), parameter :: a5 = 5.912626209773153d0
real(DP), parameter :: a6 = 0.564189583562615d0
real(DP), parameter :: b0 = 122.607931773875350d0
real(DP), parameter :: b1 = 352.730625110963558d0
real(DP), parameter :: b2 = 457.334478783897737d0
real(DP), parameter :: b3 = 348.703917719495792d0
real(DP), parameter :: b4 = 170.354001821091472d0
real(DP), parameter :: b5 = 53.992906912940207d0
real(DP), parameter :: b6 = 10.479857114260399d0

complex(DPC) :: z, zh, f

if (sigma .lt. TOL_Zero .or. gamma.lt.-TOL_Zero) &
call die('Voigt function invalid broadening')

z = cmplx(abs(x),gamma,kind=DPC) / (sqrt(2.0d0) * sigma)
zh = cmplx(aimag(z),-dble(z),kind=DPC)
f = ((((((a6*zh + a5)*zh + a4)*zh + a3)*zh + a2)*zh + a1)*zh + a0) / &
(((((((zh + b6)*zh + b5)*zh + b4)*zh + b3)*zh + b2)*zh + b1)*zh + b0)
if (x .lt. 0.0d0) f = conjg(f)
voigt = dble(f) / (sqrt(2.0d0 * PI_D) * sigma)

return
end function voigt

!================================================================================

subroutine k_range(kpt, gpt, tol)
real(DP), intent(inout) :: kpt(3)
integer, intent(out) :: gpt(3)
real(DP), intent(in) :: tol

integer :: ii

! no push_sub, called too frequently

do ii = 1, 3
gpt(ii) = 0
do while (kpt(ii) .lt. -tol)
gpt(ii) = gpt(ii) + 1
kpt(ii) = kpt(ii) + 1.0d0
enddo
do while (kpt(ii) .ge. 1.0d0 - tol)
gpt(ii) = gpt(ii) - 1
kpt(ii) = kpt(ii) - 1.0d0
enddo
enddo

return
end subroutine k_range

!=====================================================================

integer function bse_index(ik, ic, iv, is, xct, ncband, nvband)
integer, intent(in) :: ik, ic, iv, is
type(xctinfo), intent(in) :: xct
integer, optional, intent(in) :: ncband !< default is xct%ncb_fi
integer, optional, intent(in) :: nvband !< default is xct%nvb_fi

integer :: ncband_, nvband_

! The optionals are needed for the parallelization scheme sometimes, to be set to 1.
if(present(ncband)) then
ncband_ = ncband
else
ncband_ = xct%ncb_fi
endif

if(present(nvband)) then
nvband_ = nvband
else
nvband_ = xct%nvb_fi
endif

! no push_sub, called too frequently

bse_index = is + (iv - 1 + (ic - 1 + (ik - 1)*ncband_)*nvband_)*xct%nspin
return
end function bse_index

!=====================================================================

end module misc_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/fullbz.f90 > Common/fullbz.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/fullbz.p.f -o Common/fullbz.o -module Common/
# 1 "Common/fullbz.p.f"
!-----------------------------------------------------------------------
!
! module fullbz_m
!
! Routines: fullbz
!
! If wigner_seitz = .true. (for BSE, PlotXct, NonLinearOptics)
! Uses a Wigner-Seitz construction to define the Brillouin zone.
! If wigner_seitz = .false. (for Epsilon, Sigma)
! Uses the usual "box" BZ.
!
! input: crys,syms type
! ntran (number of symmetry operations)
! gr%nr
! gr%rk
!
! output: gr type (except gr%nr, gr%rk)
!
!-----------------------------------------------------------------------

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 22 "Common/Common/fullbz.f90" 2

module fullbz_m

use global_m
use misc_m
implicit none

private

public :: fullbz, dealloc_grid

contains

subroutine fullbz(crys,syms,gr,ntran,skip_checkbz,wigner_seitz,paranoid,do_nothing,nfix)
type (crystal), intent(in) :: crys
type (symmetry), intent(in) :: syms
type (grid), intent(inout) :: gr
integer, intent(in) :: ntran !< number of sym ops, typically syms%ntrans
logical, intent(out) :: skip_checkbz
logical, intent(in) :: wigner_seitz !< do a Wigner-Seitz construction
logical, intent(in) :: paranoid !< perform paranoia check: no k-pts differ by G-vector
logical, optional, intent(in) :: do_nothing !< initialize without performing any checks.
integer, optional, intent(in) :: nfix !< don`t unfold the first nfix points

integer :: ii,jj,kk,it,ir,if,i1,i2,i3,gpt(3),iostat_c,ntran_
real(DP) :: tmpf(3),tmpfm(3),length,lmin,fq(3)
real(DP), allocatable :: fk(:,:),kg0(:,:)
integer, allocatable :: indr(:),itran(:)
logical :: found
!
! i r,nr k-points in irr bz
! o fk,gr%nf k-points in full bz
! o sz radius of a spherical subzone equivalent to
! one point in the set fk
!
! Loop over ir-points
!

if(present(do_nothing)) then
if(do_nothing) then
if(wigner_seitz .or. paranoid) call die("bug: cannot call fullbz with do_nothing and wigner_seitz or paranoid.")
gr%nf=gr%nr
gr%sz=2.0d0*PI_D*(3.0d0/(4.0d0*PI_D*gr%nf*crys%celvol))**(1.0d0/3.0d0)
allocate(gr%kg0 (3,gr%nf))
allocate(gr%f (3,gr%nf))
allocate(gr%itran (gr%nf))
allocate(gr%indr (gr%nf))
gr%kg0(:,:)=0
gr%itran(:)=1
gr%f(:,:)=gr%r(:,:)
do ii=1,gr%nf
gr%indr(ii)=ii
enddo
skip_checkbz = .true.

return
endif
endif

allocate(fk (3,gr%nr*ntran))
allocate(indr (gr%nr*ntran))
allocate(itran (gr%nr*ntran))

call open_file(unit=21,file='fullbz.dat',status='old',iostat=iostat_c)
skip_checkbz = (iostat_c==0)
if (skip_checkbz) then
write(6,'(3x,a)') 'Reading the full Brillouin Zone from fullbz.dat'
write(6,'(3x,a)') 'Will not be checking if the points there form a full zone'
read(21,*) gr%nf
do ii=1,gr%nf
read(21,*) fk(1:3,ii),itran(ii),indr(ii)
enddo
call close_file(21)
! This is just in case we want to do wigner_seitz or paranoid
else
gr%nf=0

do ir=1,gr%nr
!
! Loop over transformations
!
ntran_ = ntran
if (present(nfix)) then
if (ir<=nfix) ntran_ = 1
endif
do it=1,ntran_
!
! Rotate gr%r and put into tmpf
!
tmpf(:) = matmul(dble(syms%mtrx(:,:,it)),gr%r(:,ir))

call k_range(tmpf, gpt, TOL_Small)
!
! Compare to other points in full zone
!
found = .false.
do if=1,gr%nf
if(all(abs(tmpf(1:3)-fk(1:3,if)).lt.TOL_Small)) then
found = .true.
exit
endif
enddo
if(found) cycle ! skip adding it
!
! Store new kpoint in fbz
!
gr%nf=gr%nf+1
if (gr%nf > gr%nr * ntran) call die('fullbz internal error')
fk(1:3,gr%nf)=tmpf(1:3)
!
! Store index of rotation itran and corresponding IBZ point
!
itran(gr%nf)=it
indr(gr%nf)=ir

enddo !end loop over symmetries
enddo !end loop over the q-points from epsmat and eps0mat
endif ! whether reading from fullbz.dat

!
! SIB: Now that we have the full BZ with components [0,1), we
! will move each point into the Wigner-Seitz cell by adding G-vectors
! to it until we get the shortest length vector we can. Then we find
! the appropriate Umklapp vector as well (kg0).
!

if(wigner_seitz) then
allocate(kg0 (3,gr%nr*ntran))

do ii=1,gr%nf
tmpf(:) = fk(:,ii)
lmin = 1.0d10
do i1=-ncell+1,ncell
do i2=-ncell+1,ncell
do i3=-ncell+1,ncell
fq(1) = tmpf(1) - i1
fq(2) = tmpf(2) - i2
fq(3) = tmpf(3) - i3
length = DOT_PRODUCT(fq,MATMUL(crys%bdot,fq))
if (length.lt.lmin) then
lmin = length
tmpfm(:) = fq(:)
endif
enddo
enddo
enddo
fk(:,ii) = tmpfm
!
! SIB: Find Umklapp (kg0) a.k.a. translation
!
tmpf = MATMUL(dble(syms%mtrx(:,:,itran(ii))),gr%r(:,indr(ii)))
tmpf(:) = fk(:,ii) - tmpf
do jj=1,3
if (tmpf(jj).ge.0.0) kg0(jj,ii)=tmpf(jj)+TOL_Small
if (tmpf(jj).lt.0.0) kg0(jj,ii)=tmpf(jj)-TOL_Small
enddo

enddo !over full zone (ii)

allocate(gr%kg0 (3,gr%nf))
gr%kg0(1:3,1:gr%nf)=kg0(1:3,1:gr%nf)
if(allocated(kg0))then;deallocate(kg0);endif

else
nullify(gr%kg0)
endif

!------------------------------------------------------------------------
! SIB: Paranoia check. We will compare all pairs of points in the full
! zone to each other in order to see if any of them differ by a G-vector.
! If they do, we are in big trouble and stop!

if(paranoid) then
ii_loop: do ii=1,gr%nf
do jj=1,ii-1
tmpf = abs(fk(:,ii)-fk(:,jj))
! after this loop, tmpf contains how far each component of fii-fjj is
! from the closest integer to it.
do kk=1,3
it = tmpf(kk)
tmpf(kk) = tmpf(kk)-it
if (tmpf(kk).ge.0.5) tmpf(kk)=1.0-tmpf(kk)
enddo
! if fkii-fkjj is very close to an integer vector (G-vector), trouble!
if (sum(abs(tmpf)).le.TOL_Small) then
write(0,123) ii,jj,fk(:,ii)-fk(:,jj)
123 format('equiv kpts',i4,' and ',i4,' diff=',3f10.5)
call die('equivalent points found in the full BZ')
endif
enddo
enddo ii_loop
endif

!------------------------------------------------------------------------
! SIB: Now store all gathered information where it belongs

allocate(gr%f (3,gr%nf))
allocate(gr%indr (gr%nf))
allocate(gr%itran (gr%nf))
gr%f(1:3,1:gr%nf)=fk(1:3,1:gr%nf)
gr%indr(1:gr%nf)=indr(1:gr%nf)
gr%itran(1:gr%nf)=itran(1:gr%nf)
if(allocated(fk))then;deallocate(fk);endif
if(allocated(indr))then;deallocate(indr);endif
if(allocated(itran))then;deallocate(itran);endif

! Compute radius of spherical subzone
! assuming bz filled with gr%nf spheres

gr%sz=2.0d0*PI_D*(3.0d0/(4.0d0*PI_D*gr%nf*crys%celvol))**(1.0d0/3.0d0)

if (ntran.eq.1 .and. gr%nf.ne.gr%nr .and. paranoid) then
write(0,*) gr%nf, ' and ', gr%nr
call die('fullbz paranoia check failed')
endif

return
end subroutine fullbz

!-----------------------------------------------------------------------
subroutine dealloc_grid(gr)
type(grid), intent(inout) :: gr

if(associated(gr%r))then;deallocate(gr%r);nullify(gr%r);endif
if(associated(gr%f))then;deallocate(gr%f);nullify(gr%f);endif
if(associated(gr%indr))then;deallocate(gr%indr);nullify(gr%indr);endif
if(associated(gr%itran))then;deallocate(gr%itran);nullify(gr%itran);endif
if(associated(gr%kg0))then;deallocate(gr%kg0);nullify(gr%kg0);endif

return
end subroutine dealloc_grid

end module fullbz_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/subgrp.f90 > Common/subgrp.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/subgrp.p.f -o Common/subgrp.o -module Common/
# 1 "Common/subgrp.p.f"
!==========================================================================
!
! Routines:
!
! 1. subgrp() Originally By ? Last Modified 6/12/2008 (JRD)
!
! Determines a subgroup of the symmetry group that preserves a q-vector.
!
!===========================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/subgrp.f90" 2

subroutine subgrp(qq, syms)
use global_m
use misc_m
implicit none

type (symmetry), intent(inout) :: syms
real(DP), intent(in) :: qq(3)

integer :: it, kg(3)
real(DP) :: qk(3), dqk(3)

!---------------------
! Loop over transformations testing for r(q) = q + kg0

syms%rq = qq
syms%ntranq = 0
do it = 1, syms%ntran
qk(1:3) = matmul(syms%mtrx(1:3, 1:3, it), qq(1:3))
dqk(1:3) = qk(1:3) - qq(1:3)
call k_range(dqk(1:3), kg(1:3), TOL_Small)

if (all(abs(dqk(1:3)) .lt. TOL_Small)) then
!--------------------
! Store index of element of subgroup
syms%ntranq = syms%ntranq + 1
syms%indsub(syms%ntranq) = it
syms%kgzero(1:3, syms%ntranq) = -kg(1:3)
endif
enddo

return
end subroutine subgrp
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/gmap.f90 > Common/gmap.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/gmap.p.f -o Common/gmap.o -module Common/
# 1 "Common/gmap.p.f"
!============================================================================
!
! Routines:
!
! (1) gmap Originally by ? Last Modified: 1/24/2011 (gsm)
!
! Find the index array and phases needed to map G-vectors for a
! wavefunction at one k-point to the corresponding wavefunction
! at a symmetry-related k-point. This routine is flavorless.
! In the real version, pass dphase. In complex, pass zphase.
!
!============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 15 "Common/Common/gmap.f90" 2

module gmap_m

use global_m
use misc_m

implicit none

private

public :: gmap

interface gmap
module procedure dgmap, zgmap
end interface gmap

contains

subroutine dgmap(gvec, syms, ngk, itran, kgq, isortc, isorti, ind, phase, die_outside_sphere)
type (gspace), intent(in) :: gvec !< uses gvec%components(:,isrtc(1:ngk)), and index_vec
type (symmetry), intent(in) :: syms !< uses syms%mtrx(:,:,itran) & syms%tnp(:,itran)
integer, intent(in) :: ngk !< number of g-vector entries in a wavefunction
integer, intent(in) :: itran !< index of transformation
integer, intent(in) :: kgq(3) !< an umklapp vector (i.e. integer 3-vector)
integer, intent(in) :: isortc(:) !< index array for R(q) (1:ngk)
integer, intent(in) :: isorti(:) !< inverse index array for q (1:gvec%ng)
integer, intent(out) :: ind(:) !< indices for the vectors inv(symm(itran))*(g+kgq) (ngk)
real(DP), intent(out) :: phase(:) !< exp(-i*(g+kgq).dot.syms%tnp(itran)) (ngk)
logical, intent(in) :: die_outside_sphere !< specifies whether to die if G-vectors are falling outside of the sphere

call gmap_base(gvec, syms, ngk, itran, kgq, isortc, isorti, ind, die_outside_sphere, dphase = phase)

return
end subroutine dgmap

!===============================================================================

subroutine zgmap(gvec, syms, ngk, itran, kgq, isortc, isorti, ind, phase, die_outside_sphere)
type (gspace), intent(in) :: gvec !< uses gvec%components(:,isrtc(1:ngk)), and index_vec
type (symmetry), intent(in) :: syms !< uses syms%mtrx(:,:,itran) & syms%tnp(:,itran)
integer, intent(in) :: ngk !< number of g-vector entries in a wavefunction
integer, intent(in) :: itran !< index of transformation
integer, intent(in) :: kgq(3) !< an umklapp vector (i.e. integer 3-vector)
integer, intent(in) :: isortc(:) !< index array for R(q) (1:ngk)
integer, intent(in) :: isorti(:) !< inverse index array for q (1:gvec%ng)
integer, intent(out) :: ind(:) !< indices for the vectors inv(symm(itran))*(g+kgq) (ngk)
complex(DPC), intent(out) :: phase(:) !< exp(-i*(g+kgq).dot.syms%tnp(itran)) (ngk)
logical, intent(in) :: die_outside_sphere !< specifies whether to die if G-vectors are falling outside of the sphere

call gmap_base(gvec, syms, ngk, itran, kgq, isortc, isorti, ind, die_outside_sphere, zphase = phase)

return
end subroutine zgmap

!===============================================================================

subroutine gmap_base(gvec, syms, ngk, itran, kgq, isortc, isorti, ind, die_outside_sphere, dphase, zphase)
type (gspace), intent(in) :: gvec !< uses gvec%components(:,isrtc(1:ngk)), and index_vec
type (symmetry), intent(in) :: syms !< uses syms%mtrx(:,:,itran) & syms%tnp(:,itran)
integer, intent(in) :: ngk !< number of g-vector entries in a wavefunction
integer, intent(in) :: itran !< index of transformation
integer, intent(in) :: kgq(3) !< an umklapp vector (i.e. integer 3-vector)
integer, intent(in) :: isortc(:) !< index array for R(q) (1:ngk)
integer, intent(in) :: isorti(:) !< inverse index array for q (1:gvec%ng)
integer, intent(out) :: ind(:) !< indices for the vectors inv(symm(itran))*(g+kgq) (ngk)
logical, intent(in) :: die_outside_sphere !< specifies whether to die if G-vectors are falling outside of the sphere
real(DP), optional, intent(out) :: dphase(:) !< exp(-i*(g+kgq).dot.syms%tnp(itran)) (ngk)
complex(DPC), optional, intent(out) :: zphase(:) !< exp(-i*(g+kgq).dot.syms%tnp(itran)) (ngk)

integer :: ig, kd(3), kadd, kgrad, kgrad1
integer :: kg(3), kgr(3), mtrxi(3,3), nout, nin
real(DP) :: fi

if(present(dphase) .and. present(zphase)) then
call die("gmap: cannot pass both dphase and zphase")
else if(.not. present(dphase) .and. .not. present(zphase)) then
call die("gmap: must pass either dphase or zphase")
endif

if(ngk > gvec%ng) call die("gmap: ngk (wfn cutoff) is greater than gvec%ng (rho cutoff)")

if(ubound(isorti, 1) < gvec%ng) call die("gmap: isorti size < gvec%ng")
! if(any(isorti(1:gvec%ng) < 1)) call die("gmap: isorti cannot be less than 1.")
if(any(isorti(1:gvec%ng) > gvec%ng)) call die("gmap: isorti cannot be greater than gvec%ng.")

if(ubound(isortc, 1) < ngk) call die("gmap: isortc size < ngk")
if(any(isortc(1:ngk) < 1)) call die("gmap: isortc cannot be less than 1.")
if(any(isortc(1:ngk) > gvec%ng)) call die("gmap: isortc cannot be greater than ng.")

if(ubound(gvec%index_vec, 1) /= gvec%nFFTgridpts) call die("gmap: gvec%index_vec has wrong size")
if(any(gvec%index_vec(1:gvec%nFFTgridpts) < 0)) call die("gmap: index_vec cannot be less than 0")
if(any(gvec%index_vec(1:gvec%nFFTgridpts) > gvec%ng)) call die("gmap: index_vec cannot be greater than ng")

if(present(dphase)) then
if(ubound(dphase, 1) < ngk) call die("gmap: dphase size < ngk")
else
if(ubound(zphase, 1) < ngk) call die("gmap: zphase size < ngk")
endif
if(ubound(ind, 1) < ngk) call die("gmap: ind size < ngk")

! Invert rotation matrix that gives rq

call invert_matrix_int(syms%mtrx(1:3, 1:3, itran), mtrxi(1:3, 1:3))

! JRD: Temporary Debugging

! write(6,*) peinf%inode,'itran: ',itran
! write(6,*) peinf%inode,'mtrxi: '
! do i = 1, 3
! write(6,*) peinf%inode,(mtrxi(i,j),j=1,3)
! enddo
! write(6,*) peinf%inode,'kgq',kgq

! Loop over g-vectors in function of r(q)

nout = 0 ! number of waves outside sphere
nin = 0 ! number of waves inside sphere

do ig = 1, ngk

! kg = g(ig) + kgq

kg(1:3) = gvec%components(1:3, isortc(ig)) + kgq(1:3)

! kgr = (r**-1) kg

kgr(1:3) = MATMUL(mtrxi(1:3, 1:3), kg(1:3))

! Compute address of kgr -> kgrad

kd(1:3) = kgr(1:3) + gvec%FFTgrid(1:3) / 2 + 1
if (any(kd(1:3) .lt. 1 .or. kd(1:3) .gt. gvec%FFTgrid(1:3))) then
call die('gmap: kd out of bounds')
endif
kadd = ((kd(1) - 1) * gvec%FFTgrid(2) + kd(2) - 1) * gvec%FFTgrid(3) + kd(3)
kgrad1 = gvec%index_vec(kadd) ! index_vec relate cube and sphere
if (kgrad1 .lt. 1 .or. kgrad1 .gt. gvec%ng) then
write(0,*) 'itran = ', itran, 'ig = ', ig, ', kadd = ', kadd, ', kgrad1 = ', kgrad1
call die('gmap: G-vectors falling outside of the charge-density G-sphere')
endif
kgrad = isorti(kgrad1)

! SIB: if kgr is outside the sphere, then increment out counter,
! set its phase to zero, and its ind() entry to the maximum.
if (kgrad .gt. ngk) then ! outside sphere
nout = nout + 1
ind(ig) = ngk
if(present(zphase)) then
zphase(ig) = cmplx(0d0,0d0,kind=DPC)
else
dphase(ig) = 0d0
endif
! else if (kgrad < 1) then ! inside sphere
! nin = nin + 1
! ind(ig) = 1
! if(present(zphase)) then
! zphase(ig) = cmplx(0d0,0d0,kind=DPC)
! else
! dphase(ig) = 0d0
! endif
else
! SIB: Otherwise, record the index of kgr (kgrad) into ind(ig)
! and compute the phase = exp(-i*kg.dot.syms%tnp(:,itran))
ind(ig) = kgrad
fi = dot_product(dble(kg(:)), syms%tnp(:,itran))

if(present(zphase)) then
zphase(ig) = cmplx(cos(fi),-sin(fi),kind=DPC)
else

! DAS: The imaginary part can be thrown away because it is always zero
! if we have inversion and time-reversal symmetries, and so can use the real version.
! phase = +/- 1. Otherwise the wavefunction would not be normalized.
! c(G) -> c(G) e^iGt with fractional translation.
! c(G) e^iGt = c(-G)* e^-iGt by time-reversal symmetry
! = c(G)* e^-iGt by inversion symmetry. c(G) = c(G)* since real.
! Therefore e^iGt = e^-iGt. e^iGt is real, and hence 1 or -1.
! Note there is also a global phase e^ikt, but it is just a convention
! and can be safely ignored here.

dphase(ig) = cos(fi)

if(abs(abs(dphase(ig)) - 1) .gt. TOL_Small) then
write(0,'(a,i8,a,f12.8,a)') 'phase(', ig, ') = ', dphase(ig), ' != +/- 1'
call die("Illegal non-unity phase in gmap, error in fractional translation.")
endif
if(abs(sin(fi)) .gt. TOL_Small) then
write(0,'(a,i8,a,f12.8)') 'Im phase(', ig, ') = ', -sin(fi)
call die("Illegal complex phase in gmap, error in fractional translation.")
endif
endif
endif
enddo !end loop over g-vectors (ig)

if (die_outside_sphere .and. nout .gt. 0) then
call die('G-vectors are falling outside of the sphere in gmap')
endif

! if (die_outside_sphere .and. nin .gt. 0) then
! call die('G-vectors are falling inside of the sphere in gmap')
! endif

return
end subroutine gmap_base

!===============================================================================

end module gmap_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/find_kpt_match.f90 > Common/find_kpt_match.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/find_kpt_match.p.f -o Common/find_kpt_match.o -module Common/
# 1 "Common/find_kpt_match.p.f"
!==========================================================================
!
! Routines:
!
! (1) find_kpt_match() Originally by SIB
!
! Look for rkq in the list of kpoints rotated by the symmetries.
! If found, it puts its index in ikrkq, itqq is the index
! of the symmetry that worked, and kgqq is an "umklapp" vector (i.e.
! integer 3-vector) so that rkq = symm*kvec + kgqq.
!
!==========================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 15 "Common/Common/find_kpt_match.f90" 2

module find_kpt_match_m

use global_m
implicit none

private
public :: find_kpt_match

contains

subroutine find_kpt_match(kp_point, syms, rkq, ikrkq, itqq, kgqq)
type(kpoints), intent(in) :: kp_point
type(symmetry), intent(in) :: syms
real(DP), intent(in) :: rkq(3)
integer, intent(out) :: ikrkq
integer, intent(out) :: itqq
integer, intent(out) :: kgqq(3)

integer :: ik, itq, ii
real(DP) :: qk(3), del(3)

ikrkq = 0
ik_loop: do ik = 1, kp_point%nrk
do itq = 1, syms%ntran
qk(1:3) = matmul(syms%mtrx(1:3, 1:3, itq), kp_point%rk(1:3, ik))
do ii = 1, 3
del(ii) = rkq(ii) - qk(ii)
if(del(ii).ge.0.0d0) kgqq(ii) = del(ii) + TOL_Small
if(del(ii).lt.0.0d0) kgqq(ii) = del(ii) - TOL_Small
enddo
if(all(abs(del(1:3)-kgqq(1:3)) .lt. TOL_Small)) then
ikrkq=ik
itqq = itq
exit ik_loop
endif
enddo
enddo ik_loop

return

end subroutine find_kpt_match

end module find_kpt_match_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/scalapack.f90 > Common/scalapack.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/scalapack.p.f -o Common/scalapack.o -module Common/
# 1 "Common/scalapack.p.f"
!===========================================================================
!
! Modules:
!
! scalapack_m Originally By DAS
!
! Functions, types, and interfaces for ScaLAPACK/BLACS.
! Interfaces are from http://www.netlib.org/scalapack/tools, double, complex16
! and from http://www.netlib.org/blacs/BLACS/QRef.html (entered manually...)
! Every ScaLAPACK/BLACS function used in the code should be listed here, and this
! module should be used in every routine containing ScaLAPACK/BLACS calls to ensure
! the argument types are correct.
!
!============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 17 "Common/Common/scalapack.f90" 2

module scalapack_m

use global_m
implicit none

private

public :: &
scalapack, &
blacs_setup, &
layout_scalapack, &
iceil, &
descinit, &
descset, &
pdgesv, &
pzgesv, &
pdsyevx, &
pdgeqrf, &
pzgeqrf, &
pzheevx, &
pdgemr2d, &
pzgemr2d, &
blacs_get, &
blacs_gridinit, &
blacs_gridmap, &
blacs_gridexit, &
blacs_exit

!-----------------------------

type scalapack
integer :: nprow !< the number of processors in a row of your processor grid
integer :: npcol !< the number of processors in a column of your processor grid
integer :: nbl !< the linear dimension of a block of a distributed matrix
integer :: myprow !< the processor`s row coordinate in your processor grid
integer :: mypcol !< the processor`s column coordinate in your processor grid
integer :: npr !< the number of rows of the matrix the processor owns
integer :: npc !< the number of columns of the matrix the processor owns
integer :: icntxt !< BLACS context; see BLACS documentation
integer, pointer :: npcd(:) !< global list of the number of cols of the matrix owned by all processors
integer, pointer :: nprd(:) !< global list of the number of rows of the matrix owned by all processors
integer, pointer :: isrtxrow(:) !< isrtxrow/isrtxcol give the sorted index of the gvector in a given block
integer, pointer :: isrtxcol(:) !! owned by a processor in terms of the whole list of gvectors
integer, pointer :: imycol(:) !< imyrow/imycol give the row/column index of a g-vector owned by a given
integer, pointer :: imyrow(:) !! processor in the whole matrix
integer, pointer :: imycolinv(:) !< inverse of imycol
integer, pointer :: imyrowinv(:) !! inverse of imyrow
integer, pointer :: imycold(:,:) !< imycold/imyrowd are global lists of the row/column index of g-vectors
integer, pointer :: imyrowd(:,:) !! owned by all the processors in the whole matrix
end type scalapack

!> SCALAPACK
interface
INTEGER FUNCTION ICEIL( INUM, IDENOM )
implicit none
INTEGER IDENOM, INUM
end FUNCTION ICEIL
end interface

interface
SUBROUTINE DESCINIT( DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT, LLD, INFO )
implicit none
INTEGER ICSRC, ICTXT, INFO, IRSRC, LLD, M, MB, N, NB
INTEGER DESC( * )
end SUBROUTINE DESCINIT
end interface

interface
SUBROUTINE DESCSET( DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT, LLD )
implicit none
INTEGER ICSRC, ICTXT, IRSRC, LLD, M, MB, N, NB
INTEGER DESC( * )
end SUBROUTINE DESCSET
end interface

interface
SUBROUTINE PDGESV( N, NRHS, A, IA, JA, DESCA, IPIV, B, IB, JB, DESCB, INFO )
implicit none
INTEGER IA, IB, INFO, JA, JB, N, NRHS
INTEGER DESCA( * ), DESCB( * ), IPIV( * )
DOUBLE PRECISION A( * ), B( * )
end SUBROUTINE PDGESV
end interface

interface
SUBROUTINE PZGESV( N, NRHS, A, IA, JA, DESCA, IPIV, B, IB, JB, DESCB, INFO )
implicit none
INTEGER IA, IB, INFO, JA, JB, N, NRHS
INTEGER DESCA( * ), DESCB( * ), IPIV( * )
COMPLEX*16 A( * ), B( * )
end SUBROUTINE PZGESV
end interface

interface
SUBROUTINE PDSYEVX( JOBZ, RANGE, UPLO, N, A, IA, JA, DESCA, VL, &
VU, IL, IU, ABSTOL, M, NZ, W, ORFAC, Z, IZ, JZ, DESCZ, WORK, LWORK, IWORK, LIWORK, IFAIL, &
ICLUSTR, GAP, INFO )
implicit none
CHARACTER JOBZ, RANGE, UPLO
INTEGER IA, IL, INFO, IU, IZ, JA, JZ, LIWORK, LWORK, M, N, NZ
DOUBLE PRECISION ABSTOL, ORFAC, VL, VU
INTEGER DESCA( * ), DESCZ( * ), ICLUSTR( * ), IFAIL( * ), IWORK( * )
DOUBLE PRECISION A( * ), GAP( * ), W( * ), WORK( * ), Z( * )
end SUBROUTINE PDSYEVX
end interface

interface
SUBROUTINE PDGEQRF( M, N, A, IA, JA, DESCA, TAU, WORK, LWORK, INFO )
implicit none
INTEGER IA, INFO, JA, LWORK, M, N
INTEGER DESCA( * )
DOUBLE PRECISION A( * ), TAU( * ), WORK( * )
end SUBROUTINE PDGEQRF
end interface

interface
SUBROUTINE PZGEQRF( M, N, A, IA, JA, DESCA, TAU, WORK, LWORK, INFO )
implicit none
INTEGER IA, INFO, JA, LWORK, M, N
INTEGER DESCA( * )
COMPLEX*16 A( * ), TAU( * ), WORK( * )
end SUBROUTINE PZGEQRF
end interface

interface
subroutine PZHEEVX( JOBZ, RANGE, UPLO, N, A, IA, JA, DESCA, VL, &
VU, IL, IU, ABSTOL, M, NZ, W, ORFAC, Z, IZ, &
JZ, DESCZ, WORK, LWORK, RWORK, LRWORK, IWORK, &
LIWORK, IFAIL, ICLUSTR, GAP, INFO )
implicit none
character JOBZ, RANGE, UPLO
integer IA, IL, INFO, IU, IZ, JA, JZ, LIWORK, LRWORK, LWORK, M, N, NZ
double precision ABSTOL, ORFAC, VL, VU
integer DESCA( * ), DESCZ( * ), ICLUSTR( * ), IFAIL( * ), IWORK( * )
double precision GAP( * ), RWORK( * ), W( * )
complex*16 A( * ), WORK( * ), Z( * )
end subroutine PZHEEVX
end interface

interface
subroutine PDGEMR2D( M, N, A, IA, JA, DESCA, B, IB, JB, DESCB, ICNTXT)
implicit none
integer M, N, IA, JA, IB, JB, DESCA( * ), DESCB( * ), ICNTXT
double precision A( * ), B( * )
end subroutine PDGEMR2D
end interface

interface
subroutine PZGEMR2D( M, N, A, IA, JA, DESCA, B, IB, JB, DESCB, ICNTXT)
implicit none
integer M, N, IA, JA, IB, JB, DESCA( * ), DESCB( * ), ICNTXT
double complex A( * ), B( * )
end subroutine PZGEMR2D
end interface

!> BLACS
interface
subroutine blacs_get(icontxt, what, val)
implicit none
integer, intent(in) :: icontxt
integer, intent(in) :: what
integer, intent(out) :: val
end subroutine blacs_get
end interface

interface
subroutine blacs_gridinit(icontxt, order, nprow, npcol)
implicit none
integer, intent(inout) :: icontxt
character, intent(in) :: order
integer, intent(in) :: nprow
integer, intent(in) :: npcol
end subroutine blacs_gridinit
end interface

!> note: args are out of order so that ldumap,npcol are declared
!! prior to their usage as dimensions of usermap.
interface
subroutine blacs_gridmap(icontxt, usermap, ldumap, nprow, npcol)
implicit none
integer, intent(inout) :: icontxt
integer, intent(in) :: ldumap
integer, intent(in) :: nprow
integer, intent(in) :: npcol
integer, intent(in) :: usermap(ldumap,npcol)
end subroutine blacs_gridmap
end interface

interface
subroutine blacs_gridexit(icontxt)
implicit none
integer, intent(in) :: icontxt
end subroutine blacs_gridexit
end interface

interface
subroutine blacs_exit(icontxt)
implicit none
integer, intent(in) :: icontxt
end subroutine blacs_exit
end interface

interface
subroutine blacs_gridinfo(icontxt, nprow, npcol, myprow, mypcol)
implicit none
integer, intent(in) :: icontxt
integer, intent(out) :: nprow
integer, intent(out) :: npcol
integer, intent(out) :: myprow
integer, intent(out) :: mypcol
end subroutine blacs_gridinfo
end interface

contains

!>--------------------------------------------------------------------------
!! Originally by AC, last modified 6/12/2008 (JRD)
!! Figures out a p by q processor grid layout for the scalapack library.
!! This p by q grid is used to partition the matrix with a block size b.
!! The goal is to get a processor grid which is as close to "square" as
!! possible. For more details, see scalapack documentation.
!!
!! Input nproc number of processors
!! matsize size of matrix
!!
!! Output nbl block size
!! nprow processor grid row
!! npcol processor grid column
subroutine layout_scalapack(matsize, nbl, nproc, nprow, npcol)
integer, intent(in) :: matsize
integer, intent(out) :: nbl
integer, intent(in) :: nproc
integer, intent(out) :: nprow, npcol

integer :: i

!------------------
! Find processor grid

nprow = int(sqrt(dble(nproc) + 1.0d-6))

do i = nprow, 1, -1
if(mod(nproc, i) .eq. 0) exit
enddo

nprow = i
npcol = nproc/nprow

!-------------------
! Now for the block size

nbl = min(32, matsize/(max(nprow, npcol)))

!-------------------
! Ensure nonzero

nbl = max(nbl, 1)

return
end subroutine layout_scalapack

!--------------------------------------------------------------------------
subroutine blacs_setup(scal, matsize, is_row_order,nppgroup_f,nfreq_group,np_left)
type(scalapack), intent(inout) :: scal !< other elements might have been set earlier
integer, intent(in) :: matsize
logical, intent(in) :: is_row_order
integer, intent(in),optional :: nppgroup_f !< # of proc. per freq. group
integer, intent(in),optional :: nfreq_group !< number of parallel frequencies
integer, intent(in),optional :: np_left !< # of proc. leftover for parallel frequencies

character :: order
integer :: iw,ir,ic,npe
logical :: custom_grid
integer,allocatable :: usermap(:,:)

# 387
scal%npr=matsize
scal%npc=matsize
scal%nbl=matsize
scal%nprow=1
scal%npcol=1
scal%myprow=0
scal%mypcol=0

return
end subroutine blacs_setup

end module scalapack_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/lapack.f90 > Common/lapack.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/lapack.p.f -o Common/lapack.o -module Common/
# 1 "Common/lapack.p.f"
!================================================================================
!
! Modules:
!
! (1) lapack_m Originally By DAS Last Modified 1/13/2011 (das)
!
! Interfaces for LAPACK functions, taken from http://www.netlib.org/lapack/double
! and http://www.netlib.org/lapack/complex16.
! Every LAPACK function used in the code should be listed here, and this
! module should be used in every routine containing LAPACK calls to ensure
! the argument types are correct.
!
! Note that if any array name from netlib.org is X, the interface will
! be interpreted as a preprocessor macro and cause a compilation failure,
! solved by changed to lower-case x.
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 20 "Common/Common/lapack.f90" 2

module lapack_m

public ! only interfaces in this module

interface
SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
implicit none
INTEGER INFO, LDA, LDB, N, NRHS
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
end SUBROUTINE DGESV
end interface

interface
SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
implicit none
INTEGER INFO, LDA, LDB, N, NRHS
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), B( LDB, * )
end SUBROUTINE ZGESV
end interface

interface
SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, &
ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )
implicit none
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDZ, M, N
DOUBLE PRECISION ABSTOL, VL, VU
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * )
end SUBROUTINE ZHPEVX
end interface

interface
SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, &
ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )
implicit none
CHARACTER JOBZ, RANGE, UPLO
INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N
DOUBLE PRECISION ABSTOL, VL, VU
INTEGER IFAIL( * ), IWORK( * )
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * )
end SUBROUTINE ZHEEVX
end interface

interface
SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
implicit none
INTEGER INFO, LDA, M, N
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
end SUBROUTINE DGETRF
end interface

interface
SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
implicit none
INTEGER INFO, LDA, LWORK, N
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
end SUBROUTINE DGETRI
end interface

interface
SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
implicit none
INTEGER INFO, LDA, M, N
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * )
end SUBROUTINE ZGETRF
end interface

interface
SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
implicit none
INTEGER INFO, LDA, LWORK, N
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), WORK( * )
end SUBROUTINE ZGETRI
end interface

interface
SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )
implicit none
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LWORK, N
DOUBLE PRECISION RWORK( * ), W( * )
COMPLEX*16 A( LDA, * ), WORK( * )
end SUBROUTINE ZHEEV
end interface

interface
SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
implicit none
CHARACTER JOBZ, UPLO
INTEGER INFO, LDA, LWORK, N
DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * )
end SUBROUTINE DSYEV
end interface

interface
SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
implicit none
INTEGER INFO, LDA, LWORK, M, N
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
end SUBROUTINE DGEQRF
end interface

interface
SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
implicit none
INTEGER INFO, LDA, LWORK, M, N
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
end SUBROUTINE ZGEQRF
end interface

interface
SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
implicit none
INTEGER INFO, K, LDA, LWORK, M, N
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
end SUBROUTINE DORGQR
end interface

interface
SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
implicit none
INTEGER INFO, K, LDA, LWORK, M, N
COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * )
end SUBROUTINE ZUNGQR
end interface

interface
SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
implicit none
CHARACTER UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION A( LDA, * )
end SUBROUTINE DPOTRF
end interface

end module lapack_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/essl.f90 > Common/essl.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/essl.p.f -o Common/essl.o -module Common/
# 1 "Common/essl.p.f"
!================================================================================
!
! Modules:
!
! (1) essl_m Originally By DAS Last Modified 2/2/2011 (das)
!
! Interfaces for ESSL functions.
! Every ESSL function used in the code should be listed here, and this
! module should be used in every routine containing ESSL calls to ensure
! the argument types are correct.
!
! Note that routines can take extra arguments like "*100" which directs to
! go to line 100 if error 100 occurs. This is an "alternate return specifier"
! considered an obsolescent feature in Fortran 95 and Fortran 90.
! It does not appear to be possible to declare in an interface in a way
! that will not produce compilation warnings.
!
! http://publib.boulder.ibm.com/infocenter/clresctr/vxrx/index.jsp?topic=/...
!
! In the idiotic tradition of IBM programming, ESSL now bombs
! if the matrix is singular regardless even when calling
! supposedly non-bombing routines like dgeicd... so instead
! we have to catch the error #2103 which means the matrix is singular.
! Beautiful, no!?!?
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 29 "Common/Common/essl.f90" 2

module essl_m

public ! only interfaces in this module

# 105

end module essl_m
icc -E -C -P -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/inversion.F90 > Common/inversion.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/inversion.p.f -o Common/inversion.o -module Common/
# 1 "Common/inversion.p.f"
!==============================================================================
!
! Routines:
!
! (1) Xinvert_with_scalapack_d() Originally by JRD Last Modified 02/2015 (FHJ)
!
! This routine inverts a matrix which is already distributed in block
! cyclic form with ScaLAPACK.
!
! (2) Xinvert_serial() Originally by JRD Last Modified 02/2015 (FHJ)
!
! Inverts a matrix using LAPACK.
!
!==============================================================================

module inversion_m

use global_m
use lapack_m
use scalapack_m
implicit none

private

public :: &
dinvert_serial, &
zinvert_serial

contains

!overrules flavor.mk
!The following macro puts any point/array in the [-0.5, 0.5) range:
!The following macro puts any point/array in the [0, 1) range:
!Integer division of a/b rounded up*/
!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

! deprecated identifiers

! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

! very ancient version may require NOSIZEOF

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.

! path before 4.0.9 lacks SIZEOF

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?

! It is considered a bug in OPEN64 that sizeof will not work in our code.

! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit

! name of routine to get name of host program is running on

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m

! how to get the cpu time in seconds

! interface required for mclock routine (timing) to be usable

! interface required for iargc routine (command-line arguments) to be usable

! ftell gives you the current location in a file, to fseek back to it

! if no fseek, ftell is useless

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
!===========================================================================
!
! Included from inversion.F90
!
!============================================================================

!---------------------- Use scaLAPACK For Inversion -----------------------------------

!------------------------------------------------------------

subroutine dinvert_serial(nmtx, matrix)
integer, intent(in) :: nmtx
real(DP), intent(inout) :: matrix(nmtx,nmtx)

integer :: ii, info, lwork, ipiv(nmtx)
real(DP), allocatable :: work(:)

! FHJ: LU factorization of the matrix
call dgetrf(nmtx, nmtx, matrix, nmtx, ipiv, info)
if (info/=0) then
if (peinf%inode==0) write(0,*) 'ERROR: got info = ', info, ' in ?getrf'
call die('?getrf failed')
endif

! FHJ: tringular inversion of LU decomposition
allocate(work (10))
call dgetri(nmtx, matrix, nmtx, ipiv, work, -1, info)
if (info/=0) then
if (peinf%inode==0) write(0,*) 'ERROR: got info = ', info, ' in ?getri'
call die('?getri failed for query mode')
endif

lwork = max(1,int(work(1)))
if(allocated(work))then;deallocate(work);endif
allocate(work (lwork))

call dgetri(nmtx, matrix, nmtx, ipiv, work, lwork, info)
if (info/=0) then
if (peinf%inode==0) write(0,*) 'ERROR: got info = ', info, ' in ?getri'
call die('?getri failed')
endif

if(allocated(work))then;deallocate(work);endif

return
end subroutine dinvert_serial

! use between inclusions of f_defs.h in template modules
! list here everything defined differently by flavor in f_defs.h
! these undefs prevent lots of warnings from cpp

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!The following macro puts any point/array in the [-0.5, 0.5) range:
!The following macro puts any point/array in the [0, 1) range:
!Integer division of a/b rounded up*/
!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

! deprecated identifiers

! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

! very ancient version may require NOSIZEOF

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.

! path before 4.0.9 lacks SIZEOF

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?

! It is considered a bug in OPEN64 that sizeof will not work in our code.

! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit

! name of routine to get name of host program is running on

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m

! how to get the cpu time in seconds

! interface required for mclock routine (timing) to be usable

! interface required for iargc routine (command-line arguments) to be usable

! ftell gives you the current location in a file, to fseek back to it

! if no fseek, ftell is useless

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
!===========================================================================
!
! Included from inversion.F90
!
!============================================================================

!---------------------- Use scaLAPACK For Inversion -----------------------------------

!------------------------------------------------------------

subroutine zinvert_serial(nmtx, matrix)
integer, intent(in) :: nmtx
complex(DPC), intent(inout) :: matrix(nmtx,nmtx)

integer :: ii, info, lwork, ipiv(nmtx)
complex(DPC), allocatable :: work(:)

! FHJ: LU factorization of the matrix
call zgetrf(nmtx, nmtx, matrix, nmtx, ipiv, info)
if (info/=0) then
if (peinf%inode==0) write(0,*) 'ERROR: got info = ', info, ' in ?getrf'
call die('?getrf failed')
endif

! FHJ: tringular inversion of LU decomposition
allocate(work (10))
call zgetri(nmtx, matrix, nmtx, ipiv, work, -1, info)
if (info/=0) then
if (peinf%inode==0) write(0,*) 'ERROR: got info = ', info, ' in ?getri'
call die('?getri failed for query mode')
endif

lwork = max(1,int(work(1)))
if(allocated(work))then;deallocate(work);endif
allocate(work (lwork))

call zgetri(nmtx, matrix, nmtx, ipiv, work, lwork, info)
if (info/=0) then
if (peinf%inode==0) write(0,*) 'ERROR: got info = ', info, ' in ?getri'
call die('?getri failed')
endif

if(allocated(work))then;deallocate(work);endif

return
end subroutine zinvert_serial

end module inversion_m

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/mtxel_optical.f90 > Common/mtxel_optical.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/mtxel_optical.p.f -o Common/mtxel_optical.o -module Common/
# 1 "Common/mtxel_optical.p.f"
!===============================================================================
!
! Routines:
!
! (1) mtxel_m() Originally By MLT Last Modified 6/5/2008 JRD
!
! input: crys, wfnc, wfnvq, gvec, eqp, xct types
! ik label of k-point in FBZ
!
! output: s0 matrix element of the momentum operator at point ik
!
! Calculates the momentum operator between two sets of wavefunctions
! < ic,k | P dot 2 (G+k+q) exp(-i q.r) | iv,k+q > / | P |
! Division by ( E_c^LDA - E_v^LDA ) is done only if divide_energy = .true.
! Each set has its own isort vector and the number of bands is nband
! The momentum operator is divided by electron mass m = 0.5 (in Ry atomic units)
! q is an optional small shift to k in reciprocal space
! P is the polarization vector
!
! (2) mtxel_v() Originally By MLT Last Modified: 6/5/2008 (JRD)
!
! input: wfnc, wfnvq, gvec types
! qshift length of the q-shift vector
!
! output: s0 velocity matrix elements at a k-point
!
! Calculates the velocity operator between two sets of wavefunctions
! < ic,k | exp(-i q.r) | iv,k+q > / q
! Note that this form is also correct for intraband transitions. --FHJ
! Each set has its own isort vector and the number of bands is nband
! q is a small but finite shift to k in reciprocal space
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 36 "Common/Common/mtxel_optical.f90" 2

module mtxel_optical_m

use global_m
implicit none

private
public :: mtxel_m, mtxel_v

contains

subroutine mtxel_m(crys,wfnc,wfnvq,gvec,eqp,xct,s0_dim1,s0_dim2,s0,ik,divide_energy,kpt)
type (crystal), intent(in) :: crys
type (wavefunction), intent(in) :: wfnc, wfnvq
type (gspace), intent(in) :: gvec
type (eqpinfo), intent(in) :: eqp
type (xctinfo), intent(in) :: xct
integer, intent(in) :: s0_dim1, s0_dim2
complex(DPC), intent(out) :: s0(:,:,:) !< (s0_dim1, s0_dim2, wfnc%nspin)
integer, intent(in) :: ik
logical, intent(in) :: divide_energy
real(DP),intent(in),optional::kpt(3)

real(DP) :: kpg(3)
integer :: ig, igq, ic, iv, isc, isp
integer, allocatable :: isorti(:)
real(DP) :: fac
complex(DPC) :: sum

!---------------------------------
! Initialize isorti array

s0 = (0.0d0,0.0d0)
allocate(isorti (gvec%ng))
isorti(:)=0
do ig=1, gvec%ng
isorti(wfnvq%isort(ig)) = ig
enddo

!----------------------------------
! Check if the polarization vector is properly defined

if (abs(xct%lpol).lt.TOL_Zero) then
write(0,*) xct%lpol, xct%pol(:)
call die("zero length polarization vector")
endif

!----------------------------------
! Calculate s0(ic,iv) = < ic,k | P dot 2 (G+k+q) exp(-i q.r) | iv,k+q > / | P |
! / ( E_c^LDA - E_v^LDA )
! Here, q = 0 and (P dot 2 (G+k)) is replaced with (P dot 2 G)
! because < ic,k | P dot 2 k | iv, k > = P dot 2 k < ic,k | iv,k > = 0
! (only true for interband transitions. --DAS)
! (but we need k+G for nonlinear optics --DYQ)

do isc=1,wfnc%nspin
do ic=1,s0_dim1
do iv=1,s0_dim2
sum=(0.0d0,0.0d0)
do ig=1, wfnc%ng
igq=isorti(wfnc%isort(ig))
if (present(kpt)) then
kpg(:) = gvec%components(:,wfnc%isort(ig)) + kpt(:)
else
kpg(:) = gvec%components(:,wfnc%isort(ig))
endif
fac=DOT_PRODUCT(xct%pol,MATMUL(crys%bdot,kpg))
if (igq.gt.wfnvq%ng) exit
do isp=1,wfnc%nspinor
sum = sum + conjg(wfnc%cg(ig,ic,isc*isp)) * wfnvq%cg(igq,iv,isc*isp) * fac
enddo
enddo
s0(ic,iv,isc) = 2.d0 * sum / xct%lpol
if(divide_energy) then
s0(ic,iv,isc) = s0(ic,iv,isc) / (eqp%eclda(ic,ik,isc)-eqp%evlda(iv,ik,isc))
endif
enddo
enddo
enddo

if(allocated(isorti))then;deallocate(isorti);endif

return
end subroutine mtxel_m

!===============================================================================

subroutine mtxel_v(wfnc,wfnvq,gvec,qshift,s0_dim1,s0_dim2,s0)

use global_m
implicit none

type (wavefunction), intent(in) :: wfnc, wfnvq
type (gspace), intent(in) :: gvec
real(DP), intent(in) :: qshift
integer, intent(in) :: s0_dim1, s0_dim2
complex(DPC), intent(out) :: s0(:,:,:) !< (s0_dim1, s0_dim2, wfnc%nspin)

integer :: ig, igq, ic, iv, isc, isp
integer, allocatable :: isorti(:)
complex(DPC) :: sum

!--------------------------------
! Initialize isorti array

s0 = (0.0d0,0.0d0)
allocate(isorti (gvec%ng))
isorti(:)=0
do ig=1, gvec%ng
isorti(wfnvq%isort(ig)) = ig
enddo

!--------------------------------
! Calculate s0(ic,iv) = < ic,k | exp(-i q.r) | iv,k+q > / q

do isc=1,wfnc%nspin
do ic=1,s0_dim1
do iv=1,s0_dim2
sum=(0.0d0,0.0d0)
do ig=1, wfnc%ng
igq=isorti(wfnc%isort(ig))
if (igq.gt.wfnvq%ng) exit
do isp=1,wfnc%nspinor
sum = sum + conjg(wfnc%cg(ig,ic,isc*isp)) * wfnvq%cg(igq,iv,isc*isp)
enddo
enddo
s0(ic,iv,isc) = sum / qshift
enddo ! iv
enddo ! ic
enddo ! isc

if(allocated(isorti))then;deallocate(isorti);endif

return
end subroutine mtxel_v

end module mtxel_optical_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/io_utils.f90 > Common/io_utils.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/io_utils.p.f -o Common/io_utils.o -module Common/
# 1 "Common/io_utils.p.f"
!===================================================================
!
! Modules:
!
! 1. io_utils_m Originally By FHJ
!
! Provides set of routines to standardize stdout operations.
! Objects:
!
! progress_info: tracks the progress of a task
!
!===================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 15 "Common/Common/io_utils.f90" 2

module io_utils_m

use global_m

implicit none

private

!> Progress information object. Use this object whenever you want to have
!! a nice standardized progress report on a given task, including an
!! estimate of the remaining time to complete the task.
!!
!! \sa progress_init(), progress_step() and progress_free routines().
type progress_info
real(DP) :: t_pred !< A prediction of when task will be done.
!> Time when progress_init was called (before 1st step got executed).
real(DP) :: t_wall0
!> Time elapsed, wrt t_wall0, when 1st step finished (before 2nd step got executed).
real(DP) :: dt1
real(DP) :: report_every !< How often to report progress to stdout?
integer :: num_steps !< Max. number of steps (not number of reports!)
integer :: cur_step !< Keep track of the current step
!> What is the task we are tracking? This should be a noun(-phrase). Eg:
!! "reading wavefunctions", "calculation of matrix elements", etc.
character(len=256) :: str_task
!> What defines each step/iteration? This should be a noun(-phrase). Eg:
!! "k-point", "transition", etc.
character(len=64) :: str_step
character(len=11) :: str_tot !< this is the string " / $num_steps"
logical :: should_print !< Should I write out my progress? Default is .true. for inode==0
integer :: iunit !< Defaults to 6 (stdout)
end type progress_info

public :: &
centralize, &
progress_info, &
progress_init, &
progress_step, &
progress_free, &
print_dealing_with

contains

!> Trim and centralize a string. Max width hard-coded to 256.
subroutine centralize(text_in, text_out, width)
character(len=*), intent(in) :: text_in
character(len=*), intent(out) :: text_out
integer, intent(in) :: width

character(len=256) :: text
integer :: text_len, margin, wid

wid = width
if (wid>256) wid=256
if (len(TRUNC(text_in))>wid) then
! FHJ: avoid buffer overflow.
text_out = text_in(1:wid)

return
endif

text = TRUNC(text_in)
text_len = len(TRUNC(text))
margin = (wid-text_len)/2
text_out = repeat(' ', len(text_out))
text_out(margin+1:margin+text_len) = text(1:text_len)

return

end subroutine centralize

!----------------------------------------------------------------------------
! FHJ: Progress report stuff
!----------------------------------------------------------------------------

!> Initialize a ::progress_info structure.
!!
!! This subroutine will also print the following sentence:
!! "Started ${str_task} with ${num_steps} ${str_step}s at ${TIME}."
subroutine progress_init(prog_info, str_task, str_step, num_steps, num_reports, should_print, iunit)
type(progress_info), intent(out) :: prog_info
character(len=*), intent(in) :: str_task !< See: progress_info%str_task
character(len=*), intent(in) :: str_step !< See: progress_info%str_step
integer, intent(in) :: num_steps !< How many times will you call progress_step?
!> What is the total number of times we want to write the progress to
!! stdout? Defaults to 10.
integer, intent(in), optional :: num_reports
logical, intent(in), optional :: should_print
integer, intent(in), optional :: iunit

character(len=15) :: mydate, mytime
character(len=256) :: str_tmp
real(DP) :: t_cpu
integer :: num_rep

prog_info%dt1 = 0d0
prog_info%t_pred = 0d0
prog_info%str_task = str_task
prog_info%str_step = str_step
prog_info%num_steps = num_steps
prog_info%should_print = peinf%inode==0
prog_info%iunit = 6
num_rep = 10
if (present(num_reports)) num_rep = num_reports
if (present(should_print)) prog_info%should_print = should_print
if (present(iunit)) prog_info%iunit = iunit

if (num_steps Update prediction info for current task.
!!
!! Call this function at the beginning of your loop. The variable
!! prog_info%t_pred will be updated with the prediction of when the task will
!! be finished. Depending on the current step, some info about the progress
!! of the current task will be printed. Although this function is pretty
!! lightweight, you might consider not placing the call in the innermost loop
!! if only a very simple operation is performed each step.
subroutine progress_step(prog_info, step_)
type(progress_info), intent(inout) :: prog_info
integer, intent(in), optional :: step_ !< Current step/iteration

!> Contains an estimate for the time remaining to finish the task
character(len=11) :: str_remaining_tmp
character(len=64) :: str_remaining
real(DP) :: dt, t_cpu, t_remain
character(len=15) :: mydate, mytime
integer :: step, idx1, idx2
character(len=15) :: step_str

if (present(step_)) then
prog_info%cur_step = step_
else
prog_info%cur_step = prog_info%cur_step + 1
endif
step = prog_info%cur_step

if (step<=3 .or. mod(dble(step), prog_info%report_every)<1d0) then
call timget(t_cpu, dt)
str_remaining = '.'
dt = dt - prog_info%t_wall0
if (step==2) then
prog_info%dt1 = dt
elseif (step>2) then
! FHJ: to get a better estimate, we compare the time wrt step #2, since
! step #1 is usually atypical (setup_FFTs, allocate buffers, etc.)
t_remain = (dt - prog_info%dt1) / (step-2d0) * (prog_info%num_steps-step+1d0)
prog_info%t_pred = prog_info%t_wall0 + t_remain
write(str_remaining_tmp, '(i6)') idnint(t_remain)
write(str_remaining, '(3a)') ', remaining: ', TRUNC(str_remaining_tmp),' s.'
endif

if (prog_info%should_print .and. ((step==1.or.step==3).or.&
mod(dble(step), prog_info%report_every)<1d0)) then
call date_and_time(mydate,mytime)
! FHJ: This ensures that the two numbers in (xx/yy) have the same width
write(step_str, '(i15)') step
idx2 = LEN(TRUNC(prog_info%str_tot)) - 2
idx1 = 16 - idx2
idx2 = idx1 + idx2 - 1
write(prog_info%iunit,'(1x,3a,i3,a)', advance='no') & ! [ 12:00:00 | 20% ]
'[ ', mytime(1:2)//':'//mytime(3:4)//':'//mytime(5:6), ' | ', &
idnint((step - 1d0)/dble(prog_info%num_steps)*1d2), '% ]'
write(prog_info%iunit,'(1x,a,1x,a,1x,a)', advance='no') & ! transition 16 / 128
TRUNC(prog_info%str_step), step_str(idx1:idx2), TRUNC(prog_info%str_tot)
write(prog_info%iunit,'(a)') TRUNC(str_remaining) !, remaining: 10 s.
endif
endif

end subroutine progress_step

!> Finalize a progress information task.
!!
!! This will essentially print the following sentence:
!! "Finished ${str_task} at ${TIME}."
subroutine progress_free(prog_info)
type(progress_info), intent(in) :: prog_info

real(DP) :: dt, t_cpu
character(len=15) :: mydate, mytime

if (prog_info%should_print) then
call date_and_time(mydate,mytime)
write(prog_info%iunit,'(1x,4a)') 'Finished ', TRUNC(prog_info%str_task), &
' at ', mytime(1:2)//':'//mytime(3:4)//':'//mytime(5:6)//'.'
call timget(t_cpu, dt)
dt = dt - prog_info%t_wall0
write(mytime,'(i8)') idnint(dt)
write(prog_info%iunit,'(1x,a,a,a)') 'Elapsed time: ', TRUNC(mytime), ' s.'
write(prog_info%iunit,*)
endif

end subroutine progress_free

!> Print a banner with the new q/k point we are calculating
subroutine print_dealing_with(ik, ik_max, kk, label, iunit)
integer, intent(in) :: ik !< Index of the current k-point
integer, intent(in) :: ik_max !< Total numeber of k-points
real(DP), intent(in) :: kk(:) !< (3) K-point as a vector
character(len=*), intent(in) :: label !< Either "k" or "q"
integer, optional, intent(in) :: iunit

!> Contains an estimate for the time remaining to finish the task
real(DP) :: t_cpu, t_wall
character(len=15) :: mydate, mytime
character(len=15) :: str_cur, str_max
character(len=30) :: str_sulfix
integer :: ii, idx1, idx2, iunit_

call timget(t_cpu, t_wall)
call date_and_time(mydate,mytime)
iunit_ = 6
if (present(iunit)) iunit_ = iunit
write(iunit_,'(a)') repeat('=', 80)
write(iunit_,'(1x,a)', advance='no') mytime(1:2)//':'//mytime(3:4)//':'//mytime(5:6)
write(iunit_,'(3x,a,3f10.6)', advance='no') 'Dealing with '//label(1:1)//' =', (kk(ii),ii=1,3)
! wrote 58 characters
write(str_max,'(i15)') ik_max
write(str_cur,'(i15)') ik
idx2 = LEN(TRUNC(str_max))
idx1 = 16 - idx2
idx2 = idx1 + idx2 - 1
write(str_sulfix,'(a)') str_cur(idx1:idx2)//' / '//TRUNC(str_max)
idx1 = 80 - 58 - LEN(TRUNC(str_sulfix))
write(iunit_,'(a)') repeat(' ', idx1)//TRUNC(str_sulfix)
write(iunit_,'(a,/)') repeat('=', 80)

end subroutine print_dealing_with

end module io_utils_m
icc -E -C -P -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/hdf5_io.F90 > Common/hdf5_io.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/hdf5_io.p.f -o Common/hdf5_io.o -module Common/
# 1 "Common/hdf5_io.p.f"
!>=========================================================================
!!
!! Module:
!!
!! (1) hdf5_io_m Originally by JIM Last Modified 12/2014 (FHJ)
!!
!! Routines to read and write wavefunctions in HDF5 format.
!! The code is generated through repeated inclusion of a file with
!! different preprocessor definitions each time. Consult the resulting
!! .p.f file for clarity.
!!
!!=========================================================================

!The following macro puts any point/array in the [-0.5, 0.5) range:
!The following macro puts any point/array in the [0, 1) range:
!Integer division of a/b rounded up*/
!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

! deprecated identifiers

! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

! very ancient version may require NOSIZEOF

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.

! path before 4.0.9 lacks SIZEOF

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?

! It is considered a bug in OPEN64 that sizeof will not work in our code.

! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit

! name of routine to get name of host program is running on

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m

! how to get the cpu time in seconds

! interface required for mclock routine (timing) to be usable

! interface required for iargc routine (command-line arguments) to be usable

! ftell gives you the current location in a file, to fseek back to it

! if no fseek, ftell is useless

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

module hdf5_io_m
use global_m

end module hdf5_io_m

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/write_matrix.f90 > Common/write_matrix.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/write_matrix.p.f -o Common/write_matrix.o -module Common/
# 1 "Common/write_matrix.p.f"
!=================================================================================
!
! Module write_matrix_m
!
! (1) write_matrix_d() Originally by JRD Last Modified 5/1/2008 (JRD)
!
! This program writes a distributed matrix like chimat or epsmat to file.
!
! (2) write_matrix_f() Originally by JRD Last Modified 2/5/2009 (CHP)
!
! Modification of write_matrix_d for full-frequency.
!
!=================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 16 "Common/Common/write_matrix.f90" 2

module write_matrix_m

use global_m

use hdf5_io_m
use scalapack_m
use io_utils_m

implicit none

private

public :: &
write_matrix_d, &
write_matrix_f
# 49

contains

!===================================================================================

subroutine write_matrix_d(scal,matrix,nmtx,iunit)
type(scalapack), intent(in) :: scal
complex(DPC), intent(in) :: matrix(:,:) !< (scal%npr,scal%npc)
integer, intent(in) :: nmtx
integer, intent(in) :: iunit

integer :: ii, jj

type(progress_info) :: prog_info !< a user-friendly progress report

if (peinf%verb_debug .and. peinf%inode==0) then
write(6,*) 'Writing matrix: ', nmtx, iunit
write(6,*)
endif

# 127

if (peinf%inode .eq. 0) then
call progress_init(prog_info, 'writing matrix', 'column', nmtx)
do jj = 1, nmtx
call progress_step(prog_info, jj)
write(iunit) (matrix(ii, jj), ii = 1, nmtx)
enddo
call progress_free(prog_info)
endif

return
end subroutine write_matrix_d

!=================================================================================

subroutine write_matrix_f(scal,nfreq,retarded,nmtx,iunit,nfreq_group,advanced)
type(scalapack), intent(in) :: scal
integer, intent(in) :: nfreq
complex(DPC), intent(in) :: retarded(:,:,:) !< (scal%npr,scal%npc,nfreq_in_group)
integer, intent(in) :: nmtx
integer, intent(in) :: iunit
integer, intent(in) :: nfreq_group
complex(DPC), optional, intent(in) :: advanced(:,:,:) !< (scal%npr,scal%npc,nfreq_in_group)

integer :: ii, jj, ifreq
# 162
type(progress_info) :: prog_info !< a user-friendly progress report
logical :: has_advanced

if (peinf%verb_debug .and. peinf%inode==0) then
write(6,*) 'Writing matrix: ', nfreq, nmtx, iunit
write(6,*)
endif

has_advanced = present(advanced)
# 262

if(peinf%inode .eq. 0) then
call progress_init(prog_info, 'writing matrix', 'column', nmtx)
do jj = 1, nmtx
call progress_step(prog_info, jj)
do ii = 1, nmtx
write(iunit) (retarded(ii, jj, ifreq), ifreq= 1, nfreq)
enddo

if (has_advanced) then
do ii = 1, nmtx
write(iunit) (advanced(ii, jj, ifreq),ifreq = 1, nfreq)
enddo
else
do ii = 1, nmtx
write(iunit)
enddo
endif

enddo
call progress_free(prog_info)
endif

return
end subroutine write_matrix_f

# 1290

end module write_matrix_m

icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/epsread_hdf5.f90 > Common/epsread_hdf5.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/epsread_hdf5.p.f -o Common/epsread_hdf5.o -module Common/
# 1 "Common/epsread_hdf5.p.f"
!>=========================================================================
!!
!! Module:
!!
!! epsread_hdf5_m Originally by JRD Last Modified 12/2014 (FHJ)
!!
!! Routines to read header info and matrices from epsmat files in
!! HDF5 format.
!!
!!=========================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 13 "Common/Common/epsread_hdf5.f90" 2

module epsread_hdf5_m
# 898
end module epsread_hdf5_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/read_matrix.f90 > Common/read_matrix.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/read_matrix.p.f -o Common/read_matrix.o -module Common/
# 1 "Common/read_matrix.p.f"
!=================================================================================
!
! Module read_matrix
!
! (1) read_matrix_d() Originally by JRD Last Modified 5/1/2008 (JRD)
!
! This program reads a distributed matrix like chimat or epsmat to file.
!
! (2) read_matrix_f() Originally by JRD Last Modified 9/10/2010 (gsm)
!
! Modification of read_matrix_d for full-frequency.
!
!=================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 16 "Common/Common/read_matrix.f90" 2

module read_matrix_m

use global_m
use scalapack_m
use epsread_hdf5_m

implicit none

private

public :: &
read_matrix_d, &
read_matrix_d_hdf5, &
read_matrix_f, &
read_matrix_f_hdf5

contains

subroutine read_matrix_d(scal,matrix,nmtx,iunit)
type (scalapack), intent(in) :: scal
complex(DPC), intent(out) :: matrix(:,:) !< (scal%npr,scal%npc)
integer, intent(in) :: nmtx
integer, intent(in) :: iunit

call read_matrix_d_(scal,matrix,nmtx,iunit=iunit)

end subroutine read_matrix_d

subroutine read_matrix_d_hdf5(scal,matrix,nmtx,fname,iq,is)
type (scalapack), intent(in) :: scal
complex(DPC), intent(out) :: matrix(:,:) !< (scal%npr,scal%npc)
integer, intent(in) :: nmtx
character(len=*), intent(in) :: fname
integer, intent(in) :: iq
integer, intent(in) :: is

call read_matrix_d_(scal,matrix,nmtx,fname=fname,iq=iq,is=is)

end subroutine read_matrix_d_hdf5

subroutine read_matrix_d_(scal,matrix,nmtx,iunit,fname,iq,is)
type (scalapack), intent(in) :: scal
complex(DPC), intent(out) :: matrix(:,:) !< (scal%npr,scal%npc)
integer, intent(in) :: nmtx
integer, intent(in), optional :: iunit
character(len=*), intent(in), optional :: fname
integer, intent(in), optional :: iq
integer, intent(in), optional :: is

integer :: ii, jj

logical :: use_hdf5

if (.not.present(iunit).and..not.(present(fname).and.present(iq))) then
call die("Not enough arguments to read_matrix_d_", only_root_writes=.true.)
endif
if (present(iunit).and.(present(fname).or.present(iq))) then
call die("Too many arguments to read_matrix_d_", only_root_writes=.true.)
endif
if ((present(fname).or.present(iq)).and..not.(present(fname).and.present(iq))) then
call die("Inconsistent arguments to read_matrix_d_", only_root_writes=.true.)
endif
use_hdf5 = present(fname).and.present(iq)

if (use_hdf5) then
call die("read_matrix_d_ was not compiled with HDF5 support.", only_root_writes=.true.)
endif

if (peinf%verb_debug .and. peinf%inode==0) then
if (use_hdf5) then
write(6,*) 'Reading matrix: ', nmtx, fname
else
write(6,*) 'Reading matrix: ', nmtx, iunit
endif
write(6,*)
endif

# 162

if(peinf%inode .eq. 0) then
do jj = 1, nmtx
if (use_hdf5) then

else
read(iunit) (matrix(ii, jj), ii = 1, nmtx)
endif
enddo
endif

return
end subroutine read_matrix_d_

!=================================================================================

!> FHJ: Front end for read_matrix_f_ for Fortran binary files. See that routine for more info.
subroutine read_matrix_f(scal, nfreq, nfreq_in_group, retarded, nmtx, nfreq_group, iunit, advanced)
type(scalapack), intent(in) :: scal
integer, intent(in) :: nfreq
integer, intent(in) :: nfreq_in_group
complex(DPC), intent(out) :: retarded(:,:,:) !< (nfreq_in_group,scal%npr,scal%npc)
integer, intent(in) :: nmtx
integer, intent(in) :: nfreq_group
integer, intent(in) :: iunit
complex(DPC), optional, intent(out) :: advanced(:,:,:) !< (nfreq_in_group,scal%npr,scal%npc)

call read_matrix_f_(scal, nfreq, nfreq_in_group, retarded, nmtx, nfreq_group, iunit=iunit, advanced=advanced)

end subroutine read_matrix_f

!> FHJ: Front end for read_matrix_f_ for HDF5 files. See that routine for more info.
subroutine read_matrix_f_hdf5(scal, nfreq, nfreq_in_group, retarded, nmtx, nfreq_group, fname, iq, is, advanced)
type(scalapack), intent(in) :: scal
integer, intent(in) :: nfreq
integer, intent(in) :: nfreq_in_group
complex(DPC), intent(out) :: retarded(:,:,:) !< (nfreq_in_group,scal%npr,scal%npc)
integer, intent(in) :: nmtx
integer, intent(in) :: nfreq_group
character(len=*), intent(in) :: fname
integer, intent(in) :: iq
integer, intent(in) :: is
complex(DPC), optional, intent(out) :: advanced(:,:,:) !< (nfreq_in_group,scal%npr,scal%npc)

call read_matrix_f_(scal, nfreq, nfreq_in_group, retarded, nmtx, nfreq_group, &
fname=fname, iq=iq, is=is, advanced=advanced)

end subroutine read_matrix_f_hdf5

!> FHJ: This routines the full-frequency chiR/epsR matrix from a file, and
!! optionally chiA/epsA (note: you shouldn`t really need chiA, ever...)
!! If using HDF5, we only read the retarded part. If legacy
!! Fortran binary, we read the retarded and skip the advanced. The final
!! matrix will be distributed in a ScaLAPACK layout given by scal. Note that
!! this routine is pretty innefficient, but this is not a core component
!! of BGW as it`s only used if you read_chi or use the eps*omega utility.
subroutine read_matrix_f_(scal, nfreq, nfreq_in_group, retarded, nmtx, &
nfreq_group, iunit, fname, iq, is, advanced)
type(scalapack), intent(in) :: scal
integer, intent(in) :: nfreq
integer, intent(in) :: nfreq_in_group
complex(DPC), intent(out) :: retarded(:,:,:) !< (scal%npr,scal%npc,nfreq_in_group)
integer, intent(in) :: nmtx
integer, intent(in) :: nfreq_group
integer, intent(in), optional :: iunit
character(len=*), intent(in), optional :: fname
integer, intent(in), optional :: iq
integer, intent(in), optional :: is
complex(DPC), intent(out), optional :: advanced(:,:,:) !< (scal%npr,scal%npc,nfreq_in_group)

integer :: ii, jj, ifreq,ifreq_para,freq_grp_ind
# 257
logical :: use_hdf5, want_advanced

want_advanced = .false.

want_advanced = present(advanced)

if (.not.present(iunit).and..not.(present(fname).and.present(iq))) then
call die("Not enough arguments to read_matrix_f_", only_root_writes=.true.)
endif
if (present(iunit).and.(present(fname).or.present(iq))) then
call die("Too many arguments to read_matrix_f_", only_root_writes=.true.)
endif
if ((present(fname).or.present(iq)).and..not.(present(fname).and.present(iq))) then
call die("Inconsistent arguments to read_matrix_f_", only_root_writes=.true.)
endif
use_hdf5 = present(fname).and.present(iq)

if (use_hdf5) then
call die("read_matrix_f_ was not compiled with HDF5 support.", only_root_writes=.true.)
endif

if (peinf%verb_debug .and. peinf%inode==0) then
if (use_hdf5) then
write(6,*) ' Reading matrix: ', nmtx, fname
else
write(6,*) ' Reading matrix: ', nmtx, iunit
endif
write(6,*)
endif

# 369

if(peinf%inode .eq. 0) then
do jj = 1, nmtx
if (use_hdf5) then
# 380
else
do ii = 1, nmtx
read(iunit) (retarded(ii, jj, ifreq), ifreq = 1, nfreq)
enddo

if (want_advanced) then
do ii = 1, nmtx
read(iunit) (advanced(ii, jj, ifreq), ifreq = 1, nfreq)
enddo
else
do ii = 1, nmtx
read(iunit)
enddo
endif

endif
enddo
endif

return
end subroutine read_matrix_f_

end module read_matrix_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/minibzaverage.f90 > Common/minibzaverage.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/minibzaverage.p.f -o Common/minibzaverage.o -module Common/
# 1 "Common/minibzaverage.p.f"
!=======================================================================
!
! Routines:
!
! (1) minibzaverage_3d_oneoverq2() Originally by JRD/MJ Last Modified: 8/27/2009 (MJ/JRD)
!
! (2) minibzaverage_3d_oneoverq() Originally by JRD/MJ Last Modified: 8/27/2009 (MJ/JRD)
!
! (3) minibzaverage_2d_oneoverq2() Originally by JRD/MJ Last Modified: 9/15/2009 (MJ/JRD)
!
! (4) minbizaverage_1d() Originally by JRD/MJ Last Modified: 8/27/2009 (MJ/JRD)
!
! Output: average of on the mini-BZ for a 1-D system.
! output units: units equivalent to 8Pi/q^2
!
!=======================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 19 "Common/Common/minibzaverage.f90" 2

module minibzaverage_m

use global_m
use bessel_m
use misc_m

implicit none

private

public :: minibzaverage_3d_oneoverq2, minibzaverage_3d_oneoverq, &
minibzaverage_2d_oneoverq2, minibzaverage_1d, minibzaverage_3d_oneoverq2_mod

contains

subroutine minibzaverage_3d_oneoverq2(nn,bdot,integral,qran,qk,averagew,epshead,wcoul0,q0sph2,celvol,nfk)
integer, intent(in) :: nn
real(DP), intent(in) :: bdot(3,3), qran(:,:) !< (3, nn)
real(DP), intent(out) :: integral
real(DP), intent(in) :: qk(3)
logical, intent(in) :: averagew
complex(DPC), intent(in) :: epshead
real(DP), intent(in) :: q0sph2
real(DP), intent(in) :: celvol
integer, intent(in) :: nfk
real(DP) :: gkq(3), length,length_qk
complex(DPC), intent(inout) :: wcoul0

integer :: ii, nn2

integral = 0D0
length_qk = DOT_PRODUCT(qk,MATMUL(bdot,qk))

if( length_qk < TOL_Zero ) then
nn2 = nn
do ii = 1, nn2
gkq(:) = qk(:) + qran(:,ii)
length = DOT_PRODUCT(gkq,MATMUL(bdot,gkq))
! Skip the small value of q that will be integrated analytically later on
if ( length > q0sph2 ) integral = integral + 1D0/length
enddo
else
! FHJ: for spherical integration regions, one can make the error per MC
! integration ~const. by choosing the number of points such that N ~ 1/ekinx.
! This is because, in 3D, error = sigma/N^{3/2}, and sigma ~ 1/ekinx^{3/2}
! If we fix the number of points such that N(ekinx=4*q0sph2) = nmc_coarse,
nn2 = idnint(nmc_coarse * 4d0 * q0sph2 / length_qk)
nn2 = max(1, min(nn2, nn))
do ii = 1, nn2
gkq(:) = qk(:) + qran(:,ii)
length = DOT_PRODUCT(gkq,MATMUL(bdot,gkq))
integral = integral + 1D0/length
enddo
endif

integral = integral * 8D0 * PI_D / dble(nn2)

if( length_qk < TOL_Zero ) then
integral = integral + 32.0D0 * PI_D**2 * SQRT(q0sph2) / ( 8.0D0 * PI_D**3 / (celvol * dble(nfk)) )
endif

if (length_qk .lt. TOL_Zero .and. averagew) then
wcoul0 = integral * epshead
endif

return
end subroutine minibzaverage_3d_oneoverq2

!========================================================================

! This is for Slab Truncation

subroutine minibzaverage_2d_oneoverq2(nn,bdot,integral,qran,qk,kz,zc,epshead,q0len,averagew,wcoul0)
integer, intent(in) :: nn
real(DP), intent(in) :: bdot(3,3), qran(:,:) !< (3,nn)
real(DP), intent(out) :: integral
real(DP), intent(in) :: qk(3)
logical, intent(in) :: averagew
complex(DPC), intent(in) :: epshead
complex(DPC), intent(inout) :: wcoul0
real(DP), intent(in) :: zc, q0len
real(DP), intent(out) :: kz

integer :: ii
real(DP) :: gkq(3), length, kxy, gkqxy(3),lengthqk
real(DP) :: gkqz(3),epsmodel,gamma,alpha,vc,vc_qtozero
complex(DPC) :: integralW

!
! Sahar:
! Define Gamma parameter for model epsilon (see Sohrab, PRB 2006)
! Extract the quadratic dependence of 1/epsinv(00)
! 1/epsinv(q;0,0) = 1 + q^2*vc(q)*gamma

!get Vc
vc_qtozero=((1.0d0 - exp(-q0len*zc))/q0len**2)
! Define Gamma
gamma = (1.0d0/epshead-1.0d0)/((q0len**2)*vc_qtozero)
!
! Define alpha
! Set to zero for now
alpha = 0.0d0

! length of q + G
lengthqk = sqrt(DOT_PRODUCT(qk,MATMUL(bdot,qk)))

integral = 0D0
integralW = 0D0

do ii = 1, nn
gkq(:) = qk(:)
gkq(1:2) = gkq(1:2) + qran(1:2,ii)
gkqxy(1:2) = gkq(1:2)
gkqxy(3) = 0D0
kxy=sqrt(DOT_PRODUCT(gkqxy,MATMUL(bdot,gkqxy)))
length = DOT_PRODUCT(gkq,MATMUL(bdot,gkq))

! This is Temporary??
gkqz(:)=gkq(:)
gkqz(1)=0D0
gkqz(2)=0D0
kz=sqrt(DOT_PRODUCT(gkqz,MATMUL(bdot,gkqz)))

! First average v

integral = integral + (1.0d0+exp(-kxy*zc)* &
((kz/kxy)*sin(kz*zc) - cos(kz*zc))) &
/ length

! Do we also want to average W?

! This is a waste of time if we are not qk=0
if (lengthqk.lt.TOL_zero.and.averagew) then

! Use model epsilon here
! Normalize integral by head of epsilon

vc = ((1.0d0 - exp(-kxy*zc))/kxy**2)
epsmodel=1.0d0 + vc * kxy**2 * gamma*exp(-alpha*kxy)
integralW = integralW + (vc/epsmodel)

! write(6,*) 'USING MODEL EPSILON FOR AVERAGING OF W'
! write(6,*) 'gamma: ', gamma, 'alpha: ', alpha, 'qk', qk
! write(6,*) 'qk', qk

! No model epsilon here
endif
enddo

! Convert integral to Ry

integral = integral * 8D0 * PI_D / dble(nn)
if (lengthqk.lt.TOL_zero.and.averagew) then
wcoul0 = integralW * 8D0 * PI_D / dble(nn)
endif

return
end subroutine minibzaverage_2d_oneoverq2

!========================================================================

subroutine minibzaverage_3d_oneoverq(nn,bdot,integral,qran,qk)
integer, intent(in) :: nn
real(DP), intent(in) :: bdot(3,3), qran(:,:) !< (3,nn)
real(DP), intent(out) :: integral
real(DP), intent(in) :: qk(3)

integer :: ii
real(DP) :: gkq(3), length

integral = 0D0

do ii = 1, nn

gkq(:) = qk(:) + qran(:,ii)
length = DOT_PRODUCT(gkq,MATMUL(bdot,gkq))
length = sqrt(length)
integral = integral + 1D0/length

enddo

integral = integral * 8D0 * PI_D / dble(nn)

return
end subroutine minibzaverage_3d_oneoverq

!===========================================================================

subroutine minibzaverage_1d(gvec,N_k,bdot,integral,iparallel,qk,epshead,q0len,averagew,wcoul0)
type (gspace), intent(in) :: gvec
integer, intent(in) :: N_k ! number of k-points
integer, intent(in) :: iparallel
real(DP), intent(in) :: bdot(3,3),qk(3)
real(DP), intent(out) :: integral
logical, intent(in) :: averagew
real(DP), intent(in) :: q0len
complex(DPC), intent(in) :: epshead
complex(DPC), intent(inout) :: wcoul0

real(DP) :: integralTemp
complex(DPC) :: wcoul0temp
real(DP) :: epsmodel,gamma,vc_qtozero

logical :: first_minibz
integer :: i, j, i1, i2, l1, l2, iline
real(DP) :: sum_vt, adot(3,3), rr(3), tt(3), rx, ry
real(DP) :: gpq_xy(2), gpq_z, r_len, t_len, scale, xline

integer, parameter :: nline = 1000 ! Number of points in 1-D integral

integral = 0.0d0

first_minibz = all(abs(qk(1:3)) .lt. Tol_Zero)

rr = 0.0d0
tt = 0.0d0

call invert_matrix(bdot, adot)
adot = adot * 4.d0 * PI_D * PI_D

do i=1,2
do j=1,2
adot(i,j)=adot(i,j)/(dble(gvec%FFTgrid(i)) * dble(gvec%FFTgrid(j)))
enddo
enddo

scale = adot(1,1)*adot(2,2) - adot(1,2)*adot(2,1)
scale = 4.d0 * sqrt(scale)

! Compute parameters of epsilon model

if (first_minibz .and. averagew) then
vc_qtozero = 0D0

do i2 = 1, gvec%FFTgrid(2)
rr(2) = dble(i2-1) + trunc_shift(2)
do i1 = 1, gvec%FFTgrid(1)
rr(1) = dble(i1-1) + trunc_shift(1)

r_len = INF

do l2 = -ncell+1, ncell
tt(2) = rr(2) - dble(l2 * gvec%FFTgrid(2))
do l1 = -ncell+1, ncell
tt(1) = rr(1) - dble(l1 * gvec%FFTgrid(1))
t_len = dot_product(tt,matmul(adot,tt))
if (t_len < r_len) then
r_len = t_len
endif
enddo ! l1
enddo ! l2

r_len = sqrt(r_len)
vc_qtozero = vc_qtozero + dbesk0(q0len * r_len)

enddo ! i1
enddo ! i2

vc_qtozero = vc_qtozero * scale
gamma = ((1/epshead)-1.0D0) / (q0len**2 * vc_qtozero)
endif

! Compute integral along z direction of minibz

do iline = 1, nline
if (iparallel .eq. 1 .and. mod(iline-1,peinf%npes) .ne. peinf%inode) cycle

xline = ((dble(iline) - 0.5d0) / dble(nline) - 0.5d0) / dble(N_k)
gpq_z = abs(qk(3)+xline)*sqrt(bdot(3,3))

sum_vt = 0D0

do i2 = 1, gvec%FFTgrid(2)
rr(2) = dble(i2-1) + trunc_shift(2)

do i1 = 1, gvec%FFTgrid(1)
rr(1) = dble(i1-1) + trunc_shift(1)

r_len = INF

do l2 = -ncell+1, ncell
tt(2) = rr(2) - dble(l2 * gvec%FFTgrid(2))
do l1 = -ncell+1, ncell
tt(1) = rr(1) - dble(l1 * gvec%FFTgrid(1))
t_len = dot_product(tt,matmul(adot,tt))
if (t_len < r_len) then
r_len = t_len
rx = tt(1)
ry = tt(2)
endif
enddo ! l1
enddo ! l2

r_len = sqrt(r_len)
rx = rx/dble(gvec%FFTgrid(1))
ry = ry/dble(gvec%FFTgrid(2))

gpq_xy(1:2) = qk(1:2)
sum_vt = sum_vt + dbesk0(gpq_z * r_len) * &
cos(2.0d0 * PI_D * (gpq_xy(1)*rx + gpq_xy(2)*ry))

enddo ! i1
enddo ! i2

sum_vt = sum_vt * scale
integral = integral + sum_vt

if (first_minibz .and. averagew) then
epsmodel = 1.0D0 + gamma * gpq_z**2 * sum_vt
wcoul0 = wcoul0 + (sum_vt / epsmodel)
endif

enddo

integral = integral / dble(nline)
if (first_minibz .and. averagew) then
wcoul0 = wcoul0 / dble(nline)
endif

if (iparallel .eq. 1) then
# 367

if (peinf%verb_debug .and. peinf%inode==0) then
write(6,'(3x,"vcoul =",e20.12,1x,"wcoul0 =",e20.12)') integral, wcoul0
endif
endif

return
end subroutine minibzaverage_1d

! For modified coulomb interaction
subroutine minibzaverage_3d_oneoverq2_mod(nn,bdot,integral,qran,qk,coulomb_mod)
integer, intent(in) :: nn
real(DP), intent(in) :: bdot(3,3), qran(:,:) !< (3, nn)
real(DP), intent(out) :: integral
real(DP), intent(in) :: qk(3)
type(coulomb_modifier_t), intent(in) :: coulomb_mod

real(DP) :: gkq(3), screeninv, temp_exp, length
integer :: ii

integral = 0D0
screeninv = 1.0D0/(4.0D0 * coulomb_mod%screening_length *coulomb_mod%screening_length)
! convert screening_length from A^{-1} to Bohr
screeninv = screeninv/(BOHR*BOHR)

do ii = 1, nn

gkq(:) = qk(:) + qran(:,ii)
length = DOT_PRODUCT(gkq,MATMUL(bdot,gkq))
temp_exp = exp(-screeninv*length)
integral = integral + 1D0/length*(temp_exp*coulomb_mod%long_range_frac_fock + &
(1.0D0 - temp_exp)*coulomb_mod%short_range_frac_fock)

enddo

integral = integral * 8D0 * PI_D / dble(nn)

return
end subroutine minibzaverage_3d_oneoverq2_mod

end module minibzaverage_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/random.f90 > Common/random.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/random.p.f -o Common/random.o -module Common/
# 1 "Common/random.p.f"
! Imported by MJ from:
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/VERSIONS/FORTRAN/mt95.f90
! Modified and added genrand_real4 so that it gives the same random
! numbers as other mt implementations..
! DAS: Commented out parts we do not use because ifort -O3 takes forever to
! optimize this file otherwise. Now it is much faster.
!============================================================================

! A C-program for MT19937, with initialization improved 2002/1/26.
! Coded by Takuji Nishimura and Makoto Matsumoto.

! Code converted to Fortran 95 by José Rui Faustino de Sousa
! Date: 2002-02-01

! Enhanced version by José Rui Faustino de Sousa
! Date: 2003-04-30

! Interface:
!
! Kinds:
! genrand_intg
! Integer kind used must be at least 32 bits.
! genrand_real
! Real kind used
!
! Types:
! genrand_state
! Internal representation of the RNG state.
! genrand_srepr
! Public representation of the RNG state. Should be used to save the RNG state.
!
! Procedures:
! assignment(=)
! Converts from type genrand_state to genrand_srepr and vice versa.
! genrand_init
! Internal RNG state initialization subroutine accepts either an genrand_intg integer
! or a vector as seed or a new state using "put=" returns the present state using
! "get=". If it is called with "get=" before being seeded with "put=" returns a state
! initialized with a default seed.
! genrand_int32
! Subroutine returns an array or scalar whose elements are random integer on the
! [0,0xffffffff] interval.
! genrand_int31
! Subroutine returns an array or scalar whose elements are random integer on the
! [0,0x7fffffff] interval.
! genrand_real1
! Subroutine returns an array or scalar whose elements are random real on the
! [0,1] interval.
! genrand_real2
! Subroutine returns an array or scalar whose elements are random real on the
! [0,1[ interval.
! genrand_real3
! Subroutine returns an array or scalar whose elements are random real on the
! ]0,1[ interval.
! genrand_res53
! Subroutine returns an array or scalar whose elements are random real on the
! [0,1[ interval with 53-bit resolution.

! Before using, initialize the state by using genrand_init( put=seed )

! This library is free software.
! This library is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

! Copyright (C) 1997, 2002 Makoto Matsumoto and Takuji Nishimura.
! Any feedback is very welcome.
! http://www.math.keio.ac.jp/matumoto/emt.html
! email: matumoto@math.keio.ac.jp
!module mt95

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 73 "Common/Common/random.f90" 2

module random_m

use global_m
implicit none

public :: genrand_init, genrand_real4

private

! public :: genrand_init, assignment(=)
! public :: genrand_int32, genrand_int31, genrand_real1
! public :: genrand_real2, genrand_real3, genrand_res53
! public :: genrand_real4
! private :: init_by_scalar, next_state, genrand_int32_0d, uiadd, uimlt
! private :: uiadd, uisub, uimlt, uidiv, uimod
! private :: init_by_type, init_by_scalar, init_by_array, next_state
! private :: genrand_encode, genrand_decode, genrand_load_state, genrand_dump_state
! private :: genrand_int32_0d, genrand_int32_1d, genrand_int32_2d, genrand_int32_3d
! private :: genrand_int32_4d, genrand_int32_5d, genrand_int32_6d, genrand_int32_7d
! private :: genrand_int31_0d, genrand_int31_1d, genrand_int31_2d, genrand_int31_3d
! private :: genrand_int31_4d, genrand_int31_5d, genrand_int31_6d, genrand_int31_7d
! private :: genrand_real1_0d, genrand_real1_1d, genrand_real1_2d, genrand_real1_3d
! private :: genrand_real1_4d, genrand_real1_5d, genrand_real1_6d, genrand_real1_7d
! private :: genrand_real2_0d, genrand_real2_1d, genrand_real2_2d, genrand_real2_3d
! private :: genrand_real2_4d, genrand_real2_5d, genrand_real2_6d, genrand_real2_7d
! private :: genrand_real3_0d, genrand_real3_1d, genrand_real3_2d, genrand_real3_3d
! private :: genrand_real3_4d, genrand_real3_5d, genrand_real3_6d, genrand_real3_7d
! private :: genrand_res53_0d, genrand_res53_1d, genrand_res53_2d, genrand_res53_3d
! private :: genrand_res53_4d, genrand_res53_5d, genrand_res53_6d, genrand_res53_7d

! intrinsic :: selected_int_kind, selected_real_kind

! integer, public, parameter :: genrand_intg = selected_int_kind( 9 )
! integer, public, parameter :: genrand_real = selected_real_kind( 15 )

! integer, private, parameter :: wi = genrand_intg
! integer, private, parameter :: wr = genrand_real
integer, private, parameter :: wi = kind(1)
integer, private, parameter :: wr = DP

! Period parameters
integer(kind=wi), private, parameter :: n = 624_wi
integer(kind=wi), private, parameter :: m = 397_wi

integer(kind=wi), private, parameter :: default_seed = 5489_wi

integer(kind=wi), private, parameter :: fbs = 32_wi
integer(kind=wi), private, parameter :: hbs = fbs / 2_wi
integer(kind=wi), private, parameter :: qbs = hbs / 2_wi
integer(kind=wi), private, parameter :: tbs = 3_wi * qbs

real(kind=wr), private, parameter :: p231 = 2147483648.0_wr
real(kind=wr), private, parameter :: p232 = 4294967296.0_wr
real(kind=wr), private, parameter :: p232_1 = p232 - 1.0_wr
real(kind=wr), private, parameter :: pi232 = 1.0_wr / p232
real(kind=wr), private, parameter :: pi232_1 = 1.0_wr / p232_1
real(kind=wr), private, parameter :: pi227 = 1.0_wr / 134217728.0_wr
real(kind=wr), private, parameter :: pi253 = 1.0_wr / 9007199254740992.0_wr
real(kind=wr), private, parameter :: p231d232_1 = p231 / p232_1
real(kind=wr), private, parameter :: p231_5d232 = ( p231 + 0.5_wr ) / p232

character(len=*), private, parameter :: alph = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
character(len=*), private, parameter :: sepr = "&"
integer(kind=wi), private, parameter :: alps = 62_wi
integer(kind=wi), private, parameter :: clen = ( n + 1_wi ) * 7_wi !n * ( ceiling( fbs * log( 2.0 ) / log( alps ) ) + 1 )

type, public :: genrand_state
private
logical(kind=wi) :: ini = .false._wi
integer(kind=wi) :: cnt = n+1_wi
integer(kind=wi), dimension(n) :: val = 0_wi
end type genrand_state

! type, public :: genrand_srepr
! character(len=clen) :: repr
! end type genrand_srepr

type(genrand_state), private, save :: state

! interface assignment( = )
! module procedure genrand_load_state
! module procedure genrand_dump_state
! end interface assignment( = )

interface genrand_init
! module procedure init_by_type
module procedure init_by_scalar
! module procedure init_by_array
end interface genrand_init

! interface genrand_int32
! module procedure genrand_int32_0d
! module procedure genrand_int32_1d
! module procedure genrand_int32_2d
! module procedure genrand_int32_3d
! module procedure genrand_int32_4d
! module procedure genrand_int32_5d
! module procedure genrand_int32_6d
! module procedure genrand_int32_7d
! end interface genrand_int32
!
! interface genrand_int31
! module procedure genrand_int31_0d
! module procedure genrand_int31_1d
! module procedure genrand_int31_2d
! module procedure genrand_int31_3d
! module procedure genrand_int31_4d
! module procedure genrand_int31_5d
! module procedure genrand_int31_6d
! module procedure genrand_int31_7d
! end interface genrand_int31
!
! interface genrand_real1
! module procedure genrand_real1_0d
! module procedure genrand_real1_1d
! module procedure genrand_real1_2d
! module procedure genrand_real1_3d
! module procedure genrand_real1_4d
! module procedure genrand_real1_5d
! module procedure genrand_real1_6d
! module procedure genrand_real1_7d
! end interface genrand_real1
!
! interface genrand_real2
! module procedure genrand_real2_0d
! module procedure genrand_real2_1d
! module procedure genrand_real2_2d
! module procedure genrand_real2_3d
! module procedure genrand_real2_4d
! module procedure genrand_real2_5d
! module procedure genrand_real2_6d
! module procedure genrand_real2_7d
! end interface genrand_real2
!
! interface genrand_real3
! module procedure genrand_real3_0d
! module procedure genrand_real3_1d
! module procedure genrand_real3_2d
! module procedure genrand_real3_3d
! module procedure genrand_real3_4d
! module procedure genrand_real3_5d
! module procedure genrand_real3_6d
! module procedure genrand_real3_7d
! end interface genrand_real3
!
! interface genrand_res53
! module procedure genrand_res53_0d
! module procedure genrand_res53_1d
! module procedure genrand_res53_2d
! module procedure genrand_res53_3d
! module procedure genrand_res53_4d
! module procedure genrand_res53_5d
! module procedure genrand_res53_6d
! module procedure genrand_res53_7d
! end interface genrand_res53

contains

elemental function uiadd( a, b ) result( c )

! intrinsic :: ibits, ior, ishft

integer( kind = wi ), intent( in ) :: a, b

integer( kind = wi ) :: c

integer( kind = wi ) :: a1, a2, b1, b2, s1, s2

a1 = ibits( a, 0, hbs )
a2 = ibits( a, hbs, hbs )
b1 = ibits( b, 0, hbs )
b2 = ibits( b, hbs, hbs )
s1 = a1 + b1
s2 = a2 + b2 + ibits( s1, hbs, hbs )
c = ior( ishft( s2, hbs ), ibits( s1, 0, hbs ) )
return

end function uiadd

! elemental function uisub( a, b ) result( c )
!
! intrinsic :: ibits, ior, ishft
!
! integer( kind = wi ), intent( in ) :: a, b
!
! integer( kind = wi ) :: c
!
! integer( kind = wi ) :: a1, a2, b1, b2, s1, s2
!
! a1 = ibits( a, 0, hbs )
! a2 = ibits( a, hbs, hbs )
! b1 = ibits( b, 0, hbs )
! b2 = ibits( b, hbs, hbs )
! s1 = a1 - b1
! s2 = a2 - b2 + ibits( s1, hbs, hbs )
! c = ior( ishft( s2, hbs ), ibits( s1, 0, hbs ) )
! return
!
! end function uisub
!
elemental function uimlt( a, b ) result( c )

! intrinsic :: ibits, ior, ishft

integer(kind=wi), intent(in) :: a, b

integer(kind=wi) :: c

integer(kind=wi) :: a0, a1, a2, a3
integer(kind=wi) :: b0, b1, b2, b3
integer(kind=wi) :: p0, p1, p2, p3

a0 = ibits( a, 0, qbs )
a1 = ibits( a, qbs, qbs )
a2 = ibits( a, hbs, qbs )
a3 = ibits( a, tbs, qbs )
b0 = ibits( b, 0, qbs )
b1 = ibits( b, qbs, qbs )
b2 = ibits( b, hbs, qbs )
b3 = ibits( b, tbs, qbs )
p0 = a0 * b0
p1 = a1 * b0 + a0 * b1 + ibits( p0, qbs, tbs )
p2 = a2 * b0 + a1 * b1 + a0 * b2 + ibits( p1, qbs, tbs )
p3 = a3 * b0 + a2 * b1 + a1 * b2 + a0 * b3 + ibits( p2, qbs, tbs )
c = ior( ishft( p1, qbs ), ibits( p0, 0, qbs ) )
c = ior( ishft( p2, hbs ), ibits( c, 0, hbs ) )
c = ior( ishft( p3, tbs ), ibits( c, 0, tbs ) )
return

end function uimlt
!
! elemental function uidiv( a, b ) result( c )
!
! intrinsic :: btest, ishft
!
! integer(kind=wi), intent(in) :: a, b
!
! integer(kind=wi) :: c
!
! integer(kind=wi) :: dl, rl
!
! if ( btest( a, fbs-1 ) ) then
! if ( btest( b, fbs-1 ) ) then
! if ( a < b ) then
! c = 0
! else
! c = 1
! end if
! else
! dl = ishft( ishft( a, -1 ) / b, 1 )
! rl = uisub( a, uimlt( b, dl ) )
! if ( rl < b ) then
! c = dl
! else
! c = uiadd( dl, 1 )
! end if
! end if
! else
! if ( btest( b, fbs-1 ) ) then
! c = 0
! else
! c = a / b
! end if
! end if
! return
!
! end function uidiv
!
! elemental function uimod( a, b ) result( c )
!
! intrinsic :: modulo, btest, ishft
!
! integer(kind=wi), intent(in) :: a, b
!
! integer(kind=wi) :: c
!
! integer(kind=wi) :: dl, rl
!
! if ( btest( a, fbs-1 ) ) then
! if ( btest( b, fbs-1 ) ) then
! if ( a < b ) then
! c = a
! else
! c = uisub( a, b )
! end if
! else
! dl = ishft( ishft( a, -1 ) / b, 1 )
! rl = uisub( a, uimlt( b, dl ) )
! if ( rl < b ) then
! c = rl
! else
! c = uisub( rl, b )
! end if
! end if
! else
! if ( btest( b, fbs-1 ) ) then
! c = a
! else
! c = modulo( a, b )
! end if
! end if
! return
!
! end function uimod
!
! subroutine init_by_type( put, get )
!
! intrinsic :: present
!
! type(genrand_state), optional, intent(in ) :: put
! type(genrand_state), optional, intent(out) :: get
!
! if ( present( put ) ) then
! if ( put%ini ) state = put
! else if ( present( get ) ) then
! if ( .not. state%ini ) call init_by_scalar( default_seed )
! get = state
! else
! call init_by_scalar( default_seed )
! end if
! return
!
! end subroutine init_by_type

! initializes mt[N] with a seed
subroutine init_by_scalar( put )

! intrinsic :: ishft, ieor, ibits

integer(kind=wi), parameter :: mult_a = 1812433253_wi !z'6C078965'

integer(kind=wi), intent(in) :: put

integer(kind=wi) :: i

state%ini = .true._wi
state%val(1) = ibits( put, 0, fbs )
do i = 2, n, 1
state%val(i) = ieor( state%val(i-1), ishft( state%val(i-1), -30 ) )
state%val(i) = uimlt( state%val(i), mult_a )
state%val(i) = uiadd( state%val(i), i-1_wi )
! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier.
! In the previous versions, MSBs of the seed affect
! only MSBs of the array mt[].
! 2002/01/09 modified by Makoto Matsumoto
state%val(i) = ibits( state%val(i), 0, fbs )
! for >32 bit machines
end do
state%cnt = n + 1_wi
return

end subroutine init_by_scalar

! initialize by an array with array-length
! init_key is the array for initializing keys
! key_length is its length
! subroutine init_by_array( put )
!
! intrinsic :: size, max, ishft, ieor, ibits
!
! integer(kind=wi), parameter :: seed_d = 19650218_wi !z'12BD6AA'
! integer(kind=wi), parameter :: mult_a = 1664525_wi !z'19660D'
! integer(kind=wi), parameter :: mult_b = 1566083941_wi !z'5D588B65'
! integer(kind=wi), parameter :: msb1_d = ishft( 1_wi, fbs-1 ) !z'80000000'
!
! integer(kind=wi), dimension(:), intent(in) :: put
!
! integer(kind=wi) :: i, j, k, tp, key_length
!
! call init_by_scalar( seed_d )
! key_length = size( put, dim=1 )
! i = 2_wi
! j = 1_wi
! do k = max( n, key_length ), 1, -1
! tp = ieor( state%val(i-1), ishft( state%val(i-1), -30 ) )
! tp = uimlt( tp, mult_a )
! state%val(i) = ieor( state%val(i), tp )
! state%val(i) = uiadd( state%val(i), uiadd( put(j), j-1_wi ) ) ! non linear
! state%val(i) = ibits( state%val(i), 0, fbs ) ! for WORDSIZE > 32 machines
! i = i + 1_wi
! j = j + 1_wi
! if ( i > n ) then
! state%val(1) = state%val(n)
! i = 2_wi
! end if
! if ( j > key_length) j = 1_wi
! end do
! do k = n-1, 1, -1
! tp = ieor( state%val(i-1), ishft( state%val(i-1), -30 ) )
! tp = uimlt( tp, mult_b )
! state%val(i) = ieor( state%val(i), tp )
! state%val(i) = uisub( state%val(i), i-1_wi ) ! non linear
! state%val(i) = ibits( state%val(i), 0, fbs ) ! for WORDSIZE > 32 machines
! i = i + 1_wi
! if ( i > n ) then
! state%val(1) = state%val(n)
! i = 2_wi
! end if
! end do
! state%val(1) = msb1_d ! MSB is 1; assuring non-zero initial array
! return
!
! end subroutine init_by_array

subroutine next_state( )

! intrinsic :: ishft, ieor, btest, ibits, mvbits

integer(kind=wi), parameter :: matrix_a = -1727483681_wi !z'9908b0df'

integer(kind=wi) :: i, mld

if ( .not. state%ini ) call init_by_scalar( default_seed )
do i = 1, n-m, 1
mld = ibits( state%val(i+1), 0, 31 )
call mvbits( state%val(i), 31, 1, mld, 31 )
state%val(i) = ieor( state%val(i+m), ishft( mld, -1 ) )
if ( btest( state%val(i+1), 0 ) ) state%val(i) = ieor( state%val(i), matrix_a )
end do
do i = n-m+1, n-1, 1
mld = ibits( state%val(i+1), 0, 31 )
call mvbits( state%val(i), 31, 1, mld, 31 )
state%val(i) = ieor( state%val(i+m-n), ishft( mld, -1 ) )
if ( btest( state%val(i+1), 0 ) ) state%val(i) = ieor( state%val(i), matrix_a )
end do
mld = ibits( state%val(1), 0, 31 )
call mvbits( state%val(n), 31, 1, mld, 31 )
state%val(n) = ieor( state%val(m), ishft( mld, -1 ) )
if ( btest( state%val(1), 0 ) ) state%val(n) = ieor( state%val(n), matrix_a )
state%cnt = 1_wi
return

end subroutine next_state

! elemental subroutine genrand_encode( chr, val )
!
! intrinsic :: len
!
! character(len=*), intent(out) :: chr
! integer(kind=wi), intent(in ) :: val
!
! integer(kind=wi) :: i, m, d
!
! d = val
! chr = ""
! do i = 1, len( chr ), 1
! m = uimod( d, alps ) + 1
! chr(i:i) = alph(m:m)
! d = uidiv( d, alps )
! if ( d == 0 ) exit
! end do
! return
!
! end subroutine genrand_encode
!
! elemental subroutine genrand_decode( val, chr )
!
! intrinsic :: len, len_trim, trim, adjustl, scan
!
! integer(kind=wi), intent(out) :: val
! character(len=*), intent(in ) :: chr
!
! integer(kind=wi) :: i, e, p
! character(len=len(chr)) :: c
!
! e = 1
! c = trim( adjustl( chr ) )
! val = 0
! do i = 1, len_trim( c ), 1
! p = scan( alph, c(i:i) ) - 1
! if( p >= 0 ) then
! val = uiadd( val, uimlt( p, e ) )
! e = uimlt( e, alps )
! end if
! end do
! return
!
! end subroutine genrand_decode
!
! elemental subroutine genrand_load_state( stt, rpr )
!
! intrinsic :: scan
!
! type(genrand_state), intent(out) :: stt
! type(genrand_srepr), intent(in ) :: rpr
!
! integer(kind=wi) :: i, j
! character(len=clen) :: c
!
! i = 1
! c = rpr%repr
! do
! j = scan( c, sepr )
! if ( j /= 0 ) then
! call genrand_decode( stt%val(i), c(:j-1) )
! i = i + 1
! c = c(j+1:)
! else
! exit
! end if
! end do
! call genrand_decode( stt%cnt, c )
! stt%ini = .true._wi
! return
!
! end subroutine genrand_load_state
!
! elemental subroutine genrand_dump_state( rpr, stt )
!
! intrinsic :: len_trim
!
! type(genrand_srepr), intent(out) :: rpr
! type(genrand_state), intent(in ) :: stt
!
! integer(kind=wi) :: i, j
!
! j = 1
! rpr%repr = ""
! do i = 1, n, 1
! call genrand_encode( rpr%repr(j:), stt%val(i) )
! j = len_trim( rpr%repr ) + 1
! rpr%repr(j:j) = sepr
! j = j + 1
! end do
! call genrand_encode( rpr%repr(j:), stt%cnt )
! return
!
! end subroutine genrand_dump_state

! generates a random number on [0,0xffffffff]-interval
subroutine genrand_int32_0d( y )

! intrinsic :: ieor, iand, ishft

integer(kind=wi), parameter :: temper_a = -1658038656_wi !z'9D2C5680'
integer(kind=wi), parameter :: temper_b = -272236544_wi !z'EFC60000'

integer(kind=wi), intent(out) :: y

if ( state%cnt > n ) call next_state( )
y = state%val(state%cnt)
state%cnt = state%cnt + 1_wi
! Tempering
y = ieor( y, ishft( y, -11 ) )
y = ieor( y, iand( ishft( y, 7 ), temper_a ) )
y = ieor( y, iand( ishft( y, 15 ), temper_b ) )
y = ieor( y, ishft( y, -18 ) )
return

end subroutine genrand_int32_0d

! subroutine genrand_int32_1d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 1 ), 1
! call genrand_int32_0d( y(i) )
! end do
! return
!
! end subroutine genrand_int32_1d
!
! subroutine genrand_int32_2d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 2 ), 1
! call genrand_int32_1d( y(:,i) )
! end do
! return
!
! end subroutine genrand_int32_2d
!
! subroutine genrand_int32_3d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 3 ), 1
! call genrand_int32_2d( y(:,:,i) )
! end do
! return
!
! end subroutine genrand_int32_3d
!
! subroutine genrand_int32_4d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:,:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 4 ), 1
! call genrand_int32_3d( y(:,:,:,i) )
! end do
! return
!
! end subroutine genrand_int32_4d
!
! subroutine genrand_int32_5d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:,:,:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 5 ), 1
! call genrand_int32_4d( y(:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_int32_5d
!
! subroutine genrand_int32_6d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:,:,:,:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 6 ), 1
! call genrand_int32_5d( y(:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_int32_6d
!
! subroutine genrand_int32_7d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:,:,:,:,:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 7 ), 1
! call genrand_int32_6d( y(:,:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_int32_7d
!
! ! generates a random number on [0,0x7fffffff]-interval
! subroutine genrand_int31_0d( y )
!
! intrinsic :: ishft
!
! integer(kind=wi), intent(out) :: y
!
! call genrand_int32_0d( y )
! y = ishft( y, -1 )
! return
!
! end subroutine genrand_int31_0d
!
! subroutine genrand_int31_1d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 1 ), 1
! call genrand_int31_0d( y(i) )
! end do
! return
!
! end subroutine genrand_int31_1d
!
! subroutine genrand_int31_2d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 2 ), 1
! call genrand_int31_1d( y(:,i) )
! end do
! return
!
! end subroutine genrand_int31_2d
!
! subroutine genrand_int31_3d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 3 ), 1
! call genrand_int31_2d( y(:,:,i) )
! end do
! return
!
! end subroutine genrand_int31_3d
!
! subroutine genrand_int31_4d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:,:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 4 ), 1
! call genrand_int31_3d( y(:,:,:,i) )
! end do
! return
!
! end subroutine genrand_int31_4d
!
! subroutine genrand_int31_5d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:,:,:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 5 ), 1
! call genrand_int31_4d( y(:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_int31_5d
!
! subroutine genrand_int31_6d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:,:,:,:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 6 ), 1
! call genrand_int31_5d( y(:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_int31_6d
!
! subroutine genrand_int31_7d( y )
!
! intrinsic :: size
!
! integer(kind=wi), dimension(:,:,:,:,:,:,:), intent(out) :: y
!
! integer(kind=wi) :: i
!
! do i = 1, size( y, 7 ), 1
! call genrand_int31_6d( y(:,:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_int31_7d
!
! ! generates a random number on [0,1]-real-interval
! subroutine genrand_real1_0d( r )
!
! intrinsic :: real
!
! real(kind=wr), intent(out) :: r
!
! integer(kind=wi) :: a
!
! call genrand_int32_0d( a )
! r = real( a, kind=wr ) * pi232_1 + p231d232_1
! ! divided by 2^32-1
! return
!
! end subroutine genrand_real1_0d
!
! subroutine genrand_real1_1d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 1 ), 1
! call genrand_real1_0d( r(i) )
! end do
! return
!
! end subroutine genrand_real1_1d
!
! subroutine genrand_real1_2d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 2 ), 1
! call genrand_real1_1d( r(:,i) )
! end do
! return
!
! end subroutine genrand_real1_2d
!
! subroutine genrand_real1_3d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 3 ), 1
! call genrand_real1_2d( r(:,:,i) )
! end do
! return
!
! end subroutine genrand_real1_3d
!
! subroutine genrand_real1_4d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 4 ), 1
! call genrand_real1_3d( r(:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real1_4d
!
! subroutine genrand_real1_5d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 5 ), 1
! call genrand_real1_4d( r(:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real1_5d
!
! subroutine genrand_real1_6d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 6 ), 1
! call genrand_real1_5d( r(:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real1_6d
!
! subroutine genrand_real1_7d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 7 ), 1
! call genrand_real1_6d( r(:,:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real1_7d
!
! ! generates a random number on [0,1)-real-interval
! subroutine genrand_real2_0d( r )
!
! intrinsic :: real
!
! real(kind=wr), intent(out) :: r
!
! integer(kind=wi) :: a
!
! call genrand_int32_0d( a )
! r = real( a, kind=wr ) * pi232 + 0.5_wr
! ! divided by 2^32
! return
!
! end subroutine genrand_real2_0d
!
! subroutine genrand_real2_1d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 1 ), 1
! call genrand_real2_0d( r(i) )
! end do
! return
!
! end subroutine genrand_real2_1d
!
! subroutine genrand_real2_2d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 2 ), 1
! call genrand_real2_1d( r(:,i) )
! end do
! return
!
! end subroutine genrand_real2_2d
!
! subroutine genrand_real2_3d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 3 ), 1
! call genrand_real2_2d( r(:,:,i) )
! end do
! return
!
! end subroutine genrand_real2_3d
!
! subroutine genrand_real2_4d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 4 ), 1
! call genrand_real2_3d( r(:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real2_4d
!
! subroutine genrand_real2_5d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 5 ), 1
! call genrand_real2_4d( r(:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real2_5d
!
! subroutine genrand_real2_6d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 6 ), 1
! call genrand_real2_5d( r(:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real2_6d
!
! subroutine genrand_real2_7d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 7 ), 1
! call genrand_real2_6d( r(:,:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real2_7d
!
! ! generates a random number on (0,1)-real-interval
! subroutine genrand_real3_0d( r )
!
! intrinsic :: real
!
! real(kind=wr), intent(out) :: r
!
! integer(kind=wi) :: a
!
! call genrand_int32_0d( a )
! r = real( a, kind=wr ) * pi232 + p231_5d232
! ! divided by 2^32
! return
!
! end subroutine genrand_real3_0d
!
! subroutine genrand_real3_1d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 1 ), 1
! call genrand_real3_0d( r(i) )
! end do
! return
!
! end subroutine genrand_real3_1d
!
! subroutine genrand_real3_2d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 2 ), 1
! call genrand_real3_1d( r(:,i) )
! end do
! return
!
! end subroutine genrand_real3_2d
!
! subroutine genrand_real3_3d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 3 ), 1
! call genrand_real3_2d( r(:,:,i) )
! end do
! return
!
! end subroutine genrand_real3_3d
!
! subroutine genrand_real3_4d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 4 ), 1
! call genrand_real3_3d( r(:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real3_4d
!
! subroutine genrand_real3_5d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 5 ), 1
! call genrand_real3_4d( r(:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real3_5d
!
! subroutine genrand_real3_6d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 6 ), 1
! call genrand_real3_5d( r(:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real3_6d
!
! subroutine genrand_real3_7d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 7 ), 1
! call genrand_real3_6d( r(:,:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_real3_7d
!
! ! generates a random number on [0,1) with 53-bit resolution
! subroutine genrand_res53_0d( r )
!
! intrinsic :: ishft, real
!
! real(kind=wr), intent(out) :: r
!
! integer(kind=wi) :: a, b
!
! call genrand_int32_0d( a )
! call genrand_int32_0d( b )
! a = ishft( a, -5 )
! b = ishft( b, -6 )
! r = real( a, kind=wr ) * pi227 + real( b, kind=wr ) * pi253
! return
!
! end subroutine genrand_res53_0d
!
! subroutine genrand_res53_1d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 1 ), 1
! call genrand_res53_0d( r(i) )
! end do
! return
!
! end subroutine genrand_res53_1d
!
! subroutine genrand_res53_2d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 2 ), 1
! call genrand_res53_1d( r(:,i) )
! end do
! return
!
! end subroutine genrand_res53_2d
!
! subroutine genrand_res53_3d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 3 ), 1
! call genrand_res53_2d( r(:,:,i) )
! end do
! return
!
! end subroutine genrand_res53_3d
!
! subroutine genrand_res53_4d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 4 ), 1
! call genrand_res53_3d( r(:,:,:,i) )
! end do
! return
!
! end subroutine genrand_res53_4d
!
! subroutine genrand_res53_5d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 5 ), 1
! call genrand_res53_4d( r(:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_res53_5d
!
! subroutine genrand_res53_6d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 6 ), 1
! call genrand_res53_5d( r(:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_res53_6d
!
! subroutine genrand_res53_7d( r )
!
! intrinsic :: size
!
! real(kind=wr), dimension(:,:,:,:,:,:,:), intent(out) :: r
!
! integer(kind=wi) :: i
!
! do i = 1, size( r, 7 ), 1
! call genrand_res53_6d( r(:,:,:,:,:,:,i) )
! end do
! return
!
! end subroutine genrand_res53_7d
! These real versions are due to Isaku Wada, 2002/01/09 added
! Altered by José Sousa genrand_real[1-3] will not return exactely
! the same values but should have the same properties and are faster

subroutine genrand_real4( r )

! intrinsic :: real

real(kind=wr), intent(out) :: r

integer(kind=wi) :: a

call genrand_int32_0d( a )

if (a < 0) then
r = (real( a, kind=wr ) + p232) * pi232_1
! divided by 2^32-1
else
r = real( a, kind=wr ) * pi232_1
endif
return

end subroutine genrand_real4

!end module mt95
end module random_m

icc -E -C -P -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/fftw.F90 > Common/fftw.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/fftw.p.f -o Common/fftw.o -module Common/
# 1 "Common/fftw.p.f"
!============================================================================
!
! MODULE: fftw_m, originally by DAS 1/14/2011
!
!> Routines used with FFTW, as well as interfaces for library calls.
!
! DESCRIPTION:
!> No FFTW calls should exist outside this routine: the wrapper routines
!! here should be used everywhere.
!!
!! Interfaces for FFTW2 functions are formulated from fftw-2.1.5/fftw/fftwf77.c
!! http://www.fftw.org/fftw2_doc/fftw_5.html. Every FFTW2 function used should
!! have an interface to ensure the argument types are correct.
!! Contains include file fftw_f77.i which has parameters used in FFTW2 calls.
!!
!! FFTW3 provides its own file of constants and interfaces, fftw3.f03.
!! See http://fftw.org/doc/Overview-of-Fortran-interface.html
!
!============================================================================

!The following macro puts any point/array in the [-0.5, 0.5) range:
!The following macro puts any point/array in the [0, 1) range:
!Integer division of a/b rounded up*/
!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

! deprecated identifiers

! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

! very ancient version may require NOSIZEOF

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.

! path before 4.0.9 lacks SIZEOF

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?

! It is considered a bug in OPEN64 that sizeof will not work in our code.

! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit

! name of routine to get name of host program is running on

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m

! how to get the cpu time in seconds

! interface required for mclock routine (timing) to be usable

! interface required for iargc routine (command-line arguments) to be usable

! ftell gives you the current location in a file, to fseek back to it

! if no fseek, ftell is useless

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

module fftw_m

!> use of this is recommended by FFTW3 documentation. It causes no harm for
!! FFTW2, but some compilers (e.g. Open64) do not have it available, so we
!! will keep it hidden for FFTW2 so as not to have to solve that problem yet.
use, intrinsic :: iso_c_binding
use global_m
implicit none

private

!> It is better to use this one which has interfaces too, rather than fftw3.f which has only constants
include 'fftw3.f'

integer*8, private :: fft_plan = 0
integer, private :: ifirst = 0
integer, private :: num_fft_threads = 0
integer :: iret
integer, private :: Nfftold(3) = 0

public :: &
check_FFT_size, &
setup_FFT_sizes, &
gvec_to_fft_index, &
put_into_fftbox, &
get_from_fftbox, &
do_FFT, &
conjg_fftbox, &
multiply_fftboxes, &
destroy_fftw_plans

interface put_into_fftbox
module procedure dput_into_fftbox, zput_into_fftbox
end interface put_into_fftbox

interface get_from_fftbox
module procedure dget_from_fftbox, zget_from_fftbox
end interface get_from_fftbox

contains

!> Originally by gsm Last Modified: 4/10/2010 (gsm)
!! Best FFT grid dimension is given by 2^a*3^b*5^c*7^d*11^e*13^f
!! where a,b,c,d are arbitrary and e,f are 0 or 1
!! Ref: http://www.fftw.org/fftw2_doc/fftw_3.html
!! On entry
!! Nfft = FFT grid dimension to test
!! Nfac = number of factors to test
!! On exit
!! check_FFT_size = .true. if good FFT grid dimension
logical function check_FFT_size(Nfft, Nfac)
integer, intent(in) :: Nfft, Nfac

integer :: remainder, product, ifac, ipow, maxpow
integer, parameter :: maxfac = 6
integer :: pow(maxfac)
integer, parameter :: fac(maxfac) = (/ 2, 3, 5, 7, 11, 13 /)

if(Nfft .lt. 1 .or. Nfac .lt. 1 .or. Nfac .gt. maxfac) then
call die('check_FFT_size input')
endif

remainder = Nfft
do ifac = 1, maxfac
pow(ifac) = 0
enddo

do ifac = 1, Nfac
maxpow = int(log(dble(remainder)) / log(dble(fac(ifac)))) + 1
do ipow = 1, maxpow
if (mod(remainder, fac(ifac)) .eq. 0) then
remainder = remainder / fac(ifac)
pow(ifac) = pow(ifac) + 1
endif
enddo
enddo

product = remainder
do ifac = 1, Nfac
do ipow = 1, pow(ifac)
product = product * fac(ifac)
enddo
enddo
if (product .ne. Nfft) then
call die('Internal error in check_FFT_size; factorization failed')
endif

check_FFT_size = remainder .eq. 1 .and. pow(5) .le. 1 .and. pow(6) .le. 1

return
end function check_FFT_size

!> The former "fft_routines.f90"
!! Sohrab Ismail-Beigi Feb 28 2001
!!
!! There are a set of Fast Fourier-related routines that are used
!! to compute the matrix elements of the type .
!! For many G-vectors, FFTs will be the fastest way to compute them.
!!
!! The FFTW (http://www.fftw.org) suite of routines do the actual work.
!! Most of what is below is interfacing code and routines that simplify
!! small and useful tasks.
!
!!
!! Given gvec%FFTgrid(1:3) values (in FFTgrid), finds appropriate FFT box
!! sizes to use in Nfft(1:3). scale = 1/(Nfftx*Nffty*Nfftz).
!!
subroutine setup_FFT_sizes(FFTgrid,Nfft,scale)
integer, intent(in) :: FFTgrid(3)
integer, intent(out) :: Nfft(3)
real(DP), intent(out) :: scale

integer, parameter :: Nfac = 3
integer :: i

do i=1,3
Nfft(i) = FFTgrid(i)
do while (.not. check_FFT_size(Nfft(i), Nfac))
Nfft(i) = Nfft(i) + 1
enddo
enddo
scale = 1.0d0/product(Nfft(1:3))

return
end subroutine setup_FFT_sizes

!> Takes the G-vector g(1:3) and FFT box size Nfft(1:3) and finds the
!! point idx(1:3) in the box corresponding to that G-vector.
!!
subroutine gvec_to_fft_index(g,idx,Nfft)
integer, intent(in) :: g(3), Nfft(3)
integer, intent(out) :: idx(3)

! no push/pop since called too frequently.

idx(1:3) = g(1:3) + 1

if (g(1) < 0) idx(1) = Nfft(1) + idx(1)
if (g(2) < 0) idx(2) = Nfft(2) + idx(2)
if (g(3) < 0) idx(3) = Nfft(3) + idx(3)

return
end subroutine gvec_to_fft_index

!> Do an FFT on the fftbox in place: destroys contents of fftbox
!! and replaces them by the Fourier transform.
!!
!! The FFT done is:
!!
!! fftbox(p) <- sum_j { fftbox(j)*e^{sign*i*j.p} }
!!
!! where j and p are integer 3-vectors ranging over Nfft(1:3).
!!
subroutine do_FFT(fftbox, Nfft, sign)
complex(DPC), intent(inout) :: fftbox(:,:,:)
integer, intent(in) :: Nfft(3)
integer, intent(in) :: sign

character(len=100) :: str

!JRD To be removed
!complex(DPC), allocatable :: fftbox2(:,:,:)

if (peinf%verb_max) then
write(str,'(a,2(i0," x "),i0,a)') 'Creating ', Nfft(1:3), ' FFTW plans.'
call logit(str)
endif

if(peinf%inode.eq.0) call timacc(93,1)
if (sign == 1) then
call dfftw_plan_dft(fft_plan,3,Nfft,fftbox,fftbox,FFTW_BACKWARD,FFTW_ESTIMATE)
!call dfftw_plan_dft(fft_plan,3,Nfft,fftbox,fftbox2,FFTW_BACKWARD,FFTW_MEASURE)
!call dfftw_plan_dft_3d(fft_plan,Nfft(1),Nfft(2),Nfft(3),fftbox,fftbox2,FFTW_BACKWARD,FFTW_MEASURE)
else if (sign == -1) then
call dfftw_plan_dft(fft_plan,3,Nfft,fftbox,fftbox,FFTW_FORWARD,FFTW_ESTIMATE)
!call dfftw_plan_dft(fft_plan,3,Nfft,fftbox,fftbox2,FFTW_FORWARD,FFTW_MEASURE)
!call dfftw_plan_dft_3d(fft_plan,Nfft(1),Nfft(2),Nfft(3),fftbox,fftbox2,FFTW_FORWARD,FFTW_MEASURE)
else
call die('sign is not 1 or -1 in do_FFT')
endif
if(peinf%inode.eq.0) call timacc(93,2)

if(peinf%inode.eq.0) call timacc(94,1)
call dfftw_execute_dft(fft_plan,fftbox,fftbox)
if(peinf%inode.eq.0) call timacc(94,2)

! otherwise there is a memory leak
call dfftw_destroy_plan(fft_plan)
!call dfftw_cleanup_threads()

Nfftold(:) = -1

!JRD To be removed
!fftbox(:,:,:)=fftbox2(:,:,:)
!if(allocated(fftbox2))then;deallocate(fftbox2);endif

return
end subroutine do_FFT

subroutine destroy_fftw_plans()
character(len=100) :: str

! FFTW plan was never created
if(all(Nfftold(1:3) == 0)) return

if(all(Nfftold(1:3) == -1)) then

return
! call die("Cannot destroy FFTW plan for a second time.")
endif

write(str,'(a,2(i0," x "),i0,a)') 'Destroying ', Nfftold(1:3), ' FFTW plans.'
call logit(str)
Nfftold(1:3) = -1 ! make clear there is no plan anymore so we do not try to destroy twice

call dfftw_destroy_plan(fft_plan)
! should forget wisdom here, but I cannot figure out how... --DAS

return
end subroutine destroy_fftw_plans

!> Complex conjugate contents of FFT box
!
subroutine conjg_fftbox(fftbox,Nfft)
integer, intent(in) :: Nfft(3)
complex(DPC), intent(inout) :: fftbox(:,:,:) !< (Nfft(1), Nfft(2), Nfft(3))
! for some reason, absoft segfaults if dims specified for fftbox as above right

integer :: ix,iy,iz

forall(iz=1:Nfft(3), iy=1:Nfft(2), ix=1:Nfft(1)) fftbox(ix,iy,iz) = conjg(fftbox(ix,iy,iz))

return
end subroutine conjg_fftbox

!> Multiply contents of two fft boxes, result into fftbox2
!
subroutine multiply_fftboxes(fftbox1, fftbox2, Nfft)
integer, intent(in) :: Nfft(3)
complex(DPC), intent(in) :: fftbox1(:,:,:) !< (Nfft(1), Nfft(2), Nfft(3))
complex(DPC), intent(inout) :: fftbox2(:,:,:) !< (Nfft(1), Nfft(2), Nfft(3))

integer :: ix,iy,iz

if(peinf%inode.eq.0) call timacc(95,1)

!forall(ix=1:Nfft(1), iy=1:Nfft(2), iz=1:Nfft(3)) &
! fftbox2(ix,iy,iz) = fftbox1(ix,iy,iz) * fftbox2(ix,iy,iz)

!disabled PARALLEL PRIVATE (ix,iy,iz)
!disabled DO
do iz = 1, Nfft(3)
do iy = 1, Nfft(2)
do ix = 1, Nfft(1)
fftbox2(ix,iy,iz) = fftbox1(ix,iy,iz) * fftbox2(ix,iy,iz)
enddo
enddo
enddo
!disabled END DO
!disabled END PARALLEL

if(peinf%inode.eq.0) call timacc(95,2)

return
end subroutine multiply_fftboxes

! use between inclusions of f_defs.h in template modules
! list here everything defined differently by flavor in f_defs.h
! these undefs prevent lots of warnings from cpp

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
!overrules flavor.mk
!The following macro puts any point/array in the [-0.5, 0.5) range:
!The following macro puts any point/array in the [0, 1) range:
!Integer division of a/b rounded up*/
!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

! deprecated identifiers

! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

! very ancient version may require NOSIZEOF

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.

! path before 4.0.9 lacks SIZEOF

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?

! It is considered a bug in OPEN64 that sizeof will not work in our code.

! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit

! name of routine to get name of host program is running on

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m

! how to get the cpu time in seconds

! interface required for mclock routine (timing) to be usable

! interface required for iargc routine (command-line arguments) to be usable

! ftell gives you the current location in a file, to fseek back to it

! if no fseek, ftell is useless

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
!============================================================================
!
! Included from fftw.F90
!
!============================================================================

!> This routine takes data(1:ndata) and puts it into the FFT box fftbox(:,:,:).
!! The FFT box is zeroed out first, and the data is entered into it.
!!
!! ndata -- number of data items in data(:)
!! data -- the data set, real or complex, depending on ifdef CPLX
!! ng -- number of g vectors in glist
!! glist -- a master list of g vectors
!! gindex(1:ng) -- which g vector (in the master list) the data(1:ndata)
!! actually refer to: so data(j) is for the g-vector
!! glist(1:3,gindex(j))
!! fftbox(:,:,:) -- 3D complex FFT box where the data is put
!! Nfft(1:3) -- sizes of FFT box Nx,Ny,Nz
subroutine dput_into_fftbox(ndata, data, glist, gindex, fftbox, Nfft)
integer, intent(in) :: ndata
real(DP), intent(in) :: data(:) !< (ndata) this is to avoid creation of array temporary
integer, intent(in) :: glist(:,:) !< (3, ng)
integer, intent(in) :: gindex(:) !< (ng)
integer, intent(in) :: Nfft(:) !< (3)
complex(DPC), intent(out) :: fftbox(:,:,:) !< (Nfft(1), Nfft(2), Nfft(3))

integer :: j, bidx(3)

! Zero out FFT box and put data into it
if(peinf%inode.eq.0) call timacc(91,1)

!disabled PARALLEL
!disabled DO
do j=1,Nfft(3)
fftbox(:,:,j) = (0.0d0,0.0d0)
enddo
!disabled END DO
!disabled END PARALLEL

if(peinf%inode.eq.0) call timacc(91,2)
if(peinf%inode.eq.0) call timacc(92,1)

!disabled PARALLEL PRIVATE(bidx,j) SHARED(fftbox, glist, gindex, data)
!disabled DO
do j=1,ndata
call gvec_to_fft_index(glist(:,gindex(j)),bidx,Nfft)
fftbox(bidx(1),bidx(2),bidx(3)) = data(j)
end do
!disabled END DO
!disabled END PARALLEL

if(peinf%inode.eq.0) call timacc(92,2)

return
end subroutine dput_into_fftbox

!> Does the inverse of the above routine: takes the data in the
!! fftbox(:,:,:) and puts it into the data(1:ndata) array. ndata entries
!! are extracted, and the gindex and glist specify which ones to get:
!! data(j) corresponds to the g-vector glist(:,gindex(j)). The data
!! in fftbox is multiplied by scale before storage into data(:).
!!
!! data(:) is zeroed first and then the data is put into it.
!!
subroutine dget_from_fftbox(ndata, data, glist, gindex, fftbox, Nfft, scale)
integer, intent(in) :: ndata
real(DP), intent(out) :: data(:) !< (ndata)
integer, intent(in) :: glist(:,:) !< (3, ng)
integer, intent(in) :: gindex(:) !< (ng)
integer, intent(in) :: Nfft(:)
complex(DPC), intent(in) :: fftbox(:,:,:) !< (Nfft(1), Nfft(2), Nfft(3))
real(DP), intent(in) :: scale

integer :: j, bidx(3)

! Zero out data set
data(:) = 0.0
do j=1,ndata
call gvec_to_fft_index(glist(:,gindex(j)),bidx,Nfft)
data(j) = fftbox(bidx(1),bidx(2),bidx(3))*scale
end do

return
end subroutine dget_from_fftbox

! use between inclusions of f_defs.h in template modules
! list here everything defined differently by flavor in f_defs.h
! these undefs prevent lots of warnings from cpp

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!The following macro puts any point/array in the [-0.5, 0.5) range:
!The following macro puts any point/array in the [0, 1) range:
!Integer division of a/b rounded up*/
!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

! deprecated identifiers

! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

! very ancient version may require NOSIZEOF

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.

! path before 4.0.9 lacks SIZEOF

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?

! It is considered a bug in OPEN64 that sizeof will not work in our code.

! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit

! name of routine to get name of host program is running on

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m

! how to get the cpu time in seconds

! interface required for mclock routine (timing) to be usable

! interface required for iargc routine (command-line arguments) to be usable

! ftell gives you the current location in a file, to fseek back to it

! if no fseek, ftell is useless

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
!============================================================================
!
! Included from fftw.F90
!
!============================================================================

!> This routine takes data(1:ndata) and puts it into the FFT box fftbox(:,:,:).
!! The FFT box is zeroed out first, and the data is entered into it.
!!
!! ndata -- number of data items in data(:)
!! data -- the data set, real or complex, depending on ifdef
!! ng -- number of g vectors in glist
!! glist -- a master list of g vectors
!! gindex(1:ng) -- which g vector (in the master list) the data(1:ndata)
!! actually refer to: so data(j) is for the g-vector
!! glist(1:3,gindex(j))
!! fftbox(:,:,:) -- 3D complex FFT box where the data is put
!! Nfft(1:3) -- sizes of FFT box Nx,Ny,Nz
subroutine zput_into_fftbox(ndata, data, glist, gindex, fftbox, Nfft)
integer, intent(in) :: ndata
complex(DPC), intent(in) :: data(:) !< (ndata) this is to avoid creation of array temporary
integer, intent(in) :: glist(:,:) !< (3, ng)
integer, intent(in) :: gindex(:) !< (ng)
integer, intent(in) :: Nfft(:) !< (3)
complex(DPC), intent(out) :: fftbox(:,:,:) !< (Nfft(1), Nfft(2), Nfft(3))

integer :: j, bidx(3)

! Zero out FFT box and put data into it
if(peinf%inode.eq.0) call timacc(91,1)

!disabled PARALLEL
!disabled DO
do j=1,Nfft(3)
fftbox(:,:,j) = (0.0d0,0.0d0)
enddo
!disabled END DO
!disabled END PARALLEL

if(peinf%inode.eq.0) call timacc(91,2)
if(peinf%inode.eq.0) call timacc(92,1)

!disabled PARALLEL PRIVATE(bidx,j) SHARED(fftbox, glist, gindex, data)
!disabled DO
do j=1,ndata
call gvec_to_fft_index(glist(:,gindex(j)),bidx,Nfft)
fftbox(bidx(1),bidx(2),bidx(3)) = data(j)
end do
!disabled END DO
!disabled END PARALLEL

if(peinf%inode.eq.0) call timacc(92,2)

return
end subroutine zput_into_fftbox

!> Does the inverse of the above routine: takes the data in the
!! fftbox(:,:,:) and puts it into the data(1:ndata) array. ndata entries
!! are extracted, and the gindex and glist specify which ones to get:
!! data(j) corresponds to the g-vector glist(:,gindex(j)). The data
!! in fftbox is multiplied by scale before storage into data(:).
!!
!! data(:) is zeroed first and then the data is put into it.
!!
subroutine zget_from_fftbox(ndata, data, glist, gindex, fftbox, Nfft, scale)
integer, intent(in) :: ndata
complex(DPC), intent(out) :: data(:) !< (ndata)
integer, intent(in) :: glist(:,:) !< (3, ng)
integer, intent(in) :: gindex(:) !< (ng)
integer, intent(in) :: Nfft(:)
complex(DPC), intent(in) :: fftbox(:,:,:) !< (Nfft(1), Nfft(2), Nfft(3))
real(DP), intent(in) :: scale

integer :: j, bidx(3)

! Zero out data set
data(:) = 0.0
do j=1,ndata
call gvec_to_fft_index(glist(:,gindex(j)),bidx,Nfft)
data(j) = fftbox(bidx(1),bidx(2),bidx(3))*scale
end do

return
end subroutine zget_from_fftbox

end module fftw_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/fft_parallel.f90 > Common/fft_parallel.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/fft_parallel.p.f -o Common/fft_parallel.o -module Common/
# 1 "Common/fft_parallel.p.f"
!===============================================================================
!
! Module fft_parallel_m
!
! 1. fft_set_p() Originally By gsm Last Modified 9/20/2010 (gsm)
!
! Sets up distribution of planes and rods for parallel 3D (serial 2D/1D) FFT
!
! 2. fft_map_s() Originally By gsm Last Modified 9/20/2010 (gsm)
!
! Builds box to sphere map for serial 3D FFT
!
! 3. fft_map_p() Originally By gsm Last Modified 9/20/2010 (gsm)
!
! Builds box to sphere map for parallel 3D (serial 2D/1D) FFT
!
! 4. fft_r2g_s() Originally By gsm Last Modified 9/20/2010 (gsm)
!
! Performs forward (from R-space to G-space) serial 3D FFT
!
! 5. fft_r2g_p() Originally By gsm Last Modified 9/20/2010 (gsm)
!
! Performs forward (from R-space to G-space) parallel 3D (serial 2D/1D) FFT
!
! 6. fft_g2r_s() Originally By gsm Last Modified 9/20/2010 (gsm)
!
! Performs backward (from G-space to R-space) serial 3D FFT
!
! 7. fft_g2r_p() Originally By gsm Last Modified 9/20/2010 (gsm)
!
! Performs backward (from G-space to R-space) parallel 3D (serial 2D/1D) FFT
!
!===============================================================================
!
! Forward FFT (from R-space to G-space):
! f(G) = \sum_r f(r) exp(-iGr) = (N / Omega) \int f(r) exp(-iGr) dr
!
! Backward FFT (from G-space to R-space):
! f(r) = \sum_G f(G) exp(iGr)
!
! Omega = unit cell volume, N = FFTgrid(1)*FFTgrid(2)*FFTgrid(3), FFTgrid = FFT grid size
!
! Periodic Bloch function:
! Forward FFT: scale = sqrt(Omega) / N
! u(G) = (1 / sqrt(Omega)) \int u(r) exp(-iGr) dr
! Backward FFT: scale = 1 / sqrt(Omega)
! u(r) = (1 / sqrt(Omega)) \sum_G u(G) exp(iGr)
! \int |u(r)|^2 dr = \sum_G |u(G)|^2 = 1
!
! Electron density:
! Forward FFT: scale = Omega / N
! n(G) = \int n(r) exp(-iGr) dr
! Backward FFT: scale = 1 / Omega
! n(r) = (1 / Omega) \sum_G n(G) exp(iGr)
! \int n(r) dr = n(G = 0) = number of electrons
!
! Ionic pseudopotential, Hartree potential, exchange-correlation potential:
! Forward FFT: scale = 1 / N
! V(G) = (1 / Omega) \int V(r) exp(-iGr) dr
! Backward FFT: scale = 1
! V(r) = \sum_G V(G) exp(iGr)
! (1 / Omega) \int V(r) dr = V(G = 0) = average potential
!
! Coulomb potential:
! Forward FFT: scale = Omega / N
! V_c(G) = \int V_c(r) exp(-iGr) dr = 4 pi e^2 / G^2
! Backward FFT: scale = 1 / Omega
! V_c(r) = (1 / Omega) \sum_G V_c(G) exp(iGr) = e^2 / r
! e^2 = 2 in Rydberg atomic units
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 74 "Common/Common/fft_parallel.f90" 2

module fft_parallel_m

use global_m
use fftw_m

implicit none

private

public :: &
fft_set_p, &
fft_map_s, &
fft_map_p, &
fft_r2g_s, &
fft_r2g_p, &
fft_g2r_s, &
fft_g2r_p

contains

subroutine fft_set_p(FFTgrid, Nplane, Nrod)

integer, intent(in) :: FFTgrid(3)
integer, intent(out) :: Nplane
integer, intent(out) :: Nrod

if (mod(FFTgrid(3),peinf%npes) == 0) then
Nplane = FFTgrid(3)/peinf%npes
else
Nplane = FFTgrid(3)/peinf%npes+1
endif
if (mod(FFTgrid(1)*FFTgrid(2),peinf%npes) == 0) then
Nrod = (FFTgrid(1)*FFTgrid(2))/peinf%npes
else
Nrod = (FFTgrid(1)*FFTgrid(2))/peinf%npes+1
endif

return

end subroutine fft_set_p

!-------------------------------------------------------------------------------

subroutine fft_map_s(ng,FFTgrid,isort,gvec,inv_indx)

integer, intent(in) :: ng
integer, intent(in) :: FFTgrid(3)
integer, intent(in) :: isort(:) !< (ng)
integer, intent(in) :: gvec(:,:) !< (3,ngtot)
integer, intent(out) :: inv_indx(:,:,:) !< (FFTgrid(1),FFTgrid(2),FFTgrid(3))

integer :: ig,id,idx(3)

inv_indx(:,:,:)=0
do ig=1,ng
do id=1,3
idx(id)=gvec(id,isort(ig))+1
if (idx(id).lt.1) idx(id)=idx(id)+FFTgrid(id)
enddo
inv_indx(idx(1),idx(2),idx(3))=ig
enddo

return

end subroutine fft_map_s

!-------------------------------------------------------------------------------

subroutine fft_map_p(imod,ng,ng_l,Nrod,FFTgrid,isort,gvec, &
mrod,msph,crod,csph,drod,dsph,irod,isph)

integer, intent(in) :: imod
integer, intent(in) :: ng
integer, intent(in) :: ng_l
integer, intent(in) :: Nrod
integer, intent(in) :: FFTgrid(3)
integer, intent(in) :: isort(:) !< (ng)
integer, intent(in) :: gvec(:,:) !< (3,ngtot)
integer, intent(inout) :: mrod
integer, intent(inout) :: msph
integer, intent(inout) :: crod(:) !< (peinf%npes)
integer, intent(inout) :: csph(:) !< (peinf%npes)
integer, intent(inout) :: drod(:) !< (peinf%npes)
integer, intent(inout) :: dsph(:) !< (peinf%npes)
integer, intent(out) :: irod(:,:) !< (2,MAX(1,mrod))
integer, intent(out) :: isph(:) !< (MAX(1,msph))

integer :: i,j,k,ig,id,idx(3)
integer, allocatable :: orod(:)
integer, allocatable :: osph(:)

if (imod.eq.0) then

crod(:)=0
csph(:)=0
do ig=1,ng
do id=1,3
idx(id)=gvec(id,isort(ig))+1
if (idx(id).lt.1) idx(id)=idx(id)+FFTgrid(id)
enddo
i=(idx(2)-1)*FFTgrid(1)+idx(1)-1
j=i/Nrod
k=(ig-1)/ng_l
if (peinf%inode.eq.j) crod(k+1)=crod(k+1)+1
if (peinf%inode.eq.k) csph(j+1)=csph(j+1)+1
enddo
do i=1,peinf%npes
drod(i)=sum(crod(1:i-1))
dsph(i)=sum(csph(1:i-1))
enddo
mrod=sum(crod(:))
msph=sum(csph(:))

elseif (imod.eq.1) then

irod(:,:)=0
isph(:)=0
allocate(orod (peinf%npes))
allocate(osph (peinf%npes))
orod(:)=drod(:)
osph(:)=dsph(:)
do ig=1,ng
do id=1,3
idx(id)=gvec(id,isort(ig))+1
if (idx(id).lt.1) idx(id)=idx(id)+FFTgrid(id)
enddo
i=(idx(2)-1)*FFTgrid(1)+idx(1)-1
j=i/Nrod
k=(ig-1)/ng_l
if (peinf%inode.eq.j) then
orod(k+1)=orod(k+1)+1
irod(1,orod(k+1))=idx(3)
irod(2,orod(k+1))=i-j*Nrod+1
endif
if (peinf%inode.eq.k) then
osph(j+1)=osph(j+1)+1
isph(osph(j+1))=ig-k*ng_l
endif
enddo
if(allocated(orod))then;deallocate(orod);endif
if(allocated(osph))then;deallocate(osph);endif

endif

return

end subroutine fft_map_p

!-------------------------------------------------------------------------------

subroutine fft_r2g_s(FFTgrid,scale,inv_indx,fftbox_3D,gsphere)

integer, intent(in) :: FFTgrid(3)
real(DP), intent(in) :: scale
integer, intent(in) :: inv_indx(:,:,:) !< (FFTgrid(1),FFTgrid(2),FFTgrid(3))
complex(DPC), intent(inout) :: fftbox_3D(:,:,:) !< (FFTgrid(1),FFTgrid(2),FFTgrid(3))
complex(DPC), intent(out) :: gsphere(:) !< (ng)

integer :: i1,i2,i3,j1,j2,j3,ig

call do_FFT(fftbox_3D,FFTgrid,-1)

gsphere(:)=(0.0d0,0.0d0)
do j3=-FFTgrid(3)/2,FFTgrid(3)/2-1
i3=j3+1
if (j3.lt.0) i3=FFTgrid(3)+i3
do j2=-FFTgrid(2)/2,FFTgrid(2)/2-1
i2=j2+1
if (j2.lt.0) i2=FFTgrid(2)+i2
do j1=-FFTgrid(1)/2,FFTgrid(1)/2-1
i1=j1+1
if (j1.lt.0) i1=FFTgrid(1)+i1
ig=inv_indx(i1,i2,i3)
if (ig.eq.0) cycle
gsphere(ig)=fftbox_3D(i1,i2,i3)
enddo
enddo
enddo

gsphere(:)=gsphere(:)*scale

return

end subroutine fft_r2g_s

!-------------------------------------------------------------------------------

subroutine fft_r2g_p(FFTgrid,Nplane,Nrod,mrod,msph,crod,csph, &
drod,dsph,irod,isph,scale,fftbox_2D,fftbox_1D,buffer_2D,buffer_1D, &
buffer_rod,buffer_sph,gsphere_d)

integer, intent(in) :: FFTgrid(3)
integer, intent(in) :: Nplane
integer, intent(in) :: Nrod
integer, intent(in) :: mrod
integer, intent(in) :: msph
integer, intent(in) :: crod(:) !< (peinf%npes)
integer, intent(in) :: csph(:) !< (peinf%npes)
integer, intent(in) :: drod(:) !< (peinf%npes)
integer, intent(in) :: dsph(:) !< (peinf%npes)
integer, intent(in) :: irod(:,:) !< (2,MAX(1,mrod))
integer, intent(in) :: isph(:) !< (MAX(1,msph))
real(DP), intent(in) :: scale
complex(DPC), intent(inout) :: fftbox_2D(:,:,:) !< (FFTgrid(1),FFTgrid(2),Nplane)
complex(DPC), intent(out) :: fftbox_1D(:,:) !< (FFTgrid(3),Nrod)
complex(DPC), intent(out) :: buffer_2D(:,:,:) !< (Nrod,Nplane,peinf%npes)
complex(DPC), intent(out) :: buffer_1D(:,:,:) !< (Nrod,Nplane,peinf%npes)
complex(DPC), intent(out) :: buffer_rod(:) !< (MAX(1,mrod))
complex(DPC), intent(out) :: buffer_sph(:) !< (MAX(1,msph))
complex(DPC), intent(out) :: gsphere_d(:) !< (ng_l)

integer :: i,j,k,i1,i2,i3
integer :: NSize(3)
complex(DPC), allocatable :: fftbox_temp(:,:,:)

NSize(:)=FFTgrid(:)
NSize(3)=1
allocate(fftbox_temp (NSize(1),NSize(2),NSize(3)))
do i=1,Nplane
fftbox_temp(:,:,1)=fftbox_2D(:,:,i)
call do_FFT(fftbox_temp,NSize,-1)
fftbox_2D(:,:,i)=fftbox_temp(:,:,1)
enddo
if(allocated(fftbox_temp))then;deallocate(fftbox_temp);endif

buffer_2D(:,:,:)=(0.0d0,0.0d0)
do k=1,Nplane
do i2=1,FFTgrid(2)
do i1=1,FFTgrid(1)
i=(i2-1)*FFTgrid(1)+i1-1
j=i/Nrod
buffer_2D(i-j*Nrod+1,k,j+1)=fftbox_2D(i1,i2,k)
enddo
enddo
enddo

buffer_1D(:,:,:)=buffer_2D(:,:,:)

do i3=1,FFTgrid(3)
do i=1,Nrod
j=(i3-1)/Nplane
fftbox_1D(i3,i)=buffer_1D(i,i3-j*Nplane,j+1)
enddo
enddo

NSize(:)=1
NSize(1)=FFTgrid(3)
allocate(fftbox_temp (NSize(1),NSize(2),NSize(3)))
do i=1,Nrod
fftbox_temp(:,1,1)=fftbox_1D(:,i)
call do_FFT(fftbox_temp,NSize,-1)
fftbox_1D(:,i)=fftbox_temp(:,1,1)
enddo
if(allocated(fftbox_temp))then;deallocate(fftbox_temp);endif

buffer_rod(:)=(0.0d0,0.0d0)
do i=1,mrod
buffer_rod(i)=fftbox_1D(irod(1,i),irod(2,i))
enddo

buffer_sph(:)=buffer_rod(:)

gsphere_d(:)=(0.0d0,0.0d0)
do i=1,msph
gsphere_d(isph(i))=buffer_sph(i)
enddo

gsphere_d(:)=gsphere_d(:)*scale

return
end subroutine fft_r2g_p

!-------------------------------------------------------------------------------

subroutine fft_g2r_s(FFTgrid,scale,inv_indx,gsphere,fftbox_3D)

integer, intent(in) :: FFTgrid(3)
real(DP), intent(in) :: scale
integer, intent(in) :: inv_indx(:,:,:) !< (FFTgrid(1),FFTgrid(2),FFTgrid(3))
complex(DPC), intent(in) :: gsphere(:) ! Common/trunc_cell_box.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/trunc_cell_box.p.f -o Common/trunc_cell_box.o -module Common/
# 1 "Common/trunc_cell_box.p.f"
!================================================================================
!
! Routines:
!
! 1. trunc_cell_box() Originally By JRD Last Modified 3/01/2009 (JRD)
!
! Calculate Coulomb interaction with Cell Box Truncation.
!
! The Coulomb potential is calculated through FFT on the extended cell.
!
! n_in_box is a (positive integer) parameter for real-space resolution.
! If the energy cutoff is too small, then the FFT grid may not be very
! dense and the Coulomb singularity at r=0 may be poorly handled.
! Larger values of n_in_box will add extra points in between the original
! FFT grid. If the original grid has N points covering a space of length
! L, then the grid used to do 3-dimensional FFTs will have N * n_in_box
! points covering a space of length L.
!
! When V_coul(x,y,z) is calculated, we add a shift on the grid in
! order to avoid the singularity at x = y = z = 0.
!
! Output is truncated Vcoul(G_1,G_2,G_3) in reciprocal space such that,
! without truncation, its value would be:
!
! Vcoul(ig) = 8 Pi/(q + G)*2
!
! for each G-vector G = gvec%components(:,isrtq(ig)) in the list.
!
! Calculation is distributed over processors but array vcoul returns
! with global value.
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 35 "Common/Common/trunc_cell_box.f90" 2

module trunc_cell_box_m

use global_m
use fft_parallel_m
use fftw_m
use misc_m

implicit none

private

public :: &
trunc_cell_box

contains

subroutine trunc_cell_box(gvec,verbose,bdot,ncoul,isrtq,vcoul,coulomb_mod)

type (gspace), intent(in) :: gvec !< Reciprocal space structure
logical, intent(in) :: verbose !< Flag for extra output on unit 6
real(DP), intent(in) :: bdot(3,3) !< Metric matrix in reciprocal space
integer, intent(in) :: ncoul !< Number of G-vectors
integer, intent(in) :: isrtq(ncoul) !< Indices of G-vectors
real(DP), intent(out) :: vcoul(ncoul) !< Coulomb potential
!> Optional coulomb modifier parameters. Used in TDDFT and hybrid functional calculations
!! they allow one to change the bare coulomb interaction.
type(coulomb_modifier_t), optional, intent(in) :: coulomb_mod

integer :: i1, i2, i3, j1, j2, j3, l1, l2, l3, ig, &
Nfft(3), dNfft(3), dkmax(3), i, j
real(DP) :: r_len, rr(3), t_len, tt(3), adot(3,3), &
scale, dscale, phase, vimag, vdummy, fac1, fac2, &
screening_length
real(DP) :: b(3,3)
complex(DPC) :: vtemp
complex(DPC), allocatable :: fftbox_3D(:,:,:)
complex(DPC), allocatable :: dummy(:,:,:)
integer, allocatable :: inv_indx(:,:,:)
real(DP) :: derf, derfc

! Initialize FFT grids.

call setup_FFT_sizes(gvec%FFTgrid,Nfft,scale)
dkmax(1) = gvec%FFTgrid(1) * n_in_box
dkmax(2) = gvec%FFTgrid(2) * n_in_box
dkmax(3) = gvec%FFTgrid(3) * n_in_box
call setup_FFT_sizes(dkmax,dNfft,dscale)

! Initialize real-space metric.

rr = 0.0d0
call invert_matrix(bdot, adot)
adot = adot * 4.0d0 * PI_D * PI_D

do i =1,3
do j=1,3
adot(i,j) = adot(i,j) / dble(dNfft(i) * dNfft(j))
enddo
enddo

! Initialize boxes.

allocate(fftbox_3D (dNfft(1),dNfft(2),dNfft(3)))
allocate(dummy (dNfft(1),dNfft(2),dNfft(3)))

if (verbose) then
if (peinf%inode .eq. 0) then
write(6,555) dNfft, n_in_box
endif
endif
555 format(/,1x,"Cell truncation.",/,2x,"Building truncated Coulomb", &
1x,"potential using 3-D FFTs.",/,2x,"3-D FFT grid =",3i5,/,2x, &
"Extra points between two points in a 3-D FFT grid =",i3,/)

! Rescale with the volume of the unit cell.

b = adot
scale = b(1,1)*(b(2,2)*b(3,3) - b(2,3)**2) &
+ 2*b(1,2)*b(2,3)*b(3,1) &
- b(2,2)*b(1,3)**2 - b(3,3)*b(1,2)**2
scale = 2.0d0 * dsqrt(scale)
if (present(coulomb_mod)) then
screening_length = coulomb_mod%screening_length*BOHR
fac1 = coulomb_mod%short_range_frac_fock * scale
fac2 = coulomb_mod%long_range_frac_fock * scale
else
fac1 = scale
fac2 = 0.0d0
screening_length = 0.0d0
endif

! Invert G-index

allocate(inv_indx (Nfft(1),Nfft(2),Nfft(3)))
call fft_map_s(ncoul,Nfft,isrtq,gvec%components,inv_indx)

! For each G_3 plane, calculate the potential V_trunc(r1,r2,r3).
! The potential is not zero only inside the Wigner-Seitz cell.

fftbox_3D = (0.0d0,0.0d0)
do i3 = 1, dNfft(3)
if (mod(i3-1,peinf%npes) /= peinf%inode) cycle
rr(3) = dble(i3 - 1) + trunc_shift(3)
do i2 = 1, dNfft(2)
rr(2) = dble(i2 - 1) + trunc_shift(2)
do i1 = 1, dNfft(1)
rr(1) = dble(i1 - 1) + trunc_shift(1)

r_len = INF

do l3 = -ncell+1, ncell
tt(3) = rr(3) - dble(l3 * dNfft(3))
do l2 = -ncell+1, ncell
tt(2) = rr(2) - dble(l2 * dNfft(2))
do l1 = -ncell+1, ncell
tt(1) = rr(1) - dble(l1 * dNfft(1))
t_len = dot_product(tt,matmul(adot,tt))
if (t_len < r_len) r_len = t_len
enddo
enddo
enddo

r_len = sqrt(r_len)

!fftbox_3D(i1,i2,i3) = 1.0d0 / r_len
fftbox_3D(i1,i2,i3) = fac1/ r_len

enddo
enddo
enddo

!---------------------------------------
! gsm: Below is equivalent to fft_r2g_s except we multiply by a phase,
! collect the real part and check that the imaginary part is smaller
! than the tolerance. Calling fft_r2g_s directly and then altering
! the result would cost extra memory and code execution.

! Do a three-dimensional Fourier transform:
! V_trunc(r1,r2,r3) -> V_trunc(G_1,G_2,G_3)

call do_FFT(fftbox_3D,dNfft,-1)

! Collect components of V_trunc for G-vectors in Coulomb list.

vcoul = 0.0d0
vimag = 0.0d0
do j3 = - Nfft(3)/2, Nfft(3) - Nfft(3)/2 - 1
l3 = j3 + 1
if (j3 < 0) l3 = Nfft(3) + l3
i3 = j3 + 1
if (j3 < 0) i3 = dNfft(3) + i3
do j2 = - Nfft(2)/2, Nfft(2) - Nfft(2)/2 - 1
l2 = j2 + 1
if (j2 < 0) l2 = Nfft(2) + l2
i2 = j2 + 1
if (j2 < 0) i2 = dNfft(2) + i2
do j1 = - Nfft(1)/2, Nfft(1) - Nfft(1)/2 - 1
l1 = j1 + 1
if (j1 < 0) l1 = Nfft(1) + l1
i1 = j1 + 1
if (j1 < 0) i1 = dNfft(1) + i1
ig = inv_indx(l1,l2,l3)
if (ig == 0) cycle

! (gsm) [2010-06-17] there was a bug here
! the singularity of the Coulomb potential was shifted from
! the origin of the coordinate system by half a grid step

! vcoul(ig) = dble(fftbox_3D(i1,i2,i3))

phase = dble(j1) * trunc_shift(1) / dble(dNfft(1)) &
+ dble(j2) * trunc_shift(2) / dble(dNfft(2)) &
+ dble(j3) * trunc_shift(3) / dble(dNfft(3))
phase = 2.0d0 * PI_D * phase
vtemp = fftbox_3D(i1,i2,i3)
vtemp = vtemp * cmplx(cos(phase),-sin(phase),kind=DPC)
vcoul(ig) = dble(vtemp)
vdummy = abs(aimag(vtemp))
if (vdummy.gt.vimag) vimag=vdummy
enddo
enddo
enddo

if (vimag.gt.TOL_Small) &
call die("The Coulomb interaction was incorrectly computed as complex: most likely a problem with your FFT library.", &
only_root_writes = .true.)

call destroy_fftw_plans()
if(allocated(fftbox_3D))then;deallocate(fftbox_3D);endif
if(allocated(dummy))then;deallocate(dummy);endif
if(allocated(inv_indx))then;deallocate(inv_indx);endif

return
end subroutine trunc_cell_box

end module trunc_cell_box_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/trunc_cell_box_d.f90 > Common/trunc_cell_box_d.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/trunc_cell_box_d.p.f -o Common/trunc_cell_box_d.o -module Common/
# 1 "Common/trunc_cell_box_d.p.f"
!================================================================================
!
! Routines:
!
! 1. trunc_cell_box_d() Originally By JRD Last Modified 9/09/2009 (gsm)
!
! Modification of trunc_cell_box with parallel FFT.
!
! Calculate Coulomb interaction with Cell Box Truncation.
!
! The Coulomb potential is calculated through FFT on the extended cell.
!
! n_in_box is a (positive integer) parameter for real-space resolution.
! If the energy cutoff is too small, then the FFT grid may not be very
! dense and the Coulomb singularity at r=0 may be poorly handled.
! Larger values of n_in_box will add extra points in between the original
! FFT grid. If the original grid has N points covering a space of length
! L, then the grid used to do 3-dimensional FFTs will have N * n_in_box
! points covering a space of length L.
!
! When V_coul(x,y,z) is calculated, we add a shift on the grid in
! order to avoid the singularity at x = y = z = 0.
!
! Output is truncated Vcoul(G_1,G_2,G_3) in reciprocal space such that,
! without truncation, its value would be:
!
! Vcoul(ig) = 8 Pi/(q + G)*2
!
! for each G-vector G = gvec%components(:,isrtq(ig)) in the list.
!
! Calculation is distributed over processors but array vcoul returns
! with global value.
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 37 "Common/Common/trunc_cell_box_d.f90" 2

module trunc_cell_box_d_m

use global_m
use fft_parallel_m
use fftw_m
use misc_m

implicit none

private

public :: &
trunc_cell_box_d

contains

subroutine trunc_cell_box_d(gvec,verbose,inode,npes,bdot,ncoul,isrtq,vcoul,coulomb_mod)

type (gspace), intent(in) :: gvec !< Reciprocal space structure
logical, intent(in) :: verbose !< Flag for extra output on unit 6
integer, intent(in) :: inode, npes !< MPI parameters: processor rank, number of processors
real(DP), intent(in) :: bdot(3,3) !< Metric matrix in reciprocal space
integer, intent(in) :: ncoul !< Number of G-vectors
integer, intent(in) :: isrtq(ncoul) !< Indices of G-vectors
real(DP), intent(out) :: vcoul(ncoul) !< Coulomb potential
!> Optional coulomb modifier parameters. Used in TDDFT and hybrid functional calculations
!! they allow one to change the bare coulomb interaction.
type(coulomb_modifier_t), optional, intent(in) :: coulomb_mod

integer :: i1, i2, i3, j1, j2, j3, l1, l2, l3, ig, &
Nfft(3), dNfft(3), dkmax(3), Nrod, Nplane, i, j, k, NSize(3)
real(DP) :: r_len, rr(3), t_len, tt(3), adot(3,3), &
scale, dscale, phase, vimag, vdummy, screening_length, &
fac1, fac2
real(DP) :: b(3,3)
complex(DPC) :: vtemp
real(DP), allocatable :: xdummy(:)
complex(DPC), allocatable :: fftbox_temp(:,:,:)
complex(DPC), allocatable :: fftbox_2D(:,:,:)
complex(DPC), allocatable :: fftbox_1D(:,:)
complex(DPC), allocatable :: buffer_2D(:,:,:)
complex(DPC), allocatable :: buffer_1D(:,:,:)
integer, allocatable :: inv_indx(:,:,:)
real(DP) :: derf, derfc

! Initialize FFT grids.

call setup_FFT_sizes(gvec%FFTgrid,Nfft,scale)
dkmax(1) = gvec%FFTgrid(1) * n_in_box
dkmax(2) = gvec%FFTgrid(2) * n_in_box
dkmax(3) = gvec%FFTgrid(3) * n_in_box
call setup_FFT_sizes(dkmax,dNfft,dscale)

! Initialize real-space metric.

rr = 0.0d0
call invert_matrix(bdot, adot)
adot = adot * 4.0d0 * PI_D * PI_D

do i =1,3
do j=1,3
adot(i,j) = adot(i,j) / dble(dNfft(i) * dNfft(j))
enddo
enddo

! Initialize boxes.

call fft_set_p(dNfft,Nplane,Nrod)
allocate(fftbox_2D (dNfft(1),dNfft(2),Nplane))
allocate(fftbox_1D (dNfft(3),Nrod))
allocate(buffer_2D (Nrod,Nplane,npes))
allocate(buffer_1D (Nrod,Nplane,npes))

if (verbose) then
if (inode .eq. 0) then
write(6,555) dNfft, n_in_box
endif
endif
555 format(/,1x,"Cell truncation.",/,2x,"Building truncated Coulomb", &
1x,"potential using 2-D/1-D FFTs.",/,2x,"2-D/1-D FFT grid =", &
3i5,/,2x,"Extra points between two points in a 2-D/1-D FFT", &
1x,"grid =",i3,/)

! Rescale with the volume of the unit cell.

b = adot
scale = b(1,1)*(b(2,2)*b(3,3) - b(2,3)**2) &
+ 2*b(1,2)*b(2,3)*b(3,1) &
- b(2,2)*b(1,3)**2 - b(3,3)*b(1,2)**2
scale = 2.0d0 * dsqrt(scale)
!vcoul = vcoul * scale
if (present(coulomb_mod)) then
screening_length = coulomb_mod%screening_length*BOHR
fac1 = coulomb_mod%short_range_frac_fock * scale
fac2 = coulomb_mod%long_range_frac_fock * scale
else
fac1 = scale
fac2 = 0.0d0
screening_length = 0.0d0
endif

! Invert G-index

allocate(inv_indx (Nfft(1),Nfft(2),Nfft(3)))
call fft_map_s(ncoul,Nfft,isrtq,gvec%components,inv_indx)

! For each G_3 plane, calculate the potential V_trunc(r1,r2,r3).
! The potential is not zero only inside the Wigner-Seitz cell.

fftbox_2D(:,:,:)=(0.0d0,0.0d0)
do i3 = Nplane*inode+1, min(Nplane*(inode+1),dNfft(3))
rr(3) = dble(i3 - 1) + trunc_shift(3)
do i2 = 1, dNfft(2)
rr(2) = dble(i2 - 1) + trunc_shift(2)
do i1 = 1, dNfft(1)
rr(1) = dble(i1 - 1) + trunc_shift(1)

r_len = INF

do l3 = -ncell+1, ncell
tt(3) = rr(3) - dble(l3 * dNfft(3))
do l2 = -ncell+1, ncell
tt(2) = rr(2) - dble(l2 * dNfft(2))
do l1 = -ncell+1, ncell
tt(1) = rr(1) - dble(l1 * dNfft(1))
t_len = dot_product(tt,matmul(adot,tt))
if (t_len < r_len) r_len = t_len
enddo
enddo
enddo

r_len = sqrt(r_len)

!fftbox_2D(i1,i2,i3-Nplane*inode) = 1.0d0 / r_len
fftbox_2D(i1,i2,i3-Nplane*inode) = fac1/ r_len

enddo
enddo
enddo

!---------------------------------------
! gsm: Below is equivalent to fft_r2g_p/_s except we multiply by a phase,
! collect the real part and check that the imaginary part is smaller
! than the tolerance. Calling fft_r2g_p directly and then altering
! the result would cost extra memory and code execution.

! Do two-dimensional Fourier transforms:
! V_trunc(r1,r2,r3) -> V_trunc(G_1,G_2,r3)

NSize(:)=dNfft(:)
NSize(3)=1
allocate(fftbox_temp (NSize(1),NSize(2),NSize(3)))
do i = 1, Nplane
fftbox_temp(:,:,1)=fftbox_2D(:,:,i)
call do_FFT(fftbox_temp,NSize,-1)
fftbox_2D(:,:,i)=fftbox_temp(:,:,1)
enddo
if(allocated(fftbox_temp))then;deallocate(fftbox_temp);endif

! Transfer data from fftbox_2D to fftbox_1D

buffer_2D(:,:,:)=(0.0d0,0.0d0)
do k = 1, Nplane
do i2 = 1, dNfft(2)
do i1 = 1, dNfft(1)
i = (i2-1)*dNfft(1)+i1-1
j = i/Nrod
buffer_2D(i-j*Nrod+1,k,j+1) = fftbox_2D(i1,i2,k)
enddo
enddo
enddo

buffer_1D(:,:,:)=buffer_2D(:,:,:)

do i3 = 1, dNfft(3)
j = (i3-1)/Nplane
do i = 1, Nrod
fftbox_1D(i3,i) = buffer_1D(i,i3-j*Nplane,j+1)
enddo
enddo

! Do one-dimensional Fourier transforms:
! V_trunc(G_1,G_2,r3) -> V_trunc(G_1,G_2,G_3)

NSize(:)=1
NSize(1)=dNfft(3)
allocate(fftbox_temp (NSize(1),NSize(2),NSize(3)))
do i = 1, Nrod
fftbox_temp(:,1,1)=fftbox_1D(:,i)
call do_FFT(fftbox_temp,NSize,-1)
fftbox_1D(:,i)=fftbox_temp(:,1,1)
enddo
if(allocated(fftbox_temp))then;deallocate(fftbox_temp);endif

! Collect components of V_trunc for G-vectors in Coulomb list.

vcoul = 0.0d0
vimag = 0.0d0
! XXX THREAD?
do j3 = - Nfft(3)/2, Nfft(3) - Nfft(3)/2 - 1
l3 = j3 + 1
if (j3 < 0) l3 = Nfft(3) + l3
i3 = j3 + 1
if (j3 < 0) i3 = dNfft(3) + i3
do j2 = - Nfft(2)/2, Nfft(2) - Nfft(2)/2 - 1
l2 = j2 + 1
if (j2 < 0) l2 = Nfft(2) + l2
i2 = j2 + 1
if (j2 < 0) i2 = dNfft(2) + i2
do j1 = - Nfft(1)/2, Nfft(1) - Nfft(1)/2 - 1
l1 = j1 + 1
if (j1 < 0) l1 = Nfft(1) + l1
i1 = j1 + 1
if (j1 < 0) i1 = dNfft(1) + i1
ig = inv_indx(l1,l2,l3)
if (ig == 0) cycle
i = (i2-1)*dNfft(1)+i1-1
j = i/Nrod

! (gsm) [2010-06-17] there was a bug here
! the singularity of the Coulomb potential was shiftd from
! the origin of the coordinate system by half a grid step

! if (j == inode) vcoul(ig) = &
! dble(fftbox_1D(i3,i-j*Nrod+1))

if (j == inode) then
phase = dble(j1) * trunc_shift(1) / dble(dNfft(1)) &
+ dble(j2) * trunc_shift(2) / dble(dNfft(2)) &
+ dble(j3) * trunc_shift(3) / dble(dNfft(3))
phase = 2.0d0 * PI_D * phase
vtemp = fftbox_1D(i3,i-j*Nrod+1)
vtemp = vtemp * cmplx(cos(phase),-sin(phase),kind=DPC)
vcoul(ig) = dble(vtemp)
vdummy = abs(aimag(vtemp))
if (vdummy.gt.vimag) vimag=vdummy
endif
enddo
enddo
enddo

if (vimag.gt.TOL_Small) &
call die("The Coulomb interaction was incorrectly computed as complex: most likely a problem with your FFT library.", &
only_root_writes = .true.)

call destroy_fftw_plans()
if(allocated(fftbox_2D))then;deallocate(fftbox_2D);endif
if(allocated(fftbox_1D))then;deallocate(fftbox_1D);endif
if(allocated(buffer_2D))then;deallocate(buffer_2D);endif
if(allocated(buffer_1D))then;deallocate(buffer_1D);endif
if(allocated(inv_indx))then;deallocate(inv_indx);endif

! Global reduction if there is more than one processor.

# 309

return
end subroutine trunc_cell_box_d

end module trunc_cell_box_d_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/vcoul_generator.f90 > Common/vcoul_generator.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/vcoul_generator.p.f -o Common/vcoul_generator.o -module Common/
# 1 "Common/vcoul_generator.p.f"
!==============================================================================
!
! Module:
!
! (1) vcoul_generator() Originally by JRD Last Modified: 06/21/2013 (FHJ)
!
! Generates the (Truncated) Coulomb Interaction for all G at a particular
! q. Outputs what would be 8Pi/q^2 if not for truncation.
!
!==============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 13 "Common/Common/vcoul_generator.f90" 2

module vcoul_generator_m

use global_m
use minibzaverage_m
use random_m
use trunc_cell_box_m
use trunc_cell_box_d_m

implicit none

private

public :: &
vcoul_generator, &
destroy_qran

real(DP), allocatable, private :: qran(:,:)
real(DP), private :: q0sph2 = 0d0
integer, private :: ifirst = 1

contains

!> FHJ: Calculates the (average) bare Coulomb interaction v(q+G) in Rydberg.
!! This function uses different forms of v(q+G) (see below) depending on the
!! dimensionality of the system and whether the potential is truncated. The
!! Coulomb interaction is optionally averaged on the mini-BZ around the q
!! vector, and the average screened interaction wcoul0 is also calculated for
!! q->0 and G=0.
!!
!! Note: we use a special flag, peinf%jobtypeeval, to determine whether
!! vcoul_generator should be a "dumb generator" (if jobtypeeval=0) or
!! "smart consumer" (if 1). The main reasons for this division are the following:
!! 1) For sigma and absorption, the idea is that we are evaluating the
!! "best estimate" for W(q=0) and v(q=0) for a given k-grid, using the known
!! analytical limits for epsinv and performing a Monte Carlo integration to
!! evaluate quantities such as <1/q^2>. Epsilon is always calculated with a
!! finite but non-averaged v(q), and each program that calculates W determines
!! if it`s necessary to performing such an averaging.
!! 2) In sigma, we divide SX into (SX-X) + X, so we have to be consistent with
!! the way we average the quantities v=<1/q^2> and w=. In particular,
!! we "hack" v to make it consistent with W, otherwise the partition (SX-X) + X
!! would not be correct for metals. We never perform these "hacks" on v(q)
!! if peinf%jobtypeeval=0.
subroutine vcoul_generator(itruncflag, truncval, gvec, bdot, celvol, nfq, ncoul, &
isrtq, iscreen, qvec, q0vec, vcoul, iwritecoul, iparallel, avgcut, &
oneoverq, qgrid, epshead, work_scell, averagew, wcoul0, coulomb_mod,nfreq_group)
!> Truncation flag. The current supported options are:
!! 0: No truncation (for 3D systems)
!! 4: Wire truncation (for 1D systems)
!! 5: Box truncation (for 0D systems)
!! 6: Slab truncation (for 2D systems)
integer, intent(in) :: itruncflag
!> Used for spherical truncation only.
real(DP), intent(in) :: truncval(3)
!> G space containing the G-vectors used to calculate v(q+G)
type (gspace), intent(in) :: gvec
!> Metric of the reciprocal lattice
real(DP), intent(in) :: bdot(3,3)
!> Volume of the unit cell
real(DP), intent(in) :: celvol
!> FHJ: This is used for miniBZ averages, and only if peinf%jobtypeeval==1
!! This should always match product(qgrid)
integer, intent(in) :: nfq
!> Number of G vectors to calculate v(q+G)
integer, intent(in) :: ncoul
!> (ncoul) Indices of the G vectors from gvec which we are using to build v(q+G)
integer, intent(in) :: isrtq(:)
!> Screening type. 0 for semiconductor, 1 for graphene, 2 for metal
integer, intent(in) :: iscreen
!> The q vector that we use to calculate v(q+G).
!! The null vector q=(/0,0,0/) is perfectly valid here.
real(DP), intent(in) :: qvec(3)
!> The q0 vector that was used in eps0mat, which can never be the null vector.
real(DP), intent(in) :: q0vec(3)
!> (ncoul) The output, 8*pi*<1/(q+G)^2> if there`s no truncation.
real(DP), intent(out) :: vcoul(:)
!> Write vcoul to a file?
integer, intent(in) :: iwritecoul
!> FIXME Not sure what 0 really means if you use MPI!
integer, intent(in) :: iparallel
!> If |q+G|^2 < avgcut, calculate <1/(q+G)^2>. Otherwise, calculate 1/(q+G)^2.
!! The default value for avgcut is TOL_SMALL, i.e., average only done if G=0.
real(DP), intent(in) :: avgcut
!> Returns <1/q> or 1/q0
real(DP), intent(out) :: oneoverq
!> The q/k-grid being used, which determined the mini-BZ used to construct
!! averages such as <1/(q+G)^2>. This is only used if peinf%jobtypeeval==1,
!! except for supercell truncation (untested). In this case, qgrid actualy
!! means the number of replicas of the system to include.
integer, intent(in) :: qgrid(3)
!> Head of epsilon^{-1}. Used to construct wcoul0.
complex(DPC), intent(in) :: epshead
!> FIXME A mysterious working buffer for "supercell box truncation"
type (twork_scell), intent(inout) :: work_scell
!! If .true., calculate W as
logical, intent(in) :: averagew
!> If averagew==.true., wcoul0 is . We use the analytical limit of
!! epsinv(q->0) to perform the proper average. Examples:
!! - For 3D semiconductors, epsinv(q->0)~const => wcoul0 = epsinv*vcoul(0)
!! - For 3D metals, epsinv(q->0)~q^2 => wcoul0 = epsinv*8*pi/q0^2, where q0 is
!! the same q used to evaluate epsinv(q->0).
complex(DPC), intent(inout) :: wcoul0
!> Optional coulomb modifier parameters. Used in TDDFT and hybrid functional calculations
!! they allow one to change the bare coulomb interaction. Can only
!! be used with no truncation
type(coulomb_modifier_t), optional, intent(in) :: coulomb_mod
!> DVF: Optional number of parallel frequency groups. For when this computation of the
!! bare coulomb interaction is for a calculation of epsilon using parallel frequencies
integer, intent(in), optional :: nfreq_group

integer :: i1, i2, i3, ii, jj, nn, ig, nint, iCommFlag, iCommFlagGlobal
integer :: gk(3), seed
real(DP), allocatable :: vcoul2(:)
real(DP) :: dvalue, temp_exp, screeninv
real(DP) :: qk(3), qkxy(3), qlen, q0len, ekinx, kxy
real(DP) :: kz, zc, qkz(3), dummy, qvec_mod(3)
real(DP) :: dd(3),fq(3),vlength, lmin, qpp(3)
real(DP), allocatable :: ran(:,:)

real(DP), save :: oneoverq0
real(DP), save :: vcoul0
!> Depending on avg_cut, the code needs to average the potential in the
!! miniBZ. The following flag is set to true after we calculated for
!! q->0, so we can reuse that integral later for q=0.
logical, save :: minibz_done = .false.
!> It there`s no truncation, we also need to calculate the average <1/q>
!! for the wings. The following flag is set to true after we calculated
!! <1/q> for q->0.
logical, save :: oneoverq0_done = .false.
!> Depending on avg_cut, the code needs to average the modified potential in the
!! miniBZ. The following flag is set to true after we calculated for
!! q->0 for the modified potential, so we can reuse that integral later for q=0.
!! This is separate from minibz_done because you may need to recalculate vcoul
!! without the modifier for the exchange part of the kernel etc.
logical, save :: minibz_mod_done = .false.
!> DVF: This is needed to accommodate the use of parallel frequencies group in FF
!! epsilon calculations. It is just equal to peinf%npes unless you are using
!! parallel frequency groups in FF epsilon calculations. See the epsilon code
!! for an explanation of why you need a different value in this case.
integer :: npes_local

! FHJ: Variables used for minibz calculation
real(DP) :: UU(3,3), vmid(3)
integer :: qran_nb, qran_own, qran_first, qran_last, info
integer, allocatable :: recv_cnts(:), displs(:)

logical :: verbose

verbose = peinf%verb_debug
if(size(isrtq) < ncoul) call die("vcoul_generator: isrtq not allocated to size ncoul")
if(size(vcoul) < ncoul) call die("vcoul_generator: vcoul not allocated to size ncoul")

if(ifirst == 2) call die("you destroyed qran already!")
! FHJ: TODO check that nfq == product(qgrid). This should *always*
! be the case, since qgrids are Gamma centered. So, we don`t even have
! to ask for nfq.
if(nfq<1 .and. peinf%jobtypeeval==1) call die("Illegal value for nfq in vcoul_generator")

if(.not. present(nfreq_group)) then
npes_local=peinf%npes
else
npes_local=peinf%npes_orig
endif

iCommFlag = 0
iCommFlagGlobal = 0

vcoul = 0d0

nint=100

qlen = sqrt(DOT_PRODUCT(qvec,MATMUL(bdot,qvec)))
q0len = sqrt(DOT_PRODUCT(q0vec,MATMUL(bdot,q0vec)))

! JRD: If we have a metal then the divergent components of W cancel
! and you get a constant. Epsilon was calculated at q ~ q0vec
! MJ: Not quite. We while W goes to a constant, V does not. See the
! comment below about metals. Here we set the q to be qvec (i.e.
! 0 0 0) but later make sure we change W to be evaluated at this
! q. We change epsiloninv such that epsinv*V(q0vec) = epsnewinv*V(q)
! where V(q) is the averaged quantity.

if (abs(qlen) .lt. TOL_Zero .and. iscreen .eq. 2 .and. peinf%jobtypeeval .eq. 1 .and. itruncflag .ne. 0) then
qvec_mod = q0vec
else
qvec_mod = qvec
endif

!------------------------------------------------------------------
! Generate random numbers for minibz averaging

nn = nmc

if (peinf%jobtypeeval .eq. 1 .and. ifirst .eq. 1 .and. &
(itruncflag .eq. 0 .or. itruncflag .eq. 6)) then

if (any(qgrid(1:3) .eq. 0)) then
if(peinf%inode == 0) then
write(0,*) 'Error qgrid', qgrid
write(0,*) 'You must specify qgrid in .inp file'
endif
call die ('Zero qgrid. Cannot determine minibz', only_root_writes = .true.)
endif

allocate(ran (3,nn))

if (peinf%inode .eq. 0) then
! We require a fixed seed for reproducibility of our 'random' numbers.
! call date_and_time(VALUES=values)
! seed=((values(3)*24+values(5))*60+values(6))*60+values(7)
seed = 5000
call genrand_init(put=seed)
do jj = 1, 3*nn
call genrand_real4(dummy)
enddo
do jj = 1, nn
do ii = 1, 3
call genrand_real4(ran(ii, jj))
enddo
enddo
endif

dd(1:3) = 1D0 / dble(qgrid(1:3))

UU(1:3, 1:3) = bdot(1:3, 1:3)
! FHJ: Cholesky decomposition of the metric: bdot = UU^T UU
call dpotrf('U', 3, UU, 3, info)
if (info/=0) call die('Could not compute Cholesky decomposition of the metric', &
only_root_writes=.true.)

allocate(qran (3,nn))
qran = 0d0
qran_nb = ((nn+npes_local-1)/(npes_local)) ! Block size for qran distrib.
qran_own = NUMROC(nn, qran_nb, peinf%inode, 0, npes_local) ! How many qran I own
qran_first = INDXL2G(1, qran_nb, peinf%inode, 0, npes_local) ! First qran I own
qran_last = qran_first + qran_own - 1 ! Last qran I own
! FHJ: OpenMP threading actually hurts performance (at least on Intel i5)
do jj = qran_first, qran_last
lmin = INF
qpp(:) = ran(:,jj)
do i1 = -ncell+1, ncell
fq(1) = qpp(1) - dble(i1)
do i2 = -ncell+1, ncell
fq(2) = qpp(2) - dble(i2)
do i3 = -ncell+1, ncell
fq(3) = qpp(3) - dble(i3)
!vlength = DOT_PRODUCT(fq,MATMUL(bdot,fq))
!FHJ: The following lines are mathematically equiv. to the one
!before, but it`s much faster.
vmid(1) = UU(1,1)*fq(1) + UU(1,2)*fq(2) + UU(1,3)*fq(3)
vmid(2) = UU(2,2)*fq(2) + UU(2,3)*fq(3)
vmid(3) = UU(3,3)*fq(3)
vlength = vmid(1)**2 + vmid(2)**2 + vmid(3)**2
if (vlength < lmin) then
lmin = vlength
qran(:,jj) = fq(:)
endif
enddo
enddo
enddo
qran(1:3,jj) = dd(1:3) * qran(1:3,jj)
enddo ! jj

if(itruncflag /= 6) then
!
! FB: find the (square of the) radius of the sphere contained in the miniBZ
! 1/q**2 is going to be calculated analytically in the sphere
! and numerically outside
q0sph2 = INF

do i1 = -ncell+1, ncell
fq(1) = dble(i1) * dd(1) * 0.5D0
do i2 = -ncell+1, ncell
fq(2) = dble(i2) * dd(2) * 0.5D0
do i3 = -ncell+1, ncell
fq(3) = dble(i3) * dd(3) * 0.5D0
if( i1==0 .AND. i2==0 .AND. i3==0 ) cycle

vlength = DOT_PRODUCT(fq,MATMUL(bdot,fq))
if (vlength < q0sph2) then
q0sph2 = vlength
endif
enddo
enddo
enddo
else
!
! FB: find the (square of the) radius of the sphere contained in the miniBZ
! 1/q**2 is going to be calculated analytically in the sphere
! and numerically outside
q0sph2 = INF

do i1 = -ncell+1, ncell
fq(1) = dble(i1) * dd(1) * 0.5D0
do i2 = -ncell+1, ncell
fq(2) = dble(i2) * dd(2) * 0.5D0
if( i1==0 .AND. i2==0 ) cycle

vlength = DOT_PRODUCT(fq,MATMUL(bdot,fq))
if (vlength < q0sph2) then
q0sph2 = vlength
endif
enddo
enddo

endif

if(allocated(ran))then;deallocate(ran);endif

# 345

endif

!-------------------------------------------------------------------
! No Truncation

if (itruncflag .eq. 0 .and. (.not. present(coulomb_mod))) then

! Calculate Wing Correction Factor - this is not done for Epsilon and Kernel
! since avgcut is zero and qvec_mod is not

if (peinf%inode .eq. 0 .and. qlen**2 .lt. avgcut .and. peinf%jobtypeeval .eq. 1) then
if (qlen**2 .gt. TOL_Zero .or. .not.oneoverq0_done) then
call minibzaverage_3d_oneoverq(nn,bdot,dvalue,qran,qvec_mod)
oneoverq=dvalue
if (qlen**2 .le. TOL_Zero) then
oneoverq0=dvalue
oneoverq0_done = .true.
endif
else
oneoverq=oneoverq0
endif
endif
! otherwise we set oneoverq a little later

do ig=1,ncoul
if (iparallel .eq. 1) then
if(mod(ig-1,npes_local).ne.peinf%inode) cycle
endif

gk(:)=gvec%components(:,isrtq(ig))
qk(:)=gk+qvec_mod(:)
ekinx=DOT_PRODUCT(qk,MATMUL(bdot,qk))

! We Do 3D Mini Brillouin Zone Average if q is exactly 0
! and G = 0. This should be the case when constructing W,
! but don`t want this in Epsilon code for example, where you
! have to use a finite Q.

if ( ekinx .lt. avgcut .and. peinf%jobtypeeval .eq. 1 ) then
if (iscreen .eq. 0) then ! semiconductor

if(ekinx .gt. TOL_Zero .or. .not.minibz_done) then
if (ekinx .le. TOL_Zero) then
call minibzaverage_3d_oneoverq2(nn,bdot,dvalue,qran,qk,averagew,epshead,wcoul0,q0sph2,celvol,nfq)
vcoul(ig)=dvalue
vcoul0=dvalue
iCommFlag = peinf%inode+1
minibz_done = .true.
else
call minibzaverage_3d_oneoverq2(nn,bdot,dvalue,qran,qk,averagew,epshead,wcoul0,q0sph2,celvol,nfq)
vcoul(ig)=dvalue
endif
else
vcoul(ig)=vcoul0
endif

elseif (iscreen .eq. 1) then ! graphene

if (ekinx .gt. TOL_Zero .or. .not.minibz_done) then
call minibzaverage_3d_oneoverq2(nn,bdot,dvalue,qran,qk,averagew,epshead,wcoul0,q0sph2,celvol,nfq)

if (ekinx .lt. TOL_ZERO) then
vcoul0=dvalue
call minibzaverage_3d_oneoverq(nn,bdot,dvalue,qran,qk)
if (q0len .lt. TOL_ZERO) then
write(0,'(a)') 'You have q0vec=0 but a graphene-type system!!'
call die('Bad q0vec', only_root_writes = .true.)
endif
wcoul0=epshead*dvalue/q0len
iCommFlag = peinf%inode+1
minibz_done = .true.
vcoul(ig)=vcoul0
else
! JRD: This seems wrong. We now use correct vcoul average.
! vcoul(ig)=dvalue/sqrt(ekinx)
endif
else
vcoul(ig)=vcoul0
endif

elseif (iscreen .eq. 2) then
! MJ : W(q->0) goes to a constant. But the COH term (as well as the
! Fock term) also require V(q->0). It is simpler to see this in the
! context of the COH term in COHSEX which is 0.5*(W-V). Setting V(q->0)
! based on the q0vec is dangerous because it just adds a constant to all
! the quasiparticle levels. So we keep both of these quantities
! at hand. This is only needed in the Sigma code.
! write(0,'(a)') 'You want cell averaging on a metal!!'
! write(0,'(a)') 'Specify q0vec and cell averaging will automatically'
! write(0,'(a)') 'be done for vcoul. Wcoul will use the q0vec that you'
! write(0,'(a)') 'specify!!'
! call die('Bad Screening Options', only_root_writes = .true.)
if (ekinx .gt. TOL_Zero .or. .not.minibz_done) then
call minibzaverage_3d_oneoverq2(nn,bdot,dvalue,qran,qk,averagew,epshead,wcoul0,q0sph2,celvol,nfq)

! Keep in mind that while the vcoul average out of minibzaverage_3d_oneoverq2
! is correct, wcoul0 is not. wcoul0 is just modified so that when multiplied
! by vcoul it gives the correct result.
!if (abs(ekinx-q0len) .lt. TOL_Zero) then
if (ekinx .lt. TOL_Zero) then
vcoul0=dvalue
!wcoul0=epshead*(q0len*q0len)/(dvalue/8.0/PI_D)
wcoul0=epshead*8.0*PI_D/(q0len*q0len)
iCommFlag = peinf%inode+1
minibz_done = .true.
vcoul(ig)=vcoul0
endif
else
vcoul(ig)=vcoul0
endif

endif

else if (ekinx .lt. Tol_zero) then

! We are not in an evaluation job and were sent q=0, we don`t average. We just zero. The outside code should
! do something about this value.

vcoul(ig) = 0D0

else

! For metal - we already changed qvec_mod to q0vec above

vcoul(ig) = 8.0d0*PI_D/ekinx
endif
enddo

if (qlen**2 .ge. avgcut) then
oneoverq=vcoul(1)*qlen
endif

# 497

!--------------------------------------------------------------------
! Rectangular Box Truncation

elseif (itruncflag .eq. 1) then

call die('Rectangular Truncation is No Longer Supported', only_root_writes = .true.)

!------------------------------------------------------------------
! Spherical Truncation

elseif (itruncflag .eq. 2 .and. (.not. present(coulomb_mod))) then

do ig=1,ncoul
qk(:)=gvec%components(:,isrtq(ig))+qvec_mod(:)
ekinx=DOT_PRODUCT(qk,MATMUL(bdot,qk))
if ( ekinx.lt.TOL_ZERO .and. peinf%jobtypeeval .eq. 1 ) then
vcoul(ig)=8.0D0*PI_D*((truncval(1))**2)/2D0
else if ( ekinx.lt.TOL_ZERO ) then
vcoul(ig) = 0D0
else
vcoul(ig)=8.0d0*PI_D/ekinx* &
(1.0d0-cos(truncval(1)*sqrt(ekinx)))
endif
enddo

oneoverq=vcoul(1)*qlen
wcoul0 = vcoul(1)

!------------------------------------------------------------------
! Cylindrical Box Truncation

elseif (itruncflag .eq. 3) then

call die('Cylindrical Truncation is No Longer Supported', only_root_writes = .true.)

!-----------------------------------------------------------------
! Cell Wire Truncation

elseif (itruncflag .eq. 4) then

! if (peinf%inode .eq. 0) then
! write(6,*) 'Generating Vcoul_cell_wire with FFT'
! endif

! JRD: This is hopefully temporary. q=0 gives NaN
! because the log diverges in Eq. 5 of Ismail-Beigi paper.
! For all G =/ 0, using the q0vec (small shifted vector) is
! probably good enough.
!
! JRD: This is now fixed in trunc_cell_wire where we use the scheme
! of Ismail-Beigi

if (iparallel .eq. 1) then
call trunc_cell_wire(gvec,verbose,peinf%inode, &
npes_local,bdot,qvec_mod(3),ncoul,isrtq,vcoul)
else
call trunc_cell_wire(gvec,verbose,0, &
1,bdot,qvec_mod(3),ncoul,isrtq,vcoul)
endif

! We Do 1D Mini Brillouin Zone Average if q=0, G=0 or less than avgcut
! May not be implemented correctly for graphene-type system... I`m not even sure there is a system with linear DOS in 1D...

if (iscreen .eq. 0) then ! semiconductor
do ig=1,ncoul
qk(:)=gvec%components(:,isrtq(ig))+qvec_mod(:)
ekinx=DOT_PRODUCT(qk,MATMUL(bdot,qk))
if ( ekinx .lt. avgcut .and. peinf%jobtypeeval .eq. 1) then

if (ekinx .gt. TOL_Zero .or. .not.minibz_done) then
call minibzaverage_1d(gvec,nfq,bdot,dvalue,iparallel,qk,epshead,q0len,averagew,wcoul0)
vcoul(ig)=dvalue
if (ekinx .lt. TOL_Zero) then
vcoul0=dvalue
minibz_done = .true.
endif
else
vcoul(ig)=vcoul0
endif
else if (ekinx .lt. Tol_Zero) then
vcoul(ig) = 0
endif
enddo
endif

oneoverq=vcoul(1)*qlen

!----------------------------------------------------------------
! Cell Box Truncation

elseif (itruncflag .eq. 5) then

if (qlen .gt. Tol_ZERO) then
write(0,'(a)') 'You asked for cell box truncation but have more q-points than q=0!!'
call die('Bad Truncation', only_root_writes = .true.)
endif

if (iparallel .eq. 1) then
if (.not. present(coulomb_mod)) then
call trunc_cell_box_d(gvec,verbose,peinf%inode, &
npes_local,bdot,ncoul,isrtq,vcoul)
endif
else
if (.not. present(coulomb_mod)) then
call trunc_cell_box(gvec,verbose,bdot,ncoul,isrtq,vcoul)
endif
endif

oneoverq=vcoul(1)*qlen
wcoul0 = vcoul(1)

!----------------------------------------------------------------
! Cell Slab Truncation

! JRD: This is easy because an analytic expression exists. See Sohrab.

elseif (itruncflag .eq. 6) then

if (abs(qvec_mod(3)) .gt. Tol_ZERO) then
write(0,'(a)') 'You asked for cell slab truncation but have more q-points in z direction than qz=0!!'
call die('Bad Truncation', only_root_writes = .true.)
endif

do ig=1,ncoul

if (iparallel .eq. 1) then
if(mod(ig,npes_local).ne.peinf%inode) cycle
endif

qk(:)=gvec%components(:,isrtq(ig))+qvec_mod(:)
ekinx=DOT_PRODUCT(qk,MATMUL(bdot,qk))
qkxy(1:2)=qk(1:2)
qkxy(3)=0D0
kxy=sqrt(DOT_PRODUCT(qkxy,MATMUL(bdot,qkxy)))
qkz(1:2)=0D0
qkz(3)=qk(3)
kz=sqrt(DOT_PRODUCT(qkz,MATMUL(bdot,qkz)))
zc=2D0*PI_D/(sqrt(bdot(3,3))*2D0)

! write(6,*) "zc", zc

if ( ekinx .lt. avgcut .and. peinf%jobtypeeval .eq. 1 ) then
if (iscreen .ne. 2) then ! semiconductor or graphene
if (ekinx .gt. TOL_Zero .or. .not.minibz_done) then
call minibzaverage_2d_oneoverq2(nn,bdot, &
dvalue,qran,qk,kz,zc,epshead,q0len,averagew,wcoul0)
vcoul(ig)=dvalue
if (ekinx .lt. TOL_Zero) then
vcoul0=dvalue
if (iscreen .eq. 1) then
wcoul0=vcoul0*epshead
endif
minibz_done = .true.
iCommFlag=peinf%inode+1
endif
else
vcoul(ig)=vcoul0
endif
else
write(0,'(a)') 'You have q0vec=0 but a metal!!'
call die('Bad Screening Options', only_root_writes = .true.)
endif
else if (ekinx .lt. Tol_Zero) then
vcoul(ig) = 0D0
else
vcoul(ig) = 8.0d0*PI_D/ekinx
vcoul(ig) = vcoul(ig)*(1.0d0-exp(-kxy*zc)*cos(kz*zc))
endif
enddo

# 686

! This is wrong too?

oneoverq=vcoul(1)*qlen

!----------------------------------------------------------------
! Supercell Box Truncation

elseif (itruncflag .eq. 7) then

if (iparallel .eq. 1) then
call trunc_scell_box_d(gvec,.true.,peinf%inode,npes_local, &
bdot,qvec_mod,qgrid,ncoul,isrtq,vcoul,work_scell)
else
call trunc_scell_box_d(gvec,.true.,0,1, &
bdot,qvec_mod,qgrid,ncoul,isrtq,vcoul,work_scell)
endif

oneoverq=vcoul(1)*qlen
wcoul0 = vcoul(1)

endif

! Saving qran between calls
! deallocate(qran)

!-----------------------------------------------------------------
! Print vcoul to file

if (iwritecoul .eq. 1) then
if (peinf%inode.eq.0) then
do ig=1,ncoul
write(19,'(3f12.8,1x,3i7,1x,e20.8)') &
qvec_mod(:),gvec%components(:,isrtq(ig)),vcoul(ig)
enddo
endif
endif

ifirst = 0

return
end subroutine vcoul_generator

!-----------------------------------------------------------------
subroutine destroy_qran()

ifirst = 2
if(allocated(qran))then;deallocate(qran);endif

call logit('Deallocated random numbers.')

return
end subroutine destroy_qran

end module vcoul_generator_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/trunc_cell_wire.f90 > Common/trunc_cell_wire.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/trunc_cell_wire.p.f -o Common/trunc_cell_wire.o -module Common/
# 1 "Common/trunc_cell_wire.p.f"
!================================================================================
!
! Routines:
!
! 1. trunc_cell_wire() Originally By MLT Last Modified 6/12/2008 (JRD)
!
! Calculate Coulomb interaction with wire boundary conditions. V_coul
! is calculated using truncation of periodic images following this method:
! S. Ismail-Beigi, PRB 73, 233103 (2006).
!
! The Coulomb potential is calculated through 2-D FFT on the extended cell.
!
! n_in_wire is a (positive integer) parameter for real-space resolution.
! If the energy cutoff is too small, then the FFT grid may not be very
! dense and the Coulomb singularity at r=0 may be poorly handled.
! Larger values of n_in_wire will add extra points in between the original
! FFT grid. If the original grid has N points covering a space of length
! L, then the grid used to do 2-dimensional FFTs will have N * n_in_wire
! points covering a space of length L.
!
! When V_coul(x,y,G_3+qz) is calculated, we add a shift on the grid in
! order to avoid the singularity at x = y = 0.
!
! Output is truncated Vcoul(G_1,G_2,G_3+qz) in reciprocal space such that,
! without truncation, its value would be:
!
! Vcoul(ig) = 8 Pi/(q + G)*2
!
! for each G-vector G = gvec%components(:,isrtq(ig)) in the list.
!
! Calculation is distributed over processors but array vcoul returns
! with global value.
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 37 "Common/Common/trunc_cell_wire.f90" 2

subroutine trunc_cell_wire(gvec,verbose,inode,npes,bdot,qz,ncoul,isrtq,vcoul)

use global_m
use bessel_m
use fft_parallel_m
use fftw_m
use misc_m
implicit none

type (gspace), intent(in) :: gvec !< Reciprocal space structure
logical, intent(in) :: verbose !< Flag for extra output on unit 6
integer, intent(in) :: inode, npes !< MPI parameters: processor rank, number of processors
real(DP), intent(in) :: bdot(3,3) !< Metric matrix in reciprocal space, assumed to be symmetric
!! and such that bdot(1,3) = bdot(2,3) = 0
real(DP), intent(in) :: qz !< Length of q-vector along z (z component only, not the entire vector!)
integer, intent(in) :: ncoul !< Number of G-vectors
integer, intent(in) :: isrtq(ncoul) !< Indices of G-vectors
real(DP), intent(out) :: vcoul(ncoul) !< Coulomb potential

integer :: i1, i2, j1, j2, j3, l1, l2, l3, ig, &
Nfft(3), dNfft(3), dkmax(3), i, j, Gzmin, Gzmax, NSize(3)
real(DP) :: gpq_z, r_len, rr(3), t_len, tt(3), adot(3,3), &
scale, dscale, phase, vimag, vdummy
complex(DPC) :: vtemp
real(DP), allocatable :: xdummy(:)
complex(DPC), allocatable :: fftbox_2D(:,:,:)
integer, allocatable :: inv_indx(:,:,:)

! Check metric matrix in reciprocal space

if (abs(bdot(1,3)) .gt. TOL_Zero .or. abs(bdot(2,3)) .gt. TOL_Zero) &
call die('For wire truncation, the 1st and 2nd lattice vectors must be perpendicular to the 3rd.', only_root_writes = .true.)

! Initialize FFT grids.

call setup_FFT_sizes(gvec%FFTgrid,Nfft,scale)
dkmax(1) = gvec%FFTgrid(1) * n_in_wire
dkmax(2) = gvec%FFTgrid(2) * n_in_wire
dkmax(3) = 1
call setup_FFT_sizes(dkmax,dNfft,dscale)

! Initialize real-space metric. If everything goes well, value of
! rr(3) should remain always zero.

rr = 0.0d0
tt = 0.0d0
call invert_matrix(bdot, adot)
adot = adot * 4.d0 * PI_D * PI_D

do i=1,2
do j=1,2
adot(i,j)=adot(i,j)/(1.d0 * dNfft(i) * dNfft(j))
enddo
enddo

! Initialize boxes.

allocate(fftbox_2D (dNfft(1),dNfft(2),1))

if (verbose) then
if (inode .eq. 0) then
write(6,555) dNfft(1:2), n_in_wire
endif
endif
555 format(/,1x,"Cell truncation.",/,2x,"Building truncated Coulomb", &
1x,"potential using 2-D FFTs.",/,2x,"2-D FFT grid =",2i5,/,2x, &
"Extra points between two points in a 2-D FFT grid =",i3,/)

! Invert G-index.

allocate(inv_indx (Nfft(1),Nfft(2),Nfft(3)))
call fft_map_s(ncoul,Nfft,isrtq,gvec%components,inv_indx)

! Find Gzmin & Gzmax.

Gzmin = 0
Gzmax = 0
do ig = 1, ncoul
if (gvec%components(3,isrtq(ig)) .lt. Gzmin) &
Gzmin = gvec%components(3,isrtq(ig))
if (gvec%components(3,isrtq(ig)) .gt. Gzmax) &
Gzmax = gvec%components(3,isrtq(ig))
enddo

vcoul = 0.0d0
vimag = 0.0d0
do j3 = Gzmin, Gzmax
if (mod(j3 - Gzmin, npes) /= inode) cycle

l3 = j3 + 1
if (j3 < 0) l3 = Nfft(3) + l3
gpq_z = abs(j3 + qz) * sqrt( bdot(3,3) )

! For each G_3 plane, calculate the potential V_trunc(r1,r2,G_3+qz).
! The potential is not zero only inside the Wigner-Seitz cell.
! Because of the logarithmic singularity, we must separate the case
! G_3 + qz = 0.

do i2 = 1, dNfft(2)
rr(2) = dble(i2 - 1) + trunc_shift(2)
do i1 = 1, dNfft(1)
rr(1) = dble(i1 - 1) + trunc_shift(1)

r_len = INF

do l2 = -ncell+1, ncell
tt(2) = rr(2) - dble(l2 * dNfft(2))
do l1 = -ncell+1, ncell
tt(1) = rr(1) - dble(l1 * dNfft(1))
t_len = dot_product(tt,matmul(adot,tt))
if (t_len < r_len) r_len = t_len
enddo
enddo

r_len = sqrt(r_len)

! JRD/MJ: You can split the log into two terms and the divergent gpq_z term
! is zero if you use the framework of Ismail-Beigi

if (abs(gpq_z) < TOL_Small) then
fftbox_2D(i1,i2,1) = -log( r_len )
else
fftbox_2D(i1,i2,1) = dbesk0( gpq_z * r_len )
endif

enddo
enddo

! Do a two-dimensional Fourier transform:
! V_trunc(r1,r2,G_3+qz) -> V_trunc(G_1,G_2,G_3+qz)

! Do FFT

NSize(:)=dNfft(:)
NSize(3)=1
call do_fft(fftbox_2D,NSize,-1)

! Collect components of V_trunc for G-vectors in Coulomb list.

do j2 = - Nfft(2)/2, Nfft(2) - Nfft(2)/2 - 1
l2 = j2 + 1
if (j2 < 0) l2 = Nfft(2) + l2
i2 = j2 + 1
if (j2 < 0) i2 = dNfft(2) + i2
do j1 = - Nfft(1)/2, Nfft(1) - Nfft(1)/2 - 1
l1 = j1 + 1
if (j1 < 0) l1 = Nfft(1) + l1
i1 = j1 + 1
if (j1 < 0) i1 = dNfft(1) + i1
ig = inv_indx(l1,l2,l3)
if (ig == 0) cycle

! (gsm) [2010-06-17] there was a bug here
! the singularity of the Coulomb potential was shifted from
! the origin of the coordinate system by half a grid step

! vcoul(ig) = dble(fftbox_2D(i1,i2))

phase = dble(j1) * trunc_shift(1) / dble(dNfft(1)) + dble(j2) * trunc_shift(2) / dble(dNfft(2))
phase = 2.0d0 * PI_D * phase
vtemp = fftbox_2D(i1,i2,1)
vtemp = vtemp * cmplx(cos(phase),-sin(phase),kind=DPC)
vcoul(ig) = dble(vtemp)
vdummy = abs(aimag(vtemp))
if (vdummy.gt.vimag) vimag=vdummy
enddo
enddo

enddo ! j3

# 216
if (vimag.gt.TOL_Small) &
call die("The Coulomb interaction was incorrectly computed as complex: most likely a problem with your FFT library.", &
only_root_writes = .true.)

call destroy_fftw_plans()
if(allocated(fftbox_2D))then;deallocate(fftbox_2D);endif
if(allocated(inv_indx))then;deallocate(inv_indx);endif

! Rescale with the area of the unit cell in the xy plane.

scale = adot(1,1)*adot(2,2) - adot(1,2)*adot(2,1)
scale = 4.d0 * sqrt(scale)
vcoul = vcoul * scale

! Global reduction if there is more than one processor.

# 240

return
end subroutine trunc_cell_wire
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/trunc_scell_box_d.f90 > Common/trunc_scell_box_d.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/trunc_scell_box_d.p.f -o Common/trunc_scell_box_d.o -module Common/
# 1 "Common/trunc_scell_box_d.p.f"
!================================================================================
!
! Routines:
!
! 1. trunc_scell_box_d() Originally By JRD Last Modified 8/10/2010 (gsm)
!
! WARNING - THIS ROUTINE IS CURRENTLY NOT TESTED UNDER THE TESTSUITE.
! IT NEEDS TO BE VALIDATED (COMPARED TO CELL_BOX_D) BEFORE USED IN PRODUCTION!!!
!
! Modification of trunc_cell_box_d to perform calculation on a supercell
! and fold it into q-points.
!
! Calculate Coulomb interaction with SuperCell Box Truncation.
!
! The Coulomb potential is calculated through FFT on the extended cell.
!
! n_in_box is a (positive integer) parameter for real-space resolution.
! If the energy cutoff is too small, then the FFT grid may not be very
! dense and the Coulomb singularity at r=0 may be poorly handled.
! Larger values of n_in_box will add extra points in between the original
! FFT grid. If the original grid has N points covering a space of length
! L, then the grid used to do 3-dimensional FFTs will have N * n_in_box
! points covering a space of length L.
!
! When V_coul(x,y,z) is calculated, we add a shift on the grid in
! order to avoid the singularity at x = y = z = 0.
!
! Output is truncated Vcoul(G_1,G_2,G_3) in reciprocal space such that,
! without truncation, its value would be:
!
! Vcoul(ig) = 8 Pi/(q + G)*2
!
! for each G-vector G = gvec%components(:,isrtq(ig)) in the list.
!
! Calculation is distributed over processors but array vcoul returns
! with global value.
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 41 "Common/Common/trunc_scell_box_d.f90" 2

subroutine trunc_scell_box_d(gvec,verbose,inode,npes,bdot,q,qgrid,ncoul,isrtq,vcoul,work_scell)

use global_m
use fft_parallel_m
use fftw_m
use misc_m
implicit none

type (gspace), intent(in) :: gvec !< Reciprocal space structure
logical, intent(in) :: verbose !< Flag for extra output on unit 6
integer, intent(in) :: inode, npes !< MPI parameters: processor rank, number of processors
real(DP), intent(in) :: bdot(3,3) !< Metric matrix in reciprocal space
real(DP), intent(in) :: q(3) !< q-vector
integer, intent(in) :: qgrid(3) !< q-grid
integer, intent(in) :: ncoul !< Number of G-vectors
integer, intent(in) :: isrtq(ncoul) !< Indices of G-vectors
real(DP), intent(out) :: vcoul(ncoul) !< Coulomb potential
type (twork_scell), intent(inout) :: work_scell !< Work structure to store data computed on first call

logical, save :: first_call = .true.
integer :: i1, i2, i3, j1, j2, j3, l1, l2, l3, ig, &
Nfft(3), dNfft(3), dkmax(3), Nrod, Nplane, i, j, k, iq(3), NSize(3)
real(DP) :: r_len, rr(3), t_len, tt(3), adot(3,3), scale, dscale, phase, vimag, vdummy, b(3,3), sq(3)
complex(DPC) :: vtemp
real(DP), allocatable :: xdummy(:)
complex(DPC), allocatable :: fftbox_2D(:,:,:)
complex(DPC), allocatable :: fftbox_temp(:,:,:)
complex(DPC), allocatable :: buffer_2D(:,:,:)
complex(DPC), allocatable :: buffer_1D(:,:,:)
integer, allocatable :: inv_indx(:,:,:)

! Initialize FFT grids.

call setup_FFT_sizes(gvec%FFTgrid,Nfft,scale)
dkmax(1) = gvec%FFTgrid(1) * n_in_box
dkmax(2) = gvec%FFTgrid(2) * n_in_box
dkmax(3) = gvec%FFTgrid(3) * n_in_box
call setup_FFT_sizes(dkmax,dNfft,dscale)

! Initialize real-space metric.

rr = 0.0d0
call invert_matrix(bdot, adot)
adot = adot * 4.0d0 * PI_D * PI_D

do i =1,3
do j=1,3
adot(i,j) = adot(i,j) / dble(dNfft(i) * dNfft(j))
enddo
enddo

do i = 1, 3
dNfft(i) = dNfft(i) * qgrid(i)
enddo

! Initialize boxes.

call fft_set_p(dNfft,Nplane,Nrod)

if (first_call) then

allocate(fftbox_2D (dNfft(1),dNfft(2),Nplane))
allocate(work_scell%fftbox_1D (dNfft(3),Nrod))
allocate(buffer_2D (Nrod,Nplane,npes))
allocate(buffer_1D (Nrod,Nplane,npes))

if (verbose) then
if (inode .eq. 0) then
write(6,555) qgrid, dNfft, n_in_box
endif
endif
555 format(/,1x,"Supercell truncation.",/,2x,"Building truncated Coulomb", &
1x,"potential using 2-D/1-D FFTs.",/,2x,"Supercell =",3i3,2x, &
"2-D/1-D FFT grid =",3i5,/,2x,"Extra points between two points", &
1x,"in a 2-D/1-D FFT grid =",i3,/)

endif ! first_call

sq(1:3) = q(1:3) * dble(qgrid(1:3))
call k_range(sq, iq, TOL_Small)
if (any(abs(sq(1:3)) .gt. TOL_Small)) call die('supercell truncation: q-vector mismatch')

! Invert G-index

allocate(inv_indx (Nfft(1),Nfft(2),Nfft(3)))
call fft_map_s(ncoul,Nfft,isrtq,gvec%components,inv_indx)

if (first_call) then

! For each G_3 plane, calculate the potential V_trunc(r1,r2,r3).
! The potential is not zero only inside the Wigner-Seitz cell.

fftbox_2D(:,:,:)=(0.0d0,0.0d0)
do i3 = Nplane*inode+1, min(Nplane*(inode+1),dNfft(3))
rr(3) = dble(i3 - 1) + trunc_shift(3)
do i2 = 1, dNfft(2)
rr(2) = dble(i2 - 1) + trunc_shift(2)
do i1 = 1, dNfft(1)
rr(1) = dble(i1 - 1) + trunc_shift(1)

r_len = INF

do l3 = -ncell+1, ncell
tt(3) = rr(3) - dble(l3 * dNfft(3))
do l2 = -ncell+1, ncell
tt(2) = rr(2) - dble(l2 * dNfft(2))
do l1 = -ncell+1, ncell
tt(1) = rr(1) - dble(l1 * dNfft(1))
t_len = dot_product(tt,matmul(adot,tt))
if (t_len < r_len) r_len = t_len
enddo
enddo
enddo

r_len = sqrt(r_len)

fftbox_2D(i1,i2,i3-Nplane*inode) = 1.0d0 / r_len

enddo
enddo
enddo

!---------------------------------------
! gsm: Below is equivalent to fft_r2g_p/_s except we multiply by a phase,
! collect the real part and check that the imaginary part is smaller
! than the tolerance. Calling fft_r2g_p directly and then altering
! the result would cost extra memory and code execution.

! Do two-dimensional Fourier transforms:
! V_trunc(r1,r2,r3) -> V_trunc(G_1,G_2,r3)

NSize(:)=dNfft(:)
NSize(3)=1
allocate(fftbox_temp (NSize(1),NSize(2),NSize(3)))
do i = 1, Nplane
fftbox_temp(:,:,1)=fftbox_2D(:,:,i)
call do_FFT(fftbox_temp,NSize,-1)
fftbox_2D(:,:,i)=fftbox_temp(:,:,1)
enddo
if(allocated(fftbox_temp))then;deallocate(fftbox_temp);endif

! Transfer data from fftbox_2D to fftbox_1D

buffer_2D(:,:,:)=(0.0d0,0.0d0)
do k = 1, Nplane
do i2 = 1, dNfft(2)
do i1 = 1, dNfft(1)
i = (i2-1)*dNfft(1)+i1-1
j = i/Nrod
buffer_2D(i-j*Nrod+1,k,j+1) = fftbox_2D(i1,i2,k)
enddo
enddo
enddo

buffer_1D(:,:,:)=buffer_2D(:,:,:)

do i3 = 1, dNfft(3)
do i = 1, Nrod
j = (i3-1)/Nplane
work_scell%fftbox_1D(i3,i) = buffer_1D(i,i3-j*Nplane,j+1)
enddo
enddo

! Do one-dimensional Fourier transforms:
! V_trunc(G_1,G_2,r3) -> V_trunc(G_1,G_2,G_3)

NSize(:)=1
NSize(1)=dNfft(3)
allocate(fftbox_temp (NSize(1),NSize(2),NSize(3)))
do i = 1, Nrod
fftbox_temp(:,1,1)=work_scell%fftbox_1D(:,i)
call do_FFT(fftbox_temp,NSize,-1)
work_scell%fftbox_1D(:,i)=fftbox_temp(:,1,1)
enddo
if(allocated(fftbox_temp))then;deallocate(fftbox_temp);endif

endif ! first_call

! Collect components of V_trunc for G-vectors in Coulomb list.

vcoul = 0.0d0
vimag = 0.0d0
do j3 = - Nfft(3)/2, Nfft(3) - Nfft(3)/2 - 1
l3 = j3 + 1
if (j3 < 0) l3 = Nfft(3) + l3
i3 = j3 * qgrid(3) + iq(3) + 1
if (i3 < 1) i3 = dNfft(3) + i3
if (i3 > dNfft(3)) cycle
do j2 = - Nfft(2)/2, Nfft(2) - Nfft(2)/2 - 1
l2 = j2 + 1
if (j2 < 0) l2 = Nfft(2) + l2
i2 = j2 * qgrid(2) + iq(2) + 1
if (i2 < 1) i2 = dNfft(2) + i2
if (i2 > dNfft(2)) cycle
do j1 = - Nfft(1)/2, Nfft(1) - Nfft(1)/2 - 1
l1 = j1 + 1
if (j1 < 0) l1 = Nfft(1) + l1
i1 = j1 * qgrid(1) + iq(1) + 1
if (i1 < 1) i1 = dNfft(1) + i1
if (i1 > dNfft(1)) cycle
ig = inv_indx(l1,l2,l3)
if (ig == 0) cycle
i = (i2-1)*dNfft(1)+i1-1
j = i/Nrod

! (gsm) [2010-06-17] there was a bug here
! the singularity of the Coulomb potential was shifted from
! the origin of the coordinate system by half a grid step

! if (j == inode) vcoul(ig) = &
! dble(fftbox_1D(i3,i-j*Nrod+1))

if (j == inode) then
phase = dble(j1 * qgrid(1) + iq(1)) * trunc_shift(1) / dble(dNfft(1)) &
+ dble(j2 * qgrid(2) + iq(2)) * trunc_shift(2) / dble(dNfft(2)) &
+ dble(j3 * qgrid(3) + iq(3)) * trunc_shift(3) / dble(dNfft(3))
phase = 2.0d0 * PI_D * phase
vtemp = work_scell%fftbox_1D(i3,i-j*Nrod+1)
vtemp = vtemp * cmplx(cos(phase),-sin(phase),kind=DPC)
vcoul(ig) = dble(vtemp)
vdummy = abs(aimag(vtemp))
if (vdummy.gt.vimag) vimag=vdummy
endif
enddo
enddo
enddo

# 280
if (vimag.gt.TOL_Small) &
call die("The Coulomb interaction was incorrectly computed as complex: most likely a problem with your FFT library.", &
only_root_writes = .true.)

if (first_call) then

call destroy_fftw_plans()
if(allocated(fftbox_2D))then;deallocate(fftbox_2D);endif
if(allocated(buffer_2D))then;deallocate(buffer_2D);endif
if(allocated(buffer_1D))then;deallocate(buffer_1D);endif

endif ! first_call

if(allocated(inv_indx))then;deallocate(inv_indx);endif

! Rescale with the volume of the unit cell.

b = adot
scale = b(1,1)*(b(2,2)*b(3,3) - b(2,3)**2) &
+ 2*b(1,2)*b(2,3)*b(3,1) &
- b(2,2)*b(1,3)**2 - b(3,3)*b(1,2)**2
scale = 2.0d0 * dsqrt(scale)
vcoul = vcoul * scale

! Global reduction if there is more than one processor.

# 314

first_call = .false.

return
end subroutine trunc_scell_box_d
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/fixwings.f90 > Common/fixwings.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/fixwings.p.f -o Common/fixwings.o -module Common/
# 1 "Common/fixwings.p.f"
!============================================================================
!
! MODULE: fixwings_m
!
!> Rescale epsmat to make it compatible with W averaging
!
! DESCRIPTION:
!> This module contains routines to rescale the wings and \b head of the
!! epsilon matrix so that later we can compute = .
!! Note that should take into consideration the analytical form of epsmat(q)
!! and v(q) for small q, for each type of truncation/screening.
!
! REVISION HISTORY:
! 15 Jan 2009 - Initial version (JRD and GSM)
! 13 Oct 2011 - Renamed internal variables (FHJ)
!
! (1) fixwings() Originally by JRD Last Modified: 2/09/2009 (JRD)
!
! (2) fixwings_dyn() Originally by GSM Last Modified: 15/09/2009 (JRD)
!
!============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 24 "Common/Common/fixwings.f90" 2

module fixwings_m

use global_m
implicit none

private

public :: &
fixwings, &
fixwings_dyn

contains

!> Despite its name, this routine fixes both the wings and \b head of the
!! GPP epsmat. The goal is to rescale epsmat so that we get the appropriate
!! W averaging, i.e., \f$ W_0 = \varepsilon^{-1}(q) v(q) \f$.
!!
!! \param vcoul Bare potential (v) for the given q point, taking into
!! consideration the truncation. For 3D SC, this should be 8*PI/q^2
!! \param wcoul0 Screened potential W_0. This is actually the value that W_0
!! should have, and \f$\varepsilon^{-1}(q)\f$ is rescaled in this function so
!! that \f$W_0 = \varepsilon^{-1}(q) v(q)\f$
!! \param epstemp A specific column (#icol::icol) of the dielectric matrix,
!! for a specific q point
!! \param icutv Truncation
!! \param iscreen Screening type
!! \param icol Column of the whole dielectric constant that we are dealing with
!! \param nmtx Number of cols/rows in the epsmat
!! \param irow_G0 Which row of epstmp represents the G=0 vector?
!! \param oneoverq WARNING: This is actually 8*PI/q!!!
!! \param q0flag Is this the q0 point?
!! \param averagew Should we do W averaging?
!! \param bdot Reciprocal metric
!!
!! \sa fixwings_dyn - the FF version

subroutine fixwings(vcoul,wcoul0,epstemp,icutv,iscreen, &
icol,nmtx,irow_G0,q0len,oneoverq,fact,q0flag,averagew,bdot)

use global_m
implicit none

integer, intent(in) :: icol,nmtx,irow_G0,iscreen,icutv
real(DP), intent(in) :: vcoul,oneoverq,q0len,fact
complex(DPC), intent(inout) :: epstemp(nmtx)
complex(DPC), intent(in) :: wcoul0
logical, intent(in) :: q0flag,averagew
real(DP), intent(in) :: bdot(3,3)

integer :: i
real(DP) :: zc

!if irow_G0 < avgcut \=icol
!epstemp()*oneverq*q0len
!if icol < avgcut i\=icol
!epstemp(i)*oneoverq/(vcoul(icol)*qicol00)

!----------------------
! No Truncation

if (icutv .eq. 0) then
if (icol.ne.irow_G0) then ! wing` (Gp/=0)
if (iscreen .eq. 0) then
epstemp(irow_G0) = epstemp(irow_G0)*oneoverq*q0len/(8D0*PI_D)
endif
! JRD Zero out q0 wings
if (q0flag .and. iscreen .eq. 0) epstemp(irow_G0) = 0D0
else
do i=1,nmtx
if (i .ne. irow_G0) then ! wing (G/=0)
if (iscreen .eq. 0) then
epstemp(i) = epstemp(i)*fact*oneoverq/(vcoul*q0len)
endif
if (iscreen .eq. 1) then
epstemp(i) = epstemp(i)*fact*8D0*PI_D/(vcoul*q0len**2)
endif
! JRD Zero out q0 wings
if (q0flag .and. iscreen .eq. 0) epstemp(i) = 0D0
else ! Head
if (q0flag .and. averagew) then
epstemp(i) = wcoul0/vcoul
endif
endif
enddo
endif
endif

!----------------------
! Cell Wire Truncation
! May not be implemented correctly for graphene screening... I`m not even sure there is a 1D system with linear DOS...

if (icutv .eq. 4) then
if (icol.ne.irow_G0) then ! wing` (Gp/=0)
! JRD We zero q0 wings
if (q0flag .and. iscreen .eq. 0) then
epstemp(irow_G0) = 0d0
endif
else
do i=1,nmtx
if (i .ne. irow_G0) then ! wing (G/=0)
! JRD We zero q0 wings
if (q0flag .and. iscreen .eq. 0) then
epstemp(i) = 0d0
endif
else ! Head
if (q0flag .and. averagew .and. iscreen .ne. 2) then
epstemp(i) = wcoul0/vcoul
endif
endif
enddo
endif
endif

!----------------------
! Cell Slab Truncation

if (icutv .eq. 6) then

zc=2D0*PI_D/(sqrt(bdot(3,3))*2D0)

if (icol.ne.irow_G0) then ! wing` (Gp/=0)
! JRD We zero q0 wings
if (q0flag .and. iscreen .eq. 0) epstemp(irow_G0) = 0d0
else
do i=1,nmtx
if (i .ne. irow_G0) then ! wing (G/=0)
if (iscreen .ne. 2) then
epstemp(i) = epstemp(i) * 8D0 * PI_D * fact * zc &
/ (vcoul * q0len)
! JRD We zero q0 wings
if (q0flag .and. iscreen .eq. 0) epstemp(i) = 0d0
endif
else ! Head
if (q0flag .and. averagew .and. iscreen .ne. 2) then
epstemp(i) = wcoul0/vcoul
endif
endif
enddo
endif

endif

return
end subroutine fixwings

!============================================================================

!> Full frequency version of #fixwings
!!
!! \see fixwings - the GPP version

subroutine fixwings_dyn(vcoul,epstemp,icutv,iscreen,icol, &
nfreq,nmtx,irow_G0,q0len,oneoverq,fact,q0flag,bdot)

use global_m
implicit none

integer, intent(in) :: icol,nfreq,nmtx,irow_G0,iscreen,icutv
real(DP), intent(in) :: vcoul,oneoverq,q0len,fact
complex(DPC), intent(inout) :: epstemp(nmtx,nfreq)
logical, intent(in) :: q0flag
real(DP), intent(in) :: bdot(3,3)

real(DP) :: zc
integer :: i

!----------------------
! No Truncation

! JRD This routine has horrible locality. Need to loop over iw on outside

if (icutv .eq. 0) then
if (icol.ne.irow_G0) then
if (iscreen .eq. 0) then
epstemp(irow_G0,:) = epstemp(irow_G0,:)*oneoverq*q0len/(8D0*PI_D)
endif
if (q0flag .and. iscreen .eq. 0) then
epstemp(irow_G0,:) = 0d0
endif
else
do i=1,nmtx
if (i .ne. irow_G0) then
if (iscreen .eq. 0) then
epstemp(i,:) = epstemp(i,:)*oneoverq*fact/(vcoul*q0len)
endif
if (iscreen .eq. 1) then
epstemp(i,:) = epstemp(i,:)*fact*8D0*PI_D/(vcoul*q0len**2)
endif
if (q0flag .and. iscreen .eq. 0) then
epstemp(i,:) = 0d0
endif
endif
enddo
endif
endif

!----------------------
! Cell Wire Truncation
! May not be implemented correctly for graphene screening... I`m not even sure there is a 1D system with linear DOS...

if (icutv .eq. 4) then
if (icol.ne.irow_G0) then
if (q0flag .and. iscreen .eq. 0) then
epstemp(irow_G0,:) = 0d0
endif
else
do i=1,nmtx
if (i .ne. irow_G0) then
if (q0flag .and. iscreen .eq. 0) then
epstemp(i,:) = 0d0
endif
endif
enddo
endif
endif

!----------------------
! Cell Slab Truncation

zc=2D0*PI_D/(sqrt(bdot(3,3))*2D0)

if (icutv .eq. 6) then
if (icol.ne.irow_G0) then
if (q0flag .and. iscreen .eq. 0) then
epstemp(irow_G0,:) = 0d0
endif
else
do i=1,nmtx
if (i .ne. irow_G0) then
if (iscreen .ne. 2) then
epstemp(i,:) = epstemp(i,:) * 8D0 * PI_D * fact * zc &
/ (vcoul * q0len)
if (q0flag .and. iscreen .eq. 0) then
epstemp(i,:) = 0d0
endif
endif
endif
enddo
endif
endif

return
end subroutine fixwings_dyn

end module fixwings_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/check_screening.f90 > Common/check_screening.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/check_screening.p.f -o Common/check_screening.o -module Common/
# 1 "Common/check_screening.p.f"
!============================================================================
!
! Routines:
!
! (1) check_screening_trunc Originally by JRD Last Modified: 2/09/2009 (JRD)
!
! Die if screening, truncation, and q0vec are not set consistently.
!
!============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/check_screening.f90" 2

module check_screening_m

use global_m
implicit none

private

public :: check_screening_trunc

contains

subroutine check_screening_trunc(itruncflag,iscreen,q0vec,bdot)
integer, intent(in) :: itruncflag
integer, intent(in) :: iscreen
real(DP), intent(in) :: q0vec(3)
real(DP), intent(in) :: bdot(3,3)

real(DP) :: q0len

q0len = sqrt(DOT_PRODUCT(q0vec,MATMUL(bdot,q0vec)))

if (iscreen .eq. 2 .and. q0len .lt. TOL_Small) then
if(peinf%inode == 0) then
write(0,*) ' '
write(0,*) 'You want metallic screening but didn''t specify q0vec!!'
endif
call die('Inconsistent Screening', only_root_writes = .true.)
endif

if (iscreen .eq. 1 .and. q0len .lt. TOL_Small .and. itruncflag .eq. 0) then
if(peinf%inode == 0) then
write(0,*) ' '
write(0,*) 'You want graphene screening with no truncation'
write(0,*) 'but didn''t specify q0vec!!'
endif
call die('Inconsistent Screening', only_root_writes = .true.)
endif

if ((itruncflag .eq. 0 .or. itruncflag .eq. 4 .or. &
itruncflag .eq. 6) .and. q0len .lt. TOL_Small) then
if(peinf%inode == 0) then
write(0,*) ' '
write(0,*) 'You have a divergent Coulomb interaction but didn''t specify q0vec!!'
endif
call die('Inconsistent Screening', only_root_writes = .true.)
endif

if ((itruncflag .ne. 0 .and. itruncflag .ne. 4 .and. &
itruncflag .ne. 6) .and. iscreen .ne. 2 .and. q0len .ge. TOL_Small) then
if(peinf%inode == 0) then
write(0,*) ''
write(0,*) 'You want semiconductor or graphene screening with truncation'
write(0,*) 'but specified nonzero q0vec!!'
endif
call die('Inconsistent Screening', only_root_writes = .true.)
endif

return
end subroutine check_screening_trunc

end module check_screening_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/checkgriduniformity.f90 > Common/checkgriduniformity.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/checkgriduniformity.p.f -o Common/checkgriduniformity.o -module Common/
# 1 "Common/checkgriduniformity.p.f"
!============================================================================
!
! Routines:
!
! (1) checkgriduniformity() Originally by JRD Last Modified: 3/16/2011 (das)
!
! To obtain the correct result for integrals in reciprocal space, the k+G
! sampling should be similar in each direction. This routine determines the
! sampling and writes a warning if it is too non-uniform.
!
! gsm: xgrid = sig%qgrid in Sigma/main.f90, kp%kgrid in BSE/intkernel.f90
!
! Truncation:
! icutv = 0, none : 0D truncation, compare x, y, and z
! icutv = 2, spherical : 3D truncation, no relevant directions
! icutv = 4, cell_wire : 2D truncation, z is uniform by itself automatically
! icutv = 5, cell_box : 3D truncation, no relevant directions
! icutv = 6, cell_slab : 1D truncation, compare x and y
!
!============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 23 "Common/Common/checkgriduniformity.f90" 2

module checkgriduniformity_m

use global_m
implicit none

private

public :: checkgriduniformity

contains

subroutine checkgriduniformity(xgrid, crys, icutv)
integer, intent(in) :: xgrid(3)
type(crystal), intent(in) :: crys
integer, intent(in) :: icutv !< code for type of truncation

real(DP), parameter :: TOL_Ratio = 2.0d0

integer :: maxdir
integer :: ii, jj, order(3)
real(DP) :: bb(3, 3), blen(3)
real(DP) :: cc(3, 3), clen(3)
character(len=80) :: tmpstr
character(len=12) :: fmt

if(icutv == 0) then
maxdir = 3
else if(icutv == 6) then
maxdir = 2
else
write(6,'(1x,a)') "No k+G sampling uniformity to check, given selected truncation scheme."

return
endif

! compute minicell lattice vectors
do jj = 1, 3
bb(:, jj) = crys%bvec(:, jj) / dble(xgrid(jj))
blen(jj) = sqrt(sum(bb(1:3, jj)**2))
enddo

! determine which vector is shortest, middle, and longest
order(1) = minloc(blen(1:maxdir), 1)
order(maxdir) = maxloc(blen(1:maxdir), 1)
if(order(maxdir) == order(1)) then
! all vectors must be of the same length
! just make an arbitrary choice, the order(:) elements must all be different
order(1) = 1
order(maxdir) = maxdir
endif
if(maxdir > 2) then
do ii = 1, 3
if(ii /= order(1) .and. ii /= order(3)) order(2) = ii
enddo
endif

! Gram-Schmidt orthogonalization
! go from shortest to longest, since orthogonalization always shortens
cc(1:3, 1) = bb(1:3, order(1))
if(maxdir > 2) then
cc(1:3, 2) = bb(1:3, order(2)) - cc(1:3, 1) * sum(cc(1:3, 1) * bb(1:3, order(2))) / sum(cc(1:3, 1)**2)
endif
cc(1:3, maxdir) = bb(1:3, order(maxdir)) - &
cc(1:3, maxdir - 1) * sum(cc(1:3, maxdir - 1) * bb(1:3, order(maxdir))) / sum(cc(1:3, maxdir - 1)**2)

do jj = 1, maxdir
clen(jj) = sqrt(sum(cc(1:3, jj)**2))
enddo

write(fmt,'(a,i1,a)') "(a,", maxdir, "f10.6,a)"
write(tmpstr, fmt) "k+G sampling: ", clen(1:maxdir), " (reciprocal lattice units)"

if (maxval(clen(1:maxdir)) / minval(clen(1:maxdir)) .gt. TOL_Ratio) then
write(0,'(a)') TRUNC(tmpstr)
write(0,'(a)') "WARNING: detected non-uniform k+G sampling, may cause strange results."
write(0,'(a)') "You should verify your answer with different cell-averaging cutoffs."
else
write(6,'(1x,a)') TRUNC(tmpstr)
endif

! Note: for a cell with a small angle between two equivalent lattice vectors, it will
! be impossible to satisfy this criterion without using a different k-grid in those
! two equivalent directions, breaking crystal symmetry and possibly causing other problems.
! It is unclear what should be done in such a case. --DAS

return

end subroutine checkgriduniformity

end module checkgriduniformity_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/checkbz.f90 > Common/checkbz.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/checkbz.p.f -o Common/checkbz.o -module Common/
# 1 "Common/checkbz.p.f"
!===============================================================================
!
! Routines:
!
! 1. checkbz() Originally By gsm Last Modified 7/29/2010 (gsm)
!
! Check that the Brillouin Zone generated by subroutine fullbz is
! identical to the original full Brillouin Zone. Subroutine fullbz
! constructs the Brillouin Zone by unfolding the irreducible wedge
! with all the symmetries of the space group of the crystal. If the
! irreducible wedge has missing k-points (for example from using too
! many symmetries in kgrid.x), the full Brillouin Zone will also have
! missing k-points.
!
! For the unshifted grid, fullbz generates the original full grid
! from the irreducible wedge.
!
! For the grid shifted by half a grid step, fullbz doubles the grid size.
! For fcc-Si, (4 4 4 0.5 0.5 0.5) becomes (8 8 8 0.0 0.0 0.0) where half
! the points uniformly distributed across the grid are missing.
!
! For the randomly-shifted grid, if symmetries are allowed, fullbz
! generates a non-uniform grid with the points clustered together.
! You should never allow symmetries for the randomly-shifted grid.
!
! For the grid shifted by half a grid step, checkbz would print "extra points"
! warning message. There is nothing to worry about, so we set
! allow_half_shift to .true. to suppress this warning message in this case.
! However, if you see "missing points" warning message, it may indicate a
! problem with your k-point sampling.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 35 "Common/Common/checkbz.f90" 2

module checkbz_m

use global_m
use misc_m
implicit none

private

public :: checkbz

contains

subroutine checkbz(nfk,fk,kgrid,kshift,bdot, &
filename,kqchar,wignerseitz,freplacebz,fwritebz)
integer, intent(inout) :: nfk
real(DP), intent(inout) :: fk(:,:) !< (3, nfk)
integer, intent(in) :: kgrid(3)
real(DP), intent(in) :: kshift(3)
real(DP), intent(in) :: bdot(3,3)
character(len=*), intent(in) :: filename
character, intent(in) :: kqchar
logical, intent(in) :: wignerseitz,freplacebz,fwritebz

logical, parameter :: allow_half_shift = .true.

logical :: f1,f2,f3,flag_half_shift
integer :: ii,jj,i1,i2,i3,nk,gpt(3)
real(DP) :: l1,l2,k1(3),k2(3),kpt(3)
real(DP), allocatable :: kk(:,:)
real(DP), allocatable :: kref(:,:)
character(len=128) :: tmpstr

if(size(fk, 1) /= 3) then
write(0,*) 'size(fk, 1) = ', size(fk, 1)
call die("checkbz internal error: fk must have first dimension = 3")
endif
if(size(fk, 2) /= nfk) then
write(0,*) 'nfk = ', nfk, 'size(fk, 2) = ', size(fk, 2)
call die("checkbz internal error: fk must have second dimension = nfk")
endif

! Identify the grid type
! Print a warning message if the grid type is unknown
! FHJ: Is this really necessary?!

kpt(:)=kshift(:)
call k_range(kpt, gpt, TOL_Small)

f1=.true.
f2=.true.
f3=.true.

do ii=1,3
! FHJ: ignore dimensions that have only one kpt
if (kpt(ii)<2) cycle
! the unshifted grid
f1=f1.and.(abs(kpt(ii)).lt.TOL_Small)
! the grid shifted by half a grid step
f2=f2.and.(abs(kpt(ii)-0.5d0).lt.TOL_Small)
! the randomly-shifted grid
f3=f3.and.(abs(kpt(ii)).gt.TOL_Small.and. abs(kpt(1)-0.5d0).gt.TOL_Small)
enddo

if (.not.f1.and..not.f2.and..not.f3) then
if (peinf%inode.eq.0) write(0,901) kqchar, trim(filename)
901 format(1x,"WARNING: checkbz: unknown",1x,a,"-grid type in",1x,a,/)
endif

flag_half_shift = f2

! Find the number of k-points in the full Brillouin Zone

nk=product(kgrid(1:3))
if (nk.le.0) then
if (peinf%inode.eq.0) write(0,902) kqchar, trim(filename)
902 format(1x,"WARNING: checkbz: zero",1x,a,"-grid in",1x,a,/)

return
endif

! Allocate array for k-points in the full Brillouin Zone

allocate(kk (3,nk))

! Construct k-points in the full Brillouin Zone

ii=0
do i1=0,kgrid(1)-1
do i2=0,kgrid(2)-1
do i3=0,kgrid(3)-1
ii=ii+1
kk(1,ii)=(dble(i1)+kshift(1))/dble(kgrid(1))
kk(2,ii)=(dble(i2)+kshift(2))/dble(kgrid(2))
kk(3,ii)=(dble(i3)+kshift(3))/dble(kgrid(3))
call k_range(kk(:,ii), gpt, TOL_Small)
enddo
enddo
enddo

! Construct a Wigner-Seitz box

if (wignerseitz) then
do ii=1,nk
l2=INF
do i1=-ncell+1,ncell
k1(1)=kk(1,ii)-dble(i1)
do i2=-ncell+1,ncell
k1(2)=kk(2,ii)-dble(i2)
do i3=-ncell+1,ncell
k1(3)=kk(3,ii)-dble(i3)
l1=DOT_PRODUCT(k1,MATMUL(bdot,k1))
if (l1.lt.l2) then
l2=l1
k2(:)=k1(:)
endif
enddo
enddo
enddo
kk(:,ii)=k2(:)
enddo
endif

! Write unfolded BZ and full BZ to files

if (fwritebz) then
if (peinf%inode.eq.0) then
write(tmpstr,801) kqchar, trim(filename)
801 format(a,"_",a,"_unfolded.dat")
call open_file(14, tmpstr, status='replace', form='formatted')
write(14,803) nfk
do ii=1,nfk
write(14,804) ii,fk(:,ii)
enddo
call close_file(14)
write(tmpstr,802) kqchar, trim(filename)
802 format(a,"_",a,"_full.dat")
call open_file(14, tmpstr, status='replace', form='formatted')
write(14,803) nk
do ii=1,nk
write(14,804) ii,kk(:,ii)
enddo
call close_file(14)
endif
endif

! Replace unfolded BZ with full BZ

if (freplacebz) then
if (nk.le.nfk) then
nfk=nk
fk(1:3,1:nk)=kk(1:3,1:nk)
else
call die('checkbz: failed replacebz')
endif
endif

! Before comparing k-points translate from Wigner-Seitz box
! to [0,1) interval

allocate(kref (3,nfk))
kref(1:3,1:nfk)=fk(1:3,1:nfk)

if (wignerseitz) then
do ii=1,nfk
call k_range(kref(:,ii), gpt, TOL_Small)
enddo
do ii=1,nk
call k_range(kk(:,ii), gpt, TOL_Small)
enddo
endif

! Check that kref(1:3,1:nfk) is a subset of kk(1:3,1:nk)
! Print a warning message otherwise

if(.not.(flag_half_shift.and.allow_half_shift)) then
f1=.true.
do ii=1,nfk
f3=.false.
do jj=1,nk
if (all(abs(kref(1:3,ii)-kk(1:3,jj)).lt.TOL_Small)) f3=.true.
enddo
if (.not.f3) then
f1=.false.
if (peinf%inode.eq.0) write(0,'(a,3f12.6)') 'Extra point: ', kref(1:3,ii)
endif
enddo
if (.not.f1) then
if (peinf%inode.eq.0) write(0,903) trim(filename), kqchar
903 format(1x,"WARNING: checkbz: unfolded BZ from",1x,a,1x,"has extra",1x,a,"-points",/)
endif
endif

! Check that kk(1:3,1:nk) is a subset of kref(1:3,1:nfk)
! Print a warning message otherwise

f2=.true.
do ii=1,nk
f3=.false.
do jj=1,nfk
if (all(abs(kk(1:3,ii)-kref(1:3,jj)).lt.TOL_Small)) f3=.true.
enddo
if (.not.f3) then
f2=.false.
if (peinf%inode.eq.0) write(0,'(a,3f12.6)') 'Missing point: ', kk(1:3,ii)
endif
enddo
if (.not.f2) then
if (peinf%inode.eq.0) then
write(0,904) trim(filename), kqchar
if (trim(filename) .eq. 'epsilon.inp' .and. kqchar .eq. 'q') &
write(0,905)
endif
904 format(1x,"WARNING: checkbz: unfolded BZ from",1x,a,1x,"has missing",1x,a,"-points",/)
905 format(1x,"(disregard this warning if your epsilon calculation is split by q-points)",/)
endif

! Deallocate and finish

if(allocated(kk))then;deallocate(kk);endif
if(allocated(kref))then;deallocate(kref);endif

return

803 format(i5)
804 format(i5,3f13.9)

end subroutine checkbz

end module checkbz_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/eqpcor.f90 > Common/eqpcor.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/eqpcor.p.f -o Common/eqpcor.o -module Common/
# 1 "Common/eqpcor.p.f"
!================================================================================
!
! Module eqpcor_m
!
! 1. eqpcor() Originally By gsm Last Modified 8/4/2015 (FHJ)
!
! Reads quasiparticle energy corrections from eqp.dat-type files.
! Such files are made by bin/eqp.py.
!
! There are some differences in how eqpcor is called from different codes.
!
! In Epsilon, eqpcor is called from proc 0, so set inode = 0 and npes = 1.
! In other places, set inode = peinf%inode and npes = peinf%npes.
!
! Epsilon and BSE require quasiparticle energies in Rydbergs, so set
! irydflag = 1. Sigma (outer) requires energies in eVs, so set irydflag = 0.
!
! In Epsilon and Sigma, the quasiparticle energies are returned in
! array eqp(nbmin:nbmax,1:kp%nrk,1:kp%nspin). In BSE, the valence and
! conduction energies indexed with respect to the Fermi level are
! returned in arrays eqpv(:,1:kp%nrk,1:kp%nspin) and eqpc(:,1:kp%nrk,1:kp%nspin).
!
! In inteqp, set ivalflag = 2 to return the difference Eqp - Edft.
! In other places, set ivalflag = 0 to return Eqp.
!
! DO NOT try to use both styles, they will overwrite each other!
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 31 "Common/Common/eqpcor.f90" 2

module eqpcor_m

use global_m
implicit none

private

public :: eqpcor

contains

subroutine eqpcor(fn,inode,npes,kp,nbmin,nbmax, &
nbvnum,nbcnum,eqp,eqpv,eqpc,irydflag,ivalflag,dont_write,kpt_required,allow_trs)

character(len=32), intent(in) :: fn
integer, intent(in) :: inode,npes
type(kpoints), intent(in) :: kp !< however, usually kp%el will be passed to eqp, eqpv, eqpc
integer, intent(in) :: nbmin,nbmax,nbvnum,nbcnum
real(DP), intent(inout) :: eqp(:,:,:) !< (nb, kp%nrk, kp%nspin)
real(DP), intent(inout) :: eqpv(:,:,:) !< (nbv, kp%nrk, kp%nspin)
real(DP), intent(inout) :: eqpc(:,:,:) !< (nbc, kp%nrk, kp%nspin)
integer, intent(in) :: irydflag,ivalflag
logical, optional, intent(in) :: dont_write !< silence output
!> (kp%nrk) Which k-points are required in the eqp file? Defaults to all
logical, optional, intent(in) :: kpt_required(:)
!> allow use of time-reversal symmetry to find k-points? default is .true.
logical, optional, intent(in) :: allow_trs

integer :: eof, jk, kk, is, ib, isb, nsb, nk_found, &
nbvmin, nbvmax, nbcmin, nbcmax, corsmin, corsmax, corbmin, corbmax
integer :: itrs, itrs_max
real(DP) :: dummydft, dummyqp, k(3), dk(3)
character(100) :: errmsg
logical :: dowrite, allow_trs_
logical, allocatable :: kpt_present(:)

! eqp.py from sigma.log may not give better precision than this.
real(DP), parameter :: TOL_eqp = 2d-6

dowrite = .true.
if (present(dont_write)) dowrite = .not. dont_write
dowrite = dowrite .and. peinf%verb_medium
allow_trs_ = .true.
if (present(allow_trs)) allow_trs_ = allow_trs
itrs_max = 0
if (allow_trs_) itrs_max = 1
if (inode==0) then
allocate(kpt_present (kp%nrk))
kpt_present(:) = .false.
write(6,'(/1x,a)') "Reading quasiparticle energy corrections from "//trim(fn)
call open_file(9,file=trim(fn),form='formatted',status='old')

if (ivalflag.eq.2) then
if(dowrite) write(6,922)
922 format(/,6x,"band",3x,"k-point",6x,"spin",3x,"DeltaElda (eV)",2x,"DeltaEqp (eV)")
else
if(dowrite) write(6,902)
902 format(/,6x,"band",3x,"k-point",6x,"spin",6x,"Elda (eV)",7x,"Eqp (eV)")
endif
corsmin=kp%nspin+1
corsmax=0
corbmin=kp%mnband+1
corbmax=0
nk_found=0
do while (nk_found TOL_eqp) &
call die("eqpcor mean-field energy mismatch")
eqp(ib,kk,is)=dummyqp
else
if(dowrite) write(6,903)ib,kk,is,eqp(ib,kk,is)*RYD,dummyqp
if(ivalflag /= 2 .and. abs(dummydft/RYD - eqp(ib,kk,is)) > TOL_eqp) &
call die("eqpcor mean-field energy mismatch")
eqp(ib,kk,is)=dummyqp/RYD
endif
903 format(3i10,2f15.5)
endif
if (ib.ge.nbvmin.and.ib.le.nbvmax) then
if (irydflag.eq.0) then
if(dowrite) write(6,904)ib,kk,is,eqpv(nbvmax-ib+1,kk,is),dummyqp
if(ivalflag /= 2 .and. abs(dummydft - eqpv(nbvmax-ib+1,kk,is)) > TOL_eqp) &
call die("eqpcor mean-field energy mismatch")
eqpv(nbvmax-ib+1,kk,is)=dummyqp
else
if(ivalflag /= 2 .and. abs(dummydft/RYD - eqpv(nbvmax-ib+1,kk,is)) > TOL_eqp) &
call die("eqpcor mean-field energy mismatch")
if(dowrite) write(6,904)ib,kk,is,eqpv(nbvmax-ib+1,kk,is)*RYD,dummyqp
eqpv(nbvmax-ib+1,kk,is)=dummyqp/RYD
endif
904 format("v",i9,2i10,2f15.5)
endif
if (ib.ge.nbcmin.and.ib.le.nbcmax) then
if (irydflag.eq.0) then
if(dowrite) write(6,905)ib,kk,is,eqpc(ib-nbcmin+1,kk,is),dummyqp
if(ivalflag /= 2 .and. abs(dummydft - eqpc(ib-nbcmin+1,kk,is)) > TOL_eqp) &
call die("eqpcor mean-field energy mismatch")
eqpc(ib-nbcmin+1,kk,is)=dummyqp
else
if(dowrite) write(6,905)ib,kk,is,eqpc(ib-nbcmin+1,kk,is)*RYD,dummyqp
if(ivalflag /= 2 .and. abs(dummydft/RYD - eqpc(ib-nbcmin+1,kk,is)) > TOL_eqp) &
call die("eqpcor mean-field energy mismatch")
eqpc(ib-nbcmin+1,kk,is)=dummyqp/RYD
endif
905 format("c",i9,2i10,2f15.5)
endif
enddo
enddo
call close_file(9)
if(any(kpt_present)) then
nbvmin=minval(kp%ifmax(:,:))-nbvnum+1
nbvmax=maxval(kp%ifmax(:,:))
nbcmin=minval(kp%ifmax(:,:))+1
nbcmax=maxval(kp%ifmax(:,:))+nbcnum
if (corsmin>1.or.corsmaxnbmin.or.corbmaxnbvmin.or.corbmaxnbcmin.or.corbmax Common/createpools.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/createpools.p.f -o Common/createpools.o -module Common/
# 1 "Common/createpools.p.f"
!===============================================================================
!
! Routines:
!
! 1. createpools() Originally By gsm Last Modified 06/11/2012 (DVF)
!
! Create pools of valence bands/diagonal matrix elements for Epsilon/Sigma. Number of pools
! is chosen to minimize memory in calculation. This is also used in BSE, which has multiple
! options for what is pooled based on the parameters of the problem.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 14 "Common/Common/createpools.f90" 2

module createpools_m

use global_m
implicit none

private

public :: createpools

contains

!> Create pools of valence bands (for epsilon) or diagonal matrix elements (for sigma). For BSE,
!! the description starts at `Finally,` below. You will probably still need to reference the
!! information above the `Finally,`. The description before `Finally,` is for Sigma and Epsilon.
!!
!! Each pool is defined as a group of *valence* bands or diagonal matrix elements.
!! The behaviour of the code is to minimize the memory requirement.
!! For epsilon, in a naive algorithm, if we distributed all (v,c) pairs round-robin,
!! each process could potentially get as many as (Nk*)Nc*Nv/Nproc
!! bands, which can be pretty large. The usage of pools tackles this
!! memory issue. The same holds for sigma, except Nv -> Ndiag, Nc -> Nband, where Ndiag
!! is the number of diagonal bands for which you are computing sigma (offdiagonal calculations
!! do not use this routine), and Nband is the number of bands in the CH summation (`summation bands`).
!! Obviously, (v,c) pairs goes to (diagonal matrix elements,summation bands) pairs in the above description.
!! The current algorithm works in two levels (this is for epsilon; for sigma make the replacements
!! valence bands -> diagonal matrix elements, conduction bands -> summation bands, Nv -> Ndiag):
!! (1) First, we divide the valence bands into groups (the "pools")
!! (2) Then, the conduction bands are spread across the MPI processes.
!! If the pools don`t have all the same size (i.e., if Nv is not
!! divisible by Nproc), then some MPI processes will be idle.
!! Variable description: formal name first, then actual name in epsilon and sigma in parentheses (epsilon first).
!! The variable name npq means number of pooled quantity (valence bands or diagonal matrix elements),
!! while nsq means number of spread quantity (conduction bands or summation bands), in the sense above.
!! If there is better technical language for describing this, feel free to update this description.
!! \param npq num. of pooled quantity (valence bands or diagonal matrix elements)
!! \param nsq num. of spread quantity (conduction or summation bands)
!! \param npes num. of MPI processes
!! \param npoolsout num. of (valence band or diagonal matrix element) pools created
!! \param npqownmaxout max num. of pool quantity (valence bands or diagonal matrix elements)/MPI process
!! \param nsqwnmaxout max num. of spread quantity (conduction or summation bands)/MPI process
!!
!! Finally, this routine is also used in BSE, where the pooled quantity and spread quantity depends on the
!! parameters of the problem. See BSE/distrib_kernel.f90 . The choices are 1) pooled quantity and spread
!! quantity = num. valence bands, 2) pooled quantity and spread quantity = num. cond. bands, and
!! 3) pooled quantity and spread quantity = num. k-points . The above description changes accordingly.

subroutine createpools(npq,nsq,npes,npoolsout,npqownmaxout,nsqownmaxout)

integer, intent(in) :: npq,nsq,npes
integer, intent(out) :: npoolsout,npqownmaxout,nsqownmaxout

integer :: nmemmin
integer :: npools,nsqownmax,npqownmax,nmem
integer :: npes_per_npools

nmemmin = npq + nsq + 1
npoolsout = 0
npqownmaxout = 0
nsqownmaxout = 0

! FHJ: we can`t have more pools than the number of pool quantities or MPI processes
do npools = 1, min(npq,npes)

! FHJ: npqownmax = max num. of pooled quantity per proc. for this number of pools
npqownmax = (npq + npools - 1) / npools

! FHJ: nsqownmax = max num. of spread quantity per proc. for this number of pools
! For a given pool, we have (npes/npools) MPI processes over which the
! pooled quantity is parallelized.
npes_per_npools = npes/npools
nsqownmax = (nsq + npes_per_npools - 1) / npes_per_npools

! FHJ: Note that both npqownmax and nsqownmax are max. number of the pooled/spread quantity, and for
! this reason we round the divisions up. We also round (npes/npools)
! down, so we are conservative (and pessimistic) about the resources.

! FHJ: Upper bound on the memory required for each proc to store the WFNs
nmem = npqownmax + nsqownmax
!ntime = npqownmax * nsqownmax

if (nmem .lt. nmemmin) then
nmemmin = nmem
npoolsout = npools
npqownmaxout = npqownmax
nsqownmaxout = nsqownmax
endif

enddo

return

end subroutine createpools

end module createpools_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/read_cube.f90 > Common/read_cube.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/read_cube.p.f -o Common/read_cube.o -module Common/
# 1 "Common/read_cube.p.f"

!===============================================================================
!
! Routines:
!
! 1. read_cube() Originally By gsm Last Modified 9/3/2010 (gsm)
!
! Reads Gaussian Cube file fnam on unit unum. The result is placed
! into real (if ip = 1) or imaginary (if ip = 2) part of array boxr
! on node 0 (if fparafft = .true.) or array boxr_d distributed over
! nodes (if fparafft = .false.). Gaussian Cube file is tested using
! lattice vectors a and lattice constant al (in Bohr), FFTgrid is FFT
! grid size, Nplane is number of FFT xy-planes per node, ierr is
! return error code (0 means success).
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 19 "Common/Common/read_cube.f90" 2

module read_cube_m

use global_m
implicit none

private

public :: read_cube

contains

subroutine read_cube(fparafft,unum,fnam,a,al,ip,Nplane,FFTgrid,boxr,boxr_d,ierr)
logical, intent(in) :: fparafft
integer, intent(in) :: unum
character(len=256), intent(in) :: fnam
real(DP), intent(in) :: al
real(DP), intent(in) :: a(3,3)
integer, intent(in) :: ip
integer, intent(in) :: Nplane
integer, intent(in) :: FFTgrid(3)
complex(DPC), pointer, intent(inout) :: boxr(:,:,:) !< (FFTgrid(1),FFTgrid(2),FFTgrid(3))
complex(DPC), pointer, intent(inout) :: boxr_d(:,:,:) !< (FFTgrid(1),FFTgrid(2),Nplane)
integer, intent(out) :: ierr

real(DP), parameter :: eps4 = 1.0d-4

integer :: i,j,k,k0,k1,k2,jerr,knum,na,ngrid(3)
real(DP) :: dr,origin(3),step(3,3)
real(DP), allocatable :: buffer(:)
character(len=256) :: tmpstr

if (peinf%inode.eq.0) then
na=0
ngrid(:)=0
origin(:)=0.0d0
step(:,:)=0.0d0
call open_file(unit=unum,file=fnam,status='old',form='formatted')
read(unum,*,iostat=jerr)
if (jerr.eq.0) read(unum,*,iostat=jerr)
if (jerr.eq.0) read(unum,*,iostat=jerr)na,(origin(j),j=1,3)
do i=1,3
if (jerr.eq.0) read(unum,*,iostat=jerr)ngrid(i),(step(j,i),j=1,3)
enddo
if (jerr.eq.0) call close_file(unit=unum)
endif

# 75

if (ngrid(1).ne.FFTgrid(1).or.ngrid(2).ne.FFTgrid(2).or. &
ngrid(3).ne.FFTgrid(3)) jerr=1
dr=0.0d0
do j=1,3
dr=dr+abs(origin(j))
enddo
dr=dr/dble(3)
if (dr.gt.eps4) jerr=1
dr=0.0d0
do i=1,3
do j=1,3
dr=dr+abs(dble(ngrid(i))*step(j,i)-al*a(j,i))
enddo
enddo
dr=dr/dble(9)
if (dr.gt.eps4) jerr=1

if (jerr .ne. 0) write(0,*) 'WARNING: Inconsistency in your calculation and .cube file.'
if (jerr .ne. 0) write(0,*) 'al',al
if (jerr .ne. 0) write(0,*) 'a',a
if (jerr .ne. 0) write(0,*) 'ngrid',ngrid
if (jerr .ne. 0) write(0,*) 'FFTgrid',FFTgrid
if (jerr .ne. 0) write(0,*) 'step',step

if (jerr.eq.0) then
allocate(buffer (FFTgrid(3)))
if (peinf%inode.eq.0) then
if (mod(FFTgrid(3),6).eq.0) then
knum=FFTgrid(3)/6
else
knum=FFTgrid(3)/6+1
endif
call open_file(unit=unum,file=fnam,status='old',form='formatted')
do i=1,6+na
read(unum,*)
enddo
endif
do i=1,FFTgrid(1)
do j=1,FFTgrid(2)
if (peinf%inode.eq.0) then
do k=1,knum
read(unum,103)tmpstr
k1=6*(k-1)+1
k2=6*(k-1)+6
if (k2.gt.FFTgrid(3)) k2=FFTgrid(3)
read(tmpstr,*)(buffer(k0),k0=k1,k2)
enddo
endif
if (fparafft) then

if (ip.eq.1) then
do k=1,FFTgrid(3)
if (k.ge.Nplane*peinf%inode+1.and.k.le.Nplane*(peinf%inode+1)) &
boxr_d(i,j,k-Nplane*peinf%inode)=cmplx(buffer(k),aimag(boxr_d(i,j,k-Nplane*peinf%inode)),kind=DPC)
enddo
elseif (ip.eq.2) then
do k=1,FFTgrid(3)
if (k.ge.Nplane*peinf%inode+1.and.k.le.Nplane*(peinf%inode+1)) &
boxr_d(i,j,k-Nplane*peinf%inode)=cmplx(dble(boxr_d(i,j,k-Nplane*peinf%inode)),buffer(k),kind=DPC)
enddo
endif
else
if (ip.eq.1) then
do k=1,FFTgrid(3)
boxr(i,j,k)=cmplx(buffer(k),aimag(boxr(i,j,k)),kind=DPC)
enddo
elseif (ip.eq.2) then
do k=1,FFTgrid(3)
boxr(i,j,k)=cmplx(dble(boxr(i,j,k)),buffer(k),kind=DPC)
enddo
endif
endif
enddo
enddo
if (peinf%inode.eq.0) then
call close_file(unit=unum)
endif
if(allocated(buffer))then;deallocate(buffer);endif
endif

ierr=jerr

return

103 format(a)

end subroutine read_cube

end module read_cube_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/norm.f90 > Common/norm.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/norm.p.f -o Common/norm.o -module Common/
# 1 "Common/norm.p.f"
!===============================================================================
!
! Routines:
!
! 1. norm_wfng() Originally By gsm Last Modified 9/1/2010 (gsm)
!
! Normalizes wavefunctions in G-space.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/norm.f90" 2

subroutine norm_wfng(ngk_l,nbstart,nbend,nb,ns,nk,wfn_d)

use global_m
use blas_m
implicit none

integer, intent(in) :: ngk_l,nbstart,nbend,nb,ns,nk
complex(DPC), intent(inout) :: wfn_d(ngk_l,nb,ns,nk) !< parallelized over G-vectors

integer :: ib,is,ik,nbnorm
character(len=16) :: s1,s2,s3
real(DP), allocatable :: norm2band(:)
real(DP), allocatable :: norm2dummy(:)

nbnorm=nbend-nbstart+1
allocate(norm2band (nbnorm))

do ik=1,nk
do is=1,ns
do ib=nbstart,nbend
norm2band(ib-nbstart+1) = blas_nrm2(ngk_l, wfn_d(:,ib,is,ik), 1)**2
enddo ! ib

do ib=nbstart,nbend
if (norm2band(ib-nbstart+1) .gt. TOL_Zero) then
call zscal(ngk_l, (1.0d0,0.0d0)/sqrt(norm2band(ib-nbstart+1)), wfn_d(:,ib,is,ik), 1)
else ! norm2.gt.TOL_Zero
if (peinf%inode.eq.0) then
write(s1,111)ib
write(s2,111)is
write(s3,111)ik
write(0,211)TRUNC(s1),TRUNC(s2),TRUNC(s3)
endif ! peinf%inode.eq.0
endif ! norm2.gt.TOL_Zero
enddo ! ib
enddo ! is
enddo ! ik
if(allocated(norm2band))then;deallocate(norm2band);endif

return

111 format(i16)

211 format(1x,"WARNING: zero norm for k-point =",1x,a,1x,"spin =", &
1x,a,1x,"band =",1x,a,/)

end subroutine norm_wfng
icc -E -C -P -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/sort.F90 > Common/sort.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/sort.p.f -o Common/sort.o -module Common/
# 1 "Common/sort.p.f"
!>==========================================================================
!!
!! Module sort_m:
!!
!! (1) gcutoff
!!
!! Given G-vectors sorted by kinetic energy and an energy cutoff,
!! find the corresponding G-vector cutoff.
!!
!! (2,3) sortrx, sortix
!!
!! Sorts an array by the quicksort method. real(DP) and integer versions.
!! See included sort_inc.f90.
!!
!! (4) make_identity_symmetry_first
!!
!! The identity must always be the first symmetry, as assumed in various places
!! in the code. We enforce this by swapping it with op #1 if it is not first.
!!
!! (5) sort_symmetries
!!
!! Bring symmetries into a standardized order. We are not currently using this.
!!
!!==========================================================================

!The following macro puts any point/array in the [-0.5, 0.5) range:
!The following macro puts any point/array in the [0, 1) range:
!Integer division of a/b rounded up*/
!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

! deprecated identifiers

! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

! very ancient version may require NOSIZEOF

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.

! path before 4.0.9 lacks SIZEOF

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?

! It is considered a bug in OPEN64 that sizeof will not work in our code.

! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit

! name of routine to get name of host program is running on

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m

! how to get the cpu time in seconds

! interface required for mclock routine (timing) to be usable

! interface required for iargc routine (command-line arguments) to be usable

! ftell gives you the current location in a file, to fseek back to it

! if no fseek, ftell is useless

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

module sort_m
use global_m

implicit none

private

public :: &
gcutoff, &
sortrx, &
sortix, &
make_identity_symmetry_first, &
sort_symmetries

interface sortrx
module procedure sortrx_gvec, sortrx_no_gvec
end interface
interface sortix
module procedure sortix_gvec, sortix_no_gvec
end interface

contains

!> Given G-vectors sorted by kinetic energy and an energy cutoff, find the corresponding G-vector cutoff
!! such that all(ekin(isrtrq(ig)) <= ecutoff) for ig <= gcutoff.
integer function gcutoff(ng, ekin, isrtrq, ecutoff)
integer, intent(in) :: ng !< number of G-vectors
real(DP), intent(in) :: ekin(:) !< (ng) kinetic energies, should be sorted already
integer, intent(in) :: isrtrq(:) !< (ng) this is the index array returned by sorting ekin
real(DP), intent(in) :: ecutoff !< energy cutoff, in same units as ekin (Ry typically)

integer :: gup, gdn, gmid, ig

! perhaps all G-vectors fall within the cutoff
if(ekin(isrtrq(ng)) < ecutoff) then
gcutoff = ng

return
endif

! otherwise, use bisection
gup = ng
gdn = 1

do ig = 1, ng
gmid = (gup + gdn) / 2
if(gmid == gdn) exit
if(ekin(isrtrq(gmid)) > ecutoff) then
gup = gmid
else
gdn = gmid
endif
enddo
gcutoff = gdn

return
end function gcutoff

!=====================================================================
!> The identity must always be the first symmetry, as assumed in various places in the code.
subroutine make_identity_symmetry_first(nsyms, mtrx, tnp)
integer, intent(in) :: nsyms
integer, intent(inout) :: mtrx(3, 3, 48)
real(DP), intent(inout) :: tnp(3, 48)

integer :: isym, mtrx_temp(3, 3), identity(3,3)
real(DP) :: tnp_temp(3)
logical :: found

identity = reshape((/1, 0, 0, 0, 1, 0, 0, 0, 1/), shape(identity))
found = all(mtrx(1:3, 1:3, 1) == identity(1:3, 1:3))

do isym = 2, nsyms
if(all(mtrx(1:3, 1:3, isym) == identity(1:3, 1:3))) then
if(.not. found) then
! if identity is not first, swap
mtrx_temp(1:3, 1:3) = mtrx(1:3, 1:3, 1)
mtrx(1:3, 1:3, 1) = mtrx(1:3, 1:3, isym)
mtrx(1:3, 1:3, isym) = mtrx_temp(1:3, 1:3)

tnp_temp(1:3) = tnp(1:3, 1)
tnp(1:3, 1) = tnp(1:3, isym)
tnp(1:3, isym) = tnp_temp(1:3)

found = .true.
write(0,'(a,i2)') 'WARNING: making identity first by swapping with symmetry op #', isym
else
call die("There is a duplicate identity in the symmetry operations.")
endif
endif
enddo

if(.not. found) then
call die("Identity is not present in the list of symmetries.")
endif

return
end subroutine make_identity_symmetry_first

!=====================================================================
!> Bring symmetries into a standardized order.
!! The identity is always the first one.
subroutine sort_symmetries(nsyms, mtrx, tnp)
integer, intent(in) :: nsyms
integer, intent(inout) :: mtrx(3, 3, 48)
real(DP), intent(inout) :: tnp(3, 48)

integer :: isym, ii, jj, factor, hash(48), order(48), mtrx_temp(3, 3, 48), identity(3,3)
real(DP) :: tnp_temp(3, 48)

identity = reshape((/1, 0, 0, 0, 1, 0, 0, 0, 1/), shape(identity))

do isym = 1, nsyms

! make sure the identity comes first
if(all(mtrx(1:3, 1:3, isym) == identity(1:3, 1:3))) then
hash(isym) = -1d9
cycle
endif

hash(isym) = 0
factor = 1
do jj = 1, 3
if(jj > 1) factor = factor * 3
do ii = 1, 3
if(ii > 1) factor = factor * 3
hash(isym) = hash(isym) + mtrx(4 - ii, 4 - jj, isym) * factor
enddo
enddo
enddo

call sortix(nsyms, hash, order)

do isym = 1, nsyms
mtrx_temp(1:3, 1:3, isym) = mtrx(1:3, 1:3, order(isym))
tnp_temp(1:3, isym) = tnp(1:3, order(isym))
enddo

mtrx(1:3, 1:3, 1:nsyms) = mtrx_temp(1:3, 1:3, 1:nsyms)
tnp(1:3, 1:nsyms) = tnp_temp(1:3, 1:nsyms)

return
end subroutine sort_symmetries

!=====================================================================

! FHJ: Use the preprocessor to create the following routines:
! sortix_gvec, sortix_no_gvec, sortrx_gvec, sortrx_no_gvec

! This file is based on the work of Michel Olagnon.
! The original code for the MRGRNK subroutine is available at:
! http://fortran-2000.com/rank/mrgrnk.f90

! MRGRNK - Copyright (c) Michel Olagnon
! Copying and distribution of this file, with or without modification,
! are permitted in any medium without royalty provided the copyright
! notice and this notice are preserved. This file is offered as-is,
! without any warranty.

! FHJ: WARNING - make sure you don`t change the following lines too much,
! otherwise they will be longer than 120 characters after the preprocessors kicks in.
! Note that, if there the extra "gvec" argument, we use a tolerance to figure
! out if the two items AA(ii) and AA(jj) are degenerate.

! FHJ: Note - we need to nest the "JOIN" macro otherwise the symbol sortix_gvec
! doesn`t get expanded by the C preprocessor.

!> Sorts (actually, ranks) a small array AA using the insert sort algorithm.
subroutine sortix_gvec_insertsort(NVAL, AA, ord&
, GK&
)
integer, intent(in) :: NVAL
integer, intent(in) :: AA(NVAL)
integer, intent(inout) :: ord(NVAL)
integer, intent(in) :: GK(NVAL)
integer, parameter :: TOL=TOL_ZERO

integer :: ii, jj, tord

do ii = 2, NVAL
tord = ord(ii)
jj = ii - 1
do while (jj>0)
if (.not.(AA(ord(jj))-AA(tord)>TOL . or .(AA(ord(jj))-AA(tord)> -TOL . and . GK(ord(jj))>GK(tord)))) exit
ord(jj+1) = ord(jj)
jj = jj - 1
enddo
ord(jj+1) = tord
enddo

end subroutine sortix_gvec_insertsort

!> Sorts (actually, ranks) a real/integer array AA.
!! The rank is written to the output array ord.
!! This subroutine is based on the routine MRGRNK by Michel Olagnon, which
!! uses the merge sort algorithm.
subroutine sortix_gvec(NVAL, AA, ord&
, gvec&
)
integer, intent(in) :: NVAL
integer, intent(in) :: AA(NVAL)
integer, intent(out) :: ord(NVAL)
integer, intent(in) :: gvec(3,NVAL) !< (3, N) G-vectors, used to break tie for equal data

integer :: GK(NVAL), fftgrid(3)
integer, parameter :: TOL=TOL_ZERO
!
integer :: JT(NVAL)
integer :: LMTNA, LMTNC, IRNG1, IRNG2
integer :: IIND, ID, IWRK, IWRKF, JINDA, IA, IB

fftgrid(1:3) = maxval(gvec(1:3,1:NVAL), 2) - minval(gvec(1:3,1:NVAL), 2) + 1
do IIND=1,NVAL
GK(IIND) = gvec(3,IIND) + fftgrid(3)*(gvec(2,IIND) + fftgrid(2)*gvec(1,IIND))
enddo
!
! Fill-in the index array, creating ordered couples
!
Do IIND = 2, NVAL, 2
If (&
(AA(IIND)-AA(IIND-1)>TOL . or .(AA(IIND)-AA(IIND-1)> -TOL . and . GK(IIND)>GK(IIND-1)))&
) Then
ord (IIND-1) = IIND - 1
ord (IIND) = IIND
Else
ord (IIND-1) = IIND
ord (IIND) = IIND - 1
End If
End Do
If (Modulo(NVAL, 2) /= 0) Then
ord (NVAL) = NVAL
End If

! FHJ - shortcut if the array is small enough
if (NVAL<16) then
call sortix_gvec_insertsort(NVAL, AA, ord&
, GK&
)
return
endif

!
! We will now have ordered subsets A - B - A - B - ...
! and merge A and B couples into C - C - ...
!
LMTNA = 2
LMTNC = 4
!
! First iteration. The length of the ordered subsets goes from 2 to 4
!
Do
If (NVAL <= 2) Exit
!
! Loop on merges of A and B into C
!
Do ID = 0, NVAL - 1, 4
If ((ID+4) > NVAL) Then
If ((ID+2) >= NVAL) Exit
!
! 1 2 3
!
If (&
(AA(ord(ID+3))-AA(ord(ID+2))>TOL . or .(AA(ord(ID+3))-AA(ord(ID+2))> -TOL . and . GK(ord(ID+3))>GK(ord(ID+2))))&
) Exit
!
! 1 3 2
!
If (&
(AA(ord(ID+3))-AA(ord(ID+1))>TOL . or .(AA(ord(ID+3))-AA(ord(ID+1))> -TOL . and . GK(ord(ID+3))>GK(ord(ID+1))))&
) Then
IRNG2 = ord (ID+2)
ord (ID+2) = ord (ID+3)
ord (ID+3) = IRNG2
!
! 3 1 2
!
Else
IRNG1 = ord (ID+1)
ord (ID+1) = ord (ID+3)
ord (ID+3) = ord (ID+2)
ord (ID+2) = IRNG1
End If
Exit
End If
!
! 1 2 3 4
!
If (&
(AA(ord(ID+3))-AA(ord(ID+2))>TOL . or .(AA(ord(ID+3))-AA(ord(ID+2))> -TOL . and . GK(ord(ID+3))>GK(ord(ID+2))))&
) Cycle
!
! 1 3 x x
!
If (&
(AA(ord(ID+3))-AA(ord(ID+1))>TOL . or .(AA(ord(ID+3))-AA(ord(ID+1))> -TOL . and . GK(ord(ID+3))>GK(ord(ID+1))))&
) Then
IRNG2 = ord (ID+2)
ord (ID+2) = ord (ID+3)
If (&
(AA(ord(ID+4))-AA(IRNG2)>TOL . or .(AA(ord(ID+4))-AA(IRNG2)> -TOL . and . GK(ord(ID+4))>GK(IRNG2)))&
) Then
! 1 3 2 4
ord (ID+3) = IRNG2
Else
! 1 3 4 2
ord (ID+3) = ord (ID+4)
ord (ID+4) = IRNG2
End If
!
! 3 x x x
!
Else
IRNG1 = ord (ID+1)
IRNG2 = ord (ID+2)
ord (ID+1) = ord (ID+3)
If (&
(AA(ord(ID+4))-AA(IRNG1)>TOL . or .(AA(ord(ID+4))-AA(IRNG1)> -TOL . and . GK(ord(ID+4))>GK(IRNG1)))&
) Then
ord (ID+2) = IRNG1
If (&
(AA(ord(ID+4))-AA(IRNG2)>TOL . or .(AA(ord(ID+4))-AA(IRNG2)> -TOL . and . GK(ord(ID+4))>GK(IRNG2)))&
) Then
! 3 1 2 4
ord (ID+3) = IRNG2
Else
! 3 1 4 2
ord (ID+3) = ord (ID+4)
ord (ID+4) = IRNG2
End If
Else
! 3 4 1 2
ord (ID+2) = ord (ID+4)
ord (ID+3) = IRNG1
ord (ID+4) = IRNG2
End If
End If
End Do
!
! The Cs become As and Bs
!
LMTNA = 4
Exit
End Do
!
! Iteration loop. Each time, the length of the ordered subsets
! is doubled.
!
Do
If (LMTNA >= NVAL) Exit
IWRKF = 0
LMTNC = 2 * LMTNC
!
! Loop on merges of A and B into C
!
Do
IWRK = IWRKF
ID = IWRKF + 1
JINDA = IWRKF + LMTNA
IWRKF = IWRKF + LMTNC
If (IWRKF >= NVAL) Then
If (JINDA >= NVAL) Exit
IWRKF = NVAL
End If
IA = 1
IB = JINDA + 1
!
! Shortcut for the case when the max of A is smaller
! than the min of B. This line may be activated when the
! initial set is already close to sorted.
!
IF (&
(AA(ord(IB))-AA(ord(JINDA))>TOL . or .(AA(ord(IB))-AA(ord(JINDA))> -TOL . and . GK(ord(IB))>GK(ord(JINDA))))&
) CYCLE
!
! One steps in the C subset, that we build in the final rank array
!
! Make a copy of the rank array for the merge iteration
!
JT (1:LMTNA) = ord (ID:JINDA)
!
Do
IWRK = IWRK + 1
!
! We still have unprocessed values in both A and B
!
If (&
(AA(JT(IA))-AA(ord(IB))>TOL . or .(AA(JT(IA))-AA(ord(IB))> -TOL . and . GK(JT(IA))>GK(ord(IB))))&
) Then
ord (IWRK) = ord (IB)
IB = IB + 1
If (IB > IWRKF) Then
! Only A still with unprocessed values
ord (IWRK+1:IWRKF) = JT (IA:LMTNA)
Exit
End If
Else
ord (IWRK) = JT (IA)
IA = IA + 1
If (IA > LMTNA) Exit! Only B still with unprocessed values
End If
!
End Do
End Do
!
! The Cs become As and Bs
!
LMTNA = 2 * LMTNA
End Do
!

!
End Subroutine sortix_gvec

! This file is based on the work of Michel Olagnon.
! The original code for the MRGRNK subroutine is available at:
! http://fortran-2000.com/rank/mrgrnk.f90

! MRGRNK - Copyright (c) Michel Olagnon
! Copying and distribution of this file, with or without modification,
! are permitted in any medium without royalty provided the copyright
! notice and this notice are preserved. This file is offered as-is,
! without any warranty.

! FHJ: WARNING - make sure you don`t change the following lines too much,
! otherwise they will be longer than 120 characters after the preprocessors kicks in.
! Note that, if there the extra "gvec" argument, we use a tolerance to figure
! out if the two items AA(ii) and AA(jj) are degenerate.

! FHJ: Note - we need to nest the "JOIN" macro otherwise the symbol sortix_no_gvec
! doesn`t get expanded by the C preprocessor.

!> Sorts (actually, ranks) a small array AA using the insert sort algorithm.
subroutine sortix_no_gvec_insertsort(NVAL, AA, ord&
)
integer, intent(in) :: NVAL
integer, intent(in) :: AA(NVAL)
integer, intent(inout) :: ord(NVAL)

integer :: ii, jj, tord

do ii = 2, NVAL
tord = ord(ii)
jj = ii - 1
do while (jj>0)
if (.not.(AA(ord(jj))>AA(tord))) exit
ord(jj+1) = ord(jj)
jj = jj - 1
enddo
ord(jj+1) = tord
enddo

end subroutine sortix_no_gvec_insertsort

!> Sorts (actually, ranks) a real/integer array AA.
!! The rank is written to the output array ord.
!! This subroutine is based on the routine MRGRNK by Michel Olagnon, which
!! uses the merge sort algorithm.
subroutine sortix_no_gvec(NVAL, AA, ord&
)
integer, intent(in) :: NVAL
integer, intent(in) :: AA(NVAL)
integer, intent(out) :: ord(NVAL)
!
integer :: JT(NVAL)
integer :: LMTNA, LMTNC, IRNG1, IRNG2
integer :: IIND, ID, IWRK, IWRKF, JINDA, IA, IB

!
! Fill-in the index array, creating ordered couples
!
Do IIND = 2, NVAL, 2
If (&
(AA(IIND)>AA(IIND-1))&
) Then
ord (IIND-1) = IIND - 1
ord (IIND) = IIND
Else
ord (IIND-1) = IIND
ord (IIND) = IIND - 1
End If
End Do
If (Modulo(NVAL, 2) /= 0) Then
ord (NVAL) = NVAL
End If

! FHJ - shortcut if the array is small enough
if (NVAL<16) then
call sortix_no_gvec_insertsort(NVAL, AA, ord&
)
return
endif

!
! We will now have ordered subsets A - B - A - B - ...
! and merge A and B couples into C - C - ...
!
LMTNA = 2
LMTNC = 4
!
! First iteration. The length of the ordered subsets goes from 2 to 4
!
Do
If (NVAL <= 2) Exit
!
! Loop on merges of A and B into C
!
Do ID = 0, NVAL - 1, 4
If ((ID+4) > NVAL) Then
If ((ID+2) >= NVAL) Exit
!
! 1 2 3
!
If (&
(AA(ord(ID+3))>AA(ord(ID+2)))&
) Exit
!
! 1 3 2
!
If (&
(AA(ord(ID+3))>AA(ord(ID+1)))&
) Then
IRNG2 = ord (ID+2)
ord (ID+2) = ord (ID+3)
ord (ID+3) = IRNG2
!
! 3 1 2
!
Else
IRNG1 = ord (ID+1)
ord (ID+1) = ord (ID+3)
ord (ID+3) = ord (ID+2)
ord (ID+2) = IRNG1
End If
Exit
End If
!
! 1 2 3 4
!
If (&
(AA(ord(ID+3))>AA(ord(ID+2)))&
) Cycle
!
! 1 3 x x
!
If (&
(AA(ord(ID+3))>AA(ord(ID+1)))&
) Then
IRNG2 = ord (ID+2)
ord (ID+2) = ord (ID+3)
If (&
(AA(ord(ID+4))>AA(IRNG2))&
) Then
! 1 3 2 4
ord (ID+3) = IRNG2
Else
! 1 3 4 2
ord (ID+3) = ord (ID+4)
ord (ID+4) = IRNG2
End If
!
! 3 x x x
!
Else
IRNG1 = ord (ID+1)
IRNG2 = ord (ID+2)
ord (ID+1) = ord (ID+3)
If (&
(AA(ord(ID+4))>AA(IRNG1))&
) Then
ord (ID+2) = IRNG1
If (&
(AA(ord(ID+4))>AA(IRNG2))&
) Then
! 3 1 2 4
ord (ID+3) = IRNG2
Else
! 3 1 4 2
ord (ID+3) = ord (ID+4)
ord (ID+4) = IRNG2
End If
Else
! 3 4 1 2
ord (ID+2) = ord (ID+4)
ord (ID+3) = IRNG1
ord (ID+4) = IRNG2
End If
End If
End Do
!
! The Cs become As and Bs
!
LMTNA = 4
Exit
End Do
!
! Iteration loop. Each time, the length of the ordered subsets
! is doubled.
!
Do
If (LMTNA >= NVAL) Exit
IWRKF = 0
LMTNC = 2 * LMTNC
!
! Loop on merges of A and B into C
!
Do
IWRK = IWRKF
ID = IWRKF + 1
JINDA = IWRKF + LMTNA
IWRKF = IWRKF + LMTNC
If (IWRKF >= NVAL) Then
If (JINDA >= NVAL) Exit
IWRKF = NVAL
End If
IA = 1
IB = JINDA + 1
!
! Shortcut for the case when the max of A is smaller
! than the min of B. This line may be activated when the
! initial set is already close to sorted.
!
IF (&
(AA(ord(IB))>AA(ord(JINDA)))&
) CYCLE
!
! One steps in the C subset, that we build in the final rank array
!
! Make a copy of the rank array for the merge iteration
!
JT (1:LMTNA) = ord (ID:JINDA)
!
Do
IWRK = IWRK + 1
!
! We still have unprocessed values in both A and B
!
If (&
(AA(JT(IA))>AA(ord(IB)))&
) Then
ord (IWRK) = ord (IB)
IB = IB + 1
If (IB > IWRKF) Then
! Only A still with unprocessed values
ord (IWRK+1:IWRKF) = JT (IA:LMTNA)
Exit
End If
Else
ord (IWRK) = JT (IA)
IA = IA + 1
If (IA > LMTNA) Exit! Only B still with unprocessed values
End If
!
End Do
End Do
!
! The Cs become As and Bs
!
LMTNA = 2 * LMTNA
End Do
!

!
End Subroutine sortix_no_gvec

! This file is based on the work of Michel Olagnon.
! The original code for the MRGRNK subroutine is available at:
! http://fortran-2000.com/rank/mrgrnk.f90

! MRGRNK - Copyright (c) Michel Olagnon
! Copying and distribution of this file, with or without modification,
! are permitted in any medium without royalty provided the copyright
! notice and this notice are preserved. This file is offered as-is,
! without any warranty.

! FHJ: WARNING - make sure you don`t change the following lines too much,
! otherwise they will be longer than 120 characters after the preprocessors kicks in.
! Note that, if there the extra "gvec" argument, we use a tolerance to figure
! out if the two items AA(ii) and AA(jj) are degenerate.

! FHJ: Note - we need to nest the "JOIN" macro otherwise the symbol sortrx_gvec
! doesn`t get expanded by the C preprocessor.

!> Sorts (actually, ranks) a small array AA using the insert sort algorithm.
subroutine sortrx_gvec_insertsort(NVAL, AA, ord&
, GK&
)
integer, intent(in) :: NVAL
real(DP), intent(in) :: AA(NVAL)
integer, intent(inout) :: ord(NVAL)
integer, intent(in) :: GK(NVAL)
real(DP), parameter :: TOL=TOL_ZERO

integer :: ii, jj, tord

do ii = 2, NVAL
tord = ord(ii)
jj = ii - 1
do while (jj>0)
if (.not.(AA(ord(jj))-AA(tord)>TOL . or .(AA(ord(jj))-AA(tord)> -TOL . and . GK(ord(jj))>GK(tord)))) exit
ord(jj+1) = ord(jj)
jj = jj - 1
enddo
ord(jj+1) = tord
enddo

end subroutine sortrx_gvec_insertsort

!> Sorts (actually, ranks) a real/integer array AA.
!! The rank is written to the output array ord.
!! This subroutine is based on the routine MRGRNK by Michel Olagnon, which
!! uses the merge sort algorithm.
subroutine sortrx_gvec(NVAL, AA, ord&
, gvec&
)
integer, intent(in) :: NVAL
real(DP), intent(in) :: AA(NVAL)
integer, intent(out) :: ord(NVAL)
integer, intent(in) :: gvec(3,NVAL) !< (3, N) G-vectors, used to break tie for equal data

integer :: GK(NVAL), fftgrid(3)
real(DP), parameter :: TOL=TOL_ZERO
!
integer :: JT(NVAL)
integer :: LMTNA, LMTNC, IRNG1, IRNG2
integer :: IIND, ID, IWRK, IWRKF, JINDA, IA, IB

fftgrid(1:3) = maxval(gvec(1:3,1:NVAL), 2) - minval(gvec(1:3,1:NVAL), 2) + 1
do IIND=1,NVAL
GK(IIND) = gvec(3,IIND) + fftgrid(3)*(gvec(2,IIND) + fftgrid(2)*gvec(1,IIND))
enddo
!
! Fill-in the index array, creating ordered couples
!
Do IIND = 2, NVAL, 2
If (&
(AA(IIND)-AA(IIND-1)>TOL . or .(AA(IIND)-AA(IIND-1)> -TOL . and . GK(IIND)>GK(IIND-1)))&
) Then
ord (IIND-1) = IIND - 1
ord (IIND) = IIND
Else
ord (IIND-1) = IIND
ord (IIND) = IIND - 1
End If
End Do
If (Modulo(NVAL, 2) /= 0) Then
ord (NVAL) = NVAL
End If

! FHJ - shortcut if the array is small enough
if (NVAL<16) then
call sortrx_gvec_insertsort(NVAL, AA, ord&
, GK&
)
return
endif

!
! We will now have ordered subsets A - B - A - B - ...
! and merge A and B couples into C - C - ...
!
LMTNA = 2
LMTNC = 4
!
! First iteration. The length of the ordered subsets goes from 2 to 4
!
Do
If (NVAL <= 2) Exit
!
! Loop on merges of A and B into C
!
Do ID = 0, NVAL - 1, 4
If ((ID+4) > NVAL) Then
If ((ID+2) >= NVAL) Exit
!
! 1 2 3
!
If (&
(AA(ord(ID+3))-AA(ord(ID+2))>TOL . or .(AA(ord(ID+3))-AA(ord(ID+2))> -TOL . and . GK(ord(ID+3))>GK(ord(ID+2))))&
) Exit
!
! 1 3 2
!
If (&
(AA(ord(ID+3))-AA(ord(ID+1))>TOL . or .(AA(ord(ID+3))-AA(ord(ID+1))> -TOL . and . GK(ord(ID+3))>GK(ord(ID+1))))&
) Then
IRNG2 = ord (ID+2)
ord (ID+2) = ord (ID+3)
ord (ID+3) = IRNG2
!
! 3 1 2
!
Else
IRNG1 = ord (ID+1)
ord (ID+1) = ord (ID+3)
ord (ID+3) = ord (ID+2)
ord (ID+2) = IRNG1
End If
Exit
End If
!
! 1 2 3 4
!
If (&
(AA(ord(ID+3))-AA(ord(ID+2))>TOL . or .(AA(ord(ID+3))-AA(ord(ID+2))> -TOL . and . GK(ord(ID+3))>GK(ord(ID+2))))&
) Cycle
!
! 1 3 x x
!
If (&
(AA(ord(ID+3))-AA(ord(ID+1))>TOL . or .(AA(ord(ID+3))-AA(ord(ID+1))> -TOL . and . GK(ord(ID+3))>GK(ord(ID+1))))&
) Then
IRNG2 = ord (ID+2)
ord (ID+2) = ord (ID+3)
If (&
(AA(ord(ID+4))-AA(IRNG2)>TOL . or .(AA(ord(ID+4))-AA(IRNG2)> -TOL . and . GK(ord(ID+4))>GK(IRNG2)))&
) Then
! 1 3 2 4
ord (ID+3) = IRNG2
Else
! 1 3 4 2
ord (ID+3) = ord (ID+4)
ord (ID+4) = IRNG2
End If
!
! 3 x x x
!
Else
IRNG1 = ord (ID+1)
IRNG2 = ord (ID+2)
ord (ID+1) = ord (ID+3)
If (&
(AA(ord(ID+4))-AA(IRNG1)>TOL . or .(AA(ord(ID+4))-AA(IRNG1)> -TOL . and . GK(ord(ID+4))>GK(IRNG1)))&
) Then
ord (ID+2) = IRNG1
If (&
(AA(ord(ID+4))-AA(IRNG2)>TOL . or .(AA(ord(ID+4))-AA(IRNG2)> -TOL . and . GK(ord(ID+4))>GK(IRNG2)))&
) Then
! 3 1 2 4
ord (ID+3) = IRNG2
Else
! 3 1 4 2
ord (ID+3) = ord (ID+4)
ord (ID+4) = IRNG2
End If
Else
! 3 4 1 2
ord (ID+2) = ord (ID+4)
ord (ID+3) = IRNG1
ord (ID+4) = IRNG2
End If
End If
End Do
!
! The Cs become As and Bs
!
LMTNA = 4
Exit
End Do
!
! Iteration loop. Each time, the length of the ordered subsets
! is doubled.
!
Do
If (LMTNA >= NVAL) Exit
IWRKF = 0
LMTNC = 2 * LMTNC
!
! Loop on merges of A and B into C
!
Do
IWRK = IWRKF
ID = IWRKF + 1
JINDA = IWRKF + LMTNA
IWRKF = IWRKF + LMTNC
If (IWRKF >= NVAL) Then
If (JINDA >= NVAL) Exit
IWRKF = NVAL
End If
IA = 1
IB = JINDA + 1
!
! Shortcut for the case when the max of A is smaller
! than the min of B. This line may be activated when the
! initial set is already close to sorted.
!
IF (&
(AA(ord(IB))-AA(ord(JINDA))>TOL . or .(AA(ord(IB))-AA(ord(JINDA))> -TOL . and . GK(ord(IB))>GK(ord(JINDA))))&
) CYCLE
!
! One steps in the C subset, that we build in the final rank array
!
! Make a copy of the rank array for the merge iteration
!
JT (1:LMTNA) = ord (ID:JINDA)
!
Do
IWRK = IWRK + 1
!
! We still have unprocessed values in both A and B
!
If (&
(AA(JT(IA))-AA(ord(IB))>TOL . or .(AA(JT(IA))-AA(ord(IB))> -TOL . and . GK(JT(IA))>GK(ord(IB))))&
) Then
ord (IWRK) = ord (IB)
IB = IB + 1
If (IB > IWRKF) Then
! Only A still with unprocessed values
ord (IWRK+1:IWRKF) = JT (IA:LMTNA)
Exit
End If
Else
ord (IWRK) = JT (IA)
IA = IA + 1
If (IA > LMTNA) Exit! Only B still with unprocessed values
End If
!
End Do
End Do
!
! The Cs become As and Bs
!
LMTNA = 2 * LMTNA
End Do
!

!
End Subroutine sortrx_gvec

! This file is based on the work of Michel Olagnon.
! The original code for the MRGRNK subroutine is available at:
! http://fortran-2000.com/rank/mrgrnk.f90

! MRGRNK - Copyright (c) Michel Olagnon
! Copying and distribution of this file, with or without modification,
! are permitted in any medium without royalty provided the copyright
! notice and this notice are preserved. This file is offered as-is,
! without any warranty.

! FHJ: WARNING - make sure you don`t change the following lines too much,
! otherwise they will be longer than 120 characters after the preprocessors kicks in.
! Note that, if there the extra "gvec" argument, we use a tolerance to figure
! out if the two items AA(ii) and AA(jj) are degenerate.

! FHJ: Note - we need to nest the "JOIN" macro otherwise the symbol sortrx_no_gvec
! doesn`t get expanded by the C preprocessor.

!> Sorts (actually, ranks) a small array AA using the insert sort algorithm.
subroutine sortrx_no_gvec_insertsort(NVAL, AA, ord&
)
integer, intent(in) :: NVAL
real(DP), intent(in) :: AA(NVAL)
integer, intent(inout) :: ord(NVAL)

integer :: ii, jj, tord

do ii = 2, NVAL
tord = ord(ii)
jj = ii - 1
do while (jj>0)
if (.not.(AA(ord(jj))>AA(tord))) exit
ord(jj+1) = ord(jj)
jj = jj - 1
enddo
ord(jj+1) = tord
enddo

end subroutine sortrx_no_gvec_insertsort

!> Sorts (actually, ranks) a real/integer array AA.
!! The rank is written to the output array ord.
!! This subroutine is based on the routine MRGRNK by Michel Olagnon, which
!! uses the merge sort algorithm.
subroutine sortrx_no_gvec(NVAL, AA, ord&
)
integer, intent(in) :: NVAL
real(DP), intent(in) :: AA(NVAL)
integer, intent(out) :: ord(NVAL)
!
integer :: JT(NVAL)
integer :: LMTNA, LMTNC, IRNG1, IRNG2
integer :: IIND, ID, IWRK, IWRKF, JINDA, IA, IB

!
! Fill-in the index array, creating ordered couples
!
Do IIND = 2, NVAL, 2
If (&
(AA(IIND)>AA(IIND-1))&
) Then
ord (IIND-1) = IIND - 1
ord (IIND) = IIND
Else
ord (IIND-1) = IIND
ord (IIND) = IIND - 1
End If
End Do
If (Modulo(NVAL, 2) /= 0) Then
ord (NVAL) = NVAL
End If

! FHJ - shortcut if the array is small enough
if (NVAL<16) then
call sortrx_no_gvec_insertsort(NVAL, AA, ord&
)
return
endif

!
! We will now have ordered subsets A - B - A - B - ...
! and merge A and B couples into C - C - ...
!
LMTNA = 2
LMTNC = 4
!
! First iteration. The length of the ordered subsets goes from 2 to 4
!
Do
If (NVAL <= 2) Exit
!
! Loop on merges of A and B into C
!
Do ID = 0, NVAL - 1, 4
If ((ID+4) > NVAL) Then
If ((ID+2) >= NVAL) Exit
!
! 1 2 3
!
If (&
(AA(ord(ID+3))>AA(ord(ID+2)))&
) Exit
!
! 1 3 2
!
If (&
(AA(ord(ID+3))>AA(ord(ID+1)))&
) Then
IRNG2 = ord (ID+2)
ord (ID+2) = ord (ID+3)
ord (ID+3) = IRNG2
!
! 3 1 2
!
Else
IRNG1 = ord (ID+1)
ord (ID+1) = ord (ID+3)
ord (ID+3) = ord (ID+2)
ord (ID+2) = IRNG1
End If
Exit
End If
!
! 1 2 3 4
!
If (&
(AA(ord(ID+3))>AA(ord(ID+2)))&
) Cycle
!
! 1 3 x x
!
If (&
(AA(ord(ID+3))>AA(ord(ID+1)))&
) Then
IRNG2 = ord (ID+2)
ord (ID+2) = ord (ID+3)
If (&
(AA(ord(ID+4))>AA(IRNG2))&
) Then
! 1 3 2 4
ord (ID+3) = IRNG2
Else
! 1 3 4 2
ord (ID+3) = ord (ID+4)
ord (ID+4) = IRNG2
End If
!
! 3 x x x
!
Else
IRNG1 = ord (ID+1)
IRNG2 = ord (ID+2)
ord (ID+1) = ord (ID+3)
If (&
(AA(ord(ID+4))>AA(IRNG1))&
) Then
ord (ID+2) = IRNG1
If (&
(AA(ord(ID+4))>AA(IRNG2))&
) Then
! 3 1 2 4
ord (ID+3) = IRNG2
Else
! 3 1 4 2
ord (ID+3) = ord (ID+4)
ord (ID+4) = IRNG2
End If
Else
! 3 4 1 2
ord (ID+2) = ord (ID+4)
ord (ID+3) = IRNG1
ord (ID+4) = IRNG2
End If
End If
End Do
!
! The Cs become As and Bs
!
LMTNA = 4
Exit
End Do
!
! Iteration loop. Each time, the length of the ordered subsets
! is doubled.
!
Do
If (LMTNA >= NVAL) Exit
IWRKF = 0
LMTNC = 2 * LMTNC
!
! Loop on merges of A and B into C
!
Do
IWRK = IWRKF
ID = IWRKF + 1
JINDA = IWRKF + LMTNA
IWRKF = IWRKF + LMTNC
If (IWRKF >= NVAL) Then
If (JINDA >= NVAL) Exit
IWRKF = NVAL
End If
IA = 1
IB = JINDA + 1
!
! Shortcut for the case when the max of A is smaller
! than the min of B. This line may be activated when the
! initial set is already close to sorted.
!
IF (&
(AA(ord(IB))>AA(ord(JINDA)))&
) CYCLE
!
! One steps in the C subset, that we build in the final rank array
!
! Make a copy of the rank array for the merge iteration
!
JT (1:LMTNA) = ord (ID:JINDA)
!
Do
IWRK = IWRK + 1
!
! We still have unprocessed values in both A and B
!
If (&
(AA(JT(IA))>AA(ord(IB)))&
) Then
ord (IWRK) = ord (IB)
IB = IB + 1
If (IB > IWRKF) Then
! Only A still with unprocessed values
ord (IWRK+1:IWRKF) = JT (IA:LMTNA)
Exit
End If
Else
ord (IWRK) = JT (IA)
IA = IA + 1
If (IA > LMTNA) Exit! Only B still with unprocessed values
End If
!
End Do
End Do
!
! The Cs become As and Bs
!
LMTNA = 2 * LMTNA
End Do
!

!
End Subroutine sortrx_no_gvec

end module sort_m

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/input_utils.f90 > Common/input_utils.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/input_utils.p.f -o Common/input_utils.o -module Common/
# 1 "Common/input_utils.p.f"
!===============================================================================
!
! Modules:
!
! input_utils_m Originally By DAS
!
! Several routines useful for analysis after input of wavefunctions.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/input_utils.f90" 2

module input_utils_m

use global_m
use blas_m
implicit none

private

public :: &
assess_degeneracies, &
find_efermi, &
calc_qtot, &
gvec_index, &
kinetic_energies, &
check_trunc_kpts, &
eps_setup_sizes

contains

!> calculates the degeneracy of each state in the kp object
!> if sig is provided, dies if Sigma diagonals cannot be correctly calculated
subroutine assess_degeneracies(kp, kp_el_extra, nband, efermi, tolerance, sig, ncore_excl)
type(kpoints), intent(inout) :: kp
real(DP), intent(in) :: kp_el_extra(:, :) !< (kp%nrk, kp%nspin) !< one more band
integer, intent(in) :: nband !< number of states
real(DP), intent(in) :: efermi
real(DP), intent(in) :: tolerance !< energy tolerance
type(siginfo), optional, intent(in) :: sig
integer, optional, intent(in) :: ncore_excl !< number of core states excluded

integer :: ii, jj, ik, is, band_offset
real(DP) :: energy_compare
character :: tmpstr*100,tmpstr1*16,tmpstr2*16
logical :: written_header

band_offset=0

if (present(ncore_excl)) then
band_offset = ncore_excl
endif
allocate(kp%degeneracy (nband, kp%nrk, kp%nspin))
kp%degeneracy(:,:,:) = 1
written_header = .false.

!FHJ: do we really need two nested loop over nband??
do ii = 1, nband
do jj = 1, nband + 1
if(jj == ii) cycle ! self-degeneracy
do ik = 1, kp%nrk
do is = 1, kp%nspin
if(jj > nband) then
energy_compare = kp_el_extra(ik, is)
else
energy_compare = kp%el(jj+band_offset, ik, is)
endif
! DVF : we add band_offset to ii here because the energies in kp%el
! are referenced to the case including the core states since they are
! setup during wfn i/o.
if(abs(kp%el(ii+band_offset, ik, is) - energy_compare) .lt. tolerance) then
kp%degeneracy(ii, ik, is) = kp%degeneracy(ii, ik, is) + 1

if(abs(kp%el(ii+band_offset, ik, is) - efermi / ryd) < tolerance) then
if(.not. written_header) then
write(0,'(a)') "WARNING: Degeneracies at Fermi level:"
written_header = .true.
endif
write(0,'(a,i6,a,i6,a,i6)') 'k ', ik, ', spin ', is, ', band ', ii
endif

if(present(sig)) then
! There is a problem only if: we are trying to use q-symmetry,
! we are calculating Sigma for this k-point and band, and the
! other degenerate states are not being included.
! DVF : we add band_offset to ii here because the matrix elements
! are referenced to the case including the core states.
if(sig%qgridsym .and. any(sig%indkn(1:sig%nkn) == ik) .and. &
any(sig%diag(1:sig%ndiag) .eq. ii+band_offset) .and. all(sig%diag(1:sig%ndiag) .ne. jj+band_offset)) then
write(tmpstr1,660) ii
write(tmpstr2,660) jj
660 format(i16)
write(tmpstr,'(a,a,a,a)') "Cannot correctly calculate Sigma for band ", TRUNC(tmpstr1), &
" without its degenerate partner ", TRUNC(tmpstr2)
write(0,'(a)') "Run degeneracy_check.x for allowable numbers or set no_symmetries_q_grid."
call die(tmpstr)
endif
endif

endif
enddo ! is
enddo ! ik
enddo ! ii
enddo ! jj
if(written_header) write(0,*)

return
end subroutine assess_degeneracies

!---------------------------------------------------------------------------------------------------
!> only fine unshifted grids use should_search = .true., should_update = .true.
!! coarse grids have should_search, should update true or false depending on eqp corrections vs fine grid
!! shifted grids use should_search = .false. (since may have only valence bands), should_update = .false.
subroutine find_efermi(rfermi, efermi, efermi_input, kp, nband, minband, label, should_search, should_update, &
write7, dont_die_consistency)
logical, intent(in) :: rfermi !< relative or absolute Fermi level
real(DP), intent(inout) :: efermi
real(DP), intent(in) :: efermi_input !< used to see if different from previous Fermi level
type(kpoints), intent(inout) :: kp
integer, intent(in) :: nband !< total number of bands to consider
integer, intent(in) :: minband !< lowest band to consider
character(len=*), intent(in) :: label !< name to be used in output
logical, intent(in) :: should_search !< if true, efermi is calculated
logical, intent(in) :: should_update !< if true, efermi is reset
logical, intent(in) :: write7 !< write to unit 7 as well as unit 6
!> If .true., don`t die if the consistency of ifmin/ifmax are wrong.
!! This is only ok in inteqp with unrestricted_transformation. Default=.false.
logical, intent(in), optional :: dont_die_consistency

integer :: ik, is, ib, consistency_err
real(DP) :: emiddle, efermi_temp
logical :: should_reset_fermi, should_warn_occ, first_occ_warning, die_consistency
real(DP), allocatable :: vbm(:,:), cbm(:,:)

die_consistency = .true.
if (present(dont_die_consistency)) then
die_consistency = .not. dont_die_consistency
endif

should_reset_fermi = .false.
if(should_update .and. .not. should_search) then
call die("BUG: cannot call find_efermi with should_update but not should_search")
endif

if(nband < 1 .or. nband > kp%mnband) then
call die("find_efermi: nband out of bounds")
endif

if(peinf%inode == 0) then
write(6,900) TRUNC(label), maxval(kp%ifmax(1:kp%nrk, 1:kp%nspin))
if(write7) write(7,900) TRUNC(label), maxval(kp%ifmax(1:kp%nrk, 1:kp%nspin))
900 format(1x,'Highest occupied band (', a, ') = ',i0)
endif

if(all(kp%ifmax(1:kp%nrk, 1:kp%nspin) <= 0)) then
call die("All k-points have no occupied bands.")
endif

if(should_search) then
if(any(kp%ifmax(1:kp%nrk, 1:kp%nspin) < nband)) then
allocate(vbm (1:kp%nrk, 1:kp%nspin))
allocate(cbm (1:kp%nrk, 1:kp%nspin))
do is=1,kp%nspin
do ik=1,kp%nrk
vbm(ik, is) = maxval(kp%el(minband:kp%ifmax(ik, is), ik, is))
cbm(ik, is) = minval(kp%el(kp%ifmax(ik, is)+1:nband, ik, is))
enddo
enddo
emiddle = (maxval(vbm) + minval(cbm)) / 2.0d0
if(peinf%inode == 0) then
write(6,901) 'Valence max ', TRUNC(label), maxval(vbm)*ryd
write(6,901) 'Conduction min', TRUNC(label), minval(cbm)*ryd
write(6,901) 'Middle energy ', TRUNC(label), emiddle*ryd
if(write7) then
write(7,901) 'Valence max ', TRUNC(label), maxval(vbm)*ryd
write(7,901) 'Conduction min', TRUNC(label), minval(cbm)*ryd
write(7,901) 'Middle energy ', TRUNC(label), emiddle*ryd
endif
901 format(1x,a,' (', a, ') = ',f0.6,' eV')
endif

! check for consistency: i.e. no valence band or conduction band is on the wrong side of the Fermi energy
consistency_err = 0 !0 = no error
do is = 1, kp%nspin
do ik = 1, kp%nrk
if(kp%ifmax(ik, is) > 0) then
if(any(kp%el(minband:kp%ifmax(ik, is), ik, is) > emiddle + TOL_Zero)) then
consistency_err = ior(consistency_err, 1)
endif
endif
if(kp%ifmax(ik, is) + 1 <= nband) then
if(any(kp%el(kp%ifmax(ik, is) + 1:nband, ik, is) < emiddle - TOL_Zero)) then
consistency_err = ior(consistency_err, 2)
endif
endif
enddo
enddo
if (consistency_err>0 .and. die_consistency) then
if (peinf%inode==0) then
write(0,*)
write(0,*) 'WFN ifmin/ifmax fields are inconsistent:'
if (iand(consistency_err, 1)==1) then
write(0,*) ' - there is a valence state above the middle energy'
endif
if (iand(consistency_err, 2)==2) then
write(0,*) ' - there is a conduction state below the middle energy'
endif
write(0,*) 'Possible causes are:'
write(0,*) '(1) Your k-point sampling is too coarse and cannot resolve the Fermi energy.'
write(0,*) ' Try to carefully inspect your mean-field energies, and consider using a finer k-grid.'
write(0,*) '(2) You are using eqp.dat and the QP corrections change the character of some states'
write(0,*) ' from valence<->conduction. In this case, you should use another mean-field theory'
write(0,*) ' that gives the same ground state as your GW calculation.'
write(0,*) '(3) You are running inteqp, but you are either shifting the Fermi energy or using '
write(0,*) ' restricted transformation.'
endif
call die("WFN ifmin/ifmax fields are inconsistent", only_root_writes = .true.)
else if (consistency_err>0 .and. peinf%inode==0) then
write(0,*)
write(0,*) 'WARNING: ifmin/ifmax fields are inconsistent. Beware that the reported Fermi '
write(0,*) ' and middle energy are probably wrong, as well as the order of the states.'
write(0,*)
endif

! adjust by level set in input file if appropriate
if(rfermi) then
efermi_temp = emiddle * ryd + efermi_input
else
efermi_temp = efermi_input
endif
if(peinf%inode == 0) then
write(6,902) TRUNC(label), efermi_temp
if(write7) write(7,902) TRUNC(label), efermi_temp
902 format(1x,'Fermi energy (', a, ') = ',f0.6,' eV',/)
endif

if(should_update) then
efermi = efermi_temp
endif

should_reset_fermi = (abs(efermi / ryd - emiddle) .gt. TOL_Small)
else
if(peinf%inode == 0) write(0,'(a)') &
'WARNING: There are only valence bands present; cannot determine Fermi energy.'
if ((rfermi.and.efermi_input/=0).or..not.rfermi) then
call die('No conduction bands; cannot determine nor shift the Fermi energy.', &
only_root_writes=.true.)
endif
! pick a large arbitrary value to initialize and make sure we consider all the bands fully occupied
if(should_update) efermi = INF
endif
endif ! should_search

! reset ifmax if Fermi level was moved by input file, or using Fermi level from other wfns
! if neither of these is true, we should have died above if any occs are inconsistent with Fermi level!
! FHJ: reset occupations if we are dealing with...
! 1) a regular WFN_fi file (should_search/update==.true.) and the FE changed; or
! 2) a WFNq_fi file (should_search/update==.false.), in any condition; or
! 3) BSE/input_co.f90 (should_search==.true.) with eqp_co (should_update=.true.)
! and the FE changed => equivalent to (1)
if ( (should_update.and.should_reset_fermi).or.(.not.should_search) ) then

!FHJ: never warn about resetting occupations if we manually moved the FE
should_warn_occ = (peinf%inode==0) .and. ((dabs(efermi_input) Write LDA energies, shifted energies and occupations to file OCCUPATIONS.
!!
!! Useful to debug whether scissors operators/spline adjustment to band
!! structure is correct.
subroutine write_occupations(kp)
type (kpoints), intent(in) :: kp
integer :: is, ik, nb

nb=8 !TODO create an input flag to set number of energies to output
if (peinf%inode==0) then
call open_file(unit=60, file="OCCUPATIONS", status='replace', form='formatted')
write(60, '(a)') '# kx ky kz spin ifmin ifmax'
write(60, '(a)') '# LDA energies before shift (in eV)'
write(60, '(a)') '# LDA energies after scissors/spline shift (in eV)'
write(60, '(a)') '# occupations'

do is=1, kp%nspin
do ik = 1, kp%nrk
write(60, '(3(F9.5,1x),4x,I1,2x,I3,1x,I3)') kp%rk(:, ik), is, kp%ifmin(ik, is), kp%ifmax(ik, is)
write(60, '(2x, 8(F12.5,1x))') kp%elda(1:8, ik, is)
write(60, '(2x, 8(F12.5,1x))') kp%el(1:8, ik, is)*ryd
write(60, '(2x, 8(F12.5,1x))') kp%occ(1:8, ik, is)
enddo
enddo
call close_file(60)
endif

return
end subroutine write_occupations

!---------------------------------------------------------------------------------------------------
! Calculate charge in the cell, from ifmax and from occupations. Do some checks,
! and write results to output.
subroutine calc_qtot(kp, celvol, efermi, qtot, omega_plasma, write7)
type (kpoints), intent(in) :: kp
real(DP), intent(in) :: celvol
real(DP), intent(in) :: efermi
real(DP), intent(out) :: qtot
real(DP), intent(out) :: omega_plasma
logical, intent(in) :: write7

integer :: is, ik
real(DP) :: qkpt, qkpt_occ, qtot_occ

qtot = 0.0d0
qtot_occ = 0d0
do is = 1, kp%nspin
do ik = 1, kp%nrk
qkpt_occ = sum(kp%occ(:, ik, is))

if(kp%ifmax(ik, is) == 0) then
if(kp%el(1, ik, is) < efermi / ryd + TOL_Degeneracy) then
qkpt = 0.5d0
else
qkpt = 0.0d0
endif
else
qkpt = kp%ifmax(ik, is) - kp%ifmin(ik, is)
if(kp%el(kp%ifmax(ik, is), ik, is) > efermi / ryd - TOL_Degeneracy) then
qkpt = qkpt + 0.5d0
else
qkpt = qkpt + 1.0d0
endif
endif

qtot = qtot + qkpt * kp%w(ik)
qtot_occ = qtot_occ + qkpt_occ * kp%w(ik)
enddo
enddo

qtot = qtot * 2.0d0 / dble(kp%nspin*kp%nspinor)
qtot_occ = qtot_occ * 2.0d0 / dble(kp%nspin*kp%nspinor)
omega_plasma = 4.0d0 * sqrt(PI_D * qtot / celvol)

if(peinf%inode == 0) then
write(6,904) qtot
if(write7) write(7,904) qtot
904 format(1x,'Number of electrons per unit cell (from ifmax) = ',f0.6)
if(abs(qtot - nint(qtot)) > TOL_Small * 100) then
write(0,'(a)') " WARNING: Fractional number of electrons per unit cell (from ifmax)."
endif
if(qtot < TOL_Small) then
write(0,'(a)') " WARNING: No electrons per unit cell (from ifmax)!"
endif

write(6,906) qtot_occ
if(write7) write(7,906) qtot_occ
906 format(1x,'Number of electrons per unit cell (from occupations) = ',f0.6)
if(abs(qtot_occ - nint(qtot_occ)) > TOL_Small * 100) then
write(0,'(a)') " WARNING: Fractional number of electrons per unit cell (from occupations)."
endif
if(qtot_occ < TOL_Small) then
write(0,'(a)') " WARNING: No electrons per unit cell (from occupations)!"
endif

if(abs(qtot - qtot_occ) > TOL_Small * 100) then
write(0,'(a)') " WARNING: Discrepancy between number of electron per unit cell from ifmax and from occupations."
endif

write(6,905) omega_plasma
if(write7) write(7,905) omega_plasma
905 format(1x,'Plasma Frequency = ',f0.6,' Ry',/)
endif

return
end subroutine calc_qtot

!> FOR HISTORICAL INTEREST: SIB describes original scheme, GSM describes new scheme
!! SIB: gvec%nFFTgridpts is product of 1+2*FFTgrid(i) over all directions i
!! gvec%index_vec(gvec%nFFTgridpts) is allocated.
!!
!! gvec%index_vec(:) is a table of g-vector addresses: put in address,
!! and get out g-vector index in gvec%components(1:3,index) so that
!! index = gvec%index_vec(address) points to gvec%components(:,index).
!!
!! What does this imply about the organization of gvec%components(:,:) ?
!! The address of gvec%components(:,i) is given by
!! address=((gx_i+gxmax)*(2*gymax+1)+gy_i+gymax)*(2*gzmax+1)+gz_i+gzmax+1
!! so that this means z-fastest, then y, then x. Also the g-vectors
!! live on a grid that is 2*gmax+1 in each axial direction.
!!
!! gsm: saving on memory: FFTgrid is FFT grid size, gvec%nFFTgridpts=FFTgrid(1)*FFTgrid(2)*FFTgrid(3),
!! address=((g(1)+FFTgrid(1)/2)*FFTgrid(2)+g(2)+FFTgrid(2)/2)*FFTgrid(3)+g(3)+FFTgrid(3)/2+1

!---------------------------------------------------------------------------------------------------
!> Compute index_vec indices relating G-vectors in reduced coordinates to positions in the FFT grid
subroutine gvec_index(gvec)
type(gspace), intent(inout) :: gvec

integer :: ig, iadd

gvec%nFFTgridpts = product(gvec%FFTgrid(1:3))
allocate(gvec%index_vec (gvec%nFFTgridpts))

gvec%index_vec(:)=0
do ig = 1, gvec%ng
! if a mean-field code does not use the appropriate convention, this could happen.
if(any(2 * gvec%components(1:3, ig) >= gvec%FFTgrid(1:3) .or. 2 * gvec%components(1:3, ig) < -gvec%FFTgrid(1:3))) &
call die("gvectors must be in the interval [-FFTgrid/2, FFTgrid/2)")

iadd = ((gvec%components(1,ig)+gvec%FFTgrid(1)/2)*gvec%FFTgrid(2)+gvec%components(2,ig)+ &
gvec%FFTgrid(2)/2)*gvec%FFTgrid(3)+gvec%components(3,ig)+gvec%FFTgrid(3)/2+1
gvec%index_vec(iadd) = ig
enddo

return
end subroutine gvec_index

!-----------------------------------------------------------------
!> This routine calculates the kinetic energies |G+q|^2 or |G|^2 for all
!! the G-vectors in gvec%components using the reciprocal metric bdot:
!! ekin(ig) = \sum_{m,n} G(m,ig) B(m,n) G(n,ig)
!! We perform the sum by first performing the Cholesky decomposition of B,
!! B := U^T U. Then, we write V := U G and write ekin = V^T V
!! Using Cholesky decomposition has the same flop count as using dgemms, but
!! it`s easier for the compiler to vectorize.
!!
!! \param gvec gspace structure that contains all the gvectors gvec%components
!! \param bdot reciprocal metric
!! \param ekin array holding the output kinetic energies
!! \param qvec use this to compute |q+G|^2 instead of |G|^2
subroutine kinetic_energies(gvec, bdot, ekin, qvec)
type(gspace), intent(in) :: gvec
real(DP), intent(in) :: bdot(3, 3)
real(DP), intent(out) :: ekin(:) !< (gvec%ng)
real(DP), optional, intent(in) :: qvec(3)

integer :: ig, info
real(DP) :: qkv(3,gvec%ng), vmid(3), U(3,3) ! FHJ: stack allocation is faster!

if (present(qvec)) then
do ig = 1,gvec%ng
qkv(1:3,ig) = qvec(1:3) + gvec%components(1:3,ig)
enddo
else
qkv(1:3,1:gvec%ng) = gvec%components(1:3,1:gvec%ng)
endif

U(1:3, 1:3) = bdot(1:3, 1:3)
! FHJ: Cholesky decomposition of the metric: bdot = U^T U
call dpotrf('U', 3, U, 3, info)
do ig = 1,gvec%ng
vmid(1) = U(1,1)*qkv(1,ig) + U(1,2)*qkv(2,ig) + U(1,3)*qkv(3,ig)
vmid(2) = U(2,2)*qkv(2,ig) + U(2,3)*qkv(3,ig)
vmid(3) = U(3,3)*qkv(3,ig)
ekin(ig) = vmid(1)**2 + vmid(2)**2 + vmid(3)**2
enddo

return
end subroutine kinetic_energies

!-----------------------------------------------------------------
!> Write a warning if any k-point is nonzero in a truncated direction.
subroutine check_trunc_kpts(itruncflag, kp)
integer, intent(in) :: itruncflag
type(kpoints), intent(in) :: kp

if(peinf%inode /= 0) return

select case(itruncflag)
case(0) ! none
case(2) ! spherical
if(any(abs(kp%rk(1:3,:)) > TOL_Zero)) &
write(0,'(a)') 'WARNING: spherical truncation should not be done with k-sampling in any direction.'
! there is one exception: Hartree-Fock with the Spencer-Alavi scheme (Phys. Rev. B 77, 193110 (2008))
case(4) ! cell_wire
if(any(abs(kp%rk(1:2,:)) > TOL_Zero)) &
write(0,'(a)') 'WARNING: cell_wire truncation should not be done with k-sampling in the x- or y-directions.'
case(5) ! cell_box
if(any(abs(kp%rk(1:3,:)) > TOL_Zero)) &
write(0,'(a)') 'WARNING: cell_box truncation should not be done with k-sampling in any direction.'
case(6) ! cell_slab
if(any(abs(kp%rk(3,:)) > TOL_Zero)) &
write(0,'(a)') 'WARNING: cell_slab truncation should not be done with k-sampling in the z-direction.'
case default
write(0,*) 'itruncflag = ', itruncflag
call die("Unknown truncation type.")
end select

return
end subroutine check_trunc_kpts

!-----------------------------------------------------------------
!> Set the number of matrices in the epsmat file depending on the matrix,
!! type, frequencyd dependency, and flavor. Assumes that pol%freq_dep and
!! pol%matrix_type were set.
subroutine eps_setup_sizes(pol, flavor, nspin)
type(polarizability), intent(inout) :: pol
integer, intent(in) :: flavor
integer, intent(in) :: nspin

! FHJ: old bevavior: FF calculations always compute complex dielectric
! matrices, and need two matrices (retarded+advanced).
pol%has_advanced = .false.
if (pol%freq_dep/=0 .and. flavor==2) pol%has_advanced = .true.
! FHJ: New behavior: store just the retarded matrix + v(q). Get advanced
! matrix from symmetry relations
if (pol%use_hdf5) pol%has_advanced = .false.

pol%matrix_flavor = flavor
if (pol%freq_dep/=0) pol%matrix_flavor = 2
! FHJ: Set number of matrices depending on nspin (chimat is spin resolved)
pol%nmatrix = 1
if (pol%has_advanced) pol%nmatrix = 2
if (pol%matrix_type==2) pol%nmatrix = pol%nmatrix*nspin

end subroutine eps_setup_sizes

end module input_utils_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/genwf.f90 > Common/genwf.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/genwf.p.f -o Common/genwf.o -module Common/
# 1 "Common/genwf.p.f"
# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 2 "Common/Common/genwf.f90" 2

module genwf_m

use global_m
use blas_m
use gmap_m
use input_utils_m
use sort_m
use misc_m

implicit none

private

public :: genwf

contains

subroutine genwf(crys,gvec,kg,syms,wfn,xct,ik,ik2,work,intwfn,is_cond)
type (crystal), intent(in) :: crys
type (gspace), intent(in) :: gvec
type (grid), intent(in) :: kg
type (symmetry), intent(in) :: syms
type (wavefunction), intent(out) :: wfn
type (xctinfo), intent(in) :: xct
integer, intent(in) :: ik, ik2
type (work_genwf), intent(inout) :: work
type (int_wavefunction), intent(in) :: intwfn
logical, intent(in) :: is_cond

integer :: iwrite
character :: filename*20, wfnname*10
integer :: irk, iunit
integer :: hh, ii, jj, kk, eof, ig

integer, allocatable :: isorti(:)
real(DP), allocatable :: ekin(:)

if (xct%iwriteint .eq. 0) then
if(peinf%inode.lt.10000) then
if(is_cond) then
write(filename,'(a,i4.4)') 'INT_CWFN_', peinf%inode
iunit=128+(2*peinf%inode)+1
wfnname = "conduction"
else
write(filename,'(a,i4.4)') 'INT_VWFNQ_', peinf%inode
iunit=128+(2*peinf%inode)+2
wfnname = "valence"
endif
else
call die('genwf: cannot use more than 9999 nodes')
endif
endif

!-----------------------------------------------------------------------
! Start looking for the right k-point in unit iunit

if(ik.ne.work%ikold) then
if (xct%iwriteint .eq. 0) then
call open_file(iunit,file=filename,form='unformatted',status='old')

eof=0
read(iunit) irk,work%ng,work%nb,work%ns,work%nspinor
do while((irk.ne.kg%indr(ik2)).and.(eof.eq.0))
read(iunit)
read(iunit,iostat=eof) irk,work%ng,work%nb,work%ns,work%nspinor
enddo
if(eof.ne.0) then
write(0,*) 'BUG: PE ', peinf%inode, ' could not find the ', trim(wfnname), &
'wavefunctions for k-point ', ik2
write(0,*) ' (equivalent to k-point ', kg%indr(ik2), 'in the IBZ) in file ', filename
call die("genwf wfns missing")
endif
else
iwrite=0
do ii=1, peinf%ikt(peinf%inode+1)
if(peinf%ik(peinf%inode+1,ii).eq.ik) then
iwrite=ii
work%ng=intwfn%ng(ii)
if(is_cond) then
work%nb=xct%ncb_fi
else
work%nb=xct%nvb_fi
endif
work%ns=xct%nspin
work%nspinor=intwfn%nspinor
endif
enddo
endif

if(work%ikold.ne.0) then
if(associated(work%cg))then;deallocate(work%cg);nullify(work%cg);endif
if(associated(work%ph))then;deallocate(work%ph);nullify(work%ph);endif
if(associated(work%ind))then;deallocate(work%ind);nullify(work%ind);endif
if(associated(work%isort))then;deallocate(work%isort);nullify(work%isort);endif
endif
allocate(work%cg (work%ng,work%nb,work%ns*work%nspinor))
allocate(work%ind (work%ng))
allocate(work%ph (work%ng))
allocate(work%isort (gvec%ng))
endif

wfn%ng=work%ng
wfn%nband=work%nb
wfn%nspin=work%ns
wfn%nspinor=work%nspinor
if (work%ns.ne.xct%nspin) then
write(0,*) 'spin number mismatch in file ', filename, xct%nspin, work%ns
call die("genwf spin number mismatch")
endif

allocate(wfn%cg (wfn%ng,wfn%nband,wfn%nspin*wfn%nspinor))
allocate(wfn%isort (gvec%ng))
if(ik.ne.work%ikold) then
! Read the wavefunctions for the rk-kpoint
if (xct%iwriteint .eq. 0) then
read(iunit) (work%isort(ii),ii=1,gvec%ng), &
(((work%cg(ii,jj,kk),ii=1,wfn%ng),jj=1,wfn%nband), kk=1,wfn%nspin*wfn%nspinor)
else
work%isort(:)=intwfn%isort(:,iwrite)
work%cg(1:wfn%ng,:,:)=intwfn%cgk(1:wfn%ng,:,:,iwrite)
endif

! Compute inverse index array of Fourier components around rk-kpoint
allocate(isorti (gvec%ng))
isorti(:)=0
do ii=1,wfn%ng
isorti(work%isort(ii))=ii
enddo

! Compute index array of Fourier components around fk-kpoint
allocate(ekin (gvec%ng))
call kinetic_energies(gvec, crys%bdot, ekin, qvec = kg%f(:, ik2))
call sortrx(gvec%ng, ekin, work%isort, gvec = gvec%components)
if(allocated(ekin))then;deallocate(ekin);endif

! Find ind and ph relating wavefunctions in fk to rk-kpoint
work%ind=0
work%ph=(0.0d0,0.0d0)
call gmap(gvec,syms,wfn%ng,kg%itran(ik2), &
kg%kg0(:,ik2),work%isort,isorti,work%ind,work%ph,.true.)
if(allocated(isorti))then;deallocate(isorti);endif

! Compute and renormalize wavefunctions
do kk=1,wfn%nspin
do jj=1,wfn%nband
do hh=1,wfn%nspinor
do ii=1,wfn%ng
if (work%ind(ii) .gt. 0) then
wfn%cg(ii,jj,kk*hh)=work%ph(ii)*work%cg(work%ind(ii),jj,kk*hh)
else
wfn%cg(ii,jj,kk*hh)=(0.0d0,0.0d0)
endif
enddo
enddo
call checknorm('wfn%cg',jj,ik,wfn%ng,kk,wfn%nspinor,wfn%cg(1:wfn%ng,jj,:))
enddo
enddo
work%cg=wfn%cg

if(xct%iwriteint == 0) call close_file(iunit)
endif

wfn%cg=work%cg
wfn%isort=work%isort

work%ikold=ik

return
end subroutine genwf

end module genwf_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/irrbz.f90 > Common/irrbz.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/irrbz.p.f -o Common/irrbz.o -module Common/
# 1 "Common/irrbz.p.f"
# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 2 "Common/Common/irrbz.f90" 2

module irrbz_m

use global_m
use misc_m

implicit none

private

public :: irrbz

contains

subroutine irrbz(syms,nfk,fk,nrq,neq,indrq,rq,nq,qq,itnrq,kg0,nfix)
type (symmetry), intent(in) :: syms
integer, intent(in) :: nfk
real(DP), intent(in) :: fk(:,:) !< (3,nfk)
integer, intent(out) :: nrq
integer, optional, intent(out) :: neq(:) !< nrq
integer, optional, intent(out) :: indrq(:) !< nrq
real(DP), optional, intent(out) :: rq(:,:) !< (3, nrq)
integer, optional, intent(in) :: nq
real(DP), optional, intent(in) :: qq(:,:) !< (3, nq)
integer, optional, intent(out) :: itnrq(:) !< nrq
integer, optional, intent(out) :: kg0(:,:) !< (3, nrq)
!> don`t try to fold back the first nfix points (defaults to 1)
integer, optional, intent(in) :: nfix

integer :: i,j,irq,ik,it,iflag,iq,kg(3),nq_read,line_skip,iqsave,iostat_c,nfix_
integer, allocatable :: indrk(:)
real(DP) :: qk(3)
real(DP), allocatable :: rq_read(:,:)
logical :: use_ntran ! true for Sigma, false for Epsilon
logical :: irrbz_read

!
! i nq,qq q-points for which eps**(-1)(q) is known
! i nfk,fk k-points in full BZ
! o nrq,rq q-points in irr BZ with respect to subgroup
! o neq number of points equivalent to rq
! o indrq,itnrq,kg0 index, transformation, Umklapp required for
! rq = r(q) + kg0
!

nfix_ = 1
if (present(nfix)) nfix_ = nfix

! all or nothing
if(present(rq) .and. present(nq) .and. present(qq) .and. present(itnrq) .and. present(kg0) .neqv. &
present(rq) .or. present(nq) .or. present(qq) .or. present(itnrq) .or. present(kg0)) then
call die("irrbz internal error: bad parameters")
endif
use_ntran = present(qq)
if(use_ntran .and. .not. (present(neq) .and. present(indrq))) then
call die("irrbz internal error: bad parameters 2")
endif

if(size(fk, 1) /= 3) then
write(0,*) 'size(fk, 1) = ', size(fk, 1)
call die("irrbz internal error: fk must have first dimension = 3")
endif
if(size(fk, 2) /= nfk) then
write(0,*) 'nfk = ', nfk, 'size(fk, 2) = ', size(fk, 2)
call die("irrbz internal error: fk must have second dimension = nfk")
endif

irrbz_read = .false.
if (.not. use_ntran) then
call open_file(unit=21,file='irrbz.dat',status='old',iostat=iostat_c)
if (iostat_c==0) irrbz_read=.true.
endif
if (irrbz_read) then
write(6,'(3x,a)') 'Reading the Irreducible Brillouin Zone from irrbz.dat'
read(21,*) nq_read
allocate(rq_read (3,nq_read))
read(21,*) (rq_read(1:3,iq), iq = 1,nq_read)

!Compare and find which rq_read corresponds to the syms%rq
do iq=1,nq_read
if (all(abs(rq_read(1:3,iq)-syms%rq(1:3)) .lt. TOL_Small)) then
iqsave=iq
exit
endif
write(0,'(3x,a)') 'rq not found in irrbz.dat',syms%rq(1:3)
call die("rq not found in irrbz.dat")
enddo
if(allocated(rq_read))then;deallocate(rq_read);endif

!Now just go to the line number from where we can read all the information
line_skip = 3*(iqsave-1)
do i=1,line_skip
read(21,*)
enddo
read(21,*) nrq
if (present(neq)) then
read(21,*) (neq(i), i=1,nrq)
else
read(21,*)
endif
if (present(indrq)) then
read(21,*) (indrq(i), i=1,nrq)
else
read(21,*)
endif
call close_file(21)

else

allocate(indrk (nfk))

! initialize number of points in irr. BZ
!
nrq = 0
!
! loop over k-points in full zone
!
ik_loop: do ik=1,nfk
if (ik > nfix_) then
!
! loop over transformation matrices
!
do it=1,syms%ntranq
qk(:) = matmul(dble(syms%mtrx(:,:,syms%indsub(it))),fk(:,ik))
call k_range(qk,kg,TOL_Small)

if(.not. present(neq)) cycle
!
! compare to other k-points in the irr. BZ with respect to qvec
!
do irq=1,nrq
if (all(abs(fk(1:3,indrk(irq))-qk(1:3)) .lt. TOL_Small)) then
neq(irq) = neq(irq) + 1
cycle ik_loop
endif
enddo
enddo ! loop over ntranq tranformation

endif

nrq = nrq + 1
indrk(nrq) = ik
if(use_ntran) rq(1:3,nrq) = fk(1:3,ik)
if(present(neq)) neq(nrq) = 1

if(use_ntran) then
!
! find qq to which rq is equivalent
!
iflag = 0
iq_loop: do iq=1,nq
do it=1,syms%ntran
qk(:) = matmul(dble(syms%mtrx(:,:,it)),qq(:,iq))
call k_range(qk,kg,TOL_Small)

if (all(abs(rq(1:3,nrq)-qk(1:3)) .lt. TOL_Small)) then
iflag = 1
indrq(nrq) = iq
itnrq(nrq) = it
kg0(1:3,nrq) = kg(1:3)
! there may be more than one matching sym op, but better be only one q-vector!
! exit iq_loop
endif
enddo
enddo iq_loop
!
! end of loop over q

if (iflag .eq. 0) then
write(0,'(a,3f12.6)') 'rq = ', rq(1:3,nrq)
call die('irrbz: q/rq mismatch')
endif

else
if(present(indrq)) indrq(nrq) = ik
! we do not need these, but this is what they would be
! kg0(1:3,nrq) = kg(1:3)
! itnrq(nrq) = it
endif ! use_ntran

enddo ik_loop !end loop over full BZ
endif !whether read or generated

if (peinf%inode .eq. 0 .and. use_ntran) then
! FHJ: We only print neq, everything else depends on which is the first fq
! related to rq.
write(6,'(1x,a,i0)') 'Number of q-points in the irreducible BZ(k) (nrq): ', nrq
if (peinf%verb_medium) then
write(6,'(/6x,a,5x,a)') 'q-point rq (irr. BZ)', '#eq/fBZ'
write(6,'(1x,29("-"),1x,7("-"))')
write(6,'(3(1x,f9.6),1x,i7)') (rq(1:3,j), neq(j), j=1,nrq)
endif
endif

if(allocated(indrk))then;deallocate(indrk);endif

return
end subroutine irrbz

end module irrbz_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/check_inversion.f90 > Common/check_inversion.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/check_inversion.p.f -o Common/check_inversion.o -module Common/
# 1 "Common/check_inversion.p.f"
!===============================================================================
!
! Module:
!
! (1) check_inversion_m Originally By DAS Last Modified 10/14/2010
!
! Check whether our choice of real/complex version is appropriate given the
! presence or absence of inversion symmetry about the origin, and a guess
! about time-reversal symmetry depending on the number of spin-components.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 14 "Common/Common/check_inversion.f90" 2

module check_inversion_m

use global_m
implicit none

private

public :: check_inversion, check_inversion_type

contains

subroutine check_inversion(iflavor, ntran, mtrx, nspin, warn, real_need_inv, tnp)
integer, intent(in) :: iflavor
integer, intent(in) :: ntran
integer, intent(in) :: mtrx(3, 3, 48) !< symmetry operations matrices
integer, intent(in) :: nspin
logical, intent(in) :: warn !< set to false to suppress warnings, for converters
logical, intent(in) :: real_need_inv !< use for generating routines to block real without inversion
!! this is not always true so that it is possible to run real without using symmetries
real(DP), optional, intent(in) :: tnp(3, 48) !< fractional translations.
!! optional only to avoid changing external interface for library.

integer :: invflag, isym, ii, jj, itest, real_or_complex
logical :: origin_inv
character(len=7) :: sflavor

if(iflavor .eq. 0) then

real_or_complex = 2

elseif(iflavor .eq. 1 .or. iflavor .eq. 2) then
real_or_complex = iflavor
else
write(sflavor, '(i7)') iflavor
call die("Illegal value iflavor = " // TRUNC(sflavor) // " passed to check_inversion: must be 0,1,2.", &
only_root_writes=.true.)
endif

invflag = 0
origin_inv = .false.
do isym = 1, ntran
itest = 0
do ii = 1, 3
do jj = 1, 3
if(ii .eq. jj) then
itest = itest + (mtrx(ii, jj, isym) + 1)**2
else
itest = itest + mtrx(ii, jj, isym)**2
endif
enddo
enddo
if(itest .eq. 0) then
invflag = invflag + 1
if(present(tnp)) then
if(sum(abs(tnp(1:3, isym))) < TOL_Small) origin_inv = .true.
else
origin_inv = .true.
endif
endif
enddo
if(invflag > 0 .and. .not. origin_inv .and. peinf%inode==0) then
write(0, '(a)') "WARNING: Inversion symmetry is present only with a fractional translation."
write(0, '(a)') "Apply the translation so inversion is about the origin, to be able to use the real version."
endif
if(invflag .gt. 1 .and. peinf%inode==0) &
write(0, '(a)') "WARNING: More than one inversion symmetry operation is present."

if(invflag > 0 .and. .not. present(tnp) .and. peinf%inode==0) then
write(0, '(a)') "WARNING: check_inversion did not receive fractional translations."
write(0, '(a)') "Cannot confirm that inversion symmetry is about the origin for use of real version."
endif

if(real_or_complex .eq. 2) then
if(origin_inv .and. warn .and. nspin == 1) then
if(peinf%inode .eq. 0) &
write(0, '(a)') "WARNING: Inversion symmetry about the origin is present. The real version would be faster."
endif
else
if(.not. origin_inv) then
if(real_need_inv) then
call die("The real version cannot be used without inversion symmetry about the origin.", only_root_writes = .true.)
endif
if(peinf%inode .eq. 0) then
write(0, '(a)') "WARNING: Inversion symmetry about the origin is absent in symmetries used to reduce k-grid."
write(0, '(a)') "Be sure inversion about the origin is still a spatial symmetry, or you must use complex version instead."
endif
endif
if(nspin > 1) then
call die("Real version may only be used for spin-unpolarized calculations.", only_root_writes = .true.)
endif
endif

return
end subroutine check_inversion

!=========================================================================
!> wrapper routine that uses typedefs types
subroutine check_inversion_type(iflavor, syms, nspin, warn, real_need_inv)
integer, intent(in) :: iflavor
type (symmetry), intent(in) :: syms
integer, intent(in) :: nspin
logical, intent(in) :: warn
logical, intent(in) :: real_need_inv !< use for generating routines to block real without inversion

call check_inversion(iflavor, syms%ntran, syms%mtrx, nspin, warn, real_need_inv, tnp = syms%tnp)

return
end subroutine check_inversion_type

end module check_inversion_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/svninfo.f90 > Common/svninfo.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/svninfo.p.f -o Common/svninfo.o -module Common/
# 1 "Common/svninfo.p.f"
!================================================================================
!
! Modules:
!
! (1) svninfo_m Originally By gsm Last Modified 11/08/2010 (gsm)
!
! Returns information on svn repository name, version, and revision number.
!
! Set the following svn properties on this file:
! % svn propset svn:keywords "Date Revision Author HeadURL" Common/svninfo.f90
!
! Use pre-commit hook to ensure this file is modified before each commit.
! Modify text here before making a commit --> Let there be 1.2.0!!
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 18 "Common/Common/svninfo.f90" 2

module svninfo_m

use global_m
implicit none

private

character(len=64), parameter :: svndate = &
'$Date: 2016-08-31 16:59:13 -0500 (Wed, 31 Aug 2016) $'
character(len=64), parameter :: svnrevision = '$Revision: 7090 $'
character(len=64), parameter :: svnauthor = '$Author: jornada $'
character(len=256), parameter :: svnheadurl = &
'$HeadURL: https://civet.berkeley.edu/svn/BerkeleyGW/branches/1.2.x/Common/svninfo.f90 $'

public :: getsvninfo

contains

!-------------------------------------------------------------------------------

subroutine getsvninfo(asvninfo)
character(len=256), intent(out) :: asvninfo

integer :: j1,j2,l1,i1,i2,i3,i4,f1,f2,f3

j1=scan(svnrevision,'$',.false.)+11
j2=scan(svnrevision,'$',.true.)-2

l1=len(svnheadurl)
i1=index(svnheadurl,'svn')+4
i2=index(svnheadurl(i1:l1),'/')+i1-2

f1=index(svnheadurl(i2+2:l1),'branches')
f2=index(svnheadurl(i2+2:l1),'tags')
f3=index(svnheadurl(i2+2:l1),'trunk')

if (f1 .ne. 0) then
i3=index(svnheadurl(i2+2:l1),'/')+i2+2
i4=index(svnheadurl(i3:l1),'/')+i3-2
write(asvninfo,'("branch",1x,a,1x,"revision",1x,a)') &
svnheadurl(i3:i4),svnrevision(j1:j2)
elseif (f2 .ne. 0) then
i3=index(svnheadurl(i2+2:l1),'-')+i2+2
i4=index(svnheadurl(i3:l1),'/')+i3-2
write(asvninfo,'("tag",1x,a,1x,"revision",1x,a)') &
svnheadurl(i3:i4),svnrevision(j1:j2)
elseif (f3 .ne. 0) then
write(asvninfo,'("trunk",1x,"revision",1x,a)') &
svnrevision(j1:j2)
else
write(asvninfo,'("Unknown")')
endif

i1=1
do while (i1 .ne. 0)
i1=index(asvninfo,'_')
if (i1 .ne. 0) asvninfo(i1:i1)=' '
enddo

i1=1
do while (i1 .ne. 0)
i1=index(asvninfo,'-')
if (i1 .ne. 0) asvninfo(i1:i1)=' '
enddo

return

end subroutine getsvninfo

!-------------------------------------------------------------------------------

end module svninfo_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/write_program_header.f90 > Common/write_program_header.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/write_program_header.p.f -o Common/write_program_header.o -module Common/
# 1 "Common/write_program_header.p.f"
!=========================================================================
!
! Routines:
!
! (1) write_program_header Originally by DAS Last Modified 10/15/2010 (DAS)
!
! Write a header for the beginning of each program.
!
!=========================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/write_program_header.f90" 2

subroutine write_program_header(aname, write_to_7)
use global_m
use svninfo_m
implicit none

character(len=*), intent(in) :: aname
logical, intent(in) :: write_to_7

character :: asvninfo*256, aversion*32, adate*11, atime*14
character(len=256) :: flags_str

aversion = ' code, ' + trim("Complex") + ' version, run on '
call getsvninfo(asvninfo)
call date_time(adate,atime)
if (peinf%inode==0) then
write(6,10) trim(asvninfo)
if (write_to_7) write(7,10) trim(asvninfo)
10 format(/' BerkeleyGW ',a)
write(6,20) trim(aname), trim(aversion), trim(adate), ' at ', trim(atime)
if (write_to_7) write(7,20) trim(aname), trim(aversion), trim(adate), ' at ', trim(atime)
20 format(1x,2a,1x,3a)
write(6,'()')
call write_logo()
write(6,50)
write(6,51)
write(6,50)
50 format('--------------------------------------------------------------------------------')
51 format(1x,'Please cite the following papers when using results from BerkeleyGW:',/,/, &
1x,'F. H. da Jornada, J. Deslippe, D. Vigil-Fowler, J. I. Mustafa, T. Rangel,',/, &
1x,'F. Bruneval, F. Liu, D. Y. Qiu, D. A. Strubbe, G. Samsonidze, J. Lischner,'/, &
1x,'C. Yang, J. B. Neaton, and S. G. Louie, In preparation. (2016)',/,/, &
1x,'Jack Deslippe, Georgy Samsonidze, David A. Strubbe, Manish Jain, Marvin L.',/, &
1x,'Cohen, and Steven G. Louie, "BerkeleyGW: A Massively Parallel Computer Package',/, &
1x,'for the Calculation of the Quasiparticle and Optical Properties of Materials',/, &
1x,'and Nanostructures," Comput. Phys. Commun. 183, 1269 (2012)',/,/, &
1x,'Mark S. Hybertsen and Steven G. Louie, "Electron correlation in semiconductors',/, &
1x,'and insulators: Band gaps and quasiparticle energies," Phys. Rev. B 34, 5390',/, &
1x,'(1986)',/,/, &
1x,'Michael Rohlfing and Steven G. Louie, "Electron-hole excitations and optical',/, &
1x,'spectra from first principles," Phys. Rev. B 62, 4927 (2000)')

write(6,30)
if (write_to_7) write(7,30)
# 64
30 format(1x,'Running serial version (no MPI)')

write(6,'()')
write(6,'(1x,a)') 'Compilation flags:'
write(6,'(1x,2a)') '- Compiler: ', "INTEL"
flags_str = ''
call write_flag("MPI", "MPI")
call write_flag("OMP", "OMP")
write(6,'(1x,2a)') '- Para. flags: ', trim(flags_str)
flags_str = ''
call write_flag("USESCALAPACK", "USESCALAPACK")
call write_flag("UNPACKED", "UNPACKED")
call write_flag("USEFFTW3", "1")
call write_flag("HDF5", "HDF5")
write(6,'(1x,2a)') '- Math flags: ', trim(flags_str)
flags_str = ''
call write_flag("DEBUG", "DEBUG")
call write_flag("VERBOSE", "VERBOSE")
write(6,'(1x,2a)') '- Debug flags: ', trim(flags_str)
!call write_flag("X", "X")
write(6,'()')
endif

return

contains

subroutine write_flag(flag_name, flag_tostring)
character(len=*), intent(in) :: flag_name, flag_tostring

if (flag_name/=flag_tostring) then
if (len(trim(flags_str))>0) then
flags_str = trim(flags_str) + ', ' + flag_name
else
flags_str = flag_name
endif
endif

end subroutine write_flag

subroutine write_berkeleygw()

end subroutine write_berkeleygw

subroutine write_logo()

! FHJ: Logo generated with jp2a utility. See LOGO/donkey2ascii.sh.
! FHJ: Banner was manually generated. It is based on the output of Figlet with font "Varsity"
write(6,'(a)') ' ..o. '
write(6,'(a)') ' .oxxo. '
write(6,'(a)') ' .oxxxxo... '
write(6,'(a)') ' oxxxxxxo. '
write(6,'(a)') ' .oxxxxxxx. '
write(6,'(a)') ' .ooooooxxo.. '
write(6,'(a)') ' .oooooooxo.. '
write(6,'(a)') ' .oooooxxo... '
write(6,'(a)') ' .........oxooo...... '
write(6,'(a)') ' ............................ '
write(6,'(a)') ' ................................. '
write(6,'(a)') ' .................................... '
write(6,'(a)') ' . ..oo. .... .................................oooxxxxxxxo.'
write(6,'(a)') ' .............oxxxx@ox@@@x@x.....................o...........ooooooooooxx. '
write(6,'(a)') ' .o.........oox@x.oo........xxx@@............ooxxxxo..........ooooxxxxxoxo '
write(6,'(a)') ' .x........x@xxo...............o@xxo........oxxx@@@xoooooooooooooooxxxo... '
write(6,'(a)') ' .o......ox@@o..................oox@o.....ooxxx@xoooxxxxxxxoooooooooooo.... '
write(6,'(a)') ' o..ooooo@@xoooo....ooo...........x@o.....ooxxxxo .oxxxxxxxxxxooooooo.... '
write(6,'(a)') ' . .oooo@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@....ooooox. .oxx@@@@@xxoo........ '
write(6,'(a)') ' .ooooxxxxxxxooooooxooooooooooooooxo...oooooxx. ..ox@xxxoo.........'
write(6,'(a)') ' .ooooooxxxx@xoooooooooooooxxoooooooooooxxxxx. .oxxooooooooxxo.'
write(6,'(a)') ' .oooooxxxxx@@@xxxxxxxxxxxxxxxxxxxxxxxxoxxxxo. .oxxxxxxxxo. '
write(6,'(a)') ' ....oooxxxxx@@@xo..oxxx@@@@@@xxxxoxxoooooooxx. .oxxxoo.. '
write(6,'(a)') ' .....ooxxxx@@xo. ........ .ooooooooxxo '
write(6,'(a)') ' ..oooxxxx@@@o .oooooooxoo. '
write(6,'(a)') ' ....oxooxxxxx. .ooo..oooo. '
write(6,'(a)') ' .....o.ooxxxxxo. .oooooooxo. '
write(6,'(a)') ' ......ooooxxxxxxo. .ooooooxoo.. '
write(6,'(a)') '........ooxxxxxxxo.. .o....oxoo... '
write(6,'(a)') '.......ooooxxxxxxxo. ........oooo. '
write(6,'(a)') '.ooooooo..ooxxxxoooo. .........ooo... '
write(6,'(a)') '..oxo...ooooxxxoooo.. .ooo......oooo... '
write(6,'(a)') ' .ooooo....o. .oxxxoo....ooo.... '
write(6,'(a)') ' .oooooo... ...ooooo...ooo.. '
write(6,'(a)') ' ... .oo....... '
write(6,'(a)') ' ....ooo... '
write(6,'(a)') " __ __ "
write(6,'(a)') " ______ [ | [ | ._____ _ _ "
write(6,'(a)') "|_ _ \ | | _ | | / ___ \| | | |"
write(6,'(a)') " | |_) | .---. _. _.| | / | .---. | | .---. _ _ / / \_|\ \ /\ / / "
write(6,'(a)') " | __'./ /__\\[ /`\_| '' < / /__\\ | |/ /__\\| \ | | | _____ \ \/ \/ / "
write(6,'(a)') " _| |__| | \__. | | | |`\ \ | \___. | || \___. \ \/ / \ \.___| | \ /\ / "
write(6,'(a)') "|_______/ \.__./[_] [__| \_] \.__./[___]\.__./ \ / \.____./ \/ \/ "
write(6,'(a)') " / / "
write(6,'(a)') " /_/ "

end subroutine write_logo

end subroutine write_program_header
icc -E -C -P -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/wfn_rho_vxc_io.F90 > Common/wfn_rho_vxc_io.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/wfn_rho_vxc_io.p.f -o Common/wfn_rho_vxc_io.o -module Common/
# 1 "Common/wfn_rho_vxc_io.p.f"
!>=========================================================================
!!
!! Module:
!!
!! (1) wfn_rho_vxc_io_m Originally by DAS Last Modified 10/17/2010 (DAS)
!!
!! Routines to read and write wavefunctions, density, and Vxc, and
!! deallocate associated variables. The "type" routines use typedefs.
!! The code is generated through repeated inclusion of a file with
!! different preprocessor definitions each time. You are not expected to
!! understand this. Consult the resulting .p.f file for clarity.
!!
!! Specification for ASCII matrix element files (vxc.dat, x.dat):
!! Matrix elements are in eV and are always written with real and imaginary parts.
!! They may contain any number of k-points in any order.
!! Each k-point block begins with the line:
!! kx, ky, kz [crystal coordinates], ndiag*nspin, noffdiag*nspin
!! There are then ndiag*nspin lines of the form
!! ispin, idiag, Re , Im
!! There are then noffdiag*nspin lines of the form
!! ispin, ioff1, ioff2, Re , Im
!!
!!=========================================================================

!The following macro puts any point/array in the [-0.5, 0.5) range:
!The following macro puts any point/array in the [0, 1) range:
!Integer division of a/b rounded up*/
!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

! deprecated identifiers

! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

! very ancient version may require NOSIZEOF

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.

! path before 4.0.9 lacks SIZEOF

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?

! It is considered a bug in OPEN64 that sizeof will not work in our code.

! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit

! name of routine to get name of host program is running on

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m

! how to get the cpu time in seconds

! interface required for mclock routine (timing) to be usable

! interface required for iargc routine (command-line arguments) to be usable

! ftell gives you the current location in a file, to fseek back to it

! if no fseek, ftell is useless

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

module wfn_rho_vxc_io_m

use global_m
use check_inversion_m
use sort_m

implicit none

private
!> For library usage, do not make global_m contents available
!! to avoid namespace clashes.

public :: &
bgw_conf_test, &
read_binary_header, &
write_binary_header, &
read_format_header, &
write_format_header, &
read_binary_header_type, &
write_binary_header_type, &
read_format_header_type, &
write_format_header_type, &
read_binary_gvectors, &
write_binary_gvectors, &
read_format_gvectors, &
write_format_gvectors, &
read_binary_real_data, &
write_binary_real_data, &
read_format_real_data, &
write_format_real_data, &
read_binary_complex_data, &
write_binary_complex_data, &
read_format_complex_data, &
write_format_complex_data, &
read_binary_data, &
write_binary_data, &
read_format_data, &
write_format_data, &
read_header, &
write_header, &
read_header_type, &
write_header_type, &
read_gvectors, &
write_gvectors, &
read_real_data, &
write_real_data, &
read_complex_data, &
write_complex_data, &
read_data, &
write_data, &
dealloc_header, &
dealloc_header_type, &
dealloc_crys, &
dealloc_kp, &
check_header, &
write_matrix_elements, &
write_matrix_elements_type, &
read_matrix_elements, &
read_matrix_elements_type, &
require_version, &
write_mf_header, &
read_mf_header, &
init_mf_header_from_types

!> These interfaces can be used to avoid explicit ifdef 1 switches
interface read_binary_data
module procedure read_binary_real_data, read_binary_complex_data
end interface

interface write_binary_data
module procedure write_binary_real_data, write_binary_complex_data
end interface

interface read_format_data
module procedure read_format_real_data, read_format_complex_data
end interface

interface write_format_data
module procedure write_format_real_data, write_format_complex_data
end interface

interface read_data
module procedure read_real_data, read_complex_data
end interface

interface write_data
module procedure write_real_data, write_complex_data
end interface

interface read_matrix_elements
module procedure read_matrix_elements_real, read_matrix_elements_cplx
end interface

interface read_matrix_elements_type
module procedure read_matrix_elements_type_real, read_matrix_elements_type_cplx
end interface

contains

!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!=========================================================================
subroutine read_format_header(iunit, sheader, iflavor, ns, ng, ntran, cell_symmetry, &
nat, nk, nbands, ngkmax, ecutrho, ecutwfc, FFTgrid, kgrid, kshift, celvol, &
alat, avec, adot, recvol, blat, bvec, bdot, mtrx, tnp, atyp, apos, ngk, &
kw, kpt, ifmin, ifmax, energies, occupations, nspinor, warn, dont_warn_kgrid, sdate, stime, version)
integer, intent(in) :: iunit !< unit number
character(len=3), intent(inout) :: sheader !< file header 'WFN'/'RHO'/'VXC'/'GET' -- last one is to read, and return it
integer, intent(inout) :: iflavor !< define type. always must be initialized. modified only if -1 on input
!! -1 = read from file and return it, 0 = as defined by -DCPLX, 1 = real, 2 = complex
integer, intent(out) :: ns, ng, ntran, cell_symmetry, nat, nk, nbands, ngkmax !< numbers of spins, G-vectors, symmetries,
!! cell type (0 = cubic, 1 = hexagonal), numbers of atoms, k-points, bands, max(ngk)
real(DP), intent(out) :: ecutrho, ecutwfc !< charge-density and wave-function cutoffs, in Ry
integer, intent(out) :: FFTgrid(3), kgrid(3) !< FFT grid size, k-grid size
real(DP), intent(out) :: kshift(3) !< k-grid offset
real(DP), intent(out) :: celvol, alat, avec(3, 3), adot(3, 3) !< cell volume, lattice constant,
!! lattice vectors, metric tensor in real space (in a.u., avec in units of alat)
real(DP), intent(out) :: recvol, blat, bvec(3, 3), bdot(3, 3) !< cell volume, lattice constant,
!! lattice vectors, metric tensor in reciprocal space (in a.u., bvec in units of blat)
integer, intent(out) :: mtrx(3, 3, 48) !< symmetry matrix
real(DP), intent(out) :: tnp(3, 48) !< fractional translation
integer, pointer, intent(out) :: atyp(:) !< atomic species
real(DP), pointer, intent(out) :: apos(:,:) !< atomic positions (in units of alat)
integer, pointer, intent(out) :: ngk(:) !< number of G-vectors for each k-pt, ngk(nk)
real(DP), pointer, intent(out) :: kw(:), kpt(:, :) !< k-weight, kw(nk); k-coord, kpt(3, nk) in crystal coords
integer, pointer, intent(out) :: ifmin(:, :), ifmax(:, :) !< lowest and highest occupied band, ifmin/max(nk, ns)
real(DP), pointer, intent(out) :: energies(:, :, :) !< energies(nbands, nk, ns) in Ry
real(DP), pointer, intent(out) :: occupations(:, :, :) !< occupations(nbands, nk, ns) between 0 and 1
integer, optional, intent(out) :: nspinor !< 2 if doing a two-component spinor calculation; 1 if not present
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
logical, optional, intent(in) :: dont_warn_kgrid !< if true, validity of kgrid read will not be checked.
!! use for inteqp to allow interpolation onto non-uniform fine grids
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(out) :: version !< version of the header. -1 if no version was/should be specified

character :: sdate_*32, stime_*32, stitle*32, sflavor*7
integer :: ii, jj, is, ib, ik, itran, iat, ierr, nspin
logical :: wfnflag, readwrite_version

logical :: is_get, warn_, warn_kgrid, die_spinors

if (sheader .eq. 'WFN') then
wfnflag = .true.
elseif (sheader .eq. 'RHO' .or. sheader .eq. 'VXC' .or. sheader .eq. 'KER') then
wfnflag = .false.
elseif (sheader .ne. 'GET') then
call die("Unknown file header '" + sheader + "' passed to " + "read_format_header" &
+ ": must be 'WFN'/'RHO'/'VXC'/'KER'/'GET'")
endif

if (peinf%inode .eq. 0) then

select case(iflavor)
case(-1)
case(0)
sflavor = "Complex"
case(1)
sflavor = "Real"
case(2)
sflavor = "Complex"
case default
write(sflavor, '(i7)') iflavor
call die("Illegal value iflavor = " + TRUNC(sflavor) + " passed to " + "read_format_header" &
+ ": must be -1,0,1,2.")
end select

! FHJ: we try to the version tag if the argument "version" was passed,
! and we only WRITE the version if the argument is present and /= -1.
readwrite_version=.false.
if (present(version)) then
readwrite_version = .true.
endif

ierr = -1
! FHJ: try to read/write a first time, including the version tag
if (readwrite_version) then
read(iunit , *, iostat = ierr) version, stitle, sdate_, stime_
endif

! FHJ: if there was no version tag, or if we don`t care about version...
if (ierr /= 0) then
! FHJ: go back one record if we tried reading before
if (readwrite_version) backspace(iunit, iostat = ierr)
read(iunit , *, iostat = ierr) stitle, sdate_, stime_

if(ierr /= 0) then
call die("Failed " + "read" + " operation in " + "read_format_header" &
+ " on header record in mode " + sheader + ".")
endif
if (present(version)) version = -1
endif

is_get = .false.
if(sheader == 'GET') then
sheader = stitle(1:3)
is_get = .true.
wfnflag = (sheader == 'WFN')
endif

if(iflavor == -1) then
sflavor = TRUNC(stitle(5:))
if(TRUNC(sflavor) .eq. "Real") then
iflavor = 1
else if (TRUNC(sflavor) .eq. "Complex") then
iflavor = 2
else
call die("Read unknown flavor '" + TRUNC(sflavor) + "' in " + &
"read_format_header" + ": must be '" + "Real" + "'/'" + "Complex" + "'")
endif
endif
if(TRUNC(stitle) .ne. TRUNC(sheader + "-" + sflavor)) then
call die("File header mismatch: read '" + TRUNC(stitle) + "' but expected '" &
+ sheader + "-" + TRUNC(sflavor) + "'")
endif

! scalar variables
if(wfnflag) then
read(iunit , *) nspin, ng, ntran, cell_symmetry, nat, ecutrho, nk, nbands, ngkmax, ecutwfc
if(nk < 1) call die("nk out of bounds in wfn")
if(nbands < 1) call die("nbands out of bounds in wfn")
if(ngkmax < 1) call die("ngkmax out of bounds in wfn")
if(ecutwfc < -TOL_Zero) call die("ecutwfc out of bounds in wfn")
else
read(iunit , *) nspin, ng, ntran, cell_symmetry, nat, ecutrho
endif

if(nspin /= 1 .and. nspin /= 2 .and. nspin /= 4) call die("nspin out of bounds")
if(nspin == 4) then
if(.not. present(nspinor)) call die("nspinor not passed but read nspin==4")
nspinor = 2
ns = 1

die_spinors = .true.
if(die_spinors) call die("Cannot use spinor WFN file (nspin = 4).")
else
if(present(nspinor)) nspinor = 1
ns = nspin
endif
if(ng < 1) call die("ng out of bounds")
if(ntran < 1 .or. ntran > 48) call die("ntran out of bounds")
if(cell_symmetry /= 0 .and. cell_symmetry /= 1) call die("cell_symmetry out of bounds")
if(nat < 1) call die("nat out of bounds")
if(ecutrho < -TOL_Zero) call die("ecutrho out of bounds")

! arrays of fixed size
if(wfnflag) then
read(iunit , *) (FFTgrid(ii), ii = 1, 3), (kgrid(ii), ii = 1, 3), (kshift(ii), ii = 1, 3)
warn_kgrid = .true.
if(present(dont_warn_kgrid)) warn_kgrid = .not. dont_warn_kgrid
if(warn_kgrid) then
if (any(kgrid(1:3) < 1)) call die("kgrid out of bounds in wfn")
if (all(abs(kshift(1:3)) < TOL_Zero) .and. product(kgrid(1:3)) < nk) call die("kgrid too small for nk")
! You might think such a condition would hold always but it does not necessarily, since a shifted uniform grid
! generally does not include all the points you can get from unfolding it with symmetries. --DAS
if (product(kgrid(1:3)) > nk * ntran) call die("kgrid too large compared to unfolded nk")
endif
if(any(abs(kshift(1:3)) > 1 + TOL_Zero)) call die("kshift out of bounds in wfn")
else
read(iunit , *) (FFTgrid(ii), ii = 1, 3)
endif
read(iunit , *) celvol, alat, ((avec(jj, ii), jj = 1, 3), ii = 1, 3), ((adot(jj, ii), jj = 1, 3), ii = 1, 3)
read(iunit , *) recvol, blat, ((bvec(jj, ii), jj = 1, 3), ii = 1, 3), ((bdot(jj, ii), jj = 1, 3), ii = 1, 3)
mtrx(:,:,:) = 0
tnp(:,:) = 0d0
read(iunit , *) (((mtrx(ii, jj, itran), ii = 1, 3), jj = 1, 3), itran = 1, ntran)
read(iunit , *) ((tnp(jj, itran), jj = 1, 3), itran = 1, ntran)
call make_identity_symmetry_first(ntran, mtrx, tnp)
if(any(FFTgrid(1:3) < 1)) then
call die("FFTgrid out of bounds")
endif
if(product(FFTgrid(1:3)) * 1.05 < ng * 6 / PI_D) then ! consistency of FFT grid with G-vectors, with a 5% tolerance
write(0,*) 'FFTgrid = ', FFTgrid
write(0,*) 'ng = ', ng
if(product(FFTgrid(1:3)) < ng) then
call die("FFTgrid inconsistent with ng")
else
write(0,*) 'WARNING: FFTgrid is suspiciously small. This is ok only if this system is'
write(0,*) 'extremely anisotropic. Otherwise, use the Visual/gsphere.py utility to double'
write(0,*) 'check that the G-vectors are compatible with this FFT grid.'
endif
endif
if(celvol < -TOL_Zero) call die("celvol out of bounds")
if(recvol < -TOL_Zero) call die("recvol out of bounds")
if(any(abs(mtrx(:,:,1:ntran)) > 1)) call die("symmetry matrix may only contain -1, 0, 1")
endif

if(present(sdate)) sdate = sdate_
if(present(stime)) stime = stime_

! MPI

allocate(atyp (nat))
allocate(apos (3, nat))
if (wfnflag) then
allocate(ngk (nk))
allocate(kw (nk))
allocate(kpt (3, nk))
allocate(ifmin (nk, ns))
allocate(ifmax (nk, ns))
allocate(energies (nbands, nk, ns))
allocate(occupations (nbands, nk, ns))
endif
!

! allocatable arrays
if (peinf%inode .eq. 0) then

read(iunit , *) ((apos(ii, iat), ii = 1, 3), atyp(iat), iat = 1, nat)
if (wfnflag) then
read(iunit , *) (ngk(ik), ik = 1, nk)
read(iunit , *) (kw(ik), ik = 1, nk)
read(iunit , *) ((kpt(ii, ik), ii = 1, 3), ik = 1, nk)
read(iunit , *) ((ifmin(ik, is), ik = 1, nk), is = 1, ns)
read(iunit , *) ((ifmax(ik, is), ik = 1, nk), is = 1, ns)
read(iunit , *) (((energies(ib, ik, is), ib = 1, nbands), ik = 1, nk), is = 1, ns)
read(iunit , *) (((occupations(ib, ik, is), ib = 1, nbands), ik = 1, nk), is = 1, ns)

if(any(ngk(1:nk) < 1)) then
call die("ngk out of bounds in wfn")
endif
if(maxval(ngk(1:nk)) /= ngkmax) then
call die("max(ngk(1:nk)) /= ngkmax in wfn")
endif
if(ngkmax > ng) then
call die("ngkmax > ng in wfn")
endif
if(any(kw(1:nk) < -TOL_Zero .or. kw(1:nk) > 1d0 + TOL_Zero)) then
call die("kw out of bounds in wfn")
endif
if(abs(sum(kw(1:nk)) - 1d0) > TOL_SMALL) then
write(0,*) 'sum = ', sum(kw(1:nk))
write(0,*) kw(1:nk)
call die("kweights do not sum to 1 in wfn")
endif
if(any(ifmin(1:nk, 1:ns) < 0 .or. ifmin(1:nk, 1:ns) > ifmax(1:nk, 1:ns))) then
call die("ifmin out of bounds in wfn")
endif
if(any(ifmax(1:nk, 1:ns) < 0 .or. ifmax(1:nk, 1:ns) > nbands)) then
call die("ifmax out of bounds in wfn")
endif
if(any(ifmin(1:nk, 1:ns) == 0 .and. ifmax(1:nk, 1:ns) /= 0)) then
call die("ifmin can be zero only when ifmax is zero too; out of bounds in wfn")
endif
if(any(occupations(1:nbands, 1:nk, 1:ns) < -0.5 .or. occupations(1:nbands, 1:nk, 1:ns) > 1.5)) then
call die("occupations out of bounds in wfn")
endif
if(any(occupations(1:nbands, 1:nk, 1:ns) < -TOL_Zero .or. occupations(1:nbands, 1:nk, 1:ns) > 1 + TOL_Zero)) then
write(0,'(a)') "WARNING: occupations outside of range [0,1] in wfn"
! this is expected for cold smearing and Methfessel-Paxton smearing
endif

endif

endif

! converters and utilities should not write a warning for complex with inversion
warn_ = .not. is_get
if(present(warn)) warn_ = warn
call check_inversion(iflavor, ntran, mtrx, ns, warn_, .false., tnp = tnp)

return
end subroutine read_format_header

!=========================================================================
!> wrapper routine that uses typedefs types
subroutine read_format_header_type(iunit, sheader, iflavor, kp, gvec, syms, crys, warn, dont_warn_kgrid, sdate, stime, version)
integer, intent(in) :: iunit
character(len=3), intent(inout) :: sheader
integer, intent(inout) :: iflavor
type(kpoints), intent(out) :: kp
type(gspace), intent(out) :: gvec
type(symmetry), intent(out) :: syms
type(crystal), intent(out) :: crys
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
logical, optional, intent(in) :: dont_warn_kgrid !< if true, validity of kgrid will not be checked.
!! use for inteqp to allow interpolation onto non-uniform fine grids
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(out) :: version !< version of the header. -1 if no version was/should be specified

call read_format_header(iunit, sheader, iflavor, kp%nspin, gvec%ng, syms%ntran, syms%cell_symmetry, crys%nat, &
kp%nrk, kp%mnband, kp%ngkmax, gvec%ecutrho, kp%ecutwfc, gvec%FFTgrid, kp%kgrid, kp%shift, crys%celvol, &
crys%alat, crys%avec, crys%adot, crys%recvol, crys%blat, crys%bvec, crys%bdot, syms%mtrx, syms%tnp, &
crys%atyp, crys%apos, kp%ngk, kp%w, kp%rk, kp%ifmin, kp%ifmax, kp%el, kp%occ, nspinor = kp%nspinor, &
warn = warn, dont_warn_kgrid = dont_warn_kgrid, sdate = sdate, stime = stime, version = version)

gvec%nFFTgridpts = product(gvec%FFTgrid(1:3))

return
end subroutine read_format_header_type

!TEMP_SCALAR

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine read_format_gvectors(iunit, ng, ng_bound, gvec, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(out) :: gvec(:, :) !< (3, ng_bound)
integer, optional, intent(out) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(out) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "read_format_gvectors", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
if(dont_read) call die("Formatted routine " + "read_format_gvectors" + " cannot take argument dont_read = .true.")
dont_read_ = dont_read
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "read_format_gvectors" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "read_format_gvectors")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
bcast_ = bcast
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(gvec, 1) /= 3) &
call die("In routine " + "read_format_gvectors" + ", mismatch of dimension 1 for G-vectors array")
if(ubound(gvec, 2) < ng_bound) &
call die("In routine " + "read_format_gvectors" + ", ng_bound is larger than dimension 2 for G-vectors array")
endif

if(peinf%inode .eq. 0) then
read(iunit , *) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "read_format_gvectors", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if(present(nrecord)) then
nrecord = nrecord_internal
endif
if(present(ng_record)) then
allocate(ng_record (nrecord_internal))
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers
gvec(:,:) = 0

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
read(iunit , *) ng_irecord
if(present(ng_record)) ng_record(irecord) = ng_irecord
if(dont_read_) then
read(iunit , *)
else
if(present(gindex)) then
read(iunit , *) ((gvec(ii, gindex(igg)), ii = 1, 3), igg = ig, ig + ng_irecord - 1)
else
read(iunit , *) ((gvec(ii, igg), ii = 1, 3), igg = ig, ig + ng_irecord - 1)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine read_format_gvectors

! defined || defined BINARY

! these undefs prevent lots of cpp warnings
!> write
!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!=========================================================================
subroutine write_format_header(iunit, sheader, iflavor, ns, ng, ntran, cell_symmetry, &
nat, nk, nbands, ngkmax, ecutrho, ecutwfc, FFTgrid, kgrid, kshift, celvol, &
alat, avec, adot, recvol, blat, bvec, bdot, mtrx, tnp, atyp, apos, ngk, &
kw, kpt, ifmin, ifmax, energies, occupations, nspinor, warn, dont_warn_kgrid, sdate, stime, version)
integer, intent(in) :: iunit !< unit number
character(len=3), intent(inout) :: sheader !< file header 'WFN'/'RHO'/'VXC'/'GET' -- last one is to read, and return it
integer, intent(in) :: iflavor !< define type. always must be initialized. modified only if -1 on input
!! -1 = read from file and return it, 0 = as defined by -DCPLX, 1 = real, 2 = complex
integer, intent(in) :: ns, ng, ntran, cell_symmetry, nat, nk, nbands, ngkmax !< numbers of spins, G-vectors, symmetries,
!! cell type (0 = cubic, 1 = hexagonal), numbers of atoms, k-points, bands, max(ngk)
real(DP), intent(in) :: ecutrho, ecutwfc !< charge-density and wave-function cutoffs, in Ry
integer, intent(in) :: FFTgrid(3), kgrid(3) !< FFT grid size, k-grid size
real(DP), intent(in) :: kshift(3) !< k-grid offset
real(DP), intent(in) :: celvol, alat, avec(3, 3), adot(3, 3) !< cell volume, lattice constant,
!! lattice vectors, metric tensor in real space (in a.u., avec in units of alat)
real(DP), intent(in) :: recvol, blat, bvec(3, 3), bdot(3, 3) !< cell volume, lattice constant,
!! lattice vectors, metric tensor in reciprocal space (in a.u., bvec in units of blat)
integer, intent(in) :: mtrx(3, 3, 48) !< symmetry matrix
real(DP), intent(in) :: tnp(3, 48) !< fractional translation
integer, pointer, intent(in) :: atyp(:) !< atomic species
real(DP), pointer, intent(in) :: apos(:,:) !< atomic positions (in units of alat)
integer, pointer, intent(in) :: ngk(:) !< number of G-vectors for each k-pt, ngk(nk)
real(DP), pointer, intent(in) :: kw(:), kpt(:, :) !< k-weight, kw(nk); k-coord, kpt(3, nk) in crystal coords
integer, pointer, intent(in) :: ifmin(:, :), ifmax(:, :) !< lowest and highest occupied band, ifmin/max(nk, ns)
real(DP), pointer, intent(in) :: energies(:, :, :) !< energies(nbands, nk, ns) in Ry
real(DP), pointer, intent(in) :: occupations(:, :, :) !< occupations(nbands, nk, ns) between 0 and 1
integer, optional, intent(in) :: nspinor !< 2 if doing a two-component spinor calculation; 1 if not present
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
logical, optional, intent(in) :: dont_warn_kgrid !< if true, validity of kgrid read will not be checked.
!! use for inteqp to allow interpolation onto non-uniform fine grids
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(in) :: version !< version of the header. -1 if no version was/should be specified

character :: sdate_*32, stime_*32, stitle*32, sflavor*7
integer :: ii, jj, is, ib, ik, itran, iat, ierr, nspin
logical :: wfnflag, readwrite_version

character :: adate*11, atime*14

if (sheader .eq. 'WFN') then
wfnflag = .true.
elseif (sheader .eq. 'RHO' .or. sheader .eq. 'VXC' .or. sheader .eq. 'KER') then
wfnflag = .false.
elseif (sheader .ne. 'GET') then
call die("Unknown file header '" + sheader + "' passed to " + "write_format_header" &
+ ": must be 'WFN'/'RHO'/'VXC'/'KER'/'GET'")
endif

if(sheader .eq. 'GET') call die("Header 'GET' may not be passed to " + "write_format_header" &
+ ": must be 'WFN'/'RHO'/'VXC'")

if (peinf%inode .eq. 0) then

select case(iflavor)
case(-1)
call die("iflavor = -1 cannot be passed to " + "write_format_header")
case(0)
sflavor = "Complex"
case(1)
sflavor = "Real"
case(2)
sflavor = "Complex"
case default
write(sflavor, '(i7)') iflavor
call die("Illegal value iflavor = " + TRUNC(sflavor) + " passed to " + "write_format_header" &
+ ": must be -1,0,1,2.")
end select

call date_time(adate, atime)
sdate_ = adate
stime_ = atime
stitle = sheader + "-" + sflavor

! FHJ: we try to READ the version tag if the argument "version" was passed,
! and we only WRITE the version if the argument is present and /= -1.
readwrite_version=.false.
if (present(version)) then
readwrite_version = version/=-1
endif

ierr = -1
! FHJ: try to read/write a first time, including the version tag
if (readwrite_version) then
write(iunit , *, iostat = ierr) version, stitle, sdate_, stime_
endif

! FHJ: if there was no version tag, or if we don`t care about version...
if (ierr /= 0) then
! FHJ: go back one record if we tried reading before
if (readwrite_version) backspace(iunit, iostat = ierr)
write(iunit , *, iostat = ierr) stitle, sdate_, stime_

if(ierr /= 0) then
call die("Failed " + "write" + " operation in " + "write_format_header" &
+ " on header record in mode " + sheader + ".")
endif
endif

nspin = ns
if(present(nspinor)) then
if(nspinor==2) then
nspin = 4
endif
endif

! scalar variables
if(wfnflag) then
write(iunit , *) nspin, ng, ntran, cell_symmetry, nat, ecutrho, nk, nbands, ngkmax, ecutwfc
else
write(iunit , *) nspin, ng, ntran, cell_symmetry, nat, ecutrho
endif

! arrays of fixed size
if(wfnflag) then
write(iunit , *) (FFTgrid(ii), ii = 1, 3), (kgrid(ii), ii = 1, 3), (kshift(ii), ii = 1, 3)
else
write(iunit , *) (FFTgrid(ii), ii = 1, 3)
endif
write(iunit , *) celvol, alat, ((avec(jj, ii), jj = 1, 3), ii = 1, 3), ((adot(jj, ii), jj = 1, 3), ii = 1, 3)
write(iunit , *) recvol, blat, ((bvec(jj, ii), jj = 1, 3), ii = 1, 3), ((bdot(jj, ii), jj = 1, 3), ii = 1, 3)
write(iunit , *) (((mtrx(ii, jj, itran), ii = 1, 3), jj = 1, 3), itran = 1, ntran)
write(iunit , *) ((tnp(jj, itran), jj = 1, 3), itran = 1, ntran)
endif

if(present(sdate)) sdate = sdate_
if(present(stime)) stime = stime_

! READ

! allocatable arrays
if (peinf%inode .eq. 0) then

write(iunit , *) ((apos(ii, iat), ii = 1, 3), atyp(iat), iat = 1, nat)
if (wfnflag) then
write(iunit , *) (ngk(ik), ik = 1, nk)
write(iunit , *) (kw(ik), ik = 1, nk)
write(iunit , *) ((kpt(ii, ik), ii = 1, 3), ik = 1, nk)
write(iunit , *) ((ifmin(ik, is), ik = 1, nk), is = 1, ns)
write(iunit , *) ((ifmax(ik, is), ik = 1, nk), is = 1, ns)
write(iunit , *) (((energies(ib, ik, is), ib = 1, nbands), ik = 1, nk), is = 1, ns)
write(iunit , *) (((occupations(ib, ik, is), ib = 1, nbands), ik = 1, nk), is = 1, ns)

endif

endif

return
end subroutine write_format_header

!=========================================================================
!> wrapper routine that uses typedefs types
subroutine write_format_header_type(iunit, sheader, iflavor, kp, gvec, syms, crys, warn, dont_warn_kgrid, sdate, stime, version)
integer, intent(in) :: iunit
character(len=3), intent(inout) :: sheader
integer, intent(in) :: iflavor
type(kpoints), intent(in) :: kp
type(gspace), intent(in) :: gvec
type(symmetry), intent(in) :: syms
type(crystal), intent(in) :: crys
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
logical, optional, intent(in) :: dont_warn_kgrid !< if true, validity of kgrid will not be checked.
!! use for inteqp to allow interpolation onto non-uniform fine grids
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(in) :: version !< version of the header. -1 if no version was/should be specified

call write_format_header(iunit, sheader, iflavor, kp%nspin, gvec%ng, syms%ntran, syms%cell_symmetry, crys%nat, &
kp%nrk, kp%mnband, kp%ngkmax, gvec%ecutrho, kp%ecutwfc, gvec%FFTgrid, kp%kgrid, kp%shift, crys%celvol, &
crys%alat, crys%avec, crys%adot, crys%recvol, crys%blat, crys%bvec, crys%bdot, syms%mtrx, syms%tnp, &
crys%atyp, crys%apos, kp%ngk, kp%w, kp%rk, kp%ifmin, kp%ifmax, kp%el, kp%occ, nspinor = kp%nspinor, &
warn = warn, dont_warn_kgrid = dont_warn_kgrid, sdate = sdate, stime = stime, version = version)

return
end subroutine write_format_header_type

!TEMP_SCALAR

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine write_format_gvectors(iunit, ng, ng_bound, gvec, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: gvec(:, :) !< (3, ng_bound)
integer, optional, intent(in) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(in) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "write_format_gvectors", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
call die("Write routine " + "write_format_gvectors" + " cannot take argument dont_read.")
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "write_format_gvectors" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "write_format_gvectors")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
call die("Write routine " + "write_format_gvectors" + " cannot take argument bcast.")
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(gvec, 1) /= 3) &
call die("In routine " + "write_format_gvectors" + ", mismatch of dimension 1 for G-vectors array")
if(ubound(gvec, 2) < ng_bound) &
call die("In routine " + "write_format_gvectors" + ", ng_bound is larger than dimension 2 for G-vectors array")
endif

if(.not. present(nrecord)) then
nrecord_internal = 1
ng_irecord = ng
else
nrecord_internal = nrecord

!> check validity of information if going to write
if(nrecord_internal .ne. 1 .and. .not. present(ng_record)) then
call die("Routine " + "write_format_gvectors" + " requires ng_record array if nrecord > 1.")
endif

if(present(ng_record)) then
if(nrecord_internal .ne. sum(ng_record(1:nrecord))) then
write(tmpstr,'(a, i10, a, i10, a, a)') "sum(ng_record) = ", sum(ng_record), " ! = ", nrecord , &
" = nrecord in arguments to routine ", "write_format_gvectors"
call die(tmpstr)
endif
endif
endif

if(peinf%inode .eq. 0) then
write(iunit , *) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "write_format_gvectors", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
if(present(ng_record)) ng_irecord = ng_record(irecord)
write(iunit , *) ng_irecord
if(dont_read_) then
write(iunit , *)
else
if(present(gindex)) then
write(iunit , *) ((gvec(ii, gindex(igg)), ii = 1, 3), igg = ig, ig + ng_irecord - 1)
else
write(iunit , *) ((gvec(ii, igg), ii = 1, 3), igg = ig, ig + ng_irecord - 1)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine write_format_gvectors

! defined || defined BINARY

! these undefs prevent lots of cpp warnings

!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!=========================================================================
subroutine read_binary_header(iunit, sheader, iflavor, ns, ng, ntran, cell_symmetry, &
nat, nk, nbands, ngkmax, ecutrho, ecutwfc, FFTgrid, kgrid, kshift, celvol, &
alat, avec, adot, recvol, blat, bvec, bdot, mtrx, tnp, atyp, apos, ngk, &
kw, kpt, ifmin, ifmax, energies, occupations, nspinor, warn, dont_warn_kgrid, sdate, stime, version)
integer, intent(in) :: iunit !< unit number
character(len=3), intent(inout) :: sheader !< file header 'WFN'/'RHO'/'VXC'/'GET' -- last one is to read, and return it
integer, intent(inout) :: iflavor !< define type. always must be initialized. modified only if -1 on input
!! -1 = read from file and return it, 0 = as defined by -DCPLX, 1 = real, 2 = complex
integer, intent(out) :: ns, ng, ntran, cell_symmetry, nat, nk, nbands, ngkmax !< numbers of spins, G-vectors, symmetries,
!! cell type (0 = cubic, 1 = hexagonal), numbers of atoms, k-points, bands, max(ngk)
real(DP), intent(out) :: ecutrho, ecutwfc !< charge-density and wave-function cutoffs, in Ry
integer, intent(out) :: FFTgrid(3), kgrid(3) !< FFT grid size, k-grid size
real(DP), intent(out) :: kshift(3) !< k-grid offset
real(DP), intent(out) :: celvol, alat, avec(3, 3), adot(3, 3) !< cell volume, lattice constant,
!! lattice vectors, metric tensor in real space (in a.u., avec in units of alat)
real(DP), intent(out) :: recvol, blat, bvec(3, 3), bdot(3, 3) !< cell volume, lattice constant,
!! lattice vectors, metric tensor in reciprocal space (in a.u., bvec in units of blat)
integer, intent(out) :: mtrx(3, 3, 48) !< symmetry matrix
real(DP), intent(out) :: tnp(3, 48) !< fractional translation
integer, pointer, intent(out) :: atyp(:) !< atomic species
real(DP), pointer, intent(out) :: apos(:,:) !< atomic positions (in units of alat)
integer, pointer, intent(out) :: ngk(:) !< number of G-vectors for each k-pt, ngk(nk)
real(DP), pointer, intent(out) :: kw(:), kpt(:, :) !< k-weight, kw(nk); k-coord, kpt(3, nk) in crystal coords
integer, pointer, intent(out) :: ifmin(:, :), ifmax(:, :) !< lowest and highest occupied band, ifmin/max(nk, ns)
real(DP), pointer, intent(out) :: energies(:, :, :) !< energies(nbands, nk, ns) in Ry
real(DP), pointer, intent(out) :: occupations(:, :, :) !< occupations(nbands, nk, ns) between 0 and 1
integer, optional, intent(out) :: nspinor !< 2 if doing a two-component spinor calculation; 1 if not present
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
logical, optional, intent(in) :: dont_warn_kgrid !< if true, validity of kgrid read will not be checked.
!! use for inteqp to allow interpolation onto non-uniform fine grids
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(out) :: version !< version of the header. -1 if no version was/should be specified

character :: sdate_*32, stime_*32, stitle*32, sflavor*7
integer :: ii, jj, is, ib, ik, itran, iat, ierr, nspin
logical :: wfnflag, readwrite_version

logical :: is_get, warn_, warn_kgrid, die_spinors

if (sheader .eq. 'WFN') then
wfnflag = .true.
elseif (sheader .eq. 'RHO' .or. sheader .eq. 'VXC' .or. sheader .eq. 'KER') then
wfnflag = .false.
elseif (sheader .ne. 'GET') then
call die("Unknown file header '" + sheader + "' passed to " + "read_binary_header" &
+ ": must be 'WFN'/'RHO'/'VXC'/'KER'/'GET'")
endif

if (peinf%inode .eq. 0) then

select case(iflavor)
case(-1)
case(0)
sflavor = "Complex"
case(1)
sflavor = "Real"
case(2)
sflavor = "Complex"
case default
write(sflavor, '(i7)') iflavor
call die("Illegal value iflavor = " + TRUNC(sflavor) + " passed to " + "read_binary_header" &
+ ": must be -1,0,1,2.")
end select

! FHJ: we try to the version tag if the argument "version" was passed,
! and we only WRITE the version if the argument is present and /= -1.
readwrite_version=.false.
if (present(version)) then
readwrite_version = .true.
endif

ierr = -1
! FHJ: try to read/write a first time, including the version tag
if (readwrite_version) then
read(iunit , iostat = ierr) version, stitle, sdate_, stime_
endif

! FHJ: if there was no version tag, or if we don`t care about version...
if (ierr /= 0) then
! FHJ: go back one record if we tried reading before
if (readwrite_version) backspace(iunit, iostat = ierr)
read(iunit , iostat = ierr) stitle, sdate_, stime_

if(ierr /= 0) then
call die("Failed " + "read" + " operation in " + "read_binary_header" &
+ " on header record in mode " + sheader + ".")
endif
if (present(version)) version = -1
endif

is_get = .false.
if(sheader == 'GET') then
sheader = stitle(1:3)
is_get = .true.
wfnflag = (sheader == 'WFN')
endif

if(iflavor == -1) then
sflavor = TRUNC(stitle(5:))
if(TRUNC(sflavor) .eq. "Real") then
iflavor = 1
else if (TRUNC(sflavor) .eq. "Complex") then
iflavor = 2
else
call die("Read unknown flavor '" + TRUNC(sflavor) + "' in " + &
"read_binary_header" + ": must be '" + "Real" + "'/'" + "Complex" + "'")
endif
endif
if(TRUNC(stitle) .ne. TRUNC(sheader + "-" + sflavor)) then
call die("File header mismatch: read '" + TRUNC(stitle) + "' but expected '" &
+ sheader + "-" + TRUNC(sflavor) + "'")
endif

! scalar variables
if(wfnflag) then
read(iunit ) nspin, ng, ntran, cell_symmetry, nat, ecutrho, nk, nbands, ngkmax, ecutwfc
if(nk < 1) call die("nk out of bounds in wfn")
if(nbands < 1) call die("nbands out of bounds in wfn")
if(ngkmax < 1) call die("ngkmax out of bounds in wfn")
if(ecutwfc < -TOL_Zero) call die("ecutwfc out of bounds in wfn")
else
read(iunit ) nspin, ng, ntran, cell_symmetry, nat, ecutrho
endif

if(nspin /= 1 .and. nspin /= 2 .and. nspin /= 4) call die("nspin out of bounds")
if(nspin == 4) then
if(.not. present(nspinor)) call die("nspinor not passed but read nspin==4")
nspinor = 2
ns = 1

die_spinors = .true.
if(die_spinors) call die("Cannot use spinor WFN file (nspin = 4).")
else
if(present(nspinor)) nspinor = 1
ns = nspin
endif
if(ng < 1) call die("ng out of bounds")
if(ntran < 1 .or. ntran > 48) call die("ntran out of bounds")
if(cell_symmetry /= 0 .and. cell_symmetry /= 1) call die("cell_symmetry out of bounds")
if(nat < 1) call die("nat out of bounds")
if(ecutrho < -TOL_Zero) call die("ecutrho out of bounds")

! arrays of fixed size
if(wfnflag) then
read(iunit ) (FFTgrid(ii), ii = 1, 3), (kgrid(ii), ii = 1, 3), (kshift(ii), ii = 1, 3)
warn_kgrid = .true.
if(present(dont_warn_kgrid)) warn_kgrid = .not. dont_warn_kgrid
if(warn_kgrid) then
if (any(kgrid(1:3) < 1)) call die("kgrid out of bounds in wfn")
if (all(abs(kshift(1:3)) < TOL_Zero) .and. product(kgrid(1:3)) < nk) call die("kgrid too small for nk")
! You might think such a condition would hold always but it does not necessarily, since a shifted uniform grid
! generally does not include all the points you can get from unfolding it with symmetries. --DAS
if (product(kgrid(1:3)) > nk * ntran) call die("kgrid too large compared to unfolded nk")
endif
if(any(abs(kshift(1:3)) > 1 + TOL_Zero)) call die("kshift out of bounds in wfn")
else
read(iunit ) (FFTgrid(ii), ii = 1, 3)
endif
read(iunit ) celvol, alat, ((avec(jj, ii), jj = 1, 3), ii = 1, 3), ((adot(jj, ii), jj = 1, 3), ii = 1, 3)
read(iunit ) recvol, blat, ((bvec(jj, ii), jj = 1, 3), ii = 1, 3), ((bdot(jj, ii), jj = 1, 3), ii = 1, 3)
mtrx(:,:,:) = 0
tnp(:,:) = 0d0
read(iunit ) (((mtrx(ii, jj, itran), ii = 1, 3), jj = 1, 3), itran = 1, ntran)
read(iunit ) ((tnp(jj, itran), jj = 1, 3), itran = 1, ntran)
call make_identity_symmetry_first(ntran, mtrx, tnp)
if(any(FFTgrid(1:3) < 1)) then
call die("FFTgrid out of bounds")
endif
if(product(FFTgrid(1:3)) * 1.05 < ng * 6 / PI_D) then ! consistency of FFT grid with G-vectors, with a 5% tolerance
write(0,*) 'FFTgrid = ', FFTgrid
write(0,*) 'ng = ', ng
if(product(FFTgrid(1:3)) < ng) then
call die("FFTgrid inconsistent with ng")
else
write(0,*) 'WARNING: FFTgrid is suspiciously small. This is ok only if this system is'
write(0,*) 'extremely anisotropic. Otherwise, use the Visual/gsphere.py utility to double'
write(0,*) 'check that the G-vectors are compatible with this FFT grid.'
endif
endif
if(celvol < -TOL_Zero) call die("celvol out of bounds")
if(recvol < -TOL_Zero) call die("recvol out of bounds")
if(any(abs(mtrx(:,:,1:ntran)) > 1)) call die("symmetry matrix may only contain -1, 0, 1")
endif

if(present(sdate)) sdate = sdate_
if(present(stime)) stime = stime_

! MPI

allocate(atyp (nat))
allocate(apos (3, nat))
if (wfnflag) then
allocate(ngk (nk))
allocate(kw (nk))
allocate(kpt (3, nk))
allocate(ifmin (nk, ns))
allocate(ifmax (nk, ns))
allocate(energies (nbands, nk, ns))
allocate(occupations (nbands, nk, ns))
endif
!

! allocatable arrays
if (peinf%inode .eq. 0) then

read(iunit ) ((apos(ii, iat), ii = 1, 3), atyp(iat), iat = 1, nat)
if (wfnflag) then
read(iunit ) (ngk(ik), ik = 1, nk)
read(iunit ) (kw(ik), ik = 1, nk)
read(iunit ) ((kpt(ii, ik), ii = 1, 3), ik = 1, nk)
read(iunit ) ((ifmin(ik, is), ik = 1, nk), is = 1, ns)
read(iunit ) ((ifmax(ik, is), ik = 1, nk), is = 1, ns)
read(iunit ) (((energies(ib, ik, is), ib = 1, nbands), ik = 1, nk), is = 1, ns)
read(iunit ) (((occupations(ib, ik, is), ib = 1, nbands), ik = 1, nk), is = 1, ns)

if(any(ngk(1:nk) < 1)) then
call die("ngk out of bounds in wfn")
endif
if(maxval(ngk(1:nk)) /= ngkmax) then
call die("max(ngk(1:nk)) /= ngkmax in wfn")
endif
if(ngkmax > ng) then
call die("ngkmax > ng in wfn")
endif
if(any(kw(1:nk) < -TOL_Zero .or. kw(1:nk) > 1d0 + TOL_Zero)) then
call die("kw out of bounds in wfn")
endif
if(abs(sum(kw(1:nk)) - 1d0) > TOL_SMALL) then
write(0,*) 'sum = ', sum(kw(1:nk))
write(0,*) kw(1:nk)
call die("kweights do not sum to 1 in wfn")
endif
if(any(ifmin(1:nk, 1:ns) < 0 .or. ifmin(1:nk, 1:ns) > ifmax(1:nk, 1:ns))) then
call die("ifmin out of bounds in wfn")
endif
if(any(ifmax(1:nk, 1:ns) < 0 .or. ifmax(1:nk, 1:ns) > nbands)) then
call die("ifmax out of bounds in wfn")
endif
if(any(ifmin(1:nk, 1:ns) == 0 .and. ifmax(1:nk, 1:ns) /= 0)) then
call die("ifmin can be zero only when ifmax is zero too; out of bounds in wfn")
endif
if(any(occupations(1:nbands, 1:nk, 1:ns) < -0.5 .or. occupations(1:nbands, 1:nk, 1:ns) > 1.5)) then
call die("occupations out of bounds in wfn")
endif
if(any(occupations(1:nbands, 1:nk, 1:ns) < -TOL_Zero .or. occupations(1:nbands, 1:nk, 1:ns) > 1 + TOL_Zero)) then
write(0,'(a)') "WARNING: occupations outside of range [0,1] in wfn"
! this is expected for cold smearing and Methfessel-Paxton smearing
endif

endif

endif

! converters and utilities should not write a warning for complex with inversion
warn_ = .not. is_get
if(present(warn)) warn_ = warn
call check_inversion(iflavor, ntran, mtrx, ns, warn_, .false., tnp = tnp)

return
end subroutine read_binary_header

!=========================================================================
!> wrapper routine that uses typedefs types
subroutine read_binary_header_type(iunit, sheader, iflavor, kp, gvec, syms, crys, warn, dont_warn_kgrid, sdate, stime, version)
integer, intent(in) :: iunit
character(len=3), intent(inout) :: sheader
integer, intent(inout) :: iflavor
type(kpoints), intent(out) :: kp
type(gspace), intent(out) :: gvec
type(symmetry), intent(out) :: syms
type(crystal), intent(out) :: crys
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
logical, optional, intent(in) :: dont_warn_kgrid !< if true, validity of kgrid will not be checked.
!! use for inteqp to allow interpolation onto non-uniform fine grids
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(out) :: version !< version of the header. -1 if no version was/should be specified

call read_binary_header(iunit, sheader, iflavor, kp%nspin, gvec%ng, syms%ntran, syms%cell_symmetry, crys%nat, &
kp%nrk, kp%mnband, kp%ngkmax, gvec%ecutrho, kp%ecutwfc, gvec%FFTgrid, kp%kgrid, kp%shift, crys%celvol, &
crys%alat, crys%avec, crys%adot, crys%recvol, crys%blat, crys%bvec, crys%bdot, syms%mtrx, syms%tnp, &
crys%atyp, crys%apos, kp%ngk, kp%w, kp%rk, kp%ifmin, kp%ifmax, kp%el, kp%occ, nspinor = kp%nspinor, &
warn = warn, dont_warn_kgrid = dont_warn_kgrid, sdate = sdate, stime = stime, version = version)

gvec%nFFTgridpts = product(gvec%FFTgrid(1:3))

return
end subroutine read_binary_header_type

!TEMP_SCALAR

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine read_binary_gvectors(iunit, ng, ng_bound, gvec, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(out) :: gvec(:, :) !< (3, ng_bound)
integer, optional, intent(out) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(out) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "read_binary_gvectors", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
dont_read_ = dont_read
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "read_binary_gvectors" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "read_binary_gvectors")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
bcast_ = bcast
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(gvec, 1) /= 3) &
call die("In routine " + "read_binary_gvectors" + ", mismatch of dimension 1 for G-vectors array")
if(ubound(gvec, 2) < ng_bound) &
call die("In routine " + "read_binary_gvectors" + ", ng_bound is larger than dimension 2 for G-vectors array")
endif

if(peinf%inode .eq. 0) then
read(iunit ) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "read_binary_gvectors", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if(present(nrecord)) then
nrecord = nrecord_internal
endif
if(present(ng_record)) then
allocate(ng_record (nrecord_internal))
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers
gvec(:,:) = 0

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
read(iunit ) ng_irecord
if(present(ng_record)) ng_record(irecord) = ng_irecord
if(dont_read_) then
read(iunit )
else
if(present(gindex)) then
read(iunit ) ((gvec(ii, gindex(igg)), ii = 1, 3), igg = ig, ig + ng_irecord - 1)
else
read(iunit ) ((gvec(ii, igg), ii = 1, 3), igg = ig, ig + ng_irecord - 1)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine read_binary_gvectors

! defined FORMATTED || defined

! these undefs prevent lots of cpp warnings
!> write
!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!=========================================================================
subroutine write_binary_header(iunit, sheader, iflavor, ns, ng, ntran, cell_symmetry, &
nat, nk, nbands, ngkmax, ecutrho, ecutwfc, FFTgrid, kgrid, kshift, celvol, &
alat, avec, adot, recvol, blat, bvec, bdot, mtrx, tnp, atyp, apos, ngk, &
kw, kpt, ifmin, ifmax, energies, occupations, nspinor, warn, dont_warn_kgrid, sdate, stime, version)
integer, intent(in) :: iunit !< unit number
character(len=3), intent(inout) :: sheader !< file header 'WFN'/'RHO'/'VXC'/'GET' -- last one is to read, and return it
integer, intent(in) :: iflavor !< define type. always must be initialized. modified only if -1 on input
!! -1 = read from file and return it, 0 = as defined by -DCPLX, 1 = real, 2 = complex
integer, intent(in) :: ns, ng, ntran, cell_symmetry, nat, nk, nbands, ngkmax !< numbers of spins, G-vectors, symmetries,
!! cell type (0 = cubic, 1 = hexagonal), numbers of atoms, k-points, bands, max(ngk)
real(DP), intent(in) :: ecutrho, ecutwfc !< charge-density and wave-function cutoffs, in Ry
integer, intent(in) :: FFTgrid(3), kgrid(3) !< FFT grid size, k-grid size
real(DP), intent(in) :: kshift(3) !< k-grid offset
real(DP), intent(in) :: celvol, alat, avec(3, 3), adot(3, 3) !< cell volume, lattice constant,
!! lattice vectors, metric tensor in real space (in a.u., avec in units of alat)
real(DP), intent(in) :: recvol, blat, bvec(3, 3), bdot(3, 3) !< cell volume, lattice constant,
!! lattice vectors, metric tensor in reciprocal space (in a.u., bvec in units of blat)
integer, intent(in) :: mtrx(3, 3, 48) !< symmetry matrix
real(DP), intent(in) :: tnp(3, 48) !< fractional translation
integer, pointer, intent(in) :: atyp(:) !< atomic species
real(DP), pointer, intent(in) :: apos(:,:) !< atomic positions (in units of alat)
integer, pointer, intent(in) :: ngk(:) !< number of G-vectors for each k-pt, ngk(nk)
real(DP), pointer, intent(in) :: kw(:), kpt(:, :) !< k-weight, kw(nk); k-coord, kpt(3, nk) in crystal coords
integer, pointer, intent(in) :: ifmin(:, :), ifmax(:, :) !< lowest and highest occupied band, ifmin/max(nk, ns)
real(DP), pointer, intent(in) :: energies(:, :, :) !< energies(nbands, nk, ns) in Ry
real(DP), pointer, intent(in) :: occupations(:, :, :) !< occupations(nbands, nk, ns) between 0 and 1
integer, optional, intent(in) :: nspinor !< 2 if doing a two-component spinor calculation; 1 if not present
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
logical, optional, intent(in) :: dont_warn_kgrid !< if true, validity of kgrid read will not be checked.
!! use for inteqp to allow interpolation onto non-uniform fine grids
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(in) :: version !< version of the header. -1 if no version was/should be specified

character :: sdate_*32, stime_*32, stitle*32, sflavor*7
integer :: ii, jj, is, ib, ik, itran, iat, ierr, nspin
logical :: wfnflag, readwrite_version

character :: adate*11, atime*14

if (sheader .eq. 'WFN') then
wfnflag = .true.
elseif (sheader .eq. 'RHO' .or. sheader .eq. 'VXC' .or. sheader .eq. 'KER') then
wfnflag = .false.
elseif (sheader .ne. 'GET') then
call die("Unknown file header '" + sheader + "' passed to " + "write_binary_header" &
+ ": must be 'WFN'/'RHO'/'VXC'/'KER'/'GET'")
endif

if(sheader .eq. 'GET') call die("Header 'GET' may not be passed to " + "write_binary_header" &
+ ": must be 'WFN'/'RHO'/'VXC'")

if (peinf%inode .eq. 0) then

select case(iflavor)
case(-1)
call die("iflavor = -1 cannot be passed to " + "write_binary_header")
case(0)
sflavor = "Complex"
case(1)
sflavor = "Real"
case(2)
sflavor = "Complex"
case default
write(sflavor, '(i7)') iflavor
call die("Illegal value iflavor = " + TRUNC(sflavor) + " passed to " + "write_binary_header" &
+ ": must be -1,0,1,2.")
end select

call date_time(adate, atime)
sdate_ = adate
stime_ = atime
stitle = sheader + "-" + sflavor

! FHJ: we try to READ the version tag if the argument "version" was passed,
! and we only WRITE the version if the argument is present and /= -1.
readwrite_version=.false.
if (present(version)) then
readwrite_version = version/=-1
endif

ierr = -1
! FHJ: try to read/write a first time, including the version tag
if (readwrite_version) then
write(iunit , iostat = ierr) version, stitle, sdate_, stime_
endif

! FHJ: if there was no version tag, or if we don`t care about version...
if (ierr /= 0) then
! FHJ: go back one record if we tried reading before
if (readwrite_version) backspace(iunit, iostat = ierr)
write(iunit , iostat = ierr) stitle, sdate_, stime_

if(ierr /= 0) then
call die("Failed " + "write" + " operation in " + "write_binary_header" &
+ " on header record in mode " + sheader + ".")
endif
endif

nspin = ns
if(present(nspinor)) then
if(nspinor==2) then
nspin = 4
endif
endif

! scalar variables
if(wfnflag) then
write(iunit ) nspin, ng, ntran, cell_symmetry, nat, ecutrho, nk, nbands, ngkmax, ecutwfc
else
write(iunit ) nspin, ng, ntran, cell_symmetry, nat, ecutrho
endif

! arrays of fixed size
if(wfnflag) then
write(iunit ) (FFTgrid(ii), ii = 1, 3), (kgrid(ii), ii = 1, 3), (kshift(ii), ii = 1, 3)
else
write(iunit ) (FFTgrid(ii), ii = 1, 3)
endif
write(iunit ) celvol, alat, ((avec(jj, ii), jj = 1, 3), ii = 1, 3), ((adot(jj, ii), jj = 1, 3), ii = 1, 3)
write(iunit ) recvol, blat, ((bvec(jj, ii), jj = 1, 3), ii = 1, 3), ((bdot(jj, ii), jj = 1, 3), ii = 1, 3)
write(iunit ) (((mtrx(ii, jj, itran), ii = 1, 3), jj = 1, 3), itran = 1, ntran)
write(iunit ) ((tnp(jj, itran), jj = 1, 3), itran = 1, ntran)
endif

if(present(sdate)) sdate = sdate_
if(present(stime)) stime = stime_

! READ

! allocatable arrays
if (peinf%inode .eq. 0) then

write(iunit ) ((apos(ii, iat), ii = 1, 3), atyp(iat), iat = 1, nat)
if (wfnflag) then
write(iunit ) (ngk(ik), ik = 1, nk)
write(iunit ) (kw(ik), ik = 1, nk)
write(iunit ) ((kpt(ii, ik), ii = 1, 3), ik = 1, nk)
write(iunit ) ((ifmin(ik, is), ik = 1, nk), is = 1, ns)
write(iunit ) ((ifmax(ik, is), ik = 1, nk), is = 1, ns)
write(iunit ) (((energies(ib, ik, is), ib = 1, nbands), ik = 1, nk), is = 1, ns)
write(iunit ) (((occupations(ib, ik, is), ib = 1, nbands), ik = 1, nk), is = 1, ns)

endif

endif

return
end subroutine write_binary_header

!=========================================================================
!> wrapper routine that uses typedefs types
subroutine write_binary_header_type(iunit, sheader, iflavor, kp, gvec, syms, crys, warn, dont_warn_kgrid, sdate, stime, version)
integer, intent(in) :: iunit
character(len=3), intent(inout) :: sheader
integer, intent(in) :: iflavor
type(kpoints), intent(in) :: kp
type(gspace), intent(in) :: gvec
type(symmetry), intent(in) :: syms
type(crystal), intent(in) :: crys
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
logical, optional, intent(in) :: dont_warn_kgrid !< if true, validity of kgrid will not be checked.
!! use for inteqp to allow interpolation onto non-uniform fine grids
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(in) :: version !< version of the header. -1 if no version was/should be specified

call write_binary_header(iunit, sheader, iflavor, kp%nspin, gvec%ng, syms%ntran, syms%cell_symmetry, crys%nat, &
kp%nrk, kp%mnband, kp%ngkmax, gvec%ecutrho, kp%ecutwfc, gvec%FFTgrid, kp%kgrid, kp%shift, crys%celvol, &
crys%alat, crys%avec, crys%adot, crys%recvol, crys%blat, crys%bvec, crys%bdot, syms%mtrx, syms%tnp, &
crys%atyp, crys%apos, kp%ngk, kp%w, kp%rk, kp%ifmin, kp%ifmax, kp%el, kp%occ, nspinor = kp%nspinor, &
warn = warn, dont_warn_kgrid = dont_warn_kgrid, sdate = sdate, stime = stime, version = version)

return
end subroutine write_binary_header_type

!TEMP_SCALAR

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine write_binary_gvectors(iunit, ng, ng_bound, gvec, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: gvec(:, :) !< (3, ng_bound)
integer, optional, intent(in) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(in) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "write_binary_gvectors", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
call die("Write routine " + "write_binary_gvectors" + " cannot take argument dont_read.")
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "write_binary_gvectors" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "write_binary_gvectors")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
call die("Write routine " + "write_binary_gvectors" + " cannot take argument bcast.")
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(gvec, 1) /= 3) &
call die("In routine " + "write_binary_gvectors" + ", mismatch of dimension 1 for G-vectors array")
if(ubound(gvec, 2) < ng_bound) &
call die("In routine " + "write_binary_gvectors" + ", ng_bound is larger than dimension 2 for G-vectors array")
endif

if(.not. present(nrecord)) then
nrecord_internal = 1
ng_irecord = ng
else
nrecord_internal = nrecord

!> check validity of information if going to write
if(nrecord_internal .ne. 1 .and. .not. present(ng_record)) then
call die("Routine " + "write_binary_gvectors" + " requires ng_record array if nrecord > 1.")
endif

if(present(ng_record)) then
if(nrecord_internal .ne. sum(ng_record(1:nrecord))) then
write(tmpstr,'(a, i10, a, i10, a, a)') "sum(ng_record) = ", sum(ng_record), " ! = ", nrecord , &
" = nrecord in arguments to routine ", "write_binary_gvectors"
call die(tmpstr)
endif
endif
endif

if(peinf%inode .eq. 0) then
write(iunit ) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "write_binary_gvectors", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
if(present(ng_record)) ng_irecord = ng_record(irecord)
write(iunit ) ng_irecord
if(dont_read_) then
write(iunit )
else
if(present(gindex)) then
write(iunit ) ((gvec(ii, gindex(igg)), ii = 1, 3), igg = ig, ig + ng_irecord - 1)
else
write(iunit ) ((gvec(ii, igg), ii = 1, 3), igg = ig, ig + ng_irecord - 1)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine write_binary_gvectors

! defined FORMATTED || defined

! these undefs prevent lots of cpp warnings

!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

! defined FORMATTED || defined BINARY

!> wrappers allowing selection of formatted/binary by argument
!=========================================================================
subroutine read_header(iunit, is_formatted, sheader, iflavor, ns, ng, ntran, cell_symmetry, &
nat, nk, nbands, ngkmax, ecutrho, ecutwfc, FFTgrid, kgrid, kshift, celvol, alat, avec, adot, &
recvol, blat, bvec, bdot, mtrx, tnp, atyp, apos, ngk, kw, kpt, ifmin, ifmax, energies, occupations, &
nspinor, warn, sdate, stime, version)
integer, intent(in) :: iunit !< unit number
logical, intent(in) :: is_formatted !< true = formatted, false = binary
character(len=3), intent(inout) :: sheader !< file header 'WFN'/'RHO'/'VXC'/'GET'
integer, intent(inout) :: iflavor !< define type. always must be initialized. modified only if -1 on input
integer, intent(out) :: ns, ng, ntran, cell_symmetry, nat, nk, nbands, ngkmax !< numbers of spins, G-vectors, symmetries,
real(DP), intent(out) :: ecutrho, ecutwfc !< charge-density and wave-function cutoffs, in Ry
integer, intent(out) :: FFTgrid(3), kgrid(3) !< FFT grid size, k-grid size
real(DP), intent(out) :: kshift(3) !< k-grid offset
real(DP), intent(out) :: celvol, alat, avec(3, 3), adot(3, 3) !< cell volume, lattice constant,
real(DP), intent(out) :: recvol, blat, bvec(3, 3), bdot(3, 3) !< cell volume, lattice constant,
integer, intent(out) :: mtrx(3, 3, 48) !< symmetry matrix
real(DP), intent(out) :: tnp(3, 48) !< fractional translation
integer, pointer, intent(out) :: atyp(:) !< atomic species
real(DP), pointer, intent(out) :: apos(:,:) !< atomic positions (in units of alat)
integer, pointer, intent(out) :: ngk(:) !< number of G-vectors for each k-pt, ngk(nk)
real(DP), pointer, intent(out) :: kw(:), kpt(:, :) !< k-weight, kw(nk); k-coord, kpt(3, nk) in crystal coords
integer, pointer, intent(out) :: ifmin(:, :), ifmax(:, :) !< lowest and highest occupied band, ifmin/max(nk, ns)
real(DP), pointer, intent(out) :: energies(:, :, :) !< energies(nbands, nk, ns) in Ry
real(DP), pointer, intent(out) :: occupations(:, :, :) !< occupations(nbands, nk, ns) between 0 and 1
integer, intent(out) :: nspinor !< 2 if doing a two-component spinor calculation; 1 if not present
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(out) :: version !< version of the header. -1 if no version was/should be specified

if(is_formatted) then
call read_format_header(iunit, sheader, iflavor, ns, ng, ntran, cell_symmetry, nat, nk, nbands, ngkmax, &
ecutrho, ecutwfc, FFTgrid, kgrid, kshift, celvol, alat, avec, adot, recvol, blat, bvec, bdot, mtrx, tnp, &
atyp, apos, ngk, kw, kpt, ifmin, ifmax, energies, occupations, &
nspinor = nspinor, warn = warn, sdate = sdate, stime = stime, version=version)
else
call read_binary_header(iunit, sheader, iflavor, ns, ng, ntran, cell_symmetry, nat, nk, nbands, ngkmax, &
ecutrho, ecutwfc, FFTgrid, kgrid, kshift, celvol, alat, avec, adot, recvol, blat, bvec, bdot, mtrx, tnp, &
atyp, apos, ngk, kw, kpt, ifmin, ifmax, energies, occupations, &
nspinor = nspinor, warn = warn, sdate = sdate, stime = stime, version=version)
endif

return
end subroutine read_header

!=========================================================================
!> wrapper routine that uses typedefs types
subroutine read_header_type(iunit, is_formatted, sheader, iflavor, kp, gvec, syms, crys, &
warn, dont_warn_kgrid, sdate, stime, version)
integer, intent(in) :: iunit
logical, intent(in) :: is_formatted !< true = formatted, false = binary
character(len=3), intent(inout) :: sheader
integer, intent(inout) :: iflavor
type(kpoints), intent(out) :: kp
type(gspace), intent(out) :: gvec
type(symmetry), intent(out) :: syms
type(crystal), intent(out) :: crys
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
logical, optional, intent(in) :: dont_warn_kgrid !< if true, validity of kgrid will not be checked.
!! use for inteqp to allow interpolation onto non-uniform fine grids
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(out) :: version !< version of the header. -1 if no version was/should be specified

if(is_formatted) then
call read_format_header_type(iunit, sheader, iflavor, kp, gvec, syms, crys, warn = warn, &
dont_warn_kgrid = dont_warn_kgrid, sdate = sdate, stime = stime, version=version)
else
call read_binary_header_type(iunit, sheader, iflavor, kp, gvec, syms, crys, warn = warn, &
dont_warn_kgrid = dont_warn_kgrid, sdate = sdate, stime = stime, version=version)
endif

return
end subroutine read_header_type

! defined TEMP_SCALAR

!=========================================================================
subroutine read_gvectors(iunit, is_formatted, ng, ng_bound, gvec, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
logical, intent(in) :: is_formatted !< true = formatted, false = binary
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(out) :: gvec(:, :) !< (3, ng_bound)
integer, optional, intent(out) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(out) :: ng_record(:) !< number of gvectors in each record
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

! note: surprisingly, the Fortran standard permits passing optional arguments to other routines
! in which those arguments are also optional.
if(is_formatted) then
call read_format_gvectors(iunit, ng, ng_bound, gvec, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
else
call read_binary_gvectors(iunit, ng, ng_bound, gvec, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
endif

return
end subroutine read_gvectors

! defined FORMATTED || defined BINARY

! these undefs prevent lots of cpp warnings
!> write
!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

! defined FORMATTED || defined BINARY

!> wrappers allowing selection of formatted/binary by argument
!=========================================================================
subroutine write_header(iunit, is_formatted, sheader, iflavor, ns, ng, ntran, cell_symmetry, &
nat, nk, nbands, ngkmax, ecutrho, ecutwfc, FFTgrid, kgrid, kshift, celvol, alat, avec, adot, &
recvol, blat, bvec, bdot, mtrx, tnp, atyp, apos, ngk, kw, kpt, ifmin, ifmax, energies, occupations, &
nspinor, warn, sdate, stime, version)
integer, intent(in) :: iunit !< unit number
logical, intent(in) :: is_formatted !< true = formatted, false = binary
character(len=3), intent(inout) :: sheader !< file header 'WFN'/'RHO'/'VXC'/'GET'
integer, intent(in) :: iflavor !< define type. always must be initialized. modified only if -1 on input
integer, intent(in) :: ns, ng, ntran, cell_symmetry, nat, nk, nbands, ngkmax !< numbers of spins, G-vectors, symmetries,
real(DP), intent(in) :: ecutrho, ecutwfc !< charge-density and wave-function cutoffs, in Ry
integer, intent(in) :: FFTgrid(3), kgrid(3) !< FFT grid size, k-grid size
real(DP), intent(in) :: kshift(3) !< k-grid offset
real(DP), intent(in) :: celvol, alat, avec(3, 3), adot(3, 3) !< cell volume, lattice constant,
real(DP), intent(in) :: recvol, blat, bvec(3, 3), bdot(3, 3) !< cell volume, lattice constant,
integer, intent(in) :: mtrx(3, 3, 48) !< symmetry matrix
real(DP), intent(in) :: tnp(3, 48) !< fractional translation
integer, pointer, intent(in) :: atyp(:) !< atomic species
real(DP), pointer, intent(in) :: apos(:,:) !< atomic positions (in units of alat)
integer, pointer, intent(in) :: ngk(:) !< number of G-vectors for each k-pt, ngk(nk)
real(DP), pointer, intent(in) :: kw(:), kpt(:, :) !< k-weight, kw(nk); k-coord, kpt(3, nk) in crystal coords
integer, pointer, intent(in) :: ifmin(:, :), ifmax(:, :) !< lowest and highest occupied band, ifmin/max(nk, ns)
real(DP), pointer, intent(in) :: energies(:, :, :) !< energies(nbands, nk, ns) in Ry
real(DP), pointer, intent(in) :: occupations(:, :, :) !< occupations(nbands, nk, ns) between 0 and 1
integer, intent(in) :: nspinor !< 2 if doing a two-component spinor calculation; 1 if not present
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(in) :: version !< version of the header. -1 if no version was/should be specified

if(is_formatted) then
call write_format_header(iunit, sheader, iflavor, ns, ng, ntran, cell_symmetry, nat, nk, nbands, ngkmax, &
ecutrho, ecutwfc, FFTgrid, kgrid, kshift, celvol, alat, avec, adot, recvol, blat, bvec, bdot, mtrx, tnp, &
atyp, apos, ngk, kw, kpt, ifmin, ifmax, energies, occupations, &
nspinor = nspinor, warn = warn, sdate = sdate, stime = stime, version=version)
else
call write_binary_header(iunit, sheader, iflavor, ns, ng, ntran, cell_symmetry, nat, nk, nbands, ngkmax, &
ecutrho, ecutwfc, FFTgrid, kgrid, kshift, celvol, alat, avec, adot, recvol, blat, bvec, bdot, mtrx, tnp, &
atyp, apos, ngk, kw, kpt, ifmin, ifmax, energies, occupations, &
nspinor = nspinor, warn = warn, sdate = sdate, stime = stime, version=version)
endif

return
end subroutine write_header

!=========================================================================
!> wrapper routine that uses typedefs types
subroutine write_header_type(iunit, is_formatted, sheader, iflavor, kp, gvec, syms, crys, &
warn, dont_warn_kgrid, sdate, stime, version)
integer, intent(in) :: iunit
logical, intent(in) :: is_formatted !< true = formatted, false = binary
character(len=3), intent(inout) :: sheader
integer, intent(in) :: iflavor
type(kpoints), intent(in) :: kp
type(gspace), intent(in) :: gvec
type(symmetry), intent(in) :: syms
type(crystal), intent(in) :: crys
logical, optional, intent(in) :: warn !< if false, suppresses warnings about inversion symmetries etc.
logical, optional, intent(in) :: dont_warn_kgrid !< if true, validity of kgrid will not be checked.
!! use for inteqp to allow interpolation onto non-uniform fine grids
character(len=32), optional, intent(out) :: sdate, stime !< if read, result from file is returned; if write, current is returned
integer, optional, intent(in) :: version !< version of the header. -1 if no version was/should be specified

if(is_formatted) then
call write_format_header_type(iunit, sheader, iflavor, kp, gvec, syms, crys, warn = warn, &
dont_warn_kgrid = dont_warn_kgrid, sdate = sdate, stime = stime, version=version)
else
call write_binary_header_type(iunit, sheader, iflavor, kp, gvec, syms, crys, warn = warn, &
dont_warn_kgrid = dont_warn_kgrid, sdate = sdate, stime = stime, version=version)
endif

return
end subroutine write_header_type

! defined TEMP_SCALAR

!=========================================================================
subroutine write_gvectors(iunit, is_formatted, ng, ng_bound, gvec, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
logical, intent(in) :: is_formatted !< true = formatted, false = binary
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: gvec(:, :) !< (3, ng_bound)
integer, optional, intent(in) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(in) :: ng_record(:) !< number of gvectors in each record
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

! note: surprisingly, the Fortran standard permits passing optional arguments to other routines
! in which those arguments are also optional.
if(is_formatted) then
call write_format_gvectors(iunit, ng, ng_bound, gvec, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
else
call write_binary_gvectors(iunit, ng, ng_bound, gvec, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
endif

return
end subroutine write_gvectors

! defined FORMATTED || defined BINARY

! these undefs prevent lots of cpp warnings

!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!complex(DPC)

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine read_format_complex_data(iunit, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
complex(DPC), intent(out) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(out) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(out) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "read_format_complex_data", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
if(dont_read) call die("Formatted routine " + "read_format_complex_data" + " cannot take argument dont_read = .true.")
dont_read_ = dont_read
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "read_format_complex_data" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "read_format_complex_data")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
bcast_ = bcast
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(data, 1) /= ng_bound) &
call die("In routine " + "read_format_complex_data" + ", mismatch of dimension 1 for data array")
if(ubound(data, 2) /= ns) &
call die("In routine " + "read_format_complex_data" + ", mismatch of dimension 2 for data array")
endif

if(peinf%inode .eq. 0) then
read(iunit , *) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "read_format_complex_data", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if(present(nrecord)) then
nrecord = nrecord_internal
endif
if(present(ng_record)) then
allocate(ng_record (nrecord_internal))
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers
data(:,:) = (0.0d0,0.0d0)

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
read(iunit , *) ng_irecord
if(present(ng_record)) ng_record(irecord) = ng_irecord
if(dont_read_) then
read(iunit , *)
else
if(present(gindex)) then
read(iunit , *) ((data(gindex(igg), ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
else
read(iunit , *) ((data(igg, ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine read_format_complex_data

! defined || defined BINARY

! these undefs prevent lots of cpp warnings
!> write
!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!complex(DPC)

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine write_format_complex_data(iunit, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
complex(DPC), intent(in) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(in) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(in) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "write_format_complex_data", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
call die("Write routine " + "write_format_complex_data" + " cannot take argument dont_read.")
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "write_format_complex_data" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "write_format_complex_data")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
call die("Write routine " + "write_format_complex_data" + " cannot take argument bcast.")
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(data, 1) /= ng_bound) &
call die("In routine " + "write_format_complex_data" + ", mismatch of dimension 1 for data array")
if(ubound(data, 2) /= ns) &
call die("In routine " + "write_format_complex_data" + ", mismatch of dimension 2 for data array")
endif

if(.not. present(nrecord)) then
nrecord_internal = 1
ng_irecord = ng
else
nrecord_internal = nrecord

!> check validity of information if going to write
if(nrecord_internal .ne. 1 .and. .not. present(ng_record)) then
call die("Routine " + "write_format_complex_data" + " requires ng_record array if nrecord > 1.")
endif

if(present(ng_record)) then
if(nrecord_internal .ne. sum(ng_record(1:nrecord))) then
write(tmpstr,'(a, i10, a, i10, a, a)') "sum(ng_record) = ", sum(ng_record), " ! = ", nrecord , &
" = nrecord in arguments to routine ", "write_format_complex_data"
call die(tmpstr)
endif
endif
endif

if(peinf%inode .eq. 0) then
write(iunit , *) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "write_format_complex_data", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
if(present(ng_record)) ng_irecord = ng_record(irecord)
write(iunit , *) ng_irecord
if(dont_read_) then
write(iunit , *)
else
if(present(gindex)) then
write(iunit , *) ((data(gindex(igg), ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
else
write(iunit , *) ((data(igg, ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine write_format_complex_data

! defined || defined BINARY

! these undefs prevent lots of cpp warnings

!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!complex(DPC)

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine read_binary_complex_data(iunit, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
complex(DPC), intent(out) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(out) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(out) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "read_binary_complex_data", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
dont_read_ = dont_read
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "read_binary_complex_data" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "read_binary_complex_data")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
bcast_ = bcast
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(data, 1) /= ng_bound) &
call die("In routine " + "read_binary_complex_data" + ", mismatch of dimension 1 for data array")
if(ubound(data, 2) /= ns) &
call die("In routine " + "read_binary_complex_data" + ", mismatch of dimension 2 for data array")
endif

if(peinf%inode .eq. 0) then
read(iunit ) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "read_binary_complex_data", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if(present(nrecord)) then
nrecord = nrecord_internal
endif
if(present(ng_record)) then
allocate(ng_record (nrecord_internal))
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers
data(:,:) = (0.0d0,0.0d0)

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
read(iunit ) ng_irecord
if(present(ng_record)) ng_record(irecord) = ng_irecord
if(dont_read_) then
read(iunit )
else
if(present(gindex)) then
read(iunit ) ((data(gindex(igg), ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
else
read(iunit ) ((data(igg, ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine read_binary_complex_data

! defined FORMATTED || defined

! these undefs prevent lots of cpp warnings
!> write
!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!complex(DPC)

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine write_binary_complex_data(iunit, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
complex(DPC), intent(in) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(in) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(in) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "write_binary_complex_data", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
call die("Write routine " + "write_binary_complex_data" + " cannot take argument dont_read.")
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "write_binary_complex_data" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "write_binary_complex_data")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
call die("Write routine " + "write_binary_complex_data" + " cannot take argument bcast.")
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(data, 1) /= ng_bound) &
call die("In routine " + "write_binary_complex_data" + ", mismatch of dimension 1 for data array")
if(ubound(data, 2) /= ns) &
call die("In routine " + "write_binary_complex_data" + ", mismatch of dimension 2 for data array")
endif

if(.not. present(nrecord)) then
nrecord_internal = 1
ng_irecord = ng
else
nrecord_internal = nrecord

!> check validity of information if going to write
if(nrecord_internal .ne. 1 .and. .not. present(ng_record)) then
call die("Routine " + "write_binary_complex_data" + " requires ng_record array if nrecord > 1.")
endif

if(present(ng_record)) then
if(nrecord_internal .ne. sum(ng_record(1:nrecord))) then
write(tmpstr,'(a, i10, a, i10, a, a)') "sum(ng_record) = ", sum(ng_record), " ! = ", nrecord , &
" = nrecord in arguments to routine ", "write_binary_complex_data"
call die(tmpstr)
endif
endif
endif

if(peinf%inode .eq. 0) then
write(iunit ) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "write_binary_complex_data", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
if(present(ng_record)) ng_irecord = ng_record(irecord)
write(iunit ) ng_irecord
if(dont_read_) then
write(iunit )
else
if(present(gindex)) then
write(iunit ) ((data(gindex(igg), ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
else
write(iunit ) ((data(igg, ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine write_binary_complex_data

! defined FORMATTED || defined

! these undefs prevent lots of cpp warnings

!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

! defined FORMATTED || defined BINARY

! defined complex(DPC)

!=========================================================================
subroutine read_complex_data(iunit, is_formatted, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
logical, intent(in) :: is_formatted !< true = formatted, false = binary
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
complex(DPC), intent(out) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(out) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(out) :: ng_record(:) !< number of gvectors in each record
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

! note: surprisingly, the Fortran standard permits passing optional arguments to other routines
! in which those arguments are also optional.
if(is_formatted) then
call read_format_complex_data(iunit, ng, ng_bound, ns, data, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
else
call read_binary_complex_data(iunit, ng, ng_bound, ns, data, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
endif

return
end subroutine read_complex_data

! defined FORMATTED || defined BINARY

! these undefs prevent lots of cpp warnings
!> write
!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

! defined FORMATTED || defined BINARY

! defined complex(DPC)

!=========================================================================
subroutine write_complex_data(iunit, is_formatted, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
logical, intent(in) :: is_formatted !< true = formatted, false = binary
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
complex(DPC), intent(in) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(in) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(in) :: ng_record(:) !< number of gvectors in each record
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

! note: surprisingly, the Fortran standard permits passing optional arguments to other routines
! in which those arguments are also optional.
if(is_formatted) then
call write_format_complex_data(iunit, ng, ng_bound, ns, data, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
else
call write_binary_complex_data(iunit, ng, ng_bound, ns, data, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
endif

return
end subroutine write_complex_data

! defined FORMATTED || defined BINARY

! these undefs prevent lots of cpp warnings

!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!real(DP)

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine read_format_real_data(iunit, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
real(DP), intent(out) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(out) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(out) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "read_format_real_data", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
if(dont_read) call die("Formatted routine " + "read_format_real_data" + " cannot take argument dont_read = .true.")
dont_read_ = dont_read
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "read_format_real_data" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "read_format_real_data")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
bcast_ = bcast
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(data, 1) /= ng_bound) &
call die("In routine " + "read_format_real_data" + ", mismatch of dimension 1 for data array")
if(ubound(data, 2) /= ns) &
call die("In routine " + "read_format_real_data" + ", mismatch of dimension 2 for data array")
endif

if(peinf%inode .eq. 0) then
read(iunit , *) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "read_format_real_data", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if(present(nrecord)) then
nrecord = nrecord_internal
endif
if(present(ng_record)) then
allocate(ng_record (nrecord_internal))
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers
data(:,:) = (0.0d0,0.0d0)

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
read(iunit , *) ng_irecord
if(present(ng_record)) ng_record(irecord) = ng_irecord
if(dont_read_) then
read(iunit , *)
else
if(present(gindex)) then
read(iunit , *) ((data(gindex(igg), ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
else
read(iunit , *) ((data(igg, ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine read_format_real_data

! defined || defined BINARY

! these undefs prevent lots of cpp warnings
!> write
!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!real(DP)

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine write_format_real_data(iunit, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
real(DP), intent(in) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(in) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(in) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "write_format_real_data", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
call die("Write routine " + "write_format_real_data" + " cannot take argument dont_read.")
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "write_format_real_data" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "write_format_real_data")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
call die("Write routine " + "write_format_real_data" + " cannot take argument bcast.")
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(data, 1) /= ng_bound) &
call die("In routine " + "write_format_real_data" + ", mismatch of dimension 1 for data array")
if(ubound(data, 2) /= ns) &
call die("In routine " + "write_format_real_data" + ", mismatch of dimension 2 for data array")
endif

if(.not. present(nrecord)) then
nrecord_internal = 1
ng_irecord = ng
else
nrecord_internal = nrecord

!> check validity of information if going to write
if(nrecord_internal .ne. 1 .and. .not. present(ng_record)) then
call die("Routine " + "write_format_real_data" + " requires ng_record array if nrecord > 1.")
endif

if(present(ng_record)) then
if(nrecord_internal .ne. sum(ng_record(1:nrecord))) then
write(tmpstr,'(a, i10, a, i10, a, a)') "sum(ng_record) = ", sum(ng_record), " ! = ", nrecord , &
" = nrecord in arguments to routine ", "write_format_real_data"
call die(tmpstr)
endif
endif
endif

if(peinf%inode .eq. 0) then
write(iunit , *) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "write_format_real_data", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
if(present(ng_record)) ng_irecord = ng_record(irecord)
write(iunit , *) ng_irecord
if(dont_read_) then
write(iunit , *)
else
if(present(gindex)) then
write(iunit , *) ((data(gindex(igg), ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
else
write(iunit , *) ((data(igg, ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine write_format_real_data

! defined || defined BINARY

! these undefs prevent lots of cpp warnings

!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!real(DP)

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine read_binary_real_data(iunit, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
real(DP), intent(out) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(out) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(out) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "read_binary_real_data", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
dont_read_ = dont_read
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "read_binary_real_data" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "read_binary_real_data")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
bcast_ = bcast
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(data, 1) /= ng_bound) &
call die("In routine " + "read_binary_real_data" + ", mismatch of dimension 1 for data array")
if(ubound(data, 2) /= ns) &
call die("In routine " + "read_binary_real_data" + ", mismatch of dimension 2 for data array")
endif

if(peinf%inode .eq. 0) then
read(iunit ) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "read_binary_real_data", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if(present(nrecord)) then
nrecord = nrecord_internal
endif
if(present(ng_record)) then
allocate(ng_record (nrecord_internal))
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers
data(:,:) = (0.0d0,0.0d0)

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
read(iunit ) ng_irecord
if(present(ng_record)) ng_record(irecord) = ng_irecord
if(dont_read_) then
read(iunit )
else
if(present(gindex)) then
read(iunit ) ((data(gindex(igg), ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
else
read(iunit ) ((data(igg, ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine read_binary_real_data

! defined FORMATTED || defined

! these undefs prevent lots of cpp warnings
!> write
!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

!real(DP)

!=========================================================================
!> This routine is turned into 12 variants by preprocessing.
!! If nrecord and ng_record are not provided for read, the routine simply does not tell you what it found.
!! For write, nrecord is given the default 1 if not provided. ng_record defaults to ng if nrecord = 1, but
!! if nrecord > 1, ng_record must be provided to specify how to divide up the g-vectors.
subroutine write_binary_real_data(iunit, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
real(DP), intent(in) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(in) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(in) :: ng_record(:) !< number of gvectors in each record
!! must be provided for write if nrecord > 1
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

integer :: ig, igg, irecord, ii, nrecord_internal, ng_irecord
character*100 :: tmpstr
logical :: bcast_, dont_read_

if(ng_bound < ng) then
write(tmpstr,'(3a,i10,a,i10,a)') "In routine ", "write_binary_real_data", ", ng_bound = ", ng_bound, " < ", ng, " = ng"
call die(tmpstr)
endif

dont_read_ = .false.
if(present(dont_read)) then
call die("Write routine " + "write_binary_real_data" + " cannot take argument dont_read.")
endif

if(peinf%inode .eq. 0) then
if(present(gindex) .and. .not. dont_read_) then
if(ubound(gindex, 1) < ng) &
call die("In routine " + "write_binary_real_data" + ", gindex array is too small")
if(any(gindex(1:ng) > ng_bound) .or. any(gindex(1:ng) <= 0)) then
call die("gindex out of bounds in " + "write_binary_real_data")
endif
endif
endif

bcast_ = .not. dont_read_
! if not read, no point in broadcasting
if(present(bcast)) then
call die("Write routine " + "write_binary_real_data" + " cannot take argument bcast.")
endif

! if not reading, the size of the array passed is irrelevant
if(.not. dont_read_) then
if(ubound(data, 1) /= ng_bound) &
call die("In routine " + "write_binary_real_data" + ", mismatch of dimension 1 for data array")
if(ubound(data, 2) /= ns) &
call die("In routine " + "write_binary_real_data" + ", mismatch of dimension 2 for data array")
endif

if(.not. present(nrecord)) then
nrecord_internal = 1
ng_irecord = ng
else
nrecord_internal = nrecord

!> check validity of information if going to write
if(nrecord_internal .ne. 1 .and. .not. present(ng_record)) then
call die("Routine " + "write_binary_real_data" + " requires ng_record array if nrecord > 1.")
endif

if(present(ng_record)) then
if(nrecord_internal .ne. sum(ng_record(1:nrecord))) then
write(tmpstr,'(a, i10, a, i10, a, a)') "sum(ng_record) = ", sum(ng_record), " ! = ", nrecord , &
" = nrecord in arguments to routine ", "write_binary_real_data"
call die(tmpstr)
endif
endif
endif

if(peinf%inode .eq. 0) then
write(iunit ) nrecord_internal
if(nrecord_internal < 0) then
write(tmpstr,'(3a, i10)') "In routine ", "write_binary_real_data", " illegal nrecord ", nrecord_internal
call die(tmpstr)
endif
endif

if (peinf%inode.eq.0) call timacc(81,1)

! FHJ: zero buffers

if(peinf%inode .eq. 0) then
ig = 1
!This is a PGI pragma to force the optimization level of this routine to -O1.
!With -O2 or higher (including -fast) the line after the pragma causes a segmentation fault.
!pgi$r opt=1
do irecord = 1, nrecord_internal
if(present(ng_record)) ng_irecord = ng_record(irecord)
write(iunit ) ng_irecord
if(dont_read_) then
write(iunit )
else
if(present(gindex)) then
write(iunit ) ((data(gindex(igg), ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
else
write(iunit ) ((data(igg, ii), igg = ig, ig + ng_irecord - 1), ii = 1, ns)
endif
endif
ig = ig + ng_irecord
enddo
endif

if (peinf%inode.eq.0) call timacc(81,2)
if (peinf%inode.eq.0) call timacc(82,1)

if (peinf%inode.eq.0) call timacc(82,2)

return
end subroutine write_binary_real_data

! defined FORMATTED || defined

! these undefs prevent lots of cpp warnings

!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

! defined FORMATTED || defined BINARY

! defined real(DP)

!=========================================================================
subroutine read_real_data(iunit, is_formatted, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
logical, intent(in) :: is_formatted !< true = formatted, false = binary
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
real(DP), intent(out) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(out) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(out) :: ng_record(:) !< number of gvectors in each record
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

! note: surprisingly, the Fortran standard permits passing optional arguments to other routines
! in which those arguments are also optional.
if(is_formatted) then
call read_format_real_data(iunit, ng, ng_bound, ns, data, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
else
call read_binary_real_data(iunit, ng, ng_bound, ns, data, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
endif

return
end subroutine read_real_data

! defined FORMATTED || defined BINARY

! these undefs prevent lots of cpp warnings
!> write
!=========================================================================
!
! Included from file wfn_rho_vxc_io.f90.
! You are not expected to understand this. --DAS
!
!=========================================================================

! defined FORMATTED || defined BINARY

! defined real(DP)

!=========================================================================
subroutine write_real_data(iunit, is_formatted, ng, ng_bound, ns, data, nrecord, ng_record, bcast, gindex, dont_read)
integer, intent(in) :: iunit
logical, intent(in) :: is_formatted !< true = formatted, false = binary
integer, intent(in) :: ng !< used size of array
integer, intent(in) :: ng_bound !< actual size of array, >= ng
integer, intent(in) :: ns
real(DP), intent(in) :: data(:, :) !< (ng_bound, ns)
integer, optional, intent(in) :: nrecord !< data/gvectors will be distributed among this many records
integer, optional, pointer, intent(in) :: ng_record(:) !< number of gvectors in each record
logical, optional, intent(in) :: bcast !< whether to do MPI_Bcast of what is read
integer, optional, intent(in) :: gindex(:) !< map of order in file to order in gvec
logical, optional, intent(in) :: dont_read !< if true, records will just be skipped; only for unformatted

! note: surprisingly, the Fortran standard permits passing optional arguments to other routines
! in which those arguments are also optional.
if(is_formatted) then
call write_format_real_data(iunit, ng, ng_bound, ns, data, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
else
call write_binary_real_data(iunit, ng, ng_bound, ns, data, nrecord = nrecord, &
ng_record = ng_record, bcast = bcast, gindex = gindex, dont_read = dont_read)
endif

return
end subroutine write_real_data

! defined FORMATTED || defined BINARY

! these undefs prevent lots of cpp warnings

!=========================================================================
!> this routine is purely for use in configure scripts to test module accessibility
subroutine bgw_conf_test()

write(6,*) 'Yes, it works.'

end subroutine bgw_conf_test

!=========================================================================
!> this routine is used to write the ASCII files vxc.dat and x.dat, without typedefs types
subroutine write_matrix_elements(iunit, kk, nspin, ndiag, noffdiag, spin_index, diag, offdiag1, offdiag2, mtxel)
integer, intent(in) :: iunit !< file unit to write to
real(DP), intent(in) :: kk(3) !< kpoint to write, in crystal coords
integer, intent(in) :: nspin !< number of spins to write
integer, intent(in) :: ndiag !< number of diagonal elements to write
integer, intent(in) :: noffdiag !< number of offdiagonal elements to write
integer, intent(in) :: spin_index(:) !< (nspin) mapping of 1:nspin to actual spins. 3 choices:
!! spin-unpolarized: spin_index(1) = 1
!! spin-polarized: spin_index(1) = 1, spin_index(2) = 2
!! spin-polarized, spin 2 only: spin_index(1) = 1, spin_index(2) = 2
integer, intent(in) :: diag(:) !< (ndiag) mapping of 1:ndiag onto band indices for diagonals
integer, intent(in) :: offdiag1(:) !< (noffdiag) mapping of 1:noffdiag onto band indices for offdiagonal 1
integer, intent(in) :: offdiag2(:) !< (noffdiag) mapping of 1:noffdiag onto band indices for offdiagonal 2
complex(DPC), intent(in) :: mtxel(:,:) !< (ndiag+noffdiag,nspin)

integer :: ispin, idiag, ioff

if(any(spin_index(1:nspin) < 1 .or. spin_index(1:nspin) > 2)) &
call die("write_matrix_elements: spin_index out of bounds")
if(nspin < 1 .or. nspin > 2) call die("write_matrix_elements: nspin out of bounds")
if(ndiag < 0) call die("write_matrix_elements: ndiag < 0")
if(noffdiag < 0) call die("write_matrix_elements: noffdiag < 0")

!> write header
write(iunit,'(3f15.10,2i12)') kk(1:3), ndiag*nspin, noffdiag*nspin
!> write diagonal matrix elements
do idiag=1,ndiag
do ispin=1,nspin
write(iunit,'(i3,i10,2g22.10)') spin_index(ispin), diag(idiag), dble(mtxel(idiag,ispin)), aimag(mtxel(idiag,ispin))
enddo
enddo
!> write off-diagonal matrix elements
do ioff=1,noffdiag
do ispin=1,nspin
write(iunit,'(i3,2i10,2g22.10)') spin_index(ispin), offdiag1(ioff), offdiag2(ioff), &
dble(mtxel(ioff+ndiag,ispin)), aimag(mtxel(ioff+ndiag,ispin))
enddo
enddo

return
end subroutine write_matrix_elements

!=========================================================================
!> this routine is used to write the ASCII files vxc.dat and x.dat, with typedefs types
subroutine write_matrix_elements_type(iunit, kk, sig, mtxel)
integer, intent(in) :: iunit !< file unit to write to
real(DP), intent(in) :: kk(3) !< kpoint to write, in crystal coords
type(siginfo), intent(in) :: sig !< structure containing other needed data
complex(DPC), intent(in) :: mtxel(:,:) !< (sig%ndiag+sig%noffdiag,sig%nspin)

call write_matrix_elements(iunit, kk, sig%nspin, sig%ndiag, sig%noffdiag, &
sig%spin_index, sig%diag, sig%off1, sig%off2, mtxel)

return
end subroutine write_matrix_elements_type

!=========================================================================
!> this routine is used to read the ASCII files vxc.dat and x.dat, without typedefs types. do not call directly
subroutine read_matrix_elements_base(iunit, iostat, kk, nspin, ndiag, noffdiag, &
spin_index, diag, offdiag1, offdiag2, mtxel_real, mtxel_cplx)
integer, intent(in) :: iunit !< file unit to read from
integer, intent(out) :: iostat !< status of reading header, to detect end of file
real(DP), intent(out) :: kk(3) !< kpoint read, in crystal coords
integer, intent(in) :: nspin !< number of spins to read
integer, intent(in) :: ndiag !< number of diagonal elements to read
integer, intent(in) :: noffdiag !< number of offdiagonal elements to read
integer, intent(in) :: spin_index(:) !< (nspin) mapping of 1:nspin to actual spins. 3 choices:
!! spin-unpolarized: spin_index(1) = 1
!! spin-polarized: spin_index(1) = 1, spin_index(2) = 2
!! spin-polarized, spin 2 only: spin_index(1) = 1, spin_index(2) = 2
integer, intent(in) :: diag(:) !< (ndiag) mapping of 1:ndiag onto band indices for diagonals
integer, intent(in) :: offdiag1(:) !< (noffdiag) mapping of 1:noffdiag onto band indices for offdiagonal 1
integer, intent(in) :: offdiag2(:) !< (noffdiag) mapping of 1:noffdiag onto band indices for offdiagonal 2
real(DP), optional, intent(out) :: mtxel_real(:,:) !< (ndiag+noffdiag,nspin) this or mtxel_cplx must be given
complex(DPC), optional, intent(out) :: mtxel_cplx(:,:) !< (ndiag+noffdiag,nspin) this or mtxel_real must be given

integer :: ispin, idiag, ioff, ime, ndiag_read, noffdiag_read, ispin_read, diag_read, off1_read, off2_read
real(DP) :: mtxel_re, mtxel_im
logical, allocatable :: found(:,:)

if(any(spin_index(1:nspin) < 1 .or. spin_index(1:nspin) > 2)) &
call die("read_matrix_elements: spin_index out of bounds")
if(nspin < 1 .or. nspin > 2) call die("read_matrix_elements: nspin out of bounds")
if(ndiag < 0) call die("read_matrix_elements: ndiag < 0")
if(noffdiag < 0) call die("read_matrix_elements: noffdiag < 0")
if((.not. present(mtxel_real) .and. .not. present(mtxel_cplx)) .or. (present(mtxel_real) .and. present(mtxel_cplx))) &
call die("read_matrix elements must be called with exactly one of mtxel_real and mtxel_cplx")

!> read header
read(iunit,*,iostat = iostat) kk(1:3), ndiag_read, noffdiag_read
if(iostat /= 0) then !< we are at the end of the file

return
endif

if(ndiag_read < ndiag * nspin) call die("read_matrix_elements: not enough diagonals present")
if(noffdiag_read < noffdiag * nspin) call die("read_matrix_elements: not enough offdiagonals present")

allocate(found (ndiag+noffdiag,nspin))
found(:,:) = .false.

!> read diagonal matrix elements
do ime = 1, ndiag_read
read(iunit,*) ispin_read, diag_read, mtxel_re, mtxel_im
if(present(mtxel_real) .and. abs(mtxel_im) > TOL_Zero) call die("cannot have complex matrix elements in real version")
do ispin = 1, nspin
do idiag = 1, ndiag
if (spin_index(ispin) == ispin_read .and. diag(idiag) == diag_read) then
if(present(mtxel_real)) then
mtxel_real(idiag, ispin) = mtxel_re
else
mtxel_cplx(idiag, ispin) = cmplx(mtxel_re,mtxel_im,kind=DPC)
endif
found(idiag, ispin) = .true.
endif
enddo
enddo
enddo

if(any(.not. found(1:ndiag, :))) then
if(peinf%inode == 0) then
write(0,*) 'missing diagonal matrix elements (band, spin): '
do ispin = 1, nspin
do idiag = 1, ndiag
write(0,*) '(', diag(idiag), ',', spin_index(ispin), ')'
enddo
enddo
endif
call die("read_matrix_elements: not all needed data present")
endif

!> read off-diagonal matrix elements
do ime = 1, noffdiag_read
read(iunit,*) ispin_read, off1_read, off2_read, mtxel_re, mtxel_im
if(present(mtxel_real) .and. abs(mtxel_im) > TOL_Zero) call die("cannot have complex matrix elements in real version")
do ispin = 1, nspin
do ioff = 1, noffdiag
if (spin_index(ispin) == ispin_read .and. offdiag1(ioff) == off1_read .and. offdiag2(ioff) == off2_read) then
if(present(mtxel_real)) then
mtxel_real(ndiag + ioff, ispin) = mtxel_re
else
mtxel_cplx(ndiag + ioff, ispin) = cmplx(mtxel_re,mtxel_im,kind=DPC)
endif
found(ndiag + ioff, ispin) = .true.
endif
enddo
enddo
enddo

if(any(.not. found(ndiag + 1:ndiag + noffdiag, :))) then
if(peinf%inode == 0) then
write(0,*) 'missing off-diagonal matrix elements (band, band, spin): '
do ispin = 1, nspin
do ioff = 1, noffdiag
write(0,*) '(', offdiag1(ioff), ',', offdiag2(ioff), ',', spin_index(ispin), ')'
enddo
enddo
endif
call die("read_matrix_elements: not all needed data present")
endif

if(allocated(found))then;deallocate(found);endif

return
end subroutine read_matrix_elements_base

!=========================================================================
!> this routine is used to read the ASCII files vxc.dat and x.dat, without typedefs types, with real output
subroutine read_matrix_elements_real(iunit, iostat, kk, nspin, ndiag, noffdiag, spin_index, diag, offdiag1, offdiag2, mtxel)
integer, intent(in) :: iunit !< file unit to read from
integer, intent(out) :: iostat !< status of reading header, to detect end of file
real(DP), intent(out) :: kk(3) !< kpoint read, in crystal coords
integer, intent(in) :: nspin !< number of spins to read
integer, intent(in) :: ndiag !< number of diagonal elements to read
integer, intent(in) :: noffdiag !< number of offdiagonal elements to read
integer, intent(in) :: spin_index(:) !< (nspin) mapping of 1:nspin to actual spins. 3 choices:
!! spin-unpolarized: spin_index(1) = 1
!! spin-polarized: spin_index(1) = 1, spin_index(2) = 2
!! spin-polarized, spin 2 only: spin_index(1) = 1, spin_index(2) = 2
integer, intent(in) :: diag(:) !< (ndiag) mapping of 1:ndiag onto band indices for diagonals
integer, intent(in) :: offdiag1(:) !< (noffdiag) mapping of 1:noffdiag onto band indices for offdiagonal 1
integer, intent(in) :: offdiag2(:) !< (noffdiag) mapping of 1:noffdiag onto band indices for offdiagonal 2
real(DP), intent(out) :: mtxel(:,:) !< (ndiag+noffdiag,nspin)

call read_matrix_elements_base(iunit, iostat, kk, nspin, ndiag, noffdiag, &
spin_index, diag, offdiag1, offdiag2, mtxel_real = mtxel)

return
end subroutine read_matrix_elements_real

!=========================================================================
!> this routine is used to read the ASCII files vxc.dat and x.dat, without typedefs types, with cplx output
subroutine read_matrix_elements_cplx(iunit, iostat, kk, nspin, ndiag, noffdiag, spin_index, diag, offdiag1, offdiag2, mtxel)
integer, intent(in) :: iunit !< file unit to read from
integer, intent(out) :: iostat !< status of reading header, to detect end of file
real(DP), intent(out) :: kk(3) !< kpoint read, in crystal coords
integer, intent(in) :: nspin !< number of spins to read
integer, intent(in) :: ndiag !< number of diagonal elements to read
integer, intent(in) :: noffdiag !< number of offdiagonal elements to read
integer, intent(in) :: spin_index(:) !< (nspin) mapping of 1:nspin to actual spins. 3 choices:
!! spin-unpolarized: spin_index(1) = 1
!! spin-polarized: spin_index(1) = 1, spin_index(2) = 2
!! spin-polarized, spin 2 only: spin_index(1) = 1, spin_index(2) = 2
integer, intent(in) :: diag(:) !< (ndiag) mapping of 1:ndiag onto band indices for diagonals
integer, intent(in) :: offdiag1(:) !< (noffdiag) mapping of 1:noffdiag onto band indices for offdiagonal 1
integer, intent(in) :: offdiag2(:) !< (noffdiag) mapping of 1:noffdiag onto band indices for offdiagonal 2
complex(DPC), intent(out) :: mtxel(:,:) !< (ndiag+noffdiag,nspin)

call read_matrix_elements_base(iunit, iostat, kk, nspin, ndiag, noffdiag, &
spin_index, diag, offdiag1, offdiag2, mtxel_cplx = mtxel)

return
end subroutine read_matrix_elements_cplx

!=========================================================================
!> this routine is used to read the ASCII files vxc.dat and x.dat, with typedefs types, with real output
subroutine read_matrix_elements_type_real(iunit, iostat, kk, sig, mtxel)
integer, intent(in) :: iunit !< file unit to read from
integer, intent(out) :: iostat !< status of reading header, to detect end of file
real(DP), intent(out) :: kk(3) !< kpoint read, in crystal coords
type(siginfo), intent(in) :: sig !< structure containing other needed data
real(DP), intent(out) :: mtxel(:,:) !< (ndiag+noffdiag,nspin)

call read_matrix_elements(iunit, iostat, kk, sig%nspin, sig%ndiag, sig%noffdiag, &
sig%spin_index, sig%diag, sig%off1, sig%off2, mtxel)

return
end subroutine read_matrix_elements_type_real

!=========================================================================
!> this routine is used to read the ASCII files vxc.dat and x.dat, with typedefs types, with cplx output
subroutine read_matrix_elements_type_cplx(iunit, iostat, kk, sig, mtxel)
integer, intent(in) :: iunit !< file unit to read from
integer, intent(out) :: iostat !< status of reading header, to detect end of file
real(DP), intent(out) :: kk(3) !< kpoint read, in crystal coords
type(siginfo), intent(in) :: sig !< structure containing other needed data
complex(DPC), intent(out) :: mtxel(:,:) !< (ndiag+noffdiag,nspin)

call read_matrix_elements(iunit, iostat, kk, sig%nspin, sig%ndiag, sig%noffdiag, &
sig%spin_index, sig%diag, sig%off1, sig%off2, mtxel)

return
end subroutine read_matrix_elements_type_cplx

!=========================================================================
!> deallocate variables allocated by read_header
subroutine dealloc_header(sheader, atyp, apos, ngk, kw, kpt, ifmin, ifmax, energies, occupations)
character(len=3), intent(in) :: sheader
integer, pointer, intent(inout) :: atyp(:)
real(DP), pointer, intent(inout) :: apos(:,:)
integer, pointer, intent(inout) :: ngk(:)
real(DP), pointer, intent(inout) :: kw(:), kpt(:, :)
integer, pointer, intent(inout) :: ifmin(:, :), ifmax(:, :)
real(DP), pointer, intent(inout) :: energies(:, :, :)
real(DP), pointer, intent(inout) :: occupations(:, :, :)

logical :: wfnflag

if (sheader .eq. 'WFN') then
wfnflag = .true.
elseif (sheader .eq. 'RHO' .or. sheader .eq. 'VXC') then
wfnflag = .false.
else
call die("unknown file header: '" + sheader + "' (should be 'WFN'/'RHO'/'VXC')")
endif

if(associated(atyp))then;deallocate(atyp);nullify(atyp);endif
if(associated(apos))then;deallocate(apos);nullify(apos);endif
if (wfnflag) then
if(associated(ngk))then;deallocate(ngk);nullify(ngk);endif
if(associated(kw))then;deallocate(kw);nullify(kw);endif
if(associated(kpt))then;deallocate(kpt);nullify(kpt);endif
if(associated(ifmin))then;deallocate(ifmin);nullify(ifmin);endif
if(associated(ifmax))then;deallocate(ifmax);nullify(ifmax);endif
if(associated(energies))then;deallocate(energies);nullify(energies);endif
if(associated(occupations))then;deallocate(occupations);nullify(occupations);endif
endif

return
end subroutine dealloc_header

!=========================================================================
subroutine dealloc_header_type(sheader, crys, kp)
character(len=3), intent(in) :: sheader
type(crystal), intent(inout) :: crys
type(kpoints), intent(inout) :: kp

call dealloc_header(sheader, crys%atyp, crys%apos, kp%ngk, kp%w, kp%rk, kp%ifmin, kp%ifmax, kp%el, kp%occ)

return
end subroutine dealloc_header_type

!=========================================================================
subroutine dealloc_kp(kp)
type(kpoints), intent(inout) :: kp

if(associated(kp%ngk))then;deallocate(kp%ngk);nullify(kp%ngk);endif
if(associated(kp%w))then;deallocate(kp%w);nullify(kp%w);endif
if(associated(kp%rk))then;deallocate(kp%rk);nullify(kp%rk);endif
if(associated(kp%ifmin))then;deallocate(kp%ifmin);nullify(kp%ifmin);endif
if(associated(kp%ifmax))then;deallocate(kp%ifmax);nullify(kp%ifmax);endif
if(associated(kp%el))then;deallocate(kp%el);nullify(kp%el);endif
if(associated(kp%occ))then;deallocate(kp%occ);nullify(kp%occ);endif

return
end subroutine dealloc_kp

!=========================================================================
subroutine dealloc_crys(crys)
type(crystal), intent(inout) :: crys

if(associated(crys%atyp))then;deallocate(crys%atyp);nullify(crys%atyp);endif
if(associated(crys%apos))then;deallocate(crys%apos);nullify(crys%apos);endif

return
end subroutine dealloc_crys

!=========================================================================
!> detect incompatibility between header info for wfns supposedly describing same system
subroutine check_header(name, kp, gvec, syms, crys, name2, kp2, gvec2, syms2, crys2, is_wfn, tolerant)
character(len=*), intent(in) :: name
type(kpoints), intent(in) :: kp
type(gspace), intent(in) :: gvec
type(symmetry), intent(in) :: syms
type(crystal), intent(in) :: crys
character(len=*), intent(in) :: name2
type(kpoints), intent(in) :: kp2
type(gspace), intent(in) :: gvec2
type(symmetry), intent(in) :: syms2
type(crystal), intent(in) :: crys2
logical, intent(in) :: is_wfn
!< set to false if RHO or VXC is one of the two being compared to avoid checking uninitialized fields
logical, optional, intent(in) :: tolerant !< set to true to allow difference in symmetries and atoms

character*100 :: string
logical :: tolerant_

tolerant_ = .false.
if(present(tolerant)) tolerant_ = tolerant
string = TRUNC(name) + " vs. " + TRUNC(name2)

!> kpoints
if(kp%nspin /= kp2%nspin) call die(TRUNC(string) + ": spin mismatch")
if(kp%nspinor /= kp2%nspinor) call die(TRUNC(string) + ": nspinor mismatch")
if(is_wfn .and. abs(kp%ecutwfc - kp2%ecutwfc) > TOL_Small) call die(TRUNC(string) + ": wfn cutoff mismatch")

!> gspace
if(gvec%ng /= gvec2%ng) call die(TRUNC(string) + ": total number of G-vectors mismatch")
if(abs(gvec%ecutrho - gvec2%ecutrho) > TOL_Small) call die(TRUNC(string) + ": charge-density cutoff mismatch")
if(any(gvec%FFTgrid(1:3) /= gvec2%FFTgrid(1:3))) call die(TRUNC(string) + ": FFT grid mismatch")

if(.not. tolerant_) then
!> symmetries
if(syms%ntran /= syms2%ntran) call die(TRUNC(string) + ": number of symmetries mismatch")
if(syms%cell_symmetry /= syms2%cell_symmetry) call die(TRUNC(string) + ": type of cell symmetry mismatch")
if(any(syms%mtrx(1:3, 1:3, 1:syms%ntran) /= syms2%mtrx(1:3, 1:3, 1:syms2%ntran))) &
call die(TRUNC(string) + ": symmetry rotation matrix mismatch")
if(any(abs(syms%tnp(1:3, 1:syms%ntran) - syms2%tnp(1:3, 1:syms2%ntran)) > TOL_Small)) &
call die(TRUNC(string) + ": symmetry fractional translation mismatch")

!> atoms
if(crys%nat /= crys2%nat) call die(TRUNC(string) + ": number of atoms mismatch")
if(any(crys%atyp(1:crys%nat) /= crys2%atyp(1:crys2%nat))) call die(TRUNC(string) + ": atom species mismatch")
if(any(abs(crys%alat * crys%apos(1:3, 1:crys%nat) - crys2%alat * crys2%apos(1:3, 1:crys2%nat)) > TOL_Small)) &
call die(TRUNC(string) + ": atom position mismatch")
endif

!> lattice
if(abs(crys%celvol - crys2%celvol) > TOL_Small) call die(TRUNC(string) + ": cell volume mismatch")
if(abs(crys%recvol - crys2%recvol) > TOL_Small) call die(TRUNC(string) + ": reciprocal cell volume mismatch")
if(any(abs(crys%alat * crys%avec(1:3, 1:3) - crys2%alat * crys2%avec(1:3, 1:3)) > TOL_Small)) &
call die(TRUNC(string) + ": lattice vector mismatch")
if(any(abs(crys%blat * crys%bvec(1:3, 1:3) - crys2%blat * crys2%bvec(1:3, 1:3)) > TOL_Small)) &
call die(TRUNC(string) + ": reciprocal lattice vector mismatch")
if(any(abs(crys%adot(1:3, 1:3) - crys2%adot(1:3, 1:3)) > TOL_Small)) &
call die(TRUNC(string) + ": real-space metric mismatch")
if(any(abs(crys%bdot(1:3, 1:3) - crys2%bdot(1:3, 1:3)) > TOL_Small)) &
call die(TRUNC(string) + ": reciprocal-space metric mismatch")

return
end subroutine check_header

!> require `version` to be the same as `version_ref`
subroutine require_version(fname, version, version_ref)
character(len=*), intent(in) :: fname
integer, intent(in) :: version
integer, intent(in) :: version_ref

if (version/=version_ref) then
if (peinf%inode==0) then
write(0,*) 'ERROR: Wrong version for file "',TRUNC(fname),'".'
write(0,*) 'Expected: ', version_ref
write(0,*) 'Got: ', version
endif
call die('Wrong version for file "'+TRUNC(fname)+'".', only_root_writes=.true.)
endif

end subroutine require_version

!> A high-level wrapper for write_*_header* functions
subroutine write_mf_header(iunit, mf)
integer, intent(in) :: iunit
type(mf_header_t), intent(in) :: mf

character(len=3) :: sheader
character(len=16) :: fmt_str
logical :: is_fmt = .false.

if (peinf%inode==0) then
inquire(unit=iunit, form=fmt_str)
if (TRUNC(fmt_str)=='FORMATTED') then
is_fmt = .true.
else if (TRUNC(fmt_str)/='UNFORMATTED') then
call die('Unknown value for formatted string: '+TRUNC(fmt_str), &
only_root_writes=.true.)
endif
endif
! FHJ: No need to bcast is_fmt because only inode==0 reads the file.

sheader = mf%sheader
call write_header_type(iunit, is_fmt, sheader, mf%iflavor, &
mf%kp, mf%gvec, mf%syms, mf%crys, version=mf%version)

end subroutine write_mf_header

!> A high-level wrapper for write_*_header* functions
subroutine read_mf_header(iunit, mf, iflavor, sheader, warn, dont_warn_kgrid)
integer, intent(in) :: iunit
type(mf_header_t), intent(out) :: mf
integer, intent(in), optional :: iflavor
character(len=3), intent(in), optional :: sheader
logical, intent(in), optional :: warn
logical, intent(in), optional :: dont_warn_kgrid

character(len=16) :: fmt_str
logical :: is_fmt = .false.

if (peinf%inode==0) then
inquire(unit=iunit, form=fmt_str)
if (TRUNC(fmt_str)=='FORMATTED') then
is_fmt = .true.
else if (TRUNC(fmt_str)/='UNFORMATTED') then
call die('Unknown value for formatted string: '+TRUNC(fmt_str), &
only_root_writes=.true.)
endif
endif
! FHJ: No need to bcast is_fmt because only inode==0 reads the file.

if (present(sheader)) then
mf%sheader = sheader
else
mf%sheader = 'GET'
endif
if (present(iflavor)) then
mf%iflavor = iflavor
else
mf%iflavor = -1
endif
call read_header_type(iunit, is_fmt, mf%sheader, mf%iflavor, &
mf%kp, mf%gvec, mf%syms, mf%crys, version=mf%version, sdate=mf%sdate, stime=mf%stime, &
warn=warn, dont_warn_kgrid=dont_warn_kgrid)

end subroutine read_mf_header

!> Routine to initialize the mf_header_t type from a bunch of separated data types
subroutine init_mf_header_from_types(mf_header, sheader, iflavor, version, kp, gvec, syms, crys)
type(mf_header_t), intent(out) :: mf_header
character(len=*), intent(in) :: sheader
integer, intent(in) :: iflavor
integer, intent(in) :: version
type(kpoints), intent(in) :: kp
type(gspace), intent(in) :: gvec
type(symmetry), intent(in) :: syms
type(crystal), intent(in) :: crys

mf_header%version = version
mf_header%sheader = sheader
mf_header%sdate = ''
mf_header%stime = ''
mf_header%iflavor = iflavor
mf_header%kp = kp
mf_header%gvec = gvec
mf_header%syms = syms
mf_header%crys = crys

end subroutine init_mf_header_from_types

end module wfn_rho_vxc_io_m

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/read_rho_vxc.f90 > Common/read_rho_vxc.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/read_rho_vxc.p.f -o Common/read_rho_vxc.o -module Common/
# 1 "Common/read_rho_vxc.p.f"
!===============================================================================
!
! Routines:
!
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 9 "Common/Common/read_rho_vxc.f90" 2

module read_rho_vxc_m

use global_m
use gmap_m
use wfn_rho_vxc_io_m

implicit none

private

public :: read_vxc, read_rho

contains

!---------------------------------------------------------------------------------------------------
!> Read in the exchange-correlation potential and store in array sig%vxc
subroutine read_vxc(sig, gvec, kp, syms, crys, isrti, isrt, vxc2_flag)
type(siginfo), intent(inout) :: sig
type(gspace), intent(in) :: gvec
type(kpoints), intent(in) :: kp
type(symmetry), intent(in) :: syms
type(crystal), intent(in) :: crys
integer, intent(in) :: isrti(:) !< (gvec%ng)
integer, intent(in) :: isrt(:) !< (gvec%ng)
logical, intent(in) :: vxc2_flag

character*3 :: sheader
integer :: iflavor, ig, ispin
type(gspace) :: gvec_dummy
type(crystal) :: crys_dummy
type(symmetry) :: syms_dummy
type(kpoints) :: kp_dummy
real(DP) :: discrepancy

call logit('Reading VXC')
if (vxc2_flag) then
allocate(sig%vxc2 (gvec%ng,kp%nspin))
else
allocate(sig%vxc (gvec%ng,kp%nspin))
endif

if (vxc2_flag) then
if(peinf%inode == 0) call open_file(96,file='VXC2',form='unformatted',status='old')
else
if(peinf%inode == 0) call open_file(96,file='VXC',form='unformatted',status='old')
endif

sheader = 'VXC'
iflavor = 0
call read_binary_header_type(96, sheader, iflavor, kp_dummy, gvec_dummy, syms_dummy, &
crys_dummy, warn = .false.)

call check_header('WFN_inner', kp, gvec, syms, crys, 'VXC', kp_dummy, gvec_dummy, &
syms_dummy, crys_dummy, is_wfn = .false.)

allocate(gvec_dummy%components (3, gvec_dummy%ng))
call read_binary_gvectors(96, gvec_dummy%ng, gvec_dummy%ng, gvec_dummy%components)
do ig = 1, gvec%ng
if(any(gvec_dummy%components(:,isrt(ig)) .ne. gvec%components(:,ig))) call die("gvec mismatch in VXC")
enddo
if(associated(gvec_dummy%components))then;deallocate(gvec_dummy%components);nullify(gvec_dummy%components);endif

if (vxc2_flag) then
call read_binary_data(96, gvec_dummy%ng, gvec_dummy%ng, kp%nspin, sig%vxc2, gindex = isrti)
else
call read_binary_data(96, gvec_dummy%ng, gvec_dummy%ng, kp%nspin, sig%vxc, gindex = isrti)
endif

if(peinf%inode == 0) then
call close_file(96)

if (vxc2_flag) then
do ispin = 1, kp%nspin
discrepancy = check_field_is_real(sig%vxc2(:, ispin), gvec)
if(discrepancy > TOL_Zero) then
write(0,*) 'WARNING: VXC2 is not real in real space, with discrepancy ', discrepancy, ' for spin ', ispin
endif
enddo
else
do ispin = 1, kp%nspin
discrepancy = check_field_is_real(sig%vxc(:, ispin), gvec)
if(discrepancy > TOL_Zero) then
write(0,*) 'WARNING: VXC is not real in real space, with discrepancy ', discrepancy, ' for spin ', ispin
endif
enddo
endif
endif

call dealloc_header_type(sheader, crys_dummy, kp_dummy)

end subroutine read_vxc

!---------------------------------------------------------------------------------------------------
!> Read in the charge density and store in array wpg%rho (formerly known as CD95)
!! CD95 Ref: http://www.nature.com/nature/journal/v471/n7337/full/nature09897.html
subroutine read_rho(wpg, gvec, kp, syms, crys, isrti, isrt, check_filename)
type(wpgen), intent(inout) :: wpg
type(gspace), intent(in) :: gvec
type(kpoints), intent(in) :: kp
type(symmetry), intent(in) :: syms
type(crystal), intent(in) :: crys
integer, intent(in) :: isrti(:) !< (gvec%ng)
integer, intent(in) :: isrt(:) !< (gvec%ng)
character(len=*), intent(in) :: check_filename !< This is the file
!< against which the header is
!< checked

character*3 :: sheader
integer :: iflavor, ig, ispin
type(gspace) :: gvec_dummy
type(crystal) :: crys_dummy
type(symmetry) :: syms_dummy
type(kpoints) :: kp_dummy
real(DP) :: discrepancy

call logit('Reading RHO')

allocate(wpg%rho (gvec%ng,kp%nspin))

if(peinf%inode == 0) call open_file(95,file='RHO',form='unformatted',status='old')

sheader = 'RHO'
iflavor = 0
call read_binary_header_type(95, sheader, iflavor, kp_dummy, gvec_dummy, &
syms_dummy, crys_dummy, warn = .false.)

call check_header(trim(check_filename), kp, gvec, syms, crys, 'RHO', kp_dummy, &
gvec_dummy, syms_dummy, crys_dummy, is_wfn = .false.)

allocate(gvec_dummy%components (3, gvec_dummy%ng))
call read_binary_gvectors(95, gvec_dummy%ng, gvec_dummy%ng, gvec_dummy%components)
do ig = 1, gvec%ng
if(any(gvec_dummy%components(:,isrt(ig)) .ne. gvec%components(:,ig))) call die("gvec mismatch in RHO")
enddo
if(associated(gvec_dummy%components))then;deallocate(gvec_dummy%components);nullify(gvec_dummy%components);endif

call read_binary_data(95, gvec_dummy%ng, gvec_dummy%ng, kp%nspin, wpg%rho, gindex = isrti)

if(peinf%inode == 0) call close_file(95)

! otherwise if nspin == 1, the 2 component may be uninitialized to NaN
wpg%wpsq(1:2) = 0d0
wpg%nelec(1:2) = 0d0

! since they are sorted, if G = 0 is present, it is the first one
if(any(gvec%components(1:3, 1) /= 0)) call die("gvectors for RHO must include G = 0")
! otherwise, the code below will not do what we think it does

if(any(abs(aimag(wpg%rho(1,:))) > TOL_Zero)) then
call die("Charge density in RHO has imaginary part for G=0", only_root_writes = .true.)
endif

do ispin=1,kp%nspin
wpg%nelec(ispin)=dble(wpg%rho(1,ispin))
wpg%wpsq(ispin)=ryd*ryd*16.0d0*PI_D*wpg%nelec(ispin)/crys%celvol
enddo

! This is unacceptable because it means the number of electrons is negative,
! and the plasma frequency will be imaginary!
if(any(wpg%nelec(1:kp%nspin) < TOL_Zero)) then
write(0,*) wpg%nelec(:)
call die("Charge density in RHO has negative part for G=0", only_root_writes = .true.)
endif

if(peinf%inode == 0) then
do ispin = 1, kp%nspin
discrepancy = check_field_is_real(wpg%rho(:, ispin), gvec)
if(discrepancy > TOL_Zero) then
write(0,*) 'WARNING: RHO is not real in real space, with discrepancy ', discrepancy, ' for spin ', ispin
endif
enddo
endif

call dealloc_header_type(sheader, crys_dummy, kp_dummy)

end subroutine read_rho

!---------------------------------------------------------------------------------------------------
!> RHO and VXC must be real in real space, i.e. c(G) - c(-G)* = 0
real(DP) function check_field_is_real(field, gvec)
complex(DPC), intent(in) :: field(:)
type(gspace), intent(in) :: gvec

integer :: ig, umklapp(3)
complex(DPC) :: diff
type(symmetry) :: syms_inv
integer, allocatable :: ind(:), identity(:)
complex(DPC), allocatable :: phase(:)

syms_inv%ntran = 1
syms_inv%mtrx = 0
syms_inv%tnp = 0d0
syms_inv%mtrx(1:3, 1:3, 1) = reshape((/-1, 0, 0, 0, -1, 0, 0, 0, -1/), shape(syms_inv%mtrx(:,:,1)))
umklapp(1:3) = 0

allocate(phase (gvec%ng))
allocate(ind (gvec%ng))
allocate(identity (gvec%ng))

do ig = 1, gvec%ng
identity(ig) = ig
enddo

call gmap(gvec, syms_inv, gvec%ng, 1, umklapp, identity, identity, ind, phase, die_outside_sphere = .true.)
if(any(abs(phase(1:gvec%ng) - 1d0) > TOL_Zero)) call die("non-unity phase in check_field_is_real")
if(any(ind(1:gvec%ng) == 0)) call die("ind array from gmap has a zero")

check_field_is_real = 0d0
do ig = 1, gvec%ng
diff = field(ig) - conjg(field(ind(ig))*phase(ig))
check_field_is_real = max(check_field_is_real, abs(diff))
enddo

if(allocated(phase))then;deallocate(phase);endif
if(allocated(ind))then;deallocate(ind);endif
if(allocated(identity))then;deallocate(identity);endif

end function check_field_is_real

end module read_rho_vxc_m
icc -E -C -P -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/wfn_io_hdf5.F90 > Common/wfn_io_hdf5.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/wfn_io_hdf5.p.f -o Common/wfn_io_hdf5.o -module Common/
# 1 "Common/wfn_io_hdf5.p.f"
!>=========================================================================
!!
!! Module:
!!
!! (1) wfn_io_hdf5_m Originally by JIM Last Modified 4/25/2012 (JIM)
!!
!! Routines to read and write wavefunctions in HDF5 format.
!! The code is generated through repeated inclusion of a file with
!! different preprocessor definitions each time. You are not expected to
!! understand this. Consult the resulting .p.f file for clarity.
!!
!!=========================================================================

!The following macro puts any point/array in the [-0.5, 0.5) range:
!The following macro puts any point/array in the [0, 1) range:
!Integer division of a/b rounded up*/
!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

! deprecated identifiers

! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

! very ancient version may require NOSIZEOF

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.

! path before 4.0.9 lacks SIZEOF

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?

! It is considered a bug in OPEN64 that sizeof will not work in our code.

! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit

! name of routine to get name of host program is running on

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m

! how to get the cpu time in seconds

! interface required for mclock routine (timing) to be usable

! interface required for iargc routine (command-line arguments) to be usable

! ftell gives you the current location in a file, to fseek back to it

! if no fseek, ftell is useless

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

module wfn_io_hdf5_m
use global_m

end module wfn_io_hdf5_m

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
icc -E -C -P -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/kernel_io.F90 > Common/kernel_io.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/kernel_io.p.f -o Common/kernel_io.o -module Common/
# 1 "Common/kernel_io.p.f"
!>=========================================================================
!!
!! Module:
!!
!! (1) kernel_io_m Originally by FHJ Last Modified 10/07/2013 (FHJ)
!!
!! Routines to read and write kernel files (bsedmat, ...)
!! Inspired on wfn_rho_vxc_io.F90.
!!
!!=========================================================================

!The following macro puts any point/array in the [-0.5, 0.5) range:
!The following macro puts any point/array in the [0, 1) range:
!Integer division of a/b rounded up*/
!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

! deprecated identifiers

! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

! very ancient version may require NOSIZEOF

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.

! path before 4.0.9 lacks SIZEOF

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?

! It is considered a bug in OPEN64 that sizeof will not work in our code.

! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit

! name of routine to get name of host program is running on

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m

! how to get the cpu time in seconds

! interface required for mclock routine (timing) to be usable

! interface required for iargc routine (command-line arguments) to be usable

! ftell gives you the current location in a file, to fseek back to it

! if no fseek, ftell is useless

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:

module kernel_io_m

use global_m
use wfn_rho_vxc_io_m

implicit none

private
!> For library usage, do not make global_m contents available
!! to avoid namespace clashes.

public :: &
read_binary_kernel_header, &
write_binary_kernel_header, &
read_format_kernel_header, &
write_format_kernel_header, &
read_kernel_header, &
write_kernel_header, &
xctinfo_to_kernel_header, &
check_xctinfo_kernel_header

contains

!===============================================================================
! FHJ: Below are the routines for kernel*mat files
!===============================================================================

!read_formatted_kernel_header
!=========================================================================
!
! Included from file kernel_io.F90.
! You might be expected to understand this. --FHJ
!
!=========================================================================

!> Defines a subroutine with the template {read,write}_{formatted,binary}_kernel_header
subroutine read_format_kernel_header(iunit, kernel)
integer, intent(in) :: iunit !< unit number
type(kernel_header_t), intent(out) :: kernel !< kernel_header_t type

integer :: ik

call read_mf_header(iunit, kernel%mf)
if (kernel%mf%sheader/='KER') then
write(0,*) 'ERROR: header mismatch (got "'//kernel%mf%sheader//'", expected "KER")'
call die('Input file is not from a kernel calculation (header="'//kernel%mf%sheader//'")', &
only_root_writes=.true.)
endif

if (peinf%inode==0) then
! General information
read(iunit , *) kernel%iscreen, kernel%icutv, kernel%ecuts

! Variables specific to kernel files: kpts
read(iunit , *) kernel%nk
allocate(kernel%kpts (3,kernel%nk))
do ik = 1, kernel%nk
read(iunit , *) kernel%kpts(1:3, ik)
enddo

! Variables specific to kernel files: everything else
read(iunit , *) kernel%ns, kernel%nspinor, kernel%nvb, kernel%ncb, kernel%n1b, kernel%n2b
read(iunit , *) kernel%theory, kernel%nmat, kernel%storage, kernel%nblocks
! Empty records: you can use these slots in the future to extend the file format
read(iunit , *)
read(iunit , *)
read(iunit , *)
read(iunit , *)
read(iunit , *)
endif

end subroutine read_format_kernel_header

! these undefs prevent lots of cpp warnings
!write_formatted_kernel_header
!=========================================================================
!
! Included from file kernel_io.F90.
! You might be expected to understand this. --FHJ
!
!=========================================================================

!> Defines a subroutine with the template {read,write}_{formatted,binary}_kernel_header
subroutine write_format_kernel_header(iunit, kernel)
integer, intent(in) :: iunit !< unit number
type(kernel_header_t), intent(in) :: kernel !< kernel_header_t type

integer :: ik

call write_mf_header(iunit, kernel%mf)

if (peinf%inode==0) then
! General information
write(iunit , *) kernel%iscreen, kernel%icutv, kernel%ecuts

! Variables specific to kernel files: kpts
write(iunit , *) kernel%nk
do ik = 1, kernel%nk
write(iunit , *) kernel%kpts(1:3, ik)
enddo

! Variables specific to kernel files: everything else
write(iunit , *) kernel%ns, kernel%nspinor, kernel%nvb, kernel%ncb, kernel%n1b, kernel%n2b
write(iunit , *) kernel%theory, kernel%nmat, kernel%storage, kernel%nblocks
! Empty records: you can use these slots in the future to extend the file format
write(iunit , *)
write(iunit , *)
write(iunit , *)
write(iunit , *)
write(iunit , *)
endif

end subroutine write_format_kernel_header

! these undefs prevent lots of cpp warnings

!read_binary_kernel_header
!=========================================================================
!
! Included from file kernel_io.F90.
! You might be expected to understand this. --FHJ
!
!=========================================================================

!> Defines a subroutine with the template {read,write}_{formatted,binary}_kernel_header
subroutine read_binary_kernel_header(iunit, kernel)
integer, intent(in) :: iunit !< unit number
type(kernel_header_t), intent(out) :: kernel !< kernel_header_t type

integer :: ik

call read_mf_header(iunit, kernel%mf)
if (kernel%mf%sheader/='KER') then
write(0,*) 'ERROR: header mismatch (got "'//kernel%mf%sheader//'", expected "KER")'
call die('Input file is not from a kernel calculation (header="'//kernel%mf%sheader//'")', &
only_root_writes=.true.)
endif

if (peinf%inode==0) then
! General information
read(iunit ) kernel%iscreen, kernel%icutv, kernel%ecuts

! Variables specific to kernel files: kpts
read(iunit ) kernel%nk
allocate(kernel%kpts (3,kernel%nk))
do ik = 1, kernel%nk
read(iunit ) kernel%kpts(1:3, ik)
enddo

! Variables specific to kernel files: everything else
read(iunit ) kernel%ns, kernel%nspinor, kernel%nvb, kernel%ncb, kernel%n1b, kernel%n2b
read(iunit ) kernel%theory, kernel%nmat, kernel%storage, kernel%nblocks
! Empty records: you can use these slots in the future to extend the file format
read(iunit )
read(iunit )
read(iunit )
read(iunit )
read(iunit )
endif

end subroutine read_binary_kernel_header

! these undefs prevent lots of cpp warnings
!write_binary_kernel_header
!=========================================================================
!
! Included from file kernel_io.F90.
! You might be expected to understand this. --FHJ
!
!=========================================================================

!> Defines a subroutine with the template {read,write}_{formatted,binary}_kernel_header
subroutine write_binary_kernel_header(iunit, kernel)
integer, intent(in) :: iunit !< unit number
type(kernel_header_t), intent(in) :: kernel !< kernel_header_t type

integer :: ik

call write_mf_header(iunit, kernel%mf)

if (peinf%inode==0) then
! General information
write(iunit ) kernel%iscreen, kernel%icutv, kernel%ecuts

! Variables specific to kernel files: kpts
write(iunit ) kernel%nk
do ik = 1, kernel%nk
write(iunit ) kernel%kpts(1:3, ik)
enddo

! Variables specific to kernel files: everything else
write(iunit ) kernel%ns, kernel%nspinor, kernel%nvb, kernel%ncb, kernel%n1b, kernel%n2b
write(iunit ) kernel%theory, kernel%nmat, kernel%storage, kernel%nblocks
! Empty records: you can use these slots in the future to extend the file format
write(iunit )
write(iunit )
write(iunit )
write(iunit )
write(iunit )
endif

end subroutine write_binary_kernel_header

! these undefs prevent lots of cpp warnings

!read_kernel_header
!=========================================================================
!
! Included from file kernel_io.F90.
! You might be expected to understand this. --FHJ
!
!=========================================================================

!> Automatically call {read,write}_{formatted,binary}_kernel_header
subroutine read_kernel_header(iunit, kernel)
integer, intent(in) :: iunit !< unit number
type(kernel_header_t), intent(out) :: kernel !< kernel_header_t type

character(len=16) :: fmt_str
logical :: is_fmt = .false.

if (peinf%inode==0) then
inquire(unit=iunit, form=fmt_str)
if (TRUNC(fmt_str)=='FORMATTED') then
is_fmt = .true.
else if (TRUNC(fmt_str)/='UNFORMATTED') then
call die('Unknown value for formatted string: '//TRUNC(fmt_str), &
only_root_writes=.true.)
endif
endif
! FHJ: No need to bcast is_fmt because only inode==0 reads the file.

if (is_fmt) then
call read_format_kernel_header(iunit, kernel)
else
call read_binary_kernel_header(iunit, kernel)
endif

end subroutine read_kernel_header

! these undefs prevent lots of cpp warnings
!write_kernel_header
!=========================================================================
!
! Included from file kernel_io.F90.
! You might be expected to understand this. --FHJ
!
!=========================================================================

!> Automatically call {read,write}_{formatted,binary}_kernel_header
subroutine write_kernel_header(iunit, kernel)
integer, intent(in) :: iunit !< unit number
type(kernel_header_t), intent(in) :: kernel !< kernel_header_t type

character(len=16) :: fmt_str
logical :: is_fmt = .false.

if (peinf%inode==0) then
inquire(unit=iunit, form=fmt_str)
if (TRUNC(fmt_str)=='FORMATTED') then
is_fmt = .true.
else if (TRUNC(fmt_str)/='UNFORMATTED') then
call die('Unknown value for formatted string: '//TRUNC(fmt_str), &
only_root_writes=.true.)
endif
endif
! FHJ: No need to bcast is_fmt because only inode==0 reads the file.

if (is_fmt) then
call write_format_kernel_header(iunit, kernel)
else
call write_binary_kernel_header(iunit, kernel)
endif

end subroutine write_kernel_header

! these undefs prevent lots of cpp warnings

!> Populate the non-MF part of a kernel_header_t type. We assume that the MF
!! part, i.e., kernel%mf, is already set (although we do overwrite
!! kernel%mf%sheader='BSE' to play safe).
!! Unlike WFN files, you can`t specify the flavor manually, it always matches 2 .
subroutine xctinfo_to_kernel_header(xct, kpts, kernel, nmat)
type(xctinfo), intent(in) :: xct
real(DP), intent(in) :: kpts(:,:) !< (3, nk)
type(kernel_header_t), intent(inout) :: kernel
integer, intent(in) :: nmat !< 1 for kernelxmat, 3 for kerneldmat

! Generic header
kernel%mf%sheader = 'KER'
kernel%version = VER_BSE_HDF5
kernel%iflavor = 2

! General paramters
kernel%iscreen = xct%iscreen
kernel%icutv = xct%icutv
kernel%ecuts = xct%ecute
kernel%ecutg = xct%ecutg
kernel%efermi = xct%efermi
kernel%theory = xct%theory
kernel%nblocks = 1
if (xct%extended_kernel) kernel%nblocks = 4
kernel%storage = 0 ! Hard coded for now
kernel%nmat = nmat
kernel%energy_loss = xct%energy_loss

! K-point stuff
kernel%nk = xct%nkpt_co
allocate(kernel%kpts (3,kernel%nk))
kernel%kpts = kpts(1:3, 1:kernel%nk)
kernel%kgrid = kernel%mf%kp%kgrid
kernel%qflag = xct%qflag
kernel%center_mass_q = xct%finiteq
kernel%patched_sampling = xct%patched_sampling_co

! Bands stuff
kernel%nvb = xct%nvb_co
kernel%ncb = xct%ncb_co
kernel%n1b = xct%n1b_co
kernel%n2b = xct%n2b_co
kernel%ns = xct%nspin
kernel%nspinor = xct%nspinor

end subroutine xctinfo_to_kernel_header

subroutine check_xctinfo_kernel_header(fname, xct, kernel)
character(len=*), intent(in) :: fname !< file name
type(xctinfo), intent(in) :: xct
type(kernel_header_t), intent(in) :: kernel

integer :: nblocks

! Generic variables
! FHJ: absorption doesn`t care about WFN cutoff (for now!)
!call check_R('WFN cutoff', xct%ecutg, kernel%mf%kp%ecutwfc)
call check_I('screening flag', xct%iscreen, kernel%iscreen)
call check_I('truncation flag', xct%icutv, kernel%icutv)
! FHJ: absorption doesn`t care about epsilon cutoff
!call check_R('epsilon cutoff', xct%ecute, kernel%ecuts)

! Specific to bsemat
call check_I('# of k-point', xct%nkpt_co, kernel%nk)

call check_I('# of spins', xct%nspin, kernel%ns)
call check_I('# of spinor components', xct%nspinor, kernel%nspinor)
call check_I('# of val. bands', xct%nvb_co, kernel%nvb)
call check_I('# of cond. bands', xct%ncb_co, kernel%ncb)
call check_I('# of bands 1', xct%n1b_co, kernel%n1b)
call check_I('# of bands 2', xct%n2b_co, kernel%n2b)

call check_I('theory level', 0, kernel%theory) ! Hard coded for now
nblocks = 1
if (xct%extended_kernel) nblocks = 4
call check_I('number of transition blocks', nblocks, kernel%nblocks)
call check_I('storage format', 0, kernel%storage) ! Hard coded for now

contains

subroutine check_I(label, ref, got)
character(len=*), intent(in) :: label
integer, intent(in) :: ref
integer, intent(in) :: got

if (ref/=got) then
if (peinf%inode==0) then
write(0,'(1x,3a)') 'ERROR: incompatible values found in file "', fname, '".'
write(0,'(1x,2a)') 'Quantity: ', label
write(0,'(1x,a,i0)') 'Expected: ', ref
write(0,'(1x,a,i0)') 'Got: ', got
endif
call die('Incompatible values in file "'+fname+'".', &
only_root_writes=.true.)
endif

end subroutine check_I

subroutine check_R(label, ref, got)
character(len=*), intent(in) :: label
real(DP), intent(in) :: ref
real(DP), intent(in) :: got

real(DP) :: tol=TOL_Small

if (dabs(ref-got)>tol) then
if (peinf%inode==0) then
write(0,'(1x,3a)') 'ERROR: incompatible values found in file "', fname, '".'
write(0,'(1x,2a)') 'Quantity: ', label
write(0,'(1x,a,f0.8)') 'Expected: ', ref
write(0,'(1x,a,f0.8)') 'Got: ', got
endif
call die('Incompatible values in file "'+fname+'".', &
only_root_writes=.true.)
endif

end subroutine check_R

end subroutine check_xctinfo_kernel_header

end module kernel_io_m

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/splines.f90 > Common/splines.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/splines.p.f -o Common/splines.o -module Common/
# 1 "Common/splines.p.f"
!===============================================================================
!
! MODULE:
!
! splines_m Originally by FHJ Last Modified 10/24/2011 (FHJ)
!
!> Routines to evaluate spline curves.
!
! DESCRIPTION:
!
! Main functions were adapted from P. Dierckx`s FITPACK (BSD License):
! http://www.netlib.org/dierckx/
! http://nalag.cs.kuleuven.be/research/topics/fitpack.shtml
! http://www.scipy.org/doc/api_docs/SciPy.interpolate.fitpack.html
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 19 "Common/Common/splines.f90" 2

module splines_m

use global_m
implicit none

private

public :: splev, splev_shift

contains

!The following functions were downloaded from:
! http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=dierck...
!The code was converted to F90 using Alan Miller`s 'to_f90' utility:
! http://jblevins.org/mirror/amiller/to_f90.f90

!> Subroutine fpbspl evaluates the (k+1) non-zero b-splines of degree k at
!! t(l) <= x < t(l+1) using the stable recurrence relation of de Boor and Cox.
subroutine fpbspl(t,n,k,x,l,h)
real(DP), intent(in) :: t(:) !< (n)
integer, intent(in) :: n
integer, intent(in) :: k
real(DP), intent(in) :: x
integer, intent(in) :: l
real(DP), intent(out) :: h(6)

! ..local scalars..
real(DP) :: f,one
integer :: i,j,li,lj
! ..local arrays..
real(DP) :: hh(5)
! ..

one = 0.1d+1
h(1) = one
do j=1,k
do i=1,j
hh(i) = h(i)
end do
h(1) = 0.0d0
do i=1,j
li = l+i
lj = li-j
f = hh(i)/(t(li)-t(lj))
h(i) = h(i)+f*(t(li)-x)
h(i+1) = f*(x-t(lj))
end do
end do

end subroutine fpbspl

!> Subroutine splev evaluates in a number of points x(i),i=1,2,...,m
!! a spline s(x) of degree k, given in its b-spline representation.
!!
!! Restrictions:
!! \li m >= 1
!! \li t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1.
!!
!! \param t array, length n, which contains the position of the knots.
!! \param n integer, giving the total number of knots of s(x).
!! \param c array, length n, which contains the b-spline coefficients.
!! \param k integer, giving the degree of s(x).
!! \param x array, length m, which contains the points where s(x) must
!! be evaluated.
!! \param m integer, giving the number of points where s(x) must be
!! evaluated.
!! \param y array,length m, giving the value of s(x) at the different
!! points.
!! \param ier error flag:
!! \li ier = 0: normal return
!! \li ier = 10: invalid input data (see restrictions)
subroutine splev(t,n,c,k,x,y,m,ier)
! Other subroutines required: fpbspl.

! References :
! de boor c : on calculating with b-splines, j. approximation theory
! 6 (1972) 50-62.
! cox m.g. : the numerical evaluation of b-splines, j. inst. maths
! applics 10 (1972) 134-149.
! dierckx p. : curve and surface fitting with splines, monographs on
! numerical analysis, oxford university press, 1993.

! Author :
! p.dierckx
! dept. computer science, k.u.leuven
! celestijnenlaan 200a, b-3001 heverlee, belgium.
! e-mail : Paul.Dierckx@cs.kuleuven.ac.be

! Latest Update : march 1987
! Removed go to usage, DAS Jan 2012

! ..scalar arguments..

real(DP), intent(in) :: t(:) !< (n)
integer, intent(in) :: n
real(DP), intent(in) :: c(:) !< (n)
integer, intent(in) :: k
real(DP), intent(in) :: x(:) !< (m)
real(DP), intent(out) :: y(:) !< (m)
integer, intent(in) :: m
integer, intent(out) :: ier

! ..array arguments..

! ..local scalars..
integer :: i,j,k1,l,ll,l1,nk1
real(DP) :: arg,sp,tb,te
! ..local array..
real(DP) :: h(6)

! ..
! before starting computations a data check is made. if the input data
! are invalid control is immediately repassed to the calling program.
ier = 10
if(m-1 < 0) then

return
endif
do i=2,m
if(x(i) < x(i-1)) then

return
endif
end do
ier = 0
! fetch tb and te, the boundaries of the approximation interval.
k1 = k+1
nk1 = n-k1
tb = t(k1)
te = t(nk1+1)
l = k1
l1 = l+1
! main loop for the different points.
do i=1,m
! fetch a new x-value arg.
arg = x(i)
if(arg < tb) arg = tb
if(arg > te) arg = te
! search for knot interval t(l) <= arg < t(l+1)
40 if(arg < t(l1) .or. l == nk1) go to 50
l = l1
l1 = l+1
go to 40
! evaluate the non-zero b-splines at arg.
50 call fpbspl(t,n,k,arg,l,h)
! find the value of s(x) at x=arg.
sp = 0.
ll = l-k1
do j=1,k1
ll = ll+1
sp = sp+c(ll)*h(j)
end do
y(i) = sp
end do

return
end subroutine splev

!> Similar to splines_m::splev, but modifies the energy by using the scissors operators
!! described by tck.
!! \param tck b-spline coefficient for scissors operators, in eV.
!! \param E LDA energy (will be overwritten by the corrected one).
!! \param ryd optional parameter that tells whether E is in Ryd.
!! Default is .true.. Note: tck is always assumed to be in eV.
!!
!! \sa typedefs_m::spline_tck
subroutine splev_shift(tck, E, in_ryd)
type(spline_tck), intent(in) :: tck
real(DP), intent(inout) :: E
logical, optional, intent(in) :: in_ryd

real(DP) :: x_arr(1)
real(DP) :: y_arr(1)
integer :: m, ier
logical :: conv_units

conv_units = .true.
if (present(in_ryd)) then
if (.not. in_ryd) conv_units = .false.
endif

m=1
if (conv_units) then
x_arr(1) = E*ryd
else
x_arr(1) = E
endif
call splev(tck%t,tck%n,tck%c,tck%k,x_arr,y_arr,m,ier)
if (ier==0) then
if (conv_units) then
E = E + y_arr(1)/ryd
else
E = E + y_arr(1)
endif
else
write(0,'(a)') 'WARNING: Error doing spline interpolation. Ignoring correction!'
endif

end subroutine splev_shift

end module splines_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/groupk.f90 > Common/groupk.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/groupk.p.f -o Common/groupk.o -module Common/
# 1 "Common/groupk.p.f"
!===============================================================================
!
! Routines:
!
! 1. groupk() Originally By gsm Last Modified 8/31/2010 (gsm)
!
! Generates symmetries of the k-point.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/groupk.f90" 2

module groupk_m

use global_m
implicit none

private

public :: groupk

contains

subroutine groupk(kvec,nsyml,rotl,nsymk,rotk)
real(DP), intent(in) :: kvec(:) !< (3)
integer, intent(in) :: nsyml
integer, intent(in) :: rotl(:,:,:) !< (3,3,48)
integer, intent(out) :: nsymk
integer, intent(out) :: rotk(:,:,:) !< (3,3,48)

integer :: isyml
real(DP) :: krot(3)

nsymk=0
do isyml=1,nsyml
krot(1:3) = matmul(dble(rotl(1:3, 1:3, isyml)), kvec(1:3))
if (all(abs(krot(1:3)-kvec(1:3)).lt.TOL_Small)) then
nsymk=nsymk+1
rotk(1:3, 1:3, nsymk) = rotl(1:3, 1:3, isyml)
endif
enddo

return
end subroutine groupk

end module groupk_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/symmetries.f90 > Common/symmetries.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/symmetries.p.f -o Common/symmetries.o -module Common/
# 1 "Common/symmetries.p.f"
!===============================================================================
!
! Module:
!
! symmetries_m Originally By DAS 12/20/2011
!
! Find symmetry operations from lattice vectors and atomic positions,
! using spglib 1.0.9. For use in mean-field codes such as EPM and SIESTA wrapper.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 13 "Common/Common/symmetries.f90" 2

module symmetries_m

use global_m
use misc_m
use sort_m

implicit none

private

public :: get_symmetries

real(DP), parameter :: symprec = 1d-5
! this is the same tolerance used by the Quantum ESPRESSO routines

interface
! these functions are defined in spglib_f.c

subroutine spg_get_multiplicity_f(size, lattice, position, types, num_atom, symprec)
implicit none
integer, intent(out) :: size
real(8), intent(in) :: lattice
real(8), intent(in) :: position
integer, intent(in) :: types
integer, intent(in) :: num_atom
real(8), intent(in) :: symprec
end subroutine spg_get_multiplicity_f

subroutine spg_get_symmetry_f(nsym, rotation, translation, max_size, lattice, position, types, num_atom, symprec)
implicit none
integer, intent(out) :: nsym
integer, intent(out) :: rotation
real(8), intent(out) :: translation
integer, intent(in) :: max_size
real(8), intent(in) :: lattice
real(8), intent(in) :: position
integer, intent(in) :: types
integer, intent(in) :: num_atom
real(8), intent(in) :: symprec
end subroutine spg_get_symmetry_f

subroutine spg_get_international_f(spacegroup, symbol, lattice, position, types, num_atom, symprec)
implicit none
integer, intent(out) :: spacegroup
character*11, intent(out) :: symbol
real(8), intent(in) :: lattice
real(8), intent(in) :: position
integer, intent(in) :: types
integer, intent(in) :: num_atom
real(8), intent(in) :: symprec
end subroutine spg_get_international_f

end interface

contains

subroutine get_symmetries(nat, atyp, apos, avec, nfft, cell_symmetry, ntran, mtrx, tnp, spacegroup, symbol)
integer, intent(in) :: nat !< number of atoms
integer, intent(in) :: atyp(:) !< atomic species
real(DP), intent(in) :: apos(:,:) !< (1:3,1:nat) atomic positions in crystal coordinates
real(DP), intent(in) :: avec(3,3) !< lattice vectors in real space
integer, intent(in) :: nfft(3) !< FFT grid (if = 0, not used)
integer, intent(out) :: cell_symmetry !< 0 = cubic, 1 = hexagonal
integer, intent(out) :: ntran !< number of symmetry operations
integer, intent(out) :: mtrx(:,:,:) !< rotation matrices (3, 3, 48)
real(DP), intent(out) :: tnp(:,:) !< frational translations (3, 48)
integer, intent(out) :: spacegroup !< spacegroup international index
character, intent(out) :: symbol*21 !< spacegroup symbol in Schoenflies notation

integer :: isym, ii, jj, ntran_temp, ntran_temp2, identity(3,3)
real(DP) :: C_avec(3,3), frac_fft(3)
integer, allocatable :: mtrx_inv(:,:,:) ! allocatable since more than 48 ops may be returned
real(DP), allocatable :: tnp_temp(:,:)
logical :: use_this_sym, disable_frac, found_identity

! transpose input for C call
do ii = 1, 3
C_avec(ii, 1:3) = avec(1:3, ii)
enddo

call spg_get_international_f(spacegroup, symbol, C_avec(1, 1), apos(1, 1), atyp(1), nat, symprec)

! http://en.wikipedia.org/wiki/Trigonal_crystal_system: 143-167
! http://en.wikipedia.org/wiki/Hexagonal_crystal_system: 168-194
! All others are cubic.

if(spacegroup >= 143 .and. spacegroup <= 194) then
cell_symmetry = 1 ! hexagonal
else
cell_symmetry = 0 ! cubic
endif

disable_frac = .false.
call spg_get_multiplicity_f(ntran_temp, C_avec(1,1), apos(1,1), atyp(1), nat, symprec)
allocate(mtrx_inv (3, 3, ntran_temp))
allocate(tnp_temp (3, ntran_temp))

! we need to check that it is not a supercell, as in the QE routine (sgam_at)
! they disable fractional translations if the identity has one, because the sym ops might not form a group.
! spglib may return duplicate operations in this case!

call spg_get_symmetry_f(ntran_temp2, mtrx_inv(1,1,1), tnp_temp(1,1), ntran_temp, C_avec(1,1), apos(1,1), atyp(1), nat, symprec)
if(ntran_temp2 /= ntran_temp) call die("Inconsistent number of symmetries from spglib. Internal error.")

! for debugging: write all ops
! do isym = 1, ntran_temp2
! write(6,'(10i3, 3f6.2)') isym, mtrx_inv(:,:,isym), tnp_temp(:,isym)
! enddo

if(ntran_temp > 48) then
disable_frac = .true.
write(0,'(a,i6,a)') "Number of symmetry operations = ", ntran_temp, " > 48"
endif

found_identity = .false.
identity = reshape((/1, 0, 0, 0, 1, 0, 0, 0, 1/), shape(identity))
do isym = 1, ntran_temp
if(all(mtrx_inv(1:3,1:3,isym) == identity(1:3, 1:3))) then
found_identity = .true.
if(any(abs(tnp_temp(1:3, isym)) > TOL_Zero)) then
disable_frac = .true.
write(0,'(a,3f12.6)') 'Identity has a fractional translation ', tnp_temp(1:3, isym)
endif
endif
enddo
if(.not. found_identity) call die("Symmetries internal error: Identity is missing from symmetry operations.")

if(disable_frac) then
write(0,'(a)') "WARNING: Disabling fractional translations. System appears to be a supercell."
endif

! spglib does not consider an FFT grid. below is based on QE routine sgam_at.
ntran = 0
do isym = 1, ntran_temp
if(all(nfft(1:3) /= 0)) then
! check that rotation matrix is compatible with FFT grid
use_this_sym = &
mod(mtrx_inv(2, 1, isym) * nfft(1), nfft(2)) == 0 .and. &
mod(mtrx_inv(3, 1, isym) * nfft(1), nfft(3)) == 0 .and. &
mod(mtrx_inv(1, 2, isym) * nfft(2), nfft(1)) == 0 .and. &
mod(mtrx_inv(3, 2, isym) * nfft(2), nfft(3)) == 0 .and. &
mod(mtrx_inv(1, 3, isym) * nfft(3), nfft(1)) == 0 .and. &
mod(mtrx_inv(2, 3, isym) * nfft(3), nfft(2)) == 0

! check that fractional translation is compatible with FFT grid
frac_fft(1:3) = tnp_temp(1:3, isym) * nfft(1:3)
use_this_sym = use_this_sym .and. all(abs(frac_fft(1:3) - nint(frac_fft(1:3))) / nfft(1:3) < symprec)
else
! if FFT grid is supplied as zero, we accept all operations
use_this_sym = .true.
endif

! make sure fractional translations are in the right range, just a convention
! this makes the results agree with the ESPRESSO routines, but really makes no practical difference
do jj = 1, 3
if (tnp_temp(jj, isym).ge.TOL_Zero+0.5d0) &
tnp_temp(jj, isym)=tnp_temp(jj, isym)-dble(int(tnp_temp(jj, isym)+0.5d0))
if (tnp_temp(jj, isym).lt.TOL_Zero-0.5d0) &
tnp_temp(jj, isym)=tnp_temp(jj, isym)-dble(int(tnp_temp(jj, isym)-0.5d0))
enddo

if(disable_frac) then
if(any(abs(tnp_temp(1:3,isym)) > TOL_Zero)) use_this_sym = .false.
endif

if(use_this_sym) then
ntran = ntran + 1
if(ntran > 48) call die("Internal error: There are more than 48 accepted symmetry operations.")
! this could only happen for a supercell, and we are supposed to have handled that situation already

! if accepted, add this operation to the list
call invert_matrix_int(mtrx_inv(1:3, 1:3, isym), mtrx(1:3, 1:3, ntran))
tnp(1:3, ntran) = 2 * PI_D * tnp_temp(1:3, isym)
endif
enddo

if(allocated(mtrx_inv))then;deallocate(mtrx_inv);endif
if(allocated(tnp_temp))then;deallocate(tnp_temp);endif

call make_identity_symmetry_first(ntran, mtrx, tnp)

return

end subroutine get_symmetries

end module symmetries_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/scissors.f90 > Common/scissors.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/scissors.p.f -o Common/scissors.o -module Common/
# 1 "Common/scissors.p.f"
!===============================================================================
!
! Modules:
!
! scissors_m Originally By DAS
!
! Routines for scissors corrections to mean-field eigenvalues.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/scissors.f90" 2

module scissors_m

use global_m
use splines_m

implicit none

private

public :: &
scissors_shift, &
scissors_write, &
scissors_zero, &
scissors_function, &
scissors_inread

contains

!---------------------------------------------------------------------------------------------------
!> Scissors operator to get quasi-particle spectrum from LDA eigenvalues
!! evs, ecs, ev0, ec0 are supposed to be in eV
!! kp%el is taken to be in Ry however
!! spl_tck (spline coefficients) in Ry
subroutine scissors_shift(kp, scis, spl_tck)
type(kpoints), intent(inout) :: kp
type(scissors_t), intent(in) :: scis
type(spline_tck), optional, intent(in) :: spl_tck

integer :: is, irk, ib
logical :: has_spline, use_spline
real(DP) :: spline_emin, spline_emax

has_spline=.false.
if (present(spl_tck)) then
if (spl_tck%n>0) then
has_spline = .true.
spline_emin = spl_tck%t(1)/ryd
spline_emax = spl_tck%t(spl_tck%n)/ryd
endif
endif

do is=1,kp%nspin
do irk=1,kp%nrk
do ib=1,kp%mnband

use_spline=.false.
if (has_spline) then
if ( (kp%el(ib,irk,is) > spline_emin) .and. &
(kp%el(ib,irk,is) < spline_emax) ) then
use_spline=.true.
endif
endif

if (use_spline) then
! use spline interpolation for scissors ops
call splev_shift( spl_tck, kp%el(ib,irk,is) )
else
! use regular (linear) scissors ops
if(ib <= kp%ifmax(irk,is)) then
kp%el(ib,irk,is) = scissors_function(kp%el(ib, irk, is), scis%val)
else
kp%el(ib,irk,is) = scissors_function(kp%el(ib, irk, is), scis%cond)
endif
endif

enddo ! ib (band)
enddo ! irk (kpoint)
enddo ! is (spin)

return
end subroutine scissors_shift

!---------------------------------------------------------------------------------------------------
subroutine scissors_write(iunit, scis, suffix)
integer, intent(in) :: iunit !< unit to which to write
type(scissors_t), intent(in) :: scis
character(len=*), optional, intent(in) :: suffix !< identifier to be printed

write(iunit,'(/1x,a)',advance='no') "Scissors parameters"
if(present(suffix)) then
write(iunit,'(3a)') ' (', TRUNC(suffix), '):'
else
write(iunit,'(a)') ":"
endif
write(iunit,'(1x,3(a,f8.4))') &
'- Valence: es = ', scis%val%es, ' eV, e0 = ', scis%val%e0, ' eV, edel = ', scis%val%edel
write(iunit,'(1x,3(a,f8.4))') &
'- Conduction: es = ', scis%cond%es, ' eV, e0 = ', scis%cond%e0, ' eV, edel = ', scis%cond%edel

return
end subroutine scissors_write

!---------------------------------------------------------------------------------------------------
subroutine scissors_zero(scis)
type(scissors_t), intent(out) :: scis

scis%val%es = 0d0
scis%val%e0 = 0d0
scis%val%edel = 0d0
scis%cond%es = 0d0
scis%cond%e0 = 0d0
scis%cond%edel = 0d0

return
end subroutine scissors_zero

!---------------------------------------------------------------------------------------------------
real(DP) function scissors_function(energy, scis)
real(DP), intent(in) :: energy !< should be in Ry
type(sub_scissors_t), intent(in) :: scis

scissors_function = energy + scis%es / ryd + scis%edel * (energy - scis%e0 / ryd)

return
end function scissors_function

!---------------------------------------------------------------------------------------------------
subroutine scissors_inread(keyword, line, scis, found, suffix)
character(len=*), intent(in) :: keyword, line
type(scissors_t), intent(inout) :: scis
logical, intent(out) :: found
character(len=*), optional, intent(in) :: suffix

integer :: iostat, trunc_length
character*120 :: trunc_keyword

if(present(suffix)) then
if(len(suffix) > 0) then
trunc_length = len(trim(keyword))
if(keyword(trunc_length-len(suffix)+1:trunc_length) == suffix) then
trunc_keyword = keyword(1:trunc_length-len(suffix))
else
found = .false.

return
endif
endif
else
trunc_keyword = keyword
endif

found = .true.
if(trim(trunc_keyword).eq.'cvfit') then
read(line,*,iostat = iostat) scis%val%es,scis%val%e0,scis%val%edel, &
scis%cond%es,scis%cond%e0,scis%cond%edel
elseif(trim(trunc_keyword).eq.'evs') then
read(line,*,iostat = iostat) scis%val%es
elseif(trim(trunc_keyword).eq.'ev0') then
read(line,*,iostat = iostat) scis%val%e0
elseif(trim(trunc_keyword).eq.'evdel') then
read(line,*,iostat = iostat) scis%val%edel
elseif(trim(trunc_keyword).eq.'ecs') then
read(line,*,iostat = iostat) scis%cond%es
elseif(trim(trunc_keyword).eq.'ec0') then
read(line,*,iostat = iostat) scis%cond%e0
elseif(trim(trunc_keyword).eq.'ecdel') then
read(line,*,iostat = iostat) scis%cond%edel
else
found = .false.
endif

if(found .and. iostat /= 0) call die( &
'Unexpected characters were found while reading the value for the keyword ' &
// trim(keyword) // '. ', only_root_writes = .true.)

return
end subroutine scissors_inread

end module scissors_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/epswrite_hdf5.f90 > Common/epswrite_hdf5.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/epswrite_hdf5.p.f -o Common/epswrite_hdf5.o -module Common/
# 1 "Common/epswrite_hdf5.p.f"
!>=========================================================================
!!
!! Module:
!!
!! epswrite_hdf5_m Originally by JRD Last Modified 12/2014 (FHJ)
!!
!! Routines to write header info for epsmat files in HDF5 format.
!!
!!=========================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 12 "Common/Common/epswrite_hdf5.f90" 2

module epswrite_hdf5_m
# 274
end module epswrite_hdf5_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/cells.f90 > Common/cells.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/cells.p.f -o Common/cells.o -module Common/
# 1 "Common/cells.p.f"
!===============================================================================
!
! MODULE:
!
! cells_m Originally by FHJ Last Modified 10/24/2011 (FHJ)
!
!> Implements cell lists to partition the space and permit quick search of
!! points.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 13 "Common/Common/cells.f90" 2

module cells_m

use global_m
implicit none

private

type :: cells_t
integer :: dims !< Number of dimensions
integer :: npts !< Number of points/particles/etc
integer :: n_cells(3) !< Number of cells in each particular dimension
real(DP) :: dmin(3) !< Min coordinate of cell
real(DP) :: dmax(3) !< Max coordinate of cell
real(DP) :: shift(3) !<
real(DP) :: factor(3) !<
real(DP), pointer :: pts(:,:) !< The points (dims, npts)
integer, pointer :: head(:,:,:)
integer, pointer :: list(:)
logical :: periodic !< Use periodic boundary conditions?
logical :: active_dim(3) !< Whether a direction is active or degenerate
end type cells_t

public :: cells_t, &
cells_init, &
cells_free, &
cells_get_cell_idx, &
cells_find_exactly

contains

!> Puts all points pts(3,:) into a cell structure.
!! If the cell is periodic, all points are moved to the [0, 1) range.
!! This subroutine automatically detects the number of dimension spanned by
!! the points, and it might be a good idea for the caller to check that.
!! eg: this%dims == xct%idimensions
subroutine cells_init(this, pts, periodic)
type(cells_t), intent(out) :: this
real(DP), intent(in) :: pts(:,:)
logical, intent(in) :: periodic

real(DP) :: dim_vol, prop_const
integer :: jdim
logical :: should_write

should_write = peinf%verb_debug

if (peinf%inode==0 .and. should_write) &
write(6,'(/1x,a)') 'Initializing cell structure.'

this%periodic = periodic
this%npts = size(pts, dim=2)
allocate(this%pts (3, this%npts))
if (this%periodic) then
! FHJ: this is guaranteed to be in [0, 1)
this%pts(:,:) = (pts(:,:) - floor(pts(:,:)))
else
this%pts(:,:) = pts(:,:)
endif

! FHJ: Avoid problems that a very small dimension may cause
this%active_dim(:) = .false.
this%dims = 0
this%dmin(:) = minval(this%pts(:,:), dim=2)
this%dmax(:) = maxval(this%pts(:,:), dim=2)
do jdim=1,3
if ((this%dmax(jdim)-this%dmin(jdim)) > TOL_Small) then
this%active_dim(jdim) = .true.
this%dims = this%dims + 1
if (this%periodic) then
this%dmin(jdim) = 0d0
this%dmax(jdim) = 1d0
endif
endif
enddo

! FHJ: This is only to avoid division by zero later on
this%dmin(:) = this%dmin(:) - TOL_Small
this%dmax(:) = this%dmax(:) + TOL_Small

! FHJ: number of cells is proportional to the length of each active dimension
! this should work for any number of dimensions. Proof:
! d1*d2*... = V
! n1 = c*d1*(N)^(1/D)
! n1*n2*... = c^(D)*V*N = N => c = (1/V)^(1/D)
! so, const = (N/V)^(1/D)
this%n_cells(:) = 1
if (this%dims>0) then
dim_vol=1.0d0
do jdim=1,3
if (this%active_dim(jdim)) dim_vol = dim_vol * (this%dmax(jdim)-this%dmin(jdim))
enddo
prop_const = (this%npts/dim_vol)**(1.0d0/this%dims)
do jdim=1,3
if (this%active_dim(jdim)) then
this%n_cells(jdim) = idnint(prop_const * (this%dmax(jdim)-this%dmin(jdim)))
this%n_cells(jdim) = min(max(this%n_cells(jdim), 1), this%npts)
endif
enddo
endif

this%factor(:) = this%n_cells(:) / (this%dmax(:) - this%dmin(:))
this%shift(:) = (this%dmax(:) - this%dmin(:)) / (2.0d0*this%n_cells(:))

if (peinf%inode==0 .and. should_write) then
write(6,'(1x,a,i0,a)') 'Automatically creating a cell structure for ',this%npts,' points'
write(6,'(1x,a,i0,a)') 'Found ',this%dims,' dimension(s)'
write(6,'(1x,a,3(1x,i0))') 'Number of cells:', this%n_cells(1),this%n_cells(2),this%n_cells(3)
write(6,'(1x,a,i0)') 'Total number of cells: ', this%n_cells(1)*this%n_cells(2)*this%n_cells(3)
endif

allocate(this%head (this%n_cells(1),this%n_cells(2),this%n_cells(3)))
allocate(this%list (this%npts))

! FHJ: Initialize and populate cells
this%head(:,:,:) = 0
this%list(:) = 0

if (peinf%inode==0 .and. should_write) then
do jdim=1,3
write(6,801) jdim,this%dmin(jdim),this%dmax(jdim),this%shift(jdim)*2.0d0
801 format(' Cells [',i1,'], dmin= ',f8.5,' dmax= ',f8.5,' length= ',f12.5)
enddo
endif

call cells_populate(this)
if (peinf%inode==0 .and. should_write) then
call cells_show_population(this)
write(6,'(a)') 'Finished initializing cells.'
endif

end subroutine cells_init

!> Used internally by cells_init. Puts all points into the cells, update
!! head and list structures.
subroutine cells_populate(this)
type(cells_t), intent(inout) :: this

integer :: idx_co
integer :: cell_idx(3)

do idx_co=1,this%npts
call cells_get_cell_idx(this, this%pts(:,idx_co), cell_idx)
this%list(idx_co) = this%head(cell_idx(1),cell_idx(2),cell_idx(3))
this%head(cell_idx(1),cell_idx(2),cell_idx(3)) = idx_co
enddo

end subroutine cells_populate

!> Returns the cell index for point `pt`.
subroutine cells_get_cell_idx(this, pt, cell_idx)
type(cells_t), intent(in) :: this
real(DP), intent(in) :: pt(3)
integer, intent(out) :: cell_idx(3)

! no push/pop, called too frequently
cell_idx(:) = idint((pt(:)-this%dmin(:)+this%shift(:))*this%factor(:))
if (this%periodic) then
cell_idx(:) = modulo(cell_idx(:), this%n_cells(:)) + 1
else
cell_idx(:) = min(max(cell_idx(:)+1, 1), this%n_cells(:))
endif
end subroutine cells_get_cell_idx

!> Find the index idx such that this%pts(:, idx) == pt(:)
!! The algorithm also looks for nearby cells.
subroutine cells_find_exactly(this, pt_in, idx_found)
type(cells_t), intent(in) :: this
real(DP), intent(in) :: pt_in(3)
integer, intent(out) :: idx_found

real(DP) :: pt(3), delta(3)
integer :: cell_idx(3)
integer :: i1,i2,i3,j1,j2,j3
integer :: cell_min(3), cell_max(3)

! no push/pop, called too frequently
pt(:) = pt_in(:)
if (this%periodic) pt(:) = (pt(:) - floor(pt(:)))

! See if the point is in this central cell. The subroutine should
! usually return here
call cells_get_cell_idx(this, pt, cell_idx)
call find_exactly_in_cell(cell_idx, idx_found)
if (idx_found/=0) return

! Otherwise look in neighboring cells. The routine will probably fail...
call cells_get_search_bounds(this, 1, cell_idx, cell_min, cell_max)
do i1 = cell_min(1), cell_max(1)
j1 = cells_fix_index(this, i1, 1)
cell_idx(1) = j1
do i2 = cell_min(2), cell_max(2)
j2 = cells_fix_index(this, i2, 2)
cell_idx(2) = j2
do i3 = cell_min(3), cell_max(3)
j3 = cells_fix_index(this, i3, 3)
cell_idx(3) = j3
call find_exactly_in_cell(cell_idx, idx_found)
if (idx_found/=0) then
if (peinf%inode==0) then
write(0,'(a)') &
'WARNING: find_exactly: point was not located in central cell.'
write(0,'(a)') &
'The cell structure is non-optimal.'
endif
return
endif
enddo
enddo
enddo

contains

subroutine find_exactly_in_cell(c_idx, i_found)
integer, intent(in) :: c_idx(3) !< only search in this cell index
integer, intent(out) :: i_found !< this%pts(:,i_found) == pts

integer :: idx_pt

! no push/pop, called too frequently
i_found = 0
idx_pt = this%head(c_idx(1), c_idx(2), c_idx(3))
do while (idx_pt/=0)
delta(:) = this%pts(:, idx_pt) - pt(:)
if (this%periodic) delta(:) = (delta(:) - floor(delta(:) + 0.5d0))
if (all(dabs(delta) Given a central cell and a Manhattan radius, returns the minimum and
!! maximum indices to be used in do-loops. The min and max indices obeying
!! the periodicity or finiteness of the system, and never overlap.
!! Away from borders, the subroutine simply returns:
!! cell_dmin(:) = cell_idx(:) - radius
!! cell_dmax(:) = cell_idx(:) + radius
subroutine cells_get_search_bounds(this, radius, center_idx, cell_min, cell_max)
type(cells_t), intent(in) :: this
integer, intent(in) :: radius
integer, intent(in) :: center_idx(3)
integer, intent(out) :: cell_min(3), cell_max(3)

integer :: ii

! no push/pop, called too often
do ii=1,3
if ((2*radius+1) > this%n_cells(ii)) then
cell_min(ii) = 1
cell_max(ii) = this%n_cells(ii)
else
cell_min(ii) = center_idx(ii) - radius
cell_max(ii) = center_idx(ii) + radius
endif
enddo
if (.not.this%periodic) then
cell_min(:) = max(cell_min(:), 1)
cell_max(:) = min(cell_max(:), this%n_cells(:))
endif
end subroutine cells_get_search_bounds

!> Fixed an index so that it respects the periodic boundary conditions.
!! No check is made for non-periodic cells, since functions like
!! cells_get_search_bounds are already bounded by [1, n_cells]
integer function cells_fix_index(this, idx_in, dim_)
type(cells_t), intent(in) :: this
integer, intent(in) :: idx_in
integer, intent(in) :: dim_

! no push/pop since called too frequently
cells_fix_index = idx_in
if (this%periodic) then
cells_fix_index = modulo(idx_in-1, this%n_cells(dim_)) + 1
endif
end function cells_fix_index

!> Prints a summary of the cells population
subroutine cells_show_population(this, iunit_)
type(cells_t), intent(in) :: this
integer, intent(in), optional :: iunit_

integer :: j1, j2, j3, idx_co, iunit

iunit = 6
if (present(iunit_)) iunit = iunit_
write(iunit,*) 'Cell population analysis:'
write(iunit,*)
write(iunit,900) ' x ',' y ',' z ',' members '
write(iunit,900) '---','---','---','---------'
900 format(2x, 3(a3,1x), a9)
do j1 = 1, this%n_cells(1)
do j2 = 1, this%n_cells(2)
do j3 = 1, this%n_cells(3)
write(iunit,'(2x,3(i3,1x))',advance='no') j1,j2,j3
idx_co = this%head(j1,j2,j3)
do while (idx_co>0)
write(iunit,'(1x,i5)',advance='no') idx_co
idx_co = this%list(idx_co)
enddo
write(iunit,*)
enddo
enddo
enddo
write(iunit,*)

end subroutine cells_show_population

!> Deallocates buffers related to a cell structure
subroutine cells_free(this)
type(cells_t), intent(inout) :: this

if(associated(this%head))then;deallocate(this%head);nullify(this%head);endif
if(associated(this%list))then;deallocate(this%list);nullify(this%list);endif
if(associated(this%pts))then;deallocate(this%pts);nullify(this%pts);endif

end subroutine cells_free

end module cells_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/tile.f90 > Common/tile.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/tile.p.f -o Common/tile.o -module Common/
# 1 "Common/tile.p.f"
!===============================================================================
!
! MODULE:
!
! tile_m Last Modified: Dec/2012 (FHJ)
!
!> Tiling and tessellation routines for the R^2/R^3. Currently, only Delaunay
!! triangulation is available, but Voronoi tessellation should be added soon.
!
! DESCRIPTION:
!
! This module is an abstraction layer that provides tessellation methods in
! arbitrary dimensions. The "API" declared here (in the `contains` section)
! should be generic, and the methods may be implemented by in external
! libraries. In this case, please write appropriate wrappers so that the
! routines declared here do not depend on the technical details of the
! external back end.
!
! We currently use Qhull as the back end for the Delaunay tessellation.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 24 "Common/Common/tile.f90" 2

module tile_m

use global_m

implicit none

public :: &

init_delaunay, &
find_delaunay_simplex, &
get_num_simplices, &
get_simplices, &
get_neighbors, &
free_delaunay

private

interface

!---------------------------------------------------------------------------
! FHJ: these tessellation functions are implemented in qhull/libtile_qhull.a

integer function qhull_init_delaunay(points, num_points, dimensions, inode)
implicit none
real(8), intent(in) :: points
integer, intent(in) :: num_points
integer, intent(in) :: dimensions
integer, intent(in) :: inode
end function qhull_init_delaunay

integer function qhull_find_delaunay_simplex(point, indices, coefs)
implicit none
real(8), intent(in) :: point
integer, intent(out) :: indices
real(8), intent(out) :: coefs
end function qhull_find_delaunay_simplex

integer function qhull_get_num_simplices(num_simplices)
implicit none
integer, intent(out) :: num_simplices
end function qhull_get_num_simplices

integer function qhull_get_simplices(indices)
implicit none
integer, intent(out) :: indices
end function qhull_get_simplices

integer function qhull_get_neighbors(neighbors)
implicit none
integer, intent(out) :: neighbors
end function qhull_get_neighbors

integer function qhull_free_delaunay()
implicit none
end function qhull_free_delaunay

# 105

end interface

contains

!> Calculates the Delaunay triangulation/tetrahedralization of a set of points.
!!
!! For performance issues, only one Delaunay triangulation can be active at
!! a given time.
!!
!! \param points [inout] coarse points (dim, npts)
!! \param num_points [in] number of points.
!! \param dim [in] number of dimensions
!! \return 0 for success
integer function init_delaunay(points, num_points, dimensions)
real(DP), intent(in) :: points(:,:)
integer, intent(in) :: num_points
integer, intent(in) :: dimensions

init_delaunay = qhull_init_delaunay(points(1,1), num_points, dimensions, peinf%inode)

return

end function init_delaunay

!> Finds the Delaunay triangle/tetrahedron that encloses point.
!!
!! \param point [in] real array (dim) containing the coordinates.
!! \param indices [out] integer array (dim+1) with the indices of the vertices.
!! \param coefs [out] coefficients of point in barycentric coordinates.
integer function find_delaunay_simplex(point, indices, coefs)
real(DP), intent(in) :: point(:)
integer, intent(out) :: indices(:)
real(DP), intent(out) :: coefs(:)

find_delaunay_simplex = qhull_find_delaunay_simplex(point(1), indices(1), coefs(1))

return

end function find_delaunay_simplex

!> Returns the total number of simplices obtained from the Delaunay
!! triangulation.
!!
!! \param num_simplices [out] number of simplices.
integer function get_num_simplices(num_simplices)
integer, intent(out) :: num_simplices

get_num_simplices = qhull_get_num_simplices(num_simplices)

return

end function get_num_simplices

!> Returns the indices of the points that define each simplex.
!!
!! \param simplices [out] (ndims+1, num_simplices) Vertex ivert of
!! simplex isimp corresponds to the point simplices(ivert,isimp) of
!! the original list of points.
integer function get_simplices(simplices)
integer, intent(out) :: simplices(:,:)

get_simplices = qhull_get_simplices(simplices(1,1))

return

end function get_simplices

!> Returns the indices of the neighbors for each simplex.
!!
!! \param neighbors [out] (ndims+1, num_simplices) The neighbor ivert
!! of simplex isimp is neighbors(ivert,isimp), and corresponds to the
!! simplex reached by following the ridge opposite to vertex ivert.
integer function get_neighbors(neighbors)
integer, intent(out) :: neighbors(:,:)

get_neighbors = qhull_get_neighbors(neighbors(1,1))

return

end function get_neighbors

!> Frees buffers associated to the Delaunay triangulation.
integer function free_delaunay()

free_delaunay = qhull_free_delaunay()

return

end function free_delaunay

# 320

end module tile_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/inread_common.f90 > Common/inread_common.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/inread_common.p.f -o Common/inread_common.o -module Common/
# 1 "Common/inread_common.p.f"
!===============================================================================
!
! Modules:
!
! inread_common_m Originally By FHJ
!
! A first attempt to unify the inread routines. Right now, this module
! only implements consistency checks and warning/error messages.
!
!===============================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 13 "Common/Common/inread_common.f90" 2

module inread_common_m

use global_m
implicit none

private

public :: &
check_bounds_nkq, &
check_bounds_nbands, &
check_consistency_nbands

contains

!> FHJ: Makes sure the number of {q,k}-points is less than MAX_KPTS.
!! Call this subroutine just after you read the keyword `number_{k,q}-points`.
subroutine check_bounds_nkq(nkq, k_or_q, keyword)
!> Number of {k,q}-points expected to be read (eg, pol%nq)
integer, intent(in) :: nkq
character(len=1), intent(in) :: k_or_q !< Either "k" or "q"
character(len=*), intent(in) :: keyword !< a keyword, such as `number_qpoints`

if (nkq>MAX_KPTS) then
write(0,*)
write(0,'(/,a)') 'ERROR: The number of '//&
k_or_q//'-points specified in the keyword `'//keyword//'` is '
write(0,'(a,i0)') ' larger than the maximum: MAX_KPTS=',MAX_KPTS
write(0,'(a,/)') ' Either use less '//&
k_or_q//'-points or increase MAX_KPTS in Common/nrtype.f90'
write(0,*)
call die('Too many '//k_or_q//'-points. Increase MAX_KPTS in Common/nrtypes.f90.')
endif

end subroutine check_bounds_nkq

!> FHJ: Makes sure nbMAX_BANDS) then
write(0,*)
write(0,'(a)') 'ERROR: The number of bands specified in the keyword `'//keyword//'` is larger '
write(0,'(a,i0)') ' than the maximum: MAX_BANDS=',MAX_BANDS
write(0,'(a)') ' Either use less bands or increase MAX_BANDS in Common/nrtype.f90'
write(0,*)
call die("Too many bands. Increase MAX_BANDS in Common/nrtypes.f90.")
endif

end subroutine check_bounds_nbands

!> FHJ: Makes sure nb0) then

return
endif

if(is_required .and. nb<1) then
call die("The keyword `number_bands` could not be found.", only_root_writes = .true.)
endif

call check_bounds_nbands(nb, 'number_bands')

end subroutine check_consistency_nbands

end module inread_common_m
icc -E -C -I./Common -DCPLX -DINTEL -DUSEFFTW3 Common/printsvninfo.f90 > Common/printsvninfo.p.f
ifort -E -free -I ./Common -I /opt/fftw-3.3.6-pl2/include -c -O3 Common/printsvninfo.p.f -o Common/printsvninfo.o -module Common/
# 1 "Common/printsvninfo.p.f"
!================================================================================
!
! Program:
!
! printsvninfo Originally By DAS
!
! Returns information on svn repository name, version, and revision number.
! For use by scripts to add version info to output.
!
!================================================================================

# 1 "Common/Common/f_defs.h" 1

!The following macro puts any point/array in the [-0.5, 0.5) range:

!The following macro puts any point/array in the [0, 1) range:

!Integer division of a/b rounded up*/

!Rounds a up to the smallest multiple of b*/

! disable Fortran OMP pragmas if not -DOMP*/
! note: C standard does not permit $ in identifiers, however this seems acceptable
! as an extension, for all versions of cpp I tried. --DAS

# 61

! truncate spaces in string
!#!define TRUNC(s) trim(adjustl(s))

! Sun compiler has a length limit of 132 characters and won`t support these macros
# 78
! No checking for faster performance, if not in debug mode

! Use this instead of the intrinsic 'deallocate' for pointers

! Use this instead of the intrinsic 'deallocate' for arrays

!the TOSTRING macro converts a macro into a string

# 107

! deprecated identifiers
# 120

# 1 "Common/Common/compiler.h" 1
! Created Sept 2011 by DAS.
! Define characteristics of various compilers, via compiler symbols (e.g. -DGNU)
! to be used directly from the arch.mk files, and then defining what we need to do
! for that compiler via the symbols for various properties (e.g. NOSIZEOF).
! Ideally, to support a new compiler, one need only change this file, adding a
! new block to define what -DNEWCOMPILER would mean.
! NOTE: of course, Makefile-level issues still need to be handled in common-rules.mk

# 17

# 27

! very ancient version may require NOSIZEOF
# 37

# 45

! open64 is very similar to path, it is an open-sourced version of it
! omp_lib.f90 needed to do OpenMP, see common-rules.mk.
# 58

! path before 4.0.9 lacks SIZEOF
# 68

! both open64 and path die on fseek with:
!lib-5002 : UNRECOVERABLE library error
! This FFIO request is not supported.
!
!Encountered during a GETPOS on unit 8

# 85

# 95

# 108

# 122

! cce 7.4.4 and before support sizeof for intrinsic types, but need NOSIZEOF_TYPE
! cce 8.0.0 and later do not allow sizeof for multidimensional arrays, requiring us
! to turn sizeof off everywhere. Why would Cray do this?
# 134

! It is considered a bug in OPEN64 that sizeof will not work in our code.
# 147

# 154
! Fortran 2003 prefers this as a statement, not an intrinsic

! on some platforms there is a different return value for sizeof if build is 64-bit
# 166

! name of routine to get name of host program is running on
# 175

! module required for hostnam routine to be usable

! note: interfaces are split into two lines because ifort for some reason decrees of
! 'end interface' : "END statement must be only statement on line".

! HOSTNAMEINT enables interface for hostnam routine in intrinsics_m
# 204

! how to get the cpu time in seconds
# 217

! interface required for mclock routine (timing) to be usable
# 226

! interface required for iargc routine (command-line arguments) to be usable
# 235

! ftell gives you the current location in a file, to fseek back to it
# 248

! if no fseek, ftell is useless
# 257

! #warning This compiler does not support fseek.
! fseek returns to a location in a file, bookmarked by ftell. G95 lacks it
# 267

! intrinsic module for OpenMP. external for Open64 (see common-rules.mk). NAG and G95 do not support OpenMP

! using a global var here to avoid need for conditional local declaration
# 283

# 291

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 122 "Common/Common/f_defs.h" 2

!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End:
# 13 "Common/Common/printsvninfo.f90" 2

program printsvninfo

use global_m
use svninfo_m
implicit none

character*256 :: string

call getsvninfo(string)

write(6,'(a)') trim(string)

end program printsvninfo
icc -I./Common -DCPLX -DINTEL -c -O3 Common/periodic_table.c -o Common/periodic_table.o
icc -I./Common -DCPLX -DINTEL -c -O3 Common/wfn_utils.cpp -o Common/wfn_utils.o
cd ./Common/qhull && make lib
make[3]: Entering directory '/home/jonl/Downloads/BerkeleyGW-1.2.0/Common/qhull'
icc -I../../Common -DCPLX -DINTEL -c -O3 libtile_qhull.c -o libtile_qhull.o
icc -I../../Common -DCPLX -DINTEL -c -O3 libtile_qhull_find.c -o libtile_qhull_find.o
icc -I../../Common -DCPLX -DINTEL -c -O3 geom2.c -o geom2.o
icc -I../../Common -DCPLX -DINTEL -c -O3 geom.c -o geom.o
icc -I../../Common -DCPLX -DINTEL -c -O3 global.c -o global.o
icc -I../../Common -DCPLX -DINTEL -c -O3 io.c -o io.o
icc -I../../Common -DCPLX -DINTEL -c -O3 libqhull.c -o libqhull.o
icc -I../../Common -DCPLX -DINTEL -c -O3 mem.c -o mem.o
icc -I../../Common -DCPLX -DINTEL -c -O3 merge.c -o merge.o
icc -I../../Common -DCPLX -DINTEL -c -O3 poly2.c -o poly2.o
icc -I../../Common -DCPLX -DINTEL -c -O3 poly.c -o poly.o
icc -I../../Common -DCPLX -DINTEL -c -O3 qset.c -o qset.o
icc -I../../Common -DCPLX -DINTEL -c -O3 random.c -o random.o
icc -I../../Common -DCPLX -DINTEL -c -O3 rboxlib.c -o rboxlib.o
icc -I../../Common -DCPLX -DINTEL -c -O3 stat.c -o stat.o
icc -I../../Common -DCPLX -DINTEL -c -O3 user.c -o user.o
icc -I../../Common -DCPLX -DINTEL -c -O3 usermem.c -o usermem.o
icc -I../../Common -DCPLX -DINTEL -c -O3 userprintf.c -o userprintf.o
icc -I../../Common -DCPLX -DINTEL -c -O3 userprintf_rbox.c -o userprintf_rbox.o
ar ru libtile_qhull.a libtile_qhull.o libtile_qhull_find.o geom2.o geom.o global.o io.o libqhull.o mem.o merge.o poly2.o poly.o qset.o random.o rboxlib.o stat.o user.o usermem.o userprintf.o userprintf_rbox.o
make[3]: Leaving directory '/home/jonl/Downloads/BerkeleyGW-1.2.0/Common/qhull'
ifort -O3 -o Common/printsvninfo.x Common/printsvninfo.o Common/svninfo.o Common/global.o Common/typedefs.o Common/nrtype.o Common/push_pop.o Common/message.o Common/peinfo.o Common/timing.o Common/intrinsics.o Common/scalapack_aux.o
ifort: error #10236: File not found: 'Common/printsvninfo.o'
ifort: error #10236: File not found: 'Common/svninfo.o'
Common/common-rules.mk:220: recipe for target 'Common/printsvninfo.x' failed
make[2]: *** [Common/printsvninfo.x] Error 1
make[2]: Leaving directory '/home/jonl/Downloads/BerkeleyGW-1.2.0'
Makefile:8: recipe for target 'pre' failed
make[1]: *** [pre] Error 2
make[1]: Leaving directory '/home/jonl/Downloads/BerkeleyGW-1.2.0'
Makefile:94: recipe for target 'all' failed
make: *** [all] Error 2