Branch data Line data Source code
1 : : !!****m* ABINIT/m_paw_atom_solve
2 : : !! NAME
3 : : !! m_paw_atom_solve
4 : : !!
5 : : !! FUNCTION
6 : : !! This module provides routines of the ATOMPAW code (created by NAWH, MT, FJ), modified for relaxed core paw purposes.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2013-2026 ABINIT group (MT, NBrouwer, JBoust)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !!
14 : : !! NOTES
15 : : !! FOR DEVELOPPERS: in order to preserve the portability of libPAW library,
16 : : !! please consult ~abinit/src/??_libpaw/libpaw-coding-rules.txt
17 : : !!
18 : : !! Several functions and types in this module are declared to be private to avoid
19 : : !! problems with the rest of libpaw while maintaining as much of atompaw code as possible.
20 : : !!
21 : : !! SOURCE
22 : :
23 : : #include "libpaw.h"
24 : :
25 : : module m_paw_atom_solve
26 : :
27 : : USE_DEFS
28 : : USE_MSG_HANDLING
29 : : USE_MPI_WRAPPERS
30 : : USE_MEMORY_PROFILING
31 : :
32 : : USE ieee_arithmetic
33 : : use m_libpaw_libxc
34 : : use m_pawtab
35 : : use m_pawrad
36 : : use m_paw_atomorb
37 : : use m_pawpsp
38 : : use m_paw_atom, only : atompaw_ehnzc,atompaw_dij0,atompaw_kij,atompaw_vhnzc
39 : : use m_paw_numeric
40 : : use m_pawpsp
41 : : use m_libpaw_tools, only : libpaw_get_free_unit
42 : :
43 : : implicit none
44 : : private
45 : :
46 : :
47 : :
48 : :
49 : :
50 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
51 : : ! PRIVATE PARAMETERS IMPORTED FROM ATOMPAW
52 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
53 : :
54 : :
55 : : ! Numerics
56 : : logical,private,save :: has_to_print
57 : : real(dp),private,save :: machine_zero,machine_precision,machine_infinity,practical_zero
58 : : real(dp), PRIVATE,save :: minlog,maxlog,minexp,maxexp
59 : : real(dp), PRIVATE,save :: minlogarg,maxlogarg,minexparg,maxexparg
60 : : real(dp), PARAMETER, PRIVATE :: MaxMix=0.3_dp,seterr=tol11,settoosmall=tol16
61 : : REAL(dp), parameter :: seterrmg=1.d-9,settoosmallmg=1.d-10
62 : : integer, parameter, private :: MaxIter=2000
63 : : ! Grid
64 : : INTEGER, PARAMETER, PRIVATE :: lineargrid=1 ! r(i)=h*(i-1)
65 : : INTEGER, PARAMETER, PRIVATE :: loggrid=2 ! r(i)=r0*(exp(h*(i-1))-1)
66 : : real(dp),PRIVATE, PARAMETER :: coretailtol=tol12
67 : : real(dp), PARAMETER, PRIVATE ::linrange=50._dp,linh=0.0025_dp,mxgridlin=20001
68 : : real(dp), PARAMETER, PRIVATE ::logrange=80._dp,logh=0.020_dp,mxgridlog=2001
69 : : real(dp), PARAMETER, PRIVATE :: v4logrange=100._dp,lor00=tol5
70 : : real(dp), PARAMETER, PRIVATE :: rmax_vloc=10._dp
71 : : ! Constants
72 : : real(dp), parameter :: ifsalpha2=InvFineStruct**2
73 : : real(dp), parameter :: fsalpha2=1._dp/InvFineStruct**2
74 : : ! PS scheme
75 : : INTEGER,PRIVATE,PARAMETER :: BLOECHL=1, VANDERBILT=2, CUSTOM=3, MODRRKJ=7,HFPROJ=8
76 : : INTEGER,PRIVATE,PARAMETER :: BLOECHLPS=0, POLYNOM=1,POLYNOM2=2,RRKJ=3,MARSMAN=6
77 : : INTEGER,PRIVATE,PARAMETER :: VANDERBILTORTHO=0, GRAMSCHMIDTORTHO=1
78 : : INTEGER,PRIVATE,PARAMETER :: SVDORTHO=2, HFORTHO=-13
79 : : INTEGER,PRIVATE,PARAMETER :: MTROULLIER=1, ULTRASOFT=2, BESSEL=3, KERKER_E=4,KERKER_P=5
80 : : INTEGER,PRIVATE,PARAMETER :: HARTREE_FOCK=6, SETVLOC=7, VPSMATCHNC=8,VPSMATCHNNC=9
81 : : INTEGER,PARAMETER,PRIVATE :: norbit_max=50,nbasis_add_max=25
82 : : real(dp),PARAMETER,PRIVATE :: logder_min=-5._dp,logder_max=4.95_dp,logder_pts=200
83 : : real(dp),PARAMETER,PRIVATE :: polynom2_pdeg_def=4
84 : : real(dp),PARAMETER,PRIVATE :: polynom2_qcut_def=10._dp
85 : : real(dp),PARAMETER,PRIVATE :: gausstol_def=tol4
86 : : real(dp),PARAMETER,PRIVATE :: hf_coretol_def=tol4
87 : : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_BLOECHL = 1
88 : : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_VANDERBILT= 2
89 : : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_CUSTOM = 3
90 : : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_MODRRKJ = 4
91 : : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_HF = 5
92 : : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_MARSMAN = 6
93 : : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_BLOECHL = 1
94 : : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_POLYNOM = 2
95 : : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_POLYNOM2 = 3
96 : : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_RRKJ = 4
97 : : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_BLOECHL_K = 5
98 : : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_HF = 6
99 : : INTEGER,PARAMETER,PRIVATE :: ORTHO_TYPE_GRAMSCHMIDT = 1
100 : : INTEGER,PARAMETER,PRIVATE :: ORTHO_TYPE_VANDERBILT = 2
101 : : INTEGER,PARAMETER,PRIVATE :: ORTHO_TYPE_SVD = 3
102 : : INTEGER,PARAMETER,PRIVATE :: ORTHO_TYPE_HF = 4
103 : : INTEGER,PARAMETER,PRIVATE :: SHAPEFUNC_TYPE_GAUSSIAN = 1
104 : : INTEGER,PARAMETER,PRIVATE :: SHAPEFUNC_TYPE_SINC = 2
105 : : INTEGER,PARAMETER,PRIVATE :: SHAPEFUNC_TYPE_BESSEL = 3
106 : : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_MTROULLIER = 1
107 : : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_ULTRASOFT = 2
108 : : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_BESSEL = 3
109 : : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_SETVLOC = 4
110 : : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_KERKER_EXPF = 5
111 : : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_KERKER_POLY = 6
112 : : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_VPSMATCHNC = 7
113 : : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_VPSMATCHNNC = 8
114 : : INTEGER,PARAMETER,PRIVATE :: UNKNOWN_TYPE =-1
115 : : ! XC
116 : : INTEGER, PRIVATE, PARAMETER :: LDA_PW=14
117 : : INTEGER, PRIVATE, PARAMETER :: GGA_PBE=16
118 : : INTEGER, PRIVATE, PARAMETER :: GGA_PBESOL=18
119 : : INTEGER, PRIVATE, PARAMETER :: MGGA_R2SCAN_001=13001
120 : : INTEGER, PRIVATE, PARAMETER :: MGGA_R2SCAN_01=1301
121 : : INTEGER, PRIVATE, PARAMETER :: LIBXC=-1
122 : : REAL(dp), PRIVATE, PARAMETER :: kappa= 0.804_dp
123 : : REAL(dp), PRIVATE, PARAMETER :: muorig = 0.2195149727645171_dp
124 : : REAL(dp), PRIVATE, PARAMETER :: betorig = 0.06672455060314922_dp
125 : : REAL(dp), PRIVATE, PARAMETER :: gamm = 0.03109069086965489503494086371273_dp
126 : : REAL(dp), PRIVATE, PARAMETER :: musol = 0.123456790123456_dp
127 : : REAL(dp), PRIVATE, PARAMETER :: betsol = 0.046_dp
128 : : REAL(dp), PRIVATE, PARAMETER :: AA=0.0310907_dp
129 : : REAL(dp), PRIVATE, PARAMETER :: a1=0.21370_dp
130 : : REAL(dp), PRIVATE, PARAMETER :: b1=7.59570_dp
131 : : REAL(dp), PRIVATE, PARAMETER :: b2=3.58760_dp
132 : : REAL(dp), PRIVATE, PARAMETER :: b3=1.63820_dp
133 : : REAL(dp), PRIVATE, PARAMETER :: b4=0.49294_dp
134 : : REAL(dp), PRIVATE, PARAMETER :: cx0 = 1._dp
135 : : REAL(dp), PRIVATE, PARAMETER :: cx1 = -0.667_dp
136 : : REAL(dp), PRIVATE, PARAMETER :: cx2 = -0.4445555_dp
137 : : REAL(dp), PRIVATE, PARAMETER :: cx3 = -0.663086601049_dp
138 : : REAL(dp), PRIVATE, PARAMETER :: cx4 = 1.451297044490_dp
139 : : REAL(dp), PRIVATE, PARAMETER :: cx5 = -0.887998041597_dp
140 : : REAL(dp), PRIVATE, PARAMETER :: cx6 = 0.234528941479_dp
141 : : REAL(dp), PRIVATE, PARAMETER :: cx7 = -0.023185843322_dp
142 : : REAL(dp), PRIVATE, PARAMETER :: SCANc1x = 0.667_dp
143 : : REAL(dp), PRIVATE, PARAMETER :: SCANc2x = 0.8_dp
144 : : REAL(dp), PRIVATE, PARAMETER :: SCANdx = 1.24_dp
145 : : REAL(dp), PRIVATE, PARAMETER :: k0 = 0.174_dp
146 : : REAL(dp), PRIVATE, PARAMETER :: k1 = 0.065_dp
147 : : REAL(dp), PRIVATE, PARAMETER :: mu = 10._dp/81._dp
148 : : REAL(dp), PRIVATE, PARAMETER :: SCANa1 = 4.9479_dp
149 : : REAL(dp) :: eta
150 : : REAL(dp), PRIVATE, PARAMETER :: dp2 = 0.361_dp
151 : : REAL(dp) :: C2Ceta
152 : : REAL(dp), PRIVATE, PARAMETER :: cc0 = 1._dp
153 : : REAL(dp), PRIVATE, PARAMETER :: cc1 = -0.64_dp
154 : : REAL(dp), PRIVATE, PARAMETER :: cc2 = -0.4352_dp
155 : : REAL(dp), PRIVATE, PARAMETER :: cc3 = -1.535685604549_dp
156 : : REAL(dp), PRIVATE, PARAMETER :: cc4 = 3.061560252175_dp
157 : : REAL(dp), PRIVATE, PARAMETER :: cc5 = -1.915710236206_dp
158 : : REAL(dp), PRIVATE, PARAMETER :: cc6 = 0.516884468372_dp
159 : : REAL(dp), PRIVATE, PARAMETER :: cc7 = -0.051848879792_dp
160 : : REAL(dp), PRIVATE, PARAMETER :: SCANc1c = 0.64_dp
161 : : REAL(dp), PRIVATE, PARAMETER :: SCANc2c = 1.5_dp
162 : : REAL(dp), PRIVATE, PARAMETER :: SCANdc = 0.7_dp
163 : : REAL(dp), PRIVATE, PARAMETER :: b1c = 0.0285764_dp
164 : : REAL(dp), PRIVATE, PARAMETER :: b2c = 0.0889_dp
165 : : REAL(dp), PRIVATE, PARAMETER :: b3c = 0.125541_dp
166 : : REAL(dp), PRIVATE, PARAMETER :: betaMB = 0.066725_dp
167 : : REAL(dp), PRIVATE, PARAMETER :: chiinfinity = 0.12802585262625815_dp
168 : : REAL(dp), PRIVATE, PARAMETER :: Sgam = 0.031090690869655_dp
169 : : REAL(dp), PRIVATE, PARAMETER :: Dfc2=cc1+2*cc2+3*cc3+4*cc4+5*cc5+6*cc6+7*cc7
170 : : ! Parameters for the Perdew-Wang (PRB 45,13244 (1992)) LDA correlation
171 : : REAL(dp), PRIVATE, PARAMETER :: LDAA = 0.03109070_dp
172 : : REAL(dp), PRIVATE, PARAMETER :: LDAa1 = 0.21370_dp
173 : : REAL(dp), PRIVATE, PARAMETER :: LDAb1 = 7.59570_dp
174 : : REAL(dp), PRIVATE, PARAMETER :: LDAb2 = 3.58760_dp
175 : : REAL(dp), PRIVATE, PARAMETER :: LDAb3 = 1.63820_dp
176 : : REAL(dp), PRIVATE, PARAMETER :: LDAb4 = 0.49294_dp
177 : :
178 : :
179 : :
180 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
181 : : ! PRIVATE DATA TYPES IMPORTED FROM ATOMPAW
182 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
183 : :
184 : :
185 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
186 : : !! mesh_data
187 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
188 : : type mesh_data_type
189 : : integer :: mesh_type ! Default type of meshes (lin. or log.)
190 : : integer :: nmesh ! Number of meshes
191 : : integer :: iwavmesh ! Index of mesh for partial waves
192 : : integer :: iprjmesh ! Index of mesh for projectors
193 : : integer :: icoremesh ! Index of mesh for core density
194 : : integer :: itaumesh ! Index of mesh for kinetic energy core density
195 : : integer :: ivionmesh ! Index of mesh for vion potential
196 : : integer :: ivbaremesh ! Index of mesh for vbare potential
197 : : integer :: ivlda12mesh ! Index of mesh for LDA-1/2 potential
198 : : integer :: ivalemesh ! Index of mesh for valence density
199 : : integer :: wav_meshsz ! Size of mesh for partial waves
200 : : integer :: sph_meshsz ! Size of mesh for partial waves
201 : : integer :: prj_meshsz ! Size of mesh for projectors
202 : : integer :: core_meshsz ! Size of mesh for core density
203 : : integer :: tau_meshsz ! Size of mesh for kinetic energy core density
204 : : integer :: vion_meshsz ! Size of mesh for vion potential
205 : : integer :: vbare_meshsz ! Size of mesh for vbare potential
206 : : integer :: vlda12_meshsz ! Size of mesh for LDA-1/2 potential
207 : : integer :: vale_meshsz ! Size of mesh for valence density
208 : : integer :: prj_msz_max ! Maximum size for projector (used for RSO)
209 : : real(dp) :: rad_step ! Default value for radial step
210 : : real(dp) :: log_step ! Default value for log step
211 : : integer,allocatable :: meshtp(:) ! Array storing mesh type for all meshes
212 : : integer,allocatable :: meshsz(:) ! Array storing mesh size for all meshes
213 : : real(dp),allocatable :: radstp(:) ! Array storing radial step for all meshes
214 : : real(dp),allocatable :: logstp(:) ! Array storing log step for all meshes
215 : : end type mesh_data_type
216 : :
217 : :
218 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
219 : : !! GridInfo
220 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
221 : : type,private :: GridInfo
222 : : integer :: type
223 : : integer :: n
224 : : integer :: ishift
225 : : real(dp) :: h,r0,range
226 : : real(dp), pointer :: r(:) => null()
227 : : real(dp), pointer :: drdu(:) => null() ! for loggrid -- dr/du
228 : : real(dp), pointer :: pref(:) => null() ! for loggrid -- r0*exp(u/2)
229 : : real(dp), pointer :: rr02(:) => null() ! for loggrid -- (r+r0)**2
230 : : end type GridInfo
231 : :
232 : :
233 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
234 : : !! OrbitInfo
235 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
236 : : type,private :: OrbitInfo
237 : : character(132) :: exctype
238 : : integer :: nps, npp, npd ,npf, npg, norbit
239 : : integer :: npsc, nppc, npdc ,npfc, npgc
240 : : INTEGER, POINTER :: np(:) => null()
241 : : INTEGER, POINTER :: l(:) => null()
242 : : INTEGER, POINTER :: kappa(:) => null()
243 : : real(dp), POINTER :: eig(:) => null()
244 : : real(dp), POINTER :: occ(:) => null()
245 : : real(dp), POINTER :: wfn(:,:) => null()
246 : : real(dp), POINTER :: lwfn(:,:) => null()
247 : : real(dp), POINTER :: otau(:,:) => null() ! kinetic energy density for orbital
248 : : real(dp), POINTER :: lqp(:,:) => null() ! only used for HF
249 : : real(dp), POINTER :: X(:,:) => null() ! identical to HF%SumY(:,:)
250 : : LOGICAL, POINTER :: iscore(:) => null()
251 : : LOGICAL, POINTER :: issemicore(:) => null()
252 : : real(dp),POINTER :: den(:) => null() ! accumulated over states
253 : : real(dp),POINTER :: tau(:) => null() ! accumulated over states
254 : : real(dp),POINTER :: deltatau(:) => null() !tau-tauW (tauW==Weizsacker)
255 : : ! LIBPAW specific
256 : : real(dp),POINTER :: coreden(:) => null()
257 : : real(dp),POINTER :: valeden(:) => null()
258 : : real(dp) :: qval
259 : : logical :: frozencorecalculation
260 : : logical :: frozenvalecalculation
261 : : logical :: diracrelativistic
262 : : logical :: scalarrelativistic
263 : : end type OrbitInfo
264 : :
265 : :
266 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
267 : : !! PotentialInfo
268 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
269 : : type,private :: PotentialInfo
270 : : character(2) :: sym
271 : : integer :: nz ! nz is nuclear charge
272 : : real(dp) :: zz ! zz=nz is nuclear charge
273 : : real(dp) :: q,v0,v0p ! q is total electron charge
274 : : ! v0,v0p are potential value and deriv at r=0
275 : : real(dp) :: Nv0,Nv0p ! finite nucleus value and deriv at 0
276 : : real(dp) , pointer :: rv(:) => null()
277 : : real(dp) , pointer :: rvn(:) => null()
278 : : real(dp) , pointer :: rvh(:) => null()
279 : : real(dp) , pointer :: rvx(:) => null()
280 : : ! rv(n) is veff * r
281 : : ! rvh is hartree potential for den
282 : : ! rvn is nuclear potential
283 : : ! rvx is exchange-correlation potential
284 : : real(dp) , pointer :: vtau(:) => null() !for meta-gga
285 : : integer :: finitenucleusmodel
286 : : ! Based on models 2, 3, 4, 5 discussed by Dirk Anrae ,
287 : : ! Physics Reports 336 (2000) 413-525
288 : : ! default is 0 for previous Gaussian model
289 : : ! for finitenucleusmodel<0, finite nucleus is false
290 : : ! LIBPAW specific
291 : : logical :: finitenucleus
292 : : logical :: needvtau
293 : : real(dp),allocatable :: ww(:)
294 : : real(dp), allocatable :: jj(:)
295 : : end type PotentialInfo
296 : :
297 : :
298 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
299 : : !! SCFInfo
300 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
301 : : type,private :: SCFInfo
302 : : integer :: iter
303 : : real(dp) :: delta,eone,ekin,estatic,ecoul,eexc,oepcs,etot
304 : : real(dp) :: valekin,valecoul,valeexc,corekin,evale ! used in frozencore only
305 : : end type SCFInfo
306 : :
307 : :
308 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
309 : : !! Anderson_Context
310 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
311 : : TYPE,private :: Anderson_Context !** Anderson Mixing context
312 : : real(dp) :: NewMix !** Amount of new vectors to mix, ie beta in paper.
313 : : INTEGER :: Nmax !** Max number of vectors to keep
314 : : INTEGER :: N !** Current number of vectors in list
315 : : INTEGER :: Slot !** New fill Slot
316 : : INTEGER :: VecSize !** Size of each vector
317 : : INTEGER :: Err_Unit !** Error unit
318 : : INTEGER :: MaxIter !** MaxIter
319 : : INTEGER :: CurIter !** Running iteration index
320 : : real(dp) :: err !** residue convergence tolerance
321 : : real(dp) :: toosmall !** solution obviously converged
322 : : real(dp) :: res !** Running convergence error
323 : : Logical :: writelots
324 : : real(dp), POINTER :: Matrix(:,:)
325 : : real(dp), POINTER :: Gamma(:) !** Gamma as defined in 7.6
326 : : real(dp), POINTER :: DF(:,:) !** Delta F
327 : : real(dp), POINTER :: Fprev(:)
328 : : real(dp), POINTER :: DX(:,:)
329 : : real(dp), POINTER :: Xprev(:)
330 : : ! temporary constants and arrays needed for each call to Anderson_Mix
331 : : INTEGER, POINTER :: IPIV(:)
332 : : real(dp), POINTER :: S(:)
333 : : real(dp), POINTER :: RWork(:)
334 : : real(dp), POINTER :: U(:,:)
335 : : real(dp), POINTER :: VT(:,:)
336 : : real(dp), POINTER :: Work(:)
337 : : real(dp), POINTER :: DupMatrix(:,:)
338 : : INTEGER :: Lwork
339 : : INTEGER :: LRwork
340 : : real(dp) :: ConditionNo
341 : : real(dp) :: MachAccur
342 : : END TYPE Anderson_Context
343 : :
344 : :
345 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
346 : : !! PseudoInfo
347 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
348 : : TYPE,private :: Pseudoinfo
349 : : CHARACTER(132) :: exctype
350 : : INTEGER :: lmax,irc,irc_shap,irc_vloc,irc_core,coretailpoints,mesh_size
351 : : INTEGER :: ivale,itau,ivion,mxbase
352 : : CHARACTER(15) :: orthogonalization_scheme
353 : : CHARACTER(132) :: Vloc_description
354 : : CHARACTER(132) :: Proj_description
355 : : CHARACTER(132) :: Comp_description
356 : : LOGICAL :: multi_rc,poscorenhat
357 : : real(dp) :: rc,rc_shap,rc_vloc,rc_core,energyoflmax,gausslength
358 : : real(dp), POINTER :: rcio(:) => null()
359 : : real(dp), POINTER :: vloc(:) => null()
360 : : real(dp), POINTER :: abinitvloc(:) => null()
361 : : real(dp), POINTER :: abinitnohat(:) => null()
362 : : real(dp), POINTER :: rveff(:) => null()
363 : : real(dp), POINTER :: AErefrv(:) => null()
364 : : real(dp), POINTER :: rvx(:) => null()
365 : : real(dp), POINTER :: trvx(:) => null()
366 : : real(dp), POINTER :: Ktvtau(:) => null()
367 : : real(dp), POINTER :: Krveff(:) => null()
368 : : real(dp), POINTER :: Kunscreen(:) => null() ! Kresse form
369 : : real(dp), POINTER :: projshape(:) => null()
370 : : real(dp), POINTER :: hatshape(:) => null()
371 : : real(dp), POINTER :: hatden(:) => null()
372 : : real(dp), POINTER :: hatpot(:) => null()
373 : : real(dp), POINTER :: den(:) => null()
374 : : real(dp), POINTER :: tden(:) => null()
375 : : real(dp), POINTER :: core(:) => null()
376 : : real(dp), POINTER :: tcore(:) => null()
377 : : real(dp), POINTER :: nhatv(:) => null()
378 : : real(dp), POINTER :: coretau(:) => null()
379 : : real(dp), POINTER :: tcoretau(:) => null()
380 : : real(dp), POINTER :: valetau(:) => null()
381 : : real(dp), POINTER :: tvaletau(:) => null()
382 : : real(dp), POINTER :: vtau(:) => null()
383 : : real(dp), POINTER :: tvtau(:) => null()
384 : : INTEGER :: nbase,ncoreshell
385 : : INTEGER, POINTER :: np(:) => null()
386 : : INTEGER, POINTER :: l(:) => null()
387 : : INTEGER, POINTER :: nodes(:) => null()
388 : : INTEGER, POINTER :: kappa(:) => null()
389 : : INTEGER, POINTER :: rng(:) => null() ! rng particularly of continuum states
390 : : CHARACTER(8), POINTER :: label(:) => null()
391 : : real(dp), POINTER :: phi(:,:) => null()
392 : : real(dp), POINTER :: tphi(:,:) => null()
393 : : real(dp), POINTER :: tp(:,:) => null() ! before orthog
394 : : real(dp), POINTER :: ophi(:,:) => null()
395 : : real(dp), POINTER :: otphi(:,:) => null()
396 : : real(dp), POINTER :: otp(:,:) => null() ! after orthog
397 : : real(dp), POINTER :: Kop(:,:) => null() ! for storing K|phi>
398 : : real(dp), POINTER :: eig(:) => null()
399 : : real(dp), POINTER :: occ(:) => null()
400 : : real(dp), POINTER :: ck(:) => null()
401 : : real(dp), POINTER :: vrc(:) => null()
402 : : real(dp), POINTER :: oij(:,:) => null()
403 : : real(dp), POINTER :: dij(:,:) => null()
404 : : real(dp), POINTER :: wij(:,:) => null()
405 : : !********** modified parameters for use with KS and HF
406 : : real(dp), POINTER :: rVf(:) => null()
407 : : real(dp), POINTER :: rtVf(:) => null()
408 : : real(dp), POINTER :: g(:,:) => null()
409 : : real(dp), POINTER :: Kij(:,:) => null()
410 : : real(dp), POINTER :: Vfij(:,:) => null()
411 : : real(dp), POINTER :: mLij(:,:,:) => null()
412 : : real(dp), POINTER :: DR(:,:,:,:,:) => null()
413 : : real(dp), POINTER :: DRVC(:,:,:) => null()
414 : : real(dp), POINTER :: TXVC(:,:) => null() ! now output for DFT also
415 : : real(dp) :: lambshielding
416 : : real(dp) :: XCORECORE ! output for DFT
417 : : INTEGER, POINTER :: valencemap(:) => null() ! valencemap({occ. states})={basis}
418 : : Type(OrbitInfo), POINTER :: OCCwfn => null()
419 : : Type(OrbitInfo), POINTER :: TOCCwfn => null()
420 : : real(dp) :: tkin,tion,tvale,txc,Ea,Etotal,Eaion,Eaionhat,Eaxc
421 : : real(dp) :: VlocCoef,VlocRad
422 : : !***********for HF only
423 : : real(dp), POINTER :: lmbd(:,:) => null() !(Eq. 72) lmbd({occ. states},{basis states})
424 : : real(dp), POINTER :: DRC(:,:,:,:) => null()
425 : : real(dp), POINTER :: mLic(:,:,:) => null()
426 : : real(dp), POINTER :: DRCC(:,:,:,:) => null()
427 : : real(dp), POINTER :: DRCjkl(:,:,:,:,:) => null()
428 : : real(dp), POINTER :: mLcc(:,:,:) => null()
429 : : real(dp), POINTER :: Dcj(:,:) => null()
430 : : real(dp) :: coretol
431 : : END TYPE Pseudoinfo
432 : :
433 : :
434 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
435 : : !! PseudoInfo
436 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
437 : : TYPE,private :: splinesolvinfo
438 : : INTEGER :: ns ! # spline nodes, not including origin
439 : : REAL(dp) :: r0,h
440 : : real(dp),allocatable :: u(:)
441 : : real(dp),allocatable :: pref(:)
442 : : real(dp),allocatable :: rr1(:)
443 : : real(dp),allocatable :: rr2(:)
444 : : real(dp),allocatable :: srv(:)
445 : : real(dp),allocatable :: svtau(:)
446 : : real(dp),allocatable :: sdvt(:)
447 : : real(dp),allocatable :: soneplusvt(:)
448 : : real(dp),allocatable :: fvtau(:)
449 : : real(dp),allocatable :: fdvtaudr(:)
450 : : real(dp),allocatable :: frvx(:)
451 : : real(dp),allocatable :: fden(:)
452 : : real(dp),allocatable :: ftau(:)
453 : : type(GridInfo) :: Grids
454 : : type(GridInfo) :: Gridf
455 : : END TYPE splinesolvinfo
456 : :
457 : :
458 : :
459 : :
460 : :
461 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
462 : : ! PUBLIC DATATYPES
463 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
464 : :
465 : :
466 : : !----------------------------------------------------------------------
467 : : !!***
468 : : !!****t* m_paw_atom_solve/atompaw_type
469 : : !! NAME
470 : : !! atompaw_type
471 : : !!
472 : : !! FUNCTION
473 : : !! Stores data in atompaw format, including:
474 : : !! -Input that was used to create the original PAW potentials
475 : : !! -Current spherical average of the valence band electron density
476 : : !! -Previous core charge density to be used as starting point
477 : : !! -All data needed for solving the atomic problem
478 : : !! -All data needed for pseudoization
479 : : !!
480 : : !! COPYRIGHT
481 : : !! This module is
482 : : !!
483 : : !! SOURCE
484 : : type,public :: atompaw_type
485 : : !!! Initialized in read input roughly in this order
486 : : ! Atom
487 : : CHARACTER(2) :: atomic_symbol ! Atomic symbol
488 : : INTEGER :: atomic_charge
489 : : ! Algo
490 : : logical :: scalarrelativistic
491 : : logical :: diracrelativistic
492 : : logical :: usespline
493 : : INTEGER :: splns=400 ! Spline interpolation grid length
494 : : real(dp) :: splr0=0.1_dp ! Spline interpolation r0 value
495 : : logical :: BDsolve
496 : : logical :: HFpostprocess
497 : : logical :: finitenucleus
498 : : integer :: finitenucleusmodel
499 : : ! Grid
500 : : CHARACTER(10) :: gridkey
501 : : INTEGER :: gridpoints ! Number of points of the radial grid
502 : : real(dp) :: gridrange ! Range of the radial grid
503 : : real(dp) :: gridmatch ! A matching radius in the radial grid
504 : : real(dp) :: minlogderiv
505 : : real(dp) :: maxlogderiv
506 : : integer :: nlogderiv
507 : : ! XC
508 : : CHARACTER(132) :: exctype ! Exchange-correlation type (string)
509 : : real(dp) :: temp ! temeprature
510 : : LOGICAL :: needvtau ! TRUE if Calculation is performed with full kinetic energy functional
511 : : logical :: localizedcoreexchange
512 : : LOGICAL :: fixed_zero ! Flag activating the "fixed zero" exact exchange potential calculation
513 : : INTEGER :: fixed_zero_index ! Option for "fixed zero" calculation in the exact exchange potential
514 : : type(libxc_functional_type) :: xc_functionals(2)
515 : : ! Electronic config
516 : : INTEGER :: np(5) ! Electronic configuration: number of s,p,d,f,g shells
517 : : INTEGER :: norbit ! Electronic configuration: number of orbitals
518 : : INTEGER :: norbit_mod ! Electronic configuration: number of orbitals with modified occupations
519 : : INTEGER,ALLOCATABLE :: orbit_mod_n(:) ! Electronic config.: n number of the modified orbital
520 : : INTEGER,ALLOCATABLE :: orbit_mod_l(:) ! Electronic config.: l number of the modified orbital
521 : : INTEGER,ALLOCATABLE :: orbit_mod_k(:) ! Electronic config.: kappa number of the modified orbital
522 : : real(dp),ALLOCATABLE :: orbit_mod_occ(:) ! Electronic config.: occupation of the modified orbital
523 : : LOGICAL,ALLOCATABLE :: orbit_iscore(:) ! Electronic configuration: TRUE for the core orbitals
524 : : INTEGER :: norbit_val ! Electronic configuration: number of valence orbitals
525 : : INTEGER,ALLOCATABLE :: orbit_val_n(:) ! Electronic config.: n number of the valence orbital
526 : : INTEGER,ALLOCATABLE :: orbit_val_l(:) ! Electronic config.: l number of the valence orbital
527 : : INTEGER,ALLOCATABLE :: orbit_val_k(:) ! Electronic config.: kappa number of the valence orbital
528 : : INTEGER :: lmax=-1 ! PAW Basis: maximum l value
529 : : ! Cutoff radii
530 : : real(dp) :: rc=0._dp ! PAW basis: cut-off radius for the augmentation regions
531 : : real(dp) :: rc_shap=0._dp ! PAW basis: cut-off radius of the compensation charge shape function
532 : : real(dp) :: rc_vloc=0._dp ! PAW basis: matching radius for the local potential
533 : : real(dp) :: rc_core=0._dp ! PAW basis: matching radius for the pseudo-core density
534 : : ! Additional basis functions
535 : : INTEGER :: nbasis ! PAW basis : number of basis functions
536 : : INTEGER :: nbasis_add ! PAW basis: number of additional basis functions (unbound states)
537 : : INTEGER,ALLOCATABLE :: basis_add_l(:) ! PAW basis: l number for the additional basis func.
538 : : INTEGER,ALLOCATABLE :: basis_add_k(:) ! PAW basis: kappa number for the additional basis func.
539 : : real(dp),ALLOCATABLE :: basis_add_energy(:) ! PAW basis: ref. energy for the additional basis func.
540 : : real(dp),ALLOCATABLE :: basis_func_rc(:) ! PAW basis: rcut for the additional basis func.
541 : : ! Projectors
542 : : INTEGER :: projector_type ! Type of projectors (Bloechl, Vanderbilt,...)
543 : : INTEGER :: pseudo_type ! Type of pseudization scheme (Bessel,polynom, ...)
544 : : INTEGER :: ortho_type ! Type of orthogonalization scheme(Gram-Schmidt, ...)
545 : : INTEGER :: pseudo_polynom2_pdeg ! Polynom2 projectors: degree of the polynom
546 : : real(dp) :: pseudo_polynom2_qcut ! Polynom2 projectors: q-value for Fourier filtering
547 : : INTEGER :: shapefunc_type ! Compensation shape function type (sinc2, gaussian, ...)
548 : : real(dp) :: shapefunc_gaussian_param ! Compensation shape function: parameter for gaussian type
549 : : real(dp) :: hf_coretol ! Tolerance for core density (Hartree-Fock only)
550 : : LOGICAL :: shapetcore ! Flag activating building of tcore cancelling a negative compensation charge
551 : : ! Local Psp
552 : : INTEGER :: vloc_type ! Type of local potential pseudization
553 : : INTEGER :: vloc_l ! Local potential: l quantum number (MTrouillier, Ultrasoft)
554 : : real(dp) :: vloc_ene ! Local potential: reference energy (MTrouillier, Ultrasoft)
555 : : real(dp) :: vloc_setvloc_coef ! "SetVloc" local potential: coefficient
556 : : real(dp) :: vloc_setvloc_rad ! "SetVloc" local potential: radius
557 : : INTEGER :: vloc_kerker_power(4) ! "Kerker" locazl potential: polynomial powers
558 : : ! LIBPAW specific
559 : : logical :: frozencorecalculation
560 : : logical :: frozenvalecalculation
561 : : logical :: setupfrozencore
562 : : logical :: gaussianshapefunction
563 : : logical :: besselshapefunction
564 : : logical :: ColleSalvetti
565 : : integer :: itype
566 : : integer :: ixc
567 : : integer :: xclevel
568 : : integer :: npsc,nppc,npdc,npfc,npgc
569 : : integer :: vhtnzc_mode, tpaw_mode, elin_mode
570 : : real(dp) :: electrons
571 : : real(dp) :: pot_ref
572 : : real(dp), allocatable :: pot_refo(:)
573 : : type(GridInfo) :: Grid
574 : : TYPE(OrbitInfo) :: Orbit
575 : : TYPE(PotentialInfo) :: Pot
576 : : TYPE(SCFInfo) :: SCF
577 : : TYPE(Pseudoinfo) :: PAW
578 : : type(splinesolvinfo) :: spline
579 : : character*(10000) :: input_string
580 : : logical :: prtpaw
581 : : end type atompaw_type
582 : : !!***
583 : :
584 : :
585 : :
586 : :
587 : :
588 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
589 : : ! PUBLIC SUBROUTINES
590 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
591 : :
592 : :
593 : : !!***
594 : : public :: atompaw_solve ! Solve the atomic problem at fixed valence
595 : : public :: atompaw_init ! Init the atompaw solver
596 : : public :: atompaw_destroy ! Destroy the atomic solver
597 : : !!***
598 : :
599 : :
600 : : CONTAINS !===========================================================
601 : : !!***
602 : :
603 : :
604 : : !!****f* m_paw_atom_solve/atompaw_solve
605 : : !! NAME
606 : : !! atompaw_solve
607 : : !!
608 : : !! FUNCTION
609 : : !! Solve the atomic problem (at fixed valence) and update relevant quantities
610 : : !!
611 : : !! OUTPUT
612 : : !!
613 : : !! SIDE EFFECTS
614 : : !!
615 : : !! NOTES
616 : : !!
617 : : !! SOURCE
618 : : !! Inspired from atompaw program
619 : :
620 : 19 : subroutine atompaw_solve(atp,pawrad,pawtab,&
621 [ - + - + ]: 19 : & nval,tnval,mqgrid_vl,qgrid_vl,epsatm,vlspl,&
622 : : & zion,update_paw,update_tnc,atm)
623 : :
624 : : ! TODO : vtau,dirac
625 : : implicit none
626 : :
627 : : !Arguments ------------------------------------
628 : : !scalars
629 : : integer, intent(in) :: mqgrid_vl
630 : : logical,intent(in) :: update_paw,update_tnc
631 : : real(dp), intent(inout) :: epsatm
632 : : real(dp), intent(inout) :: zion
633 : : type(atompaw_type), intent(inout) :: atp
634 : : type(pawrad_type),intent(in) :: pawrad
635 : : type(pawtab_type),intent(inout) :: pawtab
636 : : type(atomorb_type), intent(inout) :: atm
637 : : !arrays
638 : : real(dp), intent(in) :: nval(:),tnval(:)
639 : : real(dp), intent(in) :: qgrid_vl(mqgrid_vl)
640 : : real(dp),intent(out) :: vlspl(mqgrid_vl,2)
641 : : !Local variables-------------------------------
642 : : !scalars
643 : : character*(132) :: file_xml
644 : : integer :: io,ir,icor,io2,irc_max,vlocopt,irc
645 : : logical :: success,paw_proj
646 : : character(len=500) :: msg
647 : : real(dp) :: insph,norm,potshift,ovl,f1,fp1,dx,c4,c2
648 : : real(dp) :: yp1,ypn,ekin,delta_zcore,int_pot
649 : 19 : type(mesh_data_type) :: mesh_data
650 : : !arrays
651 : 19 : real(dp),ALLOCATABLE:: coredens(:),tcoredens(:),vhnzc_tmp(:)
652 : 19 : real(dp),ALLOCATABLE:: ff(:)
653 : 19 : type(pawrad_type) :: radmesh,vloc_mesh
654 : 19 : real(dp) , allocatable :: nhatc(:),vhatc(:)
655 : :
656 : : ! *************************************************************************
657 : :
658 : : ! Put valence density and core occupations to atompaw objects
659 [ - + + - : 57 : LIBPAW_ALLOCATE(coredens,(size(atp%Orbit%coreden)))
+ - + - -
+ - + ]
660 [ + + ]: 38038 : atp%Orbit%valeden=zero
661 [ + + ]: 38038 : atp%PAW%den=zero
662 [ + + ]: 38038 : atp%PAW%tden=zero
663 [ + + ]: 26913 : do io=1,pawtab%mesh_size
664 : 26894 : atp%PAW%den(io)=nval(io)
665 : 26894 : atp%Orbit%valeden(io)=nval(io)
666 : 26913 : atp%PAW%tden(io)=tnval(io)
667 : : enddo
668 [ + + + - : 38038 : if(any(atp%PAW%tden<zero)) then
- + ]
669 : 0 : write(std_out,*) 'atompaw_solve : tden is negative for some r ! Smoothening den instead'
670 : 0 : call smoothpower(atp%Grid,2,atp%PAW%den,atp%PAW%tden,atp%PAW)
671 : : endif
672 [ + + ]: 38038 : atp%Orbit%den=atp%Orbit%valeden+atp%Orbit%coreden
673 [ + - - + : 38057 : coredens=atp%Orbit%coreden
- - - - +
+ ]
674 : 19 : delta_zcore=zero
675 : 19 : icor=0
676 [ + + ]: 131 : do io=1,atp%Orbit%norbit
677 [ + + ]: 131 : if(atp%Orbit%iscore(io)) then
678 : 58 : icor=icor+1
679 : 58 : delta_zcore=delta_zcore-atp%Orbit%occ(io)
680 : 58 : atp%Orbit%occ(io)=atm%occ(icor,1)
681 : 58 : delta_zcore=delta_zcore+atp%Orbit%occ(io)
682 : : endif
683 : : enddo
684 : :
685 : : ! ! Solve atomic problem
686 [ + - ]: 19 : if(.not.atm%nc_conv) then
687 : 19 : call SCFatom(atp,.false.)
688 : : endif
689 : :
690 : : ! update core wfs and eigen energies
691 : 19 : icor=0
692 [ + + ]: 131 : do io=1,atp%Orbit%norbit
693 [ + + ]: 131 : if(atp%Orbit%iscore(io)) then
694 : 58 : icor=icor+1
695 [ + - ]: 58 : if(.not.atm%nc_conv) then
696 [ + + ]: 116 : atm%eig(icor,:)=atp%Orbit%eig(io)*half
697 : : endif
698 [ + + ]: 82170 : do ir=1,pawtab%mesh_size
699 : 82170 : atm%phi(ir,icor,1)=atp%Orbit%wfn(ir,io)
700 : : enddo
701 : : endif
702 : : enddo
703 : :
704 [ + + ]: 19 : if(.not.atp%diracrelativistic) then
705 : 18 : call pawrad_init(radmesh,atp%Grid%n,pawrad%mesh_type,pawrad%rstep,pawrad%lstep)
706 [ - + + - : 54 : LIBPAW_ALLOCATE(ff,(atp%grid%n))
+ - + - -
+ - + ]
707 : : ! Compute new core density
708 : 18 : write(msg,'(a)') 'atompaw_solve: orbital,%out sphere'
709 : 18 : call wrtout(std_out,msg,'COLL')
710 [ + + ]: 36036 : atp%Orbit%coreden=zero
711 : 18 : icor=0
712 [ + + ]: 120 : do io=1,atp%Orbit%norbit
713 [ + + ]: 120 : if(atp%Orbit%iscore(io)) then
714 : 54 : icor=icor+1
715 : 54 : norm=overlap(atp%Grid,atp%Orbit%wfn(1:atp%Grid%n,io),atp%Orbit%wfn(1:atp%Grid%n,io),1,atp%Grid%n)
716 : 54 : insph=overlap(atp%Grid,atp%Orbit%wfn(1:atp%PAW%irc,io),atp%Orbit%wfn(1:atp%PAW%irc,io),1,atp%PAW%irc)
717 : 54 : write(msg,*)io,(one -insph/norm)*100.0_dp
718 : 54 : call wrtout(std_out,msg,'COLL')
719 [ + + ]: 108108 : atp%Orbit%coreden=atp%Orbit%coreden+atp%Orbit%occ(io)*(atp%Orbit%wfn(:,io))**2
720 : : endif
721 : : enddo
722 : :
723 : : ! Compute residue
724 [ + - ]: 18 : if(.not.atm%nc_conv) then
725 [ + + ]: 36036 : ff(1:atp%Grid%n)=(atp%Orbit%coreden(1:atp%Grid%n)-coredens(1:atp%Grid%n))**2
726 : 18 : atm%nresid_c=sqrt(integrator(atp%Grid,ff)/atp%grid%r(atp%grid%n))
727 [ + + ]: 36036 : ff(1:atp%Grid%n)=atp%Orbit%coreden(1:atp%Grid%n)
728 [ + - ]: 18 : if(integrator(atp%Grid,ff)/=zero) then
729 : 18 : atm%nresid_c=atm%nresid_c/integrator(atp%Grid,ff)
730 : : else
731 : 0 : atm%nresid_c=one
732 : : endif
733 : 18 : write(msg,*) 'atompaw_solve: nc residue',atm%nresid_c
734 : 18 : call wrtout(std_out,msg,'COLL')
735 : : endif
736 : :
737 : : ! Update core dens
738 [ + + ]: 36018 : do ir=2,atp%Grid%n
739 : 36018 : coredens(ir)=atp%Orbit%coreden(ir)/(four*pi*atp%Grid%r(ir)**2)
740 : : enddo
741 : 18 : call extrapolate(coredens)
742 [ + + ]: 25482 : do ir=1,size(pawtab%coredens)
743 : 25482 : pawtab%coredens(ir)=coredens(ir)
744 : : enddo
745 : :
746 : : ! Update vhnzc
747 [ - + + - : 54 : LIBPAW_ALLOCATE(vhnzc_tmp,(radmesh%mesh_size))
+ - + - -
+ - + ]
748 [ + + ]: 36036 : vhnzc_tmp=zero
749 : 18 : call atompaw_vhnzc(coredens,radmesh,vhnzc_tmp,atm%znucl)
750 [ + + ]: 25482 : do ir=1,size(pawtab%vhnzc)
751 : 25482 : pawtab%vhnzc(ir)=vhnzc_tmp(ir)
752 : : enddo
753 [ - + ]: 18 : LIBPAW_DEALLOCATE(vhnzc_tmp)
754 : :
755 : : ! Update edcc
756 [ + + ]: 36036 : ff=zero
757 [ + + ]: 36018 : ff(2:atp%Grid%n)=atp%Pot%rv(2:atp%Grid%n)*coredens(2:atp%Grid%n)*atp%Grid%r(2:atp%Grid%n)*four_pi
758 : 18 : CALL extrapolate(ff)
759 : 18 : atm%edcc=integrator(atp%Grid,ff)/two
760 [ - + ]: 18 : LIBPAW_DEALLOCATE(ff)
761 : :
762 : : ! Update ehnzc
763 : 18 : call atompaw_ehnzc(coredens,radmesh,atm%ehnzc,atm%znucl)
764 : :
765 : : ! update core kinetic energy
766 : 18 : atm%ekinc=zero
767 : 18 : atm%eeigc=zero
768 : 18 : icor=0
769 [ + + ]: 120 : do io=1,atp%Orbit%norbit
770 [ + + ]: 120 : if(atp%Orbit%iscore(io)) then
771 : 54 : icor=icor+1
772 : 54 : CALL altkinetic(atp%Grid,atp%Orbit%wfn(:,io),atp%Orbit%eig(io),atp%Pot%rv,ekin)
773 : 54 : atm%ekinc=atm%ekinc+ekin/two*atp%Orbit%occ(io)
774 : 54 : atm%eeigc=atm%eeigc+atp%Orbit%eig(io)*half*atp%Orbit%occ(io)
775 : : endif
776 : : enddo
777 : :
778 : : ! Update tnc
779 [ + - ]: 18 : if(update_tnc) then
780 : : ! Compute new tnc
781 : 18 : call setcoretail(atp%Grid,atp%Orbit%coreden,atp%PAW,atp%needvtau)
782 [ - + + - : 54 : LIBPAW_ALLOCATE(tcoredens,(atp%Grid%n))
+ - + - -
+ - + ]
783 [ + + ]: 36018 : do ir=2,atp%Grid%n
784 : 36018 : tcoredens(ir)=atp%PAW%tcore(ir)/(four*pi*atp%Grid%r(ir)**2)
785 : : enddo
786 : 18 : call extrapolate(tcoredens)
787 : : ! Update tnc
788 [ + + ]: 25482 : do ir=1,pawtab%mesh_size
789 : 25482 : pawtab%tcoredens(ir,1)=tcoredens(ir)
790 : : enddo
791 : 18 : call pawpsp_cg(pawtab%dncdq0,pawtab%d2ncdq0,mqgrid_vl,qgrid_vl,pawtab%tcorespl(:,1),radmesh,tcoredens,yp1,ypn)
792 : 18 : call paw_spline(qgrid_vl,pawtab%tcorespl(:,1),mqgrid_vl,yp1,ypn,pawtab%tcorespl(:,2))
793 [ - + ]: 18 : LIBPAW_DEALLOCATE(tcoredens)
794 : : endif
795 : :
796 : : ! Update PAW stuff
797 [ + + - + ]: 18 : if(update_paw.or.atp%vhtnzc_mode==2) then
798 : : ! Compute potential shift
799 [ + - ]: 2 : if(atp%elin_mode==1) then
800 [ + - + + ]: 2839 : call simp_gen(int_pot,atp%Pot%rv(1:pawtab%mesh_size)*pawrad%rad(1:pawtab%mesh_size)*pawtab%shapefunc(1:pawtab%mesh_size,1),pawrad)
801 : 2 : potshift=int_pot-atp%pot_ref
802 : : else
803 : 0 : LIBPAW_ERROR('NOT ready yet')
804 : : endif
805 [ + + ]: 4004 : do io=1,atp%Grid%n
806 : 4002 : atp%Pot%rvh(io)=atp%Pot%rvh(io)-potshift*atp%Grid%r(io)
807 : 4004 : atp%Pot%rv(io)=atp%Pot%rv(io)-potshift*atp%Grid%r(io)
808 : : enddo
809 : 2 : atp%Pot%v0=atp%Pot%v0-potshift
810 : 2 : call setbasis(atp%Grid,atp%Pot,atp%Orbit,atp%PAW,atp,potshift)
811 : 2 : call SetPAWOptions2(atp,success)
812 : : ! Update PAW transform
813 [ + - ]: 2 : if(update_paw) then
814 [ - + ]: 2 : if(atp%tpaw_mode>1) then
815 [ # # # # ]: 0 : if(atp%scalarrelativistic.or.atp%diracrelativistic) then
816 : 0 : LIBPAW_ERROR('tpaw>1 not compatible with relativstic calculation.')
817 : : endif
818 [ # # # # : 0 : LIBPAW_ALLOCATE(ff,(atp%PAW%irc))
# # # # #
# # # ]
819 [ # # ]: 0 : do io=1,pawtab%basis_size
820 : 0 : paw_proj=.true.
821 [ # # ]: 0 : do io2=1,atp%Orbit%norbit
822 [ # # ]: 0 : if(atp%PAW%valencemap(io2)==io) then
823 [ # # # # ]: 0 : if(atp%orbit%issemicore(io2).and.atp%tpaw_mode==2) then
824 : 0 : paw_proj=.false.
825 : : endif
826 : : endif
827 : : enddo
828 [ # # ]: 0 : if(paw_proj) then
829 [ # # ]: 0 : atp%PAW%ophi(:,io)=zero
830 [ # # ]: 0 : atp%PAW%otphi(:,io)=zero
831 [ # # ]: 0 : do ir=1,pawtab%mesh_size
832 : 0 : atp%PAW%ophi(ir,io)=pawtab%phi(ir,io)
833 : 0 : atp%PAW%otphi(ir,io)=pawtab%tphi(ir,io)
834 : : enddo
835 [ # # ]: 0 : do io2=1,atp%Orbit%norbit
836 [ # # # # ]: 0 : if(atp%Orbit%iscore(io2).and.atp%orbit%l(io2)==atp%PAW%l(io)) then
837 : 0 : irc_max=atp%PAW%irc-5
838 [ # # ]: 0 : ff=zero
839 [ # # ]: 0 : ff(1:irc_max)=atp%orbit%wfn(1:irc_max,io2)
840 : 0 : f1=atp%orbit%wfn(irc_max,io2)
841 : 0 : fp1=Gfirstderiv(atp%Grid,irc_max,atp%orbit%wfn(:,io2))
842 : 0 : dx=-(atp%grid%r(atp%PAW%irc)-atp%grid%r(irc_max))
843 : 0 : c4=(-two*dx*f1+dx**2*fp1)/(two*dx**5)
844 : 0 : c2=(four*dx**3*f1-dx**4*fp1)/(two*dx**5)
845 [ # # ]: 0 : do ir=irc_max+1,atp%PAW%irc
846 : : ff(ir)=c4*(atp%grid%r(ir)-atp%grid%r(atp%PAW%irc))**4+c2*(atp%grid%r(ir)-&
847 : 0 : & atp%grid%r(atp%PAW%irc))**2
848 : : enddo
849 : 0 : ovl=overlap(atp%grid,atp%PAW%ophi(1:atp%PAW%irc,io),ff(1:atp%PAW%irc),1,atp%PAW%irc)
850 : : atp%PAW%ophi(1:atp%PAW%irc,io)=atp%PAW%ophi(1:atp%PAW%irc,io)-&
851 [ # # ]: 0 : & ovl*ff(1:atp%PAW%irc)
852 : : endif
853 : : enddo
854 : : endif
855 : : enddo
856 [ # # ]: 0 : LIBPAW_DEALLOCATE(ff)
857 : : endif
858 [ + + ]: 20 : do io=1,pawtab%basis_size
859 [ + + ]: 25484 : do ir=1,pawtab%mesh_size
860 : 25464 : pawtab%phi(ir,io)=atp%PAW%ophi(ir,io)
861 : 25482 : pawtab%tphi(ir,io)=atp%PAW%otphi(ir,io)
862 : : enddo
863 : : enddo
864 : : ! Update Kij
865 [ - + ]: 2 : if(.not.allocated(pawtab%kij)) then
866 [ # # # # : 0 : LIBPAW_ALLOCATE(pawtab%kij,(pawtab%lmn2_size))
# # # # #
# # # #
# ]
867 : : endif
868 : : call calc_kij(atp%PAW,atp%Grid,pawtab%kij,pawtab,&
869 : 2 : & atp%scalarrelativistic,atp%needvtau)
870 : : endif
871 : : endif
872 : :
873 : : ! Update vhtnzc, zion and epsatm
874 [ + + ]: 18 : if(abs(delta_zcore)<tol15*atm%zcore) atm%zcore_conv=.true.
875 [ + + ]: 18 : if(.not.atm%zcore_conv) then
876 : 6 : zion=atm%znucl-atm%zcore
877 : 6 : delta_zcore=atm%zcore-atm%zcore_orig
878 : 6 : write(msg,*) 'atompaw_solve: delta_zcore',delta_zcore
879 : 6 : call wrtout(std_out,msg,'COLL')
880 : : call pawrad_init(vloc_mesh,mesh_size=size(pawtab%vhtnzc),mesh_type=pawrad%mesh_type,&
881 : 6 : & rstep=pawrad%rstep,lstep=pawrad%lstep)
882 [ - + ]: 6 : if(atp%vhtnzc_mode==2) then
883 : 0 : LIBPAW_ERROR('Vhtnzc_mode>1 is work in progress')
884 : 0 : call FindVlocfromVeff(atp%Grid,atp%PAW,atp,potshift)
885 [ # # ]: 0 : if(pawtab%usexcnhat==1) then
886 [ # # ]: 0 : pawtab%vhtnzc(1:size(pawtab%vhtnzc))=half*atp%PAW%abinitvloc(1:size(pawtab%vhtnzc))
887 : : else
888 [ # # ]: 0 : pawtab%vhtnzc(1:size(pawtab%vhtnzc))=half*atp%PAW%abinitnohat(1:size(pawtab%vhtnzc))
889 : : endif
890 [ + - ]: 6 : elseif(atp%vhtnzc_mode==1) then
891 : : ! Compute nhatc=shapefunction*delta_zcore
892 [ - + + - : 18 : LIBPAW_ALLOCATE(nhatc,(size(pawtab%vhtnzc)))
+ - + - -
+ - + ]
893 [ + + ]: 12012 : nhatc=zero
894 [ + + ]: 8448 : do ir=1,size(pawtab%shapefunc(:,1))
895 : 8448 : nhatc(ir)=delta_zcore*pawtab%shapefunc(ir,1)*vloc_mesh%rad(ir)**2
896 : : enddo
897 [ - + + - : 12 : LIBPAW_ALLOCATE(vhatc,(size(pawtab%vhtnzc)))
- + - + ]
898 : 6 : call poisson(nhatc,0,vloc_mesh,vhatc)
899 [ + + ]: 12006 : do ir=2,vloc_mesh%mesh_size
900 : 12006 : vhatc(ir)=vhatc(ir)/vloc_mesh%rad(ir)
901 : : enddo
902 : 6 : call pawrad_deducer0(vhatc,vloc_mesh%mesh_size,vloc_mesh)
903 [ - + ]: 6 : LIBPAW_DEALLOCATE(nhatc)
904 : : ! Add it to original vhtnzc
905 [ + - - + : 12018 : pawtab%vhtnzc=atm%vhtnzc_orig+vhatc
- - + + ]
906 [ - + ]: 6 : LIBPAW_DEALLOCATE(vhatc)
907 : : endif
908 : : call pawpsp_lo(epsatm,mqgrid_vl,qgrid_vl,vlspl(:,1),&
909 : : & vloc_mesh,pawtab%vhtnzc,yp1,ypn,&
910 : 6 : & zion)
911 : 6 : call paw_spline(qgrid_vl,vlspl(:,1),mqgrid_vl,yp1,ypn,vlspl(:,2))
912 : 6 : write(msg,*) 'atompaw_solve: nc epsatm',epsatm
913 : 6 : call wrtout(std_out,msg,'COLL')
914 : 6 : call pawrad_free(vloc_mesh)
915 : : endif
916 : :
917 : : ! update dij0
918 : : call atompaw_dij0(pawtab%indlmn,pawtab%kij,pawtab%lmn_size,coredens,0,pawtab,pawrad,radmesh,&
919 : 18 : & pawrad,pawtab%vhtnzc,atp%Pot%zz)
920 : :
921 : : ! Write the new paw data
922 [ + + - + : 18 : if(update_paw.and.atp%prtpaw.and..not.atp%diracrelativistic) then
- - ]
923 : : if (pawtab%usexcnhat==1) then
924 : : vlocopt=1
925 : : else
926 : : vlocopt=2
927 : : end if
928 [ # # ]: 0 : atp%Orbit%coreden=zero
929 : 0 : atp%SCF%corekin=zero
930 : 0 : icor=0
931 [ # # ]: 0 : do io=1,atp%Orbit%norbit
932 [ # # ]: 0 : if(atp%Orbit%iscore(io)) then
933 : 0 : icor=icor+1
934 : 0 : atp%Orbit%occ(io)=atm%max_occ(icor,1)
935 [ # # ]: 0 : atp%Orbit%coreden=atp%Orbit%coreden+atp%Orbit%occ(io)*(atp%Orbit%wfn(:,io))**2
936 : 0 : CALL altkinetic(atp%Grid,atp%Orbit%wfn(:,io),atp%Orbit%eig(io),atp%Pot%rv,ekin)
937 : 0 : atp%SCF%corekin=atp%SCF%corekin+ekin*atp%Orbit%occ(io)
938 : : endif
939 : : enddo
940 [ # # ]: 0 : atp%PAW%abinitnohat(1:size(pawtab%vhtnzc))=atm%vhtnzc_orig(1:size(pawtab%vhtnzc))*two
941 [ # # ]: 0 : do io=1,pawtab%basis_size
942 : 0 : irc=FindGridIndex(atp%Grid,atp%basis_func_rc(io))
943 : 0 : irc=min(atp%PAW%irc,irc)
944 : 0 : atp%PAW%rcio(io)=atp%grid%r(irc)
945 : : enddo
946 : 0 : call build_mesh_data(mesh_data,atp%Grid,atp%PAW%irc,0,0,0,0)
947 [ # # ]: 0 : file_xml=trim(atp%pot%sym)//'-rcpaw.xml'
948 : : call xmloutput(trim(file_xml),atp%Grid,atp%SCF,atp%Pot,atp%Orbit,atp%PAW,mesh_data,&
949 [ # # ]: 0 : & atp%PAW%otp,2,atp%input_string,"","",-1,atm%zcore_orig,atp)
950 [ # # ]: 0 : file_xml=TRIM(atp%pot%sym)//'-rcpaw.corewf.xml'
951 [ # # ]: 0 : call xmlprtcore(trim(file_xml),atp,atm%zcore_orig,mesh_data,atp%input_string)
952 : 0 : call destroy_mesh_data(mesh_data)
953 : : endif
954 : :
955 : : ! update tcoretau : TODO : tau
956 : : ! Clean up
957 [ + + - + ]: 18 : if(update_paw.or.atp%vhtnzc_mode==2) then
958 [ + + ]: 4004 : do io=1,atp%Grid%n
959 : 4002 : atp%Pot%rvh(io)=atp%Pot%rvh(io)+potshift*atp%Grid%r(io)
960 : 4004 : atp%Pot%rv(io)=atp%Pot%rv(io)+potshift*atp%Grid%r(io)
961 : : enddo
962 : 2 : atp%Pot%v0=atp%Pot%v0+potshift
963 : : endif
964 : : endif
965 [ - + ]: 19 : LIBPAW_DEALLOCATE(coredens)
966 : 19 : call pawrad_free(radmesh)
967 [ - + - + : 19 : end subroutine atompaw_solve
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ ]
968 : : !!***
969 : :
970 : : !----------------------------------------------------------------------
971 : :
972 : : !!****f* m_paw_atom_solve/atompaw_init
973 : : !! NAME
974 : : !! atompaw_init
975 : : !!
976 : : !! FUNCTION
977 : : !! Initialize an atompaw type
978 : : !!
979 : : !! OUTPUT
980 : : !!
981 : : !! SIDE EFFECTS
982 : : !!
983 : : !! NOTES
984 : : !!
985 : : !! SOURCE
986 : : !! Inspired from SCFatom_init in atompaw
987 : :
988 : 4 : subroutine atompaw_init(pawtab,pawrad,atp,atm,sctol,elin_mode,vhtnzc_mode,tpaw_mode,dirac,filename,prtpaw)
989 : : ! TODO : BDsolve
990 : : implicit none
991 : : !Arguments ------------------------------------
992 : : !scalars
993 : : integer, intent(in) :: elin_mode,vhtnzc_mode,tpaw_mode,prtpaw
994 : : real(dp), intent(in) :: sctol
995 : : logical,intent(in) :: dirac
996 : : CHARACTER(len=*),intent(in) :: filename
997 : : type(pawtab_type), intent(inout) :: pawtab
998 : : type(pawrad_type), intent(in) :: pawrad
999 : : type(atompaw_type), intent(inout) :: atp
1000 : : type(atomorb_type), intent(inout) :: atm
1001 : : !arrays
1002 : : !Local variables-------------------------------
1003 : : !scalars
1004 : : CHARACTER(len=500) :: input_file
1005 : : character(len=500) :: msg
1006 : : character(len=fnlen) :: file_xml_core
1007 : : logical :: rcpaw_core_file,ex
1008 : : REAL(dp) :: a1,a2,a3,hval,r0,zcore
1009 : : INTEGER :: ii,jj,icor,ir,io,fnln,ios
1010 : : logical :: fmt_xml
1011 : : real(dp) :: ekin,insph,norm
1012 : 4 : type(pawrad_type) :: radmesh
1013 : 4 : type(mesh_data_type) :: mesh_data
1014 : : !arrays
1015 : 4 : real(dp), allocatable :: ff(:)
1016 : :
1017 : : ! *************************************************************************
1018 : :
1019 : : ! File to read
1020 : 4 : input_file=trim(filename)
1021 : 4 : fnln=len(trim(filename))
1022 : 4 : fmt_xml=.false.
1023 [ + - ]: 4 : if (fnln>3) then
1024 : 4 : fmt_xml=(input_file(fnln-3:fnln)=='.xml')
1025 : : endif
1026 [ - + ]: 4 : if(.not.fmt_xml) then
1027 : 0 : LIBPAW_ERROR('RCPAW ONLY COMPATIBLE WITH XML COREWF FILE')
1028 : : endif
1029 [ + - ]: 4 : input_file=input_file(1:fnln-3)//'corewf.xml'
1030 : 4 : inquire(file=trim(input_file),iostat=ios,exist=ex)
1031 [ - + ]: 4 : if (ios/=0) then
1032 : 0 : write(msg,'(2a)') 'INQUIRE returns an error for file ',trim(input_file)
1033 : 0 : LIBPAW_ERROR(msg)
1034 : : end if
1035 [ - + ]: 4 : if (.not.ex) then
1036 : 0 : write(msg,'(3a)') 'This file does not exist: ',trim(input_file),'!'
1037 : 0 : LIBPAW_ERROR(msg)
1038 : : end if
1039 : :
1040 : : ! Initialize global constants
1041 : 4 : machine_precision = zero
1042 : 4 : a1 = 4._dp/3._dp
1043 [ + + ]: 8 : DO WHILE (machine_precision == 0._dp)
1044 : 4 : a2 = a1 - 1._dp
1045 : 4 : a3 = a2 + a2 + a2
1046 : 4 : machine_precision = ABS(a3 - 1._dp)
1047 : : ENDDO
1048 : 4 : machine_zero= machine_precision**5
1049 : 4 : machine_infinity = 1._dp/machine_zero
1050 : 4 : practical_zero=machine_precision**2
1051 : 4 : minlogarg=machine_precision; minlog=LOG(minlogarg)
1052 : 4 : maxlogarg=1._dp/machine_precision; maxlog=LOG(maxlogarg)
1053 : 4 : minexparg=LOG(machine_precision); minexp=0._dp
1054 : 4 : maxexparg=-LOG(machine_precision); maxexp=EXP(maxexparg)
1055 : 4 : has_to_print=.false.
1056 : :
1057 : : ! Read atp input and initialize
1058 : 4 : atp%elin_mode=elin_mode
1059 : 4 : atp%vhtnzc_mode=vhtnzc_mode
1060 : 4 : atp%tpaw_mode=tpaw_mode
1061 : 4 : atp%prtpaw=(prtpaw>0)
1062 : :
1063 : 4 : call input_dataset_read(atp,input_file,dirac,.true.)
1064 : :
1065 : 4 : rcpaw_core_file=.false.
1066 [ + + + + ]: 4 : if((.not.dirac).and.atp%diracrelativistic) then
1067 : 1 : atp%scalarrelativistic=.true.
1068 : 1 : atp%diracrelativistic=.false.
1069 : 1 : rcpaw_core_file=.true.
1070 : : endif
1071 : 4 : atp%npsc=0
1072 : 4 : atp%nppc=1
1073 : 4 : atp%npdc=2
1074 : 4 : atp%npfc=3
1075 : 4 : atp%npgc=4
1076 : 4 : atp%frozenvalecalculation=.false.
1077 : 4 : atp%frozencorecalculation=.false.
1078 : 4 : atp%setupfrozencore=.false.
1079 : 4 : atp%gaussianshapefunction=.false.
1080 : 4 : atp%besselshapefunction=.false.
1081 : 4 : atp%collesalvetti=.false.
1082 [ - + ]: 4 : IF (TRIM(atp%gridkey)=='LINEAR') THEN
1083 : 0 : hval=atp%gridmatch/(atp%gridpoints-1)
1084 : 0 : CALL InitGrid(atp%Grid,hval,atp%gridrange)
1085 [ + - ]: 4 : ELSEIF (TRIM(atp%gridkey)=='LOGGRID') THEN
1086 : 4 : hval=logh
1087 : 4 : CALL findh(real(atp%atomic_charge,kind=dp),atp%gridmatch,atp%gridpoints,hval,r0)
1088 : 4 : CALL InitGrid(atp%Grid,pawrad%lstep,atp%gridrange,r0=pawrad%rstep)
1089 [ # # ]: 0 : ELSEIF (TRIM(atp%gridkey)=='LOGGRID4') THEN
1090 : : hval=logh
1091 : : CALL findh_given_r0(real(atp%atomic_charge,kind=dp),atp%gridmatch,lor00,&
1092 : 0 : & atp%gridpoints,hval)
1093 : 0 : CALL InitGrid(atp%Grid,hval,atp%gridrange,r0=lor00/atp%atomic_charge)
1094 : : ENDIF
1095 : 4 : call print_check_atompaw_params(atp)
1096 : 4 : call read_inputstring(atp%input_string)
1097 : :
1098 : : ! Init potentials
1099 : 4 : CALL InitPot(atp%Pot,atp%Grid%n)
1100 : 4 : atp%Pot%sym=atp%atomic_symbol
1101 : : atp%Pot%zz=0._dp
1102 : 4 : atp%Pot%q=0._dp;
1103 : 4 : atp%Pot%v0=0._dp
1104 : 4 : atp%Pot%v0p=0._dp
1105 : 4 : atp%Pot%Nv0=0
1106 : 4 : atp%Pot%Nv0p=0
1107 : 4 : atp%Pot%nz=atp%atomic_charge
1108 : 4 : atp%Pot%zz=atp%Pot%nz
1109 : 4 : atp%Pot%needvtau=atp%needvtau
1110 : 4 : atp%Pot%finitenucleus=atp%finitenucleus
1111 : 4 : atp%Pot%finitenucleusmodel=atp%finitenucleusmodel
1112 : 4 : CALL Get_Nuclearpotential(atp%Grid,atp%Pot)
1113 : :
1114 : : ! Init XC
1115 : : ! atp%temp=temp
1116 : 4 : call initexch(atp)
1117 : :
1118 : : ! Init orbitals
1119 [ + + ]: 24 : ii=maxval(atp%np)
1120 : 4 : jj=atp%np(1)
1121 : 4 : IF(atp%np(2)>0) jj=jj+atp%np(2)-1
1122 : : IF(atp%np(3)>0) jj=jj+atp%np(3)-2
1123 : : IF(atp%np(4)>0) jj=jj+atp%np(4)-3
1124 : : IF(atp%np(5)>0) jj=jj+atp%np(5)-4
1125 : : If (atp%diracrelativistic) jj=jj+jj ! need more orbitals
1126 : : CALL InitOrbit(atp%Orbit,atp%norbit,atp%Grid%n,atp%exctype,atp%diracrelativistic,atp%scalarrelativistic,&
1127 : 4 : & atp%frozencorecalculation,atp%frozenvalecalculation)
1128 : 4 : atp%Orbit%nps=atp%np(1);atp%Orbit%npp=atp%np(2);atp%Orbit%npd=atp%np(3)
1129 : 4 : atp%Orbit%npf=atp%np(4);atp%Orbit%npg=atp%np(5)
1130 : 4 : CALL Prepare_Orbit(atp,ii,atp%norbit)
1131 : 4 : atp%Orbit%npsc=atp%npsc;atp%Orbit%nppc=atp%nppc;atp%Orbit%npdc=atp%npdc
1132 : 4 : atp%Orbit%npfc=atp%npfc;atp%Orbit%npgc=atp%npgc
1133 : 4 : atp%Pot%q=atp%electrons
1134 : :
1135 : : ! Init SCF
1136 : 4 : CALL InitSCF(atp%SCF)
1137 : 4 : IF (atp%needvtau) then
1138 : 0 : atp%usespline=.true.
1139 : : endif
1140 [ - + ]: 4 : if(atp%usespline) CALL initsplinesolver(atp%Grid,atp%splns,atp%splr0,atp%needvtau,atp%spline)
1141 : :
1142 : : ! Init PAW
1143 : 4 : atp%PAW%irc=FindGridIndex(atp%Grid,atp%rc)
1144 : 4 : atp%PAW%irc_shap=FindGridIndex(atp%Grid,atp%rc_shap)
1145 : 4 : atp%PAW%irc_vloc=FindGridIndex(atp%Grid,atp%rc_vloc)
1146 : 4 : atp%PAW%irc_core=FindGridIndex(atp%Grid,atp%rc_core)
1147 : 4 : atp%PAW%rc=atp%Grid%r(atp%PAW%irc)
1148 : 4 : atp%PAW%rc_shap=atp%Grid%r(atp%PAW%irc_shap)
1149 : 4 : atp%PAW%rc_vloc=atp%Grid%r(atp%PAW%irc_vloc)
1150 : 4 : atp%PAW%rc_core=atp%Grid%r(atp%PAW%irc_core)
1151 : 4 : atp%PAW%lmax=atp%lmax
1152 : 4 : call InitPAW(atp%PAW,atp%Grid,atp%Orbit)
1153 : :
1154 : : ! Re-solve (temporary, this should be added to atompaw)
1155 : 4 : call SCFatom(atp,.true.)
1156 : :
1157 [ + + ]: 4 : if(rcpaw_core_file) then
1158 : 1 : call build_mesh_data(mesh_data,atp%Grid,atp%PAW%irc,0,0,0,0)
1159 : 1 : zcore=zero
1160 [ + + ]: 8 : do io=1,atp%norbit
1161 [ + + ]: 8 : if(atp%orbit%iscore(io)) then
1162 : 3 : zcore=zcore+atp%orbit%occ(io)
1163 : : endif
1164 : : enddo
1165 [ + - ]: 1 : file_xml_core=TRIM(atp%pot%sym)//'-tmp.corewf.xml'
1166 [ + - ]: 1 : call xmlprtcore(trim(file_xml_core),atp,zcore,mesh_data,atp%input_string)
1167 [ + - ]: 1 : file_xml_core=trim(atp%pot%sym)//'-tmp.xml'
1168 : 1 : call destroy_mesh_data(mesh_data)
1169 : : else
1170 [ - + ]: 3 : file_xml_core=filename
1171 : : endif
1172 : : ! define atom
1173 [ + - ]: 4 : call pawpsp_init_core(atm,psp_filename=trim(file_xml_core))
1174 [ + - + + ]: 5678 : call simp_gen(atp%pot_ref,atp%Pot%rv(1:pawtab%mesh_size)*pawrad%rad(1:pawtab%mesh_size)*pawtab%shapefunc(1:pawtab%mesh_size,1),pawrad)
1175 : 4 : write(msg,'(a)') 'atompaw_init: orbital, %out of sphere, core, semicore'
1176 : 4 : call wrtout(std_out,msg,'COLL')
1177 [ + + ]: 31 : do io=1,atp%Orbit%norbit
1178 : 27 : norm=overlap(atp%Grid,atp%Orbit%wfn(1:atp%Grid%n,io),atp%Orbit%wfn(1:atp%Grid%n,io),1,atp%Grid%n)
1179 : 27 : insph=overlap(atp%Grid,atp%Orbit%wfn(1:atp%PAW%irc,io),atp%Orbit%wfn(1:atp%PAW%irc,io),1,atp%PAW%irc)
1180 [ + + + + ]: 27 : if(.not.atp%Orbit%iscore(io).and.(one-insph/norm)*100.0_dp<sctol) atp%Orbit%issemicore(io)=.true.
1181 : 27 : write(msg,*)io,(one-insph/norm)*100.0_dp,atp%Orbit%iscore(io),atp%Orbit%issemicore(io)
1182 : 31 : call wrtout(std_out,msg,'COLL')
1183 : : enddo
1184 : : !!!
1185 : :
1186 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%pot_refo,(pawtab%basis_size))
+ - + - -
+ - + -
+ ]
1187 [ - + + - : 12 : LIBPAW_ALLOCATE(ff,(pawtab%mesh_size))
+ - + - -
+ - + -
+ ]
1188 [ + + ]: 5674 : ff(2:pawtab%mesh_size)=atp%Pot%rv(2:pawtab%mesh_size)/atp%grid%r(2:pawtab%mesh_size)
1189 : 4 : call extrapolate(ff)
1190 [ + + ]: 40 : do io=1,pawtab%basis_size
1191 [ + - + + ]: 50968 : call simp_gen(atp%pot_refo(io),ff(1:pawtab%mesh_size)*(pawtab%phi(1:pawtab%mesh_size,io))**2,pawrad)
1192 : : enddo
1193 [ - + ]: 4 : LIBPAW_DEALLOCATE(ff)
1194 : :
1195 : : ! Densities
1196 [ + + ]: 8008 : atp%Orbit%valeden=zero
1197 [ + + ]: 8008 : atp%Orbit%coreden=zero
1198 [ + + ]: 31 : do io=1,atp%Orbit%norbit
1199 [ + + ]: 31 : if(atp%Orbit%iscore(io)) then
1200 [ + + ]: 26026 : atp%Orbit%coreden=atp%Orbit%coreden+atp%Orbit%occ(io)*(atp%Orbit%wfn(:,io))**2
1201 : : else
1202 [ + + ]: 28028 : atp%Orbit%valeden(:)=atp%Orbit%valeden(:)+atp%Orbit%occ(io)*(atp%Orbit%wfn(:,io))**2
1203 : : endif
1204 : : enddo
1205 : : ! Core energies
1206 : 4 : atm%edcc=zero
1207 : 4 : atm%ekinc=zero
1208 : 4 : atm%eeigc=zero
1209 : 4 : icor=0
1210 [ + + ]: 31 : do io=1,atp%Orbit%norbit
1211 [ + + ]: 31 : if(atp%Orbit%iscore(io)) then
1212 : 13 : icor=icor+1
1213 : 13 : CALL altkinetic(atp%Grid,atp%Orbit%wfn(:,io),atp%Orbit%eig(io),atp%Pot%rv,ekin)
1214 : 13 : atm%ekinc=atm%ekinc+ekin/two*atp%Orbit%occ(io)
1215 : 13 : atm%eeigc=atm%eeigc+atp%Orbit%eig(io)*atp%Orbit%occ(io)/two
1216 : : endif
1217 : : enddo
1218 [ - + + - : 12 : LIBPAW_ALLOCATE(ff,(atp%grid%n))
+ - + - -
+ - + -
+ ]
1219 [ + + ]: 8008 : ff=zero
1220 : : ff(2:atp%Grid%n)=atp%Pot%rv(2:atp%Grid%n)*&
1221 [ + + ]: 8004 : & atp%Orbit%coreden(2:atp%Grid%n)/atp%Grid%r(2:atp%Grid%n)
1222 : 4 : CALL extrapolate(ff)
1223 : 4 : atm%edcc=integrator(atp%Grid,ff)/two
1224 [ + + ]: 8004 : ff(2:atp%Grid%n)=atp%Orbit%coreden(2:atp%Grid%n)/(four*pi*atp%Grid%r(2:atp%Grid%n)**2)
1225 : 4 : CALL extrapolate(ff)
1226 : 4 : call pawrad_init(radmesh,atp%Grid%n,pawrad%mesh_type,pawrad%rstep,pawrad%lstep)
1227 : 4 : call atompaw_ehnzc(ff,radmesh,atm%ehnzc,atm%znucl)
1228 [ - + ]: 4 : LIBPAW_DEALLOCATE(ff)
1229 [ + - + + : 35 : atm%min_eigv=half*minval(atp%Orbit%eig,mask=.not.atp%Orbit%iscore)
- + - - +
+ + + ]
1230 : 4 : call pawrad_free(radmesh)
1231 : :
1232 : : ! Prepare for frozen val calculation
1233 : 4 : atp%frozenvalecalculation=.true.
1234 : 4 : atp%Orbit%frozenvalecalculation=.true.
1235 : 4 : atp%projector_type=PROJECTOR_TYPE_MARSMAN
1236 [ + + + + ]: 148152 : atp%PAW%otp=zero
1237 [ + + ]: 40 : do io=1,pawtab%basis_size
1238 [ + + ]: 50788 : do ir=1,atp%PAW%irc
1239 : 50784 : atp%PAW%otp(ir,io)=pawtab%tproj(ir,io)
1240 : : enddo
1241 : : enddo
1242 : :
1243 : : ! atp%SCF%corekin=two*atm%ekinc
1244 : : ! call setcoretail(atp%Grid,atp%Orbit%coreden,atp%PAW,atp%needvtau)
1245 : : ! call setbasis(atp%Grid,atp%Pot,atp%Orbit,atp%PAW,atp,0.0_dp)
1246 : : ! call SetPAWOptions2(atp,fmt_xml)
1247 : : ! atp%PAW%abinitnohat(1:size(pawtab%vhtnzc))=pawtab%vhtnzc(1:size(pawtab%vhtnzc))*two
1248 : : ! atp%PAW%otp=zero
1249 : : ! do io=1,pawtab%basis_size
1250 : : ! do ir=1,atp%PAW%irc
1251 : : ! atp%PAW%otp(ir,io)=pawtab%tproj(ir,io)
1252 : : ! enddo
1253 : : ! enddo
1254 : : ! do io=1,pawtab%basis_size
1255 : : ! irc=FindGridIndex(atp%Grid,atp%basis_func_rc(io))
1256 : : ! irc=min(atp%PAW%irc,irc)
1257 : : ! atp%PAW%rcio(io)=atp%grid%r(irc)
1258 : : ! enddo
1259 : : ! atp%PAW%abinitnohat(1:size(pawtab%vhtnzc))=pawtab%vhtnzc(1:size(pawtab%vhtnzc))*two
1260 : : ! call build_mesh_data(mesh_data,atp%Grid,atp%PAW%irc,0,0,0,0)
1261 : : ! if(.not.allocated(pawtab%kij)) then
1262 : : ! LIBPAW_ALLOCATE(pawtab%kij,(pawtab%lmn2_size))
1263 : : ! endif
1264 : : ! call calc_kij(atp%PAW,atp%Grid,pawtab%kij,pawtab,&
1265 : : !& atp%scalarrelativistic,atp%needvtau)
1266 : : ! file_xml_core=trim(atp%pot%sym)//'-rcpaw.xml'
1267 : : ! call xmloutput(trim(file_xml_core),atp%Grid,atp%SCF,atp%Pot,atp%Orbit,atp%PAW,mesh_data,&
1268 : : !& atp%PAW%otp,2,atp%input_string,"","",-1,atm%zcore,atp)
1269 : : ! file_xml_core=TRIM(atp%pot%sym)//'-rcpaw.corewf.xml'
1270 : : ! call xmlprtcore(trim(file_xml_core),atp,atm%zcore,mesh_data,atp%input_string)
1271 : :
1272 [ + - - + : 8 : end subroutine atompaw_init
- + - + -
+ - + - +
- + - + ]
1273 : : !!***
1274 : :
1275 : : !----------------------------------------------------------------------
1276 : :
1277 : : !!****f* m_paw_atom_solve/atompaw_destroy
1278 : : !! NAME
1279 : : !! atompaw_destroy
1280 : : !!
1281 : : !! FUNCTION
1282 : : !! Destroy an atompaw type
1283 : : !!
1284 : : !! OUTPUT
1285 : : !!
1286 : : !! SIDE EFFECTS
1287 : : !!
1288 : : !! NOTES
1289 : : !!
1290 : : !! SOURCE
1291 : :
1292 : 4 : subroutine atompaw_destroy(atp)
1293 : :
1294 : : implicit none
1295 : : !Arguments ------------------------------------
1296 : : !scalars
1297 : : type(atompaw_type), intent(inout) :: atp
1298 : :
1299 : : ! *********************************************************************
1300 : :
1301 [ + - ]: 4 : if(allocated(atp%orbit_mod_n)) then
1302 : 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_n)
1303 : : endif
1304 [ + - ]: 4 : if(allocated(atp%orbit_mod_l)) then
1305 : 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_l)
1306 : : endif
1307 [ + - ]: 4 : if(allocated(atp%orbit_mod_k)) then
1308 : 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_k)
1309 : : endif
1310 [ + - ]: 4 : if(allocated(atp%orbit_mod_occ)) then
1311 : 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_occ)
1312 : : endif
1313 [ + - ]: 4 : if(allocated(atp%orbit_iscore)) then
1314 : 4 : LIBPAW_DEALLOCATE(atp%orbit_iscore)
1315 : : endif
1316 [ + - ]: 4 : if(allocated(atp%orbit_val_n)) then
1317 : 4 : LIBPAW_DEALLOCATE(atp%orbit_val_n)
1318 : : endif
1319 [ + - ]: 4 : if(allocated(atp%orbit_val_l)) then
1320 : 4 : LIBPAW_DEALLOCATE(atp%orbit_val_l)
1321 : : endif
1322 [ + - ]: 4 : if(allocated(atp%orbit_val_k)) then
1323 : 4 : LIBPAW_DEALLOCATE(atp%orbit_val_k)
1324 : : endif
1325 [ + - ]: 4 : if(allocated(atp%basis_add_l)) then
1326 : 4 : LIBPAW_DEALLOCATE(atp%basis_add_l)
1327 : : endif
1328 [ + - ]: 4 : if(allocated(atp%basis_add_k)) then
1329 : 4 : LIBPAW_DEALLOCATE(atp%basis_add_k)
1330 : : endif
1331 [ + - ]: 4 : if(allocated(atp%basis_add_energy)) then
1332 : 4 : LIBPAW_DEALLOCATE(atp%basis_add_energy)
1333 : : endif
1334 [ + - ]: 4 : if(allocated(atp%basis_func_rc)) then
1335 : 4 : LIBPAW_DEALLOCATE(atp%basis_func_rc)
1336 : : endif
1337 [ + - ]: 4 : if(allocated(atp%pot_refo)) then
1338 : 4 : LIBPAW_DEALLOCATE(atp%pot_refo)
1339 : : endif
1340 : 4 : call DestroyGrid(atp%Grid)
1341 : 4 : call DestroyOrbit(atp%Orbit)
1342 : 4 : call DestroyPot(atp%Pot)
1343 : 4 : call DestroyPAW(atp%PAW)
1344 : 4 : call deallocatesplinesolver(atp%spline,atp%needvtau)
1345 : :
1346 : 4 : end subroutine atompaw_destroy
1347 : : !!***
1348 : :
1349 : :
1350 : :
1351 : :
1352 : :
1353 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1354 : : ! BELOW THIS ARE PRIVATE ROUTINES MOSTLY IMPORTED FROM ATOMPAW
1355 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1356 : :
1357 : :
1358 : :
1359 : :
1360 : :
1361 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1362 : : ! 0. Developped for RCPAW
1363 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1364 : :
1365 : :
1366 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1367 : : !! makebasis_marsman
1368 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1369 : 2 : subroutine makebasis_marsman(atp)
1370 : : type(atompaw_type),intent(inout) :: atp
1371 : : integer :: ns,np,nd,nf,ng,io,l
1372 : : real(dp):: v0,v0p
1373 : 2 : integer, allocatable :: map(:)
1374 [ - + + - : 6 : LIBPAW_ALLOCATE(map,(atp%PAW%nbase))
+ - + - -
+ - + ]
1375 : 2 : ns=0
1376 : 2 : np=0
1377 : 2 : nd=0
1378 : 2 : nf=0
1379 : 2 : ng=0
1380 [ + + ]: 20 : map=0
1381 : 2 : call zeropot(atp%Grid,atp%PAW%rveff,v0,v0p)
1382 [ + + ]: 20 : do io=1,atp%PAW%nbase
1383 : 18 : l=atp%PAW%l(io)
1384 [ + + ]: 18 : if(l==0) then
1385 : 5 : ns=ns+1
1386 : 5 : map(io)=ns
1387 : : endif
1388 [ + + ]: 18 : if(l==1) then
1389 : 5 : np=np+1
1390 : 5 : map(io)=np
1391 : : endif
1392 [ + + ]: 18 : if(l==2) then
1393 : 5 : nd=nd+1
1394 : 5 : map(io)=nd
1395 : : endif
1396 [ + + ]: 18 : if(l==3) then
1397 : 3 : nf=nf+1
1398 : 3 : map(io)=nf
1399 : : endif
1400 [ - + ]: 20 : if(l==4) then
1401 : 0 : ng=ng+1
1402 : 0 : map(io)=ng
1403 : : endif
1404 : : enddo
1405 [ + - ]: 2 : if(ns>0) call marsman_tphi(atp,map,0,ns)
1406 [ + - ]: 2 : if(np>0) call marsman_tphi(atp,map,1,np)
1407 [ + - ]: 2 : if(nd>0) call marsman_tphi(atp,map,2,nd)
1408 [ + + ]: 2 : if(nf>0) call marsman_tphi(atp,map,3,nf)
1409 [ - + ]: 2 : if(ng>0) call marsman_tphi(atp,map,4,ng)
1410 : : ! renormalize phis
1411 [ + + ]: 20 : do io=1,atp%PAW%nbase
1412 [ + + ]: 36036 : atp%PAW%otphi(:,io)=atp%PAW%tphi(:,io)
1413 [ + + ]: 36036 : atp%PAW%ophi(:,io)=atp%PAW%phi(:,io)*atp%PAW%otphi(atp%PAW%irc,io)/atp%PAW%phi(atp%PAW%irc,io)
1414 [ + + ]: 10680 : atp%PAW%otphi(atp%PAW%irc:atp%Grid%n,io)=atp%PAW%ophi(atp%PAW%irc:atp%Grid%n,io)
1415 : 18 : atp%PAW%Kop(1,io)=zero
1416 : : atp%PAW%Kop(2:atp%Grid%n,io)=(atp%PAW%eig(io)-atp%Pot%rv(2:atp%Grid%n)/&
1417 [ + + ]: 36020 : & atp%Grid%r(2:atp%Grid%n))*atp%PAW%ophi(2:atp%Grid%n,io)
1418 : : enddo
1419 [ - + ]: 2 : LIBPAW_DEALLOCATE(map)
1420 : 2 : end subroutine makebasis_marsman
1421 : :
1422 : :
1423 : :
1424 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1425 : : !! marsman_tphi
1426 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1427 : 7 : subroutine marsman_tphi(atp,map,l_in,n)
1428 : : integer, intent(in) :: l_in
1429 : : integer, intent(in) :: n
1430 : : type(atompaw_type),intent(inout) :: atp
1431 : : integer, intent(in) :: map(atp%PAW%nbase)
1432 : : integer :: io,nodes,ii,match,irc
1433 : : integer :: io2,l2,jj,ioj,kk,l,ir,ir1
1434 : : real(dp):: energy,v0,v0p,zeroval
1435 : 7 : real(dp), allocatable :: ksi_i0(:,:),ksi_ij(:,:,:)
1436 : 7 : real(dp), allocatable :: ksi_i0_0(:),ksi_ij_0(:,:)
1437 : : REAL(dp), ALLOCATABLE :: p1(:),p2(:)
1438 : 7 : real(dp), allocatable :: AA(:,:), BB(:)
1439 : 14 : real(dp) :: dp1(atp%PAW%irc),dp2(atp%PAW%irc)
1440 : : real(dp) :: x1,y1,y2,a,b,c,r1,r2
1441 : : logical :: need_fit
1442 : 7 : irc=atp%PAW%irc
1443 : 7 : CALL zeropot(atp%Grid,atp%PAW%rveff,v0,v0p)
1444 [ - + + - : 21 : LIBPAW_ALLOCATE(p1,(atp%Grid%n))
+ - + - -
+ - + ]
1445 [ - + + - : 14 : LIBPAW_ALLOCATE(p2,(atp%Grid%n))
- + - + ]
1446 [ - + + - : 28 : LIBPAW_ALLOCATE(ksi_i0,(atp%Grid%n,n))
- + + - +
- + - - +
- + ]
1447 [ - + + - : 35 : LIBPAW_ALLOCATE(ksi_ij,(atp%Grid%n,n,n))
- + + - -
+ + - + -
+ - - + -
+ ]
1448 [ - + + - : 21 : LIBPAW_ALLOCATE(ksi_i0_0,(n))
+ - + - -
+ - + ]
1449 [ - + + - : 28 : LIBPAW_ALLOCATE(ksi_ij_0,(n,n))
- + + - +
- + - - +
- + ]
1450 [ + + + + ]: 36043 : ksi_i0=zero
1451 [ + + + + : 96121 : ksi_ij=zero
+ + ]
1452 : 7 : ii=0
1453 [ + + ]: 73 : do io=1,atp%PAW%nbase
1454 : 66 : l=atp%PAW%l(io)
1455 [ + + ]: 73 : if(l==l_in) then
1456 : 18 : ii=ii+1
1457 : 18 : energy=atp%PAW%eig(io)
1458 : 18 : CALL ClassicalTurningPoint(atp%Grid,atp%PAW%rveff,l,energy,match)
1459 [ + + ]: 18 : if(match>irc) match=2
1460 : : ! !! backward Not used anymore
1461 : : ! p2=zero
1462 : : ! p2(irc:atp%Grid%n)=atp%PAW%phi(irc:atp%Grid%n,io)
1463 : : ! CALL backward_numerov(atp%Grid,l,2,energy,atp%PAW%rveff,p2,nend=irc+1)
1464 : : !! forward
1465 [ + + ]: 36036 : p1=zero
1466 : 18 : p1(2)=wfninit(-0.5_dp*atp%PAW%rveff(1),l,v0,v0p,energy,atp%Grid%r(2))
1467 : 18 : zeroval=zero
1468 [ + + ]: 18 : IF (l==0) zeroval=atp%PAW%rveff(1)
1469 [ + + ]: 18 : IF (l==1) zeroval=2
1470 : 18 : CALL forward_numerov(atp%Grid,l,irc+5,energy,atp%PAW%rveff,zeroval,p1,nodes)!,p3val=p1(3))
1471 [ + + ]: 36036 : ksi_i0(:,ii)=p1(:)
1472 [ + + ]: 25392 : dp1=zero
1473 : 18 : call derivative(atp%grid,p1,dp1,1,irc)
1474 : : ! p2(2:size(p2))=p2(2:size(p2))*atp%grid%r(2:size(p2))**l_in
1475 : : ! call extrapolate(p2)
1476 : 18 : ksi_i0_0(ii)=dp1(irc)
1477 : 18 : jj=0
1478 [ + + ]: 198 : do io2=1,atp%PAW%nbase
1479 : 180 : l2=atp%PAW%l(io2)
1480 [ + + ]: 198 : if(l2==l) then
1481 : 48 : jj=jj+1
1482 : 48 : match=2
1483 : : ! p2=zero
1484 : : ! p2(irc:atp%Grid%n)=atp%PAW%phi(irc:atp%Grid%n,io)
1485 : : ! CALL backward_numerov(atp%Grid,l,match,energy,atp%PAW%rveff,p2,nend=irc+1,proj=atp%PAW%otp(:,io2))
1486 [ + + ]: 96096 : p1=zero
1487 : 48 : p1(2)=wfninit(-0.5_dp*atp%PAW%rveff(1),l,v0,v0p,energy,atp%Grid%r(2))
1488 : 48 : CALL forward_numerov(atp%Grid,l,irc+5,energy,atp%PAW%rveff,zeroval,p1,nodes,proj=atp%PAW%otp(:,io2))!,p3val=p1(3))
1489 [ + + ]: 96096 : ksi_ij(:,ii,jj)=p1(:)
1490 : : ! p2(2:size(p2))=p2(2:size(p2))*atp%grid%r(2:size(p2))**l_in
1491 : : ! call extrapolate(p2)
1492 [ + + ]: 67620 : dp1=zero
1493 : 48 : call derivative(atp%grid,p1,dp1,1,irc)
1494 : 48 : ksi_ij_0(ii,jj)=dp1(irc)
1495 : : endif
1496 : : enddo
1497 : : endif
1498 : : enddo
1499 [ + - - + : 28 : LIBPAW_ALLOCATE(AA,(n+1,n+1))
+ - - + +
- + - + -
- + - + ]
1500 [ - + + - : 21 : LIBPAW_ALLOCATE(BB,(n+1))
+ - + - -
+ - + ]
1501 [ + + ]: 73 : do ioj=1,atp%PAW%nbase
1502 : 66 : l=atp%PAW%l(ioj)
1503 [ + + ]: 73 : if(l==l_in) then
1504 : 18 : jj=map(ioj)
1505 [ + + + + ]: 330 : AA=zero
1506 [ + + ]: 84 : BB=zero
1507 : : ! get derivative of phi
1508 [ + + ]: 25392 : dp1=zero
1509 : 18 : call derivative(atp%grid,atp%PAW%phi(:,ioj),dp1,1,irc)
1510 : 18 : ii=0
1511 [ + + ]: 198 : do io=1,atp%PAW%nbase
1512 : 180 : l2=atp%PAW%l(io)
1513 [ + + ]: 198 : if(l==l2) then
1514 : 48 : ii=ii+1
1515 [ + + ]: 48 : if(ii==jj) BB(ii)=one
1516 [ + + ]: 96096 : p2(:)=ksi_i0(:,jj)*atp%PAW%otp(:,io)
1517 : 48 : AA(ii,n+1)=integrator(atp%Grid,p2)
1518 [ + + ]: 180 : do kk=1,n
1519 [ + + ]: 264264 : p2(:)=ksi_ij(:,jj,kk)*atp%PAW%otp(:,io)
1520 : 180 : AA(ii,kk)=integrator(atp%Grid,p2)
1521 : : enddo
1522 : : endif
1523 : : enddo
1524 [ + + ]: 66 : do kk=1,n
1525 : 66 : AA(n+1,kk)=ksi_ij_0(jj,kk)-dp1(irc)*ksi_ij(irc,jj,kk)/atp%PAW%phi(irc,ioj)
1526 : : enddo
1527 : 18 : AA(n+1,n+1)=ksi_i0_0(jj)-dp1(irc)*ksi_i0(irc,jj)/atp%PAW%phi(irc,ioj)
1528 : 18 : call SolveAXeqBM(n+1,AA,BB,n+1)
1529 [ + + ]: 36036 : atp%PAW%tphi(:,ioj)=zero
1530 [ + + ]: 66 : do kk=1,n
1531 [ + + ]: 96114 : atp%PAW%tphi(:,ioj)=atp%PAW%tphi(:,ioj)+BB(kk)*ksi_ij(:,jj,kk)
1532 : : enddo
1533 [ + + ]: 36036 : atp%PAW%tphi(:,ioj)=atp%PAW%tphi(:,ioj)+BB(n+1)*ksi_i0(:,jj)
1534 : : ! In some cases, numerical error => need to fit tail of the orbital
1535 : : ! Check if low lying orbital
1536 [ + + ]: 18 : if(atp%basis_func_rc(ioj)<atp%rc) then
1537 : : ! Check if tphi is close to 0 at irc
1538 [ + - - + : 4006 : if(abs(atp%PAW%tphi(irc,ioj))/maxval(abs(atp%PAW%tphi(:,ioj)))<tol2) then
- - + + -
+ ]
1539 : : ! Check if tphi is non-decreasing at irc
1540 : 0 : need_fit=.false.
1541 [ # # # # ]: 0 : call derivative(atp%grid,abs(atp%PAW%tphi(:,ioj)),dp2,1,irc)
1542 : 0 : ir1=FindGridIndex(atp%Grid,atp%basis_func_rc(ioj))
1543 [ # # ]: 0 : do ir=ir1,irc+5
1544 [ # # ]: 0 : if(dp2(ir)>zero) then
1545 : : need_fit=.true.
1546 : : exit
1547 : : endif
1548 : : enddo
1549 [ # # ]: 0 : if(need_fit) then
1550 : 0 : x1=atp%PAW%tphi(ir1,ioj)
1551 : 0 : call derivative(atp%grid,atp%PAW%tphi(:,ioj),dp2,1,ir1)
1552 : 0 : y1=dp2(ir1)/x1
1553 : 0 : call derivative(atp%grid,atp%PAW%phi(:,ioj),dp1,1,irc)
1554 : 0 : y2=dp1(irc)/atp%PAW%phi(irc,ioj)
1555 : 0 : r1=atp%grid%r(ir1)
1556 : 0 : r2=atp%grid%r(irc)
1557 : 0 : c=(y1-y2)/(one/r1-one/r2)
1558 : 0 : b=c/r1-y1
1559 : 0 : a=x1/(r1**c*exp(-b*r1))
1560 [ # # ]: 0 : do ir=ir1,irc+5
1561 : 0 : atp%PAW%tphi(ir,ioj)=a*atp%grid%r(ir)**c*exp(-b*atp%grid%r(ir))
1562 : : enddo
1563 : : endif
1564 : : endif
1565 : : endif
1566 : : endif
1567 : : enddo
1568 [ - + ]: 7 : LIBPAW_DEALLOCATE(AA)
1569 [ - + ]: 7 : LIBPAW_DEALLOCATE(BB)
1570 [ - + ]: 7 : LIBPAW_DEALLOCATE(p1)
1571 [ - + ]: 7 : LIBPAW_DEALLOCATE(p2)
1572 [ - + ]: 7 : LIBPAW_DEALLOCATE(ksi_i0)
1573 [ - + ]: 7 : LIBPAW_DEALLOCATE(ksi_ij)
1574 [ - + ]: 7 : LIBPAW_DEALLOCATE(ksi_i0_0)
1575 [ - + ]: 7 : LIBPAW_DEALLOCATE(ksi_ij_0)
1576 : 7 : end subroutine marsman_tphi
1577 : :
1578 : :
1579 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1580 : : !! calc_kij
1581 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1582 : 2 : subroutine calc_kij(PAW,grid,kij,pawtab,scalarrelativistic,needvtau)
1583 : : logical, intent(in) :: scalarrelativistic,needvtau
1584 : : type(gridinfo), intent(in) :: grid
1585 : : type(pseudoinfo), intent(in) :: PAW
1586 : : type(pawtab_type), intent(in) :: pawtab
1587 : : real(dp), intent(inout) :: kij(pawtab%lmn2_size)
1588 : : integer :: nbase,l,ib,jb
1589 : : integer :: jlmn,j0lmn,jlm,jln,ilmn,klmn,ilm,iln
1590 : : real(dp) :: x, y
1591 : 2 : nbase=PAW%nbase
1592 [ + + ]: 20 : DO ib=1,nbase
1593 : 18 : l=PAW%l(ib)
1594 [ + + ]: 200 : DO jb=1,nbase
1595 [ + + ]: 198 : IF (PAW%l(jb)==l) THEN
1596 [ + + ]: 48 : If (scalarrelativistic) then
1597 : 12 : call altdtij(Grid,PAW,ib,jb,x,needvtau)
1598 : : Else
1599 : : CALL deltakinetic_ij(Grid,PAW%ophi(:,ib),PAW%ophi(:,jb), &
1600 : 36 : & PAW%otphi(:,ib),PAW%otphi(:,jb),l,x,PAW%irc)
1601 : : Endif
1602 [ - + ]: 48 : if(has_to_print) WRITE(STD_OUT,'(" Kinetic ", 3i5, 1p,3e15.7)') ib,jb,l,x
1603 : 48 : PAW%Kij(ib,jb)=x
1604 : : ENDIF
1605 : : ENDDO
1606 : : ENDDO
1607 : : ! Average equivalent terms
1608 [ + + ]: 20 : DO ib=1,nbase
1609 [ + + ]: 119 : DO jb=ib,nbase
1610 [ + + ]: 117 : IF(jb>ib) THEN
1611 : 81 : x=PAW%Kij(ib,jb); y=PAW%Kij(jb,ib)
1612 : 81 : x=0.5_dp*(x+y)
1613 : 81 : PAW%Kij(ib,jb)=x; PAW%Kij(jb,ib)=x
1614 : : ENDIF
1615 : : ENDDO
1616 : : ENDDO
1617 : : ! convert from atompaw to libpaw
1618 [ + + ]: 1349 : kij=zero
1619 [ + + ]: 68 : do jlmn=1,pawtab%lmn_size
1620 : 66 : j0lmn=jlmn*(jlmn-1)/2
1621 : 66 : jlm=pawtab%indlmn(4,jlmn);jln=pawtab%indlmn(5,jlmn)
1622 [ + + ]: 1415 : do ilmn=1,jlmn
1623 : 1347 : klmn=j0lmn+ilmn
1624 : 1347 : ilm=pawtab%indlmn(4,ilmn);iln=pawtab%indlmn(5,ilmn)
1625 [ + + ]: 1413 : if (ilm==jlm) kij(klmn)=half*PAW%Kij(iln,jln) ! Conversion Ry->Ha
1626 : : enddo
1627 : : enddo
1628 : 2 : end subroutine calc_kij
1629 : :
1630 : :
1631 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1632 : : !! Prepare_Orbit
1633 : : !! Inspired from SCFatom_Init
1634 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1635 : 4 : SUBROUTINE Prepare_Orbit(atp,ii,jj)
1636 : : integer, intent(in) :: ii,jj
1637 : : type(atompaw_type), intent(inout) :: atp
1638 : : INTEGER :: icount,id,is,ip,jf,ig,io,l,nfix,kappa,i
1639 : : real(dp) :: xocc
1640 : 4 : INTEGER, ALLOCATABLE :: nl(:,:)
1641 : 4 : icount=0
1642 [ + + ]: 4 : if(.not.atp%diracrelativistic) then
1643 [ - + + - : 87 : LIBPAW_ALLOCATE(nl,(ii,jj));nl=0
- + + - +
- + - - +
- + + + +
+ ]
1644 [ + - ]: 3 : IF (atp%Orbit%nps.GT.0) THEN
1645 [ + + ]: 13 : DO is=1,atp%Orbit%nps
1646 : 10 : icount=icount+1
1647 : 10 : nl(is,1)=icount
1648 : 10 : atp%Orbit%occ(icount)=2._dp
1649 : 10 : atp%Orbit%np(icount)=is
1650 : 10 : atp%Orbit%l(icount)=0
1651 [ + + ]: 13 : if(atp%orbit_iscore(icount)) atp%npsc=is
1652 : : ENDDO
1653 : : ENDIF
1654 [ + - ]: 3 : IF (atp%Orbit%npp.GT.1) THEN
1655 [ + + ]: 9 : DO ip=2,atp%Orbit%npp
1656 : 6 : icount=icount+1
1657 : 6 : nl(ip,2)=icount
1658 : 6 : atp%Orbit%occ(icount)=6._dp
1659 : 6 : atp%Orbit%np(icount)=ip
1660 : 6 : atp%Orbit%l(icount)=1
1661 [ + + ]: 9 : if(atp%orbit_iscore(icount)) atp%nppc=ip
1662 : : ENDDO
1663 : : ENDIF
1664 [ + + ]: 3 : IF (atp%Orbit%npd.GT.2) THEN
1665 [ + + ]: 2 : DO id=3,atp%Orbit%npd
1666 : 1 : icount=icount+1
1667 : 1 : nl(id,3)=icount
1668 : 1 : atp%Orbit%occ(icount)=10._dp
1669 : 1 : atp%Orbit%np(icount)=id
1670 : 1 : atp%Orbit%l(icount)=2
1671 [ - + ]: 2 : if(atp%orbit_iscore(icount)) atp%npdc=id
1672 : : ENDDO
1673 : : ENDIF
1674 [ - + ]: 3 : IF (atp%Orbit%npf.GT.3) THEN
1675 [ # # ]: 0 : DO jf=4,atp%Orbit%npf
1676 : 0 : icount=icount+1
1677 : 0 : nl(jf,4)=icount
1678 : 0 : atp%Orbit%occ(icount)=14._dp
1679 : 0 : atp%Orbit%np(icount)=jf
1680 : 0 : atp%Orbit%l(icount)=3
1681 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npfc=jf
1682 : : ENDDO
1683 : : ENDIF
1684 [ - + ]: 3 : IF(atp%Orbit%npg.GT.4) THEN
1685 [ # # ]: 0 : DO ig=5,atp%Orbit%npg
1686 : 0 : icount=icount+1
1687 : 0 : nl(ig,5)=icount
1688 : 0 : atp%Orbit%occ(icount)=18._dp
1689 : 0 : atp%Orbit%np(icount)=ig
1690 : 0 : atp%Orbit%l(icount)=4
1691 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npgc=ig
1692 : : ENDDO
1693 : : ENDIF
1694 : 3 : atp%Orbit%norbit=icount
1695 [ - + ]: 3 : if(has_to_print) write(std_out,*)' Below are listed the default occupations '
1696 [ - + ]: 3 : if(has_to_print) write(std_out,"(' n l occupancy')")
1697 [ + + ]: 20 : DO io=1,atp%Orbit%norbit
1698 [ - + ]: 17 : if(has_to_print) WRITE(std_out,'(i2,1x,i2,4x,1p,1e15.7)') &
1699 : 3 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%occ(io)
1700 : : ENDDO
1701 [ + + ]: 20 : atp%Orbit%iscore=atp%orbit_iscore
1702 [ + + ]: 7 : DO io=1,atp%norbit_mod
1703 : 4 : l=atp%orbit_mod_l(io)
1704 : 4 : ip=atp%orbit_mod_n(io)
1705 : 4 : xocc=atp%orbit_mod_occ(io)
1706 : 4 : nfix=nl(ip,l+1)
1707 [ + - - + ]: 4 : IF (nfix<=0.OR.nfix>atp%Orbit%norbit) THEN
1708 : 0 : LIBPAW_ERROR('error in occupations')
1709 : : ENDIF
1710 : 7 : atp%Orbit%occ(nfix)=xocc
1711 : : END DO
1712 [ - + ]: 3 : if(has_to_print) WRITE(STD_OUT,*) ' Corrected occupations are: '
1713 [ - + ]: 3 : if(has_to_print) WRITE(STD_OUT,"(' n l occupancy')")
1714 : 3 : atp%electrons=0._dp
1715 [ + + ]: 20 : DO io=1,atp%Orbit%norbit
1716 [ - + ]: 17 : if(has_to_print) WRITE(STD_OUT,'(i2,1x,i2,4x,1p,1e15.7)') &
1717 : 0 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%occ(io)
1718 : 17 : atp%electrons=atp%electrons+atp%Orbit%occ(io)
1719 [ + + ]: 20 : if(.not.atp%Orbit%iscore(io)) atp%Orbit%qval=atp%Orbit%qval+atp%Orbit%occ(io)
1720 : : ENDDO
1721 : : ENDIF ! scalarrelativistic
1722 : :
1723 [ + + ]: 4 : If (atp%diracrelativistic) then
1724 : 1 : i=MAX(atp%Orbit%nps,atp%Orbit%npp,atp%Orbit%npd,atp%Orbit%npf,atp%Orbit%npg)
1725 [ - + + - : 3 : LIBPAW_ALLOCATE(nl,(i,-5:5))
+ - + - -
+ - + -
+ ]
1726 [ + + + + ]: 56 : nl=0
1727 [ + - ]: 1 : IF (atp%Orbit%nps.GT.0) THEN
1728 [ + + ]: 5 : DO is=1,atp%Orbit%nps
1729 : 4 : icount=icount+1
1730 : 4 : nl(is,-1)=icount
1731 : 4 : atp%Orbit%occ(icount)=2._dp
1732 : 4 : atp%Orbit%np(icount)=is
1733 : 4 : atp%Orbit%l(icount)=0
1734 : 4 : atp%Orbit%kappa(icount)=-1
1735 [ + + ]: 5 : if(atp%orbit_iscore(icount)) atp%npsc=is
1736 : : ENDDO
1737 : : ENDIF
1738 [ + - ]: 1 : IF (atp%Orbit%npp.GT.1) THEN
1739 [ + + ]: 3 : DO ip=2,atp%Orbit%npp
1740 : 2 : icount=icount+1
1741 : 2 : nl(ip,1)=icount
1742 : 2 : atp%Orbit%occ(icount)=2._dp
1743 : 2 : atp%Orbit%np(icount)=ip
1744 : 2 : atp%Orbit%l(icount)=1
1745 : 2 : atp%Orbit%kappa(icount)=1
1746 [ + + ]: 3 : if(atp%orbit_iscore(icount)) atp%nppc=ip
1747 : : ENDDO
1748 [ + + ]: 3 : DO ip=2,atp%Orbit%npp
1749 : 2 : icount=icount+1
1750 : 2 : nl(ip,-2)=icount
1751 : 2 : atp%Orbit%occ(icount)=4._dp
1752 : 2 : atp%Orbit%np(icount)=ip
1753 : 2 : atp%Orbit%l(icount)=1
1754 : 2 : atp%Orbit%kappa(icount)=-2
1755 [ + + ]: 3 : if(atp%orbit_iscore(icount)) atp%nppc=ip
1756 : : ENDDO
1757 : : ENDIF
1758 [ + - ]: 1 : IF (atp%Orbit%npd.GT.2) THEN
1759 [ + + ]: 2 : DO id=3,atp%Orbit%npd
1760 : 1 : icount=icount+1
1761 : 1 : nl(id,2)=icount
1762 : 1 : atp%Orbit%occ(icount)=4._dp
1763 : 1 : atp%Orbit%np(icount)=id
1764 : 1 : atp%Orbit%l(icount)=2
1765 : 1 : atp%Orbit%kappa(icount)=2
1766 [ - + ]: 2 : if(atp%orbit_iscore(icount)) atp%npdc=id
1767 : : ENDDO
1768 [ + + ]: 2 : DO id=3,atp%Orbit%npd
1769 : 1 : icount=icount+1
1770 : 1 : nl(id,-3)=icount
1771 : 1 : atp%Orbit%occ(icount)=6._dp
1772 : 1 : atp%Orbit%np(icount)=id
1773 : 1 : atp%Orbit%l(icount)=2
1774 : 1 : atp%Orbit%kappa(icount)=-3
1775 [ - + ]: 2 : if(atp%orbit_iscore(icount)) atp%npdc=id
1776 : : ENDDO
1777 : : ENDIF
1778 [ - + ]: 1 : IF (atp%Orbit%npf.GT.3) THEN
1779 [ # # ]: 0 : DO jf=4,atp%Orbit%npf
1780 : 0 : icount=icount+1
1781 : 0 : nl(jf,3)=icount
1782 : 0 : atp%Orbit%occ(icount)=6._dp
1783 : 0 : atp%Orbit%np(icount)=jf
1784 : 0 : atp%Orbit%l(icount)=3
1785 : 0 : atp%Orbit%kappa(icount)=3
1786 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npfc=jf
1787 : : ENDDO
1788 [ # # ]: 0 : DO jf=4,atp%Orbit%npf
1789 : 0 : icount=icount+1
1790 : 0 : nl(jf,-4)=icount
1791 : 0 : atp%Orbit%occ(icount)=8._dp
1792 : 0 : atp%Orbit%np(icount)=jf
1793 : 0 : atp%Orbit%l(icount)=3
1794 : 0 : atp%Orbit%kappa(icount)=-4
1795 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npfc=jf
1796 : : ENDDO
1797 : : ENDIF
1798 [ - + ]: 1 : IF(atp%Orbit%npg.GT.4) THEN
1799 [ # # ]: 0 : DO ig=5,atp%Orbit%npg
1800 : 0 : icount=icount+1
1801 : 0 : nl(ig,4)=icount
1802 : 0 : atp%Orbit%occ(icount)=8._dp
1803 : 0 : atp%Orbit%np(icount)=ig
1804 : 0 : atp%Orbit%l(icount)=4
1805 : 0 : atp%Orbit%kappa(icount)=4
1806 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npgc=ig
1807 : : ENDDO
1808 [ # # ]: 0 : DO ig=5,atp%Orbit%npg
1809 : 0 : icount=icount+1
1810 : 0 : nl(ig,-5)=icount
1811 : 0 : atp%Orbit%occ(icount)=10._dp
1812 : 0 : atp%Orbit%np(icount)=ig
1813 : 0 : atp%Orbit%l(icount)=4
1814 : 0 : atp%Orbit%kappa(icount)=-5
1815 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npgc=ig
1816 : : ENDDO
1817 : : ENDIF
1818 : 1 : atp%Orbit%norbit=icount
1819 [ - + ]: 1 : if(has_to_print) write(std_out,*)' Below are listed the default occupations '
1820 [ - + ]: 1 : if(has_to_print) write(std_out,"(' n l kappa occupancy')")
1821 [ + + ]: 11 : DO io=1,atp%Orbit%norbit
1822 [ - + ]: 10 : if(has_to_print) write(std_out,'(i2,1x,i2,3x,i2,4x,1p,1e15.7)') &
1823 : 1 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%kappa(io),atp%Orbit%occ(io)
1824 : : ENDDO
1825 : : !Corrected occupations (from input dataset)
1826 [ + + ]: 11 : atp%Orbit%iscore=atp%orbit_iscore
1827 [ + + ]: 4 : DO io=1,atp%norbit_mod
1828 : 3 : l=atp%orbit_mod_l(io)
1829 : 3 : ip=atp%orbit_mod_n(io)
1830 : 3 : kappa=atp%orbit_mod_k(io)
1831 : 3 : xocc=atp%orbit_mod_occ(io)
1832 : 3 : nfix=nl(ip,kappa)
1833 [ + - - + ]: 3 : IF (nfix<=0.OR.nfix>atp%Orbit%norbit) THEN
1834 : 0 : WRITE(STD_OUT,*) 'error in occupations -- ip,l,kappa,xocc:',&
1835 : 0 : & ip,l,kappa,xocc,nfix,atp%Orbit%norbit
1836 : 0 : STOP
1837 : : ENDIF
1838 : 4 : atp%Orbit%occ(nfix)=xocc
1839 : : END DO
1840 [ - + ]: 1 : if(has_to_print)WRITE(STD_OUT,*) ' Corrected occupations are: '
1841 [ - + ]: 1 : if(has_to_print) WRITE(STD_OUT,"(' n l kappa occupancy')")
1842 : 1 : atp%electrons=0.0_dp
1843 [ + + ]: 11 : DO io=1,atp%Orbit%norbit
1844 [ - + ]: 10 : if(has_to_print) WRITE(STD_OUT,'(i2,1x,i2,3x,i2,4x,1p,1e15.7)') &
1845 : 0 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%kappa(io),atp%Orbit%occ(io)
1846 : 10 : atp%electrons=atp%electrons+atp%Orbit%occ(io)
1847 [ + + ]: 11 : if(.not.atp%Orbit%iscore(io)) atp%Orbit%qval=atp%Orbit%qval+atp%Orbit%occ(io)
1848 : : ENDDO
1849 : : ENDIF ! completed occupations
1850 [ - + ]: 4 : LIBPAW_DEALLOCATE(nl)
1851 : 4 : end subroutine Prepare_Orbit
1852 : :
1853 : :
1854 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1855 : : !! subroutine print_atompaw_params(atp)
1856 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1857 : 4 : subroutine print_check_atompaw_params(atp)
1858 : : type(atompaw_type),intent(in) :: atp
1859 : : integer :: norb,io
1860 [ + + - + ]: 4 : if(atp%scalarrelativistic.and.atp%tpaw_mode>1) then
1861 : 0 : LIBPAW_ERROR('tpaw_mode>1 and scalarrelativistic not compatible')
1862 : : endif
1863 [ - + ]: 4 : if(atp%finitenucleus) then
1864 : 0 : LIBPAW_ERROR('Finitenucleus not implemented')
1865 : : endif
1866 [ - + ]: 4 : if(atp%HFpostprocess) then
1867 : 0 : LIBPAW_ERROR('HFpostprocess not implemented')
1868 : : endif
1869 [ - + ]: 4 : if(atp%localizedcoreexchange) then
1870 : 0 : LIBPAW_ERROR('Localized core exchange not implemented')
1871 : : endif
1872 [ - + ]: 4 : if(atp%BDsolve) then
1873 : 0 : LIBPAW_ERROR('BD solver not implemented')
1874 : : endif
1875 [ - + ]: 4 : if(atp%fixed_zero) then
1876 : 0 : LIBPAW_ERROR('Fixed zero not implemented')
1877 : : endif
1878 [ - + ]: 4 : if(atp%shapetcore) then
1879 : 0 : LIBPAW_ERROR('Shapetcore not implemented')
1880 : : endif
1881 [ - + ]: 4 : if(atp%ColleSalvetti) then
1882 : 0 : LIBPAW_ERROR('ColleSalvetti not implemented')
1883 : : endif
1884 [ - + ]: 4 : if(.not.atp%ortho_type==ORTHO_TYPE_VANDERBILT) then
1885 : 0 : LIBPAW_ERROR('RCPAW only possible with Vanderbilt ortho scheme')
1886 : : endif
1887 [ - + ]: 4 : if(has_to_print) then
1888 : 0 : WRITE(STD_OUT,'(/,3x,a)') "===== Atompaw parameters ====="
1889 : : ! Atom
1890 : 0 : WRITE(STD_OUT,'(3x,a,a2)') "Atomic symbol : ",atp%atomic_symbol
1891 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Atomic charge : ",atp%atomic_charge
1892 : : ! Algo
1893 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Scalar-relativistic calculation:",MERGE("YES"," NO",atp%scalarrelativistic)
1894 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Dirac-relativistic calculation:",MERGE("YES"," NO",atp%diracrelativistic)
1895 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Frozen core calculation:",MERGE("YES"," NO",atp%frozencorecalculation)
1896 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Frozen vale calculation:",MERGE("YES"," NO",atp%frozenvalecalculation)
1897 [ # # ]: 0 : IF (atp%usespline) THEN
1898 : 0 : WRITE(STD_OUT,'(3x,a)') " - Use a spline solver"
1899 : : END IF
1900 : 0 : WRITE(STD_OUT,'(3x,2a)') "Exchange-correlation functional:",TRIM(atp%exctype)
1901 [ # # ]: 0 : WRITE(STD_OUT,'(3x,3a)') " (mGGA kinetic energy functional:",MERGE("YES"," NO",atp%needvtau),")"
1902 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Finite-nucleus calculation:",MERGE("YES"," NO",atp%finitenucleus)
1903 [ # # ]: 0 : IF (atp%finitenucleus) THEN
1904 : 0 : WRITE(STD_OUT,'(3x,a,i0)') " - Finite-nucleus model:",atp%finitenucleusmodel
1905 : : END IF
1906 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Block-Davidson calculation:",MERGE("YES"," NO",atp%BDsolve)
1907 : : ! Grid
1908 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Grid type:",atp%Grid%type
1909 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Grid size:",atp%Grid%n
1910 : 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Grid maximum value:",atp%Grid%r(atp%Grid%n)
1911 [ # # ]: 0 : if(atp%usespline) then
1912 : 0 : WRITE(STD_OUT,'(3x,a,f7.3,2x,i0)') "Spline grid r0, ns :",&
1913 : 0 : & atp%splr0,atp%splns
1914 : : endif
1915 : : ! XC
1916 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, post-processing:",MERGE("YES"," NO",atp%HFpostprocess)
1917 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, localized coreex.:",MERGE("YES"," NO",atp%localizedcoreexchange)
1918 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, fixed zero:",MERGE("YES"," NO",atp%fixed_zero)
1919 [ # # ]: 0 : IF (atp%fixed_zero) THEN
1920 : 0 : WRITE(STD_OUT,'(3x,a,i0)') " - HF fixed zero index:",atp%fixed_zero_index
1921 : : END IF
1922 [ # # # # ]: 0 : IF (atp%BDsolve.and.atp%gridkey=='LINEAR') THEN
1923 : 0 : WRITE(STD_OUT,'(/,3x,a)') "WARNING: BlockDavidson solver works very slowlywith linear grid!"
1924 : : END IF
1925 : 0 : WRITE(STD_OUT,'(3x,a,5(1x,i0))') "Max. quantum numbers (s,p,d,f,g):",atp%np(1:5)
1926 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of orbitals: ",atp%norbit
1927 : 0 : WRITE(STD_OUT,'(3x,a)') "Core and valence orbitals:"
1928 [ # # ]: 0 : IF (.NOT.atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') "n l : type"
1929 [ # # ]: 0 : IF (atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') "n l kappa :type"
1930 : : ! io=0
1931 : : ! DO ll=0,4
1932 : : ! nn=atp%np(ll+1)
1933 : : ! IF (nn>0) THEN
1934 : : ! IF (.NOT.atp%diracrelativistic) THEN
1935 : : ! DO ii=1+ll,nn
1936 : : ! io=io+1
1937 : : ! WRITE(STD_OUT,'(7x,i1,1x,i1,2a)') ii,ll," : ", &
1938 : : !& MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
1939 : : ! END DO
1940 : : ! ELSE
1941 : : ! DO ik=1,nkappa(ll+1)
1942 : : ! kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
1943 : : ! DO ii=1+ll,nn
1944 : : ! io=io+1
1945 : : ! WRITE(STD_OUT,'(7x,i1,1x,i1,2x,i2,2x,2a)') ii,ll,kk," : ", &
1946 : : ! & MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
1947 : : ! END DO
1948 : : ! END DO
1949 : : ! END IF
1950 : : ! END IF
1951 : : ! END DO
1952 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Basis, maximum L : ",atp%lmax
1953 : : !cutoff radii
1954 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Augmentation region radius : ",atp%rc
1955 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Core dens. matching radius : ",atp%rc_core
1956 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Local pot. matching radius : ",atp%rc_vloc
1957 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Compens. shape func radius : ",atp%rc_shap
1958 : : !Additional basis
1959 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Initial number of basis functions:",atp%nbasis-atp%nbasis_add
1960 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Number of additional basis functions:",atp%nbasis_add
1961 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of basis functions:",atp%nbasis
1962 : 0 : WRITE(STD_OUT,'(3x,a)') "Additional basis functions:"
1963 [ # # ]: 0 : IF (.NOT.atp%diracrelativistic) THEN
1964 : 0 : WRITE(STD_OUT,'(7x,a)') "l : energy"
1965 [ # # ]: 0 : DO io=1,atp%nbasis_add
1966 : 0 : WRITE(STD_OUT,'(7x,i1,a,f7.4)') atp%basis_add_l(io),":",atp%basis_add_energy(io)
1967 : : END DO
1968 : : ELSE
1969 : 0 : WRITE(STD_OUT,'(7x,a)') "l kappa : energy"
1970 [ # # ]: 0 : DO io=1,atp%nbasis_add
1971 : 0 : WRITE(STD_OUT,'(7x,i1,2x,i2,2x,a,f7.4)') atp%basis_add_l(io), &
1972 : 0 : & atp%basis_add_k(io)," : " ,atp%basis_add_energy(io)
1973 : : END DO
1974 : : END IF
1975 : : !Projectors
1976 : 0 : WRITE(STD_OUT,'(3x,a)') "Projectors description:"
1977 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_BLOECHL) &
1978 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : BLOECHL"
1979 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_VANDERBILT) &
1980 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : VANDERBILT"
1981 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_MODRRKJ) &
1982 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : MODRRKJ"
1983 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_CUSTOM) &
1984 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : CUSTOM"
1985 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_HF) &
1986 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : HARTREE-FOCK"
1987 [ # # ]: 0 : IF (atp%projector_type/=PROJECTOR_TYPE_HF) THEN
1988 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL) &
1989 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL"
1990 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM) &
1991 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : POLYNOM"
1992 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_RRKJ) &
1993 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : RRKJ"
1994 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
1995 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL KERKER"
1996 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM2) &
1997 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,es9.3)') "Pseudization : POLYNOM2,pdeg=",&
1998 : 0 : & atp%pseudo_polynom2_pdeg,", qcut=",atp%pseudo_polynom2_qcut
1999 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_GRAMSCHMIDT) &
2000 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : GRAM-SCHMIDT"
2001 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_VANDERBILT) &
2002 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : VANDERBILT"
2003 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_SVD) &
2004 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : SVD"
2005 : : END IF
2006 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_GAUSSIAN) &
2007 : 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Compensation charge shape function: GAUSSIAN,tol=",&
2008 : 0 : & atp%shapefunc_gaussian_param
2009 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_SINC) &
2010 : 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : SINC2"
2011 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_BESSEL) &
2012 : 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : BESSEL"
2013 [ # # ]: 0 : IF (atp%hf_coretol>0) &
2014 : 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Core tolerance for Hartree-Fock:",atp%hf_coretol
2015 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Smooth tcore shape (no negative nhat):",MERGE("YES"," NO",atp%shapetcore)
2016 : : !Local Psp
2017 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER) &
2018 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type:MTROULLIER,l=",&
2019 : 0 : & atp%vloc_l,", energy=",atp%vloc_ene
2020 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_ULTRASOFT) &
2021 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type:ULTRASOFT,l=",&
2022 : 0 : & atp%vloc_l,", energy=",atp%vloc_ene
2023 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_BESSEL) &
2024 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : BESSEL"
2025 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNC) &
2026 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
2027 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNNC) &
2028 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNNC"
2029 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_SETVLOC) THEN
2030 : 0 : WRITE(STD_OUT,'(7x,a,es9.4,a,es9.4)') "Local pseudopotential type:SETVLOC,coef=",&
2031 : 0 : & atp%vloc_setvloc_coef,", rad=",atp%vloc_setvloc_rad
2032 [ # # ]: 0 : IF (atp%needvtau) THEN
2033 : 0 : LIBPAW_ERROR('SETVLOC option not available for MGGA')
2034 : : ENDIF
2035 : : ENDIF
2036 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_EXPF) &
2037 : 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER EXPF,powers=",&
2038 : 0 : & atp%vloc_kerker_power(1:4)
2039 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_POLY) &
2040 : 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER POLY,powers=",&
2041 : 0 : & atp%vloc_kerker_power(1:4)
2042 [ # # # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.AND.atp%needvtau) THEN
2043 : 0 : WRITE(STD_OUT,'(7x,a)') 'NOTE: MTROULLIER Vloc not available for mGGA!'
2044 : 0 : WRITE(STD_OUT,'(7x,a)') ' Calling VPSmatch with norm conservation instead.'
2045 : 0 : WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
2046 : : END IF
2047 : 0 : WRITE(STD_OUT,'(3x,a)') "Matching radius for basis functions:"
2048 [ # # ]: 0 : IF (.NOT.atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') " # - n l : radius"
2049 [ # # ]: 0 : IF (atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') " # - n l kappa :radius"
2050 : : norb=0
2051 : : ! DO ll=0,atp%lmax
2052 : : ! DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic)
2053 : : ! kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
2054 : : ! IF (.NOT.atp%diracrelativistic) kk=0
2055 : : ! DO io=1,atp%norbit_val
2056 : : ! IF (atp%orbit_val_l(io)==ll.AND. &
2057 : : ! & ((.NOT.atp%diracrelativistic).OR.atp%orbit_val_k(io)==kk))THEN
2058 : : ! norb=norb+1
2059 : : ! IF (.NOT.atp%diracrelativistic) &
2060 : : ! & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,a,f7.4)') &
2061 : : ! & norb," - ",atp%orbit_val_n(io),ll," :",atp%basis_func_rc(norb)
2062 : : ! IF (atp%diracrelativistic) &
2063 : : ! & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,2x,i2,2x,a,f7.4)') &
2064 : : ! & norb," - ",atp%orbit_val_n(io),ll,kk," :",atp%basis_func_rc(norb)
2065 : : ! END IF
2066 : : ! END DO
2067 : : ! IF (atp%nbasis_add>0) THEN
2068 : : ! DO io=1,atp%nbasis_add
2069 : : ! IF (atp%basis_add_l(io)==ll.AND. &
2070 : : ! & ((.NOT.atp%diracrelativistic).OR.atp%basis_add_k(io)==kk))THEN
2071 : : ! norb=norb+1
2072 : : ! IF (.NOT.atp%diracrelativistic) &
2073 : : ! & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,a,f7.4)') &
2074 : : ! & norb," - ",".",ll," : ",atp%basis_func_rc(norb)
2075 : : ! IF (atp%diracrelativistic) &
2076 : : ! & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,2x,i2,2x,a,f7.4)') &
2077 : : ! & norb," - ",".",ll,kk," : ",atp%basis_func_rc(norb)
2078 : : ! END IF
2079 : : ! END DO
2080 : : ! END IF
2081 : : ! END DO
2082 : : ! END DO
2083 : : endif
2084 : 4 : end subroutine print_check_atompaw_params
2085 : :
2086 : :
2087 : :
2088 : :
2089 : :
2090 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2091 : : ! 1. aeatom
2092 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2093 : :
2094 : :
2095 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2096 : : !! Potential_Init
2097 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2098 : 23 : SUBROUTINE Potential_Init(Orbit,Pot,Grid)
2099 : : IMPLICIT NONE
2100 : : TYPE(OrbitInfo),INTENT(IN) :: Orbit
2101 : : TYPE(PotentialInfo),INTENT(INOUT) :: Pot
2102 : : TYPE(GridInfo),INTENT(IN) :: Grid
2103 : : real(dp) :: ecoul,v0
2104 : 23 : CALL atompaw_poisson(Grid,Pot%q,Orbit%den,Pot%rvh,ecoul,v0)
2105 [ - + ]: 23 : if(has_to_print) write(std_out,*) 'In Potential_Init', Pot%q,ecoul
2106 : 23 : END SUBROUTINE Potential_Init
2107 : :
2108 : :
2109 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2110 : : !! SCFatom
2111 : : !! Main atomic SCF routine to calculate the all electron atomic solution.
2112 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2113 : 23 : subroutine SCFatom(atp,initialize)
2114 : : implicit none
2115 : : logical, intent(in) :: initialize
2116 : : type(atompaw_type),target, intent(inout) :: atp
2117 [ + + ]: 23 : if(initialize) then
2118 : 4 : call Orbit_Init(atp%Orbit,atp%Pot,atp)
2119 : : endif
2120 : 23 : call Potential_Init(atp%Orbit,atp%Pot,atp%Grid)
2121 [ + + ]: 23 : if(atp%Orbit%frozenvalecalculation) atp%Pot%q=atp%electrons
2122 : 23 : call LDAGGA_SCF(atp)
2123 : 23 : end subroutine SCFatom
2124 : :
2125 : :
2126 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2127 : : !! Orbit_Init
2128 : : !! From nuclear charge -- generate hydrogenic-like initial wfns
2129 : : !! and densities --
2130 : : !! fill AEOrbit%wfn, AEOrbit%eig, and AEOrbit%den and AEOrbit%q
2131 : : !! also AEOrbit%otau and AEOrbit%tau
2132 : : !! Note that both den and tau need to be divided by 4 \pi r^2
2133 : : !! Note that tau is only correct for non-relativistic case
2134 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2135 : 4 : SUBROUTINE Orbit_Init(Orbit,Pot,atp)
2136 : : IMPLICIT NONE
2137 : : TYPE(PotentialInfo),INTENT(INOUT) :: Pot
2138 : : TYPE(OrbitInfo),INTENT(INOUT) :: Orbit
2139 : : type(atompaw_type), intent(in) :: atp
2140 : : INTEGER :: io,ir,l,np,kappa
2141 : : real(dp) :: qcal,rescale,zeff,xocc,fpi
2142 : 4 : REAL(dp),allocatable :: d(:)
2143 : : INTEGER :: initialconfig=0
2144 [ - + ]: 4 : IF (initialconfig/=0) STOP 'Error in aeatom -- Orbit_Init already called'
2145 : : ! calculate initial charge density from hydrogen-like functions
2146 : : ! also initial energies
2147 : 4 : zeff=Pot%nz
2148 [ + + ]: 4 : If (.not.atp%diracrelativistic) then
2149 [ + + ]: 20 : DO io=1,Orbit%norbit
2150 [ - + - - ]: 17 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
2151 : 17 : np=Orbit%np(io)
2152 : 17 : l=Orbit%l(io)
2153 : 17 : xocc=Orbit%occ(io)
2154 [ + - ]: 17 : if(.not.Orbit%frozenvalecalculation) Orbit%eig(io)=-(zeff/(np))**2!/2.0!Hartree
2155 [ - + ]: 17 : if(has_to_print) WRITE(std_out,*) io,np,l,xocc,Orbit%eig(io),zeff
2156 [ + + ]: 34034 : DO ir=1,atp%Grid%n
2157 : 34017 : Orbit%wfn(ir,io)=hwfn(zeff,np,l,atp%Grid%r(ir))
2158 [ + + ]: 34034 : IF (ABS(Orbit%wfn(ir,io))<machine_zero) Orbit%wfn(ir,io)=0._dp
2159 : : ENDDO
2160 : 17 : zeff=zeff-0.5_dp*xocc
2161 : 20 : zeff=MAX(zeff,1._dp)
2162 : : ENDDO
2163 : : endif
2164 [ + + ]: 4 : If (atp%diracrelativistic) then
2165 [ + + ]: 11 : DO io=1,Orbit%norbit
2166 [ - + - - ]: 10 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
2167 : 10 : np=Orbit%np(io)
2168 : 10 : l=Orbit%l(io)
2169 : 10 : kappa=Orbit%kappa(io)
2170 : 10 : xocc=Orbit%occ(io)
2171 [ + - ]: 10 : if(.not.Orbit%frozenvalecalculation) Orbit%eig(io)=-(zeff/(np))**2!/2.0
2172 [ + + ]: 20020 : DO ir=1,atp%Grid%n
2173 : : call dirachwfn(np,kappa,zeff,atp%Grid%r(ir),Orbit%eig(io) &
2174 : 20010 : & ,Orbit%wfn(ir,io),Orbit%lwfn(ir,io))
2175 [ + + ]: 20010 : IF (ABS(Orbit%wfn(ir,io))<machine_zero) Orbit%wfn(ir,io)=0._dp
2176 [ + + ]: 20020 : IF (ABS(Orbit%lwfn(ir,io))<machine_zero) Orbit%lwfn(ir,io)=0._dp
2177 : : ENDDO
2178 : 10 : zeff=zeff-0.5_dp*xocc
2179 : 11 : zeff=MAX(zeff,1._dp)
2180 : : ENDDO
2181 : : endif
2182 : : ! check charge and rescale
2183 [ + + ]: 8008 : Orbit%den=0._dp
2184 [ + + ]: 8008 : Orbit%tau=0._dp
2185 [ + + ]: 31 : DO io=1,Orbit%norbit
2186 [ - + - - ]: 27 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
2187 : : CALL taufromwfn(Orbit%otau(:,io),atp%Grid,Orbit%wfn(:,io),Orbit%l(io),&
2188 : 27 : & energy=Orbit%eig(io),rPot=Pot%rv)
2189 : 27 : xocc=Orbit%occ(io)
2190 [ + + ]: 54058 : DO ir=1,atp%Grid%n
2191 : 54027 : Orbit%den(ir)=Orbit%den(ir)+(Orbit%wfn(ir,io)**2)*xocc
2192 : 54027 : Orbit%tau(ir)=Orbit%tau(ir)+xocc*Orbit%otau(ir,io)
2193 [ + + ]: 54027 : If (atp%diracrelativistic) Orbit%den(ir)=Orbit%den(ir) + &
2194 : 20037 : & xocc*((Orbit%lwfn(ir,io))**2)
2195 : : ENDDO
2196 : : ENDDO
2197 : : ! Note that kinetic energy density (tau) is in Rydberg units ???
2198 : : ! Note that kinetic energy density is only correct for non-relativistic
2199 : : ! formulation
2200 : 4 : qcal=integrator(atp%Grid,Orbit%den)
2201 [ - + ]: 4 : if(Orbit%frozenvalecalculation) qcal=qcal+atp%Orbit%qval
2202 [ - + - - ]: 4 : if(Orbit%frozenvalecalculation) Orbit%den=Orbit%den+Orbit%valeden
2203 : : !rescale density
2204 : 4 : rescale=atp%electrons/qcal
2205 [ + + ]: 8008 : Orbit%den(1:atp%Grid%n)=Orbit%den(1:atp%Grid%n)*rescale
2206 [ + + ]: 8008 : Orbit%tau(1:atp%Grid%n)=Orbit%tau(1:atp%Grid%n)*rescale
2207 : : ! determine difference with tauW (Weizsaker)
2208 [ - + + - : 12 : LIBPAW_ALLOCATE(d,(atp%Grid%n)); fpi=4*pi
+ - + - -
+ - + ]
2209 [ + + ]: 8004 : d(2:atp%Grid%n)=Orbit%den(2:atp%Grid%n)/(fpi*atp%Grid%r(2:atp%Grid%n)**2)
2210 : 4 : call extrapolate(d)
2211 : 4 : CALL derivative(atp%Grid,d,Orbit%deltatau)
2212 [ + + ]: 8008 : Do ir=1,atp%Grid%n
2213 [ + + ]: 8008 : if (d(ir)>machine_zero) then
2214 : 6639 : Orbit%deltatau(ir)=0.25_dp*(Orbit%deltatau(ir)**2)/d(ir)
2215 : : else
2216 : 1365 : Orbit%deltatau(ir)=0.0_dp
2217 : : endif
2218 : : enddo
2219 [ + + ]: 8004 : d(2:atp%Grid%n)=Orbit%tau(2:atp%Grid%n)/(fpi*atp%Grid%r(2:atp%Grid%n)**2)
2220 : 4 : call extrapolate(d)
2221 [ + + ]: 8008 : Orbit%deltatau=d-Orbit%deltatau
2222 [ - + ]: 4 : LIBPAW_DEALLOCATE(d)
2223 : 4 : END SUBROUTINE Orbit_Init
2224 : :
2225 : :
2226 : :
2227 : :
2228 : :
2229 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2230 : : ! 2. atomdata
2231 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2232 : :
2233 : :
2234 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2235 : : !! Subroutine InitOrbit -- used in CopyOrbit
2236 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2237 : 362 : subroutine InitOrbit(Orbit,norbit,n,exctype,diracrelativistic,scalarrelativistic,frozencorecalculation,frozenvalecalculation)
2238 : : type (OrbitInfo), intent(inout) :: Orbit
2239 : : logical, intent(in) :: diracrelativistic
2240 : : logical, intent(in) :: scalarrelativistic
2241 : : logical, intent(in) :: frozencorecalculation,frozenvalecalculation
2242 : : integer, intent(in) :: n,norbit
2243 : : character(*),intent(in) :: exctype
2244 : 362 : CALL DestroyOrbit(Orbit)
2245 [ - + ]: 362 : Orbit%norbit=norbit;Orbit%exctype=trim(exctype)
2246 : 362 : Orbit%nps=0;Orbit%npp=0;Orbit%npd=0;Orbit%npf=0;Orbit%npg=0
2247 : 362 : Orbit%npsc=0;Orbit%nppc=0;Orbit%npdc=0;Orbit%npfc=0;Orbit%npgc=0
2248 : 362 : Orbit%qval=0._dp
2249 [ - + + - : 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%np,(norbit))
+ - + - -
+ - + ]
2250 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%l,(norbit))
- + - + ]
2251 [ - + + - : 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%eig,(norbit))
+ - + - -
+ - + ]
2252 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%occ,(norbit))
- + - + ]
2253 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%iscore,(norbit))
- + - + ]
2254 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%issemicore,(norbit))
- + - + ]
2255 [ + + ]: 2588 : Orbit%iscore=.false.
2256 [ + + ]: 2588 : Orbit%issemicore=.false.
2257 [ + + + + ]: 4814 : Orbit%np=0;Orbit%l=0
2258 [ + + + + ]: 4814 : Orbit%eig=0._dp;Orbit%occ=0._dp
2259 [ - + + - : 1448 : LIBPAW_POINTER_ALLOCATE(Orbit%wfn,(n,norbit))
- + + - +
- + - - +
- + ]
2260 [ - + + - : 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%otau,(n,norbit))
- + + - -
+ - + ]
2261 [ - + + - : 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%den,(n))
+ - + - -
+ - + ]
2262 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%tau,(n))
- + - + ]
2263 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%coreden,(n))
- + - + ]
2264 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%valeden,(n))
- + - + ]
2265 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%deltatau,(n))
- + - + ]
2266 [ + + + + : 10361990 : Orbit%wfn=0._dp;Orbit%den=0._dp;Orbit%tau=0._dp;Orbit%otau=0._dp
+ + + + +
+ + + ]
2267 [ + + ]: 724724 : Orbit%deltatau=0._dp
2268 [ + + + + ]: 1449086 : Orbit%coreden=0._dp ; Orbit%valeden=0._dp
2269 : 362 : Orbit%scalarrelativistic=scalarrelativistic
2270 : 362 : Orbit%frozencorecalculation=frozencorecalculation
2271 : 362 : Orbit%frozenvalecalculation=frozenvalecalculation
2272 : 362 : Orbit%diracrelativistic=diracrelativistic
2273 [ + + ]: 362 : If (Orbit%diracrelativistic) then
2274 [ - + + - : 132 : LIBPAW_POINTER_ALLOCATE(Orbit%lwfn,(n,norbit))
- + + - -
+ - + ]
2275 [ - + + - : 88 : LIBPAW_POINTER_ALLOCATE(Orbit%kappa,(norbit))
- + - + ]
2276 [ + + + + ]: 880924 : Orbit%lwfn=0._dp
2277 [ + + ]: 484 : Orbit%kappa=0._dp
2278 : : else
2279 : 318 : nullify(Orbit%lwfn,Orbit%kappa)
2280 : : endif
2281 [ + - - + ]: 362 : if (exctype == "HF".or.exctype == "EXXKLI") then
2282 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Orbit%lqp,(norbit,norbit))
# # # # #
# # # # #
# # ]
2283 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Orbit%X,(n,norbit))
# # # # #
# # # ]
2284 : : else
2285 : 362 : nullify(Orbit%lqp,Orbit%X)
2286 : : endif
2287 : 362 : end subroutine InitOrbit
2288 : :
2289 : :
2290 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2291 : : !! Subroutine DestroyOrbit
2292 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2293 : 728 : subroutine DestroyOrbit(Orbit)
2294 : : type (OrbitInfo), intent(inout) :: Orbit
2295 [ + + ]: 728 : if (associated(Orbit%np)) then
2296 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%np)
2297 : : endif
2298 [ + + ]: 728 : if (associated(Orbit%l)) then
2299 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%l)
2300 : : endif
2301 [ + + ]: 728 : if (associated(Orbit%kappa)) then
2302 : 44 : LIBPAW_POINTER_DEALLOCATE(Orbit%kappa)
2303 : : endif
2304 [ + + ]: 728 : if (associated(Orbit%iscore)) then
2305 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%iscore)
2306 : : endif
2307 [ + + ]: 728 : if (associated(Orbit%issemicore)) then
2308 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%issemicore)
2309 : : endif
2310 [ + + ]: 728 : if (associated(Orbit%eig)) then
2311 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%eig)
2312 : : endif
2313 [ + + ]: 728 : if (associated(Orbit%occ)) then
2314 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%occ)
2315 : : endif
2316 [ + + ]: 728 : if (associated(Orbit%wfn)) then
2317 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%wfn)
2318 : : endif
2319 [ + + ]: 728 : if (associated(Orbit%otau)) then
2320 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%otau)
2321 : : endif
2322 [ + + ]: 728 : if (associated(Orbit%lwfn)) then
2323 : 44 : LIBPAW_POINTER_DEALLOCATE(Orbit%lwfn)
2324 : : endif
2325 [ + + ]: 728 : if (associated(Orbit%den)) then
2326 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%den)
2327 : : endif
2328 [ + + ]: 728 : if (associated(Orbit%tau)) then
2329 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%tau)
2330 : : endif
2331 [ + + ]: 728 : IF (ASSOCIATED(Orbit%deltatau)) then
2332 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%deltatau)
2333 : : endif
2334 [ - + ]: 728 : if (associated(Orbit%lqp)) then
2335 : 0 : LIBPAW_POINTER_DEALLOCATE(Orbit%lqp)
2336 : : endif
2337 [ - + ]: 728 : if (associated(Orbit%X)) then
2338 : 0 : LIBPAW_POINTER_DEALLOCATE(Orbit%X)
2339 : : endif
2340 [ + + ]: 728 : if(associated(Orbit%coreden)) then
2341 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%coreden)
2342 : : endif
2343 [ + + ]: 728 : if(associated(Orbit%valeden)) then
2344 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%valeden)
2345 : : endif
2346 : 728 : end subroutine DestroyOrbit
2347 : :
2348 : :
2349 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2350 : : !! CopyOrbit(source,copy)
2351 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2352 : 358 : subroutine CopyOrbit(SOrbit,COrbit)
2353 : : type(OrbitInfo),intent(inout)::SOrbit
2354 : : type(OrbitInfo),intent(inout)::COrbit
2355 : : integer::n
2356 : 358 : n=size(SOrbit%den,1)
2357 : : call InitOrbit(COrbit,SOrbit%norbit,n,SOrbit%exctype,SOrbit%diracrelativistic,SOrbit%scalarrelativistic,&
2358 : 358 : & SOrbit%frozencorecalculation,SOrbit%frozenvalecalculation)
2359 : 358 : COrbit%nps=SOrbit%nps
2360 : 358 : COrbit%npp=SOrbit%npp
2361 : 358 : COrbit%npd=SOrbit%npd
2362 : 358 : COrbit%npf=SOrbit%npf
2363 : 358 : COrbit%npg=SOrbit%npg
2364 : 358 : COrbit%npsc=SOrbit%npsc
2365 : 358 : COrbit%nppc=SOrbit%nppc
2366 : 358 : COrbit%npdc=SOrbit%npdc
2367 : 358 : COrbit%npfc=SOrbit%npfc
2368 : 358 : COrbit%npgc=SOrbit%npgc
2369 : 358 : COrbit%qval=SOrbit%qval
2370 [ + + ]: 2557 : COrbit%np(1:SOrbit%norbit)=SOrbit%np(1:SOrbit%norbit)
2371 [ + + ]: 2557 : COrbit%l(1:SOrbit%norbit)=SOrbit%l(1:SOrbit%norbit)
2372 [ + + ]: 2557 : COrbit%eig(1:SOrbit%norbit)=SOrbit%eig(1:SOrbit%norbit)
2373 [ + + ]: 2557 : COrbit%occ(1:SOrbit%norbit)=SOrbit%occ(1:SOrbit%norbit)
2374 [ + + + + ]: 4402756 : COrbit%wfn(:,1:SOrbit%norbit)=SOrbit%wfn(:,1:SOrbit%norbit)
2375 [ + + + + ]: 4402756 : COrbit%otau(:,1:SOrbit%norbit)=SOrbit%otau(:,1:SOrbit%norbit)
2376 [ + + ]: 2557 : COrbit%iscore(1:SOrbit%norbit)=SOrbit%iscore(1:SOrbit%norbit)
2377 [ + + ]: 2557 : COrbit%issemicore(1:SOrbit%norbit)=SOrbit%issemicore(1:SOrbit%norbit)
2378 [ + + ]: 716716 : COrbit%den=SOrbit%den
2379 [ + + ]: 716716 : COrbit%coreden=SOrbit%coreden
2380 [ + + ]: 716716 : COrbit%valeden=SOrbit%valeden
2381 [ + + ]: 716716 : COrbit%tau=SOrbit%tau
2382 [ + + ]: 716716 : COrbit%deltatau=SOrbit%deltatau
2383 [ + + ]: 358 : if (SOrbit%diracrelativistic) then
2384 [ + + + + ]: 860903 : COrbit%lwfn(:,1:SOrbit%norbit)=SOrbit%lwfn(:,1:SOrbit%norbit)
2385 [ + + ]: 473 : COrbit%kappa(1:SOrbit%norbit)=SOrbit%kappa(1:SOrbit%norbit)
2386 : : endif
2387 [ + - - + ]: 358 : if (SOrbit%exctype == "HF".or.SOrbit%exctype == "EXXKLI") then
2388 [ # # # # ]: 0 : COrbit%X(:,1:SOrbit%norbit)=SOrbit%X(:,1:SOrbit%norbit)
2389 [ # # # # ]: 0 : COrbit%lqp(1:SOrbit%norbit,1:SOrbit%norbit)=SOrbit%lqp(1:SOrbit%norbit,1:SOrbit%norbit)
2390 : : endif
2391 : 358 : end subroutine CopyOrbit
2392 : :
2393 : :
2394 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2395 : : !! InitPot
2396 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2397 : 358 : subroutine InitPot(Pot,n)
2398 : : integer, intent(in) :: n
2399 : : type (PotentialInfo), intent(inout) :: Pot
2400 : 358 : CALL DestroyPot(Pot)
2401 [ - + + - : 1074 : LIBPAW_POINTER_ALLOCATE(Pot%rv,(n))
+ - + - -
+ - + ]
2402 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%rvn,(n))
- + - + ]
2403 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%rvh,(n))
- + - + ]
2404 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%rvx,(n))
- + - + ]
2405 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%vtau,(n))
- + - + ]
2406 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%ww,(n))
- + - + -
+ ]
2407 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%jj,(n))
- + - + -
+ ]
2408 [ + + + + : 3583580 : Pot%rv=0._dp;Pot%rvn=0._dp;Pot%rvh=0._dp;Pot%rvx=0._dp;Pot%vtau=0._dp
+ + + + +
+ ]
2409 [ + + + + ]: 1433432 : Pot%ww=0._dp;Pot%jj=0._dp
2410 : 358 : end subroutine InitPot
2411 : :
2412 : :
2413 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2414 : : !! DestroyPot
2415 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2416 : 716 : subroutine DestroyPot(Pot)
2417 : : type (PotentialInfo), intent(inout) :: Pot
2418 [ + + ]: 716 : if (associated(Pot%rv)) then
2419 : 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rv)
2420 : : endif
2421 [ + + ]: 716 : if (associated(Pot%rvn)) then
2422 : 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rvn)
2423 : : endif
2424 [ + + ]: 716 : if (associated(Pot%rvh)) then
2425 : 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rvh)
2426 : : endif
2427 [ + + ]: 716 : if (associated(Pot%rvx)) then
2428 : 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rvx)
2429 : : endif
2430 [ + + ]: 716 : if (associated(Pot%vtau)) then
2431 : 358 : LIBPAW_POINTER_DEALLOCATE(Pot%vtau)
2432 : : endif
2433 [ + + ]: 716 : if (allocated(Pot%ww)) then
2434 : 358 : LIBPAW_DEALLOCATE(Pot%ww)
2435 : : endif
2436 [ + + ]: 716 : if (allocated(Pot%jj)) then
2437 : 358 : LIBPAW_DEALLOCATE(Pot%jj)
2438 : : endif
2439 : 716 : end subroutine DestroyPot
2440 : :
2441 : :
2442 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2443 : : ! CopyPot(source,copy)
2444 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2445 : 354 : subroutine CopyPot(SPot,CPot)
2446 : : type(PotentialInfo),intent(in) :: SPot
2447 : : type(PotentialInfo),intent(inout) :: CPot
2448 : : integer :: n
2449 : 354 : n=SIZE(SPot%rv,1)
2450 : 354 : CALL InitPot(CPot,n)
2451 : 354 : CPot%nz=SPot%nz
2452 : 354 : CPot%zz=SPot%zz
2453 : 354 : CPot%sym=SPot%sym
2454 : 354 : CPot%q=SPot%q
2455 : 354 : CPot%v0=SPot%v0
2456 : 354 : CPot%v0p=SPot%v0p
2457 : 354 : CPot%finitenucleusmodel=SPot%finitenucleusmodel
2458 : 354 : CPot%finitenucleus=SPot%finitenucleus
2459 : 354 : CPot%Nv0=SPot%Nv0
2460 : 354 : CPot%Nv0p=SPot%Nv0p
2461 [ + + ]: 708708 : CPot%rv(1:n)=SPot%rv(1:n)
2462 [ + + ]: 708708 : CPot%rvn(1:n)=SPot%rvn(1:n)
2463 [ + + ]: 708708 : CPot%rvh(1:n)=SPot%rvh(1:n)
2464 [ + + ]: 708708 : CPot%rvx(1:n)=SPot%rvx(1:n)
2465 [ + + ]: 708708 : CPot%vtau(1:n)=SPot%vtau(1:n)
2466 [ + + ]: 708708 : CPot%ww(1:n)=SPot%ww(1:n)
2467 [ + + ]: 708708 : CPot%jj(1:n)=SPot%jj(1:n)
2468 : 354 : CPot%needvtau=SPot%needvtau
2469 : 354 : end subroutine CopyPot
2470 : :
2471 : :
2472 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2473 : : ! InitSCF
2474 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2475 : 4 : subroutine InitSCF(SCF)
2476 : : type(SCFInfo),intent(inout)::SCF
2477 : 4 : SCF%iter=0
2478 : 4 : SCF%delta=0._dp;SCF%eone=0._dp;SCF%ekin=0._dp;SCF%estatic=0._dp
2479 : 4 : SCF%ecoul=0._dp;SCF%eexc=0._dp;SCF%oepcs=0._dp;SCF%etot=0._dp
2480 : 4 : SCF%valekin=0._dp;SCF%valecoul=0._dp;SCF%valeexc=0._dp
2481 [ - + ]: 4 : SCF%corekin=0._dp;SCF%evale=0._dp
2482 : : end subroutine InitSCF
2483 : :
2484 : :
2485 : :
2486 : :
2487 : :
2488 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2489 : : ! 3. ldagga_mod
2490 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2491 : :
2492 : :
2493 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2494 : : ! LDAGGA_SCF
2495 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2496 : 23 : SUBROUTINE LDAGGA_SCF(atp)
2497 : : TYPE(atompaw_type), INTENT(inout) :: atp
2498 : : TYPE(Anderson_context):: AC
2499 : : INTEGER :: n
2500 : : real(dp) :: en1,etxc,eex,x,y
2501 : : real(dp), ALLOCATABLE :: arg(:)
2502 : : LOGICAL :: success
2503 : : character(132):: exctypesave
2504 : 23 : n=atp%Grid%n
2505 [ - + + - : 69 : LIBPAW_ALLOCATE(arg,(n))
+ - + - -
+ - + ]
2506 [ - + ]: 23 : if(atp%needvtau) then ! first converge LDA
2507 : 0 : atp%needvtau=.false.
2508 : 0 : atp%Pot%needvtau=.false.
2509 : 0 : exctypesave=atp%exctype
2510 : 0 : atp%exctype="LDA-PW"
2511 : 0 : call initexch(atp)
2512 : : CALL exch(atp%Grid,atp%Orbit%den,atp%Pot%rvx,etxc,eex,itype=atp%itype,&
2513 : 0 : & tau=atp%Orbit%tau,vtau=atp%Pot%vtau,xc_functionals=atp%xc_functionals)
2514 [ # # # # : 0 : arg=atp%Pot%rvh+atp%Pot%rvx ! iterating only on electronic part of pot
# # # # ]
2515 [ # # ]: 0 : atp%Pot%rv=atp%Pot%rvh+atp%Pot%rvx-atp%Pot%rvx(1)
2516 : 0 : CALL zeropot(atp%Grid,atp%Pot%rv,atp%Pot%v0,atp%Pot%v0p)
2517 [ # # ]: 0 : atp%Pot%rv=atp%Pot%rv+atp%Pot%rvn+atp%Pot%rvx(1)
2518 : 0 : CALL InitAnderson_dr(AC,6,5,n,0.2_dp,1.d3,100,seterr,settoosmall,.true.)
2519 : 0 : CALL DoAndersonMix(AC,arg,en1,LDAGGAsub,success,atp)
2520 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Anderson Mix with LDA',AC%res ,' iter = ',AC%CurIter
2521 : 0 : CALL FreeAnderson(AC)
2522 [ # # ]: 0 : if(has_to_print) write(STD_OUT,*) 'Completed initial iteration '
2523 : 0 : atp%needvtau=.true.
2524 : 0 : atp%Pot%needvtau=.true.
2525 : 0 : atp%exctype=exctypesave
2526 : 0 : call initexch(atp)
2527 : : endif
2528 : : CALL exch(atp%Grid,atp%Orbit%den,atp%Pot%rvx,etxc,eex,itype=atp%itype,&
2529 : : & needvtau=atp%Pot%needvtau,tau=atp%Orbit%tau,vtau=atp%Pot%vtau,&
2530 : 23 : & xc_functionals=atp%xc_functionals)
2531 [ + + ]: 46046 : atp%Pot%rv=atp%Pot%rvh+atp%Pot%rvx-atp%Pot%rvx(1)
2532 : 23 : CALL zeropot(atp%Grid,atp%Pot%rv,atp%Pot%v0,atp%Pot%v0p)
2533 [ + + ]: 46046 : atp%Pot%rv=atp%Pot%rv+atp%Pot%rvn+atp%Pot%rvx(1)
2534 : 23 : atp%SCF%iter=0
2535 : 23 : atp%SCF%delta=0
2536 [ - + ]: 23 : If (atp%needvtau) then
2537 : 0 : x=seterrmg; y=settoosmallmg
2538 : : else
2539 : 23 : x=seterr; y=settoosmall
2540 : : endif
2541 : 23 : CALL InitAnderson_dr(AC,6,5,n,0.6_dp,1.d3,MaxIter,x,y,has_to_print)
2542 [ - + ]: 23 : If (atp%needvtau) then
2543 [ # # # # : 0 : arg=atp%Orbit%den ! iterating on density
# # # # #
# ]
2544 : 0 : CALL DoAndersonMix(AC,arg,en1,DENITERsub,success,atp)
2545 : : !!!! evaluate vxc and vtau on universal grid
2546 : : !!!! because it may be bumpy at intermediate range from spline
2547 : : !!!! evaluation
2548 : : CALL exch(atp%Grid,atp%Orbit%den,atp%Pot%rvx,etxc,eex,itype=atp%itype,&
2549 : 0 : & tau=atp%Orbit%tau,vtau=atp%Pot%vtau)
2550 [ # # ]: 0 : atp%Pot%rv=atp%Pot%rvn+atp%Pot%rvh+atp%Pot%rvx
2551 : : else
2552 [ + - - + : 46069 : arg=atp%Pot%rvh+atp%Pot%rvx
- - + + ]
2553 : 23 : CALL DoAndersonMix(AC,arg,en1,LDAGGAsub,success,atp)
2554 : : endif
2555 : 23 : atp%SCF%iter=AC%CurIter
2556 : 23 : atp%SCF%delta=AC%res
2557 [ - + ]: 23 : if(has_to_print) WRITE(STD_OUT,*) 'Anderson Mix ',success,AC%res ,' iter = ',AC%CurIter
2558 [ - + ]: 23 : if (AC%res>1._dp) then
2559 : 0 : LIBPAW_ERROR('Sadly the program has not converged, Consider trying splineinterp')
2560 : : endif
2561 : 23 : CALL FreeAnderson(AC)
2562 [ - + ]: 23 : if(has_to_print) write(std_out,*) 'Finished Anderson Mix', en1 ,' success = ', success
2563 [ - + ]: 23 : LIBPAW_DEALLOCATE(arg)
2564 : 23 : END SUBROUTINE LDAGGA_SCF
2565 : :
2566 : :
2567 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2568 : : !!!!! LDAGGASub
2569 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2570 [ - + - + ]: 354 : SUBROUTINE LDAGGASub(w,energy,residue,err,success,update,atp)
2571 : : real(dp), INTENT(INOUT) :: w(:)
2572 : : real(dp), INTENT(OUT) :: energy
2573 : : real(dp), INTENT(OUT) :: residue(:)
2574 : : real(dp), INTENT(OUT) :: err
2575 : : LOGICAL, INTENT(OUT) :: success
2576 : : LOGICAL, INTENT(IN) :: update
2577 : : type(atompaw_type), intent(inout) :: atp
2578 : : INTEGER :: i,j,n,io,nw
2579 : 354 : real(dp),ALLOCATABLE :: dum(:)
2580 : : real(dp) :: x
2581 : : TYPE (OrbitInfo) :: tmpOrbit
2582 : 354 : TYPE (PotentialInfo) :: tmpPot
2583 : 354 : n=atp%Grid%n
2584 : 354 : nw=SIZE(w)
2585 [ + - + - : 1062 : LIBPAW_ALLOCATE(dum,(nw))
+ - - + -
+ ]
2586 : 354 : CALL CopyOrbit(atp%Orbit,tmpOrbit)
2587 : 354 : CALL CopyPot(atp%Pot,tmpPot)
2588 : 354 : CALL Updatewfn(atp%Grid,tmpPot,tmpOrbit,w,success,atp%BDsolve,atp%usespline,atp%spline,atp%itype)
2589 [ - + ]: 354 : if(has_to_print) write(std_out,*) 'completed updatewfn with success ', success
2590 [ + + ]: 354 : If (.not.success) then ! attempt to stablize solution
2591 : : !w=w+tmpPot%rvn
2592 [ - + - - : 17 : if(has_to_print) write(std_out,*) 'Current eigs', (atp%Orbit%eig(io),io=1,atp%Orbit%norbit)
- - ]
2593 : : j=n
2594 : 17 : x=atp%Orbit%eig(1)
2595 [ + - ]: 17 : if (atp%Orbit%norbit>1) then
2596 [ + + ]: 114 : do io = 2, atp%Orbit%norbit
2597 [ + - + + ]: 97 : if (atp%Orbit%eig(io)<0._dp.and.x<atp%Orbit%eig(io)) &
2598 : 70 : & x=atp%Orbit%eig(io)
2599 : : enddo
2600 : : endif
2601 : 17 : x=1._dp/sqrt(abs(x))
2602 : 17 : j=FindGridIndex(atp%Grid,x)
2603 [ - + ]: 17 : if(has_to_print) write(std_out,*) 'index', x,j,atp%Grid%r(j)
2604 [ - + ]: 17 : if (j<10)j=10
2605 [ - + ]: 17 : if (j>n-10) j=n-10
2606 : 17 : w(j+1)=(-1._dp+w(j+1)/2)
2607 [ + + ]: 15945 : do i=j+2,n
2608 : 15945 : w(i)=-2._dp
2609 : : enddo
2610 [ - + ]: 17 : if(has_to_print) write(std_out,*) 'Reset tmpPot ', j
2611 [ - + ]: 17 : if(has_to_print) write(std_out,*) ' Last points '
2612 [ - + ]: 17 : if(has_to_print) write(std_out,'(1p,20e15.7)') atp%Grid%r(n),w(n)
2613 : : !w=w-tmpPot%rvn
2614 : 17 : CALL Updatewfn(atp%Grid,tmpPot,tmpOrbit,w,success,atp%BDsolve,atp%usespline,atp%spline,atp%itype)
2615 [ - + ]: 17 : if(has_to_print) write(std_out,*) 'after updatwfn from reset ',success;
2616 : : Endif
2617 [ - + ]: 354 : IF (.NOT.success) THEN
2618 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'Bad luck in Sub'
2619 : : ENDIF
2620 : 354 : CALL Get_KinCoul(atp%Grid,tmpPot,tmpOrbit,atp%SCF,atp%usespline)
2621 : 354 : CALL Get_EXC(atp,tmpPot,tmpOrbit)
2622 [ + + ]: 708708 : dum(1:n)=tmpPot%rvh(1:n)+tmpPot%rvx(1:n)-w(1:n)
2623 [ + + ]: 708708 : residue=dum
2624 [ + + ]: 708708 : err=Dot_Product(residue,residue)
2625 : 354 : energy=atp%SCF%etot
2626 [ + - ]: 354 : IF (update) THEN
2627 [ + + ]: 708708 : atp%Pot%rv=w+tmpPot%rvn
2628 [ + + ]: 708708 : atp%Pot%rvh=tmpPot%rvh
2629 [ + + ]: 708708 : atp%Pot%rvx=tmpPot%rvx
2630 [ - + - - ]: 354 : if (atp%needvtau) atp%Pot%vtau=tmpPot%vtau
2631 [ + + + + ]: 4354704 : atp%Orbit%wfn=tmpOrbit%wfn
2632 [ + + + + : 861214 : If(atp%diracrelativistic) atp%Orbit%lwfn=tmpOrbit%lwfn
+ + ]
2633 [ + + ]: 2529 : atp%Orbit%eig=tmpOrbit%eig
2634 [ + + ]: 708708 : atp%Orbit%den=tmpOrbit%den
2635 [ + + + + ]: 4354704 : atp%Orbit%otau=tmpOrbit%otau
2636 [ + + ]: 708708 : atp%Orbit%tau=tmpOrbit%tau
2637 [ + + ]: 708708 : atp%Orbit%deltatau=tmpOrbit%deltatau
2638 : : ENDIF
2639 : 354 : CALL DestroyPot(tmpPot)
2640 : 354 : CALL DestroyOrbit(tmpOrbit)
2641 [ - + ]: 354 : LIBPAW_DEALLOCATE (dum)
2642 [ - + - + : 708 : END SUBROUTINE LDAGGASub
- + ]
2643 : :
2644 : :
2645 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2646 : : !!!! DENITERSub -- w is the electron density
2647 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2648 [ # # # # ]: 0 : SUBROUTINE DENITERSub(w,energy,residue,err,success,update,atp)
2649 : : REAL(dp), INTENT(INOUT) :: w(:)
2650 : : REAL(dp), INTENT(OUT) :: energy
2651 : : REAL(dp), INTENT(OUT) :: residue(:)
2652 : : REAL(dp), INTENT(OUT) :: err
2653 : : type(atompaw_type), intent(inout) :: atp
2654 : : LOGICAL, INTENT(OUT) :: success
2655 : : LOGICAL, INTENT(IN) :: update
2656 : : INTEGER :: n,nw
2657 : 0 : REAL(dp),ALLOCATABLE :: dum(:)
2658 : : REAL(dp) :: x,y
2659 : : TYPE (OrbitInfo) :: tmpOrbit
2660 : 0 : TYPE (PotentialInfo) :: tmpPot
2661 : 0 : n=atp%Grid%n
2662 : 0 : nw=SIZE(w)
2663 : 0 : if(n/=nw) then
2664 : 0 : write(std_out,*) 'problem in DENITERsub n,nw', n,nw
2665 : 0 : stop
2666 : : endif
2667 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(nw))
# # # # #
# # # ]
2668 : 0 : CALL CopyOrbit(atp%Orbit,tmpOrbit)
2669 : 0 : CALL CopyPot(atp%Pot,tmpPot)
2670 : : ! w enters subroutine as next iteration density
2671 : : ! It needs to be renormalized
2672 : : ! tmpPot%rvh, tmpPot%rvx, tmpPot%vtau need to be generated
2673 : 0 : x=integrator(atp%Grid,w)
2674 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'In DENITERsub norm(m) adjust ', x,atp%Pot%q
2675 [ # # ]: 0 : w=w*tmpPot%q/x
2676 : 0 : call atompaw_poisson(atp%Grid,x,w,tmpPot%rvh,y)
2677 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'after poisson q,ecoul ',x,y
2678 : 0 : call exch(atp%Grid,w,tmpPot%rvx,x,y,itype=atp%itype,tau=tmpOrbit%tau,vtau=tmpPot%vtau,xc_functionals=atp%xc_functionals)
2679 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'after exch exvct, eexc ',x,y
2680 [ # # ]: 0 : tmpPot%rv=tmpPot%rvn+tmpPot%rvh+tmpPot%rvx
2681 [ # # ]: 0 : tmpOrbit%den=w
2682 : 0 : CALL Updatewfnwden(atp%Grid,tmpPot,tmpOrbit,success,atp%usespline,atp%spline,atp%itype)
2683 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'completed updatewfnwden with success ', success
2684 [ # # ]: 0 : IF (.NOT.success) THEN
2685 : 0 : WRITE(STD_OUT,*) 'Bad luck in Sub'
2686 : : ENDIF
2687 : 0 : CALL Get_KinCoul(atp%Grid,tmpPot,tmpOrbit,atp%SCF,atp%usespline)
2688 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'Check tau ', integrator(atp%Grid,tmpOrbit%tau)
2689 : 0 : CALL Get_EXC(atp,tmpPot,tmpOrbit)
2690 [ # # ]: 0 : dum(1:n)=tmpOrbit%den(1:n)-w(1:n)
2691 [ # # ]: 0 : residue=dum
2692 [ # # ]: 0 : err=Dot_Product(residue,residue)
2693 [ # # ]: 0 : if(has_to_print) write(STD_OUT,*) 'in DENITERSub err ', err
2694 : 0 : energy=atp%SCF%etot
2695 [ # # ]: 0 : IF (update) THEN
2696 [ # # ]: 0 : atp%Pot%rv=tmpPot%rv
2697 [ # # ]: 0 : atp%Pot%rvh=tmpPot%rvh
2698 [ # # ]: 0 : atp%Pot%rvx=tmpPot%rvx
2699 [ # # # # ]: 0 : if (atp%needvtau) atp%Pot%vtau=tmpPot%vtau
2700 [ # # # # ]: 0 : atp%Orbit%wfn=tmpOrbit%wfn
2701 [ # # # # : 0 : If(atp%diracrelativistic)atp%Orbit%lwfn=tmpOrbit%lwfn
# # ]
2702 [ # # ]: 0 : atp%Orbit%eig=tmpOrbit%eig
2703 [ # # ]: 0 : atp%Orbit%den=w
2704 [ # # # # ]: 0 : atp%Orbit%otau=tmpOrbit%otau
2705 [ # # ]: 0 : atp%Orbit%tau=tmpOrbit%tau
2706 [ # # ]: 0 : atp%Orbit%deltatau=tmpOrbit%deltatau
2707 : : ENDIF
2708 : 0 : CALL DestroyOrbit(tmpOrbit)
2709 : 0 : CALL DestroyPot(tmpPot)
2710 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
2711 [ # # # # : 0 : END SUBROUTINE DENITERSub
# # ]
2712 : :
2713 : :
2714 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2715 : : !! Get_EXC
2716 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2717 : 354 : SUBROUTINE Get_EXC(atp,Pot,Orbit)
2718 : : ! program to calculate exc energy and potential
2719 : : ! assumes Orbit%den already known
2720 : : ! also assume kinetic and coulomb energies
2721 : : ! calculated and stored in SCF
2722 : : TYPE(Potentialinfo), INTENT(INOUT) :: Pot
2723 : : TYPE(Orbitinfo), INTENT(INOUT) :: Orbit
2724 : : TYPE(atompaw_type), INTENT(inout) :: atp
2725 : : real(dp) :: eex,etot,etxc
2726 : 354 : real(dp), ALLOCATABLE :: dum(:)
2727 : : INTEGER :: n,fin
2728 : 354 : n=atp%Grid%n
2729 : 354 : fin=atp%grid%n
2730 [ + + ]: 354 : if(atp%frozenvalecalculation) fin=atp%PAW%irc+5
2731 : : CALL exch(atp%Grid,Orbit%den,Pot%rvx,etxc,eex,itype=atp%itype,&
2732 : 354 : & needvtau=Pot%needvtau,tau=Orbit%tau,vtau=Pot%vtau,fin=fin,xc_functionals=atp%xc_functionals)
2733 : 354 : atp%SCF%eexc=eex
2734 : 354 : etot = atp%SCF%ekin+atp%SCF%estatic+atp%SCF%eexc
2735 : 354 : atp%SCF%etot=etot
2736 [ - + ]: 354 : if(has_to_print) WRITE(STD_OUT,*) ' Total : ',etot
2737 [ - + + - : 1062 : LIBPAW_ALLOCATE(dum,(n))
+ - + - -
+ - + ]
2738 [ + + ]: 708708 : dum=0
2739 [ + + ]: 708354 : dum(2:n)=Pot%rvx(2:n)*Orbit%den(2:n)/atp%Grid%r(2:n)
2740 [ - + ]: 354 : if (Pot%needvtau) then
2741 [ # # # # ]: 0 : dum=dum+Orbit%tau*Pot%vtau !Kinetic energy correction
2742 : : endif
2743 [ - + ]: 354 : if(has_to_print) then
2744 : 0 : WRITE(STD_OUT,*) ' Total (DC form) : ',&
2745 : 0 : & atp%SCF%eone-atp%SCF%ecoul+eex-integrator(atp%Grid,dum)
2746 : : endif
2747 [ - + ]: 354 : LIBPAW_DEALLOCATE(dum)
2748 : 354 : END SUBROUTINE Get_EXC
2749 : :
2750 : :
2751 : :
2752 : :
2753 : :
2754 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2755 : : ! 4. excor
2756 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2757 : :
2758 : :
2759 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2760 : : !! SUBROUTINE initexch(atp)
2761 : : !! choose form of exchange-correlation potential
2762 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2763 : 4 : SUBROUTINE initexch(atp)
2764 : : type(atompaw_type), intent(inout) :: atp
2765 : : integer :: id(2),i_plus,ii
2766 : : character*50 :: xcstrg(2)
2767 : 4 : CALL Uppercase(atp%exctype)
2768 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,*) atp%exctype
2769 : 6 : SELECT CASE(TRIM(atp%exctype))
2770 : : CASE default
2771 : 2 : atp%itype = LIBXC
2772 : 2 : i_plus=index(atp%exctype,'+')
2773 [ - + ]: 2 : if (i_plus<=0) then
2774 : 0 : xcstrg(1)=trim(atp%exctype)
2775 : 0 : xcstrg(2)=""
2776 : : else
2777 [ + - ]: 2 : xcstrg(1)=trim(atp%exctype(1:i_plus-1))
2778 [ - + ]: 2 : xcstrg(2)=trim(atp%exctype(i_plus+1:))
2779 : : end if
2780 [ + + ]: 6 : do ii=1,2
2781 : 6 : id(ii)=libxc_functionals_getid(xcstrg(ii))
2782 : : enddo
2783 : 2 : atp%ixc=-(id(1)*1000+id(2))
2784 [ - + ]: 2 : if(has_to_print)WRITE(STD_OUT,*) 'Using Libxc --',TRIM(atp%exctype),atp%ixc
2785 : 2 : call libxc_functionals_init(atp%ixc,1,atp%xc_functionals,el_temp=zero)
2786 [ - + - - ]: 2 : if(atp%needvtau.and.(.not.libxc_functionals_ismgga(atp%xc_functionals))) then
2787 : 0 : WRITE(STD_OUT,*) 'Problem with XC functional choice -- need mgga form for vtau '
2788 : 0 : WRITE(STD_OUT,*) ' Program stopping '
2789 : 0 : stop
2790 : : endif
2791 : 2 : write(std_out,*) 'END INITEXCH'
2792 : : CASE('LDA-PW')
2793 : 0 : atp%itype = LDA_PW
2794 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Perdew-Wang correlation'
2795 : : CASE('GGA-PBE')
2796 : 2 : atp%itype = GGA_PBE
2797 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'Perdew-Burke-Ernzerhof GGA'
2798 : : CASE('GGA-PBESOL')
2799 : 0 : atp%itype = GGA_PBESOL
2800 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Perdew-Burke-Ernzerhof modified (PBEsol) GGA'
2801 : : CASE ('MGGA-R2SCAN-001')
2802 : 0 : atp%itype = MGGA_R2SCAN_001
2803 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'R2SCAN MGGA with eta=0.001'
2804 : 0 : call r2scaninit(0.001_dp)
2805 : 0 : atp%needvtau=.true.
2806 : : CASE ('MGGA-R2SCAN-01')
2807 : 0 : atp%itype = MGGA_R2SCAN_01
2808 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'R2SCAN MGGA with eta=0.01'
2809 : 0 : call r2scaninit(0.01_dp)
2810 [ + - + - : 4 : atp%needvtau=.true.
- - ]
2811 : : !CASE ('HF')
2812 : : ! itype = NO_XC
2813 : : ! WRITE(STD_OUT,*) 'No XC'
2814 : : END SELECT
2815 : 4 : END SUBROUTINE initexch
2816 : :
2817 : :
2818 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2819 : : !! Logofterm
2820 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2821 : 712964 : FUNCTION Logofterm(term)
2822 : : real(dp) :: term, Logofterm
2823 [ + + ]: 712964 : IF (ABS(term)>machine_precision) THEN
2824 : 706094 : Logofterm=ddlog(1._dp+term)
2825 : : ELSE
2826 : : Logofterm=term
2827 : : ENDIF
2828 : : RETURN
2829 : : END FUNCTION Logofterm
2830 : :
2831 : :
2832 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2833 : : ! Subroutine radialexcpbe
2834 : : ! Density(:) input on a uniform radial mesh of Npts
2835 : : ! Grid%r(:) input mesh points
2836 : : ! Exc - output integrated exchange correlation energy -- in Rydberg units
2837 : : ! vxc(:) -- output exchange correlation potential -- in Rydberg units
2838 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2839 [ - + - + ]: 230 : SUBROUTINE radialexcpbe(Grid,density,Exc,vxc,mu,beta,fin)
2840 : : IMPLICIT NONE
2841 : : TYPE (GridInfo), INTENT(IN) :: Grid
2842 : : real(dp), intent(in) :: mu,beta
2843 : : REAL(dp), INTENT(IN) :: density(:)
2844 : : REAL(dp), INTENT(OUT) :: Exc, vxc(:)
2845 : : INTEGER, INTENT(IN), OPTIONAL :: fin
2846 : : INTEGER :: i,Npts
2847 : 230 : REAL(dp),ALLOCATABLE :: gradient(:),gradmag(:),gxc(:),dgxcdr(:),fxc(:)
2848 : : REAL(dp) :: dfxcdn,dfxcdgbg
2849 : 230 : Npts=Grid%n
2850 [ + + ]: 230 : IF (PRESENT(fin)) Npts=fin
2851 [ - + + - : 690 : LIBPAW_ALLOCATE(gradient,(Npts))
+ - + - -
+ - + ]
2852 [ - + + - : 460 : LIBPAW_ALLOCATE(gradmag,(Npts))
- + - + ]
2853 [ - + + - : 460 : LIBPAW_ALLOCATE(gxc,(Npts))
- + - + ]
2854 [ - + + - : 460 : LIBPAW_ALLOCATE(dgxcdr,(Npts))
- + - + ]
2855 [ - + + - : 460 : LIBPAW_ALLOCATE(fxc,(Npts))
- + - + ]
2856 : 230 : CALL derivative(Grid,density(1:Npts),gradient(1:Npts),1,Npts)
2857 [ - + + + ]: 362680 : gradmag=ABS(gradient)
2858 [ + + ]: 362450 : DO i=1,Npts
2859 : 362220 : CALL pbefunc(density(i),gradmag(i),fxc(i),dfxcdn,dfxcdgbg,mu,beta)
2860 : 362220 : vxc(i)=dfxcdn
2861 : 362450 : gxc(i)=dfxcdgbg*gradient(i)
2862 : : ENDDO
2863 : 230 : CALL derivative(Grid,gxc(1:Npts),dgxcdr(1:Npts),1,Npts)
2864 [ + + ]: 362220 : DO i=2,Npts
2865 : 361990 : fxc(i)=2*fxc(i)*4*pi*(Grid%r(i)**2) !2* changes from Har to Ryd
2866 : 362220 : vxc(i)=2*vxc(i)-2*dgxcdr(i)-4*gxc(i)/Grid%r(i) ! Correction thanks
2867 : : ! to Marc Torrent and Francois Jollet
2868 : : ENDDO
2869 : 230 : fxc(1)=zero
2870 : 230 : CALL extrapolate(vxc)
2871 : 230 : Exc = integrator(Grid,fxc,1,Npts)
2872 [ - + ]: 230 : LIBPAW_DEALLOCATE(gradient)
2873 [ - + ]: 230 : LIBPAW_DEALLOCATE(gradmag)
2874 [ - + ]: 230 : LIBPAW_DEALLOCATE(gxc)
2875 [ - + ]: 230 : LIBPAW_DEALLOCATE(dgxcdr)
2876 : 230 : LIBPAW_DEALLOCATE(fxc)
2877 : 230 : RETURN
2878 : : END SUBROUTINE radialexcpbe
2879 : :
2880 : :
2881 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2882 : : !! exch
2883 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2884 [ - + + - : 377 : SUBROUTINE exch(Grid,den,rvxc,etxc,eexc,itype,fin,v0,v0p,needvtau,tau,vtau,xc_functionals)
+ - - + -
+ + - + -
- + ]
2885 : : ! calculate exchange correlation potentials and energies
2886 : : ! for density functional theory from electron density
2887 : : ! den(n) is electron density * (4*pi*r**2)
2888 : : ! rvxc(n) is returned as vxc * r
2889 : : ! eexc is the total exchange energy (int(den*exc))
2890 : : ! etxc is eexc - int(den*vxc)
2891 : : ! icx id of the exchange-correlation functional
2892 : : ! xclevel level of the exchange-correlation functional used
2893 : : ! fin (optional) is integer range of densities and potentials
2894 : : ! v0 (optional) is extrapolated value of vxc for r=0
2895 : : ! v0p (optional) is extrapolated value of dvxc/dr for r=0
2896 : : ! needvtau (optional) is logical .true. if mgga
2897 : : ! tau(n) (optional) is kinetic energy density * (4*pi*r**2)
2898 : : ! vtau(n) (optional) is kinetic energy contribution for mgga
2899 : : TYPE (GridInfo), INTENT(IN) :: Grid
2900 : : REAL(dp), INTENT(IN) :: den(:)
2901 : : REAL(dp), INTENT(INOUT) :: rvxc(:),etxc,eexc
2902 : : type(libxc_functional_type),intent(inout),optional :: xc_functionals(2)
2903 : : integer, intent(in) :: itype
2904 : : INTEGER, INTENT(IN), OPTIONAL :: fin
2905 : : REAL(dp), INTENT(OUT), OPTIONAL :: v0,v0p
2906 : : LOGICAL, INTENT(OUT), OPTIONAL :: needvtau
2907 : : REAL(dp), INTENT(IN),OPTIONAL :: tau(:)
2908 : : REAL(dp), INTENT(INOUT),OPTIONAL :: vtau(:)
2909 : 377 : REAL(dp), ALLOCATABLE :: tmpd(:),tmpv(:),dum(:)
2910 : 377 : REAL(dp), ALLOCATABLE :: exci(:),dfxcdgbg(:,:),gxc(:),dgxcdr(:)
2911 : 377 : REAL(dp), ALLOCATABLE :: grad(:),gradmag(:),dum1(:),sigma(:),tmpvt(:)
2912 : 377 : REAL(dp), ALLOCATABLE :: tmpt(:),tmpl(:),dgxcdl(:),dexcdn(:),dexcds(:)
2913 : : REAL(dp) :: fpi,beta,mu
2914 : : INTEGER :: i,n,order,nspden,ndvxc,nd2vxc
2915 : : REAL(dp) :: r,r2,exc,vxc
2916 : 377 : n=Grid%n
2917 [ + + ]: 377 : IF (PRESENT(fin)) n=fin
2918 : : fpi=four*pi
2919 [ + + ]: 754754 : rvxc=0;etxc=0;eexc=0
2920 [ - + ]: 377 : if (PRESENT(v0)) v0=0
2921 [ - + ]: 377 : if (PRESENT(v0p)) v0p=0
2922 [ + - ]: 377 : if (PRESENT(needvtau)) then
2923 [ - + - - ]: 377 : if (needvtau.and.(PRESENT(vtau).eqv..false.)) then
2924 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'exch: Inconsistency in mgga ', needvtau,PRESENT(vtau)
2925 : 0 : LIBPAW_ERROR('exch: stopping execution ')
2926 : : endif
2927 : : endif
2928 [ + - + + ]: 754754 : if (PRESENT(vtau)) vtau=0._dp
2929 [ + + ]: 377 : If (itype==GGA_PBE.or.itype==GGA_PBESOL) then
2930 [ - + + - : 690 : LIBPAW_ALLOCATE(tmpd,(n))
+ - + - -
+ - + ]
2931 [ - + + - : 460 : LIBPAW_ALLOCATE(tmpv,(n))
- + - + ]
2932 [ + + ]: 362450 : tmpd=zero
2933 [ + - ]: 230 : if(itype==GGA_PBE) then
2934 : 230 : mu=muorig;beta=betorig
2935 : : else
2936 : 0 : mu=musol;beta=betsol
2937 : : endif
2938 [ + + ]: 362220 : DO i=2,n
2939 : 362220 : tmpd(i)=den(i)/(fpi*(Grid%r(i)**2))
2940 : : ENDDO
2941 : 230 : CALL extrapolate(tmpd)
2942 [ + + ]: 230 : IF (PRESENT(fin)) THEN
2943 : 216 : CALL radialexcpbe(Grid,tmpd,eexc,tmpv,mu,beta,fin)
2944 : : ELSE
2945 : 14 : CALL radialexcpbe(Grid,tmpd,eexc,tmpv,mu,beta)
2946 : : ENDIF
2947 [ - + ]: 230 : IF (PRESENT(v0).AND.PRESENT(v0p)) THEN
2948 : 0 : CALL derivative(Grid,tmpv,tmpd,1,15)
2949 : 0 : v0=tmpv(1)
2950 : 0 : v0p=tmpd(1)
2951 : : ENDIF
2952 [ + + ]: 362450 : DO i=1,n
2953 : 362220 : rvxc(i)=tmpv(i)*Grid%r(i)
2954 : 362450 : tmpv(i)=tmpv(i)*den(i)
2955 : : ENDDO
2956 : 230 : etxc=eexc-integrator(Grid,tmpv(1:n),1,n)
2957 [ - + ]: 230 : LIBPAW_DEALLOCATE(tmpd)
2958 [ - + ]: 230 : LIBPAW_DEALLOCATE(tmpv)
2959 [ - + ]: 147 : ELSE IF (itype==LDA_PW) then !!! ! Perdew-Wang LDA !!!!
2960 [ # # # # : 0 : LIBPAW_ALLOCATE(tmpd,(n))
# # # # #
# # # ]
2961 [ # # # # : 0 : LIBPAW_ALLOCATE(tmpv,(n))
# # # # ]
2962 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(n))
# # # # ]
2963 [ # # # # : 0 : tmpd=0;tmpv=0;rvxc=0;dum=0
# # # # ]
2964 [ # # ]: 0 : DO i=2,n
2965 : 0 : r=Grid%r(i)
2966 : 0 : r2=r*r
2967 : 0 : tmpd(i)=den(i)/(fpi*r2)
2968 : : ENDDO
2969 : 0 : CALL extrapolate(tmpd)
2970 [ # # ]: 0 : DO i=1,n
2971 : 0 : CALL pwldafunc(tmpd(i),exc,vxc)
2972 : 0 : tmpd(i)=den(i)*(exc-vxc)
2973 : 0 : tmpv(i)=den(i)*exc
2974 : 0 : rvxc(i)=Grid%r(i)*vxc
2975 [ # # ]: 0 : IF (PRESENT(v0).AND.PRESENT(v0p)) THEN
2976 [ # # ]: 0 : IF (i==1) v0=vxc
2977 : 0 : dum(i)=vxc
2978 : : ENDIF
2979 : : ENDDO
2980 : 0 : etxc=integrator(Grid,tmpd(1:n),1,n)
2981 : 0 : eexc=integrator(Grid,tmpv(1:n),1,n)
2982 [ # # ]: 0 : IF (PRESENT(v0).AND.PRESENT(v0p)) THEN
2983 : 0 : CALL derivative(Grid,dum,tmpd,1,15)
2984 : 0 : v0p=tmpd(1)
2985 : : ENDIF
2986 [ # # ]: 0 : LIBPAW_DEALLOCATE(tmpd)
2987 [ # # ]: 0 : LIBPAW_DEALLOCATE(tmpv)
2988 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
2989 [ - + ]: 147 : ELSE IF (itype==MGGA_R2SCAN_001.or.itype==MGGA_R2SCAN_01) then !!r2scan
2990 [ # # # # : 0 : LIBPAW_ALLOCATE(tmpd,(n))
# # # # #
# # # ]
2991 [ # # # # : 0 : LIBPAW_ALLOCATE(tmpv,(n))
# # # # ]
2992 [ # # # # : 0 : LIBPAW_ALLOCATE(exci,(n))
# # # # ]
2993 [ # # # # : 0 : LIBPAW_ALLOCATE(tmpt,(n))
# # # # ]
2994 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(n))
# # # # ]
2995 [ # # # # : 0 : LIBPAW_ALLOCATE(dum1,(n))
# # # # ]
2996 [ # # # # : 0 : tmpd=0._dp; tmpv=0._dp; exci=0._dp;tmpt=0._dp
# # # # ]
2997 [ # # ]: 0 : dum1=0._dp
2998 [ # # ]: 0 : tmpd(2:n)=den(2:n)/(fpi*(Grid%r(2:n)**2))
2999 : 0 : call extrapolate(tmpd)
3000 [ # # # # : 0 : LIBPAW_ALLOCATE(grad,(n))
# # # # ]
3001 [ # # # # : 0 : LIBPAW_ALLOCATE(sigma,(n))
# # # # ]
3002 [ # # # # : 0 : LIBPAW_ALLOCATE(dexcdn,(n))
# # # # ]
3003 [ # # # # : 0 : LIBPAW_ALLOCATE(dexcds,(n))
# # # # ]
3004 [ # # # # : 0 : grad=0._dp;sigma=0._dp;dexcdn=0._dp;dexcds=0._dp
# # # # ]
3005 [ # # ]: 0 : do i=1,n
3006 : 0 : dum1(i)=ddlog(tmpd(i))
3007 : : enddo
3008 : 0 : call derivative(Grid,dum1,grad,1,n)
3009 [ # # ]: 0 : grad(1:n)=grad(1:n)*tmpd(1:n) ! perhaps more accurate???
3010 [ # # # # ]: 0 : sigma=grad**2
3011 : : ! Prepare kinetic energy input tau -- used for most mgga
3012 [ # # ]: 0 : tmpt(2:n)=tau(2:n)/(fpi*(Grid%r(2:n)**2))
3013 : 0 : call extrapolate(tmpt)
3014 : : ! convert to Hartree units
3015 [ # # ]: 0 : tmpt=0.5_dp*tmpt
3016 [ # # ]: 0 : do i=1,n
3017 : : call r2scanfun(tmpd(i),grad(i),tmpt(i),&
3018 : 0 : & exci(i),vtau(i),dexcdn(i),dexcds(i))
3019 : : enddo
3020 : : ! convert to Rydberg units
3021 [ # # ]: 0 : exci=two*exci
3022 [ # # ]: 0 : dexcdn=two*dexcdn
3023 [ # # ]: 0 : dexcds=four*dexcds !extra factor of two due to sigma=grad**2
3024 [ # # ]: 0 : rvxc=0._dp
3025 [ # # ]: 0 : rvxc=dexcdn
3026 [ # # ]: 0 : dum(1:n)=dexcds(1:n)
3027 : 0 : call derivative(Grid,dum,dum1,1,n)
3028 [ # # ]: 0 : dum(2:n)=two*dum(2:n)/(Grid%r(2:n))
3029 : 0 : call extrapolate(dum)
3030 [ # # ]: 0 : rvxc=rvxc-dum1-dum
3031 [ # # ]: 0 : dum(1:n)=exci(1:n)*fpi*(Grid%r(1:n)**2)
3032 : 0 : eexc=integrator(Grid,dum(1:n),1,n)
3033 [ # # ]: 0 : dum(1:n)=rvxc(1:n)*den(1:n)
3034 : 0 : etxc=eexc-integrator(Grid,dum(1:n),1,n)
3035 [ # # ]: 0 : rvxc(1:n)=(dexcdn(1:n)-dum1(1:n))*Grid%r(1:n)-two*dexcds(1:n)
3036 [ # # ]: 0 : LIBPAW_DEALLOCATE(grad)
3037 [ # # ]: 0 : LIBPAW_DEALLOCATE(sigma)
3038 [ # # ]: 0 : LIBPAW_DEALLOCATE(dexcdn)
3039 [ # # ]: 0 : LIBPAW_DEALLOCATE(dexcds)
3040 [ # # ]: 0 : LIBPAW_DEALLOCATE(tmpd)
3041 [ # # ]: 0 : LIBPAW_DEALLOCATE(tmpv)
3042 [ # # ]: 0 : LIBPAW_DEALLOCATE(exci)
3043 [ # # ]: 0 : LIBPAW_DEALLOCATE(tmpt)
3044 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
3045 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum1)
3046 [ + - ]: 147 : ELSE IF (itype==LIBXC) then
3047 : : ! Parameters
3048 [ + - - + : 147 : if(.not.libxc_functionals_islda(xc_functionals).and..not.libxc_functionals_isgga(xc_functionals)) then
- - ]
3049 : 0 : STOP
3050 : : endif
3051 : 147 : order=1
3052 : 147 : nspden=1
3053 : 147 : ndvxc=0
3054 : 147 : nd2vxc=0
3055 : : ! Allocations
3056 [ - + + - : 441 : LIBPAW_ALLOCATE(tmpd,(n))
+ - + - -
+ - + ]
3057 [ - + + - : 294 : LIBPAW_ALLOCATE(tmpv,(n))
- + - + ]
3058 [ - + + - : 294 : LIBPAW_ALLOCATE(exci,(n))
- + - + ]
3059 [ - + + - : 294 : LIBPAW_ALLOCATE(tmpt,(n))
- + - + ]
3060 [ - + + - : 294 : LIBPAW_ALLOCATE(grad,(n))
- + - + ]
3061 [ - + + - : 294 : LIBPAW_ALLOCATE(gradmag,(n))
- + - + ]
3062 [ - + + - : 294 : LIBPAW_ALLOCATE(gxc,(n))
- + - + ]
3063 [ - + + - : 294 : LIBPAW_ALLOCATE(dgxcdr,(n))
- + - + ]
3064 [ - + + - : 441 : LIBPAW_ALLOCATE(dfxcdgbg,(n,3))
+ - + - -
+ - + ]
3065 [ - + + - : 294 : LIBPAW_ALLOCATE(tmpl,(n))
- + - + ]
3066 [ - + + - : 294 : LIBPAW_ALLOCATE(dgxcdl,(n))
- + - + ]
3067 [ - + + - : 294 : LIBPAW_ALLOCATE(tmpvt,(n))
- + - + ]
3068 [ - + + - : 294 : LIBPAW_ALLOCATE(dum,(n))
- + - + ]
3069 [ - + + - : 294 : LIBPAW_ALLOCATE(dum1,(n))
- + - + ]
3070 [ + + + + : 1016855 : tmpd=0._dp; tmpv=0._dp; exci=0._dp;tmpt=0._dp
+ + + + ]
3071 [ + + + + : 1779827 : grad=0._dp;gradmag=0._dp;gxc=0._dp;dgxcdr=0._dp;dfxcdgbg=0._dp
+ + + + +
+ + + ]
3072 [ + + + + : 1271032 : tmpl=0._dp; dgxcdl=0._dp;tmpvt=0._dp;dum=0._dp;dum1=0._dp
+ + + + +
+ ]
3073 : : ! Density
3074 [ + + ]: 254177 : tmpd(2:n)=den(2:n)/(fpi*(Grid%r(2:n)**2))
3075 : 147 : call extrapolate(tmpd)
3076 : : ! Grad
3077 [ + + ]: 254324 : tmpv=0._dp
3078 [ + + ]: 254324 : do i=1,n
3079 : 254324 : tmpv(i)=ddlog(tmpd(i))
3080 : : enddo
3081 : 147 : call derivative(Grid,tmpv,grad,1,n)
3082 [ + + ]: 254324 : grad(1:n)=grad(1:n)*tmpd(1:n) ! perhaps more accurate???
3083 [ + + ]: 254324 : tmpv=0._dp
3084 [ - + + + ]: 254471 : gradmag=ABS(grad)*ABS(grad)
3085 : : ! Tau
3086 [ + + ]: 254177 : tmpt(2:n)=tau(2:n)/(fpi*(Grid%r(2:n)**2))
3087 : 147 : call extrapolate(tmpt)
3088 : : ! Laplacian
3089 : 147 : call derivative(Grid,grad,tmpl,1,n)
3090 [ + + ]: 254177 : tmpl(2:n)=tmpl(2:n)+2._dp*grad(2:n)/Grid%r(2:n)
3091 : 147 : call extrapolate(tmpl)
3092 : : ! calc
3093 [ + + ]: 254324 : tmpd=tmpd/two
3094 [ + + ]: 254324 : gradmag=gradmag/four
3095 : : call libxc_functionals_getvxc(ndvxc,nd2vxc,n,nspden,order,tmpd,exci,tmpv,&
3096 : : & grho2=gradmag,lrho=tmpl,vxcgr=dfxcdgbg,vxclrho=dgxcdl,tau=tmpt,vxctau=tmpvt,&
3097 : 147 : & xc_functionals=xc_functionals)
3098 [ + + ]: 254324 : tmpd=tmpd*two
3099 [ + + ]: 254324 : gradmag=gradmag*four
3100 : : ! Units
3101 [ + + ]: 254324 : exci=two*exci
3102 [ + + ]: 254324 : tmpv=two*tmpv
3103 [ + + + + ]: 763119 : dfxcdgbg=dfxcdgbg*two
3104 : : ! Post-process
3105 [ + + ]: 254324 : gxc(1:n)=dfxcdgbg(1:n,3)*grad(1:n)
3106 : 147 : call derivative(Grid,gxc,dgxcdr,1,n)
3107 [ + + ]: 254177 : tmpv(2:n)=tmpv(2:n)-dgxcdr(2:n)-2._dp*gxc(2:n)/Grid%r(2:n)
3108 : 147 : call extrapolate(tmpv)
3109 : : ! dum=0._dp
3110 : : ! call derivative(Grid,dgxcdl,dum,1,n)
3111 : : ! dum1=0._dp
3112 : : ! call derivative(Grid,dum,dum1,1,n)
3113 : : ! tmpv(2:n)=tmpv(2:n)+dum1(2:n)+2._dp*dum(2:n)/Grid%r(2:n)
3114 : : ! call extrapolate(tmpv)
3115 : : ! if (needvtau) vtau=tmpvt
3116 [ + + ]: 254324 : do i=1,n
3117 [ + - + + ]: 254177 : if (.not.ieee_is_normal(tmpv(i)).or.abs(tmpv(i)).lt.practical_zero) tmpv(i)=0._dp
3118 [ + - + + ]: 254177 : if (.not.ieee_is_normal(exci(i)).or.abs(exci(i)).lt.practical_zero)exci(i)=0._dp
3119 [ + - + - ]: 254177 : if (.not.ieee_is_normal(vtau(i)).or.abs(vtau(i)).lt.practical_zero)vtau(i)=0._dp
3120 [ + - + + ]: 254324 : if (.not.ieee_is_normal(tmpd(i)).or.abs(tmpd(i)).lt.practical_zero)tmpd(i)=0._dp
3121 : : enddo
3122 [ + + ]: 294294 : rvxc=0._dp
3123 [ + + ]: 254324 : rvxc(1:n)=tmpv(1:n)*Grid%r(1:n)
3124 [ + + ]: 254324 : exci(1:n)=exci(1:n)*tmpd(1:n)*fpi*Grid%r(1:n)**2
3125 : 147 : eexc=integrator(Grid,exci,1,n)
3126 [ - + ]: 147 : if (present(v0).and.present(v0p)) then
3127 : 0 : call derivative(Grid,tmpv,tmpd,1,15)
3128 : 0 : v0=tmpv(1);v0p=tmpd(1)
3129 : : endif
3130 [ + + ]: 254324 : tmpv(1:n)=tmpv(1:n)*den(1:n)
3131 : 147 : etxc=eexc-integrator(Grid,tmpv(1:n),1,n)
3132 [ - + ]: 147 : if(has_to_print) WRITE(STD_OUT,*) 'etxc,eexc = ',etxc,eexc
3133 : : ! DEALLOCATE
3134 [ - + ]: 147 : LIBPAW_DEALLOCATE(tmpd)
3135 [ - + ]: 147 : LIBPAW_DEALLOCATE(tmpv)
3136 [ - + ]: 147 : LIBPAW_DEALLOCATE(exci)
3137 [ - + ]: 147 : LIBPAW_DEALLOCATE(tmpt)
3138 [ - + ]: 147 : LIBPAW_DEALLOCATE(grad)
3139 [ - + ]: 147 : LIBPAW_DEALLOCATE(gradmag)
3140 [ - + ]: 147 : LIBPAW_DEALLOCATE(gxc)
3141 [ - + ]: 147 : LIBPAW_DEALLOCATE(dgxcdr)
3142 [ - + ]: 147 : LIBPAW_DEALLOCATE(dfxcdgbg)
3143 [ - + ]: 147 : LIBPAW_DEALLOCATE(tmpl)
3144 [ - + ]: 147 : LIBPAW_DEALLOCATE(dgxcdl)
3145 [ - + ]: 147 : LIBPAW_DEALLOCATE(tmpvt)
3146 [ - + ]: 147 : LIBPAW_DEALLOCATE(dum)
3147 [ - + ]: 147 : LIBPAW_DEALLOCATE(dum1)
3148 : : else
3149 : 0 : WRITE(STD_OUT,*) 'Warning (EXCOR): ', itype,' no results returned !'
3150 : 0 : STOP
3151 : : END if
3152 [ - + - + : 377 : END SUBROUTINE exch
- + - + -
+ - + - +
- + - + -
+ ]
3153 : :
3154 : :
3155 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3156 : : !! pwldafunc
3157 : : !! Subroutine to calculate the LDA exchange correlation functionals
3158 : : !! using the form of Perdew and Wang (PRB 45, 13244 (1992)
3159 : : !! assuming no spin polarization
3160 : : !! Inside this routine, energies are in Hartree units
3161 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3162 : 0 : SUBROUTINE pwldafunc(den,exc,vxc)
3163 : : real(dp), INTENT(IN) :: den !density
3164 : : real(dp), INTENT(OUT) :: exc,vxc
3165 : : real(dp), PARAMETER :: AA=0.0310907_dp
3166 : : real(dp), PARAMETER :: a1=0.21370_dp
3167 : : real(dp), PARAMETER :: b1=7.59570_dp
3168 : : real(dp), PARAMETER :: b2=3.58760_dp
3169 : : real(dp), PARAMETER :: b3=1.63820_dp
3170 : : real(dp), PARAMETER :: b4=0.49294_dp
3171 : : ! Variables depending on den
3172 : : real(dp) :: n,kf,rs,ks
3173 : : real(dp) :: ex,ec,pprs,decdrs
3174 : : real(dp) :: term
3175 : 0 : n=den
3176 [ # # ]: 0 : IF (n < machine_zero) THEN
3177 : 0 : exc=0._dp; vxc=0._dp
3178 : 0 : RETURN
3179 : : ENDIF
3180 : 0 : kf=(3._dp*(pi**2)*n)**0.3333333333333333333333333333_dp
3181 : 0 : rs=(3._dp/(4._dp*pi*n))**0.3333333333333333333333333333_dp
3182 : : ks=SQRT(4._dp*kf/pi)
3183 : 0 : ex=-3._dp*kf/(4._dp*pi)
3184 : 0 : pprs=SQRT(rs)*(b1+b3*rs)+rs*(b2+b4*rs)
3185 : 0 : term=Logofterm(1._dp/(2._dp*AA*pprs))
3186 : 0 : ec=-2._dp*AA*(1._dp+a1*rs)*term
3187 : 0 : exc=ex+ec
3188 : : decdrs=-(2._dp*AA*a1)*term &
3189 : : & +((1._dp+a1*rs)*((b1+3*b3*rs)/(2._dp*SQRT(rs))+&
3190 : 0 : & b2+2*b4*rs))/(pprs*(pprs+1._dp/(2._dp*AA)))
3191 : 0 : vxc = (4._dp/3._dp)*ex+ec-(decdrs*rs)/3._dp
3192 [ # # # # ]: 0 : IF ((ABS(exc).GT.1.d65).OR.(ABS(vxc).GT.1.d65)) THEN
3193 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Problem in PW',n,rs,ec
3194 : : ENDIF
3195 : 0 : exc=2*exc; vxc=2*vxc ! change to Rydberg units
3196 : 0 : RETURN
3197 : : END SUBROUTINE pwldafunc
3198 : :
3199 : :
3200 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3201 : : ! Subroutine to calculate the exchange correlation functionals
3202 : : ! using the form of Perdew, Burke, and Ernzerhof (PRL 77, 3865 (1996))
3203 : : ! assuming no spin polarization
3204 : : ! Inside this routine, energies are in Hartree units
3205 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3206 : 362220 : SUBROUTINE pbefunc(den,grad,fxc,dfxcdn,dfxcdgbg,mu,beta)
3207 : : REAL(dp), INTENT(IN) :: den,grad,mu,beta !density, magnitude of grad(density)
3208 : : REAL(dp), INTENT(OUT) :: fxc,dfxcdn,dfxcdgbg
3209 : : REAL(dp) :: n,g,kf,rs,ks,s,t,betabygamm
3210 : : REAL(dp) :: ex,ec,Fx,H,A,pprs,ppt,At2,dFds,dHdt,decdrs,dHdrs,dHdA,dAdrs
3211 : : REAL(dp) :: term,dHdtbg,dFdsbg
3212 : 362220 : betabygamm=beta/gamm
3213 : 362220 : n=den
3214 [ + + ]: 362220 : IF (n < machine_zero) THEN
3215 : 5738 : fxc=0.0_dp; dfxcdn=0.0_dp; dfxcdgbg=0.0_dp
3216 : 5738 : RETURN
3217 : : ENDIF
3218 : 356482 : g=grad
3219 [ - + ]: 356482 : IF (g < machine_zero) g=machine_zero
3220 : 356482 : kf=(3.0_dp*(pi**2)*n)**0.3333333333333333333333333333_dp
3221 : 356482 : rs=(3.0_dp/(4.0_dp*pi*n))**0.3333333333333333333333333333_dp
3222 : 356482 : ks=SQRT(4.0_dp*kf/pi)
3223 : 356482 : s=g/(2.0_dp*kf*n)
3224 : 356482 : t=g/(2.0_dp*ks*n)
3225 [ + - - + ]: 356482 : IF (s*s > machine_infinity .or. t*t > machine_infinity) THEN
3226 : 0 : fxc=0.0_dp; dfxcdn=0.0_dp; dfxcdgbg=0.0_dp
3227 : 0 : RETURN
3228 : : ENDIF
3229 : 356482 : ex=-3.0_dp*kf/(4.0_dp*pi)
3230 : 356482 : pprs=SQRT(rs)*(b1+b3*rs)+rs*(b2+b4*rs)
3231 : 356482 : term=Logofterm(1.0_dp/(2.0_dp*AA*pprs))
3232 : 356482 : ec=-2.0_dp*AA*(1.0_dp+a1*rs)*term
3233 : 356482 : Fx=1.0_dp+kappa -kappa/(1.0_dp+(mu/kappa)*s*s)
3234 : 356482 : A=Aofec(ec,betabygamm,beta)
3235 : 356482 : At2=A*t*t
3236 : 356482 : ppt=(1.0_dp+At2*(1.0_dp+At2))
3237 : 356482 : H=gamm*Logofterm((betabygamm)*(t*t)*((1._dp+At2)/ppt))
3238 : 356482 : fxc=n*(ex*Fx+ec+H)
3239 : 356482 : dFds = (2.0_dp*mu*s)/(1.0_dp+(mu/kappa)*(s**2))**2
3240 : 356482 : dFdsbg = ((2.0_dp*mu)/(1.0_dp+(mu/kappa)*(s**2))**2)/(2._dp*kf*n)
3241 : : dHdt = (2._dp*t*beta*gamm*(1._dp+2._dp*At2))/&
3242 : 356482 : & ((gamm*ppt+beta*t*t*(1._dp+At2))*ppt)
3243 : : dHdtbg = ((2._dp*beta*gamm*(1._dp+ &
3244 : 356482 : & 2._dp*At2))/((gamm*ppt+beta*t*t*(1._dp+At2))*ppt))/(2._dp*ks*n)
3245 : : decdrs=-(2._dp*AA*a1)*term &
3246 : : & +((1._dp+a1*rs)*((b1+3*b3*rs)/(2._dp*SQRT(rs))+ &
3247 : 356482 : & b2+2*b4*rs))/(pprs*(pprs+1._dp/(2._dp*AA)))
3248 : : dHdA=((2._dp+At2)*(At2*t*t*t*t*beta*gamm))/&
3249 : 356482 : & ((gamm*ppt+beta*t*t*(1._dp+At2))*ppt)
3250 : 356482 : dAdrs=-ddexp(-ec/gamm)*A*A*decdrs/beta
3251 : 356482 : dHdrs=dHdA*dAdrs
3252 : : dfxcdn = (4._dp/3._dp)*ex*(Fx-dFds*s)+ec-(decdrs*rs)/3._dp+H-(dHdrs*rs)/3._dp &
3253 : 356482 : & - (7._dp/6._dp)*dHdt*t
3254 : 356482 : dfxcdgbg = ex*dFdsbg/(2._dp*kf) + dHdtbg/(2._dp*ks)
3255 [ + - + - : 356482 : IF ((ABS(fxc).GT.1.d65).OR.(ABS(dfxcdn).GT.1.d65).OR.&
- + ]
3256 : : & (ABS(dfxcdgbg).GT.1.d65)) THEN
3257 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Problem in PBE',n,g,rs,s,t,ec,A,H
3258 : : ENDIF
3259 : : RETURN
3260 : : END SUBROUTINE pbefunc
3261 : :
3262 : :
3263 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3264 : : !! Function Aofec -- needed to take care of behavior for small ec
3265 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3266 : 356482 : FUNCTION Aofec(ec,betabygamm,beta)
3267 : : REAL(dp) :: ec, Aofec, betabygamm,beta
3268 [ + + ]: 356482 : IF (ABS(ec)>machine_precision) THEN
3269 : 354797 : Aofec=betabygamm/(ddexp(-ec/gamm)-1.0_dp)
3270 [ + - ]: 1685 : ELSEIF (ABS(ec)>machine_zero) THEN
3271 : 1685 : Aofec=beta/(-ec)
3272 : : ELSE
3273 : 0 : Aofec=-beta*DSIGN(machine_infinity,ec)
3274 : : ENDIF
3275 : : RETURN
3276 : : END FUNCTION Aofec
3277 : :
3278 : :
3279 : :
3280 : :
3281 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3282 : : ! 5. r2scan
3283 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3284 : :
3285 : :
3286 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3287 : : !! r2scaninit
3288 : : !!
3289 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3290 : 0 : SUBROUTINE r2scaninit(etain)
3291 : : REAL(dp), INTENT(IN) :: etain
3292 : : REAL(dp) :: o
3293 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'r2scan calculation with eta ', etain
3294 : 0 : eta=etain
3295 : 0 : o=cx1+two*cx2+three*cx3+four*cx4+five*cx5+six*cx6+seven*cx7
3296 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'r2scan check C2' , o*k0
3297 : 0 : C2Ceta = (20.0_dp/27.0_dp + (5*eta)/three)*o*k0
3298 : 0 : END SUBROUTINE r2scaninit
3299 : :
3300 : :
3301 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3302 : : !! r2scan functional
3303 : : !! length units == Bohr
3304 : : !! energy units -- Hartree
3305 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3306 : 0 : SUBROUTINE r2scanfun(rho,grad,tau,exc,vtau,vxcn,vxcs)
3307 : : REAL(dp), INTENT(IN) :: rho,grad, tau
3308 : : REAL(dp), INTENT(INOUT) :: exc,vtau,vxcn,vxcs
3309 : : REAL(dp) :: rr,ss,tt,sigma
3310 : : REAL(dp) :: kF,ks,rs,U,s,p,t,W,baralpha
3311 : : REAL(dp) :: gx,x,h0x,h1x,fx,ffx,exarg,ddfx,vxtau,ex,vx
3312 : : REAL(dp) :: ELDA,ELDA0,fc,ddfc,w1,w0,ginfinity,H0c,H1c,ec0,ec1,y
3313 : : REAL(dp) :: beta,srs,ddLDA,difddLDA,gg,corarg,ddy,vctau
3314 : : REAL(dp) :: alphadenom,dalphadn,dalphads
3315 : : REAL(dp) :: gxp,dpdn,dgxdn,dpds,dgxds,drsdn,dt2ds,dt2dn,t2
3316 : : REAL(dp) :: h1xx,xp,dh1xdn,dh1xds,vxn,vxs
3317 : : REAL(dp) :: vcn,vcs,dLDA0dn,dH0cdn,dw0dn,dgindn,dw1dn
3318 : : REAL(dp) :: dH0cds,dginds,dbetadn,dif2ddLDA,dLDAdn
3319 : : REAL(dp) :: pp,dppds,dppdn,dyds,dydn,dUdn,dWds,dWdn
3320 : : REAL(dp) :: term1,term4,dddyds,dddydnp,dddydnw,dddydnr,dH1cds
3321 : : REAL(dp) :: stf1,stf2,stf3,stf4,stf5,stf6,stf7
3322 : : REAL(dp) :: dddydnn,dddydn,dH1cdwn,dH1cdn,dec1dn,dec1ds
3323 : : REAL(dp) :: dec0ds,dec0dn,bigdenom
3324 : : REAL(dp) :: eex,eec,vtx,vtc,vvxn,vvcn,vvxs,vvcs
3325 : 0 : eex=0._dp;eec=0._dp;vtx=0._dp;vtc=0._dp;vvxn=0._dp;vvcn=0._dp;vvxs=0._dp;vvcs=0._dp
3326 [ # # ]: 0 : if(rho<(machine_zero**0.333333333333333333333333333333333_dp)) return
3327 : 0 : sigma=grad*grad
3328 : 0 : rr=rho;ss=sigma;tt=tau
3329 : 0 : rr=max(machine_zero,rr)
3330 : 0 : rr=min(machine_infinity,rr)
3331 : 0 : ss=max(machine_zero,ss)
3332 : 0 : ss=min(machine_infinity,ss)
3333 : 0 : tt=max(machine_zero,tt)
3334 : 0 : tt=min(machine_infinity,tt)
3335 : : ! Note that all derivatives with respect to sigma are also multiplied
3336 : : ! by grad
3337 : 0 : kF=3.0936677262801359310_dp*(rr**0.33333333333333333333333333333_dp)
3338 : 0 : ks=1.9846863952198559283_dp*(rr**0.16666666666666666666666666667_dp)
3339 : 0 : rs=0.62035049089940001665_dp/(rr**0.33333333333333333333333333333_dp)
3340 : 0 : drsdn=-rs/(3*rr)
3341 : 0 : srs=sqrt(rs)
3342 : 0 : U=2.8712340001881918160_dp*(rr**1.66666666666666666666666666667_dp)
3343 : 0 : dUdn=(1.666666666666666666666667_dp)*2.8712340001881918160_dp*(rr**0.66666666666666666666666666667_dp)
3344 : 0 : s=sqrt(ss)*0.16162045967399548133_dp/(rr**1.33333333333333333333333333333_dp)
3345 : 0 : p=s*s
3346 : 0 : dpdn=-2.666666666666666666666666667_dp*p/rr
3347 : 0 : dpds=0.026121172985233599568_dp*grad/(rr**2.666666666666666666666666666666667_dp)
3348 : 0 : t=sqrt(ss)*0.25192897034224488769_dp/(rr**1.166666666666666666666666666667_dp)
3349 : 0 : t2=t*t
3350 : 0 : dt2ds=0.063468206097703704205_dp*grad/(rr**2.3333333333333333333333333333_dp)
3351 : 0 : dt2dn=-t2*(2.333333333333333333333333333333333333_dp)/rr
3352 : 0 : W=0.125_dp*ss/rr
3353 : 0 : dWds=0.125_dp*grad/rr
3354 : 0 : dWdn=-W/rr
3355 : 0 : baralpha=(tt-W)/(U+eta*W)
3356 : : !!!!!!exchange part
3357 : 0 : gx=1._dp-ddexp(-SCANa1/(p**0.25_dp))
3358 : 0 : x=(c2ceta*ddexp(-(p**2)/dp2**4)+mu)*p
3359 : 0 : xp=c2ceta*ddexp(-(p**2)/dp2**4)*(-2*(p**2)/dp2**4+1._dp)+mu
3360 : 0 : h0x=1+k0
3361 : 0 : h1x=1._dp+k1-k1/(1+x/k1)
3362 [ # # ]: 0 : if(baralpha<1.d-13) then
3363 : 0 : fx=ddexp(-SCANc1x*baralpha/(1._dp-baralpha))
3364 [ # # ]: 0 : elseif (baralpha.lt.2.5_dp) then
3365 : : fx=cx0+baralpha*(cx1+baralpha*(cx2+baralpha*(cx3+baralpha*( &
3366 : 0 : & cx4+baralpha*(cx5+baralpha*(cx6+baralpha*cx7))))))
3367 [ # # ]: 0 : else if (baralpha.ge.2.5_dp) then
3368 : 0 : fx=-SCANdx*ddexp(SCANc2x/(1._dp-baralpha))
3369 : : endif
3370 [ # # ]: 0 : if(baralpha<1.d-13) then
3371 : 0 : ddfx=-(SCANc1x/((1._dp-baralpha)**2))*ddexp(-SCANc1x*baralpha/(1._dp-baralpha))
3372 [ # # ]: 0 : else if (baralpha.lt.2.5_dp) then
3373 : : ddfx=(cx1+baralpha*(2*cx2+baralpha*(3*cx3+baralpha*( &
3374 : 0 : & 4*cx4+baralpha*(5*cx5+baralpha*(6*cx6+baralpha*7*cx7))))))
3375 [ # # ]: 0 : else if (baralpha.ge.2.5_dp) then
3376 : 0 : ddfx=-(SCANdx*SCANc2x/((1._dp-baralpha)**2))*ddexp(SCANc2x/(1._dp-baralpha))
3377 : : endif
3378 : 0 : ffx=(h1x+fx*(h0x-h1x))*gx
3379 : 0 : ex=-0.73855876638202240587_dp*(rr**1.3333333333333333333333333333333333_dp)
3380 : 0 : vx=-0.98474502184269654116_dp*(rr**0.3333333333333333333333333333333333_dp)
3381 : 0 : exarg=ex*ffx
3382 : 0 : vxtau=ex*ddfx*((h0x-h1x)*gx)/(U+eta*W)
3383 : : ! density and sigma derivative terms
3384 : 0 : alphadenom=(U+eta*W)**2
3385 : 0 : dalphads=-(U+eta*tau)*dWds/alphadenom
3386 : 0 : dalphadn=-((U+eta*tau)*dWdn+(tt-W)*dUdn)/alphadenom
3387 : 0 : gxp=-0.25_dp*SCANa1*ddexp(-SCANa1/(p**0.25_dp))/(p**1.25_dp)
3388 : 0 : dgxdn=gxp*dpdn
3389 : 0 : dgxds=gxp*dpds
3390 : 0 : h1xx=1._dp/((1._dp+x/k1)**2)
3391 : 0 : dh1xdn=h1xx*xp*dpdn
3392 : 0 : dh1xds=h1xx*xp*dpds
3393 : : vxn=vx*ffx+ex*(ddfx*dalphadn*gx*(h0x-h1x)+dgxdn*(h1x+fx*(h0x-h1x)) &
3394 : 0 : & +gx*dh1xdn*(1._dp-fx))
3395 : : vxs=ex*(ddfx*dalphads*gx*(h0x-h1x)+dgxds*(h1x+fx*(h0x-h1x)) &
3396 : 0 : & +gx*dh1xds*(1._dp-fx))
3397 : : !!!! correlation part
3398 : : ELDA=-two*LDAA*(1._dp + LDAa1*rs)*ddlog(1._dp + 0.5_dp &
3399 : 0 : & /(LDAA*(sqrt(rs)*(LDAb1 + LDAb3*rs) + rs*(LDAb2 + LDAb4*rs))))
3400 : 0 : bigdenom=srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)
3401 : : dLDAdn=((-two*LDAA*LDAa1*ddlog(1._dp + &
3402 : : & 1._dp/(two*LDAA*bigdenom))) &
3403 : : & + (LDAa1*rs + 1._dp)*((LDAb3*rs + LDAb1)/(two*srs) + srs*LDAb3 + &
3404 : 0 : & two*LDAb4*rs + LDAb2)/((bigdenom**2)+bigdenom/(two*LDAA)))*drsdn
3405 : 0 : ELDA0= -b1c/(1._dp + b2c*sqrt(rs) + b3c*rs)
3406 : : dLDA0dn=b1c*(0.5_dp*b2c/sqrt(rs)+b3c)/((1._dp + b2c*sqrt(rs) + b3c*rs)**2) &
3407 : 0 : & *drsdn
3408 : 0 : ddLDA=ELDA0-ELDA
3409 : 0 : beta= betaMB*(1._dp + 0.1*rs)/(1._dp + 0.1778_dp*rs)
3410 : 0 : dbetadn=-(0.0778_dp*betaMB/(1._dp + 0.1778_dp*rs)**2)*drsdn
3411 [ # # ]: 0 : if(baralpha<1.d-13) then
3412 : 0 : fc=ddexp(-SCANc1c*baralpha/(1._dp-baralpha))
3413 [ # # ]: 0 : else if (baralpha.lt.2.5_dp) then
3414 : : fc=cc0+baralpha*(cc1+baralpha*(cc2+baralpha*(cc3+baralpha*( &
3415 : 0 : & cc4+baralpha*(cc5+baralpha*(cc6+baralpha*cc7))))))
3416 [ # # ]: 0 : else if (baralpha.ge.2.5_dp) then
3417 : 0 : fc=-SCANdc*ddexp(SCANc2c/(1._dp-baralpha))
3418 : : endif
3419 [ # # ]: 0 : if(baralpha<1.d-13) then
3420 : 0 : ddfc=-(SCANc1c/((1._dp-baralpha)**2))*ddexp(-SCANc1c*baralpha/(1._dp-baralpha))
3421 [ # # ]: 0 : else if (baralpha.lt.2.5_dp) then
3422 : : ddfc=(cc1+baralpha*(2*cc2+baralpha*(3*cc3+baralpha*( &
3423 : 0 : & 4*cc4+baralpha*(5*cc5+baralpha*(6*cc6+baralpha*7*cc7))))))
3424 [ # # ]: 0 : else if (baralpha.ge.2.5_dp) then
3425 : 0 : ddfc=-(SCANdc*SCANc2c/((1._dp-baralpha)**2))*ddexp(SCANc2c/(1._dp-baralpha))
3426 : : endif
3427 : 0 : w1= ddexp(-ELDA/Sgam) - 1._dp
3428 : 0 : dw1dn=-(ddexp(-ELDA/Sgam)/Sgam)*dLDAdn
3429 : 0 : w0= ddexp(-ELDA0/b1c) - 1._dp
3430 : 0 : dw0dn=-(ddexp(-ELDA0/b1c)/b1c)*dLDA0dn
3431 : 0 : ginfinity= 1._dp/(1._dp + 4*chiinfinity*(p))**0.25_dp
3432 : 0 : dgindn=-(chiinfinity*ginfinity/(1._dp + four*chiinfinity*(p)))*dpdn
3433 : 0 : dginds=-(chiinfinity*ginfinity/(1._dp + four*chiinfinity*(p)))*dpds
3434 : 0 : H0c= b1c*ddlog(1._dp + w0*(1._dp - ginfinity))
3435 : 0 : dH0cdn=(b1c/(1._dp+w0*(1._dp-ginfinity)))*((1._dp-ginfinity)*dw0dn-w0*dgindn)
3436 : 0 : dH0cds=(-b1c*w0*dginds/(1._dp+w0*(1._dp-ginfinity)))
3437 : 0 : ec0= ELDA0 + H0c
3438 : 0 : dec0dn=dLDA0dn+dH0cdn
3439 : 0 : dec0ds=dH0cds
3440 : : difddLDA=b1c*(b2c/(two*srs) + b3c)/(1._dp + b2c*srs + b3c*rs)**2 + &
3441 : : & two*LDAA*LDAa1*ddlog(1._dp + &
3442 : : & 1._dp/(2*LDAA*(srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)))) &
3443 : : & - (LDAa1*rs + 1._dp)*((LDAb3*rs + LDAb1)/(two*srs) + srs*LDAb3 + &
3444 : : & two*LDAb4*rs + LDAb2)/(((srs*(LDAb3*rs + LDAb1) + &
3445 : : & rs*(LDAb4*rs + LDAb2))**2)*(1._dp + 1._dp &
3446 : 0 : & /(two*LDAA*(srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)))))
3447 : 0 : y=beta*(t2)/(Sgam*w1)
3448 : 0 : dyds=beta*dt2ds/(Sgam*w1)
3449 : 0 : dydn=(1._dp/(Sgam*w1))*(dbetadn*t2+beta*dt2dn-beta*t2*dw1dn/w1)
3450 : : ddy=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*p&
3451 : 0 : & *ddexp(-(p**2)/(dp2**4))
3452 : 0 : gg=1._dp/(1._dp+4*(y-ddy))**0.25_dp
3453 : 0 : H1c=Sgam*ddlog(1._dp+w1*(1._dp-gg))
3454 : 0 : ec1=ELDA+H1c
3455 : 0 : pp=p*ddexp(-(p**2)/(dp2**4))
3456 : 0 : dppds=((ddexp(-p**2/dp2**4))*(dp2**4 - two*p**2)/dp2**4)*dpds
3457 : 0 : dppdn=((ddexp(-p**2/dp2**4))*(dp2**4 - two*p**2)/dp2**4)*dpdn
3458 : 0 : term1=1._dp+4*(y-ddy)
3459 : 0 : term4=term1**0.25_dp
3460 : 0 : dddyds=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*dppds
3461 : 0 : dddydnp=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*dppdn
3462 : 0 : dddydnw=-(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*pp*dw1dn/w1
3463 : 0 : dddydnr=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*difddLDA)*pp*drsdn
3464 : 0 : dH1cds=(Sgam*w1/(term1*(term4*(1._dp+w1)-w1)))*(dyds-dddyds)
3465 : : stf1=-b1c*(8.0_dp*srs*rs*(b3c**2) + 9.0_dp*b2c*b3c*rs + 3.0_dp*srs*(b2c**2) + b2c)&
3466 : 0 : & /(4.0_dp*rs*srs*((1._dp + b2c*srs + b3c*rs)**3))
3467 : 0 : stf2=srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)
3468 : 0 : stf3=1._dp+1._dp/(2*LDAA*stf2)
3469 : : stf4=(two*LDAa1*((LDAb3*rs+LDAb1)/(two*srs)+srs*LDAb3+two*LDAb4*rs+LDAb2)) &
3470 : 0 : & /((stf2**2)*stf3)
3471 : : stf5=(two*(LDAa1*rs+1._dp)*(((LDAb3*rs+LDAb1)/(two*srs)+srs*LDAb3+ &
3472 : 0 : & two*LDAb4*rs + LDAb2)**2))/((stf2**3)*stf3)
3473 : : stf6=(LDAa1*rs+1._dp)*(-(LDAb3*rs+LDAb1)/(four*srs*rs)+LDAb3/srs + two*LDAb4) &
3474 : 0 : & /((stf2**2)*stf3)
3475 : : stf7=(LDAa1*rs+1._dp)*&
3476 : : & (((LDAb3*rs+LDAb1)/(two*srs)+srs*LDAb3+two*LDAb4*rs+LDAb2)**2) &
3477 : 0 : & /(two*LDAA*(stf2**4)*(stf3**2))
3478 : 0 : dif2ddLDA=stf1-stf4+stf5-stf6-stf7
3479 : 0 : dddydnn=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*dif2ddLDA-45.0_dp*eta*difddLDA)*pp*drsdn
3480 : 0 : dddydn=dddydnw+dddydnp+dddydnr+dddydnn
3481 : 0 : dH1cdwn=Sgam*((term4-1._dp)/(term4*(w1+1._dp)-w1))*dw1dn
3482 : 0 : dH1cdn=dH1cdwn+(Sgam*w1/(term1*(term4*(1._dp+w1)-w1)))*(dydn-dddydn)
3483 : 0 : dec1dn=dLDAdn+dH1cdn
3484 : 0 : dec1ds=dH1cds
3485 : 0 : corarg=rr*(ec1 + fc*(ec0 - ec1))
3486 : 0 : vctau=rr*ddfc*(ec0 - ec1)/(U + eta*W)
3487 : : ! density and sigma derivative terms
3488 : 0 : vcn=ec1+fc*(ec0-ec1)+ddfc*dalphadn*rr*(ec0-ec1)+dec0dn*rr*fc+dec1dn*rr*(1._dp-fc)
3489 : 0 : vcs=ddfc*dalphads*rr*(ec0-ec1)+dec0ds*rr*fc+dec1ds*rr*(1._dp-fc)
3490 : 0 : eex=exarg;eec=corarg; exc=exarg+corarg
3491 : 0 : vtx=vxtau;vtc=vctau; vtau=vxtau+vctau
3492 : 0 : vvxn=vxn; vvcn=vcn; vxcn=vxn+vcn
3493 : 0 : vvxs=vxs; vvcs=vcs; vxcs=vxs+vcs
3494 : : END SUBROUTINE r2scanfun
3495 : :
3496 : :
3497 : :
3498 : :
3499 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3500 : : ! 5. general_mod
3501 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3502 : :
3503 : :
3504 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3505 : : !! Updatewfn(Grid,Pot,Orbit,rvin,success)
3506 : : !! Given new potential rvin, generate new Orbit%wfn,Orbit%eig,Pot%den
3507 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3508 [ - + ]: 371 : SUBROUTINE Updatewfn(Grid,Pot,Orbit,rvin,success,BDsolve,usespline,spline,itype)
3509 : : ! TODO : BDsolve
3510 : : logical,intent(in) :: usespline
3511 : : integer, intent(in) :: itype
3512 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
3513 : : TYPE (PotentialInfo), INTENT(INOUT) :: Pot
3514 : : TYPE (OrbitInfo), INTENT(INOUT) :: Orbit
3515 : : type(splinesolvinfo),intent(inout) :: spline
3516 : : logical, intent(in) :: bdsolve
3517 : : real(dp), INTENT(IN) :: rvin(:)
3518 : : LOGICAL :: success,calc_s,calc_p,calc_d,calc_f,calc_g
3519 : : INTEGER :: icount,n,it,start,ierr,nroot,s1,s2,s2t
3520 : : INTEGER :: io,l,jierr,nz,kappa
3521 : : real(dp) :: h,emin,zz
3522 : : real(dp), ALLOCATABLE :: dum(:)
3523 : : LOGICAL :: OK
3524 : 371 : n=Grid%n; h=Grid%h; nz=Pot%nz; zz=Pot%zz
3525 : 371 : success=.TRUE.
3526 [ - + + - : 1113 : LIBPAW_ALLOCATE(dum,(n))
+ - + - -
+ - + ]
3527 [ + + ]: 742742 : Pot%rv=rvin+Pot%rvn(1:n)
3528 [ + - - + : 743113 : dum=rvin
- - + + ]
3529 [ - + ]: 371 : if (Pot%needvtau) dum(1)=dum(1)-Pot%rvx(1)
3530 : 371 : CALL zeropot(Grid,dum,Pot%v0,Pot%v0p)
3531 [ - + ]: 371 : IF (ABS(Pot%v0)> 1.d6) Pot%v0=0
3532 [ + + ]: 371 : IF (ABS(Pot%v0p)> 1.d6) Pot%v0p=0
3533 [ - + ]: 371 : IF (Pot%finitenucleus) then
3534 : 0 : Pot%v0=Pot%v0+Pot%Nv0
3535 : 0 : Pot%v0p=Pot%v0p+Pot%Nv0p
3536 : : Endif
3537 [ - + ]: 371 : if(usespline) call initpotforsplinesolver(Grid,Pot,Orbit%den,Orbit%tau,spline,itype)
3538 : : ! solve for bound states of Schroedinger equation
3539 : 371 : calc_s=.true.
3540 : 371 : calc_p=.true.
3541 : 371 : calc_d=.true.
3542 : 371 : calc_f=.true.
3543 : 371 : calc_g=.true.
3544 : 371 : icount=0
3545 : 371 : jierr=0
3546 : 371 : it=0
3547 : : ! s states :
3548 [ + - ]: 371 : IF (Orbit%nps.GT.0) THEN
3549 : 371 : it=it+1
3550 : 371 : emin=-nz*nz-0.1_dp
3551 : 371 : l=0
3552 : 371 : nroot=Orbit%nps
3553 : 371 : start=1;s1=start;s2t=start+nroot-1
3554 [ + + ]: 371 : if (Orbit%frozenvalecalculation) then
3555 : 235 : nroot=Orbit%npsc
3556 [ + + ]: 540 : do io=s1+Orbit%npsc,s2t
3557 [ + + ]: 540 : if(Orbit%issemicore(io)) nroot=nroot+1
3558 : : enddo
3559 [ + - ]: 235 : if(nroot.LT.1) calc_s=.false.
3560 : : endif
3561 : 742 : s2=s1+nroot-1
3562 : : if(calc_s) then
3563 [ + + ]: 371 : IF (Orbit%scalarrelativistic) THEN
3564 : : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3565 : 102 : & l,nroot,emin,ierr,OK)
3566 [ + + ]: 269 : ELSE IF (Orbit%diracrelativistic) THEN
3567 : 46 : kappa=-1
3568 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3569 : 46 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3570 [ - + ]: 223 : ELSE IF (Pot%needvtau) THEN
3571 : : Call Boundsplinesolver(Grid,l,nroot, &
3572 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3573 : : ELSE
3574 [ - + ]: 223 : if(usespline) then
3575 : : Call Boundsplinesolver(Grid,l,nroot, &
3576 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3577 : : else
3578 : : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3579 : 223 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3580 : : endif
3581 : : ENDIF
3582 [ + + ]: 371 : IF (.NOT.OK) THEN
3583 : 2 : success=.FALSE.
3584 : : ENDIF
3585 : : endif
3586 : : ENDIF
3587 : : ! p states :
3588 [ + - ]: 371 : IF (Orbit%npp.GT.1) then
3589 : 371 : it=it+1
3590 : 371 : emin=-nz*nz/4._dp-0.5_dp
3591 : 371 : l=1
3592 : 371 : nroot=Orbit%npp-1
3593 : 371 : s1=s2t+1;s2t=s1+nroot-1
3594 [ + + ]: 371 : if (Orbit%frozenvalecalculation) then
3595 : 235 : nroot=Orbit%nppc-1
3596 [ + + ]: 470 : do io=s1+Orbit%nppc-1,s2t
3597 [ + + ]: 470 : if(Orbit%issemicore(io)) nroot=nroot+1
3598 : : enddo
3599 [ + - ]: 235 : if(nroot.LT.1) calc_p=.false.
3600 : : endif
3601 : 371 : s2=s1+nroot-1
3602 [ + - ]: 371 : if(calc_p) then
3603 [ + + ]: 371 : IF (Orbit%scalarrelativistic) THEN
3604 : : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3605 : 102 : & l,nroot,emin,ierr,OK)
3606 [ + + ]: 269 : ELSE IF (Orbit%diracrelativistic) THEN
3607 : 46 : kappa=1
3608 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3609 : 46 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3610 : 46 : s1=s2t+1;s2=s1+nroot-1
3611 : 46 : kappa=-2
3612 : 46 : emin=-nz*nz/4._dp-0.5_dp
3613 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3614 : 46 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3615 : 46 : nroot=Orbit%npp-1
3616 : 46 : s2t=s1+nroot-1
3617 [ - + ]: 223 : ELSE IF (Pot%needvtau) THEN
3618 : : Call Boundsplinesolver(Grid,l,nroot, &
3619 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3620 : : ELSE
3621 [ - + ]: 223 : if(usespline) then
3622 : : Call Boundsplinesolver(Grid,l,nroot, &
3623 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3624 : : else
3625 : : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3626 : 223 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3627 : : endif
3628 : : ENDIF
3629 [ + + ]: 371 : IF (.NOT.OK) THEN
3630 : 9 : success=.FALSE.
3631 : : ENDIF
3632 : : endif
3633 : : ENDIF
3634 : : ! d states :
3635 [ + + ]: 371 : IF (Orbit%npd.GT.2) THEN
3636 : 148 : it=it+1
3637 : 148 : emin=-nz*nz/9._dp-0.5_dp
3638 : 148 : l=2
3639 : 148 : nroot=Orbit%npd-2
3640 : 148 : s1=s2t+1;s2t=s1+nroot-1
3641 [ + + ]: 148 : if (Orbit%frozenvalecalculation) then
3642 : 70 : nroot=Orbit%npdc-2
3643 [ + + ]: 140 : do io=s1+Orbit%npdc-2,s2t
3644 [ - + ]: 140 : if(Orbit%issemicore(io)) nroot=nroot+1
3645 : : enddo
3646 [ - + ]: 70 : if(nroot.LT.1) calc_d=.false.
3647 : : endif
3648 : 148 : s2=s1+nroot-1
3649 [ + + ]: 148 : if(calc_d) then
3650 [ + + ]: 78 : IF (Orbit%scalarrelativistic) THEN
3651 : : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3652 : 44 : & l,nroot,emin,ierr,OK)
3653 [ + - ]: 34 : ELSE IF (Orbit%diracrelativistic) THEN
3654 : 34 : kappa=2
3655 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3656 : 34 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3657 : 34 : kappa=-3
3658 : 34 : s1=s2t+1;s2=s1+nroot-1
3659 : 34 : emin=-nz*nz/9._dp-0.5_dp
3660 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3661 : 34 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3662 : 34 : nroot=Orbit%npd-1
3663 : 34 : s2t=s1+nroot-1
3664 [ # # ]: 0 : ELSE IF (Pot%needvtau) THEN
3665 : : Call Boundsplinesolver(Grid,l,nroot, &
3666 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3667 : : ELSE! CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3668 [ # # ]: 0 : if(usespline) then
3669 : : Call Boundsplinesolver(Grid,l,nroot, &
3670 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3671 : : else
3672 : : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3673 : 0 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3674 : : endif
3675 : : ENDIF
3676 [ + + ]: 78 : IF (.NOT.OK) THEN
3677 : 10 : success=.FALSE.
3678 : : ENDIF
3679 : : endif
3680 : : ENDIF
3681 : : ! f states :
3682 [ - + ]: 371 : IF (Orbit%npf.GT.3) THEN
3683 : 0 : it=it+1
3684 : 0 : emin=-nz*nz/16._dp-0.5_dp
3685 : 0 : l=3
3686 : 0 : nroot=Orbit%npf-3
3687 : 0 : s1=s2t+1;s2t=s1+nroot-1
3688 [ # # ]: 0 : if (Orbit%frozenvalecalculation) then
3689 : 0 : nroot=Orbit%npfc-3
3690 [ # # ]: 0 : do io=s1+Orbit%npfc-3,s2t
3691 [ # # ]: 0 : if(Orbit%issemicore(io)) nroot=nroot+1
3692 : : enddo
3693 [ # # ]: 0 : if(nroot.LT.1) calc_f=.false.
3694 : : endif
3695 : 0 : s2=s1+nroot-1
3696 [ # # ]: 0 : if (calc_f) then
3697 [ # # ]: 0 : IF (Orbit%scalarrelativistic) THEN
3698 : : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3699 : 0 : & l,nroot,emin,ierr,OK)
3700 [ # # ]: 0 : ELSE IF (Orbit%diracrelativistic) THEN
3701 : 0 : kappa=3
3702 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3703 : 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3704 : 0 : kappa=-4
3705 : 0 : s1=s2t+1;s2=s1+nroot-1
3706 : 0 : emin=-nz*nz/16._dp-0.5_dp
3707 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3708 : 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3709 : 0 : nroot=Orbit%npf-1
3710 : 0 : s2t=s1+nroot-1
3711 [ # # ]: 0 : ELSE IF (Pot%needvtau) THEN
3712 : : Call Boundsplinesolver(Grid,l,nroot, &
3713 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3714 : : ELSE
3715 [ # # ]: 0 : if(usespline) then
3716 : : Call Boundsplinesolver(Grid,l,nroot, &
3717 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3718 : : else
3719 : : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3720 : 0 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3721 : : endif
3722 : : ENDIF
3723 [ # # ]: 0 : IF (.NOT.OK) THEN
3724 : 0 : success=.FALSE.
3725 : : ENDIF
3726 : : endif
3727 : : ENDIF
3728 : : ! g states :
3729 [ - + ]: 371 : IF (Orbit%npg.GT.4) THEN
3730 : 0 : it=it+1
3731 : 0 : emin=-nz*nz/25._dp-0.5_dp
3732 : 0 : l=4
3733 : 0 : nroot=Orbit%npg-4
3734 : 0 : s1=s2t+1;s2t=s1+nroot-1
3735 [ # # ]: 0 : if (Orbit%frozenvalecalculation) then
3736 : 0 : nroot=Orbit%npgc-4
3737 [ # # ]: 0 : do io=s1+Orbit%npgc-4,s2t
3738 [ # # ]: 0 : if(Orbit%issemicore(io)) nroot=nroot+1
3739 : : enddo
3740 [ # # ]: 0 : if(nroot.LT.1) calc_g=.false.
3741 : : endif
3742 : 0 : s2=s1+nroot-1
3743 [ # # ]: 0 : if(calc_g) then
3744 [ # # ]: 0 : IF (Orbit%scalarrelativistic) THEN
3745 : : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3746 : 0 : & l,nroot,emin,ierr,OK)
3747 [ # # ]: 0 : ELSE IF (Orbit%diracrelativistic) THEN
3748 : 0 : kappa=4
3749 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3750 : 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3751 : 0 : kappa=-5
3752 : 0 : s1=s2t+1;s2=s1+nroot-1
3753 : 0 : emin=-nz*nz/25._dp-0.5_dp
3754 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3755 : 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3756 : 0 : nroot=Orbit%npg-1
3757 : 0 : s2t=s1+nroot-1
3758 [ # # ]: 0 : ELSE IF (Pot%needvtau) THEN
3759 : : Call Boundsplinesolver(Grid,l,nroot, &
3760 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3761 : : ELSE
3762 [ # # ]: 0 : if(usespline) then
3763 : : Call Boundsplinesolver(Grid,l,nroot, &
3764 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3765 : : else
3766 : : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3767 : 0 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3768 : : endif
3769 : : ENDIF
3770 [ # # ]: 0 : IF (.NOT.OK) THEN
3771 : 0 : success=.FALSE.
3772 : : ENDIF
3773 : : endif
3774 : : ENDIF
3775 : : !Update otau according to wfn
3776 [ + + ]: 2660 : DO io=1,Orbit%norbit
3777 [ + + + + ]: 2289 : IF(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
3778 : : CALL taufromwfn(Orbit%otau(:,io),Grid,Orbit%wfn(:,io),Orbit%l(io), &
3779 : 2660 : & energy=Orbit%eig(io),rPot=Pot%rv)
3780 : : ENDDO
3781 [ - + ]: 371 : LIBPAW_DEALLOCATE(dum)
3782 : 371 : END SUBROUTINE Updatewfn
3783 : :
3784 : :
3785 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3786 : : !! SUBROUTINE Updatewfnwden(Grid,Pot,Orbit,w,success)
3787 : : !! Given new den and consistent Pot%rv
3788 : : !! generate new Orbit%wfn,Orbit%eig,Orbit%otau
3789 : : !! Orbit%den=w on input
3790 : : !! only splinesolver works for now
3791 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3792 : 0 : SUBROUTINE Updatewfnwden(Grid,Pot,Orbit,success,usespline,spline,itype)
3793 : : integer, intent(in) :: itype
3794 : : type(splinesolvinfo),intent(inout) :: spline
3795 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
3796 : : TYPE (PotentialInfo), INTENT(INOUT) :: Pot
3797 : : TYPE (OrbitInfo), INTENT(INOUT) :: Orbit
3798 : : LOGICAL,intent(inout) :: success
3799 : : LOGICAL,intent(in) :: usespline
3800 : : INTEGER :: icount,n,it,start,nroot,s1,s2,s2t
3801 : : INTEGER :: io,l,jierr,nz
3802 : : LOGICAL :: calc_s,calc_p,calc_d,calc_f,calc_g
3803 : : REAL(dp) :: h,emin,zz
3804 : 0 : REAL(dp), ALLOCATABLE :: dum(:)
3805 : : LOGICAL :: OK
3806 : : !!!since programmed only for splinesolver case, check
3807 [ # # # # ]: 0 : If (Orbit%scalarrelativistic.or.Orbit%diracrelativistic) then
3808 : 0 : write(std_out,*) 'Program Updatewfnwden not written '
3809 : 0 : write(std_out,*) ' for relativistic solver -- error stop '
3810 : 0 : stop
3811 : : ENDIF
3812 [ # # ]: 0 : If (.not.usespline) THEN
3813 : 0 : write(std_out,*) 'Program Updatewfnwden only written '
3814 : 0 : write(std_out,*) ' for usespline case -- error stop '
3815 : 0 : stop
3816 : : ENDIF
3817 : 0 : n=Grid%n; h=Grid%h; nz=Pot%nz; zz=Pot%zz
3818 : 0 : success=.TRUE.
3819 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(n))
# # # # #
# # # ]
3820 : 0 : call initpotforsplinesolver(Grid,Pot,Orbit%den,Orbit%tau,spline,itype)
3821 : : ! solve for bound states of Schroedinger equation
3822 : 0 : icount=0
3823 : 0 : jierr=0
3824 : 0 : it=0
3825 : : ! s states :
3826 : 0 : IF (Orbit%nps.GT.0) THEN
3827 : : it=it+1
3828 : : emin=-nz*nz-0.1_dp
3829 : : l=0
3830 : : nroot=Orbit%nps
3831 : : start=1;s1=start;s2t=start+nroot-1
3832 : : if (Orbit%frozenvalecalculation) then
3833 : : nroot=Orbit%npsc
3834 : : do io=s1+Orbit%npsc,s2t
3835 : : if(Orbit%issemicore(io)) nroot=nroot+1
3836 : : enddo
3837 : : if(nroot.LT.1) calc_s=.false.
3838 : : endif
3839 : : s2=s1+nroot-1
3840 : : if(calc_s) then
3841 : : Call Boundsplinesolver(Grid,l,nroot, &
3842 : : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3843 : : IF (.NOT.OK) THEN
3844 : : success=.FALSE.
3845 : : ENDIF
3846 : : endif
3847 : : ENDIF
3848 : : ! p states :
3849 : 0 : IF (Orbit%npp.GT.1) then
3850 : : it=it+1
3851 : : emin=-nz*nz/4._dp-0.5_dp
3852 : : l=1
3853 : : nroot=Orbit%npp-1
3854 : : s1=s2t+1;s2t=s1+nroot-1
3855 : : if (Orbit%frozenvalecalculation) then
3856 : : nroot=Orbit%nppc-1
3857 : : do io=s1+Orbit%nppc-1,s2t
3858 : : if(Orbit%issemicore(io)) nroot=nroot+1
3859 : : enddo
3860 : : if(nroot.LT.1) calc_p=.false.
3861 : : endif
3862 : : s2=s1+nroot-1
3863 : : if(calc_p) then
3864 : : Call Boundsplinesolver(Grid,l,nroot, &
3865 : : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3866 : : IF (.NOT.OK) THEN
3867 : : success=.FALSE.
3868 : : ENDIF
3869 : : endif
3870 : : ENDIF
3871 : : ! d states :
3872 : 0 : IF (Orbit%npd.GT.2) THEN
3873 : : it=it+1
3874 : : emin=-nz*nz/9._dp-0.5_dp
3875 : : l=2
3876 : : nroot=Orbit%npd-2
3877 : : s1=s2t+1;s2t=s1+nroot-1
3878 : : if (Orbit%frozenvalecalculation) then
3879 : : nroot=Orbit%npdc-2
3880 : : do io=s1+Orbit%npdc-2,s2t
3881 : : if(Orbit%issemicore(io)) nroot=nroot+1
3882 : : enddo
3883 : : if(nroot.LT.1) calc_d=.false.
3884 : : endif
3885 : : s2=s1+nroot-1
3886 : : if(calc_d) then
3887 : : Call Boundsplinesolver(Grid,l,nroot, &
3888 : : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3889 : : IF (.NOT.OK) THEN
3890 : : success=.FALSE.
3891 : : ENDIF
3892 : : endif
3893 : : ENDIF
3894 : : ! f states :
3895 : 0 : IF (Orbit%npf.GT.3) THEN
3896 : : it=it+1
3897 : : emin=-nz*nz/16._dp-0.5_dp
3898 : : l=3
3899 : : nroot=Orbit%npf-3
3900 : : s1=s2t+1;s2t=s1+nroot-1
3901 : : if (Orbit%frozenvalecalculation) then
3902 : : nroot=Orbit%npfc-3
3903 : : do io=s1+Orbit%npfc-3,s2t
3904 : : if(Orbit%issemicore(io)) nroot=nroot+1
3905 : : enddo
3906 : : if(nroot.LT.1) calc_f=.false.
3907 : : endif
3908 : : s2=s1+nroot-1
3909 : : if (calc_f) then
3910 : : Call Boundsplinesolver(Grid,l,nroot, &
3911 : : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3912 : : IF (.NOT.OK) THEN
3913 : : success=.FALSE.
3914 : : ENDIF
3915 : : endif
3916 : : ENDIF
3917 : : ! g states :
3918 : 0 : IF (Orbit%npg.GT.4) THEN
3919 : : it=it+1
3920 : : emin=-nz*nz/25._dp-0.5_dp
3921 : : l=4
3922 : : nroot=Orbit%npg-4
3923 : : s1=s2t+1;s2t=s1+nroot-1
3924 : : if (Orbit%frozenvalecalculation) then
3925 : : nroot=Orbit%npgc-4
3926 : : do io=s1+Orbit%npgc-4,s2t
3927 : : if(Orbit%issemicore(io)) nroot=nroot+1
3928 : : enddo
3929 : : if(nroot.LT.1) calc_g=.false.
3930 : : endif
3931 : : s2=s1+nroot-1
3932 : : if(calc_g) then
3933 : : Call Boundsplinesolver(Grid,l,nroot, &
3934 : : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3935 : : IF (.NOT.OK) THEN
3936 : : success=.FALSE.
3937 : : ENDIF
3938 : : endif
3939 : : ENDIF
3940 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
3941 : 0 : END SUBROUTINE Updatewfnwden
3942 : :
3943 : :
3944 : :
3945 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3946 : : !! Get_KinCoul
3947 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3948 : 354 : SUBROUTINE Get_KinCoul(Grid,Pot,Orbit,SCF,usespline,noalt)
3949 : : ! program to calculate Kinetic energy and Coulomb Energies from Orbit%wfn
3950 : : ! also update Pot%rvh
3951 : : logical,intent(in) :: usespline
3952 : : TYPE(GridInfo), INTENT(INOUT) :: Grid
3953 : : TYPE(PotentialInfo), INTENT(INOUT) :: Pot
3954 : : TYPE(OrbitInfo), INTENT(INOUT) :: Orbit
3955 : : TYPE(SCFInfo), INTENT(INOUT) :: SCF
3956 : : LOGICAL, OPTIONAL :: noalt
3957 : : real(dp) :: ecoul,ekin,eone,h,x,qcal,small,rescale
3958 : : real(dp) :: electrons,xocc
3959 : : INTEGER :: i,n,io
3960 : 354 : real(dp), ALLOCATABLE :: dum(:)
3961 : : real(dp) :: small0=tol6,fpi
3962 : : INTEGER :: counter=1
3963 : 354 : n=Grid%n; h=Grid%h
3964 : 354 : small=small0
3965 [ - + + - : 1062 : LIBPAW_ALLOCATE(dum,(n))
+ - + - -
+ - + ]
3966 : : !update density
3967 [ + + + + ]: 1417062 : Orbit%den=0._dp;Orbit%tau=0._dp
3968 [ + + ]: 2529 : DO io=1,Orbit%norbit
3969 [ + + + + ]: 2175 : IF(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
3970 [ + + ]: 1895 : IF (Orbit%occ(io).GT.small) THEN
3971 [ + + ]: 3067064 : DO i=1,Grid%n
3972 [ + + ]: 3065532 : IF (ABS(Orbit%wfn(i,io))<machine_zero)Orbit%wfn(i,io)=0
3973 [ + + ]: 3067064 : IF (Orbit%diracrelativistic) then
3974 [ + + ]: 716358 : IF (ABS(Orbit%lwfn(i,io))<machine_zero)Orbit%lwfn(i,io)=0
3975 : : ENDIF
3976 : : ENDDO
3977 [ + - ]: 1532 : if(.not.usespline) then
3978 : : CALL taufromwfn(Orbit%otau(:,io),Grid,Orbit%wfn(:,io),Orbit%l(io), &
3979 : 1532 : & energy=Orbit%eig(io),rPot=Pot%rv)
3980 : : endif
3981 : 1532 : xocc=Orbit%occ(io)
3982 [ + + ]: 3067064 : Do i=1,Grid%n
3983 : 3065532 : Orbit%tau(i)=Orbit%tau(i)+xocc*Orbit%otau(i,io)
3984 : 3065532 : Orbit%den(i)=Orbit%den(i)+xocc*(Orbit%wfn(i,io)**2)
3985 [ + + ]: 3067064 : IF (Orbit%diracrelativistic) then
3986 : 716358 : Orbit%den(i)=Orbit%den(i)+xocc*((Orbit%lwfn(i,io))**2)
3987 : : ENDIF
3988 : : ENDDO
3989 : : ENDIF
3990 : : ENDDO
3991 : 354 : qcal=integrator(Grid,Orbit%den)
3992 [ - + ]: 354 : if(has_to_print) WRITE(STD_OUT,*) 'qcal = ', qcal
3993 [ + + ]: 354 : IF(Orbit%frozenvalecalculation) qcal=qcal+Orbit%qval
3994 [ + + + + ]: 470589 : IF(Orbit%frozenvalecalculation) Orbit%den=Orbit%den+Orbit%valeden
3995 : 354 : electrons=Pot%q
3996 [ + + ]: 354 : IF(Orbit%frozenvalecalculation) electrons=qcal
3997 : 354 : rescale=electrons/qcal
3998 [ + + ]: 708708 : Orbit%den(1:n)=Orbit%den(1:n)*rescale
3999 [ + + ]: 708708 : Orbit%tau(1:n)=Orbit%tau(1:n)*rescale
4000 : : ! Determine difference with tauW (Weizsaker)
4001 : 354 : fpi=4*pi
4002 [ + + ]: 708354 : dum(2:Grid%n)=Orbit%den(2:Grid%n)/(fpi*Grid%r(2:Grid%n)**2)
4003 : 354 : CALL extrapolate(dum)
4004 : 354 : CALL derivative(Grid,dum,Orbit%deltatau)
4005 [ + + ]: 708708 : Do i=1,Grid%n
4006 [ + + ]: 708708 : if (dum(i)>machine_zero) then
4007 : 648887 : Orbit%deltatau(i)=0.25_dp*(Orbit%deltatau(i)**2)/dum(i)
4008 : : else
4009 : 59467 : Orbit%deltatau(i)=0.0_dp
4010 : : endif
4011 : : enddo
4012 [ + + ]: 708354 : dum(2:Grid%n)=Orbit%tau(2:Grid%n)/(fpi*Grid%r(2:Grid%n)**2)
4013 : 354 : call extrapolate(dum)
4014 [ + + ]: 708708 : Orbit%deltatau=dum-Orbit%deltatau
4015 : 354 : call poisson_marc(Grid,Pot%q,Orbit%den,Pot%rvh,ecoul)
4016 : : ! call atompaw_poisson(Grid,Pot%q,Orbit%den,Pot%rvh,ecoul)
4017 [ + + ]: 708708 : dum=zero
4018 [ + + ]: 708354 : dum(2:n)=Pot%rvn(2:n)*Orbit%den(2:n)/Grid%r(2:n)
4019 : 354 : SCF%estatic=integrator(Grid,dum)+ecoul
4020 [ - + ]: 354 : if(has_to_print) then
4021 : 0 : WRITE(STD_OUT,*) ' n l occupancy energy'
4022 [ # # ]: 0 : do io=1,Orbit%norbit
4023 : 0 : write(std_out,*) Orbit%np(io), Orbit%l(io),Orbit%occ(io),Orbit%eig(io)
4024 : : enddo
4025 : : endif
4026 [ - + ]: 354 : ekin=0.0_dp; if (Orbit%frozencorecalculation) ekin=SCF%corekin
4027 : 354 : eone=0.0_dp
4028 [ + + ]: 2529 : DO io=1,Orbit%norbit
4029 : : if(.not.Orbit%frozencorecalculation &
4030 [ - + - - ]: 2529 : & .or.Orbit%frozencorecalculation.and.(.not.Orbit%iscore(io))) then
4031 : 2175 : eone=eone+Orbit%occ(io)*Orbit%eig(io)
4032 [ + + + - ]: 2175 : IF (counter>1.and..not.present(noalt)) THEN
4033 : 2163 : CALL altkinetic(Grid,Orbit%wfn(:,io),Orbit%eig(io),Pot%rv,x)
4034 : : ELSE
4035 : 12 : x=integrator(Grid,Orbit%otau(:,io))
4036 : : ENDIF
4037 : 2175 : ekin=ekin+Orbit%occ(io)*x
4038 : : endif
4039 : : ENDDO
4040 [ - + ]: 354 : if(has_to_print) write(std_out,*) 'KinCoul check ekin ',ekin,integrator(Grid,Orbit%tau)
4041 : 354 : SCF%eone=eone
4042 : 354 : SCF%ekin=ekin
4043 : 354 : SCF%ecoul=ecoul
4044 : 354 : counter=counter+1
4045 [ - + ]: 354 : LIBPAW_DEALLOCATE(dum)
4046 : 354 : END SUBROUTINE Get_KinCoul
4047 : :
4048 : :
4049 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4050 : : !! Get_Nuclearpotential
4051 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4052 : 4 : SUBROUTINE Get_Nuclearpotential(Grid,Pot)
4053 : : ! TODO : finitenucleus
4054 : : TYPE(GridInfo), INTENT(INOUT) :: Grid
4055 : : TYPE(PotentialInfo), INTENT(INOUT) :: Pot
4056 : : ! Various finite nuclear models follow the manuscript of Andrae
4057 : : ! Physics Reports 336 (2000) 413-525
4058 : : ! finitenucleusmodel 2,3,4,5 correspond to the options
4059 : : ! described in that paper while finitenucleusmodel 0 corresponds to
4060 : : ! Gaussian model originally programmed
4061 : : ! Note that logarithmic grid is reset to be compatible with
4062 : : ! nuclear model with approximately NN integration points within
4063 : : ! finite nucleus
4064 : : INTEGER :: i
4065 : : INTEGER, PARAMETER :: NN=651 ! number of grid points within RR
4066 : : real(dp), PARAMETER :: gridrange=100._dp
4067 : : real(dp), PARAMETER :: bohr=0.529177249_dp !Ang/Bohr from Andrae
4068 [ + - ]: 4 : IF (.NOT.Pot%finitenucleus) THEN
4069 : : ! grid already set
4070 [ + + ]: 8008 : DO i=1,Grid%n
4071 : 8008 : Pot%rvn(i)=-2*Pot%nz!*0.5!Hartree
4072 : : ENDDO
4073 : : ELSE
4074 : 0 : STOP
4075 : : ! write(std_out,*) 'Finite nucleus model -- readjusting integration grid'
4076 : : ! a=bohr*10._dp**(-5)*(0.57_dp+0.836* &
4077 : : ! & (-1.168_dp+Pot%nz*(2.163_dp+Pot%nz*0.004467_dp)))
4078 : : ! ! From Eqs. A.3 and 51 in Andrae paper
4079 : : ! write(std_out,*) 'a parameter calculated to be', a
4080 : : ! call destroygrid(Grid)
4081 : : ! SELECT CASE(Pot%finitenucleusmodel)
4082 : : ! CASE DEFAULT
4083 : : ! write(std_out,*) 'Error in finitenucleusmodel',Pot%finitenucleusmodel
4084 : : ! write(std_out,*) ' Exiting '
4085 : : ! Stop
4086 : : ! CASE(0)
4087 : : ! write(std_out,*) 'Original Gaussian model'
4088 : : ! RR=Pot%nz
4089 : : ! RR=2.9*10._dp**(-5)*(RR**0.3333333333333333333333333_dp)
4090 : : ! h=log(FLOAT(NN))/(NN-1)
4091 : : ! r0=RR/(NN-1)
4092 : : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4093 : : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4094 : : ! write(std_out,*) 'New Grid ', Grid%n
4095 : : ! Call DestroyPot(Pot)
4096 : : ! Call InitPot(Pot,Grid%n)
4097 : : ! DO i=1,Grid%n
4098 : : ! Pot%rvn(i)=-2*Pot%nz*derf(Grid%r(i)/RR)
4099 : : ! ENDDO
4100 : : ! Pot%Nv0=-2*Pot%nz*sqrt(4._dp/pi)
4101 : : ! Pot%Nv0p=0._dp
4102 : : ! CASE(2)
4103 : : ! write(std_out,*) 'Model 2 -- Breit'
4104 : : ! RR=sqrt(2._dp)*a
4105 : : ! h=log(FLOAT(NN))/(NN-1)
4106 : : ! r0=RR/(NN-1)
4107 : : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4108 : : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4109 : : ! write(std_out,*) 'New Grid ', Grid%n
4110 : : ! Call DestroyPot(Pot)
4111 : : ! Call InitPot(Pot,Grid%n)
4112 : : ! DO i=1,Grid%n
4113 : : ! if (Grid%r(i)<RR) then
4114 : : ! Pot%rvn(i)=-2*Pot%nz*Grid%r(i)*(2._dp-Grid%r(i)/RR)/RR
4115 : : ! else
4116 : : ! Pot%rvn(i)=-2*Pot%nz
4117 : : ! endif
4118 : : ! ENDDO
4119 : : ! Pot%Nv0=-2*Pot%nz*2.0_dp/RR
4120 : : ! Pot%Nv0p=2*Pot%nz/(RR**2)
4121 : : ! CASE(3)
4122 : : ! write(std_out,*) 'Model 3 -- uniform'
4123 : : ! RR=sqrt(5._dp/3._dp)*a
4124 : : ! h=log(FLOAT(NN))/(NN-1)
4125 : : ! r0=RR/(NN-1)
4126 : : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4127 : : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4128 : : ! write(std_out,*) 'New Grid ', Grid%n
4129 : : ! Call DestroyPot(Pot)
4130 : : ! Call InitPot(Pot,Grid%n)
4131 : : ! DO i=1,Grid%n
4132 : : ! if (Grid%r(i)<RR) then
4133 : : ! Pot%rvn(i)=-3*Pot%nz*Grid%r(i)*&
4134 : : ! & (1._dp-(Grid%r(i)/RR)**2/3)/RR
4135 : : ! else
4136 : : ! Pot%rvn(i)=-2*Pot%nz
4137 : : ! endif
4138 : : ! ENDDO
4139 : : ! Pot%Nv0=-3*Pot%nz/RR
4140 : : ! Pot%Nv0p=0._dp
4141 : : ! CASE(4)
4142 : : ! write(std_out,*) 'Model 4 -- exponential'
4143 : : ! RR=sqrt(1._dp/12._dp)*a
4144 : : ! h=log(FLOAT(NN))/(NN-1)
4145 : : ! r0=RR/(NN-1)
4146 : : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4147 : : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4148 : : ! write(std_out,*) 'New Grid ', Grid%n
4149 : : ! Call DestroyPot(Pot)
4150 : : ! Call InitPot(Pot,Grid%n)
4151 : : ! DO i=1,Grid%n
4152 : : ! Pot%rvn(i)=-2*Pot%nz* &
4153 : : ! & (1._dp-exp(-grid%r(i)/RR)*(1._dp+0.5_dp*Grid%r(i)/RR))
4154 : : ! ENDDO
4155 : : ! Pot%Nv0=-Pot%nz/RR
4156 : : ! Pot%Nv0p=0._dp
4157 : : ! CASE(5)
4158 : : ! write(std_out,*) 'Model 5 -- Gaussian'
4159 : : ! RR=sqrt(2._dp/3._dp)*a
4160 : : ! h=log(FLOAT(NN))/(NN-1)
4161 : : ! r0=RR/(NN-1)
4162 : : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4163 : : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4164 : : ! write(std_out,*) 'New Grid ', Grid%n
4165 : : ! Call DestroyPot(Pot)
4166 : : ! Call InitPot(Pot,Grid%n)
4167 : : ! DO i=1,Grid%n
4168 : : ! Pot%rvn(i)=-2*Pot%nz*erf(Grid%r(i)/RR)
4169 : : ! ENDDO
4170 : : ! Pot%Nv0=-2*Pot%nz/RR*(sqrt(4._dp/pi))
4171 : : ! Pot%Nv0p=0._dp
4172 : : ! END SELECT
4173 : : ENDIF
4174 : 4 : END SUBROUTINE Get_Nuclearpotential
4175 : :
4176 : :
4177 : :
4178 : :
4179 : :
4180 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4181 : : ! 6. radialsr
4182 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4183 : :
4184 : :
4185 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4186 : : !! Subroutine Azeroexpand(Grid,Pot,l,energy)
4187 : : !! If finitenucleus==.true. assumes potential is non-singular
4188 : : !! at origin and Pot%v0 and Pot%v0p are properly set
4189 : : !! Otherwise, assumes nuclear potential is -2*Z/r
4190 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4191 : 18142 : Subroutine Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB,nr)
4192 : : Type(GridInfo), INTENT(IN) :: Grid
4193 : : Type(PotentialInfo), INTENT(INout) :: Pot
4194 : : Integer, INTENT(IN) :: l
4195 : : real(dp), INTENT(IN) :: energy
4196 : : real(dp), intent(inout) :: qq,gamma,c1,c2,MA,MB
4197 : : Integer, optional, INTENT(IN) :: nr
4198 : : Integer :: n
4199 : : real(dp) :: nz,angm,alpha2,balpha2
4200 : : real(dp) :: Tm10,Tm11,T00,Tm21,Tm22,term
4201 : : n=Grid%n
4202 : 18142 : if (present(nr)) n=min(n,nr)
4203 : : ! check for possible ionic charge
4204 : 18142 : n=Grid%n
4205 : 18142 : qq=pot%zz-pot%q!-Pot%rv(n)/2
4206 [ + - ]: 18142 : if(qq<0.001_dp) qq=0
4207 : 18142 : nz=Pot%nz
4208 [ + + + + ]: 72622426 : Pot%ww=0; Pot%jj=0;
4209 : 18142 : balpha2=InvFineStruct**2
4210 : 18142 : alpha2=1._dp/balpha2
4211 : : Pot%jj(1:n)=(Grid%r(1:n) + &
4212 [ + + ]: 36320284 : & 0.25_dp*alpha2*(energy*Grid%r(1:n)-Pot%rv(1:n)))!hartree
4213 : 18142 : angm=l*(l+1)
4214 : : Pot%ww(2:n)=(Pot%rv(2:n)/Grid%r(2:n)-energy) & !*2.0 &
4215 [ + + ]: 36302142 : & + angm/(Grid%r(2:n)*Pot%jj(2:n))!hartree
4216 : 18142 : Pot%ww(1)=0
4217 [ + - ]: 18142 : if (.not.Pot%finitenucleus) then
4218 : 18142 : gamma=sqrt(angm+1._dp-alpha2*nz**2)
4219 : 18142 : term=1._dp+0.25_dp*alpha2*(energy-Pot%v0)!*2.0!hartree
4220 : 18142 : Tm21=2*gamma+1; Tm22=2*(2*gamma+2)
4221 : : !hartree!hartree!hartree
4222 : 18142 : Tm10=nz*(2._dp+alpha2*(energy-Pot%v0))-(2*balpha2/nz)*term*(gamma-1._dp)
4223 : 18142 : Tm11=nz*(2._dp+alpha2*(energy-Pot%v0))-(2*balpha2/nz)*term*(gamma)
4224 : : T00=-alpha2*nz*Pot%v0p+term*(energy-Pot%v0) + &
4225 : 18142 : & (Pot%v0p/nz+(4*balpha2**2/(nz*nz))*term**2)*(gamma-1._dp)
4226 : 18142 : c1=-Tm10/Tm21
4227 : 18142 : c2=-(Tm11*C1+T00)/Tm22
4228 : 18142 : MA=0; MB=0
4229 : : else ! version for finite nuclear size
4230 : 0 : gamma=l+1._dp
4231 : 0 : term=1._dp+0.25_dp*alpha2*(energy-Pot%v0)
4232 : 0 : Tm21=2*l+2; Tm22=2*(2*l+3)
4233 : 0 : Tm10=(0.25_dp*alpha2*Pot%v0p/term)*(l)
4234 : 0 : Tm11=(0.25_dp*alpha2*Pot%v0p/term)*(l+1)
4235 : 0 : T00=(energy-Pot%v0)*term+l*((0.25_dp*alpha2*Pot%v0p/term)**2)
4236 : 0 : c1=-Tm10/Tm21
4237 : 0 : c2=-(Tm11*C1+T00)/Tm22
4238 : 0 : MA=0; MB=0
4239 : : endif
4240 : 18142 : end subroutine Azeroexpand
4241 : :
4242 : :
4243 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4244 : : !! SUBROUTINE wfnsrinit(Grid,l,wfn,lwfn,istart)
4245 : : !! returns the solution of the scalar relativistic equations near r=0
4246 : : !! using power series expansion
4247 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4248 [ - + - + : 18142 : SUBROUTINE wfnsrinit(Grid,l,wfn,lwfn,istart,finitenucleus,gamma,c1,c2,MA,MB,jj)
- + ]
4249 : : Type(GridInfo), INTENT(IN) :: Grid
4250 : : INTEGER, INTENT(IN) :: l
4251 : : real(dp),intent(in) :: gamma,c1,c2,MA,MB
4252 : : real(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
4253 : : real(dp),intent(in) :: jj(:)
4254 : : INTEGER, INTENT(OUT) :: istart
4255 : : logical, intent(in) :: finitenucleus
4256 : : real(dp) :: rr,M
4257 : : INTEGER :: i
4258 [ + + + + ]: 72621172 : wfn=0; lwfn=0
4259 : 18142 : istart=6
4260 [ + + ]: 126994 : do i=1,istart
4261 : 108852 : rr=Grid%r(i+1)
4262 [ + - ]: 126994 : if (.not.finitenucleus) then
4263 : 108852 : wfn(i+1)=1+rr*(c1+rr*c2)
4264 : 108852 : lwfn(i+1)=(gamma-1)+rr*(c1*gamma+rr*c2*(gamma+1))
4265 : 108852 : wfn(i+1)=wfn(i+1)*(rr**gamma)
4266 : 108852 : lwfn(i+1)=lwfn(i+1)*(rr**gamma)/jj(i+1)
4267 : : else ! finite nucleus case
4268 : 0 : M=MA-MB*rr
4269 : 0 : wfn(i+1)=(1+rr*(c1+rr*c2))*(rr**(l+1))
4270 : 0 : lwfn(i+1)=(l+rr*((l+1)*c1+rr*(l+2)*c2))*(rr**(l+1))/M
4271 : : endif
4272 : : enddo
4273 : 18142 : End SUBROUTINE wfnsrinit
4274 : :
4275 : :
4276 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4277 : : !! SUBROUTINE wfnsrasym(Grid,wfn,lwfn,energy,iend)
4278 : : !! returns the solution of the scalar relativistic equations near r=inf
4279 : : !! using exp(-x*r) for upper component
4280 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4281 [ - + - + : 17889 : subroutine wfnsrasym(Grid,wfn,lwfn,energy,iend,qq,jj)
- + ]
4282 : : ! returns the solution of the scalar relativistic equations near r=inf
4283 : : ! using exp(-x*r) for upper component
4284 : : Type(GridInfo), INTENT(IN) :: Grid
4285 : : real(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
4286 : : real(dp), INTENT(IN) :: energy,qq
4287 : : real(dp),intent(in) :: jj(:)
4288 : : INTEGER, INTENT(OUT) :: iend
4289 : : real(dp) :: rr,x,m,qx
4290 : : INTEGER :: i,n
4291 [ - + ]: 17889 : if (energy>0._dp) then
4292 : 0 : LIBPAW_ERROR('Error in wfnsrasym -- energy > 0')
4293 : : endif
4294 [ + + + + ]: 71609667 : wfn=0; lwfn=0;
4295 : 17889 : n=Grid%n
4296 : 17889 : m=1._dp+0.25_dp*energy/(InvFineStruct**2)!Hartree
4297 : 17889 : x=sqrt(-m*energy)!Hartree
4298 : 17889 : qx=qq ! Possible net ionic charge
4299 : 17889 : qx=(qx/x)*(1._dp+0.5_dp*energy/(InvFineStruct**2))!Hartree
4300 : 17889 : iend=5
4301 [ + + ]: 125223 : do i=n-iend,n
4302 : 107334 : wfn(i)=exp(-x*(Grid%r(i)-Grid%r(n-iend)))
4303 [ - + ]: 107334 : if (qx>0._dp) then
4304 : 0 : rr=(Grid%r(i)/Grid%r(n-iend))**qx
4305 : 0 : wfn(i)=wfn(i)*rr
4306 : : endif
4307 : 125223 : lwfn(i)=-wfn(i)*(x*Grid%r(i)+(1._dp-qx))/jj(i)
4308 : : enddo
4309 : 17889 : end subroutine wfnsrasym
4310 : :
4311 : :
4312 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4313 : : !! subroutine unboundsr(Grid,Pot,nr,l,energy,wfn,nodes)
4314 : : !! pgm to solve radial scalar relativistic equation for unbound states
4315 : : !! at energy 'energy' and at angular momentum l
4316 : : !!
4317 : : !! with potential rv/r, given in uniform linear or log mesh of n points
4318 : : !! assuming p(r)=C*r**(l+1)*polynomial(r) for r==0;
4319 : : !!
4320 : : !! nz=nuclear charge
4321 : : !!
4322 : : !! Does not use Noumerov algorithm -- but uses coupled first-order
4323 : : !! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
4324 : : !!
4325 : : !! also returns node == number of nodes for calculated state
4326 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4327 [ - + ]: 5 : SUBROUTINE unboundsr(Grid,Pot,nr,l,energy,wfn,nodes)
4328 : : TYPE(GridInfo), INTENT(IN) :: Grid
4329 : : TYPE(PotentialInfo), INTENT(INout) :: Pot
4330 : : INTEGER, INTENT(IN) :: nr,l
4331 : : real(dp), INTENT(IN) :: energy
4332 : : real(dp), INTENT(INOUT) :: wfn(:)
4333 : : INTEGER, INTENT(INOUT) :: nodes
4334 : : INTEGER :: n,istart
4335 : : real(dp) :: scale,gamma,c1,c2,MA,MB,qq
4336 : : real(dp), allocatable :: lwfn(:),zz(:,:,:),yy(:,:)
4337 : 5 : n=Grid%n
4338 [ - + ]: 5 : IF (nr > n) THEN
4339 : 0 : LIBPAW_ERROR('Error in unboundsr')
4340 : : ENDIF
4341 : 5 : call Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB,nr)
4342 [ - + + - : 15 : LIBPAW_ALLOCATE(lwfn,(nr))
+ - + - -
+ - + ]
4343 [ - + + - : 15 : LIBPAW_ALLOCATE(zz,(2,2,nr))
+ - + - -
+ - + ]
4344 [ - + + - : 15 : LIBPAW_ALLOCATE(yy,(2,nr))
+ - + - -
+ - + ]
4345 [ + + + + : 103163 : lwfn=0;zz=0;yy=0;
+ + + + +
+ + + ]
4346 : 5 : call wfnsrinit(Grid,l,wfn,lwfn,istart,Pot%finitenucleus,gamma,c1,c2,MA,MB,Pot%jj)
4347 : 5 : call prepareforcfdsol(Grid,1,istart,nr,wfn,lwfn,yy,zz,Pot%ww,Pot%jj)
4348 : 5 : call cfdsol(Grid,zz,yy,istart,nr)
4349 : 5 : call getwfnfromcfdsol(1,nr,yy,wfn)
4350 : 5 : nodes=countnodes(2,nr,wfn)
4351 : : ! normalize to unity within integration range
4352 : 5 : scale=1._dp/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr)
4353 : 5 : scale=SIGN(SQRT(scale),wfn(nr-2))
4354 [ + + ]: 9383 : wfn(1:nr)=wfn(1:nr)*scale
4355 [ - + ]: 5 : LIBPAW_DEALLOCATE(lwfn)
4356 [ - + ]: 5 : LIBPAW_DEALLOCATE(yy)
4357 [ - + ]: 5 : LIBPAW_DEALLOCATE(zz)
4358 : 5 : END SUBROUTINE unboundsr
4359 : :
4360 : :
4361 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4362 : : !! SUBROUTINE boundsr(Grid,Pot,eig,wfn,l,nroot,emin,ierr,success)
4363 : : !! pgm to solve radial scalar relativistic equation for nroot bound state
4364 : : !! energies and wavefunctions for angular momentum l
4365 : : !! with potential rv/r, given in uniform linear or log mesh of n points
4366 : : !! nz=nuclear charge
4367 : : !! emin=is estimate of lowest eigenvalue; used if nz=0
4368 : : !! otherwise, set to the value of -(nz/(l+1))**2
4369 : : !!
4370 : : !! It is assumed that the wavefunction has np-l-1 nodes, where
4371 : : !! np is the principle quantum number-- np=1,2,..nroot
4372 : : !!
4373 : : !! Does not use Noumerov algorithm -- but uses coupled first-order
4374 : : !! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
4375 : : !!
4376 : : !! Corrections are also needed for r>n*h, depending on:
4377 : : !! e0 (current guess of energy eigenvalue
4378 : : !! the extrapolated value of rv == r * v
4379 : : !!
4380 : : !! ierr=an nroot digit number indicating status of each root
4381 : : !! a digit of 1 indicates success in converging root
4382 : : !! 2 indicates near success in converging root
4383 : : !! 9 indicates that root not found
4384 : : !!
4385 : : !! first check how many roots expected = ntroot (returned as argument)
4386 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4387 [ - + - + ]: 248 : SUBROUTINE boundsr(Grid,Pot,eig,wfn,l,nroot,emin,ierr,success)
4388 : : TYPE(GridInfo), INTENT(IN) :: Grid
4389 : : TYPE(PotentialInfo), INTENT(INout) :: Pot
4390 : : real(dp), INTENT(INOUT) :: eig(:),wfn(:,:)
4391 : : INTEGER, INTENT(IN) :: l,nroot
4392 : : INTEGER, INTENT(INOUT) :: ierr
4393 : : real(dp), INTENT(INOUT) :: emin
4394 : : LOGICAL, INTENT(INOUT) :: success
4395 : : real(dp), PARAMETER :: convre=tol10,vlrg=10._dp**30
4396 : : INTEGER, PARAMETER :: niter=1000
4397 : 248 : real(dp), POINTER :: rv(:)
4398 : 248 : real(dp), ALLOCATABLE :: p1(:),p2(:),dd(:)
4399 : : INTEGER :: n
4400 : : real(dp) :: nz,h,v0,v0p
4401 : : real(dp) :: err,convrez,energy,gamma,c1,c2,MA,MB
4402 : : real(dp) :: scale,emax,best,rout,qq
4403 : : real(dp) :: rin,dele,x
4404 : : INTEGER :: iter,i,j,node,match,mxroot,ntroot,ir,iroot
4405 : : INTEGER :: ifac,istart,iend
4406 : : LOGICAL :: ok
4407 : : real(dp), allocatable :: lwfn(:),zz(:,:,:),yy(:,:)
4408 : 248 : n=Grid%n
4409 : 248 : h=Grid%h
4410 [ + - + - : 744 : LIBPAW_ALLOCATE(p1,(n))
+ - - + -
+ ]
4411 [ - + + - : 496 : LIBPAW_ALLOCATE(p2,(n))
- + - + ]
4412 [ - + + - : 496 : LIBPAW_ALLOCATE(dd,(n))
- + - + ]
4413 : 248 : success=.true.
4414 [ - + + - : 496 : LIBPAW_ALLOCATE(lwfn,(n))
- + - + ]
4415 [ - + + - : 744 : LIBPAW_ALLOCATE(zz,(2,2,n))
+ - + - -
+ - + ]
4416 [ - + + - : 744 : LIBPAW_ALLOCATE(yy,(2,n))
+ - + - -
+ - + ]
4417 : 248 : nz=Pot%nz
4418 : 248 : v0=Pot%v0
4419 : 248 : v0p=Pot%v0p
4420 : 248 : rv=>Pot%rv
4421 : 248 : err=n*nz*(h**4)!*0.5!hartree
4422 : 248 : convrez=convre
4423 [ + - ]: 248 : IF (nz>0.001_dp) convrez=convre*nz
4424 : 248 : ierr=0
4425 [ - + ]: 248 : if(has_to_print) write(std_out,*) 'z , l = ',nz,l
4426 : : ! check how many roots expected by integration outward at
4427 : : ! energy = 0
4428 : 248 : energy = 0
4429 : 248 : call Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB)
4430 [ + + + + : 5458976 : lwfn=0;zz=0;yy=0;
+ + + + +
+ + + ]
4431 : 248 : call wfnsrinit(Grid,l,p1,lwfn,istart,Pot%finitenucleus,gamma,c1,c2,MA,MB,Pot%jj)
4432 : : !start outward integration
4433 : 248 : call prepareforcfdsol(Grid,1,istart,n,p1,lwfn,yy,zz,Pot%ww,Pot%jj)
4434 : 248 : call cfdsoliter(Grid,zz,yy,istart,n)
4435 : 248 : call getwfnfromcfdsol(1,n,yy,p1)
4436 : 248 : node=countnodes(2,n,p1)
4437 [ - + ]: 248 : if(has_to_print) write(std_out,*) ' nodes at e=0 ', node
4438 : 248 : mxroot=node+1
4439 : 248 : ntroot=node
4440 [ - + ]: 248 : IF (mxroot.LT.nroot) THEN
4441 [ # # ]: 0 : if(has_to_print) write(std_out,*)'error in boundsr - for l = ',l
4442 [ # # ]: 0 : if(has_to_print) write(std_out,*) nroot,' states requested but only',mxroot,' possible'
4443 [ # # ]: 0 : DO ir=mxroot+1,nroot
4444 : 0 : ierr=ierr+9*(10**(ir-1))
4445 : : ENDDO
4446 : 0 : success=.false.
4447 : : ENDIF
4448 : 248 : mxroot=min0(mxroot,nroot)
4449 [ - + ]: 248 : IF (nz.EQ.0) energy=-ABS(emin)
4450 [ + - ]: 248 : IF (nz.NE.0) energy=-(1.1_dp*(nz/(l+1._dp))**2)!*0.5!Hartree
4451 : 248 : emin=energy-err
4452 : 248 : emax=0._dp
4453 [ + + ]: 846 : DO iroot=1,mxroot
4454 : 598 : best=1.d10; dele=1.d10
4455 : 598 : energy=emin+err
4456 [ - + ]: 598 : IF (energy.LT.emin) energy=emin
4457 [ - + ]: 598 : IF (energy.GT.emax) energy=emax
4458 : 17898 : ok=.FALSE.
4459 [ + + ]: 17898 : BigIter: DO iter=1,niter
4460 : : ! start inward integration
4461 : : ! start integration at n
4462 : 17889 : call Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB)
4463 : : ! find classical turning point
4464 : 17889 : call ClassicalTurningPoint(Grid,Pot%rv,l,energy,match)
4465 : 17889 : match=max(match,10); match=min(match,n-20)
4466 : 17889 : call wfnsrasym(Grid,p2,lwfn,energy,iend,qq,Pot%jj)
4467 : 17889 : call prepareforcfdsol(Grid,n-iend,n,n,p2,lwfn,yy,zz,Pot%ww,Pot%jj)
4468 : 17889 : call cfdsoliter(Grid,zz,yy,n-iend,match)
4469 : 17889 : call getwfnfromcfdsol(match,n,yy,p2)
4470 : 17889 : match=match+6
4471 : 17889 : rin=Gfirstderiv(Grid,match,p2)/p2(match)
4472 : 17889 : call wfnsrinit(Grid,l,p1,lwfn,istart,Pot%finitenucleus,gamma,c1,c2,MA,MB,Pot%jj)
4473 : 17889 : call prepareforcfdsol(Grid,1,istart,n,p1,lwfn,yy,zz,Pot%ww,Pot%jj)
4474 : 17889 : call cfdsoliter(Grid,zz,yy,istart,match+6)
4475 : 17889 : call getwfnfromcfdsol(1,match+6,yy,p1)
4476 : 17889 : node= countnodes(2,match+6,p1)
4477 : 17889 : rout=Gfirstderiv(Grid,match,p1)/p1(match)
4478 : : ! check whether node = (iroot-1)
4479 : : ! not enough nodes -- raise energy
4480 [ + + ]: 53676 : IF (node.LT.iroot-1) THEN
4481 : 744 : emin=MAX(emin,energy)-err
4482 : 744 : energy=emax-(emax-energy)*ranx()
4483 : 744 : ifac=9
4484 : : ! too many nodes -- lower energy
4485 [ + + ]: 17145 : ELSEIF (node.GT.iroot-1) THEN
4486 [ - + ]: 496 : IF (energy.LE.emin) THEN
4487 : 0 : ierr=ierr+9*(10**(iroot-1))
4488 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'boundsr error -- emin too high',l,nz,emin,energy
4489 [ # # ]: 0 : IF (energy.LE.emin-tol10) THEN
4490 : 0 : STOP
4491 : : ENDIF
4492 : : ENDIF
4493 : 496 : emax=MIN(emax,energy+err)
4494 : 496 : energy=emin+(energy-emin)*ranx()
4495 : : ! correct number of nodes -- estimate correction
4496 [ + - ]: 16649 : ELSEIF (node.EQ.iroot-1) THEN
4497 [ + + ]: 10690262 : DO j=1,match
4498 : 10690262 : p1(j)=p1(j)/p1(match)
4499 : : ENDDO
4500 [ + + ]: 22674334 : DO j=match,n
4501 : 22674334 : p1(j)=p2(j)/p2(match)
4502 : : ENDDO
4503 : 16649 : scale=1._dp/overlap(Grid,p1,p1)
4504 : 16649 : dele=(rout-rin)*scale
4505 : 16649 : x=ABS(dele)
4506 [ + + ]: 16649 : IF (x.LT.best) THEN
4507 : 4577 : scale=SQRT(scale)
4508 [ + + ]: 9163154 : p1(1:n)=p1(1:n)*scale
4509 : 4577 : call filter(n,p1,machine_zero)
4510 [ + + ]: 9163154 : wfn(1:n,iroot)=p1(1:n)
4511 : 4577 : eig(iroot)=energy
4512 : 4577 : best=x
4513 : : ENDIF
4514 [ + + ]: 16649 : IF (ABS(dele).LE.convrez) THEN
4515 : 589 : ok=.TRUE.
4516 : : ! eigenvalue found
4517 : 589 : ierr=ierr+10**(iroot-1)
4518 [ + + ]: 589 : IF (iroot+1.LE.mxroot) THEN
4519 : 350 : emin=energy+err
4520 : 350 : emax=0
4521 : 350 : energy=(emin+emax)/2
4522 [ - + ]: 350 : IF (energy.LT.emin) energy=emin
4523 [ - + ]: 350 : IF (energy.GT.emax) energy=emax
4524 : : best=1.d10
4525 : : ENDIF
4526 : : EXIT BigIter
4527 : : ENDIF
4528 [ + - ]: 16060 : IF (ABS(dele).GT.convrez) THEN
4529 : 16060 : energy=energy+dele!*0.5!hartree
4530 : : ! if energy is out of range, pick random energy in correct range
4531 [ + + + + ]: 16060 : IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) &
4532 : 11494 : energy=emin+(emax-emin)*ranx()
4533 : : ifac=2
4534 : : ENDIF
4535 : : ENDIF
4536 : : ENDDO BigIter !iter
4537 : 248 : IF (.NOT.ok) THEN
4538 : 9 : success=.false.
4539 : 9 : ierr=ierr+ifac*(10**(iroot-1))
4540 [ - + ]: 9 : if(has_to_print) write(std_out,*) 'no convergence in boundsr',iroot,l,dele,energy
4541 [ - + ]: 9 : if(has_to_print) write(std_out,*) ' best guess of eig, dele = ',eig(iroot),best
4542 [ - + ]: 9 : IF (iroot.LT.mxroot) THEN
4543 [ # # ]: 0 : DO ir=iroot+1,mxroot
4544 : 0 : ierr=ierr+9*(10**(ir-1))
4545 : : ENDDO
4546 : : ENDIF
4547 : : ! reset wfn with hydrogenic form
4548 : 9 : j=iroot+l+1
4549 [ + + ]: 18018 : wfn(:,iroot)=0
4550 : 9 : x=(j)*sqrt(abs(eig(iroot)*2.0))
4551 [ + + ]: 18009 : do i=2,n
4552 : 18009 : wfn(i,iroot)=hwfn(x,j,l,Grid%r(i))
4553 : : enddo
4554 : : ENDIF
4555 : : ENDDO !iroot
4556 [ - + ]: 248 : LIBPAW_DEALLOCATE(p1)
4557 [ - + ]: 248 : LIBPAW_DEALLOCATE(p2)
4558 [ - + ]: 248 : LIBPAW_DEALLOCATE(dd)
4559 [ - + ]: 248 : LIBPAW_DEALLOCATE(lwfn)
4560 [ - + ]: 248 : LIBPAW_DEALLOCATE(yy)
4561 [ - + ]: 248 : LIBPAW_DEALLOCATE(zz)
4562 [ - + ]: 496 : END SUBROUTINE Boundsr
4563 : :
4564 : :
4565 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4566 : : !! prepareforcfdsol
4567 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4568 [ - + - + : 36031 : subroutine prepareforcfdsol(Grid,i1,i2,n,wfn,lwfn,yy,zz,ww,jj)
- + - + -
+ - + ]
4569 : : Type(gridinfo), INTENT(IN) :: Grid
4570 : : INTEGER, INTENT(IN) :: i1,i2,n
4571 : : real(dp), INTENT(IN) :: wfn(:),lwfn(:)
4572 : : real(dp), INTENT(OUT) :: yy(:,:),zz(:,:,:)
4573 : : real(dp),intent(in) :: ww(:),jj(:)
4574 : : INTEGER :: i
4575 [ + + + + : 721046102 : yy=0;zz=0
+ + + + +
+ ]
4576 [ + + ]: 252217 : yy(1,i1:i2)=wfn(i1:i2)
4577 [ + + ]: 252217 : yy(2,i1:i2)=lwfn(i1:i2)
4578 [ + + ]: 72097404 : do i=2,n
4579 : 72061373 : zz(1,1,i)=1._dp/Grid%r(i)
4580 : 72061373 : zz(1,2,i)=jj(i)/Grid%r(i)
4581 : 72061373 : zz(2,2,i)=-1._dp/Grid%r(i)
4582 : 72097404 : zz(2,1,i)=ww(i)
4583 : : enddo
4584 : 36031 : end subroutine prepareforcfdsol
4585 : :
4586 : :
4587 : :
4588 : :
4589 : :
4590 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4591 : : ! 7. anderson_driver
4592 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4593 : :
4594 : :
4595 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4596 : : !! Anderson_Mix
4597 : : !! Performs the actual mixing of the input vector with the
4598 : : !! history and retuns the result.
4599 : : !!
4600 : : !! AC - Anderson context
4601 : : !! X - Current vector on input and new guess on output
4602 : : !! F - F(X) - X. Nonlinear mixing of input vector
4603 : : !!
4604 : : !! Modified to call SVD routines
4605 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4606 [ - + - + ]: 331 : SUBROUTINE Anderson_Mix(AC, X, F)
4607 : : SAVE
4608 : : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4609 : : real(dp), INTENT(INOUT) :: X(:)
4610 : : real(dp), INTENT(IN) :: F(:)
4611 : : INTEGER :: i, slot, currentdim , n ,j
4612 : : real(dp) :: term
4613 : : real(dp) :: tmp
4614 : : !First determine where to store the new correction vectors ***
4615 : 331 : AC%slot = AC%slot + 1
4616 [ + + ]: 331 : IF (AC%Slot>AC%Nmax) AC%Slot = 1
4617 [ + + - + ]: 331 : IF ((AC%N < 0) .OR. (AC%Nmax == 0)) THEN !** Simple mixing for 1st time ***
4618 [ + + ]: 46046 : AC%Xprev = X
4619 [ + + ]: 46046 : X = X + AC%NewMix*F
4620 : : ELSE
4621 : 308 : slot = AC%Slot
4622 [ + + ]: 616616 : AC%DF(:,slot) = F - AC%Fprev !** Make new DF vector
4623 [ + + ]: 616616 : AC%DX(:,slot) = X - AC%Xprev !** Make new DX vector
4624 : 308 : currentdim=MIN(AC%N+1,AC%Nmax)
4625 [ + + ]: 1624 : DO i=1, currentdim !*** Add row/col to matrix
4626 [ + + ]: 2634632 : term = DOT_PRODUCT(AC%DF(:,i), AC%DF(:,slot))
4627 : 1316 : AC%Matrix(i,slot) = term
4628 [ + + ]: 1316 : IF (i /= slot) AC%Matrix(slot,i) = (term)
4629 [ + + ]: 2634940 : AC%Gamma(i) = DOT_PRODUCT(AC%DF(:,i), F)
4630 : : END DO
4631 [ + + + + ]: 9548 : AC%DupMatrix = AC%Matrix
4632 : 308 : n = AC%Nmax; j= currentdim
4633 : : CALL DGESDD('A',j,j,AC%DupMatrix(1,1),n,AC%S(1), &
4634 : 308 : AC%U(1,1),n,AC%VT(1,1),n,AC%Work(1),AC%Lwork, AC%IPIV(1),i)
4635 [ - + ]: 308 : IF (i /= 0) THEN
4636 : 0 : LIBPAW_ERROR('Anderson_Mix: Error in DGESDD.')
4637 : : END IF
4638 [ + + ]: 1624 : AC%Work(1:j) = AC%Gamma(1:j)
4639 [ + + ]: 1848 : AC%Gamma = 0
4640 : 308 : tmp=MAX(ABS(AC%S(1))/AC%ConditionNo,AC%Machaccur)
4641 [ + + ]: 1624 : DO i=1,j
4642 [ + + ]: 1624 : IF (ABS(AC%S(i)).GT.tmp) THEN
4643 : : AC%Gamma(1:j)=AC%Gamma(1:j)+&
4644 [ + + + + ]: 5045 : (AC%VT(i,1:j))*DOT_PRODUCT(AC%U(1:j,i),AC%Work(1:j))/AC%S(i)
4645 : : ENDIF
4646 : : ENDDO
4647 [ + + ]: 616616 : AC%Xprev = X
4648 : : !*** Now calculate the new vector ***
4649 [ + + ]: 616616 : X = X + AC%NewMix*F
4650 [ + + ]: 1624 : DO i=1, currentdim ! updated vector
4651 [ + + ]: 2634940 : X = X - AC%Gamma(i)*(AC%DX(:,i) + AC%NewMix*AC%DF(:,i))
4652 : : END DO
4653 : : END IF
4654 [ + + ]: 662662 : AC%Fprev = F
4655 : 331 : AC%N = AC%N + 1
4656 [ + + ]: 331 : IF (AC%N > AC%Nmax) AC%N = AC%Nmax
4657 : 331 : RETURN
4658 : : END SUBROUTINE Anderson_Mix
4659 : :
4660 : :
4661 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4662 : : !! Anderson_ResetMix - Resets the mixing history to None
4663 : : !! AC - Anderson context to reset
4664 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4665 : 0 : SUBROUTINE Anderson_ResetMix(AC)
4666 : : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4667 : 0 : AC%N = -1
4668 : 0 : AC%Slot = -1
4669 : 0 : AC%CurIter=0
4670 : : RETURN
4671 : : END SUBROUTINE Anderson_ResetMix
4672 : :
4673 : :
4674 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4675 : : !! FreeAnderson - Frees all the data associated with the AC data structure
4676 : : !! AC -Pointer to the Anderson context to free
4677 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4678 : 23 : SUBROUTINE FreeAnderson(AC)
4679 : : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4680 [ + - ]: 23 : IF (ASSOCIATED(AC%Matrix)) then
4681 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%Matrix)
4682 : : endif
4683 [ + - ]: 23 : IF (ASSOCIATED(AC%Gamma)) then
4684 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%Gamma)
4685 : : endif
4686 [ + - ]: 23 : IF (ASSOCIATED(AC%DF)) then
4687 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%DF)
4688 : : endif
4689 [ + - ]: 23 : IF (ASSOCIATED(AC%Fprev)) then
4690 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%Fprev)
4691 : : endif
4692 [ + - ]: 23 : IF (ASSOCIATED(AC%DX)) then
4693 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%DX)
4694 : : endif
4695 [ + - ]: 23 : IF (ASSOCIATED(AC%Xprev)) then
4696 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%Xprev)
4697 : : endif
4698 [ + - ]: 23 : IF (ASSOCIATED(AC%IPIV)) then
4699 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%IPIV)
4700 : : endif
4701 [ + - ]: 23 : IF (ASSOCIATED(AC%S)) then
4702 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%S)
4703 : : endif
4704 [ + - ]: 23 : IF (ASSOCIATED(AC%RWork)) then
4705 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%RWork)
4706 : : endif
4707 [ + - ]: 23 : IF (ASSOCIATED(AC%U)) then
4708 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%U)
4709 : : endif
4710 [ + - ]: 23 : IF (ASSOCIATED(AC%VT)) then
4711 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%VT)
4712 : : endif
4713 [ + - ]: 23 : IF (ASSOCIATED(AC%Work)) then
4714 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%Work)
4715 : : endif
4716 [ + - ]: 23 : IF (ASSOCIATED(AC%DupMatrix)) then
4717 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%DupMatrix)
4718 : : endif
4719 : 23 : RETURN
4720 : : END SUBROUTINE FreeAnderson
4721 : :
4722 : :
4723 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4724 : : !! InitAnderson_dr - Initializes and Anderson_Context data structure for use
4725 : : !! AC - Anderson context created and returned
4726 : : !! Err_Unit - Output error unit
4727 : : !! Nmax - Max number of vectors to keep
4728 : : !! VecSize - Size of each vector
4729 : : !! NewMix - Mixing factor
4730 : : !! CondNo - For matrix inversion
4731 : : !! MaxIter - Maximum number of iterations
4732 : : !! err - minimum residue convergence tolerance
4733 : : !! toosmall - result obviously converged
4734 : : !! verbose - if true -- write out results
4735 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4736 : 23 : SUBROUTINE InitAnderson_dr(AC,Err_Unit,Nmax,VecSize,NewMix,CondNo,&
4737 : : & MaxIter,err,toosmall,verbose)
4738 : : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4739 : : INTEGER, INTENT(IN) :: Err_Unit
4740 : : INTEGER, INTENT(IN) :: Nmax
4741 : : INTEGER, INTENT(IN) :: VecSize
4742 : : real(dp), INTENT(IN) :: NewMix
4743 : : real(dp), INTENT(IN) :: CondNo
4744 : : INTEGER, INTENT(IN) :: MaxIter
4745 : : real(dp), INTENT(IN) :: err,toosmall
4746 : : LOGICAL, INTENT(IN) :: verbose
4747 : : real(dp) :: a1,a2,a3
4748 : 23 : AC%Nmax = Nmax !*** Store the contants
4749 : 23 : AC%VecSize = VecSize
4750 : 23 : AC%NewMix = NewMix
4751 : 23 : AC%Err_Unit = Err_Unit
4752 : 23 : AC%MaxIter = MaxIter
4753 : 23 : AC%err = err
4754 : 23 : AC%toosmall = toosmall
4755 : 23 : AC%writelots=verbose
4756 : 23 : AC%N = -1 !** Init the rest of the structure
4757 : 23 : AC%Slot = -1
4758 : 23 : AC%CurIter=0
4759 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%Xprev,(VecSize))
+ - + - -
+ - + ]
4760 [ - + + - : 46 : LIBPAW_POINTER_ALLOCATE(AC%Fprev,(VecSize))
- + - + ]
4761 [ - + + - : 92 : LIBPAW_POINTER_ALLOCATE(AC%DX,(VecSize,Nmax))
- + + - +
- + - - +
- + ]
4762 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%DF,(VecSize,Nmax))
- + + - -
+ - + ]
4763 [ - + + - : 92 : LIBPAW_POINTER_ALLOCATE(AC%Matrix,(Nmax,Nmax))
- + + - +
- + - - +
- + ]
4764 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%Gamma,(Nmax))
+ - + - -
+ - + ]
4765 : 23 : AC%Lwork=5*Nmax*Nmax+10*Nmax
4766 : 23 : AC%LRwork= 5*Nmax*Nmax+7*Nmax
4767 : 23 : AC%ConditionNo= CondNo
4768 : : ! Calculate machine accuracy
4769 : 23 : AC%Machaccur = 0
4770 : 23 : a1 = 4._dp/3._dp
4771 [ + + ]: 46 : DO WHILE (AC%Machaccur == 0._dp)
4772 : 23 : a2 = a1 - 1._dp
4773 : 23 : a3 = a2 + a2 + a2
4774 : 23 : AC%Machaccur = ABS(a3 - 1._dp)
4775 : : ENDDO
4776 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%DupMatrix,(Nmax,Nmax))
- + + - -
+ - + ]
4777 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%U,(Nmax, Nmax))
- + + - -
+ - + ]
4778 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%VT,(Nmax,Nmax))
- + + - -
+ - + ]
4779 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%Work,(AC%Lwork))
+ - + - -
+ - + ]
4780 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%RWork,(AC%LRWork))
+ - + - -
+ - + ]
4781 [ + - - + : 69 : LIBPAW_POINTER_ALLOCATE(AC%IPIV,(8*Nmax))
+ - + - +
- - + -
+ ]
4782 [ - + + - : 46 : LIBPAW_POINTER_ALLOCATE(AC%S,(Nmax))
- + - + ]
4783 [ + + + + ]: 713 : AC%Matrix = 0
4784 : 23 : RETURN
4785 : : END SUBROUTINE InitAnderson_dr
4786 : :
4787 : :
4788 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4789 : : !! DoAndersonMix
4790 : : !! Note residue can be wout-w or more general residue that tends --> 0
4791 : : !! at convergence
4792 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4793 [ - + ]: 23 : SUBROUTINE DoAndersonMix(AC,w,E,Esub,success,atp)
4794 : : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4795 : : real(dp), INTENT(INOUT) :: E,w(:)
4796 : : ! External :: Esub
4797 : : LOGICAL, INTENT(OUT) :: success
4798 : : type(atompaw_type), intent(inout) :: atp
4799 : 23 : real(dp), ALLOCATABLE :: residue(:),tmp(:)
4800 : : real(dp) :: err,v1,v2,v3,v4
4801 : : INTEGER :: i,n
4802 : : real(dp), PARAMETER :: conv1=4.d13,conv2=3.d13,conv3=2.d13,conv4=1.d13
4803 : : LOGICAL :: OK
4804 : : INTERFACE
4805 : : SUBROUTINE Esub(w,energy,residue,err,OK,update,atp)
4806 : : USE_DEFS
4807 : : import atompaw_type
4808 : : real(dp), INTENT(INOUT) :: w(:)
4809 : : real(dp), INTENT(OUT) :: energy
4810 : : real(dp), INTENT(OUT) :: residue(:)
4811 : : real(dp), INTENT(OUT) :: err
4812 : : LOGICAL, INTENT(OUT) :: OK
4813 : : LOGICAL, INTENT(IN) :: update
4814 : : type(atompaw_type), intent(inout) :: atp
4815 : : END SUBROUTINE Esub
4816 : : END INTERFACE
4817 : 23 : n=SIZE(w);success=.FALSE.
4818 [ - + + - : 69 : LIBPAW_ALLOCATE(residue,(n))
+ - + - -
+ - + ]
4819 [ - + + - : 46 : LIBPAW_ALLOCATE(tmp,(n))
- + - + ]
4820 : 23 : err=1.0d10
4821 [ + + ]: 46046 : v1=conv1;v2=conv2;v3=conv3;v4=conv4;tmp=0
4822 [ - + ]: 354 : DO i=1,AC%MaxIter
4823 : 354 : AC%CurIter=i
4824 : 354 : CALL Esub(w,E,residue,err,OK,.TRUE.,atp)
4825 : 354 : AC%res=err
4826 [ + + ]: 354 : if (err<AC%toosmall) THEN
4827 [ - + ]: 23 : If(AC%writelots)&
4828 : : write(std_out,&
4829 : : & '("AndersonMix converged in ",i5," iterations with err = ",1p,1e15.7)')&
4830 : 0 : & i, err
4831 : : EXIT
4832 : : endif
4833 : 331 : CALL shift4(v1,v2,v3,v4,err)
4834 [ + - ]: 263 : IF (i>=4.AND.OK) THEN
4835 : : IF ((.NOT.(v4.LE.v3.AND.v3.LE.v2 &
4836 [ + + + + : 263 : & .AND.v2.LE.v1).AND.v4.LE.AC%err).OR.err<AC%toosmall) THEN
+ + - + ]
4837 : : ! converged result
4838 : 0 : success=.TRUE.
4839 [ # # ]: 0 : If(AC%writelots)&
4840 : : write(std_out,&
4841 : : & '("AndersonMix converged in ",i5," iterations with err = ",1p,1e15.7)')&
4842 : 0 : & i, err
4843 : : EXIT
4844 : : ENDIF
4845 : : ENDIF
4846 [ - + ]: 331 : If(AC%writelots)write(std_out,'("AndersonMixIter ",i7,2x,1p,2e20.12)') i,E,err
4847 [ - + ]: 331 : IF (.NOT.OK) THEN
4848 : 0 : CALL Anderson_ResetMix(AC)
4849 [ # # ]: 0 : IF (i>1) THEN
4850 [ # # ]: 0 : w=tmp
4851 : 0 : AC%NewMix=MAX(0.00001_dp,AC%NewMix/2)
4852 [ # # ]: 0 : IF (AC%NewMix<=0.00001_dp) THEN
4853 : 0 : write(std_out,*) 'Sorry -- this is not working '
4854 : 0 : STOP
4855 : : ENDIF
4856 : : ENDIF
4857 : : ELSE
4858 : 331 : AC%NewMix=MIN(max(MaxMix,AC%NewMix),AC%NewMix*2)
4859 : : ENDIF
4860 [ + - - + : 662993 : tmp=w
- - + + ]
4861 : 331 : CALL Anderson_Mix(AC,w,residue)
4862 : : ENDDO
4863 [ - + ]: 23 : If (AC%CurIter.ge.AC%MaxIter) then
4864 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Anderson Mix reached MaxIter without success',AC%MaxIter
4865 : : Endif
4866 [ - + ]: 23 : LIBPAW_DEALLOCATE(residue)
4867 [ - + ]: 23 : LIBPAW_DEALLOCATE(tmp)
4868 : 23 : END SUBROUTINE DoAndersonMix
4869 : :
4870 : :
4871 : :
4872 : :
4873 : :
4874 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4875 : : ! 8. global_math
4876 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4877 : :
4878 : :
4879 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4880 : : !! subroutine shapebes(al,ql,ll,rc)
4881 : : !! Find al and ql parameters for a "Bessel" shape function:
4882 : : !! Shape(r)=al1.jl(ql1.r)+al2.jl(ql2.r)
4883 : : !! such as Shape(r) and 2 derivatives are zero at r=rc
4884 : : !! Intg_0_rc[Shape(r).r^(l+2).dr]=1
4885 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4886 : 0 : SUBROUTINE shapebes(al,ql,ll,rc)
4887 : : INTEGER,INTENT(IN) :: ll
4888 : : REAL(dp),INTENT(IN) :: rc
4889 : : REAL(dp),INTENT(OUT) :: al(2),ql(2)
4890 : : INTEGER :: i
4891 : : REAL(dp) :: alpha,beta,det,qr,jbes,jbesp,jbespp,amat(2,2),bb(2)
4892 : 0 : alpha=1.D0;beta=0.D0
4893 : 0 : CALL solvbes(ql,alpha,beta,ll,2)
4894 [ # # ]: 0 : ql(1:2)=ql(1:2)/rc
4895 [ # # ]: 0 : DO i=1,2
4896 : 0 : qr=ql(i)*rc
4897 : 0 : CALL jbessel(jbes,jbesp,jbespp,ll,1,qr)
4898 : 0 : amat(1,i)=jbesp*ql(i)
4899 : 0 : CALL jbessel(jbes,jbesp,jbespp,ll+1,0,qr)
4900 : 0 : amat(2,i)=jbes*rc**(ll+2)/ql(i) ! Intg_0_rc[jl(qr).r^(l+2).dr]
4901 : : ENDDO
4902 : 0 : bb(1)=0._dp;bb(2)=1._dp
4903 : 0 : det=amat(1,1)*amat(2,2)-amat(1,2)*amat(2,1)
4904 : 0 : al(1)=(amat(2,2)*bb(1)-amat(1,2)*bb(2))/det
4905 : 0 : al(2)=(amat(1,1)*bb(2)-amat(2,1)*bb(1))/det
4906 : 0 : END SUBROUTINE shapebes
4907 : :
4908 : :
4909 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4910 : : !! ddexp
4911 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4912 : 827568 : FUNCTION ddexp(arg)
4913 : : real(dp) :: arg,ddexp
4914 [ - + ]: 827568 : IF (arg>maxexparg) THEN
4915 : 0 : ddexp=maxexp
4916 [ + + ]: 827568 : ELSE IF (arg<minexparg) THEN
4917 : 15766 : ddexp=minexp
4918 : : ELSE
4919 : 811802 : ddexp=EXP(arg)
4920 : : ENDIF
4921 : : RETURN
4922 : : END FUNCTION ddexp
4923 : :
4924 : :
4925 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4926 : : !! ddlog
4927 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4928 : 960271 : FUNCTION ddlog(arg)
4929 : : real(dp) :: arg,ddlog
4930 [ - + ]: 960271 : IF (arg>maxlogarg) THEN
4931 : 0 : ddlog=maxlog
4932 [ + + ]: 960271 : ELSE IF (arg<minlogarg) THEN
4933 : 20700 : ddlog=minlog
4934 : : ELSE
4935 : 939571 : ddlog=LOG(arg)
4936 : : ENDIF
4937 : : RETURN
4938 : : END FUNCTION ddlog
4939 : :
4940 : :
4941 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4942 : : !! ranx
4943 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4944 : 28429 : FUNCTION ranx()
4945 : : real(dp) :: ranx
4946 : : INTEGER, PARAMETER :: konst=125
4947 : : INTEGER :: m=100001
4948 : 28429 : m=m*konst
4949 : 28429 : m=m-2796203*(m/2796203)
4950 : 12734 : ranx=m/2796203._dp
4951 : : RETURN
4952 : : END FUNCTION ranx
4953 : :
4954 : :
4955 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4956 : : !! factorial
4957 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4958 : 198041 : FUNCTION factorial(n)
4959 : : real(dp) :: factorial
4960 : : INTEGER, INTENT(IN) :: n
4961 : : INTEGER :: i
4962 : 198041 : factorial=one
4963 : 198041 : IF (n.LT.2) RETURN
4964 [ + + + + : 486077 : DO i=2,n
+ + ]
4965 : 486077 : factorial=factorial*i
4966 : : ENDDO
4967 : : END FUNCTION factorial
4968 : :
4969 : :
4970 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4971 : : !! FUNCTION hwfn(z,np,l,r)
4972 : : !! function to calculate the radial H wfn for nuclear charge z
4973 : : !! (note in this version z is real and need not be integral)
4974 : : !! principal qn np
4975 : : !! orbital qn l
4976 : : !! r*(radial H wfn) is returned
4977 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4978 : 66017 : FUNCTION hwfn(z,np,l,r)
4979 : : real(dp) :: hwfn
4980 : : real(dp), INTENT(IN) :: z,r
4981 : : INTEGER, INTENT(IN) :: np,l
4982 : : INTEGER :: node,k
4983 : : real(dp) :: scale_,rho,pref,term,sum_
4984 : 66017 : node=np-l-1
4985 : 66017 : scale_=2._dp*z/np
4986 : 66017 : rho=scale_*r
4987 [ + + + + ]: 126031 : pref=scale_*SQRT(scale_*factorial(np+l)/(2*np*factorial(node)))
4988 [ + + + + ]: 66017 : if(rho==zero.and.l==0) then
4989 : : term=one/factorial(2*l+1)
4990 : : else
4991 [ + + ]: 110014 : term=(rho**l)/factorial(2*l+1)
4992 : : endif
4993 : 66017 : sum_=term
4994 [ + + ]: 66017 : IF (node.GT.0) THEN
4995 [ + + ]: 136025 : DO k=1,node
4996 : 84015 : term=-term*(node-k+1)*rho/(k*(2*l+1+k))
4997 : 136025 : sum_=sum_+term
4998 : : ENDDO
4999 : : ENDIF
5000 : 66017 : hwfn=r*pref*ddexp(-0.5_dp*rho)*sum_
5001 : 66017 : END FUNCTION hwfn
5002 : :
5003 : :
5004 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5005 : : !! subroutine dirachwfn(np,kappa,z,r,eig,g,f)
5006 : : !! Subroutine to calculate eigenenergy and radial wavefunctions*r
5007 : : !! for bound state solutions to the Hydrogenic Dirac equation
5008 : : !! for nuclear charge z. Energy in Rydberg atomic units
5009 : : !! np is principal quantum number --
5010 : : !! np=abs(kappa), abs(kappa)+1, abs(kappa)+2 ..
5011 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5012 : 40010 : subroutine dirachwfn(np,kappa,z,r,eig,g,f)
5013 : : INTEGER, INTENT(IN) :: np, kappa
5014 : : real(dp), INTENT(IN) :: z,r
5015 : : real(dp), INTENT(INOUT) :: eig,g,f
5016 : : INTEGER :: ak,nr
5017 : : real(dp) :: norm,s,rho,ne, term1, term2, term0,x
5018 : 40010 : ak=abs(kappa)
5019 : 40010 : nr=np-ak
5020 : 40010 : s=sqrt(ak**2-(z**2)*(fsalpha2))
5021 : 40010 : ne=sqrt(np**2-2*nr*(ak-s))
5022 : 40010 : rho=2*z*r/ne
5023 : 40010 : norm=gammafunc(2*s+nr+1._dp)/(gammafunc(nr+1._dp)*4*ne*(ne-kappa))
5024 : 40010 : norm=sqrt(norm*2*z/ne)/gammafunc(2*s+1._dp)
5025 : 40010 : term1=0._dp
5026 [ + + ]: 40010 : if(nr>0) term1=nr*kummer(-nr+1,2*s+1._dp,rho)
5027 : 40010 : term2=(ne-kappa)*kummer(-nr,2*s+1._dp,rho)
5028 : 40010 : term0=norm*ddexp(-0.5_dp*rho)*(rho**s)
5029 : 40010 : eig=1._dp + ((z**2)*(fsalpha2))/(np - ak +s)**2
5030 : 40010 : eig=2*ifsalpha2*(1._dp/sqrt(eig) - 1._dp)
5031 : 40010 : x=0.5_dp*fsalpha2*eig
5032 : 40010 : g=sqrt(2._dp+x)*term0*(term2-term1)
5033 : 40010 : f=-sqrt(-x)*term0*(term2+term1)
5034 : 40010 : end subroutine dirachwfn
5035 : :
5036 : :
5037 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5038 : : ! subroutine filter(n,func,small)
5039 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5040 [ - + ]: 13881 : SUBROUTINE filter(n,func,small)
5041 : : INTEGER, INTENT(IN) :: n
5042 : : real(dp), INTENT(INOUT) :: func(:)
5043 : : real(dp), INTENT(IN) :: small
5044 : : INTEGER :: i
5045 [ + + ]: 27789762 : DO i=1,n
5046 [ + + ]: 27789762 : IF (ABS(func(i)).LT.small) func(i)=0._dp
5047 : : ENDDO
5048 : 13881 : END SUBROUTINE filter
5049 : :
5050 : :
5051 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5052 : : ! subroutine conthomas(n,o,d,sol)
5053 : : ! use Thomas's algorithm for inverting matrix
5054 : : ! Dale U. von Rosenberg, "Methods for the Numerical Solution of
5055 : : ! Partial Differential Equations,
5056 : : ! Am. Elsevier Pub., 1969, pg. 113
5057 : : ! On input, sol contains the RHS of the equation
5058 : : ! On ouput, sol contains the solution of the equation
5059 : : ! Equation: o*sol(i-1)+d*sol(i)+o*sol(i+1) = RHS(i)
5060 : : ! sol(1)==sol(n+1)==0
5061 : : ! simplified version for constant tridiagonal terms --
5062 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5063 [ - + ]: 25 : SUBROUTINE conthomas(n,o,d,sol)
5064 : : INTEGER, INTENT(IN) :: n
5065 : : real(dp), INTENT(IN) :: o,d
5066 : : real(dp), INTENT(INOUT) :: sol(:)
5067 : 25 : real(dp), ALLOCATABLE :: a(:),b(:)
5068 : : real(dp) :: ss2
5069 : : INTEGER :: i
5070 [ - + + - : 75 : LIBPAW_ALLOCATE(a,(n))
+ - + - -
+ - + ]
5071 [ - + + - : 50 : LIBPAW_ALLOCATE(b,(n))
- + - + ]
5072 : 25 : a(2)=d
5073 : 25 : ss2=o*o
5074 [ + + ]: 50000 : DO i=3,n
5075 : 50000 : a(i)=d-ss2/a(i-1)
5076 : : ENDDO
5077 : 25 : b(2)=sol(2)/d
5078 [ + + ]: 50000 : DO i=3,n
5079 : 50000 : b(i)=(sol(i)-o*b(i-1))/a(i)
5080 : : ENDDO
5081 : 25 : sol(n)=b(n)
5082 [ + + ]: 50000 : DO i=n-1,2,-1
5083 : 50000 : sol(i)=b(i)-o*sol(i+1)/a(i)
5084 : : ENDDO
5085 : 25 : sol(1)=0
5086 : 25 : LIBPAW_DEALLOCATE(a)
5087 : 25 : LIBPAW_DEALLOCATE(b)
5088 : 25 : END SUBROUTINE conthomas
5089 : :
5090 : :
5091 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5092 : : ! function kummer(n,b,z)
5093 : : ! function to return confluent hypergeometric function (Kummer)
5094 : : ! as defined in Handbook of mathematical functions pg. 504
5095 : : ! assumes n=0, -1, -2, .. for polymomials of order 0, 1, 2, etc.
5096 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5097 : 74017 : FUNCTION kummer(n,b,z)
5098 : : real(dp) :: kummer
5099 : : INTEGER, INTENT(IN) :: n
5100 : : real(dp), INTENT(IN) :: b,z
5101 : : INTEGER :: i,k,j,nn
5102 : : real(dp) :: num,den,fac,bb
5103 [ - + ]: 74017 : if (n>0) then
5104 : 0 : LIBPAW_ERROR('Error in kummer function -- n>0')
5105 : : endif
5106 : 74017 : kummer=1._dp
5107 [ + + ]: 74017 : if (n==0) return
5108 : 54010 : j=-n
5109 : 54010 : k=1
5110 : 54010 : nn=n
5111 : 54010 : bb=b
5112 : 54010 : num=n
5113 : 54010 : den=b
5114 : 54010 : fac=z*nn/(bb*k)
5115 : 54010 : kummer=kummer+fac
5116 [ + + ]: 54010 : if (j>1) then
5117 [ + + ]: 62009 : do i=1,j-1
5118 : 36005 : nn=nn+1
5119 : 36005 : bb=bb+1
5120 : 36005 : k=k+1
5121 : 36005 : fac=fac*z*nn/(bb*k)
5122 : 62009 : kummer=kummer+fac
5123 : : enddo
5124 : : endif
5125 : : END FUNCTION kummer
5126 : :
5127 : :
5128 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5129 : : ! Gamma function function obtained from netlib.org
5130 : : ! This routine calculates the GAMMA function for a real argument X
5131 : : ! Computation is based on an algorithm outlined in reference 1
5132 : : ! The program uses rational functions that approximate the GAMM
5133 : : ! function to at least 20 significant decimal digits. Coefficient
5134 : : ! for the approximation over the interval (1,2) are unpublished
5135 : : ! Those for the approximation for X .GE. 12 are from reference 2
5136 : : ! The accuracy achieved depends on the arithmetic system, th
5137 : : ! compiler, the intrinsic functions, and proper selection of th
5138 : : ! machine-dependent constants
5139 : : !
5140 : : !******************************************************************
5141 : : !
5142 : : ! Explanation of machine-dependent constant
5143 : : !
5144 : : ! beta - radix for the floating-point representatio
5145 : : ! maxexp - the smallest positive power of beta that overflow
5146 : : ! XBIG - the largest argument for which GAMMA(X) is representabl
5147 : : ! in the machine, i.e., the solution to the equatio
5148 : : ! GAMMA(XBIG) = beta**maxex
5149 : : ! XINF - the largest machine representable floating-point number
5150 : : ! approximately beta**maxex
5151 : : ! EPS - the smallest positive floating-point number such tha
5152 : : ! 1.0+EPS .GT. 1.
5153 : : ! XMININ - the smallest positive floating-point number such tha
5154 : : ! 1/XMININ is machine representabl
5155 : : !
5156 : : ! Approximate values for some important machines are
5157 : : !
5158 : : ! beta maxexp XBI
5159 : : !
5160 : : ! CRAY-1 (S.P.) 2 8191 966.96
5161 : : ! Cyber 180/85
5162 : : ! under NOS (S.P.) 2 1070 177.80
5163 : : ! IEEE (IBM/XT
5164 : : ! SUN, etc.) (S.P.) 2 128 35.04
5165 : : ! IEEE (IBM/XT
5166 : : ! SUN, etc.) (D.P.) 2 1024 171.62
5167 : : ! IBM 3033 (D.P.) 16 63 57.57
5168 : : ! VAX D-Format (D.P.) 2 127 34.84
5169 : : ! VAX G-Format (D.P.) 2 1023 171.48
5170 : : !
5171 : : ! XINF EPS XMINI
5172 : : !
5173 : : ! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-246
5174 : : ! Cyber 180/85
5175 : : ! under NOS (S.P.) 1.26E+322 3.55E-15 3.14E-29
5176 : : ! IEEE (IBM/XT
5177 : : ! SUN, etc.) (S.P.) 3.40E+38 1.19E-7 1.18E-3
5178 : : ! IEEE (IBM/XT
5179 : : ! SUN, etc.) (D.P.) 1.79D+308 2.22D-16 2.23D-30
5180 : : ! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-7
5181 : : ! VAX D-Format (D.P.) 1.70D+38 1.39D-17 5.88D-3
5182 : : ! VAX G-Format (D.P.) 8.98D+307 1.11D-16 1.12D-30
5183 : : !
5184 : : !******************************************************************
5185 : : ! Error return
5186 : : !
5187 : : ! The program returns the value XINF for singularities o
5188 : : ! when overflow would occur. The computation is believe
5189 : : ! to be free of underflow and overflow
5190 : : !
5191 : : !
5192 : : ! Intrinsic functions required are
5193 : : !
5194 : : ! INT, DBLE, EXP, LOG, REAL, SI
5195 : : !
5196 : : !
5197 : : ! References: "An Overview of Software Development for Specia
5198 : : ! Functions", W. J. Cody, Lecture Notes in Mathematics
5199 : : ! 506, Numerical Analysis Dundee, 1975, G. A. Watso
5200 : : ! (ed.), Springer Verlag, Berlin, 1976
5201 : : !
5202 : : ! Computer Approximations, Hart, Et. Al., Wiley an
5203 : : ! sons, New York, 1968
5204 : : !
5205 : : ! Latest modification: October 12, 1989
5206 : : !
5207 : : ! Authors: W. J. Cody and L. StoltZ
5208 : : ! Applied Mathematics DivisioN
5209 : : ! Argonne National LaboratorY
5210 : : ! Argonne, IL 60439
5211 : : !
5212 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5213 : 120030 : FUNCTION GAMMAFUNC(X)
5214 : : real(dp) :: GAMMAFUNC,X
5215 : : INTEGER:: I,N
5216 : : real(dp) :: &
5217 : : & CONV,EPS,FACT,HALF,ONE,RES,SQRTPI,SUM,TWELVE, &
5218 : : & TWO,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
5219 : : real(dp) :: C(7),P(8),Q(8)
5220 : : LOGICAL :: PARITY
5221 : : !---------------------------------------------------------------------
5222 : : ! Mathematical constants
5223 : : !---------------------------------------------------------------------
5224 : : DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/, &
5225 : : & SQRTPI/0.9189385332046727417803297D0/
5226 : : !!!!& PI/3.1415926535897932384626434D0/ (already defined)
5227 : : !---------------------------------------------------------------------
5228 : : ! Machine dependent parameter
5229 : : !---------------------------------------------------------------------
5230 : : DATA XBIG,XMININ,EPS,XINF/171.624D0,2.23D-308,2.22D-16,1.79D308/
5231 : : !---------------------------------------------------------------------
5232 : : ! Numerator and denominator coefficients for rational minima
5233 : : ! approximation over (1,2)
5234 : : !---------------------------------------------------------------------
5235 : : DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1, &
5236 : : & -3.79804256470945635097577D+2,6.29331155312818442661052D+2, &
5237 : : & 8.66966202790413211295064D+2,-3.14512729688483675254357D+4, &
5238 : : & -3.61444134186911729807069D+4,6.64561438202405440627855D+4/
5239 : : DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2, &
5240 : : & -1.01515636749021914166146D+3,-3.10777167157231109440444D+3, &
5241 : : & 2.25381184209801510330112D+4,4.75584627752788110767815D+3, &
5242 : : & -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/
5243 : : !---------------------------------------------------------------------
5244 : : ! Coefficients for minimax approximation over (12, INF)
5245 : : !---------------------------------------------------------------------
5246 : : DATA C/-1.910444077728D-03,8.4171387781295D-04 , &
5247 : : & -5.952379913043012D-04,7.93650793500350248D-04 , &
5248 : : & -2.777777777777681622553D-03,8.333333333333333331554247D-02 , &
5249 : : & 5.7083835261D-03/
5250 : : !---------------------------------------------------------------------
5251 : : ! Statement functions for conversion between integer and floa
5252 : : !---------------------------------------------------------------------
5253 : : CONV(I) = DBLE(I)
5254 : 120030 : PARITY = .FALSE.
5255 : 120030 : FACT = ONE
5256 : 120030 : N = 0
5257 : 120030 : Y = X
5258 [ - + ]: 120030 : IF (Y .LE. ZERO) THEN
5259 : : !---------------------------------------------------------------------
5260 : : ! Argument is negative
5261 : : !---------------------------------------------------------------------
5262 : 0 : Y = -X
5263 : 0 : Y1 = AINT(Y)
5264 : 0 : RES = Y - Y1
5265 [ # # ]: 0 : IF (RES .NE. ZERO) THEN
5266 [ # # ]: 0 : IF (Y1 .NE. AINT(Y1*HALF)*TWO) PARITY = .TRUE.
5267 : 0 : FACT = -PI / SIN(PI*RES)
5268 : 0 : Y = Y + ONE
5269 : : ELSE
5270 : 0 : RES = XINF
5271 : 0 : GO TO 900
5272 : : END IF
5273 : : END IF
5274 : : !---------------------------------------------------------------------
5275 : : ! Argument is positiv
5276 : : !---------------------------------------------------------------------
5277 [ - + ]: 120030 : IF (Y .LT. EPS) THEN
5278 : : !---------------------------------------------------------------------
5279 : : ! Argument .LT. EPS
5280 : : !---------------------------------------------------------------------
5281 [ # # ]: 0 : IF (Y .GE. XMININ) THEN
5282 : 0 : RES = ONE / Y
5283 : : ELSE
5284 : 0 : RES = XINF
5285 : 0 : GO TO 900
5286 : : END IF
5287 [ + - ]: 120030 : ELSE IF (Y .LT. TWELVE) THEN
5288 : 120030 : Y1 = Y
5289 [ - + ]: 120030 : IF (Y .LT. ONE) THEN
5290 : : !---------------------------------------------------------------------
5291 : : ! 0.0 .LT. argument .LT. 1.
5292 : : !---------------------------------------------------------------------
5293 : 0 : Z = Y
5294 : 0 : Y = Y + ONE
5295 : : ELSE
5296 : : !---------------------------------------------------------------------
5297 : : ! 1.0 .LT. argument .LT. 12.0, reduce argument if necessar
5298 : : !---------------------------------------------------------------------
5299 : 120030 : N = INT(Y) - 1
5300 : 120030 : Y = Y - CONV(N)
5301 : 120030 : Z = Y - ONE
5302 : : END IF
5303 : : !---------------------------------------------------------------------
5304 : : ! Evaluate approximation for 1.0 .LT. argument .LT. 2.
5305 : : !---------------------------------------------------------------------
5306 : 120030 : XNUM = ZERO
5307 : 120030 : XDEN = ONE
5308 [ + + ]: 1080270 : DO 260 I = 1, 8
5309 : 960240 : XNUM = (XNUM + P(I)) * Z
5310 : 960240 : XDEN = XDEN * Z + Q(I)
5311 : 120030 : 260 CONTINUE
5312 : 120030 : RES = XNUM / XDEN + ONE
5313 [ - + ]: 120030 : IF (Y1 .LT. Y) THEN
5314 : : !---------------------------------------------------------------------
5315 : : ! Adjust result for case 0.0 .LT. argument .LT. 1.
5316 : : !---------------------------------------------------------------------
5317 : 0 : RES = RES / Y1
5318 [ + + ]: 120030 : ELSE IF (Y1 .GT. Y) THEN
5319 : : !---------------------------------------------------------------------
5320 : : ! Adjust result for case 2.0 .LT. argument .LT. 12.
5321 : : !---------------------------------------------------------------------
5322 [ + + ]: 446089 : DO 290 I = 1, N
5323 : 332062 : RES = RES * Y
5324 : 332062 : Y = Y + ONE
5325 : 114027 : 290 CONTINUE
5326 : : END IF
5327 : : ELSE
5328 : : !---------------------------------------------------------------------
5329 : : ! Evaluate for argument .GE. 12.0
5330 : : !---------------------------------------------------------------------
5331 [ # # ]: 0 : IF (Y .LE. XBIG) THEN
5332 : 0 : YSQ = Y * Y
5333 : 0 : SUM = C(7)
5334 [ # # ]: 0 : DO 350 I = 1,6
5335 : 0 : SUM = SUM / YSQ + C(I)
5336 : 0 : 350 CONTINUE
5337 : 0 : SUM = SUM/Y - Y + SQRTPI
5338 : 0 : SUM = SUM + (Y-HALF)*LOG(Y)
5339 : 0 : RES = EXP(SUM)
5340 : : ELSE
5341 : 0 : RES = XINF
5342 : 0 : GO TO 900
5343 : : END IF
5344 : : END IF
5345 : : !---------------------------------------------------------------------
5346 : : ! Final adjustments and retur
5347 : : !---------------------------------------------------------------------
5348 [ - + ]: 120030 : IF (PARITY) RES = -RES
5349 [ - + ]: 120030 : IF (FACT .NE. ONE) RES = FACT / RES
5350 : 120030 : 900 GAMMAFUNC = RES
5351 : : RETURN
5352 : : ! ---------- Last line of GAMMA ---------
5353 : : END FUNCTION GAMMAFUNC
5354 : :
5355 : :
5356 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5357 : : !! SUBROUTINE shift4(v1,v2,v3,v4,NEW)
5358 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5359 : 331 : SUBROUTINE shift4(v1,v2,v3,v4,NEW)
5360 : : real(dp), INTENT(IN) :: NEW
5361 : : real(dp), INTENT(INOUT) :: v1,v2,v3,v4
5362 : 331 : v1=v2
5363 : 331 : v2=v3
5364 : 331 : v3=v4
5365 [ + + ]: 331 : v4=NEW
5366 : : RETURN
5367 : : END SUBROUTINE shift4
5368 : :
5369 : :
5370 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5371 : : ! subroutine jbessel(bes,besp,bespp,ll,order,xx)
5372 : : ! Spherical bessel function and derivatives
5373 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5374 : 0 : SUBROUTINE jbessel(bes,besp,bespp,ll,order,xx)
5375 : : INTEGER,INTENT(IN) :: ll,order
5376 : : real(dp),INTENT(IN) :: xx
5377 : : real(dp),INTENT(OUT) :: bes,besp,bespp
5378 : : INTEGER,PARAMETER :: imax=40
5379 : : real(dp),PARAMETER :: prec=tol15
5380 : : INTEGER :: ii,il
5381 : : real(dp) :: besp1,fact,factp,factpp,jn,jnp,jnpp,jr,xx2,xxinv
5382 [ # # ]: 0 : IF (order>2) STOP "Wrong order in jbessel !"
5383 [ # # ]: 0 : IF (ABS(xx)<prec) THEN
5384 [ # # ]: 0 : bes=0._dp;IF (ll==0) bes=1._dp
5385 [ # # ]: 0 : IF (order>=1) THEN
5386 [ # # ]: 0 : besp=0._dp;IF (ll==1) besp=1._dp/3._dp
5387 : : ENDIF
5388 [ # # ]: 0 : IF (order==2) THEN
5389 : 0 : bespp=0._dp
5390 [ # # ]: 0 : IF (ll==0) bespp=-1._dp/3._dp
5391 [ # # ]: 0 : IF (ll==2) bespp=2._dp/15._dp
5392 : : ENDIF
5393 : 0 : RETURN
5394 : : ENDIF
5395 : 0 : xxinv=1._dp/xx
5396 [ # # ]: 0 : IF (xx<1._dp) THEN
5397 : 0 : xx2=0.5_dp*xx*xx
5398 [ # # ]: 0 : fact=1.D0;DO il=1,ll;fact=fact*xx/DBLE(2*il+1);ENDDO
5399 : : jn=1.D0;jr=1.D0;ii=0
5400 [ # # # # ]: 0 : DO WHILE(ABS(jr)>=prec.AND.ii<imax)
5401 : 0 : ii=ii+1;jr=-jr*xx2/DBLE(ii*(2*(ll+ii)+1))
5402 : 0 : jn=jn+jr
5403 : : ENDDO
5404 : 0 : bes=jn*fact
5405 [ # # ]: 0 : IF (ABS(jr)>prec) STOP 'Error: Bessel function did not converge !'
5406 [ # # ]: 0 : IF (order>=1) THEN
5407 : 0 : factp=fact*xx/DBLE(2*ll+3)
5408 : 0 : jnp=1.D0;jr=1.D0;ii=0
5409 [ # # # # ]: 0 : DO WHILE(ABS(jr)>=prec.AND.ii<imax)
5410 : 0 : ii=ii+1;jr=-jr*xx2/DBLE(ii*(2*(ll+ii)+3))
5411 : 0 : jnp=jnp+jr
5412 : : ENDDO
5413 : 0 : besp=-jnp*factp+jn*fact*xxinv*DBLE(ll)
5414 [ # # ]: 0 : IF (ABS(jr)>prec) STOP 'Error: 1st der. of Bessel function did not converge !'
5415 : : ENDIF
5416 [ # # ]: 0 : IF (order==2) THEN
5417 : 0 : factpp=factp*xx/DBLE(2*ll+5)
5418 : 0 : jnpp=1.D0;jr=1.D0;ii=0
5419 [ # # # # ]: 0 : DO WHILE(ABS(jr)>=prec.AND.ii<imax)
5420 : 0 : ii=ii+1;jr=-jr*xx2/DBLE(ii*(2*(ll+ii)+5))
5421 : 0 : jnpp=jnpp+jr
5422 : : ENDDO
5423 : 0 : besp1=-jnpp*factpp+jnp*factp*xxinv*DBLE(ll+1)
5424 [ # # ]: 0 : IF (ABS(jr)>prec) STOP 'Error: 2nd der. of Bessel function did not converge !'
5425 : : ENDIF
5426 : : ELSE
5427 : 0 : jn =SIN(xx)*xxinv
5428 : 0 : jnp=(-COS(xx)+jn)*xxinv
5429 [ # # ]: 0 : DO il=2,ll+1
5430 : 0 : jr=-jn+DBLE(2*il-1)*jnp*xxinv
5431 : 0 : jn=jnp;jnp=jr
5432 : : ENDDO
5433 : 0 : bes=jn
5434 [ # # ]: 0 : IF (order>=1) besp =-jnp+jn *xxinv*DBLE(ll)
5435 [ # # ]: 0 : IF (order==2) besp1= jn -jnp*xxinv*DBLE(ll+2)
5436 : : ENDIF
5437 [ # # ]: 0 : IF (order==2) bespp=-besp1+besp*ll*xxinv-bes*ll*xxinv*xxinv
5438 : : END SUBROUTINE jbessel
5439 : :
5440 : :
5441 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5442 : : ! subroutine solvbes(root,alpha,l,nq)
5443 : : ! Find nq first roots of instrinsic equation:
5444 : : ! alpha.jl(Q) + beta.Q.djl/dr(Q) = 0
5445 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5446 : 0 : SUBROUTINE solvbes(root,alpha,beta,ll,nq)
5447 : : INTEGER,INTENT(IN) :: ll,nq
5448 : : real(dp),INTENT(IN) :: alpha,beta
5449 : : real(dp),INTENT(OUT) :: root(nq)
5450 : : real(dp),PARAMETER :: dh=1.D-1, tol=1.D-14
5451 : : INTEGER :: nroot
5452 : : real(dp) :: dum,y1,y2,jbes,jbesp,qq,qx,hh
5453 : 0 : qq=dh;nroot=0
5454 [ # # ]: 0 : DO WHILE (nroot<nq)
5455 : 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qq)
5456 : 0 : y1=alpha*jbes+beta*qq*jbesp
5457 : 0 : qq=qq+dh
5458 : 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qq)
5459 : 0 : y2=alpha*jbes+beta*qq*jbesp
5460 [ # # ]: 0 : DO WHILE (y1*y2>=0.D0)
5461 : 0 : qq=qq+dh
5462 : 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qq)
5463 : 0 : y2=alpha*jbes+beta*qq*jbesp
5464 : : ENDDO
5465 : 0 : hh=dh;qx=qq
5466 [ # # ]: 0 : DO WHILE (hh>tol)
5467 : 0 : hh=0.5D0*hh
5468 [ # # ]: 0 : IF (y1*y2<0) THEN
5469 : 0 : qx=qx-hh
5470 : : ELSE
5471 : 0 : qx=qx+hh
5472 : : ENDIF
5473 : 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qx)
5474 : 0 : y2=alpha*jbes+beta*qx*jbesp
5475 : : ENDDO
5476 : 0 : nroot=nroot+1
5477 : 0 : root(nroot)=qx
5478 : : ENDDO
5479 : 0 : END SUBROUTINE solvbes
5480 : :
5481 : :
5482 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5483 : : !! SUBROUTINE linsol(a,b,kk,la,ra,lb,det)
5484 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5485 : 3920 : SUBROUTINE linsol(a,b,kk,la,ra,lb,det)
5486 : : INTEGER, INTENT(IN) :: kk,la,ra,lb
5487 : : real(dp), INTENT(INOUT) :: a(la,ra),b(lb)
5488 : : real(dp), OPTIONAL, INTENT(OUT) :: det
5489 : : real(dp) :: d,s,r
5490 : : INTEGER :: kkm,i,j,k,l,ipo,n,kmo
5491 : 3920 : d = 1._dp
5492 [ - + ]: 3920 : if (kk>min(la,ra,lb)) then
5493 : 0 : LIBPAW_ERROR('Dimension error in linsol ')
5494 : : endif
5495 : 3920 : kkm=kk-1
5496 [ - + ]: 3920 : IF (kkm == 0) THEN
5497 : 0 : b(1)=b(1)/a(1,1)
5498 [ + - ]: 3920 : ELSE IF (kkm > 0) THEN
5499 [ + + ]: 23520 : DO i=1, kkm
5500 : : s = 0.0_dp
5501 : : l=i
5502 [ + + ]: 98000 : DO j=i,kk
5503 : 78400 : r=ABS(a(j,i))
5504 [ + + ]: 98000 : IF(r > s) THEN
5505 : 43120 : s=r
5506 : 43120 : l=j
5507 : : ENDIF
5508 : : ENDDO
5509 [ + + ]: 19600 : IF(l /= i) THEN
5510 [ + + ]: 86240 : DO j=i,kk
5511 : 70560 : s=a(i,j)
5512 : 70560 : a(i,j)=a(l,j)
5513 : 86240 : a(l,j)=s
5514 : : ENDDO
5515 : 15680 : s=b(i)
5516 : 15680 : b(i)=b(l)
5517 : 15680 : b(l)=s
5518 : 15680 : d = -d
5519 : : ENDIF
5520 [ + - ]: 23520 : IF (a(i,i) /= 0.0_dp) THEN
5521 : 19600 : ipo=i+1
5522 [ + + ]: 78400 : DO j=ipo,kk
5523 [ + + ]: 78400 : IF (a(j,i) /= 0.0_dp) THEN
5524 : 50960 : s=a(j,i)/a(i,i)
5525 : 50960 : a(j,i) = 0.0_dp
5526 [ + + ]: 227360 : DO k=ipo,kk
5527 : 227360 : a(j,k)=a(j,k)-a(i,k)*s
5528 : : ENDDO
5529 : 50960 : b(j)=b(j)-b(i)*s
5530 : : ENDIF
5531 : : ENDDO
5532 : : ENDIF
5533 : : ENDDO
5534 [ + + ]: 27440 : DO i=1,kk
5535 : 27440 : d=d*a(i,i)
5536 : : ENDDO
5537 : 3920 : kmo=kk-1
5538 : 3920 : b(kk)=b(kk)/a(kk,kk)
5539 [ + + ]: 23520 : DO i=1,kmo
5540 : 19600 : n=kk-i
5541 [ + + ]: 78400 : DO j=n,kmo
5542 : 78400 : b(n)=b(n)-a(n,j+1)*b(j+1)
5543 : : ENDDO
5544 : 23520 : b(n)=b(n)/a(n,n)
5545 : : ENDDO
5546 : : ENDIF
5547 : : !write(std_out,*) 'determinant from linsol ' , d
5548 [ - + - - ]: 3920 : IF(ABS(d).LT.tol10.and.has_to_print) then
5549 : 0 : WRITE(STD_OUT,*) '**warning from linsol --',&
5550 : 0 : & 'determinant too small --',d
5551 : : endif
5552 [ - + ]: 3920 : If (present(det)) det=d
5553 : 3920 : END SUBROUTINE linsol
5554 : :
5555 : :
5556 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5557 : : !! subroutine SolveAXeqB
5558 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5559 : : SUBROUTINE SolveAXeqB(n,A,B,conditionNo)
5560 : : ! General purpose AX=B solver for A, B real.
5561 : : ! On return, B stores X
5562 : : INTEGER, INTENT(IN) :: n
5563 : : REAL(dp), INTENT(IN) :: A(:,:)
5564 : : REAL(dp), INTENT(INOUT) :: B(:)
5565 : : REAL(dp), INTENT(IN), OPTIONAL :: conditionNo
5566 : : REAL(dp), ALLOCATABLE :: C(:,:),U(:,:),VT(:,:),X(:)
5567 : : REAL(dp), ALLOCATABLE :: WORK(:)
5568 : : REAL(dp), ALLOCATABLE :: S(:)
5569 : : REAL(dp), PARAMETER :: rtol=1.d-9
5570 : : INTEGER :: i,LWORK
5571 : : REAL(dp) :: xx,tol
5572 : : REAL(dp), PARAMETER :: one=1,zero=0
5573 : : IF (n == 1) THEN
5574 : : B(1)=B(1)/A(1,1)
5575 : : RETURN
5576 : : ENDIF
5577 : : LWORK=MAX(200,n*n)
5578 : : LIBPAW_ALLOCATE(C,(n,n))
5579 : : LIBPAW_ALLOCATE(X,(n))
5580 : : LIBPAW_ALLOCATE(U,(n,n))
5581 : : LIBPAW_ALLOCATE(VT,(n,n))
5582 : : LIBPAW_ALLOCATE(WORK,(LWORK))
5583 : : LIBPAW_ALLOCATE(S,(n))
5584 : : tol=rtol
5585 : : IF (PRESENT(conditionNo)) tol=1._dp/conditionNo
5586 : : C(1:n,1:n)=A(1:n,1:n)
5587 : : CALL DGESVD('A','A',n,n,C,n,S,U,n,VT,n,WORK,LWORK,i)
5588 : : tol=tol*S(1)
5589 : : X=0
5590 : : DO i=1,n
5591 : : if(has_to_print) write(std_out,*) 'Solver, tol ',i,S(i),tol
5592 : : IF (S(i)>tol) THEN
5593 : : xx=DOT_PRODUCT(U(1:n,i),B(1:n))/S(i)
5594 : : X(1:n)=X(1:n)+xx*(VT(i,1:n))
5595 : : ENDIF
5596 : : ENDDO
5597 : : B=X
5598 : : LIBPAW_DEALLOCATE(C)
5599 : : LIBPAW_DEALLOCATE(X)
5600 : : LIBPAW_DEALLOCATE(U)
5601 : : LIBPAW_DEALLOCATE(VT)
5602 : : LIBPAW_DEALLOCATE(WORK)
5603 : : LIBPAW_DEALLOCATE(S)
5604 : : END SUBROUTINE SolveAXeqB
5605 : :
5606 : :
5607 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5608 : : !! subroutine SolveAXeqBM(n,A,B,many)
5609 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5610 [ - + - + ]: 18 : subroutine SolveAXeqBM(n,A,B,many)
5611 : : integer, intent(in) :: n,many
5612 : : real(dp), intent(in) :: A(:,:)
5613 : : real(dp), intent(inout) :: B(:)
5614 : : integer :: i,LWORK
5615 : : real(dp), parameter :: rtol=tol9
5616 : : real(dp), parameter :: one=1,zero=0
5617 : : real(dp) :: xx
5618 : 18 : real(dp), allocatable :: C(:,:),U(:,:),VT(:,:),X(:)
5619 : 18 : real(dp), allocatable :: WORK(:)
5620 : 18 : real(dp), allocatable :: S(:)
5621 [ + - - + ]: 18 : if (many<1.or.many>n) then
5622 : 0 : LIBPAW_ERROR('Error in paw_SolveAXeqBM')
5623 : : endif
5624 [ - + ]: 18 : if (n == 1) then
5625 : 0 : B(1)=B(1)/A(1,1)
5626 : : return
5627 : : endif
5628 : 18 : LWORK=max(200,n*n)
5629 [ - + + - : 72 : LIBPAW_ALLOCATE(C,(n,n))
- + + - +
- + - - +
- + ]
5630 [ - + + - : 54 : LIBPAW_ALLOCATE(X,(n))
+ - + - -
+ - + ]
5631 [ - + + - : 54 : LIBPAW_ALLOCATE(U,(n,n))
- + + - -
+ - + ]
5632 [ - + + - : 54 : LIBPAW_ALLOCATE(VT,(n,n))
- + + - -
+ - + ]
5633 [ - + + - : 54 : LIBPAW_ALLOCATE(WORK,(LWORK))
+ - - + -
+ ]
5634 [ - + + - : 36 : LIBPAW_ALLOCATE(S,(n))
- + - + ]
5635 [ + + + + ]: 330 : C(1:n,1:n)=A(1:n,1:n)
5636 : 18 : call DGESVD('A','A',n,n,C,n,S,U,n,VT,n,WORK,LWORK,i)
5637 [ + + ]: 84 : X=0
5638 [ + + ]: 84 : do i=1,n
5639 [ + - ]: 84 : if (i<=many) then
5640 [ + + ]: 312 : xx=DOT_PRODUCT(U(1:n,i),B(1:n))/S(i)
5641 [ + + ]: 312 : X(1:n)=X(1:n)+xx*(VT(i,1:n))
5642 : : endif
5643 : : enddo
5644 [ + + ]: 84 : B=X
5645 [ - + ]: 18 : LIBPAW_DEALLOCATE(C)
5646 [ - + ]: 18 : LIBPAW_DEALLOCATE(X)
5647 [ - + ]: 18 : LIBPAW_DEALLOCATE(U)
5648 [ - + ]: 18 : LIBPAW_DEALLOCATE(VT)
5649 [ - + ]: 18 : LIBPAW_DEALLOCATE(WORK)
5650 [ - + ]: 18 : LIBPAW_DEALLOCATE(S)
5651 : : end subroutine SolveAXeqBM
5652 : :
5653 : :
5654 : :
5655 : :
5656 : :
5657 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5658 : : ! 9. Gridmod
5659 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5660 : :
5661 : :
5662 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5663 : : ! SUBROUTINE taufromwfn(otau,Grid,wfn,l,energy,rv)
5664 : : ! input radial wfn and output its kinetic energy density
5665 : : ! note that total wavefunction is wfn/r * Ylm
5666 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5667 [ - + - + ]: 3214 : SUBROUTINE taufromwfn(otau,Grid,wfn,l,energy,rPot)
5668 : : TYPE(GridInfo), INTENT(IN) :: Grid
5669 : : REAL(dp), INTENT(IN) :: wfn(:)
5670 : : REAL(dp), INTENT(IN), OPTIONAL :: rPot(:),energy
5671 : : INTEGER, INTENT(IN) :: l
5672 : : REAL(dp), INTENT(OUT) :: otau(:)
5673 : : LOGICAL,PARAMETER :: from_e=.false.
5674 : : INTEGER :: n
5675 : : REAL(dp) :: fac
5676 : 3214 : REAL(dp), allocatable:: pbr(:),dpdr(:),d2pdr(:)
5677 : 3214 : n=Grid%n
5678 : 3214 : fac=l*(l+1)
5679 : : !Note: Psi(r) = Yl.Wfn(r)/r
5680 : : ! Tau(r) given in Rydberg units
5681 : : !Note: there are several kinetic energy formulas
5682 : : ! differing by something*Laplacian(rho(r))
5683 : : IF (.not.from_e) THEN
5684 : : ! Standard tau formula:
5685 : : ! 4pir^2* Tau(r) = [r.d/dr(Wfn/r)]^2 + l(l+1) [Wfn/r]^2
5686 [ - + + - : 9642 : LIBPAW_ALLOCATE(pbr,(n))
+ - + - -
+ - + ]
5687 [ - + + - : 6428 : LIBPAW_ALLOCATE(dpdr,(n))
- + - + ]
5688 [ + + + + ]: 12868856 : dpdr=0._dp;pbr=0._dp
5689 [ + + ]: 6431214 : pbr(2:n)=wfn(2:n)/Grid%r(2:n)
5690 : 3214 : CALL derivative(Grid,pbr,dpdr,2,n)
5691 [ + + ]: 6431214 : otau(2:n)=(Grid%r(2:n)*dpdr(2:n))**2 + fac*pbr(2:n)**2
5692 [ + + ]: 3214 : CALL extrapolate(otau) ; if (l>0) otau(1)=0._dp
5693 [ - + ]: 3214 : LIBPAW_DEALLOCATE(pbr)
5694 [ - + ]: 3214 : LIBPAW_DEALLOCATE(dpdr)
5695 : : ELSEIF (from_e) THEN
5696 : : IF (.NOT.(PRESENT(energy).AND.PRESENT(rPot))) then
5697 : : STOP 'Error in taufromwfn: rPot and energy should be present!'
5698 : : END IF
5699 : : ! For testing purpose:
5700 : : ! Another formula for the kinetic energy density
5701 : : ! 4pir^2* Tau(r) = [Eigenvalue - Veff(r)]*Wfn^2
5702 : : IF (.TRUE.) THEN
5703 : : otau(2:n)=(energy-rPot(2:n)/Grid%r(2:n))*wfn(2:n)**2
5704 : : CALL extrapolate(otau) ; if (l>0) otau(1)=0._dp
5705 : : ! Another one:
5706 : : ! From energy + correction
5707 : : ELSE
5708 : : LIBPAW_ALLOCATE(pbr,(n))
5709 : : LIBPAW_ALLOCATE(dpdr,(n))
5710 : : LIBPAW_ALLOCATE(d2pdr,(n))
5711 : : pbr(2:n)=wfn(2:n)/Grid%r(2:n)
5712 : : CALL derivative(Grid,pbr,dpdr,2,n)
5713 : : otau(2:n)=dpdr(2:n)**2 *Grid%r(2:n)**2
5714 : : d2pdr(2:n)=pbr(2:n)**2
5715 : : call derivative(Grid,d2pdr,dpdr,2,n)
5716 : : call derivative(Grid,dpdr,d2pdr,2,n)
5717 : : d2pdr(2:n)=d2pdr(2:n)+2.*dpdr(2:n)/Grid%r(2:n)
5718 : : otau(2:n)=0.5_dp*d2pdr(2:n)*Grid%r(2:n)**2 &
5719 : : & +(energy-rPot(2:n)/Grid%r(2:n))*wfn(2:n)**2
5720 : : otau(2:n)=otau(2:n) + fac*pbr(2:n)**2
5721 : : CALL extrapolate(otau) ; if (l>0) otau(1)=0._dp
5722 : : LIBPAW_DEALLOCATE(pbr)
5723 : : LIBPAW_DEALLOCATE(dpdr)
5724 : : LIBPAW_DEALLOCATE(d2pdr)
5725 : : ENDIF
5726 : : ENDIF
5727 : 3214 : call filter(n,otau,machine_zero)
5728 : 3214 : END SUBROUTINE taufromwfn
5729 : :
5730 : :
5731 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5732 : : !! deltakinetic_ij(Grid,wfn1,wfn2,twfn1,twfn2,l,ekin,last)
5733 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5734 [ - + - + : 36 : SUBROUTINE deltakinetic_ij(Grid,wfn1,wfn2,twfn1,twfn2,l,ekin,last)
- + - + ]
5735 : : TYPE (GridInfo), INTENT(IN) :: Grid
5736 : : real(dp), INTENT(IN) :: wfn1(:),wfn2(:),twfn1(:),twfn2(:)
5737 : : INTEGER, INTENT(IN) :: l
5738 : : real(dp), INTENT(OUT) :: ekin
5739 : : INTEGER, INTENT(IN), OPTIONAL :: last
5740 : 36 : real(dp), ALLOCATABLE :: dfdr1(:),dfdr2(:),arg1(:),arg2(:)
5741 : 36 : real(dp), ALLOCATABLE :: tdfdr1(:),tdfdr2(:),targ1(:),targ2(:)
5742 : : INTEGER :: i,n
5743 : 36 : n=Grid%n
5744 [ + - ]: 36 : if (present(last)) n=last
5745 [ - + + - : 108 : LIBPAW_ALLOCATE(dfdr1,(n))
+ - + - -
+ - + ]
5746 [ - + + - : 72 : LIBPAW_ALLOCATE(arg1,(n))
- + - + ]
5747 [ - + + - : 72 : LIBPAW_ALLOCATE(dfdr2,(n))
- + - + ]
5748 [ - + + - : 72 : LIBPAW_ALLOCATE(arg2,(n))
- + - + ]
5749 [ - + + - : 72 : LIBPAW_ALLOCATE(tdfdr1,(n))
- + - + ]
5750 [ - + + - : 72 : LIBPAW_ALLOCATE(targ1,(n))
- + - + ]
5751 [ - + + - : 72 : LIBPAW_ALLOCATE(tdfdr2,(n))
- + - + ]
5752 [ - + + - : 72 : LIBPAW_ALLOCATE(targ2,(n))
- + - + ]
5753 : 36 : CALL derivative(Grid,wfn1,dfdr1,1,n)
5754 : 36 : CALL derivative(Grid,wfn2,dfdr2,1,n)
5755 : 36 : CALL derivative(Grid,twfn1,tdfdr1,1,n)
5756 : 36 : CALL derivative(Grid,twfn2,tdfdr2,1,n)
5757 [ + + + + : 202032 : arg1=0; arg2=0; targ1=0; targ2=0
+ + + + ]
5758 [ + + ]: 50472 : DO i=2,n
5759 : 50436 : arg1(i)=wfn1(i)/Grid%r(i)
5760 : 50436 : arg2(i)=wfn2(i)/Grid%r(i)
5761 : 50436 : targ1(i)=twfn1(i)/Grid%r(i)
5762 : 50472 : targ2(i)=twfn2(i)/Grid%r(i)
5763 : : ENDDO
5764 [ + + ]: 50508 : DO i=1,n
5765 : : arg1(i)=(dfdr1(i)*dfdr2(i)-tdfdr1(i)*tdfdr2(i))&
5766 : 50508 : & +(l*(l+1))*(arg1(i)*arg2(i)-targ1(i)*targ2(i))
5767 : : ENDDO
5768 : 36 : ekin=integrator(Grid,arg1,1,n)
5769 [ - + ]: 36 : LIBPAW_DEALLOCATE(dfdr1)
5770 [ - + ]: 36 : LIBPAW_DEALLOCATE(arg1)
5771 [ - + ]: 36 : LIBPAW_DEALLOCATE(dfdr2)
5772 [ - + ]: 36 : LIBPAW_DEALLOCATE(arg2)
5773 [ - + ]: 36 : LIBPAW_DEALLOCATE(tdfdr1)
5774 [ - + ]: 36 : LIBPAW_DEALLOCATE(targ1)
5775 [ - + ]: 36 : LIBPAW_DEALLOCATE(tdfdr2)
5776 [ - + ]: 36 : LIBPAW_DEALLOCATE(targ2)
5777 : 36 : END SUBROUTINE deltakinetic_ij
5778 : :
5779 : :
5780 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5781 : : !! SUBROUTINE atompaw_poisson(Grid,q,den,rv,ecoul,v00)
5782 : : !! Use Numerov algorithm to solve poisson equation
5783 : : !! den(n) is electron density * (4*pi*r**2)
5784 : : !! rv(n) is returned as electrostatic potential * r
5785 : : !! ecoul is the coulomb interaction energy
5786 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5787 [ - + - + ]: 25 : SUBROUTINE atompaw_poisson(Grid,q,den,rv,ecoul,v00)
5788 : : TYPE (GridInfo), INTENT(IN) :: Grid
5789 : : real(dp), INTENT(IN):: den(:)
5790 : : real(dp), INTENT(INOUT) :: rv(:),ecoul,q
5791 : : real(dp), OPTIONAL, INTENT(OUT) :: v00
5792 : 25 : real(dp), ALLOCATABLE :: a(:),b(:)
5793 : : real(dp) :: sd,sl,h,h2
5794 : : INTEGER :: i,n
5795 : 25 : n=Grid%n
5796 : 25 : h=Grid%h
5797 [ + + ]: 50050 : rv=0._dp
5798 : 25 : q=integrator(Grid,den)
5799 [ - + + - : 75 : LIBPAW_ALLOCATE(a,(n))
+ - + - -
+ - + ]
5800 [ - + + - : 50 : LIBPAW_ALLOCATE(b,(n))
- + - + ]
5801 [ - + ]: 25 : IF (Grid%type==lineargrid) THEN
5802 : 0 : sd=2
5803 : 0 : sl=-1
5804 : 0 : a(1)=0
5805 [ # # ]: 0 : DO i=2,n
5806 : 0 : a(i)=h*den(i)/(6*(i-1))
5807 : : ENDDO
5808 : 0 : rv(1)=0
5809 : 0 : rv(2)=10*a(2)+a(3)
5810 [ # # ]: 0 : DO i=3,n-1
5811 : 0 : rv(i)=10*a(i)+a(i+1)+a(i-1)
5812 : : ENDDO
5813 : 0 : rv(n)=10*a(n)+a(n-1)+2*q
5814 [ + - ]: 25 : ELSEIF (Grid%type==loggrid) THEN
5815 : 25 : sd=2+10*h*h/48
5816 : 25 : sl=-1+h*h/48
5817 : 25 : a(1)=0
5818 : 25 : h2=h*h
5819 [ + + ]: 50025 : DO i=2,n
5820 : 50025 : a(i)=h2*Grid%rr02(i)*den(i)/(6*Grid%r(i))/Grid%pref(i)
5821 : : ENDDO
5822 : 25 : rv(1)=0
5823 : 25 : rv(2)=10*a(2)+a(3)
5824 [ + + ]: 49975 : DO i=3,n-1
5825 : 49975 : rv(i)=10*a(i)+a(i+1)+a(i-1)
5826 : : ENDDO
5827 : : ! last term is boundary value at point n+1
5828 : 25 : rv(n)=10*a(n)+a(n-1)-2*q*sl/(Grid%pref(n)*EXP(h/2))
5829 : : ENDIF
5830 : 25 : CALL conthomas(n,sl,sd,rv)
5831 [ + - + + ]: 50050 : IF (Grid%type==loggrid) rv=rv*Grid%pref
5832 : : ! calculate ecoul
5833 [ + + ]: 50025 : DO i=2,n
5834 : 50025 : a(i)=den(i)*rv(i)/Grid%r(i)
5835 : : ENDDO
5836 : 25 : a(1)=0
5837 : 25 : ecoul=integrator(Grid,a)*0.5_dp
5838 [ + + ]: 25 : IF (PRESENT(v00)) THEN
5839 [ + + ]: 46046 : a=0
5840 [ + + ]: 46023 : a(2:n)=den(2:n)/Grid%r(2:n)
5841 : 23 : v00=2*integrator(Grid,a)
5842 : : ENDIF
5843 : 25 : LIBPAW_DEALLOCATE(a)
5844 [ - + ]: 25 : LIBPAW_DEALLOCATE(b)
5845 : 25 : END SUBROUTINE atompaw_poisson
5846 : :
5847 : :
5848 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5849 : : !! SUBROUTINE poisson_marc(Grid,q,den,rv,ecoul)
5850 : : !! use Numerov algorithm to solve poisson equation
5851 : : !! den(n) is electron density * (4*pi*r**2)
5852 : : !! rv(n) is returned as electrostatic potential * r
5853 : : !! ecoul is the coulomb interation energy
5854 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5855 [ - + - + ]: 354 : SUBROUTINE poisson_marc(Grid,q,den,rv,ecoul)
5856 : : TYPE (GridInfo), INTENT(IN) :: Grid
5857 : : real(dp), INTENT(IN):: den(:)
5858 : : real(dp), INTENT(INOUT) :: rv(:),ecoul,q
5859 : 354 : real(dp), ALLOCATABLE :: aa(:),bb(:),cc(:),dd(:)
5860 : : real(dp) :: h
5861 : : INTEGER :: i,n,ir,jr
5862 : 354 : n=Grid%n
5863 : 354 : h=Grid%h
5864 [ + + ]: 708708 : rv=0._dp
5865 : 354 : q=integrator(Grid,den)
5866 [ - + + - : 1062 : LIBPAW_ALLOCATE(aa,(n))
+ - + - -
+ - + ]
5867 [ - + + - : 708 : LIBPAW_ALLOCATE(bb,(n))
- + - + ]
5868 [ - + + - : 708 : LIBPAW_ALLOCATE(cc,(n))
- + - + ]
5869 [ - + + - : 708 : LIBPAW_ALLOCATE(dd,(n))
- + + - ]
5870 [ + + ]: 708354 : DO jr=n,2,-1
5871 : 708000 : ir=n-jr+1
5872 : 708000 : aa(ir)=den(jr)*Grid%drdu(jr)
5873 : 708354 : bb(ir)=den(jr)*Grid%drdu(jr)/Grid%r(jr)
5874 : : END DO
5875 [ + + ]: 708708 : cc=0._dp
5876 : 354 : cc(5)=aa(n-4);cc(4)=aa(n-3);cc(3)=aa(n-2);cc(2)=aa(n-1)
5877 : 354 : cc(1)=cc(4)+3._dp*(cc(2)-cc(3)) !call extrapolate(Grid,cc)
5878 : 354 : aa(n)=cc(1)
5879 : 354 : cc(5)=bb(n-4);cc(4)=bb(n-3);cc(3)=bb(n-2);cc(2)=bb(n-1)
5880 : 354 : cc(1)=cc(4)+3._dp*(cc(2)-cc(3)) !call extrapolate(Grid,cc)
5881 : 354 : bb(n)=cc(1)
5882 : 354 : cc(1)=0._dp;dd(1)=0._dp
5883 [ + - ]: 354 : DO ir=3,n,2
5884 : 354000 : cc(ir) =cc(ir-2)+h/3._dp*(aa(ir-2)+4._dp*aa(ir-1)+aa(ir))
5885 : 354000 : cc(ir-1)=cc(ir-2)+h/3._dp*(1.25_dp*aa(ir-2)+2.0_dp*aa(ir-1)-0.25_dp*aa(ir))
5886 : 354000 : dd(ir) =dd(ir-2)+h/3._dp*(bb(ir-2)+4._dp*bb(ir-1)+bb(ir))
5887 [ + + ]: 354000 : dd(ir-1)=dd(ir-2)+h/3._dp*(1.25_dp*bb(ir-2)+2._dp*bb(ir-1)-0.25_dp*bb(ir))
5888 : : END DO
5889 [ - + ]: 354 : IF (MOD(n,2)==0) THEN
5890 : 0 : cc(n)=cc(n-1)+h/3._dp*(1.25_dp*aa(n-2)+2._dp*aa(n-1)-0.25_dp*aa(n))
5891 : 0 : dd(n)=dd(n-1)+h/3._dp*(1.25_dp*bb(n-2)+2._dp*bb(n-1)-0.25_dp*bb(n))
5892 : : END IF
5893 : 354 : rv(1)=0._dp
5894 [ + + ]: 708354 : DO ir=2,n
5895 : 708000 : jr=n-ir+1
5896 : 708354 : rv(ir)=2._dp*(dd(jr)*Grid%r(ir)+(cc(n)-cc(jr))) !Ha->Ry
5897 : : END DO
5898 [ - + - - ]: 354 : if (n<Grid%n) rv(n+1:Grid%n)=rv(n)
5899 : : ! calculate ecoul
5900 : 354 : aa(1)=0._dp
5901 [ + + ]: 708354 : do i=2,n
5902 : 708354 : aa(i)=den(i)*rv(i)/Grid%r(i)
5903 : : end do
5904 : 354 : ecoul=0.5_dp*integrator(Grid,aa)
5905 : 354 : LIBPAW_DEALLOCATE(aa)
5906 : 354 : LIBPAW_DEALLOCATE(bb)
5907 : 354 : LIBPAW_DEALLOCATE(cc)
5908 : 354 : LIBPAW_DEALLOCATE(dd)
5909 : 354 : END SUBROUTINE poisson_marc
5910 : :
5911 : :
5912 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5913 : : !! zeropot(Grid,rv,v0,v0p)
5914 : : !! extrapolate potential to value at r=0
5915 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5916 [ - + ]: 403 : SUBROUTINE zeropot(Grid,rv,v0,v0p)
5917 : : TYPE (GridInfo), INTENT(IN):: Grid
5918 : : real(dp), INTENT(IN) :: rv(:) ! Note: rv(1) corresponds to r=0
5919 : : real(dp), INTENT(OUT) :: v0,v0p
5920 : : real(dp) :: tmp(15),tmp1(15)
5921 [ + + ]: 6045 : tmp(2:15)=rv(2:15)/Grid%r(2:15)
5922 : 403 : CALL extrapolate(tmp(1:15))
5923 : 403 : v0=tmp(1)
5924 : 403 : CALL derivative(Grid,tmp(1:15),tmp1(1:15),2,15)
5925 : 403 : CALL extrapolate(tmp1(1:15))
5926 : 403 : v0p=tmp1(1)
5927 : 403 : END SUBROUTINE zeropot
5928 : :
5929 : :
5930 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5931 : : !! subroutine kinetic(Grid,wfn,l,ekin)
5932 : : !! calculates expectation value of kinetic energy for wfn
5933 : : !! with orbital angular momentum l
5934 : : !! wfn == r*radialwfn in Schroedinger Equation
5935 : : !! assumes wfn=(constant)*r^(l+1) at small r
5936 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5937 : : SUBROUTINE kinetic(Grid,wfn,l,ekin)
5938 : : TYPE (GridInfo), INTENT(IN) :: Grid
5939 : : real(dp), INTENT(IN) :: wfn(:)
5940 : : INTEGER, INTENT(IN) :: l
5941 : : real(dp), INTENT(OUT) :: ekin
5942 : : real(dp), ALLOCATABLE :: dfdr(:),arg(:)
5943 : : INTEGER :: i,n
5944 : : n=Grid%n
5945 : : LIBPAW_ALLOCATE(dfdr,(n))
5946 : : LIBPAW_ALLOCATE(arg,(n))
5947 : : CALL derivative(Grid,wfn,dfdr)
5948 : : arg=0
5949 : : DO i=2,n
5950 : : arg(i)=wfn(i)/Grid%r(i)
5951 : : ENDDO
5952 : : DO i=1,n
5953 : : arg(i)=(dfdr(i))**2+(l*(l+1))*(arg(i))**2
5954 : : ENDDO
5955 : : ekin=integrator(Grid,arg)!*0.5!Hartree
5956 : : LIBPAW_DEALLOCATE(dfdr)
5957 : : LIBPAW_DEALLOCATE(arg)
5958 : : END SUBROUTINE kinetic
5959 : :
5960 : :
5961 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5962 : : !! subroutine altkinetic(Grid,wfn,energy,rv,ekin)
5963 : : !! calculates expectation value of kinetic energy for wfn
5964 : : !! with orbital wfn by integrating
5965 : : !! int(wfn**2 * (energy-rv/r), r=0..rmax)
5966 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5967 [ - + - + ]: 2230 : SUBROUTINE altkinetic(Grid,wfn,energy,rv,ekin)
5968 : : TYPE (GridInfo), INTENT(IN) :: Grid
5969 : : real(dp), INTENT(IN) :: wfn(:),rv(:),energy
5970 : : real(dp), INTENT(OUT) :: ekin
5971 : 2230 : real(dp), ALLOCATABLE :: arg(:)
5972 : : INTEGER :: i,n
5973 : 2230 : n=Grid%n
5974 [ - + + - : 6690 : LIBPAW_ALLOCATE(arg,(n))
+ - + - -
+ - + ]
5975 [ + + ]: 4464460 : arg=0
5976 [ + + ]: 4462230 : DO i=2,n
5977 : 4462230 : arg(i)=(wfn(i)**2)*(energy-rv(i)/Grid%r(i))
5978 : : ENDDO
5979 : 2230 : ekin=integrator(Grid,arg)
5980 [ - + ]: 2230 : LIBPAW_DEALLOCATE(arg)
5981 : 2230 : END SUBROUTINE altkinetic
5982 : :
5983 : :
5984 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5985 : : !! overint(n,h,f1,icorr)
5986 : : !! function to calculate the integral of one vectors f1
5987 : : !! using simpsons rule assuming a regular grid with
5988 : : !! spacing of h and n total points
5989 : : !! icorr: optional parameter: used only when n is even
5990 : : !! if icorr<0, a trapezoidal correction is applied
5991 : : !! at the start of interval
5992 : : !! if icorr>=0, a trapezoidal correction is applied
5993 : : !! at the end of interval
5994 : : !! default (if missing) is icorr=0
5995 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5996 [ - + ]: 61574 : FUNCTION overint(n,h,f1,icorr)
5997 : : real(dp) :: overint
5998 : : INTEGER, INTENT(IN) :: n
5999 : : real(dp), INTENT(IN) :: h,f1(:)
6000 : : INTEGER, OPTIONAL :: icorr
6001 : : real(dp),PARAMETER :: tol=1.D-14
6002 : : INTEGER :: i,j,istart,m
6003 : 61574 : overint=0
6004 : : !Eliminate zeros at end of interval
6005 [ + + + + ]: 13957174 : i=n;DO WHILE(ABS(f1(i))<machine_zero.AND.i>2);i=i-1;ENDDO
6006 : 61574 : m=MIN(i+1,n)
6007 [ + - ]: 61574 : IF (m<=1) THEN
6008 : : RETURN
6009 [ - + ]: 61574 : ELSEIF (m==2) THEN
6010 : 0 : overint=(f1(1)+f1(2))*(h/2) ! Trapezoidal rule
6011 : 0 : RETURN
6012 : : ENDIF
6013 : 61574 : istart=1
6014 [ - + ]: 61574 : IF (PRESENT(icorr)) THEN
6015 [ - + + + ]: 61574 : IF (icorr<0.AND.MOD(m,2)==0) istart=2
6016 : : ENDIF
6017 : 61574 : overint=f1(istart)+4*f1(istart+1)+f1(istart+2)
6018 : 61574 : j=((m-istart)/2)*2+istart
6019 [ + + ]: 61574 : IF (j>=istart+4) THEN
6020 [ - + ]: 61571 : DO i=istart+4,j,2
6021 [ + + ]: 53715109 : overint=overint+f1(i-2)+4*f1(i-1)+f1(i)
6022 : : ENDDO
6023 : : ENDIF
6024 : 61574 : overint=overint*(h/3)
6025 [ - + ]: 61574 : IF (m>j) overint=overint+(f1(j)+f1(m))*(h/2)
6026 [ + + ]: 61574 : IF (istart==2) overint=overint+(f1(1)+f1(2))*(h/2)
6027 : : RETURN
6028 : : END FUNCTION overint
6029 : :
6030 : :
6031 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6032 : : !! function integrator(Grid,arg)
6033 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6034 [ - + ]: 61574 : FUNCTION integrator(Grid,arg,str,fin)
6035 : : real(dp) :: integrator
6036 : : TYPE(GridInfo), INTENT(IN) :: Grid
6037 : : real(dp), INTENT(IN) :: arg(:)
6038 : : INTEGER, INTENT(IN), OPTIONAL :: str,fin
6039 : 61574 : real(dp), ALLOCATABLE :: dum(:)
6040 : : INTEGER :: n,i1,i2
6041 : 61574 : n=Grid%n
6042 : 61574 : i1=1;i2=n
6043 [ + + ]: 61574 : IF (PRESENT(str).AND.PRESENT(fin)) THEN
6044 : 57565 : i1=str; i2=fin; n=i2-i1+1
6045 : : ENDIF
6046 : 61574 : SELECT CASE(Grid%type)
6047 : : CASE default
6048 : 0 : LIBPAW_ERROR('Error in integrator')
6049 : : CASE(lineargrid)
6050 : 0 : integrator=overint(n,Grid%h,arg(i1:i2))
6051 : : CASE(loggrid)
6052 [ - + + - : 184722 : LIBPAW_BOUND1_ALLOCATE(dum,BOUNDS(i1,i2))
+ - + - -
+ - + ]
6053 [ + + ]: 121547557 : dum(i1:i2)=arg(i1:i2)*Grid%drdu(i1:i2)
6054 : 61574 : integrator=overint(n,Grid%h,dum(i1:i2),-1)
6055 [ - - + - : 123148 : LIBPAW_DEALLOCATE(dum)
+ ]
6056 : : END SELECT
6057 : 61574 : END FUNCTION integrator
6058 : :
6059 : :
6060 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6061 : : !! function FindGridIndex(Grid,rpoint)
6062 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6063 : 40085 : FUNCTION FindGridIndex(Grid,rpoint)
6064 : : INTEGER :: FindGridIndex
6065 : : TYPE (GridInfo), INTENT(IN) :: Grid
6066 : : real(dp), INTENT(IN) :: rpoint
6067 : : real(dp) :: r0
6068 : 40085 : FindGridIndex=0
6069 [ - + ]: 40085 : IF (Grid%type==lineargrid) THEN
6070 : 0 : FindGridIndex=rpoint/Grid%h+1
6071 [ # # ]: 0 : IF (Grid%h*(FindGridIndex-1)<rpoint-tol10) FindGridIndex=FindGridIndex+1
6072 [ + - ]: 40085 : ELSEIF (Grid%type==loggrid) THEN
6073 : 40085 : r0=Grid%drdu(1)
6074 : 40085 : FindGridIndex=LOG(rpoint/r0+1)/Grid%h+1
6075 [ + + ]: 40085 : IF (r0*EXP(Grid%h*(FindGridIndex-1))<rpoint-tol10) &
6076 : 40078 : & FindGridIndex=FindGridIndex+1
6077 : : ENDIF
6078 : 40085 : END FUNCTION FindGridIndex
6079 : :
6080 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6081 : : !! function gridindex(Grid,r)
6082 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6083 : : FUNCTION gridindex(Grid,r)
6084 : : INTEGER :: gridindex
6085 : : TYPE (GridInfo), INTENT(IN) :: Grid
6086 : : REAL(dp), INTENT(IN) :: r
6087 : : gridindex=0
6088 : : IF (Grid%type==lineargrid) THEN
6089 : : gridindex=r/Grid%h +0.1d0 +1
6090 : : ELSEIF (Grid%type==loggrid) THEN
6091 : : gridindex=LOG(1.d0+r/Grid%drdu(1))/Grid%h +0.1d0 +1
6092 : : ENDIF
6093 : : END FUNCTION gridindex
6094 : :
6095 : :
6096 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6097 : : !! ClassicalTurningPoint(Grid,rv,l,energy,turningpoint)
6098 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6099 [ - + ]: 40052 : SUBROUTINE ClassicalTurningPoint(Grid,rv,l,energy,turningpoint)
6100 : : TYPE(GridInfo), INTENT(IN) :: Grid
6101 : : real(dp), INTENT(IN) :: rv(:)
6102 : : INTEGER, INTENT(IN) :: l
6103 : : real(dp), INTENT(IN) :: energy
6104 : : INTEGER, INTENT(OUT) :: turningpoint
6105 : : INTEGER :: i,n
6106 : 40052 : real(dp), ALLOCATABLE :: v(:)
6107 : 40052 : n=Grid%n
6108 [ - + + - : 120156 : LIBPAW_ALLOCATE(v,(n))
+ - + - -
+ - + ]
6109 [ + + ]: 80184104 : v=0
6110 [ + + ]: 80144052 : v(2:n)=rv(2:n)/Grid%r(2:n)+l*(l+1)/(Grid%r(2:n)**2)!hartree
6111 : : turningpoint=n
6112 [ + + ]: 51997607 : DO i=n,2,-1
6113 [ + + ]: 51997607 : IF (v(i)<energy) EXIT
6114 : : ENDDO
6115 : : turningpoint=i
6116 : 40052 : turningpoint=MIN(turningpoint,FindGridIndex(Grid,10.0_dp))
6117 [ - + ]: 40052 : LIBPAW_DEALLOCATE(v)
6118 : 40052 : END SUBROUTINE ClassicalTurningPoint
6119 : :
6120 : :
6121 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6122 : : !! getwfnfromcfdsol(start,finish,yy,wfn)
6123 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6124 [ - + - + ]: 36031 : subroutine getwfnfromcfdsol(start,finish,yy,wfn)
6125 : : INTEGER, INTENT(IN) :: start,finish
6126 : : real(dp), INTENT(IN) :: yy(:,:)
6127 : : real(dp), INTENT(INOUT) :: wfn(:)
6128 : : INTEGER :: i
6129 [ + + ]: 72133435 : wfn=0
6130 [ + + ]: 36570103 : do i=start,finish
6131 : 36570103 : wfn(i)=yy(1,i)
6132 : : enddo
6133 : 36031 : end subroutine getwfnfromcfdsol
6134 : :
6135 : :
6136 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6137 : : !! countnodes(start,finish,wfn,filter)
6138 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6139 [ - + ]: 35362 : INTEGER function countnodes(start,finish,wfn,filter)
6140 : : INTEGER, INTENT(IN) :: start,finish
6141 : : real(dp), INTENT(IN) :: wfn(:)
6142 : : real(dp), INTENT(IN), OPTIONAL :: filter
6143 : : INTEGER :: i,nodes
6144 : 35362 : nodes=0
6145 [ + + ]: 23105223 : do i=start+1,finish
6146 [ + + ]: 23069861 : if (wfn(i)*wfn(i-1)<0._dp) nodes=nodes+1
6147 [ - + ]: 23105223 : if (PRESENT(filter)) then
6148 [ # # ]: 0 : If((abs(wfn(i))+abs(wfn(i-1)))<filter) exit
6149 : : endif
6150 : : enddo
6151 : 35362 : countnodes=nodes
6152 : 35362 : end function countnodes
6153 : :
6154 : :
6155 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6156 : : !! extrapolate(Grid,v)
6157 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6158 [ - + ]: 5853 : SUBROUTINE extrapolate(v)
6159 : : ! extrapolate array v to r=0 at v(1)
6160 : : real(dp), INTENT(INOUT) :: v(:) ! assume v(2),v(3)... given
6161 : 5853 : v(1)=5._dp*v(2)-10._dp*v(3)+10._dp*v(4)-5._dp*v(5)+v(6) ! fourth order formula
6162 : 5853 : END SUBROUTINE extrapolate
6163 : :
6164 : :
6165 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6166 : : !! subroutine derivative(Grid,f,dfdr,begin,bend)
6167 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6168 [ - + - + ]: 15426 : SUBROUTINE derivative(Grid,f,dfdr,begin,bend)
6169 : : TYPE(GridInfo), INTENT(IN) :: Grid
6170 : : real(dp), INTENT(IN) :: f(:)
6171 : : real(dp), INTENT(OUT) :: dfdr(:)
6172 : : INTEGER, OPTIONAL, INTENT(IN) :: begin,bend
6173 : : INTEGER :: i,n,i1,i2
6174 : 15426 : i1=1;i2=Grid%n;n=i2-i1+1
6175 [ + + ]: 15426 : IF (PRESENT(begin).OR.PRESENT(bend)) THEN
6176 [ + - + - ]: 15008 : IF (begin>=1.AND.bend<= Grid%n) THEN
6177 : 15008 : i1=begin;i2=bend;n=i2-i1+1
6178 : : ELSE
6179 : 0 : LIBPAW_ERROR('Error in derivative')
6180 : : ENDIF
6181 : : ENDIF
6182 : 15426 : SELECT CASE(Grid%type)
6183 : : CASE default
6184 : 0 : LIBPAW_ERROR('Error in derivative')
6185 : : CASE(lineargrid)
6186 : 0 : CALL nderiv(Grid%h,f(i1:i2),dfdr(i1:i2),n,i)
6187 [ # # ]: 0 : IF (i/=0) THEN
6188 : 0 : LIBPAW_ERROR('Error in derivative -nderiv problem')
6189 : : ENDIF
6190 : : CASE(loggrid)
6191 : 15426 : CALL nderiv(Grid%h,f(i1:i2),dfdr(i1:i2),n,i)
6192 [ - + ]: 15426 : IF (i/=0) THEN
6193 : 0 : LIBPAW_ERROR('Error in derivative -nderiv problem')
6194 : : ENDIF
6195 [ - - + + : 9220973 : dfdr(i1:i2)=dfdr(i1:i2)/Grid%drdu(i1:i2)
+ ]
6196 : : END SELECT
6197 : 15426 : END SUBROUTINE derivative
6198 : :
6199 : :
6200 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6201 : : !! nderiv(h,y,z,ndim,ierr)
6202 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6203 [ - + - + ]: 15426 : SUBROUTINE nderiv(h,y,z,ndim,ierr)
6204 : : INTEGER, INTENT(IN) :: ndim
6205 : : INTEGER, INTENT(INOUT) :: ierr
6206 : : real(dp) , INTENT(IN) :: h,y(:)
6207 : : real(dp) , INTENT(INOUT) :: z(:)
6208 : : real(dp) :: hh,yy,a,b,c
6209 : : INTEGER :: i
6210 : 15426 : ierr=-1
6211 [ + - ]: 15426 : IF (ndim.LT.5) RETURN
6212 : : ! prepare differentiation loop
6213 : 15426 : hh=.08333333333333333_dp/h
6214 : 15426 : yy=y(ndim-4)
6215 : 15426 : b=hh*(-25._dp*y(1)+48._dp*y(2)-36._dp*y(3)+16._dp*y(4)-3._dp*y(5))
6216 : 15426 : c=hh*(-3._dp*y(1)-10._dp*y(2)+18._dp*y(3)-6._dp*y(4)+y(5))
6217 : : ! start differentiation loop
6218 [ + + ]: 9143843 : DO i=5,ndim
6219 : 9128417 : a=b
6220 : 9128417 : b=c
6221 : 9128417 : c=hh*(y(i-4)-y(i)+8._dp*(y(i-1)-y(i-3)))
6222 : 9143843 : z(i-4)=a
6223 : : ENDDO
6224 : : ! end of differentiation loop
6225 : : ! normal exit
6226 : : a=hh*(-yy+6._dp*y(ndim-3)-18._dp*y(ndim-2)+10._dp*y(ndim-1) &
6227 : 15426 : & +3._dp*y(ndim))
6228 : : z(ndim)=hh*(3._dp*yy-16._dp*y(ndim-3)+36._dp*y(ndim-2) &
6229 : 15426 : & -48._dp*y(ndim-1)+25._dp*y(ndim))
6230 : 15426 : z(ndim-1)=a
6231 : 15426 : z(ndim-2)=c
6232 : 15426 : z(ndim-3)=b
6233 : 15426 : ierr=0
6234 : 15426 : RETURN
6235 : : END SUBROUTINE nderiv
6236 : :
6237 : :
6238 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6239 : : !! Second derivative for general grid
6240 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6241 [ - + ]: 2 : FUNCTION Gsecondderiv(Grid,index,g)
6242 : : real(dp) :: Gsecondderiv
6243 : : TYPE (GridInfo), INTENT(IN) :: Grid
6244 : : INTEGER, INTENT(IN) :: index
6245 : : real(dp), INTENT(IN) :: g(:)
6246 : 2 : Gsecondderiv=0
6247 [ - + ]: 2 : IF (Grid%type==lineargrid) THEN
6248 : 0 : Gsecondderiv=secondderiv(index,g,Grid%h)
6249 [ + - ]: 2 : ELSEIF (Grid%type==loggrid) THEN
6250 : : Gsecondderiv=(secondderiv(index,g,Grid%h)&
6251 : 2 : & -firstderiv(index,g,Grid%h))/Grid%rr02(index)
6252 : : ENDIF
6253 : 2 : END FUNCTION Gsecondderiv
6254 : :
6255 : :
6256 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6257 : : !! First derivative for general grid
6258 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6259 [ - + ]: 35784 : FUNCTION Gfirstderiv(Grid,index,g)
6260 : : real(dp) :: Gfirstderiv
6261 : : TYPE (GridInfo), INTENT(IN) :: Grid
6262 : : INTEGER, INTENT(IN) :: index
6263 : : real(dp), INTENT(IN) :: g(:)
6264 : 35784 : Gfirstderiv=0
6265 [ - + ]: 35784 : IF (Grid%type==lineargrid) THEN
6266 : 0 : Gfirstderiv=firstderiv(index,g,Grid%h)
6267 [ + - ]: 35784 : ELSEIF (Grid%type==loggrid) THEN
6268 : 35784 : Gfirstderiv=firstderiv(index,g,Grid%h)/Grid%drdu(index)
6269 : : ENDIF
6270 : 35784 : END FUNCTION Gfirstderiv
6271 : :
6272 : :
6273 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6274 : : !! finite difference second derivative
6275 : : !! based on 5 point formula
6276 : : !! Ref. Engeln-Mullges & Uhlig (1996)
6277 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6278 [ - + ]: 2 : FUNCTION secondderiv(index,f,h)
6279 : : real(dp) :: secondderiv
6280 : : INTEGER, INTENT(IN) :: index
6281 : : real(dp), INTENT(IN) :: f(:),h
6282 : : INTEGER :: n
6283 : 2 : n=SIZE(f)
6284 : 2 : secondderiv=0
6285 [ - + - - ]: 2 : if (index==1.and.n>=5) THEN
6286 : 0 : secondderiv=(70*f(1)-208*f(2)+228*f(3)-112*f(4)+22*f(5))/(24*h*h)
6287 [ - + - - ]: 2 : else if (index==2.and.n>=5) THEN
6288 : 0 : secondderiv=(22*f(1)-40*f(2)+12*f(3)+8*f(4)-2*f(5))/(24*h*h)
6289 [ + - + - ]: 2 : else if (index>2.and.index<=n-2) THEN
6290 : : secondderiv=-(f(index-2)+f(index+2))/12 + &
6291 : 2 : & 4*(f(index-1)+f(index+1))/3 - 5*f(index)/2
6292 : 2 : secondderiv=secondderiv/(h*h)
6293 [ # # # # ]: 0 : else if (index>=5.and.index==n-1) THEN
6294 : 0 : secondderiv=(-2*f(n-4)+8*f(n-3)+12*f(n-2)-40*f(n-1)+22*f(n))/(24*h*h)
6295 [ # # # # ]: 0 : else if (index>=5.and.index==n) THEN
6296 : 0 : secondderiv=(22*f(n-4)-112*f(n-3)+228*f(n-2)-208*f(n-1)+70*f(n))/(24*h*h)
6297 : : else
6298 : 0 : LIBPAW_ERROR('Error in secondderiv')
6299 : : ENDIF
6300 : 2 : END FUNCTION secondderiv
6301 : :
6302 : :
6303 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6304 : : !! finite difference first derivative
6305 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6306 [ - + ]: 35786 : FUNCTION firstderiv(index,f,h)
6307 : : real(dp) :: firstderiv
6308 : : INTEGER, INTENT(IN) :: index
6309 : : real(dp), INTENT(IN) :: f(:),h
6310 : : INTEGER :: n
6311 : 35786 : n=SIZE(f)
6312 : 35786 : firstderiv=0
6313 [ - + - - ]: 35786 : if (index==1.and.n>=5) THEN
6314 : 0 : firstderiv=(-25*f(1)+48*f(2)-36*f(3)+16*f(4)-3*f(5))/(12*h)
6315 [ - + - - ]: 35786 : else if (index==2.and.n>=5) THEN
6316 : 0 : firstderiv=(-3*f(1)-10*f(2)+18*f(3)-6*f(4)+f(5))/(12*h)
6317 [ + - + - ]: 35786 : else if (index>2.and.index<=n-2) THEN
6318 : 35786 : firstderiv=(f(index-2)-8*f(index-1)+8*f(index+1)-f(index+2))/(12*h)
6319 [ # # # # ]: 0 : else if (index>=5.and.index==n-1) THEN
6320 : 0 : firstderiv=(-f(n-4)+6*f(n-3)-18*f(n-2)+10*f(n-1)+3*f(n))/(12*h)
6321 [ # # # # ]: 0 : else if (index>=5.and.index==n) THEN
6322 : 0 : firstderiv=(3*f(n-4)-16*f(n-3)+36*f(n-2)-48*f(n-1)+25*f(n))/(12*h)
6323 : : else
6324 : 0 : LIBPAW_ERROR('Error in firstderiv')
6325 : : ENDIF
6326 : 35786 : END FUNCTION firstderiv
6327 : :
6328 : :
6329 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6330 : : !! function to calculate the overlap between two vectors f1 and f2
6331 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6332 [ - + - + ]: 54317 : FUNCTION overlap(Grid,f1,f2,str,fin)
6333 : : real(dp) :: overlap
6334 : : TYPE(GridInfo), INTENT(IN) :: Grid
6335 : : real(dp), INTENT(IN) :: f1(:),f2(:)
6336 : : INTEGER, INTENT(IN), OPTIONAL :: str,fin
6337 : 54317 : real(dp), ALLOCATABLE :: dum(:)
6338 : : INTEGER :: n,i1,i2
6339 : 54317 : n=Grid%n
6340 : 54317 : i1=1;i2=n
6341 [ + + ]: 54317 : IF (PRESENT(str).AND.PRESENT(fin)) THEN
6342 : 182 : i1=str; i2=fin; n=i2-i1+1
6343 : : ENDIF
6344 [ - + + - : 162951 : LIBPAW_BOUND1_ALLOCATE(dum,BOUNDS(i1,i2))
+ - + - -
+ - + ]
6345 [ + + ]: 108686480 : dum(1:n)=f1(i1:i2)*f2(i1:i2)
6346 : 54317 : overlap=integrator(Grid,dum(1:n),1,n)
6347 [ - + ]: 54317 : LIBPAW_DEALLOCATE(dum)
6348 : 54317 : END FUNCTION overlap
6349 : :
6350 : :
6351 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6352 : : !! Subroutine from David Vanderbilt's USPS code, modified by Marc
6353 : : !! Torrent and Francois Jollet, further modified by NAWH
6354 : : !!===========================================================================
6355 : : !! subroutine cfdsol(zz,yy,jj1,jj2,mesh)
6356 : : !!===========================================================================
6357 : : !! routine for solving coupled first order differential equations
6358 : : !!
6359 : : !! d yy(x,1)
6360 : : !! --------- = zz(x,1,1) * yy(x,1) + zz(x,1,2) * yy(2,1)
6361 : : !! dx
6362 : : !!
6363 : : !! d yy(x,2)
6364 : : !! --------- = zz(x,2,1) * yy(x,1) + zz(x,2,2) * yy(2,1)
6365 : : !! dx
6366 : : !!
6367 : : !!
6368 : : !! using fifth order predictor corrector algorithm
6369 : : !!
6370 : : !! routine integrates from jj1 to jj2 and can cope with both cases
6371 : : !! jj1 < jj2 and jj1 > jj2. first five starting values of yy must
6372 : : !! be provided by the calling program.
6373 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6374 [ - + - + ]: 5 : SUBROUTINE cfdsol(Grid,zz,yy,jj1,jj2)
6375 : : TYPE(gridinfo), INTENT(IN) :: Grid
6376 : : real(dp), INTENT(IN):: zz(:,:,:)
6377 : : real(dp), INTENT(INOUT):: yy(:,:)
6378 : : INTEGER, INTENT(IN) :: jj1,jj2
6379 : : real(dp):: fa(0:5),fb(0:5),abp(1:5),amc(0:4)
6380 : : INTEGER :: isgn,i,j,ip,mesh
6381 : : real(dp):: arp,brp
6382 : 5 : real(dp), ALLOCATABLE :: tmpz(:,:,:)
6383 : : real(dp), PARAMETER :: verylarge=1.d30
6384 : : real(dp) :: scale
6385 : 5 : mesh=SIZE(yy(2,:))
6386 [ - + ]: 5 : IF (SIZE(zz(2,2,:))/=mesh) THEN
6387 : 0 : LIBPAW_ERROR('cfdsol error - incompatible arrays')
6388 : : ENDIF
6389 [ + - ]: 5 : isgn = ( jj2 - jj1 ) / iabs( jj2 - jj1 )
6390 [ + - ]: 5 : IF ( isgn .EQ. + 1 ) THEN
6391 [ + - - + ]: 5 : IF ( jj1 .LE. 5 .OR. jj2 .GT. mesh ) THEN
6392 : 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6393 : : ENDIF
6394 : : ELSEIF ( isgn .EQ. - 1 ) THEN
6395 [ # # # # ]: 0 : IF ( jj1 .GE. ( mesh - 4 ) .OR. jj2 .LT. 1 ) THEN
6396 : 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6397 : : ENDIF
6398 : : ELSE
6399 : : if(has_to_print) write(std_out,*) isgn,jj1,jj2,mesh
6400 : : ENDIF
6401 [ - + + - : 15 : LIBPAW_ALLOCATE(tmpz,(2,2,mesh))
+ - + - -
+ - + ]
6402 [ + - + - : 65656 : tmpz=zz
+ - - + -
- + + + +
+ + ]
6403 [ + + ]: 15 : DO i=1,2
6404 [ + + ]: 35 : DO j=1,2
6405 [ + + ]: 37532 : tmpz(i,j,:)=tmpz(i,j,:)*Grid%h
6406 [ + - + + ]: 37542 : if (Grid%TYPE==loggrid) tmpz(i,j,1:mesh)=tmpz(i,j,1:mesh)*Grid%drdu(1:mesh)
6407 : : ENDDO
6408 : : ENDDO
6409 : 5 : abp(1) = 1901._dp / 720._dp
6410 : 5 : abp(2) = -1387._dp / 360._dp
6411 : 5 : abp(3) = 109._dp / 30._dp
6412 : 5 : abp(4) = -637._dp / 360._dp
6413 : 5 : abp(5) = 251._dp / 720._dp
6414 : 5 : amc(0) = 251._dp / 720._dp
6415 : 5 : amc(1) = 323._dp / 360._dp
6416 : 5 : amc(2) = -11._dp / 30._dp
6417 : 5 : amc(3) = 53._dp / 360._dp
6418 : 5 : amc(4) = -19._dp / 720._dp
6419 [ + + ]: 30 : DO j = 1,5
6420 : 25 : ip = jj1 - isgn * j
6421 : 25 : fa(j) = tmpz(1,1,ip) * yy(1,ip) + tmpz(1,2,ip) * yy(2,ip)
6422 : 30 : fb(j) = tmpz(2,1,ip) * yy(1,ip) + tmpz(2,2,ip) * yy(2,ip)
6423 : : ENDDO
6424 [ - + - - : 5 : DO j = jj1,jj2,isgn
- + ]
6425 : 9353 : arp = yy(1,j-isgn)
6426 : 9353 : brp = yy(2,j-isgn)
6427 [ + + - + ]: 9353 : IF (ABS(arp)>verylarge.OR.brp>verylarge) THEN
6428 : 2 : scale=1._dp/(ABS(arp)+ABS(brp))
6429 : 2 : arp=arp*scale
6430 : 2 : brp=brp*scale
6431 [ + + + + ]: 28 : fa(:)=fa(:)*scale; fb(:)=fb(:)*scale
6432 [ + + + + ]: 21359 : yy=yy*scale
6433 : : ENDIF
6434 [ + + ]: 56118 : DO i = 1,5
6435 : 46765 : arp = arp + DBLE(isgn) * abp(i) * fa(i)
6436 : 56118 : brp = brp + DBLE(isgn) * abp(i) * fb(i)
6437 : : ENDDO
6438 : 9353 : fa(0) = tmpz(1,1,j) * arp + tmpz(1,2,j) * brp
6439 : 9353 : fb(0) = tmpz(2,1,j) * arp + tmpz(2,2,j) * brp
6440 : 9353 : yy(1,j) = yy(1,j-isgn)
6441 : 9353 : yy(2,j) = yy(2,j-isgn)
6442 [ + + ]: 56118 : DO i = 0,4,1
6443 : 46765 : yy(1,j) = yy(1,j) + DBLE(isgn) * amc(i) * fa(i)
6444 : 56118 : yy(2,j) = yy(2,j) + DBLE(isgn) * amc(i) * fb(i)
6445 : : ENDDO
6446 [ + + ]: 46765 : DO i = 5,2,-1
6447 : 37412 : fa(i) = fa(i-1)
6448 : 46765 : fb(i) = fb(i-1)
6449 : : ENDDO
6450 : 9353 : fa(1) = tmpz(1,1,j) * yy(1,j) + tmpz(1,2,j) * yy(2,j)
6451 [ + + ]: 9353 : fb(1) = tmpz(2,1,j) * yy(1,j) + tmpz(2,2,j) * yy(2,j)
6452 : : ENDDO
6453 [ - + ]: 5 : LIBPAW_DEALLOCATE(tmpz)
6454 : 5 : END SUBROUTINE cfdsol
6455 : :
6456 : :
6457 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6458 : : !! SUBROUTINE cfdsoliter(Grid,zz,yy,jj1,jj2)
6459 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6460 [ - + - + ]: 70260 : SUBROUTINE cfdsoliter(Grid,zz,yy,jj1,jj2)
6461 : : TYPE(gridinfo), INTENT(IN) :: Grid
6462 : : real(dp), INTENT(IN):: zz(:,:,:)
6463 : : real(dp), INTENT(INOUT):: yy(:,:)
6464 : : INTEGER, INTENT(IN) :: jj1,jj2
6465 : : real(dp):: fa(0:5),fb(0:5),abp(1:5),amc(0:4),yprev(2),ycorr(2)
6466 : : INTEGER :: isgn,i,j,ip,mesh,k
6467 : : INTEGER, PARAMETER :: CORRITER=5
6468 : : real(dp):: arp,brp
6469 : 70260 : real(dp), ALLOCATABLE :: tmpz(:,:,:)
6470 : : real(dp), PARAMETER :: verylarge=10._dp, smallenough=tol5
6471 : : real(dp) :: scale,small
6472 : 70260 : mesh=SIZE(yy(2,:))
6473 [ - + ]: 70260 : IF (SIZE(zz(2,2,:))/=mesh) THEN
6474 : 0 : LIBPAW_ERROR('cfdsol error - incompatible arrays')
6475 : : ENDIF
6476 [ + + ]: 70260 : isgn = ( jj2 - jj1 ) / iabs( jj2 - jj1 )
6477 [ + + ]: 70260 : IF ( isgn .EQ. + 1 ) THEN
6478 [ + - - + ]: 35357 : IF ( jj1 .LE. 5 .OR. jj2 .GT. mesh ) THEN
6479 : 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6480 : : ENDIF
6481 : : ELSEIF ( isgn .EQ. - 1 ) THEN
6482 [ + - - + ]: 34903 : IF ( jj1 .GE. ( mesh - 4 ) .OR. jj2 .LT. 1 ) THEN
6483 : 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6484 : : ENDIF
6485 : : ELSE
6486 : : if(has_to_print) WRITE(STD_OUT,*) isgn,jj1,jj2,mesh
6487 : : ENDIF
6488 [ - + + - : 210780 : LIBPAW_ALLOCATE(tmpz,(2,2,mesh))
+ - + - -
+ - + ]
6489 [ + - + - : 984272340 : tmpz=zz
+ - - + -
- + + + +
+ + ]
6490 [ + + ]: 210780 : DO i=1,2
6491 [ + + ]: 491820 : DO j=1,2
6492 [ + + ]: 562642080 : tmpz(i,j,:)=tmpz(i,j,:)*Grid%h
6493 [ + - + + ]: 562782600 : if (Grid%TYPE==loggrid) tmpz(i,j,1:mesh)=tmpz(i,j,1:mesh)*Grid%drdu(1:mesh)
6494 : : ENDDO
6495 : : ENDDO
6496 : 70260 : abp(1) = 1901._dp / 720._dp
6497 : 70260 : abp(2) = -1387._dp / 360._dp
6498 : 70260 : abp(3) = 109._dp / 30._dp
6499 : 70260 : abp(4) = -637._dp / 360._dp
6500 : 70260 : abp(5) = 251._dp / 720._dp
6501 : : amc(0) = 251._dp / 720._dp
6502 : 70260 : amc(1) = 323._dp / 360._dp
6503 : 70260 : amc(2) = -11._dp / 30._dp
6504 : 70260 : amc(3) = 53._dp / 360._dp
6505 : 70260 : amc(4) = -19._dp / 720._dp
6506 [ + + ]: 421560 : DO j = 1,5
6507 : 351300 : ip = jj1 - isgn * j
6508 : 351300 : fa(j) = tmpz(1,1,ip) * yy(1,ip) + tmpz(1,2,ip) * yy(2,ip)
6509 : 421560 : fb(j) = tmpz(2,1,ip) * yy(1,ip) + tmpz(2,2,ip) * yy(2,ip)
6510 : : ENDDO
6511 [ + + + - : 70260 : DO j = jj1,jj2,isgn
- + ]
6512 : 70851796 : arp = yy(1,j-isgn)
6513 : 70851796 : brp = yy(2,j-isgn)
6514 [ + + + + ]: 70851796 : IF (ABS(arp)>verylarge.OR.brp>verylarge) THEN
6515 : 3534670 : scale=1._dp/(ABS(arp)+ABS(brp))
6516 : 3534670 : arp=arp*scale
6517 : 3534670 : brp=brp*scale
6518 [ + + + + ]: 49485380 : fa(:)=fa(:)*scale; fb(:)=fb(:)*scale
6519 [ + + + + ]: 21289475806 : yy=yy*scale
6520 : : ENDIF
6521 [ + + ]: 425110776 : DO i = 1,5
6522 : 354258980 : arp = arp + DBLE(isgn) * abp(i) * fa(i)
6523 : 425110776 : brp = brp + DBLE(isgn) * abp(i) * fb(i)
6524 : : ENDDO
6525 : 70851796 : fa(0) = tmpz(1,1,j) * arp + tmpz(1,2,j) * brp
6526 : 70851796 : fb(0) = tmpz(2,1,j) * arp + tmpz(2,2,j) * brp
6527 : 70851796 : yprev(1) = arp
6528 : 70851796 : yprev(2) = brp
6529 : 70851796 : ycorr(1) = yy(1,j-isgn)
6530 : 70851796 : ycorr(2) = yy(2,j-isgn)
6531 [ + + ]: 354258980 : DO i = 1,4,1
6532 : 283407184 : ycorr(1) = ycorr(1) + DBLE(isgn) * amc(i) * fa(i)
6533 : 354258980 : ycorr(2) = ycorr(2) + DBLE(isgn) * amc(i) * fb(i)
6534 : : ENDDO
6535 [ + + ]: 122991676 : DO k=1,CORRITER
6536 : 115269584 : yy(1,j)=ycorr(1) + DBLE(isgn) * amc(0) * fa(0)
6537 : 115269584 : yy(2,j)=ycorr(2) + DBLE(isgn) * amc(0) * fb(0)
6538 : 115269584 : small=abs(yprev(1))+abs(yprev(2))
6539 : 115269584 : small=(abs(yprev(1)-yy(1,j))+abs(yprev(2)-yy(2,j)))/small
6540 [ + + ]: 115269584 : if(small.le.smallenough) exit
6541 : 52139880 : yprev(1)= yy(1,j)
6542 : 52139880 : yprev(2)= yy(2,j)
6543 : 52139880 : fa(0) = tmpz(1,1,j) * yprev(1) + tmpz(1,2,j) * yprev(2)
6544 : 122991676 : fb(0) = tmpz(2,1,j) * yprev(1) + tmpz(2,2,j) * yprev(2)
6545 : : ENDDO
6546 [ + + ]: 354258980 : DO i = 5,2,-1
6547 : 283407184 : fa(i) = fa(i-1)
6548 : 354258980 : fb(i) = fb(i-1)
6549 : : ENDDO
6550 : 70851796 : fa(1) = tmpz(1,1,j) * yy(1,j) + tmpz(1,2,j) * yy(2,j)
6551 [ + + ]: 70851796 : fb(1) = tmpz(2,1,j) * yy(1,j) + tmpz(2,2,j) * yy(2,j)
6552 : : ENDDO
6553 [ - + ]: 70260 : LIBPAW_DEALLOCATE(tmpz)
6554 : 70260 : END SUBROUTINE cfdsoliter
6555 : :
6556 : :
6557 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6558 : : !! subroutine findh_given_r0(Z,range,r0,n,hval)
6559 : : !! find hval for fixed number of input grid points n in loggrid case
6560 : : !! assumes form r(i)=(r0/Z)*(exp(h*(i-1))-1);
6561 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6562 : 0 : SUBROUTINE findh_given_r0(Z,range,r0,n,hval)
6563 : : INTEGER, INTENT(IN) :: n
6564 : : real(dp), INTENT(IN) :: Z,range,r0
6565 : : real(dp), INTENT(INOUT) :: hval
6566 : 0 : hval=log((Z*range/r0 + 1._dp))/(n-1)
6567 : 0 : end subroutine findh_given_r0
6568 : :
6569 : :
6570 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6571 : : !! subroutine findh(Z,range,n,hval,r0)
6572 : : !! find hval for fixed number of input grid points n in loggrid case
6573 : : !! assumes form r(i)=(h/Z)*(exp(h*(i-1))-1); r0=h/Z
6574 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6575 : 4 : SUBROUTINE findh(Z,range,n,hval,r0)
6576 : : real(dp), INTENT(IN) :: Z
6577 : : INTEGER, INTENT(IN) :: n
6578 : : real(dp), INTENT(IN) :: range
6579 : : real(dp), INTENT(INOUT) :: hval,r0
6580 : : real(dp) :: h0,dh,f,df
6581 : : INTEGER :: i
6582 : : INTEGER, parameter :: iter=1000
6583 : : real(dp), parameter :: eps=1.e-15
6584 : : LOGICAL :: success
6585 : 4 : h0=hval
6586 : 4 : success=.false.
6587 [ + - ]: 34 : do i=1,iter
6588 : 34 : f=LOG(Z*range/h0+1._dp)/h0
6589 : 34 : df=-f/h0-(Z*range/h0**3)/(Z*range/h0+1._dp)
6590 : 34 : dh=(n-1-f)/df
6591 [ + + ]: 34 : if (ABS(dh)< eps) then
6592 : : success=.true.
6593 : : exit
6594 : : endif
6595 [ + + ]: 30 : if (h0+dh<0._dp) then
6596 : 4 : h0=h0/2
6597 : : else
6598 : 26 : h0=h0+dh
6599 : : endif
6600 : : enddo
6601 [ - + ]: 4 : if (.not.success) then
6602 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'Warning in findh -- dh > eps ', dh,h0
6603 : : endif
6604 : 4 : hval=h0
6605 : 4 : r0=hval/Z
6606 : 4 : end subroutine findh
6607 : :
6608 : :
6609 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6610 : : !! subroutine initgrid(Grid,h,range,r0)
6611 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6612 : 4 : SUBROUTINE InitGrid(Grid,h,range,r0,do_not_print,pawrad)
6613 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
6614 : : real(dp), INTENT(IN) :: range
6615 : : real(dp), INTENT(IN) :: h
6616 : : real(dp), OPTIONAL, INTENT(IN) :: r0
6617 : : LOGICAL, OPTIONAL, INTENT(IN) :: do_not_print
6618 : : TYPE(pawrad_type),optional, INTENT(IN) :: pawrad
6619 : : INTEGER :: i,n
6620 : : LOGICAL :: do_print
6621 [ - + ]: 4 : do_print=.false.;if (present(do_not_print)) do_print=.not.do_not_print
6622 [ - + ]: 4 : if (present(pawrad)) then
6623 [ # # ]: 0 : if (pawrad%mesh_type/=2) then
6624 : 0 : LIBPAW_ERROR("Error wrong pawrad grid")
6625 : 0 : STOP
6626 : : end if
6627 : 0 : Grid%n=pawrad%mesh_size
6628 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%r,(Grid%n))
# # # # #
# # # ]
6629 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%drdu,(Grid%n))
# # # # ]
6630 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%pref,(Grid%n))
# # # # ]
6631 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%rr02,(Grid%n))
# # # # ]
6632 [ # # ]: 0 : Grid%r(:)=pawrad%rad(:)
6633 [ # # ]: 0 : Grid%drdu(:)=pawrad%radfact(:)
6634 [ # # ]: 0 : Grid%rr02(:)=pawrad%radfact(:)**2
6635 [ # # ]: 0 : Grid%pref(:)=(pawrad%radfact(:)*pawrad%rstep)**2
6636 : 0 : Grid%r0=pawrad%rstep
6637 : 0 : Grid%range=pawrad%rmax
6638 : 0 : Grid%h=pawrad%lstep
6639 : 0 : Grid%type=loggrid
6640 : 0 : Grid%ishift=5
6641 : : else
6642 [ + - ]: 4 : IF (PRESENT(r0)) THEN
6643 : 4 : Grid%h=h
6644 : 4 : Grid%r0=r0
6645 : 4 : Grid%type=loggrid
6646 : 4 : Grid%range=range
6647 : 4 : n=LOG(range/r0+1)/h+1
6648 : 4 : Grid%ishift=5
6649 [ - + ]: 4 : IF (r0*(EXP(h*(n-1))-1)<range-tol5) n=n+1
6650 : 4 : Grid%n=n
6651 [ - + ]: 4 : if (do_print) write(std_out,*) 'InitGrid: -- logarithmic ',n, h,range,r0
6652 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(Grid%r,(n))
+ - + - -
+ - + ]
6653 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(Grid%drdu,(n))
- + - + ]
6654 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(Grid%pref,(n))
- + - + ]
6655 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(Grid%rr02,(n))
- + - + ]
6656 [ + + ]: 8008 : DO i=1,n
6657 : 8004 : Grid%r(i)=r0*(EXP(Grid%h*(i-1))-1)
6658 : 8004 : Grid%drdu(i)=r0*EXP(Grid%h*(i-1))
6659 : 8004 : Grid%pref(i)=r0*EXP(Grid%h*(i-1)/2._dp)
6660 : 8008 : Grid%rr02(i)=(Grid%r(i)+r0)**2
6661 : : ENDDO
6662 : : ELSE
6663 : 0 : Grid%h=h
6664 : 0 : Grid%r0=0._dp
6665 : 0 : Grid%type=lineargrid
6666 : 0 : Grid%range=range
6667 : 0 : n=range/h+1
6668 : 0 : Grid%ishift=25
6669 [ # # ]: 0 : IF (h*(n-1)<range-tol5) n=n+1
6670 : 0 : Grid%n=n
6671 [ # # ]: 0 : if (do_print) write(std_out,*) 'InitGrid: -- linear ', n,h,range
6672 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%r,(n))
# # # # #
# # # ]
6673 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%drdu,(n))
# # # # ]
6674 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%pref,(n))
# # # # ]
6675 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%rr02,(n))
# # # # ]
6676 [ # # ]: 0 : DO i=1,n
6677 : 0 : Grid%r(i)=(Grid%h*(i-1))
6678 : 0 : Grid%drdu(i)=1._dp
6679 : 0 : Grid%pref(i)=1._dp
6680 : 0 : Grid%rr02(i)=1._dp
6681 : : ENDDO
6682 : : ENDIF
6683 : : endif
6684 : 4 : END SUBROUTINE InitGrid
6685 : :
6686 : :
6687 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6688 : : !! subroutine destroygrid(Grid)
6689 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6690 : 8 : SUBROUTINE DestroyGrid(Grid)
6691 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
6692 [ + + ]: 8 : IF (ASSOCIATED(Grid%r)) then
6693 : 4 : LIBPAW_POINTER_DEALLOCATE(Grid%r)
6694 : : endif
6695 [ + + ]: 8 : IF (ASSOCIATED(Grid%drdu)) then
6696 : 4 : LIBPAW_POINTER_DEALLOCATE(Grid%drdu)
6697 : : endif
6698 [ + + ]: 8 : IF (ASSOCIATED(Grid%pref)) then
6699 : 4 : LIBPAW_POINTER_DEALLOCATE(Grid%pref)
6700 : : endif
6701 [ + + ]: 8 : IF (ASSOCIATED(Grid%rr02)) then
6702 : 4 : LIBPAW_POINTER_DEALLOCATE(Grid%rr02)
6703 : : endif
6704 : 8 : END SUBROUTINE DestroyGrid
6705 : :
6706 : :
6707 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6708 : : !! subroutine nullifygrid(Grid)
6709 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6710 : : SUBROUTINE NullifyGrid(Grid)
6711 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
6712 : : NULLIFY(Grid%r)
6713 : : NULLIFY(Grid%drdu)
6714 : : NULLIFY(Grid%pref)
6715 : : NULLIFY(Grid%rr02)
6716 : : END SUBROUTINE NullifyGrid
6717 : :
6718 : :
6719 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6720 : : !! SUBROUTINE backward_numerov(Grid,l,match,energy,rv,wfn,wgt,nend,proj)
6721 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6722 [ - + - - : 5131 : SUBROUTINE backward_numerov(Grid,l,match,energy,rv,wfn,wgt,nend,proj)
- - - + -
+ - + - -
- - ]
6723 : : TYPE (GridInfo), INTENT(IN) :: Grid
6724 : : INTEGER, INTENT(IN) :: l,match
6725 : : real(dp), INTENT(IN) :: energy,rv(:)
6726 : : real(dp), INTENT(INOUT) :: wfn(:) ! on input wfn(n-1) and wfn(n) given
6727 : : real(dp), INTENT(IN), OPTIONAL :: wgt(:)
6728 : : real(dp), intent(in), optional :: proj(:)
6729 : : integer, intent(in), optional :: nend
6730 : 5131 : real(dp), ALLOCATABLE :: a(:),b(:),p(:),c(:)
6731 : : real(dp) :: angm,h,h2,scale
6732 : : real(dp), PARAMETER :: vlarg=1.d30
6733 : : INTEGER :: i,n
6734 : : LOGICAL :: withwgt
6735 : 5131 : withwgt=.false.
6736 [ - + ]: 5131 : If (PRESENT(wgt)) withwgt=.true.
6737 : 5131 : n=Grid%n
6738 [ - + ]: 5131 : if(present(nend)) n=nend
6739 [ - + + - : 15393 : LIBPAW_ALLOCATE(a,(n))
+ - + - -
+ - + ]
6740 [ - + + - : 10262 : LIBPAW_ALLOCATE(b,(n))
- + - + ]
6741 [ - + + - : 10262 : LIBPAW_ALLOCATE(p,(n))
- + - + ]
6742 [ - + + - : 10262 : LIBPAW_ALLOCATE(c,(n))
- + - + ]
6743 : 5131 : p(n)=wfn(n)
6744 : 5131 : p(n-1)=wfn(n-1)
6745 : 5131 : angm=l*(l+1)
6746 [ + + ]: 10272262 : a=0
6747 [ + + ]: 10272262 : b=0
6748 [ + + ]: 10272262 : c=0
6749 : 5131 : h=Grid%h; h2=h*h
6750 [ + + ]: 3788043 : DO i=match,n
6751 [ - + ]: 3788043 : if(withwgt) then
6752 : 0 : a(i)=rv(i)/Grid%r(i)-energy*wgt(i)+angm/(Grid%r(i)**2)
6753 : : else
6754 : 3782912 : a(i)=rv(i)/Grid%r(i)-energy+angm/(Grid%r(i)**2)
6755 : : endif
6756 : : ENDDO
6757 [ - + - - ]: 5131 : if(present(proj)) b(match:n)=0.1_dp*h2*proj(match:n)
6758 [ + - ]: 5131 : IF (Grid%type==loggrid) THEN
6759 [ + + ]: 15393 : p(n-1:n)=p(n-1:n)/Grid%pref(n-1:n)
6760 [ + + ]: 3788043 : a(match:n)=0.25_dp+Grid%rr02(match:n)*a(match:n)
6761 [ - + - - ]: 5131 : if(present(proj)) b(match:n)=Grid%rr02(match:n)*b(match:n)/Grid%pref(match:n)
6762 : : ENDIF
6763 [ # # ]: 0 : if(present(proj)) then
6764 [ # # ]: 0 : do i=match+1,n-1
6765 : 0 : c(i)=10*b(i)+b(i-1)+b(i+1)
6766 : : enddo
6767 : : endif
6768 [ + + ]: 3788043 : b(match:n)=2.4_dp+h2*a(match:n)
6769 [ + + ]: 3788043 : a(match:n)=1.2_dp-0.1_dp*h2*a(match:n)
6770 [ + + ]: 3777781 : DO i=n-2,match,-1
6771 : 3772650 : p(i)=(b(i+1)*p(i+1)-a(i+2)*p(i+2)-c(i+1))/a(i)
6772 : : !renormalize if necessary
6773 : 3772650 : scale=ABS(p(i))
6774 [ + + ]: 3777781 : IF (scale > vlarg) THEN
6775 : 15262 : scale=1._dp/scale
6776 [ + + ]: 2634457 : p(i:n)=scale*p(i:n)
6777 : : ENDIF
6778 : : ENDDO
6779 [ + + ]: 3788043 : wfn(match:n)=p(match:n)
6780 [ + - ]: 5131 : IF (Grid%type==loggrid) THEN
6781 [ + + ]: 3788043 : wfn(match:n)=wfn(match:n)*Grid%pref(match:n)
6782 : : ENDIF
6783 [ - + ]: 5131 : LIBPAW_DEALLOCATE(a)
6784 [ - + ]: 5131 : LIBPAW_DEALLOCATE(b)
6785 : 5131 : LIBPAW_DEALLOCATE(p)
6786 [ - + ]: 5131 : LIBPAW_DEALLOCATE(c)
6787 : 5131 : END SUBROUTINE backward_numerov
6788 : :
6789 : :
6790 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6791 : : !! SUBROUTINE
6792 : : !forward_numerov(Grid,l,many,energy,rv,zeroval,wfn,nodes,wgt,proj,p3val)
6793 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6794 [ - + - - : 5210 : SUBROUTINE forward_numerov(Grid,l,many,energy,rv,zeroval,wfn,nodes,wgt,proj,p3val)
- - - + -
+ + + + -
- + ]
6795 : : TYPE (GridInfo), INTENT(IN) :: Grid
6796 : : INTEGER, INTENT(IN) :: l,many
6797 : : real(dp), INTENT(IN) :: energy,zeroval,rv(:)
6798 : : real(dp), INTENT(INOUT) :: wfn(:) ! on input wfn(1) and wfn(2) given
6799 : : INTEGER, INTENT(OUT) :: nodes
6800 : : real(dp), INTENT(IN), OPTIONAL :: wgt(:)
6801 : : real(dp), intent(in), optional :: p3val
6802 : : real(dp), intent(in), optional :: proj(:)
6803 : 5210 : real(dp), ALLOCATABLE :: a(:),b(:),p(:),c(:)
6804 : : real(dp) :: xx,angm,h,h2,scale
6805 : : real(dp), PARAMETER :: vlarg=1.d30
6806 : : INTEGER :: i
6807 : : LOGICAL :: withwgt
6808 : 5210 : withwgt=.false.
6809 [ - + ]: 5210 : If (PRESENT(wgt)) withwgt=.true.
6810 [ - + + - : 15630 : LIBPAW_ALLOCATE(a,(many))
+ - + - -
+ - + ]
6811 [ - + + - : 10420 : LIBPAW_ALLOCATE(b,(many))
- + - + ]
6812 [ - + + - : 10420 : LIBPAW_ALLOCATE(p,(many))
- + - + ]
6813 [ - + + - : 10420 : LIBPAW_ALLOCATE(c,(many))
- + - + ]
6814 : 5210 : p(1)=wfn(1)
6815 : 5210 : p(2)=wfn(2)
6816 : 5210 : xx=zeroval
6817 : 5210 : angm=l*(l+1)
6818 [ + + ]: 6668839 : a=0
6819 [ + + ]: 6668839 : c=0
6820 : 5210 : h=Grid%h; h2=h*h
6821 [ + + ]: 6663629 : DO i=2,many
6822 [ - + ]: 6663629 : if (withwgt) then
6823 : 0 : a(i)=rv(i)/Grid%r(i)-energy*wgt(i)+angm/(Grid%r(i)**2)
6824 : : else
6825 : 6658419 : a(i)=rv(i)/Grid%r(i)-energy+angm/(Grid%r(i)**2)
6826 : : endif
6827 : : ENDDO
6828 [ + + + + ]: 73022 : if(present(proj)) b(1:many)=0.1_dp*h2*proj(1:many)
6829 [ + - ]: 5210 : IF (Grid%type==loggrid) THEN
6830 [ + + ]: 15630 : p(1:2)=wfn(1:2)/Grid%pref(1:2)
6831 : 5210 : xx=Grid%rr02(1)*xx/Grid%pref(1)
6832 [ - + + + ]: 6674049 : a=0.25_dp+Grid%rr02(1:many)*a
6833 [ + + + + ]: 73070 : if(present(proj)) b(1:many)=Grid%rr02(1:many)*b(1:many)/Grid%pref(1:many)
6834 : : ENDIF
6835 [ + - ]: 48 : if(present(proj)) then
6836 [ + + ]: 67764 : do i=2,many-1
6837 : 67764 : c(i)=10*b(i)+b(i-1)+b(i+1)
6838 : : enddo
6839 : : endif
6840 [ - + + + ]: 6674049 : b=2.4_dp+h2*a
6841 [ + + ]: 6668839 : a=1.2_dp-0.1_dp*h2*a
6842 : 5210 : p(3)=(b(2)*p(2)+0.1_dp*h2*xx)/a(3)
6843 [ - + ]: 5210 : if(present(p3val)) then
6844 : 0 : p(3)=p3val
6845 [ # # ]: 0 : IF (Grid%type==loggrid) p(3)=p3val/Grid%pref(3)
6846 : : endif
6847 : 5210 : nodes=0
6848 [ + + ]: 6653209 : DO i=4,many
6849 : 6647999 : p(i)=(b(i-1)*p(i-1)-a(i-2)*p(i-2)-c(i-1))/a(i)
6850 [ + + ]: 6647999 : IF (p(i)*p(i-1) < 0._dp) nodes=nodes+1
6851 : : !renormalize if necessary
6852 : 6647999 : scale=ABS(p(i))
6853 [ - + ]: 6653209 : IF (scale > vlarg) THEN
6854 : 0 : scale=1._dp/scale
6855 [ # # ]: 0 : p(1:i)=scale*p(1:i)
6856 : : ENDIF
6857 : : ENDDO
6858 [ + + ]: 6668839 : wfn(1:many)=p(1:many)
6859 [ + - ]: 5210 : IF (Grid%type==loggrid) THEN
6860 [ + + ]: 6668839 : wfn(1:many)=wfn(1:many)*Grid%pref(1:many)
6861 : : ENDIF
6862 : 5210 : LIBPAW_DEALLOCATE(a)
6863 : 5210 : LIBPAW_DEALLOCATE(b)
6864 : 5210 : LIBPAW_DEALLOCATE(p)
6865 [ - + ]: 5210 : LIBPAW_DEALLOCATE(c)
6866 : 5210 : END SUBROUTINE forward_numerov
6867 : :
6868 : :
6869 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6870 : : !! subroutine initgridwithn(Grid,type,n,r0,h)
6871 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6872 : 0 : SUBROUTINE initgridwithn(Grid,type,n,r0,h)
6873 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
6874 : : INTEGER, INTENT(IN) :: type,n !type=1 lin,2 log
6875 : : REAL(dp), INTENT(IN) :: r0,h
6876 : : INTEGER :: i
6877 [ # # ]: 0 : IF (type==loggrid) THEN
6878 : 0 : Grid%h=h
6879 : 0 : Grid%r0=r0
6880 : 0 : Grid%type=loggrid
6881 : 0 : Grid%ishift=5
6882 : 0 : Grid%n=n
6883 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%r,(n))
# # # # #
# # # ]
6884 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%drdu,(n))
# # # # ]
6885 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%pref,(n))
# # # # ]
6886 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%rr02,(n))
# # # # ]
6887 [ # # ]: 0 : DO i=1,n
6888 : 0 : Grid%r(i)=r0*(EXP(Grid%h*(i-1))-1)
6889 : 0 : Grid%drdu(i)=r0*EXP(Grid%h*(i-1))
6890 : 0 : Grid%pref(i)=r0*EXP(Grid%h*(i-1)/2._dp)
6891 : 0 : Grid%rr02(i)=(Grid%r(i)+r0)**2
6892 : : ENDDO
6893 : 0 : Grid%range=Grid%r(n)
6894 [ # # ]: 0 : if(has_to_print)WRITE(STD_OUT,*) 'InitGridwithn: -- logarithmic ',n, h,Grid%range,r0
6895 [ # # ]: 0 : ELSEIF (type==lineargrid) THEN
6896 : 0 : Grid%h=h
6897 : 0 : Grid%r0=0._dp
6898 : 0 : Grid%type=lineargrid
6899 : 0 : Grid%ishift=25
6900 : 0 : Grid%n=n
6901 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%r,(n))
# # # # #
# # # ]
6902 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%drdu,(n))
# # # # ]
6903 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%pref,(n))
# # # # ]
6904 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%rr02,(n))
# # # # ]
6905 [ # # ]: 0 : DO i=1,n
6906 : 0 : Grid%r(i)=(Grid%h*(i-1))
6907 : 0 : Grid%drdu(i)=1._dp
6908 : 0 : Grid%pref(i)=1._dp
6909 : 0 : Grid%rr02(i)=1._dp
6910 : : ENDDO
6911 : 0 : Grid%range=Grid%r(n)
6912 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'InitGridwithn: -- linear ',n, h,Grid%range,r0
6913 : : ELSE
6914 : 0 : write(std_out,*) 'error in initgridwithn -- type =',type
6915 : 0 : stop
6916 : : ENDIF
6917 : 0 : END SUBROUTINE initgridwithn
6918 : :
6919 : :
6920 : :
6921 : :
6922 : :
6923 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6924 : : ! 10. pseudo
6925 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6926 : :
6927 : :
6928 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6929 : : !! SUBROUTINE sethat(Grid,PAW,gaussparam,besselopt)
6930 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6931 : :
6932 : :
6933 : 2 : SUBROUTINE sethat(Grid,PAW,gaussparam,besselopt)
6934 : : TYPE(GridInfo), INTENT(IN) :: Grid
6935 : : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
6936 : : INTEGER,INTENT(IN), OPTIONAL :: besselopt
6937 : : REAL(dp),INTENT(IN), OPTIONAL :: gaussparam
6938 : : INTEGER :: n,irc,irc_shap,i
6939 : 2 : REAL(dp), POINTER :: r(:)
6940 : : REAL(dp) :: h,con,rc,rc_shap,selfen,d,dd,jbes1,jbes2,qr
6941 : : REAL(dp) :: al(2),ql(2)
6942 : 2 : n=Grid%n
6943 : 2 : h=Grid%h
6944 : 2 : irc=PAW%irc
6945 : 2 : rc=PAW%rc
6946 : 2 : irc_shap=PAW%irc_shap
6947 : 2 : rc_shap=PAW%rc_shap
6948 : 2 : r=>Grid%r
6949 [ + + ]: 4004 : PAW%hatden=0
6950 [ + + ]: 4004 : PAW%projshape=0
6951 [ + + ]: 4004 : PAW%hatshape=0
6952 : 2 : PAW%projshape(1)=1
6953 : 2 : PAW%hatshape(1)=1
6954 [ + + ]: 2825 : DO i=2,irc-1
6955 : 2825 : PAW%projshape(i)=(SIN(pi*r(i)/rc)/(pi*r(i)/rc))**2
6956 : : ENDDO
6957 [ - + ]: 2 : if(present(gaussparam)) then
6958 : 0 : d=rc_shap/SQRT(LOG(1._dp/gaussparam))
6959 : 0 : PAW%gausslength=d
6960 [ # # ]: 0 : DO i=2,irc
6961 : 0 : PAW%hatshape(i)=EXP(-(r(i)/d)**2)
6962 : : ENDDO
6963 : 0 : PAW%irc_shap=PAW%irc
6964 : 0 : PAW%rc_shap=PAW%rc
6965 [ - + ]: 2 : else if(present(besselopt)) then
6966 : 0 : call shapebes(al,ql,0,rc_shap)
6967 [ # # ]: 0 : DO i=1,irc_shap-1
6968 : 0 : qr=ql(1)*r(i);CALL jbessel(jbes1,d,dd,0,0,qr)
6969 : 0 : qr=ql(2)*r(i);CALL jbessel(jbes2,d,dd,0,0,qr)
6970 : 0 : PAW%hatshape(i)=al(1)*jbes1+al(2)*jbes2
6971 : : ENDDO
6972 : : else
6973 [ + + ]: 2809 : DO i=2,irc_shap-1
6974 : 2809 : PAW%hatshape(i)=(SIN(pi*r(i)/rc_shap)/(pi*r(i)/rc_shap))**2
6975 : : ENDDO
6976 : : endif
6977 [ + + ]: 2829 : PAW%hatden(1:irc)=PAW%hatshape(1:irc)*(r(1:irc)**2)
6978 : : ! normalize
6979 [ + - ]: 2 : if (.not.present(besselopt)) then
6980 : 2 : con=integrator(Grid,PAW%hatden,1,PAW%irc_shap)
6981 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) ' check hatden normalization', con
6982 [ + + ]: 4004 : PAW%hatden=PAW%hatden/con
6983 : : endif
6984 : 2 : CALL atompaw_poisson(Grid,con,PAW%hatden,PAW%hatpot,selfen)
6985 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'Self energy for L=0 hat density ', selfen
6986 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'hatden charge ', con
6987 : 2 : END SUBROUTINE sethat
6988 : :
6989 : :
6990 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6991 : : !! SUBROUTINE FindVlocfromVeff(Grid,Orbit,PAW)
6992 : : ! Assumes prior call to SUBROUTINE calculate_tvtau
6993 : : ! which now fills PAW%tden and PAW%ttau
6994 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6995 : 0 : SUBROUTINE FindVlocfromVeff(Grid,PAW,atp,potshift)
6996 : : ! TODO : needvtau,allocates
6997 : : TYPE(GridInfo), INTENT(INOUT) :: Grid
6998 : : type(atompaw_type),intent(inout) :: atp
6999 : : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
7000 : : real(dp),intent(in) :: potshift
7001 : 0 : REAL(dp), POINTER :: r(:)
7002 : : REAL(dp) :: h,tq,rat,q00,etxc,eexc
7003 : : INTEGER :: n,irc,nbase
7004 : : REAL(dp), allocatable :: d(:),v(:),vxB(:),vxK(:)
7005 : : REAL(dp), allocatable :: t(:),vt(:),vthat(:)
7006 : 0 : CALL FillHat(Grid,PAW,atp%besselshapefunction)
7007 : : !if (Vlocalindex == SETVLOC) then
7008 : : ! write(std_out,*) 'Vloc == VlocCoef*shapefunc '
7009 : : ! return
7010 : : !endif
7011 : 0 : n=Grid%n;irc=PAW%irc
7012 : 0 : nbase=PAW%nbase
7013 : 0 : h=Grid%h ; r=>Grid%r
7014 : 0 : irc=max(PAW%irc,PAW%irc_shap,PAW%irc_vloc,PAW%irc_core)
7015 : : ! Recalculate den and tau
7016 [ # # # # ]: 0 : PAW%valetau=0._dp;PAW%tvaletau=0._dp
7017 [ # # # # : 0 : LIBPAW_ALLOCATE(d,(n))
# # # # #
# # # ]
7018 [ # # # # : 0 : LIBPAW_ALLOCATE(vxB,(n))
# # # # ]
7019 [ # # # # : 0 : LIBPAW_ALLOCATE(v,(n))
# # # # ]
7020 [ # # # # : 0 : LIBPAW_ALLOCATE(vxK,(n))
# # # # ]
7021 [ # # # # : 0 : LIBPAW_ALLOCATE(t,(n))
# # # # ]
7022 [ # # # # : 0 : LIBPAW_ALLOCATE(vt,(n))
# # # # ]
7023 [ # # # # : 0 : LIBPAW_ALLOCATE(vthat,(n))
# # # # ]
7024 [ # # # # : 0 : d=PAW%den-PAW%tden
# # # # ]
7025 : 0 : tq=integrator(Grid,d,1,irc)
7026 [ # # ]: 0 : if(has_to_print) write(std_out,*) ' Delta Qval = ', tq
7027 : : ! Compute VH(tDEN+hatDEN)
7028 [ # # # # : 0 : d=PAW%tden+tq*PAW%hatden
# # # # ]
7029 : 0 : call poisson_marc(Grid,q00,d,v,rat)
7030 [ # # ]: 0 : if(has_to_print) write(std_out,*) ' Completed Poisson with q00 = ', q00
7031 [ # # ]: 0 : if(has_to_print) write(std_out,*) ' Completed Poisson with v(n) = ', v(n)
7032 : : ! Compute Blochl exc
7033 [ # # # # : 0 : d=PAW%tden+PAW%tcore
# # # # ]
7034 [ # # # # : 0 : t=PAW%tcoretau+PAW%tvaletau
# # # # ]
7035 : : CALL exch(Grid,d,vxB,etxc,eexc,itype=atp%itype,needvtau=atp%Pot%needvtau,&
7036 : 0 : & tau=t,vtau=vt,xc_functionals=atp%xc_functionals)
7037 : : ! Compute Kresse exc Vxc(tcore+tDEN+hatDEN)
7038 [ # # # # : 0 : d=PAW%tcore+PAW%tden+tq*PAW%hatden
# # # # ]
7039 [ # # # # : 0 : t=PAW%tcoretau+PAW%tvaletau
# # # # ]
7040 : : CALL exch(Grid,d,vxK,etxc,eexc,itype=atp%itype,needvtau=atp%Pot%needvtau,&
7041 : 0 : & tau=t,vtau=vthat,xc_functionals=atp%xc_functionals)
7042 [ # # # # ]: 0 : PAW%abinitvloc=zero; PAW%abinitnohat=zero
7043 [ # # ]: 0 : PAW%abinitnohat(2:n)=(PAW%rveff(2:n)-v(2:n)-vxB(2:n))/r(2:n)+potshift
7044 : 0 : call extrapolate(PAW%abinitnohat)
7045 [ # # ]: 0 : PAW%abinitvloc(2:n)=(PAW%rveff(2:n)-v(2:n)-vxK(2:n))/r(2:n)+potshift
7046 : 0 : call extrapolate(PAW%abinitvloc)
7047 : : ! Reassess poscorenhat
7048 : : ! check if PAW%tcore+PAW%tden+tq*PAW%hatden is positive
7049 : 0 : PAW%poscorenhat=.true.
7050 [ # # ]: 0 : LIBPAW_DEALLOCATE(v)
7051 [ # # ]: 0 : LIBPAW_DEALLOCATE(vxB)
7052 [ # # ]: 0 : LIBPAW_DEALLOCATE(vxK)
7053 [ # # ]: 0 : LIBPAW_DEALLOCATE(d)
7054 [ # # ]: 0 : LIBPAW_DEALLOCATE(vt)
7055 [ # # ]: 0 : LIBPAW_DEALLOCATE(vthat)
7056 [ # # ]: 0 : END SUBROUTINE FindVlocfromVeff
7057 : :
7058 : :
7059 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7060 : : !! SUBROUTINE SetPAWOptions2(Grid,Orbit,Pot,success,atp)
7061 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7062 : 2 : SUBROUTINE SetPAWOptions2(atp,success)
7063 : : LOGICAL , INTENT(OUT) :: success
7064 : : type(atompaw_type), intent(inout) :: atp
7065 : : INTEGER :: l
7066 : : integer :: Projectorindex,Vlocalindex
7067 : : real(dp) :: e
7068 : 2 : success=.true.
7069 : : IF (atp%projector_type==PROJECTOR_TYPE_MARSMAN) Projectorindex=MARSMAN
7070 : : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER) Vlocalindex=MTROULLIER
7071 [ - + ]: 2 : IF (atp%vloc_type==VLOC_TYPE_ULTRASOFT) Vlocalindex=ULTRASOFT
7072 [ - + ]: 2 : IF (atp%vloc_type==VLOC_TYPE_BESSEL) Vlocalindex=BESSEL
7073 [ - + ]: 2 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNC) Vlocalindex=VPSMATCHNC
7074 [ + - ]: 2 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNNC) Vlocalindex=VPSMATCHNNC
7075 : : !Store the description of Vloc scheme in a string
7076 [ + - ]: 2 : if (Vlocalindex==MTROULLIER) then
7077 : 2 : l=atp%vloc_l ; e=atp%vloc_ene
7078 [ - + ]: 2 : if(has_to_print) then
7079 : : WRITE(atp%PAW%Vloc_description,&
7080 : 0 : & '("Vloc: Norm-conserving Troullier-Martins with l=",i1,";e=",1p,1e12.4)')l,e
7081 : : endif
7082 : : endif
7083 [ - + ]: 2 : if (Vlocalindex==ULTRASOFT) then
7084 : 0 : l=atp%vloc_l ; e=atp%vloc_ene
7085 [ # # ]: 0 : if(has_to_print) then
7086 : : WRITE(atp%PAW%Vloc_description,&
7087 : 0 : & '("Vloc: Non norm-conserving form with l= ",i1,";e= ",1p,1e12.4)')l,e
7088 : : endif
7089 : : endif
7090 [ - + ]: 2 : if (Vlocalindex==BESSEL) then
7091 [ # # ]: 0 : if(has_to_print) then
7092 : : WRITE(atp%PAW%Vloc_description,&
7093 : 0 : & '("Vloc: truncated form - Vps(r)=A.sin(qr)/r for r<rc")')
7094 : : endif
7095 : : endif
7096 : : !Shape function parameters (from input dataset)
7097 [ - + ]: 2 : if (atp%shapefunc_type==SHAPEFUNC_TYPE_GAUSSIAN) then
7098 : 0 : atp%gaussianshapefunction=.true.
7099 : 0 : CALL sethat(atp%Grid,atp%PAW,gaussparam=atp%shapefunc_gaussian_param) !Gaussian shape function
7100 [ - + ]: 2 : else if (atp%shapefunc_type==SHAPEFUNC_TYPE_BESSEL) then
7101 : 0 : atp%besselshapefunction=.true.
7102 : 0 : CALL sethat(atp%Grid,atp%PAW,besselopt=0) ! Bessel shape function
7103 : : else
7104 : 2 : CALL sethat(atp%Grid,atp%PAW) ! sinc^2 shape function
7105 : : endif
7106 : : !Call the routine computing Vloc - Not mGGA
7107 [ + - ]: 2 : IF (.NOT.atp%needvtau) THEN
7108 [ + - ]: 2 : IF (Vlocalindex==MTROULLIER.and.Projectorindex/=HFPROJ) THEN
7109 : 2 : CALL troullier(atp%Grid,atp%Pot,atp%PAW,l,e,atp%needvtau,atp%scalarrelativistic)
7110 : : ENDIF
7111 [ - + ]: 2 : IF (Vlocalindex==ULTRASOFT) CALL nonncps(atp%Grid,atp%Pot,atp%PAW,l,e,atp%scalarrelativistic)
7112 [ - + ]: 2 : IF (Vlocalindex==BESSEL) CALL besselps(atp%Grid,atp%Pot,atp%PAW)
7113 : 2 : call makebasis_marsman(atp)
7114 : : ENDIF
7115 : : !Call the routine computing Vloc - mGGA case
7116 : : ! IF (atp%needvtau) THEN
7117 : : ! !All compatibility checks in input_dataset_read routine
7118 : : ! if(has_to_print) WRITE(STD_OUT,*) 'Sequence of dataset construction modified for MGGA'
7119 : : ! if(has_to_print) WRITE(STD_OUT,*) ' Not all possibilites tested carefully yet.... '
7120 : : ! if(has_to_print) WRITE(STD_OUT,*) ' Some possibilites not yet programmed.... '
7121 : : ! !Calculate PAW%vtau and PAW%tvtau
7122 : : ! CALL calculate_tvtau(atp%Grid,atp%PAW,atp%itype)
7123 : : ! !Set pseudoptentials
7124 : : ! ! IF (Vlocalindex==MTROULLIER.and.(TRIM(atp%Orbit%exctype)/='HF')) then
7125 : : ! ! if(has_to_print) WRITE(STD_OUT,*) 'TROULLIER PS not available for MGGA '
7126 : : ! ! if(has_to_print) WRITE(STD_OUT,*) ' calling VPSmatch with norm conservation instead '
7127 : : ! ! CALL VPSmatch(atp%Grid,atp%Pot,atp%PAW,l,e,.true.,atp%scalarrelativistic)
7128 : : ! ! ENDIF
7129 : : ! IF (Vlocalindex==VPSMATCHNNC) CALL VPSmatch(atp%Grid,atp%Pot,atp%PAW,l,e,.false.,atp%scalarrelativistic)
7130 : : ! IF (Vlocalindex==VPSMATCHNC) CALL VPSmatch(atp%Grid,atp%Pot,atp%PAW,l,e,.true.,atp%scalarrelativistic)
7131 : : ! IF (Vlocalindex==ULTRASOFT) CALL nonncps(atp%Grid,atp%Pot,atp%PAW,l,e,atp%scalarrelativistic)
7132 : : ! IF (Vlocalindex==BESSEL) CALL besselps(atp%Grid,atp%Pot,atp%PAW)
7133 : : ! !Calculate projectors
7134 : : ! call makebasis_marsman(atp)
7135 : : ! ENDIF
7136 : : !Output in summary file
7137 [ - + ]: 2 : IF (atp%needvtau) THEN
7138 [ # # ]: 0 : if(has_to_print) WRITE(std_out,*) 'Sequence of dataset construction steps modified for mGGA'
7139 [ # # ]: 0 : if(has_to_print) WRITE(std_out,*) 'Only projectors from Vanderbilt scheme available'
7140 : : ENDIF
7141 : 2 : CALL StoreTOCCWFN(atp%PAW)
7142 : 2 : END SUBROUTINE SetPAWOptions2
7143 : :
7144 : :
7145 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7146 : : !! SUBROUTINE Troullier(Grid,Pot,PAW,l,e,needvtau,scalarrelativistic)
7147 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7148 : 2 : SUBROUTINE Troullier(Grid,Pot,PAW,l,e,needvtau,scalarrelativistic)
7149 : : TYPE(Gridinfo), INTENT(IN) :: Grid
7150 : : TYPE(Potentialinfo), INTENT(INout) :: Pot
7151 : : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
7152 : : INTEGER,INTENT(IN) :: l
7153 : : logical,intent(in) :: needvtau,scalarrelativistic
7154 : : real(dp),INTENT(IN) :: e
7155 : 2 : real(dp), ALLOCATABLE :: VNC(:)
7156 : : real(dp) :: A0,A,B,B0,C,C0,D,F,S
7157 : : real(dp) :: Coef(6),Coef0,Coef0old
7158 : : real(dp) :: h,rc,delta,x,dpp,ddpp,dddpp,ddddpp
7159 : : INTEGER :: i,n,iter,nr,nodes,irc
7160 : : INTEGER, PARAMETER :: niter=5000
7161 : : real(dp), PARAMETER :: small=tol9
7162 : 2 : real(dp), ALLOCATABLE :: wfn(:),p(:),dum(:),aux(:)
7163 : 2 : real(dp), POINTER :: r(:),rv(:)
7164 : 2 : n=Grid%n
7165 : 2 : h=Grid%h
7166 : 2 : r=>Grid%r
7167 : 2 : rv=>Pot%rv
7168 : 2 : nr=min(PAW%irc_vloc+5,n)
7169 : 2 : irc=PAW%irc_vloc
7170 : 2 : rc=PAW%rc_vloc
7171 [ + - + - : 6 : LIBPAW_ALLOCATE(VNC,(n))
+ - - + -
+ ]
7172 [ - + + - : 6 : LIBPAW_ALLOCATE(wfn,(nr))
+ - + - -
+ - + ]
7173 [ - + + - : 4 : LIBPAW_ALLOCATE(p,(nr))
- + - + ]
7174 [ - + + - : 4 : LIBPAW_ALLOCATE(dum,(nr))
- + - + ]
7175 [ - + + - : 4 : LIBPAW_ALLOCATE(aux,(nr))
- + - + ]
7176 [ + + ]: 2 : if (scalarrelativistic) then
7177 : 1 : CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes)
7178 [ - + ]: 1 : else if (needvtau) then
7179 : 0 : CALL unboundked(Grid,Pot,nr,l,e,wfn,nodes)
7180 : : else
7181 : 1 : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,nr,l,e,wfn,nodes)
7182 : : endif
7183 [ - + - - ]: 2 : IF (wfn(irc)<0) wfn=-wfn
7184 [ + + ]: 2773 : dum(1:irc)=(wfn(1:irc)**2)
7185 : 2 : S=integrator(Grid,dum(1:irc),1,irc)
7186 : 2 : A0=LOG(wfn(irc)/(rc**(l+1)))
7187 : 2 : B0=(rc*Gfirstderiv(Grid,irc,wfn)/wfn(irc)-(l+1))
7188 : 2 : C0=rc*(rv(irc)-rc*e)-B0*(B0+2*l+2)
7189 : 2 : D=-rc*(rv(irc)-rc*Gfirstderiv(Grid,irc,rv))-2*B0*C0-2*(l+1)*(C0-B0)
7190 : : F=rc*(2*rv(irc)-rc*(2*Gfirstderiv(Grid,irc,rv) &
7191 : : & -rc*Gsecondderiv(Grid,irc,rv)))+&
7192 : 2 : & 4*(l+1)*(C0-B0)-2*(l+1)*D-2*C0**2-2*B0*D
7193 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'In troullier -- matching parameters',S,A0,B0,C0,D,F
7194 : 2 : delta=1.d10
7195 : 2 : iter=0
7196 : 2 : Coef0=0
7197 [ + + - + ]: 973 : DO WHILE(delta>small.AND.iter<=niter)
7198 : 971 : iter=iter+1
7199 : 971 : A=A0-Coef0
7200 : 971 : B=B0
7201 : 971 : C=C0
7202 : 971 : CALL EvaluateTp(l,A,B,C,D,F,coef)
7203 [ + + ]: 1343969 : dum=0
7204 [ + + ]: 1339114 : DO i=1,irc
7205 : 1338143 : x=(r(i)/rc)**2
7206 : : p(i)=x*(Coef(1)+x*(Coef(2)+x*(Coef(3)+&
7207 : 1338143 : & x*(Coef(4)+x*(Coef(5)+x*Coef(6))))))
7208 : 1339114 : dum(i)=((r(i)**(l+1))*EXP(p(i)))**2
7209 : : ENDDO
7210 : 971 : Coef0old=Coef0
7211 : 971 : x=integrator(Grid,dum(1:irc),1,irc)
7212 : 971 : Coef0=(LOG(S/x))/2
7213 : 971 : delta=ABS(Coef0-Coef0old)
7214 : : ENDDO
7215 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) ' VNC converged in ', iter,' iterations'
7216 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) ' Coefficients -- ', Coef0,Coef(1:6)
7217 : : ! Now calculate VNC
7218 [ - + ]: 2 : if (needvtau) then
7219 [ # # ]: 0 : aux=0._dp
7220 : 0 : call derivative(Grid,PAW%tvtau,aux,1,nr)
7221 : : endif
7222 [ + + ]: 4004 : VNC=0
7223 [ + + ]: 2781 : DO i=2,nr
7224 : 2779 : x=(r(i)/rc)**2
7225 : : p(i)=Coef0+x*(Coef(1)+x*(Coef(2)+&
7226 : 2779 : & x*(Coef(3)+x*(Coef(4)+x*(Coef(5)+x*Coef(6))))))
7227 : : dpp=2*r(i)/(rc**2)*(Coef(1)+x*(2*Coef(2)+x*(3*Coef(3)+&
7228 : 2779 : & x*(4*Coef(4)+x*(5*Coef(5)+x*6*Coef(6))))))
7229 : : ddpp=(1/(rc**2))*(2*Coef(1)+x*(12*Coef(2)+x*(30*Coef(3)+&
7230 : 2779 : & x*(56*Coef(4)+x*(90*Coef(5)+x*132*Coef(6))))))
7231 : : dddpp=(r(i)/rc**4)*(24*Coef(2)+x*(120*Coef(3)+x*(336*Coef(4)+&
7232 : 2779 : & x*(720*Coef(5)+x*1320*Coef(6)))))
7233 : : ddddpp=(1/(rc**4)*(24*Coef(2)+x*(360*Coef(3)+x*(1680*Coef(4)+&
7234 : 2779 : & x*(5040*Coef(5)+x*11880*Coef(6))))))
7235 [ + + ]: 2779 : IF (i==irc) THEN
7236 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'check dp ', dpp, B0/rc
7237 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'check ddp ', ddpp, C0/rc**2
7238 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'check dddp', dddpp, D/rc**3
7239 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'check ddddp', ddddpp, F/rc**4
7240 : : ENDIF
7241 [ - + ]: 2779 : if (needvtau) then
7242 : : VNC(i)=e+(1._dp+PAW%tvtau(i))*(ddpp+dpp*(dpp+2*(l+1)/r(i))) &
7243 : 0 : & +aux(i)*(dpp+l/r(i))
7244 : : else
7245 : 2779 : VNC(i)=e+ddpp+dpp*(dpp+2*(l+1)/r(i))
7246 : : endif
7247 : 2781 : dum(i)=(r(i)**(l+1))*EXP(p(i))
7248 : : ENDDO
7249 : 2 : x=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7250 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'check norm ',x,S
7251 [ + + ]: 1235 : VNC(irc:n)=rv(irc:n)/r(irc:n)
7252 [ + + ]: 4004 : PAW%rveff(1:n)=VNC(1:n)*r(1:n)
7253 [ - + ]: 2 : LIBPAW_DEALLOCATE(VNC)
7254 : 2 : LIBPAW_DEALLOCATE(wfn)
7255 [ - + ]: 2 : LIBPAW_DEALLOCATE(p)
7256 [ - + ]: 2 : LIBPAW_DEALLOCATE(dum)
7257 [ - + ]: 2 : LIBPAW_DEALLOCATE(aux)
7258 [ - + ]: 2 : END SUBROUTINE troullier
7259 : :
7260 : :
7261 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7262 : : !! StoreTOCCWFN(PAW)
7263 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7264 : 2 : SUBROUTINE StoreTOCCWFN(PAW)
7265 : : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
7266 : : INTEGER :: io,ib
7267 [ + + ]: 14 : do io=1,PAW%TOCCWFN%norbit
7268 [ + + ]: 14 : if (PAW%valencemap(io)>0) then
7269 : 6 : ib=PAW%valencemap(io)
7270 [ + + ]: 12012 : PAW%TOCCWFN%wfn(:,io)=PAW%tphi(:,ib)
7271 : : endif
7272 : : enddo
7273 : 2 : END SUBROUTINE StoreTOCCWFN
7274 : :
7275 : :
7276 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7277 : : !! SUBROUTINE setbasis(Grid,Pot,Orbit,PAW,atp)
7278 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7279 : 2 : SUBROUTINE setbasis(Grid,Pot,Orbit,PAW,atp,potshift)
7280 : : TYPE(GridInfo), INTENT(IN) :: Grid
7281 : : real(dp), intent(in) :: potshift
7282 : : TYPE(PotentialInfo), INTENT(INout) :: Pot
7283 : : TYPE(OrbitInfo), INTENT(INOUT) :: Orbit
7284 : : TYPE(PseudoInfo), intent(inout) :: PAW
7285 : : TYPE(atompaw_type), intent(in) :: atp
7286 : : INTEGER :: n,irc,nbase,l,lmax,mxbase,currentnode
7287 : : INTEGER :: i,k,io,nbl,nr,nodes,ibasis_add
7288 : : real(dp) :: h,rc,energy,rat,range
7289 : 2 : real(dp),allocatable :: checkden(:),valden(:)
7290 : 2 : real(dp), POINTER :: r(:)
7291 : 2 : n=Grid%n
7292 : 2 : h=Grid%h
7293 : 2 : r=>Grid%r
7294 : 2 : irc=PAW%irc
7295 : 2 : nr=MIN(irc+100,n-100)
7296 : 2 : rc=PAW%rc
7297 : 2 : lmax=PAW%lmax
7298 [ + - + - : 6 : LIBPAW_ALLOCATE(checkden,(n))
+ - - + -
+ ]
7299 [ - + + - : 4 : LIBPAW_ALLOCATE(valden,(n))
- + - + ]
7300 [ + + + + ]: 8006 : checkden=0._dp;valden=0._dp
7301 : : !Check beginning valence density
7302 [ + + ]: 14 : DO io=1,Orbit%norbit
7303 [ + + ]: 14 : if (.not.Orbit%iscore(io)) then
7304 [ - + + + ]: 12018 : valden=valden+Orbit%occ(io)*(Orbit%wfn(:,io)**2)
7305 : : endif
7306 : : ENDDO
7307 : : ! set AErefrv
7308 [ + + ]: 4004 : PAW%AErefrv=Pot%rv
7309 [ + + ]: 4004 : PAW%rvx=Pot%rvx
7310 : 2 : PAW%exctype=Orbit%exctype
7311 : 2 : nbase=PAW%nbase
7312 : 2 : mxbase=PAW%mxbase
7313 : : ! "filter" occupied states for long-range noise
7314 [ + + ]: 14 : DO io=1,Orbit%norbit
7315 : 14 : Call Filter(n,Orbit%wfn(:,io),machine_zero)
7316 : : ENDDO
7317 : 2 : call CopyOrbit(Orbit,PAW%OCCwfn)
7318 : 2 : call CopyOrbit(Orbit,PAW%TOCCwfn)
7319 [ + + ]: 14 : PAW%valencemap=-13
7320 [ - + ]: 2 : IF (Orbit%exctype=='HF') THEN
7321 : 0 : range=r(n)
7322 : 0 : rat=-1.d30; k=1
7323 [ # # ]: 0 : do io=1,Orbit%norbit
7324 [ # # # # ]: 0 : if ((Orbit%occ(io)>tol5).and.Orbit%eig(io)>rat) then
7325 : 0 : rat=Orbit%eig(io)
7326 : 0 : k=io
7327 : : endif
7328 : : enddo
7329 [ # # ]: 0 : do i=n,irc+1,-1
7330 [ # # ]: 0 : if (ABS(Orbit%wfn(i,k))>tol4) then
7331 : 0 : range=r(i)
7332 : 0 : exit
7333 : : endif
7334 : : enddo
7335 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'range ', k,range!; call flush_unit(std_out)
7336 : : ENDIF
7337 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) ' basis functions:'
7338 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*)' No. n l energy occ '
7339 : 2 : nbase=0 ; ibasis_add=1
7340 [ + + ]: 9 : DO l=0,lmax
7341 : 7 : currentnode=-1
7342 : 7 : nbl=0
7343 [ + + ]: 48 : DO io=1,Orbit%norbit ! cycle through all configuration
7344 [ + + ]: 48 : IF (Orbit%l(io).EQ.l) THEN
7345 : 12 : currentnode=Orbit%np(io)-l-1
7346 [ + + ]: 12 : IF (.NOT.Orbit%iscore(io)) THEN
7347 : 6 : nbl=nbl+1
7348 : 6 : nbase=nbase+1
7349 : 6 : PAW%np(nbase)=Orbit%np(io)
7350 : 6 : PAW%l(nbase)=l
7351 : 6 : PAW%nodes(nbase)=PAW%np(nbase)-l-1
7352 [ - + ]: 6 : if(has_to_print) write(std_out,*) 'l,nbase,node',l,nbase,currentnode
7353 : 6 : PAW%eig(nbase)=Orbit%eig(io)
7354 [ + + ]: 6 : if(Orbit%issemicore(io)) PAW%eig(nbase)=PAW%eig(nbase)-potshift
7355 : 6 : PAW%occ(nbase)=Orbit%occ(io)
7356 [ + - + + ]: 6 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%issemicore(io))) then
7357 : 4 : energy=PAW%eig(nbase)
7358 [ + + ]: 8008 : Orbit%wfn(:,io)=zero
7359 [ + + ]: 4 : if (Orbit%scalarrelativistic) then
7360 : 2 : CALL unboundsr(Grid,Pot,n,l,energy,Orbit%wfn(:,io),nodes)
7361 : : else
7362 : : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,&
7363 : 2 : & nr,l,energy,Orbit%wfn(:,io),nodes)
7364 : : endif
7365 : : endif
7366 [ + + ]: 12012 : PAW%phi(:,nbase)=Orbit%wfn(:,io)
7367 [ - + ]: 6 : if(Orbit%diracrelativistic) then
7368 : 0 : STOP 'Error -- setbasis subroutine not ready for diracrelativistic!'
7369 : : endif
7370 : 6 : PAW%valencemap(io)=nbase
7371 [ - + ]: 6 : if(has_to_print) WRITE(STD_OUT,'(3i6,1p,2e15.6)') nbase,PAW%np(nbase),l,&
7372 : 0 : & PAW%eig(nbase),PAW%occ(nbase)!; call flush_unit(std_out)
7373 : : ENDIF
7374 : : ENDIF
7375 : : ENDDO
7376 : 2 : generalizedloop: DO
7377 [ + + ]: 19 : IF (ibasis_add>atp%nbasis_add) EXIT generalizedloop
7378 [ + + ]: 17 : IF (atp%basis_add_l(ibasis_add)/=l) EXIT generalizedloop
7379 : 12 : energy=atp%basis_add_energy(ibasis_add)
7380 [ - + - - ]: 12 : IF (energy<0._dp.and.has_to_print) then
7381 : 0 : WRITE(STD_OUT,*) 'energy is negative',energy,' -- WARNING WARNING !!!'
7382 : : endif
7383 : 12 : nbase=nbase+1
7384 [ - + ]: 12 : IF (nbase > mxbase ) THEN
7385 : 0 : LIBPAW_ERROR('Error in setbasis -- too many functions ')
7386 : : ENDIF
7387 : 12 : PAW%l(nbase)=l
7388 : 12 : PAW%np(nbase)=999
7389 : 12 : PAW%nodes(nbase)=currentnode+1
7390 : 12 : currentnode=PAW%nodes(nbase)
7391 [ - + ]: 12 : if(has_to_print) write(std_out,*) 'l,nbase,node',l,nbase,currentnode
7392 : 12 : PAW%eig(nbase)=energy
7393 : 12 : PAW%occ(nbase)=0._dp
7394 [ + + ]: 24024 : PAW%phi(1:n,nbase)=0._dp
7395 [ + + ]: 12 : if (Orbit%scalarrelativistic) then
7396 : 2 : CALL unboundsr(Grid,Pot,n,l,energy,PAW%phi(:,nbase),nodes)
7397 [ - + ]: 10 : else if (Pot%needvtau) then
7398 : 0 : CALL unboundked(Grid,Pot,n,l,energy,PAW%phi(:,nbase),nodes)
7399 : : else
7400 : : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,&
7401 : 10 : & nr,l,energy,PAW%phi(:,nbase),nodes)
7402 : : endif
7403 : 12 : rat=MAX(ABS(PAW%phi(irc,nbase)),ABS(PAW%phi(irc+1,nbase)))
7404 : 12 : rat=DSIGN(rat,PAW%phi(irc,nbase))
7405 [ + + ]: 24024 : PAW%phi(1:n,nbase)=PAW%phi(1:n,nbase)/rat
7406 [ - + - - : 12 : if(has_to_print) write(std_out,*) 'MAX PHI=',nbase,maxval(PAW%phi(:,nbase))
- - - - -
- ]
7407 [ - + ]: 12 : if(has_to_print) then
7408 : 0 : WRITE(STD_OUT,'(3i6,1p,2e15.6)') nbase,PAW%np(nbase),l, &
7409 : 0 : & PAW%eig(nbase),PAW%occ(nbase)
7410 : : endif
7411 : 12 : nbl=nbl+1
7412 : 17 : ibasis_add=ibasis_add+1
7413 : : ENDDO generalizedloop
7414 : : ENDDO ! end lmax loop
7415 [ - + ]: 2 : if(has_to_print) WRITE(std_out,*) 'completed phi basis with ',nbase,' functions '
7416 : 2 : PAW%nbase=nbase ! reset nbase
7417 [ - + ]: 2 : LIBPAW_DEALLOCATE(checkden)
7418 [ - + ]: 2 : LIBPAW_DEALLOCATE(valden)
7419 [ - + ]: 2 : END SUBROUTINE setbasis
7420 : :
7421 : :
7422 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7423 : : !! SUBROUTINE smoothcore(Grid,orig,PAW)
7424 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7425 [ - + ]: 18 : SUBROUTINE smoothcore(Grid,orig,PAW)
7426 : : TYPE(GridInfo), INTENT(IN) :: Grid
7427 : : real(dp), INTENT(IN) :: orig(:)
7428 : : type(pseudoInfo), intent(inout) :: PAW
7429 : : real(dp) :: rc,h,x,y,z,u0,u2,u4
7430 : 18 : real(dp), allocatable :: d1(:),d2(:)
7431 : : INTEGER :: i,n,irc
7432 : 18 : n=Grid%n
7433 : 18 : h=Grid%h
7434 : 18 : irc=PAW%irc_core
7435 : 18 : rc=PAW%rc_core
7436 [ - + ]: 18 : if(has_to_print) write(std_out,*) 'In smoothcore ', irc,rc
7437 [ - + + - : 54 : LIBPAW_ALLOCATE(d1,(n))
+ - + - -
+ - + ]
7438 [ - + + - : 36 : LIBPAW_ALLOCATE(d2,(n))
- + - + ]
7439 : 18 : CALL derivative(Grid,orig,d1)
7440 : 18 : CALL derivative(Grid,d1,d2)
7441 : 18 : x=orig(irc)
7442 : 18 : y=d1(irc)*rc
7443 : 18 : z=d2(irc)*(rc*rc)
7444 [ - + ]: 18 : if(has_to_print) write(std_out,*) 'smoothcore: x,y,z = ', x,y,z
7445 : 18 : u0=3*x - 9*y/8 + z/8
7446 : 18 : u2=-3*x + 7*y/4 - z/4
7447 : 18 : u4=x - 5*y/8 + z/8
7448 [ - + ]: 18 : if(has_to_print) write(std_out,*) 'smoothcore: u0,u2,u4 = ', u0,u2,u4
7449 [ + + ]: 36036 : PAW%tcore=orig
7450 [ + + ]: 24282 : do i=1,irc
7451 : 24264 : x=(Grid%r(i)/rc)**2
7452 : 24282 : PAW%tcore(i)= x*(u0+x*(u2+x*u4))
7453 : : enddo
7454 : 18 : LIBPAW_DEALLOCATE(d1)
7455 : 18 : LIBPAW_DEALLOCATE(d2)
7456 : 18 : END SUBROUTINE smoothcore
7457 : :
7458 : :
7459 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7460 : : !! SUBROUTINE smoothpower
7461 : : !! program to take array orig (all electron tau or den)
7462 : : !! and return smooth polynomial function for 0 \le r \le rc_core
7463 : : !! matching 4 points less than and equal to rc_core
7464 : : !! power could be 2 or 4, representing the leading power
7465 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7466 [ # # # # ]: 0 : SUBROUTINE smoothpower(Grid,power,orig,smooth,PAW)
7467 : : TYPE(GridInfo), INTENT(IN) :: Grid
7468 : : type(pseudoInfo), intent(in) :: PAW
7469 : : INTEGER, INTENT(IN) :: power
7470 : : REAL(dp), INTENT(IN) :: orig(:)
7471 : : REAL(dp), INTENT(INOUT) :: smooth(:)
7472 : : INTEGER, parameter :: terms=5
7473 : : REAL(dp) :: rc,h,x
7474 : : REAL(dp) :: aa(terms,terms),Ci(terms)
7475 : : INTEGER :: i,j,n,irc
7476 : 0 : n=Grid%n
7477 : 0 : h=Grid%h
7478 : 0 : irc=PAW%irc_core
7479 : 0 : rc=Grid%r(irc)
7480 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'smoothpower -- ', power,irc,rc
7481 : 0 : aa=zero; Ci=zero
7482 [ # # ]: 0 : do i=1,terms
7483 : 0 : x=Grid%r(irc-terms+i)
7484 : 0 : Ci(i)=orig(irc-terms+i)/x**power
7485 [ # # ]: 0 : do j=1,terms
7486 : 0 : aa(i,j)=x**(2*(j-1))
7487 : : enddo
7488 : : enddo
7489 : 0 : call SolveAXeqBM(terms,aa,Ci,terms-1)
7490 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'Completed SolveAXeqB with coefficients'
7491 [ # # ]: 0 : if(has_to_print) write(std_out,'(1p,10e15.7)') (Ci(i),i=1,terms)
7492 [ # # ]: 0 : smooth=orig
7493 [ # # ]: 0 : do i=1,irc-1
7494 : 0 : smooth(i)=0
7495 : 0 : x=Grid%r(i)
7496 [ # # ]: 0 : do j=1,terms
7497 : 0 : smooth(i)=smooth(i)+Ci(j)*(x**(power+2*(j-1)))
7498 : : enddo
7499 : : enddo
7500 : 0 : END SUBROUTINE smoothpower
7501 : :
7502 : :
7503 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7504 : : !! SUBROUTINE setcoretail(Grid,coreden,PAW)
7505 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7506 [ - + ]: 18 : SUBROUTINE setcoretail(Grid,coreden,PAW,needvtau)
7507 : : logical,intent(in) :: needvtau
7508 : : TYPE(GridInfo), INTENT(IN) :: Grid
7509 : : real(dp), INTENT(IN) :: coreden(:)
7510 : : type(pseudoInfo), intent(inout) :: PAW
7511 : : real(dp) :: rc,h,z
7512 : : INTEGER :: i,n,irc
7513 : 18 : n=Grid%n
7514 : 18 : h=Grid%h
7515 : 18 : irc=PAW%irc_core
7516 : 18 : rc=PAW%rc_core
7517 [ + - ]: 18 : If(.not.needvtau) then
7518 : 18 : CALL smoothcore(Grid,coreden,PAW)
7519 : : else
7520 : 0 : CALL smoothpower(Grid,2,coreden,PAW%tcore,PAW)
7521 : : endif
7522 [ + + ]: 36036 : PAW%core=coreden
7523 : : ! Find coretailpoints
7524 : 18 : z = integrator(Grid,coreden)
7525 : 18 : PAW%coretailpoints=PAW%irc+Grid%ishift !! coretailpoints should be>=PAW%irc
7526 [ + - ]: 1471 : do i=PAW%irc+Grid%ishift,n
7527 [ + + ]: 1471 : if(ABS(z-integrator(Grid,coreden,1,i))<coretailtol) then
7528 : 18 : PAW%coretailpoints=i
7529 : 18 : exit
7530 : : endif
7531 : : enddo
7532 [ - + ]: 18 : if(has_to_print) write(std_out,*) 'coretailpoints = ',PAW%coretailpoints
7533 : 18 : END SUBROUTINE setcoretail
7534 : :
7535 : :
7536 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7537 : : !! SUBROUTINE nonncps(lmax,Grid,Pot)
7538 : : !! Creates screened pseudopotential by inverting Schroedinger
7539 : : !! equation from a pseudized radial wave function of the form:
7540 : : !! Psi(r) = r**(l+1) * exp (a + b*r**2 + c*r**4 + d*r**6)
7541 : : !! No norm-conserving condition is imposed on Psi
7542 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7543 : 0 : SUBROUTINE nonncps(Grid,Pot,PAW,l,e,scalarrelativistic)
7544 : : logical, intent(in) :: scalarrelativistic
7545 : : TYPE(Gridinfo), INTENT(IN) :: Grid
7546 : : TYPE(Potentialinfo), INTENT(INout) :: Pot
7547 : : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
7548 : : INTEGER,INTENT(IN) :: l
7549 : : REAL(dp),INTENT(IN) :: e
7550 : : INTEGER :: i,irc,n,nr,nodes,i1,i2,i3,i4
7551 : : REAL(dp) :: rc,x,y1,y2,y3,p0,p1,p2,p3,sgn
7552 : : REAL(dp) :: b(4),c(4),d(4),amat(4,4)
7553 : 0 : REAL(dp),ALLOCATABLE :: VNC(:),wfn(:),aux(:)
7554 : 0 : REAL(dp),POINTER :: r(:),rv(:)
7555 : : !Polynomial definitions
7556 : : p0(x,y1,y2,y3)=(x-y1)*(x-y2)*(x-y3)
7557 : : p1(x,y1,y2,y3)=(x-y2)*(x-y3)+(x-y1)*(x-y3)+(x-y1)*(x-y2)
7558 : : p2(x,y1,y2,y3)=two*((x-y1)+(x-y2)+(x-y3))
7559 : : p3(x,y1,y2,y3)=six
7560 : 0 : n=Grid%n
7561 : 0 : r=>Grid%r
7562 : 0 : rv=>Pot%rv
7563 : 0 : nr=min(PAW%irc_vloc+10,n)
7564 : 0 : irc=PAW%irc_vloc
7565 : 0 : rc=PAW%rc_vloc
7566 [ # # # # : 0 : LIBPAW_ALLOCATE(VNC,(n))
# # # # #
# ]
7567 [ # # # # : 0 : LIBPAW_ALLOCATE(wfn,(nr))
# # # # #
# # # ]
7568 [ # # # # : 0 : LIBPAW_ALLOCATE(aux,(nr))
# # # # ]
7569 [ # # ]: 0 : if (scalarrelativistic) then
7570 : 0 : CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes)
7571 [ # # ]: 0 : else if (Pot%needvtau) then
7572 : 0 : CALL unboundked(Grid,Pot,nr,l,e,wfn,nodes)
7573 : : else
7574 : 0 : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,nr,l,e,wfn,nodes)
7575 : : endif
7576 [ # # # # ]: 0 : IF (wfn(irc)<0) wfn=-wfn
7577 [ # # ]: 0 : DO i=2,nr
7578 : 0 : wfn(i)=wfn(i)/r(i)**dble(l+1)
7579 : : ENDDO
7580 : 0 : i1=irc-1;i2=i1+1;i3=i2+1;i4=i3+1
7581 : 0 : c(1)=wfn(i1)/p0(r(i1),r(i2),r(i3),r(i4))
7582 : 0 : c(2)=wfn(i2)/p0(r(i2),r(i3),r(i4),r(i1))
7583 : 0 : c(3)=wfn(i3)/p0(r(i3),r(i4),r(i1),r(i2))
7584 : 0 : c(4)=wfn(i4)/p0(r(i4),r(i1),r(i2),r(i3))
7585 : : d(1)=c(1)*p0(rc,r(i2),r(i3),r(i4)) + c(2)*p0(rc,r(i3),r(i4),r(i1)) + &
7586 : 0 : & c(3)*p0(rc,r(i4),r(i1),r(i2)) + c(4)*p0(rc,r(i1),r(i2),r(i3))
7587 : : d(2)=c(1)*p1(rc,r(i2),r(i3),r(i4)) + c(2)*p1(rc,r(i3),r(i4),r(i1)) + &
7588 : 0 : & c(3)*p1(rc,r(i4),r(i1),r(i2)) + c(4)*p1(rc,r(i1),r(i2),r(i3))
7589 : : d(3)=c(1)*p2(rc,r(i2),r(i3),r(i4)) + c(2)*p2(rc,r(i3),r(i4),r(i1)) + &
7590 : 0 : & c(3)*p2(rc,r(i4),r(i1),r(i2)) + c(4)*p2(rc,r(i1),r(i2),r(i3))
7591 : : d(4)=c(1)*p3(rc,r(i2),r(i3),r(i4)) + c(2)*p3(rc,r(i3),r(i4),r(i1)) + &
7592 : 0 : & c(3)*p3(rc,r(i4),r(i1),r(i2)) + c(4)*p3(rc,r(i1),r(i2),r(i3))
7593 [ # # ]: 0 : sgn=d(1)/abs(d(1));d(1:4)=d(1:4)*sgn
7594 [ # # ]: 0 : b(1)=log(d(1));b(2:4)=d(2:4)
7595 : 0 : amat(1,1)= 1.0_dp
7596 [ # # ]: 0 : amat(2:4,1)= 0.0_dp
7597 : 0 : amat(1,2)= rc**2
7598 : 0 : amat(2,2)= 2.0_dp*d(1)*rc
7599 : 0 : amat(3,2)= 2.0_dp*d(1) +2.0_dp*d(2)*rc
7600 : 0 : amat(4,2)= 4.0_dp*d(2) +2.0_dp*d(3)*rc
7601 : 0 : amat(1,3)= rc**4
7602 : 0 : amat(2,3)= 4.0_dp*d(1)*rc**3
7603 : 0 : amat(3,3)= 12.0_dp*d(1)*rc**2+ 4.0_dp*d(2)*rc**3
7604 : 0 : amat(4,3)= 24.0_dp*d(1)*rc +24.0_dp*d(2)*rc**2+4.0_dp*d(3)*rc**3
7605 : 0 : amat(1,4)= rc**6
7606 : 0 : amat(2,4)= 6.0_dp*d(1)*rc**5
7607 : 0 : amat(3,4)= 30.0_dp*d(1)*rc**4+ 6.0_dp*d(2)*rc**5
7608 : 0 : amat(4,4)= 120.0_dp*d(1)*rc**3+60.0_dp*d(2)*rc**4+6.0_dp*d(3)*rc**5
7609 : 0 : CALL linsol(amat,b,4,4,4,4)
7610 [ # # ]: 0 : if (Pot%needvtau) then
7611 [ # # ]: 0 : aux=zero
7612 : 0 : call derivative(Grid,PAW%tvtau,aux,1,nr)
7613 : : endif
7614 : 0 : PAW%rveff(1)=0._dp
7615 [ # # ]: 0 : DO i=2,irc-1
7616 : 0 : c(1)=2.0_dp*b(2)*r(i)+ 4.0_dp*b(3)*r(i)**3+ 6.0_dp*b(4)*r(i)**5
7617 : 0 : c(2)=2.0_dp*b(2) +12.0_dp*b(3)*r(i)**2+30.0_dp*b(4)*r(i)**4
7618 [ # # ]: 0 : if (pot%needvtau) then
7619 : : PAW%rveff(i)=r(i)*(e+(dble(2*l+2)*c(1)/r(i)+c(1)**2+&
7620 : 0 : & c(2))*(1._dp+PAW%tvtau(i))+aux(i)*(c(1)+dble(l)/r(i)))
7621 : : else
7622 : 0 : PAW%rveff(i)=r(i)*(e+dble(2*l+2)*c(1)/r(i)+c(1)**2+c(2))
7623 : : endif
7624 : : ENDDO
7625 [ # # ]: 0 : PAW%rveff(irc:n)=rv(irc:n)
7626 [ # # ]: 0 : LIBPAW_DEALLOCATE(VNC)
7627 : 0 : LIBPAW_DEALLOCATE(wfn)
7628 [ # # ]: 0 : LIBPAW_DEALLOCATE(aux)
7629 [ # # ]: 0 : END SUBROUTINE nonncps
7630 : :
7631 : :
7632 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7633 : : ! SUBROUTINE VPSmatch(lmax,Grid,Pot,NC)
7634 : : ! Creates screened norm-conserving pseudopotential similar to the
7635 : : ! approach of N. Troullier and J. L. Martins, PRB 43, 1993 (1991)
7636 : : ! Uses p(r)=a0+f(r); f(r)=SUMm(Coef(m)*r^(2*m), where
7637 : : ! m=1,2..6
7638 : : ! Psi(r) = r^(l+1)*exp(p(r))
7639 : : ! Modified for MGGA case and norm conserving condition is optional
7640 : : ! norm conservation controlled with optional variable NC
7641 : : ! defaults to no norm conservation
7642 : : ! Note this program assumes that wfn keeps the same sign for
7643 : : ! all matching points r(irc-match+1)....r(irc)
7644 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7645 : : SUBROUTINE VPSmatch(Grid,Pot,PAW,l,e,NC,scalarrelativistic)
7646 : : logical,intent(in) :: scalarrelativistic
7647 : : TYPE(Gridinfo), INTENT(IN) :: Grid
7648 : : TYPE(Potentialinfo), INTENT(INout) :: Pot
7649 : : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
7650 : : INTEGER,INTENT(IN) :: l
7651 : : REAL(dp),INTENT(IN) :: e
7652 : : LOGICAL,INTENT(IN), OPTIONAL :: NC
7653 : : REAL(dp), ALLOCATABLE :: VNC(:)
7654 : : REAL(dp) :: C0,S
7655 : : REAL(dp) :: Coef0,Coef0old
7656 : : REAL(dp) :: h,rc,delta,x
7657 : : INTEGER :: i,j,n,iter,nr,nodes,irc
7658 : : INTEGER, parameter :: match=6
7659 : : REAL(dp) :: AAA(match,match),BBB(match)
7660 : : REAL(dp) :: AAAA(match-1,match-1),BBBB(match-1)
7661 : : INTEGER, PARAMETER :: niter=5000
7662 : : REAL(dp), PARAMETER :: small=1.0d-9
7663 : : REAL(dp), ALLOCATABLE :: wfn(:),p(:),dum(:),aux(:),Kaux(:),v(:),dp1(:),ddp(:)
7664 : : REAL(dp), POINTER :: r(:),rv(:)
7665 : : LOGICAL :: normcons
7666 : : normcons=.false.
7667 : : if(PRESENT(NC)) normcons=NC
7668 : : if(has_to_print) write(std_out,*) 'Entering VPSmatch with normcons ', normcons
7669 : : n=Grid%n
7670 : : h=Grid%h
7671 : : r=>Grid%r
7672 : : rv=>Pot%rv
7673 : : nr=min(PAW%irc_vloc+10,n)
7674 : : irc=PAW%irc_vloc
7675 : : rc=PAW%rc_vloc
7676 : : LIBPAW_ALLOCATE(VNC,(n))
7677 : : LIBPAW_ALLOCATE(wfn,(n))
7678 : : LIBPAW_ALLOCATE(p,(n))
7679 : : LIBPAW_ALLOCATE(dum,(n))
7680 : : LIBPAW_ALLOCATE(aux,(n))
7681 : : LIBPAW_ALLOCATE(dp1,(n))
7682 : : LIBPAW_ALLOCATE(ddp,(n))
7683 : : LIBPAW_ALLOCATE(Kaux,(n))
7684 : : LIBPAW_ALLOCATE(v,(n))
7685 : : wfn=zero
7686 : : if (scalarrelativistic) then
7687 : : CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes)
7688 : : else if (Pot%needvtau) then
7689 : : CALL unboundked(Grid,Pot,nr,l,e,wfn,nodes)
7690 : : else
7691 : : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,nr,l,e,wfn,nodes)
7692 : : endif
7693 : : IF (wfn(irc)<0) wfn=-wfn
7694 : : ! first solve non-norm conserving results
7695 : : AAA=zero;BBB=zero
7696 : : Do i=1,match
7697 : : x=r(irc-match+i)
7698 : : BBB(i)=log(wfn(irc-match+i)/(x**(l+1)))
7699 : : do j=1,match
7700 : : AAA(i,j)=x**(2*(j-1))
7701 : : enddo
7702 : : Enddo
7703 : : CALL SolveAXeqB(match,AAA,BBB,1.d20)
7704 : : if(has_to_print) write(std_out,*) 'Returned from SolveAXeqB in VPSmatch with Coefficients '
7705 : : if(has_to_print) write(std_out,'(1p,50e16.7)') (BBB(i),i=1,match)
7706 : : ! Now calculate VNC
7707 : : if (Pot%needvtau) then
7708 : : aux=0._dp
7709 : : call derivative(Grid,PAW%tvtau,aux,1,nr)
7710 : : Kaux=0._dp
7711 : : call derivative(Grid,PAW%Ktvtau,Kaux,1,nr) ! Kresse form
7712 : : endif
7713 : : VNC=zero;p=zero;dp1=zero;ddp=zero;dum=zero
7714 : : !specific for match=6
7715 : : DO i=2,nr
7716 : : x=(r(i))**2
7717 : : p(i)=BBB(1)+x*(BBB(2)+x*(BBB(3)+x*(BBB(4)+x*(BBB(5)+x*BBB(6)))))
7718 : : dp1(i)=two*r(i)*(BBB(2)+x*(two*BBB(3)+x*(three*BBB(4)+x*(four*BBB(5)+five*x*BBB(6)))))
7719 : : ddp(i)=2.0_dp*(BBB(2)+x*(6.0_dp*BBB(3)+x*(15.0_dp*BBB(4)+x*(28.0_dp*BBB(5)+45.0_dp*x*BBB(6)))))
7720 : : if (Pot%needvtau) then
7721 : : VNC(i)=e+(1._dp+PAW%tvtau(i))*(ddp(i)+ &
7722 : : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7723 : : & +aux(i)*(dp1(i)+l/r(i))
7724 : : v(i)=e+(1._dp+PAW%Ktvtau(i))*(ddp(i)+ &
7725 : : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7726 : : & +Kaux(i)*(dp1(i)+l/r(i))
7727 : : else
7728 : : VNC(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7729 : : v(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7730 : : endif
7731 : : dum(i)=(r(i)**(l+1))*EXP(p(i))
7732 : : ENDDO
7733 : : S=overlap(Grid,wfn(1:irc),wfn(1:irc),1,irc)
7734 : : C0=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7735 : : if(has_to_print) WRITE(STD_OUT,*) 'check norm ',C0,S
7736 : : VNC(irc:n)=rv(irc:n)/r(irc:n)
7737 : : v(irc:n)=rv(irc:n)/r(irc:n)
7738 : : PAW%rveff(1:n)=VNC(1:n)*r(1:n)
7739 : : PAW%Krveff(1:n)=v(1:n)*r(1:n)
7740 : : if(has_to_print) write(std_out,*) 'Completed non-norm-conserving PS '
7741 : : if(.not.normcons) return
7742 : : ! Iterate to find norm conserving results
7743 : : C0=C0/(EXP(2*BBB(1)))
7744 : : delta=1.d10
7745 : : iter=zero
7746 : : Coef0=0.5_dp*log(S/C0)
7747 : : DO WHILE(delta>small.AND.iter<=niter)
7748 : : Coef0old=Coef0
7749 : : iter=iter+1
7750 : : AAAA=zero;BBBB=zero
7751 : : Do i=1,match-1
7752 : : x=r(irc-match+1+i)
7753 : : BBBB(i)=log(wfn(irc-match+1+i)/(x**(l+1)))-Coef0old
7754 : : do j=1,match-1
7755 : : AAAA(i,j)=x**(2*(j))
7756 : : enddo
7757 : : Enddo
7758 : : CALL SolveAXeqB(match-1,AAAA,BBBB,1.d20)
7759 : : if(has_to_print) write(std_out,*) 'Returned from SolveAXeqB in VPSmatch with Coefficients'
7760 : : if(has_to_print) write(std_out,'(1p,50e16.7)') (BBBB(i),i=1,match-1)
7761 : : !specific for match-1=5
7762 : : p=zero;dum=zero
7763 : : DO i=2,nr
7764 : : x=(r(i))**2
7765 : : p(i)=x*(BBBB(1)+x*(BBBB(2)+x*(BBBB(3)+x*(BBBB(4)+x*BBBB(5)))))
7766 : : dum(i)=(r(i)**(l+1))*EXP(Coef0+p(i))
7767 : : ENDDO
7768 : : C0=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7769 : : if(has_to_print) WRITE(std_out,*) 'check norm ',C0,S
7770 : : Coef0=0.5_dp*log(S/C0)
7771 : : delta=ABS(Coef0-Coef0old)
7772 : : if(has_to_print) WRITE(std_out,'(" VNC: iter Coef0 delta",i5,1p,2e15.7)') iter,Coef0,delta
7773 : : ENDDO
7774 : : if(has_to_print) WRITE(std_out,*) ' VNC converged in ', iter,' iterations'
7775 : : if(has_to_print) WRITE(std_out,*) ' Coefficients -- ', Coef0,BBBB(1:match-1)
7776 : : ! Now calculate VNC
7777 : : if (Pot%needvtau) then
7778 : : aux=0._dp
7779 : : call derivative(Grid,PAW%tvtau,aux,1,nr)
7780 : : Kaux=0._dp
7781 : : call derivative(Grid,PAW%Ktvtau,Kaux,1,nr)
7782 : : endif
7783 : : VNC=zero;p=zero;dp1=zero;ddp=zero;v=zero
7784 : : DO i=2,nr
7785 : : x=(r(i))**2
7786 : : p(i)=x*(BBBB(1)+x*(BBBB(2)+x*(BBBB(3)+x*(BBBB(4)+x*BBBB(5)))))
7787 : : dp1(i)=two*r(i)*(BBBB(1)+x*(two*BBBB(2)+x*(three*BBBB(3)+x*(four*BBBB(4)+five*x*BBBB(5)))))
7788 : : ddp(i)=2.0_dp*(BBBB(1)+x*(6.0_dp*BBBB(2)+x*(15.0_dp*BBBB(3)+x*(28.0_dp*BBBB(4)+45.0_dp*x*BBBB(5)))))
7789 : : if (Pot%needvtau) then
7790 : : VNC(i)=e+(1._dp+PAW%tvtau(i))*(ddp(i)+ &
7791 : : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7792 : : & +aux(i)*(dp1(i)+l/r(i))
7793 : : v(i)=e+(1._dp+PAW%Ktvtau(i))*(ddp(i)+ &
7794 : : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7795 : : & +Kaux(i)*(dp1(i)+l/r(i))
7796 : : else
7797 : : VNC(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7798 : : v(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7799 : : endif
7800 : : dum(i)=(r(i)**(l+1))*EXP(Coef0+p(i))
7801 : : ENDDO
7802 : : C0=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7803 : : if(has_to_print) WRITE(std_out,*) 'check norm ',C0,S
7804 : : VNC(irc:n)=rv(irc:n)/r(irc:n)
7805 : : v(irc:n)=rv(irc:n)/r(irc:n)
7806 : : PAW%rveff(1:n)=VNC(1:n)*r(1:n)
7807 : : PAW%Krveff(1:n)=v(1:n)*r(1:n)
7808 : : if(has_to_print)write(std_out,*) 'Completed norm-conserving PS '
7809 : : if (iter.ge.niter) then
7810 : : write(std_out,*) 'Failed to converged norm-conserving VPS '
7811 : : stop
7812 : : endif
7813 : : LIBPAW_DEALLOCATE(VNC)
7814 : : LIBPAW_DEALLOCATE(wfn)
7815 : : LIBPAW_DEALLOCATE(p)
7816 : : LIBPAW_DEALLOCATE(dp1)
7817 : : LIBPAW_DEALLOCATE(ddp)
7818 : : LIBPAW_DEALLOCATE(dum)
7819 : : LIBPAW_DEALLOCATE(aux)
7820 : : LIBPAW_DEALLOCATE(Kaux)
7821 : : LIBPAW_DEALLOCATE(v)
7822 : : END SUBROUTINE VPSmatch
7823 : :
7824 : :
7825 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7826 : : ! calculate_tvtau for MGGA case
7827 : : ! Assume valence pseudo wavefunctions known
7828 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7829 : : SUBROUTINE calculate_tvtau(Grid,PAW,itype)
7830 : : TYPE(GridInfo), INTENT(IN) :: Grid
7831 : : type(pseudoInfo),intent(inout) :: PAW
7832 : : integer,intent(in) :: itype
7833 : : INTEGER :: i
7834 : : REAL(dp), allocatable :: dp1(:),ddp(:),vxc(:),tvxc(:),locald(:),localtd(:)
7835 : : REAL(dp), allocatable :: Ktvxc(:),Kd(:)
7836 : : REAL(dp) :: exc,texc,sum,tsum
7837 : : REAL(dp), parameter :: small=1.d-5
7838 : : LIBPAW_ALLOCATE(dp1,(Grid%n))
7839 : : LIBPAW_ALLOCATE(ddp,(Grid%n))
7840 : : LIBPAW_ALLOCATE(vxc,(Grid%n))
7841 : : LIBPAW_ALLOCATE(tvxc,(Grid%n))
7842 : : LIBPAW_ALLOCATE(locald,(Grid%n))
7843 : : LIBPAW_ALLOCATE(localtd,(Grid%n))
7844 : : LIBPAW_ALLOCATE(Ktvxc,(Grid%n))
7845 : : LIBPAW_ALLOCATE(Kd,(Grid%n))
7846 : : locald=PAW%core
7847 : : localtd=PAW%tcore
7848 : : PAW%valetau=0._dp
7849 : : PAW%tvaletau=0._dp
7850 : : do i=1,PAW%nbase
7851 : : if(has_to_print) write(std_out,*) 'tvtau -- ', i,PAW%l(i),PAW%occ(i),PAW%eig(i)
7852 : : if (PAW%occ(i).gt.small) then
7853 : : locald=locald+PAW%occ(i)*(PAW%phi(:,i)**2)
7854 : : localtd=localtd+PAW%occ(i)*(PAW%tphi(:,i)**2)
7855 : : CALL taufromwfn(dp1,Grid,PAW%phi(:,i),PAW%l(i))
7856 : : CALL taufromwfn(ddp,Grid,PAW%tphi(:,i),PAW%l(i))
7857 : : PAW%valetau=PAW%valetau+PAW%occ(i)*dp1
7858 : : PAW%tvaletau=PAW%tvaletau+PAW%occ(i)*ddp
7859 : : endif
7860 : : enddo
7861 : : dp1=PAW%coretau+PAW%valetau
7862 : : ddp=PAW%tcoretau+PAW%tvaletau
7863 : : CALL exch(Grid,locald,vxc,sum,exc,itype,&
7864 : : & tau=dp1,vtau=PAW%vtau)
7865 : : CALL exch(Grid,localtd,tvxc,tsum,texc,itype,&
7866 : : & tau=ddp,vtau=PAW%tvtau)
7867 : : if(has_to_print) write(std_out,*) 'tvtau exc texc ', exc, texc
7868 : : ! Kresse form
7869 : : Kd=locald-PAW%core-localtd+PAW%tcore
7870 : : sum=integrator(Grid,Kd)
7871 : : if(has_to_print) write(std_out,*) 'compensation charge in Ktvtau ', sum
7872 : : Kd=localtd+sum*PAW%hatden
7873 : : CALL exch(Grid,Kd,Ktvxc,tsum,texc,itype,&
7874 : : & tau=ddp,vtau=PAW%Ktvtau)
7875 : : LIBPAW_DEALLOCATE(dp1)
7876 : : LIBPAW_DEALLOCATE(ddp)
7877 : : LIBPAW_DEALLOCATE(vxc)
7878 : : LIBPAW_DEALLOCATE(tvxc)
7879 : : LIBPAW_DEALLOCATE(locald)
7880 : : LIBPAW_DEALLOCATE(localtd)
7881 : : LIBPAW_DEALLOCATE(Kd)
7882 : : LIBPAW_DEALLOCATE(Ktvxc)
7883 : : END SUBROUTINE calculate_tvtau
7884 : :
7885 : :
7886 : :
7887 : :
7888 : :
7889 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7890 : : ! 11. Pseudo_sub
7891 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7892 : :
7893 : :
7894 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7895 : : !! subroutine hatL
7896 : : !! Calculates density associated with L component
7897 : : !! normalized to unity
7898 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7899 [ # # ]: 0 : SUBROUTINE hatL(Grid,PAW,l,dhat,besselshapefunction)
7900 : : TYPE(GridInfo), INTENT(IN) :: Grid
7901 : : TYPE(PseudoInfo), INTENT(IN) :: PAW
7902 : : INTEGER, INTENT(IN) :: l
7903 : : logical, intent(in) :: besselshapefunction
7904 : : REAL(dp), INTENT(OUT) :: dhat(:)
7905 : : INTEGER :: n,irc,i
7906 : 0 : REAL(dp), POINTER :: r(:)
7907 : 0 : REAL(dp), ALLOCATABLE :: den(:),a(:)
7908 : : REAL(dp) :: h,con
7909 : : REAL(dp) :: qr,jbes1,jbes2,dum1,dum2,al(2),ql(2)
7910 : 0 : n=Grid%n
7911 : 0 : h=Grid%h
7912 : 0 : r=>Grid%r
7913 : 0 : irc=PAW%irc
7914 [ # # # # : 0 : LIBPAW_ALLOCATE(den,(n))
# # # # #
# ]
7915 [ # # # # : 0 : LIBPAW_ALLOCATE(a,(n))
# # # # ]
7916 [ # # ]: 0 : IF (besselshapefunction) THEN
7917 : 0 : CALL shapebes(al,ql,l,PAW%rc_shap)
7918 [ # # ]: 0 : DO i=1,PAW%irc_shap
7919 : 0 : qr=ql(1)*r(i);CALL jbessel(jbes1,dum1,dum2,l,0,qr)
7920 : 0 : qr=ql(2)*r(i);CALL jbessel(jbes2,dum1,dum2,l,0,qr)
7921 : 0 : den(i)=(al(1)*jbes1+al(2)*jbes2)*r(i)**2
7922 : : ENDDO
7923 [ # # # # ]: 0 : IF (n>PAW%irc_shap) den(PAW%irc_shap+1:n)=0._dp
7924 : : ELSE
7925 [ # # ]: 0 : DO i=1,n
7926 : 0 : den(i)=(r(i)**l)*PAW%hatden(i)
7927 : : ENDDO
7928 [ # # ]: 0 : a(1:n)=den(1:n)*(r(1:n)**l)
7929 : 0 : con=integrator(Grid,a,1,PAW%irc_shap)
7930 [ # # ]: 0 : den=den/con
7931 : : ENDIF
7932 [ # # ]: 0 : dhat=zero
7933 [ # # ]: 0 : dhat(1:n)=den(1:n)
7934 [ # # ]: 0 : LIBPAW_DEALLOCATE(den)
7935 [ # # ]: 0 : LIBPAW_DEALLOCATE(a)
7936 [ # # ]: 0 : END SUBROUTINE hatL
7937 : :
7938 : :
7939 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7940 : : !! SUBROUTINE FillHat(Grid,PAW)
7941 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7942 : 0 : SUBROUTINE FillHat(Grid,PAW,besselshape)
7943 : : logical,intent(in) :: besselshape
7944 : : TYPE(GridInfo) , INTENT(IN):: Grid
7945 : : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
7946 : : INTEGER :: ll,n,l
7947 [ # # ]: 0 : ll=MAXVAL(PAW%TOCCWFN%l(:)); ll=MAX(ll,PAW%lmax); ll=2*ll
7948 : 0 : n=Grid%n
7949 [ # # # # : 0 : LIBPAW_ALLOCATE(PAW%g,(n,ll+1))
# # # # #
# # # # #
# # # # ]
7950 [ # # ]: 0 : DO l=0,ll
7951 : 0 : CALL hatL(Grid,PAW,l,PAW%g(:,l+1),besselshape)
7952 : : ENDDO
7953 : 0 : END SUBROUTINE FillHat
7954 : :
7955 : :
7956 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7957 : : ! SUBROUTINE altdtij
7958 : : ! on input: f1(i) and f2(i) are radial wfn * r for angular momentum l
7959 : : ! on input: t1(i) and t2(i) are smooth radial wfn * r for angular momentum l
7960 : : ! for r > rc, f1=t1, f2=t2
7961 : : ! on output: tij is difference kinetic energy matrix element in Rydberg units
7962 : : ! tij =<f1|T|f2>-<t1|T|t2>
7963 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7964 : 12 : SUBROUTINE altdtij(Grid,PAW,ib,ic,tij,needvtau)
7965 : : logical, intent(in) :: needvtau
7966 : : TYPE(GridInfo), INTENT(IN) :: Grid
7967 : : TYPE(PseudoInfo), INTENT(IN) :: PAW
7968 : : INTEGER, INTENT(IN) :: ib,ic
7969 : : REAL(dp), INTENT(OUT) :: tij
7970 : : INTEGER :: n,i,l,irc
7971 : : REAL(dp) :: angm
7972 : 12 : REAL(dp), POINTER :: r(:)
7973 : 12 : REAL(dp), ALLOCATABLE :: dum(:),tdel1(:),tdel2(:),aux(:),auxp(:)
7974 : 12 : tij=0
7975 : 12 : IF (PAW%l(ib)/=PAW%l(ic)) RETURN
7976 : 12 : n=Grid%n; r=>Grid%r; l=PAW%l(ib); irc=PAW%irc
7977 [ - + + - : 36 : LIBPAW_ALLOCATE(dum,(n))
+ - + - -
+ - + ]
7978 [ - + + - : 24 : LIBPAW_ALLOCATE(tdel1,(n))
- + - + ]
7979 [ - + + - : 24 : LIBPAW_ALLOCATE(tdel2,(n))
- + - + ]
7980 [ - + + - : 24 : LIBPAW_ALLOCATE(aux,(n))
- + - + ]
7981 [ - + + - : 24 : LIBPAW_ALLOCATE(auxp,(n))
- + - + ]
7982 [ + + ]: 24024 : dum=zero
7983 [ + + ]: 17100 : DO i=2,irc
7984 : 17100 : dum(i)=PAW%ophi(i,ib)*PAW%Kop(i,ic) !Corrected 6/6/2023 Thanks to MT
7985 : : ENDDO
7986 : 12 : CALL derivative(Grid,PAW%otphi(:,ic),tdel1)
7987 : 12 : CALL derivative(Grid,tdel1,tdel2)
7988 [ + + + + ]: 48036 : aux=1.0_dp;auxp=0.0_dp
7989 [ - + ]: 12 : if(needvtau) then
7990 [ # # # # : 0 : aux=1._dp+PAW%tvtau
# # # # ]
7991 : 0 : call derivative(Grid,PAW%tvtau,auxp)
7992 : : endif
7993 : 12 : angm=l*(l+1)
7994 [ + + ]: 17100 : DO i=2,irc
7995 : : dum(i)=dum(i)+PAW%otphi(i,ib)*(aux(i)*(tdel2(i)-&
7996 : : & angm*PAW%otphi(i,ic)/(Grid%r(i)**2))+auxp(i)*&
7997 : 17100 : & (tdel1(i)-PAW%otphi(i,ic)/Grid%r(i)))
7998 : : ENDDO
7999 : 12 : tij=integrator(Grid,dum,1,irc)
8000 [ - + ]: 12 : LIBPAW_DEALLOCATE(dum)
8001 [ - + ]: 12 : LIBPAW_DEALLOCATE(tdel1)
8002 [ - + ]: 12 : LIBPAW_DEALLOCATE(tdel2)
8003 [ - + ]: 12 : LIBPAW_DEALLOCATE(aux)
8004 [ - + ]: 12 : LIBPAW_DEALLOCATE(auxp)
8005 [ - + ]: 12 : END SUBROUTINE altdtij
8006 : :
8007 : :
8008 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8009 : : !! SUBROUTINE besselps(Grid,Pot,PAW)
8010 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8011 : 0 : SUBROUTINE besselps(Grid,Pot,PAW)
8012 : : TYPE(Gridinfo), INTENT(IN) :: Grid
8013 : : TYPE(Potentialinfo), INTENT(IN) :: Pot
8014 : : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
8015 : : INTEGER :: i,irc,n
8016 : : real(dp) :: rc,alpha,beta,vv,vvp,AA,QQ,xx(1)
8017 : 0 : real(dp),POINTER :: r(:),rv(:)
8018 : 0 : n=Grid%n
8019 : 0 : r=>Grid%r
8020 : 0 : rv=>Pot%rv
8021 : 0 : irc=PAW%irc_vloc
8022 : 0 : rc=PAW%rc_vloc
8023 : 0 : vv=rv(irc);vvp=Gfirstderiv(Grid,irc,rv)
8024 : 0 : alpha=1.D0-rc*vvp/vv;beta=1.D0
8025 : 0 : call solvbes(xx,alpha,beta,0,1);QQ=xx(1)
8026 : 0 : AA=vv/sin(QQ);QQ=QQ/rc
8027 : 0 : PAW%rveff(1)=0._dp
8028 [ # # ]: 0 : PAW%rveff(irc+1:n)=rv(irc+1:n)
8029 [ # # ]: 0 : do i=2,irc
8030 : 0 : PAW%rveff(i)=AA*sin(QQ*r(i))
8031 : : enddo
8032 : 0 : END SUBROUTINE besselps
8033 : :
8034 : :
8035 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8036 : : !! SUBROUTINE EvaluateTp
8037 : : !! Inverts 5x5 matrix used by troullier subroutine
8038 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8039 : 971 : SUBROUTINE EvaluateTp(l,A,B,C,D,F,coef)
8040 : : INTEGER, INTENT(IN) :: l
8041 : : real(dp), INTENT(IN) :: A,B,C,D,F
8042 : : real(dp), INTENT(OUT) :: coef(6)
8043 : : real(dp) :: t(6,6),coef10,old
8044 : : real(dp), PARAMETER :: small=1.e-10
8045 : : INTEGER :: i,n,iter
8046 : : INTEGER, PARAMETER :: niter=1000
8047 : 971 : old=-1.e30; Coef10=-1; iter=-1
8048 [ + - + + ]: 4891 : DO WHILE (iter < niter .AND. ABS(old-coef10)> small)
8049 : 3920 : iter=iter+1
8050 : 3920 : t=0
8051 : 3920 : Coef(1)=A-Coef10; Coef(2)=B-2*Coef10; Coef(3)=C-2*Coef10;
8052 : 3920 : Coef(4)=D; Coef(5)=F
8053 : 3920 : Coef(6)=-Coef10**2
8054 [ + + ]: 27440 : DO i=1,6
8055 : 23520 : t(1,i)=1
8056 : 23520 : t(2,i)=2*i
8057 : 23520 : t(3,i)=2*i*(2*i-1)
8058 : 23520 : t(4,i)=2*i*(2*i-1)*(2*i-2)
8059 : 27440 : t(5,i)=2*i*(2*i-1)*(2*i-2)*(2*i-3)
8060 : : ENDDO
8061 : 3920 : t(6,1)=2*Coef10; t(6,2)=2*l+5
8062 : 3920 : n=6
8063 : 3920 : CALL linsol(t,Coef,n,6,6,6)
8064 : 3920 : old=Coef10; Coef10=Coef10+Coef(1)
8065 : 4891 : Coef(1)=Coef10
8066 : : ENDDO
8067 [ - + ]: 971 : IF (iter >= niter) THEN
8068 : 0 : LIBPAW_ERROR('Error in EvaluateTP -- no convergence')
8069 : : ENDIF
8070 : 971 : END SUBROUTINE EvaluateTp
8071 : :
8072 : :
8073 : :
8074 : :
8075 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8076 : : ! 12. Pseudo_data
8077 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8078 : :
8079 : :
8080 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8081 : : !! SUBROUTINE InitPAW(PAW,Grid,Orbit)
8082 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8083 : 4 : SUBROUTINE InitPAW(PAW,Grid,Orbit)
8084 : : TYPE(GridInfo), INTENT(IN) :: Grid
8085 : : TYPE(OrbitInfo), INTENT(IN) :: Orbit
8086 : : Type(PseudoInfo), INTENT(INOUT) :: PAW
8087 : : INTEGER :: io,l,n,mxbase,nbase
8088 : : !Initialize logical variables
8089 : 4 : PAW%multi_rc=.false.
8090 : 4 : PAW%poscorenhat=.true.
8091 : 4 : CALL DestroyPAW(PAW)
8092 : : !Compute initial size of basis
8093 : 4 : n=Grid%n
8094 : 4 : nbase=0
8095 [ + + ]: 18 : DO l=0,PAW%lmax
8096 [ + + ]: 109 : DO io=1,Orbit%norbit ! cycle through all configurations
8097 [ + + + + ]: 105 : IF (Orbit%l(io).EQ.l.AND.(.NOT.Orbit%iscore(io))) THEN
8098 : 14 : nbase=nbase+1
8099 : : ENDIF
8100 : : ENDDO
8101 : : ENDDO
8102 : 4 : PAW%mxbase=nbase+6*max(1,PAW%lmax)
8103 : 4 : mxbase=PAW%mxbase !Estimate excess
8104 : 4 : PAW%nbase=nbase
8105 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,*) 'Found ', nbase,' valence basis functions '
8106 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,*) 'Allocating for ', mxbase, ' total basis functions'
8107 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%projshape,(n))
+ - + - -
+ - + ]
8108 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%hatden,(n))
- + - + ]
8109 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%hatpot,(n))
- + - + ]
8110 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%hatshape,(n))
- + - + ]
8111 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%vloc,(n))
- + - + ]
8112 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rveff,(n))
- + - + ]
8113 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%abinitvloc,(n))
- + - + ]
8114 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%abinitnohat,(n))
- + - + ]
8115 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%AErefrv,(n))
- + - + ]
8116 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rvx,(n))
- + - + ]
8117 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%trvx,(n))
- + - + ]
8118 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%den,(n))
- + - + ]
8119 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%tden,(n))
- + - + ]
8120 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%core,(n))
- + - + ]
8121 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%tcore,(n))
- + - + ]
8122 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%coretau,(n))
- + - + ]
8123 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%tcoretau,(n))
- + - + ]
8124 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%valetau,(n))
- + - + ]
8125 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%tvaletau,(n))
- + - + ]
8126 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%vtau,(n))
- + - + ]
8127 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%tvtau,(n))
- + - + ]
8128 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%nhatv,(n))
- + - + ]
8129 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%Ktvtau,(n))
- + - + ]
8130 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%Krveff,(n))
- + - + ]
8131 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%Kunscreen,(n))
- + - + ]
8132 [ + + + + : 24016 : PAW%projshape=0._dp;PAW%hatden=0._dp;PAW%hatpot=0._dp
+ + ]
8133 [ + + + + : 24016 : PAW%hatshape=0._dp;PAW%vloc=0._dp;PAW%rveff=0._dp
+ + ]
8134 [ + + + + ]: 16012 : PAW%abinitvloc=0._dp;PAW%abinitnohat=0._dp
8135 [ + + + + : 24016 : PAW%AErefrv=0._dp;PAW%rvx=0._dp;PAW%trvx=0._dp
+ + ]
8136 [ + + + + : 32020 : PAW%den=0._dp;PAW%tden=0._dp;PAW%core=0._dp;PAW%tcore=0._dp
+ + + + ]
8137 [ + + ]: 8008 : PAW%XCORECORE=0._dp;PAW%nhatv=0._dp
8138 [ + + + + ]: 16012 : PAW%coretau=0._dp;PAW%tcoretau=0._dp
8139 [ + + + + ]: 16012 : PAW%valetau=0._dp;PAW%tvaletau=0._dp
8140 [ + + + + ]: 16012 : PAW%vtau=0._dp;PAW%tvtau=0._dp
8141 [ + + + + : 24016 : PAW%Ktvtau=0._dp;PAW%Krveff=0._dp;PAW%Kunscreen=0._dp
+ + ]
8142 [ - + + - : 16 : LIBPAW_POINTER_ALLOCATE(PAW%phi,(n,mxbase))
- + + - +
- + - - +
- + ]
8143 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%tphi,(n,mxbase))
- + + - -
+ - + ]
8144 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%tp,(n,mxbase))
- + + - -
+ - + ]
8145 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%ophi,(n,mxbase))
- + + - -
+ - + ]
8146 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%otphi,(n,mxbase))
- + + - -
+ - + ]
8147 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%otp,(n,mxbase))
- + + - -
+ - + ]
8148 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%np,(mxbase))
+ - + - -
+ - + ]
8149 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%l,(mxbase))
- + - + ]
8150 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%eig,(mxbase))
+ - + - -
+ - + ]
8151 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%occ,(mxbase))
- + - + ]
8152 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%ck,(mxbase))
- + - + ]
8153 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%vrc,(mxbase))
- + - + ]
8154 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%Kop,(n,mxbase))
- + + - -
+ - + ]
8155 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rng,(mxbase))
- + - + ]
8156 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rcio,(mxbase))
- + - + ]
8157 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%nodes,(mxbase))
- + - + ]
8158 [ + + + + : 444448 : PAW%phi=0._dp;PAW%tphi=0._dp;PAW%tp=0._dp
+ + + + +
+ + + ]
8159 [ + + + + : 444448 : PAW%ophi=0._dp;PAW%otphi=0._dp;PAW%otp=0._dp
+ + + + +
+ + + ]
8160 [ + + + + : 148448 : PAW%eig=0._dp;PAW%occ=0._dp;PAW%vrc=0._dp;PAW%ck=0._dp;PAW%Kop=0._dp
+ + + + +
+ + + ]
8161 [ + + + + : 226 : PAW%rcio=0._dp;PAW%np=0;PAW%l=0
+ + ]
8162 [ + + ]: 4 : if(Orbit%diracrelativistic) then
8163 [ - + + - : 2 : LIBPAW_POINTER_ALLOCATE(PAW%kappa,(mxbase))
- + - + ]
8164 [ + + ]: 19 : PAW%kappa=0
8165 : : endif
8166 [ + + ]: 78 : PAW%rng=Grid%n
8167 [ - + + - : 16 : LIBPAW_POINTER_ALLOCATE(PAW%oij,(mxbase,mxbase))
- + + - +
- + - - +
- + ]
8168 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%dij,(mxbase,mxbase))
- + + - -
+ - + ]
8169 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%wij,(mxbase,mxbase))
- + + - -
+ - + ]
8170 [ + + + + : 4366 : PAW%oij=0._dp;PAW%dij=0._dp;PAW%wij=0._dp
+ + + + +
+ + + ]
8171 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rVf,(n))
- + - + ]
8172 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rtVf,(n))
- + - + ]
8173 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%Kij,(mxbase,mxbase))
- + + - -
+ - + ]
8174 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%Vfij,(mxbase,mxbase))
- + + - -
+ - + ]
8175 [ + + + + : 18920 : PAW%rVf=0._dp;PAW%rtVf=0._dp;PAW%Kij=0._dp;PAW%Vfij=0._dp
+ + + + +
+ + + ]
8176 [ - + ]: 4 : IF (Orbit%exctype=='HF') THEN
8177 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(PAW%lmbd,(Orbit%norbit,mxbase))
# # # # #
# # # # #
# # ]
8178 [ # # # # ]: 0 : PAW%lmbd=0._dp
8179 : : ELSE
8180 : 4 : nullify(PAW%lmbd)
8181 : : ENDIF
8182 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%valencemap,(Orbit%norbit))
+ - + - -
+ - + ]
8183 [ - + ]: 4 : LIBPAW_DATATYPE_ALLOCATE(PAW%OCCwfn,)
8184 [ - + ]: 4 : LIBPAW_DATATYPE_ALLOCATE(PAW%TOCCwfn,)
8185 : 4 : END SUBROUTINE InitPAW
8186 : :
8187 : :
8188 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8189 : : !! Subroutine DestroyPAW(PAW)
8190 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8191 : 8 : Subroutine DestroyPAW(PAW)
8192 : : Type(PseudoInfo), INTENT(INOUT) :: PAW
8193 [ + + ]: 8 : IF(associated(PAW%Ktvtau)) then
8194 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Ktvtau)
8195 : : endif
8196 [ + + ]: 8 : IF(associated(PAW%Krveff)) then
8197 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Krveff)
8198 : : endif
8199 [ + + ]: 8 : if(associated(PAW%Kunscreen)) then
8200 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Kunscreen)
8201 : : endif
8202 [ + + ]: 8 : IF (ASSOCIATED(PAW%rcio)) then
8203 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rcio)
8204 : : endif
8205 [ + + ]: 8 : If (ASSOCIATED(PAW%vloc)) then
8206 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%vloc)
8207 : : endif
8208 [ + + ]: 8 : If (ASSOCIATED(PAW%abinitvloc)) then
8209 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%abinitvloc)
8210 : : endif
8211 [ + + ]: 8 : If (ASSOCIATED(PAW%abinitnohat)) then
8212 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%abinitnohat)
8213 : : endif
8214 [ + + ]: 8 : If (ASSOCIATED(PAW%rveff)) then
8215 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rveff)
8216 : : endif
8217 [ + + ]: 8 : If (ASSOCIATED(PAW%AErefrv)) then
8218 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%AErefrv)
8219 : : endif
8220 [ + + ]: 8 : If (ASSOCIATED(PAW%rvx)) then
8221 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rvx)
8222 : : endif
8223 [ + + ]: 8 : If (ASSOCIATED(PAW%trvx)) then
8224 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%trvx)
8225 : : endif
8226 [ + + ]: 8 : If (ASSOCIATED(PAW%projshape)) then
8227 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%projshape)
8228 : : endif
8229 [ + + ]: 8 : If (ASSOCIATED(PAW%hatshape)) then
8230 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%hatshape)
8231 : : endif
8232 [ + + ]: 8 : If (ASSOCIATED(PAW%hatden)) then
8233 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%hatden)
8234 : : endif
8235 [ + + ]: 8 : If (ASSOCIATED(PAW%hatpot)) then
8236 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%hatpot)
8237 : : endif
8238 [ + + ]: 8 : If (ASSOCIATED(PAW%den)) then
8239 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%den)
8240 : : endif
8241 [ + + ]: 8 : If (ASSOCIATED(PAW%tden)) then
8242 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tden)
8243 : : endif
8244 [ + + ]: 8 : If (ASSOCIATED(PAW%core)) then
8245 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%core)
8246 : : endif
8247 [ + + ]: 8 : If (ASSOCIATED(PAW%tcore)) then
8248 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tcore)
8249 : : endif
8250 [ + + ]: 8 : If (ASSOCIATED(PAW%coretau)) then
8251 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%coretau)
8252 : : endif
8253 [ + + ]: 8 : If (ASSOCIATED(PAW%tcoretau)) then
8254 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tcoretau)
8255 : : endif
8256 [ + + ]: 8 : If (ASSOCIATED(PAW%valetau)) then
8257 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%valetau)
8258 : : endif
8259 [ + + ]: 8 : If (ASSOCIATED(PAW%tvaletau)) then
8260 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tvaletau)
8261 : : endif
8262 [ + + ]: 8 : If (ASSOCIATED(PAW%vtau)) then
8263 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%vtau)
8264 : : endif
8265 [ + + ]: 8 : If (ASSOCIATED(PAW%tvtau)) then
8266 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tvtau)
8267 : : endif
8268 [ + + ]: 8 : If (ASSOCIATED(PAW%nhatv)) then
8269 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%nhatv)
8270 : : endif
8271 [ + + ]: 8 : If (ASSOCIATED(PAW%np)) then
8272 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%np)
8273 : : endif
8274 [ + + ]: 8 : If (ASSOCIATED(PAW%l)) then
8275 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%l)
8276 : : endif
8277 [ + + ]: 8 : If (ASSOCIATED(PAW%nodes)) then
8278 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%nodes)
8279 : : endif
8280 [ + + ]: 8 : If (ASSOCIATED(PAW%kappa)) then
8281 : 1 : LIBPAW_POINTER_DEALLOCATE(PAW%kappa)
8282 : : endif
8283 [ + + ]: 8 : If (ASSOCIATED(PAW%rng)) then
8284 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rng)
8285 : : endif
8286 [ - + ]: 8 : If (ASSOCIATED(PAW%label)) then
8287 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%label)
8288 : : endif
8289 [ + + ]: 8 : If (ASSOCIATED(PAW%phi)) then
8290 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%phi)
8291 : : endif
8292 [ + + ]: 8 : If (ASSOCIATED(PAW%tphi)) then
8293 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tphi)
8294 : : endif
8295 [ + + ]: 8 : If (ASSOCIATED(PAW%tp)) then
8296 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tp)
8297 : : endif
8298 [ + + ]: 8 : If (ASSOCIATED(PAW%ophi)) then
8299 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%ophi)
8300 : : endif
8301 [ + + ]: 8 : If (ASSOCIATED(PAW%otphi)) then
8302 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%otphi)
8303 : : endif
8304 [ + + ]: 8 : If (ASSOCIATED(PAW%otp)) then
8305 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%otp)
8306 : : endif
8307 [ + + ]: 8 : If (ASSOCIATED(PAW%Kop)) then
8308 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Kop)
8309 : : endif
8310 [ + + ]: 8 : If (ASSOCIATED(PAW%eig)) then
8311 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%eig)
8312 : : endif
8313 [ + + ]: 8 : If (ASSOCIATED(PAW%occ)) then
8314 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%occ)
8315 : : endif
8316 [ + + ]: 8 : If (ASSOCIATED(PAW%ck)) then
8317 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%ck)
8318 : : endif
8319 [ + + ]: 8 : If (ASSOCIATED(PAW%vrc)) then
8320 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%vrc)
8321 : : endif
8322 [ + + ]: 8 : If (ASSOCIATED(PAW%oij)) then
8323 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%oij)
8324 : : endif
8325 [ + + ]: 8 : If (ASSOCIATED(PAW%dij)) then
8326 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%dij)
8327 : : endif
8328 [ + + ]: 8 : If (ASSOCIATED(PAW%wij)) then
8329 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%wij)
8330 : : endif
8331 [ + + ]: 8 : If (ASSOCIATED(PAW%rVf)) then
8332 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rVf)
8333 : : endif
8334 [ + + ]: 8 : If (ASSOCIATED(PAW%rtVf)) then
8335 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rtVf)
8336 : : endif
8337 [ - + ]: 8 : If (ASSOCIATED(PAW%g)) then
8338 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%g)
8339 : : endif
8340 [ + + ]: 8 : If (ASSOCIATED(PAW%Kij)) then
8341 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Kij)
8342 : : endif
8343 [ + + ]: 8 : If (ASSOCIATED(PAW%Vfij)) then
8344 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Vfij)
8345 : : endif
8346 [ - + ]: 8 : If (ASSOCIATED(PAW%mLij)) then
8347 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%mLij)
8348 : : endif
8349 [ - + ]: 8 : If (ASSOCIATED(PAW%DR)) then
8350 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DR)
8351 : : endif
8352 [ - + ]: 8 : If (ASSOCIATED(PAW%DRVC)) then
8353 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRVC)
8354 : : endif
8355 [ - + ]: 8 : If (ASSOCIATED(PAW%TXVC)) then
8356 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%TXVC)
8357 : : endif
8358 [ + + ]: 8 : If (ASSOCIATED(PAW%valencemap)) then
8359 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%valencemap)
8360 : : endif
8361 [ - + ]: 8 : If (ASSOCIATED(PAW%lmbd)) then
8362 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%lmbd)
8363 : : endif
8364 [ - + ]: 8 : If (ASSOCIATED(PAW%DRC)) then
8365 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRC)
8366 : : endif
8367 [ - + ]: 8 : If (ASSOCIATED(PAW%DRCC)) then
8368 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRCC)
8369 : : endif
8370 [ - + ]: 8 : If (ASSOCIATED(PAW%DRCjkl)) then
8371 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRCjkl)
8372 : : endif
8373 [ - + ]: 8 : If (ASSOCIATED(PAW%mLic)) then
8374 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%mLic)
8375 : : endif
8376 [ - + ]: 8 : If (ASSOCIATED(PAW%mLcc)) then
8377 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%mLcc)
8378 : : endif
8379 [ - + ]: 8 : If (ASSOCIATED(PAW%Dcj)) then
8380 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%Dcj)
8381 : : endif
8382 [ + + ]: 8 : If (ASSOCIATED(PAW%OCCwfn)) then
8383 : 4 : call DestroyOrbit(PAW%OCCwfn)
8384 [ - + ]: 4 : LIBPAW_DATATYPE_DEALLOCATE(PAW%OCCwfn)
8385 : : end if
8386 [ + + ]: 8 : If (ASSOCIATED(PAW%TOCCwfn)) then
8387 : 4 : call DestroyOrbit(PAW%TOCCwfn)
8388 [ - + ]: 4 : LIBPAW_DATATYPE_DEALLOCATE(PAW%TOCCwfn)
8389 : : end if
8390 : 8 : End Subroutine DestroyPAW
8391 : :
8392 : :
8393 : :
8394 : :
8395 : :
8396 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8397 : : ! 13. Numerov
8398 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8399 : :
8400 : :
8401 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8402 : : !! SUBROUTINE BoundNumerov(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,BDsolve,success)
8403 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8404 [ - + - + : 446 : SUBROUTINE BoundNumerov(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,BDsolve,success)
- + ]
8405 : : TYPE(GridInfo), INTENT(IN) :: Grid
8406 : : real(dp), INTENT(IN) :: rv(:),v0,v0p
8407 : : INTEGER, INTENT(IN) :: nz,l,nroot
8408 : : real(dp), INTENT(INOUT) :: Eig(:), Psi(:,:)
8409 : : LOGICAL, INTENT(IN) :: BDsolve
8410 : : LOGICAL, INTENT(INOUT) :: success
8411 : : INTEGER, PARAMETER :: repeat=4
8412 : : INTEGER :: j
8413 : : ! TODO : BDsolve
8414 [ - + ]: 446 : if(BDsolve) then
8415 : 0 : STOP
8416 : : endif
8417 [ - + ]: 446 : if(has_to_print) write(std_out,*) 'Before newboundsch',l,nroot, Eig(1:nroot)
8418 : 446 : CALL newboundsch(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,success)
8419 [ - + ]: 446 : if(has_to_print) write(std_out,*) 'After newboundsch',l,nroot, Eig(1:nroot)
8420 : : ! adjust sign
8421 [ + + ]: 1231 : Do j=1,nroot
8422 [ + + + + ]: 549779 : if (Psi(3,j)<0._dp) Psi(:,j)=-Psi(:,j)
8423 : : Enddo
8424 : 446 : END SUBROUTINE BoundNumerov
8425 : :
8426 : :
8427 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8428 : : !! SUBROUTINE newboundsch(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,ok)
8429 : : !! pgm to solve radial schroedinger equation for nroot bound state
8430 : : !! energies and wavefunctions for angular momentum l
8431 : : !! with potential rv/r
8432 : : !!
8433 : : !! Assymptotic from of wfn:
8434 : : !! Psi(r) = const*(r**q/kappa)*EXP(-kappa*r), where eig=-kappa**2
8435 : : !! uses Noumerov algorithm
8436 : : !!
8437 : : !! For l=0,1 corrections are needed to approximate wfn(r=0)
8438 : : !! These depend upon:
8439 : : !! e0 (current guess of energy eigenvalue)
8440 : : !! l,nz
8441 : : !! v(0) == v0 electronic potential at r=0
8442 : : !! v'(0) == v0p derivative of electronic potential at r=0
8443 : : !!
8444 : : !! Corrections are also needed for r>n*h, depending on:
8445 : : !! e0 (current guess of energy eigenvalue
8446 : : !! the extrapolated value of rv == r * v
8447 : : !!
8448 : : !! ierr=an nroot digit number indicating status of each root
8449 : : !! a digit of 1 indicates success in converging root
8450 : : !! 2 indicates near success in converging root
8451 : : !! 9 indicates that root not found
8452 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8453 [ - + - + : 446 : SUBROUTINE newboundsch(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,ok)
- + ]
8454 : : TYPE(GridInfo), INTENT(IN) :: Grid
8455 : : real(dp), INTENT(IN) :: rv(:),v0,v0p
8456 : : INTEGER, INTENT(IN) :: nz,l,nroot
8457 : : real(dp), INTENT(INOUT) :: Eig(:), Psi(:,:)
8458 : : LOGICAL, INTENT(OUT) :: ok
8459 : : real(dp), PARAMETER :: convre=tol10,vlrg=10._dp**30
8460 : : INTEGER, PARAMETER :: niter=300
8461 : 446 : real(dp), ALLOCATABLE :: p1(:),p2(:),dd(:)
8462 : : INTEGER :: n,ierr
8463 : : real(dp) :: h,qq
8464 : : real(dp) :: err,convrez,energy,zeroval,zz
8465 : : real(dp) :: scale,emin,emax,best,rout,ppp
8466 : : real(dp) :: rin,dele,x
8467 : : INTEGER :: iter,i,j,node,match,ir,iroot
8468 : : INTEGER :: ifac
8469 : 446 : ifac=0
8470 : 446 : n=Grid%n
8471 : 446 : h=Grid%h
8472 [ - + + - : 1338 : LIBPAW_ALLOCATE(p1,(n))
+ - + - -
+ - + ]
8473 [ - + + - : 892 : LIBPAW_ALLOCATE(p2,(n))
- + - + ]
8474 [ - + + - : 892 : LIBPAW_ALLOCATE(dd,(n))
- + - + ]
8475 : 446 : zz=nz
8476 : : qq=-rv(n)/2
8477 : : IF (qq<0.001_dp) qq=0._dp
8478 : 446 : qq=zero
8479 : 446 : err=n*nz*(h**4); if (err<tol6) err=tol6
8480 : 446 : convrez=convre
8481 [ + - ]: 446 : IF (nz.GT.0) convrez=convre*nz
8482 : 446 : ierr=0
8483 : 446 : emin=(-REAL((nz)**2)/(l+1)**2-0.5_dp)
8484 : 446 : emax=0._dp
8485 [ + + ]: 1231 : DO iroot=1,nroot
8486 : 785 : best=1.d10; dele=1.d10
8487 : 785 : energy=Eig(iroot)
8488 [ + + ]: 785 : IF (energy.LT.emin) energy=emin
8489 [ - + ]: 785 : IF (energy.GT.emax) energy=emax
8490 : 785 : ok=.FALSE.
8491 [ + + ]: 5138 : BigIter: DO iter=1,niter
8492 : : ! start inward integration
8493 : : ! start integration at n
8494 : : ! find classical turning point
8495 : 5131 : CALL ClassicalTurningPoint(Grid,rv,l,energy,match)
8496 : 5131 : match=MAX(5,match)
8497 : 5131 : match=MIN(n-15,match)
8498 : 5131 : ppp=SQRT(ABS(-energy))
8499 [ + + ]: 10272262 : p2=0
8500 : 5131 : p2(n)=wfnend(l,energy,Grid%r(n),Grid%r(n),qq)
8501 : 5131 : p2(n-1)=wfnend(l,energy,Grid%r(n-1),Grid%r(n),qq)
8502 : 5131 : CALL backward_numerov(Grid,l,match,energy,rv,p2)
8503 : 5131 : match=match+6
8504 : 5131 : CALL derivative(Grid,p2,dd,match-5,match+5)
8505 : 5131 : rin=dd(match)/p2(match)
8506 : : ! start outward integration
8507 : : ! correct behavior near r=0
8508 : : ! initialize p1
8509 [ + + ]: 10272262 : p1=0
8510 : 5131 : p1(2)=wfninit(-0.5_dp*rv(1),l,v0,v0p,energy,Grid%r(2))
8511 : 5131 : zeroval=0
8512 [ + + ]: 5131 : IF (l==0) zeroval=rv(1)
8513 [ + + ]: 5131 : IF (l==1) zeroval=2
8514 : 5131 : CALL forward_numerov(Grid,l,match+6,energy,rv,zeroval,p1,node)
8515 : 5131 : CALL derivative(Grid,p1,dd,match-5,match+5)
8516 : 5131 : rout=dd(match)/p1(match)
8517 : : ! check whether node = (iroot-1)
8518 : : ! not enough nodes -- raise energy
8519 [ + + ]: 5138 : IF (node.LT.iroot-1) THEN
8520 : 122 : emin=MAX(emin,energy)-tol5
8521 : 122 : energy=emax-(emax-energy)*ranx()
8522 : 122 : ifac=9
8523 : : ! too many nodes -- lower energy
8524 [ + + ]: 5009 : ELSEIF (node.GT.iroot-1) THEN
8525 [ - + ]: 111 : IF (energy.LT.emin) THEN
8526 : 0 : ierr=ierr+9*(10**(iroot-1))
8527 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'newboundsch error -- emin too high',l,nz,emin,energy
8528 : : RETURN
8529 : : ENDIF
8530 : 111 : emax=MIN(emax,energy+tol5)
8531 : 111 : energy=emin+(energy-emin)*ranx()
8532 : : ! correct number of nodes -- estimate correction
8533 [ + - ]: 4898 : ELSEIF (node.EQ.iroot-1) THEN
8534 [ + + ]: 6216179 : DO j=1,match
8535 : 6216179 : p1(j)=p1(j)/p1(match)
8536 : : ENDDO
8537 [ + + ]: 3599413 : DO j=match,n
8538 : 3599413 : p1(j)=p2(j)/p2(match)
8539 : : ENDDO
8540 : 4898 : scale=1._dp/overlap(Grid,p1,p1)
8541 : 4898 : dele=(rout-rin)*scale
8542 : 4898 : x=ABS(dele)
8543 [ + + ]: 4898 : IF (x.LT.best) THEN
8544 : 2273 : scale=SQRT(scale)
8545 [ + + ]: 4550546 : p1(1:n)=p1(1:n)*scale
8546 [ + + ]: 4550546 : Psi(1:n,iroot)=p1(1:n)
8547 : 2273 : Eig(iroot)=energy
8548 : 2273 : best=x
8549 : : ENDIF
8550 [ + + ]: 4898 : IF (ABS(dele).LE.convrez) THEN
8551 [ - + ]: 778 : if(has_to_print) WRITE(STD_OUT,*) 'converged iter with dele' , iter,dele
8552 : 778 : ok=.TRUE.
8553 : : ! eigenvalue found
8554 : 778 : ierr=ierr+10**(iroot-1)
8555 [ + + ]: 778 : IF (iroot+1.LE.nroot) THEN
8556 : 339 : emin=energy+tol5
8557 : 339 : emax=0
8558 : 339 : energy=(emin+emax)/2
8559 [ - + ]: 339 : IF (energy.LT.emin) energy=emin
8560 [ - + ]: 339 : IF (energy.GT.emax) energy=emax
8561 : 339 : best=1.d10
8562 : : ENDIF
8563 : : EXIT BigIter
8564 : : ENDIF
8565 [ + - ]: 4120 : IF (ABS(dele).GT.convrez) THEN
8566 : 4120 : energy=energy+dele
8567 : : ! if energy is out of range, pick random energy in correct range
8568 [ + + + + ]: 4120 : IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) &
8569 : 2029 : & energy=emin+(emax-emin)*ranx()
8570 : : ifac=2
8571 : : ENDIF
8572 : : ENDIF
8573 : : ENDDO BigIter !iter
8574 [ + + ]: 1231 : IF (.NOT.ok) THEN
8575 : 7 : ierr=ierr+ifac*(10**(iroot-1))
8576 [ - + ]: 7 : if(has_to_print) WRITE(STD_OUT,*) 'no convergence in newboundsch',iroot,l,dele,energy
8577 [ - + ]: 7 : if(has_to_print) WRITE(STD_OUT,*) ' best guess of eig, dele = ',Eig(iroot),best
8578 [ - + ]: 7 : IF (iroot.LT.nroot) THEN
8579 [ # # ]: 0 : DO ir=iroot+1,nroot
8580 : 0 : ierr=ierr+9*(10**(ir-1))
8581 : : ENDDO
8582 : : ENDIF
8583 : : ! reset wfn with hydrogenic form
8584 : 7 : j=iroot+l+1
8585 [ + + ]: 14014 : Psi(:,iroot)=0
8586 : 7 : ppp=(j)*SQRT(ABS(Eig(iroot)))
8587 [ + + ]: 14007 : DO i=2,n
8588 : 14007 : Psi(i,iroot)=hwfn(ppp,j,l,Grid%r(i))
8589 : : ENDDO
8590 : : ENDIF
8591 : : ENDDO !iroot
8592 [ - + ]: 446 : if(has_to_print) WRITE(STD_OUT,'("finish boundsch with eigenvalues -- ",1p,20e15.7)') &
8593 : 0 : & Eig(1:nroot)
8594 [ - + ]: 446 : LIBPAW_DEALLOCATE(p1)
8595 [ - + ]: 446 : LIBPAW_DEALLOCATE(p2)
8596 [ - + ]: 446 : LIBPAW_DEALLOCATE(dd)
8597 [ - + ]: 446 : if(has_to_print) WRITE(STD_OUT,*) 'returning from newboundsch -- ierr=',ierr
8598 : 0 : END SUBROUTINE newboundsch
8599 : :
8600 : :
8601 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8602 : : !! FUNCTION wfninit(nz,l,v0,v0p,energy,r)
8603 : : !! returns the solution of the Schroedinger equation near r=0
8604 : : !! using power series expansion
8605 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8606 : 5210 : FUNCTION wfninit(nz,l,v0,v0p,energy,r)
8607 : : real(dp) :: wfninit
8608 : : INTEGER, INTENT(IN) :: l
8609 : : real(dp), INTENT(IN) :: nz,v0,v0p,energy,r
8610 : : real(dp) :: c1,c2,c3
8611 : 5210 : c1=-REAL(nz)/(l+1._dp)
8612 : 5210 : c2=((v0-energy)-2*nz*c1)/(4*l+6._dp)
8613 : 5210 : c3=(v0p+(v0-energy)*c1-2*nz*c2)/(6*l+12._dp)
8614 : 5210 : wfninit=(r**(l+1))*(1+r*(c1+r*(c2+r*c3)))
8615 : 5210 : END FUNCTION wfninit
8616 : :
8617 : :
8618 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8619 : : !! FUNCTION wfnend(l,energy,r,rN)
8620 : : !!
8621 : : !! Find asymptotic form of wavefunction
8622 : : !! assuming equations has form
8623 : : !! (- d^2 +l(l+1) -2q +b^2 )
8624 : : !! ( --- ------ --- ) P(r) = 0
8625 : : !! ( dr^2 r^2 r )
8626 : : !! where b^2=-energy
8627 : : !!
8628 : : !! P(r) = exp(-b*(r-rN))*r^(q/b)(1+(l*(l+1)-q/b)*(q/b-1)/(2*b)/r + ...)
8629 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8630 : 10262 : FUNCTION wfnend(l,energy,r,rN,qq)
8631 : : real(dp) :: wfnend
8632 : : INTEGER, INTENT(IN) :: l
8633 : : real(dp), INTENT(IN) :: energy,r,rN,qq
8634 : : real(dp) :: qbb,b,wfn,cn,term,fac
8635 : : INTEGER :: i
8636 : : INTEGER, PARAMETER :: last=5
8637 [ + - ]: 10262 : IF (energy>=0._dp) THEN
8638 : 10262 : wfnend=zero
8639 : : RETURN
8640 : : ENDIF
8641 : 10262 : b=SQRT(-energy)
8642 : 10262 : qbb=qq/b
8643 : 10262 : cn=l*(l+1)
8644 : 10262 : fac=DDEXP(-b*(r-rN))*(r**qbb)
8645 : 10262 : term=1._dp; wfn=zero
8646 [ + + ]: 61572 : DO i=1,last
8647 : 51310 : wfn=wfn+term
8648 [ + + ]: 61572 : IF (i<last) THEN
8649 : 41048 : term=-term*((qbb-i+1)*(qbb-i)-cn)/(2*b*i)/r
8650 : : ENDIF
8651 : : ENDDO
8652 : 10262 : wfnend=fac*wfn
8653 : 10262 : END FUNCTION wfnend
8654 : :
8655 : :
8656 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8657 : : !! subroutine unboundsch(Grid,rv,v0,v0p,nr,l,energy,wfn,nodes)
8658 : : !! pgm to solve radial schroedinger equation for unbound states
8659 : : !! at energy 'energy' and at angular momentum l
8660 : : !!
8661 : : !! with potential rv/r, given in uniform mesh of n points
8662 : : !! r=i*h, i=1,...n-1 ;assuming p(r)=C*r**(l+1)*polynomial(r) for r==0;
8663 : : !! p((n+1)*h)=0
8664 : : !! nz=nuclear charge
8665 : : !!
8666 : : !! uses Noumerov algorithm
8667 : : !!
8668 : : !! For l=0,1 corrections are needed to approximate wfn(r=0)
8669 : : !! These depend upon:
8670 : : !! e0 (current guess of energy eigenvalue)
8671 : : !! l,nz
8672 : : !! v(0) == v0 electronic potential at r=0
8673 : : !! v'(0) == v0p derivative of electronic potential at r=0
8674 : : !!
8675 : : !! also returns node == number of nodes for calculated state
8676 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8677 [ - + - + ]: 13 : SUBROUTINE unboundsch(Grid,rv,v0,v0p,nr,l,energy,wfn,nodes)
8678 : : TYPE(GridInfo), INTENT(IN) :: Grid
8679 : : real(dp), INTENT(IN) :: rv(:),v0,v0p
8680 : : INTEGER, INTENT(IN) :: nr,l
8681 : : real(dp), INTENT(IN) :: energy
8682 : : real(dp), INTENT(INOUT) :: wfn(:)
8683 : : INTEGER, INTENT(INOUT) :: nodes
8684 : : INTEGER :: n
8685 : : real(dp) :: zeroval,scale
8686 : 13 : n=Grid%n
8687 [ - + ]: 13 : IF (nr > n) THEN
8688 : 0 : LIBPAW_ERROR('Error in unboundsch -- nr > n')
8689 : : ENDIF
8690 : : ! initialize wfn
8691 [ + + ]: 25432 : wfn=0
8692 : 13 : wfn(2)=wfninit(-0.5_dp*rv(1),l,v0,v0p,energy,Grid%r(2))
8693 : 13 : zeroval=0
8694 [ + + ]: 13 : if (l==0) zeroval=rv(1)
8695 [ + + ]: 13 : if (l==1) zeroval=2
8696 : 13 : call forward_numerov(Grid,l,nr,energy,rv,zeroval,wfn,nodes)
8697 : : ! normalize to unity within integration range
8698 : 13 : scale=1._dp/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr)
8699 : 13 : scale=SIGN(SQRT(scale),wfn(nr-2))
8700 [ + + ]: 19444 : wfn(1:nr)=wfn(1:nr)*scale
8701 : 13 : END SUBROUTINE unboundsch
8702 : :
8703 : :
8704 : :
8705 : :
8706 : :
8707 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8708 : : ! 14. tools_mod
8709 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8710 : :
8711 : :
8712 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8713 : : !! SUBROUTINE extractword(wordindex,stringin,stringout)
8714 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8715 : 30 : SUBROUTINE extractword(wordindex,stringin,stringout)
8716 : : INTEGER, INTENT(IN) :: wordindex
8717 : : CHARACTER(*), INTENT(IN) :: stringin
8718 : : CHARACTER(*), INTENT(OUT) :: stringout
8719 : : INTEGER :: i,j,n,str,fin,icount
8720 : 30 : stringout=''
8721 : 30 : n=LEN(stringin)
8722 [ + - ]: 30 : i=INDEX(stringin,'!');IF (i==0) i=n
8723 [ + - ]: 30 : j=INDEX(stringin,'#');IF (j==0) j=n
8724 : 30 : n=MIN(i,j,n)
8725 : 30 : str=1;fin=n
8726 [ + + ]: 74 : DO icount=1,MAX(1,wordindex-1)
8727 [ + - ]: 58 : DO i=str,n
8728 [ + + ]: 58 : IF (stringin(i:i)/=' ') EXIT
8729 : : ENDDO
8730 : 44 : str=i
8731 [ + - ]: 44 : IF (n>str) THEN
8732 [ + - ]: 152 : DO i=str+1,n
8733 [ + + ]: 152 : IF(stringin(i:i)==' ') EXIT
8734 : : ENDDO
8735 : : fin=i
8736 : : ENDIF
8737 [ + + ]: 74 : IF (wordindex>2) THEN
8738 [ - + ]: 24 : IF (fin<n) THEN
8739 : 24 : str=fin+1
8740 : : ELSE
8741 : : EXIT
8742 : : ENDIF
8743 : : ENDIF
8744 : : ENDDO
8745 [ + + ]: 30 : IF (wordindex>1) THEN
8746 [ + - ]: 20 : IF (fin>=n) RETURN
8747 [ + + ]: 1180 : DO i=fin+1,n
8748 [ + + ]: 1180 : IF (stringin(i:i)/=' ') EXIT
8749 : : ENDDO
8750 : 20 : str=i
8751 [ + + ]: 20 : IF (n>str) THEN
8752 [ + - ]: 44 : DO i=str+1,n
8753 [ + + ]: 44 : IF(stringin(i:i)==' ') EXIT
8754 : : ENDDO
8755 : : fin=i
8756 : : ENDIF
8757 : : ENDIF
8758 [ + - + - ]: 30 : stringout=stringin(str:fin)
8759 [ + - ]: 30 : END SUBROUTINE extractword
8760 : :
8761 : :
8762 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8763 : : !! SUBROUTINE UpperCase(str)
8764 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8765 : 20 : SUBROUTINE UpperCase(str)
8766 : : CHARACTER(*), INTENT(INOUT) :: str
8767 : : INTEGER :: i, j, k
8768 : 20 : j = LEN(Str)
8769 [ + + ]: 3972 : DO i=1, j
8770 : 3952 : k = IACHAR(str(i:i))
8771 [ + + ]: 3972 : IF ((k>96) .AND. (k<123)) str(i:i) = ACHAR(k-32)
8772 : : END DO
8773 : 20 : RETURN
8774 : : END SUBROUTINE UpperCase
8775 : :
8776 : :
8777 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8778 : : !! FUNCTION checkline2(inputline,in1,in2)
8779 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8780 : : LOGICAL FUNCTION checkline2(inputline,in1,in2)
8781 : : CHARACTER(*), INTENT(IN) :: inputline
8782 : : CHARACTER(*), INTENT(IN) :: in1,in2
8783 : : INTEGER :: leninput,len1,len2
8784 : : CHARACTER(120) :: inputline_u,in1_u,in2_u
8785 : : inputline_u=trim(inputline) ; call UpperCase(inputline_u)
8786 : : in1_u=trim(in1) ; call UpperCase(in1_u)
8787 : : in2_u=trim(in2) ; call UpperCase(in2_u)
8788 : : leninput=len(trim(inputline));len1=len(trim(in1));len2=len(trim(in2))
8789 : : checkline2=.false.
8790 : : if (leninput==len1) checkline2=(inputline_u(1:len1)==trim(in1))
8791 : : if ((.not.checkline2).and.leninput==len2) checkline2=(inputline_u(1:len2)==trim(in2))
8792 : : RETURN
8793 : : END FUNCTION checkline2
8794 : :
8795 : :
8796 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8797 : : ! eliminate_comment - Eliminate comment on the right of a line (! or #)
8798 : : ! line - string to convert (output replaces input)
8799 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8800 : 169 : SUBROUTINE eliminate_comment(line)
8801 : : CHARACTER(*), INTENT(INOUT) :: line
8802 : : INTEGER :: i,i0
8803 : 169 : i0=-1 ; i=1
8804 [ + + + + ]: 29606 : DO WHILE (i0<0.AND.i<LEN(line))
8805 : 29437 : i=i+1
8806 [ + + + - ]: 29606 : IF (line(i:i)=="!".OR.line(i:i)=="#") i0=i
8807 : : END DO
8808 [ + + + - : 169 : IF (i0 >1) line=line(1:i0-1)
+ - ]
8809 : : IF (i0==1) line=""
8810 : 169 : END SUBROUTINE eliminate_comment
8811 : :
8812 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8813 : : !! stripchar - Eliminate blanks
8814 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8815 : 6 : FUNCTION stripchar(inputchar)
8816 : : CHARACTER(20) :: stripchar
8817 : : CHARACTER*(*), INTENT(IN) :: inputchar
8818 : : INTEGER :: i,j,n
8819 : 6 : n=LEN(inputchar)
8820 [ + + ]: 126 : DO i=1,20
8821 : 126 : stripchar(i:i)=''
8822 : : ENDDO
8823 : : j=0
8824 [ + + ]: 72 : DO i=1,n
8825 [ + + ]: 72 : IF (inputchar(i:i) /= '') THEN
8826 : 48 : j=j+1
8827 : 48 : stripchar(j:j)=inputchar(i:i)
8828 : : ENDIF
8829 : : ENDDO
8830 : 6 : END FUNCTION stripchar
8831 : :
8832 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8833 : : !! mkname - Subroutine to take an integer (.le. 4 digits) and return it
8834 : : !! in the form of a character string
8835 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8836 : 6 : SUBROUTINE mkname(i,stuff)
8837 : : CHARACTER(4) stuff
8838 : : INTEGER i,i1,i10,i100,i1000
8839 : 6 : stuff='?'
8840 [ - + ]: 6 : IF (i.GT.9999) i=MOD(i,10000)
8841 : 6 : i1000=i/1000
8842 : 6 : i100=(i-1000*i1000)/100
8843 : 6 : i10=(i-1000*i1000-100*i100)/10
8844 : 6 : i1=(i-1000*i1000-100*i100-10*i10)
8845 [ - + ]: 6 : IF (i.GE.1000) THEN
8846 : 0 : stuff=CHAR(i1000+48)//CHAR(i100+48)//CHAR(i10+48)//CHAR(i1+48)
8847 : 0 : RETURN
8848 : : ENDIF
8849 [ - + ]: 6 : IF (i.GE.100) THEN
8850 : 0 : stuff=CHAR(i100+48)//CHAR(i10+48)//CHAR(i1+48)
8851 : 0 : RETURN
8852 : : ENDIF
8853 [ - + ]: 6 : IF (i.GE.10) THEN
8854 : 0 : stuff=CHAR(i10+48)//CHAR(i1+48)
8855 : 0 : RETURN
8856 : : ENDIF
8857 [ + - ]: 6 : IF (i.GE.0) stuff=CHAR(i1+48)
8858 : : RETURN
8859 : : END SUBROUTINE mkname
8860 : :
8861 : :
8862 : :
8863 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8864 : : ! 15. radialked
8865 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8866 : :
8867 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8868 : : ! subroutine unboundked(Grid,Pot,nr,l,energy,wfn,nodes)
8869 : : ! pgm to solve radial kinetic energy derivative equations for unbound states
8870 : : ! at energy 'energy' and at angular momentum l
8871 : : ! with potential rv/r, given in uniform linear or log mesh of n points
8872 : : ! assuming p(r)=C*r**(l+1)*polynomial(r) for r==0;
8873 : : ! nz=nuclear chargedd
8874 : : ! Does not use Noumerov algorithm -- but uses coupled first-order
8875 : : ! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
8876 : : ! also returns node == number of nodes for calculated state
8877 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8878 [ # # ]: 0 : SUBROUTINE unboundked(Grid,Pot,nr,l,energy,wfn,nodes)
8879 : : TYPE(GridInfo), INTENT(IN) :: Grid
8880 : : TYPE(PotentialInfo), INTENT(IN) :: Pot
8881 : : INTEGER, INTENT(IN) :: nr,l
8882 : : REAL(dp), INTENT(IN) :: energy
8883 : : REAL(dp), INTENT(INOUT) :: wfn(:)
8884 : : INTEGER, INTENT(INOUT) :: nodes
8885 : : INTEGER :: n,istart
8886 : 0 : REAL(dp) :: oneplusvtau(Grid%n),dvtaudr(Grid%n)
8887 : : REAL(dp) :: scale,qq,zxc
8888 : 0 : REAL(dp), allocatable :: lwfn(:),zz(:,:,:),yy(:,:)
8889 : 0 : n=Grid%n
8890 [ # # ]: 0 : IF (nr > n) THEN
8891 : 0 : write(std_out,*) 'Error in unboundked -- nr > n', nr,n
8892 : 0 : STOP
8893 : : ENDIF
8894 : 0 : call Set_Pot(Grid,Pot,qq,zxc,oneplusvtau,dvtaudr)
8895 [ # # # # : 0 : LIBPAW_ALLOCATE(lwfn,(nr))
# # # # #
# # # ]
8896 [ # # # # : 0 : LIBPAW_ALLOCATE(zz,(2,2,nr))
# # # # #
# # # ]
8897 [ # # # # : 0 : LIBPAW_ALLOCATE(yy,(2,nr))
# # # # #
# # # ]
8898 [ # # # # : 0 : lwfn=0;zz=0;yy=0;
# # # # #
# # # ]
8899 : 0 : call wfnkedinit(Grid,l,Pot%nz,wfn,lwfn,istart,zxc,oneplusvtau,dvtaudr)
8900 : 0 : call setupforcfdsol(Grid,Pot%rv,1,istart,nr,l,energy,wfn,lwfn,yy,zz,oneplusvtau,dvtaudr)
8901 : 0 : call cfdsoliter(Grid,zz,yy,istart,nr)
8902 : 0 : call getwfnfromcfdsol(1,nr,yy,wfn)
8903 : 0 : nodes=countnodes(2,nr,wfn)
8904 : : ! normalize to unity within integration range
8905 : 0 : scale=1._dp/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr)
8906 : 0 : scale=SIGN(SQRT(scale),wfn(nr-2))
8907 [ # # ]: 0 : wfn(1:nr)=wfn(1:nr)*scale
8908 [ # # ]: 0 : LIBPAW_DEALLOCATE(lwfn)
8909 [ # # ]: 0 : LIBPAW_DEALLOCATE(yy)
8910 [ # # ]: 0 : LIBPAW_DEALLOCATE(zz)
8911 : 0 : END SUBROUTINE unboundked
8912 : :
8913 : :
8914 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8915 : : ! Set_Pot
8916 : : ! Version with polynomial fitting of vtau for 0<=r<=0.001
8917 : : ! and corresponding reseting of oneplusvtau and dvtaudr in that range
8918 : : ! NAWH 4/6/2021
8919 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8920 [ # # # # ]: 0 : Subroutine Set_Pot(Grid,Pot,qq,zxc,oneplusvtau,dvtaudr)
8921 : : real(dp),intent(inout) :: qq,zxc
8922 : : real(dp),intent(inout) :: oneplusvtau(:),dvtaudr(:)
8923 : : Type(GridInfo), INTENT(IN) :: Grid
8924 : : TYPE(PotentialInfo), INTENT(IN) :: Pot
8925 : : INTEGER :: n
8926 : : REAL(dp),parameter :: smallr=0.001_dp
8927 : : INTEGER, parameter :: order=4
8928 : 0 : n=Grid%n
8929 : : ! check for possible ionic charge
8930 : 0 : qq=-Pot%rv(n)/two
8931 [ # # ]: 0 : if(qq<0.001_dp) qq=zero
8932 [ # # # # ]: 0 : oneplusvtau=0._dp; dvtaudr=0._dp
8933 [ # # ]: 0 : oneplusvtau=1._dp+Pot%vtau
8934 : 0 : call derivative(Grid,Pot%vtau,dvtaudr)
8935 : 0 : zxc=Pot%rvx(1)
8936 : 0 : END Subroutine Set_Pot
8937 : :
8938 : :
8939 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8940 : : ! SUBROUTINE wfnkedinit(Grid,l,nz,v0,wfn,lwfn,istart)
8941 : : ! returns the solution of the modified KS equations near r=0
8942 : : ! using power series expansion assuming including vtau contributions
8943 : : ! wfn=P(r) lwfn=(1+vtau)*dP/dr
8944 : : ! P(r)~~(r**(l+1))*(1+c1*r)
8945 : : ! Assumes v(r) ~~ -2*nz/r+zxc/r for r-->0
8946 : : ! Assumes vtau(r) -- t0 +t1*r for r-->0
8947 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8948 [ # # # # ]: 0 : SUBROUTINE wfnkedinit(Grid,l,nz,wfn,lwfn,istart,zxc,oneplusvtau,dvtaudr)
8949 : : real(dp),intent(in) :: zxc
8950 : : real(dp),intent(in) :: oneplusvtau(:),dvtaudr(:)
8951 : : Type(GridInfo), INTENT(IN) :: Grid
8952 : : INTEGER, INTENT(IN) :: l,nz
8953 : : REAL(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
8954 : : INTEGER, INTENT(OUT) :: istart
8955 : : REAL(dp) :: rr,c1,t1,t0
8956 : : INTEGER :: i
8957 : 0 : t0=oneplusvtau(1);t1=dvtaudr(1)
8958 [ # # # # ]: 0 : wfn=zero; lwfn=zero
8959 : 0 : c1=-(two*nz-zxc+l*t1)/(two*(l+1)*(oneplusvtau(1)))
8960 : 0 : istart=6
8961 [ # # ]: 0 : do i=1,istart
8962 : 0 : rr=Grid%r(i)
8963 : 0 : wfn(i)=1+rr*c1
8964 : 0 : lwfn(i)=(rr**l)*((l+1)*wfn(i)+rr*(c1))
8965 : 0 : lwfn(i)=(t0+t1*rr)*lwfn(i)
8966 : 0 : wfn(i)=wfn(i)*(rr**(l+1))
8967 : : enddo
8968 : 0 : End SUBROUTINE wfnkedinit
8969 : :
8970 : :
8971 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8972 : : !! subroutine setupforcfdsol(Grid,rv,i1,i2,n,l,energy,wfn,lwfn,yy,zz)
8973 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8974 [ # # # # : 0 : subroutine setupforcfdsol(Grid,rv,i1,i2,n,l,energy,wfn,lwfn,yy,zz,oneplusvtau,dvtaudr)
# # # # #
# # # #
# ]
8975 : : Type(gridinfo), INTENT(IN) :: Grid
8976 : : real(dp),intent(in) :: oneplusvtau(:),dvtaudr(:)
8977 : : INTEGER, INTENT(IN) :: i1,i2,n,l
8978 : : REAL(dp), INTENT(IN) :: energy
8979 : : REAL(dp), INTENT(IN) :: wfn(:),lwfn(:),rv(:)
8980 : : REAL(dp), INTENT(INOUT) :: yy(:,:),zz(:,:,:)
8981 : : INTEGER :: i
8982 : : REAL(dp) :: x
8983 : 0 : x=l*(l+1)
8984 [ # # # # : 0 : yy=zero;zz=zero
# # # # #
# ]
8985 [ # # ]: 0 : yy(1,i1:i2)=wfn(i1:i2)
8986 [ # # ]: 0 : yy(2,i1:i2)=lwfn(i1:i2)
8987 [ # # ]: 0 : do i=1,n
8988 : 0 : zz(1,2,i)=1._dp/oneplusvtau(i)
8989 [ # # ]: 0 : if(i==1) then
8990 : 0 : zz(2,1,i)=0._dp
8991 : : else
8992 : : zz(2,1,i)=oneplusvtau(i)*x/(Grid%r(i)*Grid%r(i))+&
8993 : 0 : & dvtaudr(i)/Grid%r(i)+(rv(i)/Grid%r(i)-energy)
8994 : : endif
8995 : : enddo
8996 : 0 : end subroutine setupforcfdsol
8997 : :
8998 : :
8999 : :
9000 : :
9001 : :
9002 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9003 : : ! 16. splinesolver
9004 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9005 : :
9006 : :
9007 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9008 : : ! Program uses two grids -- "universal grid" Grid
9009 : : ! and modified grid Grids, with fixed Grids%n=401 and ns=400
9010 : : ! and Grids%r0=0.1 which are found to work well for splinesolver
9011 : : ! Internally need to omit origin and so ns=Grids%n-1
9012 : : ! For MGGA case (needvtau=.true.) also need fine linear grid
9013 : : ! Gridf
9014 : : ! Setup local private grid
9015 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9016 : 0 : SUBROUTINE initsplinesolver(Grid,splns,splr0,needvtau,spline)
9017 : : type(splinesolvinfo),intent(inout) :: spline
9018 : : logical,intent(in) :: needvtau
9019 : : Type(GridInfo), INTENT(IN) :: Grid !Input universal grid
9020 : : INTEGER, INTENT(IN) :: splns !spline grid
9021 : : REAL(dp), INTENT(IN) :: splr0 !spline r0
9022 : : INTEGER :: i,nf
9023 : : REAL(dp) :: hf
9024 : 0 : spline%r0=splr0
9025 : 0 : spline%ns=splns
9026 : 0 : spline%h=log(1._dp+Grid%r(Grid%n)/spline%r0)/spline%ns
9027 : 0 : call initgridwithn(spline%Grids,2,spline%ns+1,spline%r0,spline%h) !local loggrid
9028 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'initsplinesolve ', spline%r0,spline%ns,spline%h
9029 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%u,(spline%ns+1))
# # # # #
# # # # #
# # ]
9030 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%pref,(spline%ns+1))
# # # # #
# ]
9031 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%rr1,(spline%ns+1))
# # # # #
# ]
9032 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%rr2,(spline%ns+1))
# # # # #
# ]
9033 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%srv,(spline%ns+1))
# # # # #
# ]
9034 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%svtau,(spline%ns+1))
# # # # #
# ]
9035 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%sdvt,(spline%ns+1))
# # # # #
# ]
9036 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%soneplusvt,(spline%ns+1))
# # # # #
# ]
9037 [ # # ]: 0 : do i=1,spline%ns+1
9038 : 0 : spline%u(i)=(i-1)*spline%h
9039 : 0 : spline%pref(i)=exp(0.5_dp*spline%u(i))
9040 : 0 : spline%rr1(i)=((spline%Grids%r(i)+spline%r0))
9041 : 0 : spline%rr2(i)=((spline%Grids%r(i)+spline%r0)**2)
9042 : : enddo
9043 [ # # ]: 0 : if(needvtau) then ! set up fine linear grid
9044 : 0 : nf=20001
9045 : 0 : hf=Grid%r(Grid%n)/(nf-1)
9046 : 0 : call initgridwithn(spline%Gridf,1,nf,0._dp,hf) !local fine linear grid
9047 [ # # # # ]: 0 : LIBPAW_ALLOCATE(spline%fvtau,(nf))
9048 [ # # # # ]: 0 : LIBPAW_ALLOCATE(spline%fdvtaudr,(nf))
9049 [ # # # # ]: 0 : LIBPAW_ALLOCATE(spline%frvx,(nf))
9050 [ # # # # ]: 0 : LIBPAW_ALLOCATE(spline%fden,(nf))
9051 [ # # # # ]: 0 : LIBPAW_ALLOCATE(spline%ftau,(nf))
9052 [ # # # # : 0 : spline%fvtau=0._dp;spline%fdvtaudr=0._dp;spline%frvx=0._dp
# # ]
9053 [ # # # # ]: 0 : spline%fden=0._dp;spline%ftau=0._dp
9054 : : endif
9055 [ # # ]: 0 : spline%soneplusvt=1._dp;
9056 [ # # # # ]: 0 : spline%svtau=0._dp;spline%sdvt=0._dp
9057 : 0 : END SUBROUTINE initsplinesolver
9058 : :
9059 : :
9060 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9061 : : !!
9062 : : !! SUBROUTINE initpotforsplinesolver
9063 : : !!
9064 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9065 [ # # # # ]: 0 : SUBROUTINE initpotforsplinesolver(Grid,Pot,den,tau,spline,itype)
9066 : : type(splinesolvinfo),intent(inout) :: spline
9067 : : Type(GridInfo), INTENT(IN) :: Grid
9068 : : integer,intent(in) :: itype
9069 : : Type(Potentialinfo), INTENT(INOUT) :: Pot !Universal grid
9070 : : REAL(dp), INTENT(IN) :: den(:),tau(:) !Universal grid
9071 : : INTEGER :: i,n
9072 : 0 : REAL(dp), allocatable :: dum(:),dum1(:)
9073 : : REAL(dp) :: etxc,eexc
9074 : 0 : n=Grid%n
9075 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'initpot ', n,spline%ns
9076 [ # # ]: 0 : If (Pot%needvtau) then
9077 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(spline%ns+1))
# # # # #
# # # #
# ]
9078 [ # # # # : 0 : LIBPAW_ALLOCATE(dum1,(spline%ns+1))
# # # # ]
9079 : 0 : call interpfunc(n,Grid%r,den,spline%Gridf%n,spline%Gridf%r,spline%fden)
9080 : 0 : call interpfunc(n,Grid%r,tau,spline%Gridf%n,spline%Gridf%r,spline%ftau)
9081 : 0 : call exch(spline%Gridf,spline%fden,spline%frvx,etxc,eexc,itype=itype,tau=spline%ftau,vtau=spline%fvtau)
9082 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'called exch from splinesolver ', eexc
9083 : 0 : call nderiv(spline%Gridf%h,spline%fvtau,spline%fdvtaudr,spline%Gridf%n,i)
9084 [ # # # # : 0 : dum=Pot%rvn+Pot%rvh ! presumably these are smooth
# # # # ]
9085 : 0 : call interpfunc(n,Grid%r,dum,spline%ns+1,spline%Grids%r,spline%srv)
9086 : 0 : call interpfunc(spline%Gridf%n,spline%Gridf%r,spline%frvx,spline%Grids%n,spline%Grids%r,dum1)
9087 [ # # # # ]: 0 : spline%srv=spline%srv+dum1
9088 : 0 : call interpfunc(spline%Gridf%n,spline%Gridf%r,spline%fvtau,spline%Grids%n,spline%Grids%r,spline%svtau)
9089 : 0 : call interpfunc(spline%Gridf%n,spline%Gridf%r,spline%fdvtaudr,spline%Grids%n,spline%Grids%r,spline%sdvt)
9090 [ # # # # : 0 : spline%soneplusvt=1._dp+spline%svtau
# # # # ]
9091 [ # # # # ]: 0 : spline%sdvt=spline%sdvt*spline%Grids%drdu ! needed in algorithm
9092 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
9093 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum1)
9094 : : else ! finegrid not needed
9095 : 0 : call interpfunc(n,Grid%r,Pot%rv,spline%ns+1,spline%Grids%r,spline%srv)
9096 [ # # ]: 0 : spline%soneplusvt=1._dp;
9097 [ # # # # ]: 0 : spline%svtau=0._dp;spline%sdvt=0._dp
9098 : : endif
9099 [ # # # # ]: 0 : END SUBROUTINE initpotforsplinesolver
9100 : :
9101 : :
9102 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9103 : : !! SUBROUTINE Boundsplinesolver(Grid,l,neig,eig,wfn,otau,OK)
9104 : : !! Note that although the universal Grid and the local Grids
9105 : : !! have the same range, they differ by the number of points and
9106 : : !! the r0 parameter.
9107 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9108 [ # # # # : 0 : SUBROUTINE Boundsplinesolver(Grid,l,neig,eig,wfn,otau,OK,spline)
# # ]
9109 : : type(splinesolvinfo),intent(inout) :: spline
9110 : : Type(GridInfo), INTENT(IN) :: Grid
9111 : : INTEGER, INTENT(IN) :: l,neig
9112 : : REAL(dp), INTENT(INOUT) :: eig(:),wfn(:,:),otau(:,:)
9113 : : LOGICAL, INTENT(OUT) :: OK
9114 : 0 : real(dp), allocatable :: A(:,:),B(:,:),G(:,:),D(:),DL(:),DU(:),work(:)
9115 : 0 : real(dp), allocatable :: vl(:,:),vr(:,:),wr(:),wi(:)
9116 : 0 : integer, allocatable :: lut(:)
9117 : 0 : REAL(dp), allocatable :: P(:),MP(:)
9118 : 0 : REAL(dp), allocatable :: dum(:),dP1(:)
9119 : 0 : REAL(dp), allocatable :: F1(:,:),F2(:,:),S(:),E(:),V(:)
9120 : : integer :: i,m,n, info,lwork,nu
9121 : : real(dp) :: ol,x
9122 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'entering boundspline with l,neig ', l, neig
9123 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'in splinesolver '
9124 : 0 : OK=.false.
9125 : 0 : n=spline%ns+1 !Grids%n within this routine only
9126 : 0 : nu=Grid%n ! Universal grid
9127 : 0 : ol=l*(l+1)
9128 : 0 : lwork=spline%ns**2
9129 [ # # # # : 0 : LIBPAW_ALLOCATE(A,(spline%ns,spline%ns))
# # # # #
# # # # #
# # ]
9130 [ # # # # : 0 : LIBPAW_ALLOCATE(B,(spline%ns,spline%ns))
# # # # #
# # # ]
9131 [ # # # # : 0 : LIBPAW_ALLOCATE(G,(spline%ns,spline%ns))
# # # # #
# # # ]
9132 [ # # # # : 0 : LIBPAW_ALLOCATE(D,(spline%ns))
# # # # #
# # # ]
9133 [ # # # # : 0 : LIBPAW_ALLOCATE(DL,(spline%ns))
# # # # ]
9134 [ # # # # : 0 : LIBPAW_ALLOCATE(DU,(spline%ns))
# # # # ]
9135 [ # # # # : 0 : LIBPAW_ALLOCATE(work,(lwork))
# # # # #
# # # ]
9136 [ # # # # : 0 : LIBPAW_ALLOCATE(vl,(spline%ns,spline%ns))
# # # # #
# # # ]
9137 [ # # # # : 0 : LIBPAW_ALLOCATE(vr,(spline%ns,spline%ns))
# # # # #
# # # ]
9138 [ # # # # : 0 : LIBPAW_ALLOCATE(wr,(spline%ns))
# # # # ]
9139 [ # # # # : 0 : LIBPAW_ALLOCATE(wi,(spline%ns))
# # # # ]
9140 [ # # # # : 0 : LIBPAW_ALLOCATE(lut,(spline%ns))
# # # # #
# # # ]
9141 [ # # # # : 0 : LIBPAW_ALLOCATE(P,(n))
# # # # #
# # # ]
9142 [ # # # # : 0 : LIBPAW_ALLOCATE(MP,(n))
# # # # ]
9143 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(nu))
# # # # #
# # # ]
9144 [ # # # # : 0 : LIBPAW_ALLOCATE(dP1,(nu))
# # # # ]
9145 [ # # # # : 0 : LIBPAW_ALLOCATE(F1,(spline%ns,spline%ns))
# # # # #
# # # ]
9146 [ # # # # : 0 : LIBPAW_ALLOCATE(F2,(spline%ns,spline%ns))
# # # # #
# # # ]
9147 [ # # # # : 0 : LIBPAW_ALLOCATE(S,(n))
# # # # ]
9148 [ # # # # : 0 : LIBPAW_ALLOCATE(E,(n))
# # # # ]
9149 [ # # # # : 0 : LIBPAW_ALLOCATE(V,(n))
# # # # ]
9150 [ # # ]: 0 : D(1:spline%ns)=2._dp
9151 [ # # ]: 0 : DL(1:spline%ns-1)=0.5_dp
9152 [ # # ]: 0 : DU(1:spline%ns-1)=0.5_dp
9153 : : !correct first row assuming wfn=r^(l+1)*(W0+r*W1)
9154 : 0 : D(1)=0.5_dp*(5._dp+two*l)/(1._dp+l)
9155 [ # # # # ]: 0 : B=0._dp
9156 [ # # ]: 0 : do i=1,spline%ns
9157 : 0 : B(i,i)=1._dp
9158 : : enddo
9159 : 0 : call dgtsv(spline%ns,spline%ns,DL,D,DU,B,spline%ns,info)
9160 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'Completed dgtsv with info = '
9161 [ # # # # ]: 0 : A=0._dp
9162 [ # # ]: 0 : do i=1,spline%ns
9163 : 0 : A(i,i)=-2._dp
9164 : : enddo
9165 [ # # ]: 0 : do i=1,spline%ns-1
9166 : 0 : A(i,i+1)=1._dp
9167 : 0 : A(i+1,i)=1._dp
9168 : : enddo
9169 : : ! correct first row values
9170 : 0 : A(1,1)=-0.5_dp*(l+4._dp);
9171 [ # # # # ]: 0 : A=3.0_dp*A/(spline%h**2)
9172 [ # # # # ]: 0 : G=0._dp
9173 [ # # # # : 0 : G=MATMUL(B,A) ! G stores transformation to find M=G*y
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
9174 : : ! Calculate full matrix
9175 [ # # # # : 0 : A=0.0_dp;S=0.0_dp;E=0.0_dp;V=0.0_dp
# # # # #
# ]
9176 : : ! These arrays have the full range 1..n
9177 [ # # # # : 0 : S=-spline%soneplusvt/spline%rr2
# # # # ]
9178 [ # # # # : 0 : E=-spline%sdvt/spline%rr2
# # # # ]
9179 [ # # # # : 0 : V=0.5_dp*E-0.25_dp*S !Including only non diverging term
# # # # ]
9180 [ # # ]: 0 : do i=2,n
9181 : : V(i)=V(i)+spline%soneplusvt(i)*ol/(spline%Grids%r(i)**2)&
9182 : : & +spline%sdvt(i)/(spline%Grids%r(i)*spline%rr1(i)) &
9183 : 0 : & +spline%srv(i)/spline%Grids%r(i)
9184 : : enddo
9185 [ # # # # : 0 : F1=0._dp;F2=0._dp
# # # # ]
9186 [ # # ]: 0 : do i=1,spline%ns
9187 : 0 : F1(i,i)=S(i+1)-E(i+1)*spline%h/three
9188 : 0 : F1(i,i+1)=-E(i+1)*spline%h/six
9189 : 0 : F2(i,i)=V(i+1)-E(i+1)/spline%h
9190 : 0 : F2(i,i+1)=E(i+1)/spline%h
9191 : : ENDDO
9192 [ # # # # : 0 : A=MATMUL(F1,G)+F2
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
9193 : 0 : call dgeev('N','V',spline%ns,A,spline%ns,wr,wi,vl,spline%ns,vr,spline%ns,work,lwork,info)
9194 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'dgeev completed with info = ',info
9195 [ # # ]: 0 : if (info/=0) then
9196 : 0 : OK=.false.
9197 : 0 : return
9198 : : endif
9199 : 0 : call real_InsSort(wr,lut,.true.)
9200 [ # # # # : 0 : if(has_to_print) write(std_out,*) 'Results for l = ', l, (wr(lut(i)),i=1,10)
# # ]
9201 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'enumeration for neig solutions ', neig
9202 [ # # ]: 0 : do m=1,neig
9203 [ # # ]: 0 : if(has_to_print) write(std_out,'(1p,2e20.8)') wr(lut(m)),wi(lut(m))
9204 : 0 : eig(m)=wr(lut(m))
9205 [ # # # # ]: 0 : D=vr(:,lut(m)) !Q
9206 [ # # # # : 0 : DL=MATMUL(G,D) !MQ
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
9207 : : ! now extend grid to r=0 Still Q and MQ
9208 [ # # # # ]: 0 : P=0.0_dp;MP=0.0_dp
9209 [ # # ]: 0 : P(2:spline%ns+1)=D(1:spline%ns)
9210 [ # # ]: 0 : MP(2:spline%ns+1)=DL(1:spline%ns)
9211 [ # # ]: 0 : if(l==0) then
9212 [ # # ]: 0 : dum=0
9213 [ # # ]: 0 : do i=2,10
9214 : 0 : dum(i)=P(i)/spline%Grids%r(i)
9215 : : enddo
9216 : 0 : call extrapolate(dum)
9217 : 0 : x=1._dp/(S(1)-E(1)*spline%h/three)
9218 : 0 : MP(1)=(E(1)*(MP(2)*spline%h/six-P(2))-(spline%sdvt(1)/spline%rr1(1)+spline%srv(1))*dum(1))*x
9219 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'MP(1) for l=0',MP(1),dum(1)
9220 : : endif
9221 [ # # ]: 0 : if(l==1) then
9222 [ # # ]: 0 : dum=0.0_dp
9223 [ # # ]: 0 : do i=2,10
9224 : 0 : dum(i)=P(i)/(spline%Grids%r(i)**2)
9225 : : enddo
9226 : 0 : call extrapolate(dum)
9227 : 0 : x=1._dp/(S(1)-E(1)*spline%h/three)
9228 : 0 : MP(1)=(E(1)*(MP(2)*spline%h/six-P(2))-(two*spline%soneplusvt(1))*dum(1))*x
9229 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'MP(1) for l=1',MP(1),dum(1)
9230 : : endif
9231 [ # # # # : 0 : MP=spline%pref*(MP-0.25_dp*P)/spline%rr2
# # # # ]
9232 [ # # # # : 0 : P=spline%pref*P
# # # # ]
9233 : 0 : call specialinterp(n,spline%Grids%r,P,MP,Grid%n,Grid%r,wfn(:,m),dP1(:))
9234 [ # # # # ]: 0 : dum=0._dp; dum(2:nu)=wfn(2:nu,m)/Grid%r(2:nu)
9235 : 0 : call extrapolate(dum)
9236 [ # # ]: 0 : do i=1,nu
9237 : 0 : otau(i,m)= (dP1(i)-dum(i))**2+l*(l+1)*(dum(i))**2
9238 : : enddo
9239 : 0 : x=overlap(Grid,wfn(:,m),wfn(:,m))
9240 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'overlap integral ', x
9241 : 0 : x=1._dp/x
9242 [ # # ]: 0 : otau(:,m)=x*otau(:,m)
9243 : 0 : x=sqrt(x)
9244 [ # # ]: 0 : wfn(:,m)=x*wfn(:,m) ! should be normalized now
9245 : : enddo
9246 : 0 : OK=.true.
9247 [ # # ]: 0 : LIBPAW_DEALLOCATE(A)
9248 [ # # ]: 0 : LIBPAW_DEALLOCATE(B)
9249 [ # # ]: 0 : LIBPAW_DEALLOCATE(G)
9250 [ # # ]: 0 : LIBPAW_DEALLOCATE(D)
9251 [ # # ]: 0 : LIBPAW_DEALLOCATE(DL)
9252 [ # # ]: 0 : LIBPAW_DEALLOCATE(DU)
9253 [ # # ]: 0 : LIBPAW_DEALLOCATE(work)
9254 [ # # ]: 0 : LIBPAW_DEALLOCATE(vl)
9255 [ # # ]: 0 : LIBPAW_DEALLOCATE(vr)
9256 [ # # ]: 0 : LIBPAW_DEALLOCATE(wr)
9257 [ # # ]: 0 : LIBPAW_DEALLOCATE(wi)
9258 [ # # ]: 0 : LIBPAW_DEALLOCATE(lut)
9259 [ # # ]: 0 : LIBPAW_DEALLOCATE(P)
9260 [ # # ]: 0 : LIBPAW_DEALLOCATE(MP)
9261 [ # # ]: 0 : LIBPAW_DEALLOCATE(dP1)
9262 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
9263 [ # # ]: 0 : LIBPAW_DEALLOCATE(F1)
9264 [ # # ]: 0 : LIBPAW_DEALLOCATE(F2)
9265 [ # # ]: 0 : LIBPAW_DEALLOCATE(S)
9266 [ # # ]: 0 : LIBPAW_DEALLOCATE(E)
9267 [ # # ]: 0 : LIBPAW_DEALLOCATE(V)
9268 [ # # # # : 0 : end SUBROUTINE Boundsplinesolver
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
9269 : :
9270 : :
9271 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9272 : : !! SUBROUTINE deallocatesplinesolver
9273 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9274 : 4 : SUBROUTINE deallocatesplinesolver(spline,needvtau)
9275 : : type(splinesolvinfo),intent(inout) :: spline
9276 : : logical,intent(in) :: needvtau
9277 [ - + ]: 4 : if (allocated(spline%u)) then
9278 : 0 : LIBPAW_DEALLOCATE(spline%u)
9279 : : endif
9280 [ - + ]: 4 : if (allocated(spline%pref)) then
9281 : 0 : LIBPAW_DEALLOCATE(spline%pref)
9282 : : endif
9283 [ - + ]: 4 : if (allocated(spline%rr1)) then
9284 : 0 : LIBPAW_DEALLOCATE(spline%rr1)
9285 : : endif
9286 [ - + ]: 4 : if (allocated(spline%rr2)) then
9287 : 0 : LIBPAW_DEALLOCATE(spline%rr2)
9288 : : endif
9289 [ - + ]: 4 : if (allocated(spline%srv)) then
9290 : 0 : LIBPAW_DEALLOCATE(spline%srv)
9291 : : endif
9292 [ - + ]: 4 : if (allocated(spline%svtau)) then
9293 : 0 : LIBPAW_DEALLOCATE(spline%svtau)
9294 : : endif
9295 [ - + ]: 4 : if (allocated(spline%soneplusvt)) then
9296 : 0 : LIBPAW_DEALLOCATE(spline%soneplusvt)
9297 : : endif
9298 : 4 : call destroygrid(spline%Grids)
9299 [ - + ]: 4 : if(needvtau) then
9300 [ # # ]: 0 : LIBPAW_DEALLOCATE(spline%fvtau)
9301 [ # # ]: 0 : LIBPAW_DEALLOCATE(spline%fdvtaudr)
9302 [ # # ]: 0 : LIBPAW_DEALLOCATE(spline%frvx)
9303 [ # # ]: 0 : LIBPAW_DEALLOCATE(spline%fden)
9304 [ # # ]: 0 : LIBPAW_DEALLOCATE(spline%ftau)
9305 : 0 : call destroygrid(spline%Gridf)
9306 : : endif
9307 : 4 : END SUBROUTINE deallocatesplinesolver
9308 : :
9309 : :
9310 : :
9311 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9312 : : ! 17. radialdirac
9313 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9314 : :
9315 : :
9316 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9317 : : !! SUBROUTINE boundD(Grid,Pot,eig,wfn,lwfn,kappa,nroot,emin,ierr,success)
9318 : : !! pgm to solve radial Dirac relativistic equation for nroot bound state
9319 : : !! energies and wavefunctions for spin orbit parameter kappa
9320 : : !! with potential rv/r, given in uniform linear or log mesh of n points
9321 : : !! nz=nuclear charge
9322 : : !! emin=is estimate of lowest eigenvalue; used if nz=0
9323 : : !! otherwise, set to the value of -(nz/(l+1))**2
9324 : : !! It is assumed that the wavefunction has np-l-1 nodes, where
9325 : : !! np is the principal quantum number-- np=1,2,..nroot
9326 : : !! Does not use Noumerov algorithm -- but uses coupled first-order
9327 : : !! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
9328 : : !! Corrections are also needed for r>n*h, depending on:
9329 : : !! e0 (current guess of energy eigenvalue
9330 : : !! the extrapolated value of rv == r * v
9331 : : !! ierr=an nroot digit number indicating status of each root
9332 : : !! a digit of 1 indicates success in converging root
9333 : : !! 2 indicates near success in converging root
9334 : : !! 9 indicates that root not found
9335 : : !! first check how many roots expected = ntroot (returned as argument)
9336 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9337 [ - + - + : 206 : SUBROUTINE boundD(Grid,Pot,eig,wfn,lwfn,kappa,nroot,emin,ierr,success)
- + ]
9338 : : TYPE(GridInfo), INTENT(IN) :: Grid
9339 : : TYPE(PotentialInfo), INTENT(INout) :: Pot
9340 : : REAL(dp), INTENT(INOUT) :: eig(:),wfn(:,:),lwfn(:,:)
9341 : : INTEGER, INTENT(IN) :: kappa,nroot
9342 : : INTEGER, INTENT(INOUT) :: ierr
9343 : : REAL(dp), INTENT(INOUT) :: emin
9344 : : LOGICAL, INTENT(INOUT) :: success
9345 : : REAL(dp), PARAMETER :: convre=1.d-10,vlrg=1.d30
9346 : : REAL(dp), PARAMETER :: ftr=0.5_dp/InvFineStruct
9347 : : INTEGER, PARAMETER :: niter=1000
9348 : 206 : REAL(dp), POINTER :: rv(:)
9349 : 206 : REAL(dp), ALLOCATABLE :: p1(:),lp1(:),p2(:),lp2(:),dd(:)
9350 : : INTEGER :: n
9351 : : REAL(dp) :: nz,h,v0,v0p
9352 : : REAL(dp) :: err,convrez,energy
9353 : : REAL(dp) :: scale,emax,best,rout
9354 : : REAL(dp) :: arg,rin,dele,x
9355 : : INTEGER :: iter,i,j,node,match,mxroot,ntroot,ir,iroot,l
9356 : : INTEGER :: ifac,istart,iend
9357 : : LOGICAL :: ok
9358 : : Real(dp) :: A0,B0,A1,B1,s
9359 : : REAL(dp), allocatable :: zz(:,:,:),yy(:,:)
9360 : 206 : n=Grid%n
9361 : 206 : h=Grid%h
9362 : 126 : if (kappa<0) l=-kappa-1
9363 [ + + ]: 206 : if (kappa>0) l=kappa
9364 [ - + + - : 618 : LIBPAW_ALLOCATE(p1,(n))
+ - + - -
+ - + ]
9365 [ - + + - : 412 : LIBPAW_ALLOCATE(lp1,(n))
- + - + ]
9366 [ - + + - : 412 : LIBPAW_ALLOCATE(p2,(n))
- + - + ]
9367 [ - + + - : 412 : LIBPAW_ALLOCATE(lp2,(n))
- + - + ]
9368 [ - + + - : 412 : LIBPAW_ALLOCATE(dd,(n))
- + - + ]
9369 [ - + + - : 618 : LIBPAW_ALLOCATE(zz,(2,2,n))
+ - + - -
+ - + ]
9370 [ - + + - : 618 : LIBPAW_ALLOCATE(yy,(2,n))
+ - + - -
+ - + ]
9371 : 206 : success=.true.
9372 : 206 : nz=Pot%nz
9373 : 206 : v0=Pot%v0
9374 : 206 : v0p=Pot%v0p
9375 : 206 : rv=>Pot%rv
9376 : 206 : err=n*nz*(h**4)
9377 : 206 : convrez=convre
9378 [ + - ]: 206 : IF (nz>0.001_dp) convrez=convre*nz
9379 : 206 : ierr=0
9380 [ - + ]: 206 : if(has_to_print) WRITE(STD_OUT,*) 'z ,kappa, l = ',nz,kappa,l
9381 : : ! check how many roots expected by integration outward at
9382 : : ! energy = 0
9383 : 206 : energy = zero
9384 : 206 : call Dzeroexpand(Grid,Pot,kappa,energy,A0,A1,B0,B1,s)
9385 [ + + + + : 4122266 : zz=zero;yy=zero
+ + + + +
+ ]
9386 : 206 : call wfnDinit(Grid,p1,lp1,istart,A0,A1,B0,B1,s,Pot%finitenucleus)
9387 : : !start outward integration
9388 : 206 : call prepareforcfdsolD(Grid,1,istart,n,kappa,p1,lp1,yy,zz,Pot%ww,Pot%jj)
9389 : 206 : call cfdsoliter(Grid,zz,yy,istart,n)
9390 : 206 : call getwfnfromcfdsolD(1,n,yy,p1,lp1)
9391 : 206 : node=countnodes(2,n,p1)
9392 [ - + ]: 206 : if(has_to_print) WRITE(STD_OUT,*) ' nodes at e=0 ', node
9393 : 206 : mxroot=node+1
9394 : 206 : ntroot=node
9395 [ - + ]: 206 : IF (mxroot.LT.nroot) THEN
9396 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*)'error in boundD - for l = ',l
9397 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) nroot,' states requested but only',mxroot,' possible'
9398 [ # # ]: 0 : DO ir=mxroot+1,nroot
9399 : 0 : ierr=ierr+9*(10**(ir-1))
9400 : : ENDDO
9401 : 0 : success=.false.
9402 : : ENDIF
9403 : 206 : mxroot=min0(mxroot,nroot)
9404 [ - + ]: 206 : IF (nz.EQ.0) energy=-ABS(emin)
9405 [ + - ]: 206 : IF (nz.NE.0) energy=-1.1_dp*(nz/(l+1._dp))**2
9406 : 206 : emin=energy-err
9407 : 206 : emax=0._dp
9408 [ + + ]: 630 : DO iroot=1,mxroot
9409 : 424 : best=1.d10; dele=1.d10
9410 : 424 : energy=emin+err
9411 [ - + ]: 424 : IF (energy.LT.emin) energy=emin
9412 [ - + ]: 424 : IF (energy.GT.emax) energy=emax
9413 : 17024 : ok=.FALSE.
9414 [ + + ]: 17024 : BigIter: DO iter=1,niter
9415 : : ! start inward integration
9416 : : ! start integration at n
9417 : 17014 : call Dzeroexpand(Grid,Pot,kappa,energy,A0,A1,B0,B1,s)
9418 : : ! find classical turning point
9419 : 17014 : call ClassicalTurningPoint(Grid,Pot%rv,l,energy,match)
9420 : 17014 : match=max(match,10); match=min(match,n-20)
9421 : 17014 : call wfnDasym(Grid,p2,lp2,energy,iend)
9422 : 17014 : call prepareforcfdsolD(Grid,n-iend,n,n,kappa,p2,lp2,yy,zz,Pot%ww,Pot%jj)
9423 : 17014 : call cfdsoliter(Grid,zz,yy,n-iend,match)
9424 : 17014 : call getwfnfromcfdsolD(match,n,yy,p2,lp2)
9425 : 17014 : match=match+6
9426 : 17014 : rin=lp2(match)/p2(match)
9427 : 17014 : call wfnDinit(Grid,p1,lp1,istart,A0,A1,B0,B1,s,Pot%finitenucleus)
9428 : 17014 : call prepareforcfdsolD(Grid,1,istart,n,kappa,p1,lp1,yy,zz,Pot%ww,Pot%jj)
9429 : 17014 : call cfdsoliter(Grid,zz,yy,istart,match+6)
9430 : 17014 : call getwfnfromcfdsolD(1,match+6,yy,p1,lp1)
9431 : 17014 : node= countnodes(2,match+6,p1)
9432 : 17014 : rout=lp1(match)/p1(match)
9433 : : ! check whether node = (iroot-1)
9434 : : ! not enough nodes -- raise energy
9435 [ + + ]: 51052 : IF (node.LT.iroot-1) THEN
9436 : 439 : emin=MAX(emin,energy)-err
9437 : 439 : energy=emax-(emax-energy)*ranx()
9438 : 439 : ifac=9
9439 : : ! too many nodes -- lower energy
9440 [ + + ]: 16575 : ELSEIF (node.GT.iroot-1) THEN
9441 [ - + ]: 281 : IF (energy.LE.emin) THEN
9442 : 0 : ierr=ierr+9*(10**(iroot-1))
9443 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'boundD error -- emin too high',l,nz,emin,energy
9444 [ # # ]: 0 : IF (energy.LE.emin-1.d-10) THEN
9445 : 0 : STOP
9446 : : ENDIF
9447 : : ENDIF
9448 : 281 : emax=MIN(emax,energy+err)
9449 : 281 : energy=emin+(energy-emin)*ranx()
9450 : : ! correct number of nodes -- estimate correction
9451 [ + - ]: 16294 : ELSEIF (node.EQ.iroot-1) THEN
9452 [ + + ]: 9003011 : DO j=1,match
9453 : 8986717 : p1(j)=p1(j)/p1(match)
9454 : 9003011 : lp1(j)=ftr*lp1(j)/p1(match)
9455 : : ENDDO
9456 [ + + ]: 23650165 : DO j=match,n
9457 : 23633871 : p1(j)=p2(j)/p2(match)
9458 : 23650165 : lp1(j)=ftr*lp2(j)/p2(match)
9459 : : ENDDO
9460 : 16294 : scale=overlap(Grid,p1,p1)+overlap(Grid,lp1,lp1)
9461 : 16294 : dele=(rout-rin)/scale
9462 : 16294 : x=ABS(dele)
9463 [ + + ]: 16294 : IF (x.LT.best) THEN
9464 : 3039 : scale=1._dp/SQRT(scale)
9465 [ + + ]: 6084078 : p1(1:n)=p1(1:n)*scale
9466 [ + + ]: 6084078 : lp1(1:n)=lp1(1:n)*scale
9467 : 3039 : call filter(n,p1,machine_zero)
9468 : 3039 : call filter(n,lp1,machine_zero)
9469 [ + + ]: 6084078 : wfn(1:n,iroot)=p1(1:n)
9470 [ + + ]: 6084078 : lwfn(1:n,iroot)=lp1(1:n)
9471 : 3039 : eig(iroot)=energy
9472 : 3039 : best=x
9473 : : ENDIF
9474 [ + + ]: 16294 : IF (ABS(dele).LE.convrez) THEN
9475 : 414 : ok=.TRUE.
9476 : : ! eigenvalue found
9477 : 414 : ierr=ierr+10**(iroot-1)
9478 [ + + ]: 414 : IF (iroot+1.LE.mxroot) THEN
9479 : 218 : emin=energy+err
9480 : 218 : emax=zero
9481 : 218 : energy=(emin+emax)/2
9482 [ - + ]: 218 : IF (energy.LT.emin) energy=emin
9483 [ - + ]: 218 : IF (energy.GT.emax) energy=emax
9484 : 218 : best=1.d10
9485 : : ENDIF
9486 : : EXIT BigIter
9487 : : ENDIF
9488 [ + - ]: 15880 : IF (ABS(dele).GT.convrez) THEN
9489 : 15880 : energy=energy+dele
9490 : : ! if energy is out of range, pick random energy in correct range
9491 [ + + + + ]: 15880 : IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) then
9492 : 12713 : energy=emin+(emax-emin)*ranx()
9493 : : endif
9494 : : ifac=2
9495 : : ENDIF
9496 : : ENDIF
9497 : : ENDDO BigIter !iter
9498 : 206 : IF (.NOT.ok) THEN
9499 : 10 : success=.false.
9500 : 10 : ierr=ierr+ifac*(10**(iroot-1))
9501 [ - + ]: 10 : if(has_to_print) WRITE(STD_OUT,*) 'no convergence in boundD',iroot,l,dele,energy
9502 [ - + ]: 10 : if(has_to_print) WRITE(STD_OUT,*) ' best guess of eig, dele = ',eig(iroot),best
9503 [ - + ]: 10 : IF (iroot.LT.mxroot) THEN
9504 [ # # ]: 0 : DO ir=iroot+1,mxroot
9505 : 0 : ierr=ierr+9*(10**(ir-1))
9506 : : ENDDO
9507 : : ENDIF
9508 : : ! reset wfn with hydrogenic form
9509 : 10 : j=iroot+l+1
9510 [ + + ]: 20020 : wfn(:,iroot)=zero
9511 [ + + ]: 20020 : lwfn(:,iroot)=zero
9512 : 10 : x=(j)*sqrt(abs(eig(iroot)))
9513 [ + + ]: 20010 : do i=2,n
9514 : 20010 : call dirachwfn(j,kappa,x,Grid%r(i),arg,wfn(i,iroot),lwfn(i,iroot))
9515 : : enddo
9516 : : ENDIF
9517 : : ENDDO !iroot
9518 [ - + ]: 206 : LIBPAW_DEALLOCATE(p1)
9519 [ - + ]: 206 : LIBPAW_DEALLOCATE(lp1)
9520 [ - + ]: 206 : LIBPAW_DEALLOCATE(p2)
9521 [ - + ]: 206 : LIBPAW_DEALLOCATE(lp2)
9522 [ - + ]: 206 : LIBPAW_DEALLOCATE(dd)
9523 [ - + ]: 206 : LIBPAW_DEALLOCATE(yy)
9524 [ - + ]: 206 : LIBPAW_DEALLOCATE(zz)
9525 [ - + ]: 206 : if(has_to_print) write(std_out,*) 'returning from boundD -- ierr=',ierr
9526 [ + + ]: 412 : END SUBROUTINE BoundD
9527 : :
9528 : :
9529 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9530 : : !! subroutine prepareforcfdsolD(Grid,i1,i2,n,kappa,wfn,lwfn,yy,zz)
9531 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9532 [ - + - + : 34234 : subroutine prepareforcfdsolD(Grid,i1,i2,n,kappa,wfn,lwfn,yy,zz,ww,jj)
- + - + -
+ - + ]
9533 : : real(dp),intent(in) :: ww(:),jj(:)
9534 : : Type(gridinfo), INTENT(IN) :: Grid
9535 : : INTEGER, INTENT(IN) :: i1,i2,n,kappa
9536 : : REAL(dp), INTENT(IN) :: wfn(:),lwfn(:)
9537 : : REAL(dp), INTENT(OUT) :: yy(:,:),zz(:,:,:)
9538 : : INTEGER :: i
9539 [ + + + + : 685090808 : yy=zero;zz=zero
+ + + + +
+ ]
9540 [ + + ]: 239638 : yy(1,i1:i2)=wfn(i1:i2)
9541 [ + + ]: 239638 : yy(2,i1:i2)=lwfn(i1:i2)
9542 [ + + ]: 68502234 : do i=2,n
9543 : 68468000 : zz(1,1,i)=-kappa/Grid%r(i)
9544 : 68468000 : zz(1,2,i)=jj(i)
9545 : 68468000 : zz(2,2,i)=kappa/Grid%r(i)
9546 : 68502234 : zz(2,1,i)=-ww(i)
9547 : : enddo
9548 : 34234 : end subroutine prepareforcfdsolD
9549 : :
9550 : :
9551 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9552 : : !! Subroutine Dzeroexpand(Grid,Pot,kappa,energy)
9553 : : !! If finitenucleus==.true. assumes potential is non-singular
9554 : : !! at origin and Pot%v0 and Pot%v0p are properly set
9555 : : !! -- actually not programmed yet
9556 : : !! Otherwise, assumes nuclear potential is -2*Z/r
9557 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9558 : 17220 : Subroutine Dzeroexpand(Grid,Pot,kappa,energy,A0,A1,B0,B1,s,nr)
9559 : : Real(dp), intent(inout) :: A0,B0,A1,B1,s
9560 : : Type(GridInfo), INTENT(IN) :: Grid
9561 : : Type(PotentialInfo), INTENT(INout) :: Pot
9562 : : Integer, INTENT(IN) :: kappa
9563 : : Real(dp), INTENT(IN) :: energy
9564 : : Integer, optional, INTENT(IN) :: nr
9565 : : Integer :: n
9566 : : Real(dp) :: nz,alpha2,balpha2
9567 : : Real(dp) :: x,y,z
9568 : 17220 : n=Grid%n
9569 [ - + ]: 17220 : if (present(nr)) n=min(n,nr)
9570 : 17220 : nz=Pot%nz
9571 [ + + + + ]: 68931660 : Pot%ww=zero; Pot%jj=zero
9572 : 17220 : balpha2=InvFineStruct**2
9573 : 17220 : alpha2=1._dp/balpha2
9574 [ + + ]: 34457220 : Pot%ww(2:n)=energy-Pot%rv(2:n)/Grid%r(2:n)
9575 [ + + ]: 34457220 : Pot%jj(2:n)=(1._dp + 0.25_dp*alpha2*Pot%ww(2:n))
9576 [ + - ]: 17220 : if (.not.Pot%finitenucleus) then
9577 : 17220 : s=sqrt(kappa*kappa-alpha2*nz**2)
9578 : 17220 : A0=1._dp
9579 : 17220 : B0=2._dp*(s+kappa)*balpha2/nz
9580 : 17220 : z=two*s+one
9581 : 17220 : x=alpha2*(nz**2)
9582 : 17220 : y=four*alpha2+energy-Pot%v0
9583 : 17220 : A1=(four*alpha2*x+y*(s+kappa-two*x))/(two*nz*z)
9584 : 17220 : y=two*alpha2+energy-Pot%v0
9585 : 17220 : B1=-(y*(two*(s+kappa)+energy-Pot%v0))/z
9586 : : else ! version for finite nuclear size
9587 : 0 : write(std_out,*) 'Dirac case not yet programmed for finite nucleus'
9588 : 0 : stop
9589 : : endif
9590 : 17220 : end subroutine Dzeroexpand
9591 : :
9592 : :
9593 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9594 : : !! SUBROUTINE wfnDinit(Grid,kappa,wfn,lwfn,istart)
9595 : : !! returns the solution of the Dirac relativistic equations near r=0
9596 : : !! using power series expansion
9597 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9598 [ - + - + ]: 17220 : SUBROUTINE wfnDinit(Grid,wfn,lwfn,istart,A0,A1,B0,B1,s,finitenucleus)
9599 : : logical,intent(in) :: finitenucleus
9600 : : Real(dp), intent(in) :: A0,B0,A1,B1,s
9601 : : Type(GridInfo), INTENT(IN) :: Grid
9602 : : REAL(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
9603 : : INTEGER, INTENT(OUT) :: istart
9604 : : REAL(dp) :: rr
9605 : : INTEGER :: i
9606 [ + + + + ]: 68931660 : wfn=zero; lwfn=zero
9607 : 17220 : istart=6
9608 [ + + ]: 120540 : do i=1,istart
9609 : 103320 : rr=Grid%r(i+1)
9610 [ + - ]: 120540 : if (.not.finitenucleus) then
9611 : 103320 : wfn(i+1)=(rr**s)*(A0+A1*rr)
9612 : 103320 : lwfn(i+1)=(rr**s)*(B0+B1*rr)
9613 : : else ! finite nucleus case
9614 : 0 : write(std_out,*) 'Dirac case not programmed for finite nucleus'
9615 : 0 : STOP
9616 : : endif
9617 : : enddo
9618 : 17220 : End SUBROUTINE wfnDinit
9619 : :
9620 : :
9621 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9622 : : !! subroutine wfnDasym(Grid,wfn,lwfn,energy,iend)
9623 : : !! returns the solution of the Dirac relativistic equations near r=inf
9624 : : !! using exp(-x*r) for upper component
9625 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9626 [ - + - + ]: 17014 : subroutine wfnDasym(Grid,wfn,lwfn,energy,iend)
9627 : : Type(GridInfo), INTENT(IN) :: Grid
9628 : : REAL(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
9629 : : REAL(dp), INTENT(IN) :: energy
9630 : : INTEGER, INTENT(OUT) :: iend
9631 : : REAL(dp) :: rr,x,m
9632 : : INTEGER :: i,n
9633 [ - + ]: 17014 : if (energy>0._dp) then
9634 : 0 : write(std_out,*) 'Error in wfnDasym -- energy > 0', energy
9635 : 0 : stop
9636 : : endif
9637 [ + + + + ]: 68107042 : wfn=zero; lwfn=zero
9638 : 17014 : n=Grid%n
9639 : 17014 : m=1._dp+0.25_dp*energy/(InvFineStruct**2)
9640 : 17014 : x=sqrt(-m*energy)
9641 : 17014 : rr=energy/x
9642 : 17014 : iend=5
9643 [ + + ]: 119098 : do i=n-iend,n
9644 : 102084 : wfn(i)=exp(-x*(Grid%r(i)-Grid%r(n-iend)))
9645 : 119098 : lwfn(i)=rr*wfn(i)
9646 : : enddo
9647 : 17014 : end subroutine wfnDasym
9648 : :
9649 : :
9650 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9651 : : !! subroutine getwfnfromcfdsolD(start,finish,yy,wfn,lwfn)
9652 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9653 [ - + - + : 34234 : subroutine getwfnfromcfdsolD(start,finish,yy,wfn,lwfn)
- + ]
9654 : : INTEGER, INTENT(IN) :: start,finish
9655 : : REAL(dp), INTENT(IN) :: yy(:,:)
9656 : : REAL(dp), INTENT(INOUT) :: wfn(:),lwfn(:)
9657 : : INTEGER :: i
9658 [ + + ]: 68536468 : wfn=0
9659 [ + + ]: 34712636 : do i=start,finish
9660 : 34678402 : wfn(i)=yy(1,i)
9661 : 34712636 : lwfn(i)=yy(2,i)
9662 : : enddo
9663 : 34234 : end subroutine getwfnfromcfdsolD
9664 : :
9665 : :
9666 : :
9667 : :
9668 : :
9669 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9670 : : ! 18. interpolation_mod
9671 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9672 : :
9673 : :
9674 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9675 : : ! cubic spline interpolation for nin>2
9676 : : ! linear interpolation for nin=2
9677 : : ! error end if rout points are not within range of rin
9678 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9679 [ # # # # : 0 : SUBROUTINE interpfunc(nin,rin,fin,nout,rout,fout)
# # # # ]
9680 : : INTEGER, INTENT(IN) :: nin,nout
9681 : : REAL(dp), INTENT(IN) :: rin(:),fin(:),rout(:)
9682 : : REAL(dp), INTENT(INOUT) :: fout(:)
9683 : 0 : REAL(dp), ALLOCATABLE :: c(:,:)
9684 : : INTEGER :: i,j
9685 : : REAL(dp) :: x,s
9686 : : LOGICAL :: leftin,lefton,leftout,rightin,righton,rightout
9687 : : ! check if grid is within interpolation range
9688 : 0 : call checkrange(rin(1),rout(1),leftin,lefton,leftout)
9689 : 0 : call checkrange(rout(nout),rin(nin),rightin,righton,rightout)
9690 [ # # ]: 0 : if (leftout.or.rightout) then
9691 : 0 : write(std_out,*) 'Grid error in interpfunc',rin(1),rout(1),rin(nin),rout(nout)
9692 : 0 : stop
9693 : : endif
9694 [ # # ]: 0 : fout=0
9695 : : ! linear interpolation if nin=2
9696 [ # # ]: 0 : if (nin==2) then
9697 : 0 : s=(fin(2)-fin(1))/(rin(2)-rin(1))
9698 [ # # ]: 0 : do i=1,nout
9699 : 0 : fout(i)=fin(1)+(rout(i)-rin(1))*s
9700 : : enddo
9701 : : return
9702 : : endif
9703 [ # # # # : 0 : LIBPAW_ALLOCATE(c,(4,nin))
# # # # #
# # # ]
9704 [ # # # # ]: 0 : c=zero;
9705 [ # # ]: 0 : c(1,1:nin)=fin(1:nin)
9706 [ # # # # : 0 : call cubspl(rin,c,nin,0,0)
# # # # #
# ]
9707 [ # # ]: 0 : do i=1,nout
9708 [ # # ]: 0 : do j=1,nin-1
9709 : 0 : call checkrange(rin(j),rout(i),leftin,lefton,leftout)
9710 : 0 : call checkrange(rout(i),rin(j+1),rightin,righton,rightout)
9711 [ # # # # : 0 : if ((leftin.or.lefton).and.(rightin.or.righton)) then
# # # # ]
9712 : 0 : x=rout(i)-rin(j)
9713 : 0 : fout(i)=c(1,j)+x*(c(2,j)+x*(c(3,j)+x*c(4,j)/3)/2)
9714 : 0 : exit
9715 : : endif
9716 : : enddo
9717 : : enddo
9718 [ # # ]: 0 : LIBPAW_DEALLOCATE(c)
9719 : 0 : END SUBROUTINE interpfunc
9720 : :
9721 : :
9722 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9723 : : !! cubspl
9724 : : !! from webpage
9725 : : !! http://pages.cs.wisc.edu/~deboor/pgs/cubspl.f
9726 : : !! Transformed into fortran 90 and REAL(8)
9727 : : !! from * a practical guide to splines * by c. de boor
9728 : : !! ************************ input ***************************
9729 : : !! n = number of data points. assumed to be .ge. 2.
9730 : : !! (tau(i), c(1,i), i=1,...,n) = abscissae and ordinates of the
9731 : : !! data points. tau is assumed to be strictly increasing.
9732 : : !! ibcbeg, ibcend = boundary condition indicators, and
9733 : : !! c(2,1), c(2,n) = boundary condition information. specifically,
9734 : : !! ibcbeg = 0 means no boundary condition at tau(1) is given.
9735 : : !! in this case, the not-a-knot condition is used, i.e. the
9736 : : !! jump in the third derivative across tau(2) is forced to
9737 : : !! zero, thus the first and the second cubic polynomial pieces
9738 : : !! are made to coincide.)
9739 : : !! ibcbeg = 1 means that the slope at tau(1) is made to equal
9740 : : !! c(2,1), supplied by input.
9741 : : !! ibcbeg = 2 means that the second derivative at tau(1) is
9742 : : !! made to equal c(2,1), supplied by input.
9743 : : !! ibcend = 0, 1, or 2 has analogous meaning concerning the
9744 : : !! boundary condition at tau(n), with the additional infor-
9745 : : !! mation taken from c(2,n).
9746 : : !! *********************** output **************************
9747 : : !! c(j,i), j=1,...,4; i=1,...,l (= n-1) = the polynomial coefficients
9748 : : !! of the cubic interpolating spline with interior knots (or
9749 : : !! joints) tau(2), ..., tau(n-1). precisely, in the interval
9750 : : !! (tau(i), tau(i+1)), the spline f is given by
9751 : : !! f(x) = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.)
9752 : : !! where h = x - tau(i). the function program *ppvalu* may be
9753 : : !! used to evaluate f or its derivatives from tau,c, l = n-1,
9754 : : !! and k=4.
9755 : : !! A tridiagonal linear system for the unknown slopes s(i) of
9756 : : !! f at tau(i), i=1,...,n, is generated and then solved by gauss elim-
9757 : : !! ination, with s(i) ending up in c(2,i), all i.
9758 : : !! c(3,.) and c(4,.) are used initially for temporary storage.
9759 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9760 : 0 : subroutine cubspl ( tau, c, n, ibcbeg, ibcend )
9761 : : integer :: ibcbeg,ibcend,n, i,j,l,m
9762 : : real(dp) :: c(4,n),tau(n), divdf1,divdf3,dtau,g
9763 : 0 : l = n-1
9764 : : !compute first differences of tau sequence and store in c(3,.). also,
9765 : : !compute first divided difference of data and store in c(4,.).
9766 [ # # ]: 0 : do m=2,n
9767 : 0 : c(3,m) = tau(m) - tau(m-1)
9768 : 0 : c(4,m) = (c(1,m) - c(1,m-1))/c(3,m)
9769 : : enddo
9770 : : !construct first equation from the boundary condition, of the form
9771 : : ! c(4,1)*s(1) + c(3,1)*s(2) = c(2,1)
9772 [ # # ]: 0 : if (ibcbeg-1 <0) go to 11
9773 [ # # ]: 0 : if (ibcbeg-1==0) go to 15
9774 : : if (ibcbeg-1 >0) go to 16
9775 [ # # ]: 0 : 11 if (n .gt. 2) go to 12
9776 : : ! no condition at left end and n = 2.
9777 : 0 : c(4,1) = 1._dp
9778 : 0 : c(3,1) = 1._dp
9779 : 0 : c(2,1) = 2._dp*c(4,2)
9780 : 0 : go to 25
9781 : : ! not-a-knot condition at left end and n .gt. 2.
9782 : 0 : 12 c(4,1) = c(3,3)
9783 : 0 : c(3,1) = c(3,2) + c(3,3)
9784 : 0 : c(2,1) =((c(3,2)+2._dp*c(3,1))*c(4,2)*c(3,3)+c(3,2)**2*c(4,3))/c(3,1)
9785 : 0 : go to 19
9786 : : ! slope prescribed at left end.
9787 : 0 : 15 c(4,1) = 1._dp
9788 : 0 : c(3,1) = 0._dp
9789 : 0 : go to 18
9790 : : ! second derivative prescribed at left end.
9791 : 0 : 16 c(4,1) = 2._dp
9792 : 0 : c(3,1) = 1._dp
9793 : 0 : c(2,1) = 3._dp*c(4,2) - c(3,2)/2._dp*c(2,1)
9794 [ # # ]: 0 : 18 if(n .eq. 2) go to 25
9795 : : ! if there are interior knots, generate the corresp. equations and car-
9796 : : ! ry out the forward pass of gauss elimination, after which the m-th
9797 : : ! equation reads c(4,m)*s(m) + c(3,m)*s(m+1) = c(2,m).
9798 [ # # ]: 0 : 19 do m=2,l
9799 : 0 : g = -c(3,m+1)/c(4,m-1)
9800 : 0 : c(2,m) = g*c(2,m-1) + 3._dp*(c(3,m)*c(4,m+1)+c(3,m+1)*c(4,m))
9801 : 0 : c(4,m) = g*c(3,m-1) + 2._dp*(c(3,m) + c(3,m+1))
9802 : : enddo
9803 : : !construct last equation from the second boundary condition, of the form
9804 : : ! (-g*c(4,n-1))*s(n-1) + c(4,n)*s(n) = c(2,n)
9805 : : ! if slope is prescribed at right end, one can go directly to back-
9806 : : ! substitution, since c array happens to be set up just right for it
9807 : : ! at this point.
9808 [ # # ]: 0 : if (ibcend-1 <0) go to 21
9809 [ # # ]: 0 : if (ibcend-1==0) go to 30
9810 : : if (ibcend-1 >0) go to 24
9811 [ # # # # ]: 0 : 21 if (n .eq. 3 .and. ibcbeg .eq. 0) go to 22
9812 : : ! not-a-knot and n .ge. 3, and either n.gt.3 or also not-a-knot at
9813 : : ! left end point.
9814 : 0 : g = c(3,n-1) + c(3,n)
9815 : : c(2,n) = ((c(3,n)+2._dp*g)*c(4,n)*c(3,n-1) &
9816 : 0 : & + c(3,n)**2*(c(1,n-1)-c(1,n-2))/c(3,n-1))/g
9817 : 0 : g = -g/c(4,n-1)
9818 : 0 : c(4,n) = c(3,n-1)
9819 : 0 : go to 29
9820 : : ! either (n=3 and not-a-knot also at left) or (n=2 and not not-a-
9821 : : ! knot at left end point).
9822 : 0 : 22 c(2,n) = 2._dp*c(4,n)
9823 : 0 : c(4,n) = 1._dp
9824 : 0 : go to 28
9825 : : ! second derivative prescribed at right endpoint.
9826 : 0 : 24 c(2,n) = 3._dp*c(4,n) + c(3,n)/2._dp*c(2,n)
9827 : 0 : c(4,n) = 2._dp
9828 : 0 : go to 28
9829 : : 25 continue
9830 [ # # ]: 0 : if (ibcend-1 <0) go to 26
9831 [ # # ]: 0 : if (ibcend-1==0) go to 30
9832 : : if (ibcend-1 >0) go to 24
9833 [ # # ]: 0 : 26 if (ibcbeg .gt. 0) go to 22
9834 : : ! not-a-knot at right endpoint and at left endpoint and n = 2.
9835 : 0 : c(2,n) = c(4,n)
9836 : 0 : go to 30
9837 : 0 : 28 g = -1._dp/c(4,n-1)
9838 : : !complete forward pass of gauss elimination.
9839 : 0 : 29 c(4,n) = g*c(3,n-1) + c(4,n)
9840 : 0 : c(2,n) = (g*c(2,n-1) + c(2,n))/c(4,n)
9841 : : !carry out back substitution
9842 : 0 : 30 j = l
9843 : 0 : 40 c(2,j) = (c(2,j) - c(3,j)*c(2,j+1))/c(4,j)
9844 : 0 : j = j - 1
9845 [ # # ]: 0 : if (j .gt. 0) go to 40
9846 : : !****** generate cubic coefficients in each interval, i.e., the deriv.s
9847 : : ! at its left endpoint, from value and slope at its endpoints.
9848 [ # # ]: 0 : do i=2,n
9849 : 0 : dtau = c(3,i)
9850 : 0 : divdf1 = (c(1,i) - c(1,i-1))/dtau
9851 : 0 : divdf3 = c(2,i-1) + c(2,i) - 2._dp*divdf1
9852 : 0 : c(3,i-1) = 2._dp*(divdf1 - c(2,i-1) - divdf3)/dtau
9853 : 0 : c(4,i-1) = (divdf3/dtau)*(6._dp/dtau)
9854 : : enddo
9855 : 0 : END subroutine cubspl
9856 : :
9857 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
9858 : : ! Subroutine to use input from Ahlberg spline interpolation
9859 : : ! for node points rin(1..nin) and function values yin and
9860 : : ! second derivative values Min to interpolate to radial grid
9861 : : ! rout with values yout. For the range 0 \le r \le rin(1)
9862 : : ! it is assumed that yout=r**(l+1)(W0+W1*r) where l denotes
9863 : : ! the angular momentum of the function
9864 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
9865 [ # # # # : 0 : subroutine specialinterp(nin,rin,yin,MMin,nout,rout,yout,ypout)
# # # # #
# # # ]
9866 : : integer, intent(IN) :: nin,nout
9867 : : real(dp), intent(IN) :: rin(:),yin(:),MMin(:),rout(:)
9868 : : real(dp), intent(INOUT) :: yout(:),ypout(:)
9869 : 0 : real(dp), allocatable :: h(:),C(:,:)
9870 : : real(dp) :: x
9871 : : integer :: i,j
9872 : : LOGICAL :: leftin,lefton,leftout,rightin,righton,rightout
9873 [ # # # # : 0 : LIBPAW_ALLOCATE(h,(nin))
# # # # #
# # # ]
9874 [ # # # # : 0 : LIBPAW_ALLOCATE(C,(4,nin))
# # # # #
# # # ]
9875 [ # # ]: 0 : h=0
9876 [ # # ]: 0 : do i=2,nin
9877 : 0 : h(i)=rin(i)-rin(i-1)
9878 : : enddo
9879 : : !h(1) is hopefully not used
9880 [ # # # # ]: 0 : C=0
9881 [ # # ]: 0 : C(1,1:nin)=yin(1:nin)
9882 [ # # ]: 0 : C(3,1:nin)=MMin(1:nin)
9883 [ # # ]: 0 : do i=1,nin-1
9884 : 0 : C(4,i)=(MMin(i+1)-MMin(i))/h(i+1)
9885 : 0 : C(2,i)=((yin(i+1)-yin(i))/h(i+1)-(MMin(i+1)+2*MMin(i))*h(i+1)/6)
9886 : : enddo
9887 [ # # # # ]: 0 : yout=0;ypout=0
9888 : : ! check if grid is within interpolation range
9889 : 0 : call checkrange(rin(1),rout(1),leftin,lefton,leftout)
9890 : 0 : call checkrange(rout(nout),rin(nin),rightin,righton,rightout)
9891 [ # # ]: 0 : if (leftout.or.rightout) then
9892 : 0 : write(std_out,*) 'Grid error in specialint',rin(1),rout(1),rin(nin),rout(nout)
9893 : 0 : stop
9894 : : endif
9895 [ # # ]: 0 : do i=1,nout
9896 [ # # ]: 0 : do j=1,nin-1
9897 : 0 : call checkrange(rin(j),rout(i),leftin,lefton,leftout)
9898 : 0 : call checkrange(rout(i),rin(j+1),rightin,righton,rightout)
9899 [ # # # # : 0 : if ((leftin.or.lefton).and.(rightin.or.righton)) then
# # # # ]
9900 : 0 : x=rout(i)-rin(j)
9901 : 0 : yout(i)=c(1,j)+x*(c(2,j)+x*(c(3,j)+x*c(4,j)/3)/2)
9902 : 0 : ypout(i)=c(2,j)+x*(c(3,j)+0.5_dp*x*c(4,j))
9903 : 0 : exit
9904 : : endif
9905 : : enddo
9906 : : enddo
9907 [ # # ]: 0 : LIBPAW_DEALLOCATE(h)
9908 [ # # ]: 0 : LIBPAW_DEALLOCATE(C)
9909 : 0 : end subroutine specialinterp
9910 : :
9911 : :
9912 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9913 : : !! checkrange
9914 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9915 : 0 : subroutine checkrange(rin,rout,inrange,onrange,outofbounds)
9916 : : LOGICAL, INTENT(OUT) :: inrange,onrange,outofbounds
9917 : : REAL(dp), INTENT(IN) :: rin,rout
9918 : : REAL(dp), parameter :: tol=1.d-7
9919 : 0 : inrange=.false.;onrange=.false.;outofbounds=.false.
9920 [ # # # # : 0 : if (rout>=rin) then
# # # # #
# # # ]
9921 : 0 : inrange=.true.
9922 : : return
9923 : : endif
9924 [ # # # # : 0 : if (abs(rout-rin).le.tol) then
# # # # #
# # # # #
# # ]
9925 : 0 : onrange=.true.
9926 : : return
9927 : : endif
9928 [ # # # # : 0 : outofbounds=.true.
# # # # ]
9929 : : end subroutine checkrange
9930 : :
9931 : :
9932 : :
9933 : :
9934 : :
9935 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9936 : : ! 19. search_sort
9937 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9938 : :
9939 : :
9940 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9941 : : !! SUBROUTINE Real_InsSort(A, LUT, Ascending)
9942 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9943 [ # # # # ]: 0 : SUBROUTINE Real_InsSort(A, LUT, Ascending)
9944 : : REAL(dp), INTENT(IN) :: A(:)
9945 : : INTEGER, INTENT(INOUT) :: LUT(:)
9946 : : LOGICAL, INTENT(IN) :: Ascending
9947 : : INTEGER :: i, j, k, A_Size
9948 : : REAL(dp) :: CurrVal
9949 : 0 : A_Size = SIZE(A)
9950 [ # # ]: 0 : DO i=1, A_Size
9951 : 0 : LUT(i) = i
9952 : : END DO
9953 [ # # ]: 0 : DO i = 2, A_Size
9954 : 0 : CurrVal = A(LUT(i))
9955 : 0 : j = i - 1
9956 [ # # # # ]: 0 : DO WHILE ((CurrVal < A(LUT(j))) .AND. (j>1))
9957 : 0 : LUT(j+1) = LUT(j)
9958 : 0 : j = j - 1
9959 : : END DO
9960 [ # # ]: 0 : IF (CurrVal < A(LUT(j))) THEN
9961 : 0 : LUT(j+1) = LUT(j)
9962 : 0 : j = j - 1
9963 : : END IF
9964 : 0 : LUT(j+1) = i
9965 : : END DO
9966 [ # # ]: 0 : IF (.NOT. Ascending) THEN
9967 : 0 : j = A_Size / 2
9968 [ # # ]: 0 : DO i = 1, j
9969 : 0 : k = LUT(i)
9970 : 0 : LUT(i) = LUT(A_Size - i + 1)
9971 : 0 : LUT(A_Size - i + 1) = k
9972 : : END DO
9973 : : END IF
9974 : 0 : RETURN
9975 : : END SUBROUTINE Real_InsSort
9976 : :
9977 : :
9978 : :
9979 : :
9980 : :
9981 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9982 : : ! 20. input_dataset_mod
9983 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9984 : :
9985 : :
9986 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9987 : : !! NAME
9988 : : !! input_dataset_read
9989 : : !!
9990 : : !! FUNCTION
9991 : : !! Initialize an input_dataset datastructure by reading it from
9992 : : !! a file. If file is omitted, then read from standard input.
9993 : : !! Note: we only read here data used to generate the PAW dataset,
9994 : : !! not data used for the post-processing (output, explore, scfpaw, ...)
9995 : : !!
9996 : : !! INPUTS (all optionals)
9997 : : !! [inputfile]= name of input file to be read
9998 : : !! [echofile]= name of a file to echo input file content
9999 : : !! [read_global_data]= if TRUE, read global data (atom, XC, grid, ...) -
10000 : : !Default TRUE
10001 : : !! [read_elec_data]= if TRUE, read electronic configuration (orbital &
10002 : : !occupations) - Default TRUE
10003 : : !! [read_coreval_data]= if TRUE, read electronic config (core and valence) -
10004 : : !Default TRUE
10005 : : !! [read_basis_data]= if TRUE, read basis data (radii, pseudo scheme, ...) -
10006 : : !Default TRUE
10007 : : !!
10008 : : !! OUTPUT
10009 : : !! [input_dt]= datastructure containing the complete input file.
10010 : : !! If omitted, then the global public `input_dataset`
10011 : : !! is used.
10012 : : !!
10013 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
10014 : 4 : SUBROUTINE input_dataset_read(atp,inputfile,dirac,has_to_echo,&
10015 : : &read_global_data,read_elec_data,read_coreval_data,read_basis_data)
10016 : : !---- Arguments
10017 : : CHARACTER*(*),INTENT(IN) :: inputfile
10018 : : logical,intent(in) :: has_to_echo
10019 : : logical,intent(in) :: dirac
10020 : : LOGICAL,INTENT(IN),OPTIONAL :: read_global_data,read_elec_data,&
10021 : : & read_coreval_data,read_basis_data
10022 : : TYPE(atompaw_type),INTENT(INOUT) :: atp
10023 : : !---- Local variables
10024 : : CHARACTER(132) :: echofile
10025 : : INTEGER :: ifunit
10026 : : INTEGER,PARAMETER :: ecunit=222
10027 : : INTEGER,PARAMETER :: nkappa(5)=(/1,2,2,2,2/)
10028 : : INTEGER :: input_unit
10029 : : integer :: i_usexcnhat,i_logspline,i_rsoptim,i_lda12
10030 : : INTEGER :: ii,io,nadd,norb,nval,nbl,nn,ik,kk,jdirac
10031 : : INTEGER :: ilin,ilog,inrl,iscl,ipnt,ifin,iend,ihfpp,ilcex,itau
10032 : : INTEGER :: igrid,irelat,ilogder,ilogv4,ibd,idirac,ifixz,ll,nstart
10033 : : INTEGER :: ispline,isplr0,isplns
10034 : : LOGICAL :: read_global_data_,read_elec_data_,read_coreval_data_,read_basis_data_
10035 : : CHARACTER(200) :: inputline,inputword
10036 : : !CHARACTER(128) :: exchangecorrelationandgridline
10037 : : CHARACTER(256) :: exchangecorrelationandgridline
10038 : : CHARACTER(1) :: CHR
10039 : : integer,parameter :: XML_RECL=50000
10040 : : character (len=XML_RECL) :: line,readline
10041 : : logical :: found
10042 : : real(dp) :: x1,x2,xocc
10043 : : INTEGER :: basis_add_l(nbasis_add_max)
10044 : : INTEGER :: basis_add_k(nbasis_add_max)
10045 : : real(dp) :: basis_add_energy(nbasis_add_max)
10046 : : INTEGER :: tmp_n(norbit_max),tmp_l(norbit_max),tmp_k(norbit_max)
10047 : : real(dp) :: tmp_occ(norbit_max)
10048 : 4 : ifunit=libpaw_get_free_unit()
10049 : 4 : input_unit=ifunit
10050 : 4 : OPEN(ifunit,file=trim(inputfile),form='formatted',action="read")
10051 : : !Select which components have to be read
10052 [ - + ]: 4 : read_global_data_=.true.;if (PRESENT(read_global_data))read_global_data_=read_global_data
10053 [ - + ]: 4 : read_elec_data_=.true.;if (PRESENT(read_elec_data))read_elec_data_=read_elec_data
10054 [ - + ]: 4 : read_coreval_data_=.true.;if (PRESENT(read_coreval_data))read_coreval_data_=read_coreval_data
10055 [ - + ]: 4 : read_basis_data_=.true.;if (PRESENT(read_basis_data))read_basis_data_=read_basis_data
10056 : : !Print a title
10057 [ - + - - ]: 4 : IF(read_global_data_.OR.read_elec_data_.OR.read_coreval_data_.OR.read_basis_data_)THEN
10058 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,'(/,3x,a)') "===== READING OF INPUT FILE ====="
10059 : : END IF
10060 : :
10061 : : found=.false.
10062 : : do while (.not.found)
10063 [ + - ]: 20160 : read(input_unit,'(a)',err=10,end=10) readline
10064 : 20160 : line=adjustl(readline);goto 20
10065 : 0 : 10 write(std_out,*) 'ERROR in reading atp file' ; stop
10066 : : 20 continue
10067 [ + + ]: 20160 : if (line(1:22)=='<!-- Program: atompaw') then
10068 : : found=.true.
10069 : : end if
10070 : : enddo
10071 : : if(.not.found) then
10072 : : LIBPAW_ERROR('XML COREWF FILE NOT CORRECT')
10073 : : endif
10074 : :
10075 : : !------------------------------------------------------------------
10076 : : !Start reading of AE data
10077 [ + - ]: 4 : IF (read_global_data_) THEN
10078 : : !------------------------------------------------------------------
10079 : : !=== 1st line: read atomic symbol, atomic number
10080 : 4 : READ(input_unit,'(a)') inputline
10081 : 4 : CALL eliminate_comment(inputline)
10082 : 4 : READ(inputline,*) atp%atomic_symbol,atp%atomic_charge
10083 [ + - ]: 4 : echofile=trim(atp%atomic_symbol)//'_atp_echofile'
10084 [ + - ]: 4 : IF (has_to_echo) THEN
10085 : 4 : OPEN(ecunit,file=trim(echofile),form='formatted')
10086 : : END IF
10087 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10088 : : !Print read data
10089 [ - + ]: 4 : IF (has_to_print) THEN
10090 : 0 : WRITE(STD_OUT,'(3x,a,a2)') "Atomic symbol : ",atp%atomic_symbol
10091 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Atomic charge : ",atp%atomic_charge
10092 : : END IF
10093 : : !------------------------------------------------------------------
10094 : : !=== 2nd line: read XC type, grid data, relativistic,point-nucleus,
10095 : : ! logderiv data, HF data, Block-Davidson keyword
10096 : : !Read full line
10097 : 4 : READ(input_unit,'(a)') exchangecorrelationandgridline
10098 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(exchangecorrelationandgridline)
10099 : 4 : CALL eliminate_comment(exchangecorrelationandgridline)
10100 : 4 : CALL Uppercase(exchangecorrelationandgridline)
10101 : : exchangecorrelationandgridline=trim(exchangecorrelationandgridline)
10102 : : !Retrieve keyword indexes
10103 : 4 : ilin=0;ilin=0;ilog=0;ilogv4=0;inrl=0;iscl=0;ipnt=0;ifin=0
10104 : 4 : ihfpp=0;ilcex=0;igrid=0;irelat=0;ilogder=0;ibd=0;idirac=0
10105 : 4 : ispline=0;isplr0=0;isplns=0
10106 : 4 : ilin=INDEX(exchangecorrelationandgridline,'LINEARGRID')
10107 : 4 : ilog=INDEX(exchangecorrelationandgridline,'LOGGRID')
10108 : 4 : ilogv4=INDEX(exchangecorrelationandgridline,'LOGGRIDV4')
10109 : 4 : ibd=INDEX(exchangecorrelationandgridline,'BDSOLVE')
10110 : 4 : inrl=INDEX(exchangecorrelationandgridline,'NONRELATIVISTIC')
10111 : 4 : iscl=INDEX(exchangecorrelationandgridline,'SCALARRELATIVISTIC')
10112 : 4 : idirac=INDEX(exchangecorrelationandgridline,'DIRACRELATIVISTIC')
10113 : 4 : ipnt=INDEX(exchangecorrelationandgridline,'POINT-NUCLEUS')
10114 : 4 : ifin=INDEX(exchangecorrelationandgridline,'FINITE-NUCLEUS')
10115 : 4 : ilogder=INDEX(exchangecorrelationandgridline,'LOGDERIVRANGE')
10116 : 4 : ihfpp=INDEX(exchangecorrelationandgridline,'HFPOSTPROCESS')
10117 : 4 : ilcex=INDEX(exchangecorrelationandgridline,'LOCALIZEDCOREEXCHANGE')
10118 : 4 : ifixz=INDEX(exchangecorrelationandgridline,'FIXED_ZERO')
10119 : 4 : itau=INDEX(exchangecorrelationandgridline,'WTAU')
10120 : 4 : ispline=INDEX(exchangecorrelationandgridline,'SPLINEINTERP')
10121 : 4 : isplr0=INDEX(exchangecorrelationandgridline,'SPLR0')
10122 : 4 : isplns=INDEX(exchangecorrelationandgridline,'SPLNS')
10123 : 4 : igrid=max(ilin,ilog) !This line may need attention....
10124 : 4 : irelat=max(inrl,iscl) !This line may need attention....
10125 : : !!Treat simple logical variables
10126 : 4 : atp%scalarrelativistic=(iscl>0.and.inrl==0)
10127 : 4 : atp%diracrelativistic=(idirac>0.and.inrl==0)
10128 [ + - - + ]: 4 : atp%usespline=(itau>0.or.ispline>0.and.inrl==0)
10129 : 4 : atp%finitenucleus=(ifin>0.and.ipnt==0)
10130 : 4 : atp%BDsolve=(ibd>0)
10131 : 4 : atp%HFpostprocess=(ihfpp>0)
10132 : : !!Treat finite nucleus option
10133 : 4 : atp%finitenucleusmodel=-1
10134 [ - + ]: 4 : IF (atp%finitenucleus) THEN
10135 : 0 : READ(exchangecorrelationandgridline(ifin+14:ifin+14),'(a)') CHR
10136 [ # # ]: 0 : IF (CHR=="2") atp%finitenucleusmodel=2
10137 [ # # ]: 0 : IF (CHR=="3") atp%finitenucleusmodel=3
10138 [ # # ]: 0 : IF (CHR=="4") atp%finitenucleusmodel=4
10139 [ # # ]: 0 : IF (CHR=="5") atp%finitenucleusmodel=5
10140 : : END IF
10141 : : !Treat possible changes to spline grid
10142 [ - + ]: 4 : if (isplr0>0) then
10143 : 0 : READ(exchangecorrelationandgridline(isplr0+5:),*) atp%splr0
10144 : : end if
10145 [ - + ]: 4 : if (isplns>0) then
10146 : 0 : READ(exchangecorrelationandgridline(isplns+5:),*) atp%splns
10147 : : end if
10148 : : !!Treat grid data
10149 : 4 : atp%gridkey='LINEAR'
10150 : 4 : atp%gridpoints=mxgridlin
10151 : 4 : atp%gridrange=linrange
10152 : 4 : atp%gridmatch=linrange
10153 [ + - + - ]: 4 : IF (ilog>0.and.ilin==0.and.ilogv4==0) THEN
10154 : 4 : atp%gridkey='LOGGRID'
10155 : 4 : atp%gridpoints=mxgridlog;
10156 : 4 : atp%gridrange=logrange
10157 : 4 : atp%gridmatch=logrange
10158 : : END IF
10159 [ + - - + ]: 4 : IF (ilog>0.and.ilin==0.and.ilogv4>0) THEN
10160 : 0 : atp%gridkey='LOGGRID4'
10161 : 0 : atp%gridpoints=mxgridlog;
10162 : 0 : atp%gridrange=v4logrange
10163 : 0 : atp%gridmatch=v4logrange
10164 : : END IF
10165 [ + - ]: 4 : IF (igrid>0) THEN
10166 : 4 : iend=256
10167 [ - + ]: 4 : IF (irelat >igrid.and.irelat-1 <iend) iend=irelat -1
10168 [ + + ]: 4 : IF (ilogder>igrid.and.ilogder-1<iend) iend=ilogder-1
10169 [ - + ]: 4 : IF (ibd>igrid.and.ibd-1<iend) iend=ibd-1
10170 : 4 : inputline=""
10171 [ + - + - ]: 4 : IF (ilog>0.and.ilogv4==0.and.iend>igrid+7) &
10172 [ + + ]: 4 : & inputline=TRIM(exchangecorrelationandgridline(igrid+7:iend))
10173 [ - + - - ]: 4 : IF (ilog>0.and.ilogv4>0.and.iend>igrid+9) &
10174 [ # # ]: 0 : & inputline=TRIM(exchangecorrelationandgridline(igrid+9:iend))
10175 [ - + - - ]: 4 : IF (ilin>0.and.iend>igrid+10) &
10176 [ # # ]: 0 : & inputline=TRIM(exchangecorrelationandgridline(igrid+10:iend))
10177 [ + - ]: 4 : IF (inputline/="") THEN
10178 : 4 : CALL extractword(1,inputline,inputword);inputword=trim(inputword)
10179 [ + - ]: 4 : IF (inputword/="") THEN
10180 : 4 : READ(inputword,*) atp%gridpoints
10181 : 4 : CALL extractword(2,inputline,inputword);inputword=trim(inputword)
10182 [ - + ]: 4 : IF (inputword/="") THEN
10183 : 0 : READ(inputword,*) atp%gridrange
10184 : 0 : atp%gridmatch=atp%gridrange
10185 : 0 : CALL extractword(3,inputline,inputword);inputword=trim(inputword)
10186 [ # # ]: 0 : IF (inputword/="") read(inputword,*) atp%gridmatch
10187 : : END IF
10188 : : END IF
10189 : : END IF
10190 [ - + ]: 4 : IF (atp%gridpoints<=0) STOP "input_dataset: error -- number of grid points should be >0!"
10191 : : END IF
10192 : : !Treat logderiv data
10193 : 4 : atp%minlogderiv=logder_min
10194 : 4 : atp%maxlogderiv=logder_max
10195 : 4 : atp%nlogderiv=logder_pts
10196 [ + + ]: 4 : IF (ilogder>0) THEN
10197 : 2 : iend=256
10198 [ - + ]: 2 : IF (igrid >ilogder.and.igrid-1 <iend) iend=igrid -1
10199 [ - + ]: 2 : IF (irelat>ilogder.and.irelat-1<iend) iend=irelat-1
10200 : 2 : inputline=""
10201 [ + - - + ]: 2 : IF (iend>ilogder+13)inputline=trim(exchangecorrelationandgridline(ilogder+13:iend))
10202 [ + - ]: 2 : IF (inputline/="") THEN
10203 : 2 : CALL extractword(1,inputline,inputword);inputword=trim(inputword)
10204 [ + - ]: 2 : IF (inputword/="") THEN
10205 : 2 : READ(inputword,*) atp%minlogderiv
10206 : 2 : CALL extractword(2,inputline,inputword);inputword=trim(inputword)
10207 [ + - ]: 2 : IF (inputword/="") THEN
10208 : 2 : READ(inputword,*) atp%maxlogderiv
10209 : 2 : CALL extractword(3,inputline,inputword);inputword=trim(inputword)
10210 [ - + ]: 2 : IF (inputword/="") READ(inputword,*) atp%nlogderiv
10211 : : END IF
10212 : : END IF
10213 : : END IF
10214 : : END IF
10215 : : !Treat XC/HF
10216 [ - + ]: 4 : if (itau>0) then
10217 : 0 : READ(unit=exchangecorrelationandgridline(itau+5:),fmt=*) atp%exctype
10218 : : else
10219 : 4 : READ(unit=exchangecorrelationandgridline(1:),fmt=*) atp%exctype
10220 : : endif
10221 [ + - - + : 4 : atp%needvtau=(itau>0.or.TRIM(atp%exctype)=='MGGA-R2SCAN-001'.or.TRIM(atp%exctype)=='MGGA-R2SCAN-01')
- + ]
10222 : 4 : atp%localizedcoreexchange=(ilcex>0)
10223 : 4 : atp%fixed_zero=(ifixz>0) ; atp%fixed_zero_index=-1
10224 [ - + ]: 4 : IF (atp%fixed_zero) &
10225 : 0 : & READ(unit=exchangecorrelationandgridline(ifixz+10:),fmt=*)atp%fixed_zero_index
10226 : : !Print read data
10227 [ - + ]: 4 : IF (has_to_print) THEN
10228 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Scalar-relativistic calculation:",MERGE("YES"," NO",atp%scalarrelativistic)
10229 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Dirac-relativistic calculation:",MERGE("YES"," NO",atp%diracrelativistic)
10230 [ # # ]: 0 : IF (atp%usespline) THEN
10231 : 0 : WRITE(STD_OUT,'(3x,a)') " - Use a spline solver"
10232 : : END IF
10233 : 0 : WRITE(STD_OUT,'(3x,2a)') "Exchange-correlation functional:",TRIM(atp%exctype)
10234 [ # # ]: 0 : WRITE(STD_OUT,'(3x,3a)') " (mGGA kinetic energy functional:",MERGE("YES"," NO",atp%needvtau),")"
10235 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Finite-nucleus calculation:",MERGE("YES"," NO",atp%finitenucleus)
10236 [ # # ]: 0 : IF (atp%finitenucleus) THEN
10237 : 0 : WRITE(STD_OUT,'(3x,a,i0)') " - Finite-nucleus model:",atp%finitenucleusmodel
10238 : : END IF
10239 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Block-Davidson calculation:",MERGE("YES"," NO",atp%BDsolve)
10240 : 0 : WRITE(STD_OUT,'(3x,2a)') "Grid type:",TRIM(atp%gridkey)
10241 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Grid size:",atp%gridpoints
10242 : 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Grid maximum value:",atp%gridrange
10243 : 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Grid imposed value:",atp%gridmatch
10244 [ # # ]: 0 : if(atp%usespline) then
10245 : 0 : WRITE(STD_OUT,'(3x,a,f7.3,2x,i0)') "Spline grid r0, ns :",&
10246 : 0 : & atp%splr0,atp%splns
10247 : : endif
10248 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Log. derivative, number of pts:",atp%nlogderiv
10249 : 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Log. derivative, min. energy:",atp%minlogderiv
10250 : 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Log. derivative, max. energy:",atp%maxlogderiv
10251 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, post-processing:",MERGE("YES"," NO",atp%HFpostprocess)
10252 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, localized coreex.:",MERGE("YES"," NO",atp%localizedcoreexchange)
10253 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, fixed zero:",MERGE("YES"," NO",atp%fixed_zero)
10254 [ # # ]: 0 : IF (atp%fixed_zero) THEN
10255 : 0 : WRITE(STD_OUT,'(3x,a,i0)') " - HF fixed zero index:",atp%fixed_zero_index
10256 : : END IF
10257 [ # # # # ]: 0 : IF (atp%BDsolve.and.atp%gridkey=='LINEAR') THEN
10258 : 0 : WRITE(STD_OUT,'(/,3x,a)') "WARNING: BlockDavidson solver works very slowlywith linear grid!"
10259 : : END IF
10260 : : END IF
10261 : : !------------------------------------------------------------------
10262 : : !End reading of global data. Start reading of electronic configuration data
10263 : : ENDIF
10264 [ + - ]: 4 : IF (read_elec_data_) THEN
10265 : : !------------------------------------------------------------------
10266 : : !=== 3rd line and following: electronic configuration of atom
10267 : 4 : READ(input_unit,'(a)') inputline
10268 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10269 : 4 : CALL eliminate_comment(inputline)
10270 : 4 : READ(inputline,*) atp%np(1:5)
10271 [ + + ]: 24 : DO ll=1,5
10272 [ - + ]: 24 : IF(atp%np(ll)<0) atp%np(ll)=0
10273 : : END DO
10274 : : atp%norbit=atp%np(1)+max(atp%np(2)-1,0)+max(atp%np(3)-2,0) &
10275 : 4 : & +max(atp%np(4)-3,0)+max(atp%np(5)-4,0)
10276 [ + + + + ]: 4 : IF (atp%diracrelativistic.and.dirac) atp%norbit=2*atp%norbit-atp%np(1)
10277 : : !Print read data
10278 [ - + ]: 4 : IF (has_to_print) THEN
10279 : 0 : WRITE(STD_OUT,'(3x,a,5(1x,i0))') "Max. quantum numbers(s,p,d,f,g):",atp%np(1:5)
10280 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of orbitals: ",atp%norbit
10281 : : END IF
10282 : : ! CALL input_dataset_read_occ(dataset%norbit_mod,dataset%orbit_mod_l,&
10283 : : !&dataset%orbit_mod_n,dataset%orbit_mod_k,dataset%orbit_mod_occ,&
10284 : : !& dataset%np,dataset%diracrelativistic,&
10285 : : !& inputfile_unit=input_unit,echofile_unit=ecunit)
10286 : 4 : atp%norbit_mod=0
10287 : 4 : kk=0
10288 : : DO
10289 : 12 : READ(input_unit,'(a)') inputline
10290 [ + - ]: 12 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10291 : 12 : CALL eliminate_comment(inputline)
10292 [ + + ]: 12 : if (.not.atp%diracrelativistic) READ(inputline,*) nn,ll,xocc
10293 [ + + ]: 12 : if (atp%diracrelativistic) READ(inputline,*) nn,ll,kk,xocc
10294 [ + + ]: 12 : IF (nn<=0) EXIT
10295 : : IF (xocc<0._dp.OR.&
10296 [ + - + + : 8 : & ((.NOT.atp%diracrelativistic).AND.(xocc>2._dp*(2*ll+1))).OR.&
+ - + + -
+ ]
10297 : : & (( atp%diracrelativistic).AND.(xocc>2._dp*ABS(kk)))) THEN
10298 : 0 : LIBPAW_ERROR('input_dataset: error in occupations')
10299 : : END IF
10300 : 8 : atp%norbit_mod=atp%norbit_mod+1
10301 [ + + + + : 8 : if(atp%diracrelativistic.and.(.not.dirac).and.atp%norbit_mod>1) then
+ + ]
10302 [ + + ]: 2 : if(ll==tmp_l(atp%norbit_mod-1)) then
10303 : 1 : atp%norbit_mod=atp%norbit_mod-1
10304 : 1 : tmp_occ(atp%norbit_mod)=tmp_occ(atp%norbit_mod)+xocc
10305 : 1 : go to 30
10306 : : endif
10307 : : endif
10308 [ - + ]: 7 : if (atp%norbit_mod>norbit_max) stop 'input_dataset_occ: error -- to many occupation lines!'
10309 : 7 : tmp_l(atp%norbit_mod)=ll
10310 : 7 : tmp_n(atp%norbit_mod)=nn
10311 : 7 : tmp_k(atp%norbit_mod)=kk
10312 : 7 : tmp_occ(atp%norbit_mod)=xocc
10313 : 4 : 30 continue
10314 : : END DO
10315 [ - + ]: 4 : IF(ALLOCATED(atp%orbit_mod_l)) then
10316 : 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_l)
10317 : : endif
10318 [ - + ]: 4 : IF(ALLOCATED(atp%orbit_mod_n)) then
10319 : 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_n)
10320 : : endif
10321 [ - + ]: 4 : IF(ALLOCATED(atp%orbit_mod_k)) then
10322 : 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_k)
10323 : : endif
10324 [ - + ]: 4 : IF(ALLOCATED(atp%orbit_mod_occ)) then
10325 : 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_occ)
10326 : : endif
10327 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%orbit_mod_l,(atp%norbit_mod))
+ - + - -
+ - + -
+ ]
10328 [ - + + - : 8 : LIBPAW_ALLOCATE(atp%orbit_mod_n,(atp%norbit_mod))
- + - + -
+ ]
10329 [ - + + - : 8 : LIBPAW_ALLOCATE(atp%orbit_mod_k,(atp%norbit_mod))
- + - + -
+ ]
10330 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%orbit_mod_occ,(atp%norbit_mod))
+ - + - -
+ - + -
+ ]
10331 [ + + ]: 11 : atp%orbit_mod_l(1:atp%norbit_mod)=tmp_l(1:atp%norbit_mod)
10332 [ + + ]: 11 : atp%orbit_mod_n(1:atp%norbit_mod)=tmp_n(1:atp%norbit_mod)
10333 [ + + ]: 11 : atp%orbit_mod_k(1:atp%norbit_mod)=tmp_k(1:atp%norbit_mod)
10334 [ + + ]: 11 : atp%orbit_mod_occ(1:atp%norbit_mod)=tmp_occ(1:atp%norbit_mod)
10335 : : !------------------------------------------------------------------
10336 : : !End reading of electronic data. Start reading of core/valence data
10337 : : ENDIF
10338 [ + - ]: 4 : IF (read_coreval_data_) THEN
10339 : : !------------------------------------------------------------------
10340 : : !=== Core and valence states
10341 : : !Read core and valence states
10342 [ - + ]: 4 : IF (ALLOCATED(atp%orbit_iscore)) then
10343 : 0 : LIBPAW_DEALLOCATE(atp%orbit_iscore)
10344 : : endif
10345 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%orbit_iscore,(atp%norbit))
+ - + - -
+ - + -
+ ]
10346 : 4 : jdirac=1
10347 [ + + ]: 31 : DO io=1,atp%norbit
10348 : 0 : DO
10349 [ + + + + ]: 27 : if(atp%diracrelativistic.and.(.not.dirac)) then
10350 [ + + ]: 7 : if(jdirac==atp%np(1)+max(atp%np(2)-1,0)) then
10351 [ + + ]: 3 : do ii=1,max(atp%np(2)-1,0)
10352 : 2 : READ(input_unit,'(a)') inputline
10353 : 3 : jdirac=jdirac+1
10354 : : enddo
10355 : : endif
10356 [ + + ]: 7 : if(jdirac==atp%np(1)+2*max(atp%np(2)-1,0)+max(atp%np(3)-2,0)) then
10357 [ + + ]: 2 : do ii=1,max(atp%np(3)-2,0)
10358 : 1 : READ(input_unit,'(a)') inputline
10359 : 2 : jdirac=jdirac+1
10360 : : enddo
10361 : : endif
10362 [ + + ]: 7 : if(jdirac==atp%np(1)+2*max(atp%np(2)-1,0)+2*max(atp%np(3)-2,0) &
10363 : : & +max(atp%np(4)-3,0)) then
10364 [ - + ]: 1 : do ii=1,max(atp%np(4)-3,0)
10365 : 0 : READ(input_unit,'(a)') inputline
10366 : 1 : jdirac=jdirac+1
10367 : : enddo
10368 : : endif
10369 : : endif
10370 : 27 : READ(input_unit,'(a)') inputline
10371 : 27 : jdirac=jdirac+1
10372 : 27 : CALL eliminate_comment(inputline)
10373 : 27 : READ(inputline,*) CHR
10374 : : IF (CHR=='c'.OR.CHR=='C'.OR.&
10375 [ + - ]: 27 : & CHR=='v'.OR.CHR=='V') THEN
10376 [ + - ]: 27 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10377 : : EXIT
10378 : : ELSE
10379 : 0 : LIBPAW_ERROR('Please input c or v!')
10380 : : END IF
10381 : : END DO
10382 : 31 : atp%orbit_iscore(io)=(CHR=='c'.OR.CHR=='C')
10383 : : END DO
10384 : : !Store valence states
10385 [ + + + + ]: 31 : atp%norbit_val=atp%norbit-COUNT(atp%orbit_iscore(:))
10386 [ - + ]: 4 : IF (ALLOCATED(atp%orbit_val_n)) then
10387 : 0 : LIBPAW_DEALLOCATE(atp%orbit_val_n)
10388 : : endif
10389 [ - + ]: 4 : IF (ALLOCATED(atp%orbit_val_l)) then
10390 : 0 : LIBPAW_DEALLOCATE(atp%orbit_val_l)
10391 : : endif
10392 [ - + ]: 4 : IF (ALLOCATED(atp%orbit_val_k)) then
10393 : 0 : LIBPAW_DEALLOCATE(atp%orbit_val_k)
10394 : : endif
10395 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%orbit_val_n,(atp%norbit_val))
+ - + - -
+ - + -
+ ]
10396 [ - + + - : 8 : LIBPAW_ALLOCATE(atp%orbit_val_l,(atp%norbit_val))
- + - + -
+ ]
10397 [ - + + - : 8 : LIBPAW_ALLOCATE(atp%orbit_val_k,(atp%norbit_val))
- + - + -
+ ]
10398 : 4 : kk=0
10399 : 4 : io=0;nval=0
10400 [ + + ]: 24 : DO ll=0,4
10401 : 20 : nn=atp%np(ll+1)
10402 [ + + ]: 24 : IF (nn>0) THEN
10403 [ + + + + : 29 : DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic.and.dirac)
+ + ]
10404 [ + + + + ]: 14 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10405 [ + + + + ]: 12 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) kk=0
10406 [ + + ]: 49 : DO ii=1+ll,nn
10407 : 27 : io=io+1
10408 [ + + ]: 39 : IF (.NOT.atp%orbit_iscore(io)) THEN
10409 : 14 : nval=nval+1
10410 : 14 : atp%orbit_val_n(nval)=ii
10411 : 14 : atp%orbit_val_l(nval)=ll
10412 : 14 : atp%orbit_val_k(nval)=kk
10413 : : END IF
10414 : : END DO
10415 : : END DO
10416 : : END IF
10417 : : END DO
10418 [ - + ]: 4 : IF (atp%norbit_val/=nval) STOP 'input_dataset: bug -- wrong nval!'
10419 : : !Print read data
10420 [ - + ]: 4 : IF (has_to_print) THEN
10421 : 0 : WRITE(STD_OUT,'(3x,a)') "Core and valence orbitals:"
10422 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) WRITE(STD_OUT,'(7x,a)') "n l : type"
10423 [ # # # # ]: 0 : IF (atp%diracrelativistic.and.dirac) WRITE(STD_OUT,'(7x,a)') "n l kappa :type"
10424 : 0 : io=0
10425 [ # # ]: 0 : DO ll=0,4
10426 : 0 : nn=atp%np(ll+1)
10427 [ # # ]: 0 : IF (nn>0) THEN
10428 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) THEN
10429 [ # # ]: 0 : DO ii=1+ll,nn
10430 : 0 : io=io+1
10431 : 0 : WRITE(STD_OUT,'(7x,i1,1x,i1,2a)') ii,ll," : ", &
10432 [ # # ]: 0 : & MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
10433 : : END DO
10434 : : ELSE
10435 [ # # ]: 0 : DO ik=1,nkappa(ll+1)
10436 [ # # # # ]: 0 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10437 [ # # ]: 0 : DO ii=1+ll,nn
10438 : 0 : io=io+1
10439 : 0 : WRITE(STD_OUT,'(7x,i1,1x,i1,2x,i2,2x,2a)') ii,ll,kk," : ", &
10440 [ # # ]: 0 : & MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
10441 : : END DO
10442 : : END DO
10443 : : END IF
10444 : : END IF
10445 : : END DO
10446 : : END IF
10447 : : !------------------------------------------------------------------
10448 : : !End reading of AE data. Start reading of basis data
10449 : : ENDIF
10450 [ + - ]: 4 : IF (read_basis_data_) THEN
10451 : : !------------------------------------------------------------------
10452 : : !=== Maximum L for basis functions
10453 : 4 : READ(input_unit,'(a)') inputline
10454 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10455 : 4 : CALL eliminate_comment(inputline)
10456 : 4 : READ(inputline,*) atp%lmax
10457 : : !Print read data
10458 [ - + ]: 4 : IF (has_to_print) THEN
10459 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Basis, maximum L : ",atp%lmax
10460 : : END IF
10461 : : !------------------------------------------------------------------
10462 : : !=== Cut-off radii
10463 : 4 : READ(input_unit,'(a)') inputline
10464 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10465 : 4 : CALL eliminate_comment(inputline)
10466 : 4 : CALL extractword(1,inputline,inputword);inputword=trim(inputword)
10467 [ + - ]: 4 : IF (inputword/="") READ(inputword,*) atp%rc
10468 [ - + ]: 4 : IF (atp%rc<=tol12) THEN
10469 : 0 : LIBPAW_ERROR('input_dataset: error -- rc too small ')
10470 : : END IF
10471 : 4 : CALL extractword(2,inputline,inputword);inputword=trim(inputword)
10472 [ + - ]: 4 : IF (inputword/="") THEN
10473 : 4 : READ(inputword,*) atp%rc_shap
10474 : 4 : CALL extractword(3,inputline,inputword);inputword=trim(inputword)
10475 [ + - ]: 4 : IF (inputword/="") THEN
10476 : 4 : READ(inputword,*) atp%rc_vloc
10477 : 4 : CALL extractword(4,inputline,inputword);inputword=trim(inputword)
10478 [ + - ]: 4 : IF (inputword/="") THEN
10479 : 4 : READ(inputword,*) atp%rc_core
10480 : : ELSE
10481 : 0 : LIBPAW_ERROR('input_dataset: error -- rc(core) is missing!')
10482 : : END IF
10483 : : ELSE
10484 : 0 : LIBPAW_ERROR('input_dataset: error -- rc(Vloc) is missing!')
10485 : : END IF
10486 [ + - + - : 4 : IF (atp%rc_shap<=tol12.OR.atp%rc_vloc<=tol12.OR.&
- + ]
10487 : : & atp%rc_core<=tol12) THEN
10488 : 0 : LIBPAW_ERROR('input_dataset: error -- one rc is too small!')
10489 : : END IF
10490 [ + - + - : 4 : IF (atp%rc_shap>atp%rc.OR.atp%rc_vloc>atp%rc.OR.&
- + ]
10491 : : & atp%rc_core>atp%rc) THEN
10492 : 0 : LIBPAW_ERROR('input_dataset: error -- rc_shape, rc_vloc and rc_core must be <rc!')
10493 : : END IF
10494 : : ENDIF
10495 [ - + ]: 4 : IF(atp%rc_shap==zero) atp%rc_shap=atp%rc
10496 [ - + ]: 4 : IF(atp%rc_vloc==zero) atp%rc_vloc=atp%rc
10497 [ - + ]: 4 : IF(atp%rc_core==zero) atp%rc_core=atp%rc
10498 : : !Print read data
10499 [ - + ]: 4 : IF (has_to_print) THEN
10500 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Augmentation region radius : ",atp%rc
10501 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Core dens. matching radius : ",atp%rc_core
10502 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Local pot. matching radius : ",atp%rc_vloc
10503 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Compens. shape func radius : ",atp%rc_shap
10504 : : END IF
10505 : :
10506 : : !------------------------------------------------------------------
10507 : : !=== Additional basis functions
10508 : 4 : nstart=0 ; atp%nbasis_add=0 ; basis_add_k(:)=0
10509 [ + + ]: 18 : DO ll=0,atp%lmax
10510 : 14 : nbl=0
10511 [ + + + + ]: 14 : nadd = MERGE(nkappa(ll+1),1,atp%diracrelativistic.and.dirac)
10512 : : IF (atp%np(ll+1)>0) THEN
10513 : 14 : nbl=COUNT(.NOT.atp%orbit_iscore(nstart+1:nstart+atp%np(ll+1)-ll))
10514 : 14 : nstart=nstart+atp%np(ll+1)-ll
10515 : : END IF
10516 : 28 : DO
10517 : 38 : READ(input_unit,'(a)') inputline
10518 [ + - ]: 38 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10519 : 38 : CALL eliminate_comment(inputline)
10520 : 38 : READ(inputline,*) CHR
10521 [ + + ]: 38 : IF (CHR/='y'.AND.CHR/='Y') THEN
10522 [ - + ]: 14 : IF (CHR/='n'.AND.CHR/='N') STOP 'input_dataset: error -- Please enter Y or N!'
10523 : : EXIT
10524 : : END IF
10525 : 24 : atp%nbasis_add=atp%nbasis_add+nadd
10526 [ - + ]: 24 : IF (atp%nbasis_add>nbasis_add_max) STOP 'Too many additional basis functions!'
10527 [ + + ]: 50 : basis_add_l(atp%nbasis_add-nadd+1:atp%nbasis_add)=ll
10528 [ + + + + ]: 24 : IF (atp%diracrelativistic.and.dirac) THEN
10529 : 2 : basis_add_k(atp%nbasis_add)=-1
10530 [ + - ]: 2 : IF (ll/=0) THEN
10531 : 2 : basis_add_k(atp%nbasis_add-1)=ll
10532 : 2 : basis_add_k(atp%nbasis_add)=-(ll+1)
10533 : : END IF
10534 : : END IF
10535 : 24 : READ(input_unit,'(a)') inputline
10536 [ + - ]: 24 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10537 : 24 : CALL eliminate_comment(inputline)
10538 : 24 : READ(inputline,*) basis_add_energy(atp%nbasis_add-nadd+1:atp%nbasis_add)
10539 : : END DO
10540 : : END DO
10541 [ - + ]: 4 : IF (ALLOCATED(atp%basis_add_l)) then
10542 : 0 : LIBPAW_DEALLOCATE(atp%basis_add_l)
10543 : : endif
10544 [ - + ]: 4 : IF (ALLOCATED(atp%basis_add_k)) then
10545 : 0 : LIBPAW_DEALLOCATE(atp%basis_add_k)
10546 : : endif
10547 [ - + ]: 4 : IF (ALLOCATED(atp%basis_add_energy)) then
10548 : 0 : LIBPAW_DEALLOCATE(atp%basis_add_energy)
10549 : : endif
10550 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%basis_add_l,(atp%nbasis_add))
+ - + - -
+ - + -
+ ]
10551 [ - + + - : 8 : LIBPAW_ALLOCATE(atp%basis_add_k,(atp%nbasis_add))
- + - + -
+ ]
10552 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%basis_add_energy,(atp%nbasis_add))
+ - + - -
+ - + -
+ ]
10553 [ + - ]: 4 : IF (atp%nbasis_add>0) THEN
10554 [ + + ]: 30 : atp%basis_add_l(1:atp%nbasis_add)=basis_add_l(1:atp%nbasis_add)
10555 [ + + ]: 30 : atp%basis_add_k(1:atp%nbasis_add)=basis_add_k(1:atp%nbasis_add)
10556 [ + + ]: 30 : atp%basis_add_energy(1:atp%nbasis_add)=basis_add_energy(1:atp%nbasis_add)
10557 : : END IF
10558 [ + + + + ]: 31 : atp%nbasis=COUNT(.NOT.atp%orbit_iscore(:))+atp%nbasis_add
10559 : : !Print read data
10560 [ - + ]: 4 : IF (has_to_print) THEN
10561 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Initial number of basis functions:",atp%nbasis-atp%nbasis_add
10562 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Number of additional basis functions:",atp%nbasis_add
10563 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of basis functions:",atp%nbasis
10564 : 0 : WRITE(STD_OUT,'(3x,a)') "Additional basis functions:"
10565 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) THEN
10566 : 0 : WRITE(STD_OUT,'(7x,a)') "l : energy"
10567 [ # # ]: 0 : DO io=1,atp%nbasis_add
10568 : 0 : WRITE(STD_OUT,'(7x,i1,a,f7.4)') atp%basis_add_l(io)," :",atp%basis_add_energy(io)
10569 : : END DO
10570 : : ELSE
10571 : 0 : WRITE(STD_OUT,'(7x,a)') "l kappa : energy"
10572 [ # # ]: 0 : DO io=1,atp%nbasis_add
10573 : 0 : WRITE(STD_OUT,'(7x,i1,2x,i2,2x,a,f7.4)') atp%basis_add_l(io), &
10574 : 0 : & atp%basis_add_k(io)," : " ,atp%basis_add_energy(io)
10575 : : END DO
10576 : : END IF
10577 : : END IF
10578 : : !------------------------------------------------------------------
10579 : : !=== Projectors, compensation charge shape function, core tolerance
10580 : 4 : READ(input_unit,'(a)') inputline
10581 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10582 : 4 : CALL eliminate_comment(inputline)
10583 : 4 : CALL Uppercase(inputline)
10584 : : inputline=TRIM(inputline)
10585 : 4 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL
10586 : 4 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10587 : 4 : atp%pseudo_polynom2_pdeg=polynom2_pdeg_def
10588 : 4 : atp%pseudo_polynom2_qcut=polynom2_qcut_def
10589 : 4 : atp%shapefunc_type=SHAPEFUNC_TYPE_SINC
10590 : 4 : atp%shapefunc_gaussian_param=gausstol_def
10591 : 4 : atp%hf_coretol=hf_coretol_def
10592 : 4 : READ(unit=inputline,fmt=*) inputword
10593 [ + - - + ]: 4 : IF (TRIM(inputword)=='BLOECHL'.OR.TRIM(inputword)=='VNCT') THEN
10594 : 0 : atp%projector_type=PROJECTOR_TYPE_BLOECHL
10595 : 0 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL
10596 : 0 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10597 [ - + ]: 4 : ELSE IF (TRIM(inputword)=='VNCK') THEN
10598 : 0 : atp%projector_type=PROJECTOR_TYPE_BLOECHL
10599 : 0 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL_K
10600 : 0 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10601 [ + + - + ]: 4 : ELSE IF (TRIM(inputword)=='VANDERBILT'.OR.TRIM(inputword)=='VNCTV') THEN
10602 : 2 : atp%projector_type=PROJECTOR_TYPE_VANDERBILT
10603 : 2 : atp%pseudo_type=PSEUDO_TYPE_POLYNOM
10604 : 2 : atp%ortho_type=ORTHO_TYPE_VANDERBILT
10605 [ - + ]: 2 : ELSE IF(TRIM(inputword)=='MODRRKJ') THEN
10606 : 0 : atp%projector_type=PROJECTOR_TYPE_MODRRKJ
10607 : 0 : atp%pseudo_type=PSEUDO_TYPE_RRKJ
10608 : 0 : atp%ortho_type=ORTHO_TYPE_VANDERBILT
10609 : : IF (INDEX(inputline,'VANDERBILTORTHO')>0)atp%ortho_type=ORTHO_TYPE_VANDERBILT
10610 [ # # ]: 0 : IF (INDEX(inputline,'GRAMSCHMIDTORTHO')>0)atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10611 [ # # ]: 0 : IF (INDEX(inputline,'SVDORTHO')>0) atp%ortho_type=ORTHO_TYPE_SVD
10612 [ + - ]: 2 : ELSE IF (TRIM(inputword)=='CUSTOM') THEN
10613 : 2 : atp%projector_type=PROJECTOR_TYPE_CUSTOM
10614 [ - + ]: 2 : IF (INDEX(inputline,'BLOECHLPS')>0) THEN
10615 : 0 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL
10616 : 0 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10617 [ - + ]: 2 : ELSE IF (INDEX(inputline,'POLYNOM2')>0) THEN
10618 : 0 : atp%pseudo_type=PSEUDO_TYPE_POLYNOM2
10619 : 0 : nstart=INDEX(inputline,'POLYNOM2')
10620 : : READ(unit=inputline(nstart+8:),fmt=*,err=111,end=111,iostat=io) &
10621 [ # # ]: 0 : & atp%pseudo_polynom2_pdeg,atp%pseudo_polynom2_qcut
10622 : : 111 CONTINUE
10623 [ - + ]: 2 : ELSE IF (INDEX(inputline,'POLYNOM')>0) THEN
10624 : 0 : atp%pseudo_type=PSEUDO_TYPE_POLYNOM
10625 [ + - ]: 2 : ELSE IF (INDEX(inputline,'RRKJ')>0) THEN
10626 : 2 : atp%pseudo_type=PSEUDO_TYPE_RRKJ
10627 : : END IF
10628 [ + - ]: 2 : IF (INDEX(inputline,'VANDERBILTORTHO')>0)atp%ortho_type=ORTHO_TYPE_VANDERBILT
10629 [ - + ]: 2 : IF (INDEX(inputline,'GRAMSCHMIDTORTHO')>0)atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10630 : : END IF
10631 [ - + ]: 4 : IF (TRIM(atp%exctype)=='HF') THEN
10632 : 0 : atp%projector_type=PROJECTOR_TYPE_HF
10633 : 0 : atp%pseudo_type=PSEUDO_TYPE_HF
10634 : 0 : atp%ortho_type=ORTHO_TYPE_HF
10635 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,'(3x,a)') '>> You are using HF XC type: pseudo and orthogonalization line will be ignored!'
10636 : : END IF
10637 : : IF ((atp%pseudo_type==PSEUDO_TYPE_BLOECHL.OR. &
10638 : : & atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10639 [ - + - - ]: 4 : & .AND.atp%ortho_type==ORTHO_TYPE_VANDERBILT) STOP &
10640 : 0 : & 'input_dataset: error -- Vanderbilt orthogonalization not compatible with Bloechls projector scheme!'
10641 : : IF ((atp%pseudo_type==PSEUDO_TYPE_BLOECHL.OR. &
10642 : : & atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10643 [ - + - - ]: 4 : & .AND.atp%ortho_type==ORTHO_TYPE_VANDERBILT) STOP &
10644 : 0 : & 'input_dataset: error -- Vanderbilt orthogonalization not compatible with Bloechls projector scheme!'
10645 : : IF ((atp%projector_type==PROJECTOR_TYPE_BLOECHL) &
10646 [ - + - - ]: 4 : & .AND.atp%needvtau) STOP &
10647 : 0 : & 'input_dataset: error -- mGGA not compatible the Bloechl projector scheme!'
10648 : : !!!! Hopefully this will never happen
10649 : : IF ((atp%projector_type==PROJECTOR_TYPE_HF) &
10650 [ - + - - ]: 4 : & .AND.atp%needvtau) STOP &
10651 : 0 : & 'input_dataset: error -- mGGA and Hartree-Fock are not compatible!'
10652 : : IF ((atp%pseudo_type==PSEUDO_TYPE_BLOECHL.OR. &
10653 : : & atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10654 [ - + - - ]: 4 : & .AND.atp%needvtau) STOP &
10655 : 0 : & 'input_dataset: error -- mGGA not compatible the Bloechl pseudization scheme!'
10656 [ - + ]: 4 : IF (INDEX(inputline,'SINC2')>0) THEN
10657 : 0 : atp%shapefunc_type=SHAPEFUNC_TYPE_SINC
10658 [ - + ]: 4 : ELSE IF (INDEX(inputline,'GAUSSIAN')>0) THEN
10659 : 0 : atp%shapefunc_type=SHAPEFUNC_TYPE_GAUSSIAN
10660 : 0 : nstart=INDEX(inputline,'GAUSSIAN')
10661 : : READ(unit=inputline(nstart+8:),fmt=*,err=222,end=222,iostat=io) &
10662 [ # # ]: 0 : & atp%shapefunc_gaussian_param
10663 : : 222 CONTINUE
10664 [ - + ]: 4 : ELSE IF (INDEX(inputline,'BESSELSHAPE')>0) THEN
10665 : 0 : atp%shapefunc_type=SHAPEFUNC_TYPE_BESSEL
10666 : : END IF
10667 : 4 : nstart=INDEX(inputline,'CORETOL')
10668 [ - + ]: 4 : IF (nstart>0) THEN
10669 : 0 : READ(unit=inputline(nstart+7:),fmt=*) atp%hf_coretol
10670 : : END IF
10671 : 4 : atp%shapetcore=(INDEX(inputline,'SHAPETCORE')>0)
10672 : : !Print read data
10673 [ - + ]: 4 : IF (has_to_print) THEN
10674 : 0 : WRITE(STD_OUT,'(3x,a)') "Projectors description:"
10675 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_BLOECHL) &
10676 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : BLOECHL"
10677 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_VANDERBILT) &
10678 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : VANDERBILT"
10679 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_MODRRKJ) &
10680 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : MODRRKJ"
10681 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_CUSTOM) &
10682 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : CUSTOM"
10683 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_HF) &
10684 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : HARTREE-FOCK"
10685 [ # # ]: 0 : IF (atp%projector_type/=PROJECTOR_TYPE_HF) THEN
10686 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL) &
10687 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL"
10688 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM) &
10689 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : POLYNOM"
10690 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_RRKJ) &
10691 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : RRKJ"
10692 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10693 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL KERKER"
10694 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM2) &
10695 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,es9.3)') "Pseudization : POLYNOM2,pdeg=",&
10696 : 0 : & atp%pseudo_polynom2_pdeg,", qcut=",atp%pseudo_polynom2_qcut
10697 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_GRAMSCHMIDT) &
10698 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : GRAM-SCHMIDT"
10699 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_VANDERBILT) &
10700 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : VANDERBILT"
10701 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_SVD) &
10702 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : SVD"
10703 : : END IF
10704 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_GAUSSIAN) &
10705 : 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Compensation charge shape function : GAUSSIAN, tol=",&
10706 : 0 : & atp%shapefunc_gaussian_param
10707 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_SINC) &
10708 : 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : SINC2"
10709 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_BESSEL) &
10710 : 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : BESSEL"
10711 [ # # ]: 0 : IF (INDEX(inputline,'CORETOL')>0) &
10712 : 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Core tolerance for Hartree-Fock:",atp%hf_coretol
10713 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Smooth tcore shape (no negative nhat):",MERGE("YES"," NO",atp%shapetcore)
10714 : : END IF
10715 : : !------------------------------------------------------------------
10716 : : !=== Local pseudopotential
10717 : 4 : READ(input_unit,'(a)') inputline
10718 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10719 : 4 : CALL eliminate_comment(inputline)
10720 : 4 : call Uppercase(inputline)
10721 : : inputline=TRIM(inputline)
10722 : 4 : atp%vloc_type=VLOC_TYPE_MTROULLIER
10723 : 4 : atp%vloc_l=-1
10724 : 4 : atp%vloc_ene=0._dp
10725 : 4 : atp%vloc_setvloc_coef=0._dp
10726 : 4 : atp%vloc_setvloc_rad=atp%rc
10727 [ + + ]: 20 : atp%vloc_kerker_power(:)=0
10728 [ + - ]: 4 : IF (INDEX(inputline,'MTROULLIER')>0) THEN
10729 : : atp%vloc_type=VLOC_TYPE_MTROULLIER
10730 [ - + ]: 4 : ELSE IF (INDEX(inputline,'ULTRASOFT')>0) THEN
10731 : 0 : atp%vloc_type=VLOC_TYPE_ULTRASOFT
10732 [ - + ]: 4 : ELSE IF (INDEX(inputline,'BESSEL')>0) THEN
10733 : 0 : atp%vloc_type=VLOC_TYPE_BESSEL
10734 [ - + ]: 4 : ELSE IF (INDEX(inputline,'VPSMATCHNC')>0) THEN
10735 : 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNC
10736 [ - + ]: 4 : ELSE IF (INDEX(inputline,'VPSMATCHNNC')>0) THEN
10737 : 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNNC
10738 [ - + ]: 4 : ELSE IF (INDEX(inputline,'SETVLOC')>0) THEN
10739 : 0 : atp%vloc_type=VLOC_TYPE_SETVLOC
10740 : 0 : nstart=INDEX(inputline,'SETVLOC')
10741 [ # # ]: 0 : READ(unit=inputline(nstart+8:),fmt=*,err=333,end=333,iostat=io) x1,x2
10742 [ # # # # ]: 0 : IF (x1<10._dp**3.AND.x1>-10._dp**3) atp%vloc_setvloc_coef=x1
10743 [ # # # # ]: 0 : IF (x2>tol8.AND.x2<atp%rc) atp%vloc_setvloc_rad=x2
10744 : : 333 CONTINUE
10745 [ + - - + ]: 4 : ELSE IF (INDEX(inputline,'KERKER')>0.OR.atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) THEN
10746 [ # # ]: 0 : IF (INDEX(inputline,'EXPF')>0) THEN
10747 : 0 : atp%vloc_type=VLOC_TYPE_KERKER_EXPF
10748 : 0 : nstart=INDEX(inputline,'EXPF')
10749 [ # # ]: 0 : ELSE IF (INDEX(inputline,'POLY')>0) THEN
10750 : 0 : atp%vloc_type=VLOC_TYPE_KERKER_POLY
10751 : 0 : nstart=INDEX(inputline,'POLY')
10752 : : ELSE
10753 : 0 : STOP "EXPF or POLY keyword missing!"
10754 : : END IF
10755 : : READ(unit=inputline(nstart+5:),fmt=*,err=334,end=334,iostat=io) &
10756 [ # # ]: 0 : & atp%vloc_kerker_power(1:4)
10757 : : 334 CONTINUE
10758 : : END IF
10759 : : IF ((atp%vloc_type==VLOC_TYPE_SETVLOC.OR. &
10760 : : & atp%vloc_type==VLOC_TYPE_KERKER_EXPF.OR. &
10761 : : & atp%vloc_type==VLOC_TYPE_KERKER_POLY) &
10762 [ - + - - ]: 4 : & .AND.atp%needvtau) STOP &
10763 : 0 : & 'input_dataset: error -- mGGA not compatible the chosen Vloc scheme!'
10764 : : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.OR. &
10765 : : & atp%vloc_type==VLOC_TYPE_VPSMATCHNC.OR. &
10766 [ - + - - : 4 : & atp%vloc_type==VLOC_TYPE_VPSMATCHNNC.OR. &
- - ]
10767 : : & atp%vloc_type==VLOC_TYPE_ULTRASOFT) THEN
10768 [ + - ]: 4 : READ(unit=inputline,fmt=*,err=444,end=444,iostat=io) atp%vloc_l,atp%vloc_ene
10769 : : 444 CONTINUE
10770 [ - + ]: 4 : IF (atp%vloc_l<0.or.atp%vloc_l>10) STOP 'input_dataset: error while reading Vloc parameters!'
10771 : : END IF
10772 [ + - - + ]: 4 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.AND.atp%needvtau) then
10773 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,'(7x,a)') 'NOTE: MTROULLIER Vloc not available for mGGA!'
10774 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,'(7x,a)') ' Calling VPSmatch with norm conservation instead.'
10775 : 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNC
10776 : : ENDIF
10777 : : !Print read data
10778 [ - + ]: 4 : IF (has_to_print) THEN
10779 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER) &
10780 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type : MTROULLIER,l=",&
10781 : 0 : & atp%vloc_l,", energy=",atp%vloc_ene
10782 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_ULTRASOFT) &
10783 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type : ULTRASOFT,l=",&
10784 : 0 : & atp%vloc_l,", energy=",atp%vloc_ene
10785 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_BESSEL) &
10786 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : BESSEL"
10787 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNC) &
10788 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
10789 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNNC) &
10790 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNNC"
10791 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_SETVLOC) THEN
10792 : 0 : WRITE(STD_OUT,'(7x,a,es9.4,a,es9.4)') "Local pseudopotential type :SETVLOC, coef=",&
10793 : 0 : & atp%vloc_setvloc_coef,", rad=",atp%vloc_setvloc_rad
10794 [ # # ]: 0 : IF (atp%needvtau) THEN
10795 : 0 : LIBPAW_ERROR('SETVLOC option not available for MGGA')
10796 : : ENDIF
10797 : : ENDIF
10798 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_EXPF) &
10799 : 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER EXPF,powers=",&
10800 : 0 : & atp%vloc_kerker_power(1:4)
10801 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_POLY) &
10802 : 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER POLY,powers=",&
10803 : 0 : & atp%vloc_kerker_power(1:4)
10804 [ # # # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.AND.atp%needvtau) THEN
10805 : 0 : WRITE(STD_OUT,'(7x,a)') 'NOTE: MTROULLIER Vloc not available for mGGA!'
10806 : 0 : WRITE(STD_OUT,'(7x,a)') ' Calling VPSmatch with norm conservation instead.'
10807 : 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNC
10808 : 0 : WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
10809 : : END IF
10810 : : END IF
10811 : :
10812 : :
10813 : :
10814 : :
10815 : :
10816 : :
10817 : :
10818 : : !------------------------------------------------------------------
10819 : : !=== Matching radii for the basis functions
10820 : : !Not for all choice of projectors
10821 : : IF (atp%projector_type==PROJECTOR_TYPE_CUSTOM.OR.&
10822 : : & atp%projector_type==PROJECTOR_TYPE_VANDERBILT.OR.&
10823 [ - + - - : 4 : & atp%projector_type==PROJECTOR_TYPE_MODRRKJ.OR.&
- - ]
10824 : : & atp%projector_type==PROJECTOR_TYPE_HF.AND.atp%vloc_type==VLOC_TYPE_MTROULLIER)THEN
10825 [ - + ]: 4 : IF (ALLOCATED(atp%basis_func_rc)) then
10826 : 0 : LIBPAW_DEALLOCATE(atp%basis_func_rc)
10827 : : endif
10828 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%basis_func_rc,(atp%nbasis))
+ - + - -
+ - + -
+ ]
10829 : 4 : norb=0
10830 [ + + ]: 18 : DO ll=0,atp%lmax
10831 [ + + + + ]: 44 : DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic)
10832 [ + + + + ]: 18 : if((.not.dirac).and.(ik>1)) cycle
10833 [ + + + + ]: 18 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10834 [ + + + + ]: 16 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) kk=0
10835 [ + + ]: 74 : DO io=1,atp%norbit_val
10836 [ + + + + : 58 : IF (atp%orbit_val_l(io)==ll.AND. &
+ + + + ]
10837 : 16 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%orbit_val_k(io)==kk)) THEN
10838 : 14 : norb=norb+1
10839 : 14 : READ(input_unit,'(a)') inputline
10840 [ + - ]: 14 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10841 : 14 : CALL eliminate_comment(inputline)
10842 : 14 : READ(inputline,*) atp%basis_func_rc(norb)
10843 : : END IF
10844 : : END DO
10845 [ + - ]: 30 : IF (atp%nbasis_add>0) THEN
10846 [ + + ]: 122 : DO io=1,atp%nbasis_add
10847 [ + + + + : 106 : IF (atp%basis_add_l(io)==ll.AND. &
+ + + + ]
10848 : 16 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%basis_add_k(io)==kk)) THEN
10849 : 26 : norb=norb+1
10850 : 26 : READ(input_unit,'(a)') inputline
10851 [ + - ]: 26 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10852 : 26 : CALL eliminate_comment(inputline)
10853 : 26 : READ(inputline,*) atp%basis_func_rc(norb)
10854 : : END IF
10855 : : END DO
10856 : : END IF
10857 : : END DO
10858 : : END DO
10859 [ - + ]: 4 : IF (atp%nbasis/=norb) STOP 'input_dataset: error -- inconsistency in the number of basis functions!'
10860 : : ! Print read data
10861 [ - + ]: 4 : IF (has_to_print) THEN
10862 : 0 : WRITE(STD_OUT,'(3x,a)') "Matching radius for basis functions:"
10863 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) WRITE(STD_OUT,'(7x,a)') " # - n l : radius"
10864 [ # # # # ]: 0 : IF (atp%diracrelativistic.and.dirac) WRITE(STD_OUT,'(7x,a)') " # - n l kappa : radius"
10865 : 0 : norb=0
10866 [ # # ]: 0 : DO ll=0,atp%lmax
10867 [ # # # # : 0 : DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic.and.dirac)
# # ]
10868 [ # # # # ]: 0 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10869 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) kk=0
10870 [ # # ]: 0 : DO io=1,atp%norbit_val
10871 [ # # # # : 0 : IF (atp%orbit_val_l(io)==ll.AND. &
# # # # ]
10872 : 0 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%orbit_val_k(io)==kk))THEN
10873 : 0 : norb=norb+1
10874 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) &
10875 : : & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,a,f7.4)') &
10876 : 0 : & norb," - ",atp%orbit_val_n(io),ll," :",atp%basis_func_rc(norb)
10877 [ # # # # ]: 0 : IF (atp%diracrelativistic.and.dirac) &
10878 : : & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,2x,i2,2x,a,f7.4)') &
10879 : 0 : & norb," - ",atp%orbit_val_n(io),ll,kk," :",atp%basis_func_rc(norb)
10880 : : END IF
10881 : : END DO
10882 [ # # ]: 0 : IF (atp%nbasis_add>0) THEN
10883 [ # # ]: 0 : DO io=1,atp%nbasis_add
10884 [ # # # # : 0 : IF (atp%basis_add_l(io)==ll.AND. &
# # # # ]
10885 : 0 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%basis_add_k(io)==kk))THEN
10886 : 0 : norb=norb+1
10887 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) &
10888 : : & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,a,f7.4)') &
10889 : 0 : & norb," - ",".",ll," : ",atp%basis_func_rc(norb)
10890 [ # # # # ]: 0 : IF (atp%diracrelativistic.and.dirac) &
10891 : : & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,2x,i2,2x,a,f7.4)') &
10892 : 0 : & norb," - ",".",ll,kk," : ",atp%basis_func_rc(norb)
10893 : : END IF
10894 : : END DO
10895 : : END IF
10896 : : END DO
10897 : : END DO
10898 : : END IF
10899 : : ELSE ! Other projectors
10900 [ # # ]: 0 : IF (ALLOCATED(atp%basis_func_rc)) then
10901 : 0 : LIBPAW_DEALLOCATE(atp%basis_func_rc)
10902 : : endif
10903 [ # # # # ]: 0 : LIBPAW_ALLOCATE(atp%basis_func_rc,(0))
10904 : : END IF
10905 : : !------------------------------------------------------------------
10906 : : !End reading of basis data
10907 : : ENDIF
10908 : : !Final message
10909 [ - + - - ]: 4 : IF(read_global_data_.OR.read_elec_data_.OR.read_coreval_data_.OR.read_basis_data_)THEN
10910 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,'(3x,a)') "===== END READING OF INPUT FILE ====="
10911 : : END IF
10912 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,'(2/)')
10913 : : !------------------------------------------------------------------
10914 : : ! Checks
10915 : 4 : READ(input_unit,'(a)') inputline
10916 : 4 : READ(input_unit,'(a)') inputline
10917 : 4 : CALL Uppercase(inputline)
10918 : 4 : i_usexcnhat=INDEX(inputline,'USEXCNHAT')
10919 : 4 : i_logspline=INDEX(inputline,'WITHSPLGRID')
10920 : 4 : i_rsoptim =INDEX(inputline,'RSOPTIM')
10921 : 4 : i_lda12 =INDEX(inputline,'LDA12')
10922 [ + - - + ]: 4 : if(i_usexcnhat>0.or.i_logspline>0.or.i_rsoptim>0.or.i_lda12>0) then
10923 : 0 : LIBPAW_ERROR('RCPAW not compatible with usexcnhat, logspline, rsoptim, lda12')
10924 : : endif
10925 : : !Close files
10926 : 4 : CLOSE(ifunit)
10927 [ + - ]: 4 : IF (has_to_echo) THEN
10928 : 4 : CLOSE(ecunit)
10929 : : END IF
10930 : 4 : END SUBROUTINE input_dataset_read
10931 : :
10932 : :
10933 : :
10934 : :
10935 : :
10936 : :
10937 : :
10938 : :
10939 : :
10940 : :
10941 : :
10942 : :
10943 : :
10944 : :
10945 : :
10946 : :
10947 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! xmlinterface !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
10948 : :
10949 : :
10950 : : !!=================================================================
10951 : : !! NAME
10952 : : !! xmlprtcore
10953 : : !!
10954 : : !! FUNCTION
10955 : : !! Write the core wave functions in XML format
10956 : : !!
10957 : : !! INPUTS
10958 : : !! fname=file name (with .xml suffixe)
10959 : : !! mesh_data= datatructure containing the definition of
10960 : : !! all the radial meshes used in the XML file
10961 : : !!
10962 : : !! PARENTS
10963 : : !! atompaw2xml
10964 : : !!
10965 : : !! CHILDREN
10966 : : !!
10967 : : !!=================================================================
10968 : :
10969 : 1 : SUBROUTINE xmlprtcore(fname,atp,zcore,mesh_data,input_string)
10970 : :
10971 : : character(len=*),intent(in) :: fname
10972 : : type(atompaw_type),intent(in) :: atp
10973 : : real(dp) ,intent(in) :: zcore
10974 : : TYPE(mesh_data_type),intent(in) :: mesh_data
10975 : : character(len=*), intent(in) :: input_string
10976 : :
10977 : : !------------------------------------------------------------------
10978 : : !---- Local variables
10979 : : !------------------------------------------------------------------
10980 : :
10981 : : integer :: core_size,corewf_meshsz,ib,icor,ii,ir,nmesh,nsppol
10982 : : integer :: unit_xml_core
10983 : : real(dp) :: radstp0,logstp0
10984 : 2 : character(len=3) :: gridt(mesh_data%nmesh)
10985 : : character(len=4) :: char4
10986 : : character(len=5) :: char5a
10987 : : character(len=20) :: char20,char21
10988 : : character(len=1) :: char_orb(4)
10989 : 1 : integer,allocatable :: irwf(:)
10990 : 1 : real(dp),allocatable :: dum(:)
10991 : :
10992 : : !------------------------------------------------------------------
10993 : : !---- Executable code
10994 : : !------------------------------------------------------------------
10995 : 1 : unit_xml_core=1113
10996 : : !Hard-coded values, spin unrestricted
10997 : : !Spinors or collinear magnetism not yet supported
10998 : 1 : nsppol=1
10999 : 1 : char_orb(1)="s";char_orb(2)="p";char_orb(3)="d";char_orb(4)="f"
11000 : : !Open file for writing
11001 : 1 : OPEN(unit_xml_core,file=TRIM(fname),form='formatted')
11002 : :
11003 : : !Write XML header
11004 : 1 : WRITE(unit_xml_core,'("<?xml version=""1.0""?>")')
11005 : 1 : WRITE(unit_xml_core,'("<paw_setup version=""0.7"">")')
11006 : :
11007 : : !Write title
11008 [ + - ]: 1 : WRITE(unit_xml_core,'(/,"<!-- All-electron core wavefunctions for ",a," -->")')trim(ADJUSTL(atp%Pot%sym))
11009 : :
11010 : : !Write Atompaw information
11011 : 1 : WRITE(unit_xml_core,'("<!-- ",a)') trim('GENERATED by RC-PAW')
11012 : 1 : WRITE(unit_xml_core,'(" Energy units=Hartree, length units=bohr")')
11013 : 1 : WRITE(unit_xml_core,'("-->",/)')
11014 : :
11015 : : !Write atom definition
11016 : 1 : WRITE(unit=char5a,fmt='(f5.2)') atp%Pot%zz
11017 : : WRITE(unit_xml_core,'("<atom symbol=""",a,""" Z=""",a)',ADVANCE='NO') &
11018 [ + - + - ]: 1 : & trim(ADJUSTL(atp%Pot%sym)),trim(ADJUSTL(char5a))
11019 : 1 : WRITE(unit=char5a,fmt='(f5.2)') zcore
11020 [ + - ]: 1 : WRITE(unit_xml_core,'(""" core=""",a,"""/>")')trim(ADJUSTL(char5a))
11021 : :
11022 : :
11023 : : !!Write XC definition
11024 : : ! call get_xc_data(xc_type,xc_name)
11025 : : ! if (have_libxc.and.xc_type/="UNKNOWN") then
11026 : : ! call libxc_getshortname(xc_name,xcname_short)
11027 : : ! call get_xc_alias(xcname_short,xc_name)
11028 : : ! endif
11029 : : ! WRITE(unit_xml_core,'("<xc_functional type=""",a,""" name=""",a,"""/>")') &
11030 : : !& TRIM(xc_type),TRIM(xc_name)
11031 : :
11032 : :
11033 : : !Generator data
11034 [ + - ]: 1 : if (atp%scalarrelativistic) then
11035 : 1 : WRITE(unit_xml_core,'("<generator type=""scalar-relativistic"" name=""atompaw"">")')
11036 [ # # ]: 0 : else if (atp%diracrelativistic) then
11037 : 0 : WRITE(unit_xml_core,'("<generator type=""dirac-relativistic"" name=""atompaw"">")')
11038 : : else
11039 : 0 : WRITE(unit_xml_core,'("<generator type=""non-relativistic"" name=""atompaw"">")')
11040 : : endif
11041 : 1 : WRITE(unit_xml_core,'("</generator>)")')
11042 : :
11043 : : !Number of core orbitals (not needed)
11044 [ + + + + ]: 8 : core_size=count(atp%Orbit%iscore(1:atp%Orbit%norbit))
11045 : : !WRITE(unit_xml_core,'("<orbitals norbs=""",i2,"""/>")') core_size
11046 : :
11047 : : !Read mesh size
11048 : 1 : ii=0
11049 [ - + + - : 3 : LIBPAW_ALLOCATE(irwf,(core_size))
+ - + - -
+ - + ]
11050 [ + + ]: 4 : irwf(:)=mesh_data%meshsz(mesh_data%iwavmesh)
11051 [ + + ]: 8 : do ib=1,atp%Orbit%norbit
11052 [ + + ]: 8 : if (atp%Orbit%iscore(ib)) then
11053 : 3 : ii=ii+1;ir=mesh_data%meshsz(mesh_data%iwavmesh)+1
11054 [ - + ]: 1688 : do while (ir>1)
11055 : 1688 : ir=ir-1
11056 [ + + ]: 1688 : if (abs(atp%Orbit%wfn(ir,ib))>tol10) then
11057 : 3 : irwf(ii)=min(ir+1,mesh_data%meshsz(mesh_data%iwavmesh));ir=1
11058 : : end if
11059 : : end do
11060 : : end if
11061 : : end do
11062 : 1 : corewf_meshsz=maxval(irwf(1:core_size))
11063 [ - + ]: 1 : LIBPAW_DEALLOCATE(irwf)
11064 [ + + ]: 5 : corewf_meshsz=maxval(mesh_data%meshsz(1:mesh_data%nmesh))
11065 : : !Electronic configuration
11066 : 1 : WRITE(unit_xml_core,'("<core_states>")')
11067 : 1 : icor=0
11068 [ + + ]: 8 : do ib=1,atp%Orbit%norbit
11069 [ + + ]: 8 : if (atp%Orbit%iscore(ib)) then
11070 [ - + ]: 3 : icor=icor+1;if (icor>core_size) stop ' Bug (1) in xmlprtcore!'
11071 : 3 : call mkname(icor,char4)
11072 : 3 : char20=stripchar('"'//atp%Pot%sym//'_core'//char4//'"')
11073 [ - + ]: 3 : if(atp%diracrelativistic) then
11074 : : WRITE(unit_xml_core,'(" <state n=""",i2,""" l=""",i1,""" kappa=""",i2,""" f=""",1pe14.7)',ADVANCE='NO')&
11075 : 0 : & atp%Orbit%np(ib),atp%Orbit%l(ib),atp%Orbit%kappa(ib),atp%Orbit%occ(ib)
11076 : : else
11077 : : WRITE(unit_xml_core,'(" <state n=""",i2,""" l=""",i1,""" f=""",1pe14.7)',ADVANCE='NO')&
11078 : 3 : & atp%Orbit%np(ib),atp%Orbit%l(ib),atp%Orbit%occ(ib)
11079 : : endif
11080 : : WRITE(unit_xml_core,'(""" e=""",1pe14.7,""" id=",a11,"/>")')&
11081 : 3 : & atp%Orbit%eig(ib)*0.5d0,TRIM(char20)
11082 : : end if
11083 : : enddo
11084 : 1 : WRITE(unit_xml_core,'("</core_states>")')
11085 : :
11086 : : !Radial meshes definitions
11087 : 1 : nmesh=1
11088 [ + + ]: 2 : do ii=1,nmesh
11089 [ - + + - : 3 : LIBPAW_ALLOCATE(dum,(corewf_meshsz))
+ - + - -
+ - + -
+ ]
11090 : 1 : select case(mesh_data%meshtp(ii))
11091 : : case(1)
11092 : 0 : char21='r=d*i'
11093 : 0 : gridt(ii)="lin"
11094 : 0 : radstp0=zero
11095 : 0 : logstp0=mesh_data%radstp(ii)
11096 [ # # ]: 0 : dum(:)=logstp0
11097 : : case(2)
11098 : 1 : char21='r=a*(exp(d*i)-1)'
11099 : 1 : gridt(ii)="log"
11100 : 1 : radstp0=mesh_data%radstp(ii)
11101 : 1 : logstp0=mesh_data%logstp(ii)
11102 [ + + ]: 2002 : dum(1:corewf_meshsz)=logstp0*(radstp0+atp%Grid%r(1:corewf_meshsz))
11103 : : case default
11104 [ - + - ]: 1 : stop ' Bug (2) in xmlprtcore: mesh type not implemented in Atompaw!'
11105 : : end select
11106 : 1 : WRITE(unit_xml_core,'("<radial_grid eq=""",a,""" a=""",es23.16)',ADVANCE='NO')trim(char21),radstp0
11107 : : WRITE(unit_xml_core,'(""" d=""",es23.16,""" istart=""0"" iend=""",i5)',ADVANCE='NO') &
11108 : 1 : & logstp0,corewf_meshsz-1
11109 : 1 : WRITE(unit_xml_core,'(""" id=""",a,i1,"""/>")') gridt(ii),ii
11110 : 1 : WRITE(unit_xml_core,'(" <values>")')
11111 [ + - + + ]: 2002 : WRITE(unit_xml_core,'(3(1x,es23.16))') (atp%Grid%r(ir),ir=1,corewf_meshsz)
11112 : 1 : WRITE(unit_xml_core,'(" </values>")')
11113 : 1 : WRITE(unit_xml_core,'(" <derivatives>")')
11114 : 1 : WRITE(unit_xml_core,'(3(1x,es23.16))') (dum(ir),ir=1,corewf_meshsz)
11115 : 1 : WRITE(unit_xml_core,'(" </derivatives>")')
11116 [ - + ]: 2 : LIBPAW_DEALLOCATE(dum)
11117 : : end do
11118 : :
11119 : : !Write the core wave functions
11120 : 1 : icor=0
11121 [ + + ]: 8 : do ib=1,atp%Orbit%norbit
11122 [ + + ]: 8 : if (atp%Orbit%iscore(ib)) then
11123 [ - + ]: 3 : icor=icor+1;if (icor>core_size) stop 'Bug (3) in xmlprtcore!'
11124 : 3 : call mkname(atp%Orbit%np(ib),char4)
11125 : 3 : char20=stripchar('"'//atp%Pot%sym//char4//char_orb(atp%Orbit%l(ib)+1)//'"')
11126 : : WRITE(unit_xml_core,'("<ae_core_wavefunction state=",a6," grid=""",a,i1,""">")') &
11127 : 3 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11128 [ - + + - : 9 : LIBPAW_ALLOCATE(dum,(mesh_data%meshsz(mesh_data%iwavmesh)))
+ - + - -
+ - + -
+ ]
11129 [ + + ]: 6006 : dum=zero
11130 : : dum(2:mesh_data%meshsz(mesh_data%iwavmesh))= &
11131 : : & atp%Orbit%wfn(2:mesh_data%meshsz(mesh_data%iwavmesh),ib) &
11132 [ + + ]: 6003 : & /atp%Grid%r(2:mesh_data%meshsz(mesh_data%iwavmesh))
11133 : 3 : call extrapolate(dum)
11134 : 3 : WRITE(unit_xml_core,'(3(1x,es23.16))') (dum(ir),ir=1,corewf_meshsz)
11135 [ - + ]: 3 : LIBPAW_DEALLOCATE(dum)
11136 : 3 : WRITE(unit_xml_core,'("</ae_core_wavefunction>")')
11137 : : end if ! if icore
11138 : : end do !ib
11139 : :
11140 : : !Write the core lwave functions
11141 [ - + ]: 1 : if(atp%diracrelativistic) then
11142 : 0 : icor=0
11143 [ # # ]: 0 : do ib=1,atp%Orbit%norbit
11144 [ # # ]: 0 : if (atp%Orbit%iscore(ib)) then
11145 [ # # ]: 0 : icor=icor+1;if (icor>core_size) stop ' Bug (4) in xmlprtcore!'
11146 : 0 : call mkname(atp%Orbit%np(ib),char4)
11147 : 0 : char20=stripchar('"'//atp%Pot%sym//char4//char_orb(atp%Orbit%l(ib)+1)//'"')
11148 : : WRITE(unit_xml_core,'("<ae_core_lwavefunction state=",a6," grid=""",a,i1,""">")') &
11149 : 0 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11150 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(mesh_data%meshsz(mesh_data%iwavmesh)))
# # # # #
# # # #
# ]
11151 [ # # ]: 0 : dum=zero
11152 : : dum(2:mesh_data%meshsz(mesh_data%iwavmesh))= &
11153 : : & atp%Orbit%lwfn(2:mesh_data%meshsz(mesh_data%iwavmesh),ib) &
11154 [ # # ]: 0 : & /atp%Grid%r(2:mesh_data%meshsz(mesh_data%iwavmesh))
11155 : 0 : call extrapolate(dum)
11156 : 0 : WRITE(unit_xml_core,'(3(1x,es23.16))') (dum(ir),ir=1,corewf_meshsz)
11157 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
11158 : 0 : WRITE(unit_xml_core,'("</ae_core_lwavefunction>")')
11159 : : end if ! if icore
11160 : : end do !ib
11161 : : end if ! diracrelativistic
11162 : :
11163 : : !Echi input file content
11164 : 1 : WRITE(unit_xml_core,'("<!-- Program: atompaw - input data follows: ")')
11165 : 1 : WRITE(unit_xml_core,'(a)') trim(input_string)
11166 : 1 : WRITE(unit_xml_core,'(a)') "XMLOUT"
11167 : 1 : WRITE(unit_xml_core,'(a)') "prtcorewf"
11168 : 1 : WRITE(unit_xml_core,'(a)') "END"
11169 : 1 : WRITE(unit_xml_core,'(" Program: atompaw - input end -->")')
11170 : 1 : WRITE(unit_xml_core,'("</paw_setup>")')
11171 : :
11172 : : !Close the file
11173 : 1 : close(unit_xml_core)
11174 : 1 : WRITE(STD_OUT,'(/,2x,a)') 'XML core orbitals file created.'
11175 : :
11176 [ - + ]: 1 : end subroutine xmlprtcore
11177 : :
11178 : :
11179 : : !!=================================================================
11180 : : !! NAME
11181 : : !! build_mesh_data
11182 : : !!
11183 : : !! FUNCTION
11184 : : !! Determine meshes definitions
11185 : : !! (if necessary define a logarithmic radial grid)
11186 : : !!
11187 : : !! INPUTS
11188 : : !! Grid=grid datastructure in AtomPAW format
11189 : : !! irc=index of rc in Grid
11190 : : !!
11191 : : !! OUTPUT
11192 : : !! mesh_data
11193 : : !! Data defining various meshes
11194 : : !!
11195 : : !! PARENTS
11196 : : !!
11197 : : !!=================================================================
11198 : :
11199 [ - + - + : 1 : subroutine build_mesh_data(mesh_data,Grid,irc,ivion,ivale,coretailpoints,itau)
- + - + ]
11200 : :
11201 : : type(mesh_data_type),intent(out) :: mesh_data
11202 : : type(GridInfo),intent(in) :: Grid
11203 : : integer, optional, intent(in) :: irc,ivion,ivale,coretailpoints,itau
11204 : :
11205 : : !------------------------------------------------------------------
11206 : : !---- Local variables
11207 : : !------------------------------------------------------------------
11208 : :
11209 : : integer, parameter :: nmesh_max=10
11210 : : integer :: ii1
11211 : : logical :: aeonly=.true.
11212 : :
11213 : : !------------------------------------------------------------------
11214 : : !---- Executable code
11215 : : !------------------------------------------------------------------
11216 : :
11217 [ - + ]: 1 : LIBPAW_ALLOCATE(mesh_data%meshtp,(nmesh_max))
11218 [ - + ]: 1 : LIBPAW_ALLOCATE(mesh_data%meshsz,(nmesh_max))
11219 [ - + ]: 1 : LIBPAW_ALLOCATE(mesh_data%radstp,(nmesh_max))
11220 [ - + ]: 1 : LIBPAW_ALLOCATE(mesh_data%logstp,(nmesh_max))
11221 : :
11222 : : !Mesh definition
11223 [ + - ]: 1 : if (Grid%type==loggrid) then
11224 : 1 : mesh_data%mesh_type=2
11225 : 1 : mesh_data%rad_step=Grid%drdu(1)
11226 : 1 : mesh_data%log_step=Grid%h
11227 : : else
11228 : 0 : mesh_data%mesh_type=1
11229 : 0 : mesh_data%rad_step=Grid%h
11230 : 0 : mesh_data%log_step=zero
11231 : : end if
11232 : :
11233 [ + - + - : 1 : if (PRESENT(irc).and.PRESENT(ivion).and.PRESENT(ivale).and.PRESENT(coretailpoints).and.PRESENT(itau)) then
+ - ]
11234 : 1 : aeonly=.false.
11235 : : endif
11236 : :
11237 : : !Various mesh sizes
11238 [ + - ]: 1 : if (Grid%type==loggrid) then
11239 : 1 : mesh_data%wav_meshsz=Grid%n
11240 [ + - ]: 1 : if (.not.aeonly) then
11241 : 1 : mesh_data%sph_meshsz=min(1+nint(log(one+Grid%r(irc)/mesh_data%rad_step)/mesh_data%log_step),mesh_data%wav_meshsz)
11242 : : else
11243 : 0 : mesh_data%sph_meshsz=Grid%n
11244 : : endif
11245 : : else
11246 [ # # ]: 0 : if (.not.aeonly) then
11247 : 0 : mesh_data%wav_meshsz=irc+Grid%ishift
11248 : 0 : mesh_data%sph_meshsz=min(1+nint(Grid%r(irc)/mesh_data%rad_step),mesh_data%wav_meshsz)
11249 : : else
11250 : 0 : mesh_data%wav_meshsz=Grid%n
11251 : 0 : mesh_data%sph_meshsz=Grid%n
11252 : : endif
11253 : : endif
11254 : 1 : mesh_data%prj_meshsz=mesh_data%sph_meshsz ! To be modified by RSO
11255 : :
11256 [ + - ]: 1 : if (.not.aeonly) then
11257 : 1 : mesh_data%core_meshsz=coretailpoints
11258 : 1 : mesh_data%vale_meshsz=ivale
11259 : 1 : mesh_data%tau_meshsz=itau
11260 : 1 : mesh_data%vion_meshsz=ivion
11261 : : else
11262 : 0 : mesh_data%core_meshsz=Grid%n
11263 : 0 : mesh_data%vale_meshsz=Grid%n
11264 : 0 : mesh_data%tau_meshsz=Grid%n
11265 : 0 : mesh_data%vion_meshsz=Grid%n
11266 : : endif
11267 : :
11268 [ + - ]: 1 : if (mesh_data%vion_meshsz<=0) then
11269 [ - + ]: 1 : if (mesh_data%mesh_type==1) then
11270 : 0 : ii1=int(one+rmax_vloc/mesh_data%rad_step)
11271 : : else
11272 : 1 : ii1=int(log(one+rmax_vloc/mesh_data%rad_step)/mesh_data%log_step)+1
11273 : : endif
11274 : 1 : mesh_data%vion_meshsz=max(mesh_data%sph_meshsz,mesh_data%core_meshsz,ii1)
11275 : : endif
11276 : :
11277 : 1 : mesh_data%vlda12_meshsz=max(mesh_data%vale_meshsz,mesh_data%vion_meshsz)
11278 : :
11279 : : !Mesh for vbare should be inside augmentation region
11280 : : !For compatibility with other codes, could put it to the same mesh
11281 : : !as ionic potential
11282 : : !mesh_data%vbare_meshsz=mesh_data%vion_meshsz
11283 : 1 : mesh_data%vbare_meshsz=mesh_data%sph_meshsz
11284 : :
11285 : 1 : mesh_data%prj_msz_max=four*mesh_data%sph_meshsz
11286 : :
11287 : : !=== Build mesh definitions ===
11288 : :
11289 [ + + + + ]: 21 : mesh_data%meshtp=-1;mesh_data%meshsz=0
11290 [ + + + + ]: 21 : mesh_data%radstp=zero;mesh_data%logstp=zero
11291 : :
11292 : : !Partial waves
11293 : 1 : mesh_data%nmesh=1
11294 : 1 : mesh_data%iwavmesh=1
11295 : 1 : mesh_data%meshtp(1)=mesh_data%mesh_type
11296 : 1 : mesh_data%meshsz(1)=mesh_data%wav_meshsz
11297 : 1 : mesh_data%radstp(1)=mesh_data%rad_step
11298 : 1 : mesh_data%logstp(1)=mesh_data%log_step
11299 : : !Projectors
11300 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%prj_meshsz) then
11301 : 1 : mesh_data%nmesh=mesh_data%nmesh+1
11302 : 1 : mesh_data%iprjmesh=mesh_data%nmesh
11303 : 1 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11304 : 1 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%prj_meshsz
11305 : 1 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11306 : 1 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11307 : : else
11308 : 0 : mesh_data%iprjmesh=mesh_data%iwavmesh
11309 : : endif
11310 : : !Core density
11311 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%core_meshsz) then
11312 [ + - ]: 1 : if (mesh_data%prj_meshsz/=mesh_data%core_meshsz) then
11313 : 1 : mesh_data%nmesh=mesh_data%nmesh+1
11314 : 1 : mesh_data%icoremesh=mesh_data%nmesh
11315 : 1 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11316 : 1 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%core_meshsz
11317 : 1 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11318 : 1 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11319 : : else
11320 : 0 : mesh_data%icoremesh=mesh_data%iprjmesh
11321 : : endif
11322 : : else
11323 : 0 : mesh_data%icoremesh=mesh_data%iwavmesh
11324 : : endif
11325 : : !Local ionic potential
11326 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%vion_meshsz) then
11327 [ + - ]: 1 : if(mesh_data%prj_meshsz/=mesh_data%vion_meshsz) then
11328 [ + - ]: 1 : if(mesh_data%core_meshsz/=mesh_data%vion_meshsz) then
11329 : 1 : mesh_data%nmesh=mesh_data%nmesh+1
11330 : 1 : mesh_data%ivionmesh=mesh_data%nmesh
11331 : 1 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11332 : 1 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vion_meshsz
11333 : 1 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11334 : 1 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11335 : : else
11336 : 0 : mesh_data%ivionmesh=mesh_data%icoremesh
11337 : : endif
11338 : : else
11339 : 0 : mesh_data%ivionmesh=mesh_data%iprjmesh
11340 : : endif
11341 : : else
11342 : 0 : mesh_data%ivionmesh=mesh_data%iwavmesh
11343 : : endif
11344 : : !Local vbare potential
11345 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%vbare_meshsz) then
11346 : : if(mesh_data%prj_meshsz/=mesh_data%vbare_meshsz) then
11347 : : if(mesh_data%core_meshsz/=mesh_data%vbare_meshsz) then
11348 : : if(mesh_data%vion_meshsz/=mesh_data%vbare_meshsz) then
11349 : : mesh_data%nmesh=mesh_data%nmesh+1
11350 : : mesh_data%ivbaremesh=mesh_data%nmesh
11351 : : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11352 : : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vbare_meshsz
11353 : : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11354 : : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11355 : : else
11356 : : mesh_data%ivbaremesh=mesh_data%ivionmesh
11357 : : endif
11358 : : else
11359 : : mesh_data%ivbaremesh=mesh_data%icoremesh
11360 : : endif
11361 : : else
11362 : 1 : mesh_data%ivbaremesh=mesh_data%iprjmesh
11363 : : endif
11364 : : else
11365 : 0 : mesh_data%ivbaremesh=mesh_data%iwavmesh
11366 : : endif
11367 : : !Valence density
11368 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%vale_meshsz) then
11369 [ + - ]: 1 : if(mesh_data%prj_meshsz/=mesh_data%vale_meshsz) then
11370 [ - + ]: 1 : if(mesh_data%core_meshsz/=mesh_data%vale_meshsz) then
11371 [ # # ]: 0 : if(mesh_data%vion_meshsz/=mesh_data%vale_meshsz) then
11372 : : if(mesh_data%vbare_meshsz/=mesh_data%vale_meshsz) then
11373 : 0 : mesh_data%nmesh=mesh_data%nmesh+1
11374 : 0 : mesh_data%ivalemesh=mesh_data%nmesh
11375 : 0 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11376 : 0 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vale_meshsz
11377 : 0 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11378 : 0 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11379 : : else
11380 : : mesh_data%ivalemesh=mesh_data%ivbaremesh
11381 : : endif
11382 : : else
11383 : 0 : mesh_data%ivalemesh=mesh_data%ivionmesh
11384 : : endif
11385 : : else
11386 : 1 : mesh_data%ivalemesh=mesh_data%icoremesh
11387 : : endif
11388 : : else
11389 : 0 : mesh_data%ivalemesh=mesh_data%iprjmesh
11390 : : endif
11391 : : else
11392 : 0 : mesh_data%ivalemesh=mesh_data%iwavmesh
11393 : : endif
11394 : : !Kinetic energy density
11395 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%tau_meshsz) then
11396 [ + - ]: 1 : if(mesh_data%prj_meshsz/=mesh_data%tau_meshsz) then
11397 [ - + ]: 1 : if(mesh_data%core_meshsz/=mesh_data%tau_meshsz) then
11398 [ # # ]: 0 : if(mesh_data%vion_meshsz/=mesh_data%tau_meshsz) then
11399 : : if(mesh_data%vbare_meshsz/=mesh_data%tau_meshsz) then
11400 [ # # ]: 0 : if(mesh_data%vale_meshsz/=mesh_data%tau_meshsz) then
11401 : 0 : mesh_data%nmesh=mesh_data%nmesh+1
11402 : 0 : mesh_data%itaumesh=mesh_data%nmesh
11403 : 0 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11404 : 0 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%tau_meshsz
11405 : 0 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11406 : 0 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11407 : : else
11408 : 0 : mesh_data%itaumesh=mesh_data%ivalemesh
11409 : : endif
11410 : : else
11411 : : mesh_data%itaumesh=mesh_data%ivbaremesh
11412 : : endif
11413 : : else
11414 : 0 : mesh_data%itaumesh=mesh_data%ivionmesh
11415 : : endif
11416 : : else
11417 : 1 : mesh_data%itaumesh=mesh_data%icoremesh
11418 : : endif
11419 : : else
11420 : 0 : mesh_data%itaumesh=mesh_data%iprjmesh
11421 : : endif
11422 : : else
11423 : 0 : mesh_data%itaumesh=mesh_data%iwavmesh
11424 : : endif
11425 : : !LDA-1/2 potential
11426 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%vlda12_meshsz) then
11427 [ + - ]: 1 : if(mesh_data%prj_meshsz/=mesh_data%vlda12_meshsz) then
11428 [ + - ]: 1 : if(mesh_data%core_meshsz/=mesh_data%vlda12_meshsz) then
11429 [ - + ]: 1 : if(mesh_data%vion_meshsz/=mesh_data%vlda12_meshsz) then
11430 : : if(mesh_data%vbare_meshsz/=mesh_data%vlda12_meshsz) then
11431 : : if(mesh_data%vale_meshsz/=mesh_data%vlda12_meshsz) then
11432 : : if(mesh_data%tau_meshsz/=mesh_data%vlda12_meshsz) then
11433 : : mesh_data%nmesh=mesh_data%nmesh+1
11434 : : mesh_data%ivlda12mesh=mesh_data%nmesh
11435 : : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11436 : : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vlda12_meshsz
11437 : : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11438 : : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11439 : : else
11440 : : mesh_data%ivlda12mesh=mesh_data%itaumesh
11441 : : endif
11442 : : else
11443 : 0 : mesh_data%ivlda12mesh=mesh_data%ivalemesh
11444 : : endif
11445 : : else
11446 : : mesh_data%ivlda12mesh=mesh_data%ivbaremesh
11447 : : endif
11448 : : else
11449 : 1 : mesh_data%ivlda12mesh=mesh_data%ivionmesh
11450 : : endif
11451 : : else
11452 : 0 : mesh_data%ivlda12mesh=mesh_data%icoremesh
11453 : : endif
11454 : : else
11455 : 0 : mesh_data%ivlda12mesh=mesh_data%iprjmesh
11456 : : endif
11457 : : else
11458 : 0 : mesh_data%ivlda12mesh=mesh_data%iwavmesh
11459 : : endif
11460 : :
11461 : 1 : end subroutine build_mesh_data
11462 : :
11463 : :
11464 : 1 : subroutine destroy_mesh_data(mesh_data)
11465 : :
11466 : : type(mesh_data_type),intent(inout) :: mesh_data
11467 : :
11468 : : !------------------------------------------------------------------
11469 : : !---- Executable code
11470 : : !------------------------------------------------------------------
11471 : :
11472 [ + - ]: 1 : if (allocated(mesh_data%meshtp)) then
11473 : 1 : LIBPAW_DEALLOCATE(mesh_data%meshtp)
11474 : : endif
11475 [ + - ]: 1 : if (allocated(mesh_data%meshsz)) then
11476 : 1 : LIBPAW_DEALLOCATE(mesh_data%meshsz)
11477 : : endif
11478 [ + - ]: 1 : if (allocated(mesh_data%radstp)) then
11479 : 1 : LIBPAW_DEALLOCATE(mesh_data%radstp)
11480 : : endif
11481 [ + - ]: 1 : if (allocated(mesh_data%logstp)) then
11482 : 1 : LIBPAW_DEALLOCATE(mesh_data%logstp)
11483 : : endif
11484 : :
11485 : 1 : end subroutine destroy_mesh_data
11486 : :
11487 : :
11488 : :
11489 : : !!=================================================================
11490 : : !! NAME
11491 : : !! xmloutput
11492 : : !!
11493 : : !! FUNCTION
11494 : : !! Write the PAW data file in XML format
11495 : : !!
11496 : : !! INPUTS
11497 : : !! fname=file name (with .xml suffixe)
11498 : : !! Grid= Grid datastructure from atompaw
11499 : : !! AESCF= AESCF datastructure from atompaw
11500 : : !! AEPOT= AEPOT datastructure from atompaw
11501 : : !! PAW= PAW datastructure from atompaw
11502 : : !! ORB= ORB datastructure from atompaw
11503 : : !! mesh_data= datatructure containing the definition of
11504 : : !! all the radial meshes used in the XML file
11505 : : !! tproj(prj_msz_max,nbase)= PAW projectors
11506 : : !! (might be modified by real space optimization)
11507 : : !! vlocopt= option for local potential (1=Blochl, 2=Kresse)
11508 : : !! input_string= string containing a copy of atompaw input file
11509 : : !! author= string containing the author(s) name
11510 : : !! comment= additional comment line to be printed in the header (usually table
11511 : : !version)
11512 : : !! nsplgrid=if >0, size of a (reduced) grid on which interpolate all data in XML
11513 : : !file
11514 : : !! pawlda12
11515 : : !! %uselda12=TRUE if LDA-1/2 potential calculation is required
11516 : : !! %rcut=LDA-1/2 parameter: cut-off radius (in bohr)
11517 : : !! %pot(:)=LDA-1/2 parameter: local potential used to apply LDA-1/2 method
11518 : : !!
11519 : : !! PARENTS
11520 : : !! atompaw2xml
11521 : : !!
11522 : : !! CHILDREN
11523 : : !!
11524 : : !!=================================================================
11525 [ # # ]: 0 : subroutine xmloutput(fname,Grid,AESCF,AEPot,Orb,PAW,mesh_data,tproj,&
11526 : : & vlocopt,input_string,author,comment,nsplgrid,zcore,atp)
11527 : : integer,intent(in) :: vlocopt,nsplgrid
11528 : : character(len=*),intent(in) :: input_string,author,comment,fname
11529 : : real(dp), intent(in) :: zcore
11530 : : TYPE(Gridinfo),intent(in) :: Grid
11531 : : TYPE (SCFInfo),intent(in) :: AESCF
11532 : : TYPE(Potentialinfo),intent(in) :: AEPot
11533 : : TYPE (OrbitInfo),intent(in) :: Orb
11534 : : TYPE(Pseudoinfo),intent(in) :: PAW
11535 : : type(atompaw_type),intent(in) :: atp
11536 : : ! TYPE(pawlda12_type),intent(in) :: pawlda12
11537 : : TYPE(mesh_data_type),intent(inout) :: mesh_data
11538 : : real(dp),intent(in) :: tproj(:,:)
11539 : : !------------------------------------------------------------------
11540 : : !---- Local variables
11541 : : !------------------------------------------------------------------
11542 : : real(dp), parameter :: tol_zero=1.d-50 ! Threshold below which quantities are zero
11543 : : integer :: ib,ic,ii,n,n_aux,ir,irc_aux,meshsz,meshsz_aux,meshst_aux,nmesh
11544 : 0 : integer :: mesh_start(mesh_data%nmesh),mesh_size(mesh_data%nmesh)
11545 : : integer :: unit_xml=1234
11546 : : logical :: extra1
11547 : : character(len=4) :: char4
11548 : : character(len=5) :: char5a,char5b,xc_type
11549 : : character(len=20) :: char20
11550 : : character(len=132) :: xc_name,xcname_short,code_name
11551 : : real(dp) :: sqr4pi,radstp0,logstp0,radstp_spl,logstp_spl
11552 : 0 : character(len=3) :: gridt(mesh_data%nmesh)
11553 : 0 : real(dp),allocatable :: dum(:),dum_aux(:),rad_aux(:),dudr(:)
11554 : 0 : real(dp),allocatable :: phi_aux(:,:),tphi_aux(:,:),proj_aux(:,:)
11555 : : TYPE(Gridinfo) :: Grid1
11556 : : !------------------------------------------------------------------
11557 : : !---- Executable code
11558 : : !------------------------------------------------------------------
11559 : : !Some defs
11560 : 0 : sqr4pi=sqrt(4*pi)
11561 : 0 : n=Grid%n
11562 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(n))
# # # # #
# ]
11563 : 0 : extra1=.false.
11564 : :
11565 : : !In a change of grid has been requested, determine new grid data
11566 : 0 : radstp_spl=-1.d0 ; logstp_spl=-1.d0
11567 [ # # ]: 0 : if (nsplgrid>0) then
11568 : 0 : write(std_out,'(/,2x,a,/,2x,a,i5,a)') 'Atompaw2XML info:',&
11569 : 0 : & ' All quantities will be interpolated on a ',nsplgrid,'-point log. grid.'
11570 : 0 : n_aux=nsplgrid
11571 : 0 : logstp_spl=0.02d0
11572 : 0 : call findh(AEPot%zz,Grid%r(mesh_data%meshsz(1)-1),nsplgrid,logstp_spl,radstp_spl)
11573 : 0 : irc_aux=int(tol8+log(1.d0+PAW%rc/radstp_spl)/logstp_spl)+1
11574 : 0 : radstp_spl= PAW%rc/(exp(logstp_spl*(irc_aux-1))-1.d0)
11575 : 0 : extra1=(Grid%r(mesh_data%meshsz(1))<radstp_spl*(exp(logstp_spl*(nsplgrid-1))-1.d0))
11576 [ # # ]: 0 : if (extra1) then
11577 : 0 : n_aux=n_aux+1
11578 : 0 : logstp_spl=0.02d0
11579 : 0 : call findh(AEPot%zz,Grid%r(mesh_data%meshsz(1)-1),nsplgrid+1,logstp_spl,radstp_spl)
11580 : 0 : irc_aux=int(tol8+log(1.d0+PAW%rc/radstp_spl)/logstp_spl)+1
11581 : 0 : radstp_spl= PAW%rc/(exp(logstp_spl*(irc_aux-1))-1.d0)
11582 : : end if
11583 [ # # # # : 0 : LIBPAW_ALLOCATE(rad_aux,(n_aux))
# # # # #
# ]
11584 [ # # # # : 0 : LIBPAW_ALLOCATE(dum_aux,(n_aux))
# # # # ]
11585 : 0 : call InitGrid(Grid1,logstp_spl,Grid%range,r0=radstp_spl,do_not_print=.true.)
11586 [ # # ]: 0 : rad_aux(1:nsplgrid)=Grid1%r(1:nsplgrid)
11587 : : else
11588 [ # # # # : 0 : LIBPAW_ALLOCATE(rad_aux,(n))
# # # # ]
11589 [ # # # # : 0 : LIBPAW_ALLOCATE(dum_aux,(n))
# # # # ]
11590 [ # # ]: 0 : rad_aux(1:n)=Grid%r(1:n)
11591 : 0 : irc_aux=PAW%irc
11592 : : end if
11593 : :
11594 : : !Open file for writing
11595 : 0 : OPEN(unit_xml,file=TRIM(fname),form='formatted')
11596 : :
11597 : : !Write XML header
11598 : 0 : WRITE(unit_xml,'("<?xml version=""1.0""?>")')
11599 : 0 : WRITE(unit_xml,'("<paw_dataset version=""0.7"">")')
11600 : 0 : WRITE(unit_xml,'("<!-- PAW-XML specification: http://esl.cecam.org/Paw-xml-->")')
11601 : :
11602 : : !Write title
11603 [ # # ]: 0 : WRITE(unit_xml,'(/,"<!-- PAW atomic dataset for ",a," -->")')trim(ADJUSTL(AEPot%sym))
11604 : :
11605 : : !Write additional comment line (usually table version)
11606 [ # # ]: 0 : if (trim(comment)/="") WRITE(unit_xml,'("<!-- ",a," -->")') trim(comment)
11607 : :
11608 : : !Write Atompaw information
11609 : 0 : WRITE(unit_xml,'(/,"<!-- ",a)')
11610 : 0 : WRITE(unit_xml,'(" Energy units=Hartree, length units=bohr")')
11611 [ # # ]: 0 : if (trim(author)/="") WRITE(unit_xml,'(a,a)') ' by ',trim(author)
11612 : 0 : WRITE(unit_xml,'(" The input file is available at the end of this file")')
11613 : 0 : WRITE(unit_xml,'("-->",/)')
11614 : :
11615 : : !Write atom definition
11616 : 0 : WRITE(unit=char5a,fmt='(f5.2)') AEPot%zz
11617 : : WRITE(unit_xml,'("<atom symbol=""",a,""" Z=""",a)',ADVANCE='NO') &
11618 [ # # # # ]: 0 : & trim(ADJUSTL(AEPot%sym)),trim(ADJUSTL(char5a))
11619 : 0 : WRITE(unit=char5a,fmt='(f5.2)') zcore
11620 : 0 : WRITE(unit=char5b,fmt='(f5.2)') AEPot%nz-zcore
11621 : : WRITE(unit_xml,'(""" core=""",a,""" valence=""",a,"""/>")') &
11622 [ # # # # ]: 0 : & trim(ADJUSTL(char5a)),trim(ADJUSTL(char5b))
11623 : :
11624 : : !Write XC definition
11625 : 0 : call get_xc_data(atp,xc_type,xc_name)
11626 [ # # ]: 0 : if (atp%itype==LIBXC.and.xc_type/="UNKNOWN") then
11627 : 0 : xcname_short= libxc_functionals_fullname(atp%xc_functionals)
11628 : 0 : call uppercase(xcname_short)
11629 : 0 : call get_xc_alias(xcname_short,xc_name)
11630 : : endif
11631 : : WRITE(unit_xml,'("<xc_functional type=""",a,""" name=""",a,"""/>")') &
11632 : 0 : & TRIM(xc_type),TRIM(xc_name)
11633 : 0 : code_name="rcpaw"
11634 : :
11635 : : !Generator data
11636 [ # # ]: 0 : if (atp%scalarrelativistic) then
11637 : : WRITE(unit_xml,'("<generator type=""scalar-relativistic"" name=""",a,""" orthogonalisation=""", a,"""/>")')&
11638 : 0 : & TRIM(code_name),"marsman"
11639 : : ! else if (diracrelativistic) then
11640 : : ! WRITE(unit_xml,'("<generator type=""dirac-relativistic"" name=""",a,""" orthogonalisation=""", a,"""/>")')&
11641 : : !& TRIM(code_name),trim(PAW%orthogonalization_scheme)
11642 : : else
11643 : : WRITE(unit_xml,'("<generator type=""non-relativistic"" name=""",a,""" orthogonalisation=""", a,"""/>")')&
11644 : 0 : & TRIM(code_name),"marsman"
11645 : : endif
11646 : :
11647 : : !Energies
11648 : : WRITE(unit_xml,'("<ae_energy kinetic=""",1pe25.17,""" xc=""",1pe25.17,"""")') &
11649 : 0 : & AESCF%ekin/2,AESCF%eexc/2
11650 : : WRITE(unit_xml,'(" electrostatic=""",1pe25.17,""" total=""",1pe25.17,"""/>")')&
11651 : 0 : & AESCF%estatic/2,AESCF%etot/2
11652 : 0 : WRITE(unit_xml,'("<core_energy kinetic=""",1pe25.17,"""/>")') AESCF%corekin*0.5d0
11653 : :
11654 : : !PAW radius
11655 : 0 : WRITE(unit_xml,'("<paw_radius rc=""",f17.14,"""/>")') match_on_splgrid(PAW%rc)
11656 : :
11657 : : !Electronic configuration
11658 : 0 : WRITE(unit_xml,'("<valence_states>")')
11659 [ # # ]: 0 : do ib=1,PAW%nbase
11660 : 0 : call mkname(ib,char4)
11661 : 0 : char20=stripchar('"'//AEPot%sym//char4//'"')
11662 : 0 : ii=min(ABS(PAW%np(ib)),100)
11663 [ # # ]: 0 : if (ii<100) then
11664 : : ! if(diracrelativistic) then
11665 : : ! WRITE(unit_xml,'(" <state n=""",i2,""" l=""",i1,""" kappa=""",i2,""" f=""",1pe14.7)',ADVANCE='NO')&
11666 : : !& ii,PAW%l(ib),PAW%kappa(ib),Orb%occ(ib)
11667 : : ! else
11668 : : WRITE(unit_xml,'(" <state n=""",i2,""" l=""",i1,""" f=""",1pe14.7)',ADVANCE='NO')&
11669 : 0 : & ii,PAW%l(ib),PAW%occ(ib)
11670 : : ! end if
11671 : : WRITE(unit_xml,'(""" rc=""",f13.10,""" e=""",1pe14.7,""" id=",a6,"/>")')&
11672 : 0 : & match_on_splgrid(PAW%rcio(ib)),PAW%eig(ib)*0.5d0,TRIM(char20)
11673 : : else
11674 : : ! if(diracrelativistic) then
11675 : : ! WRITE(unit_xml,'(" <state l=""",i1,""" kappa=""",i2)',ADVANCE='NO')PAW%l(ib),PAW%kappa(ib)
11676 : : ! else
11677 : 0 : WRITE(unit_xml,'(" <state l=""",i1)',ADVANCE='NO') PAW%l(ib)
11678 : : ! end if
11679 : : WRITE(unit_xml,'(""" rc=""",f13.10,""" e=""",1pe14.7,""" id=",a6,"/>")')&
11680 : 0 : & match_on_splgrid(PAW%rcio(ib)),PAW%eig(ib)*0.5d0,TRIM(char20)
11681 : : end if
11682 : : enddo
11683 : 0 : WRITE(unit_xml,'("</valence_states>")')
11684 : :
11685 : : !Radial meshes definitions
11686 : 0 : nmesh=mesh_data%nmesh
11687 [ # # # # : 0 : if(maxval(mesh_data%meshtp(1:mesh_data%nmesh))==minval(mesh_data%meshtp(1:mesh_data%nmesh)))then
# # ]
11688 [ # # # # ]: 0 : mesh_data%meshsz(1:mesh_data%nmesh)=maxval(mesh_data%meshsz(1:mesh_data%nmesh))
11689 : 0 : nmesh=1
11690 : 0 : mesh_data%icoremesh=1
11691 : 0 : mesh_data%itaumesh=1
11692 : 0 : mesh_data%iprjmesh=1
11693 : 0 : mesh_data%iwavmesh=1
11694 : 0 : mesh_data%ivionmesh=1
11695 : 0 : mesh_data%ivalemesh=1
11696 : 0 : mesh_data%ivbaremesh=1
11697 : 0 : mesh_data%ivlda12mesh=1
11698 : : endif
11699 [ # # # # ]: 0 : if (nmesh>1.and.nsplgrid>0) stop ' Bug (1) in xmlinterface: nmesh>1 and nsplgrid>0!'
11700 : :
11701 [ # # ]: 0 : do ii=1,nmesh
11702 [ # # # # : 0 : LIBPAW_ALLOCATE(dudr,(mesh_data%meshsz(ii)))
# # # # #
# # # ]
11703 : 0 : select case(mesh_data%meshtp(ii))
11704 : : case(1)
11705 : 0 : char20='r=d*i'
11706 : 0 : gridt(ii)="lin"
11707 : 0 : mesh_start(ii)=1
11708 : 0 : mesh_size(ii)=mesh_data%meshsz(ii)
11709 : 0 : radstp0=zero
11710 : 0 : logstp0=mesh_data%radstp(ii)
11711 [ # # ]: 0 : dudr(1:mesh_data%meshsz(ii))=logstp0
11712 : :
11713 : : case(2)
11714 : 0 : char20='r=a*(exp(d*i)-1)'
11715 : 0 : gridt(ii)="log"
11716 : 0 : mesh_start(ii)=1
11717 [ # # ]: 0 : if (nsplgrid<=0) then
11718 : 0 : mesh_size(ii)=mesh_data%meshsz(ii)
11719 : 0 : radstp0=mesh_data%radstp(ii)
11720 : 0 : logstp0=mesh_data%logstp(ii)
11721 : : else
11722 : 0 : mesh_size(ii)=nsplgrid
11723 : 0 : radstp0=radstp_spl
11724 : 0 : logstp0=logstp_spl
11725 : : end if
11726 [ # # ]: 0 : dudr(1:mesh_size(ii))=logstp0*(radstp0+rad_aux(1:mesh_size(ii)))
11727 : :
11728 : : case default
11729 [ # # # ]: 0 : stop ' Bug (2) in xmlinterface: mesh type not implemented in Atompaw!'
11730 : : end select
11731 : :
11732 : 0 : WRITE(unit_xml,'("<radial_grid eq=""",a,""" a=""",es23.16)',ADVANCE='NO')trim(char20),radstp0
11733 : 0 : WRITE(unit_xml,'(""" d=""",es23.16,""" istart=""0"" iend=""",i5)',ADVANCE='NO')logstp0,mesh_size(ii)-mesh_start(ii)
11734 : 0 : WRITE(unit_xml,'(""" id=""",a,i1,""">")') gridt(ii),ii
11735 : 0 : WRITE(unit_xml,'(" <values>")')
11736 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (rad_aux(ir),ir=mesh_start(ii),mesh_size(ii))
11737 : 0 : WRITE(unit_xml,'(" </values>")')
11738 : 0 : WRITE(unit_xml,'(" <derivatives>")')
11739 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dudr(ir),ir=mesh_start(ii),mesh_size(ii))
11740 : 0 : WRITE(unit_xml,'(" </derivatives>")')
11741 : 0 : WRITE(unit_xml,'("</radial_grid>")')
11742 [ # # ]: 0 : LIBPAW_DEALLOCATE(dudr)
11743 : :
11744 : : end do
11745 : :
11746 : : !Compensation charge shape function
11747 [ # # ]: 0 : if (atp%gaussianshapefunction) then
11748 : 0 : WRITE(unit_xml,'("<shape_function type=""gauss"" rc=""",f19.16,"""/>")')match_on_splgrid(PAW%gausslength)
11749 [ # # ]: 0 : else if (atp%besselshapefunction) then
11750 : 0 : WRITE(unit_xml,'("<shape_function type=""bessel"" rc=""",f19.16,"""/>")')match_on_splgrid(PAW%rc_shap)
11751 : : else
11752 : 0 : WRITE(unit_xml,'("<shape_function type=""sinc"" rc=""",f19.16,"""/>")')match_on_splgrid(PAW%rc_shap)
11753 : : endif
11754 : :
11755 : : !Core densities
11756 : 0 : meshsz=mesh_data%meshsz(mesh_data%icoremesh)
11757 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%icoremesh),extra1)
11758 : 0 : meshst_aux=mesh_start(mesh_data%icoremesh)
11759 [ # # ]: 0 : dum(2:meshsz)=sqr4pi*Orb%coreden(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11760 : 0 : call extrapolate(dum(1:meshsz))
11761 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11762 : : WRITE(unit_xml,'("<ae_core_density grid=""",a,i1,""">")') &
11763 : 0 : & gridt(mesh_data%icoremesh),mesh_data%icoremesh
11764 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11765 : 0 : WRITE(unit_xml,'("</ae_core_density>")')
11766 [ # # ]: 0 : dum(2:meshsz)=sqr4pi*PAW%tcore(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11767 : 0 : call extrapolate(dum(1:meshsz))
11768 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11769 : : WRITE(unit_xml,'("<pseudo_core_density grid=""",a,i1,""" rc=""",f19.16,""">")')&
11770 : 0 : & gridt(mesh_data%icoremesh),mesh_data%icoremesh,match_on_splgrid(PAW%rc_core)
11771 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11772 : 0 : WRITE(unit_xml,'("</pseudo_core_density>")')
11773 : :
11774 : : !!Kinetic energy core densities
11775 : : !!Available in scalar relativistic (although approximate)
11776 : : ! if (.true.) then
11777 : : ! meshsz=mesh_data%meshsz(mesh_data%itaumesh)
11778 : : ! meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%itaumesh),extra1)
11779 : : ! meshst_aux=mesh_start(mesh_data%itaumesh)
11780 : : ! dum(2:meshsz)= half*sqr4pi*FC%coretau(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11781 : : ! call extrapolate(Grid,dum(1:meshsz))
11782 : : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11783 : : ! WRITE(unit_xml,'("<ae_core_kinetic_energy_density grid=""",a,i1,""" rc=""",f19.16,""">")') &
11784 : : !& gridt(mesh_data%itaumesh),mesh_data%itaumesh,match_on_splgrid(PAW%rc_core)
11785 : : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11786 : : ! WRITE(unit_xml,'("</ae_core_kinetic_energy_density>")')
11787 : : ! dum(2:meshsz)= half*sqr4pi*PAW%tcoretau(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11788 : : ! call extrapolate(Grid,dum(1:meshsz))
11789 : : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11790 : : ! WRITE(unit_xml,'("<pseudo_core_kinetic_energy_density grid=""",a,i1,""" rc=""",f19.16,""">")') &
11791 : : !& gridt(mesh_data%itaumesh),mesh_data%itaumesh,match_on_splgrid(PAW%rc_core)
11792 : : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11793 : : ! WRITE(unit_xml,'("</pseudo_core_kinetic_energy_density>")')
11794 : : ! else
11795 : : ! write(std_out,'(5(/,2x,a))') 'Atompaw2XML WARNING!!!!!',&
11796 : : !& ' Kinetic energy core density is not available',&
11797 : : !& ' within scalar relativistic scheme!',&
11798 : : !& ' Will not be present in the XML dataset.',&
11799 : : !& ' This is temporary, sorry!'
11800 : : ! end if
11801 : :
11802 : : !!Valence density
11803 : : ! meshsz=mesh_data%meshsz(mesh_data%ivalemesh)
11804 : : ! meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivalemesh),extra1)
11805 : : ! meshst_aux=mesh_start(mesh_data%ivalemesh)
11806 : : ! dum(2:meshsz)=sqr4pi*PAW%tden(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11807 : : ! call extrapolate(dum(1:meshsz))
11808 : : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11809 : : ! rad=maxval(PAW%rcio(1:PAW%nbase))
11810 : : ! WRITE(unit_xml,'("<pseudo_valence_density grid=""",a,i1,""" rc=""",f19.16,""">")') &
11811 : : !& gridt(mesh_data%ivalemesh),mesh_data%ivalemesh,match_on_splgrid(rad)
11812 : : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11813 : : ! WRITE(unit_xml,'("</pseudo_valence_density>")')
11814 : :
11815 : : !Vbare potential
11816 : 0 : meshsz=mesh_data%meshsz(mesh_data%ivbaremesh)
11817 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivbaremesh),extra1)
11818 : 0 : meshst_aux=mesh_start(mesh_data%ivbaremesh)
11819 [ # # ]: 0 : dum(1:meshsz)=sqr4pi*half*PAW%vloc(1:meshsz)
11820 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11821 [ # # ]: 0 : dum_aux(irc_aux:meshsz_aux)=0.d0 ! Vbare has to be zero at rc
11822 : : WRITE(unit_xml,'("<zero_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11823 : 0 : & gridt(mesh_data%ivbaremesh),mesh_data%ivbaremesh,match_on_splgrid(PAW%rc)
11824 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11825 : 0 : WRITE(unit_xml,'("</zero_potential>")')
11826 : :
11827 : : !Local ionic potential
11828 [ # # ]: 0 : if (vlocopt==1) then
11829 : 0 : meshsz=mesh_data%meshsz(mesh_data%ivionmesh)
11830 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivionmesh),extra1)
11831 : 0 : meshst_aux=mesh_start(mesh_data%ivionmesh)
11832 [ # # ]: 0 : dum(1:meshsz)=sqr4pi*half*PAW%abinitvloc(1:meshsz)
11833 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11834 : : WRITE(unit_xml,'("<kresse_joubert_local_ionic_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11835 : 0 : & gridt(mesh_data%ivionmesh),mesh_data%ivionmesh,match_on_splgrid(PAW%rc)
11836 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11837 : 0 : WRITE(unit_xml,'("</kresse_joubert_local_ionic_potential>")')
11838 : : end if
11839 : :
11840 : : !Local Blochl''s potential
11841 [ # # ]: 0 : if(vlocopt==2) then
11842 : 0 : meshsz=mesh_data%meshsz(mesh_data%ivionmesh)
11843 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivionmesh),extra1)
11844 : 0 : meshst_aux=mesh_start(mesh_data%ivionmesh)
11845 [ # # ]: 0 : dum(1:meshsz)=sqr4pi*half*PAW%abinitnohat(1:meshsz)
11846 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11847 : : WRITE(unit_xml,'("<blochl_local_ionic_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11848 : 0 : & gridt(mesh_data%ivionmesh),mesh_data%ivionmesh,match_on_splgrid(PAW%rc)
11849 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11850 : 0 : WRITE(unit_xml,'("</blochl_local_ionic_potential>")')
11851 : : endif
11852 : :
11853 : : !Local LDA-1/2 potential
11854 : : ! if (pawlda12%uselda12) then
11855 : : ! meshsz=mesh_data%meshsz(mesh_data%ivlda12mesh)
11856 : : ! meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivlda12mesh),extra1)
11857 : : ! meshst_aux=mesh_start(mesh_data%ivlda12mesh)
11858 : : ! dum(1:meshsz)=pawlda12%pot(1:meshsz)
11859 : : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11860 : : ! ir=index_on_splgrid(pawlda12%rcut)
11861 : : ! dum_aux(ir+1:meshsz_aux)=0.d0 ! V_lda12 has to be zero for r>rc
11862 : : ! WRITE(unit_xml,'("<LDA_minus_half_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11863 : : !& gridt(mesh_data%ivlda12mesh),mesh_data%ivlda12mesh,match_on_splgrid(pawlda12%rcut)
11864 : : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11865 : : ! WRITE(unit_xml,'("</LDA_minus_half_potential>")')
11866 : : ! end if
11867 : :
11868 : : !Partial waves and projectors
11869 : : !-- Partial waves
11870 : 0 : meshsz=mesh_data%meshsz(mesh_data%iwavmesh)
11871 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%iwavmesh),extra1)
11872 : 0 : meshst_aux=mesh_start(mesh_data%iwavmesh)
11873 [ # # # # : 0 : LIBPAW_ALLOCATE(phi_aux,(meshsz_aux-meshst_aux+1,PAW%nbase))
# # # # #
# # # # #
# # # # ]
11874 [ # # # # : 0 : LIBPAW_ALLOCATE(tphi_aux,(meshsz_aux-meshst_aux+1,PAW%nbase))
# # # # #
# # # ]
11875 [ # # ]: 0 : Do ib=1,PAW%nbase
11876 [ # # ]: 0 : dum(2:meshsz)=PAW%ophi(2:meshsz,ib)/Grid%r(2:meshsz)
11877 : 0 : call extrapolate(dum(1:meshsz))
11878 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11879 [ # # ]: 0 : phi_aux(1:meshsz_aux,ib)=dum_aux(1:meshsz_aux)
11880 [ # # ]: 0 : dum(2:meshsz)=PAW%otphi(2:meshsz,ib)/Grid%r(2:meshsz)
11881 : 0 : call extrapolate(dum(1:meshsz))
11882 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11883 [ # # # # ]: 0 : if(nsplgrid>0) dum_aux(irc_aux:meshsz_aux)=phi_aux(irc_aux:meshsz_aux,ib)
11884 [ # # ]: 0 : tphi_aux(meshst_aux:meshsz_aux,ib)=dum_aux(meshst_aux:meshsz_aux)
11885 : : Enddo
11886 : : !-- Projectors
11887 : 0 : meshsz=mesh_data%meshsz(mesh_data%iprjmesh)
11888 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%iprjmesh),extra1)
11889 : 0 : meshst_aux=mesh_start(mesh_data%iprjmesh)
11890 [ # # # # : 0 : LIBPAW_ALLOCATE(proj_aux,(meshsz_aux-meshst_aux+1,PAW%nbase))
# # # # #
# # # # #
# # # # ]
11891 [ # # ]: 0 : Do ib=1,PAW%nbase
11892 [ # # ]: 0 : dum(2:meshsz)=tproj(2:meshsz,ib)/Grid%r(2:meshsz)
11893 : 0 : call extrapolate(dum(1:meshsz))
11894 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11895 [ # # # # ]: 0 : if(nsplgrid>0) dum_aux(irc_aux:meshsz_aux)=zero
11896 [ # # ]: 0 : proj_aux(meshst_aux:meshsz_aux,ib)=dum_aux(meshst_aux:meshsz_aux)
11897 : : Enddo
11898 : : !-- In case of a spline, re-orthogonalize projectors
11899 : : ! if (nsplgrid >0) then
11900 : : ! Do ib=1,PAW%nbase
11901 : : ! tphi_aux(1:meshsz_aux,ib)=tphi_aux(1:meshsz_aux,ib)*Grid1%r(1:meshsz_aux)
11902 : : ! proj_aux(1:meshsz_aux,ib)=proj_aux(1:meshsz_aux,ib)*Grid1%r(1:meshsz_aux)
11903 : : ! Enddo
11904 : : ! call vdborth(irc_aux,tphi_aux,proj_aux)
11905 : : ! Do ib=1,PAW%nbase
11906 : : ! tphi_aux(2:meshsz_aux,ib)=tphi_aux(2:meshsz_aux,ib)/Grid1%r(2:meshsz_aux)
11907 : : ! call extrapolate(tphi_aux(1:meshsz_aux,ib))
11908 : : ! proj_aux(2:meshsz_aux,ib)=proj_aux(2:meshsz_aux,ib)/Grid1%r(2:meshsz_aux)
11909 : : ! call extrapolate(proj_aux(1:meshsz_aux,ib))
11910 : : ! Enddo
11911 : : ! end if
11912 : : !-- Writing
11913 [ # # ]: 0 : Do ib=1,PAW%nbase
11914 : 0 : call mkname(ib,char4)
11915 : 0 : char20=stripchar('"'//AEPot%sym//char4//'"')
11916 : : WRITE(unit_xml,'("<ae_partial_wave state=",a6," grid=""",a,i1,""">")') &
11917 : 0 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11918 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (phi_aux(ii,ib),ii=meshst_aux,meshsz_aux)
11919 : 0 : WRITE(unit_xml,'("</ae_partial_wave>")')
11920 : : WRITE(unit_xml,'("<pseudo_partial_wave state=",a6," grid=""",a,i1,""">")')&
11921 : 0 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11922 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (tphi_aux(ii,ib),ii=meshst_aux,meshsz_aux)
11923 : 0 : WRITE(unit_xml,'("</pseudo_partial_wave>")')
11924 : : WRITE(unit_xml,'("<projector_function state=",a6," grid=""",a,i1,""">")') &
11925 : 0 : & TRIM(char20),gridt(mesh_data%iprjmesh),mesh_data%iprjmesh
11926 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (proj_aux(ii,ib),ii=meshst_aux,meshsz_aux)
11927 : 0 : WRITE(unit_xml,'("</projector_function>")')
11928 : : !do ic=1,PAW%nbase
11929 : : ! write(std_out,*) "splined", ib,ic
11930 : : ! dum(meshst_aux:meshsz_aux)=tphi_aux(meshst_aux:meshsz_aux,ib)*proj_aux(meshst_aux:meshsz_aux,ic)*dudr(meshst_aux:meshsz_aux)
11931 : : ! dum(meshst_aux:meshsz_aux)=dum(meshst_aux:meshsz_aux)*rad_aux(meshst_aux:meshsz_aux)*rad_aux(meshst_aux:meshsz_aux)
11932 : : ! xx=overint(meshsz_aux-meshst_aux+1,logstp0,dum(meshst_aux:meshsz_aux),-1)
11933 : : ! write(std_out,*) "ORTHO", ib,xx/logstp0
11934 : : !end do
11935 : : Enddo
11936 : : !-- Release memory
11937 [ # # ]: 0 : LIBPAW_DEALLOCATE(phi_aux)
11938 [ # # ]: 0 : LIBPAW_DEALLOCATE(proj_aux)
11939 [ # # ]: 0 : LIBPAW_DEALLOCATE(tphi_aux)
11940 : :
11941 : : !Kinetic terms
11942 : 0 : WRITE(unit_xml,'("<kinetic_energy_differences>")')
11943 [ # # # # : 0 : WRITE(unit_xml,'(3(1x,es23.16))')((PAW%kij(ib,ic)/2,ic=1,PAW%nbase),ib=1,PAW%nbase)
# # # # ]
11944 : 0 : WRITE(unit_xml,'("</kinetic_energy_differences>")')
11945 : :
11946 : : !!Core-valence exchange terms
11947 : : ! WRITE(unit_xml,'("<exact_exchange_X_matrix>")')
11948 : : ! WRITE(unit_xml,'(3(1x,es23.16))')((PAW%TXVC(ib,ic)/2,ic=1,PAW%nbase),ib=1,PAW%nbase)
11949 : : ! WRITE(unit_xml,'("</exact_exchange_X_matrix>")')
11950 : : !
11951 : : !!Core-core exchange terms
11952 : : ! WRITE(unit_xml,'("<exact_exchange core-core=""", 1x,es23.16,"""/>")') &
11953 : : !& PAW%XCORECORE/2
11954 : : !
11955 : : !!Lamb shielding
11956 : : ! WRITE(unit_xml,'("<lamb_shielding shielding=""", 1x,es23.16,"""/>")') &
11957 : : !& PAW%lambshielding
11958 : : !
11959 : : !! Input file
11960 : 0 : WRITE(unit_xml,'("<!-- Program: atompaw - input data follows: ")')
11961 : 0 : WRITE(unit_xml,'(a)') trim(input_string)
11962 : 0 : WRITE(unit_xml,'(a)') "END"
11963 : 0 : WRITE(unit_xml,'(" Program: atompaw - input end -->")')
11964 : 0 : WRITE(unit_xml,'("</paw_dataset>")')
11965 : :
11966 : : !Close file and end
11967 : 0 : CLOSE(unit_xml)
11968 : 0 : WRITE(STD_OUT,'(/,2x,a)') 'XML atomic dataset created.'
11969 : :
11970 [ # # ]: 0 : if(nsplgrid>0) call destroygrid(Grid1)
11971 [ # # ]: 0 : LIBPAW_DEALLOCATE(rad_aux)
11972 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum_aux)
11973 [ # # # # ]: 0 : LIBPAW_DEALLOCATE(dum)
11974 : :
11975 : : CONTAINS
11976 : : !**************************************************
11977 : : ! If an interpolation on an auxiliary grid is
11978 : : ! requested, give index of input radius
11979 : : ! on this auxiliary grid
11980 : : !**************************************************
11981 : : integer function index_on_splgrid(input_radius)
11982 : : real(dp),intent(in) :: input_radius
11983 : : if (nsplgrid>0) then
11984 : : if (logstp_spl>0.d0) then
11985 : : index_on_splgrid=int(tol8+log(1.d0+input_radius/radstp_spl)/logstp_spl)+1
11986 : : else if (radstp_spl>0.d0) then
11987 : : index_on_splgrid=int(tol8+input_radius/radstp_spl)+1
11988 : : end if
11989 : : else
11990 : : index_on_splgrid=FindGridIndex(Grid,input_radius)
11991 : : end if
11992 : : end function index_on_splgrid
11993 : :
11994 : : !**************************************************
11995 : : ! If an interpolation on an auxiliary grid is
11996 : : ! requested, match input radius on this auxiliary
11997 : : ! grid (defined by radstp_spl, logstp_spl)
11998 : : !**************************************************
11999 : 0 : real(dp) function match_on_splgrid(input_radius)
12000 : : real(dp),intent(in) :: input_radius
12001 : : integer :: indx
12002 : 0 : match_on_splgrid=input_radius
12003 [ # # ]: 0 : if (nsplgrid>0) then
12004 [ # # ]: 0 : if (logstp_spl>0.d0) then
12005 : 0 : indx=int(tol8+log(1.d0+input_radius/radstp_spl)/logstp_spl)+1
12006 : 0 : match_on_splgrid=radstp_spl*(exp(logstp_spl*(indx-1))-1.d0)
12007 [ # # ]: 0 : else if (radstp_spl>0.d0) then
12008 : 0 : indx=int(tol8+input_radius/radstp_spl)+1
12009 : 0 : match_on_splgrid=radstp_spl*(indx-1)
12010 : : end if
12011 : : end if
12012 : 0 : end function match_on_splgrid
12013 : :
12014 : : !**************************************************
12015 : : ! If an interpolation on an auxiliary grid is
12016 : : ! requested, inerpolate an input function on
12017 : : ! this auxiliary grid.
12018 : : ! Also filter the input function (put zero below
12019 : : ! a given threshold)
12020 : : !**************************************************
12021 [ # # # # ]: 0 : subroutine interp_and_filter(func_in,func_out)
12022 : : real(dp),intent(in) :: func_in(:)
12023 : : real(dp),intent(out) :: func_out(:)
12024 : : integer :: jj,msz_in,msz_out,msz_spl
12025 : : logical :: extra
12026 : 0 : msz_in=size(func_in) ; msz_out=size(func_out)
12027 [ # # ]: 0 : func_out=zero
12028 [ # # ]: 0 : if (nsplgrid>0) then
12029 [ # # ]: 0 : if (msz_out/=nsplgrid) stop ' Bug (1) in interp_and_filter: msz_out/=nsplgrid!'
12030 : 0 : extra=(Grid%r(msz_in)<Grid1%r(msz_out))
12031 [ # # ]: 0 : msz_spl=merge(msz_out-1,msz_out,extra)
12032 : 0 : call interpfunc(msz_in,Grid%r,func_in,msz_spl,Grid1%r,func_out)
12033 : : else
12034 [ # # ]: 0 : if (msz_out>msz_in) stop ' Bug (2) in interp_and_filter: msz_out>msz_in!'
12035 [ # # ]: 0 : func_out(1:msz_out)=func_in(1:msz_out)
12036 : : end if
12037 [ # # ]: 0 : do jj=1,msz_out
12038 [ # # ]: 0 : if (abs(func_out(jj))<tol_zero) func_out(jj)=0.d0
12039 : : end do
12040 : :
12041 : 0 : end subroutine interp_and_filter
12042 : :
12043 : : !***********************************************************************
12044 : : !* In case of interpolation on an auxiliary grid, a
12045 : : !* reorthonomalisation of projector and pseudo wavefunctions
12046 : : !* is necessary. This is done thanks to a Vanderbilt orthonormalisation
12047 : : !************************************************************************
12048 : : ! subroutine vdborth(irc_aux,tphi_aux,proj_aux)
12049 : : !
12050 : : ! real(dp),intent(in) :: tphi_aux(:,:)
12051 : : ! real(dp),intent(inout) :: proj_aux(:,:)
12052 : : ! integer :: irc_aux
12053 : : !
12054 : : ! integer :: i,icount,io,irc,j,jo,l,lmax,nbase
12055 : : ! real(dp), allocatable :: aa(:,:),ai(:,:),omap(:),proj_aux1(:,:)
12056 : : !
12057 : : ! allocate(proj_aux1(size(proj_aux,1),PAW%nbase))
12058 : : ! lmax=PAW%lmax
12059 : : ! nbase=PAW%nbase
12060 : : ! irc=irc_aux
12061 : : ! do l=0,lmax
12062 : : ! icount=0
12063 : : ! do io=1,nbase
12064 : : ! if (PAW%l(io)==l) icount=icount+1
12065 : : ! enddo
12066 : : ! if (icount==0) cycle
12067 : : ! allocate(aa(icount,icount),ai(icount,icount),omap(icount))
12068 : : ! aa=0;icount=0
12069 : : ! do io=1,nbase
12070 : : ! if (PAW%l(io)==l) then
12071 : : ! icount=icount+1
12072 : : ! omap(icount)=io
12073 : : ! endif
12074 : : ! enddo
12075 : : ! do i=1,icount
12076 : : ! io=omap(i)
12077 : : ! do j=1,icount
12078 : : ! jo=omap(j)
12079 : : ! aa(i,j)=overlap(Grid1,tphi_aux(:,io),proj_aux(:,jo),1,irc)
12080 : : ! enddo
12081 : : ! enddo
12082 : : ! ai=aa;call minverse(ai,icount,icount,icount)
12083 : : !
12084 : : ! do i=1,icount
12085 : : ! io=omap(i)
12086 : : ! proj_aux1(:,io)=0
12087 : : ! do j=1,icount
12088 : : ! jo=omap(j)
12089 : : ! proj_aux1(:,io)=proj_aux1(:,io)+proj_aux(:,jo)*ai(j,i)
12090 : : ! enddo
12091 : : ! enddo
12092 : : ! deallocate(aa,ai,omap)
12093 : : ! enddo
12094 : : ! proj_aux=proj_aux1
12095 : : ! deallocate(proj_aux1)
12096 : : ! end subroutine vdborth
12097 : :
12098 : : END SUBROUTINE xmloutput
12099 : :
12100 : :
12101 : : !!=================================================================
12102 : : !! NAME
12103 : : !! get_xc_data
12104 : : !!
12105 : : !! FUNCTION
12106 : : !! Get XC data in a suitable form for XML printing
12107 : : !!
12108 : : !! INPUTS
12109 : : !! exctype= string containing XC type
12110 : : !!
12111 : : !! OUTPUT
12112 : : !! xc_name= name of XC functional
12113 : : !! xc_type= LDA or GGA
12114 : : !!
12115 : : !! PARENTS
12116 : : !! xmlout,xmlprtcore
12117 : : !!
12118 : : !!=================================================================
12119 : :
12120 : 0 : subroutine get_xc_data(atp,xctype,xcname)
12121 : : type(atompaw_type),intent(in) :: atp
12122 : : character(len=*),intent(out) :: xctype,xcname
12123 : :
12124 : : !------------------------------------------------------------------
12125 : : !---- Executable code
12126 : : !------------------------------------------------------------------
12127 : :
12128 [ # # ]: 0 : if (trim(ADJUSTL(atp%exctype))=="LDA-PW") then
12129 [ # # # # ]: 0 : xctype="LDA"
12130 [ # # # # ]: 0 : xcname="PW"
12131 [ # # ]: 0 : elseif (trim(ADJUSTL(atp%exctype))=="GGA-PBE") then
12132 [ # # # # ]: 0 : xctype="GGA"
12133 [ # # # # ]: 0 : xcname="PBE"
12134 [ # # ]: 0 : elseif (trim(ADJUSTL(atp%exctype))=="GGA-PBESOL") then
12135 [ # # # # ]: 0 : xctype="GGA"
12136 [ # # # # ]: 0 : xcname="PBESOL"
12137 [ # # ]: 0 : else if(atp%itype==LIBXC) then
12138 [ # # ]: 0 : if (libxc_functionals_ismgga(atp%xc_functionals)) then
12139 [ # # # # ]: 0 : xctype="MGGA"
12140 [ # # ]: 0 : else if (libxc_functionals_isgga(atp%xc_functionals)) then
12141 [ # # # # ]: 0 : xctype="GGA"
12142 : : else
12143 [ # # # # ]: 0 : xctype="LDA"
12144 : : end if
12145 [ # # # # ]: 0 : xcname=trim(atp%exctype)
12146 : : else
12147 : 0 : LIBPAW_ERROR("Unknown XC type")
12148 : : end if
12149 : :
12150 : 0 : end subroutine get_xc_data
12151 : :
12152 : :
12153 : :
12154 : : !!=================================================================
12155 : : !! NAME
12156 : : !! get_xc_alias
12157 : : !!
12158 : : !! FUNCTION
12159 : : !! Get XC name alias (following PAW-XML specification)
12160 : : !! from a libXC functional name
12161 : : !!
12162 : : !! INPUTS
12163 : : !! xc_name= string containing long XC name
12164 : : !!
12165 : : !! OUTPUT
12166 : : !! xc_alias= alias of XC functional
12167 : : !!
12168 : : !! PARENTS
12169 : : !! xmlout,xmlprtcore
12170 : : !!
12171 : : !!=================================================================
12172 : :
12173 : 0 : subroutine get_xc_alias(xc_name,xc_alias)
12174 : :
12175 : : character(len=*),intent(in) :: xc_name
12176 : : character(len=*),intent(out) :: xc_alias
12177 : :
12178 : : !------------------------------------------------------------------
12179 : : !---- Executable code
12180 : : !------------------------------------------------------------------
12181 : :
12182 : 0 : select case(trim(xc_name))
12183 : : case('LDA_X+LDA_C_PW')
12184 [ # # # # ]: 0 : xc_alias='PW'
12185 : : case('GGA_X_PBE+GGA_C_PBE')
12186 [ # # # # ]: 0 : xc_alias='PBE'
12187 : : case('LDA_X+LDA_C_PZ')
12188 [ # # # # ]: 0 : xc_alias='PZ'
12189 : : case('LDA_X+LDA_C_WIGNER')
12190 [ # # # # ]: 0 : xc_alias='W'
12191 : : case('LDA_X+LDA_C_HL')
12192 [ # # # # ]: 0 : xc_alias='HL'
12193 : : case('LDA_X+LDA_C_GL')
12194 [ # # # # ]: 0 : xc_alias='GL'
12195 : : case('LDA_X+LDA_C_VWN')
12196 [ # # # # ]: 0 : xc_alias='VWN'
12197 : : case('GGA_X_PBE_R+GGA_C_PBE')
12198 [ # # # # ]: 0 : xc_alias='revPBE'
12199 : : case('GGA_X_RPBE+GGA_C_PBE')
12200 [ # # # # ]: 0 : xc_alias='RPBE'
12201 : : case('GGA_X_PW91+GGA_C_PW91')
12202 [ # # # # ]: 0 : xc_alias='PW91'
12203 : : case('GGA_X_B88+GGA_C_LYP')
12204 [ # # # # ]: 0 : xc_alias='BLYP'
12205 : : case DEFAULT
12206 [ # # # # ]: 0 : xc_alias=xc_name
12207 : : end select
12208 : :
12209 [ # # # # : 0 : end subroutine get_xc_alias
# # # # #
# # # ]
12210 : :
12211 : :
12212 : :
12213 : : !!=================================================================
12214 : : !! NAME
12215 : : !! read_inputstring
12216 : : !!
12217 : : !! FUNCTION
12218 : : !! Read the file echoing the atompaw input file
12219 : : !! and transfer it into a character string
12220 : : !!
12221 : : !! OUTPUT
12222 : : !! input_string=character string containing the file
12223 : : !!
12224 : : !! PARENTS
12225 : : ! xml2abinit
12226 : : !!=================================================================
12227 : :
12228 : 4 : subroutine read_inputstring(input_string)
12229 : :
12230 : : character(len=*) :: input_string
12231 : :
12232 : : !------------------------------------------------------------------
12233 : : !---- Local variables
12234 : : !------------------------------------------------------------------
12235 : :
12236 : : integer :: OK,input_unit
12237 : : character(len=132) :: inputline
12238 : :
12239 : : !------------------------------------------------------------------
12240 : : !---- Executable code
12241 : : !------------------------------------------------------------------
12242 : :
12243 : 4 : open(input_unit,file='dummy',form='formatted')
12244 [ - + ]: 4 : read(input_unit,'(a)',iostat=OK,end=10) inputline
12245 [ # # ]: 0 : if (OK/=0) return
12246 [ # # # # ]: 0 : input_string=trim(inputline)
12247 : 0 : do
12248 [ # # ]: 0 : read(input_unit,'(a)',iostat=OK,end=10) inputline
12249 [ # # ]: 0 : if (OK/=0) exit
12250 : 0 : write(unit=input_string,fmt='(3a)') trim(input_string),char(10),trim(inputline)
12251 : : enddo
12252 : : return
12253 : : 10 continue
12254 : 4 : close(input_unit)
12255 : :
12256 : 4 : end subroutine read_inputstring
12257 : :
12258 : :
12259 [ # # # # : 0 : end module m_paw_atom_solve
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
12260 : : !!***
|
