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 [ # # ]: 0 : if(xmpi_comm_rank(xmpi_world)==0) then
949 : : call xmloutput(trim(file_xml),atp%Grid,atp%SCF,atp%Pot,atp%Orbit,atp%PAW,mesh_data,&
950 [ # # ]: 0 : & atp%PAW%otp,2,atp%input_string,"","",-1,atm%zcore_orig,atp)
951 [ # # ]: 0 : file_xml=TRIM(atp%pot%sym)//'-rcpaw.corewf.xml'
952 [ # # ]: 0 : call xmlprtcore(trim(file_xml),atp,atm%zcore_orig,mesh_data,atp%input_string)
953 : : endif
954 : 0 : call destroy_mesh_data(mesh_data)
955 : : endif
956 : :
957 : : ! update tcoretau : TODO : tau
958 : : ! Clean up
959 [ + + - + ]: 18 : if(update_paw.or.atp%vhtnzc_mode==2) then
960 [ + + ]: 4004 : do io=1,atp%Grid%n
961 : 4002 : atp%Pot%rvh(io)=atp%Pot%rvh(io)+potshift*atp%Grid%r(io)
962 : 4004 : atp%Pot%rv(io)=atp%Pot%rv(io)+potshift*atp%Grid%r(io)
963 : : enddo
964 : 2 : atp%Pot%v0=atp%Pot%v0+potshift
965 : : endif
966 : : endif
967 [ - + ]: 19 : LIBPAW_DEALLOCATE(coredens)
968 : 19 : call pawrad_free(radmesh)
969 [ - + - + : 19 : end subroutine atompaw_solve
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ ]
970 : : !!***
971 : :
972 : : !----------------------------------------------------------------------
973 : :
974 : : !!****f* m_paw_atom_solve/atompaw_init
975 : : !! NAME
976 : : !! atompaw_init
977 : : !!
978 : : !! FUNCTION
979 : : !! Initialize an atompaw type
980 : : !!
981 : : !! OUTPUT
982 : : !!
983 : : !! SIDE EFFECTS
984 : : !!
985 : : !! NOTES
986 : : !!
987 : : !! SOURCE
988 : : !! Inspired from SCFatom_init in atompaw
989 : :
990 : 4 : subroutine atompaw_init(pawtab,pawrad,atp,atm,sctol,elin_mode,vhtnzc_mode,tpaw_mode,dirac,filename,prtpaw)
991 : : ! TODO : BDsolve
992 : : implicit none
993 : : !Arguments ------------------------------------
994 : : !scalars
995 : : integer, intent(in) :: elin_mode,vhtnzc_mode,tpaw_mode,prtpaw
996 : : real(dp), intent(in) :: sctol
997 : : logical,intent(in) :: dirac
998 : : CHARACTER(len=*),intent(in) :: filename
999 : : type(pawtab_type), intent(inout) :: pawtab
1000 : : type(pawrad_type), intent(in) :: pawrad
1001 : : type(atompaw_type), intent(inout) :: atp
1002 : : type(atomorb_type), intent(inout) :: atm
1003 : : !arrays
1004 : : !Local variables-------------------------------
1005 : : !scalars
1006 : : CHARACTER(len=500) :: input_file
1007 : : character(len=500) :: msg
1008 : : character(len=fnlen) :: file_xml_core
1009 : : logical :: rcpaw_core_file,ex
1010 : : REAL(dp) :: a1,a2,a3,hval,r0,zcore
1011 : : INTEGER :: ii,jj,icor,ir,io,fnln,ios
1012 : : logical :: fmt_xml
1013 : : real(dp) :: ekin,insph,norm
1014 : 4 : type(pawrad_type) :: radmesh
1015 : 4 : type(mesh_data_type) :: mesh_data
1016 : : !arrays
1017 : 4 : real(dp), allocatable :: ff(:)
1018 : :
1019 : : ! *************************************************************************
1020 : :
1021 : : ! File to read
1022 : 4 : input_file=trim(filename)
1023 : 4 : fnln=len(trim(filename))
1024 : 4 : fmt_xml=.false.
1025 [ + - ]: 4 : if (fnln>3) then
1026 : 4 : fmt_xml=(input_file(fnln-3:fnln)=='.xml')
1027 : : endif
1028 [ - + ]: 4 : if(.not.fmt_xml) then
1029 : 0 : LIBPAW_ERROR('RCPAW ONLY COMPATIBLE WITH XML COREWF FILE')
1030 : : endif
1031 [ + - ]: 4 : input_file=input_file(1:fnln-3)//'corewf.xml'
1032 : 4 : inquire(file=trim(input_file),iostat=ios,exist=ex)
1033 [ - + ]: 4 : if (ios/=0) then
1034 : 0 : write(msg,'(2a)') 'INQUIRE returns an error for file ',trim(input_file)
1035 : 0 : LIBPAW_ERROR(msg)
1036 : : end if
1037 [ - + ]: 4 : if (.not.ex) then
1038 : 0 : write(msg,'(3a)') 'This file does not exist: ',trim(input_file),'!'
1039 : 0 : LIBPAW_ERROR(msg)
1040 : : end if
1041 : :
1042 : : ! Initialize global constants
1043 : 4 : machine_precision = zero
1044 : 4 : a1 = 4._dp/3._dp
1045 [ + + ]: 8 : DO WHILE (machine_precision == 0._dp)
1046 : 4 : a2 = a1 - 1._dp
1047 : 4 : a3 = a2 + a2 + a2
1048 : 4 : machine_precision = ABS(a3 - 1._dp)
1049 : : ENDDO
1050 : 4 : machine_zero= machine_precision**5
1051 : 4 : machine_infinity = 1._dp/machine_zero
1052 : 4 : practical_zero=machine_precision**2
1053 : 4 : minlogarg=machine_precision; minlog=LOG(minlogarg)
1054 : 4 : maxlogarg=1._dp/machine_precision; maxlog=LOG(maxlogarg)
1055 : 4 : minexparg=LOG(machine_precision); minexp=0._dp
1056 : 4 : maxexparg=-LOG(machine_precision); maxexp=EXP(maxexparg)
1057 : 4 : has_to_print=.false.
1058 : :
1059 : : ! Read atp input and initialize
1060 : 4 : atp%elin_mode=elin_mode
1061 : 4 : atp%vhtnzc_mode=vhtnzc_mode
1062 : 4 : atp%tpaw_mode=tpaw_mode
1063 : 4 : atp%prtpaw=(prtpaw>0)
1064 : :
1065 : 4 : call input_dataset_read(atp,input_file,dirac,.true.)
1066 : :
1067 : 4 : rcpaw_core_file=.false.
1068 [ + + + + ]: 4 : if((.not.dirac).and.atp%diracrelativistic) then
1069 : 1 : atp%scalarrelativistic=.true.
1070 : 1 : atp%diracrelativistic=.false.
1071 : 1 : rcpaw_core_file=.true.
1072 : : endif
1073 : 4 : atp%npsc=0
1074 : 4 : atp%nppc=1
1075 : 4 : atp%npdc=2
1076 : 4 : atp%npfc=3
1077 : 4 : atp%npgc=4
1078 : 4 : atp%frozenvalecalculation=.false.
1079 : 4 : atp%frozencorecalculation=.false.
1080 : 4 : atp%setupfrozencore=.false.
1081 : 4 : atp%gaussianshapefunction=.false.
1082 : 4 : atp%besselshapefunction=.false.
1083 : 4 : atp%collesalvetti=.false.
1084 [ - + ]: 4 : IF (TRIM(atp%gridkey)=='LINEAR') THEN
1085 : 0 : hval=atp%gridmatch/(atp%gridpoints-1)
1086 : 0 : CALL InitGrid(atp%Grid,hval,atp%gridrange)
1087 [ + - ]: 4 : ELSEIF (TRIM(atp%gridkey)=='LOGGRID') THEN
1088 : 4 : hval=logh
1089 : 4 : CALL findh(real(atp%atomic_charge,kind=dp),atp%gridmatch,atp%gridpoints,hval,r0)
1090 : 4 : CALL InitGrid(atp%Grid,pawrad%lstep,atp%gridrange,r0=pawrad%rstep)
1091 [ # # ]: 0 : ELSEIF (TRIM(atp%gridkey)=='LOGGRID4') THEN
1092 : : hval=logh
1093 : : CALL findh_given_r0(real(atp%atomic_charge,kind=dp),atp%gridmatch,lor00,&
1094 : 0 : & atp%gridpoints,hval)
1095 : 0 : CALL InitGrid(atp%Grid,hval,atp%gridrange,r0=lor00/atp%atomic_charge)
1096 : : ENDIF
1097 : 4 : call print_check_atompaw_params(atp)
1098 [ + - ]: 4 : call read_inputstring(atp%input_string,trim(atp%atomic_symbol)//'_atp_echofile')
1099 : :
1100 : : ! Init potentials
1101 : 4 : CALL InitPot(atp%Pot,atp%Grid%n)
1102 : 4 : atp%Pot%sym=atp%atomic_symbol
1103 : : atp%Pot%zz=0._dp
1104 : 4 : atp%Pot%q=0._dp;
1105 : 4 : atp%Pot%v0=0._dp
1106 : 4 : atp%Pot%v0p=0._dp
1107 : 4 : atp%Pot%Nv0=0
1108 : 4 : atp%Pot%Nv0p=0
1109 : 4 : atp%Pot%nz=atp%atomic_charge
1110 : 4 : atp%Pot%zz=atp%Pot%nz
1111 : 4 : atp%Pot%needvtau=atp%needvtau
1112 : 4 : atp%Pot%finitenucleus=atp%finitenucleus
1113 : 4 : atp%Pot%finitenucleusmodel=atp%finitenucleusmodel
1114 : 4 : CALL Get_Nuclearpotential(atp%Grid,atp%Pot)
1115 : :
1116 : : ! Init XC
1117 : : ! atp%temp=temp
1118 : 4 : call initexch(atp)
1119 : :
1120 : : ! Init orbitals
1121 [ + + ]: 24 : ii=maxval(atp%np)
1122 : 4 : jj=atp%np(1)
1123 : 4 : IF(atp%np(2)>0) jj=jj+atp%np(2)-1
1124 : : IF(atp%np(3)>0) jj=jj+atp%np(3)-2
1125 : : IF(atp%np(4)>0) jj=jj+atp%np(4)-3
1126 : : IF(atp%np(5)>0) jj=jj+atp%np(5)-4
1127 : : If (atp%diracrelativistic) jj=jj+jj ! need more orbitals
1128 : : CALL InitOrbit(atp%Orbit,atp%norbit,atp%Grid%n,atp%exctype,atp%diracrelativistic,atp%scalarrelativistic,&
1129 : 4 : & atp%frozencorecalculation,atp%frozenvalecalculation)
1130 : 4 : atp%Orbit%nps=atp%np(1);atp%Orbit%npp=atp%np(2);atp%Orbit%npd=atp%np(3)
1131 : 4 : atp%Orbit%npf=atp%np(4);atp%Orbit%npg=atp%np(5)
1132 : 4 : CALL Prepare_Orbit(atp,ii,atp%norbit)
1133 : 4 : atp%Orbit%npsc=atp%npsc;atp%Orbit%nppc=atp%nppc;atp%Orbit%npdc=atp%npdc
1134 : 4 : atp%Orbit%npfc=atp%npfc;atp%Orbit%npgc=atp%npgc
1135 : 4 : atp%Pot%q=atp%electrons
1136 : :
1137 : : ! Init SCF
1138 : 4 : CALL InitSCF(atp%SCF)
1139 : 4 : IF (atp%needvtau) then
1140 : 0 : atp%usespline=.true.
1141 : : endif
1142 [ - + ]: 4 : if(atp%usespline) CALL initsplinesolver(atp%Grid,atp%splns,atp%splr0,atp%needvtau,atp%spline)
1143 : :
1144 : : ! Init PAW
1145 : 4 : atp%PAW%irc=FindGridIndex(atp%Grid,atp%rc)
1146 : 4 : atp%PAW%irc_shap=FindGridIndex(atp%Grid,atp%rc_shap)
1147 : 4 : atp%PAW%irc_vloc=FindGridIndex(atp%Grid,atp%rc_vloc)
1148 : 4 : atp%PAW%irc_core=FindGridIndex(atp%Grid,atp%rc_core)
1149 : 4 : atp%PAW%rc=atp%Grid%r(atp%PAW%irc)
1150 : 4 : atp%PAW%rc_shap=atp%Grid%r(atp%PAW%irc_shap)
1151 : 4 : atp%PAW%rc_vloc=atp%Grid%r(atp%PAW%irc_vloc)
1152 : 4 : atp%PAW%rc_core=atp%Grid%r(atp%PAW%irc_core)
1153 : 4 : atp%PAW%lmax=atp%lmax
1154 : 4 : call InitPAW(atp%PAW,atp%Grid,atp%Orbit)
1155 : :
1156 : : ! Re-solve (temporary, this should be added to atompaw)
1157 : 4 : call SCFatom(atp,.true.)
1158 : :
1159 [ + + ]: 4 : if(rcpaw_core_file) then
1160 : 1 : call build_mesh_data(mesh_data,atp%Grid,atp%PAW%irc,0,0,0,0)
1161 : 1 : zcore=zero
1162 [ + + ]: 8 : do io=1,atp%norbit
1163 [ + + ]: 8 : if(atp%orbit%iscore(io)) then
1164 : 3 : zcore=zcore+atp%orbit%occ(io)
1165 : : endif
1166 : : enddo
1167 [ + - ]: 1 : file_xml_core=TRIM(atp%pot%sym)//'-tmp.corewf.xml'
1168 [ + - ]: 1 : if(xmpi_comm_rank(xmpi_world)==0) then
1169 [ + - ]: 1 : call xmlprtcore(trim(file_xml_core),atp,zcore,mesh_data,atp%input_string)
1170 : : endif
1171 [ + - ]: 1 : file_xml_core=trim(atp%pot%sym)//'-tmp.xml'
1172 : 1 : call destroy_mesh_data(mesh_data)
1173 : : else
1174 [ - + ]: 3 : file_xml_core=filename
1175 : : endif
1176 : : ! define atom
1177 [ + - ]: 4 : call pawpsp_init_core(atm,psp_filename=trim(file_xml_core))
1178 [ + - + + ]: 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)
1179 : 4 : write(msg,'(a)') 'atompaw_init: orbital, %out of sphere, core, semicore'
1180 : 4 : call wrtout(std_out,msg,'COLL')
1181 [ + + ]: 31 : do io=1,atp%Orbit%norbit
1182 : 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)
1183 : 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)
1184 [ + + + + ]: 27 : if(.not.atp%Orbit%iscore(io).and.(one-insph/norm)*100.0_dp<sctol) atp%Orbit%issemicore(io)=.true.
1185 : 27 : write(msg,*)io,(one-insph/norm)*100.0_dp,atp%Orbit%iscore(io),atp%Orbit%issemicore(io)
1186 : 31 : call wrtout(std_out,msg,'COLL')
1187 : : enddo
1188 : : !!!
1189 : :
1190 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%pot_refo,(pawtab%basis_size))
+ - + - -
+ - + -
+ ]
1191 [ - + + - : 12 : LIBPAW_ALLOCATE(ff,(pawtab%mesh_size))
+ - + - -
+ - + -
+ ]
1192 [ + + ]: 5674 : ff(2:pawtab%mesh_size)=atp%Pot%rv(2:pawtab%mesh_size)/atp%grid%r(2:pawtab%mesh_size)
1193 : 4 : call extrapolate(ff)
1194 [ + + ]: 40 : do io=1,pawtab%basis_size
1195 [ + - + + ]: 50968 : call simp_gen(atp%pot_refo(io),ff(1:pawtab%mesh_size)*(pawtab%phi(1:pawtab%mesh_size,io))**2,pawrad)
1196 : : enddo
1197 [ - + ]: 4 : LIBPAW_DEALLOCATE(ff)
1198 : :
1199 : : ! Densities
1200 [ + + ]: 8008 : atp%Orbit%valeden=zero
1201 [ + + ]: 8008 : atp%Orbit%coreden=zero
1202 [ + + ]: 31 : do io=1,atp%Orbit%norbit
1203 [ + + ]: 31 : if(atp%Orbit%iscore(io)) then
1204 [ + + ]: 26026 : atp%Orbit%coreden=atp%Orbit%coreden+atp%Orbit%occ(io)*(atp%Orbit%wfn(:,io))**2
1205 : : else
1206 [ + + ]: 28028 : atp%Orbit%valeden(:)=atp%Orbit%valeden(:)+atp%Orbit%occ(io)*(atp%Orbit%wfn(:,io))**2
1207 : : endif
1208 : : enddo
1209 : : ! Core energies
1210 : 4 : atm%edcc=zero
1211 : 4 : atm%ekinc=zero
1212 : 4 : atm%eeigc=zero
1213 : 4 : icor=0
1214 [ + + ]: 31 : do io=1,atp%Orbit%norbit
1215 [ + + ]: 31 : if(atp%Orbit%iscore(io)) then
1216 : 13 : icor=icor+1
1217 : 13 : CALL altkinetic(atp%Grid,atp%Orbit%wfn(:,io),atp%Orbit%eig(io),atp%Pot%rv,ekin)
1218 : 13 : atm%ekinc=atm%ekinc+ekin/two*atp%Orbit%occ(io)
1219 : 13 : atm%eeigc=atm%eeigc+atp%Orbit%eig(io)*atp%Orbit%occ(io)/two
1220 : : endif
1221 : : enddo
1222 [ - + + - : 12 : LIBPAW_ALLOCATE(ff,(atp%grid%n))
+ - + - -
+ - + -
+ ]
1223 [ + + ]: 8008 : ff=zero
1224 : : ff(2:atp%Grid%n)=atp%Pot%rv(2:atp%Grid%n)*&
1225 [ + + ]: 8004 : & atp%Orbit%coreden(2:atp%Grid%n)/atp%Grid%r(2:atp%Grid%n)
1226 : 4 : CALL extrapolate(ff)
1227 : 4 : atm%edcc=integrator(atp%Grid,ff)/two
1228 [ + + ]: 8004 : ff(2:atp%Grid%n)=atp%Orbit%coreden(2:atp%Grid%n)/(four*pi*atp%Grid%r(2:atp%Grid%n)**2)
1229 : 4 : CALL extrapolate(ff)
1230 : 4 : call pawrad_init(radmesh,atp%Grid%n,pawrad%mesh_type,pawrad%rstep,pawrad%lstep)
1231 : 4 : call atompaw_ehnzc(ff,radmesh,atm%ehnzc,atm%znucl)
1232 [ - + ]: 4 : LIBPAW_DEALLOCATE(ff)
1233 [ + - + + : 35 : atm%min_eigv=half*minval(atp%Orbit%eig,mask=.not.atp%Orbit%iscore)
- + - - +
+ + + ]
1234 : 4 : call pawrad_free(radmesh)
1235 : :
1236 : : ! Prepare for frozen val calculation
1237 : 4 : atp%frozenvalecalculation=.true.
1238 : 4 : atp%Orbit%frozenvalecalculation=.true.
1239 : 4 : atp%projector_type=PROJECTOR_TYPE_MARSMAN
1240 [ + + + + ]: 148152 : atp%PAW%otp=zero
1241 [ + + ]: 40 : do io=1,pawtab%basis_size
1242 [ + + ]: 50788 : do ir=1,atp%PAW%irc
1243 : 50784 : atp%PAW%otp(ir,io)=pawtab%tproj(ir,io)
1244 : : enddo
1245 : : enddo
1246 : :
1247 : : ! atp%SCF%corekin=two*atm%ekinc
1248 : : ! call setcoretail(atp%Grid,atp%Orbit%coreden,atp%PAW,atp%needvtau)
1249 : : ! call setbasis(atp%Grid,atp%Pot,atp%Orbit,atp%PAW,atp,0.0_dp)
1250 : : ! call SetPAWOptions2(atp,fmt_xml)
1251 : : ! atp%PAW%abinitnohat(1:size(pawtab%vhtnzc))=pawtab%vhtnzc(1:size(pawtab%vhtnzc))*two
1252 : : ! atp%PAW%otp=zero
1253 : : ! do io=1,pawtab%basis_size
1254 : : ! do ir=1,atp%PAW%irc
1255 : : ! atp%PAW%otp(ir,io)=pawtab%tproj(ir,io)
1256 : : ! enddo
1257 : : ! enddo
1258 : : ! do io=1,pawtab%basis_size
1259 : : ! irc=FindGridIndex(atp%Grid,atp%basis_func_rc(io))
1260 : : ! irc=min(atp%PAW%irc,irc)
1261 : : ! atp%PAW%rcio(io)=atp%grid%r(irc)
1262 : : ! enddo
1263 : : ! atp%PAW%abinitnohat(1:size(pawtab%vhtnzc))=pawtab%vhtnzc(1:size(pawtab%vhtnzc))*two
1264 : : ! call build_mesh_data(mesh_data,atp%Grid,atp%PAW%irc,0,0,0,0)
1265 : : ! if(.not.allocated(pawtab%kij)) then
1266 : : ! LIBPAW_ALLOCATE(pawtab%kij,(pawtab%lmn2_size))
1267 : : ! endif
1268 : : ! call calc_kij(atp%PAW,atp%Grid,pawtab%kij,pawtab,&
1269 : : !& atp%scalarrelativistic,atp%needvtau)
1270 : : ! file_xml_core=trim(atp%pot%sym)//'-rcpaw.xml'
1271 : : ! call xmloutput(trim(file_xml_core),atp%Grid,atp%SCF,atp%Pot,atp%Orbit,atp%PAW,mesh_data,&
1272 : : !& atp%PAW%otp,2,atp%input_string,"","",-1,atm%zcore,atp)
1273 : : ! file_xml_core=TRIM(atp%pot%sym)//'-rcpaw.corewf.xml'
1274 : : ! call xmlprtcore(trim(file_xml_core),atp,atm%zcore,mesh_data,atp%input_string)
1275 : :
1276 [ + - - + : 8 : end subroutine atompaw_init
- + - + -
+ - + - +
- + - + ]
1277 : : !!***
1278 : :
1279 : : !----------------------------------------------------------------------
1280 : :
1281 : : !!****f* m_paw_atom_solve/atompaw_destroy
1282 : : !! NAME
1283 : : !! atompaw_destroy
1284 : : !!
1285 : : !! FUNCTION
1286 : : !! Destroy an atompaw type
1287 : : !!
1288 : : !! OUTPUT
1289 : : !!
1290 : : !! SIDE EFFECTS
1291 : : !!
1292 : : !! NOTES
1293 : : !!
1294 : : !! SOURCE
1295 : :
1296 : 4 : subroutine atompaw_destroy(atp)
1297 : :
1298 : : implicit none
1299 : : !Arguments ------------------------------------
1300 : : !scalars
1301 : : type(atompaw_type), intent(inout) :: atp
1302 : :
1303 : : ! *********************************************************************
1304 : :
1305 [ + - ]: 4 : if(allocated(atp%orbit_mod_n)) then
1306 : 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_n)
1307 : : endif
1308 [ + - ]: 4 : if(allocated(atp%orbit_mod_l)) then
1309 : 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_l)
1310 : : endif
1311 [ + - ]: 4 : if(allocated(atp%orbit_mod_k)) then
1312 : 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_k)
1313 : : endif
1314 [ + - ]: 4 : if(allocated(atp%orbit_mod_occ)) then
1315 : 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_occ)
1316 : : endif
1317 [ + - ]: 4 : if(allocated(atp%orbit_iscore)) then
1318 : 4 : LIBPAW_DEALLOCATE(atp%orbit_iscore)
1319 : : endif
1320 [ + - ]: 4 : if(allocated(atp%orbit_val_n)) then
1321 : 4 : LIBPAW_DEALLOCATE(atp%orbit_val_n)
1322 : : endif
1323 [ + - ]: 4 : if(allocated(atp%orbit_val_l)) then
1324 : 4 : LIBPAW_DEALLOCATE(atp%orbit_val_l)
1325 : : endif
1326 [ + - ]: 4 : if(allocated(atp%orbit_val_k)) then
1327 : 4 : LIBPAW_DEALLOCATE(atp%orbit_val_k)
1328 : : endif
1329 [ + - ]: 4 : if(allocated(atp%basis_add_l)) then
1330 : 4 : LIBPAW_DEALLOCATE(atp%basis_add_l)
1331 : : endif
1332 [ + - ]: 4 : if(allocated(atp%basis_add_k)) then
1333 : 4 : LIBPAW_DEALLOCATE(atp%basis_add_k)
1334 : : endif
1335 [ + - ]: 4 : if(allocated(atp%basis_add_energy)) then
1336 : 4 : LIBPAW_DEALLOCATE(atp%basis_add_energy)
1337 : : endif
1338 [ + - ]: 4 : if(allocated(atp%basis_func_rc)) then
1339 : 4 : LIBPAW_DEALLOCATE(atp%basis_func_rc)
1340 : : endif
1341 [ + - ]: 4 : if(allocated(atp%pot_refo)) then
1342 : 4 : LIBPAW_DEALLOCATE(atp%pot_refo)
1343 : : endif
1344 : 4 : call DestroyGrid(atp%Grid)
1345 : 4 : call DestroyOrbit(atp%Orbit)
1346 : 4 : call DestroyPot(atp%Pot)
1347 : 4 : call DestroyPAW(atp%PAW)
1348 : 4 : call deallocatesplinesolver(atp%spline,atp%needvtau)
1349 : :
1350 : 4 : end subroutine atompaw_destroy
1351 : : !!***
1352 : :
1353 : :
1354 : :
1355 : :
1356 : :
1357 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1358 : : ! BELOW THIS ARE PRIVATE ROUTINES MOSTLY IMPORTED FROM ATOMPAW
1359 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1360 : :
1361 : :
1362 : :
1363 : :
1364 : :
1365 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1366 : : ! 0. Developped for RCPAW
1367 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1368 : :
1369 : :
1370 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1371 : : !! makebasis_marsman
1372 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1373 : 2 : subroutine makebasis_marsman(atp)
1374 : : type(atompaw_type),intent(inout) :: atp
1375 : : integer :: ns,np,nd,nf,ng,io,l
1376 : : real(dp):: v0,v0p
1377 : 2 : integer, allocatable :: map(:)
1378 [ - + + - : 6 : LIBPAW_ALLOCATE(map,(atp%PAW%nbase))
+ - + - -
+ - + ]
1379 : 2 : ns=0
1380 : 2 : np=0
1381 : 2 : nd=0
1382 : 2 : nf=0
1383 : 2 : ng=0
1384 [ + + ]: 20 : map=0
1385 : 2 : call zeropot(atp%Grid,atp%PAW%rveff,v0,v0p)
1386 [ + + ]: 20 : do io=1,atp%PAW%nbase
1387 : 18 : l=atp%PAW%l(io)
1388 [ + + ]: 18 : if(l==0) then
1389 : 5 : ns=ns+1
1390 : 5 : map(io)=ns
1391 : : endif
1392 [ + + ]: 18 : if(l==1) then
1393 : 5 : np=np+1
1394 : 5 : map(io)=np
1395 : : endif
1396 [ + + ]: 18 : if(l==2) then
1397 : 5 : nd=nd+1
1398 : 5 : map(io)=nd
1399 : : endif
1400 [ + + ]: 18 : if(l==3) then
1401 : 3 : nf=nf+1
1402 : 3 : map(io)=nf
1403 : : endif
1404 [ - + ]: 20 : if(l==4) then
1405 : 0 : ng=ng+1
1406 : 0 : map(io)=ng
1407 : : endif
1408 : : enddo
1409 [ + - ]: 2 : if(ns>0) call marsman_tphi(atp,map,0,ns)
1410 [ + - ]: 2 : if(np>0) call marsman_tphi(atp,map,1,np)
1411 [ + - ]: 2 : if(nd>0) call marsman_tphi(atp,map,2,nd)
1412 [ + + ]: 2 : if(nf>0) call marsman_tphi(atp,map,3,nf)
1413 [ - + ]: 2 : if(ng>0) call marsman_tphi(atp,map,4,ng)
1414 : : ! renormalize phis
1415 [ + + ]: 20 : do io=1,atp%PAW%nbase
1416 [ + + ]: 36036 : atp%PAW%otphi(:,io)=atp%PAW%tphi(:,io)
1417 [ + + ]: 36036 : atp%PAW%ophi(:,io)=atp%PAW%phi(:,io)*atp%PAW%otphi(atp%PAW%irc,io)/atp%PAW%phi(atp%PAW%irc,io)
1418 [ + + ]: 10680 : atp%PAW%otphi(atp%PAW%irc:atp%Grid%n,io)=atp%PAW%ophi(atp%PAW%irc:atp%Grid%n,io)
1419 : 18 : atp%PAW%Kop(1,io)=zero
1420 : : atp%PAW%Kop(2:atp%Grid%n,io)=(atp%PAW%eig(io)-atp%Pot%rv(2:atp%Grid%n)/&
1421 [ + + ]: 36020 : & atp%Grid%r(2:atp%Grid%n))*atp%PAW%ophi(2:atp%Grid%n,io)
1422 : : enddo
1423 [ - + ]: 2 : LIBPAW_DEALLOCATE(map)
1424 : 2 : end subroutine makebasis_marsman
1425 : :
1426 : :
1427 : :
1428 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1429 : : !! marsman_tphi
1430 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1431 : 7 : subroutine marsman_tphi(atp,map,l_in,n)
1432 : : integer, intent(in) :: l_in
1433 : : integer, intent(in) :: n
1434 : : type(atompaw_type),intent(inout) :: atp
1435 : : integer, intent(in) :: map(atp%PAW%nbase)
1436 : : integer :: io,nodes,ii,match,irc
1437 : : integer :: io2,l2,jj,ioj,kk,l,ir,ir1
1438 : : real(dp):: energy,v0,v0p,zeroval
1439 : 7 : real(dp), allocatable :: ksi_i0(:,:),ksi_ij(:,:,:)
1440 : 7 : real(dp), allocatable :: ksi_i0_0(:),ksi_ij_0(:,:)
1441 : : REAL(dp), ALLOCATABLE :: p1(:),p2(:)
1442 : 7 : real(dp), allocatable :: AA(:,:), BB(:)
1443 : 14 : real(dp) :: dp1(atp%PAW%irc),dp2(atp%PAW%irc)
1444 : : real(dp) :: x1,y1,y2,a,b,c,r1,r2
1445 : : logical :: need_fit
1446 : 7 : irc=atp%PAW%irc
1447 : 7 : CALL zeropot(atp%Grid,atp%PAW%rveff,v0,v0p)
1448 [ - + + - : 21 : LIBPAW_ALLOCATE(p1,(atp%Grid%n))
+ - + - -
+ - + ]
1449 [ - + + - : 14 : LIBPAW_ALLOCATE(p2,(atp%Grid%n))
- + - + ]
1450 [ - + + - : 28 : LIBPAW_ALLOCATE(ksi_i0,(atp%Grid%n,n))
- + + - +
- + - - +
- + ]
1451 [ - + + - : 35 : LIBPAW_ALLOCATE(ksi_ij,(atp%Grid%n,n,n))
- + + - -
+ + - + -
+ - - + -
+ ]
1452 [ - + + - : 21 : LIBPAW_ALLOCATE(ksi_i0_0,(n))
+ - + - -
+ - + ]
1453 [ - + + - : 28 : LIBPAW_ALLOCATE(ksi_ij_0,(n,n))
- + + - +
- + - - +
- + ]
1454 [ + + + + ]: 36043 : ksi_i0=zero
1455 [ + + + + : 96121 : ksi_ij=zero
+ + ]
1456 : 7 : ii=0
1457 [ + + ]: 73 : do io=1,atp%PAW%nbase
1458 : 66 : l=atp%PAW%l(io)
1459 [ + + ]: 73 : if(l==l_in) then
1460 : 18 : ii=ii+1
1461 : 18 : energy=atp%PAW%eig(io)
1462 : 18 : CALL ClassicalTurningPoint(atp%Grid,atp%PAW%rveff,l,energy,match)
1463 [ + + ]: 18 : if(match>irc) match=2
1464 : : ! !! backward Not used anymore
1465 : : ! p2=zero
1466 : : ! p2(irc:atp%Grid%n)=atp%PAW%phi(irc:atp%Grid%n,io)
1467 : : ! CALL backward_numerov(atp%Grid,l,2,energy,atp%PAW%rveff,p2,nend=irc+1)
1468 : : !! forward
1469 [ + + ]: 36036 : p1=zero
1470 : 18 : p1(2)=wfninit(-0.5_dp*atp%PAW%rveff(1),l,v0,v0p,energy,atp%Grid%r(2))
1471 : 18 : zeroval=zero
1472 [ + + ]: 18 : IF (l==0) zeroval=atp%PAW%rveff(1)
1473 [ + + ]: 18 : IF (l==1) zeroval=2
1474 : 18 : CALL forward_numerov(atp%Grid,l,irc+5,energy,atp%PAW%rveff,zeroval,p1,nodes)!,p3val=p1(3))
1475 [ + + ]: 36036 : ksi_i0(:,ii)=p1(:)
1476 [ + + ]: 25392 : dp1=zero
1477 : 18 : call derivative(atp%grid,p1,dp1,1,irc)
1478 : : ! p2(2:size(p2))=p2(2:size(p2))*atp%grid%r(2:size(p2))**l_in
1479 : : ! call extrapolate(p2)
1480 : 18 : ksi_i0_0(ii)=dp1(irc)
1481 : 18 : jj=0
1482 [ + + ]: 198 : do io2=1,atp%PAW%nbase
1483 : 180 : l2=atp%PAW%l(io2)
1484 [ + + ]: 198 : if(l2==l) then
1485 : 48 : jj=jj+1
1486 : 48 : match=2
1487 : : ! p2=zero
1488 : : ! p2(irc:atp%Grid%n)=atp%PAW%phi(irc:atp%Grid%n,io)
1489 : : ! CALL backward_numerov(atp%Grid,l,match,energy,atp%PAW%rveff,p2,nend=irc+1,proj=atp%PAW%otp(:,io2))
1490 [ + + ]: 96096 : p1=zero
1491 : 48 : p1(2)=wfninit(-0.5_dp*atp%PAW%rveff(1),l,v0,v0p,energy,atp%Grid%r(2))
1492 : 48 : CALL forward_numerov(atp%Grid,l,irc+5,energy,atp%PAW%rveff,zeroval,p1,nodes,proj=atp%PAW%otp(:,io2))!,p3val=p1(3))
1493 [ + + ]: 96096 : ksi_ij(:,ii,jj)=p1(:)
1494 : : ! p2(2:size(p2))=p2(2:size(p2))*atp%grid%r(2:size(p2))**l_in
1495 : : ! call extrapolate(p2)
1496 [ + + ]: 67620 : dp1=zero
1497 : 48 : call derivative(atp%grid,p1,dp1,1,irc)
1498 : 48 : ksi_ij_0(ii,jj)=dp1(irc)
1499 : : endif
1500 : : enddo
1501 : : endif
1502 : : enddo
1503 [ + - - + : 28 : LIBPAW_ALLOCATE(AA,(n+1,n+1))
+ - - + +
- + - + -
- + - + ]
1504 [ - + + - : 21 : LIBPAW_ALLOCATE(BB,(n+1))
+ - + - -
+ - + ]
1505 [ + + ]: 73 : do ioj=1,atp%PAW%nbase
1506 : 66 : l=atp%PAW%l(ioj)
1507 [ + + ]: 73 : if(l==l_in) then
1508 : 18 : jj=map(ioj)
1509 [ + + + + ]: 330 : AA=zero
1510 [ + + ]: 84 : BB=zero
1511 : : ! get derivative of phi
1512 [ + + ]: 25392 : dp1=zero
1513 : 18 : call derivative(atp%grid,atp%PAW%phi(:,ioj),dp1,1,irc)
1514 : 18 : ii=0
1515 [ + + ]: 198 : do io=1,atp%PAW%nbase
1516 : 180 : l2=atp%PAW%l(io)
1517 [ + + ]: 198 : if(l==l2) then
1518 : 48 : ii=ii+1
1519 [ + + ]: 48 : if(ii==jj) BB(ii)=one
1520 [ + + ]: 96096 : p2(:)=ksi_i0(:,jj)*atp%PAW%otp(:,io)
1521 : 48 : AA(ii,n+1)=integrator(atp%Grid,p2)
1522 [ + + ]: 180 : do kk=1,n
1523 [ + + ]: 264264 : p2(:)=ksi_ij(:,jj,kk)*atp%PAW%otp(:,io)
1524 : 180 : AA(ii,kk)=integrator(atp%Grid,p2)
1525 : : enddo
1526 : : endif
1527 : : enddo
1528 [ + + ]: 66 : do kk=1,n
1529 : 66 : AA(n+1,kk)=ksi_ij_0(jj,kk)-dp1(irc)*ksi_ij(irc,jj,kk)/atp%PAW%phi(irc,ioj)
1530 : : enddo
1531 : 18 : AA(n+1,n+1)=ksi_i0_0(jj)-dp1(irc)*ksi_i0(irc,jj)/atp%PAW%phi(irc,ioj)
1532 : 18 : call SolveAXeqBM(n+1,AA,BB,n+1)
1533 [ + + ]: 36036 : atp%PAW%tphi(:,ioj)=zero
1534 [ + + ]: 66 : do kk=1,n
1535 [ + + ]: 96114 : atp%PAW%tphi(:,ioj)=atp%PAW%tphi(:,ioj)+BB(kk)*ksi_ij(:,jj,kk)
1536 : : enddo
1537 [ + + ]: 36036 : atp%PAW%tphi(:,ioj)=atp%PAW%tphi(:,ioj)+BB(n+1)*ksi_i0(:,jj)
1538 : : ! In some cases, numerical error => need to fit tail of the orbital
1539 : : ! Check if low lying orbital
1540 [ + + ]: 18 : if(atp%basis_func_rc(ioj)<atp%rc) then
1541 : : ! Check if tphi is close to 0 at irc
1542 [ + - - + : 4006 : if(abs(atp%PAW%tphi(irc,ioj))/maxval(abs(atp%PAW%tphi(:,ioj)))<tol2) then
- - + + -
+ ]
1543 : : ! Check if tphi is non-decreasing at irc
1544 : 0 : need_fit=.false.
1545 [ # # # # ]: 0 : call derivative(atp%grid,abs(atp%PAW%tphi(:,ioj)),dp2,1,irc)
1546 : 0 : ir1=FindGridIndex(atp%Grid,atp%basis_func_rc(ioj))
1547 [ # # ]: 0 : do ir=ir1,irc+5
1548 [ # # ]: 0 : if(dp2(ir)>zero) then
1549 : : need_fit=.true.
1550 : : exit
1551 : : endif
1552 : : enddo
1553 [ # # ]: 0 : if(need_fit) then
1554 : 0 : x1=atp%PAW%tphi(ir1,ioj)
1555 : 0 : call derivative(atp%grid,atp%PAW%tphi(:,ioj),dp2,1,ir1)
1556 : 0 : y1=dp2(ir1)/x1
1557 : 0 : call derivative(atp%grid,atp%PAW%phi(:,ioj),dp1,1,irc)
1558 : 0 : y2=dp1(irc)/atp%PAW%phi(irc,ioj)
1559 : 0 : r1=atp%grid%r(ir1)
1560 : 0 : r2=atp%grid%r(irc)
1561 : 0 : c=(y1-y2)/(one/r1-one/r2)
1562 : 0 : b=c/r1-y1
1563 : 0 : a=x1/(r1**c*exp(-b*r1))
1564 [ # # ]: 0 : do ir=ir1,irc+5
1565 : 0 : atp%PAW%tphi(ir,ioj)=a*atp%grid%r(ir)**c*exp(-b*atp%grid%r(ir))
1566 : : enddo
1567 : : endif
1568 : : endif
1569 : : endif
1570 : : endif
1571 : : enddo
1572 [ - + ]: 7 : LIBPAW_DEALLOCATE(AA)
1573 [ - + ]: 7 : LIBPAW_DEALLOCATE(BB)
1574 [ - + ]: 7 : LIBPAW_DEALLOCATE(p1)
1575 [ - + ]: 7 : LIBPAW_DEALLOCATE(p2)
1576 [ - + ]: 7 : LIBPAW_DEALLOCATE(ksi_i0)
1577 [ - + ]: 7 : LIBPAW_DEALLOCATE(ksi_ij)
1578 [ - + ]: 7 : LIBPAW_DEALLOCATE(ksi_i0_0)
1579 [ - + ]: 7 : LIBPAW_DEALLOCATE(ksi_ij_0)
1580 : 7 : end subroutine marsman_tphi
1581 : :
1582 : :
1583 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1584 : : !! calc_kij
1585 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1586 : 2 : subroutine calc_kij(PAW,grid,kij,pawtab,scalarrelativistic,needvtau)
1587 : : logical, intent(in) :: scalarrelativistic,needvtau
1588 : : type(gridinfo), intent(in) :: grid
1589 : : type(pseudoinfo), intent(in) :: PAW
1590 : : type(pawtab_type), intent(in) :: pawtab
1591 : : real(dp), intent(inout) :: kij(pawtab%lmn2_size)
1592 : : integer :: nbase,l,ib,jb
1593 : : integer :: jlmn,j0lmn,jlm,jln,ilmn,klmn,ilm,iln
1594 : : real(dp) :: x, y
1595 : 2 : nbase=PAW%nbase
1596 [ + + ]: 20 : DO ib=1,nbase
1597 : 18 : l=PAW%l(ib)
1598 [ + + ]: 200 : DO jb=1,nbase
1599 [ + + ]: 198 : IF (PAW%l(jb)==l) THEN
1600 [ + + ]: 48 : If (scalarrelativistic) then
1601 : 12 : call altdtij(Grid,PAW,ib,jb,x,needvtau)
1602 : : Else
1603 : : CALL deltakinetic_ij(Grid,PAW%ophi(:,ib),PAW%ophi(:,jb), &
1604 : 36 : & PAW%otphi(:,ib),PAW%otphi(:,jb),l,x,PAW%irc)
1605 : : Endif
1606 [ - + ]: 48 : if(has_to_print) WRITE(STD_OUT,'(" Kinetic ", 3i5, 1p,3e15.7)') ib,jb,l,x
1607 : 48 : PAW%Kij(ib,jb)=x
1608 : : ENDIF
1609 : : ENDDO
1610 : : ENDDO
1611 : : ! Average equivalent terms
1612 [ + + ]: 20 : DO ib=1,nbase
1613 [ + + ]: 119 : DO jb=ib,nbase
1614 [ + + ]: 117 : IF(jb>ib) THEN
1615 : 81 : x=PAW%Kij(ib,jb); y=PAW%Kij(jb,ib)
1616 : 81 : x=0.5_dp*(x+y)
1617 : 81 : PAW%Kij(ib,jb)=x; PAW%Kij(jb,ib)=x
1618 : : ENDIF
1619 : : ENDDO
1620 : : ENDDO
1621 : : ! convert from atompaw to libpaw
1622 [ + + ]: 1349 : kij=zero
1623 [ + + ]: 68 : do jlmn=1,pawtab%lmn_size
1624 : 66 : j0lmn=jlmn*(jlmn-1)/2
1625 : 66 : jlm=pawtab%indlmn(4,jlmn);jln=pawtab%indlmn(5,jlmn)
1626 [ + + ]: 1415 : do ilmn=1,jlmn
1627 : 1347 : klmn=j0lmn+ilmn
1628 : 1347 : ilm=pawtab%indlmn(4,ilmn);iln=pawtab%indlmn(5,ilmn)
1629 [ + + ]: 1413 : if (ilm==jlm) kij(klmn)=half*PAW%Kij(iln,jln) ! Conversion Ry->Ha
1630 : : enddo
1631 : : enddo
1632 : 2 : end subroutine calc_kij
1633 : :
1634 : :
1635 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1636 : : !! Prepare_Orbit
1637 : : !! Inspired from SCFatom_Init
1638 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1639 : 4 : SUBROUTINE Prepare_Orbit(atp,ii,jj)
1640 : : integer, intent(in) :: ii,jj
1641 : : type(atompaw_type), intent(inout) :: atp
1642 : : INTEGER :: icount,id,is,ip,jf,ig,io,l,nfix,kappa,i
1643 : : real(dp) :: xocc
1644 : 4 : INTEGER, ALLOCATABLE :: nl(:,:)
1645 : 4 : icount=0
1646 [ + + ]: 4 : if(.not.atp%diracrelativistic) then
1647 [ - + + - : 87 : LIBPAW_ALLOCATE(nl,(ii,jj));nl=0
- + + - +
- + - - +
- + + + +
+ ]
1648 [ + - ]: 3 : IF (atp%Orbit%nps.GT.0) THEN
1649 [ + + ]: 13 : DO is=1,atp%Orbit%nps
1650 : 10 : icount=icount+1
1651 : 10 : nl(is,1)=icount
1652 : 10 : atp%Orbit%occ(icount)=2._dp
1653 : 10 : atp%Orbit%np(icount)=is
1654 : 10 : atp%Orbit%l(icount)=0
1655 [ + + ]: 13 : if(atp%orbit_iscore(icount)) atp%npsc=is
1656 : : ENDDO
1657 : : ENDIF
1658 [ + - ]: 3 : IF (atp%Orbit%npp.GT.1) THEN
1659 [ + + ]: 9 : DO ip=2,atp%Orbit%npp
1660 : 6 : icount=icount+1
1661 : 6 : nl(ip,2)=icount
1662 : 6 : atp%Orbit%occ(icount)=6._dp
1663 : 6 : atp%Orbit%np(icount)=ip
1664 : 6 : atp%Orbit%l(icount)=1
1665 [ + + ]: 9 : if(atp%orbit_iscore(icount)) atp%nppc=ip
1666 : : ENDDO
1667 : : ENDIF
1668 [ + + ]: 3 : IF (atp%Orbit%npd.GT.2) THEN
1669 [ + + ]: 2 : DO id=3,atp%Orbit%npd
1670 : 1 : icount=icount+1
1671 : 1 : nl(id,3)=icount
1672 : 1 : atp%Orbit%occ(icount)=10._dp
1673 : 1 : atp%Orbit%np(icount)=id
1674 : 1 : atp%Orbit%l(icount)=2
1675 [ - + ]: 2 : if(atp%orbit_iscore(icount)) atp%npdc=id
1676 : : ENDDO
1677 : : ENDIF
1678 [ - + ]: 3 : IF (atp%Orbit%npf.GT.3) THEN
1679 [ # # ]: 0 : DO jf=4,atp%Orbit%npf
1680 : 0 : icount=icount+1
1681 : 0 : nl(jf,4)=icount
1682 : 0 : atp%Orbit%occ(icount)=14._dp
1683 : 0 : atp%Orbit%np(icount)=jf
1684 : 0 : atp%Orbit%l(icount)=3
1685 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npfc=jf
1686 : : ENDDO
1687 : : ENDIF
1688 [ - + ]: 3 : IF(atp%Orbit%npg.GT.4) THEN
1689 [ # # ]: 0 : DO ig=5,atp%Orbit%npg
1690 : 0 : icount=icount+1
1691 : 0 : nl(ig,5)=icount
1692 : 0 : atp%Orbit%occ(icount)=18._dp
1693 : 0 : atp%Orbit%np(icount)=ig
1694 : 0 : atp%Orbit%l(icount)=4
1695 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npgc=ig
1696 : : ENDDO
1697 : : ENDIF
1698 : 3 : atp%Orbit%norbit=icount
1699 [ - + ]: 3 : if(has_to_print) write(std_out,*)' Below are listed the default occupations '
1700 [ - + ]: 3 : if(has_to_print) write(std_out,"(' n l occupancy')")
1701 [ + + ]: 20 : DO io=1,atp%Orbit%norbit
1702 [ - + ]: 17 : if(has_to_print) WRITE(std_out,'(i2,1x,i2,4x,1p,1e15.7)') &
1703 : 3 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%occ(io)
1704 : : ENDDO
1705 [ + + ]: 20 : atp%Orbit%iscore=atp%orbit_iscore
1706 [ + + ]: 7 : DO io=1,atp%norbit_mod
1707 : 4 : l=atp%orbit_mod_l(io)
1708 : 4 : ip=atp%orbit_mod_n(io)
1709 : 4 : xocc=atp%orbit_mod_occ(io)
1710 : 4 : nfix=nl(ip,l+1)
1711 [ + - - + ]: 4 : IF (nfix<=0.OR.nfix>atp%Orbit%norbit) THEN
1712 : 0 : LIBPAW_ERROR('error in occupations')
1713 : : ENDIF
1714 : 7 : atp%Orbit%occ(nfix)=xocc
1715 : : END DO
1716 [ - + ]: 3 : if(has_to_print) WRITE(STD_OUT,*) ' Corrected occupations are: '
1717 [ - + ]: 3 : if(has_to_print) WRITE(STD_OUT,"(' n l occupancy')")
1718 : 3 : atp%electrons=0._dp
1719 [ + + ]: 20 : DO io=1,atp%Orbit%norbit
1720 [ - + ]: 17 : if(has_to_print) WRITE(STD_OUT,'(i2,1x,i2,4x,1p,1e15.7)') &
1721 : 0 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%occ(io)
1722 : 17 : atp%electrons=atp%electrons+atp%Orbit%occ(io)
1723 [ + + ]: 20 : if(.not.atp%Orbit%iscore(io)) atp%Orbit%qval=atp%Orbit%qval+atp%Orbit%occ(io)
1724 : : ENDDO
1725 : : ENDIF ! scalarrelativistic
1726 : :
1727 [ + + ]: 4 : If (atp%diracrelativistic) then
1728 : 1 : i=MAX(atp%Orbit%nps,atp%Orbit%npp,atp%Orbit%npd,atp%Orbit%npf,atp%Orbit%npg)
1729 [ - + + - : 3 : LIBPAW_ALLOCATE(nl,(i,-5:5))
+ - + - -
+ - + -
+ ]
1730 [ + + + + ]: 56 : nl=0
1731 [ + - ]: 1 : IF (atp%Orbit%nps.GT.0) THEN
1732 [ + + ]: 5 : DO is=1,atp%Orbit%nps
1733 : 4 : icount=icount+1
1734 : 4 : nl(is,-1)=icount
1735 : 4 : atp%Orbit%occ(icount)=2._dp
1736 : 4 : atp%Orbit%np(icount)=is
1737 : 4 : atp%Orbit%l(icount)=0
1738 : 4 : atp%Orbit%kappa(icount)=-1
1739 [ + + ]: 5 : if(atp%orbit_iscore(icount)) atp%npsc=is
1740 : : ENDDO
1741 : : ENDIF
1742 [ + - ]: 1 : IF (atp%Orbit%npp.GT.1) THEN
1743 [ + + ]: 3 : DO ip=2,atp%Orbit%npp
1744 : 2 : icount=icount+1
1745 : 2 : nl(ip,1)=icount
1746 : 2 : atp%Orbit%occ(icount)=2._dp
1747 : 2 : atp%Orbit%np(icount)=ip
1748 : 2 : atp%Orbit%l(icount)=1
1749 : 2 : atp%Orbit%kappa(icount)=1
1750 [ + + ]: 3 : if(atp%orbit_iscore(icount)) atp%nppc=ip
1751 : : ENDDO
1752 [ + + ]: 3 : DO ip=2,atp%Orbit%npp
1753 : 2 : icount=icount+1
1754 : 2 : nl(ip,-2)=icount
1755 : 2 : atp%Orbit%occ(icount)=4._dp
1756 : 2 : atp%Orbit%np(icount)=ip
1757 : 2 : atp%Orbit%l(icount)=1
1758 : 2 : atp%Orbit%kappa(icount)=-2
1759 [ + + ]: 3 : if(atp%orbit_iscore(icount)) atp%nppc=ip
1760 : : ENDDO
1761 : : ENDIF
1762 [ + - ]: 1 : IF (atp%Orbit%npd.GT.2) THEN
1763 [ + + ]: 2 : DO id=3,atp%Orbit%npd
1764 : 1 : icount=icount+1
1765 : 1 : nl(id,2)=icount
1766 : 1 : atp%Orbit%occ(icount)=4._dp
1767 : 1 : atp%Orbit%np(icount)=id
1768 : 1 : atp%Orbit%l(icount)=2
1769 : 1 : atp%Orbit%kappa(icount)=2
1770 [ - + ]: 2 : if(atp%orbit_iscore(icount)) atp%npdc=id
1771 : : ENDDO
1772 [ + + ]: 2 : DO id=3,atp%Orbit%npd
1773 : 1 : icount=icount+1
1774 : 1 : nl(id,-3)=icount
1775 : 1 : atp%Orbit%occ(icount)=6._dp
1776 : 1 : atp%Orbit%np(icount)=id
1777 : 1 : atp%Orbit%l(icount)=2
1778 : 1 : atp%Orbit%kappa(icount)=-3
1779 [ - + ]: 2 : if(atp%orbit_iscore(icount)) atp%npdc=id
1780 : : ENDDO
1781 : : ENDIF
1782 [ - + ]: 1 : IF (atp%Orbit%npf.GT.3) THEN
1783 [ # # ]: 0 : DO jf=4,atp%Orbit%npf
1784 : 0 : icount=icount+1
1785 : 0 : nl(jf,3)=icount
1786 : 0 : atp%Orbit%occ(icount)=6._dp
1787 : 0 : atp%Orbit%np(icount)=jf
1788 : 0 : atp%Orbit%l(icount)=3
1789 : 0 : atp%Orbit%kappa(icount)=3
1790 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npfc=jf
1791 : : ENDDO
1792 [ # # ]: 0 : DO jf=4,atp%Orbit%npf
1793 : 0 : icount=icount+1
1794 : 0 : nl(jf,-4)=icount
1795 : 0 : atp%Orbit%occ(icount)=8._dp
1796 : 0 : atp%Orbit%np(icount)=jf
1797 : 0 : atp%Orbit%l(icount)=3
1798 : 0 : atp%Orbit%kappa(icount)=-4
1799 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npfc=jf
1800 : : ENDDO
1801 : : ENDIF
1802 [ - + ]: 1 : IF(atp%Orbit%npg.GT.4) THEN
1803 [ # # ]: 0 : DO ig=5,atp%Orbit%npg
1804 : 0 : icount=icount+1
1805 : 0 : nl(ig,4)=icount
1806 : 0 : atp%Orbit%occ(icount)=8._dp
1807 : 0 : atp%Orbit%np(icount)=ig
1808 : 0 : atp%Orbit%l(icount)=4
1809 : 0 : atp%Orbit%kappa(icount)=4
1810 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npgc=ig
1811 : : ENDDO
1812 [ # # ]: 0 : DO ig=5,atp%Orbit%npg
1813 : 0 : icount=icount+1
1814 : 0 : nl(ig,-5)=icount
1815 : 0 : atp%Orbit%occ(icount)=10._dp
1816 : 0 : atp%Orbit%np(icount)=ig
1817 : 0 : atp%Orbit%l(icount)=4
1818 : 0 : atp%Orbit%kappa(icount)=-5
1819 [ # # ]: 0 : if(atp%orbit_iscore(icount)) atp%npgc=ig
1820 : : ENDDO
1821 : : ENDIF
1822 : 1 : atp%Orbit%norbit=icount
1823 [ - + ]: 1 : if(has_to_print) write(std_out,*)' Below are listed the default occupations '
1824 [ - + ]: 1 : if(has_to_print) write(std_out,"(' n l kappa occupancy')")
1825 [ + + ]: 11 : DO io=1,atp%Orbit%norbit
1826 [ - + ]: 10 : if(has_to_print) write(std_out,'(i2,1x,i2,3x,i2,4x,1p,1e15.7)') &
1827 : 1 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%kappa(io),atp%Orbit%occ(io)
1828 : : ENDDO
1829 : : !Corrected occupations (from input dataset)
1830 [ + + ]: 11 : atp%Orbit%iscore=atp%orbit_iscore
1831 [ + + ]: 4 : DO io=1,atp%norbit_mod
1832 : 3 : l=atp%orbit_mod_l(io)
1833 : 3 : ip=atp%orbit_mod_n(io)
1834 : 3 : kappa=atp%orbit_mod_k(io)
1835 : 3 : xocc=atp%orbit_mod_occ(io)
1836 : 3 : nfix=nl(ip,kappa)
1837 [ + - - + ]: 3 : IF (nfix<=0.OR.nfix>atp%Orbit%norbit) THEN
1838 : 0 : WRITE(STD_OUT,*) 'error in occupations -- ip,l,kappa,xocc:',&
1839 : 0 : & ip,l,kappa,xocc,nfix,atp%Orbit%norbit
1840 : 0 : STOP
1841 : : ENDIF
1842 : 4 : atp%Orbit%occ(nfix)=xocc
1843 : : END DO
1844 [ - + ]: 1 : if(has_to_print)WRITE(STD_OUT,*) ' Corrected occupations are: '
1845 [ - + ]: 1 : if(has_to_print) WRITE(STD_OUT,"(' n l kappa occupancy')")
1846 : 1 : atp%electrons=0.0_dp
1847 [ + + ]: 11 : DO io=1,atp%Orbit%norbit
1848 [ - + ]: 10 : if(has_to_print) WRITE(STD_OUT,'(i2,1x,i2,3x,i2,4x,1p,1e15.7)') &
1849 : 0 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%kappa(io),atp%Orbit%occ(io)
1850 : 10 : atp%electrons=atp%electrons+atp%Orbit%occ(io)
1851 [ + + ]: 11 : if(.not.atp%Orbit%iscore(io)) atp%Orbit%qval=atp%Orbit%qval+atp%Orbit%occ(io)
1852 : : ENDDO
1853 : : ENDIF ! completed occupations
1854 [ - + ]: 4 : LIBPAW_DEALLOCATE(nl)
1855 : 4 : end subroutine Prepare_Orbit
1856 : :
1857 : :
1858 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1859 : : !! subroutine print_atompaw_params(atp)
1860 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1861 : 4 : subroutine print_check_atompaw_params(atp)
1862 : : type(atompaw_type),intent(in) :: atp
1863 : : integer :: norb,io
1864 [ + + - + ]: 4 : if(atp%scalarrelativistic.and.atp%tpaw_mode>1) then
1865 : 0 : LIBPAW_ERROR('tpaw_mode>1 and scalarrelativistic not compatible')
1866 : : endif
1867 [ - + ]: 4 : if(atp%finitenucleus) then
1868 : 0 : LIBPAW_ERROR('Finitenucleus not implemented')
1869 : : endif
1870 [ - + ]: 4 : if(atp%HFpostprocess) then
1871 : 0 : LIBPAW_ERROR('HFpostprocess not implemented')
1872 : : endif
1873 [ - + ]: 4 : if(atp%localizedcoreexchange) then
1874 : 0 : LIBPAW_ERROR('Localized core exchange not implemented')
1875 : : endif
1876 [ - + ]: 4 : if(atp%BDsolve) then
1877 : 0 : LIBPAW_ERROR('BD solver not implemented')
1878 : : endif
1879 [ - + ]: 4 : if(atp%fixed_zero) then
1880 : 0 : LIBPAW_ERROR('Fixed zero not implemented')
1881 : : endif
1882 [ - + ]: 4 : if(atp%shapetcore) then
1883 : 0 : LIBPAW_ERROR('Shapetcore not implemented')
1884 : : endif
1885 [ - + ]: 4 : if(atp%ColleSalvetti) then
1886 : 0 : LIBPAW_ERROR('ColleSalvetti not implemented')
1887 : : endif
1888 [ - + ]: 4 : if(.not.atp%ortho_type==ORTHO_TYPE_VANDERBILT) then
1889 : 0 : LIBPAW_ERROR('RCPAW only possible with Vanderbilt ortho scheme')
1890 : : endif
1891 [ - + ]: 4 : if(has_to_print) then
1892 : 0 : WRITE(STD_OUT,'(/,3x,a)') "===== Atompaw parameters ====="
1893 : : ! Atom
1894 : 0 : WRITE(STD_OUT,'(3x,a,a2)') "Atomic symbol : ",atp%atomic_symbol
1895 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Atomic charge : ",atp%atomic_charge
1896 : : ! Algo
1897 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Scalar-relativistic calculation:",MERGE("YES"," NO",atp%scalarrelativistic)
1898 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Dirac-relativistic calculation:",MERGE("YES"," NO",atp%diracrelativistic)
1899 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Frozen core calculation:",MERGE("YES"," NO",atp%frozencorecalculation)
1900 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Frozen vale calculation:",MERGE("YES"," NO",atp%frozenvalecalculation)
1901 [ # # ]: 0 : IF (atp%usespline) THEN
1902 : 0 : WRITE(STD_OUT,'(3x,a)') " - Use a spline solver"
1903 : : END IF
1904 : 0 : WRITE(STD_OUT,'(3x,2a)') "Exchange-correlation functional:",TRIM(atp%exctype)
1905 [ # # ]: 0 : WRITE(STD_OUT,'(3x,3a)') " (mGGA kinetic energy functional:",MERGE("YES"," NO",atp%needvtau),")"
1906 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Finite-nucleus calculation:",MERGE("YES"," NO",atp%finitenucleus)
1907 [ # # ]: 0 : IF (atp%finitenucleus) THEN
1908 : 0 : WRITE(STD_OUT,'(3x,a,i0)') " - Finite-nucleus model:",atp%finitenucleusmodel
1909 : : END IF
1910 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Block-Davidson calculation:",MERGE("YES"," NO",atp%BDsolve)
1911 : : ! Grid
1912 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Grid type:",atp%Grid%type
1913 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Grid size:",atp%Grid%n
1914 : 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Grid maximum value:",atp%Grid%r(atp%Grid%n)
1915 [ # # ]: 0 : if(atp%usespline) then
1916 : 0 : WRITE(STD_OUT,'(3x,a,f7.3,2x,i0)') "Spline grid r0, ns :",&
1917 : 0 : & atp%splr0,atp%splns
1918 : : endif
1919 : : ! XC
1920 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, post-processing:",MERGE("YES"," NO",atp%HFpostprocess)
1921 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, localized coreex.:",MERGE("YES"," NO",atp%localizedcoreexchange)
1922 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, fixed zero:",MERGE("YES"," NO",atp%fixed_zero)
1923 [ # # ]: 0 : IF (atp%fixed_zero) THEN
1924 : 0 : WRITE(STD_OUT,'(3x,a,i0)') " - HF fixed zero index:",atp%fixed_zero_index
1925 : : END IF
1926 [ # # # # ]: 0 : IF (atp%BDsolve.and.atp%gridkey=='LINEAR') THEN
1927 : 0 : WRITE(STD_OUT,'(/,3x,a)') "WARNING: BlockDavidson solver works very slowlywith linear grid!"
1928 : : END IF
1929 : 0 : WRITE(STD_OUT,'(3x,a,5(1x,i0))') "Max. quantum numbers (s,p,d,f,g):",atp%np(1:5)
1930 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of orbitals: ",atp%norbit
1931 : 0 : WRITE(STD_OUT,'(3x,a)') "Core and valence orbitals:"
1932 [ # # ]: 0 : IF (.NOT.atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') "n l : type"
1933 [ # # ]: 0 : IF (atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') "n l kappa :type"
1934 : : ! io=0
1935 : : ! DO ll=0,4
1936 : : ! nn=atp%np(ll+1)
1937 : : ! IF (nn>0) THEN
1938 : : ! IF (.NOT.atp%diracrelativistic) THEN
1939 : : ! DO ii=1+ll,nn
1940 : : ! io=io+1
1941 : : ! WRITE(STD_OUT,'(7x,i1,1x,i1,2a)') ii,ll," : ", &
1942 : : !& MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
1943 : : ! END DO
1944 : : ! ELSE
1945 : : ! DO ik=1,nkappa(ll+1)
1946 : : ! kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
1947 : : ! DO ii=1+ll,nn
1948 : : ! io=io+1
1949 : : ! WRITE(STD_OUT,'(7x,i1,1x,i1,2x,i2,2x,2a)') ii,ll,kk," : ", &
1950 : : ! & MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
1951 : : ! END DO
1952 : : ! END DO
1953 : : ! END IF
1954 : : ! END IF
1955 : : ! END DO
1956 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Basis, maximum L : ",atp%lmax
1957 : : !cutoff radii
1958 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Augmentation region radius : ",atp%rc
1959 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Core dens. matching radius : ",atp%rc_core
1960 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Local pot. matching radius : ",atp%rc_vloc
1961 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Compens. shape func radius : ",atp%rc_shap
1962 : : !Additional basis
1963 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Initial number of basis functions:",atp%nbasis-atp%nbasis_add
1964 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Number of additional basis functions:",atp%nbasis_add
1965 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of basis functions:",atp%nbasis
1966 : 0 : WRITE(STD_OUT,'(3x,a)') "Additional basis functions:"
1967 [ # # ]: 0 : IF (.NOT.atp%diracrelativistic) THEN
1968 : 0 : WRITE(STD_OUT,'(7x,a)') "l : energy"
1969 [ # # ]: 0 : DO io=1,atp%nbasis_add
1970 : 0 : WRITE(STD_OUT,'(7x,i1,a,f7.4)') atp%basis_add_l(io),":",atp%basis_add_energy(io)
1971 : : END DO
1972 : : ELSE
1973 : 0 : WRITE(STD_OUT,'(7x,a)') "l kappa : energy"
1974 [ # # ]: 0 : DO io=1,atp%nbasis_add
1975 : 0 : WRITE(STD_OUT,'(7x,i1,2x,i2,2x,a,f7.4)') atp%basis_add_l(io), &
1976 : 0 : & atp%basis_add_k(io)," : " ,atp%basis_add_energy(io)
1977 : : END DO
1978 : : END IF
1979 : : !Projectors
1980 : 0 : WRITE(STD_OUT,'(3x,a)') "Projectors description:"
1981 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_BLOECHL) &
1982 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : BLOECHL"
1983 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_VANDERBILT) &
1984 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : VANDERBILT"
1985 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_MODRRKJ) &
1986 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : MODRRKJ"
1987 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_CUSTOM) &
1988 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : CUSTOM"
1989 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_HF) &
1990 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : HARTREE-FOCK"
1991 [ # # ]: 0 : IF (atp%projector_type/=PROJECTOR_TYPE_HF) THEN
1992 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL) &
1993 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL"
1994 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM) &
1995 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : POLYNOM"
1996 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_RRKJ) &
1997 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : RRKJ"
1998 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
1999 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL KERKER"
2000 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM2) &
2001 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,es9.3)') "Pseudization : POLYNOM2,pdeg=",&
2002 : 0 : & atp%pseudo_polynom2_pdeg,", qcut=",atp%pseudo_polynom2_qcut
2003 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_GRAMSCHMIDT) &
2004 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : GRAM-SCHMIDT"
2005 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_VANDERBILT) &
2006 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : VANDERBILT"
2007 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_SVD) &
2008 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : SVD"
2009 : : END IF
2010 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_GAUSSIAN) &
2011 : 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Compensation charge shape function: GAUSSIAN,tol=",&
2012 : 0 : & atp%shapefunc_gaussian_param
2013 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_SINC) &
2014 : 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : SINC2"
2015 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_BESSEL) &
2016 : 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : BESSEL"
2017 [ # # ]: 0 : IF (atp%hf_coretol>0) &
2018 : 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Core tolerance for Hartree-Fock:",atp%hf_coretol
2019 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Smooth tcore shape (no negative nhat):",MERGE("YES"," NO",atp%shapetcore)
2020 : : !Local Psp
2021 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER) &
2022 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type:MTROULLIER,l=",&
2023 : 0 : & atp%vloc_l,", energy=",atp%vloc_ene
2024 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_ULTRASOFT) &
2025 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type:ULTRASOFT,l=",&
2026 : 0 : & atp%vloc_l,", energy=",atp%vloc_ene
2027 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_BESSEL) &
2028 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : BESSEL"
2029 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNC) &
2030 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
2031 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNNC) &
2032 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNNC"
2033 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_SETVLOC) THEN
2034 : 0 : WRITE(STD_OUT,'(7x,a,es9.4,a,es9.4)') "Local pseudopotential type:SETVLOC,coef=",&
2035 : 0 : & atp%vloc_setvloc_coef,", rad=",atp%vloc_setvloc_rad
2036 [ # # ]: 0 : IF (atp%needvtau) THEN
2037 : 0 : LIBPAW_ERROR('SETVLOC option not available for MGGA')
2038 : : ENDIF
2039 : : ENDIF
2040 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_EXPF) &
2041 : 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER EXPF,powers=",&
2042 : 0 : & atp%vloc_kerker_power(1:4)
2043 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_POLY) &
2044 : 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER POLY,powers=",&
2045 : 0 : & atp%vloc_kerker_power(1:4)
2046 [ # # # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.AND.atp%needvtau) THEN
2047 : 0 : WRITE(STD_OUT,'(7x,a)') 'NOTE: MTROULLIER Vloc not available for mGGA!'
2048 : 0 : WRITE(STD_OUT,'(7x,a)') ' Calling VPSmatch with norm conservation instead.'
2049 : 0 : WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
2050 : : END IF
2051 : 0 : WRITE(STD_OUT,'(3x,a)') "Matching radius for basis functions:"
2052 [ # # ]: 0 : IF (.NOT.atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') " # - n l : radius"
2053 [ # # ]: 0 : IF (atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') " # - n l kappa :radius"
2054 : : norb=0
2055 : : ! DO ll=0,atp%lmax
2056 : : ! DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic)
2057 : : ! kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
2058 : : ! IF (.NOT.atp%diracrelativistic) kk=0
2059 : : ! DO io=1,atp%norbit_val
2060 : : ! IF (atp%orbit_val_l(io)==ll.AND. &
2061 : : ! & ((.NOT.atp%diracrelativistic).OR.atp%orbit_val_k(io)==kk))THEN
2062 : : ! norb=norb+1
2063 : : ! IF (.NOT.atp%diracrelativistic) &
2064 : : ! & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,a,f7.4)') &
2065 : : ! & norb," - ",atp%orbit_val_n(io),ll," :",atp%basis_func_rc(norb)
2066 : : ! IF (atp%diracrelativistic) &
2067 : : ! & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,2x,i2,2x,a,f7.4)') &
2068 : : ! & norb," - ",atp%orbit_val_n(io),ll,kk," :",atp%basis_func_rc(norb)
2069 : : ! END IF
2070 : : ! END DO
2071 : : ! IF (atp%nbasis_add>0) THEN
2072 : : ! DO io=1,atp%nbasis_add
2073 : : ! IF (atp%basis_add_l(io)==ll.AND. &
2074 : : ! & ((.NOT.atp%diracrelativistic).OR.atp%basis_add_k(io)==kk))THEN
2075 : : ! norb=norb+1
2076 : : ! IF (.NOT.atp%diracrelativistic) &
2077 : : ! & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,a,f7.4)') &
2078 : : ! & norb," - ",".",ll," : ",atp%basis_func_rc(norb)
2079 : : ! IF (atp%diracrelativistic) &
2080 : : ! & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,2x,i2,2x,a,f7.4)') &
2081 : : ! & norb," - ",".",ll,kk," : ",atp%basis_func_rc(norb)
2082 : : ! END IF
2083 : : ! END DO
2084 : : ! END IF
2085 : : ! END DO
2086 : : ! END DO
2087 : : endif
2088 : 4 : end subroutine print_check_atompaw_params
2089 : :
2090 : :
2091 : :
2092 : :
2093 : :
2094 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2095 : : ! 1. aeatom
2096 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2097 : :
2098 : :
2099 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2100 : : !! Potential_Init
2101 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2102 : 23 : SUBROUTINE Potential_Init(Orbit,Pot,Grid)
2103 : : IMPLICIT NONE
2104 : : TYPE(OrbitInfo),INTENT(IN) :: Orbit
2105 : : TYPE(PotentialInfo),INTENT(INOUT) :: Pot
2106 : : TYPE(GridInfo),INTENT(IN) :: Grid
2107 : : real(dp) :: ecoul,v0
2108 : 23 : CALL atompaw_poisson(Grid,Pot%q,Orbit%den,Pot%rvh,ecoul,v0)
2109 [ - + ]: 23 : if(has_to_print) write(std_out,*) 'In Potential_Init', Pot%q,ecoul
2110 : 23 : END SUBROUTINE Potential_Init
2111 : :
2112 : :
2113 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2114 : : !! SCFatom
2115 : : !! Main atomic SCF routine to calculate the all electron atomic solution.
2116 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2117 : 23 : subroutine SCFatom(atp,initialize)
2118 : : implicit none
2119 : : logical, intent(in) :: initialize
2120 : : type(atompaw_type),target, intent(inout) :: atp
2121 [ + + ]: 23 : if(initialize) then
2122 : 4 : call Orbit_Init(atp%Orbit,atp%Pot,atp)
2123 : : endif
2124 : 23 : call Potential_Init(atp%Orbit,atp%Pot,atp%Grid)
2125 [ + + ]: 23 : if(atp%Orbit%frozenvalecalculation) atp%Pot%q=atp%electrons
2126 : 23 : call LDAGGA_SCF(atp)
2127 : 23 : end subroutine SCFatom
2128 : :
2129 : :
2130 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2131 : : !! Orbit_Init
2132 : : !! From nuclear charge -- generate hydrogenic-like initial wfns
2133 : : !! and densities --
2134 : : !! fill AEOrbit%wfn, AEOrbit%eig, and AEOrbit%den and AEOrbit%q
2135 : : !! also AEOrbit%otau and AEOrbit%tau
2136 : : !! Note that both den and tau need to be divided by 4 \pi r^2
2137 : : !! Note that tau is only correct for non-relativistic case
2138 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2139 : 4 : SUBROUTINE Orbit_Init(Orbit,Pot,atp)
2140 : : IMPLICIT NONE
2141 : : TYPE(PotentialInfo),INTENT(INOUT) :: Pot
2142 : : TYPE(OrbitInfo),INTENT(INOUT) :: Orbit
2143 : : type(atompaw_type), intent(in) :: atp
2144 : : INTEGER :: io,ir,l,np,kappa
2145 : : real(dp) :: qcal,rescale,zeff,xocc,fpi
2146 : 4 : REAL(dp),allocatable :: d(:)
2147 : : INTEGER :: initialconfig=0
2148 [ - + ]: 4 : IF (initialconfig/=0) STOP 'Error in aeatom -- Orbit_Init already called'
2149 : : ! calculate initial charge density from hydrogen-like functions
2150 : : ! also initial energies
2151 : 4 : zeff=Pot%nz
2152 [ + + ]: 4 : If (.not.atp%diracrelativistic) then
2153 [ + + ]: 20 : DO io=1,Orbit%norbit
2154 [ - + - - ]: 17 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
2155 : 17 : np=Orbit%np(io)
2156 : 17 : l=Orbit%l(io)
2157 : 17 : xocc=Orbit%occ(io)
2158 [ + - ]: 17 : if(.not.Orbit%frozenvalecalculation) Orbit%eig(io)=-(zeff/(np))**2!/2.0!Hartree
2159 [ - + ]: 17 : if(has_to_print) WRITE(std_out,*) io,np,l,xocc,Orbit%eig(io),zeff
2160 [ + + ]: 34034 : DO ir=1,atp%Grid%n
2161 : 34017 : Orbit%wfn(ir,io)=hwfn(zeff,np,l,atp%Grid%r(ir))
2162 [ + + ]: 34034 : IF (ABS(Orbit%wfn(ir,io))<machine_zero) Orbit%wfn(ir,io)=0._dp
2163 : : ENDDO
2164 : 17 : zeff=zeff-0.5_dp*xocc
2165 : 20 : zeff=MAX(zeff,1._dp)
2166 : : ENDDO
2167 : : endif
2168 [ + + ]: 4 : If (atp%diracrelativistic) then
2169 [ + + ]: 11 : DO io=1,Orbit%norbit
2170 [ - + - - ]: 10 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
2171 : 10 : np=Orbit%np(io)
2172 : 10 : l=Orbit%l(io)
2173 : 10 : kappa=Orbit%kappa(io)
2174 : 10 : xocc=Orbit%occ(io)
2175 [ + - ]: 10 : if(.not.Orbit%frozenvalecalculation) Orbit%eig(io)=-(zeff/(np))**2!/2.0
2176 [ + + ]: 20020 : DO ir=1,atp%Grid%n
2177 : : call dirachwfn(np,kappa,zeff,atp%Grid%r(ir),Orbit%eig(io) &
2178 : 20010 : & ,Orbit%wfn(ir,io),Orbit%lwfn(ir,io))
2179 [ + + ]: 20010 : IF (ABS(Orbit%wfn(ir,io))<machine_zero) Orbit%wfn(ir,io)=0._dp
2180 [ + + ]: 20020 : IF (ABS(Orbit%lwfn(ir,io))<machine_zero) Orbit%lwfn(ir,io)=0._dp
2181 : : ENDDO
2182 : 10 : zeff=zeff-0.5_dp*xocc
2183 : 11 : zeff=MAX(zeff,1._dp)
2184 : : ENDDO
2185 : : endif
2186 : : ! check charge and rescale
2187 [ + + ]: 8008 : Orbit%den=0._dp
2188 [ + + ]: 8008 : Orbit%tau=0._dp
2189 [ + + ]: 31 : DO io=1,Orbit%norbit
2190 [ - + - - ]: 27 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
2191 : : CALL taufromwfn(Orbit%otau(:,io),atp%Grid,Orbit%wfn(:,io),Orbit%l(io),&
2192 : 27 : & energy=Orbit%eig(io),rPot=Pot%rv)
2193 : 27 : xocc=Orbit%occ(io)
2194 [ + + ]: 54058 : DO ir=1,atp%Grid%n
2195 : 54027 : Orbit%den(ir)=Orbit%den(ir)+(Orbit%wfn(ir,io)**2)*xocc
2196 : 54027 : Orbit%tau(ir)=Orbit%tau(ir)+xocc*Orbit%otau(ir,io)
2197 [ + + ]: 54027 : If (atp%diracrelativistic) Orbit%den(ir)=Orbit%den(ir) + &
2198 : 20037 : & xocc*((Orbit%lwfn(ir,io))**2)
2199 : : ENDDO
2200 : : ENDDO
2201 : : ! Note that kinetic energy density (tau) is in Rydberg units ???
2202 : : ! Note that kinetic energy density is only correct for non-relativistic
2203 : : ! formulation
2204 : 4 : qcal=integrator(atp%Grid,Orbit%den)
2205 [ - + ]: 4 : if(Orbit%frozenvalecalculation) qcal=qcal+atp%Orbit%qval
2206 [ - + - - ]: 4 : if(Orbit%frozenvalecalculation) Orbit%den=Orbit%den+Orbit%valeden
2207 : : !rescale density
2208 : 4 : rescale=atp%electrons/qcal
2209 [ + + ]: 8008 : Orbit%den(1:atp%Grid%n)=Orbit%den(1:atp%Grid%n)*rescale
2210 [ + + ]: 8008 : Orbit%tau(1:atp%Grid%n)=Orbit%tau(1:atp%Grid%n)*rescale
2211 : : ! determine difference with tauW (Weizsaker)
2212 [ - + + - : 12 : LIBPAW_ALLOCATE(d,(atp%Grid%n)); fpi=4*pi
+ - + - -
+ - + ]
2213 [ + + ]: 8004 : d(2:atp%Grid%n)=Orbit%den(2:atp%Grid%n)/(fpi*atp%Grid%r(2:atp%Grid%n)**2)
2214 : 4 : call extrapolate(d)
2215 : 4 : CALL derivative(atp%Grid,d,Orbit%deltatau)
2216 [ + + ]: 8008 : Do ir=1,atp%Grid%n
2217 [ + + ]: 8008 : if (d(ir)>machine_zero) then
2218 : 6639 : Orbit%deltatau(ir)=0.25_dp*(Orbit%deltatau(ir)**2)/d(ir)
2219 : : else
2220 : 1365 : Orbit%deltatau(ir)=0.0_dp
2221 : : endif
2222 : : enddo
2223 [ + + ]: 8004 : d(2:atp%Grid%n)=Orbit%tau(2:atp%Grid%n)/(fpi*atp%Grid%r(2:atp%Grid%n)**2)
2224 : 4 : call extrapolate(d)
2225 [ + + ]: 8008 : Orbit%deltatau=d-Orbit%deltatau
2226 [ - + ]: 4 : LIBPAW_DEALLOCATE(d)
2227 : 4 : END SUBROUTINE Orbit_Init
2228 : :
2229 : :
2230 : :
2231 : :
2232 : :
2233 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2234 : : ! 2. atomdata
2235 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2236 : :
2237 : :
2238 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2239 : : !! Subroutine InitOrbit -- used in CopyOrbit
2240 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2241 : 362 : subroutine InitOrbit(Orbit,norbit,n,exctype,diracrelativistic,scalarrelativistic,frozencorecalculation,frozenvalecalculation)
2242 : : type (OrbitInfo), intent(inout) :: Orbit
2243 : : logical, intent(in) :: diracrelativistic
2244 : : logical, intent(in) :: scalarrelativistic
2245 : : logical, intent(in) :: frozencorecalculation,frozenvalecalculation
2246 : : integer, intent(in) :: n,norbit
2247 : : character(*),intent(in) :: exctype
2248 : 362 : CALL DestroyOrbit(Orbit)
2249 [ - + ]: 362 : Orbit%norbit=norbit;Orbit%exctype=trim(exctype)
2250 : 362 : Orbit%nps=0;Orbit%npp=0;Orbit%npd=0;Orbit%npf=0;Orbit%npg=0
2251 : 362 : Orbit%npsc=0;Orbit%nppc=0;Orbit%npdc=0;Orbit%npfc=0;Orbit%npgc=0
2252 : 362 : Orbit%qval=0._dp
2253 [ - + + - : 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%np,(norbit))
+ - + - -
+ - + ]
2254 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%l,(norbit))
- + - + ]
2255 [ - + + - : 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%eig,(norbit))
+ - + - -
+ - + ]
2256 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%occ,(norbit))
- + - + ]
2257 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%iscore,(norbit))
- + - + ]
2258 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%issemicore,(norbit))
- + - + ]
2259 [ + + ]: 2588 : Orbit%iscore=.false.
2260 [ + + ]: 2588 : Orbit%issemicore=.false.
2261 [ + + + + ]: 4814 : Orbit%np=0;Orbit%l=0
2262 [ + + + + ]: 4814 : Orbit%eig=0._dp;Orbit%occ=0._dp
2263 [ - + + - : 1448 : LIBPAW_POINTER_ALLOCATE(Orbit%wfn,(n,norbit))
- + + - +
- + - - +
- + ]
2264 [ - + + - : 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%otau,(n,norbit))
- + + - -
+ - + ]
2265 [ - + + - : 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%den,(n))
+ - + - -
+ - + ]
2266 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%tau,(n))
- + - + ]
2267 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%coreden,(n))
- + - + ]
2268 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%valeden,(n))
- + - + ]
2269 [ - + + - : 724 : LIBPAW_POINTER_ALLOCATE(Orbit%deltatau,(n))
- + - + ]
2270 [ + + + + : 10361990 : Orbit%wfn=0._dp;Orbit%den=0._dp;Orbit%tau=0._dp;Orbit%otau=0._dp
+ + + + +
+ + + ]
2271 [ + + ]: 724724 : Orbit%deltatau=0._dp
2272 [ + + + + ]: 1449086 : Orbit%coreden=0._dp ; Orbit%valeden=0._dp
2273 : 362 : Orbit%scalarrelativistic=scalarrelativistic
2274 : 362 : Orbit%frozencorecalculation=frozencorecalculation
2275 : 362 : Orbit%frozenvalecalculation=frozenvalecalculation
2276 : 362 : Orbit%diracrelativistic=diracrelativistic
2277 [ + + ]: 362 : If (Orbit%diracrelativistic) then
2278 [ - + + - : 132 : LIBPAW_POINTER_ALLOCATE(Orbit%lwfn,(n,norbit))
- + + - -
+ - + ]
2279 [ - + + - : 88 : LIBPAW_POINTER_ALLOCATE(Orbit%kappa,(norbit))
- + - + ]
2280 [ + + + + ]: 880924 : Orbit%lwfn=0._dp
2281 [ + + ]: 484 : Orbit%kappa=0._dp
2282 : : else
2283 : 318 : nullify(Orbit%lwfn,Orbit%kappa)
2284 : : endif
2285 [ + - - + ]: 362 : if (exctype == "HF".or.exctype == "EXXKLI") then
2286 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Orbit%lqp,(norbit,norbit))
# # # # #
# # # # #
# # ]
2287 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Orbit%X,(n,norbit))
# # # # #
# # # ]
2288 : : else
2289 : 362 : nullify(Orbit%lqp,Orbit%X)
2290 : : endif
2291 : 362 : end subroutine InitOrbit
2292 : :
2293 : :
2294 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2295 : : !! Subroutine DestroyOrbit
2296 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2297 : 728 : subroutine DestroyOrbit(Orbit)
2298 : : type (OrbitInfo), intent(inout) :: Orbit
2299 [ + + ]: 728 : if (associated(Orbit%np)) then
2300 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%np)
2301 : : endif
2302 [ + + ]: 728 : if (associated(Orbit%l)) then
2303 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%l)
2304 : : endif
2305 [ + + ]: 728 : if (associated(Orbit%kappa)) then
2306 : 44 : LIBPAW_POINTER_DEALLOCATE(Orbit%kappa)
2307 : : endif
2308 [ + + ]: 728 : if (associated(Orbit%iscore)) then
2309 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%iscore)
2310 : : endif
2311 [ + + ]: 728 : if (associated(Orbit%issemicore)) then
2312 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%issemicore)
2313 : : endif
2314 [ + + ]: 728 : if (associated(Orbit%eig)) then
2315 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%eig)
2316 : : endif
2317 [ + + ]: 728 : if (associated(Orbit%occ)) then
2318 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%occ)
2319 : : endif
2320 [ + + ]: 728 : if (associated(Orbit%wfn)) then
2321 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%wfn)
2322 : : endif
2323 [ + + ]: 728 : if (associated(Orbit%otau)) then
2324 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%otau)
2325 : : endif
2326 [ + + ]: 728 : if (associated(Orbit%lwfn)) then
2327 : 44 : LIBPAW_POINTER_DEALLOCATE(Orbit%lwfn)
2328 : : endif
2329 [ + + ]: 728 : if (associated(Orbit%den)) then
2330 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%den)
2331 : : endif
2332 [ + + ]: 728 : if (associated(Orbit%tau)) then
2333 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%tau)
2334 : : endif
2335 [ + + ]: 728 : IF (ASSOCIATED(Orbit%deltatau)) then
2336 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%deltatau)
2337 : : endif
2338 [ - + ]: 728 : if (associated(Orbit%lqp)) then
2339 : 0 : LIBPAW_POINTER_DEALLOCATE(Orbit%lqp)
2340 : : endif
2341 [ - + ]: 728 : if (associated(Orbit%X)) then
2342 : 0 : LIBPAW_POINTER_DEALLOCATE(Orbit%X)
2343 : : endif
2344 [ + + ]: 728 : if(associated(Orbit%coreden)) then
2345 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%coreden)
2346 : : endif
2347 [ + + ]: 728 : if(associated(Orbit%valeden)) then
2348 : 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%valeden)
2349 : : endif
2350 : 728 : end subroutine DestroyOrbit
2351 : :
2352 : :
2353 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2354 : : !! CopyOrbit(source,copy)
2355 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2356 : 358 : subroutine CopyOrbit(SOrbit,COrbit)
2357 : : type(OrbitInfo),intent(inout)::SOrbit
2358 : : type(OrbitInfo),intent(inout)::COrbit
2359 : : integer::n
2360 : 358 : n=size(SOrbit%den,1)
2361 : : call InitOrbit(COrbit,SOrbit%norbit,n,SOrbit%exctype,SOrbit%diracrelativistic,SOrbit%scalarrelativistic,&
2362 : 358 : & SOrbit%frozencorecalculation,SOrbit%frozenvalecalculation)
2363 : 358 : COrbit%nps=SOrbit%nps
2364 : 358 : COrbit%npp=SOrbit%npp
2365 : 358 : COrbit%npd=SOrbit%npd
2366 : 358 : COrbit%npf=SOrbit%npf
2367 : 358 : COrbit%npg=SOrbit%npg
2368 : 358 : COrbit%npsc=SOrbit%npsc
2369 : 358 : COrbit%nppc=SOrbit%nppc
2370 : 358 : COrbit%npdc=SOrbit%npdc
2371 : 358 : COrbit%npfc=SOrbit%npfc
2372 : 358 : COrbit%npgc=SOrbit%npgc
2373 : 358 : COrbit%qval=SOrbit%qval
2374 [ + + ]: 2557 : COrbit%np(1:SOrbit%norbit)=SOrbit%np(1:SOrbit%norbit)
2375 [ + + ]: 2557 : COrbit%l(1:SOrbit%norbit)=SOrbit%l(1:SOrbit%norbit)
2376 [ + + ]: 2557 : COrbit%eig(1:SOrbit%norbit)=SOrbit%eig(1:SOrbit%norbit)
2377 [ + + ]: 2557 : COrbit%occ(1:SOrbit%norbit)=SOrbit%occ(1:SOrbit%norbit)
2378 [ + + + + ]: 4402756 : COrbit%wfn(:,1:SOrbit%norbit)=SOrbit%wfn(:,1:SOrbit%norbit)
2379 [ + + + + ]: 4402756 : COrbit%otau(:,1:SOrbit%norbit)=SOrbit%otau(:,1:SOrbit%norbit)
2380 [ + + ]: 2557 : COrbit%iscore(1:SOrbit%norbit)=SOrbit%iscore(1:SOrbit%norbit)
2381 [ + + ]: 2557 : COrbit%issemicore(1:SOrbit%norbit)=SOrbit%issemicore(1:SOrbit%norbit)
2382 [ + + ]: 716716 : COrbit%den=SOrbit%den
2383 [ + + ]: 716716 : COrbit%coreden=SOrbit%coreden
2384 [ + + ]: 716716 : COrbit%valeden=SOrbit%valeden
2385 [ + + ]: 716716 : COrbit%tau=SOrbit%tau
2386 [ + + ]: 716716 : COrbit%deltatau=SOrbit%deltatau
2387 [ + + ]: 358 : if (SOrbit%diracrelativistic) then
2388 [ + + + + ]: 860903 : COrbit%lwfn(:,1:SOrbit%norbit)=SOrbit%lwfn(:,1:SOrbit%norbit)
2389 [ + + ]: 473 : COrbit%kappa(1:SOrbit%norbit)=SOrbit%kappa(1:SOrbit%norbit)
2390 : : endif
2391 [ + - - + ]: 358 : if (SOrbit%exctype == "HF".or.SOrbit%exctype == "EXXKLI") then
2392 [ # # # # ]: 0 : COrbit%X(:,1:SOrbit%norbit)=SOrbit%X(:,1:SOrbit%norbit)
2393 [ # # # # ]: 0 : COrbit%lqp(1:SOrbit%norbit,1:SOrbit%norbit)=SOrbit%lqp(1:SOrbit%norbit,1:SOrbit%norbit)
2394 : : endif
2395 : 358 : end subroutine CopyOrbit
2396 : :
2397 : :
2398 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2399 : : !! InitPot
2400 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2401 : 358 : subroutine InitPot(Pot,n)
2402 : : integer, intent(in) :: n
2403 : : type (PotentialInfo), intent(inout) :: Pot
2404 : 358 : CALL DestroyPot(Pot)
2405 [ - + + - : 1074 : LIBPAW_POINTER_ALLOCATE(Pot%rv,(n))
+ - + - -
+ - + ]
2406 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%rvn,(n))
- + - + ]
2407 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%rvh,(n))
- + - + ]
2408 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%rvx,(n))
- + - + ]
2409 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%vtau,(n))
- + - + ]
2410 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%ww,(n))
- + - + -
+ ]
2411 [ - + + - : 716 : LIBPAW_POINTER_ALLOCATE(Pot%jj,(n))
- + - + -
+ ]
2412 [ + + + + : 3583580 : Pot%rv=0._dp;Pot%rvn=0._dp;Pot%rvh=0._dp;Pot%rvx=0._dp;Pot%vtau=0._dp
+ + + + +
+ ]
2413 [ + + + + ]: 1433432 : Pot%ww=0._dp;Pot%jj=0._dp
2414 : 358 : end subroutine InitPot
2415 : :
2416 : :
2417 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2418 : : !! DestroyPot
2419 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2420 : 716 : subroutine DestroyPot(Pot)
2421 : : type (PotentialInfo), intent(inout) :: Pot
2422 [ + + ]: 716 : if (associated(Pot%rv)) then
2423 : 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rv)
2424 : : endif
2425 [ + + ]: 716 : if (associated(Pot%rvn)) then
2426 : 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rvn)
2427 : : endif
2428 [ + + ]: 716 : if (associated(Pot%rvh)) then
2429 : 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rvh)
2430 : : endif
2431 [ + + ]: 716 : if (associated(Pot%rvx)) then
2432 : 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rvx)
2433 : : endif
2434 [ + + ]: 716 : if (associated(Pot%vtau)) then
2435 : 358 : LIBPAW_POINTER_DEALLOCATE(Pot%vtau)
2436 : : endif
2437 [ + + ]: 716 : if (allocated(Pot%ww)) then
2438 : 358 : LIBPAW_DEALLOCATE(Pot%ww)
2439 : : endif
2440 [ + + ]: 716 : if (allocated(Pot%jj)) then
2441 : 358 : LIBPAW_DEALLOCATE(Pot%jj)
2442 : : endif
2443 : 716 : end subroutine DestroyPot
2444 : :
2445 : :
2446 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2447 : : ! CopyPot(source,copy)
2448 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2449 : 354 : subroutine CopyPot(SPot,CPot)
2450 : : type(PotentialInfo),intent(in) :: SPot
2451 : : type(PotentialInfo),intent(inout) :: CPot
2452 : : integer :: n
2453 : 354 : n=SIZE(SPot%rv,1)
2454 : 354 : CALL InitPot(CPot,n)
2455 : 354 : CPot%nz=SPot%nz
2456 : 354 : CPot%zz=SPot%zz
2457 : 354 : CPot%sym=SPot%sym
2458 : 354 : CPot%q=SPot%q
2459 : 354 : CPot%v0=SPot%v0
2460 : 354 : CPot%v0p=SPot%v0p
2461 : 354 : CPot%finitenucleusmodel=SPot%finitenucleusmodel
2462 : 354 : CPot%finitenucleus=SPot%finitenucleus
2463 : 354 : CPot%Nv0=SPot%Nv0
2464 : 354 : CPot%Nv0p=SPot%Nv0p
2465 [ + + ]: 708708 : CPot%rv(1:n)=SPot%rv(1:n)
2466 [ + + ]: 708708 : CPot%rvn(1:n)=SPot%rvn(1:n)
2467 [ + + ]: 708708 : CPot%rvh(1:n)=SPot%rvh(1:n)
2468 [ + + ]: 708708 : CPot%rvx(1:n)=SPot%rvx(1:n)
2469 [ + + ]: 708708 : CPot%vtau(1:n)=SPot%vtau(1:n)
2470 [ + + ]: 708708 : CPot%ww(1:n)=SPot%ww(1:n)
2471 [ + + ]: 708708 : CPot%jj(1:n)=SPot%jj(1:n)
2472 : 354 : CPot%needvtau=SPot%needvtau
2473 : 354 : end subroutine CopyPot
2474 : :
2475 : :
2476 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2477 : : ! InitSCF
2478 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2479 : 4 : subroutine InitSCF(SCF)
2480 : : type(SCFInfo),intent(inout)::SCF
2481 : 4 : SCF%iter=0
2482 : 4 : SCF%delta=0._dp;SCF%eone=0._dp;SCF%ekin=0._dp;SCF%estatic=0._dp
2483 : 4 : SCF%ecoul=0._dp;SCF%eexc=0._dp;SCF%oepcs=0._dp;SCF%etot=0._dp
2484 : 4 : SCF%valekin=0._dp;SCF%valecoul=0._dp;SCF%valeexc=0._dp
2485 [ - + ]: 4 : SCF%corekin=0._dp;SCF%evale=0._dp
2486 : : end subroutine InitSCF
2487 : :
2488 : :
2489 : :
2490 : :
2491 : :
2492 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2493 : : ! 3. ldagga_mod
2494 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2495 : :
2496 : :
2497 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2498 : : ! LDAGGA_SCF
2499 : : !!!!!!!!!!!!!!!!!!!!!!!!!
2500 : 23 : SUBROUTINE LDAGGA_SCF(atp)
2501 : : TYPE(atompaw_type), INTENT(inout) :: atp
2502 : : TYPE(Anderson_context):: AC
2503 : : INTEGER :: n
2504 : : real(dp) :: en1,etxc,eex,x,y
2505 : : real(dp), ALLOCATABLE :: arg(:)
2506 : : LOGICAL :: success
2507 : : character(132):: exctypesave
2508 : 23 : n=atp%Grid%n
2509 [ - + + - : 69 : LIBPAW_ALLOCATE(arg,(n))
+ - + - -
+ - + ]
2510 [ - + ]: 23 : if(atp%needvtau) then ! first converge LDA
2511 : 0 : atp%needvtau=.false.
2512 : 0 : atp%Pot%needvtau=.false.
2513 : 0 : exctypesave=atp%exctype
2514 : 0 : atp%exctype="LDA-PW"
2515 : 0 : call initexch(atp)
2516 : : CALL exch(atp%Grid,atp%Orbit%den,atp%Pot%rvx,etxc,eex,itype=atp%itype,&
2517 : 0 : & tau=atp%Orbit%tau,vtau=atp%Pot%vtau,xc_functionals=atp%xc_functionals)
2518 [ # # # # : 0 : arg=atp%Pot%rvh+atp%Pot%rvx ! iterating only on electronic part of pot
# # # # ]
2519 [ # # ]: 0 : atp%Pot%rv=atp%Pot%rvh+atp%Pot%rvx-atp%Pot%rvx(1)
2520 : 0 : CALL zeropot(atp%Grid,atp%Pot%rv,atp%Pot%v0,atp%Pot%v0p)
2521 [ # # ]: 0 : atp%Pot%rv=atp%Pot%rv+atp%Pot%rvn+atp%Pot%rvx(1)
2522 : 0 : CALL InitAnderson_dr(AC,6,5,n,0.2_dp,1.d3,100,seterr,settoosmall,.true.)
2523 : 0 : CALL DoAndersonMix(AC,arg,en1,LDAGGAsub,success,atp)
2524 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Anderson Mix with LDA',AC%res ,' iter = ',AC%CurIter
2525 : 0 : CALL FreeAnderson(AC)
2526 [ # # ]: 0 : if(has_to_print) write(STD_OUT,*) 'Completed initial iteration '
2527 : 0 : atp%needvtau=.true.
2528 : 0 : atp%Pot%needvtau=.true.
2529 : 0 : atp%exctype=exctypesave
2530 : 0 : call initexch(atp)
2531 : : endif
2532 : : CALL exch(atp%Grid,atp%Orbit%den,atp%Pot%rvx,etxc,eex,itype=atp%itype,&
2533 : : & needvtau=atp%Pot%needvtau,tau=atp%Orbit%tau,vtau=atp%Pot%vtau,&
2534 : 23 : & xc_functionals=atp%xc_functionals)
2535 [ + + ]: 46046 : atp%Pot%rv=atp%Pot%rvh+atp%Pot%rvx-atp%Pot%rvx(1)
2536 : 23 : CALL zeropot(atp%Grid,atp%Pot%rv,atp%Pot%v0,atp%Pot%v0p)
2537 [ + + ]: 46046 : atp%Pot%rv=atp%Pot%rv+atp%Pot%rvn+atp%Pot%rvx(1)
2538 : 23 : atp%SCF%iter=0
2539 : 23 : atp%SCF%delta=0
2540 [ - + ]: 23 : If (atp%needvtau) then
2541 : 0 : x=seterrmg; y=settoosmallmg
2542 : : else
2543 : 23 : x=seterr; y=settoosmall
2544 : : endif
2545 : 23 : CALL InitAnderson_dr(AC,6,5,n,0.6_dp,1.d3,MaxIter,x,y,has_to_print)
2546 [ - + ]: 23 : If (atp%needvtau) then
2547 [ # # # # : 0 : arg=atp%Orbit%den ! iterating on density
# # # # #
# ]
2548 : 0 : CALL DoAndersonMix(AC,arg,en1,DENITERsub,success,atp)
2549 : : !!!! evaluate vxc and vtau on universal grid
2550 : : !!!! because it may be bumpy at intermediate range from spline
2551 : : !!!! evaluation
2552 : : CALL exch(atp%Grid,atp%Orbit%den,atp%Pot%rvx,etxc,eex,itype=atp%itype,&
2553 : 0 : & tau=atp%Orbit%tau,vtau=atp%Pot%vtau)
2554 [ # # ]: 0 : atp%Pot%rv=atp%Pot%rvn+atp%Pot%rvh+atp%Pot%rvx
2555 : : else
2556 [ + - - + : 46069 : arg=atp%Pot%rvh+atp%Pot%rvx
- - + + ]
2557 : 23 : CALL DoAndersonMix(AC,arg,en1,LDAGGAsub,success,atp)
2558 : : endif
2559 : 23 : atp%SCF%iter=AC%CurIter
2560 : 23 : atp%SCF%delta=AC%res
2561 [ - + ]: 23 : if(has_to_print) WRITE(STD_OUT,*) 'Anderson Mix ',success,AC%res ,' iter = ',AC%CurIter
2562 [ - + ]: 23 : if (AC%res>1._dp) then
2563 : 0 : LIBPAW_ERROR('Sadly the program has not converged, Consider trying splineinterp')
2564 : : endif
2565 : 23 : CALL FreeAnderson(AC)
2566 [ - + ]: 23 : if(has_to_print) write(std_out,*) 'Finished Anderson Mix', en1 ,' success = ', success
2567 [ - + ]: 23 : LIBPAW_DEALLOCATE(arg)
2568 : 23 : END SUBROUTINE LDAGGA_SCF
2569 : :
2570 : :
2571 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2572 : : !!!!! LDAGGASub
2573 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2574 [ - + - + ]: 354 : SUBROUTINE LDAGGASub(w,energy,residue,err,success,update,atp)
2575 : : real(dp), INTENT(INOUT) :: w(:)
2576 : : real(dp), INTENT(OUT) :: energy
2577 : : real(dp), INTENT(OUT) :: residue(:)
2578 : : real(dp), INTENT(OUT) :: err
2579 : : LOGICAL, INTENT(OUT) :: success
2580 : : LOGICAL, INTENT(IN) :: update
2581 : : type(atompaw_type), intent(inout) :: atp
2582 : : INTEGER :: i,j,n,io,nw
2583 : 354 : real(dp),ALLOCATABLE :: dum(:)
2584 : : real(dp) :: x
2585 : : TYPE (OrbitInfo) :: tmpOrbit
2586 : 354 : TYPE (PotentialInfo) :: tmpPot
2587 : 354 : n=atp%Grid%n
2588 : 354 : nw=SIZE(w)
2589 [ + - + - : 1062 : LIBPAW_ALLOCATE(dum,(nw))
+ - - + -
+ ]
2590 : 354 : CALL CopyOrbit(atp%Orbit,tmpOrbit)
2591 : 354 : CALL CopyPot(atp%Pot,tmpPot)
2592 : 354 : CALL Updatewfn(atp%Grid,tmpPot,tmpOrbit,w,success,atp%BDsolve,atp%usespline,atp%spline,atp%itype)
2593 [ - + ]: 354 : if(has_to_print) write(std_out,*) 'completed updatewfn with success ', success
2594 [ + + ]: 354 : If (.not.success) then ! attempt to stablize solution
2595 : : !w=w+tmpPot%rvn
2596 [ - + - - : 17 : if(has_to_print) write(std_out,*) 'Current eigs', (atp%Orbit%eig(io),io=1,atp%Orbit%norbit)
- - ]
2597 : : j=n
2598 : 17 : x=atp%Orbit%eig(1)
2599 [ + - ]: 17 : if (atp%Orbit%norbit>1) then
2600 [ + + ]: 114 : do io = 2, atp%Orbit%norbit
2601 [ + - + + ]: 97 : if (atp%Orbit%eig(io)<0._dp.and.x<atp%Orbit%eig(io)) &
2602 : 70 : & x=atp%Orbit%eig(io)
2603 : : enddo
2604 : : endif
2605 : 17 : x=1._dp/sqrt(abs(x))
2606 : 17 : j=FindGridIndex(atp%Grid,x)
2607 [ - + ]: 17 : if(has_to_print) write(std_out,*) 'index', x,j,atp%Grid%r(j)
2608 [ - + ]: 17 : if (j<10)j=10
2609 [ - + ]: 17 : if (j>n-10) j=n-10
2610 : 17 : w(j+1)=(-1._dp+w(j+1)/2)
2611 [ + + ]: 15945 : do i=j+2,n
2612 : 15945 : w(i)=-2._dp
2613 : : enddo
2614 [ - + ]: 17 : if(has_to_print) write(std_out,*) 'Reset tmpPot ', j
2615 [ - + ]: 17 : if(has_to_print) write(std_out,*) ' Last points '
2616 [ - + ]: 17 : if(has_to_print) write(std_out,'(1p,20e15.7)') atp%Grid%r(n),w(n)
2617 : : !w=w-tmpPot%rvn
2618 : 17 : CALL Updatewfn(atp%Grid,tmpPot,tmpOrbit,w,success,atp%BDsolve,atp%usespline,atp%spline,atp%itype)
2619 [ - + ]: 17 : if(has_to_print) write(std_out,*) 'after updatwfn from reset ',success;
2620 : : Endif
2621 [ - + ]: 354 : IF (.NOT.success) THEN
2622 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'Bad luck in Sub'
2623 : : ENDIF
2624 : 354 : CALL Get_KinCoul(atp%Grid,tmpPot,tmpOrbit,atp%SCF,atp%usespline)
2625 : 354 : CALL Get_EXC(atp,tmpPot,tmpOrbit)
2626 [ + + ]: 708708 : dum(1:n)=tmpPot%rvh(1:n)+tmpPot%rvx(1:n)-w(1:n)
2627 [ + + ]: 708708 : residue=dum
2628 [ + + ]: 708708 : err=Dot_Product(residue,residue)
2629 : 354 : energy=atp%SCF%etot
2630 [ + - ]: 354 : IF (update) THEN
2631 [ + + ]: 708708 : atp%Pot%rv=w+tmpPot%rvn
2632 [ + + ]: 708708 : atp%Pot%rvh=tmpPot%rvh
2633 [ + + ]: 708708 : atp%Pot%rvx=tmpPot%rvx
2634 [ - + - - ]: 354 : if (atp%needvtau) atp%Pot%vtau=tmpPot%vtau
2635 [ + + + + ]: 4354704 : atp%Orbit%wfn=tmpOrbit%wfn
2636 [ + + + + : 861214 : If(atp%diracrelativistic) atp%Orbit%lwfn=tmpOrbit%lwfn
+ + ]
2637 [ + + ]: 2529 : atp%Orbit%eig=tmpOrbit%eig
2638 [ + + ]: 708708 : atp%Orbit%den=tmpOrbit%den
2639 [ + + + + ]: 4354704 : atp%Orbit%otau=tmpOrbit%otau
2640 [ + + ]: 708708 : atp%Orbit%tau=tmpOrbit%tau
2641 [ + + ]: 708708 : atp%Orbit%deltatau=tmpOrbit%deltatau
2642 : : ENDIF
2643 : 354 : CALL DestroyPot(tmpPot)
2644 : 354 : CALL DestroyOrbit(tmpOrbit)
2645 [ - + ]: 354 : LIBPAW_DEALLOCATE (dum)
2646 [ - + - + : 708 : END SUBROUTINE LDAGGASub
- + ]
2647 : :
2648 : :
2649 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2650 : : !!!! DENITERSub -- w is the electron density
2651 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2652 [ # # # # ]: 0 : SUBROUTINE DENITERSub(w,energy,residue,err,success,update,atp)
2653 : : REAL(dp), INTENT(INOUT) :: w(:)
2654 : : REAL(dp), INTENT(OUT) :: energy
2655 : : REAL(dp), INTENT(OUT) :: residue(:)
2656 : : REAL(dp), INTENT(OUT) :: err
2657 : : type(atompaw_type), intent(inout) :: atp
2658 : : LOGICAL, INTENT(OUT) :: success
2659 : : LOGICAL, INTENT(IN) :: update
2660 : : INTEGER :: n,nw
2661 : 0 : REAL(dp),ALLOCATABLE :: dum(:)
2662 : : REAL(dp) :: x,y
2663 : : TYPE (OrbitInfo) :: tmpOrbit
2664 : 0 : TYPE (PotentialInfo) :: tmpPot
2665 : 0 : n=atp%Grid%n
2666 : 0 : nw=SIZE(w)
2667 : 0 : if(n/=nw) then
2668 : 0 : write(std_out,*) 'problem in DENITERsub n,nw', n,nw
2669 : 0 : stop
2670 : : endif
2671 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(nw))
# # # # #
# # # ]
2672 : 0 : CALL CopyOrbit(atp%Orbit,tmpOrbit)
2673 : 0 : CALL CopyPot(atp%Pot,tmpPot)
2674 : : ! w enters subroutine as next iteration density
2675 : : ! It needs to be renormalized
2676 : : ! tmpPot%rvh, tmpPot%rvx, tmpPot%vtau need to be generated
2677 : 0 : x=integrator(atp%Grid,w)
2678 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'In DENITERsub norm(m) adjust ', x,atp%Pot%q
2679 [ # # ]: 0 : w=w*tmpPot%q/x
2680 : 0 : call atompaw_poisson(atp%Grid,x,w,tmpPot%rvh,y)
2681 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'after poisson q,ecoul ',x,y
2682 : 0 : call exch(atp%Grid,w,tmpPot%rvx,x,y,itype=atp%itype,tau=tmpOrbit%tau,vtau=tmpPot%vtau,xc_functionals=atp%xc_functionals)
2683 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'after exch exvct, eexc ',x,y
2684 [ # # ]: 0 : tmpPot%rv=tmpPot%rvn+tmpPot%rvh+tmpPot%rvx
2685 [ # # ]: 0 : tmpOrbit%den=w
2686 : 0 : CALL Updatewfnwden(atp%Grid,tmpPot,tmpOrbit,success,atp%usespline,atp%spline,atp%itype)
2687 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'completed updatewfnwden with success ', success
2688 [ # # ]: 0 : IF (.NOT.success) THEN
2689 : 0 : WRITE(STD_OUT,*) 'Bad luck in Sub'
2690 : : ENDIF
2691 : 0 : CALL Get_KinCoul(atp%Grid,tmpPot,tmpOrbit,atp%SCF,atp%usespline)
2692 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'Check tau ', integrator(atp%Grid,tmpOrbit%tau)
2693 : 0 : CALL Get_EXC(atp,tmpPot,tmpOrbit)
2694 [ # # ]: 0 : dum(1:n)=tmpOrbit%den(1:n)-w(1:n)
2695 [ # # ]: 0 : residue=dum
2696 [ # # ]: 0 : err=Dot_Product(residue,residue)
2697 [ # # ]: 0 : if(has_to_print) write(STD_OUT,*) 'in DENITERSub err ', err
2698 : 0 : energy=atp%SCF%etot
2699 [ # # ]: 0 : IF (update) THEN
2700 [ # # ]: 0 : atp%Pot%rv=tmpPot%rv
2701 [ # # ]: 0 : atp%Pot%rvh=tmpPot%rvh
2702 [ # # ]: 0 : atp%Pot%rvx=tmpPot%rvx
2703 [ # # # # ]: 0 : if (atp%needvtau) atp%Pot%vtau=tmpPot%vtau
2704 [ # # # # ]: 0 : atp%Orbit%wfn=tmpOrbit%wfn
2705 [ # # # # : 0 : If(atp%diracrelativistic)atp%Orbit%lwfn=tmpOrbit%lwfn
# # ]
2706 [ # # ]: 0 : atp%Orbit%eig=tmpOrbit%eig
2707 [ # # ]: 0 : atp%Orbit%den=w
2708 [ # # # # ]: 0 : atp%Orbit%otau=tmpOrbit%otau
2709 [ # # ]: 0 : atp%Orbit%tau=tmpOrbit%tau
2710 [ # # ]: 0 : atp%Orbit%deltatau=tmpOrbit%deltatau
2711 : : ENDIF
2712 : 0 : CALL DestroyOrbit(tmpOrbit)
2713 : 0 : CALL DestroyPot(tmpPot)
2714 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
2715 [ # # # # : 0 : END SUBROUTINE DENITERSub
# # ]
2716 : :
2717 : :
2718 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2719 : : !! Get_EXC
2720 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2721 : 354 : SUBROUTINE Get_EXC(atp,Pot,Orbit)
2722 : : ! program to calculate exc energy and potential
2723 : : ! assumes Orbit%den already known
2724 : : ! also assume kinetic and coulomb energies
2725 : : ! calculated and stored in SCF
2726 : : TYPE(Potentialinfo), INTENT(INOUT) :: Pot
2727 : : TYPE(Orbitinfo), INTENT(INOUT) :: Orbit
2728 : : TYPE(atompaw_type), INTENT(inout) :: atp
2729 : : real(dp) :: eex,etot,etxc
2730 : 354 : real(dp), ALLOCATABLE :: dum(:)
2731 : : INTEGER :: n,fin
2732 : 354 : n=atp%Grid%n
2733 : 354 : fin=atp%grid%n
2734 [ + + ]: 354 : if(atp%frozenvalecalculation) fin=atp%PAW%irc+5
2735 : : CALL exch(atp%Grid,Orbit%den,Pot%rvx,etxc,eex,itype=atp%itype,&
2736 : 354 : & needvtau=Pot%needvtau,tau=Orbit%tau,vtau=Pot%vtau,fin=fin,xc_functionals=atp%xc_functionals)
2737 : 354 : atp%SCF%eexc=eex
2738 : 354 : etot = atp%SCF%ekin+atp%SCF%estatic+atp%SCF%eexc
2739 : 354 : atp%SCF%etot=etot
2740 [ - + ]: 354 : if(has_to_print) WRITE(STD_OUT,*) ' Total : ',etot
2741 [ - + + - : 1062 : LIBPAW_ALLOCATE(dum,(n))
+ - + - -
+ - + ]
2742 [ + + ]: 708708 : dum=0
2743 [ + + ]: 708354 : dum(2:n)=Pot%rvx(2:n)*Orbit%den(2:n)/atp%Grid%r(2:n)
2744 [ - + ]: 354 : if (Pot%needvtau) then
2745 [ # # # # ]: 0 : dum=dum+Orbit%tau*Pot%vtau !Kinetic energy correction
2746 : : endif
2747 [ - + ]: 354 : if(has_to_print) then
2748 : 0 : WRITE(STD_OUT,*) ' Total (DC form) : ',&
2749 : 0 : & atp%SCF%eone-atp%SCF%ecoul+eex-integrator(atp%Grid,dum)
2750 : : endif
2751 [ - + ]: 354 : LIBPAW_DEALLOCATE(dum)
2752 : 354 : END SUBROUTINE Get_EXC
2753 : :
2754 : :
2755 : :
2756 : :
2757 : :
2758 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2759 : : ! 4. excor
2760 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2761 : :
2762 : :
2763 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2764 : : !! SUBROUTINE initexch(atp)
2765 : : !! choose form of exchange-correlation potential
2766 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2767 : 4 : SUBROUTINE initexch(atp)
2768 : : type(atompaw_type), intent(inout) :: atp
2769 : : integer :: id(2),i_plus,ii
2770 : : character*50 :: xcstrg(2)
2771 : 4 : CALL Uppercase(atp%exctype)
2772 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,*) atp%exctype
2773 : 6 : SELECT CASE(TRIM(atp%exctype))
2774 : : CASE default
2775 : 2 : atp%itype = LIBXC
2776 : 2 : i_plus=index(atp%exctype,'+')
2777 [ - + ]: 2 : if (i_plus<=0) then
2778 : 0 : xcstrg(1)=trim(atp%exctype)
2779 : 0 : xcstrg(2)=""
2780 : : else
2781 [ + - ]: 2 : xcstrg(1)=trim(atp%exctype(1:i_plus-1))
2782 [ - + ]: 2 : xcstrg(2)=trim(atp%exctype(i_plus+1:))
2783 : : end if
2784 [ + + ]: 6 : do ii=1,2
2785 : 6 : id(ii)=libxc_functionals_getid(xcstrg(ii))
2786 : : enddo
2787 : 2 : atp%ixc=-(id(1)*1000+id(2))
2788 [ - + ]: 2 : if(has_to_print)WRITE(STD_OUT,*) 'Using Libxc --',TRIM(atp%exctype),atp%ixc
2789 : 2 : call libxc_functionals_init(atp%ixc,1,atp%xc_functionals,el_temp=zero)
2790 [ - + - - ]: 2 : if(atp%needvtau.and.(.not.libxc_functionals_ismgga(atp%xc_functionals))) then
2791 : 0 : WRITE(STD_OUT,*) 'Problem with XC functional choice -- need mgga form for vtau '
2792 : 0 : WRITE(STD_OUT,*) ' Program stopping '
2793 : 0 : stop
2794 : : endif
2795 : : CASE('LDA-PW')
2796 : 0 : atp%itype = LDA_PW
2797 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Perdew-Wang correlation'
2798 : : CASE('GGA-PBE')
2799 : 2 : atp%itype = GGA_PBE
2800 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'Perdew-Burke-Ernzerhof GGA'
2801 : : CASE('GGA-PBESOL')
2802 : 0 : atp%itype = GGA_PBESOL
2803 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Perdew-Burke-Ernzerhof modified (PBEsol) GGA'
2804 : : CASE ('MGGA-R2SCAN-001')
2805 : 0 : atp%itype = MGGA_R2SCAN_001
2806 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'R2SCAN MGGA with eta=0.001'
2807 : 0 : call r2scaninit(0.001_dp)
2808 : 0 : atp%needvtau=.true.
2809 : : CASE ('MGGA-R2SCAN-01')
2810 : 0 : atp%itype = MGGA_R2SCAN_01
2811 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'R2SCAN MGGA with eta=0.01'
2812 : 0 : call r2scaninit(0.01_dp)
2813 [ + - + - : 4 : atp%needvtau=.true.
- - ]
2814 : : !CASE ('HF')
2815 : : ! itype = NO_XC
2816 : : ! WRITE(STD_OUT,*) 'No XC'
2817 : : END SELECT
2818 : 4 : END SUBROUTINE initexch
2819 : :
2820 : :
2821 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2822 : : !! Logofterm
2823 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2824 : 712964 : FUNCTION Logofterm(term)
2825 : : real(dp) :: term, Logofterm
2826 [ + + ]: 712964 : IF (ABS(term)>machine_precision) THEN
2827 : 706094 : Logofterm=ddlog(1._dp+term)
2828 : : ELSE
2829 : : Logofterm=term
2830 : : ENDIF
2831 : : RETURN
2832 : : END FUNCTION Logofterm
2833 : :
2834 : :
2835 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2836 : : ! Subroutine radialexcpbe
2837 : : ! Density(:) input on a uniform radial mesh of Npts
2838 : : ! Grid%r(:) input mesh points
2839 : : ! Exc - output integrated exchange correlation energy -- in Rydberg units
2840 : : ! vxc(:) -- output exchange correlation potential -- in Rydberg units
2841 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2842 [ - + - + ]: 230 : SUBROUTINE radialexcpbe(Grid,density,Exc,vxc,mu,beta,fin)
2843 : : IMPLICIT NONE
2844 : : TYPE (GridInfo), INTENT(IN) :: Grid
2845 : : real(dp), intent(in) :: mu,beta
2846 : : REAL(dp), INTENT(IN) :: density(:)
2847 : : REAL(dp), INTENT(OUT) :: Exc, vxc(:)
2848 : : INTEGER, INTENT(IN), OPTIONAL :: fin
2849 : : INTEGER :: i,Npts
2850 : 230 : REAL(dp),ALLOCATABLE :: gradient(:),gradmag(:),gxc(:),dgxcdr(:),fxc(:)
2851 : : REAL(dp) :: dfxcdn,dfxcdgbg
2852 : 230 : Npts=Grid%n
2853 [ + + ]: 230 : IF (PRESENT(fin)) Npts=fin
2854 [ - + + - : 690 : LIBPAW_ALLOCATE(gradient,(Npts))
+ - + - -
+ - + ]
2855 [ - + + - : 460 : LIBPAW_ALLOCATE(gradmag,(Npts))
- + - + ]
2856 [ - + + - : 460 : LIBPAW_ALLOCATE(gxc,(Npts))
- + - + ]
2857 [ - + + - : 460 : LIBPAW_ALLOCATE(dgxcdr,(Npts))
- + - + ]
2858 [ - + + - : 460 : LIBPAW_ALLOCATE(fxc,(Npts))
- + - + ]
2859 : 230 : CALL derivative(Grid,density(1:Npts),gradient(1:Npts),1,Npts)
2860 [ - + + + ]: 362680 : gradmag=ABS(gradient)
2861 [ + + ]: 362450 : DO i=1,Npts
2862 : 362220 : CALL pbefunc(density(i),gradmag(i),fxc(i),dfxcdn,dfxcdgbg,mu,beta)
2863 : 362220 : vxc(i)=dfxcdn
2864 : 362450 : gxc(i)=dfxcdgbg*gradient(i)
2865 : : ENDDO
2866 : 230 : CALL derivative(Grid,gxc(1:Npts),dgxcdr(1:Npts),1,Npts)
2867 [ + + ]: 362220 : DO i=2,Npts
2868 : 361990 : fxc(i)=2*fxc(i)*4*pi*(Grid%r(i)**2) !2* changes from Har to Ryd
2869 : 362220 : vxc(i)=2*vxc(i)-2*dgxcdr(i)-4*gxc(i)/Grid%r(i) ! Correction thanks
2870 : : ! to Marc Torrent and Francois Jollet
2871 : : ENDDO
2872 : 230 : fxc(1)=zero
2873 : 230 : CALL extrapolate(vxc)
2874 : 230 : Exc = integrator(Grid,fxc,1,Npts)
2875 [ - + ]: 230 : LIBPAW_DEALLOCATE(gradient)
2876 [ - + ]: 230 : LIBPAW_DEALLOCATE(gradmag)
2877 [ - + ]: 230 : LIBPAW_DEALLOCATE(gxc)
2878 [ - + ]: 230 : LIBPAW_DEALLOCATE(dgxcdr)
2879 : 230 : LIBPAW_DEALLOCATE(fxc)
2880 : 230 : RETURN
2881 : : END SUBROUTINE radialexcpbe
2882 : :
2883 : :
2884 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2885 : : !! exch
2886 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2887 [ - + + - : 377 : SUBROUTINE exch(Grid,den,rvxc,etxc,eexc,itype,fin,v0,v0p,needvtau,tau,vtau,xc_functionals)
+ - - + -
+ + - + -
- + ]
2888 : : ! calculate exchange correlation potentials and energies
2889 : : ! for density functional theory from electron density
2890 : : ! den(n) is electron density * (4*pi*r**2)
2891 : : ! rvxc(n) is returned as vxc * r
2892 : : ! eexc is the total exchange energy (int(den*exc))
2893 : : ! etxc is eexc - int(den*vxc)
2894 : : ! icx id of the exchange-correlation functional
2895 : : ! xclevel level of the exchange-correlation functional used
2896 : : ! fin (optional) is integer range of densities and potentials
2897 : : ! v0 (optional) is extrapolated value of vxc for r=0
2898 : : ! v0p (optional) is extrapolated value of dvxc/dr for r=0
2899 : : ! needvtau (optional) is logical .true. if mgga
2900 : : ! tau(n) (optional) is kinetic energy density * (4*pi*r**2)
2901 : : ! vtau(n) (optional) is kinetic energy contribution for mgga
2902 : : TYPE (GridInfo), INTENT(IN) :: Grid
2903 : : REAL(dp), INTENT(IN) :: den(:)
2904 : : REAL(dp), INTENT(INOUT) :: rvxc(:),etxc,eexc
2905 : : type(libxc_functional_type),intent(inout),optional :: xc_functionals(2)
2906 : : integer, intent(in) :: itype
2907 : : INTEGER, INTENT(IN), OPTIONAL :: fin
2908 : : REAL(dp), INTENT(OUT), OPTIONAL :: v0,v0p
2909 : : LOGICAL, INTENT(OUT), OPTIONAL :: needvtau
2910 : : REAL(dp), INTENT(IN),OPTIONAL :: tau(:)
2911 : : REAL(dp), INTENT(INOUT),OPTIONAL :: vtau(:)
2912 : 377 : REAL(dp), ALLOCATABLE :: tmpd(:),tmpv(:),dum(:)
2913 : 377 : REAL(dp), ALLOCATABLE :: exci(:),dfxcdgbg(:,:),gxc(:),dgxcdr(:)
2914 : 377 : REAL(dp), ALLOCATABLE :: grad(:),gradmag(:),dum1(:),sigma(:),tmpvt(:)
2915 : 377 : REAL(dp), ALLOCATABLE :: tmpt(:),tmpl(:),dgxcdl(:),dexcdn(:),dexcds(:)
2916 : : REAL(dp) :: fpi,beta,mu
2917 : : INTEGER :: i,n,order,nspden,ndvxc,nd2vxc
2918 : : REAL(dp) :: r,r2,exc,vxc
2919 : 377 : n=Grid%n
2920 [ + + ]: 377 : IF (PRESENT(fin)) n=fin
2921 : : fpi=four*pi
2922 [ + + ]: 754754 : rvxc=0;etxc=0;eexc=0
2923 [ - + ]: 377 : if (PRESENT(v0)) v0=0
2924 [ - + ]: 377 : if (PRESENT(v0p)) v0p=0
2925 [ + - ]: 377 : if (PRESENT(needvtau)) then
2926 [ - + - - ]: 377 : if (needvtau.and.(PRESENT(vtau).eqv..false.)) then
2927 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'exch: Inconsistency in mgga ', needvtau,PRESENT(vtau)
2928 : 0 : LIBPAW_ERROR('exch: stopping execution ')
2929 : : endif
2930 : : endif
2931 [ + - + + ]: 754754 : if (PRESENT(vtau)) vtau=0._dp
2932 [ + + ]: 377 : If (itype==GGA_PBE.or.itype==GGA_PBESOL) then
2933 [ - + + - : 690 : LIBPAW_ALLOCATE(tmpd,(n))
+ - + - -
+ - + ]
2934 [ - + + - : 460 : LIBPAW_ALLOCATE(tmpv,(n))
- + - + ]
2935 [ + + ]: 362450 : tmpd=zero
2936 [ + - ]: 230 : if(itype==GGA_PBE) then
2937 : 230 : mu=muorig;beta=betorig
2938 : : else
2939 : 0 : mu=musol;beta=betsol
2940 : : endif
2941 [ + + ]: 362220 : DO i=2,n
2942 : 362220 : tmpd(i)=den(i)/(fpi*(Grid%r(i)**2))
2943 : : ENDDO
2944 : 230 : CALL extrapolate(tmpd)
2945 [ + + ]: 230 : IF (PRESENT(fin)) THEN
2946 : 216 : CALL radialexcpbe(Grid,tmpd,eexc,tmpv,mu,beta,fin)
2947 : : ELSE
2948 : 14 : CALL radialexcpbe(Grid,tmpd,eexc,tmpv,mu,beta)
2949 : : ENDIF
2950 [ - + ]: 230 : IF (PRESENT(v0).AND.PRESENT(v0p)) THEN
2951 : 0 : CALL derivative(Grid,tmpv,tmpd,1,15)
2952 : 0 : v0=tmpv(1)
2953 : 0 : v0p=tmpd(1)
2954 : : ENDIF
2955 [ + + ]: 362450 : DO i=1,n
2956 : 362220 : rvxc(i)=tmpv(i)*Grid%r(i)
2957 : 362450 : tmpv(i)=tmpv(i)*den(i)
2958 : : ENDDO
2959 : 230 : etxc=eexc-integrator(Grid,tmpv(1:n),1,n)
2960 [ - + ]: 230 : LIBPAW_DEALLOCATE(tmpd)
2961 [ - + ]: 230 : LIBPAW_DEALLOCATE(tmpv)
2962 [ - + ]: 147 : ELSE IF (itype==LDA_PW) then !!! ! Perdew-Wang LDA !!!!
2963 [ # # # # : 0 : LIBPAW_ALLOCATE(tmpd,(n))
# # # # #
# # # ]
2964 [ # # # # : 0 : LIBPAW_ALLOCATE(tmpv,(n))
# # # # ]
2965 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(n))
# # # # ]
2966 [ # # # # : 0 : tmpd=0;tmpv=0;rvxc=0;dum=0
# # # # ]
2967 [ # # ]: 0 : DO i=2,n
2968 : 0 : r=Grid%r(i)
2969 : 0 : r2=r*r
2970 : 0 : tmpd(i)=den(i)/(fpi*r2)
2971 : : ENDDO
2972 : 0 : CALL extrapolate(tmpd)
2973 [ # # ]: 0 : DO i=1,n
2974 : 0 : CALL pwldafunc(tmpd(i),exc,vxc)
2975 : 0 : tmpd(i)=den(i)*(exc-vxc)
2976 : 0 : tmpv(i)=den(i)*exc
2977 : 0 : rvxc(i)=Grid%r(i)*vxc
2978 [ # # ]: 0 : IF (PRESENT(v0).AND.PRESENT(v0p)) THEN
2979 [ # # ]: 0 : IF (i==1) v0=vxc
2980 : 0 : dum(i)=vxc
2981 : : ENDIF
2982 : : ENDDO
2983 : 0 : etxc=integrator(Grid,tmpd(1:n),1,n)
2984 : 0 : eexc=integrator(Grid,tmpv(1:n),1,n)
2985 [ # # ]: 0 : IF (PRESENT(v0).AND.PRESENT(v0p)) THEN
2986 : 0 : CALL derivative(Grid,dum,tmpd,1,15)
2987 : 0 : v0p=tmpd(1)
2988 : : ENDIF
2989 [ # # ]: 0 : LIBPAW_DEALLOCATE(tmpd)
2990 [ # # ]: 0 : LIBPAW_DEALLOCATE(tmpv)
2991 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
2992 [ - + ]: 147 : ELSE IF (itype==MGGA_R2SCAN_001.or.itype==MGGA_R2SCAN_01) then !!r2scan
2993 [ # # # # : 0 : LIBPAW_ALLOCATE(tmpd,(n))
# # # # #
# # # ]
2994 [ # # # # : 0 : LIBPAW_ALLOCATE(tmpv,(n))
# # # # ]
2995 [ # # # # : 0 : LIBPAW_ALLOCATE(exci,(n))
# # # # ]
2996 [ # # # # : 0 : LIBPAW_ALLOCATE(tmpt,(n))
# # # # ]
2997 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(n))
# # # # ]
2998 [ # # # # : 0 : LIBPAW_ALLOCATE(dum1,(n))
# # # # ]
2999 [ # # # # : 0 : tmpd=0._dp; tmpv=0._dp; exci=0._dp;tmpt=0._dp
# # # # ]
3000 [ # # ]: 0 : dum1=0._dp
3001 [ # # ]: 0 : tmpd(2:n)=den(2:n)/(fpi*(Grid%r(2:n)**2))
3002 : 0 : call extrapolate(tmpd)
3003 [ # # # # : 0 : LIBPAW_ALLOCATE(grad,(n))
# # # # ]
3004 [ # # # # : 0 : LIBPAW_ALLOCATE(sigma,(n))
# # # # ]
3005 [ # # # # : 0 : LIBPAW_ALLOCATE(dexcdn,(n))
# # # # ]
3006 [ # # # # : 0 : LIBPAW_ALLOCATE(dexcds,(n))
# # # # ]
3007 [ # # # # : 0 : grad=0._dp;sigma=0._dp;dexcdn=0._dp;dexcds=0._dp
# # # # ]
3008 [ # # ]: 0 : do i=1,n
3009 : 0 : dum1(i)=ddlog(tmpd(i))
3010 : : enddo
3011 : 0 : call derivative(Grid,dum1,grad,1,n)
3012 [ # # ]: 0 : grad(1:n)=grad(1:n)*tmpd(1:n) ! perhaps more accurate???
3013 [ # # # # ]: 0 : sigma=grad**2
3014 : : ! Prepare kinetic energy input tau -- used for most mgga
3015 [ # # ]: 0 : tmpt(2:n)=tau(2:n)/(fpi*(Grid%r(2:n)**2))
3016 : 0 : call extrapolate(tmpt)
3017 : : ! convert to Hartree units
3018 [ # # ]: 0 : tmpt=0.5_dp*tmpt
3019 [ # # ]: 0 : do i=1,n
3020 : : call r2scanfun(tmpd(i),grad(i),tmpt(i),&
3021 : 0 : & exci(i),vtau(i),dexcdn(i),dexcds(i))
3022 : : enddo
3023 : : ! convert to Rydberg units
3024 [ # # ]: 0 : exci=two*exci
3025 [ # # ]: 0 : dexcdn=two*dexcdn
3026 [ # # ]: 0 : dexcds=four*dexcds !extra factor of two due to sigma=grad**2
3027 [ # # ]: 0 : rvxc=0._dp
3028 [ # # ]: 0 : rvxc=dexcdn
3029 [ # # ]: 0 : dum(1:n)=dexcds(1:n)
3030 : 0 : call derivative(Grid,dum,dum1,1,n)
3031 [ # # ]: 0 : dum(2:n)=two*dum(2:n)/(Grid%r(2:n))
3032 : 0 : call extrapolate(dum)
3033 [ # # ]: 0 : rvxc=rvxc-dum1-dum
3034 [ # # ]: 0 : dum(1:n)=exci(1:n)*fpi*(Grid%r(1:n)**2)
3035 : 0 : eexc=integrator(Grid,dum(1:n),1,n)
3036 [ # # ]: 0 : dum(1:n)=rvxc(1:n)*den(1:n)
3037 : 0 : etxc=eexc-integrator(Grid,dum(1:n),1,n)
3038 [ # # ]: 0 : rvxc(1:n)=(dexcdn(1:n)-dum1(1:n))*Grid%r(1:n)-two*dexcds(1:n)
3039 [ # # ]: 0 : LIBPAW_DEALLOCATE(grad)
3040 [ # # ]: 0 : LIBPAW_DEALLOCATE(sigma)
3041 [ # # ]: 0 : LIBPAW_DEALLOCATE(dexcdn)
3042 [ # # ]: 0 : LIBPAW_DEALLOCATE(dexcds)
3043 [ # # ]: 0 : LIBPAW_DEALLOCATE(tmpd)
3044 [ # # ]: 0 : LIBPAW_DEALLOCATE(tmpv)
3045 [ # # ]: 0 : LIBPAW_DEALLOCATE(exci)
3046 [ # # ]: 0 : LIBPAW_DEALLOCATE(tmpt)
3047 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
3048 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum1)
3049 [ + - ]: 147 : ELSE IF (itype==LIBXC) then
3050 : : ! Parameters
3051 [ + - - + : 147 : if(.not.libxc_functionals_islda(xc_functionals).and..not.libxc_functionals_isgga(xc_functionals)) then
- - ]
3052 : 0 : STOP
3053 : : endif
3054 : 147 : order=1
3055 : 147 : nspden=1
3056 : 147 : ndvxc=0
3057 : 147 : nd2vxc=0
3058 : : ! Allocations
3059 [ - + + - : 441 : LIBPAW_ALLOCATE(tmpd,(n))
+ - + - -
+ - + ]
3060 [ - + + - : 294 : LIBPAW_ALLOCATE(tmpv,(n))
- + - + ]
3061 [ - + + - : 294 : LIBPAW_ALLOCATE(exci,(n))
- + - + ]
3062 [ - + + - : 294 : LIBPAW_ALLOCATE(tmpt,(n))
- + - + ]
3063 [ - + + - : 294 : LIBPAW_ALLOCATE(grad,(n))
- + - + ]
3064 [ - + + - : 294 : LIBPAW_ALLOCATE(gradmag,(n))
- + - + ]
3065 [ - + + - : 294 : LIBPAW_ALLOCATE(gxc,(n))
- + - + ]
3066 [ - + + - : 294 : LIBPAW_ALLOCATE(dgxcdr,(n))
- + - + ]
3067 [ - + + - : 441 : LIBPAW_ALLOCATE(dfxcdgbg,(n,3))
+ - + - -
+ - + ]
3068 [ - + + - : 294 : LIBPAW_ALLOCATE(tmpl,(n))
- + - + ]
3069 [ - + + - : 294 : LIBPAW_ALLOCATE(dgxcdl,(n))
- + - + ]
3070 [ - + + - : 294 : LIBPAW_ALLOCATE(tmpvt,(n))
- + - + ]
3071 [ - + + - : 294 : LIBPAW_ALLOCATE(dum,(n))
- + - + ]
3072 [ - + + - : 294 : LIBPAW_ALLOCATE(dum1,(n))
- + - + ]
3073 [ + + + + : 1016855 : tmpd=0._dp; tmpv=0._dp; exci=0._dp;tmpt=0._dp
+ + + + ]
3074 [ + + + + : 1779827 : grad=0._dp;gradmag=0._dp;gxc=0._dp;dgxcdr=0._dp;dfxcdgbg=0._dp
+ + + + +
+ + + ]
3075 [ + + + + : 1271032 : tmpl=0._dp; dgxcdl=0._dp;tmpvt=0._dp;dum=0._dp;dum1=0._dp
+ + + + +
+ ]
3076 : : ! Density
3077 [ + + ]: 254177 : tmpd(2:n)=den(2:n)/(fpi*(Grid%r(2:n)**2))
3078 : 147 : call extrapolate(tmpd)
3079 : : ! Grad
3080 [ + + ]: 254324 : tmpv=0._dp
3081 [ + + ]: 254324 : do i=1,n
3082 : 254324 : tmpv(i)=ddlog(tmpd(i))
3083 : : enddo
3084 : 147 : call derivative(Grid,tmpv,grad,1,n)
3085 [ + + ]: 254324 : grad(1:n)=grad(1:n)*tmpd(1:n) ! perhaps more accurate???
3086 [ + + ]: 254324 : tmpv=0._dp
3087 [ - + + + ]: 254471 : gradmag=ABS(grad)*ABS(grad)
3088 : : ! Tau
3089 [ + + ]: 254177 : tmpt(2:n)=tau(2:n)/(fpi*(Grid%r(2:n)**2))
3090 : 147 : call extrapolate(tmpt)
3091 : : ! Laplacian
3092 : 147 : call derivative(Grid,grad,tmpl,1,n)
3093 [ + + ]: 254177 : tmpl(2:n)=tmpl(2:n)+2._dp*grad(2:n)/Grid%r(2:n)
3094 : 147 : call extrapolate(tmpl)
3095 : : ! calc
3096 [ + + ]: 254324 : tmpd=tmpd/two
3097 [ + + ]: 254324 : gradmag=gradmag/four
3098 : : call libxc_functionals_getvxc(ndvxc,nd2vxc,n,nspden,order,tmpd,exci,tmpv,&
3099 : : & grho2=gradmag,lrho=tmpl,vxcgr=dfxcdgbg,vxclrho=dgxcdl,tau=tmpt,vxctau=tmpvt,&
3100 : 147 : & xc_functionals=xc_functionals)
3101 [ + + ]: 254324 : tmpd=tmpd*two
3102 [ + + ]: 254324 : gradmag=gradmag*four
3103 : : ! Units
3104 [ + + ]: 254324 : exci=two*exci
3105 [ + + ]: 254324 : tmpv=two*tmpv
3106 [ + + + + ]: 763119 : dfxcdgbg=dfxcdgbg*two
3107 : : ! Post-process
3108 [ + + ]: 254324 : gxc(1:n)=dfxcdgbg(1:n,3)*grad(1:n)
3109 : 147 : call derivative(Grid,gxc,dgxcdr,1,n)
3110 [ + + ]: 254177 : tmpv(2:n)=tmpv(2:n)-dgxcdr(2:n)-2._dp*gxc(2:n)/Grid%r(2:n)
3111 : 147 : call extrapolate(tmpv)
3112 : : ! dum=0._dp
3113 : : ! call derivative(Grid,dgxcdl,dum,1,n)
3114 : : ! dum1=0._dp
3115 : : ! call derivative(Grid,dum,dum1,1,n)
3116 : : ! tmpv(2:n)=tmpv(2:n)+dum1(2:n)+2._dp*dum(2:n)/Grid%r(2:n)
3117 : : ! call extrapolate(tmpv)
3118 : : ! if (needvtau) vtau=tmpvt
3119 [ + + ]: 254324 : do i=1,n
3120 [ + - + + ]: 254177 : if (.not.ieee_is_normal(tmpv(i)).or.abs(tmpv(i)).lt.practical_zero) tmpv(i)=0._dp
3121 [ + - + + ]: 254177 : if (.not.ieee_is_normal(exci(i)).or.abs(exci(i)).lt.practical_zero)exci(i)=0._dp
3122 [ + - + - ]: 254177 : if (.not.ieee_is_normal(vtau(i)).or.abs(vtau(i)).lt.practical_zero)vtau(i)=0._dp
3123 [ + - + + ]: 254324 : if (.not.ieee_is_normal(tmpd(i)).or.abs(tmpd(i)).lt.practical_zero)tmpd(i)=0._dp
3124 : : enddo
3125 [ + + ]: 294294 : rvxc=0._dp
3126 [ + + ]: 254324 : rvxc(1:n)=tmpv(1:n)*Grid%r(1:n)
3127 [ + + ]: 254324 : exci(1:n)=exci(1:n)*tmpd(1:n)*fpi*Grid%r(1:n)**2
3128 : 147 : eexc=integrator(Grid,exci,1,n)
3129 [ - + ]: 147 : if (present(v0).and.present(v0p)) then
3130 : 0 : call derivative(Grid,tmpv,tmpd,1,15)
3131 : 0 : v0=tmpv(1);v0p=tmpd(1)
3132 : : endif
3133 [ + + ]: 254324 : tmpv(1:n)=tmpv(1:n)*den(1:n)
3134 : 147 : etxc=eexc-integrator(Grid,tmpv(1:n),1,n)
3135 [ - + ]: 147 : if(has_to_print) WRITE(STD_OUT,*) 'etxc,eexc = ',etxc,eexc
3136 : : ! DEALLOCATE
3137 [ - + ]: 147 : LIBPAW_DEALLOCATE(tmpd)
3138 [ - + ]: 147 : LIBPAW_DEALLOCATE(tmpv)
3139 [ - + ]: 147 : LIBPAW_DEALLOCATE(exci)
3140 [ - + ]: 147 : LIBPAW_DEALLOCATE(tmpt)
3141 [ - + ]: 147 : LIBPAW_DEALLOCATE(grad)
3142 [ - + ]: 147 : LIBPAW_DEALLOCATE(gradmag)
3143 [ - + ]: 147 : LIBPAW_DEALLOCATE(gxc)
3144 [ - + ]: 147 : LIBPAW_DEALLOCATE(dgxcdr)
3145 [ - + ]: 147 : LIBPAW_DEALLOCATE(dfxcdgbg)
3146 [ - + ]: 147 : LIBPAW_DEALLOCATE(tmpl)
3147 [ - + ]: 147 : LIBPAW_DEALLOCATE(dgxcdl)
3148 [ - + ]: 147 : LIBPAW_DEALLOCATE(tmpvt)
3149 [ - + ]: 147 : LIBPAW_DEALLOCATE(dum)
3150 [ - + ]: 147 : LIBPAW_DEALLOCATE(dum1)
3151 : : else
3152 : 0 : WRITE(STD_OUT,*) 'Warning (EXCOR): ', itype,' no results returned !'
3153 : 0 : STOP
3154 : : END if
3155 [ - + - + : 377 : END SUBROUTINE exch
- + - + -
+ - + - +
- + - + -
+ ]
3156 : :
3157 : :
3158 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3159 : : !! pwldafunc
3160 : : !! Subroutine to calculate the LDA exchange correlation functionals
3161 : : !! using the form of Perdew and Wang (PRB 45, 13244 (1992)
3162 : : !! assuming no spin polarization
3163 : : !! Inside this routine, energies are in Hartree units
3164 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3165 : 0 : SUBROUTINE pwldafunc(den,exc,vxc)
3166 : : real(dp), INTENT(IN) :: den !density
3167 : : real(dp), INTENT(OUT) :: exc,vxc
3168 : : real(dp), PARAMETER :: AA=0.0310907_dp
3169 : : real(dp), PARAMETER :: a1=0.21370_dp
3170 : : real(dp), PARAMETER :: b1=7.59570_dp
3171 : : real(dp), PARAMETER :: b2=3.58760_dp
3172 : : real(dp), PARAMETER :: b3=1.63820_dp
3173 : : real(dp), PARAMETER :: b4=0.49294_dp
3174 : : ! Variables depending on den
3175 : : real(dp) :: n,kf,rs,ks
3176 : : real(dp) :: ex,ec,pprs,decdrs
3177 : : real(dp) :: term
3178 : 0 : n=den
3179 [ # # ]: 0 : IF (n < machine_zero) THEN
3180 : 0 : exc=0._dp; vxc=0._dp
3181 : 0 : RETURN
3182 : : ENDIF
3183 : 0 : kf=(3._dp*(pi**2)*n)**0.3333333333333333333333333333_dp
3184 : 0 : rs=(3._dp/(4._dp*pi*n))**0.3333333333333333333333333333_dp
3185 : : ks=SQRT(4._dp*kf/pi)
3186 : 0 : ex=-3._dp*kf/(4._dp*pi)
3187 : 0 : pprs=SQRT(rs)*(b1+b3*rs)+rs*(b2+b4*rs)
3188 : 0 : term=Logofterm(1._dp/(2._dp*AA*pprs))
3189 : 0 : ec=-2._dp*AA*(1._dp+a1*rs)*term
3190 : 0 : exc=ex+ec
3191 : : decdrs=-(2._dp*AA*a1)*term &
3192 : : & +((1._dp+a1*rs)*((b1+3*b3*rs)/(2._dp*SQRT(rs))+&
3193 : 0 : & b2+2*b4*rs))/(pprs*(pprs+1._dp/(2._dp*AA)))
3194 : 0 : vxc = (4._dp/3._dp)*ex+ec-(decdrs*rs)/3._dp
3195 [ # # # # ]: 0 : IF ((ABS(exc).GT.1.d65).OR.(ABS(vxc).GT.1.d65)) THEN
3196 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Problem in PW',n,rs,ec
3197 : : ENDIF
3198 : 0 : exc=2*exc; vxc=2*vxc ! change to Rydberg units
3199 : 0 : RETURN
3200 : : END SUBROUTINE pwldafunc
3201 : :
3202 : :
3203 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3204 : : ! Subroutine to calculate the exchange correlation functionals
3205 : : ! using the form of Perdew, Burke, and Ernzerhof (PRL 77, 3865 (1996))
3206 : : ! assuming no spin polarization
3207 : : ! Inside this routine, energies are in Hartree units
3208 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3209 : 362220 : SUBROUTINE pbefunc(den,grad,fxc,dfxcdn,dfxcdgbg,mu,beta)
3210 : : REAL(dp), INTENT(IN) :: den,grad,mu,beta !density, magnitude of grad(density)
3211 : : REAL(dp), INTENT(OUT) :: fxc,dfxcdn,dfxcdgbg
3212 : : REAL(dp) :: n,g,kf,rs,ks,s,t,betabygamm
3213 : : REAL(dp) :: ex,ec,Fx,H,A,pprs,ppt,At2,dFds,dHdt,decdrs,dHdrs,dHdA,dAdrs
3214 : : REAL(dp) :: term,dHdtbg,dFdsbg
3215 : 362220 : betabygamm=beta/gamm
3216 : 362220 : n=den
3217 [ + + ]: 362220 : IF (n < machine_zero) THEN
3218 : 5738 : fxc=0.0_dp; dfxcdn=0.0_dp; dfxcdgbg=0.0_dp
3219 : 5738 : RETURN
3220 : : ENDIF
3221 : 356482 : g=grad
3222 [ - + ]: 356482 : IF (g < machine_zero) g=machine_zero
3223 : 356482 : kf=(3.0_dp*(pi**2)*n)**0.3333333333333333333333333333_dp
3224 : 356482 : rs=(3.0_dp/(4.0_dp*pi*n))**0.3333333333333333333333333333_dp
3225 : 356482 : ks=SQRT(4.0_dp*kf/pi)
3226 : 356482 : s=g/(2.0_dp*kf*n)
3227 : 356482 : t=g/(2.0_dp*ks*n)
3228 [ + - - + ]: 356482 : IF (s*s > machine_infinity .or. t*t > machine_infinity) THEN
3229 : 0 : fxc=0.0_dp; dfxcdn=0.0_dp; dfxcdgbg=0.0_dp
3230 : 0 : RETURN
3231 : : ENDIF
3232 : 356482 : ex=-3.0_dp*kf/(4.0_dp*pi)
3233 : 356482 : pprs=SQRT(rs)*(b1+b3*rs)+rs*(b2+b4*rs)
3234 : 356482 : term=Logofterm(1.0_dp/(2.0_dp*AA*pprs))
3235 : 356482 : ec=-2.0_dp*AA*(1.0_dp+a1*rs)*term
3236 : 356482 : Fx=1.0_dp+kappa -kappa/(1.0_dp+(mu/kappa)*s*s)
3237 : 356482 : A=Aofec(ec,betabygamm,beta)
3238 : 356482 : At2=A*t*t
3239 : 356482 : ppt=(1.0_dp+At2*(1.0_dp+At2))
3240 : 356482 : H=gamm*Logofterm((betabygamm)*(t*t)*((1._dp+At2)/ppt))
3241 : 356482 : fxc=n*(ex*Fx+ec+H)
3242 : 356482 : dFds = (2.0_dp*mu*s)/(1.0_dp+(mu/kappa)*(s**2))**2
3243 : 356482 : dFdsbg = ((2.0_dp*mu)/(1.0_dp+(mu/kappa)*(s**2))**2)/(2._dp*kf*n)
3244 : : dHdt = (2._dp*t*beta*gamm*(1._dp+2._dp*At2))/&
3245 : 356482 : & ((gamm*ppt+beta*t*t*(1._dp+At2))*ppt)
3246 : : dHdtbg = ((2._dp*beta*gamm*(1._dp+ &
3247 : 356482 : & 2._dp*At2))/((gamm*ppt+beta*t*t*(1._dp+At2))*ppt))/(2._dp*ks*n)
3248 : : decdrs=-(2._dp*AA*a1)*term &
3249 : : & +((1._dp+a1*rs)*((b1+3*b3*rs)/(2._dp*SQRT(rs))+ &
3250 : 356482 : & b2+2*b4*rs))/(pprs*(pprs+1._dp/(2._dp*AA)))
3251 : : dHdA=((2._dp+At2)*(At2*t*t*t*t*beta*gamm))/&
3252 : 356482 : & ((gamm*ppt+beta*t*t*(1._dp+At2))*ppt)
3253 : 356482 : dAdrs=-ddexp(-ec/gamm)*A*A*decdrs/beta
3254 : 356482 : dHdrs=dHdA*dAdrs
3255 : : dfxcdn = (4._dp/3._dp)*ex*(Fx-dFds*s)+ec-(decdrs*rs)/3._dp+H-(dHdrs*rs)/3._dp &
3256 : 356482 : & - (7._dp/6._dp)*dHdt*t
3257 : 356482 : dfxcdgbg = ex*dFdsbg/(2._dp*kf) + dHdtbg/(2._dp*ks)
3258 [ + - + - : 356482 : IF ((ABS(fxc).GT.1.d65).OR.(ABS(dfxcdn).GT.1.d65).OR.&
- + ]
3259 : : & (ABS(dfxcdgbg).GT.1.d65)) THEN
3260 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Problem in PBE',n,g,rs,s,t,ec,A,H
3261 : : ENDIF
3262 : : RETURN
3263 : : END SUBROUTINE pbefunc
3264 : :
3265 : :
3266 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3267 : : !! Function Aofec -- needed to take care of behavior for small ec
3268 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3269 : 356482 : FUNCTION Aofec(ec,betabygamm,beta)
3270 : : REAL(dp) :: ec, Aofec, betabygamm,beta
3271 [ + + ]: 356482 : IF (ABS(ec)>machine_precision) THEN
3272 : 354797 : Aofec=betabygamm/(ddexp(-ec/gamm)-1.0_dp)
3273 [ + - ]: 1685 : ELSEIF (ABS(ec)>machine_zero) THEN
3274 : 1685 : Aofec=beta/(-ec)
3275 : : ELSE
3276 : 0 : Aofec=-beta*DSIGN(machine_infinity,ec)
3277 : : ENDIF
3278 : : RETURN
3279 : : END FUNCTION Aofec
3280 : :
3281 : :
3282 : :
3283 : :
3284 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3285 : : ! 5. r2scan
3286 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3287 : :
3288 : :
3289 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3290 : : !! r2scaninit
3291 : : !!
3292 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3293 : 0 : SUBROUTINE r2scaninit(etain)
3294 : : REAL(dp), INTENT(IN) :: etain
3295 : : REAL(dp) :: o
3296 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'r2scan calculation with eta ', etain
3297 : 0 : eta=etain
3298 : 0 : o=cx1+two*cx2+three*cx3+four*cx4+five*cx5+six*cx6+seven*cx7
3299 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'r2scan check C2' , o*k0
3300 : 0 : C2Ceta = (20.0_dp/27.0_dp + (5*eta)/three)*o*k0
3301 : 0 : END SUBROUTINE r2scaninit
3302 : :
3303 : :
3304 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3305 : : !! r2scan functional
3306 : : !! length units == Bohr
3307 : : !! energy units -- Hartree
3308 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3309 : 0 : SUBROUTINE r2scanfun(rho,grad,tau,exc,vtau,vxcn,vxcs)
3310 : : REAL(dp), INTENT(IN) :: rho,grad, tau
3311 : : REAL(dp), INTENT(INOUT) :: exc,vtau,vxcn,vxcs
3312 : : REAL(dp) :: rr,ss,tt,sigma
3313 : : REAL(dp) :: kF,ks,rs,U,s,p,t,W,baralpha
3314 : : REAL(dp) :: gx,x,h0x,h1x,fx,ffx,exarg,ddfx,vxtau,ex,vx
3315 : : REAL(dp) :: ELDA,ELDA0,fc,ddfc,w1,w0,ginfinity,H0c,H1c,ec0,ec1,y
3316 : : REAL(dp) :: beta,srs,ddLDA,difddLDA,gg,corarg,ddy,vctau
3317 : : REAL(dp) :: alphadenom,dalphadn,dalphads
3318 : : REAL(dp) :: gxp,dpdn,dgxdn,dpds,dgxds,drsdn,dt2ds,dt2dn,t2
3319 : : REAL(dp) :: h1xx,xp,dh1xdn,dh1xds,vxn,vxs
3320 : : REAL(dp) :: vcn,vcs,dLDA0dn,dH0cdn,dw0dn,dgindn,dw1dn
3321 : : REAL(dp) :: dH0cds,dginds,dbetadn,dif2ddLDA,dLDAdn
3322 : : REAL(dp) :: pp,dppds,dppdn,dyds,dydn,dUdn,dWds,dWdn
3323 : : REAL(dp) :: term1,term4,dddyds,dddydnp,dddydnw,dddydnr,dH1cds
3324 : : REAL(dp) :: stf1,stf2,stf3,stf4,stf5,stf6,stf7
3325 : : REAL(dp) :: dddydnn,dddydn,dH1cdwn,dH1cdn,dec1dn,dec1ds
3326 : : REAL(dp) :: dec0ds,dec0dn,bigdenom
3327 : : REAL(dp) :: eex,eec,vtx,vtc,vvxn,vvcn,vvxs,vvcs
3328 : 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
3329 [ # # ]: 0 : if(rho<(machine_zero**0.333333333333333333333333333333333_dp)) return
3330 : 0 : sigma=grad*grad
3331 : 0 : rr=rho;ss=sigma;tt=tau
3332 : 0 : rr=max(machine_zero,rr)
3333 : 0 : rr=min(machine_infinity,rr)
3334 : 0 : ss=max(machine_zero,ss)
3335 : 0 : ss=min(machine_infinity,ss)
3336 : 0 : tt=max(machine_zero,tt)
3337 : 0 : tt=min(machine_infinity,tt)
3338 : : ! Note that all derivatives with respect to sigma are also multiplied
3339 : : ! by grad
3340 : 0 : kF=3.0936677262801359310_dp*(rr**0.33333333333333333333333333333_dp)
3341 : 0 : ks=1.9846863952198559283_dp*(rr**0.16666666666666666666666666667_dp)
3342 : 0 : rs=0.62035049089940001665_dp/(rr**0.33333333333333333333333333333_dp)
3343 : 0 : drsdn=-rs/(3*rr)
3344 : 0 : srs=sqrt(rs)
3345 : 0 : U=2.8712340001881918160_dp*(rr**1.66666666666666666666666666667_dp)
3346 : 0 : dUdn=(1.666666666666666666666667_dp)*2.8712340001881918160_dp*(rr**0.66666666666666666666666666667_dp)
3347 : 0 : s=sqrt(ss)*0.16162045967399548133_dp/(rr**1.33333333333333333333333333333_dp)
3348 : 0 : p=s*s
3349 : 0 : dpdn=-2.666666666666666666666666667_dp*p/rr
3350 : 0 : dpds=0.026121172985233599568_dp*grad/(rr**2.666666666666666666666666666666667_dp)
3351 : 0 : t=sqrt(ss)*0.25192897034224488769_dp/(rr**1.166666666666666666666666666667_dp)
3352 : 0 : t2=t*t
3353 : 0 : dt2ds=0.063468206097703704205_dp*grad/(rr**2.3333333333333333333333333333_dp)
3354 : 0 : dt2dn=-t2*(2.333333333333333333333333333333333333_dp)/rr
3355 : 0 : W=0.125_dp*ss/rr
3356 : 0 : dWds=0.125_dp*grad/rr
3357 : 0 : dWdn=-W/rr
3358 : 0 : baralpha=(tt-W)/(U+eta*W)
3359 : : !!!!!!exchange part
3360 : 0 : gx=1._dp-ddexp(-SCANa1/(p**0.25_dp))
3361 : 0 : x=(c2ceta*ddexp(-(p**2)/dp2**4)+mu)*p
3362 : 0 : xp=c2ceta*ddexp(-(p**2)/dp2**4)*(-2*(p**2)/dp2**4+1._dp)+mu
3363 : 0 : h0x=1+k0
3364 : 0 : h1x=1._dp+k1-k1/(1+x/k1)
3365 [ # # ]: 0 : if(baralpha<1.d-13) then
3366 : 0 : fx=ddexp(-SCANc1x*baralpha/(1._dp-baralpha))
3367 [ # # ]: 0 : elseif (baralpha.lt.2.5_dp) then
3368 : : fx=cx0+baralpha*(cx1+baralpha*(cx2+baralpha*(cx3+baralpha*( &
3369 : 0 : & cx4+baralpha*(cx5+baralpha*(cx6+baralpha*cx7))))))
3370 [ # # ]: 0 : else if (baralpha.ge.2.5_dp) then
3371 : 0 : fx=-SCANdx*ddexp(SCANc2x/(1._dp-baralpha))
3372 : : endif
3373 [ # # ]: 0 : if(baralpha<1.d-13) then
3374 : 0 : ddfx=-(SCANc1x/((1._dp-baralpha)**2))*ddexp(-SCANc1x*baralpha/(1._dp-baralpha))
3375 [ # # ]: 0 : else if (baralpha.lt.2.5_dp) then
3376 : : ddfx=(cx1+baralpha*(2*cx2+baralpha*(3*cx3+baralpha*( &
3377 : 0 : & 4*cx4+baralpha*(5*cx5+baralpha*(6*cx6+baralpha*7*cx7))))))
3378 [ # # ]: 0 : else if (baralpha.ge.2.5_dp) then
3379 : 0 : ddfx=-(SCANdx*SCANc2x/((1._dp-baralpha)**2))*ddexp(SCANc2x/(1._dp-baralpha))
3380 : : endif
3381 : 0 : ffx=(h1x+fx*(h0x-h1x))*gx
3382 : 0 : ex=-0.73855876638202240587_dp*(rr**1.3333333333333333333333333333333333_dp)
3383 : 0 : vx=-0.98474502184269654116_dp*(rr**0.3333333333333333333333333333333333_dp)
3384 : 0 : exarg=ex*ffx
3385 : 0 : vxtau=ex*ddfx*((h0x-h1x)*gx)/(U+eta*W)
3386 : : ! density and sigma derivative terms
3387 : 0 : alphadenom=(U+eta*W)**2
3388 : 0 : dalphads=-(U+eta*tau)*dWds/alphadenom
3389 : 0 : dalphadn=-((U+eta*tau)*dWdn+(tt-W)*dUdn)/alphadenom
3390 : 0 : gxp=-0.25_dp*SCANa1*ddexp(-SCANa1/(p**0.25_dp))/(p**1.25_dp)
3391 : 0 : dgxdn=gxp*dpdn
3392 : 0 : dgxds=gxp*dpds
3393 : 0 : h1xx=1._dp/((1._dp+x/k1)**2)
3394 : 0 : dh1xdn=h1xx*xp*dpdn
3395 : 0 : dh1xds=h1xx*xp*dpds
3396 : : vxn=vx*ffx+ex*(ddfx*dalphadn*gx*(h0x-h1x)+dgxdn*(h1x+fx*(h0x-h1x)) &
3397 : 0 : & +gx*dh1xdn*(1._dp-fx))
3398 : : vxs=ex*(ddfx*dalphads*gx*(h0x-h1x)+dgxds*(h1x+fx*(h0x-h1x)) &
3399 : 0 : & +gx*dh1xds*(1._dp-fx))
3400 : : !!!! correlation part
3401 : : ELDA=-two*LDAA*(1._dp + LDAa1*rs)*ddlog(1._dp + 0.5_dp &
3402 : 0 : & /(LDAA*(sqrt(rs)*(LDAb1 + LDAb3*rs) + rs*(LDAb2 + LDAb4*rs))))
3403 : 0 : bigdenom=srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)
3404 : : dLDAdn=((-two*LDAA*LDAa1*ddlog(1._dp + &
3405 : : & 1._dp/(two*LDAA*bigdenom))) &
3406 : : & + (LDAa1*rs + 1._dp)*((LDAb3*rs + LDAb1)/(two*srs) + srs*LDAb3 + &
3407 : 0 : & two*LDAb4*rs + LDAb2)/((bigdenom**2)+bigdenom/(two*LDAA)))*drsdn
3408 : 0 : ELDA0= -b1c/(1._dp + b2c*sqrt(rs) + b3c*rs)
3409 : : dLDA0dn=b1c*(0.5_dp*b2c/sqrt(rs)+b3c)/((1._dp + b2c*sqrt(rs) + b3c*rs)**2) &
3410 : 0 : & *drsdn
3411 : 0 : ddLDA=ELDA0-ELDA
3412 : 0 : beta= betaMB*(1._dp + 0.1*rs)/(1._dp + 0.1778_dp*rs)
3413 : 0 : dbetadn=-(0.0778_dp*betaMB/(1._dp + 0.1778_dp*rs)**2)*drsdn
3414 [ # # ]: 0 : if(baralpha<1.d-13) then
3415 : 0 : fc=ddexp(-SCANc1c*baralpha/(1._dp-baralpha))
3416 [ # # ]: 0 : else if (baralpha.lt.2.5_dp) then
3417 : : fc=cc0+baralpha*(cc1+baralpha*(cc2+baralpha*(cc3+baralpha*( &
3418 : 0 : & cc4+baralpha*(cc5+baralpha*(cc6+baralpha*cc7))))))
3419 [ # # ]: 0 : else if (baralpha.ge.2.5_dp) then
3420 : 0 : fc=-SCANdc*ddexp(SCANc2c/(1._dp-baralpha))
3421 : : endif
3422 [ # # ]: 0 : if(baralpha<1.d-13) then
3423 : 0 : ddfc=-(SCANc1c/((1._dp-baralpha)**2))*ddexp(-SCANc1c*baralpha/(1._dp-baralpha))
3424 [ # # ]: 0 : else if (baralpha.lt.2.5_dp) then
3425 : : ddfc=(cc1+baralpha*(2*cc2+baralpha*(3*cc3+baralpha*( &
3426 : 0 : & 4*cc4+baralpha*(5*cc5+baralpha*(6*cc6+baralpha*7*cc7))))))
3427 [ # # ]: 0 : else if (baralpha.ge.2.5_dp) then
3428 : 0 : ddfc=-(SCANdc*SCANc2c/((1._dp-baralpha)**2))*ddexp(SCANc2c/(1._dp-baralpha))
3429 : : endif
3430 : 0 : w1= ddexp(-ELDA/Sgam) - 1._dp
3431 : 0 : dw1dn=-(ddexp(-ELDA/Sgam)/Sgam)*dLDAdn
3432 : 0 : w0= ddexp(-ELDA0/b1c) - 1._dp
3433 : 0 : dw0dn=-(ddexp(-ELDA0/b1c)/b1c)*dLDA0dn
3434 : 0 : ginfinity= 1._dp/(1._dp + 4*chiinfinity*(p))**0.25_dp
3435 : 0 : dgindn=-(chiinfinity*ginfinity/(1._dp + four*chiinfinity*(p)))*dpdn
3436 : 0 : dginds=-(chiinfinity*ginfinity/(1._dp + four*chiinfinity*(p)))*dpds
3437 : 0 : H0c= b1c*ddlog(1._dp + w0*(1._dp - ginfinity))
3438 : 0 : dH0cdn=(b1c/(1._dp+w0*(1._dp-ginfinity)))*((1._dp-ginfinity)*dw0dn-w0*dgindn)
3439 : 0 : dH0cds=(-b1c*w0*dginds/(1._dp+w0*(1._dp-ginfinity)))
3440 : 0 : ec0= ELDA0 + H0c
3441 : 0 : dec0dn=dLDA0dn+dH0cdn
3442 : 0 : dec0ds=dH0cds
3443 : : difddLDA=b1c*(b2c/(two*srs) + b3c)/(1._dp + b2c*srs + b3c*rs)**2 + &
3444 : : & two*LDAA*LDAa1*ddlog(1._dp + &
3445 : : & 1._dp/(2*LDAA*(srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)))) &
3446 : : & - (LDAa1*rs + 1._dp)*((LDAb3*rs + LDAb1)/(two*srs) + srs*LDAb3 + &
3447 : : & two*LDAb4*rs + LDAb2)/(((srs*(LDAb3*rs + LDAb1) + &
3448 : : & rs*(LDAb4*rs + LDAb2))**2)*(1._dp + 1._dp &
3449 : 0 : & /(two*LDAA*(srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)))))
3450 : 0 : y=beta*(t2)/(Sgam*w1)
3451 : 0 : dyds=beta*dt2ds/(Sgam*w1)
3452 : 0 : dydn=(1._dp/(Sgam*w1))*(dbetadn*t2+beta*dt2dn-beta*t2*dw1dn/w1)
3453 : : ddy=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*p&
3454 : 0 : & *ddexp(-(p**2)/(dp2**4))
3455 : 0 : gg=1._dp/(1._dp+4*(y-ddy))**0.25_dp
3456 : 0 : H1c=Sgam*ddlog(1._dp+w1*(1._dp-gg))
3457 : 0 : ec1=ELDA+H1c
3458 : 0 : pp=p*ddexp(-(p**2)/(dp2**4))
3459 : 0 : dppds=((ddexp(-p**2/dp2**4))*(dp2**4 - two*p**2)/dp2**4)*dpds
3460 : 0 : dppdn=((ddexp(-p**2/dp2**4))*(dp2**4 - two*p**2)/dp2**4)*dpdn
3461 : 0 : term1=1._dp+4*(y-ddy)
3462 : 0 : term4=term1**0.25_dp
3463 : 0 : dddyds=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*dppds
3464 : 0 : dddydnp=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*dppdn
3465 : 0 : dddydnw=-(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*pp*dw1dn/w1
3466 : 0 : dddydnr=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*difddLDA)*pp*drsdn
3467 : 0 : dH1cds=(Sgam*w1/(term1*(term4*(1._dp+w1)-w1)))*(dyds-dddyds)
3468 : : stf1=-b1c*(8.0_dp*srs*rs*(b3c**2) + 9.0_dp*b2c*b3c*rs + 3.0_dp*srs*(b2c**2) + b2c)&
3469 : 0 : & /(4.0_dp*rs*srs*((1._dp + b2c*srs + b3c*rs)**3))
3470 : 0 : stf2=srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)
3471 : 0 : stf3=1._dp+1._dp/(2*LDAA*stf2)
3472 : : stf4=(two*LDAa1*((LDAb3*rs+LDAb1)/(two*srs)+srs*LDAb3+two*LDAb4*rs+LDAb2)) &
3473 : 0 : & /((stf2**2)*stf3)
3474 : : stf5=(two*(LDAa1*rs+1._dp)*(((LDAb3*rs+LDAb1)/(two*srs)+srs*LDAb3+ &
3475 : 0 : & two*LDAb4*rs + LDAb2)**2))/((stf2**3)*stf3)
3476 : : stf6=(LDAa1*rs+1._dp)*(-(LDAb3*rs+LDAb1)/(four*srs*rs)+LDAb3/srs + two*LDAb4) &
3477 : 0 : & /((stf2**2)*stf3)
3478 : : stf7=(LDAa1*rs+1._dp)*&
3479 : : & (((LDAb3*rs+LDAb1)/(two*srs)+srs*LDAb3+two*LDAb4*rs+LDAb2)**2) &
3480 : 0 : & /(two*LDAA*(stf2**4)*(stf3**2))
3481 : 0 : dif2ddLDA=stf1-stf4+stf5-stf6-stf7
3482 : 0 : dddydnn=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*dif2ddLDA-45.0_dp*eta*difddLDA)*pp*drsdn
3483 : 0 : dddydn=dddydnw+dddydnp+dddydnr+dddydnn
3484 : 0 : dH1cdwn=Sgam*((term4-1._dp)/(term4*(w1+1._dp)-w1))*dw1dn
3485 : 0 : dH1cdn=dH1cdwn+(Sgam*w1/(term1*(term4*(1._dp+w1)-w1)))*(dydn-dddydn)
3486 : 0 : dec1dn=dLDAdn+dH1cdn
3487 : 0 : dec1ds=dH1cds
3488 : 0 : corarg=rr*(ec1 + fc*(ec0 - ec1))
3489 : 0 : vctau=rr*ddfc*(ec0 - ec1)/(U + eta*W)
3490 : : ! density and sigma derivative terms
3491 : 0 : vcn=ec1+fc*(ec0-ec1)+ddfc*dalphadn*rr*(ec0-ec1)+dec0dn*rr*fc+dec1dn*rr*(1._dp-fc)
3492 : 0 : vcs=ddfc*dalphads*rr*(ec0-ec1)+dec0ds*rr*fc+dec1ds*rr*(1._dp-fc)
3493 : 0 : eex=exarg;eec=corarg; exc=exarg+corarg
3494 : 0 : vtx=vxtau;vtc=vctau; vtau=vxtau+vctau
3495 : 0 : vvxn=vxn; vvcn=vcn; vxcn=vxn+vcn
3496 : 0 : vvxs=vxs; vvcs=vcs; vxcs=vxs+vcs
3497 : : END SUBROUTINE r2scanfun
3498 : :
3499 : :
3500 : :
3501 : :
3502 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3503 : : ! 5. general_mod
3504 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3505 : :
3506 : :
3507 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3508 : : !! Updatewfn(Grid,Pot,Orbit,rvin,success)
3509 : : !! Given new potential rvin, generate new Orbit%wfn,Orbit%eig,Pot%den
3510 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3511 [ - + ]: 371 : SUBROUTINE Updatewfn(Grid,Pot,Orbit,rvin,success,BDsolve,usespline,spline,itype)
3512 : : ! TODO : BDsolve
3513 : : logical,intent(in) :: usespline
3514 : : integer, intent(in) :: itype
3515 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
3516 : : TYPE (PotentialInfo), INTENT(INOUT) :: Pot
3517 : : TYPE (OrbitInfo), INTENT(INOUT) :: Orbit
3518 : : type(splinesolvinfo),intent(inout) :: spline
3519 : : logical, intent(in) :: bdsolve
3520 : : real(dp), INTENT(IN) :: rvin(:)
3521 : : LOGICAL :: success,calc_s,calc_p,calc_d,calc_f,calc_g
3522 : : INTEGER :: icount,n,it,start,ierr,nroot,s1,s2,s2t
3523 : : INTEGER :: io,l,jierr,nz,kappa
3524 : : real(dp) :: h,emin,zz
3525 : : real(dp), ALLOCATABLE :: dum(:)
3526 : : LOGICAL :: OK
3527 : 371 : n=Grid%n; h=Grid%h; nz=Pot%nz; zz=Pot%zz
3528 : 371 : success=.TRUE.
3529 [ - + + - : 1113 : LIBPAW_ALLOCATE(dum,(n))
+ - + - -
+ - + ]
3530 [ + + ]: 742742 : Pot%rv=rvin+Pot%rvn(1:n)
3531 [ + - - + : 743113 : dum=rvin
- - + + ]
3532 [ - + ]: 371 : if (Pot%needvtau) dum(1)=dum(1)-Pot%rvx(1)
3533 : 371 : CALL zeropot(Grid,dum,Pot%v0,Pot%v0p)
3534 [ - + ]: 371 : IF (ABS(Pot%v0)> 1.d6) Pot%v0=0
3535 [ + + ]: 371 : IF (ABS(Pot%v0p)> 1.d6) Pot%v0p=0
3536 [ - + ]: 371 : IF (Pot%finitenucleus) then
3537 : 0 : Pot%v0=Pot%v0+Pot%Nv0
3538 : 0 : Pot%v0p=Pot%v0p+Pot%Nv0p
3539 : : Endif
3540 [ - + ]: 371 : if(usespline) call initpotforsplinesolver(Grid,Pot,Orbit%den,Orbit%tau,spline,itype)
3541 : : ! solve for bound states of Schroedinger equation
3542 : 371 : calc_s=.true.
3543 : 371 : calc_p=.true.
3544 : 371 : calc_d=.true.
3545 : 371 : calc_f=.true.
3546 : 371 : calc_g=.true.
3547 : 371 : icount=0
3548 : 371 : jierr=0
3549 : 371 : it=0
3550 : : ! s states :
3551 [ + - ]: 371 : IF (Orbit%nps.GT.0) THEN
3552 : 371 : it=it+1
3553 : 371 : emin=-nz*nz-0.1_dp
3554 : 371 : l=0
3555 : 371 : nroot=Orbit%nps
3556 : 371 : start=1;s1=start;s2t=start+nroot-1
3557 [ + + ]: 371 : if (Orbit%frozenvalecalculation) then
3558 : 235 : nroot=Orbit%npsc
3559 [ + + ]: 540 : do io=s1+Orbit%npsc,s2t
3560 [ + + ]: 540 : if(Orbit%issemicore(io)) nroot=nroot+1
3561 : : enddo
3562 [ + - ]: 235 : if(nroot.LT.1) calc_s=.false.
3563 : : endif
3564 : 742 : s2=s1+nroot-1
3565 : : if(calc_s) then
3566 [ + + ]: 371 : IF (Orbit%scalarrelativistic) THEN
3567 : : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3568 : 102 : & l,nroot,emin,ierr,OK)
3569 [ + + ]: 269 : ELSE IF (Orbit%diracrelativistic) THEN
3570 : 46 : kappa=-1
3571 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3572 : 46 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3573 [ - + ]: 223 : ELSE IF (Pot%needvtau) THEN
3574 : : Call Boundsplinesolver(Grid,l,nroot, &
3575 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3576 : : ELSE
3577 [ - + ]: 223 : if(usespline) then
3578 : : Call Boundsplinesolver(Grid,l,nroot, &
3579 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3580 : : else
3581 : : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3582 : 223 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3583 : : endif
3584 : : ENDIF
3585 [ + + ]: 371 : IF (.NOT.OK) THEN
3586 : 2 : success=.FALSE.
3587 : : ENDIF
3588 : : endif
3589 : : ENDIF
3590 : : ! p states :
3591 [ + - ]: 371 : IF (Orbit%npp.GT.1) then
3592 : 371 : it=it+1
3593 : 371 : emin=-nz*nz/4._dp-0.5_dp
3594 : 371 : l=1
3595 : 371 : nroot=Orbit%npp-1
3596 : 371 : s1=s2t+1;s2t=s1+nroot-1
3597 [ + + ]: 371 : if (Orbit%frozenvalecalculation) then
3598 : 235 : nroot=Orbit%nppc-1
3599 [ + + ]: 470 : do io=s1+Orbit%nppc-1,s2t
3600 [ + + ]: 470 : if(Orbit%issemicore(io)) nroot=nroot+1
3601 : : enddo
3602 [ + - ]: 235 : if(nroot.LT.1) calc_p=.false.
3603 : : endif
3604 : 371 : s2=s1+nroot-1
3605 [ + - ]: 371 : if(calc_p) then
3606 [ + + ]: 371 : IF (Orbit%scalarrelativistic) THEN
3607 : : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3608 : 102 : & l,nroot,emin,ierr,OK)
3609 [ + + ]: 269 : ELSE IF (Orbit%diracrelativistic) THEN
3610 : 46 : kappa=1
3611 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3612 : 46 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3613 : 46 : s1=s2t+1;s2=s1+nroot-1
3614 : 46 : kappa=-2
3615 : 46 : emin=-nz*nz/4._dp-0.5_dp
3616 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3617 : 46 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3618 : 46 : nroot=Orbit%npp-1
3619 : 46 : s2t=s1+nroot-1
3620 [ - + ]: 223 : ELSE IF (Pot%needvtau) THEN
3621 : : Call Boundsplinesolver(Grid,l,nroot, &
3622 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3623 : : ELSE
3624 [ - + ]: 223 : if(usespline) then
3625 : : Call Boundsplinesolver(Grid,l,nroot, &
3626 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3627 : : else
3628 : : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3629 : 223 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3630 : : endif
3631 : : ENDIF
3632 [ + + ]: 371 : IF (.NOT.OK) THEN
3633 : 9 : success=.FALSE.
3634 : : ENDIF
3635 : : endif
3636 : : ENDIF
3637 : : ! d states :
3638 [ + + ]: 371 : IF (Orbit%npd.GT.2) THEN
3639 : 148 : it=it+1
3640 : 148 : emin=-nz*nz/9._dp-0.5_dp
3641 : 148 : l=2
3642 : 148 : nroot=Orbit%npd-2
3643 : 148 : s1=s2t+1;s2t=s1+nroot-1
3644 [ + + ]: 148 : if (Orbit%frozenvalecalculation) then
3645 : 70 : nroot=Orbit%npdc-2
3646 [ + + ]: 140 : do io=s1+Orbit%npdc-2,s2t
3647 [ - + ]: 140 : if(Orbit%issemicore(io)) nroot=nroot+1
3648 : : enddo
3649 [ - + ]: 70 : if(nroot.LT.1) calc_d=.false.
3650 : : endif
3651 : 148 : s2=s1+nroot-1
3652 [ + + ]: 148 : if(calc_d) then
3653 [ + + ]: 78 : IF (Orbit%scalarrelativistic) THEN
3654 : : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3655 : 44 : & l,nroot,emin,ierr,OK)
3656 [ + - ]: 34 : ELSE IF (Orbit%diracrelativistic) THEN
3657 : 34 : kappa=2
3658 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3659 : 34 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3660 : 34 : kappa=-3
3661 : 34 : s1=s2t+1;s2=s1+nroot-1
3662 : 34 : emin=-nz*nz/9._dp-0.5_dp
3663 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3664 : 34 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3665 : 34 : nroot=Orbit%npd-1
3666 : 34 : s2t=s1+nroot-1
3667 [ # # ]: 0 : ELSE IF (Pot%needvtau) THEN
3668 : : Call Boundsplinesolver(Grid,l,nroot, &
3669 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3670 : : ELSE! CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3671 [ # # ]: 0 : if(usespline) then
3672 : : Call Boundsplinesolver(Grid,l,nroot, &
3673 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3674 : : else
3675 : : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3676 : 0 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3677 : : endif
3678 : : ENDIF
3679 [ + + ]: 78 : IF (.NOT.OK) THEN
3680 : 10 : success=.FALSE.
3681 : : ENDIF
3682 : : endif
3683 : : ENDIF
3684 : : ! f states :
3685 [ - + ]: 371 : IF (Orbit%npf.GT.3) THEN
3686 : 0 : it=it+1
3687 : 0 : emin=-nz*nz/16._dp-0.5_dp
3688 : 0 : l=3
3689 : 0 : nroot=Orbit%npf-3
3690 : 0 : s1=s2t+1;s2t=s1+nroot-1
3691 [ # # ]: 0 : if (Orbit%frozenvalecalculation) then
3692 : 0 : nroot=Orbit%npfc-3
3693 [ # # ]: 0 : do io=s1+Orbit%npfc-3,s2t
3694 [ # # ]: 0 : if(Orbit%issemicore(io)) nroot=nroot+1
3695 : : enddo
3696 [ # # ]: 0 : if(nroot.LT.1) calc_f=.false.
3697 : : endif
3698 : 0 : s2=s1+nroot-1
3699 [ # # ]: 0 : if (calc_f) then
3700 [ # # ]: 0 : IF (Orbit%scalarrelativistic) THEN
3701 : : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3702 : 0 : & l,nroot,emin,ierr,OK)
3703 [ # # ]: 0 : ELSE IF (Orbit%diracrelativistic) THEN
3704 : 0 : kappa=3
3705 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3706 : 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3707 : 0 : kappa=-4
3708 : 0 : s1=s2t+1;s2=s1+nroot-1
3709 : 0 : emin=-nz*nz/16._dp-0.5_dp
3710 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3711 : 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3712 : 0 : nroot=Orbit%npf-1
3713 : 0 : s2t=s1+nroot-1
3714 [ # # ]: 0 : ELSE IF (Pot%needvtau) THEN
3715 : : Call Boundsplinesolver(Grid,l,nroot, &
3716 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3717 : : ELSE
3718 [ # # ]: 0 : if(usespline) then
3719 : : Call Boundsplinesolver(Grid,l,nroot, &
3720 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3721 : : else
3722 : : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3723 : 0 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3724 : : endif
3725 : : ENDIF
3726 [ # # ]: 0 : IF (.NOT.OK) THEN
3727 : 0 : success=.FALSE.
3728 : : ENDIF
3729 : : endif
3730 : : ENDIF
3731 : : ! g states :
3732 [ - + ]: 371 : IF (Orbit%npg.GT.4) THEN
3733 : 0 : it=it+1
3734 : 0 : emin=-nz*nz/25._dp-0.5_dp
3735 : 0 : l=4
3736 : 0 : nroot=Orbit%npg-4
3737 : 0 : s1=s2t+1;s2t=s1+nroot-1
3738 [ # # ]: 0 : if (Orbit%frozenvalecalculation) then
3739 : 0 : nroot=Orbit%npgc-4
3740 [ # # ]: 0 : do io=s1+Orbit%npgc-4,s2t
3741 [ # # ]: 0 : if(Orbit%issemicore(io)) nroot=nroot+1
3742 : : enddo
3743 [ # # ]: 0 : if(nroot.LT.1) calc_g=.false.
3744 : : endif
3745 : 0 : s2=s1+nroot-1
3746 [ # # ]: 0 : if(calc_g) then
3747 [ # # ]: 0 : IF (Orbit%scalarrelativistic) THEN
3748 : : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3749 : 0 : & l,nroot,emin,ierr,OK)
3750 [ # # ]: 0 : ELSE IF (Orbit%diracrelativistic) THEN
3751 : 0 : kappa=4
3752 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3753 : 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3754 : 0 : kappa=-5
3755 : 0 : s1=s2t+1;s2=s1+nroot-1
3756 : 0 : emin=-nz*nz/25._dp-0.5_dp
3757 : : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3758 : 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3759 : 0 : nroot=Orbit%npg-1
3760 : 0 : s2t=s1+nroot-1
3761 [ # # ]: 0 : ELSE IF (Pot%needvtau) THEN
3762 : : Call Boundsplinesolver(Grid,l,nroot, &
3763 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3764 : : ELSE
3765 [ # # ]: 0 : if(usespline) then
3766 : : Call Boundsplinesolver(Grid,l,nroot, &
3767 : 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3768 : : else
3769 : : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3770 : 0 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3771 : : endif
3772 : : ENDIF
3773 [ # # ]: 0 : IF (.NOT.OK) THEN
3774 : 0 : success=.FALSE.
3775 : : ENDIF
3776 : : endif
3777 : : ENDIF
3778 : : !Update otau according to wfn
3779 [ + + ]: 2660 : DO io=1,Orbit%norbit
3780 [ + + + + ]: 2289 : IF(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
3781 : : CALL taufromwfn(Orbit%otau(:,io),Grid,Orbit%wfn(:,io),Orbit%l(io), &
3782 : 2660 : & energy=Orbit%eig(io),rPot=Pot%rv)
3783 : : ENDDO
3784 [ - + ]: 371 : LIBPAW_DEALLOCATE(dum)
3785 : 371 : END SUBROUTINE Updatewfn
3786 : :
3787 : :
3788 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3789 : : !! SUBROUTINE Updatewfnwden(Grid,Pot,Orbit,w,success)
3790 : : !! Given new den and consistent Pot%rv
3791 : : !! generate new Orbit%wfn,Orbit%eig,Orbit%otau
3792 : : !! Orbit%den=w on input
3793 : : !! only splinesolver works for now
3794 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3795 : 0 : SUBROUTINE Updatewfnwden(Grid,Pot,Orbit,success,usespline,spline,itype)
3796 : : integer, intent(in) :: itype
3797 : : type(splinesolvinfo),intent(inout) :: spline
3798 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
3799 : : TYPE (PotentialInfo), INTENT(INOUT) :: Pot
3800 : : TYPE (OrbitInfo), INTENT(INOUT) :: Orbit
3801 : : LOGICAL,intent(inout) :: success
3802 : : LOGICAL,intent(in) :: usespline
3803 : : INTEGER :: icount,n,it,start,nroot,s1,s2,s2t
3804 : : INTEGER :: io,l,jierr,nz
3805 : : LOGICAL :: calc_s,calc_p,calc_d,calc_f,calc_g
3806 : : REAL(dp) :: h,emin,zz
3807 : 0 : REAL(dp), ALLOCATABLE :: dum(:)
3808 : : LOGICAL :: OK
3809 : : !!!since programmed only for splinesolver case, check
3810 [ # # # # ]: 0 : If (Orbit%scalarrelativistic.or.Orbit%diracrelativistic) then
3811 : 0 : write(std_out,*) 'Program Updatewfnwden not written '
3812 : 0 : write(std_out,*) ' for relativistic solver -- error stop '
3813 : 0 : stop
3814 : : ENDIF
3815 [ # # ]: 0 : If (.not.usespline) THEN
3816 : 0 : write(std_out,*) 'Program Updatewfnwden only written '
3817 : 0 : write(std_out,*) ' for usespline case -- error stop '
3818 : 0 : stop
3819 : : ENDIF
3820 : 0 : n=Grid%n; h=Grid%h; nz=Pot%nz; zz=Pot%zz
3821 : 0 : success=.TRUE.
3822 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(n))
# # # # #
# # # ]
3823 : 0 : call initpotforsplinesolver(Grid,Pot,Orbit%den,Orbit%tau,spline,itype)
3824 : : ! solve for bound states of Schroedinger equation
3825 : 0 : icount=0
3826 : 0 : jierr=0
3827 : 0 : it=0
3828 : : ! s states :
3829 : 0 : IF (Orbit%nps.GT.0) THEN
3830 : : it=it+1
3831 : : emin=-nz*nz-0.1_dp
3832 : : l=0
3833 : : nroot=Orbit%nps
3834 : : start=1;s1=start;s2t=start+nroot-1
3835 : : if (Orbit%frozenvalecalculation) then
3836 : : nroot=Orbit%npsc
3837 : : do io=s1+Orbit%npsc,s2t
3838 : : if(Orbit%issemicore(io)) nroot=nroot+1
3839 : : enddo
3840 : : if(nroot.LT.1) calc_s=.false.
3841 : : endif
3842 : : s2=s1+nroot-1
3843 : : if(calc_s) then
3844 : : Call Boundsplinesolver(Grid,l,nroot, &
3845 : : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3846 : : IF (.NOT.OK) THEN
3847 : : success=.FALSE.
3848 : : ENDIF
3849 : : endif
3850 : : ENDIF
3851 : : ! p states :
3852 : 0 : IF (Orbit%npp.GT.1) then
3853 : : it=it+1
3854 : : emin=-nz*nz/4._dp-0.5_dp
3855 : : l=1
3856 : : nroot=Orbit%npp-1
3857 : : s1=s2t+1;s2t=s1+nroot-1
3858 : : if (Orbit%frozenvalecalculation) then
3859 : : nroot=Orbit%nppc-1
3860 : : do io=s1+Orbit%nppc-1,s2t
3861 : : if(Orbit%issemicore(io)) nroot=nroot+1
3862 : : enddo
3863 : : if(nroot.LT.1) calc_p=.false.
3864 : : endif
3865 : : s2=s1+nroot-1
3866 : : if(calc_p) then
3867 : : Call Boundsplinesolver(Grid,l,nroot, &
3868 : : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3869 : : IF (.NOT.OK) THEN
3870 : : success=.FALSE.
3871 : : ENDIF
3872 : : endif
3873 : : ENDIF
3874 : : ! d states :
3875 : 0 : IF (Orbit%npd.GT.2) THEN
3876 : : it=it+1
3877 : : emin=-nz*nz/9._dp-0.5_dp
3878 : : l=2
3879 : : nroot=Orbit%npd-2
3880 : : s1=s2t+1;s2t=s1+nroot-1
3881 : : if (Orbit%frozenvalecalculation) then
3882 : : nroot=Orbit%npdc-2
3883 : : do io=s1+Orbit%npdc-2,s2t
3884 : : if(Orbit%issemicore(io)) nroot=nroot+1
3885 : : enddo
3886 : : if(nroot.LT.1) calc_d=.false.
3887 : : endif
3888 : : s2=s1+nroot-1
3889 : : if(calc_d) then
3890 : : Call Boundsplinesolver(Grid,l,nroot, &
3891 : : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3892 : : IF (.NOT.OK) THEN
3893 : : success=.FALSE.
3894 : : ENDIF
3895 : : endif
3896 : : ENDIF
3897 : : ! f states :
3898 : 0 : IF (Orbit%npf.GT.3) THEN
3899 : : it=it+1
3900 : : emin=-nz*nz/16._dp-0.5_dp
3901 : : l=3
3902 : : nroot=Orbit%npf-3
3903 : : s1=s2t+1;s2t=s1+nroot-1
3904 : : if (Orbit%frozenvalecalculation) then
3905 : : nroot=Orbit%npfc-3
3906 : : do io=s1+Orbit%npfc-3,s2t
3907 : : if(Orbit%issemicore(io)) nroot=nroot+1
3908 : : enddo
3909 : : if(nroot.LT.1) calc_f=.false.
3910 : : endif
3911 : : s2=s1+nroot-1
3912 : : if (calc_f) then
3913 : : Call Boundsplinesolver(Grid,l,nroot, &
3914 : : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3915 : : IF (.NOT.OK) THEN
3916 : : success=.FALSE.
3917 : : ENDIF
3918 : : endif
3919 : : ENDIF
3920 : : ! g states :
3921 : 0 : IF (Orbit%npg.GT.4) THEN
3922 : : it=it+1
3923 : : emin=-nz*nz/25._dp-0.5_dp
3924 : : l=4
3925 : : nroot=Orbit%npg-4
3926 : : s1=s2t+1;s2t=s1+nroot-1
3927 : : if (Orbit%frozenvalecalculation) then
3928 : : nroot=Orbit%npgc-4
3929 : : do io=s1+Orbit%npgc-4,s2t
3930 : : if(Orbit%issemicore(io)) nroot=nroot+1
3931 : : enddo
3932 : : if(nroot.LT.1) calc_g=.false.
3933 : : endif
3934 : : s2=s1+nroot-1
3935 : : if(calc_g) then
3936 : : Call Boundsplinesolver(Grid,l,nroot, &
3937 : : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3938 : : IF (.NOT.OK) THEN
3939 : : success=.FALSE.
3940 : : ENDIF
3941 : : endif
3942 : : ENDIF
3943 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
3944 : 0 : END SUBROUTINE Updatewfnwden
3945 : :
3946 : :
3947 : :
3948 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3949 : : !! Get_KinCoul
3950 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3951 : 354 : SUBROUTINE Get_KinCoul(Grid,Pot,Orbit,SCF,usespline,noalt)
3952 : : ! program to calculate Kinetic energy and Coulomb Energies from Orbit%wfn
3953 : : ! also update Pot%rvh
3954 : : logical,intent(in) :: usespline
3955 : : TYPE(GridInfo), INTENT(INOUT) :: Grid
3956 : : TYPE(PotentialInfo), INTENT(INOUT) :: Pot
3957 : : TYPE(OrbitInfo), INTENT(INOUT) :: Orbit
3958 : : TYPE(SCFInfo), INTENT(INOUT) :: SCF
3959 : : LOGICAL, OPTIONAL :: noalt
3960 : : real(dp) :: ecoul,ekin,eone,h,x,qcal,small,rescale
3961 : : real(dp) :: electrons,xocc
3962 : : INTEGER :: i,n,io
3963 : 354 : real(dp), ALLOCATABLE :: dum(:)
3964 : : real(dp) :: small0=tol6,fpi
3965 : : INTEGER :: counter=1
3966 : 354 : n=Grid%n; h=Grid%h
3967 : 354 : small=small0
3968 [ - + + - : 1062 : LIBPAW_ALLOCATE(dum,(n))
+ - + - -
+ - + ]
3969 : : !update density
3970 [ + + + + ]: 1417062 : Orbit%den=0._dp;Orbit%tau=0._dp
3971 [ + + ]: 2529 : DO io=1,Orbit%norbit
3972 [ + + + + ]: 2175 : IF(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
3973 [ + + ]: 1895 : IF (Orbit%occ(io).GT.small) THEN
3974 [ + + ]: 3067064 : DO i=1,Grid%n
3975 [ + + ]: 3065532 : IF (ABS(Orbit%wfn(i,io))<machine_zero)Orbit%wfn(i,io)=0
3976 [ + + ]: 3067064 : IF (Orbit%diracrelativistic) then
3977 [ + + ]: 716358 : IF (ABS(Orbit%lwfn(i,io))<machine_zero)Orbit%lwfn(i,io)=0
3978 : : ENDIF
3979 : : ENDDO
3980 [ + - ]: 1532 : if(.not.usespline) then
3981 : : CALL taufromwfn(Orbit%otau(:,io),Grid,Orbit%wfn(:,io),Orbit%l(io), &
3982 : 1532 : & energy=Orbit%eig(io),rPot=Pot%rv)
3983 : : endif
3984 : 1532 : xocc=Orbit%occ(io)
3985 [ + + ]: 3067064 : Do i=1,Grid%n
3986 : 3065532 : Orbit%tau(i)=Orbit%tau(i)+xocc*Orbit%otau(i,io)
3987 : 3065532 : Orbit%den(i)=Orbit%den(i)+xocc*(Orbit%wfn(i,io)**2)
3988 [ + + ]: 3067064 : IF (Orbit%diracrelativistic) then
3989 : 716358 : Orbit%den(i)=Orbit%den(i)+xocc*((Orbit%lwfn(i,io))**2)
3990 : : ENDIF
3991 : : ENDDO
3992 : : ENDIF
3993 : : ENDDO
3994 : 354 : qcal=integrator(Grid,Orbit%den)
3995 [ - + ]: 354 : if(has_to_print) WRITE(STD_OUT,*) 'qcal = ', qcal
3996 [ + + ]: 354 : IF(Orbit%frozenvalecalculation) qcal=qcal+Orbit%qval
3997 [ + + + + ]: 470589 : IF(Orbit%frozenvalecalculation) Orbit%den=Orbit%den+Orbit%valeden
3998 : 354 : electrons=Pot%q
3999 [ + + ]: 354 : IF(Orbit%frozenvalecalculation) electrons=qcal
4000 : 354 : rescale=electrons/qcal
4001 [ + + ]: 708708 : Orbit%den(1:n)=Orbit%den(1:n)*rescale
4002 [ + + ]: 708708 : Orbit%tau(1:n)=Orbit%tau(1:n)*rescale
4003 : : ! Determine difference with tauW (Weizsaker)
4004 : 354 : fpi=4*pi
4005 [ + + ]: 708354 : dum(2:Grid%n)=Orbit%den(2:Grid%n)/(fpi*Grid%r(2:Grid%n)**2)
4006 : 354 : CALL extrapolate(dum)
4007 : 354 : CALL derivative(Grid,dum,Orbit%deltatau)
4008 [ + + ]: 708708 : Do i=1,Grid%n
4009 [ + + ]: 708708 : if (dum(i)>machine_zero) then
4010 : 648887 : Orbit%deltatau(i)=0.25_dp*(Orbit%deltatau(i)**2)/dum(i)
4011 : : else
4012 : 59467 : Orbit%deltatau(i)=0.0_dp
4013 : : endif
4014 : : enddo
4015 [ + + ]: 708354 : dum(2:Grid%n)=Orbit%tau(2:Grid%n)/(fpi*Grid%r(2:Grid%n)**2)
4016 : 354 : call extrapolate(dum)
4017 [ + + ]: 708708 : Orbit%deltatau=dum-Orbit%deltatau
4018 : 354 : call poisson_marc(Grid,Pot%q,Orbit%den,Pot%rvh,ecoul)
4019 : : ! call atompaw_poisson(Grid,Pot%q,Orbit%den,Pot%rvh,ecoul)
4020 [ + + ]: 708708 : dum=zero
4021 [ + + ]: 708354 : dum(2:n)=Pot%rvn(2:n)*Orbit%den(2:n)/Grid%r(2:n)
4022 : 354 : SCF%estatic=integrator(Grid,dum)+ecoul
4023 [ - + ]: 354 : if(has_to_print) then
4024 : 0 : WRITE(STD_OUT,*) ' n l occupancy energy'
4025 [ # # ]: 0 : do io=1,Orbit%norbit
4026 : 0 : write(std_out,*) Orbit%np(io), Orbit%l(io),Orbit%occ(io),Orbit%eig(io)
4027 : : enddo
4028 : : endif
4029 [ - + ]: 354 : ekin=0.0_dp; if (Orbit%frozencorecalculation) ekin=SCF%corekin
4030 : 354 : eone=0.0_dp
4031 [ + + ]: 2529 : DO io=1,Orbit%norbit
4032 : : if(.not.Orbit%frozencorecalculation &
4033 [ - + - - ]: 2529 : & .or.Orbit%frozencorecalculation.and.(.not.Orbit%iscore(io))) then
4034 : 2175 : eone=eone+Orbit%occ(io)*Orbit%eig(io)
4035 [ + + + - ]: 2175 : IF (counter>1.and..not.present(noalt)) THEN
4036 : 2163 : CALL altkinetic(Grid,Orbit%wfn(:,io),Orbit%eig(io),Pot%rv,x)
4037 : : ELSE
4038 : 12 : x=integrator(Grid,Orbit%otau(:,io))
4039 : : ENDIF
4040 : 2175 : ekin=ekin+Orbit%occ(io)*x
4041 : : endif
4042 : : ENDDO
4043 [ - + ]: 354 : if(has_to_print) write(std_out,*) 'KinCoul check ekin ',ekin,integrator(Grid,Orbit%tau)
4044 : 354 : SCF%eone=eone
4045 : 354 : SCF%ekin=ekin
4046 : 354 : SCF%ecoul=ecoul
4047 : 354 : counter=counter+1
4048 [ - + ]: 354 : LIBPAW_DEALLOCATE(dum)
4049 : 354 : END SUBROUTINE Get_KinCoul
4050 : :
4051 : :
4052 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4053 : : !! Get_Nuclearpotential
4054 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4055 : 4 : SUBROUTINE Get_Nuclearpotential(Grid,Pot)
4056 : : ! TODO : finitenucleus
4057 : : TYPE(GridInfo), INTENT(INOUT) :: Grid
4058 : : TYPE(PotentialInfo), INTENT(INOUT) :: Pot
4059 : : ! Various finite nuclear models follow the manuscript of Andrae
4060 : : ! Physics Reports 336 (2000) 413-525
4061 : : ! finitenucleusmodel 2,3,4,5 correspond to the options
4062 : : ! described in that paper while finitenucleusmodel 0 corresponds to
4063 : : ! Gaussian model originally programmed
4064 : : ! Note that logarithmic grid is reset to be compatible with
4065 : : ! nuclear model with approximately NN integration points within
4066 : : ! finite nucleus
4067 : : INTEGER :: i
4068 : : INTEGER, PARAMETER :: NN=651 ! number of grid points within RR
4069 : : real(dp), PARAMETER :: gridrange=100._dp
4070 : : real(dp), PARAMETER :: bohr=0.529177249_dp !Ang/Bohr from Andrae
4071 [ + - ]: 4 : IF (.NOT.Pot%finitenucleus) THEN
4072 : : ! grid already set
4073 [ + + ]: 8008 : DO i=1,Grid%n
4074 : 8008 : Pot%rvn(i)=-2*Pot%nz!*0.5!Hartree
4075 : : ENDDO
4076 : : ELSE
4077 : 0 : STOP
4078 : : ! write(std_out,*) 'Finite nucleus model -- readjusting integration grid'
4079 : : ! a=bohr*10._dp**(-5)*(0.57_dp+0.836* &
4080 : : ! & (-1.168_dp+Pot%nz*(2.163_dp+Pot%nz*0.004467_dp)))
4081 : : ! ! From Eqs. A.3 and 51 in Andrae paper
4082 : : ! write(std_out,*) 'a parameter calculated to be', a
4083 : : ! call destroygrid(Grid)
4084 : : ! SELECT CASE(Pot%finitenucleusmodel)
4085 : : ! CASE DEFAULT
4086 : : ! write(std_out,*) 'Error in finitenucleusmodel',Pot%finitenucleusmodel
4087 : : ! write(std_out,*) ' Exiting '
4088 : : ! Stop
4089 : : ! CASE(0)
4090 : : ! write(std_out,*) 'Original Gaussian model'
4091 : : ! RR=Pot%nz
4092 : : ! RR=2.9*10._dp**(-5)*(RR**0.3333333333333333333333333_dp)
4093 : : ! h=log(FLOAT(NN))/(NN-1)
4094 : : ! r0=RR/(NN-1)
4095 : : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4096 : : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4097 : : ! write(std_out,*) 'New Grid ', Grid%n
4098 : : ! Call DestroyPot(Pot)
4099 : : ! Call InitPot(Pot,Grid%n)
4100 : : ! DO i=1,Grid%n
4101 : : ! Pot%rvn(i)=-2*Pot%nz*derf(Grid%r(i)/RR)
4102 : : ! ENDDO
4103 : : ! Pot%Nv0=-2*Pot%nz*sqrt(4._dp/pi)
4104 : : ! Pot%Nv0p=0._dp
4105 : : ! CASE(2)
4106 : : ! write(std_out,*) 'Model 2 -- Breit'
4107 : : ! RR=sqrt(2._dp)*a
4108 : : ! h=log(FLOAT(NN))/(NN-1)
4109 : : ! r0=RR/(NN-1)
4110 : : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4111 : : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4112 : : ! write(std_out,*) 'New Grid ', Grid%n
4113 : : ! Call DestroyPot(Pot)
4114 : : ! Call InitPot(Pot,Grid%n)
4115 : : ! DO i=1,Grid%n
4116 : : ! if (Grid%r(i)<RR) then
4117 : : ! Pot%rvn(i)=-2*Pot%nz*Grid%r(i)*(2._dp-Grid%r(i)/RR)/RR
4118 : : ! else
4119 : : ! Pot%rvn(i)=-2*Pot%nz
4120 : : ! endif
4121 : : ! ENDDO
4122 : : ! Pot%Nv0=-2*Pot%nz*2.0_dp/RR
4123 : : ! Pot%Nv0p=2*Pot%nz/(RR**2)
4124 : : ! CASE(3)
4125 : : ! write(std_out,*) 'Model 3 -- uniform'
4126 : : ! RR=sqrt(5._dp/3._dp)*a
4127 : : ! h=log(FLOAT(NN))/(NN-1)
4128 : : ! r0=RR/(NN-1)
4129 : : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4130 : : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4131 : : ! write(std_out,*) 'New Grid ', Grid%n
4132 : : ! Call DestroyPot(Pot)
4133 : : ! Call InitPot(Pot,Grid%n)
4134 : : ! DO i=1,Grid%n
4135 : : ! if (Grid%r(i)<RR) then
4136 : : ! Pot%rvn(i)=-3*Pot%nz*Grid%r(i)*&
4137 : : ! & (1._dp-(Grid%r(i)/RR)**2/3)/RR
4138 : : ! else
4139 : : ! Pot%rvn(i)=-2*Pot%nz
4140 : : ! endif
4141 : : ! ENDDO
4142 : : ! Pot%Nv0=-3*Pot%nz/RR
4143 : : ! Pot%Nv0p=0._dp
4144 : : ! CASE(4)
4145 : : ! write(std_out,*) 'Model 4 -- exponential'
4146 : : ! RR=sqrt(1._dp/12._dp)*a
4147 : : ! h=log(FLOAT(NN))/(NN-1)
4148 : : ! r0=RR/(NN-1)
4149 : : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4150 : : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4151 : : ! write(std_out,*) 'New Grid ', Grid%n
4152 : : ! Call DestroyPot(Pot)
4153 : : ! Call InitPot(Pot,Grid%n)
4154 : : ! DO i=1,Grid%n
4155 : : ! Pot%rvn(i)=-2*Pot%nz* &
4156 : : ! & (1._dp-exp(-grid%r(i)/RR)*(1._dp+0.5_dp*Grid%r(i)/RR))
4157 : : ! ENDDO
4158 : : ! Pot%Nv0=-Pot%nz/RR
4159 : : ! Pot%Nv0p=0._dp
4160 : : ! CASE(5)
4161 : : ! write(std_out,*) 'Model 5 -- Gaussian'
4162 : : ! RR=sqrt(2._dp/3._dp)*a
4163 : : ! h=log(FLOAT(NN))/(NN-1)
4164 : : ! r0=RR/(NN-1)
4165 : : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4166 : : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4167 : : ! write(std_out,*) 'New Grid ', Grid%n
4168 : : ! Call DestroyPot(Pot)
4169 : : ! Call InitPot(Pot,Grid%n)
4170 : : ! DO i=1,Grid%n
4171 : : ! Pot%rvn(i)=-2*Pot%nz*erf(Grid%r(i)/RR)
4172 : : ! ENDDO
4173 : : ! Pot%Nv0=-2*Pot%nz/RR*(sqrt(4._dp/pi))
4174 : : ! Pot%Nv0p=0._dp
4175 : : ! END SELECT
4176 : : ENDIF
4177 : 4 : END SUBROUTINE Get_Nuclearpotential
4178 : :
4179 : :
4180 : :
4181 : :
4182 : :
4183 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4184 : : ! 6. radialsr
4185 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4186 : :
4187 : :
4188 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4189 : : !! Subroutine Azeroexpand(Grid,Pot,l,energy)
4190 : : !! If finitenucleus==.true. assumes potential is non-singular
4191 : : !! at origin and Pot%v0 and Pot%v0p are properly set
4192 : : !! Otherwise, assumes nuclear potential is -2*Z/r
4193 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4194 : 18142 : Subroutine Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB,nr)
4195 : : Type(GridInfo), INTENT(IN) :: Grid
4196 : : Type(PotentialInfo), INTENT(INout) :: Pot
4197 : : Integer, INTENT(IN) :: l
4198 : : real(dp), INTENT(IN) :: energy
4199 : : real(dp), intent(inout) :: qq,gamma,c1,c2,MA,MB
4200 : : Integer, optional, INTENT(IN) :: nr
4201 : : Integer :: n
4202 : : real(dp) :: nz,angm,alpha2,balpha2
4203 : : real(dp) :: Tm10,Tm11,T00,Tm21,Tm22,term
4204 : : n=Grid%n
4205 : 18142 : if (present(nr)) n=min(n,nr)
4206 : : ! check for possible ionic charge
4207 : 18142 : n=Grid%n
4208 : 18142 : qq=pot%zz-pot%q!-Pot%rv(n)/2
4209 [ + - ]: 18142 : if(qq<0.001_dp) qq=0
4210 : 18142 : nz=Pot%nz
4211 [ + + + + ]: 72622426 : Pot%ww=0; Pot%jj=0;
4212 : 18142 : balpha2=InvFineStruct**2
4213 : 18142 : alpha2=1._dp/balpha2
4214 : : Pot%jj(1:n)=(Grid%r(1:n) + &
4215 [ + + ]: 36320284 : & 0.25_dp*alpha2*(energy*Grid%r(1:n)-Pot%rv(1:n)))!hartree
4216 : 18142 : angm=l*(l+1)
4217 : : Pot%ww(2:n)=(Pot%rv(2:n)/Grid%r(2:n)-energy) & !*2.0 &
4218 [ + + ]: 36302142 : & + angm/(Grid%r(2:n)*Pot%jj(2:n))!hartree
4219 : 18142 : Pot%ww(1)=0
4220 [ + - ]: 18142 : if (.not.Pot%finitenucleus) then
4221 : 18142 : gamma=sqrt(angm+1._dp-alpha2*nz**2)
4222 : 18142 : term=1._dp+0.25_dp*alpha2*(energy-Pot%v0)!*2.0!hartree
4223 : 18142 : Tm21=2*gamma+1; Tm22=2*(2*gamma+2)
4224 : : !hartree!hartree!hartree
4225 : 18142 : Tm10=nz*(2._dp+alpha2*(energy-Pot%v0))-(2*balpha2/nz)*term*(gamma-1._dp)
4226 : 18142 : Tm11=nz*(2._dp+alpha2*(energy-Pot%v0))-(2*balpha2/nz)*term*(gamma)
4227 : : T00=-alpha2*nz*Pot%v0p+term*(energy-Pot%v0) + &
4228 : 18142 : & (Pot%v0p/nz+(4*balpha2**2/(nz*nz))*term**2)*(gamma-1._dp)
4229 : 18142 : c1=-Tm10/Tm21
4230 : 18142 : c2=-(Tm11*C1+T00)/Tm22
4231 : 18142 : MA=0; MB=0
4232 : : else ! version for finite nuclear size
4233 : 0 : gamma=l+1._dp
4234 : 0 : term=1._dp+0.25_dp*alpha2*(energy-Pot%v0)
4235 : 0 : Tm21=2*l+2; Tm22=2*(2*l+3)
4236 : 0 : Tm10=(0.25_dp*alpha2*Pot%v0p/term)*(l)
4237 : 0 : Tm11=(0.25_dp*alpha2*Pot%v0p/term)*(l+1)
4238 : 0 : T00=(energy-Pot%v0)*term+l*((0.25_dp*alpha2*Pot%v0p/term)**2)
4239 : 0 : c1=-Tm10/Tm21
4240 : 0 : c2=-(Tm11*C1+T00)/Tm22
4241 : 0 : MA=0; MB=0
4242 : : endif
4243 : 18142 : end subroutine Azeroexpand
4244 : :
4245 : :
4246 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4247 : : !! SUBROUTINE wfnsrinit(Grid,l,wfn,lwfn,istart)
4248 : : !! returns the solution of the scalar relativistic equations near r=0
4249 : : !! using power series expansion
4250 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4251 [ - + - + : 18142 : SUBROUTINE wfnsrinit(Grid,l,wfn,lwfn,istart,finitenucleus,gamma,c1,c2,MA,MB,jj)
- + ]
4252 : : Type(GridInfo), INTENT(IN) :: Grid
4253 : : INTEGER, INTENT(IN) :: l
4254 : : real(dp),intent(in) :: gamma,c1,c2,MA,MB
4255 : : real(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
4256 : : real(dp),intent(in) :: jj(:)
4257 : : INTEGER, INTENT(OUT) :: istart
4258 : : logical, intent(in) :: finitenucleus
4259 : : real(dp) :: rr,M
4260 : : INTEGER :: i
4261 [ + + + + ]: 72621172 : wfn=0; lwfn=0
4262 : 18142 : istart=6
4263 [ + + ]: 126994 : do i=1,istart
4264 : 108852 : rr=Grid%r(i+1)
4265 [ + - ]: 126994 : if (.not.finitenucleus) then
4266 : 108852 : wfn(i+1)=1+rr*(c1+rr*c2)
4267 : 108852 : lwfn(i+1)=(gamma-1)+rr*(c1*gamma+rr*c2*(gamma+1))
4268 : 108852 : wfn(i+1)=wfn(i+1)*(rr**gamma)
4269 : 108852 : lwfn(i+1)=lwfn(i+1)*(rr**gamma)/jj(i+1)
4270 : : else ! finite nucleus case
4271 : 0 : M=MA-MB*rr
4272 : 0 : wfn(i+1)=(1+rr*(c1+rr*c2))*(rr**(l+1))
4273 : 0 : lwfn(i+1)=(l+rr*((l+1)*c1+rr*(l+2)*c2))*(rr**(l+1))/M
4274 : : endif
4275 : : enddo
4276 : 18142 : End SUBROUTINE wfnsrinit
4277 : :
4278 : :
4279 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4280 : : !! SUBROUTINE wfnsrasym(Grid,wfn,lwfn,energy,iend)
4281 : : !! returns the solution of the scalar relativistic equations near r=inf
4282 : : !! using exp(-x*r) for upper component
4283 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4284 [ - + - + : 17889 : subroutine wfnsrasym(Grid,wfn,lwfn,energy,iend,qq,jj)
- + ]
4285 : : ! returns the solution of the scalar relativistic equations near r=inf
4286 : : ! using exp(-x*r) for upper component
4287 : : Type(GridInfo), INTENT(IN) :: Grid
4288 : : real(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
4289 : : real(dp), INTENT(IN) :: energy,qq
4290 : : real(dp),intent(in) :: jj(:)
4291 : : INTEGER, INTENT(OUT) :: iend
4292 : : real(dp) :: rr,x,m,qx
4293 : : INTEGER :: i,n
4294 [ - + ]: 17889 : if (energy>0._dp) then
4295 : 0 : LIBPAW_ERROR('Error in wfnsrasym -- energy > 0')
4296 : : endif
4297 [ + + + + ]: 71609667 : wfn=0; lwfn=0;
4298 : 17889 : n=Grid%n
4299 : 17889 : m=1._dp+0.25_dp*energy/(InvFineStruct**2)!Hartree
4300 : 17889 : x=sqrt(-m*energy)!Hartree
4301 : 17889 : qx=qq ! Possible net ionic charge
4302 : 17889 : qx=(qx/x)*(1._dp+0.5_dp*energy/(InvFineStruct**2))!Hartree
4303 : 17889 : iend=5
4304 [ + + ]: 125223 : do i=n-iend,n
4305 : 107334 : wfn(i)=exp(-x*(Grid%r(i)-Grid%r(n-iend)))
4306 [ - + ]: 107334 : if (qx>0._dp) then
4307 : 0 : rr=(Grid%r(i)/Grid%r(n-iend))**qx
4308 : 0 : wfn(i)=wfn(i)*rr
4309 : : endif
4310 : 125223 : lwfn(i)=-wfn(i)*(x*Grid%r(i)+(1._dp-qx))/jj(i)
4311 : : enddo
4312 : 17889 : end subroutine wfnsrasym
4313 : :
4314 : :
4315 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4316 : : !! subroutine unboundsr(Grid,Pot,nr,l,energy,wfn,nodes)
4317 : : !! pgm to solve radial scalar relativistic equation for unbound states
4318 : : !! at energy 'energy' and at angular momentum l
4319 : : !!
4320 : : !! with potential rv/r, given in uniform linear or log mesh of n points
4321 : : !! assuming p(r)=C*r**(l+1)*polynomial(r) for r==0;
4322 : : !!
4323 : : !! nz=nuclear charge
4324 : : !!
4325 : : !! Does not use Noumerov algorithm -- but uses coupled first-order
4326 : : !! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
4327 : : !!
4328 : : !! also returns node == number of nodes for calculated state
4329 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4330 [ - + ]: 5 : SUBROUTINE unboundsr(Grid,Pot,nr,l,energy,wfn,nodes)
4331 : : TYPE(GridInfo), INTENT(IN) :: Grid
4332 : : TYPE(PotentialInfo), INTENT(INout) :: Pot
4333 : : INTEGER, INTENT(IN) :: nr,l
4334 : : real(dp), INTENT(IN) :: energy
4335 : : real(dp), INTENT(INOUT) :: wfn(:)
4336 : : INTEGER, INTENT(INOUT) :: nodes
4337 : : INTEGER :: n,istart
4338 : : real(dp) :: scale,gamma,c1,c2,MA,MB,qq
4339 : : real(dp), allocatable :: lwfn(:),zz(:,:,:),yy(:,:)
4340 : 5 : n=Grid%n
4341 [ - + ]: 5 : IF (nr > n) THEN
4342 : 0 : LIBPAW_ERROR('Error in unboundsr')
4343 : : ENDIF
4344 : 5 : call Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB,nr)
4345 [ - + + - : 15 : LIBPAW_ALLOCATE(lwfn,(nr))
+ - + - -
+ - + ]
4346 [ - + + - : 15 : LIBPAW_ALLOCATE(zz,(2,2,nr))
+ - + - -
+ - + ]
4347 [ - + + - : 15 : LIBPAW_ALLOCATE(yy,(2,nr))
+ - + - -
+ - + ]
4348 [ + + + + : 103163 : lwfn=0;zz=0;yy=0;
+ + + + +
+ + + ]
4349 : 5 : call wfnsrinit(Grid,l,wfn,lwfn,istart,Pot%finitenucleus,gamma,c1,c2,MA,MB,Pot%jj)
4350 : 5 : call prepareforcfdsol(Grid,1,istart,nr,wfn,lwfn,yy,zz,Pot%ww,Pot%jj)
4351 : 5 : call cfdsol(Grid,zz,yy,istart,nr)
4352 : 5 : call getwfnfromcfdsol(1,nr,yy,wfn)
4353 : 5 : nodes=countnodes(2,nr,wfn)
4354 : : ! normalize to unity within integration range
4355 : 5 : scale=1._dp/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr)
4356 : 5 : scale=SIGN(SQRT(scale),wfn(nr-2))
4357 [ + + ]: 9383 : wfn(1:nr)=wfn(1:nr)*scale
4358 [ - + ]: 5 : LIBPAW_DEALLOCATE(lwfn)
4359 [ - + ]: 5 : LIBPAW_DEALLOCATE(yy)
4360 [ - + ]: 5 : LIBPAW_DEALLOCATE(zz)
4361 : 5 : END SUBROUTINE unboundsr
4362 : :
4363 : :
4364 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4365 : : !! SUBROUTINE boundsr(Grid,Pot,eig,wfn,l,nroot,emin,ierr,success)
4366 : : !! pgm to solve radial scalar relativistic equation for nroot bound state
4367 : : !! energies and wavefunctions for angular momentum l
4368 : : !! with potential rv/r, given in uniform linear or log mesh of n points
4369 : : !! nz=nuclear charge
4370 : : !! emin=is estimate of lowest eigenvalue; used if nz=0
4371 : : !! otherwise, set to the value of -(nz/(l+1))**2
4372 : : !!
4373 : : !! It is assumed that the wavefunction has np-l-1 nodes, where
4374 : : !! np is the principle quantum number-- np=1,2,..nroot
4375 : : !!
4376 : : !! Does not use Noumerov algorithm -- but uses coupled first-order
4377 : : !! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
4378 : : !!
4379 : : !! Corrections are also needed for r>n*h, depending on:
4380 : : !! e0 (current guess of energy eigenvalue
4381 : : !! the extrapolated value of rv == r * v
4382 : : !!
4383 : : !! ierr=an nroot digit number indicating status of each root
4384 : : !! a digit of 1 indicates success in converging root
4385 : : !! 2 indicates near success in converging root
4386 : : !! 9 indicates that root not found
4387 : : !!
4388 : : !! first check how many roots expected = ntroot (returned as argument)
4389 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4390 [ - + - + ]: 248 : SUBROUTINE boundsr(Grid,Pot,eig,wfn,l,nroot,emin,ierr,success)
4391 : : TYPE(GridInfo), INTENT(IN) :: Grid
4392 : : TYPE(PotentialInfo), INTENT(INout) :: Pot
4393 : : real(dp), INTENT(INOUT) :: eig(:),wfn(:,:)
4394 : : INTEGER, INTENT(IN) :: l,nroot
4395 : : INTEGER, INTENT(INOUT) :: ierr
4396 : : real(dp), INTENT(INOUT) :: emin
4397 : : LOGICAL, INTENT(INOUT) :: success
4398 : : real(dp), PARAMETER :: convre=tol10,vlrg=10._dp**30
4399 : : INTEGER, PARAMETER :: niter=1000
4400 : 248 : real(dp), POINTER :: rv(:)
4401 : 248 : real(dp), ALLOCATABLE :: p1(:),p2(:),dd(:)
4402 : : INTEGER :: n
4403 : : real(dp) :: nz,h,v0,v0p
4404 : : real(dp) :: err,convrez,energy,gamma,c1,c2,MA,MB
4405 : : real(dp) :: scale,emax,best,rout,qq
4406 : : real(dp) :: rin,dele,x
4407 : : INTEGER :: iter,i,j,node,match,mxroot,ntroot,ir,iroot
4408 : : INTEGER :: ifac,istart,iend
4409 : : LOGICAL :: ok
4410 : : real(dp), allocatable :: lwfn(:),zz(:,:,:),yy(:,:)
4411 : 248 : n=Grid%n
4412 : 248 : h=Grid%h
4413 [ + - + - : 744 : LIBPAW_ALLOCATE(p1,(n))
+ - - + -
+ ]
4414 [ - + + - : 496 : LIBPAW_ALLOCATE(p2,(n))
- + - + ]
4415 [ - + + - : 496 : LIBPAW_ALLOCATE(dd,(n))
- + - + ]
4416 : 248 : success=.true.
4417 [ - + + - : 496 : LIBPAW_ALLOCATE(lwfn,(n))
- + - + ]
4418 [ - + + - : 744 : LIBPAW_ALLOCATE(zz,(2,2,n))
+ - + - -
+ - + ]
4419 [ - + + - : 744 : LIBPAW_ALLOCATE(yy,(2,n))
+ - + - -
+ - + ]
4420 : 248 : nz=Pot%nz
4421 : 248 : v0=Pot%v0
4422 : 248 : v0p=Pot%v0p
4423 : 248 : rv=>Pot%rv
4424 : 248 : err=n*nz*(h**4)!*0.5!hartree
4425 : 248 : convrez=convre
4426 [ + - ]: 248 : IF (nz>0.001_dp) convrez=convre*nz
4427 : 248 : ierr=0
4428 [ - + ]: 248 : if(has_to_print) write(std_out,*) 'z , l = ',nz,l
4429 : : ! check how many roots expected by integration outward at
4430 : : ! energy = 0
4431 : 248 : energy = 0
4432 : 248 : call Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB)
4433 [ + + + + : 5458976 : lwfn=0;zz=0;yy=0;
+ + + + +
+ + + ]
4434 : 248 : call wfnsrinit(Grid,l,p1,lwfn,istart,Pot%finitenucleus,gamma,c1,c2,MA,MB,Pot%jj)
4435 : : !start outward integration
4436 : 248 : call prepareforcfdsol(Grid,1,istart,n,p1,lwfn,yy,zz,Pot%ww,Pot%jj)
4437 : 248 : call cfdsoliter(Grid,zz,yy,istart,n)
4438 : 248 : call getwfnfromcfdsol(1,n,yy,p1)
4439 : 248 : node=countnodes(2,n,p1)
4440 [ - + ]: 248 : if(has_to_print) write(std_out,*) ' nodes at e=0 ', node
4441 : 248 : mxroot=node+1
4442 : 248 : ntroot=node
4443 [ - + ]: 248 : IF (mxroot.LT.nroot) THEN
4444 [ # # ]: 0 : if(has_to_print) write(std_out,*)'error in boundsr - for l = ',l
4445 [ # # ]: 0 : if(has_to_print) write(std_out,*) nroot,' states requested but only',mxroot,' possible'
4446 [ # # ]: 0 : DO ir=mxroot+1,nroot
4447 : 0 : ierr=ierr+9*(10**(ir-1))
4448 : : ENDDO
4449 : 0 : success=.false.
4450 : : ENDIF
4451 : 248 : mxroot=min0(mxroot,nroot)
4452 [ - + ]: 248 : IF (nz.EQ.0) energy=-ABS(emin)
4453 [ + - ]: 248 : IF (nz.NE.0) energy=-(1.1_dp*(nz/(l+1._dp))**2)!*0.5!Hartree
4454 : 248 : emin=energy-err
4455 : 248 : emax=0._dp
4456 [ + + ]: 846 : DO iroot=1,mxroot
4457 : 598 : best=1.d10; dele=1.d10
4458 : 598 : energy=emin+err
4459 [ - + ]: 598 : IF (energy.LT.emin) energy=emin
4460 [ - + ]: 598 : IF (energy.GT.emax) energy=emax
4461 : 17898 : ok=.FALSE.
4462 [ + + ]: 17898 : BigIter: DO iter=1,niter
4463 : : ! start inward integration
4464 : : ! start integration at n
4465 : 17889 : call Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB)
4466 : : ! find classical turning point
4467 : 17889 : call ClassicalTurningPoint(Grid,Pot%rv,l,energy,match)
4468 : 17889 : match=max(match,10); match=min(match,n-20)
4469 : 17889 : call wfnsrasym(Grid,p2,lwfn,energy,iend,qq,Pot%jj)
4470 : 17889 : call prepareforcfdsol(Grid,n-iend,n,n,p2,lwfn,yy,zz,Pot%ww,Pot%jj)
4471 : 17889 : call cfdsoliter(Grid,zz,yy,n-iend,match)
4472 : 17889 : call getwfnfromcfdsol(match,n,yy,p2)
4473 : 17889 : match=match+6
4474 : 17889 : rin=Gfirstderiv(Grid,match,p2)/p2(match)
4475 : 17889 : call wfnsrinit(Grid,l,p1,lwfn,istart,Pot%finitenucleus,gamma,c1,c2,MA,MB,Pot%jj)
4476 : 17889 : call prepareforcfdsol(Grid,1,istart,n,p1,lwfn,yy,zz,Pot%ww,Pot%jj)
4477 : 17889 : call cfdsoliter(Grid,zz,yy,istart,match+6)
4478 : 17889 : call getwfnfromcfdsol(1,match+6,yy,p1)
4479 : 17889 : node= countnodes(2,match+6,p1)
4480 : 17889 : rout=Gfirstderiv(Grid,match,p1)/p1(match)
4481 : : ! check whether node = (iroot-1)
4482 : : ! not enough nodes -- raise energy
4483 [ + + ]: 53676 : IF (node.LT.iroot-1) THEN
4484 : 744 : emin=MAX(emin,energy)-err
4485 : 744 : energy=emax-(emax-energy)*ranx()
4486 : 744 : ifac=9
4487 : : ! too many nodes -- lower energy
4488 [ + + ]: 17145 : ELSEIF (node.GT.iroot-1) THEN
4489 [ - + ]: 496 : IF (energy.LE.emin) THEN
4490 : 0 : ierr=ierr+9*(10**(iroot-1))
4491 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'boundsr error -- emin too high',l,nz,emin,energy
4492 [ # # ]: 0 : IF (energy.LE.emin-tol10) THEN
4493 : 0 : STOP
4494 : : ENDIF
4495 : : ENDIF
4496 : 496 : emax=MIN(emax,energy+err)
4497 : 496 : energy=emin+(energy-emin)*ranx()
4498 : : ! correct number of nodes -- estimate correction
4499 [ + - ]: 16649 : ELSEIF (node.EQ.iroot-1) THEN
4500 [ + + ]: 10690262 : DO j=1,match
4501 : 10690262 : p1(j)=p1(j)/p1(match)
4502 : : ENDDO
4503 [ + + ]: 22674334 : DO j=match,n
4504 : 22674334 : p1(j)=p2(j)/p2(match)
4505 : : ENDDO
4506 : 16649 : scale=1._dp/overlap(Grid,p1,p1)
4507 : 16649 : dele=(rout-rin)*scale
4508 : 16649 : x=ABS(dele)
4509 [ + + ]: 16649 : IF (x.LT.best) THEN
4510 : 4577 : scale=SQRT(scale)
4511 [ + + ]: 9163154 : p1(1:n)=p1(1:n)*scale
4512 : 4577 : call filter(n,p1,machine_zero)
4513 [ + + ]: 9163154 : wfn(1:n,iroot)=p1(1:n)
4514 : 4577 : eig(iroot)=energy
4515 : 4577 : best=x
4516 : : ENDIF
4517 [ + + ]: 16649 : IF (ABS(dele).LE.convrez) THEN
4518 : 589 : ok=.TRUE.
4519 : : ! eigenvalue found
4520 : 589 : ierr=ierr+10**(iroot-1)
4521 [ + + ]: 589 : IF (iroot+1.LE.mxroot) THEN
4522 : 350 : emin=energy+err
4523 : 350 : emax=0
4524 : 350 : energy=(emin+emax)/2
4525 [ - + ]: 350 : IF (energy.LT.emin) energy=emin
4526 [ - + ]: 350 : IF (energy.GT.emax) energy=emax
4527 : : best=1.d10
4528 : : ENDIF
4529 : : EXIT BigIter
4530 : : ENDIF
4531 [ + - ]: 16060 : IF (ABS(dele).GT.convrez) THEN
4532 : 16060 : energy=energy+dele!*0.5!hartree
4533 : : ! if energy is out of range, pick random energy in correct range
4534 [ + + + + ]: 16060 : IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) &
4535 : 11494 : energy=emin+(emax-emin)*ranx()
4536 : : ifac=2
4537 : : ENDIF
4538 : : ENDIF
4539 : : ENDDO BigIter !iter
4540 : 248 : IF (.NOT.ok) THEN
4541 : 9 : success=.false.
4542 : 9 : ierr=ierr+ifac*(10**(iroot-1))
4543 [ - + ]: 9 : if(has_to_print) write(std_out,*) 'no convergence in boundsr',iroot,l,dele,energy
4544 [ - + ]: 9 : if(has_to_print) write(std_out,*) ' best guess of eig, dele = ',eig(iroot),best
4545 [ - + ]: 9 : IF (iroot.LT.mxroot) THEN
4546 [ # # ]: 0 : DO ir=iroot+1,mxroot
4547 : 0 : ierr=ierr+9*(10**(ir-1))
4548 : : ENDDO
4549 : : ENDIF
4550 : : ! reset wfn with hydrogenic form
4551 : 9 : j=iroot+l+1
4552 [ + + ]: 18018 : wfn(:,iroot)=0
4553 : 9 : x=(j)*sqrt(abs(eig(iroot)*2.0))
4554 [ + + ]: 18009 : do i=2,n
4555 : 18009 : wfn(i,iroot)=hwfn(x,j,l,Grid%r(i))
4556 : : enddo
4557 : : ENDIF
4558 : : ENDDO !iroot
4559 [ - + ]: 248 : LIBPAW_DEALLOCATE(p1)
4560 [ - + ]: 248 : LIBPAW_DEALLOCATE(p2)
4561 [ - + ]: 248 : LIBPAW_DEALLOCATE(dd)
4562 [ - + ]: 248 : LIBPAW_DEALLOCATE(lwfn)
4563 [ - + ]: 248 : LIBPAW_DEALLOCATE(yy)
4564 [ - + ]: 248 : LIBPAW_DEALLOCATE(zz)
4565 [ - + ]: 496 : END SUBROUTINE Boundsr
4566 : :
4567 : :
4568 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4569 : : !! prepareforcfdsol
4570 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4571 [ - + - + : 36031 : subroutine prepareforcfdsol(Grid,i1,i2,n,wfn,lwfn,yy,zz,ww,jj)
- + - + -
+ - + ]
4572 : : Type(gridinfo), INTENT(IN) :: Grid
4573 : : INTEGER, INTENT(IN) :: i1,i2,n
4574 : : real(dp), INTENT(IN) :: wfn(:),lwfn(:)
4575 : : real(dp), INTENT(OUT) :: yy(:,:),zz(:,:,:)
4576 : : real(dp),intent(in) :: ww(:),jj(:)
4577 : : INTEGER :: i
4578 [ + + + + : 721046102 : yy=0;zz=0
+ + + + +
+ ]
4579 [ + + ]: 252217 : yy(1,i1:i2)=wfn(i1:i2)
4580 [ + + ]: 252217 : yy(2,i1:i2)=lwfn(i1:i2)
4581 [ + + ]: 72097404 : do i=2,n
4582 : 72061373 : zz(1,1,i)=1._dp/Grid%r(i)
4583 : 72061373 : zz(1,2,i)=jj(i)/Grid%r(i)
4584 : 72061373 : zz(2,2,i)=-1._dp/Grid%r(i)
4585 : 72097404 : zz(2,1,i)=ww(i)
4586 : : enddo
4587 : 36031 : end subroutine prepareforcfdsol
4588 : :
4589 : :
4590 : :
4591 : :
4592 : :
4593 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4594 : : ! 7. anderson_driver
4595 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4596 : :
4597 : :
4598 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4599 : : !! Anderson_Mix
4600 : : !! Performs the actual mixing of the input vector with the
4601 : : !! history and retuns the result.
4602 : : !!
4603 : : !! AC - Anderson context
4604 : : !! X - Current vector on input and new guess on output
4605 : : !! F - F(X) - X. Nonlinear mixing of input vector
4606 : : !!
4607 : : !! Modified to call SVD routines
4608 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4609 [ - + - + ]: 331 : SUBROUTINE Anderson_Mix(AC, X, F)
4610 : : SAVE
4611 : : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4612 : : real(dp), INTENT(INOUT) :: X(:)
4613 : : real(dp), INTENT(IN) :: F(:)
4614 : : INTEGER :: i, slot, currentdim , n ,j
4615 : : real(dp) :: term
4616 : : real(dp) :: tmp
4617 : : !First determine where to store the new correction vectors ***
4618 : 331 : AC%slot = AC%slot + 1
4619 [ + + ]: 331 : IF (AC%Slot>AC%Nmax) AC%Slot = 1
4620 [ + + - + ]: 331 : IF ((AC%N < 0) .OR. (AC%Nmax == 0)) THEN !** Simple mixing for 1st time ***
4621 [ + + ]: 46046 : AC%Xprev = X
4622 [ + + ]: 46046 : X = X + AC%NewMix*F
4623 : : ELSE
4624 : 308 : slot = AC%Slot
4625 [ + + ]: 616616 : AC%DF(:,slot) = F - AC%Fprev !** Make new DF vector
4626 [ + + ]: 616616 : AC%DX(:,slot) = X - AC%Xprev !** Make new DX vector
4627 : 308 : currentdim=MIN(AC%N+1,AC%Nmax)
4628 [ + + ]: 1624 : DO i=1, currentdim !*** Add row/col to matrix
4629 [ + + ]: 2634632 : term = DOT_PRODUCT(AC%DF(:,i), AC%DF(:,slot))
4630 : 1316 : AC%Matrix(i,slot) = term
4631 [ + + ]: 1316 : IF (i /= slot) AC%Matrix(slot,i) = (term)
4632 [ + + ]: 2634940 : AC%Gamma(i) = DOT_PRODUCT(AC%DF(:,i), F)
4633 : : END DO
4634 [ + + + + ]: 9548 : AC%DupMatrix = AC%Matrix
4635 : 308 : n = AC%Nmax; j= currentdim
4636 : : CALL DGESDD('A',j,j,AC%DupMatrix(1,1),n,AC%S(1), &
4637 : 308 : AC%U(1,1),n,AC%VT(1,1),n,AC%Work(1),AC%Lwork, AC%IPIV(1),i)
4638 [ - + ]: 308 : IF (i /= 0) THEN
4639 : 0 : LIBPAW_ERROR('Anderson_Mix: Error in DGESDD.')
4640 : : END IF
4641 [ + + ]: 1624 : AC%Work(1:j) = AC%Gamma(1:j)
4642 [ + + ]: 1848 : AC%Gamma = 0
4643 : 308 : tmp=MAX(ABS(AC%S(1))/AC%ConditionNo,AC%Machaccur)
4644 [ + + ]: 1624 : DO i=1,j
4645 [ + + ]: 1624 : IF (ABS(AC%S(i)).GT.tmp) THEN
4646 : : AC%Gamma(1:j)=AC%Gamma(1:j)+&
4647 [ + + + + ]: 5045 : (AC%VT(i,1:j))*DOT_PRODUCT(AC%U(1:j,i),AC%Work(1:j))/AC%S(i)
4648 : : ENDIF
4649 : : ENDDO
4650 [ + + ]: 616616 : AC%Xprev = X
4651 : : !*** Now calculate the new vector ***
4652 [ + + ]: 616616 : X = X + AC%NewMix*F
4653 [ + + ]: 1624 : DO i=1, currentdim ! updated vector
4654 [ + + ]: 2634940 : X = X - AC%Gamma(i)*(AC%DX(:,i) + AC%NewMix*AC%DF(:,i))
4655 : : END DO
4656 : : END IF
4657 [ + + ]: 662662 : AC%Fprev = F
4658 : 331 : AC%N = AC%N + 1
4659 [ + + ]: 331 : IF (AC%N > AC%Nmax) AC%N = AC%Nmax
4660 : 331 : RETURN
4661 : : END SUBROUTINE Anderson_Mix
4662 : :
4663 : :
4664 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4665 : : !! Anderson_ResetMix - Resets the mixing history to None
4666 : : !! AC - Anderson context to reset
4667 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4668 : 0 : SUBROUTINE Anderson_ResetMix(AC)
4669 : : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4670 : 0 : AC%N = -1
4671 : 0 : AC%Slot = -1
4672 : 0 : AC%CurIter=0
4673 : : RETURN
4674 : : END SUBROUTINE Anderson_ResetMix
4675 : :
4676 : :
4677 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4678 : : !! FreeAnderson - Frees all the data associated with the AC data structure
4679 : : !! AC -Pointer to the Anderson context to free
4680 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4681 : 23 : SUBROUTINE FreeAnderson(AC)
4682 : : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4683 [ + - ]: 23 : IF (ASSOCIATED(AC%Matrix)) then
4684 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%Matrix)
4685 : : endif
4686 [ + - ]: 23 : IF (ASSOCIATED(AC%Gamma)) then
4687 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%Gamma)
4688 : : endif
4689 [ + - ]: 23 : IF (ASSOCIATED(AC%DF)) then
4690 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%DF)
4691 : : endif
4692 [ + - ]: 23 : IF (ASSOCIATED(AC%Fprev)) then
4693 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%Fprev)
4694 : : endif
4695 [ + - ]: 23 : IF (ASSOCIATED(AC%DX)) then
4696 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%DX)
4697 : : endif
4698 [ + - ]: 23 : IF (ASSOCIATED(AC%Xprev)) then
4699 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%Xprev)
4700 : : endif
4701 [ + - ]: 23 : IF (ASSOCIATED(AC%IPIV)) then
4702 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%IPIV)
4703 : : endif
4704 [ + - ]: 23 : IF (ASSOCIATED(AC%S)) then
4705 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%S)
4706 : : endif
4707 [ + - ]: 23 : IF (ASSOCIATED(AC%RWork)) then
4708 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%RWork)
4709 : : endif
4710 [ + - ]: 23 : IF (ASSOCIATED(AC%U)) then
4711 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%U)
4712 : : endif
4713 [ + - ]: 23 : IF (ASSOCIATED(AC%VT)) then
4714 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%VT)
4715 : : endif
4716 [ + - ]: 23 : IF (ASSOCIATED(AC%Work)) then
4717 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%Work)
4718 : : endif
4719 [ + - ]: 23 : IF (ASSOCIATED(AC%DupMatrix)) then
4720 : 23 : LIBPAW_POINTER_DEALLOCATE(AC%DupMatrix)
4721 : : endif
4722 : 23 : RETURN
4723 : : END SUBROUTINE FreeAnderson
4724 : :
4725 : :
4726 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4727 : : !! InitAnderson_dr - Initializes and Anderson_Context data structure for use
4728 : : !! AC - Anderson context created and returned
4729 : : !! Err_Unit - Output error unit
4730 : : !! Nmax - Max number of vectors to keep
4731 : : !! VecSize - Size of each vector
4732 : : !! NewMix - Mixing factor
4733 : : !! CondNo - For matrix inversion
4734 : : !! MaxIter - Maximum number of iterations
4735 : : !! err - minimum residue convergence tolerance
4736 : : !! toosmall - result obviously converged
4737 : : !! verbose - if true -- write out results
4738 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4739 : 23 : SUBROUTINE InitAnderson_dr(AC,Err_Unit,Nmax,VecSize,NewMix,CondNo,&
4740 : : & MaxIter,err,toosmall,verbose)
4741 : : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4742 : : INTEGER, INTENT(IN) :: Err_Unit
4743 : : INTEGER, INTENT(IN) :: Nmax
4744 : : INTEGER, INTENT(IN) :: VecSize
4745 : : real(dp), INTENT(IN) :: NewMix
4746 : : real(dp), INTENT(IN) :: CondNo
4747 : : INTEGER, INTENT(IN) :: MaxIter
4748 : : real(dp), INTENT(IN) :: err,toosmall
4749 : : LOGICAL, INTENT(IN) :: verbose
4750 : : real(dp) :: a1,a2,a3
4751 : 23 : AC%Nmax = Nmax !*** Store the contants
4752 : 23 : AC%VecSize = VecSize
4753 : 23 : AC%NewMix = NewMix
4754 : 23 : AC%Err_Unit = Err_Unit
4755 : 23 : AC%MaxIter = MaxIter
4756 : 23 : AC%err = err
4757 : 23 : AC%toosmall = toosmall
4758 : 23 : AC%writelots=verbose
4759 : 23 : AC%N = -1 !** Init the rest of the structure
4760 : 23 : AC%Slot = -1
4761 : 23 : AC%CurIter=0
4762 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%Xprev,(VecSize))
+ - + - -
+ - + ]
4763 [ - + + - : 46 : LIBPAW_POINTER_ALLOCATE(AC%Fprev,(VecSize))
- + - + ]
4764 [ - + + - : 92 : LIBPAW_POINTER_ALLOCATE(AC%DX,(VecSize,Nmax))
- + + - +
- + - - +
- + ]
4765 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%DF,(VecSize,Nmax))
- + + - -
+ - + ]
4766 [ - + + - : 92 : LIBPAW_POINTER_ALLOCATE(AC%Matrix,(Nmax,Nmax))
- + + - +
- + - - +
- + ]
4767 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%Gamma,(Nmax))
+ - + - -
+ - + ]
4768 : 23 : AC%Lwork=5*Nmax*Nmax+10*Nmax
4769 : 23 : AC%LRwork= 5*Nmax*Nmax+7*Nmax
4770 : 23 : AC%ConditionNo= CondNo
4771 : : ! Calculate machine accuracy
4772 : 23 : AC%Machaccur = 0
4773 : 23 : a1 = 4._dp/3._dp
4774 [ + + ]: 46 : DO WHILE (AC%Machaccur == 0._dp)
4775 : 23 : a2 = a1 - 1._dp
4776 : 23 : a3 = a2 + a2 + a2
4777 : 23 : AC%Machaccur = ABS(a3 - 1._dp)
4778 : : ENDDO
4779 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%DupMatrix,(Nmax,Nmax))
- + + - -
+ - + ]
4780 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%U,(Nmax, Nmax))
- + + - -
+ - + ]
4781 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%VT,(Nmax,Nmax))
- + + - -
+ - + ]
4782 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%Work,(AC%Lwork))
+ - + - -
+ - + ]
4783 [ - + + - : 69 : LIBPAW_POINTER_ALLOCATE(AC%RWork,(AC%LRWork))
+ - + - -
+ - + ]
4784 [ + - - + : 69 : LIBPAW_POINTER_ALLOCATE(AC%IPIV,(8*Nmax))
+ - + - +
- - + -
+ ]
4785 [ - + + - : 46 : LIBPAW_POINTER_ALLOCATE(AC%S,(Nmax))
- + - + ]
4786 [ + + + + ]: 713 : AC%Matrix = 0
4787 : 23 : RETURN
4788 : : END SUBROUTINE InitAnderson_dr
4789 : :
4790 : :
4791 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4792 : : !! DoAndersonMix
4793 : : !! Note residue can be wout-w or more general residue that tends --> 0
4794 : : !! at convergence
4795 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4796 [ - + ]: 23 : SUBROUTINE DoAndersonMix(AC,w,E,Esub,success,atp)
4797 : : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4798 : : real(dp), INTENT(INOUT) :: E,w(:)
4799 : : ! External :: Esub
4800 : : LOGICAL, INTENT(OUT) :: success
4801 : : type(atompaw_type), intent(inout) :: atp
4802 : 23 : real(dp), ALLOCATABLE :: residue(:),tmp(:)
4803 : : real(dp) :: err,v1,v2,v3,v4
4804 : : INTEGER :: i,n
4805 : : real(dp), PARAMETER :: conv1=4.d13,conv2=3.d13,conv3=2.d13,conv4=1.d13
4806 : : LOGICAL :: OK
4807 : : INTERFACE
4808 : : SUBROUTINE Esub(w,energy,residue,err,OK,update,atp)
4809 : : USE_DEFS
4810 : : import atompaw_type
4811 : : real(dp), INTENT(INOUT) :: w(:)
4812 : : real(dp), INTENT(OUT) :: energy
4813 : : real(dp), INTENT(OUT) :: residue(:)
4814 : : real(dp), INTENT(OUT) :: err
4815 : : LOGICAL, INTENT(OUT) :: OK
4816 : : LOGICAL, INTENT(IN) :: update
4817 : : type(atompaw_type), intent(inout) :: atp
4818 : : END SUBROUTINE Esub
4819 : : END INTERFACE
4820 : 23 : n=SIZE(w);success=.FALSE.
4821 [ - + + - : 69 : LIBPAW_ALLOCATE(residue,(n))
+ - + - -
+ - + ]
4822 [ - + + - : 46 : LIBPAW_ALLOCATE(tmp,(n))
- + - + ]
4823 : 23 : err=1.0d10
4824 [ + + ]: 46046 : v1=conv1;v2=conv2;v3=conv3;v4=conv4;tmp=0
4825 [ - + ]: 354 : DO i=1,AC%MaxIter
4826 : 354 : AC%CurIter=i
4827 : 354 : CALL Esub(w,E,residue,err,OK,.TRUE.,atp)
4828 : 354 : AC%res=err
4829 [ + + ]: 354 : if (err<AC%toosmall) THEN
4830 [ - + ]: 23 : If(AC%writelots)&
4831 : : write(std_out,&
4832 : : & '("AndersonMix converged in ",i5," iterations with err = ",1p,1e15.7)')&
4833 : 0 : & i, err
4834 : : EXIT
4835 : : endif
4836 : 331 : CALL shift4(v1,v2,v3,v4,err)
4837 [ + - ]: 263 : IF (i>=4.AND.OK) THEN
4838 : : IF ((.NOT.(v4.LE.v3.AND.v3.LE.v2 &
4839 [ + + + + : 263 : & .AND.v2.LE.v1).AND.v4.LE.AC%err).OR.err<AC%toosmall) THEN
+ + - + ]
4840 : : ! converged result
4841 : 0 : success=.TRUE.
4842 [ # # ]: 0 : If(AC%writelots)&
4843 : : write(std_out,&
4844 : : & '("AndersonMix converged in ",i5," iterations with err = ",1p,1e15.7)')&
4845 : 0 : & i, err
4846 : : EXIT
4847 : : ENDIF
4848 : : ENDIF
4849 [ - + ]: 331 : If(AC%writelots)write(std_out,'("AndersonMixIter ",i7,2x,1p,2e20.12)') i,E,err
4850 [ - + ]: 331 : IF (.NOT.OK) THEN
4851 : 0 : CALL Anderson_ResetMix(AC)
4852 [ # # ]: 0 : IF (i>1) THEN
4853 [ # # ]: 0 : w=tmp
4854 : 0 : AC%NewMix=MAX(0.00001_dp,AC%NewMix/2)
4855 [ # # ]: 0 : IF (AC%NewMix<=0.00001_dp) THEN
4856 : 0 : write(std_out,*) 'Sorry -- this is not working '
4857 : 0 : STOP
4858 : : ENDIF
4859 : : ENDIF
4860 : : ELSE
4861 : 331 : AC%NewMix=MIN(max(MaxMix,AC%NewMix),AC%NewMix*2)
4862 : : ENDIF
4863 [ + - - + : 662993 : tmp=w
- - + + ]
4864 : 331 : CALL Anderson_Mix(AC,w,residue)
4865 : : ENDDO
4866 [ - + ]: 23 : If (AC%CurIter.ge.AC%MaxIter) then
4867 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'Anderson Mix reached MaxIter without success',AC%MaxIter
4868 : : Endif
4869 [ - + ]: 23 : LIBPAW_DEALLOCATE(residue)
4870 [ - + ]: 23 : LIBPAW_DEALLOCATE(tmp)
4871 : 23 : END SUBROUTINE DoAndersonMix
4872 : :
4873 : :
4874 : :
4875 : :
4876 : :
4877 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4878 : : ! 8. global_math
4879 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4880 : :
4881 : :
4882 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4883 : : !! subroutine shapebes(al,ql,ll,rc)
4884 : : !! Find al and ql parameters for a "Bessel" shape function:
4885 : : !! Shape(r)=al1.jl(ql1.r)+al2.jl(ql2.r)
4886 : : !! such as Shape(r) and 2 derivatives are zero at r=rc
4887 : : !! Intg_0_rc[Shape(r).r^(l+2).dr]=1
4888 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4889 : 0 : SUBROUTINE shapebes(al,ql,ll,rc)
4890 : : INTEGER,INTENT(IN) :: ll
4891 : : REAL(dp),INTENT(IN) :: rc
4892 : : REAL(dp),INTENT(OUT) :: al(2),ql(2)
4893 : : INTEGER :: i
4894 : : REAL(dp) :: alpha,beta,det,qr,jbes,jbesp,jbespp,amat(2,2),bb(2)
4895 : 0 : alpha=1.D0;beta=0.D0
4896 : 0 : CALL solvbes(ql,alpha,beta,ll,2)
4897 [ # # ]: 0 : ql(1:2)=ql(1:2)/rc
4898 [ # # ]: 0 : DO i=1,2
4899 : 0 : qr=ql(i)*rc
4900 : 0 : CALL jbessel(jbes,jbesp,jbespp,ll,1,qr)
4901 : 0 : amat(1,i)=jbesp*ql(i)
4902 : 0 : CALL jbessel(jbes,jbesp,jbespp,ll+1,0,qr)
4903 : 0 : amat(2,i)=jbes*rc**(ll+2)/ql(i) ! Intg_0_rc[jl(qr).r^(l+2).dr]
4904 : : ENDDO
4905 : 0 : bb(1)=0._dp;bb(2)=1._dp
4906 : 0 : det=amat(1,1)*amat(2,2)-amat(1,2)*amat(2,1)
4907 : 0 : al(1)=(amat(2,2)*bb(1)-amat(1,2)*bb(2))/det
4908 : 0 : al(2)=(amat(1,1)*bb(2)-amat(2,1)*bb(1))/det
4909 : 0 : END SUBROUTINE shapebes
4910 : :
4911 : :
4912 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4913 : : !! ddexp
4914 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4915 : 827568 : FUNCTION ddexp(arg)
4916 : : real(dp) :: arg,ddexp
4917 [ - + ]: 827568 : IF (arg>maxexparg) THEN
4918 : 0 : ddexp=maxexp
4919 [ + + ]: 827568 : ELSE IF (arg<minexparg) THEN
4920 : 15766 : ddexp=minexp
4921 : : ELSE
4922 : 811802 : ddexp=EXP(arg)
4923 : : ENDIF
4924 : : RETURN
4925 : : END FUNCTION ddexp
4926 : :
4927 : :
4928 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4929 : : !! ddlog
4930 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4931 : 960271 : FUNCTION ddlog(arg)
4932 : : real(dp) :: arg,ddlog
4933 [ - + ]: 960271 : IF (arg>maxlogarg) THEN
4934 : 0 : ddlog=maxlog
4935 [ + + ]: 960271 : ELSE IF (arg<minlogarg) THEN
4936 : 20700 : ddlog=minlog
4937 : : ELSE
4938 : 939571 : ddlog=LOG(arg)
4939 : : ENDIF
4940 : : RETURN
4941 : : END FUNCTION ddlog
4942 : :
4943 : :
4944 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4945 : : !! ranx
4946 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4947 : 28429 : FUNCTION ranx()
4948 : : real(dp) :: ranx
4949 : : INTEGER, PARAMETER :: konst=125
4950 : : INTEGER :: m=100001
4951 : 28429 : m=m*konst
4952 : 28429 : m=m-2796203*(m/2796203)
4953 : 12734 : ranx=m/2796203._dp
4954 : : RETURN
4955 : : END FUNCTION ranx
4956 : :
4957 : :
4958 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4959 : : !! factorial
4960 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4961 : 198041 : FUNCTION factorial(n)
4962 : : real(dp) :: factorial
4963 : : INTEGER, INTENT(IN) :: n
4964 : : INTEGER :: i
4965 : 198041 : factorial=one
4966 : 198041 : IF (n.LT.2) RETURN
4967 [ + + + + : 486077 : DO i=2,n
+ + ]
4968 : 486077 : factorial=factorial*i
4969 : : ENDDO
4970 : : END FUNCTION factorial
4971 : :
4972 : :
4973 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4974 : : !! FUNCTION hwfn(z,np,l,r)
4975 : : !! function to calculate the radial H wfn for nuclear charge z
4976 : : !! (note in this version z is real and need not be integral)
4977 : : !! principal qn np
4978 : : !! orbital qn l
4979 : : !! r*(radial H wfn) is returned
4980 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4981 : 66017 : FUNCTION hwfn(z,np,l,r)
4982 : : real(dp) :: hwfn
4983 : : real(dp), INTENT(IN) :: z,r
4984 : : INTEGER, INTENT(IN) :: np,l
4985 : : INTEGER :: node,k
4986 : : real(dp) :: scale_,rho,pref,term,sum_
4987 : 66017 : node=np-l-1
4988 : 66017 : scale_=2._dp*z/np
4989 : 66017 : rho=scale_*r
4990 [ + + + + ]: 126031 : pref=scale_*SQRT(scale_*factorial(np+l)/(2*np*factorial(node)))
4991 [ + + + + ]: 66017 : if(rho==zero.and.l==0) then
4992 : : term=one/factorial(2*l+1)
4993 : : else
4994 [ + + ]: 110014 : term=(rho**l)/factorial(2*l+1)
4995 : : endif
4996 : 66017 : sum_=term
4997 [ + + ]: 66017 : IF (node.GT.0) THEN
4998 [ + + ]: 136025 : DO k=1,node
4999 : 84015 : term=-term*(node-k+1)*rho/(k*(2*l+1+k))
5000 : 136025 : sum_=sum_+term
5001 : : ENDDO
5002 : : ENDIF
5003 : 66017 : hwfn=r*pref*ddexp(-0.5_dp*rho)*sum_
5004 : 66017 : END FUNCTION hwfn
5005 : :
5006 : :
5007 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5008 : : !! subroutine dirachwfn(np,kappa,z,r,eig,g,f)
5009 : : !! Subroutine to calculate eigenenergy and radial wavefunctions*r
5010 : : !! for bound state solutions to the Hydrogenic Dirac equation
5011 : : !! for nuclear charge z. Energy in Rydberg atomic units
5012 : : !! np is principal quantum number --
5013 : : !! np=abs(kappa), abs(kappa)+1, abs(kappa)+2 ..
5014 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5015 : 40010 : subroutine dirachwfn(np,kappa,z,r,eig,g,f)
5016 : : INTEGER, INTENT(IN) :: np, kappa
5017 : : real(dp), INTENT(IN) :: z,r
5018 : : real(dp), INTENT(INOUT) :: eig,g,f
5019 : : INTEGER :: ak,nr
5020 : : real(dp) :: norm,s,rho,ne, term1, term2, term0,x
5021 : 40010 : ak=abs(kappa)
5022 : 40010 : nr=np-ak
5023 : 40010 : s=sqrt(ak**2-(z**2)*(fsalpha2))
5024 : 40010 : ne=sqrt(np**2-2*nr*(ak-s))
5025 : 40010 : rho=2*z*r/ne
5026 : 40010 : norm=gammafunc(2*s+nr+1._dp)/(gammafunc(nr+1._dp)*4*ne*(ne-kappa))
5027 : 40010 : norm=sqrt(norm*2*z/ne)/gammafunc(2*s+1._dp)
5028 : 40010 : term1=0._dp
5029 [ + + ]: 40010 : if(nr>0) term1=nr*kummer(-nr+1,2*s+1._dp,rho)
5030 : 40010 : term2=(ne-kappa)*kummer(-nr,2*s+1._dp,rho)
5031 : 40010 : term0=norm*ddexp(-0.5_dp*rho)*(rho**s)
5032 : 40010 : eig=1._dp + ((z**2)*(fsalpha2))/(np - ak +s)**2
5033 : 40010 : eig=2*ifsalpha2*(1._dp/sqrt(eig) - 1._dp)
5034 : 40010 : x=0.5_dp*fsalpha2*eig
5035 : 40010 : g=sqrt(2._dp+x)*term0*(term2-term1)
5036 : 40010 : f=-sqrt(-x)*term0*(term2+term1)
5037 : 40010 : end subroutine dirachwfn
5038 : :
5039 : :
5040 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5041 : : ! subroutine filter(n,func,small)
5042 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5043 [ - + ]: 13881 : SUBROUTINE filter(n,func,small)
5044 : : INTEGER, INTENT(IN) :: n
5045 : : real(dp), INTENT(INOUT) :: func(:)
5046 : : real(dp), INTENT(IN) :: small
5047 : : INTEGER :: i
5048 [ + + ]: 27789762 : DO i=1,n
5049 [ + + ]: 27789762 : IF (ABS(func(i)).LT.small) func(i)=0._dp
5050 : : ENDDO
5051 : 13881 : END SUBROUTINE filter
5052 : :
5053 : :
5054 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5055 : : ! subroutine conthomas(n,o,d,sol)
5056 : : ! use Thomas's algorithm for inverting matrix
5057 : : ! Dale U. von Rosenberg, "Methods for the Numerical Solution of
5058 : : ! Partial Differential Equations,
5059 : : ! Am. Elsevier Pub., 1969, pg. 113
5060 : : ! On input, sol contains the RHS of the equation
5061 : : ! On ouput, sol contains the solution of the equation
5062 : : ! Equation: o*sol(i-1)+d*sol(i)+o*sol(i+1) = RHS(i)
5063 : : ! sol(1)==sol(n+1)==0
5064 : : ! simplified version for constant tridiagonal terms --
5065 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5066 [ - + ]: 25 : SUBROUTINE conthomas(n,o,d,sol)
5067 : : INTEGER, INTENT(IN) :: n
5068 : : real(dp), INTENT(IN) :: o,d
5069 : : real(dp), INTENT(INOUT) :: sol(:)
5070 : 25 : real(dp), ALLOCATABLE :: a(:),b(:)
5071 : : real(dp) :: ss2
5072 : : INTEGER :: i
5073 [ - + + - : 75 : LIBPAW_ALLOCATE(a,(n))
+ - + - -
+ - + ]
5074 [ - + + - : 50 : LIBPAW_ALLOCATE(b,(n))
- + - + ]
5075 : 25 : a(2)=d
5076 : 25 : ss2=o*o
5077 [ + + ]: 50000 : DO i=3,n
5078 : 50000 : a(i)=d-ss2/a(i-1)
5079 : : ENDDO
5080 : 25 : b(2)=sol(2)/d
5081 [ + + ]: 50000 : DO i=3,n
5082 : 50000 : b(i)=(sol(i)-o*b(i-1))/a(i)
5083 : : ENDDO
5084 : 25 : sol(n)=b(n)
5085 [ + + ]: 50000 : DO i=n-1,2,-1
5086 : 50000 : sol(i)=b(i)-o*sol(i+1)/a(i)
5087 : : ENDDO
5088 : 25 : sol(1)=0
5089 : 25 : LIBPAW_DEALLOCATE(a)
5090 : 25 : LIBPAW_DEALLOCATE(b)
5091 : 25 : END SUBROUTINE conthomas
5092 : :
5093 : :
5094 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5095 : : ! function kummer(n,b,z)
5096 : : ! function to return confluent hypergeometric function (Kummer)
5097 : : ! as defined in Handbook of mathematical functions pg. 504
5098 : : ! assumes n=0, -1, -2, .. for polymomials of order 0, 1, 2, etc.
5099 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5100 : 74017 : FUNCTION kummer(n,b,z)
5101 : : real(dp) :: kummer
5102 : : INTEGER, INTENT(IN) :: n
5103 : : real(dp), INTENT(IN) :: b,z
5104 : : INTEGER :: i,k,j,nn
5105 : : real(dp) :: num,den,fac,bb
5106 [ - + ]: 74017 : if (n>0) then
5107 : 0 : LIBPAW_ERROR('Error in kummer function -- n>0')
5108 : : endif
5109 : 74017 : kummer=1._dp
5110 [ + + ]: 74017 : if (n==0) return
5111 : 54010 : j=-n
5112 : 54010 : k=1
5113 : 54010 : nn=n
5114 : 54010 : bb=b
5115 : 54010 : num=n
5116 : 54010 : den=b
5117 : 54010 : fac=z*nn/(bb*k)
5118 : 54010 : kummer=kummer+fac
5119 [ + + ]: 54010 : if (j>1) then
5120 [ + + ]: 62009 : do i=1,j-1
5121 : 36005 : nn=nn+1
5122 : 36005 : bb=bb+1
5123 : 36005 : k=k+1
5124 : 36005 : fac=fac*z*nn/(bb*k)
5125 : 62009 : kummer=kummer+fac
5126 : : enddo
5127 : : endif
5128 : : END FUNCTION kummer
5129 : :
5130 : :
5131 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5132 : : ! Gamma function function obtained from netlib.org
5133 : : ! This routine calculates the GAMMA function for a real argument X
5134 : : ! Computation is based on an algorithm outlined in reference 1
5135 : : ! The program uses rational functions that approximate the GAMM
5136 : : ! function to at least 20 significant decimal digits. Coefficient
5137 : : ! for the approximation over the interval (1,2) are unpublished
5138 : : ! Those for the approximation for X .GE. 12 are from reference 2
5139 : : ! The accuracy achieved depends on the arithmetic system, th
5140 : : ! compiler, the intrinsic functions, and proper selection of th
5141 : : ! machine-dependent constants
5142 : : !
5143 : : !******************************************************************
5144 : : !
5145 : : ! Explanation of machine-dependent constant
5146 : : !
5147 : : ! beta - radix for the floating-point representatio
5148 : : ! maxexp - the smallest positive power of beta that overflow
5149 : : ! XBIG - the largest argument for which GAMMA(X) is representabl
5150 : : ! in the machine, i.e., the solution to the equatio
5151 : : ! GAMMA(XBIG) = beta**maxex
5152 : : ! XINF - the largest machine representable floating-point number
5153 : : ! approximately beta**maxex
5154 : : ! EPS - the smallest positive floating-point number such tha
5155 : : ! 1.0+EPS .GT. 1.
5156 : : ! XMININ - the smallest positive floating-point number such tha
5157 : : ! 1/XMININ is machine representabl
5158 : : !
5159 : : ! Approximate values for some important machines are
5160 : : !
5161 : : ! beta maxexp XBI
5162 : : !
5163 : : ! CRAY-1 (S.P.) 2 8191 966.96
5164 : : ! Cyber 180/85
5165 : : ! under NOS (S.P.) 2 1070 177.80
5166 : : ! IEEE (IBM/XT
5167 : : ! SUN, etc.) (S.P.) 2 128 35.04
5168 : : ! IEEE (IBM/XT
5169 : : ! SUN, etc.) (D.P.) 2 1024 171.62
5170 : : ! IBM 3033 (D.P.) 16 63 57.57
5171 : : ! VAX D-Format (D.P.) 2 127 34.84
5172 : : ! VAX G-Format (D.P.) 2 1023 171.48
5173 : : !
5174 : : ! XINF EPS XMINI
5175 : : !
5176 : : ! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-246
5177 : : ! Cyber 180/85
5178 : : ! under NOS (S.P.) 1.26E+322 3.55E-15 3.14E-29
5179 : : ! IEEE (IBM/XT
5180 : : ! SUN, etc.) (S.P.) 3.40E+38 1.19E-7 1.18E-3
5181 : : ! IEEE (IBM/XT
5182 : : ! SUN, etc.) (D.P.) 1.79D+308 2.22D-16 2.23D-30
5183 : : ! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-7
5184 : : ! VAX D-Format (D.P.) 1.70D+38 1.39D-17 5.88D-3
5185 : : ! VAX G-Format (D.P.) 8.98D+307 1.11D-16 1.12D-30
5186 : : !
5187 : : !******************************************************************
5188 : : ! Error return
5189 : : !
5190 : : ! The program returns the value XINF for singularities o
5191 : : ! when overflow would occur. The computation is believe
5192 : : ! to be free of underflow and overflow
5193 : : !
5194 : : !
5195 : : ! Intrinsic functions required are
5196 : : !
5197 : : ! INT, DBLE, EXP, LOG, REAL, SI
5198 : : !
5199 : : !
5200 : : ! References: "An Overview of Software Development for Specia
5201 : : ! Functions", W. J. Cody, Lecture Notes in Mathematics
5202 : : ! 506, Numerical Analysis Dundee, 1975, G. A. Watso
5203 : : ! (ed.), Springer Verlag, Berlin, 1976
5204 : : !
5205 : : ! Computer Approximations, Hart, Et. Al., Wiley an
5206 : : ! sons, New York, 1968
5207 : : !
5208 : : ! Latest modification: October 12, 1989
5209 : : !
5210 : : ! Authors: W. J. Cody and L. StoltZ
5211 : : ! Applied Mathematics DivisioN
5212 : : ! Argonne National LaboratorY
5213 : : ! Argonne, IL 60439
5214 : : !
5215 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5216 : 120030 : FUNCTION GAMMAFUNC(X)
5217 : : real(dp) :: GAMMAFUNC,X
5218 : : INTEGER:: I,N
5219 : : real(dp) :: &
5220 : : & CONV,EPS,FACT,HALF,ONE,RES,SQRTPI,SUM,TWELVE, &
5221 : : & TWO,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
5222 : : real(dp) :: C(7),P(8),Q(8)
5223 : : LOGICAL :: PARITY
5224 : : !---------------------------------------------------------------------
5225 : : ! Mathematical constants
5226 : : !---------------------------------------------------------------------
5227 : : DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/, &
5228 : : & SQRTPI/0.9189385332046727417803297D0/
5229 : : !!!!& PI/3.1415926535897932384626434D0/ (already defined)
5230 : : !---------------------------------------------------------------------
5231 : : ! Machine dependent parameter
5232 : : !---------------------------------------------------------------------
5233 : : DATA XBIG,XMININ,EPS,XINF/171.624D0,2.23D-308,2.22D-16,1.79D308/
5234 : : !---------------------------------------------------------------------
5235 : : ! Numerator and denominator coefficients for rational minima
5236 : : ! approximation over (1,2)
5237 : : !---------------------------------------------------------------------
5238 : : DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1, &
5239 : : & -3.79804256470945635097577D+2,6.29331155312818442661052D+2, &
5240 : : & 8.66966202790413211295064D+2,-3.14512729688483675254357D+4, &
5241 : : & -3.61444134186911729807069D+4,6.64561438202405440627855D+4/
5242 : : DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2, &
5243 : : & -1.01515636749021914166146D+3,-3.10777167157231109440444D+3, &
5244 : : & 2.25381184209801510330112D+4,4.75584627752788110767815D+3, &
5245 : : & -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/
5246 : : !---------------------------------------------------------------------
5247 : : ! Coefficients for minimax approximation over (12, INF)
5248 : : !---------------------------------------------------------------------
5249 : : DATA C/-1.910444077728D-03,8.4171387781295D-04 , &
5250 : : & -5.952379913043012D-04,7.93650793500350248D-04 , &
5251 : : & -2.777777777777681622553D-03,8.333333333333333331554247D-02 , &
5252 : : & 5.7083835261D-03/
5253 : : !---------------------------------------------------------------------
5254 : : ! Statement functions for conversion between integer and floa
5255 : : !---------------------------------------------------------------------
5256 : : CONV(I) = DBLE(I)
5257 : 120030 : PARITY = .FALSE.
5258 : 120030 : FACT = ONE
5259 : 120030 : N = 0
5260 : 120030 : Y = X
5261 [ - + ]: 120030 : IF (Y .LE. ZERO) THEN
5262 : : !---------------------------------------------------------------------
5263 : : ! Argument is negative
5264 : : !---------------------------------------------------------------------
5265 : 0 : Y = -X
5266 : 0 : Y1 = AINT(Y)
5267 : 0 : RES = Y - Y1
5268 [ # # ]: 0 : IF (RES .NE. ZERO) THEN
5269 [ # # ]: 0 : IF (Y1 .NE. AINT(Y1*HALF)*TWO) PARITY = .TRUE.
5270 : 0 : FACT = -PI / SIN(PI*RES)
5271 : 0 : Y = Y + ONE
5272 : : ELSE
5273 : 0 : RES = XINF
5274 : 0 : GO TO 900
5275 : : END IF
5276 : : END IF
5277 : : !---------------------------------------------------------------------
5278 : : ! Argument is positiv
5279 : : !---------------------------------------------------------------------
5280 [ - + ]: 120030 : IF (Y .LT. EPS) THEN
5281 : : !---------------------------------------------------------------------
5282 : : ! Argument .LT. EPS
5283 : : !---------------------------------------------------------------------
5284 [ # # ]: 0 : IF (Y .GE. XMININ) THEN
5285 : 0 : RES = ONE / Y
5286 : : ELSE
5287 : 0 : RES = XINF
5288 : 0 : GO TO 900
5289 : : END IF
5290 [ + - ]: 120030 : ELSE IF (Y .LT. TWELVE) THEN
5291 : 120030 : Y1 = Y
5292 [ - + ]: 120030 : IF (Y .LT. ONE) THEN
5293 : : !---------------------------------------------------------------------
5294 : : ! 0.0 .LT. argument .LT. 1.
5295 : : !---------------------------------------------------------------------
5296 : 0 : Z = Y
5297 : 0 : Y = Y + ONE
5298 : : ELSE
5299 : : !---------------------------------------------------------------------
5300 : : ! 1.0 .LT. argument .LT. 12.0, reduce argument if necessar
5301 : : !---------------------------------------------------------------------
5302 : 120030 : N = INT(Y) - 1
5303 : 120030 : Y = Y - CONV(N)
5304 : 120030 : Z = Y - ONE
5305 : : END IF
5306 : : !---------------------------------------------------------------------
5307 : : ! Evaluate approximation for 1.0 .LT. argument .LT. 2.
5308 : : !---------------------------------------------------------------------
5309 : 120030 : XNUM = ZERO
5310 : 120030 : XDEN = ONE
5311 [ + + ]: 1080270 : DO 260 I = 1, 8
5312 : 960240 : XNUM = (XNUM + P(I)) * Z
5313 : 960240 : XDEN = XDEN * Z + Q(I)
5314 : 120030 : 260 CONTINUE
5315 : 120030 : RES = XNUM / XDEN + ONE
5316 [ - + ]: 120030 : IF (Y1 .LT. Y) THEN
5317 : : !---------------------------------------------------------------------
5318 : : ! Adjust result for case 0.0 .LT. argument .LT. 1.
5319 : : !---------------------------------------------------------------------
5320 : 0 : RES = RES / Y1
5321 [ + + ]: 120030 : ELSE IF (Y1 .GT. Y) THEN
5322 : : !---------------------------------------------------------------------
5323 : : ! Adjust result for case 2.0 .LT. argument .LT. 12.
5324 : : !---------------------------------------------------------------------
5325 [ + + ]: 446089 : DO 290 I = 1, N
5326 : 332062 : RES = RES * Y
5327 : 332062 : Y = Y + ONE
5328 : 114027 : 290 CONTINUE
5329 : : END IF
5330 : : ELSE
5331 : : !---------------------------------------------------------------------
5332 : : ! Evaluate for argument .GE. 12.0
5333 : : !---------------------------------------------------------------------
5334 [ # # ]: 0 : IF (Y .LE. XBIG) THEN
5335 : 0 : YSQ = Y * Y
5336 : 0 : SUM = C(7)
5337 [ # # ]: 0 : DO 350 I = 1,6
5338 : 0 : SUM = SUM / YSQ + C(I)
5339 : 0 : 350 CONTINUE
5340 : 0 : SUM = SUM/Y - Y + SQRTPI
5341 : 0 : SUM = SUM + (Y-HALF)*LOG(Y)
5342 : 0 : RES = EXP(SUM)
5343 : : ELSE
5344 : 0 : RES = XINF
5345 : 0 : GO TO 900
5346 : : END IF
5347 : : END IF
5348 : : !---------------------------------------------------------------------
5349 : : ! Final adjustments and retur
5350 : : !---------------------------------------------------------------------
5351 [ - + ]: 120030 : IF (PARITY) RES = -RES
5352 [ - + ]: 120030 : IF (FACT .NE. ONE) RES = FACT / RES
5353 : 120030 : 900 GAMMAFUNC = RES
5354 : : RETURN
5355 : : ! ---------- Last line of GAMMA ---------
5356 : : END FUNCTION GAMMAFUNC
5357 : :
5358 : :
5359 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5360 : : !! SUBROUTINE shift4(v1,v2,v3,v4,NEW)
5361 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5362 : 331 : SUBROUTINE shift4(v1,v2,v3,v4,NEW)
5363 : : real(dp), INTENT(IN) :: NEW
5364 : : real(dp), INTENT(INOUT) :: v1,v2,v3,v4
5365 : 331 : v1=v2
5366 : 331 : v2=v3
5367 : 331 : v3=v4
5368 [ + + ]: 331 : v4=NEW
5369 : : RETURN
5370 : : END SUBROUTINE shift4
5371 : :
5372 : :
5373 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5374 : : ! subroutine jbessel(bes,besp,bespp,ll,order,xx)
5375 : : ! Spherical bessel function and derivatives
5376 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5377 : 0 : SUBROUTINE jbessel(bes,besp,bespp,ll,order,xx)
5378 : : INTEGER,INTENT(IN) :: ll,order
5379 : : real(dp),INTENT(IN) :: xx
5380 : : real(dp),INTENT(OUT) :: bes,besp,bespp
5381 : : INTEGER,PARAMETER :: imax=40
5382 : : real(dp),PARAMETER :: prec=tol15
5383 : : INTEGER :: ii,il
5384 : : real(dp) :: besp1,fact,factp,factpp,jn,jnp,jnpp,jr,xx2,xxinv
5385 [ # # ]: 0 : IF (order>2) STOP "Wrong order in jbessel !"
5386 [ # # ]: 0 : IF (ABS(xx)<prec) THEN
5387 [ # # ]: 0 : bes=0._dp;IF (ll==0) bes=1._dp
5388 [ # # ]: 0 : IF (order>=1) THEN
5389 [ # # ]: 0 : besp=0._dp;IF (ll==1) besp=1._dp/3._dp
5390 : : ENDIF
5391 [ # # ]: 0 : IF (order==2) THEN
5392 : 0 : bespp=0._dp
5393 [ # # ]: 0 : IF (ll==0) bespp=-1._dp/3._dp
5394 [ # # ]: 0 : IF (ll==2) bespp=2._dp/15._dp
5395 : : ENDIF
5396 : 0 : RETURN
5397 : : ENDIF
5398 : 0 : xxinv=1._dp/xx
5399 [ # # ]: 0 : IF (xx<1._dp) THEN
5400 : 0 : xx2=0.5_dp*xx*xx
5401 [ # # ]: 0 : fact=1.D0;DO il=1,ll;fact=fact*xx/DBLE(2*il+1);ENDDO
5402 : : jn=1.D0;jr=1.D0;ii=0
5403 [ # # # # ]: 0 : DO WHILE(ABS(jr)>=prec.AND.ii<imax)
5404 : 0 : ii=ii+1;jr=-jr*xx2/DBLE(ii*(2*(ll+ii)+1))
5405 : 0 : jn=jn+jr
5406 : : ENDDO
5407 : 0 : bes=jn*fact
5408 [ # # ]: 0 : IF (ABS(jr)>prec) STOP 'Error: Bessel function did not converge !'
5409 [ # # ]: 0 : IF (order>=1) THEN
5410 : 0 : factp=fact*xx/DBLE(2*ll+3)
5411 : 0 : jnp=1.D0;jr=1.D0;ii=0
5412 [ # # # # ]: 0 : DO WHILE(ABS(jr)>=prec.AND.ii<imax)
5413 : 0 : ii=ii+1;jr=-jr*xx2/DBLE(ii*(2*(ll+ii)+3))
5414 : 0 : jnp=jnp+jr
5415 : : ENDDO
5416 : 0 : besp=-jnp*factp+jn*fact*xxinv*DBLE(ll)
5417 [ # # ]: 0 : IF (ABS(jr)>prec) STOP 'Error: 1st der. of Bessel function did not converge !'
5418 : : ENDIF
5419 [ # # ]: 0 : IF (order==2) THEN
5420 : 0 : factpp=factp*xx/DBLE(2*ll+5)
5421 : 0 : jnpp=1.D0;jr=1.D0;ii=0
5422 [ # # # # ]: 0 : DO WHILE(ABS(jr)>=prec.AND.ii<imax)
5423 : 0 : ii=ii+1;jr=-jr*xx2/DBLE(ii*(2*(ll+ii)+5))
5424 : 0 : jnpp=jnpp+jr
5425 : : ENDDO
5426 : 0 : besp1=-jnpp*factpp+jnp*factp*xxinv*DBLE(ll+1)
5427 [ # # ]: 0 : IF (ABS(jr)>prec) STOP 'Error: 2nd der. of Bessel function did not converge !'
5428 : : ENDIF
5429 : : ELSE
5430 : 0 : jn =SIN(xx)*xxinv
5431 : 0 : jnp=(-COS(xx)+jn)*xxinv
5432 [ # # ]: 0 : DO il=2,ll+1
5433 : 0 : jr=-jn+DBLE(2*il-1)*jnp*xxinv
5434 : 0 : jn=jnp;jnp=jr
5435 : : ENDDO
5436 : 0 : bes=jn
5437 [ # # ]: 0 : IF (order>=1) besp =-jnp+jn *xxinv*DBLE(ll)
5438 [ # # ]: 0 : IF (order==2) besp1= jn -jnp*xxinv*DBLE(ll+2)
5439 : : ENDIF
5440 [ # # ]: 0 : IF (order==2) bespp=-besp1+besp*ll*xxinv-bes*ll*xxinv*xxinv
5441 : : END SUBROUTINE jbessel
5442 : :
5443 : :
5444 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5445 : : ! subroutine solvbes(root,alpha,l,nq)
5446 : : ! Find nq first roots of instrinsic equation:
5447 : : ! alpha.jl(Q) + beta.Q.djl/dr(Q) = 0
5448 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5449 : 0 : SUBROUTINE solvbes(root,alpha,beta,ll,nq)
5450 : : INTEGER,INTENT(IN) :: ll,nq
5451 : : real(dp),INTENT(IN) :: alpha,beta
5452 : : real(dp),INTENT(OUT) :: root(nq)
5453 : : real(dp),PARAMETER :: dh=1.D-1, tol=1.D-14
5454 : : INTEGER :: nroot
5455 : : real(dp) :: dum,y1,y2,jbes,jbesp,qq,qx,hh
5456 : 0 : qq=dh;nroot=0
5457 [ # # ]: 0 : DO WHILE (nroot<nq)
5458 : 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qq)
5459 : 0 : y1=alpha*jbes+beta*qq*jbesp
5460 : 0 : qq=qq+dh
5461 : 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qq)
5462 : 0 : y2=alpha*jbes+beta*qq*jbesp
5463 [ # # ]: 0 : DO WHILE (y1*y2>=0.D0)
5464 : 0 : qq=qq+dh
5465 : 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qq)
5466 : 0 : y2=alpha*jbes+beta*qq*jbesp
5467 : : ENDDO
5468 : 0 : hh=dh;qx=qq
5469 [ # # ]: 0 : DO WHILE (hh>tol)
5470 : 0 : hh=0.5D0*hh
5471 [ # # ]: 0 : IF (y1*y2<0) THEN
5472 : 0 : qx=qx-hh
5473 : : ELSE
5474 : 0 : qx=qx+hh
5475 : : ENDIF
5476 : 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qx)
5477 : 0 : y2=alpha*jbes+beta*qx*jbesp
5478 : : ENDDO
5479 : 0 : nroot=nroot+1
5480 : 0 : root(nroot)=qx
5481 : : ENDDO
5482 : 0 : END SUBROUTINE solvbes
5483 : :
5484 : :
5485 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5486 : : !! SUBROUTINE linsol(a,b,kk,la,ra,lb,det)
5487 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5488 : 3920 : SUBROUTINE linsol(a,b,kk,la,ra,lb,det)
5489 : : INTEGER, INTENT(IN) :: kk,la,ra,lb
5490 : : real(dp), INTENT(INOUT) :: a(la,ra),b(lb)
5491 : : real(dp), OPTIONAL, INTENT(OUT) :: det
5492 : : real(dp) :: d,s,r
5493 : : INTEGER :: kkm,i,j,k,l,ipo,n,kmo
5494 : 3920 : d = 1._dp
5495 [ - + ]: 3920 : if (kk>min(la,ra,lb)) then
5496 : 0 : LIBPAW_ERROR('Dimension error in linsol ')
5497 : : endif
5498 : 3920 : kkm=kk-1
5499 [ - + ]: 3920 : IF (kkm == 0) THEN
5500 : 0 : b(1)=b(1)/a(1,1)
5501 [ + - ]: 3920 : ELSE IF (kkm > 0) THEN
5502 [ + + ]: 23520 : DO i=1, kkm
5503 : : s = 0.0_dp
5504 : : l=i
5505 [ + + ]: 98000 : DO j=i,kk
5506 : 78400 : r=ABS(a(j,i))
5507 [ + + ]: 98000 : IF(r > s) THEN
5508 : 43120 : s=r
5509 : 43120 : l=j
5510 : : ENDIF
5511 : : ENDDO
5512 [ + + ]: 19600 : IF(l /= i) THEN
5513 [ + + ]: 86240 : DO j=i,kk
5514 : 70560 : s=a(i,j)
5515 : 70560 : a(i,j)=a(l,j)
5516 : 86240 : a(l,j)=s
5517 : : ENDDO
5518 : 15680 : s=b(i)
5519 : 15680 : b(i)=b(l)
5520 : 15680 : b(l)=s
5521 : 15680 : d = -d
5522 : : ENDIF
5523 [ + - ]: 23520 : IF (a(i,i) /= 0.0_dp) THEN
5524 : 19600 : ipo=i+1
5525 [ + + ]: 78400 : DO j=ipo,kk
5526 [ + + ]: 78400 : IF (a(j,i) /= 0.0_dp) THEN
5527 : 50960 : s=a(j,i)/a(i,i)
5528 : 50960 : a(j,i) = 0.0_dp
5529 [ + + ]: 227360 : DO k=ipo,kk
5530 : 227360 : a(j,k)=a(j,k)-a(i,k)*s
5531 : : ENDDO
5532 : 50960 : b(j)=b(j)-b(i)*s
5533 : : ENDIF
5534 : : ENDDO
5535 : : ENDIF
5536 : : ENDDO
5537 [ + + ]: 27440 : DO i=1,kk
5538 : 27440 : d=d*a(i,i)
5539 : : ENDDO
5540 : 3920 : kmo=kk-1
5541 : 3920 : b(kk)=b(kk)/a(kk,kk)
5542 [ + + ]: 23520 : DO i=1,kmo
5543 : 19600 : n=kk-i
5544 [ + + ]: 78400 : DO j=n,kmo
5545 : 78400 : b(n)=b(n)-a(n,j+1)*b(j+1)
5546 : : ENDDO
5547 : 23520 : b(n)=b(n)/a(n,n)
5548 : : ENDDO
5549 : : ENDIF
5550 : : !write(std_out,*) 'determinant from linsol ' , d
5551 [ - + - - ]: 3920 : IF(ABS(d).LT.tol10.and.has_to_print) then
5552 : 0 : WRITE(STD_OUT,*) '**warning from linsol --',&
5553 : 0 : & 'determinant too small --',d
5554 : : endif
5555 [ - + ]: 3920 : If (present(det)) det=d
5556 : 3920 : END SUBROUTINE linsol
5557 : :
5558 : :
5559 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5560 : : !! subroutine SolveAXeqB
5561 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5562 : : SUBROUTINE SolveAXeqB(n,A,B,conditionNo)
5563 : : ! General purpose AX=B solver for A, B real.
5564 : : ! On return, B stores X
5565 : : INTEGER, INTENT(IN) :: n
5566 : : REAL(dp), INTENT(IN) :: A(:,:)
5567 : : REAL(dp), INTENT(INOUT) :: B(:)
5568 : : REAL(dp), INTENT(IN), OPTIONAL :: conditionNo
5569 : : REAL(dp), ALLOCATABLE :: C(:,:),U(:,:),VT(:,:),X(:)
5570 : : REAL(dp), ALLOCATABLE :: WORK(:)
5571 : : REAL(dp), ALLOCATABLE :: S(:)
5572 : : REAL(dp), PARAMETER :: rtol=1.d-9
5573 : : INTEGER :: i,LWORK
5574 : : REAL(dp) :: xx,tol
5575 : : REAL(dp), PARAMETER :: one=1,zero=0
5576 : : IF (n == 1) THEN
5577 : : B(1)=B(1)/A(1,1)
5578 : : RETURN
5579 : : ENDIF
5580 : : LWORK=MAX(200,n*n)
5581 : : LIBPAW_ALLOCATE(C,(n,n))
5582 : : LIBPAW_ALLOCATE(X,(n))
5583 : : LIBPAW_ALLOCATE(U,(n,n))
5584 : : LIBPAW_ALLOCATE(VT,(n,n))
5585 : : LIBPAW_ALLOCATE(WORK,(LWORK))
5586 : : LIBPAW_ALLOCATE(S,(n))
5587 : : tol=rtol
5588 : : IF (PRESENT(conditionNo)) tol=1._dp/conditionNo
5589 : : C(1:n,1:n)=A(1:n,1:n)
5590 : : CALL DGESVD('A','A',n,n,C,n,S,U,n,VT,n,WORK,LWORK,i)
5591 : : tol=tol*S(1)
5592 : : X=0
5593 : : DO i=1,n
5594 : : if(has_to_print) write(std_out,*) 'Solver, tol ',i,S(i),tol
5595 : : IF (S(i)>tol) THEN
5596 : : xx=DOT_PRODUCT(U(1:n,i),B(1:n))/S(i)
5597 : : X(1:n)=X(1:n)+xx*(VT(i,1:n))
5598 : : ENDIF
5599 : : ENDDO
5600 : : B=X
5601 : : LIBPAW_DEALLOCATE(C)
5602 : : LIBPAW_DEALLOCATE(X)
5603 : : LIBPAW_DEALLOCATE(U)
5604 : : LIBPAW_DEALLOCATE(VT)
5605 : : LIBPAW_DEALLOCATE(WORK)
5606 : : LIBPAW_DEALLOCATE(S)
5607 : : END SUBROUTINE SolveAXeqB
5608 : :
5609 : :
5610 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5611 : : !! subroutine SolveAXeqBM(n,A,B,many)
5612 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5613 [ - + - + ]: 18 : subroutine SolveAXeqBM(n,A,B,many)
5614 : : integer, intent(in) :: n,many
5615 : : real(dp), intent(in) :: A(:,:)
5616 : : real(dp), intent(inout) :: B(:)
5617 : : integer :: i,LWORK
5618 : : real(dp), parameter :: rtol=tol9
5619 : : real(dp), parameter :: one=1,zero=0
5620 : : real(dp) :: xx
5621 : 18 : real(dp), allocatable :: C(:,:),U(:,:),VT(:,:),X(:)
5622 : 18 : real(dp), allocatable :: WORK(:)
5623 : 18 : real(dp), allocatable :: S(:)
5624 [ + - - + ]: 18 : if (many<1.or.many>n) then
5625 : 0 : LIBPAW_ERROR('Error in paw_SolveAXeqBM')
5626 : : endif
5627 [ - + ]: 18 : if (n == 1) then
5628 : 0 : B(1)=B(1)/A(1,1)
5629 : : return
5630 : : endif
5631 : 18 : LWORK=max(200,n*n)
5632 [ - + + - : 72 : LIBPAW_ALLOCATE(C,(n,n))
- + + - +
- + - - +
- + ]
5633 [ - + + - : 54 : LIBPAW_ALLOCATE(X,(n))
+ - + - -
+ - + ]
5634 [ - + + - : 54 : LIBPAW_ALLOCATE(U,(n,n))
- + + - -
+ - + ]
5635 [ - + + - : 54 : LIBPAW_ALLOCATE(VT,(n,n))
- + + - -
+ - + ]
5636 [ - + + - : 54 : LIBPAW_ALLOCATE(WORK,(LWORK))
+ - - + -
+ ]
5637 [ - + + - : 36 : LIBPAW_ALLOCATE(S,(n))
- + - + ]
5638 [ + + + + ]: 330 : C(1:n,1:n)=A(1:n,1:n)
5639 : 18 : call DGESVD('A','A',n,n,C,n,S,U,n,VT,n,WORK,LWORK,i)
5640 [ + + ]: 84 : X=0
5641 [ + + ]: 84 : do i=1,n
5642 [ + - ]: 84 : if (i<=many) then
5643 [ + + ]: 312 : xx=DOT_PRODUCT(U(1:n,i),B(1:n))/S(i)
5644 [ + + ]: 312 : X(1:n)=X(1:n)+xx*(VT(i,1:n))
5645 : : endif
5646 : : enddo
5647 [ + + ]: 84 : B=X
5648 [ - + ]: 18 : LIBPAW_DEALLOCATE(C)
5649 [ - + ]: 18 : LIBPAW_DEALLOCATE(X)
5650 [ - + ]: 18 : LIBPAW_DEALLOCATE(U)
5651 [ - + ]: 18 : LIBPAW_DEALLOCATE(VT)
5652 [ - + ]: 18 : LIBPAW_DEALLOCATE(WORK)
5653 [ - + ]: 18 : LIBPAW_DEALLOCATE(S)
5654 : : end subroutine SolveAXeqBM
5655 : :
5656 : :
5657 : :
5658 : :
5659 : :
5660 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5661 : : ! 9. Gridmod
5662 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5663 : :
5664 : :
5665 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5666 : : ! SUBROUTINE taufromwfn(otau,Grid,wfn,l,energy,rv)
5667 : : ! input radial wfn and output its kinetic energy density
5668 : : ! note that total wavefunction is wfn/r * Ylm
5669 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5670 [ - + - + ]: 3214 : SUBROUTINE taufromwfn(otau,Grid,wfn,l,energy,rPot)
5671 : : TYPE(GridInfo), INTENT(IN) :: Grid
5672 : : REAL(dp), INTENT(IN) :: wfn(:)
5673 : : REAL(dp), INTENT(IN), OPTIONAL :: rPot(:),energy
5674 : : INTEGER, INTENT(IN) :: l
5675 : : REAL(dp), INTENT(OUT) :: otau(:)
5676 : : LOGICAL,PARAMETER :: from_e=.false.
5677 : : INTEGER :: n
5678 : : REAL(dp) :: fac
5679 : 3214 : REAL(dp), allocatable:: pbr(:),dpdr(:),d2pdr(:)
5680 : 3214 : n=Grid%n
5681 : 3214 : fac=l*(l+1)
5682 : : !Note: Psi(r) = Yl.Wfn(r)/r
5683 : : ! Tau(r) given in Rydberg units
5684 : : !Note: there are several kinetic energy formulas
5685 : : ! differing by something*Laplacian(rho(r))
5686 : : IF (.not.from_e) THEN
5687 : : ! Standard tau formula:
5688 : : ! 4pir^2* Tau(r) = [r.d/dr(Wfn/r)]^2 + l(l+1) [Wfn/r]^2
5689 [ - + + - : 9642 : LIBPAW_ALLOCATE(pbr,(n))
+ - + - -
+ - + ]
5690 [ - + + - : 6428 : LIBPAW_ALLOCATE(dpdr,(n))
- + - + ]
5691 [ + + + + ]: 12868856 : dpdr=0._dp;pbr=0._dp
5692 [ + + ]: 6431214 : pbr(2:n)=wfn(2:n)/Grid%r(2:n)
5693 : 3214 : CALL derivative(Grid,pbr,dpdr,2,n)
5694 [ + + ]: 6431214 : otau(2:n)=(Grid%r(2:n)*dpdr(2:n))**2 + fac*pbr(2:n)**2
5695 [ + + ]: 3214 : CALL extrapolate(otau) ; if (l>0) otau(1)=0._dp
5696 [ - + ]: 3214 : LIBPAW_DEALLOCATE(pbr)
5697 [ - + ]: 3214 : LIBPAW_DEALLOCATE(dpdr)
5698 : : ELSEIF (from_e) THEN
5699 : : IF (.NOT.(PRESENT(energy).AND.PRESENT(rPot))) then
5700 : : STOP 'Error in taufromwfn: rPot and energy should be present!'
5701 : : END IF
5702 : : ! For testing purpose:
5703 : : ! Another formula for the kinetic energy density
5704 : : ! 4pir^2* Tau(r) = [Eigenvalue - Veff(r)]*Wfn^2
5705 : : IF (.TRUE.) THEN
5706 : : otau(2:n)=(energy-rPot(2:n)/Grid%r(2:n))*wfn(2:n)**2
5707 : : CALL extrapolate(otau) ; if (l>0) otau(1)=0._dp
5708 : : ! Another one:
5709 : : ! From energy + correction
5710 : : ELSE
5711 : : LIBPAW_ALLOCATE(pbr,(n))
5712 : : LIBPAW_ALLOCATE(dpdr,(n))
5713 : : LIBPAW_ALLOCATE(d2pdr,(n))
5714 : : pbr(2:n)=wfn(2:n)/Grid%r(2:n)
5715 : : CALL derivative(Grid,pbr,dpdr,2,n)
5716 : : otau(2:n)=dpdr(2:n)**2 *Grid%r(2:n)**2
5717 : : d2pdr(2:n)=pbr(2:n)**2
5718 : : call derivative(Grid,d2pdr,dpdr,2,n)
5719 : : call derivative(Grid,dpdr,d2pdr,2,n)
5720 : : d2pdr(2:n)=d2pdr(2:n)+2.*dpdr(2:n)/Grid%r(2:n)
5721 : : otau(2:n)=0.5_dp*d2pdr(2:n)*Grid%r(2:n)**2 &
5722 : : & +(energy-rPot(2:n)/Grid%r(2:n))*wfn(2:n)**2
5723 : : otau(2:n)=otau(2:n) + fac*pbr(2:n)**2
5724 : : CALL extrapolate(otau) ; if (l>0) otau(1)=0._dp
5725 : : LIBPAW_DEALLOCATE(pbr)
5726 : : LIBPAW_DEALLOCATE(dpdr)
5727 : : LIBPAW_DEALLOCATE(d2pdr)
5728 : : ENDIF
5729 : : ENDIF
5730 : 3214 : call filter(n,otau,machine_zero)
5731 : 3214 : END SUBROUTINE taufromwfn
5732 : :
5733 : :
5734 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5735 : : !! deltakinetic_ij(Grid,wfn1,wfn2,twfn1,twfn2,l,ekin,last)
5736 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5737 [ - + - + : 36 : SUBROUTINE deltakinetic_ij(Grid,wfn1,wfn2,twfn1,twfn2,l,ekin,last)
- + - + ]
5738 : : TYPE (GridInfo), INTENT(IN) :: Grid
5739 : : real(dp), INTENT(IN) :: wfn1(:),wfn2(:),twfn1(:),twfn2(:)
5740 : : INTEGER, INTENT(IN) :: l
5741 : : real(dp), INTENT(OUT) :: ekin
5742 : : INTEGER, INTENT(IN), OPTIONAL :: last
5743 : 36 : real(dp), ALLOCATABLE :: dfdr1(:),dfdr2(:),arg1(:),arg2(:)
5744 : 36 : real(dp), ALLOCATABLE :: tdfdr1(:),tdfdr2(:),targ1(:),targ2(:)
5745 : : INTEGER :: i,n
5746 : 36 : n=Grid%n
5747 [ + - ]: 36 : if (present(last)) n=last
5748 [ - + + - : 108 : LIBPAW_ALLOCATE(dfdr1,(n))
+ - + - -
+ - + ]
5749 [ - + + - : 72 : LIBPAW_ALLOCATE(arg1,(n))
- + - + ]
5750 [ - + + - : 72 : LIBPAW_ALLOCATE(dfdr2,(n))
- + - + ]
5751 [ - + + - : 72 : LIBPAW_ALLOCATE(arg2,(n))
- + - + ]
5752 [ - + + - : 72 : LIBPAW_ALLOCATE(tdfdr1,(n))
- + - + ]
5753 [ - + + - : 72 : LIBPAW_ALLOCATE(targ1,(n))
- + - + ]
5754 [ - + + - : 72 : LIBPAW_ALLOCATE(tdfdr2,(n))
- + - + ]
5755 [ - + + - : 72 : LIBPAW_ALLOCATE(targ2,(n))
- + - + ]
5756 : 36 : CALL derivative(Grid,wfn1,dfdr1,1,n)
5757 : 36 : CALL derivative(Grid,wfn2,dfdr2,1,n)
5758 : 36 : CALL derivative(Grid,twfn1,tdfdr1,1,n)
5759 : 36 : CALL derivative(Grid,twfn2,tdfdr2,1,n)
5760 [ + + + + : 202032 : arg1=0; arg2=0; targ1=0; targ2=0
+ + + + ]
5761 [ + + ]: 50472 : DO i=2,n
5762 : 50436 : arg1(i)=wfn1(i)/Grid%r(i)
5763 : 50436 : arg2(i)=wfn2(i)/Grid%r(i)
5764 : 50436 : targ1(i)=twfn1(i)/Grid%r(i)
5765 : 50472 : targ2(i)=twfn2(i)/Grid%r(i)
5766 : : ENDDO
5767 [ + + ]: 50508 : DO i=1,n
5768 : : arg1(i)=(dfdr1(i)*dfdr2(i)-tdfdr1(i)*tdfdr2(i))&
5769 : 50508 : & +(l*(l+1))*(arg1(i)*arg2(i)-targ1(i)*targ2(i))
5770 : : ENDDO
5771 : 36 : ekin=integrator(Grid,arg1,1,n)
5772 [ - + ]: 36 : LIBPAW_DEALLOCATE(dfdr1)
5773 [ - + ]: 36 : LIBPAW_DEALLOCATE(arg1)
5774 [ - + ]: 36 : LIBPAW_DEALLOCATE(dfdr2)
5775 [ - + ]: 36 : LIBPAW_DEALLOCATE(arg2)
5776 [ - + ]: 36 : LIBPAW_DEALLOCATE(tdfdr1)
5777 [ - + ]: 36 : LIBPAW_DEALLOCATE(targ1)
5778 [ - + ]: 36 : LIBPAW_DEALLOCATE(tdfdr2)
5779 [ - + ]: 36 : LIBPAW_DEALLOCATE(targ2)
5780 : 36 : END SUBROUTINE deltakinetic_ij
5781 : :
5782 : :
5783 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5784 : : !! SUBROUTINE atompaw_poisson(Grid,q,den,rv,ecoul,v00)
5785 : : !! Use Numerov algorithm to solve poisson equation
5786 : : !! den(n) is electron density * (4*pi*r**2)
5787 : : !! rv(n) is returned as electrostatic potential * r
5788 : : !! ecoul is the coulomb interaction energy
5789 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5790 [ - + - + ]: 25 : SUBROUTINE atompaw_poisson(Grid,q,den,rv,ecoul,v00)
5791 : : TYPE (GridInfo), INTENT(IN) :: Grid
5792 : : real(dp), INTENT(IN):: den(:)
5793 : : real(dp), INTENT(INOUT) :: rv(:),ecoul,q
5794 : : real(dp), OPTIONAL, INTENT(OUT) :: v00
5795 : 25 : real(dp), ALLOCATABLE :: a(:),b(:)
5796 : : real(dp) :: sd,sl,h,h2
5797 : : INTEGER :: i,n
5798 : 25 : n=Grid%n
5799 : 25 : h=Grid%h
5800 [ + + ]: 50050 : rv=0._dp
5801 : 25 : q=integrator(Grid,den)
5802 [ - + + - : 75 : LIBPAW_ALLOCATE(a,(n))
+ - + - -
+ - + ]
5803 [ - + + - : 50 : LIBPAW_ALLOCATE(b,(n))
- + - + ]
5804 [ - + ]: 25 : IF (Grid%type==lineargrid) THEN
5805 : 0 : sd=2
5806 : 0 : sl=-1
5807 : 0 : a(1)=0
5808 [ # # ]: 0 : DO i=2,n
5809 : 0 : a(i)=h*den(i)/(6*(i-1))
5810 : : ENDDO
5811 : 0 : rv(1)=0
5812 : 0 : rv(2)=10*a(2)+a(3)
5813 [ # # ]: 0 : DO i=3,n-1
5814 : 0 : rv(i)=10*a(i)+a(i+1)+a(i-1)
5815 : : ENDDO
5816 : 0 : rv(n)=10*a(n)+a(n-1)+2*q
5817 [ + - ]: 25 : ELSEIF (Grid%type==loggrid) THEN
5818 : 25 : sd=2+10*h*h/48
5819 : 25 : sl=-1+h*h/48
5820 : 25 : a(1)=0
5821 : 25 : h2=h*h
5822 [ + + ]: 50025 : DO i=2,n
5823 : 50025 : a(i)=h2*Grid%rr02(i)*den(i)/(6*Grid%r(i))/Grid%pref(i)
5824 : : ENDDO
5825 : 25 : rv(1)=0
5826 : 25 : rv(2)=10*a(2)+a(3)
5827 [ + + ]: 49975 : DO i=3,n-1
5828 : 49975 : rv(i)=10*a(i)+a(i+1)+a(i-1)
5829 : : ENDDO
5830 : : ! last term is boundary value at point n+1
5831 : 25 : rv(n)=10*a(n)+a(n-1)-2*q*sl/(Grid%pref(n)*EXP(h/2))
5832 : : ENDIF
5833 : 25 : CALL conthomas(n,sl,sd,rv)
5834 [ + - + + ]: 50050 : IF (Grid%type==loggrid) rv=rv*Grid%pref
5835 : : ! calculate ecoul
5836 [ + + ]: 50025 : DO i=2,n
5837 : 50025 : a(i)=den(i)*rv(i)/Grid%r(i)
5838 : : ENDDO
5839 : 25 : a(1)=0
5840 : 25 : ecoul=integrator(Grid,a)*0.5_dp
5841 [ + + ]: 25 : IF (PRESENT(v00)) THEN
5842 [ + + ]: 46046 : a=0
5843 [ + + ]: 46023 : a(2:n)=den(2:n)/Grid%r(2:n)
5844 : 23 : v00=2*integrator(Grid,a)
5845 : : ENDIF
5846 : 25 : LIBPAW_DEALLOCATE(a)
5847 [ - + ]: 25 : LIBPAW_DEALLOCATE(b)
5848 : 25 : END SUBROUTINE atompaw_poisson
5849 : :
5850 : :
5851 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5852 : : !! SUBROUTINE poisson_marc(Grid,q,den,rv,ecoul)
5853 : : !! use Numerov algorithm to solve poisson equation
5854 : : !! den(n) is electron density * (4*pi*r**2)
5855 : : !! rv(n) is returned as electrostatic potential * r
5856 : : !! ecoul is the coulomb interation energy
5857 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5858 [ - + - + ]: 354 : SUBROUTINE poisson_marc(Grid,q,den,rv,ecoul)
5859 : : TYPE (GridInfo), INTENT(IN) :: Grid
5860 : : real(dp), INTENT(IN):: den(:)
5861 : : real(dp), INTENT(INOUT) :: rv(:),ecoul,q
5862 : 354 : real(dp), ALLOCATABLE :: aa(:),bb(:),cc(:),dd(:)
5863 : : real(dp) :: h
5864 : : INTEGER :: i,n,ir,jr
5865 : 354 : n=Grid%n
5866 : 354 : h=Grid%h
5867 [ + + ]: 708708 : rv=0._dp
5868 : 354 : q=integrator(Grid,den)
5869 [ - + + - : 1062 : LIBPAW_ALLOCATE(aa,(n))
+ - + - -
+ - + ]
5870 [ - + + - : 708 : LIBPAW_ALLOCATE(bb,(n))
- + - + ]
5871 [ - + + - : 708 : LIBPAW_ALLOCATE(cc,(n))
- + - + ]
5872 [ - + + - : 708 : LIBPAW_ALLOCATE(dd,(n))
- + + - ]
5873 [ + + ]: 708354 : DO jr=n,2,-1
5874 : 708000 : ir=n-jr+1
5875 : 708000 : aa(ir)=den(jr)*Grid%drdu(jr)
5876 : 708354 : bb(ir)=den(jr)*Grid%drdu(jr)/Grid%r(jr)
5877 : : END DO
5878 [ + + ]: 708708 : cc=0._dp
5879 : 354 : cc(5)=aa(n-4);cc(4)=aa(n-3);cc(3)=aa(n-2);cc(2)=aa(n-1)
5880 : 354 : cc(1)=cc(4)+3._dp*(cc(2)-cc(3)) !call extrapolate(Grid,cc)
5881 : 354 : aa(n)=cc(1)
5882 : 354 : cc(5)=bb(n-4);cc(4)=bb(n-3);cc(3)=bb(n-2);cc(2)=bb(n-1)
5883 : 354 : cc(1)=cc(4)+3._dp*(cc(2)-cc(3)) !call extrapolate(Grid,cc)
5884 : 354 : bb(n)=cc(1)
5885 : 354 : cc(1)=0._dp;dd(1)=0._dp
5886 [ + - ]: 354 : DO ir=3,n,2
5887 : 354000 : cc(ir) =cc(ir-2)+h/3._dp*(aa(ir-2)+4._dp*aa(ir-1)+aa(ir))
5888 : 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))
5889 : 354000 : dd(ir) =dd(ir-2)+h/3._dp*(bb(ir-2)+4._dp*bb(ir-1)+bb(ir))
5890 [ + + ]: 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))
5891 : : END DO
5892 [ - + ]: 354 : IF (MOD(n,2)==0) THEN
5893 : 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))
5894 : 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))
5895 : : END IF
5896 : 354 : rv(1)=0._dp
5897 [ + + ]: 708354 : DO ir=2,n
5898 : 708000 : jr=n-ir+1
5899 : 708354 : rv(ir)=2._dp*(dd(jr)*Grid%r(ir)+(cc(n)-cc(jr))) !Ha->Ry
5900 : : END DO
5901 [ - + - - ]: 354 : if (n<Grid%n) rv(n+1:Grid%n)=rv(n)
5902 : : ! calculate ecoul
5903 : 354 : aa(1)=0._dp
5904 [ + + ]: 708354 : do i=2,n
5905 : 708354 : aa(i)=den(i)*rv(i)/Grid%r(i)
5906 : : end do
5907 : 354 : ecoul=0.5_dp*integrator(Grid,aa)
5908 : 354 : LIBPAW_DEALLOCATE(aa)
5909 : 354 : LIBPAW_DEALLOCATE(bb)
5910 : 354 : LIBPAW_DEALLOCATE(cc)
5911 : 354 : LIBPAW_DEALLOCATE(dd)
5912 : 354 : END SUBROUTINE poisson_marc
5913 : :
5914 : :
5915 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5916 : : !! zeropot(Grid,rv,v0,v0p)
5917 : : !! extrapolate potential to value at r=0
5918 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5919 [ - + ]: 403 : SUBROUTINE zeropot(Grid,rv,v0,v0p)
5920 : : TYPE (GridInfo), INTENT(IN):: Grid
5921 : : real(dp), INTENT(IN) :: rv(:) ! Note: rv(1) corresponds to r=0
5922 : : real(dp), INTENT(OUT) :: v0,v0p
5923 : : real(dp) :: tmp(15),tmp1(15)
5924 [ + + ]: 6045 : tmp(2:15)=rv(2:15)/Grid%r(2:15)
5925 : 403 : CALL extrapolate(tmp(1:15))
5926 : 403 : v0=tmp(1)
5927 : 403 : CALL derivative(Grid,tmp(1:15),tmp1(1:15),2,15)
5928 : 403 : CALL extrapolate(tmp1(1:15))
5929 : 403 : v0p=tmp1(1)
5930 : 403 : END SUBROUTINE zeropot
5931 : :
5932 : :
5933 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5934 : : !! subroutine kinetic(Grid,wfn,l,ekin)
5935 : : !! calculates expectation value of kinetic energy for wfn
5936 : : !! with orbital angular momentum l
5937 : : !! wfn == r*radialwfn in Schroedinger Equation
5938 : : !! assumes wfn=(constant)*r^(l+1) at small r
5939 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5940 : : SUBROUTINE kinetic(Grid,wfn,l,ekin)
5941 : : TYPE (GridInfo), INTENT(IN) :: Grid
5942 : : real(dp), INTENT(IN) :: wfn(:)
5943 : : INTEGER, INTENT(IN) :: l
5944 : : real(dp), INTENT(OUT) :: ekin
5945 : : real(dp), ALLOCATABLE :: dfdr(:),arg(:)
5946 : : INTEGER :: i,n
5947 : : n=Grid%n
5948 : : LIBPAW_ALLOCATE(dfdr,(n))
5949 : : LIBPAW_ALLOCATE(arg,(n))
5950 : : CALL derivative(Grid,wfn,dfdr)
5951 : : arg=0
5952 : : DO i=2,n
5953 : : arg(i)=wfn(i)/Grid%r(i)
5954 : : ENDDO
5955 : : DO i=1,n
5956 : : arg(i)=(dfdr(i))**2+(l*(l+1))*(arg(i))**2
5957 : : ENDDO
5958 : : ekin=integrator(Grid,arg)!*0.5!Hartree
5959 : : LIBPAW_DEALLOCATE(dfdr)
5960 : : LIBPAW_DEALLOCATE(arg)
5961 : : END SUBROUTINE kinetic
5962 : :
5963 : :
5964 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5965 : : !! subroutine altkinetic(Grid,wfn,energy,rv,ekin)
5966 : : !! calculates expectation value of kinetic energy for wfn
5967 : : !! with orbital wfn by integrating
5968 : : !! int(wfn**2 * (energy-rv/r), r=0..rmax)
5969 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5970 [ - + - + ]: 2230 : SUBROUTINE altkinetic(Grid,wfn,energy,rv,ekin)
5971 : : TYPE (GridInfo), INTENT(IN) :: Grid
5972 : : real(dp), INTENT(IN) :: wfn(:),rv(:),energy
5973 : : real(dp), INTENT(OUT) :: ekin
5974 : 2230 : real(dp), ALLOCATABLE :: arg(:)
5975 : : INTEGER :: i,n
5976 : 2230 : n=Grid%n
5977 [ - + + - : 6690 : LIBPAW_ALLOCATE(arg,(n))
+ - + - -
+ - + ]
5978 [ + + ]: 4464460 : arg=0
5979 [ + + ]: 4462230 : DO i=2,n
5980 : 4462230 : arg(i)=(wfn(i)**2)*(energy-rv(i)/Grid%r(i))
5981 : : ENDDO
5982 : 2230 : ekin=integrator(Grid,arg)
5983 [ - + ]: 2230 : LIBPAW_DEALLOCATE(arg)
5984 : 2230 : END SUBROUTINE altkinetic
5985 : :
5986 : :
5987 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5988 : : !! overint(n,h,f1,icorr)
5989 : : !! function to calculate the integral of one vectors f1
5990 : : !! using simpsons rule assuming a regular grid with
5991 : : !! spacing of h and n total points
5992 : : !! icorr: optional parameter: used only when n is even
5993 : : !! if icorr<0, a trapezoidal correction is applied
5994 : : !! at the start of interval
5995 : : !! if icorr>=0, a trapezoidal correction is applied
5996 : : !! at the end of interval
5997 : : !! default (if missing) is icorr=0
5998 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5999 [ - + ]: 61574 : FUNCTION overint(n,h,f1,icorr)
6000 : : real(dp) :: overint
6001 : : INTEGER, INTENT(IN) :: n
6002 : : real(dp), INTENT(IN) :: h,f1(:)
6003 : : INTEGER, OPTIONAL :: icorr
6004 : : real(dp),PARAMETER :: tol=1.D-14
6005 : : INTEGER :: i,j,istart,m
6006 : 61574 : overint=0
6007 : : !Eliminate zeros at end of interval
6008 [ + + + + ]: 13957174 : i=n;DO WHILE(ABS(f1(i))<machine_zero.AND.i>2);i=i-1;ENDDO
6009 : 61574 : m=MIN(i+1,n)
6010 [ + - ]: 61574 : IF (m<=1) THEN
6011 : : RETURN
6012 [ - + ]: 61574 : ELSEIF (m==2) THEN
6013 : 0 : overint=(f1(1)+f1(2))*(h/2) ! Trapezoidal rule
6014 : 0 : RETURN
6015 : : ENDIF
6016 : 61574 : istart=1
6017 [ - + ]: 61574 : IF (PRESENT(icorr)) THEN
6018 [ - + + + ]: 61574 : IF (icorr<0.AND.MOD(m,2)==0) istart=2
6019 : : ENDIF
6020 : 61574 : overint=f1(istart)+4*f1(istart+1)+f1(istart+2)
6021 : 61574 : j=((m-istart)/2)*2+istart
6022 [ + + ]: 61574 : IF (j>=istart+4) THEN
6023 [ - + ]: 61571 : DO i=istart+4,j,2
6024 [ + + ]: 53715109 : overint=overint+f1(i-2)+4*f1(i-1)+f1(i)
6025 : : ENDDO
6026 : : ENDIF
6027 : 61574 : overint=overint*(h/3)
6028 [ - + ]: 61574 : IF (m>j) overint=overint+(f1(j)+f1(m))*(h/2)
6029 [ + + ]: 61574 : IF (istart==2) overint=overint+(f1(1)+f1(2))*(h/2)
6030 : : RETURN
6031 : : END FUNCTION overint
6032 : :
6033 : :
6034 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6035 : : !! function integrator(Grid,arg)
6036 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6037 [ - + ]: 61574 : FUNCTION integrator(Grid,arg,str,fin)
6038 : : real(dp) :: integrator
6039 : : TYPE(GridInfo), INTENT(IN) :: Grid
6040 : : real(dp), INTENT(IN) :: arg(:)
6041 : : INTEGER, INTENT(IN), OPTIONAL :: str,fin
6042 : 61574 : real(dp), ALLOCATABLE :: dum(:)
6043 : : INTEGER :: n,i1,i2
6044 : 61574 : n=Grid%n
6045 : 61574 : i1=1;i2=n
6046 [ + + ]: 61574 : IF (PRESENT(str).AND.PRESENT(fin)) THEN
6047 : 57565 : i1=str; i2=fin; n=i2-i1+1
6048 : : ENDIF
6049 : 61574 : SELECT CASE(Grid%type)
6050 : : CASE default
6051 : 0 : LIBPAW_ERROR('Error in integrator')
6052 : : CASE(lineargrid)
6053 : 0 : integrator=overint(n,Grid%h,arg(i1:i2))
6054 : : CASE(loggrid)
6055 [ - + + - : 184722 : LIBPAW_BOUND1_ALLOCATE(dum,BOUNDS(i1,i2))
+ - + - -
+ - + ]
6056 [ + + ]: 121547557 : dum(i1:i2)=arg(i1:i2)*Grid%drdu(i1:i2)
6057 : 61574 : integrator=overint(n,Grid%h,dum(i1:i2),-1)
6058 [ - - + - : 123148 : LIBPAW_DEALLOCATE(dum)
+ ]
6059 : : END SELECT
6060 : 61574 : END FUNCTION integrator
6061 : :
6062 : :
6063 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6064 : : !! function FindGridIndex(Grid,rpoint)
6065 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6066 : 40085 : FUNCTION FindGridIndex(Grid,rpoint)
6067 : : INTEGER :: FindGridIndex
6068 : : TYPE (GridInfo), INTENT(IN) :: Grid
6069 : : real(dp), INTENT(IN) :: rpoint
6070 : : real(dp) :: r0
6071 : 40085 : FindGridIndex=0
6072 [ - + ]: 40085 : IF (Grid%type==lineargrid) THEN
6073 : 0 : FindGridIndex=rpoint/Grid%h+1
6074 [ # # ]: 0 : IF (Grid%h*(FindGridIndex-1)<rpoint-tol10) FindGridIndex=FindGridIndex+1
6075 [ + - ]: 40085 : ELSEIF (Grid%type==loggrid) THEN
6076 : 40085 : r0=Grid%drdu(1)
6077 : 40085 : FindGridIndex=LOG(rpoint/r0+1)/Grid%h+1
6078 [ + + ]: 40085 : IF (r0*EXP(Grid%h*(FindGridIndex-1))<rpoint-tol10) &
6079 : 40078 : & FindGridIndex=FindGridIndex+1
6080 : : ENDIF
6081 : 40085 : END FUNCTION FindGridIndex
6082 : :
6083 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6084 : : !! function gridindex(Grid,r)
6085 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6086 : : FUNCTION gridindex(Grid,r)
6087 : : INTEGER :: gridindex
6088 : : TYPE (GridInfo), INTENT(IN) :: Grid
6089 : : REAL(dp), INTENT(IN) :: r
6090 : : gridindex=0
6091 : : IF (Grid%type==lineargrid) THEN
6092 : : gridindex=r/Grid%h +0.1d0 +1
6093 : : ELSEIF (Grid%type==loggrid) THEN
6094 : : gridindex=LOG(1.d0+r/Grid%drdu(1))/Grid%h +0.1d0 +1
6095 : : ENDIF
6096 : : END FUNCTION gridindex
6097 : :
6098 : :
6099 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6100 : : !! ClassicalTurningPoint(Grid,rv,l,energy,turningpoint)
6101 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6102 [ - + ]: 40052 : SUBROUTINE ClassicalTurningPoint(Grid,rv,l,energy,turningpoint)
6103 : : TYPE(GridInfo), INTENT(IN) :: Grid
6104 : : real(dp), INTENT(IN) :: rv(:)
6105 : : INTEGER, INTENT(IN) :: l
6106 : : real(dp), INTENT(IN) :: energy
6107 : : INTEGER, INTENT(OUT) :: turningpoint
6108 : : INTEGER :: i,n
6109 : 40052 : real(dp), ALLOCATABLE :: v(:)
6110 : 40052 : n=Grid%n
6111 [ - + + - : 120156 : LIBPAW_ALLOCATE(v,(n))
+ - + - -
+ - + ]
6112 [ + + ]: 80184104 : v=0
6113 [ + + ]: 80144052 : v(2:n)=rv(2:n)/Grid%r(2:n)+l*(l+1)/(Grid%r(2:n)**2)!hartree
6114 : : turningpoint=n
6115 [ + + ]: 51997607 : DO i=n,2,-1
6116 [ + + ]: 51997607 : IF (v(i)<energy) EXIT
6117 : : ENDDO
6118 : : turningpoint=i
6119 : 40052 : turningpoint=MIN(turningpoint,FindGridIndex(Grid,10.0_dp))
6120 [ - + ]: 40052 : LIBPAW_DEALLOCATE(v)
6121 : 40052 : END SUBROUTINE ClassicalTurningPoint
6122 : :
6123 : :
6124 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6125 : : !! getwfnfromcfdsol(start,finish,yy,wfn)
6126 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6127 [ - + - + ]: 36031 : subroutine getwfnfromcfdsol(start,finish,yy,wfn)
6128 : : INTEGER, INTENT(IN) :: start,finish
6129 : : real(dp), INTENT(IN) :: yy(:,:)
6130 : : real(dp), INTENT(INOUT) :: wfn(:)
6131 : : INTEGER :: i
6132 [ + + ]: 72133435 : wfn=0
6133 [ + + ]: 36570103 : do i=start,finish
6134 : 36570103 : wfn(i)=yy(1,i)
6135 : : enddo
6136 : 36031 : end subroutine getwfnfromcfdsol
6137 : :
6138 : :
6139 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6140 : : !! countnodes(start,finish,wfn,filter)
6141 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6142 [ - + ]: 35362 : INTEGER function countnodes(start,finish,wfn,filter)
6143 : : INTEGER, INTENT(IN) :: start,finish
6144 : : real(dp), INTENT(IN) :: wfn(:)
6145 : : real(dp), INTENT(IN), OPTIONAL :: filter
6146 : : INTEGER :: i,nodes
6147 : 35362 : nodes=0
6148 [ + + ]: 23105223 : do i=start+1,finish
6149 [ + + ]: 23069861 : if (wfn(i)*wfn(i-1)<0._dp) nodes=nodes+1
6150 [ - + ]: 23105223 : if (PRESENT(filter)) then
6151 [ # # ]: 0 : If((abs(wfn(i))+abs(wfn(i-1)))<filter) exit
6152 : : endif
6153 : : enddo
6154 : 35362 : countnodes=nodes
6155 : 35362 : end function countnodes
6156 : :
6157 : :
6158 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6159 : : !! extrapolate(Grid,v)
6160 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6161 [ - + ]: 5853 : SUBROUTINE extrapolate(v)
6162 : : ! extrapolate array v to r=0 at v(1)
6163 : : real(dp), INTENT(INOUT) :: v(:) ! assume v(2),v(3)... given
6164 : 5853 : v(1)=5._dp*v(2)-10._dp*v(3)+10._dp*v(4)-5._dp*v(5)+v(6) ! fourth order formula
6165 : 5853 : END SUBROUTINE extrapolate
6166 : :
6167 : :
6168 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6169 : : !! subroutine derivative(Grid,f,dfdr,begin,bend)
6170 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6171 [ - + - + ]: 15426 : SUBROUTINE derivative(Grid,f,dfdr,begin,bend)
6172 : : TYPE(GridInfo), INTENT(IN) :: Grid
6173 : : real(dp), INTENT(IN) :: f(:)
6174 : : real(dp), INTENT(OUT) :: dfdr(:)
6175 : : INTEGER, OPTIONAL, INTENT(IN) :: begin,bend
6176 : : INTEGER :: i,n,i1,i2
6177 : 15426 : i1=1;i2=Grid%n;n=i2-i1+1
6178 [ + + ]: 15426 : IF (PRESENT(begin).OR.PRESENT(bend)) THEN
6179 [ + - + - ]: 15008 : IF (begin>=1.AND.bend<= Grid%n) THEN
6180 : 15008 : i1=begin;i2=bend;n=i2-i1+1
6181 : : ELSE
6182 : 0 : LIBPAW_ERROR('Error in derivative')
6183 : : ENDIF
6184 : : ENDIF
6185 : 15426 : SELECT CASE(Grid%type)
6186 : : CASE default
6187 : 0 : LIBPAW_ERROR('Error in derivative')
6188 : : CASE(lineargrid)
6189 : 0 : CALL nderiv(Grid%h,f(i1:i2),dfdr(i1:i2),n,i)
6190 [ # # ]: 0 : IF (i/=0) THEN
6191 : 0 : LIBPAW_ERROR('Error in derivative -nderiv problem')
6192 : : ENDIF
6193 : : CASE(loggrid)
6194 : 15426 : CALL nderiv(Grid%h,f(i1:i2),dfdr(i1:i2),n,i)
6195 [ - + ]: 15426 : IF (i/=0) THEN
6196 : 0 : LIBPAW_ERROR('Error in derivative -nderiv problem')
6197 : : ENDIF
6198 [ - - + + : 9220973 : dfdr(i1:i2)=dfdr(i1:i2)/Grid%drdu(i1:i2)
+ ]
6199 : : END SELECT
6200 : 15426 : END SUBROUTINE derivative
6201 : :
6202 : :
6203 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6204 : : !! nderiv(h,y,z,ndim,ierr)
6205 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6206 [ - + - + ]: 15426 : SUBROUTINE nderiv(h,y,z,ndim,ierr)
6207 : : INTEGER, INTENT(IN) :: ndim
6208 : : INTEGER, INTENT(INOUT) :: ierr
6209 : : real(dp) , INTENT(IN) :: h,y(:)
6210 : : real(dp) , INTENT(INOUT) :: z(:)
6211 : : real(dp) :: hh,yy,a,b,c
6212 : : INTEGER :: i
6213 : 15426 : ierr=-1
6214 [ + - ]: 15426 : IF (ndim.LT.5) RETURN
6215 : : ! prepare differentiation loop
6216 : 15426 : hh=.08333333333333333_dp/h
6217 : 15426 : yy=y(ndim-4)
6218 : 15426 : b=hh*(-25._dp*y(1)+48._dp*y(2)-36._dp*y(3)+16._dp*y(4)-3._dp*y(5))
6219 : 15426 : c=hh*(-3._dp*y(1)-10._dp*y(2)+18._dp*y(3)-6._dp*y(4)+y(5))
6220 : : ! start differentiation loop
6221 [ + + ]: 9143843 : DO i=5,ndim
6222 : 9128417 : a=b
6223 : 9128417 : b=c
6224 : 9128417 : c=hh*(y(i-4)-y(i)+8._dp*(y(i-1)-y(i-3)))
6225 : 9143843 : z(i-4)=a
6226 : : ENDDO
6227 : : ! end of differentiation loop
6228 : : ! normal exit
6229 : : a=hh*(-yy+6._dp*y(ndim-3)-18._dp*y(ndim-2)+10._dp*y(ndim-1) &
6230 : 15426 : & +3._dp*y(ndim))
6231 : : z(ndim)=hh*(3._dp*yy-16._dp*y(ndim-3)+36._dp*y(ndim-2) &
6232 : 15426 : & -48._dp*y(ndim-1)+25._dp*y(ndim))
6233 : 15426 : z(ndim-1)=a
6234 : 15426 : z(ndim-2)=c
6235 : 15426 : z(ndim-3)=b
6236 : 15426 : ierr=0
6237 : 15426 : RETURN
6238 : : END SUBROUTINE nderiv
6239 : :
6240 : :
6241 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6242 : : !! Second derivative for general grid
6243 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6244 [ - + ]: 2 : FUNCTION Gsecondderiv(Grid,index,g)
6245 : : real(dp) :: Gsecondderiv
6246 : : TYPE (GridInfo), INTENT(IN) :: Grid
6247 : : INTEGER, INTENT(IN) :: index
6248 : : real(dp), INTENT(IN) :: g(:)
6249 : 2 : Gsecondderiv=0
6250 [ - + ]: 2 : IF (Grid%type==lineargrid) THEN
6251 : 0 : Gsecondderiv=secondderiv(index,g,Grid%h)
6252 [ + - ]: 2 : ELSEIF (Grid%type==loggrid) THEN
6253 : : Gsecondderiv=(secondderiv(index,g,Grid%h)&
6254 : 2 : & -firstderiv(index,g,Grid%h))/Grid%rr02(index)
6255 : : ENDIF
6256 : 2 : END FUNCTION Gsecondderiv
6257 : :
6258 : :
6259 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6260 : : !! First derivative for general grid
6261 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6262 [ - + ]: 35784 : FUNCTION Gfirstderiv(Grid,index,g)
6263 : : real(dp) :: Gfirstderiv
6264 : : TYPE (GridInfo), INTENT(IN) :: Grid
6265 : : INTEGER, INTENT(IN) :: index
6266 : : real(dp), INTENT(IN) :: g(:)
6267 : 35784 : Gfirstderiv=0
6268 [ - + ]: 35784 : IF (Grid%type==lineargrid) THEN
6269 : 0 : Gfirstderiv=firstderiv(index,g,Grid%h)
6270 [ + - ]: 35784 : ELSEIF (Grid%type==loggrid) THEN
6271 : 35784 : Gfirstderiv=firstderiv(index,g,Grid%h)/Grid%drdu(index)
6272 : : ENDIF
6273 : 35784 : END FUNCTION Gfirstderiv
6274 : :
6275 : :
6276 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6277 : : !! finite difference second derivative
6278 : : !! based on 5 point formula
6279 : : !! Ref. Engeln-Mullges & Uhlig (1996)
6280 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6281 [ - + ]: 2 : FUNCTION secondderiv(index,f,h)
6282 : : real(dp) :: secondderiv
6283 : : INTEGER, INTENT(IN) :: index
6284 : : real(dp), INTENT(IN) :: f(:),h
6285 : : INTEGER :: n
6286 : 2 : n=SIZE(f)
6287 : 2 : secondderiv=0
6288 [ - + - - ]: 2 : if (index==1.and.n>=5) THEN
6289 : 0 : secondderiv=(70*f(1)-208*f(2)+228*f(3)-112*f(4)+22*f(5))/(24*h*h)
6290 [ - + - - ]: 2 : else if (index==2.and.n>=5) THEN
6291 : 0 : secondderiv=(22*f(1)-40*f(2)+12*f(3)+8*f(4)-2*f(5))/(24*h*h)
6292 [ + - + - ]: 2 : else if (index>2.and.index<=n-2) THEN
6293 : : secondderiv=-(f(index-2)+f(index+2))/12 + &
6294 : 2 : & 4*(f(index-1)+f(index+1))/3 - 5*f(index)/2
6295 : 2 : secondderiv=secondderiv/(h*h)
6296 [ # # # # ]: 0 : else if (index>=5.and.index==n-1) THEN
6297 : 0 : secondderiv=(-2*f(n-4)+8*f(n-3)+12*f(n-2)-40*f(n-1)+22*f(n))/(24*h*h)
6298 [ # # # # ]: 0 : else if (index>=5.and.index==n) THEN
6299 : 0 : secondderiv=(22*f(n-4)-112*f(n-3)+228*f(n-2)-208*f(n-1)+70*f(n))/(24*h*h)
6300 : : else
6301 : 0 : LIBPAW_ERROR('Error in secondderiv')
6302 : : ENDIF
6303 : 2 : END FUNCTION secondderiv
6304 : :
6305 : :
6306 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6307 : : !! finite difference first derivative
6308 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6309 [ - + ]: 35786 : FUNCTION firstderiv(index,f,h)
6310 : : real(dp) :: firstderiv
6311 : : INTEGER, INTENT(IN) :: index
6312 : : real(dp), INTENT(IN) :: f(:),h
6313 : : INTEGER :: n
6314 : 35786 : n=SIZE(f)
6315 : 35786 : firstderiv=0
6316 [ - + - - ]: 35786 : if (index==1.and.n>=5) THEN
6317 : 0 : firstderiv=(-25*f(1)+48*f(2)-36*f(3)+16*f(4)-3*f(5))/(12*h)
6318 [ - + - - ]: 35786 : else if (index==2.and.n>=5) THEN
6319 : 0 : firstderiv=(-3*f(1)-10*f(2)+18*f(3)-6*f(4)+f(5))/(12*h)
6320 [ + - + - ]: 35786 : else if (index>2.and.index<=n-2) THEN
6321 : 35786 : firstderiv=(f(index-2)-8*f(index-1)+8*f(index+1)-f(index+2))/(12*h)
6322 [ # # # # ]: 0 : else if (index>=5.and.index==n-1) THEN
6323 : 0 : firstderiv=(-f(n-4)+6*f(n-3)-18*f(n-2)+10*f(n-1)+3*f(n))/(12*h)
6324 [ # # # # ]: 0 : else if (index>=5.and.index==n) THEN
6325 : 0 : firstderiv=(3*f(n-4)-16*f(n-3)+36*f(n-2)-48*f(n-1)+25*f(n))/(12*h)
6326 : : else
6327 : 0 : LIBPAW_ERROR('Error in firstderiv')
6328 : : ENDIF
6329 : 35786 : END FUNCTION firstderiv
6330 : :
6331 : :
6332 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6333 : : !! function to calculate the overlap between two vectors f1 and f2
6334 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6335 [ - + - + ]: 54317 : FUNCTION overlap(Grid,f1,f2,str,fin)
6336 : : real(dp) :: overlap
6337 : : TYPE(GridInfo), INTENT(IN) :: Grid
6338 : : real(dp), INTENT(IN) :: f1(:),f2(:)
6339 : : INTEGER, INTENT(IN), OPTIONAL :: str,fin
6340 : 54317 : real(dp), ALLOCATABLE :: dum(:)
6341 : : INTEGER :: n,i1,i2
6342 : 54317 : n=Grid%n
6343 : 54317 : i1=1;i2=n
6344 [ + + ]: 54317 : IF (PRESENT(str).AND.PRESENT(fin)) THEN
6345 : 182 : i1=str; i2=fin; n=i2-i1+1
6346 : : ENDIF
6347 [ - + + - : 162951 : LIBPAW_BOUND1_ALLOCATE(dum,BOUNDS(i1,i2))
+ - + - -
+ - + ]
6348 [ + + ]: 108686480 : dum(1:n)=f1(i1:i2)*f2(i1:i2)
6349 : 54317 : overlap=integrator(Grid,dum(1:n),1,n)
6350 [ - + ]: 54317 : LIBPAW_DEALLOCATE(dum)
6351 : 54317 : END FUNCTION overlap
6352 : :
6353 : :
6354 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6355 : : !! Subroutine from David Vanderbilt's USPS code, modified by Marc
6356 : : !! Torrent and Francois Jollet, further modified by NAWH
6357 : : !!===========================================================================
6358 : : !! subroutine cfdsol(zz,yy,jj1,jj2,mesh)
6359 : : !!===========================================================================
6360 : : !! routine for solving coupled first order differential equations
6361 : : !!
6362 : : !! d yy(x,1)
6363 : : !! --------- = zz(x,1,1) * yy(x,1) + zz(x,1,2) * yy(2,1)
6364 : : !! dx
6365 : : !!
6366 : : !! d yy(x,2)
6367 : : !! --------- = zz(x,2,1) * yy(x,1) + zz(x,2,2) * yy(2,1)
6368 : : !! dx
6369 : : !!
6370 : : !!
6371 : : !! using fifth order predictor corrector algorithm
6372 : : !!
6373 : : !! routine integrates from jj1 to jj2 and can cope with both cases
6374 : : !! jj1 < jj2 and jj1 > jj2. first five starting values of yy must
6375 : : !! be provided by the calling program.
6376 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6377 [ - + - + ]: 5 : SUBROUTINE cfdsol(Grid,zz,yy,jj1,jj2)
6378 : : TYPE(gridinfo), INTENT(IN) :: Grid
6379 : : real(dp), INTENT(IN):: zz(:,:,:)
6380 : : real(dp), INTENT(INOUT):: yy(:,:)
6381 : : INTEGER, INTENT(IN) :: jj1,jj2
6382 : : real(dp):: fa(0:5),fb(0:5),abp(1:5),amc(0:4)
6383 : : INTEGER :: isgn,i,j,ip,mesh
6384 : : real(dp):: arp,brp
6385 : 5 : real(dp), ALLOCATABLE :: tmpz(:,:,:)
6386 : : real(dp), PARAMETER :: verylarge=1.d30
6387 : : real(dp) :: scale
6388 : 5 : mesh=SIZE(yy(2,:))
6389 [ - + ]: 5 : IF (SIZE(zz(2,2,:))/=mesh) THEN
6390 : 0 : LIBPAW_ERROR('cfdsol error - incompatible arrays')
6391 : : ENDIF
6392 [ + - ]: 5 : isgn = ( jj2 - jj1 ) / iabs( jj2 - jj1 )
6393 [ + - ]: 5 : IF ( isgn .EQ. + 1 ) THEN
6394 [ + - - + ]: 5 : IF ( jj1 .LE. 5 .OR. jj2 .GT. mesh ) THEN
6395 : 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6396 : : ENDIF
6397 : : ELSEIF ( isgn .EQ. - 1 ) THEN
6398 [ # # # # ]: 0 : IF ( jj1 .GE. ( mesh - 4 ) .OR. jj2 .LT. 1 ) THEN
6399 : 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6400 : : ENDIF
6401 : : ELSE
6402 : : if(has_to_print) write(std_out,*) isgn,jj1,jj2,mesh
6403 : : ENDIF
6404 [ - + + - : 15 : LIBPAW_ALLOCATE(tmpz,(2,2,mesh))
+ - + - -
+ - + ]
6405 [ + - + - : 65656 : tmpz=zz
+ - - + -
- + + + +
+ + ]
6406 [ + + ]: 15 : DO i=1,2
6407 [ + + ]: 35 : DO j=1,2
6408 [ + + ]: 37532 : tmpz(i,j,:)=tmpz(i,j,:)*Grid%h
6409 [ + - + + ]: 37542 : if (Grid%TYPE==loggrid) tmpz(i,j,1:mesh)=tmpz(i,j,1:mesh)*Grid%drdu(1:mesh)
6410 : : ENDDO
6411 : : ENDDO
6412 : 5 : abp(1) = 1901._dp / 720._dp
6413 : 5 : abp(2) = -1387._dp / 360._dp
6414 : 5 : abp(3) = 109._dp / 30._dp
6415 : 5 : abp(4) = -637._dp / 360._dp
6416 : 5 : abp(5) = 251._dp / 720._dp
6417 : 5 : amc(0) = 251._dp / 720._dp
6418 : 5 : amc(1) = 323._dp / 360._dp
6419 : 5 : amc(2) = -11._dp / 30._dp
6420 : 5 : amc(3) = 53._dp / 360._dp
6421 : 5 : amc(4) = -19._dp / 720._dp
6422 [ + + ]: 30 : DO j = 1,5
6423 : 25 : ip = jj1 - isgn * j
6424 : 25 : fa(j) = tmpz(1,1,ip) * yy(1,ip) + tmpz(1,2,ip) * yy(2,ip)
6425 : 30 : fb(j) = tmpz(2,1,ip) * yy(1,ip) + tmpz(2,2,ip) * yy(2,ip)
6426 : : ENDDO
6427 [ - + - - : 5 : DO j = jj1,jj2,isgn
- + ]
6428 : 9353 : arp = yy(1,j-isgn)
6429 : 9353 : brp = yy(2,j-isgn)
6430 [ + + - + ]: 9353 : IF (ABS(arp)>verylarge.OR.brp>verylarge) THEN
6431 : 2 : scale=1._dp/(ABS(arp)+ABS(brp))
6432 : 2 : arp=arp*scale
6433 : 2 : brp=brp*scale
6434 [ + + + + ]: 28 : fa(:)=fa(:)*scale; fb(:)=fb(:)*scale
6435 [ + + + + ]: 21359 : yy=yy*scale
6436 : : ENDIF
6437 [ + + ]: 56118 : DO i = 1,5
6438 : 46765 : arp = arp + DBLE(isgn) * abp(i) * fa(i)
6439 : 56118 : brp = brp + DBLE(isgn) * abp(i) * fb(i)
6440 : : ENDDO
6441 : 9353 : fa(0) = tmpz(1,1,j) * arp + tmpz(1,2,j) * brp
6442 : 9353 : fb(0) = tmpz(2,1,j) * arp + tmpz(2,2,j) * brp
6443 : 9353 : yy(1,j) = yy(1,j-isgn)
6444 : 9353 : yy(2,j) = yy(2,j-isgn)
6445 [ + + ]: 56118 : DO i = 0,4,1
6446 : 46765 : yy(1,j) = yy(1,j) + DBLE(isgn) * amc(i) * fa(i)
6447 : 56118 : yy(2,j) = yy(2,j) + DBLE(isgn) * amc(i) * fb(i)
6448 : : ENDDO
6449 [ + + ]: 46765 : DO i = 5,2,-1
6450 : 37412 : fa(i) = fa(i-1)
6451 : 46765 : fb(i) = fb(i-1)
6452 : : ENDDO
6453 : 9353 : fa(1) = tmpz(1,1,j) * yy(1,j) + tmpz(1,2,j) * yy(2,j)
6454 [ + + ]: 9353 : fb(1) = tmpz(2,1,j) * yy(1,j) + tmpz(2,2,j) * yy(2,j)
6455 : : ENDDO
6456 [ - + ]: 5 : LIBPAW_DEALLOCATE(tmpz)
6457 : 5 : END SUBROUTINE cfdsol
6458 : :
6459 : :
6460 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6461 : : !! SUBROUTINE cfdsoliter(Grid,zz,yy,jj1,jj2)
6462 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6463 [ - + - + ]: 70260 : SUBROUTINE cfdsoliter(Grid,zz,yy,jj1,jj2)
6464 : : TYPE(gridinfo), INTENT(IN) :: Grid
6465 : : real(dp), INTENT(IN):: zz(:,:,:)
6466 : : real(dp), INTENT(INOUT):: yy(:,:)
6467 : : INTEGER, INTENT(IN) :: jj1,jj2
6468 : : real(dp):: fa(0:5),fb(0:5),abp(1:5),amc(0:4),yprev(2),ycorr(2)
6469 : : INTEGER :: isgn,i,j,ip,mesh,k
6470 : : INTEGER, PARAMETER :: CORRITER=5
6471 : : real(dp):: arp,brp
6472 : 70260 : real(dp), ALLOCATABLE :: tmpz(:,:,:)
6473 : : real(dp), PARAMETER :: verylarge=10._dp, smallenough=tol5
6474 : : real(dp) :: scale,small
6475 : 70260 : mesh=SIZE(yy(2,:))
6476 [ - + ]: 70260 : IF (SIZE(zz(2,2,:))/=mesh) THEN
6477 : 0 : LIBPAW_ERROR('cfdsol error - incompatible arrays')
6478 : : ENDIF
6479 [ + + ]: 70260 : isgn = ( jj2 - jj1 ) / iabs( jj2 - jj1 )
6480 [ + + ]: 70260 : IF ( isgn .EQ. + 1 ) THEN
6481 [ + - - + ]: 35357 : IF ( jj1 .LE. 5 .OR. jj2 .GT. mesh ) THEN
6482 : 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6483 : : ENDIF
6484 : : ELSEIF ( isgn .EQ. - 1 ) THEN
6485 [ + - - + ]: 34903 : IF ( jj1 .GE. ( mesh - 4 ) .OR. jj2 .LT. 1 ) THEN
6486 : 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6487 : : ENDIF
6488 : : ELSE
6489 : : if(has_to_print) WRITE(STD_OUT,*) isgn,jj1,jj2,mesh
6490 : : ENDIF
6491 [ - + + - : 210780 : LIBPAW_ALLOCATE(tmpz,(2,2,mesh))
+ - + - -
+ - + ]
6492 [ + - + - : 984272340 : tmpz=zz
+ - - + -
- + + + +
+ + ]
6493 [ + + ]: 210780 : DO i=1,2
6494 [ + + ]: 491820 : DO j=1,2
6495 [ + + ]: 562642080 : tmpz(i,j,:)=tmpz(i,j,:)*Grid%h
6496 [ + - + + ]: 562782600 : if (Grid%TYPE==loggrid) tmpz(i,j,1:mesh)=tmpz(i,j,1:mesh)*Grid%drdu(1:mesh)
6497 : : ENDDO
6498 : : ENDDO
6499 : 70260 : abp(1) = 1901._dp / 720._dp
6500 : 70260 : abp(2) = -1387._dp / 360._dp
6501 : 70260 : abp(3) = 109._dp / 30._dp
6502 : 70260 : abp(4) = -637._dp / 360._dp
6503 : 70260 : abp(5) = 251._dp / 720._dp
6504 : : amc(0) = 251._dp / 720._dp
6505 : 70260 : amc(1) = 323._dp / 360._dp
6506 : 70260 : amc(2) = -11._dp / 30._dp
6507 : 70260 : amc(3) = 53._dp / 360._dp
6508 : 70260 : amc(4) = -19._dp / 720._dp
6509 [ + + ]: 421560 : DO j = 1,5
6510 : 351300 : ip = jj1 - isgn * j
6511 : 351300 : fa(j) = tmpz(1,1,ip) * yy(1,ip) + tmpz(1,2,ip) * yy(2,ip)
6512 : 421560 : fb(j) = tmpz(2,1,ip) * yy(1,ip) + tmpz(2,2,ip) * yy(2,ip)
6513 : : ENDDO
6514 [ + + + - : 70260 : DO j = jj1,jj2,isgn
- + ]
6515 : 70851796 : arp = yy(1,j-isgn)
6516 : 70851796 : brp = yy(2,j-isgn)
6517 [ + + + + ]: 70851796 : IF (ABS(arp)>verylarge.OR.brp>verylarge) THEN
6518 : 3534670 : scale=1._dp/(ABS(arp)+ABS(brp))
6519 : 3534670 : arp=arp*scale
6520 : 3534670 : brp=brp*scale
6521 [ + + + + ]: 49485380 : fa(:)=fa(:)*scale; fb(:)=fb(:)*scale
6522 [ + + + + ]: 21289475806 : yy=yy*scale
6523 : : ENDIF
6524 [ + + ]: 425110776 : DO i = 1,5
6525 : 354258980 : arp = arp + DBLE(isgn) * abp(i) * fa(i)
6526 : 425110776 : brp = brp + DBLE(isgn) * abp(i) * fb(i)
6527 : : ENDDO
6528 : 70851796 : fa(0) = tmpz(1,1,j) * arp + tmpz(1,2,j) * brp
6529 : 70851796 : fb(0) = tmpz(2,1,j) * arp + tmpz(2,2,j) * brp
6530 : 70851796 : yprev(1) = arp
6531 : 70851796 : yprev(2) = brp
6532 : 70851796 : ycorr(1) = yy(1,j-isgn)
6533 : 70851796 : ycorr(2) = yy(2,j-isgn)
6534 [ + + ]: 354258980 : DO i = 1,4,1
6535 : 283407184 : ycorr(1) = ycorr(1) + DBLE(isgn) * amc(i) * fa(i)
6536 : 354258980 : ycorr(2) = ycorr(2) + DBLE(isgn) * amc(i) * fb(i)
6537 : : ENDDO
6538 [ + + ]: 122991676 : DO k=1,CORRITER
6539 : 115269584 : yy(1,j)=ycorr(1) + DBLE(isgn) * amc(0) * fa(0)
6540 : 115269584 : yy(2,j)=ycorr(2) + DBLE(isgn) * amc(0) * fb(0)
6541 : 115269584 : small=abs(yprev(1))+abs(yprev(2))
6542 : 115269584 : small=(abs(yprev(1)-yy(1,j))+abs(yprev(2)-yy(2,j)))/small
6543 [ + + ]: 115269584 : if(small.le.smallenough) exit
6544 : 52139880 : yprev(1)= yy(1,j)
6545 : 52139880 : yprev(2)= yy(2,j)
6546 : 52139880 : fa(0) = tmpz(1,1,j) * yprev(1) + tmpz(1,2,j) * yprev(2)
6547 : 122991676 : fb(0) = tmpz(2,1,j) * yprev(1) + tmpz(2,2,j) * yprev(2)
6548 : : ENDDO
6549 [ + + ]: 354258980 : DO i = 5,2,-1
6550 : 283407184 : fa(i) = fa(i-1)
6551 : 354258980 : fb(i) = fb(i-1)
6552 : : ENDDO
6553 : 70851796 : fa(1) = tmpz(1,1,j) * yy(1,j) + tmpz(1,2,j) * yy(2,j)
6554 [ + + ]: 70851796 : fb(1) = tmpz(2,1,j) * yy(1,j) + tmpz(2,2,j) * yy(2,j)
6555 : : ENDDO
6556 [ - + ]: 70260 : LIBPAW_DEALLOCATE(tmpz)
6557 : 70260 : END SUBROUTINE cfdsoliter
6558 : :
6559 : :
6560 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6561 : : !! subroutine findh_given_r0(Z,range,r0,n,hval)
6562 : : !! find hval for fixed number of input grid points n in loggrid case
6563 : : !! assumes form r(i)=(r0/Z)*(exp(h*(i-1))-1);
6564 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6565 : 0 : SUBROUTINE findh_given_r0(Z,range,r0,n,hval)
6566 : : INTEGER, INTENT(IN) :: n
6567 : : real(dp), INTENT(IN) :: Z,range,r0
6568 : : real(dp), INTENT(INOUT) :: hval
6569 : 0 : hval=log((Z*range/r0 + 1._dp))/(n-1)
6570 : 0 : end subroutine findh_given_r0
6571 : :
6572 : :
6573 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6574 : : !! subroutine findh(Z,range,n,hval,r0)
6575 : : !! find hval for fixed number of input grid points n in loggrid case
6576 : : !! assumes form r(i)=(h/Z)*(exp(h*(i-1))-1); r0=h/Z
6577 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6578 : 4 : SUBROUTINE findh(Z,range,n,hval,r0)
6579 : : real(dp), INTENT(IN) :: Z
6580 : : INTEGER, INTENT(IN) :: n
6581 : : real(dp), INTENT(IN) :: range
6582 : : real(dp), INTENT(INOUT) :: hval,r0
6583 : : real(dp) :: h0,dh,f,df
6584 : : INTEGER :: i
6585 : : INTEGER, parameter :: iter=1000
6586 : : real(dp), parameter :: eps=1.e-15
6587 : : LOGICAL :: success
6588 : 4 : h0=hval
6589 : 4 : success=.false.
6590 [ + - ]: 34 : do i=1,iter
6591 : 34 : f=LOG(Z*range/h0+1._dp)/h0
6592 : 34 : df=-f/h0-(Z*range/h0**3)/(Z*range/h0+1._dp)
6593 : 34 : dh=(n-1-f)/df
6594 [ + + ]: 34 : if (ABS(dh)< eps) then
6595 : : success=.true.
6596 : : exit
6597 : : endif
6598 [ + + ]: 30 : if (h0+dh<0._dp) then
6599 : 4 : h0=h0/2
6600 : : else
6601 : 26 : h0=h0+dh
6602 : : endif
6603 : : enddo
6604 [ - + ]: 4 : if (.not.success) then
6605 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'Warning in findh -- dh > eps ', dh,h0
6606 : : endif
6607 : 4 : hval=h0
6608 : 4 : r0=hval/Z
6609 : 4 : end subroutine findh
6610 : :
6611 : :
6612 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6613 : : !! subroutine initgrid(Grid,h,range,r0)
6614 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6615 : 4 : SUBROUTINE InitGrid(Grid,h,range,r0,do_not_print,pawrad)
6616 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
6617 : : real(dp), INTENT(IN) :: range
6618 : : real(dp), INTENT(IN) :: h
6619 : : real(dp), OPTIONAL, INTENT(IN) :: r0
6620 : : LOGICAL, OPTIONAL, INTENT(IN) :: do_not_print
6621 : : TYPE(pawrad_type),optional, INTENT(IN) :: pawrad
6622 : : INTEGER :: i,n
6623 : : LOGICAL :: do_print
6624 [ - + ]: 4 : do_print=.false.;if (present(do_not_print)) do_print=.not.do_not_print
6625 [ - + ]: 4 : if (present(pawrad)) then
6626 [ # # ]: 0 : if (pawrad%mesh_type/=2) then
6627 : 0 : LIBPAW_ERROR("Error wrong pawrad grid")
6628 : 0 : STOP
6629 : : end if
6630 : 0 : Grid%n=pawrad%mesh_size
6631 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%r,(Grid%n))
# # # # #
# # # ]
6632 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%drdu,(Grid%n))
# # # # ]
6633 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%pref,(Grid%n))
# # # # ]
6634 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%rr02,(Grid%n))
# # # # ]
6635 [ # # ]: 0 : Grid%r(:)=pawrad%rad(:)
6636 [ # # ]: 0 : Grid%drdu(:)=pawrad%radfact(:)
6637 [ # # ]: 0 : Grid%rr02(:)=pawrad%radfact(:)**2
6638 [ # # ]: 0 : Grid%pref(:)=(pawrad%radfact(:)*pawrad%rstep)**2
6639 : 0 : Grid%r0=pawrad%rstep
6640 : 0 : Grid%range=pawrad%rmax
6641 : 0 : Grid%h=pawrad%lstep
6642 : 0 : Grid%type=loggrid
6643 : 0 : Grid%ishift=5
6644 : : else
6645 [ + - ]: 4 : IF (PRESENT(r0)) THEN
6646 : 4 : Grid%h=h
6647 : 4 : Grid%r0=r0
6648 : 4 : Grid%type=loggrid
6649 : 4 : Grid%range=range
6650 : 4 : n=LOG(range/r0+1)/h+1
6651 : 4 : Grid%ishift=5
6652 [ - + ]: 4 : IF (r0*(EXP(h*(n-1))-1)<range-tol5) n=n+1
6653 : 4 : Grid%n=n
6654 [ - + ]: 4 : if (do_print) write(std_out,*) 'InitGrid: -- logarithmic ',n, h,range,r0
6655 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(Grid%r,(n))
+ - + - -
+ - + ]
6656 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(Grid%drdu,(n))
- + - + ]
6657 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(Grid%pref,(n))
- + - + ]
6658 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(Grid%rr02,(n))
- + - + ]
6659 [ + + ]: 8008 : DO i=1,n
6660 : 8004 : Grid%r(i)=r0*(EXP(Grid%h*(i-1))-1)
6661 : 8004 : Grid%drdu(i)=r0*EXP(Grid%h*(i-1))
6662 : 8004 : Grid%pref(i)=r0*EXP(Grid%h*(i-1)/2._dp)
6663 : 8008 : Grid%rr02(i)=(Grid%r(i)+r0)**2
6664 : : ENDDO
6665 : : ELSE
6666 : 0 : Grid%h=h
6667 : 0 : Grid%r0=0._dp
6668 : 0 : Grid%type=lineargrid
6669 : 0 : Grid%range=range
6670 : 0 : n=range/h+1
6671 : 0 : Grid%ishift=25
6672 [ # # ]: 0 : IF (h*(n-1)<range-tol5) n=n+1
6673 : 0 : Grid%n=n
6674 [ # # ]: 0 : if (do_print) write(std_out,*) 'InitGrid: -- linear ', n,h,range
6675 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%r,(n))
# # # # #
# # # ]
6676 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%drdu,(n))
# # # # ]
6677 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%pref,(n))
# # # # ]
6678 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(Grid%rr02,(n))
# # # # ]
6679 [ # # ]: 0 : DO i=1,n
6680 : 0 : Grid%r(i)=(Grid%h*(i-1))
6681 : 0 : Grid%drdu(i)=1._dp
6682 : 0 : Grid%pref(i)=1._dp
6683 : 0 : Grid%rr02(i)=1._dp
6684 : : ENDDO
6685 : : ENDIF
6686 : : endif
6687 : 4 : END SUBROUTINE InitGrid
6688 : :
6689 : :
6690 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6691 : : !! subroutine destroygrid(Grid)
6692 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6693 : 8 : SUBROUTINE DestroyGrid(Grid)
6694 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
6695 [ + + ]: 8 : IF (ASSOCIATED(Grid%r)) then
6696 : 4 : LIBPAW_POINTER_DEALLOCATE(Grid%r)
6697 : : endif
6698 [ + + ]: 8 : IF (ASSOCIATED(Grid%drdu)) then
6699 : 4 : LIBPAW_POINTER_DEALLOCATE(Grid%drdu)
6700 : : endif
6701 [ + + ]: 8 : IF (ASSOCIATED(Grid%pref)) then
6702 : 4 : LIBPAW_POINTER_DEALLOCATE(Grid%pref)
6703 : : endif
6704 [ + + ]: 8 : IF (ASSOCIATED(Grid%rr02)) then
6705 : 4 : LIBPAW_POINTER_DEALLOCATE(Grid%rr02)
6706 : : endif
6707 : 8 : END SUBROUTINE DestroyGrid
6708 : :
6709 : :
6710 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6711 : : !! subroutine nullifygrid(Grid)
6712 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6713 : : SUBROUTINE NullifyGrid(Grid)
6714 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
6715 : : NULLIFY(Grid%r)
6716 : : NULLIFY(Grid%drdu)
6717 : : NULLIFY(Grid%pref)
6718 : : NULLIFY(Grid%rr02)
6719 : : END SUBROUTINE NullifyGrid
6720 : :
6721 : :
6722 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6723 : : !! SUBROUTINE backward_numerov(Grid,l,match,energy,rv,wfn,wgt,nend,proj)
6724 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6725 [ - + - - : 5131 : SUBROUTINE backward_numerov(Grid,l,match,energy,rv,wfn,wgt,nend,proj)
- - - + -
+ - + - -
- - ]
6726 : : TYPE (GridInfo), INTENT(IN) :: Grid
6727 : : INTEGER, INTENT(IN) :: l,match
6728 : : real(dp), INTENT(IN) :: energy,rv(:)
6729 : : real(dp), INTENT(INOUT) :: wfn(:) ! on input wfn(n-1) and wfn(n) given
6730 : : real(dp), INTENT(IN), OPTIONAL :: wgt(:)
6731 : : real(dp), intent(in), optional :: proj(:)
6732 : : integer, intent(in), optional :: nend
6733 : 5131 : real(dp), ALLOCATABLE :: a(:),b(:),p(:),c(:)
6734 : : real(dp) :: angm,h,h2,scale
6735 : : real(dp), PARAMETER :: vlarg=1.d30
6736 : : INTEGER :: i,n
6737 : : LOGICAL :: withwgt
6738 : 5131 : withwgt=.false.
6739 [ - + ]: 5131 : If (PRESENT(wgt)) withwgt=.true.
6740 : 5131 : n=Grid%n
6741 [ - + ]: 5131 : if(present(nend)) n=nend
6742 [ - + + - : 15393 : LIBPAW_ALLOCATE(a,(n))
+ - + - -
+ - + ]
6743 [ - + + - : 10262 : LIBPAW_ALLOCATE(b,(n))
- + - + ]
6744 [ - + + - : 10262 : LIBPAW_ALLOCATE(p,(n))
- + - + ]
6745 [ - + + - : 10262 : LIBPAW_ALLOCATE(c,(n))
- + - + ]
6746 : 5131 : p(n)=wfn(n)
6747 : 5131 : p(n-1)=wfn(n-1)
6748 : 5131 : angm=l*(l+1)
6749 [ + + ]: 10272262 : a=0
6750 [ + + ]: 10272262 : b=0
6751 [ + + ]: 10272262 : c=0
6752 : 5131 : h=Grid%h; h2=h*h
6753 [ + + ]: 3788043 : DO i=match,n
6754 [ - + ]: 3788043 : if(withwgt) then
6755 : 0 : a(i)=rv(i)/Grid%r(i)-energy*wgt(i)+angm/(Grid%r(i)**2)
6756 : : else
6757 : 3782912 : a(i)=rv(i)/Grid%r(i)-energy+angm/(Grid%r(i)**2)
6758 : : endif
6759 : : ENDDO
6760 [ - + - - ]: 5131 : if(present(proj)) b(match:n)=0.1_dp*h2*proj(match:n)
6761 [ + - ]: 5131 : IF (Grid%type==loggrid) THEN
6762 [ + + ]: 15393 : p(n-1:n)=p(n-1:n)/Grid%pref(n-1:n)
6763 [ + + ]: 3788043 : a(match:n)=0.25_dp+Grid%rr02(match:n)*a(match:n)
6764 [ - + - - ]: 5131 : if(present(proj)) b(match:n)=Grid%rr02(match:n)*b(match:n)/Grid%pref(match:n)
6765 : : ENDIF
6766 [ # # ]: 0 : if(present(proj)) then
6767 [ # # ]: 0 : do i=match+1,n-1
6768 : 0 : c(i)=10*b(i)+b(i-1)+b(i+1)
6769 : : enddo
6770 : : endif
6771 [ + + ]: 3788043 : b(match:n)=2.4_dp+h2*a(match:n)
6772 [ + + ]: 3788043 : a(match:n)=1.2_dp-0.1_dp*h2*a(match:n)
6773 [ + + ]: 3777781 : DO i=n-2,match,-1
6774 : 3772650 : p(i)=(b(i+1)*p(i+1)-a(i+2)*p(i+2)-c(i+1))/a(i)
6775 : : !renormalize if necessary
6776 : 3772650 : scale=ABS(p(i))
6777 [ + + ]: 3777781 : IF (scale > vlarg) THEN
6778 : 15262 : scale=1._dp/scale
6779 [ + + ]: 2634457 : p(i:n)=scale*p(i:n)
6780 : : ENDIF
6781 : : ENDDO
6782 [ + + ]: 3788043 : wfn(match:n)=p(match:n)
6783 [ + - ]: 5131 : IF (Grid%type==loggrid) THEN
6784 [ + + ]: 3788043 : wfn(match:n)=wfn(match:n)*Grid%pref(match:n)
6785 : : ENDIF
6786 [ - + ]: 5131 : LIBPAW_DEALLOCATE(a)
6787 [ - + ]: 5131 : LIBPAW_DEALLOCATE(b)
6788 : 5131 : LIBPAW_DEALLOCATE(p)
6789 [ - + ]: 5131 : LIBPAW_DEALLOCATE(c)
6790 : 5131 : END SUBROUTINE backward_numerov
6791 : :
6792 : :
6793 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6794 : : !! SUBROUTINE
6795 : : !forward_numerov(Grid,l,many,energy,rv,zeroval,wfn,nodes,wgt,proj,p3val)
6796 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6797 [ - + - - : 5210 : SUBROUTINE forward_numerov(Grid,l,many,energy,rv,zeroval,wfn,nodes,wgt,proj,p3val)
- - - + -
+ + + + -
- + ]
6798 : : TYPE (GridInfo), INTENT(IN) :: Grid
6799 : : INTEGER, INTENT(IN) :: l,many
6800 : : real(dp), INTENT(IN) :: energy,zeroval,rv(:)
6801 : : real(dp), INTENT(INOUT) :: wfn(:) ! on input wfn(1) and wfn(2) given
6802 : : INTEGER, INTENT(OUT) :: nodes
6803 : : real(dp), INTENT(IN), OPTIONAL :: wgt(:)
6804 : : real(dp), intent(in), optional :: p3val
6805 : : real(dp), intent(in), optional :: proj(:)
6806 : 5210 : real(dp), ALLOCATABLE :: a(:),b(:),p(:),c(:)
6807 : : real(dp) :: xx,angm,h,h2,scale
6808 : : real(dp), PARAMETER :: vlarg=1.d30
6809 : : INTEGER :: i
6810 : : LOGICAL :: withwgt
6811 : 5210 : withwgt=.false.
6812 [ - + ]: 5210 : If (PRESENT(wgt)) withwgt=.true.
6813 [ - + + - : 15630 : LIBPAW_ALLOCATE(a,(many))
+ - + - -
+ - + ]
6814 [ - + + - : 10420 : LIBPAW_ALLOCATE(b,(many))
- + - + ]
6815 [ - + + - : 10420 : LIBPAW_ALLOCATE(p,(many))
- + - + ]
6816 [ - + + - : 10420 : LIBPAW_ALLOCATE(c,(many))
- + - + ]
6817 : 5210 : p(1)=wfn(1)
6818 : 5210 : p(2)=wfn(2)
6819 : 5210 : xx=zeroval
6820 : 5210 : angm=l*(l+1)
6821 [ + + ]: 6668839 : a=0
6822 [ + + ]: 6668839 : c=0
6823 : 5210 : h=Grid%h; h2=h*h
6824 [ + + ]: 6663629 : DO i=2,many
6825 [ - + ]: 6663629 : if (withwgt) then
6826 : 0 : a(i)=rv(i)/Grid%r(i)-energy*wgt(i)+angm/(Grid%r(i)**2)
6827 : : else
6828 : 6658419 : a(i)=rv(i)/Grid%r(i)-energy+angm/(Grid%r(i)**2)
6829 : : endif
6830 : : ENDDO
6831 [ + + + + ]: 73022 : if(present(proj)) b(1:many)=0.1_dp*h2*proj(1:many)
6832 [ + - ]: 5210 : IF (Grid%type==loggrid) THEN
6833 [ + + ]: 15630 : p(1:2)=wfn(1:2)/Grid%pref(1:2)
6834 : 5210 : xx=Grid%rr02(1)*xx/Grid%pref(1)
6835 [ - + + + ]: 6674049 : a=0.25_dp+Grid%rr02(1:many)*a
6836 [ + + + + ]: 73070 : if(present(proj)) b(1:many)=Grid%rr02(1:many)*b(1:many)/Grid%pref(1:many)
6837 : : ENDIF
6838 [ + - ]: 48 : if(present(proj)) then
6839 [ + + ]: 67764 : do i=2,many-1
6840 : 67764 : c(i)=10*b(i)+b(i-1)+b(i+1)
6841 : : enddo
6842 : : endif
6843 [ - + + + ]: 6674049 : b=2.4_dp+h2*a
6844 [ + + ]: 6668839 : a=1.2_dp-0.1_dp*h2*a
6845 : 5210 : p(3)=(b(2)*p(2)+0.1_dp*h2*xx)/a(3)
6846 [ - + ]: 5210 : if(present(p3val)) then
6847 : 0 : p(3)=p3val
6848 [ # # ]: 0 : IF (Grid%type==loggrid) p(3)=p3val/Grid%pref(3)
6849 : : endif
6850 : 5210 : nodes=0
6851 [ + + ]: 6653209 : DO i=4,many
6852 : 6647999 : p(i)=(b(i-1)*p(i-1)-a(i-2)*p(i-2)-c(i-1))/a(i)
6853 [ + + ]: 6647999 : IF (p(i)*p(i-1) < 0._dp) nodes=nodes+1
6854 : : !renormalize if necessary
6855 : 6647999 : scale=ABS(p(i))
6856 [ - + ]: 6653209 : IF (scale > vlarg) THEN
6857 : 0 : scale=1._dp/scale
6858 [ # # ]: 0 : p(1:i)=scale*p(1:i)
6859 : : ENDIF
6860 : : ENDDO
6861 [ + + ]: 6668839 : wfn(1:many)=p(1:many)
6862 [ + - ]: 5210 : IF (Grid%type==loggrid) THEN
6863 [ + + ]: 6668839 : wfn(1:many)=wfn(1:many)*Grid%pref(1:many)
6864 : : ENDIF
6865 : 5210 : LIBPAW_DEALLOCATE(a)
6866 : 5210 : LIBPAW_DEALLOCATE(b)
6867 : 5210 : LIBPAW_DEALLOCATE(p)
6868 [ - + ]: 5210 : LIBPAW_DEALLOCATE(c)
6869 : 5210 : END SUBROUTINE forward_numerov
6870 : :
6871 : :
6872 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6873 : : !! subroutine initgridwithn(Grid,type,n,r0,h)
6874 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6875 : 0 : SUBROUTINE initgridwithn(Grid,type,n,r0,h)
6876 : : TYPE (GridInfo), INTENT(INOUT) :: Grid
6877 : : INTEGER, INTENT(IN) :: type,n !type=1 lin,2 log
6878 : : REAL(dp), INTENT(IN) :: r0,h
6879 : : INTEGER :: i
6880 [ # # ]: 0 : IF (type==loggrid) THEN
6881 : 0 : Grid%h=h
6882 : 0 : Grid%r0=r0
6883 : 0 : Grid%type=loggrid
6884 : 0 : Grid%ishift=5
6885 : 0 : Grid%n=n
6886 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%r,(n))
# # # # #
# # # ]
6887 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%drdu,(n))
# # # # ]
6888 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%pref,(n))
# # # # ]
6889 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%rr02,(n))
# # # # ]
6890 [ # # ]: 0 : DO i=1,n
6891 : 0 : Grid%r(i)=r0*(EXP(Grid%h*(i-1))-1)
6892 : 0 : Grid%drdu(i)=r0*EXP(Grid%h*(i-1))
6893 : 0 : Grid%pref(i)=r0*EXP(Grid%h*(i-1)/2._dp)
6894 : 0 : Grid%rr02(i)=(Grid%r(i)+r0)**2
6895 : : ENDDO
6896 : 0 : Grid%range=Grid%r(n)
6897 [ # # ]: 0 : if(has_to_print)WRITE(STD_OUT,*) 'InitGridwithn: -- logarithmic ',n, h,Grid%range,r0
6898 [ # # ]: 0 : ELSEIF (type==lineargrid) THEN
6899 : 0 : Grid%h=h
6900 : 0 : Grid%r0=0._dp
6901 : 0 : Grid%type=lineargrid
6902 : 0 : Grid%ishift=25
6903 : 0 : Grid%n=n
6904 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%r,(n))
# # # # #
# # # ]
6905 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%drdu,(n))
# # # # ]
6906 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%pref,(n))
# # # # ]
6907 [ # # # # : 0 : LIBPAW_ALLOCATE(Grid%rr02,(n))
# # # # ]
6908 [ # # ]: 0 : DO i=1,n
6909 : 0 : Grid%r(i)=(Grid%h*(i-1))
6910 : 0 : Grid%drdu(i)=1._dp
6911 : 0 : Grid%pref(i)=1._dp
6912 : 0 : Grid%rr02(i)=1._dp
6913 : : ENDDO
6914 : 0 : Grid%range=Grid%r(n)
6915 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'InitGridwithn: -- linear ',n, h,Grid%range,r0
6916 : : ELSE
6917 : 0 : write(std_out,*) 'error in initgridwithn -- type =',type
6918 : 0 : stop
6919 : : ENDIF
6920 : 0 : END SUBROUTINE initgridwithn
6921 : :
6922 : :
6923 : :
6924 : :
6925 : :
6926 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6927 : : ! 10. pseudo
6928 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6929 : :
6930 : :
6931 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6932 : : !! SUBROUTINE sethat(Grid,PAW,gaussparam,besselopt)
6933 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6934 : :
6935 : :
6936 : 2 : SUBROUTINE sethat(Grid,PAW,gaussparam,besselopt)
6937 : : TYPE(GridInfo), INTENT(IN) :: Grid
6938 : : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
6939 : : INTEGER,INTENT(IN), OPTIONAL :: besselopt
6940 : : REAL(dp),INTENT(IN), OPTIONAL :: gaussparam
6941 : : INTEGER :: n,irc,irc_shap,i
6942 : 2 : REAL(dp), POINTER :: r(:)
6943 : : REAL(dp) :: h,con,rc,rc_shap,selfen,d,dd,jbes1,jbes2,qr
6944 : : REAL(dp) :: al(2),ql(2)
6945 : 2 : n=Grid%n
6946 : 2 : h=Grid%h
6947 : 2 : irc=PAW%irc
6948 : 2 : rc=PAW%rc
6949 : 2 : irc_shap=PAW%irc_shap
6950 : 2 : rc_shap=PAW%rc_shap
6951 : 2 : r=>Grid%r
6952 [ + + ]: 4004 : PAW%hatden=0
6953 [ + + ]: 4004 : PAW%projshape=0
6954 [ + + ]: 4004 : PAW%hatshape=0
6955 : 2 : PAW%projshape(1)=1
6956 : 2 : PAW%hatshape(1)=1
6957 [ + + ]: 2825 : DO i=2,irc-1
6958 : 2825 : PAW%projshape(i)=(SIN(pi*r(i)/rc)/(pi*r(i)/rc))**2
6959 : : ENDDO
6960 [ - + ]: 2 : if(present(gaussparam)) then
6961 : 0 : d=rc_shap/SQRT(LOG(1._dp/gaussparam))
6962 : 0 : PAW%gausslength=d
6963 [ # # ]: 0 : DO i=2,irc
6964 : 0 : PAW%hatshape(i)=EXP(-(r(i)/d)**2)
6965 : : ENDDO
6966 : 0 : PAW%irc_shap=PAW%irc
6967 : 0 : PAW%rc_shap=PAW%rc
6968 [ - + ]: 2 : else if(present(besselopt)) then
6969 : 0 : call shapebes(al,ql,0,rc_shap)
6970 [ # # ]: 0 : DO i=1,irc_shap-1
6971 : 0 : qr=ql(1)*r(i);CALL jbessel(jbes1,d,dd,0,0,qr)
6972 : 0 : qr=ql(2)*r(i);CALL jbessel(jbes2,d,dd,0,0,qr)
6973 : 0 : PAW%hatshape(i)=al(1)*jbes1+al(2)*jbes2
6974 : : ENDDO
6975 : : else
6976 [ + + ]: 2809 : DO i=2,irc_shap-1
6977 : 2809 : PAW%hatshape(i)=(SIN(pi*r(i)/rc_shap)/(pi*r(i)/rc_shap))**2
6978 : : ENDDO
6979 : : endif
6980 [ + + ]: 2829 : PAW%hatden(1:irc)=PAW%hatshape(1:irc)*(r(1:irc)**2)
6981 : : ! normalize
6982 [ + - ]: 2 : if (.not.present(besselopt)) then
6983 : 2 : con=integrator(Grid,PAW%hatden,1,PAW%irc_shap)
6984 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) ' check hatden normalization', con
6985 [ + + ]: 4004 : PAW%hatden=PAW%hatden/con
6986 : : endif
6987 : 2 : CALL atompaw_poisson(Grid,con,PAW%hatden,PAW%hatpot,selfen)
6988 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'Self energy for L=0 hat density ', selfen
6989 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'hatden charge ', con
6990 : 2 : END SUBROUTINE sethat
6991 : :
6992 : :
6993 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6994 : : !! SUBROUTINE FindVlocfromVeff(Grid,Orbit,PAW)
6995 : : ! Assumes prior call to SUBROUTINE calculate_tvtau
6996 : : ! which now fills PAW%tden and PAW%ttau
6997 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6998 : 0 : SUBROUTINE FindVlocfromVeff(Grid,PAW,atp,potshift)
6999 : : ! TODO : needvtau,allocates
7000 : : TYPE(GridInfo), INTENT(INOUT) :: Grid
7001 : : type(atompaw_type),intent(inout) :: atp
7002 : : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
7003 : : real(dp),intent(in) :: potshift
7004 : 0 : REAL(dp), POINTER :: r(:)
7005 : : REAL(dp) :: h,tq,rat,q00,etxc,eexc
7006 : : INTEGER :: n,irc,nbase
7007 : : REAL(dp), allocatable :: d(:),v(:),vxB(:),vxK(:)
7008 : : REAL(dp), allocatable :: t(:),vt(:),vthat(:)
7009 : 0 : CALL FillHat(Grid,PAW,atp%besselshapefunction)
7010 : : !if (Vlocalindex == SETVLOC) then
7011 : : ! write(std_out,*) 'Vloc == VlocCoef*shapefunc '
7012 : : ! return
7013 : : !endif
7014 : 0 : n=Grid%n;irc=PAW%irc
7015 : 0 : nbase=PAW%nbase
7016 : 0 : h=Grid%h ; r=>Grid%r
7017 : 0 : irc=max(PAW%irc,PAW%irc_shap,PAW%irc_vloc,PAW%irc_core)
7018 : : ! Recalculate den and tau
7019 [ # # # # ]: 0 : PAW%valetau=0._dp;PAW%tvaletau=0._dp
7020 [ # # # # : 0 : LIBPAW_ALLOCATE(d,(n))
# # # # #
# # # ]
7021 [ # # # # : 0 : LIBPAW_ALLOCATE(vxB,(n))
# # # # ]
7022 [ # # # # : 0 : LIBPAW_ALLOCATE(v,(n))
# # # # ]
7023 [ # # # # : 0 : LIBPAW_ALLOCATE(vxK,(n))
# # # # ]
7024 [ # # # # : 0 : LIBPAW_ALLOCATE(t,(n))
# # # # ]
7025 [ # # # # : 0 : LIBPAW_ALLOCATE(vt,(n))
# # # # ]
7026 [ # # # # : 0 : LIBPAW_ALLOCATE(vthat,(n))
# # # # ]
7027 [ # # # # : 0 : d=PAW%den-PAW%tden
# # # # ]
7028 : 0 : tq=integrator(Grid,d,1,irc)
7029 [ # # ]: 0 : if(has_to_print) write(std_out,*) ' Delta Qval = ', tq
7030 : : ! Compute VH(tDEN+hatDEN)
7031 [ # # # # : 0 : d=PAW%tden+tq*PAW%hatden
# # # # ]
7032 : 0 : call poisson_marc(Grid,q00,d,v,rat)
7033 [ # # ]: 0 : if(has_to_print) write(std_out,*) ' Completed Poisson with q00 = ', q00
7034 [ # # ]: 0 : if(has_to_print) write(std_out,*) ' Completed Poisson with v(n) = ', v(n)
7035 : : ! Compute Blochl exc
7036 [ # # # # : 0 : d=PAW%tden+PAW%tcore
# # # # ]
7037 [ # # # # : 0 : t=PAW%tcoretau+PAW%tvaletau
# # # # ]
7038 : : CALL exch(Grid,d,vxB,etxc,eexc,itype=atp%itype,needvtau=atp%Pot%needvtau,&
7039 : 0 : & tau=t,vtau=vt,xc_functionals=atp%xc_functionals)
7040 : : ! Compute Kresse exc Vxc(tcore+tDEN+hatDEN)
7041 [ # # # # : 0 : d=PAW%tcore+PAW%tden+tq*PAW%hatden
# # # # ]
7042 [ # # # # : 0 : t=PAW%tcoretau+PAW%tvaletau
# # # # ]
7043 : : CALL exch(Grid,d,vxK,etxc,eexc,itype=atp%itype,needvtau=atp%Pot%needvtau,&
7044 : 0 : & tau=t,vtau=vthat,xc_functionals=atp%xc_functionals)
7045 [ # # # # ]: 0 : PAW%abinitvloc=zero; PAW%abinitnohat=zero
7046 [ # # ]: 0 : PAW%abinitnohat(2:n)=(PAW%rveff(2:n)-v(2:n)-vxB(2:n))/r(2:n)+potshift
7047 : 0 : call extrapolate(PAW%abinitnohat)
7048 [ # # ]: 0 : PAW%abinitvloc(2:n)=(PAW%rveff(2:n)-v(2:n)-vxK(2:n))/r(2:n)+potshift
7049 : 0 : call extrapolate(PAW%abinitvloc)
7050 : : ! Reassess poscorenhat
7051 : : ! check if PAW%tcore+PAW%tden+tq*PAW%hatden is positive
7052 : 0 : PAW%poscorenhat=.true.
7053 [ # # ]: 0 : LIBPAW_DEALLOCATE(v)
7054 [ # # ]: 0 : LIBPAW_DEALLOCATE(vxB)
7055 [ # # ]: 0 : LIBPAW_DEALLOCATE(vxK)
7056 [ # # ]: 0 : LIBPAW_DEALLOCATE(d)
7057 [ # # ]: 0 : LIBPAW_DEALLOCATE(vt)
7058 [ # # ]: 0 : LIBPAW_DEALLOCATE(vthat)
7059 [ # # ]: 0 : END SUBROUTINE FindVlocfromVeff
7060 : :
7061 : :
7062 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7063 : : !! SUBROUTINE SetPAWOptions2(Grid,Orbit,Pot,success,atp)
7064 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7065 : 2 : SUBROUTINE SetPAWOptions2(atp,success)
7066 : : LOGICAL , INTENT(OUT) :: success
7067 : : type(atompaw_type), intent(inout) :: atp
7068 : : INTEGER :: l
7069 : : integer :: Projectorindex,Vlocalindex
7070 : : real(dp) :: e
7071 : 2 : success=.true.
7072 : : IF (atp%projector_type==PROJECTOR_TYPE_MARSMAN) Projectorindex=MARSMAN
7073 : : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER) Vlocalindex=MTROULLIER
7074 [ - + ]: 2 : IF (atp%vloc_type==VLOC_TYPE_ULTRASOFT) Vlocalindex=ULTRASOFT
7075 [ - + ]: 2 : IF (atp%vloc_type==VLOC_TYPE_BESSEL) Vlocalindex=BESSEL
7076 [ - + ]: 2 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNC) Vlocalindex=VPSMATCHNC
7077 [ + - ]: 2 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNNC) Vlocalindex=VPSMATCHNNC
7078 : : !Store the description of Vloc scheme in a string
7079 [ + - ]: 2 : if (Vlocalindex==MTROULLIER) then
7080 : 2 : l=atp%vloc_l ; e=atp%vloc_ene
7081 [ - + ]: 2 : if(has_to_print) then
7082 : : WRITE(atp%PAW%Vloc_description,&
7083 : 0 : & '("Vloc: Norm-conserving Troullier-Martins with l=",i1,";e=",1p,1e12.4)')l,e
7084 : : endif
7085 : : endif
7086 [ - + ]: 2 : if (Vlocalindex==ULTRASOFT) then
7087 : 0 : l=atp%vloc_l ; e=atp%vloc_ene
7088 [ # # ]: 0 : if(has_to_print) then
7089 : : WRITE(atp%PAW%Vloc_description,&
7090 : 0 : & '("Vloc: Non norm-conserving form with l= ",i1,";e= ",1p,1e12.4)')l,e
7091 : : endif
7092 : : endif
7093 [ - + ]: 2 : if (Vlocalindex==BESSEL) then
7094 [ # # ]: 0 : if(has_to_print) then
7095 : : WRITE(atp%PAW%Vloc_description,&
7096 : 0 : & '("Vloc: truncated form - Vps(r)=A.sin(qr)/r for r<rc")')
7097 : : endif
7098 : : endif
7099 : : !Shape function parameters (from input dataset)
7100 [ - + ]: 2 : if (atp%shapefunc_type==SHAPEFUNC_TYPE_GAUSSIAN) then
7101 : 0 : atp%gaussianshapefunction=.true.
7102 : 0 : CALL sethat(atp%Grid,atp%PAW,gaussparam=atp%shapefunc_gaussian_param) !Gaussian shape function
7103 [ - + ]: 2 : else if (atp%shapefunc_type==SHAPEFUNC_TYPE_BESSEL) then
7104 : 0 : atp%besselshapefunction=.true.
7105 : 0 : CALL sethat(atp%Grid,atp%PAW,besselopt=0) ! Bessel shape function
7106 : : else
7107 : 2 : CALL sethat(atp%Grid,atp%PAW) ! sinc^2 shape function
7108 : : endif
7109 : : !Call the routine computing Vloc - Not mGGA
7110 [ + - ]: 2 : IF (.NOT.atp%needvtau) THEN
7111 [ + - ]: 2 : IF (Vlocalindex==MTROULLIER.and.Projectorindex/=HFPROJ) THEN
7112 : 2 : CALL troullier(atp%Grid,atp%Pot,atp%PAW,l,e,atp%needvtau,atp%scalarrelativistic)
7113 : : ENDIF
7114 [ - + ]: 2 : IF (Vlocalindex==ULTRASOFT) CALL nonncps(atp%Grid,atp%Pot,atp%PAW,l,e,atp%scalarrelativistic)
7115 [ - + ]: 2 : IF (Vlocalindex==BESSEL) CALL besselps(atp%Grid,atp%Pot,atp%PAW)
7116 : 2 : call makebasis_marsman(atp)
7117 : : ENDIF
7118 : : !Call the routine computing Vloc - mGGA case
7119 : : ! IF (atp%needvtau) THEN
7120 : : ! !All compatibility checks in input_dataset_read routine
7121 : : ! if(has_to_print) WRITE(STD_OUT,*) 'Sequence of dataset construction modified for MGGA'
7122 : : ! if(has_to_print) WRITE(STD_OUT,*) ' Not all possibilites tested carefully yet.... '
7123 : : ! if(has_to_print) WRITE(STD_OUT,*) ' Some possibilites not yet programmed.... '
7124 : : ! !Calculate PAW%vtau and PAW%tvtau
7125 : : ! CALL calculate_tvtau(atp%Grid,atp%PAW,atp%itype)
7126 : : ! !Set pseudoptentials
7127 : : ! ! IF (Vlocalindex==MTROULLIER.and.(TRIM(atp%Orbit%exctype)/='HF')) then
7128 : : ! ! if(has_to_print) WRITE(STD_OUT,*) 'TROULLIER PS not available for MGGA '
7129 : : ! ! if(has_to_print) WRITE(STD_OUT,*) ' calling VPSmatch with norm conservation instead '
7130 : : ! ! CALL VPSmatch(atp%Grid,atp%Pot,atp%PAW,l,e,.true.,atp%scalarrelativistic)
7131 : : ! ! ENDIF
7132 : : ! IF (Vlocalindex==VPSMATCHNNC) CALL VPSmatch(atp%Grid,atp%Pot,atp%PAW,l,e,.false.,atp%scalarrelativistic)
7133 : : ! IF (Vlocalindex==VPSMATCHNC) CALL VPSmatch(atp%Grid,atp%Pot,atp%PAW,l,e,.true.,atp%scalarrelativistic)
7134 : : ! IF (Vlocalindex==ULTRASOFT) CALL nonncps(atp%Grid,atp%Pot,atp%PAW,l,e,atp%scalarrelativistic)
7135 : : ! IF (Vlocalindex==BESSEL) CALL besselps(atp%Grid,atp%Pot,atp%PAW)
7136 : : ! !Calculate projectors
7137 : : ! call makebasis_marsman(atp)
7138 : : ! ENDIF
7139 : : !Output in summary file
7140 [ - + ]: 2 : IF (atp%needvtau) THEN
7141 [ # # ]: 0 : if(has_to_print) WRITE(std_out,*) 'Sequence of dataset construction steps modified for mGGA'
7142 [ # # ]: 0 : if(has_to_print) WRITE(std_out,*) 'Only projectors from Vanderbilt scheme available'
7143 : : ENDIF
7144 : 2 : CALL StoreTOCCWFN(atp%PAW)
7145 : 2 : END SUBROUTINE SetPAWOptions2
7146 : :
7147 : :
7148 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7149 : : !! SUBROUTINE Troullier(Grid,Pot,PAW,l,e,needvtau,scalarrelativistic)
7150 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7151 : 2 : SUBROUTINE Troullier(Grid,Pot,PAW,l,e,needvtau,scalarrelativistic)
7152 : : TYPE(Gridinfo), INTENT(IN) :: Grid
7153 : : TYPE(Potentialinfo), INTENT(INout) :: Pot
7154 : : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
7155 : : INTEGER,INTENT(IN) :: l
7156 : : logical,intent(in) :: needvtau,scalarrelativistic
7157 : : real(dp),INTENT(IN) :: e
7158 : 2 : real(dp), ALLOCATABLE :: VNC(:)
7159 : : real(dp) :: A0,A,B,B0,C,C0,D,F,S
7160 : : real(dp) :: Coef(6),Coef0,Coef0old
7161 : : real(dp) :: h,rc,delta,x,dpp,ddpp,dddpp,ddddpp
7162 : : INTEGER :: i,n,iter,nr,nodes,irc
7163 : : INTEGER, PARAMETER :: niter=5000
7164 : : real(dp), PARAMETER :: small=tol9
7165 : 2 : real(dp), ALLOCATABLE :: wfn(:),p(:),dum(:),aux(:)
7166 : 2 : real(dp), POINTER :: r(:),rv(:)
7167 : 2 : n=Grid%n
7168 : 2 : h=Grid%h
7169 : 2 : r=>Grid%r
7170 : 2 : rv=>Pot%rv
7171 : 2 : nr=min(PAW%irc_vloc+5,n)
7172 : 2 : irc=PAW%irc_vloc
7173 : 2 : rc=PAW%rc_vloc
7174 [ + - + - : 6 : LIBPAW_ALLOCATE(VNC,(n))
+ - - + -
+ ]
7175 [ - + + - : 6 : LIBPAW_ALLOCATE(wfn,(nr))
+ - + - -
+ - + ]
7176 [ - + + - : 4 : LIBPAW_ALLOCATE(p,(nr))
- + - + ]
7177 [ - + + - : 4 : LIBPAW_ALLOCATE(dum,(nr))
- + - + ]
7178 [ - + + - : 4 : LIBPAW_ALLOCATE(aux,(nr))
- + - + ]
7179 [ + + ]: 2 : if (scalarrelativistic) then
7180 : 1 : CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes)
7181 [ - + ]: 1 : else if (needvtau) then
7182 : 0 : CALL unboundked(Grid,Pot,nr,l,e,wfn,nodes)
7183 : : else
7184 : 1 : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,nr,l,e,wfn,nodes)
7185 : : endif
7186 [ - + - - ]: 2 : IF (wfn(irc)<0) wfn=-wfn
7187 [ + + ]: 2773 : dum(1:irc)=(wfn(1:irc)**2)
7188 : 2 : S=integrator(Grid,dum(1:irc),1,irc)
7189 : 2 : A0=LOG(wfn(irc)/(rc**(l+1)))
7190 : 2 : B0=(rc*Gfirstderiv(Grid,irc,wfn)/wfn(irc)-(l+1))
7191 : 2 : C0=rc*(rv(irc)-rc*e)-B0*(B0+2*l+2)
7192 : 2 : D=-rc*(rv(irc)-rc*Gfirstderiv(Grid,irc,rv))-2*B0*C0-2*(l+1)*(C0-B0)
7193 : : F=rc*(2*rv(irc)-rc*(2*Gfirstderiv(Grid,irc,rv) &
7194 : : & -rc*Gsecondderiv(Grid,irc,rv)))+&
7195 : 2 : & 4*(l+1)*(C0-B0)-2*(l+1)*D-2*C0**2-2*B0*D
7196 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'In troullier -- matching parameters',S,A0,B0,C0,D,F
7197 : 2 : delta=1.d10
7198 : 2 : iter=0
7199 : 2 : Coef0=0
7200 [ + + - + ]: 973 : DO WHILE(delta>small.AND.iter<=niter)
7201 : 971 : iter=iter+1
7202 : 971 : A=A0-Coef0
7203 : 971 : B=B0
7204 : 971 : C=C0
7205 : 971 : CALL EvaluateTp(l,A,B,C,D,F,coef)
7206 [ + + ]: 1343969 : dum=0
7207 [ + + ]: 1339114 : DO i=1,irc
7208 : 1338143 : x=(r(i)/rc)**2
7209 : : p(i)=x*(Coef(1)+x*(Coef(2)+x*(Coef(3)+&
7210 : 1338143 : & x*(Coef(4)+x*(Coef(5)+x*Coef(6))))))
7211 : 1339114 : dum(i)=((r(i)**(l+1))*EXP(p(i)))**2
7212 : : ENDDO
7213 : 971 : Coef0old=Coef0
7214 : 971 : x=integrator(Grid,dum(1:irc),1,irc)
7215 : 971 : Coef0=(LOG(S/x))/2
7216 : 971 : delta=ABS(Coef0-Coef0old)
7217 : : ENDDO
7218 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) ' VNC converged in ', iter,' iterations'
7219 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) ' Coefficients -- ', Coef0,Coef(1:6)
7220 : : ! Now calculate VNC
7221 [ - + ]: 2 : if (needvtau) then
7222 [ # # ]: 0 : aux=0._dp
7223 : 0 : call derivative(Grid,PAW%tvtau,aux,1,nr)
7224 : : endif
7225 [ + + ]: 4004 : VNC=0
7226 [ + + ]: 2781 : DO i=2,nr
7227 : 2779 : x=(r(i)/rc)**2
7228 : : p(i)=Coef0+x*(Coef(1)+x*(Coef(2)+&
7229 : 2779 : & x*(Coef(3)+x*(Coef(4)+x*(Coef(5)+x*Coef(6))))))
7230 : : dpp=2*r(i)/(rc**2)*(Coef(1)+x*(2*Coef(2)+x*(3*Coef(3)+&
7231 : 2779 : & x*(4*Coef(4)+x*(5*Coef(5)+x*6*Coef(6))))))
7232 : : ddpp=(1/(rc**2))*(2*Coef(1)+x*(12*Coef(2)+x*(30*Coef(3)+&
7233 : 2779 : & x*(56*Coef(4)+x*(90*Coef(5)+x*132*Coef(6))))))
7234 : : dddpp=(r(i)/rc**4)*(24*Coef(2)+x*(120*Coef(3)+x*(336*Coef(4)+&
7235 : 2779 : & x*(720*Coef(5)+x*1320*Coef(6)))))
7236 : : ddddpp=(1/(rc**4)*(24*Coef(2)+x*(360*Coef(3)+x*(1680*Coef(4)+&
7237 : 2779 : & x*(5040*Coef(5)+x*11880*Coef(6))))))
7238 [ + + ]: 2779 : IF (i==irc) THEN
7239 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'check dp ', dpp, B0/rc
7240 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'check ddp ', ddpp, C0/rc**2
7241 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'check dddp', dddpp, D/rc**3
7242 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'check ddddp', ddddpp, F/rc**4
7243 : : ENDIF
7244 [ - + ]: 2779 : if (needvtau) then
7245 : : VNC(i)=e+(1._dp+PAW%tvtau(i))*(ddpp+dpp*(dpp+2*(l+1)/r(i))) &
7246 : 0 : & +aux(i)*(dpp+l/r(i))
7247 : : else
7248 : 2779 : VNC(i)=e+ddpp+dpp*(dpp+2*(l+1)/r(i))
7249 : : endif
7250 : 2781 : dum(i)=(r(i)**(l+1))*EXP(p(i))
7251 : : ENDDO
7252 : 2 : x=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7253 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) 'check norm ',x,S
7254 [ + + ]: 1235 : VNC(irc:n)=rv(irc:n)/r(irc:n)
7255 [ + + ]: 4004 : PAW%rveff(1:n)=VNC(1:n)*r(1:n)
7256 [ - + ]: 2 : LIBPAW_DEALLOCATE(VNC)
7257 : 2 : LIBPAW_DEALLOCATE(wfn)
7258 [ - + ]: 2 : LIBPAW_DEALLOCATE(p)
7259 [ - + ]: 2 : LIBPAW_DEALLOCATE(dum)
7260 [ - + ]: 2 : LIBPAW_DEALLOCATE(aux)
7261 [ - + ]: 2 : END SUBROUTINE troullier
7262 : :
7263 : :
7264 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7265 : : !! StoreTOCCWFN(PAW)
7266 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7267 : 2 : SUBROUTINE StoreTOCCWFN(PAW)
7268 : : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
7269 : : INTEGER :: io,ib
7270 [ + + ]: 14 : do io=1,PAW%TOCCWFN%norbit
7271 [ + + ]: 14 : if (PAW%valencemap(io)>0) then
7272 : 6 : ib=PAW%valencemap(io)
7273 [ + + ]: 12012 : PAW%TOCCWFN%wfn(:,io)=PAW%tphi(:,ib)
7274 : : endif
7275 : : enddo
7276 : 2 : END SUBROUTINE StoreTOCCWFN
7277 : :
7278 : :
7279 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7280 : : !! SUBROUTINE setbasis(Grid,Pot,Orbit,PAW,atp)
7281 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7282 : 2 : SUBROUTINE setbasis(Grid,Pot,Orbit,PAW,atp,potshift)
7283 : : TYPE(GridInfo), INTENT(IN) :: Grid
7284 : : real(dp), intent(in) :: potshift
7285 : : TYPE(PotentialInfo), INTENT(INout) :: Pot
7286 : : TYPE(OrbitInfo), INTENT(INOUT) :: Orbit
7287 : : TYPE(PseudoInfo), intent(inout) :: PAW
7288 : : TYPE(atompaw_type), intent(in) :: atp
7289 : : INTEGER :: n,irc,nbase,l,lmax,mxbase,currentnode
7290 : : INTEGER :: i,k,io,nbl,nr,nodes,ibasis_add
7291 : : real(dp) :: h,rc,energy,rat,range
7292 : 2 : real(dp),allocatable :: checkden(:),valden(:)
7293 : 2 : real(dp), POINTER :: r(:)
7294 : 2 : n=Grid%n
7295 : 2 : h=Grid%h
7296 : 2 : r=>Grid%r
7297 : 2 : irc=PAW%irc
7298 : 2 : nr=MIN(irc+100,n-100)
7299 : 2 : rc=PAW%rc
7300 : 2 : lmax=PAW%lmax
7301 [ + - + - : 6 : LIBPAW_ALLOCATE(checkden,(n))
+ - - + -
+ ]
7302 [ - + + - : 4 : LIBPAW_ALLOCATE(valden,(n))
- + - + ]
7303 [ + + + + ]: 8006 : checkden=0._dp;valden=0._dp
7304 : : !Check beginning valence density
7305 [ + + ]: 14 : DO io=1,Orbit%norbit
7306 [ + + ]: 14 : if (.not.Orbit%iscore(io)) then
7307 [ - + + + ]: 12018 : valden=valden+Orbit%occ(io)*(Orbit%wfn(:,io)**2)
7308 : : endif
7309 : : ENDDO
7310 : : ! set AErefrv
7311 [ + + ]: 4004 : PAW%AErefrv=Pot%rv
7312 [ + + ]: 4004 : PAW%rvx=Pot%rvx
7313 : 2 : PAW%exctype=Orbit%exctype
7314 : 2 : nbase=PAW%nbase
7315 : 2 : mxbase=PAW%mxbase
7316 : : ! "filter" occupied states for long-range noise
7317 [ + + ]: 14 : DO io=1,Orbit%norbit
7318 : 14 : Call Filter(n,Orbit%wfn(:,io),machine_zero)
7319 : : ENDDO
7320 : 2 : call CopyOrbit(Orbit,PAW%OCCwfn)
7321 : 2 : call CopyOrbit(Orbit,PAW%TOCCwfn)
7322 [ + + ]: 14 : PAW%valencemap=-13
7323 [ - + ]: 2 : IF (Orbit%exctype=='HF') THEN
7324 : 0 : range=r(n)
7325 : 0 : rat=-1.d30; k=1
7326 [ # # ]: 0 : do io=1,Orbit%norbit
7327 [ # # # # ]: 0 : if ((Orbit%occ(io)>tol5).and.Orbit%eig(io)>rat) then
7328 : 0 : rat=Orbit%eig(io)
7329 : 0 : k=io
7330 : : endif
7331 : : enddo
7332 [ # # ]: 0 : do i=n,irc+1,-1
7333 [ # # ]: 0 : if (ABS(Orbit%wfn(i,k))>tol4) then
7334 : 0 : range=r(i)
7335 : 0 : exit
7336 : : endif
7337 : : enddo
7338 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'range ', k,range!; call flush_unit(std_out)
7339 : : ENDIF
7340 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*) ' basis functions:'
7341 [ - + ]: 2 : if(has_to_print) WRITE(STD_OUT,*)' No. n l energy occ '
7342 : 2 : nbase=0 ; ibasis_add=1
7343 [ + + ]: 9 : DO l=0,lmax
7344 : 7 : currentnode=-1
7345 : 7 : nbl=0
7346 [ + + ]: 48 : DO io=1,Orbit%norbit ! cycle through all configuration
7347 [ + + ]: 48 : IF (Orbit%l(io).EQ.l) THEN
7348 : 12 : currentnode=Orbit%np(io)-l-1
7349 [ + + ]: 12 : IF (.NOT.Orbit%iscore(io)) THEN
7350 : 6 : nbl=nbl+1
7351 : 6 : nbase=nbase+1
7352 : 6 : PAW%np(nbase)=Orbit%np(io)
7353 : 6 : PAW%l(nbase)=l
7354 : 6 : PAW%nodes(nbase)=PAW%np(nbase)-l-1
7355 [ - + ]: 6 : if(has_to_print) write(std_out,*) 'l,nbase,node',l,nbase,currentnode
7356 : 6 : PAW%eig(nbase)=Orbit%eig(io)
7357 [ + + ]: 6 : if(Orbit%issemicore(io)) PAW%eig(nbase)=PAW%eig(nbase)-potshift
7358 : 6 : PAW%occ(nbase)=Orbit%occ(io)
7359 [ + - + + ]: 6 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%issemicore(io))) then
7360 : 4 : energy=PAW%eig(nbase)
7361 [ + + ]: 8008 : Orbit%wfn(:,io)=zero
7362 [ + + ]: 4 : if (Orbit%scalarrelativistic) then
7363 : 2 : CALL unboundsr(Grid,Pot,n,l,energy,Orbit%wfn(:,io),nodes)
7364 : : else
7365 : : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,&
7366 : 2 : & nr,l,energy,Orbit%wfn(:,io),nodes)
7367 : : endif
7368 : : endif
7369 [ + + ]: 12012 : PAW%phi(:,nbase)=Orbit%wfn(:,io)
7370 [ - + ]: 6 : if(Orbit%diracrelativistic) then
7371 : 0 : STOP 'Error -- setbasis subroutine not ready for diracrelativistic!'
7372 : : endif
7373 : 6 : PAW%valencemap(io)=nbase
7374 [ - + ]: 6 : if(has_to_print) WRITE(STD_OUT,'(3i6,1p,2e15.6)') nbase,PAW%np(nbase),l,&
7375 : 0 : & PAW%eig(nbase),PAW%occ(nbase)!; call flush_unit(std_out)
7376 : : ENDIF
7377 : : ENDIF
7378 : : ENDDO
7379 : 2 : generalizedloop: DO
7380 [ + + ]: 19 : IF (ibasis_add>atp%nbasis_add) EXIT generalizedloop
7381 [ + + ]: 17 : IF (atp%basis_add_l(ibasis_add)/=l) EXIT generalizedloop
7382 : 12 : energy=atp%basis_add_energy(ibasis_add)
7383 [ - + - - ]: 12 : IF (energy<0._dp.and.has_to_print) then
7384 : 0 : WRITE(STD_OUT,*) 'energy is negative',energy,' -- WARNING WARNING !!!'
7385 : : endif
7386 : 12 : nbase=nbase+1
7387 [ - + ]: 12 : IF (nbase > mxbase ) THEN
7388 : 0 : LIBPAW_ERROR('Error in setbasis -- too many functions ')
7389 : : ENDIF
7390 : 12 : PAW%l(nbase)=l
7391 : 12 : PAW%np(nbase)=999
7392 : 12 : PAW%nodes(nbase)=currentnode+1
7393 : 12 : currentnode=PAW%nodes(nbase)
7394 [ - + ]: 12 : if(has_to_print) write(std_out,*) 'l,nbase,node',l,nbase,currentnode
7395 : 12 : PAW%eig(nbase)=energy
7396 : 12 : PAW%occ(nbase)=0._dp
7397 [ + + ]: 24024 : PAW%phi(1:n,nbase)=0._dp
7398 [ + + ]: 12 : if (Orbit%scalarrelativistic) then
7399 : 2 : CALL unboundsr(Grid,Pot,n,l,energy,PAW%phi(:,nbase),nodes)
7400 [ - + ]: 10 : else if (Pot%needvtau) then
7401 : 0 : CALL unboundked(Grid,Pot,n,l,energy,PAW%phi(:,nbase),nodes)
7402 : : else
7403 : : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,&
7404 : 10 : & nr,l,energy,PAW%phi(:,nbase),nodes)
7405 : : endif
7406 : 12 : rat=MAX(ABS(PAW%phi(irc,nbase)),ABS(PAW%phi(irc+1,nbase)))
7407 : 12 : rat=DSIGN(rat,PAW%phi(irc,nbase))
7408 [ + + ]: 24024 : PAW%phi(1:n,nbase)=PAW%phi(1:n,nbase)/rat
7409 [ - + - - : 12 : if(has_to_print) write(std_out,*) 'MAX PHI=',nbase,maxval(PAW%phi(:,nbase))
- - - - -
- ]
7410 [ - + ]: 12 : if(has_to_print) then
7411 : 0 : WRITE(STD_OUT,'(3i6,1p,2e15.6)') nbase,PAW%np(nbase),l, &
7412 : 0 : & PAW%eig(nbase),PAW%occ(nbase)
7413 : : endif
7414 : 12 : nbl=nbl+1
7415 : 17 : ibasis_add=ibasis_add+1
7416 : : ENDDO generalizedloop
7417 : : ENDDO ! end lmax loop
7418 [ - + ]: 2 : if(has_to_print) WRITE(std_out,*) 'completed phi basis with ',nbase,' functions '
7419 : 2 : PAW%nbase=nbase ! reset nbase
7420 [ - + ]: 2 : LIBPAW_DEALLOCATE(checkden)
7421 [ - + ]: 2 : LIBPAW_DEALLOCATE(valden)
7422 [ - + ]: 2 : END SUBROUTINE setbasis
7423 : :
7424 : :
7425 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7426 : : !! SUBROUTINE smoothcore(Grid,orig,PAW)
7427 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7428 [ - + ]: 18 : SUBROUTINE smoothcore(Grid,orig,PAW)
7429 : : TYPE(GridInfo), INTENT(IN) :: Grid
7430 : : real(dp), INTENT(IN) :: orig(:)
7431 : : type(pseudoInfo), intent(inout) :: PAW
7432 : : real(dp) :: rc,h,x,y,z,u0,u2,u4
7433 : 18 : real(dp), allocatable :: d1(:),d2(:)
7434 : : INTEGER :: i,n,irc
7435 : 18 : n=Grid%n
7436 : 18 : h=Grid%h
7437 : 18 : irc=PAW%irc_core
7438 : 18 : rc=PAW%rc_core
7439 [ - + ]: 18 : if(has_to_print) write(std_out,*) 'In smoothcore ', irc,rc
7440 [ - + + - : 54 : LIBPAW_ALLOCATE(d1,(n))
+ - + - -
+ - + ]
7441 [ - + + - : 36 : LIBPAW_ALLOCATE(d2,(n))
- + - + ]
7442 : 18 : CALL derivative(Grid,orig,d1)
7443 : 18 : CALL derivative(Grid,d1,d2)
7444 : 18 : x=orig(irc)
7445 : 18 : y=d1(irc)*rc
7446 : 18 : z=d2(irc)*(rc*rc)
7447 [ - + ]: 18 : if(has_to_print) write(std_out,*) 'smoothcore: x,y,z = ', x,y,z
7448 : 18 : u0=3*x - 9*y/8 + z/8
7449 : 18 : u2=-3*x + 7*y/4 - z/4
7450 : 18 : u4=x - 5*y/8 + z/8
7451 [ - + ]: 18 : if(has_to_print) write(std_out,*) 'smoothcore: u0,u2,u4 = ', u0,u2,u4
7452 [ + + ]: 36036 : PAW%tcore=orig
7453 [ + + ]: 24282 : do i=1,irc
7454 : 24264 : x=(Grid%r(i)/rc)**2
7455 : 24282 : PAW%tcore(i)= x*(u0+x*(u2+x*u4))
7456 : : enddo
7457 : 18 : LIBPAW_DEALLOCATE(d1)
7458 : 18 : LIBPAW_DEALLOCATE(d2)
7459 : 18 : END SUBROUTINE smoothcore
7460 : :
7461 : :
7462 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7463 : : !! SUBROUTINE smoothpower
7464 : : !! program to take array orig (all electron tau or den)
7465 : : !! and return smooth polynomial function for 0 \le r \le rc_core
7466 : : !! matching 4 points less than and equal to rc_core
7467 : : !! power could be 2 or 4, representing the leading power
7468 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7469 [ # # # # ]: 0 : SUBROUTINE smoothpower(Grid,power,orig,smooth,PAW)
7470 : : TYPE(GridInfo), INTENT(IN) :: Grid
7471 : : type(pseudoInfo), intent(in) :: PAW
7472 : : INTEGER, INTENT(IN) :: power
7473 : : REAL(dp), INTENT(IN) :: orig(:)
7474 : : REAL(dp), INTENT(INOUT) :: smooth(:)
7475 : : INTEGER, parameter :: terms=5
7476 : : REAL(dp) :: rc,h,x
7477 : : REAL(dp) :: aa(terms,terms),Ci(terms)
7478 : : INTEGER :: i,j,n,irc
7479 : 0 : n=Grid%n
7480 : 0 : h=Grid%h
7481 : 0 : irc=PAW%irc_core
7482 : 0 : rc=Grid%r(irc)
7483 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'smoothpower -- ', power,irc,rc
7484 : 0 : aa=zero; Ci=zero
7485 [ # # ]: 0 : do i=1,terms
7486 : 0 : x=Grid%r(irc-terms+i)
7487 : 0 : Ci(i)=orig(irc-terms+i)/x**power
7488 [ # # ]: 0 : do j=1,terms
7489 : 0 : aa(i,j)=x**(2*(j-1))
7490 : : enddo
7491 : : enddo
7492 : 0 : call SolveAXeqBM(terms,aa,Ci,terms-1)
7493 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'Completed SolveAXeqB with coefficients'
7494 [ # # ]: 0 : if(has_to_print) write(std_out,'(1p,10e15.7)') (Ci(i),i=1,terms)
7495 [ # # ]: 0 : smooth=orig
7496 [ # # ]: 0 : do i=1,irc-1
7497 : 0 : smooth(i)=0
7498 : 0 : x=Grid%r(i)
7499 [ # # ]: 0 : do j=1,terms
7500 : 0 : smooth(i)=smooth(i)+Ci(j)*(x**(power+2*(j-1)))
7501 : : enddo
7502 : : enddo
7503 : 0 : END SUBROUTINE smoothpower
7504 : :
7505 : :
7506 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7507 : : !! SUBROUTINE setcoretail(Grid,coreden,PAW)
7508 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7509 [ - + ]: 18 : SUBROUTINE setcoretail(Grid,coreden,PAW,needvtau)
7510 : : logical,intent(in) :: needvtau
7511 : : TYPE(GridInfo), INTENT(IN) :: Grid
7512 : : real(dp), INTENT(IN) :: coreden(:)
7513 : : type(pseudoInfo), intent(inout) :: PAW
7514 : : real(dp) :: rc,h,z
7515 : : INTEGER :: i,n,irc
7516 : 18 : n=Grid%n
7517 : 18 : h=Grid%h
7518 : 18 : irc=PAW%irc_core
7519 : 18 : rc=PAW%rc_core
7520 [ + - ]: 18 : If(.not.needvtau) then
7521 : 18 : CALL smoothcore(Grid,coreden,PAW)
7522 : : else
7523 : 0 : CALL smoothpower(Grid,2,coreden,PAW%tcore,PAW)
7524 : : endif
7525 [ + + ]: 36036 : PAW%core=coreden
7526 : : ! Find coretailpoints
7527 : 18 : z = integrator(Grid,coreden)
7528 : 18 : PAW%coretailpoints=PAW%irc+Grid%ishift !! coretailpoints should be>=PAW%irc
7529 [ + - ]: 1471 : do i=PAW%irc+Grid%ishift,n
7530 [ + + ]: 1471 : if(ABS(z-integrator(Grid,coreden,1,i))<coretailtol) then
7531 : 18 : PAW%coretailpoints=i
7532 : 18 : exit
7533 : : endif
7534 : : enddo
7535 [ - + ]: 18 : if(has_to_print) write(std_out,*) 'coretailpoints = ',PAW%coretailpoints
7536 : 18 : END SUBROUTINE setcoretail
7537 : :
7538 : :
7539 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7540 : : !! SUBROUTINE nonncps(lmax,Grid,Pot)
7541 : : !! Creates screened pseudopotential by inverting Schroedinger
7542 : : !! equation from a pseudized radial wave function of the form:
7543 : : !! Psi(r) = r**(l+1) * exp (a + b*r**2 + c*r**4 + d*r**6)
7544 : : !! No norm-conserving condition is imposed on Psi
7545 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7546 : 0 : SUBROUTINE nonncps(Grid,Pot,PAW,l,e,scalarrelativistic)
7547 : : logical, intent(in) :: scalarrelativistic
7548 : : TYPE(Gridinfo), INTENT(IN) :: Grid
7549 : : TYPE(Potentialinfo), INTENT(INout) :: Pot
7550 : : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
7551 : : INTEGER,INTENT(IN) :: l
7552 : : REAL(dp),INTENT(IN) :: e
7553 : : INTEGER :: i,irc,n,nr,nodes,i1,i2,i3,i4
7554 : : REAL(dp) :: rc,x,y1,y2,y3,p0,p1,p2,p3,sgn
7555 : : REAL(dp) :: b(4),c(4),d(4),amat(4,4)
7556 : 0 : REAL(dp),ALLOCATABLE :: VNC(:),wfn(:),aux(:)
7557 : 0 : REAL(dp),POINTER :: r(:),rv(:)
7558 : : !Polynomial definitions
7559 : : p0(x,y1,y2,y3)=(x-y1)*(x-y2)*(x-y3)
7560 : : p1(x,y1,y2,y3)=(x-y2)*(x-y3)+(x-y1)*(x-y3)+(x-y1)*(x-y2)
7561 : : p2(x,y1,y2,y3)=two*((x-y1)+(x-y2)+(x-y3))
7562 : : p3(x,y1,y2,y3)=six
7563 : 0 : n=Grid%n
7564 : 0 : r=>Grid%r
7565 : 0 : rv=>Pot%rv
7566 : 0 : nr=min(PAW%irc_vloc+10,n)
7567 : 0 : irc=PAW%irc_vloc
7568 : 0 : rc=PAW%rc_vloc
7569 [ # # # # : 0 : LIBPAW_ALLOCATE(VNC,(n))
# # # # #
# ]
7570 [ # # # # : 0 : LIBPAW_ALLOCATE(wfn,(nr))
# # # # #
# # # ]
7571 [ # # # # : 0 : LIBPAW_ALLOCATE(aux,(nr))
# # # # ]
7572 [ # # ]: 0 : if (scalarrelativistic) then
7573 : 0 : CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes)
7574 [ # # ]: 0 : else if (Pot%needvtau) then
7575 : 0 : CALL unboundked(Grid,Pot,nr,l,e,wfn,nodes)
7576 : : else
7577 : 0 : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,nr,l,e,wfn,nodes)
7578 : : endif
7579 [ # # # # ]: 0 : IF (wfn(irc)<0) wfn=-wfn
7580 [ # # ]: 0 : DO i=2,nr
7581 : 0 : wfn(i)=wfn(i)/r(i)**dble(l+1)
7582 : : ENDDO
7583 : 0 : i1=irc-1;i2=i1+1;i3=i2+1;i4=i3+1
7584 : 0 : c(1)=wfn(i1)/p0(r(i1),r(i2),r(i3),r(i4))
7585 : 0 : c(2)=wfn(i2)/p0(r(i2),r(i3),r(i4),r(i1))
7586 : 0 : c(3)=wfn(i3)/p0(r(i3),r(i4),r(i1),r(i2))
7587 : 0 : c(4)=wfn(i4)/p0(r(i4),r(i1),r(i2),r(i3))
7588 : : d(1)=c(1)*p0(rc,r(i2),r(i3),r(i4)) + c(2)*p0(rc,r(i3),r(i4),r(i1)) + &
7589 : 0 : & c(3)*p0(rc,r(i4),r(i1),r(i2)) + c(4)*p0(rc,r(i1),r(i2),r(i3))
7590 : : d(2)=c(1)*p1(rc,r(i2),r(i3),r(i4)) + c(2)*p1(rc,r(i3),r(i4),r(i1)) + &
7591 : 0 : & c(3)*p1(rc,r(i4),r(i1),r(i2)) + c(4)*p1(rc,r(i1),r(i2),r(i3))
7592 : : d(3)=c(1)*p2(rc,r(i2),r(i3),r(i4)) + c(2)*p2(rc,r(i3),r(i4),r(i1)) + &
7593 : 0 : & c(3)*p2(rc,r(i4),r(i1),r(i2)) + c(4)*p2(rc,r(i1),r(i2),r(i3))
7594 : : d(4)=c(1)*p3(rc,r(i2),r(i3),r(i4)) + c(2)*p3(rc,r(i3),r(i4),r(i1)) + &
7595 : 0 : & c(3)*p3(rc,r(i4),r(i1),r(i2)) + c(4)*p3(rc,r(i1),r(i2),r(i3))
7596 [ # # ]: 0 : sgn=d(1)/abs(d(1));d(1:4)=d(1:4)*sgn
7597 [ # # ]: 0 : b(1)=log(d(1));b(2:4)=d(2:4)
7598 : 0 : amat(1,1)= 1.0_dp
7599 [ # # ]: 0 : amat(2:4,1)= 0.0_dp
7600 : 0 : amat(1,2)= rc**2
7601 : 0 : amat(2,2)= 2.0_dp*d(1)*rc
7602 : 0 : amat(3,2)= 2.0_dp*d(1) +2.0_dp*d(2)*rc
7603 : 0 : amat(4,2)= 4.0_dp*d(2) +2.0_dp*d(3)*rc
7604 : 0 : amat(1,3)= rc**4
7605 : 0 : amat(2,3)= 4.0_dp*d(1)*rc**3
7606 : 0 : amat(3,3)= 12.0_dp*d(1)*rc**2+ 4.0_dp*d(2)*rc**3
7607 : 0 : amat(4,3)= 24.0_dp*d(1)*rc +24.0_dp*d(2)*rc**2+4.0_dp*d(3)*rc**3
7608 : 0 : amat(1,4)= rc**6
7609 : 0 : amat(2,4)= 6.0_dp*d(1)*rc**5
7610 : 0 : amat(3,4)= 30.0_dp*d(1)*rc**4+ 6.0_dp*d(2)*rc**5
7611 : 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
7612 : 0 : CALL linsol(amat,b,4,4,4,4)
7613 [ # # ]: 0 : if (Pot%needvtau) then
7614 [ # # ]: 0 : aux=zero
7615 : 0 : call derivative(Grid,PAW%tvtau,aux,1,nr)
7616 : : endif
7617 : 0 : PAW%rveff(1)=0._dp
7618 [ # # ]: 0 : DO i=2,irc-1
7619 : 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
7620 : 0 : c(2)=2.0_dp*b(2) +12.0_dp*b(3)*r(i)**2+30.0_dp*b(4)*r(i)**4
7621 [ # # ]: 0 : if (pot%needvtau) then
7622 : : PAW%rveff(i)=r(i)*(e+(dble(2*l+2)*c(1)/r(i)+c(1)**2+&
7623 : 0 : & c(2))*(1._dp+PAW%tvtau(i))+aux(i)*(c(1)+dble(l)/r(i)))
7624 : : else
7625 : 0 : PAW%rveff(i)=r(i)*(e+dble(2*l+2)*c(1)/r(i)+c(1)**2+c(2))
7626 : : endif
7627 : : ENDDO
7628 [ # # ]: 0 : PAW%rveff(irc:n)=rv(irc:n)
7629 [ # # ]: 0 : LIBPAW_DEALLOCATE(VNC)
7630 : 0 : LIBPAW_DEALLOCATE(wfn)
7631 [ # # ]: 0 : LIBPAW_DEALLOCATE(aux)
7632 [ # # ]: 0 : END SUBROUTINE nonncps
7633 : :
7634 : :
7635 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7636 : : ! SUBROUTINE VPSmatch(lmax,Grid,Pot,NC)
7637 : : ! Creates screened norm-conserving pseudopotential similar to the
7638 : : ! approach of N. Troullier and J. L. Martins, PRB 43, 1993 (1991)
7639 : : ! Uses p(r)=a0+f(r); f(r)=SUMm(Coef(m)*r^(2*m), where
7640 : : ! m=1,2..6
7641 : : ! Psi(r) = r^(l+1)*exp(p(r))
7642 : : ! Modified for MGGA case and norm conserving condition is optional
7643 : : ! norm conservation controlled with optional variable NC
7644 : : ! defaults to no norm conservation
7645 : : ! Note this program assumes that wfn keeps the same sign for
7646 : : ! all matching points r(irc-match+1)....r(irc)
7647 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7648 : : SUBROUTINE VPSmatch(Grid,Pot,PAW,l,e,NC,scalarrelativistic)
7649 : : logical,intent(in) :: scalarrelativistic
7650 : : TYPE(Gridinfo), INTENT(IN) :: Grid
7651 : : TYPE(Potentialinfo), INTENT(INout) :: Pot
7652 : : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
7653 : : INTEGER,INTENT(IN) :: l
7654 : : REAL(dp),INTENT(IN) :: e
7655 : : LOGICAL,INTENT(IN), OPTIONAL :: NC
7656 : : REAL(dp), ALLOCATABLE :: VNC(:)
7657 : : REAL(dp) :: C0,S
7658 : : REAL(dp) :: Coef0,Coef0old
7659 : : REAL(dp) :: h,rc,delta,x
7660 : : INTEGER :: i,j,n,iter,nr,nodes,irc
7661 : : INTEGER, parameter :: match=6
7662 : : REAL(dp) :: AAA(match,match),BBB(match)
7663 : : REAL(dp) :: AAAA(match-1,match-1),BBBB(match-1)
7664 : : INTEGER, PARAMETER :: niter=5000
7665 : : REAL(dp), PARAMETER :: small=1.0d-9
7666 : : REAL(dp), ALLOCATABLE :: wfn(:),p(:),dum(:),aux(:),Kaux(:),v(:),dp1(:),ddp(:)
7667 : : REAL(dp), POINTER :: r(:),rv(:)
7668 : : LOGICAL :: normcons
7669 : : normcons=.false.
7670 : : if(PRESENT(NC)) normcons=NC
7671 : : if(has_to_print) write(std_out,*) 'Entering VPSmatch with normcons ', normcons
7672 : : n=Grid%n
7673 : : h=Grid%h
7674 : : r=>Grid%r
7675 : : rv=>Pot%rv
7676 : : nr=min(PAW%irc_vloc+10,n)
7677 : : irc=PAW%irc_vloc
7678 : : rc=PAW%rc_vloc
7679 : : LIBPAW_ALLOCATE(VNC,(n))
7680 : : LIBPAW_ALLOCATE(wfn,(n))
7681 : : LIBPAW_ALLOCATE(p,(n))
7682 : : LIBPAW_ALLOCATE(dum,(n))
7683 : : LIBPAW_ALLOCATE(aux,(n))
7684 : : LIBPAW_ALLOCATE(dp1,(n))
7685 : : LIBPAW_ALLOCATE(ddp,(n))
7686 : : LIBPAW_ALLOCATE(Kaux,(n))
7687 : : LIBPAW_ALLOCATE(v,(n))
7688 : : wfn=zero
7689 : : if (scalarrelativistic) then
7690 : : CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes)
7691 : : else if (Pot%needvtau) then
7692 : : CALL unboundked(Grid,Pot,nr,l,e,wfn,nodes)
7693 : : else
7694 : : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,nr,l,e,wfn,nodes)
7695 : : endif
7696 : : IF (wfn(irc)<0) wfn=-wfn
7697 : : ! first solve non-norm conserving results
7698 : : AAA=zero;BBB=zero
7699 : : Do i=1,match
7700 : : x=r(irc-match+i)
7701 : : BBB(i)=log(wfn(irc-match+i)/(x**(l+1)))
7702 : : do j=1,match
7703 : : AAA(i,j)=x**(2*(j-1))
7704 : : enddo
7705 : : Enddo
7706 : : CALL SolveAXeqB(match,AAA,BBB,1.d20)
7707 : : if(has_to_print) write(std_out,*) 'Returned from SolveAXeqB in VPSmatch with Coefficients '
7708 : : if(has_to_print) write(std_out,'(1p,50e16.7)') (BBB(i),i=1,match)
7709 : : ! Now calculate VNC
7710 : : if (Pot%needvtau) then
7711 : : aux=0._dp
7712 : : call derivative(Grid,PAW%tvtau,aux,1,nr)
7713 : : Kaux=0._dp
7714 : : call derivative(Grid,PAW%Ktvtau,Kaux,1,nr) ! Kresse form
7715 : : endif
7716 : : VNC=zero;p=zero;dp1=zero;ddp=zero;dum=zero
7717 : : !specific for match=6
7718 : : DO i=2,nr
7719 : : x=(r(i))**2
7720 : : p(i)=BBB(1)+x*(BBB(2)+x*(BBB(3)+x*(BBB(4)+x*(BBB(5)+x*BBB(6)))))
7721 : : dp1(i)=two*r(i)*(BBB(2)+x*(two*BBB(3)+x*(three*BBB(4)+x*(four*BBB(5)+five*x*BBB(6)))))
7722 : : 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)))))
7723 : : if (Pot%needvtau) then
7724 : : VNC(i)=e+(1._dp+PAW%tvtau(i))*(ddp(i)+ &
7725 : : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7726 : : & +aux(i)*(dp1(i)+l/r(i))
7727 : : v(i)=e+(1._dp+PAW%Ktvtau(i))*(ddp(i)+ &
7728 : : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7729 : : & +Kaux(i)*(dp1(i)+l/r(i))
7730 : : else
7731 : : VNC(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7732 : : v(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7733 : : endif
7734 : : dum(i)=(r(i)**(l+1))*EXP(p(i))
7735 : : ENDDO
7736 : : S=overlap(Grid,wfn(1:irc),wfn(1:irc),1,irc)
7737 : : C0=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7738 : : if(has_to_print) WRITE(STD_OUT,*) 'check norm ',C0,S
7739 : : VNC(irc:n)=rv(irc:n)/r(irc:n)
7740 : : v(irc:n)=rv(irc:n)/r(irc:n)
7741 : : PAW%rveff(1:n)=VNC(1:n)*r(1:n)
7742 : : PAW%Krveff(1:n)=v(1:n)*r(1:n)
7743 : : if(has_to_print) write(std_out,*) 'Completed non-norm-conserving PS '
7744 : : if(.not.normcons) return
7745 : : ! Iterate to find norm conserving results
7746 : : C0=C0/(EXP(2*BBB(1)))
7747 : : delta=1.d10
7748 : : iter=zero
7749 : : Coef0=0.5_dp*log(S/C0)
7750 : : DO WHILE(delta>small.AND.iter<=niter)
7751 : : Coef0old=Coef0
7752 : : iter=iter+1
7753 : : AAAA=zero;BBBB=zero
7754 : : Do i=1,match-1
7755 : : x=r(irc-match+1+i)
7756 : : BBBB(i)=log(wfn(irc-match+1+i)/(x**(l+1)))-Coef0old
7757 : : do j=1,match-1
7758 : : AAAA(i,j)=x**(2*(j))
7759 : : enddo
7760 : : Enddo
7761 : : CALL SolveAXeqB(match-1,AAAA,BBBB,1.d20)
7762 : : if(has_to_print) write(std_out,*) 'Returned from SolveAXeqB in VPSmatch with Coefficients'
7763 : : if(has_to_print) write(std_out,'(1p,50e16.7)') (BBBB(i),i=1,match-1)
7764 : : !specific for match-1=5
7765 : : p=zero;dum=zero
7766 : : DO i=2,nr
7767 : : x=(r(i))**2
7768 : : p(i)=x*(BBBB(1)+x*(BBBB(2)+x*(BBBB(3)+x*(BBBB(4)+x*BBBB(5)))))
7769 : : dum(i)=(r(i)**(l+1))*EXP(Coef0+p(i))
7770 : : ENDDO
7771 : : C0=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7772 : : if(has_to_print) WRITE(std_out,*) 'check norm ',C0,S
7773 : : Coef0=0.5_dp*log(S/C0)
7774 : : delta=ABS(Coef0-Coef0old)
7775 : : if(has_to_print) WRITE(std_out,'(" VNC: iter Coef0 delta",i5,1p,2e15.7)') iter,Coef0,delta
7776 : : ENDDO
7777 : : if(has_to_print) WRITE(std_out,*) ' VNC converged in ', iter,' iterations'
7778 : : if(has_to_print) WRITE(std_out,*) ' Coefficients -- ', Coef0,BBBB(1:match-1)
7779 : : ! Now calculate VNC
7780 : : if (Pot%needvtau) then
7781 : : aux=0._dp
7782 : : call derivative(Grid,PAW%tvtau,aux,1,nr)
7783 : : Kaux=0._dp
7784 : : call derivative(Grid,PAW%Ktvtau,Kaux,1,nr)
7785 : : endif
7786 : : VNC=zero;p=zero;dp1=zero;ddp=zero;v=zero
7787 : : DO i=2,nr
7788 : : x=(r(i))**2
7789 : : p(i)=x*(BBBB(1)+x*(BBBB(2)+x*(BBBB(3)+x*(BBBB(4)+x*BBBB(5)))))
7790 : : dp1(i)=two*r(i)*(BBBB(1)+x*(two*BBBB(2)+x*(three*BBBB(3)+x*(four*BBBB(4)+five*x*BBBB(5)))))
7791 : : 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)))))
7792 : : if (Pot%needvtau) then
7793 : : VNC(i)=e+(1._dp+PAW%tvtau(i))*(ddp(i)+ &
7794 : : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7795 : : & +aux(i)*(dp1(i)+l/r(i))
7796 : : v(i)=e+(1._dp+PAW%Ktvtau(i))*(ddp(i)+ &
7797 : : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7798 : : & +Kaux(i)*(dp1(i)+l/r(i))
7799 : : else
7800 : : VNC(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7801 : : v(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7802 : : endif
7803 : : dum(i)=(r(i)**(l+1))*EXP(Coef0+p(i))
7804 : : ENDDO
7805 : : C0=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7806 : : if(has_to_print) WRITE(std_out,*) 'check norm ',C0,S
7807 : : VNC(irc:n)=rv(irc:n)/r(irc:n)
7808 : : v(irc:n)=rv(irc:n)/r(irc:n)
7809 : : PAW%rveff(1:n)=VNC(1:n)*r(1:n)
7810 : : PAW%Krveff(1:n)=v(1:n)*r(1:n)
7811 : : if(has_to_print)write(std_out,*) 'Completed norm-conserving PS '
7812 : : if (iter.ge.niter) then
7813 : : write(std_out,*) 'Failed to converged norm-conserving VPS '
7814 : : stop
7815 : : endif
7816 : : LIBPAW_DEALLOCATE(VNC)
7817 : : LIBPAW_DEALLOCATE(wfn)
7818 : : LIBPAW_DEALLOCATE(p)
7819 : : LIBPAW_DEALLOCATE(dp1)
7820 : : LIBPAW_DEALLOCATE(ddp)
7821 : : LIBPAW_DEALLOCATE(dum)
7822 : : LIBPAW_DEALLOCATE(aux)
7823 : : LIBPAW_DEALLOCATE(Kaux)
7824 : : LIBPAW_DEALLOCATE(v)
7825 : : END SUBROUTINE VPSmatch
7826 : :
7827 : :
7828 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7829 : : ! calculate_tvtau for MGGA case
7830 : : ! Assume valence pseudo wavefunctions known
7831 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7832 : : SUBROUTINE calculate_tvtau(Grid,PAW,itype)
7833 : : TYPE(GridInfo), INTENT(IN) :: Grid
7834 : : type(pseudoInfo),intent(inout) :: PAW
7835 : : integer,intent(in) :: itype
7836 : : INTEGER :: i
7837 : : REAL(dp), allocatable :: dp1(:),ddp(:),vxc(:),tvxc(:),locald(:),localtd(:)
7838 : : REAL(dp), allocatable :: Ktvxc(:),Kd(:)
7839 : : REAL(dp) :: exc,texc,sum,tsum
7840 : : REAL(dp), parameter :: small=1.d-5
7841 : : LIBPAW_ALLOCATE(dp1,(Grid%n))
7842 : : LIBPAW_ALLOCATE(ddp,(Grid%n))
7843 : : LIBPAW_ALLOCATE(vxc,(Grid%n))
7844 : : LIBPAW_ALLOCATE(tvxc,(Grid%n))
7845 : : LIBPAW_ALLOCATE(locald,(Grid%n))
7846 : : LIBPAW_ALLOCATE(localtd,(Grid%n))
7847 : : LIBPAW_ALLOCATE(Ktvxc,(Grid%n))
7848 : : LIBPAW_ALLOCATE(Kd,(Grid%n))
7849 : : locald=PAW%core
7850 : : localtd=PAW%tcore
7851 : : PAW%valetau=0._dp
7852 : : PAW%tvaletau=0._dp
7853 : : do i=1,PAW%nbase
7854 : : if(has_to_print) write(std_out,*) 'tvtau -- ', i,PAW%l(i),PAW%occ(i),PAW%eig(i)
7855 : : if (PAW%occ(i).gt.small) then
7856 : : locald=locald+PAW%occ(i)*(PAW%phi(:,i)**2)
7857 : : localtd=localtd+PAW%occ(i)*(PAW%tphi(:,i)**2)
7858 : : CALL taufromwfn(dp1,Grid,PAW%phi(:,i),PAW%l(i))
7859 : : CALL taufromwfn(ddp,Grid,PAW%tphi(:,i),PAW%l(i))
7860 : : PAW%valetau=PAW%valetau+PAW%occ(i)*dp1
7861 : : PAW%tvaletau=PAW%tvaletau+PAW%occ(i)*ddp
7862 : : endif
7863 : : enddo
7864 : : dp1=PAW%coretau+PAW%valetau
7865 : : ddp=PAW%tcoretau+PAW%tvaletau
7866 : : CALL exch(Grid,locald,vxc,sum,exc,itype,&
7867 : : & tau=dp1,vtau=PAW%vtau)
7868 : : CALL exch(Grid,localtd,tvxc,tsum,texc,itype,&
7869 : : & tau=ddp,vtau=PAW%tvtau)
7870 : : if(has_to_print) write(std_out,*) 'tvtau exc texc ', exc, texc
7871 : : ! Kresse form
7872 : : Kd=locald-PAW%core-localtd+PAW%tcore
7873 : : sum=integrator(Grid,Kd)
7874 : : if(has_to_print) write(std_out,*) 'compensation charge in Ktvtau ', sum
7875 : : Kd=localtd+sum*PAW%hatden
7876 : : CALL exch(Grid,Kd,Ktvxc,tsum,texc,itype,&
7877 : : & tau=ddp,vtau=PAW%Ktvtau)
7878 : : LIBPAW_DEALLOCATE(dp1)
7879 : : LIBPAW_DEALLOCATE(ddp)
7880 : : LIBPAW_DEALLOCATE(vxc)
7881 : : LIBPAW_DEALLOCATE(tvxc)
7882 : : LIBPAW_DEALLOCATE(locald)
7883 : : LIBPAW_DEALLOCATE(localtd)
7884 : : LIBPAW_DEALLOCATE(Kd)
7885 : : LIBPAW_DEALLOCATE(Ktvxc)
7886 : : END SUBROUTINE calculate_tvtau
7887 : :
7888 : :
7889 : :
7890 : :
7891 : :
7892 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7893 : : ! 11. Pseudo_sub
7894 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7895 : :
7896 : :
7897 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7898 : : !! subroutine hatL
7899 : : !! Calculates density associated with L component
7900 : : !! normalized to unity
7901 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7902 [ # # ]: 0 : SUBROUTINE hatL(Grid,PAW,l,dhat,besselshapefunction)
7903 : : TYPE(GridInfo), INTENT(IN) :: Grid
7904 : : TYPE(PseudoInfo), INTENT(IN) :: PAW
7905 : : INTEGER, INTENT(IN) :: l
7906 : : logical, intent(in) :: besselshapefunction
7907 : : REAL(dp), INTENT(OUT) :: dhat(:)
7908 : : INTEGER :: n,irc,i
7909 : 0 : REAL(dp), POINTER :: r(:)
7910 : 0 : REAL(dp), ALLOCATABLE :: den(:),a(:)
7911 : : REAL(dp) :: h,con
7912 : : REAL(dp) :: qr,jbes1,jbes2,dum1,dum2,al(2),ql(2)
7913 : 0 : n=Grid%n
7914 : 0 : h=Grid%h
7915 : 0 : r=>Grid%r
7916 : 0 : irc=PAW%irc
7917 [ # # # # : 0 : LIBPAW_ALLOCATE(den,(n))
# # # # #
# ]
7918 [ # # # # : 0 : LIBPAW_ALLOCATE(a,(n))
# # # # ]
7919 [ # # ]: 0 : IF (besselshapefunction) THEN
7920 : 0 : CALL shapebes(al,ql,l,PAW%rc_shap)
7921 [ # # ]: 0 : DO i=1,PAW%irc_shap
7922 : 0 : qr=ql(1)*r(i);CALL jbessel(jbes1,dum1,dum2,l,0,qr)
7923 : 0 : qr=ql(2)*r(i);CALL jbessel(jbes2,dum1,dum2,l,0,qr)
7924 : 0 : den(i)=(al(1)*jbes1+al(2)*jbes2)*r(i)**2
7925 : : ENDDO
7926 [ # # # # ]: 0 : IF (n>PAW%irc_shap) den(PAW%irc_shap+1:n)=0._dp
7927 : : ELSE
7928 [ # # ]: 0 : DO i=1,n
7929 : 0 : den(i)=(r(i)**l)*PAW%hatden(i)
7930 : : ENDDO
7931 [ # # ]: 0 : a(1:n)=den(1:n)*(r(1:n)**l)
7932 : 0 : con=integrator(Grid,a,1,PAW%irc_shap)
7933 [ # # ]: 0 : den=den/con
7934 : : ENDIF
7935 [ # # ]: 0 : dhat=zero
7936 [ # # ]: 0 : dhat(1:n)=den(1:n)
7937 [ # # ]: 0 : LIBPAW_DEALLOCATE(den)
7938 [ # # ]: 0 : LIBPAW_DEALLOCATE(a)
7939 [ # # ]: 0 : END SUBROUTINE hatL
7940 : :
7941 : :
7942 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7943 : : !! SUBROUTINE FillHat(Grid,PAW)
7944 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7945 : 0 : SUBROUTINE FillHat(Grid,PAW,besselshape)
7946 : : logical,intent(in) :: besselshape
7947 : : TYPE(GridInfo) , INTENT(IN):: Grid
7948 : : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
7949 : : INTEGER :: ll,n,l
7950 [ # # ]: 0 : ll=MAXVAL(PAW%TOCCWFN%l(:)); ll=MAX(ll,PAW%lmax); ll=2*ll
7951 : 0 : n=Grid%n
7952 [ # # # # : 0 : LIBPAW_ALLOCATE(PAW%g,(n,ll+1))
# # # # #
# # # # #
# # # # ]
7953 [ # # ]: 0 : DO l=0,ll
7954 : 0 : CALL hatL(Grid,PAW,l,PAW%g(:,l+1),besselshape)
7955 : : ENDDO
7956 : 0 : END SUBROUTINE FillHat
7957 : :
7958 : :
7959 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7960 : : ! SUBROUTINE altdtij
7961 : : ! on input: f1(i) and f2(i) are radial wfn * r for angular momentum l
7962 : : ! on input: t1(i) and t2(i) are smooth radial wfn * r for angular momentum l
7963 : : ! for r > rc, f1=t1, f2=t2
7964 : : ! on output: tij is difference kinetic energy matrix element in Rydberg units
7965 : : ! tij =<f1|T|f2>-<t1|T|t2>
7966 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7967 : 12 : SUBROUTINE altdtij(Grid,PAW,ib,ic,tij,needvtau)
7968 : : logical, intent(in) :: needvtau
7969 : : TYPE(GridInfo), INTENT(IN) :: Grid
7970 : : TYPE(PseudoInfo), INTENT(IN) :: PAW
7971 : : INTEGER, INTENT(IN) :: ib,ic
7972 : : REAL(dp), INTENT(OUT) :: tij
7973 : : INTEGER :: n,i,l,irc
7974 : : REAL(dp) :: angm
7975 : 12 : REAL(dp), POINTER :: r(:)
7976 : 12 : REAL(dp), ALLOCATABLE :: dum(:),tdel1(:),tdel2(:),aux(:),auxp(:)
7977 : 12 : tij=0
7978 : 12 : IF (PAW%l(ib)/=PAW%l(ic)) RETURN
7979 : 12 : n=Grid%n; r=>Grid%r; l=PAW%l(ib); irc=PAW%irc
7980 [ - + + - : 36 : LIBPAW_ALLOCATE(dum,(n))
+ - + - -
+ - + ]
7981 [ - + + - : 24 : LIBPAW_ALLOCATE(tdel1,(n))
- + - + ]
7982 [ - + + - : 24 : LIBPAW_ALLOCATE(tdel2,(n))
- + - + ]
7983 [ - + + - : 24 : LIBPAW_ALLOCATE(aux,(n))
- + - + ]
7984 [ - + + - : 24 : LIBPAW_ALLOCATE(auxp,(n))
- + - + ]
7985 [ + + ]: 24024 : dum=zero
7986 [ + + ]: 17100 : DO i=2,irc
7987 : 17100 : dum(i)=PAW%ophi(i,ib)*PAW%Kop(i,ic) !Corrected 6/6/2023 Thanks to MT
7988 : : ENDDO
7989 : 12 : CALL derivative(Grid,PAW%otphi(:,ic),tdel1)
7990 : 12 : CALL derivative(Grid,tdel1,tdel2)
7991 [ + + + + ]: 48036 : aux=1.0_dp;auxp=0.0_dp
7992 [ - + ]: 12 : if(needvtau) then
7993 [ # # # # : 0 : aux=1._dp+PAW%tvtau
# # # # ]
7994 : 0 : call derivative(Grid,PAW%tvtau,auxp)
7995 : : endif
7996 : 12 : angm=l*(l+1)
7997 [ + + ]: 17100 : DO i=2,irc
7998 : : dum(i)=dum(i)+PAW%otphi(i,ib)*(aux(i)*(tdel2(i)-&
7999 : : & angm*PAW%otphi(i,ic)/(Grid%r(i)**2))+auxp(i)*&
8000 : 17100 : & (tdel1(i)-PAW%otphi(i,ic)/Grid%r(i)))
8001 : : ENDDO
8002 : 12 : tij=integrator(Grid,dum,1,irc)
8003 [ - + ]: 12 : LIBPAW_DEALLOCATE(dum)
8004 [ - + ]: 12 : LIBPAW_DEALLOCATE(tdel1)
8005 [ - + ]: 12 : LIBPAW_DEALLOCATE(tdel2)
8006 [ - + ]: 12 : LIBPAW_DEALLOCATE(aux)
8007 [ - + ]: 12 : LIBPAW_DEALLOCATE(auxp)
8008 [ - + ]: 12 : END SUBROUTINE altdtij
8009 : :
8010 : :
8011 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8012 : : !! SUBROUTINE besselps(Grid,Pot,PAW)
8013 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8014 : 0 : SUBROUTINE besselps(Grid,Pot,PAW)
8015 : : TYPE(Gridinfo), INTENT(IN) :: Grid
8016 : : TYPE(Potentialinfo), INTENT(IN) :: Pot
8017 : : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
8018 : : INTEGER :: i,irc,n
8019 : : real(dp) :: rc,alpha,beta,vv,vvp,AA,QQ,xx(1)
8020 : 0 : real(dp),POINTER :: r(:),rv(:)
8021 : 0 : n=Grid%n
8022 : 0 : r=>Grid%r
8023 : 0 : rv=>Pot%rv
8024 : 0 : irc=PAW%irc_vloc
8025 : 0 : rc=PAW%rc_vloc
8026 : 0 : vv=rv(irc);vvp=Gfirstderiv(Grid,irc,rv)
8027 : 0 : alpha=1.D0-rc*vvp/vv;beta=1.D0
8028 : 0 : call solvbes(xx,alpha,beta,0,1);QQ=xx(1)
8029 : 0 : AA=vv/sin(QQ);QQ=QQ/rc
8030 : 0 : PAW%rveff(1)=0._dp
8031 [ # # ]: 0 : PAW%rveff(irc+1:n)=rv(irc+1:n)
8032 [ # # ]: 0 : do i=2,irc
8033 : 0 : PAW%rveff(i)=AA*sin(QQ*r(i))
8034 : : enddo
8035 : 0 : END SUBROUTINE besselps
8036 : :
8037 : :
8038 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8039 : : !! SUBROUTINE EvaluateTp
8040 : : !! Inverts 5x5 matrix used by troullier subroutine
8041 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8042 : 971 : SUBROUTINE EvaluateTp(l,A,B,C,D,F,coef)
8043 : : INTEGER, INTENT(IN) :: l
8044 : : real(dp), INTENT(IN) :: A,B,C,D,F
8045 : : real(dp), INTENT(OUT) :: coef(6)
8046 : : real(dp) :: t(6,6),coef10,old
8047 : : real(dp), PARAMETER :: small=1.e-10
8048 : : INTEGER :: i,n,iter
8049 : : INTEGER, PARAMETER :: niter=1000
8050 : 971 : old=-1.e30; Coef10=-1; iter=-1
8051 [ + - + + ]: 4891 : DO WHILE (iter < niter .AND. ABS(old-coef10)> small)
8052 : 3920 : iter=iter+1
8053 : 3920 : t=0
8054 : 3920 : Coef(1)=A-Coef10; Coef(2)=B-2*Coef10; Coef(3)=C-2*Coef10;
8055 : 3920 : Coef(4)=D; Coef(5)=F
8056 : 3920 : Coef(6)=-Coef10**2
8057 [ + + ]: 27440 : DO i=1,6
8058 : 23520 : t(1,i)=1
8059 : 23520 : t(2,i)=2*i
8060 : 23520 : t(3,i)=2*i*(2*i-1)
8061 : 23520 : t(4,i)=2*i*(2*i-1)*(2*i-2)
8062 : 27440 : t(5,i)=2*i*(2*i-1)*(2*i-2)*(2*i-3)
8063 : : ENDDO
8064 : 3920 : t(6,1)=2*Coef10; t(6,2)=2*l+5
8065 : 3920 : n=6
8066 : 3920 : CALL linsol(t,Coef,n,6,6,6)
8067 : 3920 : old=Coef10; Coef10=Coef10+Coef(1)
8068 : 4891 : Coef(1)=Coef10
8069 : : ENDDO
8070 [ - + ]: 971 : IF (iter >= niter) THEN
8071 : 0 : LIBPAW_ERROR('Error in EvaluateTP -- no convergence')
8072 : : ENDIF
8073 : 971 : END SUBROUTINE EvaluateTp
8074 : :
8075 : :
8076 : :
8077 : :
8078 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8079 : : ! 12. Pseudo_data
8080 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8081 : :
8082 : :
8083 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8084 : : !! SUBROUTINE InitPAW(PAW,Grid,Orbit)
8085 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8086 : 4 : SUBROUTINE InitPAW(PAW,Grid,Orbit)
8087 : : TYPE(GridInfo), INTENT(IN) :: Grid
8088 : : TYPE(OrbitInfo), INTENT(IN) :: Orbit
8089 : : Type(PseudoInfo), INTENT(INOUT) :: PAW
8090 : : INTEGER :: io,l,n,mxbase,nbase
8091 : : !Initialize logical variables
8092 : 4 : PAW%multi_rc=.false.
8093 : 4 : PAW%poscorenhat=.true.
8094 : 4 : CALL DestroyPAW(PAW)
8095 : : !Compute initial size of basis
8096 : 4 : n=Grid%n
8097 : 4 : nbase=0
8098 [ + + ]: 18 : DO l=0,PAW%lmax
8099 [ + + ]: 109 : DO io=1,Orbit%norbit ! cycle through all configurations
8100 [ + + + + ]: 105 : IF (Orbit%l(io).EQ.l.AND.(.NOT.Orbit%iscore(io))) THEN
8101 : 14 : nbase=nbase+1
8102 : : ENDIF
8103 : : ENDDO
8104 : : ENDDO
8105 : 4 : PAW%mxbase=nbase+6*max(1,PAW%lmax)
8106 : 4 : mxbase=PAW%mxbase !Estimate excess
8107 : 4 : PAW%nbase=nbase
8108 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,*) 'Found ', nbase,' valence basis functions '
8109 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,*) 'Allocating for ', mxbase, ' total basis functions'
8110 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%projshape,(n))
+ - + - -
+ - + ]
8111 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%hatden,(n))
- + - + ]
8112 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%hatpot,(n))
- + - + ]
8113 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%hatshape,(n))
- + - + ]
8114 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%vloc,(n))
- + - + ]
8115 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rveff,(n))
- + - + ]
8116 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%abinitvloc,(n))
- + - + ]
8117 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%abinitnohat,(n))
- + - + ]
8118 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%AErefrv,(n))
- + - + ]
8119 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rvx,(n))
- + - + ]
8120 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%trvx,(n))
- + - + ]
8121 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%den,(n))
- + - + ]
8122 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%tden,(n))
- + - + ]
8123 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%core,(n))
- + - + ]
8124 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%tcore,(n))
- + - + ]
8125 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%coretau,(n))
- + - + ]
8126 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%tcoretau,(n))
- + - + ]
8127 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%valetau,(n))
- + - + ]
8128 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%tvaletau,(n))
- + - + ]
8129 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%vtau,(n))
- + - + ]
8130 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%tvtau,(n))
- + - + ]
8131 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%nhatv,(n))
- + - + ]
8132 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%Ktvtau,(n))
- + - + ]
8133 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%Krveff,(n))
- + - + ]
8134 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%Kunscreen,(n))
- + - + ]
8135 [ + + + + : 24016 : PAW%projshape=0._dp;PAW%hatden=0._dp;PAW%hatpot=0._dp
+ + ]
8136 [ + + + + : 24016 : PAW%hatshape=0._dp;PAW%vloc=0._dp;PAW%rveff=0._dp
+ + ]
8137 [ + + + + ]: 16012 : PAW%abinitvloc=0._dp;PAW%abinitnohat=0._dp
8138 [ + + + + : 24016 : PAW%AErefrv=0._dp;PAW%rvx=0._dp;PAW%trvx=0._dp
+ + ]
8139 [ + + + + : 32020 : PAW%den=0._dp;PAW%tden=0._dp;PAW%core=0._dp;PAW%tcore=0._dp
+ + + + ]
8140 [ + + ]: 8008 : PAW%XCORECORE=0._dp;PAW%nhatv=0._dp
8141 [ + + + + ]: 16012 : PAW%coretau=0._dp;PAW%tcoretau=0._dp
8142 [ + + + + ]: 16012 : PAW%valetau=0._dp;PAW%tvaletau=0._dp
8143 [ + + + + ]: 16012 : PAW%vtau=0._dp;PAW%tvtau=0._dp
8144 [ + + + + : 24016 : PAW%Ktvtau=0._dp;PAW%Krveff=0._dp;PAW%Kunscreen=0._dp
+ + ]
8145 [ - + + - : 16 : LIBPAW_POINTER_ALLOCATE(PAW%phi,(n,mxbase))
- + + - +
- + - - +
- + ]
8146 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%tphi,(n,mxbase))
- + + - -
+ - + ]
8147 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%tp,(n,mxbase))
- + + - -
+ - + ]
8148 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%ophi,(n,mxbase))
- + + - -
+ - + ]
8149 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%otphi,(n,mxbase))
- + + - -
+ - + ]
8150 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%otp,(n,mxbase))
- + + - -
+ - + ]
8151 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%np,(mxbase))
+ - + - -
+ - + ]
8152 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%l,(mxbase))
- + - + ]
8153 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%eig,(mxbase))
+ - + - -
+ - + ]
8154 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%occ,(mxbase))
- + - + ]
8155 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%ck,(mxbase))
- + - + ]
8156 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%vrc,(mxbase))
- + - + ]
8157 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%Kop,(n,mxbase))
- + + - -
+ - + ]
8158 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rng,(mxbase))
- + - + ]
8159 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rcio,(mxbase))
- + - + ]
8160 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%nodes,(mxbase))
- + - + ]
8161 [ + + + + : 444448 : PAW%phi=0._dp;PAW%tphi=0._dp;PAW%tp=0._dp
+ + + + +
+ + + ]
8162 [ + + + + : 444448 : PAW%ophi=0._dp;PAW%otphi=0._dp;PAW%otp=0._dp
+ + + + +
+ + + ]
8163 [ + + + + : 148448 : PAW%eig=0._dp;PAW%occ=0._dp;PAW%vrc=0._dp;PAW%ck=0._dp;PAW%Kop=0._dp
+ + + + +
+ + + ]
8164 [ + + + + : 226 : PAW%rcio=0._dp;PAW%np=0;PAW%l=0
+ + ]
8165 [ + + ]: 4 : if(Orbit%diracrelativistic) then
8166 [ - + + - : 2 : LIBPAW_POINTER_ALLOCATE(PAW%kappa,(mxbase))
- + - + ]
8167 [ + + ]: 19 : PAW%kappa=0
8168 : : endif
8169 [ + + ]: 78 : PAW%rng=Grid%n
8170 [ - + + - : 16 : LIBPAW_POINTER_ALLOCATE(PAW%oij,(mxbase,mxbase))
- + + - +
- + - - +
- + ]
8171 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%dij,(mxbase,mxbase))
- + + - -
+ - + ]
8172 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%wij,(mxbase,mxbase))
- + + - -
+ - + ]
8173 [ + + + + : 4366 : PAW%oij=0._dp;PAW%dij=0._dp;PAW%wij=0._dp
+ + + + +
+ + + ]
8174 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rVf,(n))
- + - + ]
8175 [ - + + - : 8 : LIBPAW_POINTER_ALLOCATE(PAW%rtVf,(n))
- + - + ]
8176 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%Kij,(mxbase,mxbase))
- + + - -
+ - + ]
8177 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%Vfij,(mxbase,mxbase))
- + + - -
+ - + ]
8178 [ + + + + : 18920 : PAW%rVf=0._dp;PAW%rtVf=0._dp;PAW%Kij=0._dp;PAW%Vfij=0._dp
+ + + + +
+ + + ]
8179 [ - + ]: 4 : IF (Orbit%exctype=='HF') THEN
8180 [ # # # # : 0 : LIBPAW_POINTER_ALLOCATE(PAW%lmbd,(Orbit%norbit,mxbase))
# # # # #
# # # # #
# # ]
8181 [ # # # # ]: 0 : PAW%lmbd=0._dp
8182 : : ELSE
8183 : 4 : nullify(PAW%lmbd)
8184 : : ENDIF
8185 [ - + + - : 12 : LIBPAW_POINTER_ALLOCATE(PAW%valencemap,(Orbit%norbit))
+ - + - -
+ - + ]
8186 [ - + ]: 4 : LIBPAW_DATATYPE_ALLOCATE(PAW%OCCwfn,)
8187 [ - + ]: 4 : LIBPAW_DATATYPE_ALLOCATE(PAW%TOCCwfn,)
8188 : 4 : END SUBROUTINE InitPAW
8189 : :
8190 : :
8191 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8192 : : !! Subroutine DestroyPAW(PAW)
8193 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8194 : 8 : Subroutine DestroyPAW(PAW)
8195 : : Type(PseudoInfo), INTENT(INOUT) :: PAW
8196 [ + + ]: 8 : IF(associated(PAW%Ktvtau)) then
8197 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Ktvtau)
8198 : : endif
8199 [ + + ]: 8 : IF(associated(PAW%Krveff)) then
8200 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Krveff)
8201 : : endif
8202 [ + + ]: 8 : if(associated(PAW%Kunscreen)) then
8203 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Kunscreen)
8204 : : endif
8205 [ + + ]: 8 : IF (ASSOCIATED(PAW%rcio)) then
8206 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rcio)
8207 : : endif
8208 [ + + ]: 8 : If (ASSOCIATED(PAW%vloc)) then
8209 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%vloc)
8210 : : endif
8211 [ + + ]: 8 : If (ASSOCIATED(PAW%abinitvloc)) then
8212 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%abinitvloc)
8213 : : endif
8214 [ + + ]: 8 : If (ASSOCIATED(PAW%abinitnohat)) then
8215 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%abinitnohat)
8216 : : endif
8217 [ + + ]: 8 : If (ASSOCIATED(PAW%rveff)) then
8218 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rveff)
8219 : : endif
8220 [ + + ]: 8 : If (ASSOCIATED(PAW%AErefrv)) then
8221 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%AErefrv)
8222 : : endif
8223 [ + + ]: 8 : If (ASSOCIATED(PAW%rvx)) then
8224 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rvx)
8225 : : endif
8226 [ + + ]: 8 : If (ASSOCIATED(PAW%trvx)) then
8227 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%trvx)
8228 : : endif
8229 [ + + ]: 8 : If (ASSOCIATED(PAW%projshape)) then
8230 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%projshape)
8231 : : endif
8232 [ + + ]: 8 : If (ASSOCIATED(PAW%hatshape)) then
8233 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%hatshape)
8234 : : endif
8235 [ + + ]: 8 : If (ASSOCIATED(PAW%hatden)) then
8236 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%hatden)
8237 : : endif
8238 [ + + ]: 8 : If (ASSOCIATED(PAW%hatpot)) then
8239 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%hatpot)
8240 : : endif
8241 [ + + ]: 8 : If (ASSOCIATED(PAW%den)) then
8242 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%den)
8243 : : endif
8244 [ + + ]: 8 : If (ASSOCIATED(PAW%tden)) then
8245 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tden)
8246 : : endif
8247 [ + + ]: 8 : If (ASSOCIATED(PAW%core)) then
8248 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%core)
8249 : : endif
8250 [ + + ]: 8 : If (ASSOCIATED(PAW%tcore)) then
8251 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tcore)
8252 : : endif
8253 [ + + ]: 8 : If (ASSOCIATED(PAW%coretau)) then
8254 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%coretau)
8255 : : endif
8256 [ + + ]: 8 : If (ASSOCIATED(PAW%tcoretau)) then
8257 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tcoretau)
8258 : : endif
8259 [ + + ]: 8 : If (ASSOCIATED(PAW%valetau)) then
8260 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%valetau)
8261 : : endif
8262 [ + + ]: 8 : If (ASSOCIATED(PAW%tvaletau)) then
8263 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tvaletau)
8264 : : endif
8265 [ + + ]: 8 : If (ASSOCIATED(PAW%vtau)) then
8266 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%vtau)
8267 : : endif
8268 [ + + ]: 8 : If (ASSOCIATED(PAW%tvtau)) then
8269 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tvtau)
8270 : : endif
8271 [ + + ]: 8 : If (ASSOCIATED(PAW%nhatv)) then
8272 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%nhatv)
8273 : : endif
8274 [ + + ]: 8 : If (ASSOCIATED(PAW%np)) then
8275 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%np)
8276 : : endif
8277 [ + + ]: 8 : If (ASSOCIATED(PAW%l)) then
8278 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%l)
8279 : : endif
8280 [ + + ]: 8 : If (ASSOCIATED(PAW%nodes)) then
8281 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%nodes)
8282 : : endif
8283 [ + + ]: 8 : If (ASSOCIATED(PAW%kappa)) then
8284 : 1 : LIBPAW_POINTER_DEALLOCATE(PAW%kappa)
8285 : : endif
8286 [ + + ]: 8 : If (ASSOCIATED(PAW%rng)) then
8287 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rng)
8288 : : endif
8289 [ - + ]: 8 : If (ASSOCIATED(PAW%label)) then
8290 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%label)
8291 : : endif
8292 [ + + ]: 8 : If (ASSOCIATED(PAW%phi)) then
8293 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%phi)
8294 : : endif
8295 [ + + ]: 8 : If (ASSOCIATED(PAW%tphi)) then
8296 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tphi)
8297 : : endif
8298 [ + + ]: 8 : If (ASSOCIATED(PAW%tp)) then
8299 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tp)
8300 : : endif
8301 [ + + ]: 8 : If (ASSOCIATED(PAW%ophi)) then
8302 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%ophi)
8303 : : endif
8304 [ + + ]: 8 : If (ASSOCIATED(PAW%otphi)) then
8305 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%otphi)
8306 : : endif
8307 [ + + ]: 8 : If (ASSOCIATED(PAW%otp)) then
8308 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%otp)
8309 : : endif
8310 [ + + ]: 8 : If (ASSOCIATED(PAW%Kop)) then
8311 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Kop)
8312 : : endif
8313 [ + + ]: 8 : If (ASSOCIATED(PAW%eig)) then
8314 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%eig)
8315 : : endif
8316 [ + + ]: 8 : If (ASSOCIATED(PAW%occ)) then
8317 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%occ)
8318 : : endif
8319 [ + + ]: 8 : If (ASSOCIATED(PAW%ck)) then
8320 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%ck)
8321 : : endif
8322 [ + + ]: 8 : If (ASSOCIATED(PAW%vrc)) then
8323 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%vrc)
8324 : : endif
8325 [ + + ]: 8 : If (ASSOCIATED(PAW%oij)) then
8326 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%oij)
8327 : : endif
8328 [ + + ]: 8 : If (ASSOCIATED(PAW%dij)) then
8329 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%dij)
8330 : : endif
8331 [ + + ]: 8 : If (ASSOCIATED(PAW%wij)) then
8332 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%wij)
8333 : : endif
8334 [ + + ]: 8 : If (ASSOCIATED(PAW%rVf)) then
8335 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rVf)
8336 : : endif
8337 [ + + ]: 8 : If (ASSOCIATED(PAW%rtVf)) then
8338 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rtVf)
8339 : : endif
8340 [ - + ]: 8 : If (ASSOCIATED(PAW%g)) then
8341 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%g)
8342 : : endif
8343 [ + + ]: 8 : If (ASSOCIATED(PAW%Kij)) then
8344 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Kij)
8345 : : endif
8346 [ + + ]: 8 : If (ASSOCIATED(PAW%Vfij)) then
8347 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Vfij)
8348 : : endif
8349 [ - + ]: 8 : If (ASSOCIATED(PAW%mLij)) then
8350 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%mLij)
8351 : : endif
8352 [ - + ]: 8 : If (ASSOCIATED(PAW%DR)) then
8353 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DR)
8354 : : endif
8355 [ - + ]: 8 : If (ASSOCIATED(PAW%DRVC)) then
8356 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRVC)
8357 : : endif
8358 [ - + ]: 8 : If (ASSOCIATED(PAW%TXVC)) then
8359 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%TXVC)
8360 : : endif
8361 [ + + ]: 8 : If (ASSOCIATED(PAW%valencemap)) then
8362 : 4 : LIBPAW_POINTER_DEALLOCATE(PAW%valencemap)
8363 : : endif
8364 [ - + ]: 8 : If (ASSOCIATED(PAW%lmbd)) then
8365 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%lmbd)
8366 : : endif
8367 [ - + ]: 8 : If (ASSOCIATED(PAW%DRC)) then
8368 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRC)
8369 : : endif
8370 [ - + ]: 8 : If (ASSOCIATED(PAW%DRCC)) then
8371 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRCC)
8372 : : endif
8373 [ - + ]: 8 : If (ASSOCIATED(PAW%DRCjkl)) then
8374 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRCjkl)
8375 : : endif
8376 [ - + ]: 8 : If (ASSOCIATED(PAW%mLic)) then
8377 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%mLic)
8378 : : endif
8379 [ - + ]: 8 : If (ASSOCIATED(PAW%mLcc)) then
8380 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%mLcc)
8381 : : endif
8382 [ - + ]: 8 : If (ASSOCIATED(PAW%Dcj)) then
8383 : 0 : LIBPAW_POINTER_DEALLOCATE(PAW%Dcj)
8384 : : endif
8385 [ + + ]: 8 : If (ASSOCIATED(PAW%OCCwfn)) then
8386 : 4 : call DestroyOrbit(PAW%OCCwfn)
8387 [ - + ]: 4 : LIBPAW_DATATYPE_DEALLOCATE(PAW%OCCwfn)
8388 : : end if
8389 [ + + ]: 8 : If (ASSOCIATED(PAW%TOCCwfn)) then
8390 : 4 : call DestroyOrbit(PAW%TOCCwfn)
8391 [ - + ]: 4 : LIBPAW_DATATYPE_DEALLOCATE(PAW%TOCCwfn)
8392 : : end if
8393 : 8 : End Subroutine DestroyPAW
8394 : :
8395 : :
8396 : :
8397 : :
8398 : :
8399 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8400 : : ! 13. Numerov
8401 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8402 : :
8403 : :
8404 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8405 : : !! SUBROUTINE BoundNumerov(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,BDsolve,success)
8406 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8407 [ - + - + : 446 : SUBROUTINE BoundNumerov(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,BDsolve,success)
- + ]
8408 : : TYPE(GridInfo), INTENT(IN) :: Grid
8409 : : real(dp), INTENT(IN) :: rv(:),v0,v0p
8410 : : INTEGER, INTENT(IN) :: nz,l,nroot
8411 : : real(dp), INTENT(INOUT) :: Eig(:), Psi(:,:)
8412 : : LOGICAL, INTENT(IN) :: BDsolve
8413 : : LOGICAL, INTENT(INOUT) :: success
8414 : : INTEGER, PARAMETER :: repeat=4
8415 : : INTEGER :: j
8416 : : ! TODO : BDsolve
8417 [ - + ]: 446 : if(BDsolve) then
8418 : 0 : STOP
8419 : : endif
8420 [ - + ]: 446 : if(has_to_print) write(std_out,*) 'Before newboundsch',l,nroot, Eig(1:nroot)
8421 : 446 : CALL newboundsch(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,success)
8422 [ - + ]: 446 : if(has_to_print) write(std_out,*) 'After newboundsch',l,nroot, Eig(1:nroot)
8423 : : ! adjust sign
8424 [ + + ]: 1231 : Do j=1,nroot
8425 [ + + + + ]: 549779 : if (Psi(3,j)<0._dp) Psi(:,j)=-Psi(:,j)
8426 : : Enddo
8427 : 446 : END SUBROUTINE BoundNumerov
8428 : :
8429 : :
8430 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8431 : : !! SUBROUTINE newboundsch(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,ok)
8432 : : !! pgm to solve radial schroedinger equation for nroot bound state
8433 : : !! energies and wavefunctions for angular momentum l
8434 : : !! with potential rv/r
8435 : : !!
8436 : : !! Assymptotic from of wfn:
8437 : : !! Psi(r) = const*(r**q/kappa)*EXP(-kappa*r), where eig=-kappa**2
8438 : : !! uses Noumerov algorithm
8439 : : !!
8440 : : !! For l=0,1 corrections are needed to approximate wfn(r=0)
8441 : : !! These depend upon:
8442 : : !! e0 (current guess of energy eigenvalue)
8443 : : !! l,nz
8444 : : !! v(0) == v0 electronic potential at r=0
8445 : : !! v'(0) == v0p derivative of electronic potential at r=0
8446 : : !!
8447 : : !! Corrections are also needed for r>n*h, depending on:
8448 : : !! e0 (current guess of energy eigenvalue
8449 : : !! the extrapolated value of rv == r * v
8450 : : !!
8451 : : !! ierr=an nroot digit number indicating status of each root
8452 : : !! a digit of 1 indicates success in converging root
8453 : : !! 2 indicates near success in converging root
8454 : : !! 9 indicates that root not found
8455 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8456 [ - + - + : 446 : SUBROUTINE newboundsch(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,ok)
- + ]
8457 : : TYPE(GridInfo), INTENT(IN) :: Grid
8458 : : real(dp), INTENT(IN) :: rv(:),v0,v0p
8459 : : INTEGER, INTENT(IN) :: nz,l,nroot
8460 : : real(dp), INTENT(INOUT) :: Eig(:), Psi(:,:)
8461 : : LOGICAL, INTENT(OUT) :: ok
8462 : : real(dp), PARAMETER :: convre=tol10,vlrg=10._dp**30
8463 : : INTEGER, PARAMETER :: niter=300
8464 : 446 : real(dp), ALLOCATABLE :: p1(:),p2(:),dd(:)
8465 : : INTEGER :: n,ierr
8466 : : real(dp) :: h,qq
8467 : : real(dp) :: err,convrez,energy,zeroval,zz
8468 : : real(dp) :: scale,emin,emax,best,rout,ppp
8469 : : real(dp) :: rin,dele,x
8470 : : INTEGER :: iter,i,j,node,match,ir,iroot
8471 : : INTEGER :: ifac
8472 : 446 : ifac=0
8473 : 446 : n=Grid%n
8474 : 446 : h=Grid%h
8475 [ - + + - : 1338 : LIBPAW_ALLOCATE(p1,(n))
+ - + - -
+ - + ]
8476 [ - + + - : 892 : LIBPAW_ALLOCATE(p2,(n))
- + - + ]
8477 [ - + + - : 892 : LIBPAW_ALLOCATE(dd,(n))
- + - + ]
8478 : 446 : zz=nz
8479 : : qq=-rv(n)/2
8480 : : IF (qq<0.001_dp) qq=0._dp
8481 : 446 : qq=zero
8482 : 446 : err=n*nz*(h**4); if (err<tol6) err=tol6
8483 : 446 : convrez=convre
8484 [ + - ]: 446 : IF (nz.GT.0) convrez=convre*nz
8485 : 446 : ierr=0
8486 : 446 : emin=(-REAL((nz)**2)/(l+1)**2-0.5_dp)
8487 : 446 : emax=0._dp
8488 [ + + ]: 1231 : DO iroot=1,nroot
8489 : 785 : best=1.d10; dele=1.d10
8490 : 785 : energy=Eig(iroot)
8491 [ + + ]: 785 : IF (energy.LT.emin) energy=emin
8492 [ - + ]: 785 : IF (energy.GT.emax) energy=emax
8493 : 785 : ok=.FALSE.
8494 [ + + ]: 5138 : BigIter: DO iter=1,niter
8495 : : ! start inward integration
8496 : : ! start integration at n
8497 : : ! find classical turning point
8498 : 5131 : CALL ClassicalTurningPoint(Grid,rv,l,energy,match)
8499 : 5131 : match=MAX(5,match)
8500 : 5131 : match=MIN(n-15,match)
8501 : 5131 : ppp=SQRT(ABS(-energy))
8502 [ + + ]: 10272262 : p2=0
8503 : 5131 : p2(n)=wfnend(l,energy,Grid%r(n),Grid%r(n),qq)
8504 : 5131 : p2(n-1)=wfnend(l,energy,Grid%r(n-1),Grid%r(n),qq)
8505 : 5131 : CALL backward_numerov(Grid,l,match,energy,rv,p2)
8506 : 5131 : match=match+6
8507 : 5131 : CALL derivative(Grid,p2,dd,match-5,match+5)
8508 : 5131 : rin=dd(match)/p2(match)
8509 : : ! start outward integration
8510 : : ! correct behavior near r=0
8511 : : ! initialize p1
8512 [ + + ]: 10272262 : p1=0
8513 : 5131 : p1(2)=wfninit(-0.5_dp*rv(1),l,v0,v0p,energy,Grid%r(2))
8514 : 5131 : zeroval=0
8515 [ + + ]: 5131 : IF (l==0) zeroval=rv(1)
8516 [ + + ]: 5131 : IF (l==1) zeroval=2
8517 : 5131 : CALL forward_numerov(Grid,l,match+6,energy,rv,zeroval,p1,node)
8518 : 5131 : CALL derivative(Grid,p1,dd,match-5,match+5)
8519 : 5131 : rout=dd(match)/p1(match)
8520 : : ! check whether node = (iroot-1)
8521 : : ! not enough nodes -- raise energy
8522 [ + + ]: 5138 : IF (node.LT.iroot-1) THEN
8523 : 122 : emin=MAX(emin,energy)-tol5
8524 : 122 : energy=emax-(emax-energy)*ranx()
8525 : 122 : ifac=9
8526 : : ! too many nodes -- lower energy
8527 [ + + ]: 5009 : ELSEIF (node.GT.iroot-1) THEN
8528 [ - + ]: 111 : IF (energy.LT.emin) THEN
8529 : 0 : ierr=ierr+9*(10**(iroot-1))
8530 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'newboundsch error -- emin too high',l,nz,emin,energy
8531 : : RETURN
8532 : : ENDIF
8533 : 111 : emax=MIN(emax,energy+tol5)
8534 : 111 : energy=emin+(energy-emin)*ranx()
8535 : : ! correct number of nodes -- estimate correction
8536 [ + - ]: 4898 : ELSEIF (node.EQ.iroot-1) THEN
8537 [ + + ]: 6216179 : DO j=1,match
8538 : 6216179 : p1(j)=p1(j)/p1(match)
8539 : : ENDDO
8540 [ + + ]: 3599413 : DO j=match,n
8541 : 3599413 : p1(j)=p2(j)/p2(match)
8542 : : ENDDO
8543 : 4898 : scale=1._dp/overlap(Grid,p1,p1)
8544 : 4898 : dele=(rout-rin)*scale
8545 : 4898 : x=ABS(dele)
8546 [ + + ]: 4898 : IF (x.LT.best) THEN
8547 : 2273 : scale=SQRT(scale)
8548 [ + + ]: 4550546 : p1(1:n)=p1(1:n)*scale
8549 [ + + ]: 4550546 : Psi(1:n,iroot)=p1(1:n)
8550 : 2273 : Eig(iroot)=energy
8551 : 2273 : best=x
8552 : : ENDIF
8553 [ + + ]: 4898 : IF (ABS(dele).LE.convrez) THEN
8554 [ - + ]: 778 : if(has_to_print) WRITE(STD_OUT,*) 'converged iter with dele' , iter,dele
8555 : 778 : ok=.TRUE.
8556 : : ! eigenvalue found
8557 : 778 : ierr=ierr+10**(iroot-1)
8558 [ + + ]: 778 : IF (iroot+1.LE.nroot) THEN
8559 : 339 : emin=energy+tol5
8560 : 339 : emax=0
8561 : 339 : energy=(emin+emax)/2
8562 [ - + ]: 339 : IF (energy.LT.emin) energy=emin
8563 [ - + ]: 339 : IF (energy.GT.emax) energy=emax
8564 : 339 : best=1.d10
8565 : : ENDIF
8566 : : EXIT BigIter
8567 : : ENDIF
8568 [ + - ]: 4120 : IF (ABS(dele).GT.convrez) THEN
8569 : 4120 : energy=energy+dele
8570 : : ! if energy is out of range, pick random energy in correct range
8571 [ + + + + ]: 4120 : IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) &
8572 : 2029 : & energy=emin+(emax-emin)*ranx()
8573 : : ifac=2
8574 : : ENDIF
8575 : : ENDIF
8576 : : ENDDO BigIter !iter
8577 [ + + ]: 1231 : IF (.NOT.ok) THEN
8578 : 7 : ierr=ierr+ifac*(10**(iroot-1))
8579 [ - + ]: 7 : if(has_to_print) WRITE(STD_OUT,*) 'no convergence in newboundsch',iroot,l,dele,energy
8580 [ - + ]: 7 : if(has_to_print) WRITE(STD_OUT,*) ' best guess of eig, dele = ',Eig(iroot),best
8581 [ - + ]: 7 : IF (iroot.LT.nroot) THEN
8582 [ # # ]: 0 : DO ir=iroot+1,nroot
8583 : 0 : ierr=ierr+9*(10**(ir-1))
8584 : : ENDDO
8585 : : ENDIF
8586 : : ! reset wfn with hydrogenic form
8587 : 7 : j=iroot+l+1
8588 [ + + ]: 14014 : Psi(:,iroot)=0
8589 : 7 : ppp=(j)*SQRT(ABS(Eig(iroot)))
8590 [ + + ]: 14007 : DO i=2,n
8591 : 14007 : Psi(i,iroot)=hwfn(ppp,j,l,Grid%r(i))
8592 : : ENDDO
8593 : : ENDIF
8594 : : ENDDO !iroot
8595 [ - + ]: 446 : if(has_to_print) WRITE(STD_OUT,'("finish boundsch with eigenvalues -- ",1p,20e15.7)') &
8596 : 0 : & Eig(1:nroot)
8597 [ - + ]: 446 : LIBPAW_DEALLOCATE(p1)
8598 [ - + ]: 446 : LIBPAW_DEALLOCATE(p2)
8599 [ - + ]: 446 : LIBPAW_DEALLOCATE(dd)
8600 [ - + ]: 446 : if(has_to_print) WRITE(STD_OUT,*) 'returning from newboundsch -- ierr=',ierr
8601 : 0 : END SUBROUTINE newboundsch
8602 : :
8603 : :
8604 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8605 : : !! FUNCTION wfninit(nz,l,v0,v0p,energy,r)
8606 : : !! returns the solution of the Schroedinger equation near r=0
8607 : : !! using power series expansion
8608 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8609 : 5210 : FUNCTION wfninit(nz,l,v0,v0p,energy,r)
8610 : : real(dp) :: wfninit
8611 : : INTEGER, INTENT(IN) :: l
8612 : : real(dp), INTENT(IN) :: nz,v0,v0p,energy,r
8613 : : real(dp) :: c1,c2,c3
8614 : 5210 : c1=-REAL(nz)/(l+1._dp)
8615 : 5210 : c2=((v0-energy)-2*nz*c1)/(4*l+6._dp)
8616 : 5210 : c3=(v0p+(v0-energy)*c1-2*nz*c2)/(6*l+12._dp)
8617 : 5210 : wfninit=(r**(l+1))*(1+r*(c1+r*(c2+r*c3)))
8618 : 5210 : END FUNCTION wfninit
8619 : :
8620 : :
8621 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8622 : : !! FUNCTION wfnend(l,energy,r,rN)
8623 : : !!
8624 : : !! Find asymptotic form of wavefunction
8625 : : !! assuming equations has form
8626 : : !! (- d^2 +l(l+1) -2q +b^2 )
8627 : : !! ( --- ------ --- ) P(r) = 0
8628 : : !! ( dr^2 r^2 r )
8629 : : !! where b^2=-energy
8630 : : !!
8631 : : !! P(r) = exp(-b*(r-rN))*r^(q/b)(1+(l*(l+1)-q/b)*(q/b-1)/(2*b)/r + ...)
8632 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8633 : 10262 : FUNCTION wfnend(l,energy,r,rN,qq)
8634 : : real(dp) :: wfnend
8635 : : INTEGER, INTENT(IN) :: l
8636 : : real(dp), INTENT(IN) :: energy,r,rN,qq
8637 : : real(dp) :: qbb,b,wfn,cn,term,fac
8638 : : INTEGER :: i
8639 : : INTEGER, PARAMETER :: last=5
8640 [ + - ]: 10262 : IF (energy>=0._dp) THEN
8641 : 10262 : wfnend=zero
8642 : : RETURN
8643 : : ENDIF
8644 : 10262 : b=SQRT(-energy)
8645 : 10262 : qbb=qq/b
8646 : 10262 : cn=l*(l+1)
8647 : 10262 : fac=DDEXP(-b*(r-rN))*(r**qbb)
8648 : 10262 : term=1._dp; wfn=zero
8649 [ + + ]: 61572 : DO i=1,last
8650 : 51310 : wfn=wfn+term
8651 [ + + ]: 61572 : IF (i<last) THEN
8652 : 41048 : term=-term*((qbb-i+1)*(qbb-i)-cn)/(2*b*i)/r
8653 : : ENDIF
8654 : : ENDDO
8655 : 10262 : wfnend=fac*wfn
8656 : 10262 : END FUNCTION wfnend
8657 : :
8658 : :
8659 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8660 : : !! subroutine unboundsch(Grid,rv,v0,v0p,nr,l,energy,wfn,nodes)
8661 : : !! pgm to solve radial schroedinger equation for unbound states
8662 : : !! at energy 'energy' and at angular momentum l
8663 : : !!
8664 : : !! with potential rv/r, given in uniform mesh of n points
8665 : : !! r=i*h, i=1,...n-1 ;assuming p(r)=C*r**(l+1)*polynomial(r) for r==0;
8666 : : !! p((n+1)*h)=0
8667 : : !! nz=nuclear charge
8668 : : !!
8669 : : !! uses Noumerov algorithm
8670 : : !!
8671 : : !! For l=0,1 corrections are needed to approximate wfn(r=0)
8672 : : !! These depend upon:
8673 : : !! e0 (current guess of energy eigenvalue)
8674 : : !! l,nz
8675 : : !! v(0) == v0 electronic potential at r=0
8676 : : !! v'(0) == v0p derivative of electronic potential at r=0
8677 : : !!
8678 : : !! also returns node == number of nodes for calculated state
8679 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8680 [ - + - + ]: 13 : SUBROUTINE unboundsch(Grid,rv,v0,v0p,nr,l,energy,wfn,nodes)
8681 : : TYPE(GridInfo), INTENT(IN) :: Grid
8682 : : real(dp), INTENT(IN) :: rv(:),v0,v0p
8683 : : INTEGER, INTENT(IN) :: nr,l
8684 : : real(dp), INTENT(IN) :: energy
8685 : : real(dp), INTENT(INOUT) :: wfn(:)
8686 : : INTEGER, INTENT(INOUT) :: nodes
8687 : : INTEGER :: n
8688 : : real(dp) :: zeroval,scale
8689 : 13 : n=Grid%n
8690 [ - + ]: 13 : IF (nr > n) THEN
8691 : 0 : LIBPAW_ERROR('Error in unboundsch -- nr > n')
8692 : : ENDIF
8693 : : ! initialize wfn
8694 [ + + ]: 25432 : wfn=0
8695 : 13 : wfn(2)=wfninit(-0.5_dp*rv(1),l,v0,v0p,energy,Grid%r(2))
8696 : 13 : zeroval=0
8697 [ + + ]: 13 : if (l==0) zeroval=rv(1)
8698 [ + + ]: 13 : if (l==1) zeroval=2
8699 : 13 : call forward_numerov(Grid,l,nr,energy,rv,zeroval,wfn,nodes)
8700 : : ! normalize to unity within integration range
8701 : 13 : scale=1._dp/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr)
8702 : 13 : scale=SIGN(SQRT(scale),wfn(nr-2))
8703 [ + + ]: 19444 : wfn(1:nr)=wfn(1:nr)*scale
8704 : 13 : END SUBROUTINE unboundsch
8705 : :
8706 : :
8707 : :
8708 : :
8709 : :
8710 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8711 : : ! 14. tools_mod
8712 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8713 : :
8714 : :
8715 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8716 : : !! SUBROUTINE extractword(wordindex,stringin,stringout)
8717 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8718 : 30 : SUBROUTINE extractword(wordindex,stringin,stringout)
8719 : : INTEGER, INTENT(IN) :: wordindex
8720 : : CHARACTER(*), INTENT(IN) :: stringin
8721 : : CHARACTER(*), INTENT(OUT) :: stringout
8722 : : INTEGER :: i,j,n,str,fin,icount
8723 : 30 : stringout=''
8724 : 30 : n=LEN(stringin)
8725 [ + - ]: 30 : i=INDEX(stringin,'!');IF (i==0) i=n
8726 [ + - ]: 30 : j=INDEX(stringin,'#');IF (j==0) j=n
8727 : 30 : n=MIN(i,j,n)
8728 : 30 : str=1;fin=n
8729 [ + + ]: 74 : DO icount=1,MAX(1,wordindex-1)
8730 [ + - ]: 58 : DO i=str,n
8731 [ + + ]: 58 : IF (stringin(i:i)/=' ') EXIT
8732 : : ENDDO
8733 : 44 : str=i
8734 [ + - ]: 44 : IF (n>str) THEN
8735 [ + - ]: 152 : DO i=str+1,n
8736 [ + + ]: 152 : IF(stringin(i:i)==' ') EXIT
8737 : : ENDDO
8738 : : fin=i
8739 : : ENDIF
8740 [ + + ]: 74 : IF (wordindex>2) THEN
8741 [ - + ]: 24 : IF (fin<n) THEN
8742 : 24 : str=fin+1
8743 : : ELSE
8744 : : EXIT
8745 : : ENDIF
8746 : : ENDIF
8747 : : ENDDO
8748 [ + + ]: 30 : IF (wordindex>1) THEN
8749 [ + - ]: 20 : IF (fin>=n) RETURN
8750 [ + + ]: 1180 : DO i=fin+1,n
8751 [ + + ]: 1180 : IF (stringin(i:i)/=' ') EXIT
8752 : : ENDDO
8753 : 20 : str=i
8754 [ + + ]: 20 : IF (n>str) THEN
8755 [ + - ]: 44 : DO i=str+1,n
8756 [ + + ]: 44 : IF(stringin(i:i)==' ') EXIT
8757 : : ENDDO
8758 : : fin=i
8759 : : ENDIF
8760 : : ENDIF
8761 [ + - + - ]: 30 : stringout=stringin(str:fin)
8762 [ + - ]: 30 : END SUBROUTINE extractword
8763 : :
8764 : :
8765 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8766 : : !! SUBROUTINE UpperCase(str)
8767 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8768 : 20 : SUBROUTINE UpperCase(str)
8769 : : CHARACTER(*), INTENT(INOUT) :: str
8770 : : INTEGER :: i, j, k
8771 : 20 : j = LEN(Str)
8772 [ + + ]: 3972 : DO i=1, j
8773 : 3952 : k = IACHAR(str(i:i))
8774 [ + + ]: 3972 : IF ((k>96) .AND. (k<123)) str(i:i) = ACHAR(k-32)
8775 : : END DO
8776 : 20 : RETURN
8777 : : END SUBROUTINE UpperCase
8778 : :
8779 : :
8780 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8781 : : !! FUNCTION checkline2(inputline,in1,in2)
8782 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8783 : : LOGICAL FUNCTION checkline2(inputline,in1,in2)
8784 : : CHARACTER(*), INTENT(IN) :: inputline
8785 : : CHARACTER(*), INTENT(IN) :: in1,in2
8786 : : INTEGER :: leninput,len1,len2
8787 : : CHARACTER(120) :: inputline_u,in1_u,in2_u
8788 : : inputline_u=trim(inputline) ; call UpperCase(inputline_u)
8789 : : in1_u=trim(in1) ; call UpperCase(in1_u)
8790 : : in2_u=trim(in2) ; call UpperCase(in2_u)
8791 : : leninput=len(trim(inputline));len1=len(trim(in1));len2=len(trim(in2))
8792 : : checkline2=.false.
8793 : : if (leninput==len1) checkline2=(inputline_u(1:len1)==trim(in1))
8794 : : if ((.not.checkline2).and.leninput==len2) checkline2=(inputline_u(1:len2)==trim(in2))
8795 : : RETURN
8796 : : END FUNCTION checkline2
8797 : :
8798 : :
8799 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8800 : : ! eliminate_comment - Eliminate comment on the right of a line (! or #)
8801 : : ! line - string to convert (output replaces input)
8802 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8803 : 169 : SUBROUTINE eliminate_comment(line)
8804 : : CHARACTER(*), INTENT(INOUT) :: line
8805 : : INTEGER :: i,i0
8806 : 169 : i0=-1 ; i=1
8807 [ + + + + ]: 29606 : DO WHILE (i0<0.AND.i<LEN(line))
8808 : 29437 : i=i+1
8809 [ + + + - ]: 29606 : IF (line(i:i)=="!".OR.line(i:i)=="#") i0=i
8810 : : END DO
8811 [ + + + - : 169 : IF (i0 >1) line=line(1:i0-1)
+ - ]
8812 : : IF (i0==1) line=""
8813 : 169 : END SUBROUTINE eliminate_comment
8814 : :
8815 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8816 : : !! stripchar - Eliminate blanks
8817 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8818 : 6 : FUNCTION stripchar(inputchar)
8819 : : CHARACTER(20) :: stripchar
8820 : : CHARACTER*(*), INTENT(IN) :: inputchar
8821 : : INTEGER :: i,j,n
8822 : 6 : n=LEN(inputchar)
8823 [ + + ]: 126 : DO i=1,20
8824 : 126 : stripchar(i:i)=''
8825 : : ENDDO
8826 : : j=0
8827 [ + + ]: 72 : DO i=1,n
8828 [ + + ]: 72 : IF (inputchar(i:i) /= '') THEN
8829 : 48 : j=j+1
8830 : 48 : stripchar(j:j)=inputchar(i:i)
8831 : : ENDIF
8832 : : ENDDO
8833 : 6 : END FUNCTION stripchar
8834 : :
8835 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8836 : : !! mkname - Subroutine to take an integer (.le. 4 digits) and return it
8837 : : !! in the form of a character string
8838 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8839 : 6 : SUBROUTINE mkname(i,stuff)
8840 : : CHARACTER(4) stuff
8841 : : INTEGER i,i1,i10,i100,i1000
8842 : 6 : stuff='?'
8843 [ - + ]: 6 : IF (i.GT.9999) i=MOD(i,10000)
8844 : 6 : i1000=i/1000
8845 : 6 : i100=(i-1000*i1000)/100
8846 : 6 : i10=(i-1000*i1000-100*i100)/10
8847 : 6 : i1=(i-1000*i1000-100*i100-10*i10)
8848 [ - + ]: 6 : IF (i.GE.1000) THEN
8849 : 0 : stuff=CHAR(i1000+48)//CHAR(i100+48)//CHAR(i10+48)//CHAR(i1+48)
8850 : 0 : RETURN
8851 : : ENDIF
8852 [ - + ]: 6 : IF (i.GE.100) THEN
8853 : 0 : stuff=CHAR(i100+48)//CHAR(i10+48)//CHAR(i1+48)
8854 : 0 : RETURN
8855 : : ENDIF
8856 [ - + ]: 6 : IF (i.GE.10) THEN
8857 : 0 : stuff=CHAR(i10+48)//CHAR(i1+48)
8858 : 0 : RETURN
8859 : : ENDIF
8860 [ + - ]: 6 : IF (i.GE.0) stuff=CHAR(i1+48)
8861 : : RETURN
8862 : : END SUBROUTINE mkname
8863 : :
8864 : :
8865 : :
8866 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8867 : : ! 15. radialked
8868 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8869 : :
8870 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8871 : : ! subroutine unboundked(Grid,Pot,nr,l,energy,wfn,nodes)
8872 : : ! pgm to solve radial kinetic energy derivative equations for unbound states
8873 : : ! at energy 'energy' and at angular momentum l
8874 : : ! with potential rv/r, given in uniform linear or log mesh of n points
8875 : : ! assuming p(r)=C*r**(l+1)*polynomial(r) for r==0;
8876 : : ! nz=nuclear chargedd
8877 : : ! Does not use Noumerov algorithm -- but uses coupled first-order
8878 : : ! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
8879 : : ! also returns node == number of nodes for calculated state
8880 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8881 [ # # ]: 0 : SUBROUTINE unboundked(Grid,Pot,nr,l,energy,wfn,nodes)
8882 : : TYPE(GridInfo), INTENT(IN) :: Grid
8883 : : TYPE(PotentialInfo), INTENT(IN) :: Pot
8884 : : INTEGER, INTENT(IN) :: nr,l
8885 : : REAL(dp), INTENT(IN) :: energy
8886 : : REAL(dp), INTENT(INOUT) :: wfn(:)
8887 : : INTEGER, INTENT(INOUT) :: nodes
8888 : : INTEGER :: n,istart
8889 : 0 : REAL(dp) :: oneplusvtau(Grid%n),dvtaudr(Grid%n)
8890 : : REAL(dp) :: scale,qq,zxc
8891 : 0 : REAL(dp), allocatable :: lwfn(:),zz(:,:,:),yy(:,:)
8892 : 0 : n=Grid%n
8893 [ # # ]: 0 : IF (nr > n) THEN
8894 : 0 : write(std_out,*) 'Error in unboundked -- nr > n', nr,n
8895 : 0 : STOP
8896 : : ENDIF
8897 : 0 : call Set_Pot(Grid,Pot,qq,zxc,oneplusvtau,dvtaudr)
8898 [ # # # # : 0 : LIBPAW_ALLOCATE(lwfn,(nr))
# # # # #
# # # ]
8899 [ # # # # : 0 : LIBPAW_ALLOCATE(zz,(2,2,nr))
# # # # #
# # # ]
8900 [ # # # # : 0 : LIBPAW_ALLOCATE(yy,(2,nr))
# # # # #
# # # ]
8901 [ # # # # : 0 : lwfn=0;zz=0;yy=0;
# # # # #
# # # ]
8902 : 0 : call wfnkedinit(Grid,l,Pot%nz,wfn,lwfn,istart,zxc,oneplusvtau,dvtaudr)
8903 : 0 : call setupforcfdsol(Grid,Pot%rv,1,istart,nr,l,energy,wfn,lwfn,yy,zz,oneplusvtau,dvtaudr)
8904 : 0 : call cfdsoliter(Grid,zz,yy,istart,nr)
8905 : 0 : call getwfnfromcfdsol(1,nr,yy,wfn)
8906 : 0 : nodes=countnodes(2,nr,wfn)
8907 : : ! normalize to unity within integration range
8908 : 0 : scale=1._dp/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr)
8909 : 0 : scale=SIGN(SQRT(scale),wfn(nr-2))
8910 [ # # ]: 0 : wfn(1:nr)=wfn(1:nr)*scale
8911 [ # # ]: 0 : LIBPAW_DEALLOCATE(lwfn)
8912 [ # # ]: 0 : LIBPAW_DEALLOCATE(yy)
8913 [ # # ]: 0 : LIBPAW_DEALLOCATE(zz)
8914 : 0 : END SUBROUTINE unboundked
8915 : :
8916 : :
8917 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8918 : : ! Set_Pot
8919 : : ! Version with polynomial fitting of vtau for 0<=r<=0.001
8920 : : ! and corresponding reseting of oneplusvtau and dvtaudr in that range
8921 : : ! NAWH 4/6/2021
8922 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8923 [ # # # # ]: 0 : Subroutine Set_Pot(Grid,Pot,qq,zxc,oneplusvtau,dvtaudr)
8924 : : real(dp),intent(inout) :: qq,zxc
8925 : : real(dp),intent(inout) :: oneplusvtau(:),dvtaudr(:)
8926 : : Type(GridInfo), INTENT(IN) :: Grid
8927 : : TYPE(PotentialInfo), INTENT(IN) :: Pot
8928 : : INTEGER :: n
8929 : : REAL(dp),parameter :: smallr=0.001_dp
8930 : : INTEGER, parameter :: order=4
8931 : 0 : n=Grid%n
8932 : : ! check for possible ionic charge
8933 : 0 : qq=-Pot%rv(n)/two
8934 [ # # ]: 0 : if(qq<0.001_dp) qq=zero
8935 [ # # # # ]: 0 : oneplusvtau=0._dp; dvtaudr=0._dp
8936 [ # # ]: 0 : oneplusvtau=1._dp+Pot%vtau
8937 : 0 : call derivative(Grid,Pot%vtau,dvtaudr)
8938 : 0 : zxc=Pot%rvx(1)
8939 : 0 : END Subroutine Set_Pot
8940 : :
8941 : :
8942 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8943 : : ! SUBROUTINE wfnkedinit(Grid,l,nz,v0,wfn,lwfn,istart)
8944 : : ! returns the solution of the modified KS equations near r=0
8945 : : ! using power series expansion assuming including vtau contributions
8946 : : ! wfn=P(r) lwfn=(1+vtau)*dP/dr
8947 : : ! P(r)~~(r**(l+1))*(1+c1*r)
8948 : : ! Assumes v(r) ~~ -2*nz/r+zxc/r for r-->0
8949 : : ! Assumes vtau(r) -- t0 +t1*r for r-->0
8950 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8951 [ # # # # ]: 0 : SUBROUTINE wfnkedinit(Grid,l,nz,wfn,lwfn,istart,zxc,oneplusvtau,dvtaudr)
8952 : : real(dp),intent(in) :: zxc
8953 : : real(dp),intent(in) :: oneplusvtau(:),dvtaudr(:)
8954 : : Type(GridInfo), INTENT(IN) :: Grid
8955 : : INTEGER, INTENT(IN) :: l,nz
8956 : : REAL(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
8957 : : INTEGER, INTENT(OUT) :: istart
8958 : : REAL(dp) :: rr,c1,t1,t0
8959 : : INTEGER :: i
8960 : 0 : t0=oneplusvtau(1);t1=dvtaudr(1)
8961 [ # # # # ]: 0 : wfn=zero; lwfn=zero
8962 : 0 : c1=-(two*nz-zxc+l*t1)/(two*(l+1)*(oneplusvtau(1)))
8963 : 0 : istart=6
8964 [ # # ]: 0 : do i=1,istart
8965 : 0 : rr=Grid%r(i)
8966 : 0 : wfn(i)=1+rr*c1
8967 : 0 : lwfn(i)=(rr**l)*((l+1)*wfn(i)+rr*(c1))
8968 : 0 : lwfn(i)=(t0+t1*rr)*lwfn(i)
8969 : 0 : wfn(i)=wfn(i)*(rr**(l+1))
8970 : : enddo
8971 : 0 : End SUBROUTINE wfnkedinit
8972 : :
8973 : :
8974 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8975 : : !! subroutine setupforcfdsol(Grid,rv,i1,i2,n,l,energy,wfn,lwfn,yy,zz)
8976 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8977 [ # # # # : 0 : subroutine setupforcfdsol(Grid,rv,i1,i2,n,l,energy,wfn,lwfn,yy,zz,oneplusvtau,dvtaudr)
# # # # #
# # # #
# ]
8978 : : Type(gridinfo), INTENT(IN) :: Grid
8979 : : real(dp),intent(in) :: oneplusvtau(:),dvtaudr(:)
8980 : : INTEGER, INTENT(IN) :: i1,i2,n,l
8981 : : REAL(dp), INTENT(IN) :: energy
8982 : : REAL(dp), INTENT(IN) :: wfn(:),lwfn(:),rv(:)
8983 : : REAL(dp), INTENT(INOUT) :: yy(:,:),zz(:,:,:)
8984 : : INTEGER :: i
8985 : : REAL(dp) :: x
8986 : 0 : x=l*(l+1)
8987 [ # # # # : 0 : yy=zero;zz=zero
# # # # #
# ]
8988 [ # # ]: 0 : yy(1,i1:i2)=wfn(i1:i2)
8989 [ # # ]: 0 : yy(2,i1:i2)=lwfn(i1:i2)
8990 [ # # ]: 0 : do i=1,n
8991 : 0 : zz(1,2,i)=1._dp/oneplusvtau(i)
8992 [ # # ]: 0 : if(i==1) then
8993 : 0 : zz(2,1,i)=0._dp
8994 : : else
8995 : : zz(2,1,i)=oneplusvtau(i)*x/(Grid%r(i)*Grid%r(i))+&
8996 : 0 : & dvtaudr(i)/Grid%r(i)+(rv(i)/Grid%r(i)-energy)
8997 : : endif
8998 : : enddo
8999 : 0 : end subroutine setupforcfdsol
9000 : :
9001 : :
9002 : :
9003 : :
9004 : :
9005 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9006 : : ! 16. splinesolver
9007 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9008 : :
9009 : :
9010 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9011 : : ! Program uses two grids -- "universal grid" Grid
9012 : : ! and modified grid Grids, with fixed Grids%n=401 and ns=400
9013 : : ! and Grids%r0=0.1 which are found to work well for splinesolver
9014 : : ! Internally need to omit origin and so ns=Grids%n-1
9015 : : ! For MGGA case (needvtau=.true.) also need fine linear grid
9016 : : ! Gridf
9017 : : ! Setup local private grid
9018 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9019 : 0 : SUBROUTINE initsplinesolver(Grid,splns,splr0,needvtau,spline)
9020 : : type(splinesolvinfo),intent(inout) :: spline
9021 : : logical,intent(in) :: needvtau
9022 : : Type(GridInfo), INTENT(IN) :: Grid !Input universal grid
9023 : : INTEGER, INTENT(IN) :: splns !spline grid
9024 : : REAL(dp), INTENT(IN) :: splr0 !spline r0
9025 : : INTEGER :: i,nf
9026 : : REAL(dp) :: hf
9027 : 0 : spline%r0=splr0
9028 : 0 : spline%ns=splns
9029 : 0 : spline%h=log(1._dp+Grid%r(Grid%n)/spline%r0)/spline%ns
9030 : 0 : call initgridwithn(spline%Grids,2,spline%ns+1,spline%r0,spline%h) !local loggrid
9031 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'initsplinesolve ', spline%r0,spline%ns,spline%h
9032 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%u,(spline%ns+1))
# # # # #
# # # # #
# # ]
9033 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%pref,(spline%ns+1))
# # # # #
# ]
9034 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%rr1,(spline%ns+1))
# # # # #
# ]
9035 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%rr2,(spline%ns+1))
# # # # #
# ]
9036 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%srv,(spline%ns+1))
# # # # #
# ]
9037 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%svtau,(spline%ns+1))
# # # # #
# ]
9038 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%sdvt,(spline%ns+1))
# # # # #
# ]
9039 [ # # # # : 0 : LIBPAW_ALLOCATE(spline%soneplusvt,(spline%ns+1))
# # # # #
# ]
9040 [ # # ]: 0 : do i=1,spline%ns+1
9041 : 0 : spline%u(i)=(i-1)*spline%h
9042 : 0 : spline%pref(i)=exp(0.5_dp*spline%u(i))
9043 : 0 : spline%rr1(i)=((spline%Grids%r(i)+spline%r0))
9044 : 0 : spline%rr2(i)=((spline%Grids%r(i)+spline%r0)**2)
9045 : : enddo
9046 [ # # ]: 0 : if(needvtau) then ! set up fine linear grid
9047 : 0 : nf=20001
9048 : 0 : hf=Grid%r(Grid%n)/(nf-1)
9049 : 0 : call initgridwithn(spline%Gridf,1,nf,0._dp,hf) !local fine linear grid
9050 [ # # # # ]: 0 : LIBPAW_ALLOCATE(spline%fvtau,(nf))
9051 [ # # # # ]: 0 : LIBPAW_ALLOCATE(spline%fdvtaudr,(nf))
9052 [ # # # # ]: 0 : LIBPAW_ALLOCATE(spline%frvx,(nf))
9053 [ # # # # ]: 0 : LIBPAW_ALLOCATE(spline%fden,(nf))
9054 [ # # # # ]: 0 : LIBPAW_ALLOCATE(spline%ftau,(nf))
9055 [ # # # # : 0 : spline%fvtau=0._dp;spline%fdvtaudr=0._dp;spline%frvx=0._dp
# # ]
9056 [ # # # # ]: 0 : spline%fden=0._dp;spline%ftau=0._dp
9057 : : endif
9058 [ # # ]: 0 : spline%soneplusvt=1._dp;
9059 [ # # # # ]: 0 : spline%svtau=0._dp;spline%sdvt=0._dp
9060 : 0 : END SUBROUTINE initsplinesolver
9061 : :
9062 : :
9063 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9064 : : !!
9065 : : !! SUBROUTINE initpotforsplinesolver
9066 : : !!
9067 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9068 [ # # # # ]: 0 : SUBROUTINE initpotforsplinesolver(Grid,Pot,den,tau,spline,itype)
9069 : : type(splinesolvinfo),intent(inout) :: spline
9070 : : Type(GridInfo), INTENT(IN) :: Grid
9071 : : integer,intent(in) :: itype
9072 : : Type(Potentialinfo), INTENT(INOUT) :: Pot !Universal grid
9073 : : REAL(dp), INTENT(IN) :: den(:),tau(:) !Universal grid
9074 : : INTEGER :: i,n
9075 : 0 : REAL(dp), allocatable :: dum(:),dum1(:)
9076 : : REAL(dp) :: etxc,eexc
9077 : 0 : n=Grid%n
9078 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'initpot ', n,spline%ns
9079 [ # # ]: 0 : If (Pot%needvtau) then
9080 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(spline%ns+1))
# # # # #
# # # #
# ]
9081 [ # # # # : 0 : LIBPAW_ALLOCATE(dum1,(spline%ns+1))
# # # # ]
9082 : 0 : call interpfunc(n,Grid%r,den,spline%Gridf%n,spline%Gridf%r,spline%fden)
9083 : 0 : call interpfunc(n,Grid%r,tau,spline%Gridf%n,spline%Gridf%r,spline%ftau)
9084 : 0 : call exch(spline%Gridf,spline%fden,spline%frvx,etxc,eexc,itype=itype,tau=spline%ftau,vtau=spline%fvtau)
9085 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'called exch from splinesolver ', eexc
9086 : 0 : call nderiv(spline%Gridf%h,spline%fvtau,spline%fdvtaudr,spline%Gridf%n,i)
9087 [ # # # # : 0 : dum=Pot%rvn+Pot%rvh ! presumably these are smooth
# # # # ]
9088 : 0 : call interpfunc(n,Grid%r,dum,spline%ns+1,spline%Grids%r,spline%srv)
9089 : 0 : call interpfunc(spline%Gridf%n,spline%Gridf%r,spline%frvx,spline%Grids%n,spline%Grids%r,dum1)
9090 [ # # # # ]: 0 : spline%srv=spline%srv+dum1
9091 : 0 : call interpfunc(spline%Gridf%n,spline%Gridf%r,spline%fvtau,spline%Grids%n,spline%Grids%r,spline%svtau)
9092 : 0 : call interpfunc(spline%Gridf%n,spline%Gridf%r,spline%fdvtaudr,spline%Grids%n,spline%Grids%r,spline%sdvt)
9093 [ # # # # : 0 : spline%soneplusvt=1._dp+spline%svtau
# # # # ]
9094 [ # # # # ]: 0 : spline%sdvt=spline%sdvt*spline%Grids%drdu ! needed in algorithm
9095 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
9096 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum1)
9097 : : else ! finegrid not needed
9098 : 0 : call interpfunc(n,Grid%r,Pot%rv,spline%ns+1,spline%Grids%r,spline%srv)
9099 [ # # ]: 0 : spline%soneplusvt=1._dp;
9100 [ # # # # ]: 0 : spline%svtau=0._dp;spline%sdvt=0._dp
9101 : : endif
9102 [ # # # # ]: 0 : END SUBROUTINE initpotforsplinesolver
9103 : :
9104 : :
9105 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9106 : : !! SUBROUTINE Boundsplinesolver(Grid,l,neig,eig,wfn,otau,OK)
9107 : : !! Note that although the universal Grid and the local Grids
9108 : : !! have the same range, they differ by the number of points and
9109 : : !! the r0 parameter.
9110 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9111 [ # # # # : 0 : SUBROUTINE Boundsplinesolver(Grid,l,neig,eig,wfn,otau,OK,spline)
# # ]
9112 : : type(splinesolvinfo),intent(inout) :: spline
9113 : : Type(GridInfo), INTENT(IN) :: Grid
9114 : : INTEGER, INTENT(IN) :: l,neig
9115 : : REAL(dp), INTENT(INOUT) :: eig(:),wfn(:,:),otau(:,:)
9116 : : LOGICAL, INTENT(OUT) :: OK
9117 : 0 : real(dp), allocatable :: A(:,:),B(:,:),G(:,:),D(:),DL(:),DU(:),work(:)
9118 : 0 : real(dp), allocatable :: vl(:,:),vr(:,:),wr(:),wi(:)
9119 : 0 : integer, allocatable :: lut(:)
9120 : 0 : REAL(dp), allocatable :: P(:),MP(:)
9121 : 0 : REAL(dp), allocatable :: dum(:),dP1(:)
9122 : 0 : REAL(dp), allocatable :: F1(:,:),F2(:,:),S(:),E(:),V(:)
9123 : : integer :: i,m,n, info,lwork,nu
9124 : : real(dp) :: ol,x
9125 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'entering boundspline with l,neig ', l, neig
9126 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'in splinesolver '
9127 : 0 : OK=.false.
9128 : 0 : n=spline%ns+1 !Grids%n within this routine only
9129 : 0 : nu=Grid%n ! Universal grid
9130 : 0 : ol=l*(l+1)
9131 : 0 : lwork=spline%ns**2
9132 [ # # # # : 0 : LIBPAW_ALLOCATE(A,(spline%ns,spline%ns))
# # # # #
# # # # #
# # ]
9133 [ # # # # : 0 : LIBPAW_ALLOCATE(B,(spline%ns,spline%ns))
# # # # #
# # # ]
9134 [ # # # # : 0 : LIBPAW_ALLOCATE(G,(spline%ns,spline%ns))
# # # # #
# # # ]
9135 [ # # # # : 0 : LIBPAW_ALLOCATE(D,(spline%ns))
# # # # #
# # # ]
9136 [ # # # # : 0 : LIBPAW_ALLOCATE(DL,(spline%ns))
# # # # ]
9137 [ # # # # : 0 : LIBPAW_ALLOCATE(DU,(spline%ns))
# # # # ]
9138 [ # # # # : 0 : LIBPAW_ALLOCATE(work,(lwork))
# # # # #
# # # ]
9139 [ # # # # : 0 : LIBPAW_ALLOCATE(vl,(spline%ns,spline%ns))
# # # # #
# # # ]
9140 [ # # # # : 0 : LIBPAW_ALLOCATE(vr,(spline%ns,spline%ns))
# # # # #
# # # ]
9141 [ # # # # : 0 : LIBPAW_ALLOCATE(wr,(spline%ns))
# # # # ]
9142 [ # # # # : 0 : LIBPAW_ALLOCATE(wi,(spline%ns))
# # # # ]
9143 [ # # # # : 0 : LIBPAW_ALLOCATE(lut,(spline%ns))
# # # # #
# # # ]
9144 [ # # # # : 0 : LIBPAW_ALLOCATE(P,(n))
# # # # #
# # # ]
9145 [ # # # # : 0 : LIBPAW_ALLOCATE(MP,(n))
# # # # ]
9146 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(nu))
# # # # #
# # # ]
9147 [ # # # # : 0 : LIBPAW_ALLOCATE(dP1,(nu))
# # # # ]
9148 [ # # # # : 0 : LIBPAW_ALLOCATE(F1,(spline%ns,spline%ns))
# # # # #
# # # ]
9149 [ # # # # : 0 : LIBPAW_ALLOCATE(F2,(spline%ns,spline%ns))
# # # # #
# # # ]
9150 [ # # # # : 0 : LIBPAW_ALLOCATE(S,(n))
# # # # ]
9151 [ # # # # : 0 : LIBPAW_ALLOCATE(E,(n))
# # # # ]
9152 [ # # # # : 0 : LIBPAW_ALLOCATE(V,(n))
# # # # ]
9153 [ # # ]: 0 : D(1:spline%ns)=2._dp
9154 [ # # ]: 0 : DL(1:spline%ns-1)=0.5_dp
9155 [ # # ]: 0 : DU(1:spline%ns-1)=0.5_dp
9156 : : !correct first row assuming wfn=r^(l+1)*(W0+r*W1)
9157 : 0 : D(1)=0.5_dp*(5._dp+two*l)/(1._dp+l)
9158 [ # # # # ]: 0 : B=0._dp
9159 [ # # ]: 0 : do i=1,spline%ns
9160 : 0 : B(i,i)=1._dp
9161 : : enddo
9162 : 0 : call dgtsv(spline%ns,spline%ns,DL,D,DU,B,spline%ns,info)
9163 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'Completed dgtsv with info = '
9164 [ # # # # ]: 0 : A=0._dp
9165 [ # # ]: 0 : do i=1,spline%ns
9166 : 0 : A(i,i)=-2._dp
9167 : : enddo
9168 [ # # ]: 0 : do i=1,spline%ns-1
9169 : 0 : A(i,i+1)=1._dp
9170 : 0 : A(i+1,i)=1._dp
9171 : : enddo
9172 : : ! correct first row values
9173 : 0 : A(1,1)=-0.5_dp*(l+4._dp);
9174 [ # # # # ]: 0 : A=3.0_dp*A/(spline%h**2)
9175 [ # # # # ]: 0 : G=0._dp
9176 [ # # # # : 0 : G=MATMUL(B,A) ! G stores transformation to find M=G*y
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
9177 : : ! Calculate full matrix
9178 [ # # # # : 0 : A=0.0_dp;S=0.0_dp;E=0.0_dp;V=0.0_dp
# # # # #
# ]
9179 : : ! These arrays have the full range 1..n
9180 [ # # # # : 0 : S=-spline%soneplusvt/spline%rr2
# # # # ]
9181 [ # # # # : 0 : E=-spline%sdvt/spline%rr2
# # # # ]
9182 [ # # # # : 0 : V=0.5_dp*E-0.25_dp*S !Including only non diverging term
# # # # ]
9183 [ # # ]: 0 : do i=2,n
9184 : : V(i)=V(i)+spline%soneplusvt(i)*ol/(spline%Grids%r(i)**2)&
9185 : : & +spline%sdvt(i)/(spline%Grids%r(i)*spline%rr1(i)) &
9186 : 0 : & +spline%srv(i)/spline%Grids%r(i)
9187 : : enddo
9188 [ # # # # : 0 : F1=0._dp;F2=0._dp
# # # # ]
9189 [ # # ]: 0 : do i=1,spline%ns
9190 : 0 : F1(i,i)=S(i+1)-E(i+1)*spline%h/three
9191 : 0 : F1(i,i+1)=-E(i+1)*spline%h/six
9192 : 0 : F2(i,i)=V(i+1)-E(i+1)/spline%h
9193 : 0 : F2(i,i+1)=E(i+1)/spline%h
9194 : : ENDDO
9195 [ # # # # : 0 : A=MATMUL(F1,G)+F2
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
9196 : 0 : call dgeev('N','V',spline%ns,A,spline%ns,wr,wi,vl,spline%ns,vr,spline%ns,work,lwork,info)
9197 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'dgeev completed with info = ',info
9198 [ # # ]: 0 : if (info/=0) then
9199 : 0 : OK=.false.
9200 : 0 : return
9201 : : endif
9202 : 0 : call real_InsSort(wr,lut,.true.)
9203 [ # # # # : 0 : if(has_to_print) write(std_out,*) 'Results for l = ', l, (wr(lut(i)),i=1,10)
# # ]
9204 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'enumeration for neig solutions ', neig
9205 [ # # ]: 0 : do m=1,neig
9206 [ # # ]: 0 : if(has_to_print) write(std_out,'(1p,2e20.8)') wr(lut(m)),wi(lut(m))
9207 : 0 : eig(m)=wr(lut(m))
9208 [ # # # # ]: 0 : D=vr(:,lut(m)) !Q
9209 [ # # # # : 0 : DL=MATMUL(G,D) !MQ
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
9210 : : ! now extend grid to r=0 Still Q and MQ
9211 [ # # # # ]: 0 : P=0.0_dp;MP=0.0_dp
9212 [ # # ]: 0 : P(2:spline%ns+1)=D(1:spline%ns)
9213 [ # # ]: 0 : MP(2:spline%ns+1)=DL(1:spline%ns)
9214 [ # # ]: 0 : if(l==0) then
9215 [ # # ]: 0 : dum=0
9216 [ # # ]: 0 : do i=2,10
9217 : 0 : dum(i)=P(i)/spline%Grids%r(i)
9218 : : enddo
9219 : 0 : call extrapolate(dum)
9220 : 0 : x=1._dp/(S(1)-E(1)*spline%h/three)
9221 : 0 : MP(1)=(E(1)*(MP(2)*spline%h/six-P(2))-(spline%sdvt(1)/spline%rr1(1)+spline%srv(1))*dum(1))*x
9222 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'MP(1) for l=0',MP(1),dum(1)
9223 : : endif
9224 [ # # ]: 0 : if(l==1) then
9225 [ # # ]: 0 : dum=0.0_dp
9226 [ # # ]: 0 : do i=2,10
9227 : 0 : dum(i)=P(i)/(spline%Grids%r(i)**2)
9228 : : enddo
9229 : 0 : call extrapolate(dum)
9230 : 0 : x=1._dp/(S(1)-E(1)*spline%h/three)
9231 : 0 : MP(1)=(E(1)*(MP(2)*spline%h/six-P(2))-(two*spline%soneplusvt(1))*dum(1))*x
9232 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'MP(1) for l=1',MP(1),dum(1)
9233 : : endif
9234 [ # # # # : 0 : MP=spline%pref*(MP-0.25_dp*P)/spline%rr2
# # # # ]
9235 [ # # # # : 0 : P=spline%pref*P
# # # # ]
9236 : 0 : call specialinterp(n,spline%Grids%r,P,MP,Grid%n,Grid%r,wfn(:,m),dP1(:))
9237 [ # # # # ]: 0 : dum=0._dp; dum(2:nu)=wfn(2:nu,m)/Grid%r(2:nu)
9238 : 0 : call extrapolate(dum)
9239 [ # # ]: 0 : do i=1,nu
9240 : 0 : otau(i,m)= (dP1(i)-dum(i))**2+l*(l+1)*(dum(i))**2
9241 : : enddo
9242 : 0 : x=overlap(Grid,wfn(:,m),wfn(:,m))
9243 [ # # ]: 0 : if(has_to_print) write(std_out,*) 'overlap integral ', x
9244 : 0 : x=1._dp/x
9245 [ # # ]: 0 : otau(:,m)=x*otau(:,m)
9246 : 0 : x=sqrt(x)
9247 [ # # ]: 0 : wfn(:,m)=x*wfn(:,m) ! should be normalized now
9248 : : enddo
9249 : 0 : OK=.true.
9250 [ # # ]: 0 : LIBPAW_DEALLOCATE(A)
9251 [ # # ]: 0 : LIBPAW_DEALLOCATE(B)
9252 [ # # ]: 0 : LIBPAW_DEALLOCATE(G)
9253 [ # # ]: 0 : LIBPAW_DEALLOCATE(D)
9254 [ # # ]: 0 : LIBPAW_DEALLOCATE(DL)
9255 [ # # ]: 0 : LIBPAW_DEALLOCATE(DU)
9256 [ # # ]: 0 : LIBPAW_DEALLOCATE(work)
9257 [ # # ]: 0 : LIBPAW_DEALLOCATE(vl)
9258 [ # # ]: 0 : LIBPAW_DEALLOCATE(vr)
9259 [ # # ]: 0 : LIBPAW_DEALLOCATE(wr)
9260 [ # # ]: 0 : LIBPAW_DEALLOCATE(wi)
9261 [ # # ]: 0 : LIBPAW_DEALLOCATE(lut)
9262 [ # # ]: 0 : LIBPAW_DEALLOCATE(P)
9263 [ # # ]: 0 : LIBPAW_DEALLOCATE(MP)
9264 [ # # ]: 0 : LIBPAW_DEALLOCATE(dP1)
9265 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
9266 [ # # ]: 0 : LIBPAW_DEALLOCATE(F1)
9267 [ # # ]: 0 : LIBPAW_DEALLOCATE(F2)
9268 [ # # ]: 0 : LIBPAW_DEALLOCATE(S)
9269 [ # # ]: 0 : LIBPAW_DEALLOCATE(E)
9270 [ # # ]: 0 : LIBPAW_DEALLOCATE(V)
9271 [ # # # # : 0 : end SUBROUTINE Boundsplinesolver
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
9272 : :
9273 : :
9274 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9275 : : !! SUBROUTINE deallocatesplinesolver
9276 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9277 : 4 : SUBROUTINE deallocatesplinesolver(spline,needvtau)
9278 : : type(splinesolvinfo),intent(inout) :: spline
9279 : : logical,intent(in) :: needvtau
9280 [ - + ]: 4 : if (allocated(spline%u)) then
9281 : 0 : LIBPAW_DEALLOCATE(spline%u)
9282 : : endif
9283 [ - + ]: 4 : if (allocated(spline%pref)) then
9284 : 0 : LIBPAW_DEALLOCATE(spline%pref)
9285 : : endif
9286 [ - + ]: 4 : if (allocated(spline%rr1)) then
9287 : 0 : LIBPAW_DEALLOCATE(spline%rr1)
9288 : : endif
9289 [ - + ]: 4 : if (allocated(spline%rr2)) then
9290 : 0 : LIBPAW_DEALLOCATE(spline%rr2)
9291 : : endif
9292 [ - + ]: 4 : if (allocated(spline%srv)) then
9293 : 0 : LIBPAW_DEALLOCATE(spline%srv)
9294 : : endif
9295 [ - + ]: 4 : if (allocated(spline%svtau)) then
9296 : 0 : LIBPAW_DEALLOCATE(spline%svtau)
9297 : : endif
9298 [ - + ]: 4 : if (allocated(spline%soneplusvt)) then
9299 : 0 : LIBPAW_DEALLOCATE(spline%soneplusvt)
9300 : : endif
9301 : 4 : call destroygrid(spline%Grids)
9302 [ - + ]: 4 : if(needvtau) then
9303 [ # # ]: 0 : LIBPAW_DEALLOCATE(spline%fvtau)
9304 [ # # ]: 0 : LIBPAW_DEALLOCATE(spline%fdvtaudr)
9305 [ # # ]: 0 : LIBPAW_DEALLOCATE(spline%frvx)
9306 [ # # ]: 0 : LIBPAW_DEALLOCATE(spline%fden)
9307 [ # # ]: 0 : LIBPAW_DEALLOCATE(spline%ftau)
9308 : 0 : call destroygrid(spline%Gridf)
9309 : : endif
9310 : 4 : END SUBROUTINE deallocatesplinesolver
9311 : :
9312 : :
9313 : :
9314 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9315 : : ! 17. radialdirac
9316 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9317 : :
9318 : :
9319 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9320 : : !! SUBROUTINE boundD(Grid,Pot,eig,wfn,lwfn,kappa,nroot,emin,ierr,success)
9321 : : !! pgm to solve radial Dirac relativistic equation for nroot bound state
9322 : : !! energies and wavefunctions for spin orbit parameter kappa
9323 : : !! with potential rv/r, given in uniform linear or log mesh of n points
9324 : : !! nz=nuclear charge
9325 : : !! emin=is estimate of lowest eigenvalue; used if nz=0
9326 : : !! otherwise, set to the value of -(nz/(l+1))**2
9327 : : !! It is assumed that the wavefunction has np-l-1 nodes, where
9328 : : !! np is the principal quantum number-- np=1,2,..nroot
9329 : : !! Does not use Noumerov algorithm -- but uses coupled first-order
9330 : : !! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
9331 : : !! Corrections are also needed for r>n*h, depending on:
9332 : : !! e0 (current guess of energy eigenvalue
9333 : : !! the extrapolated value of rv == r * v
9334 : : !! ierr=an nroot digit number indicating status of each root
9335 : : !! a digit of 1 indicates success in converging root
9336 : : !! 2 indicates near success in converging root
9337 : : !! 9 indicates that root not found
9338 : : !! first check how many roots expected = ntroot (returned as argument)
9339 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9340 [ - + - + : 206 : SUBROUTINE boundD(Grid,Pot,eig,wfn,lwfn,kappa,nroot,emin,ierr,success)
- + ]
9341 : : TYPE(GridInfo), INTENT(IN) :: Grid
9342 : : TYPE(PotentialInfo), INTENT(INout) :: Pot
9343 : : REAL(dp), INTENT(INOUT) :: eig(:),wfn(:,:),lwfn(:,:)
9344 : : INTEGER, INTENT(IN) :: kappa,nroot
9345 : : INTEGER, INTENT(INOUT) :: ierr
9346 : : REAL(dp), INTENT(INOUT) :: emin
9347 : : LOGICAL, INTENT(INOUT) :: success
9348 : : REAL(dp), PARAMETER :: convre=1.d-10,vlrg=1.d30
9349 : : REAL(dp), PARAMETER :: ftr=0.5_dp/InvFineStruct
9350 : : INTEGER, PARAMETER :: niter=1000
9351 : 206 : REAL(dp), POINTER :: rv(:)
9352 : 206 : REAL(dp), ALLOCATABLE :: p1(:),lp1(:),p2(:),lp2(:),dd(:)
9353 : : INTEGER :: n
9354 : : REAL(dp) :: nz,h,v0,v0p
9355 : : REAL(dp) :: err,convrez,energy
9356 : : REAL(dp) :: scale,emax,best,rout
9357 : : REAL(dp) :: arg,rin,dele,x
9358 : : INTEGER :: iter,i,j,node,match,mxroot,ntroot,ir,iroot,l
9359 : : INTEGER :: ifac,istart,iend
9360 : : LOGICAL :: ok
9361 : : Real(dp) :: A0,B0,A1,B1,s
9362 : : REAL(dp), allocatable :: zz(:,:,:),yy(:,:)
9363 : 206 : n=Grid%n
9364 : 206 : h=Grid%h
9365 : 126 : if (kappa<0) l=-kappa-1
9366 [ + + ]: 206 : if (kappa>0) l=kappa
9367 [ - + + - : 618 : LIBPAW_ALLOCATE(p1,(n))
+ - + - -
+ - + ]
9368 [ - + + - : 412 : LIBPAW_ALLOCATE(lp1,(n))
- + - + ]
9369 [ - + + - : 412 : LIBPAW_ALLOCATE(p2,(n))
- + - + ]
9370 [ - + + - : 412 : LIBPAW_ALLOCATE(lp2,(n))
- + - + ]
9371 [ - + + - : 412 : LIBPAW_ALLOCATE(dd,(n))
- + - + ]
9372 [ - + + - : 618 : LIBPAW_ALLOCATE(zz,(2,2,n))
+ - + - -
+ - + ]
9373 [ - + + - : 618 : LIBPAW_ALLOCATE(yy,(2,n))
+ - + - -
+ - + ]
9374 : 206 : success=.true.
9375 : 206 : nz=Pot%nz
9376 : 206 : v0=Pot%v0
9377 : 206 : v0p=Pot%v0p
9378 : 206 : rv=>Pot%rv
9379 : 206 : err=n*nz*(h**4)
9380 : 206 : convrez=convre
9381 [ + - ]: 206 : IF (nz>0.001_dp) convrez=convre*nz
9382 : 206 : ierr=0
9383 [ - + ]: 206 : if(has_to_print) WRITE(STD_OUT,*) 'z ,kappa, l = ',nz,kappa,l
9384 : : ! check how many roots expected by integration outward at
9385 : : ! energy = 0
9386 : 206 : energy = zero
9387 : 206 : call Dzeroexpand(Grid,Pot,kappa,energy,A0,A1,B0,B1,s)
9388 [ + + + + : 4122266 : zz=zero;yy=zero
+ + + + +
+ ]
9389 : 206 : call wfnDinit(Grid,p1,lp1,istart,A0,A1,B0,B1,s,Pot%finitenucleus)
9390 : : !start outward integration
9391 : 206 : call prepareforcfdsolD(Grid,1,istart,n,kappa,p1,lp1,yy,zz,Pot%ww,Pot%jj)
9392 : 206 : call cfdsoliter(Grid,zz,yy,istart,n)
9393 : 206 : call getwfnfromcfdsolD(1,n,yy,p1,lp1)
9394 : 206 : node=countnodes(2,n,p1)
9395 [ - + ]: 206 : if(has_to_print) WRITE(STD_OUT,*) ' nodes at e=0 ', node
9396 : 206 : mxroot=node+1
9397 : 206 : ntroot=node
9398 [ - + ]: 206 : IF (mxroot.LT.nroot) THEN
9399 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*)'error in boundD - for l = ',l
9400 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) nroot,' states requested but only',mxroot,' possible'
9401 [ # # ]: 0 : DO ir=mxroot+1,nroot
9402 : 0 : ierr=ierr+9*(10**(ir-1))
9403 : : ENDDO
9404 : 0 : success=.false.
9405 : : ENDIF
9406 : 206 : mxroot=min0(mxroot,nroot)
9407 [ - + ]: 206 : IF (nz.EQ.0) energy=-ABS(emin)
9408 [ + - ]: 206 : IF (nz.NE.0) energy=-1.1_dp*(nz/(l+1._dp))**2
9409 : 206 : emin=energy-err
9410 : 206 : emax=0._dp
9411 [ + + ]: 630 : DO iroot=1,mxroot
9412 : 424 : best=1.d10; dele=1.d10
9413 : 424 : energy=emin+err
9414 [ - + ]: 424 : IF (energy.LT.emin) energy=emin
9415 [ - + ]: 424 : IF (energy.GT.emax) energy=emax
9416 : 17024 : ok=.FALSE.
9417 [ + + ]: 17024 : BigIter: DO iter=1,niter
9418 : : ! start inward integration
9419 : : ! start integration at n
9420 : 17014 : call Dzeroexpand(Grid,Pot,kappa,energy,A0,A1,B0,B1,s)
9421 : : ! find classical turning point
9422 : 17014 : call ClassicalTurningPoint(Grid,Pot%rv,l,energy,match)
9423 : 17014 : match=max(match,10); match=min(match,n-20)
9424 : 17014 : call wfnDasym(Grid,p2,lp2,energy,iend)
9425 : 17014 : call prepareforcfdsolD(Grid,n-iend,n,n,kappa,p2,lp2,yy,zz,Pot%ww,Pot%jj)
9426 : 17014 : call cfdsoliter(Grid,zz,yy,n-iend,match)
9427 : 17014 : call getwfnfromcfdsolD(match,n,yy,p2,lp2)
9428 : 17014 : match=match+6
9429 : 17014 : rin=lp2(match)/p2(match)
9430 : 17014 : call wfnDinit(Grid,p1,lp1,istart,A0,A1,B0,B1,s,Pot%finitenucleus)
9431 : 17014 : call prepareforcfdsolD(Grid,1,istart,n,kappa,p1,lp1,yy,zz,Pot%ww,Pot%jj)
9432 : 17014 : call cfdsoliter(Grid,zz,yy,istart,match+6)
9433 : 17014 : call getwfnfromcfdsolD(1,match+6,yy,p1,lp1)
9434 : 17014 : node= countnodes(2,match+6,p1)
9435 : 17014 : rout=lp1(match)/p1(match)
9436 : : ! check whether node = (iroot-1)
9437 : : ! not enough nodes -- raise energy
9438 [ + + ]: 51052 : IF (node.LT.iroot-1) THEN
9439 : 439 : emin=MAX(emin,energy)-err
9440 : 439 : energy=emax-(emax-energy)*ranx()
9441 : 439 : ifac=9
9442 : : ! too many nodes -- lower energy
9443 [ + + ]: 16575 : ELSEIF (node.GT.iroot-1) THEN
9444 [ - + ]: 281 : IF (energy.LE.emin) THEN
9445 : 0 : ierr=ierr+9*(10**(iroot-1))
9446 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,*) 'boundD error -- emin too high',l,nz,emin,energy
9447 [ # # ]: 0 : IF (energy.LE.emin-1.d-10) THEN
9448 : 0 : STOP
9449 : : ENDIF
9450 : : ENDIF
9451 : 281 : emax=MIN(emax,energy+err)
9452 : 281 : energy=emin+(energy-emin)*ranx()
9453 : : ! correct number of nodes -- estimate correction
9454 [ + - ]: 16294 : ELSEIF (node.EQ.iroot-1) THEN
9455 [ + + ]: 9003011 : DO j=1,match
9456 : 8986717 : p1(j)=p1(j)/p1(match)
9457 : 9003011 : lp1(j)=ftr*lp1(j)/p1(match)
9458 : : ENDDO
9459 [ + + ]: 23650165 : DO j=match,n
9460 : 23633871 : p1(j)=p2(j)/p2(match)
9461 : 23650165 : lp1(j)=ftr*lp2(j)/p2(match)
9462 : : ENDDO
9463 : 16294 : scale=overlap(Grid,p1,p1)+overlap(Grid,lp1,lp1)
9464 : 16294 : dele=(rout-rin)/scale
9465 : 16294 : x=ABS(dele)
9466 [ + + ]: 16294 : IF (x.LT.best) THEN
9467 : 3039 : scale=1._dp/SQRT(scale)
9468 [ + + ]: 6084078 : p1(1:n)=p1(1:n)*scale
9469 [ + + ]: 6084078 : lp1(1:n)=lp1(1:n)*scale
9470 : 3039 : call filter(n,p1,machine_zero)
9471 : 3039 : call filter(n,lp1,machine_zero)
9472 [ + + ]: 6084078 : wfn(1:n,iroot)=p1(1:n)
9473 [ + + ]: 6084078 : lwfn(1:n,iroot)=lp1(1:n)
9474 : 3039 : eig(iroot)=energy
9475 : 3039 : best=x
9476 : : ENDIF
9477 [ + + ]: 16294 : IF (ABS(dele).LE.convrez) THEN
9478 : 414 : ok=.TRUE.
9479 : : ! eigenvalue found
9480 : 414 : ierr=ierr+10**(iroot-1)
9481 [ + + ]: 414 : IF (iroot+1.LE.mxroot) THEN
9482 : 218 : emin=energy+err
9483 : 218 : emax=zero
9484 : 218 : energy=(emin+emax)/2
9485 [ - + ]: 218 : IF (energy.LT.emin) energy=emin
9486 [ - + ]: 218 : IF (energy.GT.emax) energy=emax
9487 : 218 : best=1.d10
9488 : : ENDIF
9489 : : EXIT BigIter
9490 : : ENDIF
9491 [ + - ]: 15880 : IF (ABS(dele).GT.convrez) THEN
9492 : 15880 : energy=energy+dele
9493 : : ! if energy is out of range, pick random energy in correct range
9494 [ + + + + ]: 15880 : IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) then
9495 : 12713 : energy=emin+(emax-emin)*ranx()
9496 : : endif
9497 : : ifac=2
9498 : : ENDIF
9499 : : ENDIF
9500 : : ENDDO BigIter !iter
9501 : 206 : IF (.NOT.ok) THEN
9502 : 10 : success=.false.
9503 : 10 : ierr=ierr+ifac*(10**(iroot-1))
9504 [ - + ]: 10 : if(has_to_print) WRITE(STD_OUT,*) 'no convergence in boundD',iroot,l,dele,energy
9505 [ - + ]: 10 : if(has_to_print) WRITE(STD_OUT,*) ' best guess of eig, dele = ',eig(iroot),best
9506 [ - + ]: 10 : IF (iroot.LT.mxroot) THEN
9507 [ # # ]: 0 : DO ir=iroot+1,mxroot
9508 : 0 : ierr=ierr+9*(10**(ir-1))
9509 : : ENDDO
9510 : : ENDIF
9511 : : ! reset wfn with hydrogenic form
9512 : 10 : j=iroot+l+1
9513 [ + + ]: 20020 : wfn(:,iroot)=zero
9514 [ + + ]: 20020 : lwfn(:,iroot)=zero
9515 : 10 : x=(j)*sqrt(abs(eig(iroot)))
9516 [ + + ]: 20010 : do i=2,n
9517 : 20010 : call dirachwfn(j,kappa,x,Grid%r(i),arg,wfn(i,iroot),lwfn(i,iroot))
9518 : : enddo
9519 : : ENDIF
9520 : : ENDDO !iroot
9521 [ - + ]: 206 : LIBPAW_DEALLOCATE(p1)
9522 [ - + ]: 206 : LIBPAW_DEALLOCATE(lp1)
9523 [ - + ]: 206 : LIBPAW_DEALLOCATE(p2)
9524 [ - + ]: 206 : LIBPAW_DEALLOCATE(lp2)
9525 [ - + ]: 206 : LIBPAW_DEALLOCATE(dd)
9526 [ - + ]: 206 : LIBPAW_DEALLOCATE(yy)
9527 [ - + ]: 206 : LIBPAW_DEALLOCATE(zz)
9528 [ - + ]: 206 : if(has_to_print) write(std_out,*) 'returning from boundD -- ierr=',ierr
9529 [ + + ]: 412 : END SUBROUTINE BoundD
9530 : :
9531 : :
9532 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9533 : : !! subroutine prepareforcfdsolD(Grid,i1,i2,n,kappa,wfn,lwfn,yy,zz)
9534 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9535 [ - + - + : 34234 : subroutine prepareforcfdsolD(Grid,i1,i2,n,kappa,wfn,lwfn,yy,zz,ww,jj)
- + - + -
+ - + ]
9536 : : real(dp),intent(in) :: ww(:),jj(:)
9537 : : Type(gridinfo), INTENT(IN) :: Grid
9538 : : INTEGER, INTENT(IN) :: i1,i2,n,kappa
9539 : : REAL(dp), INTENT(IN) :: wfn(:),lwfn(:)
9540 : : REAL(dp), INTENT(OUT) :: yy(:,:),zz(:,:,:)
9541 : : INTEGER :: i
9542 [ + + + + : 685090808 : yy=zero;zz=zero
+ + + + +
+ ]
9543 [ + + ]: 239638 : yy(1,i1:i2)=wfn(i1:i2)
9544 [ + + ]: 239638 : yy(2,i1:i2)=lwfn(i1:i2)
9545 [ + + ]: 68502234 : do i=2,n
9546 : 68468000 : zz(1,1,i)=-kappa/Grid%r(i)
9547 : 68468000 : zz(1,2,i)=jj(i)
9548 : 68468000 : zz(2,2,i)=kappa/Grid%r(i)
9549 : 68502234 : zz(2,1,i)=-ww(i)
9550 : : enddo
9551 : 34234 : end subroutine prepareforcfdsolD
9552 : :
9553 : :
9554 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9555 : : !! Subroutine Dzeroexpand(Grid,Pot,kappa,energy)
9556 : : !! If finitenucleus==.true. assumes potential is non-singular
9557 : : !! at origin and Pot%v0 and Pot%v0p are properly set
9558 : : !! -- actually not programmed yet
9559 : : !! Otherwise, assumes nuclear potential is -2*Z/r
9560 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9561 : 17220 : Subroutine Dzeroexpand(Grid,Pot,kappa,energy,A0,A1,B0,B1,s,nr)
9562 : : Real(dp), intent(inout) :: A0,B0,A1,B1,s
9563 : : Type(GridInfo), INTENT(IN) :: Grid
9564 : : Type(PotentialInfo), INTENT(INout) :: Pot
9565 : : Integer, INTENT(IN) :: kappa
9566 : : Real(dp), INTENT(IN) :: energy
9567 : : Integer, optional, INTENT(IN) :: nr
9568 : : Integer :: n
9569 : : Real(dp) :: nz,alpha2,balpha2
9570 : : Real(dp) :: x,y,z
9571 : 17220 : n=Grid%n
9572 [ - + ]: 17220 : if (present(nr)) n=min(n,nr)
9573 : 17220 : nz=Pot%nz
9574 [ + + + + ]: 68931660 : Pot%ww=zero; Pot%jj=zero
9575 : 17220 : balpha2=InvFineStruct**2
9576 : 17220 : alpha2=1._dp/balpha2
9577 [ + + ]: 34457220 : Pot%ww(2:n)=energy-Pot%rv(2:n)/Grid%r(2:n)
9578 [ + + ]: 34457220 : Pot%jj(2:n)=(1._dp + 0.25_dp*alpha2*Pot%ww(2:n))
9579 [ + - ]: 17220 : if (.not.Pot%finitenucleus) then
9580 : 17220 : s=sqrt(kappa*kappa-alpha2*nz**2)
9581 : 17220 : A0=1._dp
9582 : 17220 : B0=2._dp*(s+kappa)*balpha2/nz
9583 : 17220 : z=two*s+one
9584 : 17220 : x=alpha2*(nz**2)
9585 : 17220 : y=four*alpha2+energy-Pot%v0
9586 : 17220 : A1=(four*alpha2*x+y*(s+kappa-two*x))/(two*nz*z)
9587 : 17220 : y=two*alpha2+energy-Pot%v0
9588 : 17220 : B1=-(y*(two*(s+kappa)+energy-Pot%v0))/z
9589 : : else ! version for finite nuclear size
9590 : 0 : write(std_out,*) 'Dirac case not yet programmed for finite nucleus'
9591 : 0 : stop
9592 : : endif
9593 : 17220 : end subroutine Dzeroexpand
9594 : :
9595 : :
9596 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9597 : : !! SUBROUTINE wfnDinit(Grid,kappa,wfn,lwfn,istart)
9598 : : !! returns the solution of the Dirac relativistic equations near r=0
9599 : : !! using power series expansion
9600 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9601 [ - + - + ]: 17220 : SUBROUTINE wfnDinit(Grid,wfn,lwfn,istart,A0,A1,B0,B1,s,finitenucleus)
9602 : : logical,intent(in) :: finitenucleus
9603 : : Real(dp), intent(in) :: A0,B0,A1,B1,s
9604 : : Type(GridInfo), INTENT(IN) :: Grid
9605 : : REAL(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
9606 : : INTEGER, INTENT(OUT) :: istart
9607 : : REAL(dp) :: rr
9608 : : INTEGER :: i
9609 [ + + + + ]: 68931660 : wfn=zero; lwfn=zero
9610 : 17220 : istart=6
9611 [ + + ]: 120540 : do i=1,istart
9612 : 103320 : rr=Grid%r(i+1)
9613 [ + - ]: 120540 : if (.not.finitenucleus) then
9614 : 103320 : wfn(i+1)=(rr**s)*(A0+A1*rr)
9615 : 103320 : lwfn(i+1)=(rr**s)*(B0+B1*rr)
9616 : : else ! finite nucleus case
9617 : 0 : write(std_out,*) 'Dirac case not programmed for finite nucleus'
9618 : 0 : STOP
9619 : : endif
9620 : : enddo
9621 : 17220 : End SUBROUTINE wfnDinit
9622 : :
9623 : :
9624 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9625 : : !! subroutine wfnDasym(Grid,wfn,lwfn,energy,iend)
9626 : : !! returns the solution of the Dirac relativistic equations near r=inf
9627 : : !! using exp(-x*r) for upper component
9628 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9629 [ - + - + ]: 17014 : subroutine wfnDasym(Grid,wfn,lwfn,energy,iend)
9630 : : Type(GridInfo), INTENT(IN) :: Grid
9631 : : REAL(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
9632 : : REAL(dp), INTENT(IN) :: energy
9633 : : INTEGER, INTENT(OUT) :: iend
9634 : : REAL(dp) :: rr,x,m
9635 : : INTEGER :: i,n
9636 [ - + ]: 17014 : if (energy>0._dp) then
9637 : 0 : write(std_out,*) 'Error in wfnDasym -- energy > 0', energy
9638 : 0 : stop
9639 : : endif
9640 [ + + + + ]: 68107042 : wfn=zero; lwfn=zero
9641 : 17014 : n=Grid%n
9642 : 17014 : m=1._dp+0.25_dp*energy/(InvFineStruct**2)
9643 : 17014 : x=sqrt(-m*energy)
9644 : 17014 : rr=energy/x
9645 : 17014 : iend=5
9646 [ + + ]: 119098 : do i=n-iend,n
9647 : 102084 : wfn(i)=exp(-x*(Grid%r(i)-Grid%r(n-iend)))
9648 : 119098 : lwfn(i)=rr*wfn(i)
9649 : : enddo
9650 : 17014 : end subroutine wfnDasym
9651 : :
9652 : :
9653 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9654 : : !! subroutine getwfnfromcfdsolD(start,finish,yy,wfn,lwfn)
9655 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9656 [ - + - + : 34234 : subroutine getwfnfromcfdsolD(start,finish,yy,wfn,lwfn)
- + ]
9657 : : INTEGER, INTENT(IN) :: start,finish
9658 : : REAL(dp), INTENT(IN) :: yy(:,:)
9659 : : REAL(dp), INTENT(INOUT) :: wfn(:),lwfn(:)
9660 : : INTEGER :: i
9661 [ + + ]: 68536468 : wfn=0
9662 [ + + ]: 34712636 : do i=start,finish
9663 : 34678402 : wfn(i)=yy(1,i)
9664 : 34712636 : lwfn(i)=yy(2,i)
9665 : : enddo
9666 : 34234 : end subroutine getwfnfromcfdsolD
9667 : :
9668 : :
9669 : :
9670 : :
9671 : :
9672 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9673 : : ! 18. interpolation_mod
9674 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9675 : :
9676 : :
9677 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9678 : : ! cubic spline interpolation for nin>2
9679 : : ! linear interpolation for nin=2
9680 : : ! error end if rout points are not within range of rin
9681 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9682 [ # # # # : 0 : SUBROUTINE interpfunc(nin,rin,fin,nout,rout,fout)
# # # # ]
9683 : : INTEGER, INTENT(IN) :: nin,nout
9684 : : REAL(dp), INTENT(IN) :: rin(:),fin(:),rout(:)
9685 : : REAL(dp), INTENT(INOUT) :: fout(:)
9686 : 0 : REAL(dp), ALLOCATABLE :: c(:,:)
9687 : : INTEGER :: i,j
9688 : : REAL(dp) :: x,s
9689 : : LOGICAL :: leftin,lefton,leftout,rightin,righton,rightout
9690 : : ! check if grid is within interpolation range
9691 : 0 : call checkrange(rin(1),rout(1),leftin,lefton,leftout)
9692 : 0 : call checkrange(rout(nout),rin(nin),rightin,righton,rightout)
9693 [ # # ]: 0 : if (leftout.or.rightout) then
9694 : 0 : write(std_out,*) 'Grid error in interpfunc',rin(1),rout(1),rin(nin),rout(nout)
9695 : 0 : stop
9696 : : endif
9697 [ # # ]: 0 : fout=0
9698 : : ! linear interpolation if nin=2
9699 [ # # ]: 0 : if (nin==2) then
9700 : 0 : s=(fin(2)-fin(1))/(rin(2)-rin(1))
9701 [ # # ]: 0 : do i=1,nout
9702 : 0 : fout(i)=fin(1)+(rout(i)-rin(1))*s
9703 : : enddo
9704 : : return
9705 : : endif
9706 [ # # # # : 0 : LIBPAW_ALLOCATE(c,(4,nin))
# # # # #
# # # ]
9707 [ # # # # ]: 0 : c=zero;
9708 [ # # ]: 0 : c(1,1:nin)=fin(1:nin)
9709 [ # # # # : 0 : call cubspl(rin,c,nin,0,0)
# # # # #
# ]
9710 [ # # ]: 0 : do i=1,nout
9711 [ # # ]: 0 : do j=1,nin-1
9712 : 0 : call checkrange(rin(j),rout(i),leftin,lefton,leftout)
9713 : 0 : call checkrange(rout(i),rin(j+1),rightin,righton,rightout)
9714 [ # # # # : 0 : if ((leftin.or.lefton).and.(rightin.or.righton)) then
# # # # ]
9715 : 0 : x=rout(i)-rin(j)
9716 : 0 : fout(i)=c(1,j)+x*(c(2,j)+x*(c(3,j)+x*c(4,j)/3)/2)
9717 : 0 : exit
9718 : : endif
9719 : : enddo
9720 : : enddo
9721 [ # # ]: 0 : LIBPAW_DEALLOCATE(c)
9722 : 0 : END SUBROUTINE interpfunc
9723 : :
9724 : :
9725 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9726 : : !! cubspl
9727 : : !! from webpage
9728 : : !! http://pages.cs.wisc.edu/~deboor/pgs/cubspl.f
9729 : : !! Transformed into fortran 90 and REAL(8)
9730 : : !! from * a practical guide to splines * by c. de boor
9731 : : !! ************************ input ***************************
9732 : : !! n = number of data points. assumed to be .ge. 2.
9733 : : !! (tau(i), c(1,i), i=1,...,n) = abscissae and ordinates of the
9734 : : !! data points. tau is assumed to be strictly increasing.
9735 : : !! ibcbeg, ibcend = boundary condition indicators, and
9736 : : !! c(2,1), c(2,n) = boundary condition information. specifically,
9737 : : !! ibcbeg = 0 means no boundary condition at tau(1) is given.
9738 : : !! in this case, the not-a-knot condition is used, i.e. the
9739 : : !! jump in the third derivative across tau(2) is forced to
9740 : : !! zero, thus the first and the second cubic polynomial pieces
9741 : : !! are made to coincide.)
9742 : : !! ibcbeg = 1 means that the slope at tau(1) is made to equal
9743 : : !! c(2,1), supplied by input.
9744 : : !! ibcbeg = 2 means that the second derivative at tau(1) is
9745 : : !! made to equal c(2,1), supplied by input.
9746 : : !! ibcend = 0, 1, or 2 has analogous meaning concerning the
9747 : : !! boundary condition at tau(n), with the additional infor-
9748 : : !! mation taken from c(2,n).
9749 : : !! *********************** output **************************
9750 : : !! c(j,i), j=1,...,4; i=1,...,l (= n-1) = the polynomial coefficients
9751 : : !! of the cubic interpolating spline with interior knots (or
9752 : : !! joints) tau(2), ..., tau(n-1). precisely, in the interval
9753 : : !! (tau(i), tau(i+1)), the spline f is given by
9754 : : !! f(x) = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.)
9755 : : !! where h = x - tau(i). the function program *ppvalu* may be
9756 : : !! used to evaluate f or its derivatives from tau,c, l = n-1,
9757 : : !! and k=4.
9758 : : !! A tridiagonal linear system for the unknown slopes s(i) of
9759 : : !! f at tau(i), i=1,...,n, is generated and then solved by gauss elim-
9760 : : !! ination, with s(i) ending up in c(2,i), all i.
9761 : : !! c(3,.) and c(4,.) are used initially for temporary storage.
9762 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9763 : 0 : subroutine cubspl ( tau, c, n, ibcbeg, ibcend )
9764 : : integer :: ibcbeg,ibcend,n, i,j,l,m
9765 : : real(dp) :: c(4,n),tau(n), divdf1,divdf3,dtau,g
9766 : 0 : l = n-1
9767 : : !compute first differences of tau sequence and store in c(3,.). also,
9768 : : !compute first divided difference of data and store in c(4,.).
9769 [ # # ]: 0 : do m=2,n
9770 : 0 : c(3,m) = tau(m) - tau(m-1)
9771 : 0 : c(4,m) = (c(1,m) - c(1,m-1))/c(3,m)
9772 : : enddo
9773 : : !construct first equation from the boundary condition, of the form
9774 : : ! c(4,1)*s(1) + c(3,1)*s(2) = c(2,1)
9775 [ # # ]: 0 : if (ibcbeg-1 <0) go to 11
9776 [ # # ]: 0 : if (ibcbeg-1==0) go to 15
9777 : : if (ibcbeg-1 >0) go to 16
9778 [ # # ]: 0 : 11 if (n .gt. 2) go to 12
9779 : : ! no condition at left end and n = 2.
9780 : 0 : c(4,1) = 1._dp
9781 : 0 : c(3,1) = 1._dp
9782 : 0 : c(2,1) = 2._dp*c(4,2)
9783 : 0 : go to 25
9784 : : ! not-a-knot condition at left end and n .gt. 2.
9785 : 0 : 12 c(4,1) = c(3,3)
9786 : 0 : c(3,1) = c(3,2) + c(3,3)
9787 : 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)
9788 : 0 : go to 19
9789 : : ! slope prescribed at left end.
9790 : 0 : 15 c(4,1) = 1._dp
9791 : 0 : c(3,1) = 0._dp
9792 : 0 : go to 18
9793 : : ! second derivative prescribed at left end.
9794 : 0 : 16 c(4,1) = 2._dp
9795 : 0 : c(3,1) = 1._dp
9796 : 0 : c(2,1) = 3._dp*c(4,2) - c(3,2)/2._dp*c(2,1)
9797 [ # # ]: 0 : 18 if(n .eq. 2) go to 25
9798 : : ! if there are interior knots, generate the corresp. equations and car-
9799 : : ! ry out the forward pass of gauss elimination, after which the m-th
9800 : : ! equation reads c(4,m)*s(m) + c(3,m)*s(m+1) = c(2,m).
9801 [ # # ]: 0 : 19 do m=2,l
9802 : 0 : g = -c(3,m+1)/c(4,m-1)
9803 : 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))
9804 : 0 : c(4,m) = g*c(3,m-1) + 2._dp*(c(3,m) + c(3,m+1))
9805 : : enddo
9806 : : !construct last equation from the second boundary condition, of the form
9807 : : ! (-g*c(4,n-1))*s(n-1) + c(4,n)*s(n) = c(2,n)
9808 : : ! if slope is prescribed at right end, one can go directly to back-
9809 : : ! substitution, since c array happens to be set up just right for it
9810 : : ! at this point.
9811 [ # # ]: 0 : if (ibcend-1 <0) go to 21
9812 [ # # ]: 0 : if (ibcend-1==0) go to 30
9813 : : if (ibcend-1 >0) go to 24
9814 [ # # # # ]: 0 : 21 if (n .eq. 3 .and. ibcbeg .eq. 0) go to 22
9815 : : ! not-a-knot and n .ge. 3, and either n.gt.3 or also not-a-knot at
9816 : : ! left end point.
9817 : 0 : g = c(3,n-1) + c(3,n)
9818 : : c(2,n) = ((c(3,n)+2._dp*g)*c(4,n)*c(3,n-1) &
9819 : 0 : & + c(3,n)**2*(c(1,n-1)-c(1,n-2))/c(3,n-1))/g
9820 : 0 : g = -g/c(4,n-1)
9821 : 0 : c(4,n) = c(3,n-1)
9822 : 0 : go to 29
9823 : : ! either (n=3 and not-a-knot also at left) or (n=2 and not not-a-
9824 : : ! knot at left end point).
9825 : 0 : 22 c(2,n) = 2._dp*c(4,n)
9826 : 0 : c(4,n) = 1._dp
9827 : 0 : go to 28
9828 : : ! second derivative prescribed at right endpoint.
9829 : 0 : 24 c(2,n) = 3._dp*c(4,n) + c(3,n)/2._dp*c(2,n)
9830 : 0 : c(4,n) = 2._dp
9831 : 0 : go to 28
9832 : : 25 continue
9833 [ # # ]: 0 : if (ibcend-1 <0) go to 26
9834 [ # # ]: 0 : if (ibcend-1==0) go to 30
9835 : : if (ibcend-1 >0) go to 24
9836 [ # # ]: 0 : 26 if (ibcbeg .gt. 0) go to 22
9837 : : ! not-a-knot at right endpoint and at left endpoint and n = 2.
9838 : 0 : c(2,n) = c(4,n)
9839 : 0 : go to 30
9840 : 0 : 28 g = -1._dp/c(4,n-1)
9841 : : !complete forward pass of gauss elimination.
9842 : 0 : 29 c(4,n) = g*c(3,n-1) + c(4,n)
9843 : 0 : c(2,n) = (g*c(2,n-1) + c(2,n))/c(4,n)
9844 : : !carry out back substitution
9845 : 0 : 30 j = l
9846 : 0 : 40 c(2,j) = (c(2,j) - c(3,j)*c(2,j+1))/c(4,j)
9847 : 0 : j = j - 1
9848 [ # # ]: 0 : if (j .gt. 0) go to 40
9849 : : !****** generate cubic coefficients in each interval, i.e., the deriv.s
9850 : : ! at its left endpoint, from value and slope at its endpoints.
9851 [ # # ]: 0 : do i=2,n
9852 : 0 : dtau = c(3,i)
9853 : 0 : divdf1 = (c(1,i) - c(1,i-1))/dtau
9854 : 0 : divdf3 = c(2,i-1) + c(2,i) - 2._dp*divdf1
9855 : 0 : c(3,i-1) = 2._dp*(divdf1 - c(2,i-1) - divdf3)/dtau
9856 : 0 : c(4,i-1) = (divdf3/dtau)*(6._dp/dtau)
9857 : : enddo
9858 : 0 : END subroutine cubspl
9859 : :
9860 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
9861 : : ! Subroutine to use input from Ahlberg spline interpolation
9862 : : ! for node points rin(1..nin) and function values yin and
9863 : : ! second derivative values Min to interpolate to radial grid
9864 : : ! rout with values yout. For the range 0 \le r \le rin(1)
9865 : : ! it is assumed that yout=r**(l+1)(W0+W1*r) where l denotes
9866 : : ! the angular momentum of the function
9867 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
9868 [ # # # # : 0 : subroutine specialinterp(nin,rin,yin,MMin,nout,rout,yout,ypout)
# # # # #
# # # ]
9869 : : integer, intent(IN) :: nin,nout
9870 : : real(dp), intent(IN) :: rin(:),yin(:),MMin(:),rout(:)
9871 : : real(dp), intent(INOUT) :: yout(:),ypout(:)
9872 : 0 : real(dp), allocatable :: h(:),C(:,:)
9873 : : real(dp) :: x
9874 : : integer :: i,j
9875 : : LOGICAL :: leftin,lefton,leftout,rightin,righton,rightout
9876 [ # # # # : 0 : LIBPAW_ALLOCATE(h,(nin))
# # # # #
# # # ]
9877 [ # # # # : 0 : LIBPAW_ALLOCATE(C,(4,nin))
# # # # #
# # # ]
9878 [ # # ]: 0 : h=0
9879 [ # # ]: 0 : do i=2,nin
9880 : 0 : h(i)=rin(i)-rin(i-1)
9881 : : enddo
9882 : : !h(1) is hopefully not used
9883 [ # # # # ]: 0 : C=0
9884 [ # # ]: 0 : C(1,1:nin)=yin(1:nin)
9885 [ # # ]: 0 : C(3,1:nin)=MMin(1:nin)
9886 [ # # ]: 0 : do i=1,nin-1
9887 : 0 : C(4,i)=(MMin(i+1)-MMin(i))/h(i+1)
9888 : 0 : C(2,i)=((yin(i+1)-yin(i))/h(i+1)-(MMin(i+1)+2*MMin(i))*h(i+1)/6)
9889 : : enddo
9890 [ # # # # ]: 0 : yout=0;ypout=0
9891 : : ! check if grid is within interpolation range
9892 : 0 : call checkrange(rin(1),rout(1),leftin,lefton,leftout)
9893 : 0 : call checkrange(rout(nout),rin(nin),rightin,righton,rightout)
9894 [ # # ]: 0 : if (leftout.or.rightout) then
9895 : 0 : write(std_out,*) 'Grid error in specialint',rin(1),rout(1),rin(nin),rout(nout)
9896 : 0 : stop
9897 : : endif
9898 [ # # ]: 0 : do i=1,nout
9899 [ # # ]: 0 : do j=1,nin-1
9900 : 0 : call checkrange(rin(j),rout(i),leftin,lefton,leftout)
9901 : 0 : call checkrange(rout(i),rin(j+1),rightin,righton,rightout)
9902 [ # # # # : 0 : if ((leftin.or.lefton).and.(rightin.or.righton)) then
# # # # ]
9903 : 0 : x=rout(i)-rin(j)
9904 : 0 : yout(i)=c(1,j)+x*(c(2,j)+x*(c(3,j)+x*c(4,j)/3)/2)
9905 : 0 : ypout(i)=c(2,j)+x*(c(3,j)+0.5_dp*x*c(4,j))
9906 : 0 : exit
9907 : : endif
9908 : : enddo
9909 : : enddo
9910 [ # # ]: 0 : LIBPAW_DEALLOCATE(h)
9911 [ # # ]: 0 : LIBPAW_DEALLOCATE(C)
9912 : 0 : end subroutine specialinterp
9913 : :
9914 : :
9915 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9916 : : !! checkrange
9917 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9918 : 0 : subroutine checkrange(rin,rout,inrange,onrange,outofbounds)
9919 : : LOGICAL, INTENT(OUT) :: inrange,onrange,outofbounds
9920 : : REAL(dp), INTENT(IN) :: rin,rout
9921 : : REAL(dp), parameter :: tol=1.d-7
9922 : 0 : inrange=.false.;onrange=.false.;outofbounds=.false.
9923 [ # # # # : 0 : if (rout>=rin) then
# # # # #
# # # ]
9924 : 0 : inrange=.true.
9925 : : return
9926 : : endif
9927 [ # # # # : 0 : if (abs(rout-rin).le.tol) then
# # # # #
# # # # #
# # ]
9928 : 0 : onrange=.true.
9929 : : return
9930 : : endif
9931 [ # # # # : 0 : outofbounds=.true.
# # # # ]
9932 : : end subroutine checkrange
9933 : :
9934 : :
9935 : :
9936 : :
9937 : :
9938 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9939 : : ! 19. search_sort
9940 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9941 : :
9942 : :
9943 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9944 : : !! SUBROUTINE Real_InsSort(A, LUT, Ascending)
9945 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9946 [ # # # # ]: 0 : SUBROUTINE Real_InsSort(A, LUT, Ascending)
9947 : : REAL(dp), INTENT(IN) :: A(:)
9948 : : INTEGER, INTENT(INOUT) :: LUT(:)
9949 : : LOGICAL, INTENT(IN) :: Ascending
9950 : : INTEGER :: i, j, k, A_Size
9951 : : REAL(dp) :: CurrVal
9952 : 0 : A_Size = SIZE(A)
9953 [ # # ]: 0 : DO i=1, A_Size
9954 : 0 : LUT(i) = i
9955 : : END DO
9956 [ # # ]: 0 : DO i = 2, A_Size
9957 : 0 : CurrVal = A(LUT(i))
9958 : 0 : j = i - 1
9959 [ # # # # ]: 0 : DO WHILE ((CurrVal < A(LUT(j))) .AND. (j>1))
9960 : 0 : LUT(j+1) = LUT(j)
9961 : 0 : j = j - 1
9962 : : END DO
9963 [ # # ]: 0 : IF (CurrVal < A(LUT(j))) THEN
9964 : 0 : LUT(j+1) = LUT(j)
9965 : 0 : j = j - 1
9966 : : END IF
9967 : 0 : LUT(j+1) = i
9968 : : END DO
9969 [ # # ]: 0 : IF (.NOT. Ascending) THEN
9970 : 0 : j = A_Size / 2
9971 [ # # ]: 0 : DO i = 1, j
9972 : 0 : k = LUT(i)
9973 : 0 : LUT(i) = LUT(A_Size - i + 1)
9974 : 0 : LUT(A_Size - i + 1) = k
9975 : : END DO
9976 : : END IF
9977 : 0 : RETURN
9978 : : END SUBROUTINE Real_InsSort
9979 : :
9980 : :
9981 : :
9982 : :
9983 : :
9984 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9985 : : ! 20. input_dataset_mod
9986 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9987 : :
9988 : :
9989 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9990 : : !! NAME
9991 : : !! input_dataset_read
9992 : : !!
9993 : : !! FUNCTION
9994 : : !! Initialize an input_dataset datastructure by reading it from
9995 : : !! a file. If file is omitted, then read from standard input.
9996 : : !! Note: we only read here data used to generate the PAW dataset,
9997 : : !! not data used for the post-processing (output, explore, scfpaw, ...)
9998 : : !!
9999 : : !! INPUTS (all optionals)
10000 : : !! [inputfile]= name of input file to be read
10001 : : !! [echofile]= name of a file to echo input file content
10002 : : !! [read_global_data]= if TRUE, read global data (atom, XC, grid, ...) -
10003 : : !Default TRUE
10004 : : !! [read_elec_data]= if TRUE, read electronic configuration (orbital &
10005 : : !occupations) - Default TRUE
10006 : : !! [read_coreval_data]= if TRUE, read electronic config (core and valence) -
10007 : : !Default TRUE
10008 : : !! [read_basis_data]= if TRUE, read basis data (radii, pseudo scheme, ...) -
10009 : : !Default TRUE
10010 : : !!
10011 : : !! OUTPUT
10012 : : !! [input_dt]= datastructure containing the complete input file.
10013 : : !! If omitted, then the global public `input_dataset`
10014 : : !! is used.
10015 : : !!
10016 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
10017 : 4 : SUBROUTINE input_dataset_read(atp,inputfile,dirac,has_to_echo,&
10018 : : &read_global_data,read_elec_data,read_coreval_data,read_basis_data)
10019 : : !---- Arguments
10020 : : CHARACTER*(*),INTENT(IN) :: inputfile
10021 : : logical,intent(in) :: has_to_echo
10022 : : logical,intent(in) :: dirac
10023 : : LOGICAL,INTENT(IN),OPTIONAL :: read_global_data,read_elec_data,&
10024 : : & read_coreval_data,read_basis_data
10025 : : TYPE(atompaw_type),INTENT(INOUT) :: atp
10026 : : !---- Local variables
10027 : : CHARACTER(132) :: echofile
10028 : : INTEGER :: ifunit
10029 : : INTEGER,PARAMETER :: ecunit=222
10030 : : INTEGER,PARAMETER :: nkappa(5)=(/1,2,2,2,2/)
10031 : : INTEGER :: input_unit
10032 : : integer :: i_usexcnhat,i_logspline,i_rsoptim,i_lda12
10033 : : INTEGER :: ii,io,nadd,norb,nval,nbl,nn,ik,kk,jdirac
10034 : : INTEGER :: ilin,ilog,inrl,iscl,ipnt,ifin,iend,ihfpp,ilcex,itau
10035 : : INTEGER :: igrid,irelat,ilogder,ilogv4,ibd,idirac,ifixz,ll,nstart
10036 : : INTEGER :: ispline,isplr0,isplns
10037 : : LOGICAL :: read_global_data_,read_elec_data_,read_coreval_data_,read_basis_data_
10038 : : CHARACTER(200) :: inputline,inputword
10039 : : !CHARACTER(128) :: exchangecorrelationandgridline
10040 : : CHARACTER(256) :: exchangecorrelationandgridline
10041 : : CHARACTER(1) :: CHR
10042 : : integer,parameter :: XML_RECL=50000
10043 : : character (len=XML_RECL) :: line,readline
10044 : : logical :: found
10045 : : real(dp) :: x1,x2,xocc
10046 : : INTEGER :: basis_add_l(nbasis_add_max)
10047 : : INTEGER :: basis_add_k(nbasis_add_max)
10048 : : real(dp) :: basis_add_energy(nbasis_add_max)
10049 : : INTEGER :: tmp_n(norbit_max),tmp_l(norbit_max),tmp_k(norbit_max)
10050 : : real(dp) :: tmp_occ(norbit_max)
10051 : 4 : ifunit=libpaw_get_free_unit()
10052 : 4 : input_unit=ifunit
10053 : 4 : OPEN(ifunit,file=trim(inputfile),form='formatted',action="read")
10054 : : !Select which components have to be read
10055 [ - + ]: 4 : read_global_data_=.true.;if (PRESENT(read_global_data))read_global_data_=read_global_data
10056 [ - + ]: 4 : read_elec_data_=.true.;if (PRESENT(read_elec_data))read_elec_data_=read_elec_data
10057 [ - + ]: 4 : read_coreval_data_=.true.;if (PRESENT(read_coreval_data))read_coreval_data_=read_coreval_data
10058 [ - + ]: 4 : read_basis_data_=.true.;if (PRESENT(read_basis_data))read_basis_data_=read_basis_data
10059 : : !Print a title
10060 [ - + - - ]: 4 : IF(read_global_data_.OR.read_elec_data_.OR.read_coreval_data_.OR.read_basis_data_)THEN
10061 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,'(/,3x,a)') "===== READING OF INPUT FILE ====="
10062 : : END IF
10063 : :
10064 : : found=.false.
10065 : : do while (.not.found)
10066 [ + - ]: 20160 : read(input_unit,'(a)',err=10,end=10) readline
10067 : 20160 : line=adjustl(readline);goto 20
10068 : 0 : 10 write(std_out,*) 'ERROR in reading atp file' ; stop
10069 : : 20 continue
10070 [ + + ]: 20160 : if (line(1:22)=='<!-- Program: atompaw') then
10071 : : found=.true.
10072 : : end if
10073 : : enddo
10074 : : if(.not.found) then
10075 : : LIBPAW_ERROR('XML COREWF FILE NOT CORRECT')
10076 : : endif
10077 : :
10078 : : !------------------------------------------------------------------
10079 : : !Start reading of AE data
10080 [ + - ]: 4 : IF (read_global_data_) THEN
10081 : : !------------------------------------------------------------------
10082 : : !=== 1st line: read atomic symbol, atomic number
10083 : 4 : READ(input_unit,'(a)') inputline
10084 : 4 : CALL eliminate_comment(inputline)
10085 : 4 : READ(inputline,*) atp%atomic_symbol,atp%atomic_charge
10086 [ + - ]: 4 : echofile=trim(atp%atomic_symbol)//'_atp_echofile'
10087 [ + - ]: 4 : IF (has_to_echo) THEN
10088 : 4 : OPEN(ecunit,file=trim(echofile),form='formatted')
10089 : : END IF
10090 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10091 : : !Print read data
10092 [ - + ]: 4 : IF (has_to_print) THEN
10093 : 0 : WRITE(STD_OUT,'(3x,a,a2)') "Atomic symbol : ",atp%atomic_symbol
10094 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Atomic charge : ",atp%atomic_charge
10095 : : END IF
10096 : : !------------------------------------------------------------------
10097 : : !=== 2nd line: read XC type, grid data, relativistic,point-nucleus,
10098 : : ! logderiv data, HF data, Block-Davidson keyword
10099 : : !Read full line
10100 : 4 : READ(input_unit,'(a)') exchangecorrelationandgridline
10101 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(exchangecorrelationandgridline)
10102 : 4 : CALL eliminate_comment(exchangecorrelationandgridline)
10103 : 4 : CALL Uppercase(exchangecorrelationandgridline)
10104 : : exchangecorrelationandgridline=trim(exchangecorrelationandgridline)
10105 : : !Retrieve keyword indexes
10106 : 4 : ilin=0;ilin=0;ilog=0;ilogv4=0;inrl=0;iscl=0;ipnt=0;ifin=0
10107 : 4 : ihfpp=0;ilcex=0;igrid=0;irelat=0;ilogder=0;ibd=0;idirac=0
10108 : 4 : ispline=0;isplr0=0;isplns=0
10109 : 4 : ilin=INDEX(exchangecorrelationandgridline,'LINEARGRID')
10110 : 4 : ilog=INDEX(exchangecorrelationandgridline,'LOGGRID')
10111 : 4 : ilogv4=INDEX(exchangecorrelationandgridline,'LOGGRIDV4')
10112 : 4 : ibd=INDEX(exchangecorrelationandgridline,'BDSOLVE')
10113 : 4 : inrl=INDEX(exchangecorrelationandgridline,'NONRELATIVISTIC')
10114 : 4 : iscl=INDEX(exchangecorrelationandgridline,'SCALARRELATIVISTIC')
10115 : 4 : idirac=INDEX(exchangecorrelationandgridline,'DIRACRELATIVISTIC')
10116 : 4 : ipnt=INDEX(exchangecorrelationandgridline,'POINT-NUCLEUS')
10117 : 4 : ifin=INDEX(exchangecorrelationandgridline,'FINITE-NUCLEUS')
10118 : 4 : ilogder=INDEX(exchangecorrelationandgridline,'LOGDERIVRANGE')
10119 : 4 : ihfpp=INDEX(exchangecorrelationandgridline,'HFPOSTPROCESS')
10120 : 4 : ilcex=INDEX(exchangecorrelationandgridline,'LOCALIZEDCOREEXCHANGE')
10121 : 4 : ifixz=INDEX(exchangecorrelationandgridline,'FIXED_ZERO')
10122 : 4 : itau=INDEX(exchangecorrelationandgridline,'WTAU')
10123 : 4 : ispline=INDEX(exchangecorrelationandgridline,'SPLINEINTERP')
10124 : 4 : isplr0=INDEX(exchangecorrelationandgridline,'SPLR0')
10125 : 4 : isplns=INDEX(exchangecorrelationandgridline,'SPLNS')
10126 : 4 : igrid=max(ilin,ilog) !This line may need attention....
10127 : 4 : irelat=max(inrl,iscl) !This line may need attention....
10128 : : !!Treat simple logical variables
10129 : 4 : atp%scalarrelativistic=(iscl>0.and.inrl==0)
10130 : 4 : atp%diracrelativistic=(idirac>0.and.inrl==0)
10131 [ + - - + ]: 4 : atp%usespline=(itau>0.or.ispline>0.and.inrl==0)
10132 : 4 : atp%finitenucleus=(ifin>0.and.ipnt==0)
10133 : 4 : atp%BDsolve=(ibd>0)
10134 : 4 : atp%HFpostprocess=(ihfpp>0)
10135 : : !!Treat finite nucleus option
10136 : 4 : atp%finitenucleusmodel=-1
10137 [ - + ]: 4 : IF (atp%finitenucleus) THEN
10138 : 0 : READ(exchangecorrelationandgridline(ifin+14:ifin+14),'(a)') CHR
10139 [ # # ]: 0 : IF (CHR=="2") atp%finitenucleusmodel=2
10140 [ # # ]: 0 : IF (CHR=="3") atp%finitenucleusmodel=3
10141 [ # # ]: 0 : IF (CHR=="4") atp%finitenucleusmodel=4
10142 [ # # ]: 0 : IF (CHR=="5") atp%finitenucleusmodel=5
10143 : : END IF
10144 : : !Treat possible changes to spline grid
10145 [ - + ]: 4 : if (isplr0>0) then
10146 : 0 : READ(exchangecorrelationandgridline(isplr0+5:),*) atp%splr0
10147 : : end if
10148 [ - + ]: 4 : if (isplns>0) then
10149 : 0 : READ(exchangecorrelationandgridline(isplns+5:),*) atp%splns
10150 : : end if
10151 : : !!Treat grid data
10152 : 4 : atp%gridkey='LINEAR'
10153 : 4 : atp%gridpoints=mxgridlin
10154 : 4 : atp%gridrange=linrange
10155 : 4 : atp%gridmatch=linrange
10156 [ + - + - ]: 4 : IF (ilog>0.and.ilin==0.and.ilogv4==0) THEN
10157 : 4 : atp%gridkey='LOGGRID'
10158 : 4 : atp%gridpoints=mxgridlog;
10159 : 4 : atp%gridrange=logrange
10160 : 4 : atp%gridmatch=logrange
10161 : : END IF
10162 [ + - - + ]: 4 : IF (ilog>0.and.ilin==0.and.ilogv4>0) THEN
10163 : 0 : atp%gridkey='LOGGRID4'
10164 : 0 : atp%gridpoints=mxgridlog;
10165 : 0 : atp%gridrange=v4logrange
10166 : 0 : atp%gridmatch=v4logrange
10167 : : END IF
10168 [ + - ]: 4 : IF (igrid>0) THEN
10169 : 4 : iend=256
10170 [ - + ]: 4 : IF (irelat >igrid.and.irelat-1 <iend) iend=irelat -1
10171 [ + + ]: 4 : IF (ilogder>igrid.and.ilogder-1<iend) iend=ilogder-1
10172 [ - + ]: 4 : IF (ibd>igrid.and.ibd-1<iend) iend=ibd-1
10173 : 4 : inputline=""
10174 [ + - + - ]: 4 : IF (ilog>0.and.ilogv4==0.and.iend>igrid+7) &
10175 [ + + ]: 4 : & inputline=TRIM(exchangecorrelationandgridline(igrid+7:iend))
10176 [ - + - - ]: 4 : IF (ilog>0.and.ilogv4>0.and.iend>igrid+9) &
10177 [ # # ]: 0 : & inputline=TRIM(exchangecorrelationandgridline(igrid+9:iend))
10178 [ - + - - ]: 4 : IF (ilin>0.and.iend>igrid+10) &
10179 [ # # ]: 0 : & inputline=TRIM(exchangecorrelationandgridline(igrid+10:iend))
10180 [ + - ]: 4 : IF (inputline/="") THEN
10181 : 4 : CALL extractword(1,inputline,inputword);inputword=trim(inputword)
10182 [ + - ]: 4 : IF (inputword/="") THEN
10183 : 4 : READ(inputword,*) atp%gridpoints
10184 : 4 : CALL extractword(2,inputline,inputword);inputword=trim(inputword)
10185 [ - + ]: 4 : IF (inputword/="") THEN
10186 : 0 : READ(inputword,*) atp%gridrange
10187 : 0 : atp%gridmatch=atp%gridrange
10188 : 0 : CALL extractword(3,inputline,inputword);inputword=trim(inputword)
10189 [ # # ]: 0 : IF (inputword/="") read(inputword,*) atp%gridmatch
10190 : : END IF
10191 : : END IF
10192 : : END IF
10193 [ - + ]: 4 : IF (atp%gridpoints<=0) STOP "input_dataset: error -- number of grid points should be >0!"
10194 : : END IF
10195 : : !Treat logderiv data
10196 : 4 : atp%minlogderiv=logder_min
10197 : 4 : atp%maxlogderiv=logder_max
10198 : 4 : atp%nlogderiv=logder_pts
10199 [ + + ]: 4 : IF (ilogder>0) THEN
10200 : 2 : iend=256
10201 [ - + ]: 2 : IF (igrid >ilogder.and.igrid-1 <iend) iend=igrid -1
10202 [ - + ]: 2 : IF (irelat>ilogder.and.irelat-1<iend) iend=irelat-1
10203 : 2 : inputline=""
10204 [ + - - + ]: 2 : IF (iend>ilogder+13)inputline=trim(exchangecorrelationandgridline(ilogder+13:iend))
10205 [ + - ]: 2 : IF (inputline/="") THEN
10206 : 2 : CALL extractword(1,inputline,inputword);inputword=trim(inputword)
10207 [ + - ]: 2 : IF (inputword/="") THEN
10208 : 2 : READ(inputword,*) atp%minlogderiv
10209 : 2 : CALL extractword(2,inputline,inputword);inputword=trim(inputword)
10210 [ + - ]: 2 : IF (inputword/="") THEN
10211 : 2 : READ(inputword,*) atp%maxlogderiv
10212 : 2 : CALL extractword(3,inputline,inputword);inputword=trim(inputword)
10213 [ - + ]: 2 : IF (inputword/="") READ(inputword,*) atp%nlogderiv
10214 : : END IF
10215 : : END IF
10216 : : END IF
10217 : : END IF
10218 : : !Treat XC/HF
10219 [ - + ]: 4 : if (itau>0) then
10220 : 0 : READ(unit=exchangecorrelationandgridline(itau+5:),fmt=*) atp%exctype
10221 : : else
10222 : 4 : READ(unit=exchangecorrelationandgridline(1:),fmt=*) atp%exctype
10223 : : endif
10224 [ + - - + : 4 : atp%needvtau=(itau>0.or.TRIM(atp%exctype)=='MGGA-R2SCAN-001'.or.TRIM(atp%exctype)=='MGGA-R2SCAN-01')
- + ]
10225 : 4 : atp%localizedcoreexchange=(ilcex>0)
10226 : 4 : atp%fixed_zero=(ifixz>0) ; atp%fixed_zero_index=-1
10227 [ - + ]: 4 : IF (atp%fixed_zero) &
10228 : 0 : & READ(unit=exchangecorrelationandgridline(ifixz+10:),fmt=*)atp%fixed_zero_index
10229 : : !Print read data
10230 [ - + ]: 4 : IF (has_to_print) THEN
10231 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Scalar-relativistic calculation:",MERGE("YES"," NO",atp%scalarrelativistic)
10232 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Dirac-relativistic calculation:",MERGE("YES"," NO",atp%diracrelativistic)
10233 [ # # ]: 0 : IF (atp%usespline) THEN
10234 : 0 : WRITE(STD_OUT,'(3x,a)') " - Use a spline solver"
10235 : : END IF
10236 : 0 : WRITE(STD_OUT,'(3x,2a)') "Exchange-correlation functional:",TRIM(atp%exctype)
10237 [ # # ]: 0 : WRITE(STD_OUT,'(3x,3a)') " (mGGA kinetic energy functional:",MERGE("YES"," NO",atp%needvtau),")"
10238 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Finite-nucleus calculation:",MERGE("YES"," NO",atp%finitenucleus)
10239 [ # # ]: 0 : IF (atp%finitenucleus) THEN
10240 : 0 : WRITE(STD_OUT,'(3x,a,i0)') " - Finite-nucleus model:",atp%finitenucleusmodel
10241 : : END IF
10242 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Block-Davidson calculation:",MERGE("YES"," NO",atp%BDsolve)
10243 : 0 : WRITE(STD_OUT,'(3x,2a)') "Grid type:",TRIM(atp%gridkey)
10244 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Grid size:",atp%gridpoints
10245 : 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Grid maximum value:",atp%gridrange
10246 : 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Grid imposed value:",atp%gridmatch
10247 [ # # ]: 0 : if(atp%usespline) then
10248 : 0 : WRITE(STD_OUT,'(3x,a,f7.3,2x,i0)') "Spline grid r0, ns :",&
10249 : 0 : & atp%splr0,atp%splns
10250 : : endif
10251 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Log. derivative, number of pts:",atp%nlogderiv
10252 : 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Log. derivative, min. energy:",atp%minlogderiv
10253 : 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Log. derivative, max. energy:",atp%maxlogderiv
10254 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, post-processing:",MERGE("YES"," NO",atp%HFpostprocess)
10255 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, localized coreex.:",MERGE("YES"," NO",atp%localizedcoreexchange)
10256 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, fixed zero:",MERGE("YES"," NO",atp%fixed_zero)
10257 [ # # ]: 0 : IF (atp%fixed_zero) THEN
10258 : 0 : WRITE(STD_OUT,'(3x,a,i0)') " - HF fixed zero index:",atp%fixed_zero_index
10259 : : END IF
10260 [ # # # # ]: 0 : IF (atp%BDsolve.and.atp%gridkey=='LINEAR') THEN
10261 : 0 : WRITE(STD_OUT,'(/,3x,a)') "WARNING: BlockDavidson solver works very slowlywith linear grid!"
10262 : : END IF
10263 : : END IF
10264 : : !------------------------------------------------------------------
10265 : : !End reading of global data. Start reading of electronic configuration data
10266 : : ENDIF
10267 [ + - ]: 4 : IF (read_elec_data_) THEN
10268 : : !------------------------------------------------------------------
10269 : : !=== 3rd line and following: electronic configuration of atom
10270 : 4 : READ(input_unit,'(a)') inputline
10271 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10272 : 4 : CALL eliminate_comment(inputline)
10273 : 4 : READ(inputline,*) atp%np(1:5)
10274 [ + + ]: 24 : DO ll=1,5
10275 [ - + ]: 24 : IF(atp%np(ll)<0) atp%np(ll)=0
10276 : : END DO
10277 : : atp%norbit=atp%np(1)+max(atp%np(2)-1,0)+max(atp%np(3)-2,0) &
10278 : 4 : & +max(atp%np(4)-3,0)+max(atp%np(5)-4,0)
10279 [ + + + + ]: 4 : IF (atp%diracrelativistic.and.dirac) atp%norbit=2*atp%norbit-atp%np(1)
10280 : : !Print read data
10281 [ - + ]: 4 : IF (has_to_print) THEN
10282 : 0 : WRITE(STD_OUT,'(3x,a,5(1x,i0))') "Max. quantum numbers(s,p,d,f,g):",atp%np(1:5)
10283 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of orbitals: ",atp%norbit
10284 : : END IF
10285 : : ! CALL input_dataset_read_occ(dataset%norbit_mod,dataset%orbit_mod_l,&
10286 : : !&dataset%orbit_mod_n,dataset%orbit_mod_k,dataset%orbit_mod_occ,&
10287 : : !& dataset%np,dataset%diracrelativistic,&
10288 : : !& inputfile_unit=input_unit,echofile_unit=ecunit)
10289 : 4 : atp%norbit_mod=0
10290 : 4 : kk=0
10291 : : DO
10292 : 12 : READ(input_unit,'(a)') inputline
10293 [ + - ]: 12 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10294 : 12 : CALL eliminate_comment(inputline)
10295 [ + + ]: 12 : if (.not.atp%diracrelativistic) READ(inputline,*) nn,ll,xocc
10296 [ + + ]: 12 : if (atp%diracrelativistic) READ(inputline,*) nn,ll,kk,xocc
10297 [ + + ]: 12 : IF (nn<=0) EXIT
10298 : : IF (xocc<0._dp.OR.&
10299 [ + - + + : 8 : & ((.NOT.atp%diracrelativistic).AND.(xocc>2._dp*(2*ll+1))).OR.&
+ - + + -
+ ]
10300 : : & (( atp%diracrelativistic).AND.(xocc>2._dp*ABS(kk)))) THEN
10301 : 0 : LIBPAW_ERROR('input_dataset: error in occupations')
10302 : : END IF
10303 : 8 : atp%norbit_mod=atp%norbit_mod+1
10304 [ + + + + : 8 : if(atp%diracrelativistic.and.(.not.dirac).and.atp%norbit_mod>1) then
+ + ]
10305 [ + + ]: 2 : if(ll==tmp_l(atp%norbit_mod-1)) then
10306 : 1 : atp%norbit_mod=atp%norbit_mod-1
10307 : 1 : tmp_occ(atp%norbit_mod)=tmp_occ(atp%norbit_mod)+xocc
10308 : 1 : go to 30
10309 : : endif
10310 : : endif
10311 [ - + ]: 7 : if (atp%norbit_mod>norbit_max) stop 'input_dataset_occ: error -- to many occupation lines!'
10312 : 7 : tmp_l(atp%norbit_mod)=ll
10313 : 7 : tmp_n(atp%norbit_mod)=nn
10314 : 7 : tmp_k(atp%norbit_mod)=kk
10315 : 7 : tmp_occ(atp%norbit_mod)=xocc
10316 : 4 : 30 continue
10317 : : END DO
10318 [ - + ]: 4 : IF(ALLOCATED(atp%orbit_mod_l)) then
10319 : 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_l)
10320 : : endif
10321 [ - + ]: 4 : IF(ALLOCATED(atp%orbit_mod_n)) then
10322 : 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_n)
10323 : : endif
10324 [ - + ]: 4 : IF(ALLOCATED(atp%orbit_mod_k)) then
10325 : 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_k)
10326 : : endif
10327 [ - + ]: 4 : IF(ALLOCATED(atp%orbit_mod_occ)) then
10328 : 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_occ)
10329 : : endif
10330 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%orbit_mod_l,(atp%norbit_mod))
+ - + - -
+ - + -
+ ]
10331 [ - + + - : 8 : LIBPAW_ALLOCATE(atp%orbit_mod_n,(atp%norbit_mod))
- + - + -
+ ]
10332 [ - + + - : 8 : LIBPAW_ALLOCATE(atp%orbit_mod_k,(atp%norbit_mod))
- + - + -
+ ]
10333 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%orbit_mod_occ,(atp%norbit_mod))
+ - + - -
+ - + -
+ ]
10334 [ + + ]: 11 : atp%orbit_mod_l(1:atp%norbit_mod)=tmp_l(1:atp%norbit_mod)
10335 [ + + ]: 11 : atp%orbit_mod_n(1:atp%norbit_mod)=tmp_n(1:atp%norbit_mod)
10336 [ + + ]: 11 : atp%orbit_mod_k(1:atp%norbit_mod)=tmp_k(1:atp%norbit_mod)
10337 [ + + ]: 11 : atp%orbit_mod_occ(1:atp%norbit_mod)=tmp_occ(1:atp%norbit_mod)
10338 : : !------------------------------------------------------------------
10339 : : !End reading of electronic data. Start reading of core/valence data
10340 : : ENDIF
10341 [ + - ]: 4 : IF (read_coreval_data_) THEN
10342 : : !------------------------------------------------------------------
10343 : : !=== Core and valence states
10344 : : !Read core and valence states
10345 [ - + ]: 4 : IF (ALLOCATED(atp%orbit_iscore)) then
10346 : 0 : LIBPAW_DEALLOCATE(atp%orbit_iscore)
10347 : : endif
10348 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%orbit_iscore,(atp%norbit))
+ - + - -
+ - + -
+ ]
10349 : 4 : jdirac=1
10350 [ + + ]: 31 : DO io=1,atp%norbit
10351 : 0 : DO
10352 [ + + + + ]: 27 : if(atp%diracrelativistic.and.(.not.dirac)) then
10353 [ + + ]: 7 : if(jdirac==atp%np(1)+max(atp%np(2)-1,0)) then
10354 [ + + ]: 3 : do ii=1,max(atp%np(2)-1,0)
10355 : 2 : READ(input_unit,'(a)') inputline
10356 : 3 : jdirac=jdirac+1
10357 : : enddo
10358 : : endif
10359 [ + + ]: 7 : if(jdirac==atp%np(1)+2*max(atp%np(2)-1,0)+max(atp%np(3)-2,0)) then
10360 [ + + ]: 2 : do ii=1,max(atp%np(3)-2,0)
10361 : 1 : READ(input_unit,'(a)') inputline
10362 : 2 : jdirac=jdirac+1
10363 : : enddo
10364 : : endif
10365 [ + + ]: 7 : if(jdirac==atp%np(1)+2*max(atp%np(2)-1,0)+2*max(atp%np(3)-2,0) &
10366 : : & +max(atp%np(4)-3,0)) then
10367 [ - + ]: 1 : do ii=1,max(atp%np(4)-3,0)
10368 : 0 : READ(input_unit,'(a)') inputline
10369 : 1 : jdirac=jdirac+1
10370 : : enddo
10371 : : endif
10372 : : endif
10373 : 27 : READ(input_unit,'(a)') inputline
10374 : 27 : jdirac=jdirac+1
10375 : 27 : CALL eliminate_comment(inputline)
10376 : 27 : READ(inputline,*) CHR
10377 : : IF (CHR=='c'.OR.CHR=='C'.OR.&
10378 [ + - ]: 27 : & CHR=='v'.OR.CHR=='V') THEN
10379 [ + - ]: 27 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10380 : : EXIT
10381 : : ELSE
10382 : 0 : LIBPAW_ERROR('Please input c or v!')
10383 : : END IF
10384 : : END DO
10385 : 31 : atp%orbit_iscore(io)=(CHR=='c'.OR.CHR=='C')
10386 : : END DO
10387 : : !Store valence states
10388 [ + + + + ]: 31 : atp%norbit_val=atp%norbit-COUNT(atp%orbit_iscore(:))
10389 [ - + ]: 4 : IF (ALLOCATED(atp%orbit_val_n)) then
10390 : 0 : LIBPAW_DEALLOCATE(atp%orbit_val_n)
10391 : : endif
10392 [ - + ]: 4 : IF (ALLOCATED(atp%orbit_val_l)) then
10393 : 0 : LIBPAW_DEALLOCATE(atp%orbit_val_l)
10394 : : endif
10395 [ - + ]: 4 : IF (ALLOCATED(atp%orbit_val_k)) then
10396 : 0 : LIBPAW_DEALLOCATE(atp%orbit_val_k)
10397 : : endif
10398 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%orbit_val_n,(atp%norbit_val))
+ - + - -
+ - + -
+ ]
10399 [ - + + - : 8 : LIBPAW_ALLOCATE(atp%orbit_val_l,(atp%norbit_val))
- + - + -
+ ]
10400 [ - + + - : 8 : LIBPAW_ALLOCATE(atp%orbit_val_k,(atp%norbit_val))
- + - + -
+ ]
10401 : 4 : kk=0
10402 : 4 : io=0;nval=0
10403 [ + + ]: 24 : DO ll=0,4
10404 : 20 : nn=atp%np(ll+1)
10405 [ + + ]: 24 : IF (nn>0) THEN
10406 [ + + + + : 29 : DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic.and.dirac)
+ + ]
10407 [ + + + + ]: 14 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10408 [ + + + + ]: 12 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) kk=0
10409 [ + + ]: 49 : DO ii=1+ll,nn
10410 : 27 : io=io+1
10411 [ + + ]: 39 : IF (.NOT.atp%orbit_iscore(io)) THEN
10412 : 14 : nval=nval+1
10413 : 14 : atp%orbit_val_n(nval)=ii
10414 : 14 : atp%orbit_val_l(nval)=ll
10415 : 14 : atp%orbit_val_k(nval)=kk
10416 : : END IF
10417 : : END DO
10418 : : END DO
10419 : : END IF
10420 : : END DO
10421 [ - + ]: 4 : IF (atp%norbit_val/=nval) STOP 'input_dataset: bug -- wrong nval!'
10422 : : !Print read data
10423 [ - + ]: 4 : IF (has_to_print) THEN
10424 : 0 : WRITE(STD_OUT,'(3x,a)') "Core and valence orbitals:"
10425 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) WRITE(STD_OUT,'(7x,a)') "n l : type"
10426 [ # # # # ]: 0 : IF (atp%diracrelativistic.and.dirac) WRITE(STD_OUT,'(7x,a)') "n l kappa :type"
10427 : 0 : io=0
10428 [ # # ]: 0 : DO ll=0,4
10429 : 0 : nn=atp%np(ll+1)
10430 [ # # ]: 0 : IF (nn>0) THEN
10431 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) THEN
10432 [ # # ]: 0 : DO ii=1+ll,nn
10433 : 0 : io=io+1
10434 : 0 : WRITE(STD_OUT,'(7x,i1,1x,i1,2a)') ii,ll," : ", &
10435 [ # # ]: 0 : & MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
10436 : : END DO
10437 : : ELSE
10438 [ # # ]: 0 : DO ik=1,nkappa(ll+1)
10439 [ # # # # ]: 0 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10440 [ # # ]: 0 : DO ii=1+ll,nn
10441 : 0 : io=io+1
10442 : 0 : WRITE(STD_OUT,'(7x,i1,1x,i1,2x,i2,2x,2a)') ii,ll,kk," : ", &
10443 [ # # ]: 0 : & MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
10444 : : END DO
10445 : : END DO
10446 : : END IF
10447 : : END IF
10448 : : END DO
10449 : : END IF
10450 : : !------------------------------------------------------------------
10451 : : !End reading of AE data. Start reading of basis data
10452 : : ENDIF
10453 [ + - ]: 4 : IF (read_basis_data_) THEN
10454 : : !------------------------------------------------------------------
10455 : : !=== Maximum L for basis functions
10456 : 4 : READ(input_unit,'(a)') inputline
10457 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10458 : 4 : CALL eliminate_comment(inputline)
10459 : 4 : READ(inputline,*) atp%lmax
10460 : : !Print read data
10461 [ - + ]: 4 : IF (has_to_print) THEN
10462 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Basis, maximum L : ",atp%lmax
10463 : : END IF
10464 : : !------------------------------------------------------------------
10465 : : !=== Cut-off radii
10466 : 4 : READ(input_unit,'(a)') inputline
10467 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10468 : 4 : CALL eliminate_comment(inputline)
10469 : 4 : CALL extractword(1,inputline,inputword);inputword=trim(inputword)
10470 [ + - ]: 4 : IF (inputword/="") READ(inputword,*) atp%rc
10471 [ - + ]: 4 : IF (atp%rc<=tol12) THEN
10472 : 0 : LIBPAW_ERROR('input_dataset: error -- rc too small ')
10473 : : END IF
10474 : 4 : CALL extractword(2,inputline,inputword);inputword=trim(inputword)
10475 [ + - ]: 4 : IF (inputword/="") THEN
10476 : 4 : READ(inputword,*) atp%rc_shap
10477 : 4 : CALL extractword(3,inputline,inputword);inputword=trim(inputword)
10478 [ + - ]: 4 : IF (inputword/="") THEN
10479 : 4 : READ(inputword,*) atp%rc_vloc
10480 : 4 : CALL extractword(4,inputline,inputword);inputword=trim(inputword)
10481 [ + - ]: 4 : IF (inputword/="") THEN
10482 : 4 : READ(inputword,*) atp%rc_core
10483 : : ELSE
10484 : 0 : LIBPAW_ERROR('input_dataset: error -- rc(core) is missing!')
10485 : : END IF
10486 : : ELSE
10487 : 0 : LIBPAW_ERROR('input_dataset: error -- rc(Vloc) is missing!')
10488 : : END IF
10489 [ + - + - : 4 : IF (atp%rc_shap<=tol12.OR.atp%rc_vloc<=tol12.OR.&
- + ]
10490 : : & atp%rc_core<=tol12) THEN
10491 : 0 : LIBPAW_ERROR('input_dataset: error -- one rc is too small!')
10492 : : END IF
10493 [ + - + - : 4 : IF (atp%rc_shap>atp%rc.OR.atp%rc_vloc>atp%rc.OR.&
- + ]
10494 : : & atp%rc_core>atp%rc) THEN
10495 : 0 : LIBPAW_ERROR('input_dataset: error -- rc_shape, rc_vloc and rc_core must be <rc!')
10496 : : END IF
10497 : : ENDIF
10498 [ - + ]: 4 : IF(atp%rc_shap==zero) atp%rc_shap=atp%rc
10499 [ - + ]: 4 : IF(atp%rc_vloc==zero) atp%rc_vloc=atp%rc
10500 [ - + ]: 4 : IF(atp%rc_core==zero) atp%rc_core=atp%rc
10501 : : !Print read data
10502 [ - + ]: 4 : IF (has_to_print) THEN
10503 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Augmentation region radius : ",atp%rc
10504 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Core dens. matching radius : ",atp%rc_core
10505 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Local pot. matching radius : ",atp%rc_vloc
10506 : 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Compens. shape func radius : ",atp%rc_shap
10507 : : END IF
10508 : :
10509 : : !------------------------------------------------------------------
10510 : : !=== Additional basis functions
10511 : 4 : nstart=0 ; atp%nbasis_add=0 ; basis_add_k(:)=0
10512 [ + + ]: 18 : DO ll=0,atp%lmax
10513 : 14 : nbl=0
10514 [ + + + + ]: 14 : nadd = MERGE(nkappa(ll+1),1,atp%diracrelativistic.and.dirac)
10515 : : IF (atp%np(ll+1)>0) THEN
10516 : 14 : nbl=COUNT(.NOT.atp%orbit_iscore(nstart+1:nstart+atp%np(ll+1)-ll))
10517 : 14 : nstart=nstart+atp%np(ll+1)-ll
10518 : : END IF
10519 : 28 : DO
10520 : 38 : READ(input_unit,'(a)') inputline
10521 [ + - ]: 38 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10522 : 38 : CALL eliminate_comment(inputline)
10523 : 38 : READ(inputline,*) CHR
10524 [ + + ]: 38 : IF (CHR/='y'.AND.CHR/='Y') THEN
10525 [ - + ]: 14 : IF (CHR/='n'.AND.CHR/='N') STOP 'input_dataset: error -- Please enter Y or N!'
10526 : : EXIT
10527 : : END IF
10528 : 24 : atp%nbasis_add=atp%nbasis_add+nadd
10529 [ - + ]: 24 : IF (atp%nbasis_add>nbasis_add_max) STOP 'Too many additional basis functions!'
10530 [ + + ]: 50 : basis_add_l(atp%nbasis_add-nadd+1:atp%nbasis_add)=ll
10531 [ + + + + ]: 24 : IF (atp%diracrelativistic.and.dirac) THEN
10532 : 2 : basis_add_k(atp%nbasis_add)=-1
10533 [ + - ]: 2 : IF (ll/=0) THEN
10534 : 2 : basis_add_k(atp%nbasis_add-1)=ll
10535 : 2 : basis_add_k(atp%nbasis_add)=-(ll+1)
10536 : : END IF
10537 : : END IF
10538 : 24 : READ(input_unit,'(a)') inputline
10539 [ + - ]: 24 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10540 : 24 : CALL eliminate_comment(inputline)
10541 : 24 : READ(inputline,*) basis_add_energy(atp%nbasis_add-nadd+1:atp%nbasis_add)
10542 : : END DO
10543 : : END DO
10544 [ - + ]: 4 : IF (ALLOCATED(atp%basis_add_l)) then
10545 : 0 : LIBPAW_DEALLOCATE(atp%basis_add_l)
10546 : : endif
10547 [ - + ]: 4 : IF (ALLOCATED(atp%basis_add_k)) then
10548 : 0 : LIBPAW_DEALLOCATE(atp%basis_add_k)
10549 : : endif
10550 [ - + ]: 4 : IF (ALLOCATED(atp%basis_add_energy)) then
10551 : 0 : LIBPAW_DEALLOCATE(atp%basis_add_energy)
10552 : : endif
10553 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%basis_add_l,(atp%nbasis_add))
+ - + - -
+ - + -
+ ]
10554 [ - + + - : 8 : LIBPAW_ALLOCATE(atp%basis_add_k,(atp%nbasis_add))
- + - + -
+ ]
10555 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%basis_add_energy,(atp%nbasis_add))
+ - + - -
+ - + -
+ ]
10556 [ + - ]: 4 : IF (atp%nbasis_add>0) THEN
10557 [ + + ]: 30 : atp%basis_add_l(1:atp%nbasis_add)=basis_add_l(1:atp%nbasis_add)
10558 [ + + ]: 30 : atp%basis_add_k(1:atp%nbasis_add)=basis_add_k(1:atp%nbasis_add)
10559 [ + + ]: 30 : atp%basis_add_energy(1:atp%nbasis_add)=basis_add_energy(1:atp%nbasis_add)
10560 : : END IF
10561 [ + + + + ]: 31 : atp%nbasis=COUNT(.NOT.atp%orbit_iscore(:))+atp%nbasis_add
10562 : : !Print read data
10563 [ - + ]: 4 : IF (has_to_print) THEN
10564 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Initial number of basis functions:",atp%nbasis-atp%nbasis_add
10565 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Number of additional basis functions:",atp%nbasis_add
10566 : 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of basis functions:",atp%nbasis
10567 : 0 : WRITE(STD_OUT,'(3x,a)') "Additional basis functions:"
10568 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) THEN
10569 : 0 : WRITE(STD_OUT,'(7x,a)') "l : energy"
10570 [ # # ]: 0 : DO io=1,atp%nbasis_add
10571 : 0 : WRITE(STD_OUT,'(7x,i1,a,f7.4)') atp%basis_add_l(io)," :",atp%basis_add_energy(io)
10572 : : END DO
10573 : : ELSE
10574 : 0 : WRITE(STD_OUT,'(7x,a)') "l kappa : energy"
10575 [ # # ]: 0 : DO io=1,atp%nbasis_add
10576 : 0 : WRITE(STD_OUT,'(7x,i1,2x,i2,2x,a,f7.4)') atp%basis_add_l(io), &
10577 : 0 : & atp%basis_add_k(io)," : " ,atp%basis_add_energy(io)
10578 : : END DO
10579 : : END IF
10580 : : END IF
10581 : : !------------------------------------------------------------------
10582 : : !=== Projectors, compensation charge shape function, core tolerance
10583 : 4 : READ(input_unit,'(a)') inputline
10584 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10585 : 4 : CALL eliminate_comment(inputline)
10586 : 4 : CALL Uppercase(inputline)
10587 : : inputline=TRIM(inputline)
10588 : 4 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL
10589 : 4 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10590 : 4 : atp%pseudo_polynom2_pdeg=polynom2_pdeg_def
10591 : 4 : atp%pseudo_polynom2_qcut=polynom2_qcut_def
10592 : 4 : atp%shapefunc_type=SHAPEFUNC_TYPE_SINC
10593 : 4 : atp%shapefunc_gaussian_param=gausstol_def
10594 : 4 : atp%hf_coretol=hf_coretol_def
10595 : 4 : READ(unit=inputline,fmt=*) inputword
10596 [ + - - + ]: 4 : IF (TRIM(inputword)=='BLOECHL'.OR.TRIM(inputword)=='VNCT') THEN
10597 : 0 : atp%projector_type=PROJECTOR_TYPE_BLOECHL
10598 : 0 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL
10599 : 0 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10600 [ - + ]: 4 : ELSE IF (TRIM(inputword)=='VNCK') THEN
10601 : 0 : atp%projector_type=PROJECTOR_TYPE_BLOECHL
10602 : 0 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL_K
10603 : 0 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10604 [ + + - + ]: 4 : ELSE IF (TRIM(inputword)=='VANDERBILT'.OR.TRIM(inputword)=='VNCTV') THEN
10605 : 2 : atp%projector_type=PROJECTOR_TYPE_VANDERBILT
10606 : 2 : atp%pseudo_type=PSEUDO_TYPE_POLYNOM
10607 : 2 : atp%ortho_type=ORTHO_TYPE_VANDERBILT
10608 [ - + ]: 2 : ELSE IF(TRIM(inputword)=='MODRRKJ') THEN
10609 : 0 : atp%projector_type=PROJECTOR_TYPE_MODRRKJ
10610 : 0 : atp%pseudo_type=PSEUDO_TYPE_RRKJ
10611 : 0 : atp%ortho_type=ORTHO_TYPE_VANDERBILT
10612 : : IF (INDEX(inputline,'VANDERBILTORTHO')>0)atp%ortho_type=ORTHO_TYPE_VANDERBILT
10613 [ # # ]: 0 : IF (INDEX(inputline,'GRAMSCHMIDTORTHO')>0)atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10614 [ # # ]: 0 : IF (INDEX(inputline,'SVDORTHO')>0) atp%ortho_type=ORTHO_TYPE_SVD
10615 [ + - ]: 2 : ELSE IF (TRIM(inputword)=='CUSTOM') THEN
10616 : 2 : atp%projector_type=PROJECTOR_TYPE_CUSTOM
10617 [ - + ]: 2 : IF (INDEX(inputline,'BLOECHLPS')>0) THEN
10618 : 0 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL
10619 : 0 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10620 [ - + ]: 2 : ELSE IF (INDEX(inputline,'POLYNOM2')>0) THEN
10621 : 0 : atp%pseudo_type=PSEUDO_TYPE_POLYNOM2
10622 : 0 : nstart=INDEX(inputline,'POLYNOM2')
10623 : : READ(unit=inputline(nstart+8:),fmt=*,err=111,end=111,iostat=io) &
10624 [ # # ]: 0 : & atp%pseudo_polynom2_pdeg,atp%pseudo_polynom2_qcut
10625 : : 111 CONTINUE
10626 [ - + ]: 2 : ELSE IF (INDEX(inputline,'POLYNOM')>0) THEN
10627 : 0 : atp%pseudo_type=PSEUDO_TYPE_POLYNOM
10628 [ + - ]: 2 : ELSE IF (INDEX(inputline,'RRKJ')>0) THEN
10629 : 2 : atp%pseudo_type=PSEUDO_TYPE_RRKJ
10630 : : END IF
10631 [ + - ]: 2 : IF (INDEX(inputline,'VANDERBILTORTHO')>0)atp%ortho_type=ORTHO_TYPE_VANDERBILT
10632 [ - + ]: 2 : IF (INDEX(inputline,'GRAMSCHMIDTORTHO')>0)atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10633 : : END IF
10634 [ - + ]: 4 : IF (TRIM(atp%exctype)=='HF') THEN
10635 : 0 : atp%projector_type=PROJECTOR_TYPE_HF
10636 : 0 : atp%pseudo_type=PSEUDO_TYPE_HF
10637 : 0 : atp%ortho_type=ORTHO_TYPE_HF
10638 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,'(3x,a)') '>> You are using HF XC type: pseudo and orthogonalization line will be ignored!'
10639 : : END IF
10640 : : IF ((atp%pseudo_type==PSEUDO_TYPE_BLOECHL.OR. &
10641 : : & atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10642 [ - + - - ]: 4 : & .AND.atp%ortho_type==ORTHO_TYPE_VANDERBILT) STOP &
10643 : 0 : & 'input_dataset: error -- Vanderbilt orthogonalization not compatible with Bloechls projector scheme!'
10644 : : IF ((atp%pseudo_type==PSEUDO_TYPE_BLOECHL.OR. &
10645 : : & atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10646 [ - + - - ]: 4 : & .AND.atp%ortho_type==ORTHO_TYPE_VANDERBILT) STOP &
10647 : 0 : & 'input_dataset: error -- Vanderbilt orthogonalization not compatible with Bloechls projector scheme!'
10648 : : IF ((atp%projector_type==PROJECTOR_TYPE_BLOECHL) &
10649 [ - + - - ]: 4 : & .AND.atp%needvtau) STOP &
10650 : 0 : & 'input_dataset: error -- mGGA not compatible the Bloechl projector scheme!'
10651 : : !!!! Hopefully this will never happen
10652 : : IF ((atp%projector_type==PROJECTOR_TYPE_HF) &
10653 [ - + - - ]: 4 : & .AND.atp%needvtau) STOP &
10654 : 0 : & 'input_dataset: error -- mGGA and Hartree-Fock are not compatible!'
10655 : : IF ((atp%pseudo_type==PSEUDO_TYPE_BLOECHL.OR. &
10656 : : & atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10657 [ - + - - ]: 4 : & .AND.atp%needvtau) STOP &
10658 : 0 : & 'input_dataset: error -- mGGA not compatible the Bloechl pseudization scheme!'
10659 [ - + ]: 4 : IF (INDEX(inputline,'SINC2')>0) THEN
10660 : 0 : atp%shapefunc_type=SHAPEFUNC_TYPE_SINC
10661 [ - + ]: 4 : ELSE IF (INDEX(inputline,'GAUSSIAN')>0) THEN
10662 : 0 : atp%shapefunc_type=SHAPEFUNC_TYPE_GAUSSIAN
10663 : 0 : nstart=INDEX(inputline,'GAUSSIAN')
10664 : : READ(unit=inputline(nstart+8:),fmt=*,err=222,end=222,iostat=io) &
10665 [ # # ]: 0 : & atp%shapefunc_gaussian_param
10666 : : 222 CONTINUE
10667 [ - + ]: 4 : ELSE IF (INDEX(inputline,'BESSELSHAPE')>0) THEN
10668 : 0 : atp%shapefunc_type=SHAPEFUNC_TYPE_BESSEL
10669 : : END IF
10670 : 4 : nstart=INDEX(inputline,'CORETOL')
10671 [ - + ]: 4 : IF (nstart>0) THEN
10672 : 0 : READ(unit=inputline(nstart+7:),fmt=*) atp%hf_coretol
10673 : : END IF
10674 : 4 : atp%shapetcore=(INDEX(inputline,'SHAPETCORE')>0)
10675 : : !Print read data
10676 [ - + ]: 4 : IF (has_to_print) THEN
10677 : 0 : WRITE(STD_OUT,'(3x,a)') "Projectors description:"
10678 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_BLOECHL) &
10679 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : BLOECHL"
10680 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_VANDERBILT) &
10681 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : VANDERBILT"
10682 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_MODRRKJ) &
10683 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : MODRRKJ"
10684 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_CUSTOM) &
10685 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : CUSTOM"
10686 [ # # ]: 0 : IF (atp%projector_type==PROJECTOR_TYPE_HF) &
10687 : 0 : & WRITE(STD_OUT,'(7x,a)') "Type : HARTREE-FOCK"
10688 [ # # ]: 0 : IF (atp%projector_type/=PROJECTOR_TYPE_HF) THEN
10689 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL) &
10690 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL"
10691 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM) &
10692 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : POLYNOM"
10693 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_RRKJ) &
10694 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : RRKJ"
10695 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10696 : 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL KERKER"
10697 [ # # ]: 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM2) &
10698 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,es9.3)') "Pseudization : POLYNOM2,pdeg=",&
10699 : 0 : & atp%pseudo_polynom2_pdeg,", qcut=",atp%pseudo_polynom2_qcut
10700 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_GRAMSCHMIDT) &
10701 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : GRAM-SCHMIDT"
10702 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_VANDERBILT) &
10703 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : VANDERBILT"
10704 [ # # ]: 0 : IF (atp%ortho_type==ORTHO_TYPE_SVD) &
10705 : 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : SVD"
10706 : : END IF
10707 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_GAUSSIAN) &
10708 : 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Compensation charge shape function : GAUSSIAN, tol=",&
10709 : 0 : & atp%shapefunc_gaussian_param
10710 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_SINC) &
10711 : 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : SINC2"
10712 [ # # ]: 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_BESSEL) &
10713 : 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : BESSEL"
10714 [ # # ]: 0 : IF (INDEX(inputline,'CORETOL')>0) &
10715 : 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Core tolerance for Hartree-Fock:",atp%hf_coretol
10716 [ # # ]: 0 : WRITE(STD_OUT,'(3x,2a)') "Smooth tcore shape (no negative nhat):",MERGE("YES"," NO",atp%shapetcore)
10717 : : END IF
10718 : : !------------------------------------------------------------------
10719 : : !=== Local pseudopotential
10720 : 4 : READ(input_unit,'(a)') inputline
10721 [ + - ]: 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10722 : 4 : CALL eliminate_comment(inputline)
10723 : 4 : call Uppercase(inputline)
10724 : : inputline=TRIM(inputline)
10725 : 4 : atp%vloc_type=VLOC_TYPE_MTROULLIER
10726 : 4 : atp%vloc_l=-1
10727 : 4 : atp%vloc_ene=0._dp
10728 : 4 : atp%vloc_setvloc_coef=0._dp
10729 : 4 : atp%vloc_setvloc_rad=atp%rc
10730 [ + + ]: 20 : atp%vloc_kerker_power(:)=0
10731 [ + - ]: 4 : IF (INDEX(inputline,'MTROULLIER')>0) THEN
10732 : : atp%vloc_type=VLOC_TYPE_MTROULLIER
10733 [ - + ]: 4 : ELSE IF (INDEX(inputline,'ULTRASOFT')>0) THEN
10734 : 0 : atp%vloc_type=VLOC_TYPE_ULTRASOFT
10735 [ - + ]: 4 : ELSE IF (INDEX(inputline,'BESSEL')>0) THEN
10736 : 0 : atp%vloc_type=VLOC_TYPE_BESSEL
10737 [ - + ]: 4 : ELSE IF (INDEX(inputline,'VPSMATCHNC')>0) THEN
10738 : 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNC
10739 [ - + ]: 4 : ELSE IF (INDEX(inputline,'VPSMATCHNNC')>0) THEN
10740 : 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNNC
10741 [ - + ]: 4 : ELSE IF (INDEX(inputline,'SETVLOC')>0) THEN
10742 : 0 : atp%vloc_type=VLOC_TYPE_SETVLOC
10743 : 0 : nstart=INDEX(inputline,'SETVLOC')
10744 [ # # ]: 0 : READ(unit=inputline(nstart+8:),fmt=*,err=333,end=333,iostat=io) x1,x2
10745 [ # # # # ]: 0 : IF (x1<10._dp**3.AND.x1>-10._dp**3) atp%vloc_setvloc_coef=x1
10746 [ # # # # ]: 0 : IF (x2>tol8.AND.x2<atp%rc) atp%vloc_setvloc_rad=x2
10747 : : 333 CONTINUE
10748 [ + - - + ]: 4 : ELSE IF (INDEX(inputline,'KERKER')>0.OR.atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) THEN
10749 [ # # ]: 0 : IF (INDEX(inputline,'EXPF')>0) THEN
10750 : 0 : atp%vloc_type=VLOC_TYPE_KERKER_EXPF
10751 : 0 : nstart=INDEX(inputline,'EXPF')
10752 [ # # ]: 0 : ELSE IF (INDEX(inputline,'POLY')>0) THEN
10753 : 0 : atp%vloc_type=VLOC_TYPE_KERKER_POLY
10754 : 0 : nstart=INDEX(inputline,'POLY')
10755 : : ELSE
10756 : 0 : STOP "EXPF or POLY keyword missing!"
10757 : : END IF
10758 : : READ(unit=inputline(nstart+5:),fmt=*,err=334,end=334,iostat=io) &
10759 [ # # ]: 0 : & atp%vloc_kerker_power(1:4)
10760 : : 334 CONTINUE
10761 : : END IF
10762 : : IF ((atp%vloc_type==VLOC_TYPE_SETVLOC.OR. &
10763 : : & atp%vloc_type==VLOC_TYPE_KERKER_EXPF.OR. &
10764 : : & atp%vloc_type==VLOC_TYPE_KERKER_POLY) &
10765 [ - + - - ]: 4 : & .AND.atp%needvtau) STOP &
10766 : 0 : & 'input_dataset: error -- mGGA not compatible the chosen Vloc scheme!'
10767 : : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.OR. &
10768 : : & atp%vloc_type==VLOC_TYPE_VPSMATCHNC.OR. &
10769 [ - + - - : 4 : & atp%vloc_type==VLOC_TYPE_VPSMATCHNNC.OR. &
- - ]
10770 : : & atp%vloc_type==VLOC_TYPE_ULTRASOFT) THEN
10771 [ + - ]: 4 : READ(unit=inputline,fmt=*,err=444,end=444,iostat=io) atp%vloc_l,atp%vloc_ene
10772 : : 444 CONTINUE
10773 [ - + ]: 4 : IF (atp%vloc_l<0.or.atp%vloc_l>10) STOP 'input_dataset: error while reading Vloc parameters!'
10774 : : END IF
10775 [ + - - + ]: 4 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.AND.atp%needvtau) then
10776 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,'(7x,a)') 'NOTE: MTROULLIER Vloc not available for mGGA!'
10777 [ # # ]: 0 : if(has_to_print) WRITE(STD_OUT,'(7x,a)') ' Calling VPSmatch with norm conservation instead.'
10778 : 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNC
10779 : : ENDIF
10780 : : !Print read data
10781 [ - + ]: 4 : IF (has_to_print) THEN
10782 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER) &
10783 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type : MTROULLIER,l=",&
10784 : 0 : & atp%vloc_l,", energy=",atp%vloc_ene
10785 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_ULTRASOFT) &
10786 : 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type : ULTRASOFT,l=",&
10787 : 0 : & atp%vloc_l,", energy=",atp%vloc_ene
10788 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_BESSEL) &
10789 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : BESSEL"
10790 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNC) &
10791 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
10792 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNNC) &
10793 : 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNNC"
10794 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_SETVLOC) THEN
10795 : 0 : WRITE(STD_OUT,'(7x,a,es9.4,a,es9.4)') "Local pseudopotential type :SETVLOC, coef=",&
10796 : 0 : & atp%vloc_setvloc_coef,", rad=",atp%vloc_setvloc_rad
10797 [ # # ]: 0 : IF (atp%needvtau) THEN
10798 : 0 : LIBPAW_ERROR('SETVLOC option not available for MGGA')
10799 : : ENDIF
10800 : : ENDIF
10801 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_EXPF) &
10802 : 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER EXPF,powers=",&
10803 : 0 : & atp%vloc_kerker_power(1:4)
10804 [ # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_POLY) &
10805 : 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER POLY,powers=",&
10806 : 0 : & atp%vloc_kerker_power(1:4)
10807 [ # # # # ]: 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.AND.atp%needvtau) THEN
10808 : 0 : WRITE(STD_OUT,'(7x,a)') 'NOTE: MTROULLIER Vloc not available for mGGA!'
10809 : 0 : WRITE(STD_OUT,'(7x,a)') ' Calling VPSmatch with norm conservation instead.'
10810 : 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNC
10811 : 0 : WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
10812 : : END IF
10813 : : END IF
10814 : :
10815 : :
10816 : :
10817 : :
10818 : :
10819 : :
10820 : :
10821 : : !------------------------------------------------------------------
10822 : : !=== Matching radii for the basis functions
10823 : : !Not for all choice of projectors
10824 : : IF (atp%projector_type==PROJECTOR_TYPE_CUSTOM.OR.&
10825 : : & atp%projector_type==PROJECTOR_TYPE_VANDERBILT.OR.&
10826 [ - + - - : 4 : & atp%projector_type==PROJECTOR_TYPE_MODRRKJ.OR.&
- - ]
10827 : : & atp%projector_type==PROJECTOR_TYPE_HF.AND.atp%vloc_type==VLOC_TYPE_MTROULLIER)THEN
10828 [ - + ]: 4 : IF (ALLOCATED(atp%basis_func_rc)) then
10829 : 0 : LIBPAW_DEALLOCATE(atp%basis_func_rc)
10830 : : endif
10831 [ - + + - : 12 : LIBPAW_ALLOCATE(atp%basis_func_rc,(atp%nbasis))
+ - + - -
+ - + -
+ ]
10832 : 4 : norb=0
10833 [ + + ]: 18 : DO ll=0,atp%lmax
10834 [ + + + + ]: 44 : DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic)
10835 [ + + + + ]: 18 : if((.not.dirac).and.(ik>1)) cycle
10836 [ + + + + ]: 18 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10837 [ + + + + ]: 16 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) kk=0
10838 [ + + ]: 74 : DO io=1,atp%norbit_val
10839 [ + + + + : 58 : IF (atp%orbit_val_l(io)==ll.AND. &
+ + + + ]
10840 : 16 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%orbit_val_k(io)==kk)) THEN
10841 : 14 : norb=norb+1
10842 : 14 : READ(input_unit,'(a)') inputline
10843 [ + - ]: 14 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10844 : 14 : CALL eliminate_comment(inputline)
10845 : 14 : READ(inputline,*) atp%basis_func_rc(norb)
10846 : : END IF
10847 : : END DO
10848 [ + - ]: 30 : IF (atp%nbasis_add>0) THEN
10849 [ + + ]: 122 : DO io=1,atp%nbasis_add
10850 [ + + + + : 106 : IF (atp%basis_add_l(io)==ll.AND. &
+ + + + ]
10851 : 16 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%basis_add_k(io)==kk)) THEN
10852 : 26 : norb=norb+1
10853 : 26 : READ(input_unit,'(a)') inputline
10854 [ + - ]: 26 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10855 : 26 : CALL eliminate_comment(inputline)
10856 : 26 : READ(inputline,*) atp%basis_func_rc(norb)
10857 : : END IF
10858 : : END DO
10859 : : END IF
10860 : : END DO
10861 : : END DO
10862 [ - + ]: 4 : IF (atp%nbasis/=norb) STOP 'input_dataset: error -- inconsistency in the number of basis functions!'
10863 : : ! Print read data
10864 [ - + ]: 4 : IF (has_to_print) THEN
10865 : 0 : WRITE(STD_OUT,'(3x,a)') "Matching radius for basis functions:"
10866 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) WRITE(STD_OUT,'(7x,a)') " # - n l : radius"
10867 [ # # # # ]: 0 : IF (atp%diracrelativistic.and.dirac) WRITE(STD_OUT,'(7x,a)') " # - n l kappa : radius"
10868 : 0 : norb=0
10869 [ # # ]: 0 : DO ll=0,atp%lmax
10870 [ # # # # : 0 : DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic.and.dirac)
# # ]
10871 [ # # # # ]: 0 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10872 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) kk=0
10873 [ # # ]: 0 : DO io=1,atp%norbit_val
10874 [ # # # # : 0 : IF (atp%orbit_val_l(io)==ll.AND. &
# # # # ]
10875 : 0 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%orbit_val_k(io)==kk))THEN
10876 : 0 : norb=norb+1
10877 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) &
10878 : : & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,a,f7.4)') &
10879 : 0 : & norb," - ",atp%orbit_val_n(io),ll," :",atp%basis_func_rc(norb)
10880 [ # # # # ]: 0 : IF (atp%diracrelativistic.and.dirac) &
10881 : : & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,2x,i2,2x,a,f7.4)') &
10882 : 0 : & norb," - ",atp%orbit_val_n(io),ll,kk," :",atp%basis_func_rc(norb)
10883 : : END IF
10884 : : END DO
10885 [ # # ]: 0 : IF (atp%nbasis_add>0) THEN
10886 [ # # ]: 0 : DO io=1,atp%nbasis_add
10887 [ # # # # : 0 : IF (atp%basis_add_l(io)==ll.AND. &
# # # # ]
10888 : 0 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%basis_add_k(io)==kk))THEN
10889 : 0 : norb=norb+1
10890 [ # # # # ]: 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) &
10891 : : & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,a,f7.4)') &
10892 : 0 : & norb," - ",".",ll," : ",atp%basis_func_rc(norb)
10893 [ # # # # ]: 0 : IF (atp%diracrelativistic.and.dirac) &
10894 : : & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,2x,i2,2x,a,f7.4)') &
10895 : 0 : & norb," - ",".",ll,kk," : ",atp%basis_func_rc(norb)
10896 : : END IF
10897 : : END DO
10898 : : END IF
10899 : : END DO
10900 : : END DO
10901 : : END IF
10902 : : ELSE ! Other projectors
10903 [ # # ]: 0 : IF (ALLOCATED(atp%basis_func_rc)) then
10904 : 0 : LIBPAW_DEALLOCATE(atp%basis_func_rc)
10905 : : endif
10906 [ # # # # ]: 0 : LIBPAW_ALLOCATE(atp%basis_func_rc,(0))
10907 : : END IF
10908 : : !------------------------------------------------------------------
10909 : : !End reading of basis data
10910 : : ENDIF
10911 : : !Final message
10912 [ - + - - ]: 4 : IF(read_global_data_.OR.read_elec_data_.OR.read_coreval_data_.OR.read_basis_data_)THEN
10913 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,'(3x,a)') "===== END READING OF INPUT FILE ====="
10914 : : END IF
10915 [ - + ]: 4 : if(has_to_print) WRITE(STD_OUT,'(2/)')
10916 : : !------------------------------------------------------------------
10917 : : ! Checks
10918 : 4 : READ(input_unit,'(a)') inputline
10919 : 4 : READ(input_unit,'(a)') inputline
10920 : 4 : CALL Uppercase(inputline)
10921 : 4 : i_usexcnhat=INDEX(inputline,'USEXCNHAT')
10922 : 4 : i_logspline=INDEX(inputline,'WITHSPLGRID')
10923 : 4 : i_rsoptim =INDEX(inputline,'RSOPTIM')
10924 : 4 : i_lda12 =INDEX(inputline,'LDA12')
10925 [ + - - + ]: 4 : if(i_usexcnhat>0.or.i_logspline>0.or.i_rsoptim>0.or.i_lda12>0) then
10926 : 0 : LIBPAW_ERROR('RCPAW not compatible with usexcnhat, logspline, rsoptim, lda12')
10927 : : endif
10928 : : !Close files
10929 : 4 : CLOSE(ifunit)
10930 [ + - ]: 4 : IF (has_to_echo) THEN
10931 : 4 : CLOSE(ecunit)
10932 : : END IF
10933 : 4 : END SUBROUTINE input_dataset_read
10934 : :
10935 : :
10936 : :
10937 : :
10938 : :
10939 : :
10940 : :
10941 : :
10942 : :
10943 : :
10944 : :
10945 : :
10946 : :
10947 : :
10948 : :
10949 : :
10950 : : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! xmlinterface !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
10951 : :
10952 : :
10953 : : !!=================================================================
10954 : : !! NAME
10955 : : !! xmlprtcore
10956 : : !!
10957 : : !! FUNCTION
10958 : : !! Write the core wave functions in XML format
10959 : : !!
10960 : : !! INPUTS
10961 : : !! fname=file name (with .xml suffixe)
10962 : : !! mesh_data= datatructure containing the definition of
10963 : : !! all the radial meshes used in the XML file
10964 : : !!
10965 : : !! PARENTS
10966 : : !! atompaw2xml
10967 : : !!
10968 : : !! CHILDREN
10969 : : !!
10970 : : !!=================================================================
10971 : :
10972 : 1 : SUBROUTINE xmlprtcore(fname,atp,zcore,mesh_data,input_string)
10973 : :
10974 : : character(len=*),intent(in) :: fname
10975 : : type(atompaw_type),intent(in) :: atp
10976 : : real(dp) ,intent(in) :: zcore
10977 : : TYPE(mesh_data_type),intent(in) :: mesh_data
10978 : : character(len=*), intent(in) :: input_string
10979 : :
10980 : : !------------------------------------------------------------------
10981 : : !---- Local variables
10982 : : !------------------------------------------------------------------
10983 : :
10984 : : integer :: core_size,corewf_meshsz,ib,icor,ii,ir,nmesh,nsppol
10985 : : integer :: unit_xml_core
10986 : : real(dp) :: radstp0,logstp0
10987 : 2 : character(len=3) :: gridt(mesh_data%nmesh)
10988 : : character(len=4) :: char4
10989 : : character(len=5) :: char5a
10990 : : character(len=20) :: char20,char21
10991 : : character(len=1) :: char_orb(4)
10992 : 1 : integer,allocatable :: irwf(:)
10993 : 1 : real(dp),allocatable :: dum(:)
10994 : :
10995 : : !------------------------------------------------------------------
10996 : : !---- Executable code
10997 : : !------------------------------------------------------------------
10998 : 1 : unit_xml_core=1113
10999 : : !Hard-coded values, spin unrestricted
11000 : : !Spinors or collinear magnetism not yet supported
11001 : 1 : nsppol=1
11002 : 1 : char_orb(1)="s";char_orb(2)="p";char_orb(3)="d";char_orb(4)="f"
11003 : : !Open file for writing
11004 : 1 : OPEN(unit_xml_core,file=TRIM(fname),form='formatted')
11005 : :
11006 : : !Write XML header
11007 : 1 : WRITE(unit_xml_core,'("<?xml version=""1.0""?>")')
11008 : 1 : WRITE(unit_xml_core,'("<paw_setup version=""0.7"">")')
11009 : :
11010 : : !Write title
11011 [ + - ]: 1 : WRITE(unit_xml_core,'(/,"<!-- All-electron core wavefunctions for ",a," -->")')trim(ADJUSTL(atp%Pot%sym))
11012 : :
11013 : : !Write Atompaw information
11014 : 1 : WRITE(unit_xml_core,'("<!-- ",a)') trim('GENERATED by RC-PAW')
11015 : 1 : WRITE(unit_xml_core,'(" Energy units=Hartree, length units=bohr")')
11016 : 1 : WRITE(unit_xml_core,'("-->",/)')
11017 : :
11018 : : !Write atom definition
11019 : 1 : WRITE(unit=char5a,fmt='(f5.2)') atp%Pot%zz
11020 : : WRITE(unit_xml_core,'("<atom symbol=""",a,""" Z=""",a)',ADVANCE='NO') &
11021 [ + - + - ]: 1 : & trim(ADJUSTL(atp%Pot%sym)),trim(ADJUSTL(char5a))
11022 : 1 : WRITE(unit=char5a,fmt='(f5.2)') zcore
11023 [ + - ]: 1 : WRITE(unit_xml_core,'(""" core=""",a,"""/>")')trim(ADJUSTL(char5a))
11024 : :
11025 : :
11026 : : !!Write XC definition
11027 : : ! call get_xc_data(xc_type,xc_name)
11028 : : ! if (have_libxc.and.xc_type/="UNKNOWN") then
11029 : : ! call libxc_getshortname(xc_name,xcname_short)
11030 : : ! call get_xc_alias(xcname_short,xc_name)
11031 : : ! endif
11032 : : ! WRITE(unit_xml_core,'("<xc_functional type=""",a,""" name=""",a,"""/>")') &
11033 : : !& TRIM(xc_type),TRIM(xc_name)
11034 : :
11035 : :
11036 : : !Generator data
11037 [ + - ]: 1 : if (atp%scalarrelativistic) then
11038 : 1 : WRITE(unit_xml_core,'("<generator type=""scalar-relativistic"" name=""atompaw"">")')
11039 [ # # ]: 0 : else if (atp%diracrelativistic) then
11040 : 0 : WRITE(unit_xml_core,'("<generator type=""dirac-relativistic"" name=""atompaw"">")')
11041 : : else
11042 : 0 : WRITE(unit_xml_core,'("<generator type=""non-relativistic"" name=""atompaw"">")')
11043 : : endif
11044 : 1 : WRITE(unit_xml_core,'("</generator>)")')
11045 : :
11046 : : !Number of core orbitals (not needed)
11047 [ + + + + ]: 8 : core_size=count(atp%Orbit%iscore(1:atp%Orbit%norbit))
11048 : : !WRITE(unit_xml_core,'("<orbitals norbs=""",i2,"""/>")') core_size
11049 : :
11050 : : !Read mesh size
11051 : 1 : ii=0
11052 [ - + + - : 3 : LIBPAW_ALLOCATE(irwf,(core_size))
+ - + - -
+ - + ]
11053 [ + + ]: 4 : irwf(:)=mesh_data%meshsz(mesh_data%iwavmesh)
11054 [ + + ]: 8 : do ib=1,atp%Orbit%norbit
11055 [ + + ]: 8 : if (atp%Orbit%iscore(ib)) then
11056 : 3 : ii=ii+1;ir=mesh_data%meshsz(mesh_data%iwavmesh)+1
11057 [ - + ]: 1688 : do while (ir>1)
11058 : 1688 : ir=ir-1
11059 [ + + ]: 1688 : if (abs(atp%Orbit%wfn(ir,ib))>tol10) then
11060 : 3 : irwf(ii)=min(ir+1,mesh_data%meshsz(mesh_data%iwavmesh));ir=1
11061 : : end if
11062 : : end do
11063 : : end if
11064 : : end do
11065 : 1 : corewf_meshsz=maxval(irwf(1:core_size))
11066 [ - + ]: 1 : LIBPAW_DEALLOCATE(irwf)
11067 [ + + ]: 5 : corewf_meshsz=maxval(mesh_data%meshsz(1:mesh_data%nmesh))
11068 : : !Electronic configuration
11069 : 1 : WRITE(unit_xml_core,'("<core_states>")')
11070 : 1 : icor=0
11071 [ + + ]: 8 : do ib=1,atp%Orbit%norbit
11072 [ + + ]: 8 : if (atp%Orbit%iscore(ib)) then
11073 [ - + ]: 3 : icor=icor+1;if (icor>core_size) stop ' Bug (1) in xmlprtcore!'
11074 : 3 : call mkname(icor,char4)
11075 : 3 : char20=stripchar('"'//atp%Pot%sym//'_core'//char4//'"')
11076 [ - + ]: 3 : if(atp%diracrelativistic) then
11077 : : WRITE(unit_xml_core,'(" <state n=""",i2,""" l=""",i1,""" kappa=""",i2,""" f=""",1pe14.7)',ADVANCE='NO')&
11078 : 0 : & atp%Orbit%np(ib),atp%Orbit%l(ib),atp%Orbit%kappa(ib),atp%Orbit%occ(ib)
11079 : : else
11080 : : WRITE(unit_xml_core,'(" <state n=""",i2,""" l=""",i1,""" f=""",1pe14.7)',ADVANCE='NO')&
11081 : 3 : & atp%Orbit%np(ib),atp%Orbit%l(ib),atp%Orbit%occ(ib)
11082 : : endif
11083 : : WRITE(unit_xml_core,'(""" e=""",1pe14.7,""" id=",a11,"/>")')&
11084 : 3 : & atp%Orbit%eig(ib)*0.5d0,TRIM(char20)
11085 : : end if
11086 : : enddo
11087 : 1 : WRITE(unit_xml_core,'("</core_states>")')
11088 : :
11089 : : !Radial meshes definitions
11090 : 1 : nmesh=1
11091 [ + + ]: 2 : do ii=1,nmesh
11092 [ - + + - : 3 : LIBPAW_ALLOCATE(dum,(corewf_meshsz))
+ - + - -
+ - + -
+ ]
11093 : 1 : select case(mesh_data%meshtp(ii))
11094 : : case(1)
11095 : 0 : char21='r=d*i'
11096 : 0 : gridt(ii)="lin"
11097 : 0 : radstp0=zero
11098 : 0 : logstp0=mesh_data%radstp(ii)
11099 [ # # ]: 0 : dum(:)=logstp0
11100 : : case(2)
11101 : 1 : char21='r=a*(exp(d*i)-1)'
11102 : 1 : gridt(ii)="log"
11103 : 1 : radstp0=mesh_data%radstp(ii)
11104 : 1 : logstp0=mesh_data%logstp(ii)
11105 [ + + ]: 2002 : dum(1:corewf_meshsz)=logstp0*(radstp0+atp%Grid%r(1:corewf_meshsz))
11106 : : case default
11107 [ - + - ]: 1 : stop ' Bug (2) in xmlprtcore: mesh type not implemented in Atompaw!'
11108 : : end select
11109 : 1 : WRITE(unit_xml_core,'("<radial_grid eq=""",a,""" a=""",es23.16)',ADVANCE='NO')trim(char21),radstp0
11110 : : WRITE(unit_xml_core,'(""" d=""",es23.16,""" istart=""0"" iend=""",i5)',ADVANCE='NO') &
11111 : 1 : & logstp0,corewf_meshsz-1
11112 : 1 : WRITE(unit_xml_core,'(""" id=""",a,i1,"""/>")') gridt(ii),ii
11113 : 1 : WRITE(unit_xml_core,'(" <values>")')
11114 [ + - + + ]: 2002 : WRITE(unit_xml_core,'(3(1x,es23.16))') (atp%Grid%r(ir),ir=1,corewf_meshsz)
11115 : 1 : WRITE(unit_xml_core,'(" </values>")')
11116 : 1 : WRITE(unit_xml_core,'(" <derivatives>")')
11117 : 1 : WRITE(unit_xml_core,'(3(1x,es23.16))') (dum(ir),ir=1,corewf_meshsz)
11118 : 1 : WRITE(unit_xml_core,'(" </derivatives>")')
11119 [ - + ]: 2 : LIBPAW_DEALLOCATE(dum)
11120 : : end do
11121 : :
11122 : : !Write the core wave functions
11123 : 1 : icor=0
11124 [ + + ]: 8 : do ib=1,atp%Orbit%norbit
11125 [ + + ]: 8 : if (atp%Orbit%iscore(ib)) then
11126 [ - + ]: 3 : icor=icor+1;if (icor>core_size) stop 'Bug (3) in xmlprtcore!'
11127 : 3 : call mkname(atp%Orbit%np(ib),char4)
11128 : 3 : char20=stripchar('"'//atp%Pot%sym//char4//char_orb(atp%Orbit%l(ib)+1)//'"')
11129 : : WRITE(unit_xml_core,'("<ae_core_wavefunction state=",a6," grid=""",a,i1,""">")') &
11130 : 3 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11131 [ - + + - : 9 : LIBPAW_ALLOCATE(dum,(mesh_data%meshsz(mesh_data%iwavmesh)))
+ - + - -
+ - + -
+ ]
11132 [ + + ]: 6006 : dum=zero
11133 : : dum(2:mesh_data%meshsz(mesh_data%iwavmesh))= &
11134 : : & atp%Orbit%wfn(2:mesh_data%meshsz(mesh_data%iwavmesh),ib) &
11135 [ + + ]: 6003 : & /atp%Grid%r(2:mesh_data%meshsz(mesh_data%iwavmesh))
11136 : 3 : call extrapolate(dum)
11137 : 3 : WRITE(unit_xml_core,'(3(1x,es23.16))') (dum(ir),ir=1,corewf_meshsz)
11138 [ - + ]: 3 : LIBPAW_DEALLOCATE(dum)
11139 : 3 : WRITE(unit_xml_core,'("</ae_core_wavefunction>")')
11140 : : end if ! if icore
11141 : : end do !ib
11142 : :
11143 : : !Write the core lwave functions
11144 [ - + ]: 1 : if(atp%diracrelativistic) then
11145 : 0 : icor=0
11146 [ # # ]: 0 : do ib=1,atp%Orbit%norbit
11147 [ # # ]: 0 : if (atp%Orbit%iscore(ib)) then
11148 [ # # ]: 0 : icor=icor+1;if (icor>core_size) stop ' Bug (4) in xmlprtcore!'
11149 : 0 : call mkname(atp%Orbit%np(ib),char4)
11150 : 0 : char20=stripchar('"'//atp%Pot%sym//char4//char_orb(atp%Orbit%l(ib)+1)//'"')
11151 : : WRITE(unit_xml_core,'("<ae_core_lwavefunction state=",a6," grid=""",a,i1,""">")') &
11152 : 0 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11153 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(mesh_data%meshsz(mesh_data%iwavmesh)))
# # # # #
# # # #
# ]
11154 [ # # ]: 0 : dum=zero
11155 : : dum(2:mesh_data%meshsz(mesh_data%iwavmesh))= &
11156 : : & atp%Orbit%lwfn(2:mesh_data%meshsz(mesh_data%iwavmesh),ib) &
11157 [ # # ]: 0 : & /atp%Grid%r(2:mesh_data%meshsz(mesh_data%iwavmesh))
11158 : 0 : call extrapolate(dum)
11159 : 0 : WRITE(unit_xml_core,'(3(1x,es23.16))') (dum(ir),ir=1,corewf_meshsz)
11160 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum)
11161 : 0 : WRITE(unit_xml_core,'("</ae_core_lwavefunction>")')
11162 : : end if ! if icore
11163 : : end do !ib
11164 : : end if ! diracrelativistic
11165 : :
11166 : : !Echi input file content
11167 : 1 : WRITE(unit_xml_core,'("<!-- Program: atompaw - input data follows: ")')
11168 : 1 : WRITE(unit_xml_core,'(a)') trim(input_string)
11169 : 1 : WRITE(unit_xml_core,'(a)') "XMLOUT"
11170 : 1 : WRITE(unit_xml_core,'(a)') "prtcorewf"
11171 : 1 : WRITE(unit_xml_core,'(a)') "END"
11172 : 1 : WRITE(unit_xml_core,'(" Program: atompaw - input end -->")')
11173 : 1 : WRITE(unit_xml_core,'("</paw_setup>")')
11174 : :
11175 : : !Close the file
11176 : 1 : close(unit_xml_core)
11177 : 1 : WRITE(STD_OUT,'(/,2x,a)') 'XML core orbitals file created.'
11178 : :
11179 [ - + ]: 1 : end subroutine xmlprtcore
11180 : :
11181 : :
11182 : : !!=================================================================
11183 : : !! NAME
11184 : : !! build_mesh_data
11185 : : !!
11186 : : !! FUNCTION
11187 : : !! Determine meshes definitions
11188 : : !! (if necessary define a logarithmic radial grid)
11189 : : !!
11190 : : !! INPUTS
11191 : : !! Grid=grid datastructure in AtomPAW format
11192 : : !! irc=index of rc in Grid
11193 : : !!
11194 : : !! OUTPUT
11195 : : !! mesh_data
11196 : : !! Data defining various meshes
11197 : : !!
11198 : : !! PARENTS
11199 : : !!
11200 : : !!=================================================================
11201 : :
11202 [ - + - + : 1 : subroutine build_mesh_data(mesh_data,Grid,irc,ivion,ivale,coretailpoints,itau)
- + - + ]
11203 : :
11204 : : type(mesh_data_type),intent(out) :: mesh_data
11205 : : type(GridInfo),intent(in) :: Grid
11206 : : integer, optional, intent(in) :: irc,ivion,ivale,coretailpoints,itau
11207 : :
11208 : : !------------------------------------------------------------------
11209 : : !---- Local variables
11210 : : !------------------------------------------------------------------
11211 : :
11212 : : integer, parameter :: nmesh_max=10
11213 : : integer :: ii1
11214 : : logical :: aeonly=.true.
11215 : :
11216 : : !------------------------------------------------------------------
11217 : : !---- Executable code
11218 : : !------------------------------------------------------------------
11219 : :
11220 [ - + ]: 1 : LIBPAW_ALLOCATE(mesh_data%meshtp,(nmesh_max))
11221 [ - + ]: 1 : LIBPAW_ALLOCATE(mesh_data%meshsz,(nmesh_max))
11222 [ - + ]: 1 : LIBPAW_ALLOCATE(mesh_data%radstp,(nmesh_max))
11223 [ - + ]: 1 : LIBPAW_ALLOCATE(mesh_data%logstp,(nmesh_max))
11224 : :
11225 : : !Mesh definition
11226 [ + - ]: 1 : if (Grid%type==loggrid) then
11227 : 1 : mesh_data%mesh_type=2
11228 : 1 : mesh_data%rad_step=Grid%drdu(1)
11229 : 1 : mesh_data%log_step=Grid%h
11230 : : else
11231 : 0 : mesh_data%mesh_type=1
11232 : 0 : mesh_data%rad_step=Grid%h
11233 : 0 : mesh_data%log_step=zero
11234 : : end if
11235 : :
11236 [ + - + - : 1 : if (PRESENT(irc).and.PRESENT(ivion).and.PRESENT(ivale).and.PRESENT(coretailpoints).and.PRESENT(itau)) then
+ - ]
11237 : 1 : aeonly=.false.
11238 : : endif
11239 : :
11240 : : !Various mesh sizes
11241 [ + - ]: 1 : if (Grid%type==loggrid) then
11242 : 1 : mesh_data%wav_meshsz=Grid%n
11243 [ + - ]: 1 : if (.not.aeonly) then
11244 : 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)
11245 : : else
11246 : 0 : mesh_data%sph_meshsz=Grid%n
11247 : : endif
11248 : : else
11249 [ # # ]: 0 : if (.not.aeonly) then
11250 : 0 : mesh_data%wav_meshsz=irc+Grid%ishift
11251 : 0 : mesh_data%sph_meshsz=min(1+nint(Grid%r(irc)/mesh_data%rad_step),mesh_data%wav_meshsz)
11252 : : else
11253 : 0 : mesh_data%wav_meshsz=Grid%n
11254 : 0 : mesh_data%sph_meshsz=Grid%n
11255 : : endif
11256 : : endif
11257 : 1 : mesh_data%prj_meshsz=mesh_data%sph_meshsz ! To be modified by RSO
11258 : :
11259 [ + - ]: 1 : if (.not.aeonly) then
11260 : 1 : mesh_data%core_meshsz=coretailpoints
11261 : 1 : mesh_data%vale_meshsz=ivale
11262 : 1 : mesh_data%tau_meshsz=itau
11263 : 1 : mesh_data%vion_meshsz=ivion
11264 : : else
11265 : 0 : mesh_data%core_meshsz=Grid%n
11266 : 0 : mesh_data%vale_meshsz=Grid%n
11267 : 0 : mesh_data%tau_meshsz=Grid%n
11268 : 0 : mesh_data%vion_meshsz=Grid%n
11269 : : endif
11270 : :
11271 [ + - ]: 1 : if (mesh_data%vion_meshsz<=0) then
11272 [ - + ]: 1 : if (mesh_data%mesh_type==1) then
11273 : 0 : ii1=int(one+rmax_vloc/mesh_data%rad_step)
11274 : : else
11275 : 1 : ii1=int(log(one+rmax_vloc/mesh_data%rad_step)/mesh_data%log_step)+1
11276 : : endif
11277 : 1 : mesh_data%vion_meshsz=max(mesh_data%sph_meshsz,mesh_data%core_meshsz,ii1)
11278 : : endif
11279 : :
11280 : 1 : mesh_data%vlda12_meshsz=max(mesh_data%vale_meshsz,mesh_data%vion_meshsz)
11281 : :
11282 : : !Mesh for vbare should be inside augmentation region
11283 : : !For compatibility with other codes, could put it to the same mesh
11284 : : !as ionic potential
11285 : : !mesh_data%vbare_meshsz=mesh_data%vion_meshsz
11286 : 1 : mesh_data%vbare_meshsz=mesh_data%sph_meshsz
11287 : :
11288 : 1 : mesh_data%prj_msz_max=four*mesh_data%sph_meshsz
11289 : :
11290 : : !=== Build mesh definitions ===
11291 : :
11292 [ + + + + ]: 21 : mesh_data%meshtp=-1;mesh_data%meshsz=0
11293 [ + + + + ]: 21 : mesh_data%radstp=zero;mesh_data%logstp=zero
11294 : :
11295 : : !Partial waves
11296 : 1 : mesh_data%nmesh=1
11297 : 1 : mesh_data%iwavmesh=1
11298 : 1 : mesh_data%meshtp(1)=mesh_data%mesh_type
11299 : 1 : mesh_data%meshsz(1)=mesh_data%wav_meshsz
11300 : 1 : mesh_data%radstp(1)=mesh_data%rad_step
11301 : 1 : mesh_data%logstp(1)=mesh_data%log_step
11302 : : !Projectors
11303 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%prj_meshsz) then
11304 : 1 : mesh_data%nmesh=mesh_data%nmesh+1
11305 : 1 : mesh_data%iprjmesh=mesh_data%nmesh
11306 : 1 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11307 : 1 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%prj_meshsz
11308 : 1 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11309 : 1 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11310 : : else
11311 : 0 : mesh_data%iprjmesh=mesh_data%iwavmesh
11312 : : endif
11313 : : !Core density
11314 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%core_meshsz) then
11315 [ + - ]: 1 : if (mesh_data%prj_meshsz/=mesh_data%core_meshsz) then
11316 : 1 : mesh_data%nmesh=mesh_data%nmesh+1
11317 : 1 : mesh_data%icoremesh=mesh_data%nmesh
11318 : 1 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11319 : 1 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%core_meshsz
11320 : 1 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11321 : 1 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11322 : : else
11323 : 0 : mesh_data%icoremesh=mesh_data%iprjmesh
11324 : : endif
11325 : : else
11326 : 0 : mesh_data%icoremesh=mesh_data%iwavmesh
11327 : : endif
11328 : : !Local ionic potential
11329 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%vion_meshsz) then
11330 [ + - ]: 1 : if(mesh_data%prj_meshsz/=mesh_data%vion_meshsz) then
11331 [ + - ]: 1 : if(mesh_data%core_meshsz/=mesh_data%vion_meshsz) then
11332 : 1 : mesh_data%nmesh=mesh_data%nmesh+1
11333 : 1 : mesh_data%ivionmesh=mesh_data%nmesh
11334 : 1 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11335 : 1 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vion_meshsz
11336 : 1 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11337 : 1 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11338 : : else
11339 : 0 : mesh_data%ivionmesh=mesh_data%icoremesh
11340 : : endif
11341 : : else
11342 : 0 : mesh_data%ivionmesh=mesh_data%iprjmesh
11343 : : endif
11344 : : else
11345 : 0 : mesh_data%ivionmesh=mesh_data%iwavmesh
11346 : : endif
11347 : : !Local vbare potential
11348 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%vbare_meshsz) then
11349 : : if(mesh_data%prj_meshsz/=mesh_data%vbare_meshsz) then
11350 : : if(mesh_data%core_meshsz/=mesh_data%vbare_meshsz) then
11351 : : if(mesh_data%vion_meshsz/=mesh_data%vbare_meshsz) then
11352 : : mesh_data%nmesh=mesh_data%nmesh+1
11353 : : mesh_data%ivbaremesh=mesh_data%nmesh
11354 : : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11355 : : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vbare_meshsz
11356 : : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11357 : : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11358 : : else
11359 : : mesh_data%ivbaremesh=mesh_data%ivionmesh
11360 : : endif
11361 : : else
11362 : : mesh_data%ivbaremesh=mesh_data%icoremesh
11363 : : endif
11364 : : else
11365 : 1 : mesh_data%ivbaremesh=mesh_data%iprjmesh
11366 : : endif
11367 : : else
11368 : 0 : mesh_data%ivbaremesh=mesh_data%iwavmesh
11369 : : endif
11370 : : !Valence density
11371 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%vale_meshsz) then
11372 [ + - ]: 1 : if(mesh_data%prj_meshsz/=mesh_data%vale_meshsz) then
11373 [ - + ]: 1 : if(mesh_data%core_meshsz/=mesh_data%vale_meshsz) then
11374 [ # # ]: 0 : if(mesh_data%vion_meshsz/=mesh_data%vale_meshsz) then
11375 : : if(mesh_data%vbare_meshsz/=mesh_data%vale_meshsz) then
11376 : 0 : mesh_data%nmesh=mesh_data%nmesh+1
11377 : 0 : mesh_data%ivalemesh=mesh_data%nmesh
11378 : 0 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11379 : 0 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vale_meshsz
11380 : 0 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11381 : 0 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11382 : : else
11383 : : mesh_data%ivalemesh=mesh_data%ivbaremesh
11384 : : endif
11385 : : else
11386 : 0 : mesh_data%ivalemesh=mesh_data%ivionmesh
11387 : : endif
11388 : : else
11389 : 1 : mesh_data%ivalemesh=mesh_data%icoremesh
11390 : : endif
11391 : : else
11392 : 0 : mesh_data%ivalemesh=mesh_data%iprjmesh
11393 : : endif
11394 : : else
11395 : 0 : mesh_data%ivalemesh=mesh_data%iwavmesh
11396 : : endif
11397 : : !Kinetic energy density
11398 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%tau_meshsz) then
11399 [ + - ]: 1 : if(mesh_data%prj_meshsz/=mesh_data%tau_meshsz) then
11400 [ - + ]: 1 : if(mesh_data%core_meshsz/=mesh_data%tau_meshsz) then
11401 [ # # ]: 0 : if(mesh_data%vion_meshsz/=mesh_data%tau_meshsz) then
11402 : : if(mesh_data%vbare_meshsz/=mesh_data%tau_meshsz) then
11403 [ # # ]: 0 : if(mesh_data%vale_meshsz/=mesh_data%tau_meshsz) then
11404 : 0 : mesh_data%nmesh=mesh_data%nmesh+1
11405 : 0 : mesh_data%itaumesh=mesh_data%nmesh
11406 : 0 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11407 : 0 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%tau_meshsz
11408 : 0 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11409 : 0 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11410 : : else
11411 : 0 : mesh_data%itaumesh=mesh_data%ivalemesh
11412 : : endif
11413 : : else
11414 : : mesh_data%itaumesh=mesh_data%ivbaremesh
11415 : : endif
11416 : : else
11417 : 0 : mesh_data%itaumesh=mesh_data%ivionmesh
11418 : : endif
11419 : : else
11420 : 1 : mesh_data%itaumesh=mesh_data%icoremesh
11421 : : endif
11422 : : else
11423 : 0 : mesh_data%itaumesh=mesh_data%iprjmesh
11424 : : endif
11425 : : else
11426 : 0 : mesh_data%itaumesh=mesh_data%iwavmesh
11427 : : endif
11428 : : !LDA-1/2 potential
11429 [ + - ]: 1 : if (mesh_data%wav_meshsz/=mesh_data%vlda12_meshsz) then
11430 [ + - ]: 1 : if(mesh_data%prj_meshsz/=mesh_data%vlda12_meshsz) then
11431 [ + - ]: 1 : if(mesh_data%core_meshsz/=mesh_data%vlda12_meshsz) then
11432 [ - + ]: 1 : if(mesh_data%vion_meshsz/=mesh_data%vlda12_meshsz) then
11433 : : if(mesh_data%vbare_meshsz/=mesh_data%vlda12_meshsz) then
11434 : : if(mesh_data%vale_meshsz/=mesh_data%vlda12_meshsz) then
11435 : : if(mesh_data%tau_meshsz/=mesh_data%vlda12_meshsz) then
11436 : : mesh_data%nmesh=mesh_data%nmesh+1
11437 : : mesh_data%ivlda12mesh=mesh_data%nmesh
11438 : : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11439 : : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vlda12_meshsz
11440 : : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11441 : : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11442 : : else
11443 : : mesh_data%ivlda12mesh=mesh_data%itaumesh
11444 : : endif
11445 : : else
11446 : 0 : mesh_data%ivlda12mesh=mesh_data%ivalemesh
11447 : : endif
11448 : : else
11449 : : mesh_data%ivlda12mesh=mesh_data%ivbaremesh
11450 : : endif
11451 : : else
11452 : 1 : mesh_data%ivlda12mesh=mesh_data%ivionmesh
11453 : : endif
11454 : : else
11455 : 0 : mesh_data%ivlda12mesh=mesh_data%icoremesh
11456 : : endif
11457 : : else
11458 : 0 : mesh_data%ivlda12mesh=mesh_data%iprjmesh
11459 : : endif
11460 : : else
11461 : 0 : mesh_data%ivlda12mesh=mesh_data%iwavmesh
11462 : : endif
11463 : :
11464 : 1 : end subroutine build_mesh_data
11465 : :
11466 : :
11467 : 1 : subroutine destroy_mesh_data(mesh_data)
11468 : :
11469 : : type(mesh_data_type),intent(inout) :: mesh_data
11470 : :
11471 : : !------------------------------------------------------------------
11472 : : !---- Executable code
11473 : : !------------------------------------------------------------------
11474 : :
11475 [ + - ]: 1 : if (allocated(mesh_data%meshtp)) then
11476 : 1 : LIBPAW_DEALLOCATE(mesh_data%meshtp)
11477 : : endif
11478 [ + - ]: 1 : if (allocated(mesh_data%meshsz)) then
11479 : 1 : LIBPAW_DEALLOCATE(mesh_data%meshsz)
11480 : : endif
11481 [ + - ]: 1 : if (allocated(mesh_data%radstp)) then
11482 : 1 : LIBPAW_DEALLOCATE(mesh_data%radstp)
11483 : : endif
11484 [ + - ]: 1 : if (allocated(mesh_data%logstp)) then
11485 : 1 : LIBPAW_DEALLOCATE(mesh_data%logstp)
11486 : : endif
11487 : :
11488 : 1 : end subroutine destroy_mesh_data
11489 : :
11490 : :
11491 : :
11492 : : !!=================================================================
11493 : : !! NAME
11494 : : !! xmloutput
11495 : : !!
11496 : : !! FUNCTION
11497 : : !! Write the PAW data file in XML format
11498 : : !!
11499 : : !! INPUTS
11500 : : !! fname=file name (with .xml suffixe)
11501 : : !! Grid= Grid datastructure from atompaw
11502 : : !! AESCF= AESCF datastructure from atompaw
11503 : : !! AEPOT= AEPOT datastructure from atompaw
11504 : : !! PAW= PAW datastructure from atompaw
11505 : : !! ORB= ORB datastructure from atompaw
11506 : : !! mesh_data= datatructure containing the definition of
11507 : : !! all the radial meshes used in the XML file
11508 : : !! tproj(prj_msz_max,nbase)= PAW projectors
11509 : : !! (might be modified by real space optimization)
11510 : : !! vlocopt= option for local potential (1=Blochl, 2=Kresse)
11511 : : !! input_string= string containing a copy of atompaw input file
11512 : : !! author= string containing the author(s) name
11513 : : !! comment= additional comment line to be printed in the header (usually table
11514 : : !version)
11515 : : !! nsplgrid=if >0, size of a (reduced) grid on which interpolate all data in XML
11516 : : !file
11517 : : !! pawlda12
11518 : : !! %uselda12=TRUE if LDA-1/2 potential calculation is required
11519 : : !! %rcut=LDA-1/2 parameter: cut-off radius (in bohr)
11520 : : !! %pot(:)=LDA-1/2 parameter: local potential used to apply LDA-1/2 method
11521 : : !!
11522 : : !! PARENTS
11523 : : !! atompaw2xml
11524 : : !!
11525 : : !! CHILDREN
11526 : : !!
11527 : : !!=================================================================
11528 [ # # ]: 0 : subroutine xmloutput(fname,Grid,AESCF,AEPot,Orb,PAW,mesh_data,tproj,&
11529 : : & vlocopt,input_string,author,comment,nsplgrid,zcore,atp)
11530 : : integer,intent(in) :: vlocopt,nsplgrid
11531 : : character(len=*),intent(in) :: input_string,author,comment,fname
11532 : : real(dp), intent(in) :: zcore
11533 : : TYPE(Gridinfo),intent(in) :: Grid
11534 : : TYPE (SCFInfo),intent(in) :: AESCF
11535 : : TYPE(Potentialinfo),intent(in) :: AEPot
11536 : : TYPE (OrbitInfo),intent(in) :: Orb
11537 : : TYPE(Pseudoinfo),intent(in) :: PAW
11538 : : type(atompaw_type),intent(in) :: atp
11539 : : ! TYPE(pawlda12_type),intent(in) :: pawlda12
11540 : : TYPE(mesh_data_type),intent(inout) :: mesh_data
11541 : : real(dp),intent(in) :: tproj(:,:)
11542 : : !------------------------------------------------------------------
11543 : : !---- Local variables
11544 : : !------------------------------------------------------------------
11545 : : real(dp), parameter :: tol_zero=1.d-50 ! Threshold below which quantities are zero
11546 : : integer :: ib,ic,ii,n,n_aux,ir,irc_aux,meshsz,meshsz_aux,meshst_aux,nmesh
11547 : 0 : integer :: mesh_start(mesh_data%nmesh),mesh_size(mesh_data%nmesh)
11548 : : integer :: unit_xml=1114
11549 : : logical :: extra1
11550 : : character(len=4) :: char4
11551 : : character(len=5) :: char5a,char5b,xc_type
11552 : : character(len=20) :: char20
11553 : : character(len=132) :: xc_name,xcname_short,code_name
11554 : : real(dp) :: sqr4pi,radstp0,logstp0,radstp_spl,logstp_spl
11555 : 0 : character(len=3) :: gridt(mesh_data%nmesh)
11556 : 0 : real(dp),allocatable :: dum(:),dum_aux(:),rad_aux(:),dudr(:)
11557 : 0 : real(dp),allocatable :: phi_aux(:,:),tphi_aux(:,:),proj_aux(:,:)
11558 : : TYPE(Gridinfo) :: Grid1
11559 : : !------------------------------------------------------------------
11560 : : !---- Executable code
11561 : : !------------------------------------------------------------------
11562 : : !Some defs
11563 : 0 : sqr4pi=sqrt(4*pi)
11564 : 0 : n=Grid%n
11565 [ # # # # : 0 : LIBPAW_ALLOCATE(dum,(n))
# # # # #
# ]
11566 : 0 : extra1=.false.
11567 : :
11568 : : !In a change of grid has been requested, determine new grid data
11569 : 0 : radstp_spl=-1.d0 ; logstp_spl=-1.d0
11570 [ # # ]: 0 : if (nsplgrid>0) then
11571 : 0 : write(std_out,'(/,2x,a,/,2x,a,i5,a)') 'Atompaw2XML info:',&
11572 : 0 : & ' All quantities will be interpolated on a ',nsplgrid,'-point log. grid.'
11573 : 0 : n_aux=nsplgrid
11574 : 0 : logstp_spl=0.02d0
11575 : 0 : call findh(AEPot%zz,Grid%r(mesh_data%meshsz(1)-1),nsplgrid,logstp_spl,radstp_spl)
11576 : 0 : irc_aux=int(tol8+log(1.d0+PAW%rc/radstp_spl)/logstp_spl)+1
11577 : 0 : radstp_spl= PAW%rc/(exp(logstp_spl*(irc_aux-1))-1.d0)
11578 : 0 : extra1=(Grid%r(mesh_data%meshsz(1))<radstp_spl*(exp(logstp_spl*(nsplgrid-1))-1.d0))
11579 [ # # ]: 0 : if (extra1) then
11580 : 0 : n_aux=n_aux+1
11581 : 0 : logstp_spl=0.02d0
11582 : 0 : call findh(AEPot%zz,Grid%r(mesh_data%meshsz(1)-1),nsplgrid+1,logstp_spl,radstp_spl)
11583 : 0 : irc_aux=int(tol8+log(1.d0+PAW%rc/radstp_spl)/logstp_spl)+1
11584 : 0 : radstp_spl= PAW%rc/(exp(logstp_spl*(irc_aux-1))-1.d0)
11585 : : end if
11586 [ # # # # : 0 : LIBPAW_ALLOCATE(rad_aux,(n_aux))
# # # # #
# ]
11587 [ # # # # : 0 : LIBPAW_ALLOCATE(dum_aux,(n_aux))
# # # # ]
11588 : 0 : call InitGrid(Grid1,logstp_spl,Grid%range,r0=radstp_spl,do_not_print=.true.)
11589 [ # # ]: 0 : rad_aux(1:nsplgrid)=Grid1%r(1:nsplgrid)
11590 : : else
11591 [ # # # # : 0 : LIBPAW_ALLOCATE(rad_aux,(n))
# # # # ]
11592 [ # # # # : 0 : LIBPAW_ALLOCATE(dum_aux,(n))
# # # # ]
11593 [ # # ]: 0 : rad_aux(1:n)=Grid%r(1:n)
11594 : 0 : irc_aux=PAW%irc
11595 : : end if
11596 : :
11597 : : !Open file for writing
11598 : 0 : OPEN(unit_xml,file=TRIM(fname),form='formatted')
11599 : :
11600 : : !Write XML header
11601 : 0 : WRITE(unit_xml,'("<?xml version=""1.0""?>")')
11602 : 0 : WRITE(unit_xml,'("<paw_dataset version=""0.7"">")')
11603 : 0 : WRITE(unit_xml,'("<!-- PAW-XML specification: http://esl.cecam.org/Paw-xml-->")')
11604 : :
11605 : : !Write title
11606 [ # # ]: 0 : WRITE(unit_xml,'(/,"<!-- PAW atomic dataset for ",a," -->")')trim(ADJUSTL(AEPot%sym))
11607 : :
11608 : : !Write additional comment line (usually table version)
11609 [ # # ]: 0 : if (trim(comment)/="") WRITE(unit_xml,'("<!-- ",a," -->")') trim(comment)
11610 : :
11611 : : !Write Atompaw information
11612 : 0 : WRITE(unit_xml,'(/,"<!-- ",a)')
11613 : 0 : WRITE(unit_xml,'(" Energy units=Hartree, length units=bohr")')
11614 [ # # ]: 0 : if (trim(author)/="") WRITE(unit_xml,'(a,a)') ' by ',trim(author)
11615 : 0 : WRITE(unit_xml,'(" The input file is available at the end of this file")')
11616 : 0 : WRITE(unit_xml,'("-->",/)')
11617 : :
11618 : : !Write atom definition
11619 : 0 : WRITE(unit=char5a,fmt='(f5.2)') AEPot%zz
11620 : : WRITE(unit_xml,'("<atom symbol=""",a,""" Z=""",a)',ADVANCE='NO') &
11621 [ # # # # ]: 0 : & trim(ADJUSTL(AEPot%sym)),trim(ADJUSTL(char5a))
11622 : 0 : WRITE(unit=char5a,fmt='(f5.2)') zcore
11623 : 0 : WRITE(unit=char5b,fmt='(f5.2)') AEPot%nz-zcore
11624 : : WRITE(unit_xml,'(""" core=""",a,""" valence=""",a,"""/>")') &
11625 [ # # # # ]: 0 : & trim(ADJUSTL(char5a)),trim(ADJUSTL(char5b))
11626 : :
11627 : : !Write XC definition
11628 : 0 : call get_xc_data(atp,xc_type,xc_name)
11629 [ # # ]: 0 : if (atp%itype==LIBXC.and.xc_type/="UNKNOWN") then
11630 : 0 : xcname_short= libxc_functionals_fullname(atp%xc_functionals)
11631 : 0 : call uppercase(xcname_short)
11632 : 0 : call get_xc_alias(xcname_short,xc_name)
11633 : : endif
11634 : : WRITE(unit_xml,'("<xc_functional type=""",a,""" name=""",a,"""/>")') &
11635 : 0 : & TRIM(xc_type),TRIM(xc_name)
11636 : 0 : code_name="rcpaw"
11637 : :
11638 : : !Generator data
11639 [ # # ]: 0 : if (atp%scalarrelativistic) then
11640 : : WRITE(unit_xml,'("<generator type=""scalar-relativistic"" name=""",a,""" orthogonalisation=""", a,"""/>")')&
11641 : 0 : & TRIM(code_name),"marsman"
11642 : : ! else if (diracrelativistic) then
11643 : : ! WRITE(unit_xml,'("<generator type=""dirac-relativistic"" name=""",a,""" orthogonalisation=""", a,"""/>")')&
11644 : : !& TRIM(code_name),trim(PAW%orthogonalization_scheme)
11645 : : else
11646 : : WRITE(unit_xml,'("<generator type=""non-relativistic"" name=""",a,""" orthogonalisation=""", a,"""/>")')&
11647 : 0 : & TRIM(code_name),"marsman"
11648 : : endif
11649 : :
11650 : : !Energies
11651 : : WRITE(unit_xml,'("<ae_energy kinetic=""",1pe25.17,""" xc=""",1pe25.17,"""")') &
11652 : 0 : & AESCF%ekin/2,AESCF%eexc/2
11653 : : WRITE(unit_xml,'(" electrostatic=""",1pe25.17,""" total=""",1pe25.17,"""/>")')&
11654 : 0 : & AESCF%estatic/2,AESCF%etot/2
11655 : 0 : WRITE(unit_xml,'("<core_energy kinetic=""",1pe25.17,"""/>")') AESCF%corekin*0.5d0
11656 : :
11657 : : !PAW radius
11658 : 0 : WRITE(unit_xml,'("<paw_radius rc=""",f17.14,"""/>")') match_on_splgrid(PAW%rc)
11659 : :
11660 : : !Electronic configuration
11661 : 0 : WRITE(unit_xml,'("<valence_states>")')
11662 [ # # ]: 0 : do ib=1,PAW%nbase
11663 : 0 : call mkname(ib,char4)
11664 : 0 : char20=stripchar('"'//AEPot%sym//char4//'"')
11665 : 0 : ii=min(ABS(PAW%np(ib)),100)
11666 [ # # ]: 0 : if (ii<100) then
11667 : : ! if(diracrelativistic) then
11668 : : ! WRITE(unit_xml,'(" <state n=""",i2,""" l=""",i1,""" kappa=""",i2,""" f=""",1pe14.7)',ADVANCE='NO')&
11669 : : !& ii,PAW%l(ib),PAW%kappa(ib),Orb%occ(ib)
11670 : : ! else
11671 : : WRITE(unit_xml,'(" <state n=""",i2,""" l=""",i1,""" f=""",1pe14.7)',ADVANCE='NO')&
11672 : 0 : & ii,PAW%l(ib),PAW%occ(ib)
11673 : : ! end if
11674 : : WRITE(unit_xml,'(""" rc=""",f13.10,""" e=""",1pe14.7,""" id=",a6,"/>")')&
11675 : 0 : & match_on_splgrid(PAW%rcio(ib)),PAW%eig(ib)*0.5d0,TRIM(char20)
11676 : : else
11677 : : ! if(diracrelativistic) then
11678 : : ! WRITE(unit_xml,'(" <state l=""",i1,""" kappa=""",i2)',ADVANCE='NO')PAW%l(ib),PAW%kappa(ib)
11679 : : ! else
11680 : 0 : WRITE(unit_xml,'(" <state l=""",i1)',ADVANCE='NO') PAW%l(ib)
11681 : : ! end if
11682 : : WRITE(unit_xml,'(""" rc=""",f13.10,""" e=""",1pe14.7,""" id=",a6,"/>")')&
11683 : 0 : & match_on_splgrid(PAW%rcio(ib)),PAW%eig(ib)*0.5d0,TRIM(char20)
11684 : : end if
11685 : : enddo
11686 : 0 : WRITE(unit_xml,'("</valence_states>")')
11687 : :
11688 : : !Radial meshes definitions
11689 : 0 : nmesh=mesh_data%nmesh
11690 [ # # # # : 0 : if(maxval(mesh_data%meshtp(1:mesh_data%nmesh))==minval(mesh_data%meshtp(1:mesh_data%nmesh)))then
# # ]
11691 [ # # # # ]: 0 : mesh_data%meshsz(1:mesh_data%nmesh)=maxval(mesh_data%meshsz(1:mesh_data%nmesh))
11692 : 0 : nmesh=1
11693 : 0 : mesh_data%icoremesh=1
11694 : 0 : mesh_data%itaumesh=1
11695 : 0 : mesh_data%iprjmesh=1
11696 : 0 : mesh_data%iwavmesh=1
11697 : 0 : mesh_data%ivionmesh=1
11698 : 0 : mesh_data%ivalemesh=1
11699 : 0 : mesh_data%ivbaremesh=1
11700 : 0 : mesh_data%ivlda12mesh=1
11701 : : endif
11702 [ # # # # ]: 0 : if (nmesh>1.and.nsplgrid>0) stop ' Bug (1) in xmlinterface: nmesh>1 and nsplgrid>0!'
11703 : :
11704 [ # # ]: 0 : do ii=1,nmesh
11705 [ # # # # : 0 : LIBPAW_ALLOCATE(dudr,(mesh_data%meshsz(ii)))
# # # # #
# # # ]
11706 : 0 : select case(mesh_data%meshtp(ii))
11707 : : case(1)
11708 : 0 : char20='r=d*i'
11709 : 0 : gridt(ii)="lin"
11710 : 0 : mesh_start(ii)=1
11711 : 0 : mesh_size(ii)=mesh_data%meshsz(ii)
11712 : 0 : radstp0=zero
11713 : 0 : logstp0=mesh_data%radstp(ii)
11714 [ # # ]: 0 : dudr(1:mesh_data%meshsz(ii))=logstp0
11715 : :
11716 : : case(2)
11717 : 0 : char20='r=a*(exp(d*i)-1)'
11718 : 0 : gridt(ii)="log"
11719 : 0 : mesh_start(ii)=1
11720 [ # # ]: 0 : if (nsplgrid<=0) then
11721 : 0 : mesh_size(ii)=mesh_data%meshsz(ii)
11722 : 0 : radstp0=mesh_data%radstp(ii)
11723 : 0 : logstp0=mesh_data%logstp(ii)
11724 : : else
11725 : 0 : mesh_size(ii)=nsplgrid
11726 : 0 : radstp0=radstp_spl
11727 : 0 : logstp0=logstp_spl
11728 : : end if
11729 [ # # ]: 0 : dudr(1:mesh_size(ii))=logstp0*(radstp0+rad_aux(1:mesh_size(ii)))
11730 : :
11731 : : case default
11732 [ # # # ]: 0 : stop ' Bug (2) in xmlinterface: mesh type not implemented in Atompaw!'
11733 : : end select
11734 : :
11735 : 0 : WRITE(unit_xml,'("<radial_grid eq=""",a,""" a=""",es23.16)',ADVANCE='NO')trim(char20),radstp0
11736 : 0 : WRITE(unit_xml,'(""" d=""",es23.16,""" istart=""0"" iend=""",i5)',ADVANCE='NO')logstp0,mesh_size(ii)-mesh_start(ii)
11737 : 0 : WRITE(unit_xml,'(""" id=""",a,i1,""">")') gridt(ii),ii
11738 : 0 : WRITE(unit_xml,'(" <values>")')
11739 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (rad_aux(ir),ir=mesh_start(ii),mesh_size(ii))
11740 : 0 : WRITE(unit_xml,'(" </values>")')
11741 : 0 : WRITE(unit_xml,'(" <derivatives>")')
11742 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dudr(ir),ir=mesh_start(ii),mesh_size(ii))
11743 : 0 : WRITE(unit_xml,'(" </derivatives>")')
11744 : 0 : WRITE(unit_xml,'("</radial_grid>")')
11745 [ # # ]: 0 : LIBPAW_DEALLOCATE(dudr)
11746 : :
11747 : : end do
11748 : :
11749 : : !Compensation charge shape function
11750 [ # # ]: 0 : if (atp%gaussianshapefunction) then
11751 : 0 : WRITE(unit_xml,'("<shape_function type=""gauss"" rc=""",f19.16,"""/>")')match_on_splgrid(PAW%gausslength)
11752 [ # # ]: 0 : else if (atp%besselshapefunction) then
11753 : 0 : WRITE(unit_xml,'("<shape_function type=""bessel"" rc=""",f19.16,"""/>")')match_on_splgrid(PAW%rc_shap)
11754 : : else
11755 : 0 : WRITE(unit_xml,'("<shape_function type=""sinc"" rc=""",f19.16,"""/>")')match_on_splgrid(PAW%rc_shap)
11756 : : endif
11757 : :
11758 : : !Core densities
11759 : 0 : meshsz=mesh_data%meshsz(mesh_data%icoremesh)
11760 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%icoremesh),extra1)
11761 : 0 : meshst_aux=mesh_start(mesh_data%icoremesh)
11762 [ # # ]: 0 : dum(2:meshsz)=sqr4pi*Orb%coreden(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11763 : 0 : call extrapolate(dum(1:meshsz))
11764 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11765 : : WRITE(unit_xml,'("<ae_core_density grid=""",a,i1,""">")') &
11766 : 0 : & gridt(mesh_data%icoremesh),mesh_data%icoremesh
11767 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11768 : 0 : WRITE(unit_xml,'("</ae_core_density>")')
11769 [ # # ]: 0 : dum(2:meshsz)=sqr4pi*PAW%tcore(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11770 : 0 : call extrapolate(dum(1:meshsz))
11771 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11772 : : WRITE(unit_xml,'("<pseudo_core_density grid=""",a,i1,""" rc=""",f19.16,""">")')&
11773 : 0 : & gridt(mesh_data%icoremesh),mesh_data%icoremesh,match_on_splgrid(PAW%rc_core)
11774 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11775 : 0 : WRITE(unit_xml,'("</pseudo_core_density>")')
11776 : :
11777 : : !!Kinetic energy core densities
11778 : : !!Available in scalar relativistic (although approximate)
11779 : : ! if (.true.) then
11780 : : ! meshsz=mesh_data%meshsz(mesh_data%itaumesh)
11781 : : ! meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%itaumesh),extra1)
11782 : : ! meshst_aux=mesh_start(mesh_data%itaumesh)
11783 : : ! dum(2:meshsz)= half*sqr4pi*FC%coretau(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11784 : : ! call extrapolate(Grid,dum(1:meshsz))
11785 : : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11786 : : ! WRITE(unit_xml,'("<ae_core_kinetic_energy_density grid=""",a,i1,""" rc=""",f19.16,""">")') &
11787 : : !& gridt(mesh_data%itaumesh),mesh_data%itaumesh,match_on_splgrid(PAW%rc_core)
11788 : : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11789 : : ! WRITE(unit_xml,'("</ae_core_kinetic_energy_density>")')
11790 : : ! dum(2:meshsz)= half*sqr4pi*PAW%tcoretau(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11791 : : ! call extrapolate(Grid,dum(1:meshsz))
11792 : : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11793 : : ! WRITE(unit_xml,'("<pseudo_core_kinetic_energy_density grid=""",a,i1,""" rc=""",f19.16,""">")') &
11794 : : !& gridt(mesh_data%itaumesh),mesh_data%itaumesh,match_on_splgrid(PAW%rc_core)
11795 : : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11796 : : ! WRITE(unit_xml,'("</pseudo_core_kinetic_energy_density>")')
11797 : : ! else
11798 : : ! write(std_out,'(5(/,2x,a))') 'Atompaw2XML WARNING!!!!!',&
11799 : : !& ' Kinetic energy core density is not available',&
11800 : : !& ' within scalar relativistic scheme!',&
11801 : : !& ' Will not be present in the XML dataset.',&
11802 : : !& ' This is temporary, sorry!'
11803 : : ! end if
11804 : :
11805 : : !!Valence density
11806 : : ! meshsz=mesh_data%meshsz(mesh_data%ivalemesh)
11807 : : ! meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivalemesh),extra1)
11808 : : ! meshst_aux=mesh_start(mesh_data%ivalemesh)
11809 : : ! dum(2:meshsz)=sqr4pi*PAW%tden(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11810 : : ! call extrapolate(dum(1:meshsz))
11811 : : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11812 : : ! rad=maxval(PAW%rcio(1:PAW%nbase))
11813 : : ! WRITE(unit_xml,'("<pseudo_valence_density grid=""",a,i1,""" rc=""",f19.16,""">")') &
11814 : : !& gridt(mesh_data%ivalemesh),mesh_data%ivalemesh,match_on_splgrid(rad)
11815 : : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11816 : : ! WRITE(unit_xml,'("</pseudo_valence_density>")')
11817 : :
11818 : : !Vbare potential
11819 : 0 : meshsz=mesh_data%meshsz(mesh_data%ivbaremesh)
11820 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivbaremesh),extra1)
11821 : 0 : meshst_aux=mesh_start(mesh_data%ivbaremesh)
11822 [ # # ]: 0 : dum(1:meshsz)=sqr4pi*half*PAW%vloc(1:meshsz)
11823 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11824 [ # # ]: 0 : dum_aux(irc_aux:meshsz_aux)=0.d0 ! Vbare has to be zero at rc
11825 : : WRITE(unit_xml,'("<zero_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11826 : 0 : & gridt(mesh_data%ivbaremesh),mesh_data%ivbaremesh,match_on_splgrid(PAW%rc)
11827 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11828 : 0 : WRITE(unit_xml,'("</zero_potential>")')
11829 : :
11830 : : !Local ionic potential
11831 [ # # ]: 0 : if (vlocopt==1) then
11832 : 0 : meshsz=mesh_data%meshsz(mesh_data%ivionmesh)
11833 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivionmesh),extra1)
11834 : 0 : meshst_aux=mesh_start(mesh_data%ivionmesh)
11835 [ # # ]: 0 : dum(1:meshsz)=sqr4pi*half*PAW%abinitvloc(1:meshsz)
11836 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11837 : : WRITE(unit_xml,'("<kresse_joubert_local_ionic_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11838 : 0 : & gridt(mesh_data%ivionmesh),mesh_data%ivionmesh,match_on_splgrid(PAW%rc)
11839 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11840 : 0 : WRITE(unit_xml,'("</kresse_joubert_local_ionic_potential>")')
11841 : : end if
11842 : :
11843 : : !Local Blochl''s potential
11844 [ # # ]: 0 : if(vlocopt==2) then
11845 : 0 : meshsz=mesh_data%meshsz(mesh_data%ivionmesh)
11846 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivionmesh),extra1)
11847 : 0 : meshst_aux=mesh_start(mesh_data%ivionmesh)
11848 [ # # ]: 0 : dum(1:meshsz)=sqr4pi*half*PAW%abinitnohat(1:meshsz)
11849 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11850 : : WRITE(unit_xml,'("<blochl_local_ionic_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11851 : 0 : & gridt(mesh_data%ivionmesh),mesh_data%ivionmesh,match_on_splgrid(PAW%rc)
11852 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11853 : 0 : WRITE(unit_xml,'("</blochl_local_ionic_potential>")')
11854 : : endif
11855 : :
11856 : : !Local LDA-1/2 potential
11857 : : ! if (pawlda12%uselda12) then
11858 : : ! meshsz=mesh_data%meshsz(mesh_data%ivlda12mesh)
11859 : : ! meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivlda12mesh),extra1)
11860 : : ! meshst_aux=mesh_start(mesh_data%ivlda12mesh)
11861 : : ! dum(1:meshsz)=pawlda12%pot(1:meshsz)
11862 : : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11863 : : ! ir=index_on_splgrid(pawlda12%rcut)
11864 : : ! dum_aux(ir+1:meshsz_aux)=0.d0 ! V_lda12 has to be zero for r>rc
11865 : : ! WRITE(unit_xml,'("<LDA_minus_half_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11866 : : !& gridt(mesh_data%ivlda12mesh),mesh_data%ivlda12mesh,match_on_splgrid(pawlda12%rcut)
11867 : : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11868 : : ! WRITE(unit_xml,'("</LDA_minus_half_potential>")')
11869 : : ! end if
11870 : :
11871 : : !Partial waves and projectors
11872 : : !-- Partial waves
11873 : 0 : meshsz=mesh_data%meshsz(mesh_data%iwavmesh)
11874 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%iwavmesh),extra1)
11875 : 0 : meshst_aux=mesh_start(mesh_data%iwavmesh)
11876 [ # # # # : 0 : LIBPAW_ALLOCATE(phi_aux,(meshsz_aux-meshst_aux+1,PAW%nbase))
# # # # #
# # # # #
# # # # ]
11877 [ # # # # : 0 : LIBPAW_ALLOCATE(tphi_aux,(meshsz_aux-meshst_aux+1,PAW%nbase))
# # # # #
# # # ]
11878 [ # # ]: 0 : Do ib=1,PAW%nbase
11879 [ # # ]: 0 : dum(2:meshsz)=PAW%ophi(2:meshsz,ib)/Grid%r(2:meshsz)
11880 : 0 : call extrapolate(dum(1:meshsz))
11881 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11882 [ # # ]: 0 : phi_aux(1:meshsz_aux,ib)=dum_aux(1:meshsz_aux)
11883 [ # # ]: 0 : dum(2:meshsz)=PAW%otphi(2:meshsz,ib)/Grid%r(2:meshsz)
11884 : 0 : call extrapolate(dum(1:meshsz))
11885 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11886 [ # # # # ]: 0 : if(nsplgrid>0) dum_aux(irc_aux:meshsz_aux)=phi_aux(irc_aux:meshsz_aux,ib)
11887 [ # # ]: 0 : tphi_aux(meshst_aux:meshsz_aux,ib)=dum_aux(meshst_aux:meshsz_aux)
11888 : : Enddo
11889 : : !-- Projectors
11890 : 0 : meshsz=mesh_data%meshsz(mesh_data%iprjmesh)
11891 [ # # ]: 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%iprjmesh),extra1)
11892 : 0 : meshst_aux=mesh_start(mesh_data%iprjmesh)
11893 [ # # # # : 0 : LIBPAW_ALLOCATE(proj_aux,(meshsz_aux-meshst_aux+1,PAW%nbase))
# # # # #
# # # # #
# # # # ]
11894 [ # # ]: 0 : Do ib=1,PAW%nbase
11895 [ # # ]: 0 : dum(2:meshsz)=tproj(2:meshsz,ib)/Grid%r(2:meshsz)
11896 : 0 : call extrapolate(dum(1:meshsz))
11897 : 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11898 [ # # # # ]: 0 : if(nsplgrid>0) dum_aux(irc_aux:meshsz_aux)=zero
11899 [ # # ]: 0 : proj_aux(meshst_aux:meshsz_aux,ib)=dum_aux(meshst_aux:meshsz_aux)
11900 : : Enddo
11901 : : !-- In case of a spline, re-orthogonalize projectors
11902 : : ! if (nsplgrid >0) then
11903 : : ! Do ib=1,PAW%nbase
11904 : : ! tphi_aux(1:meshsz_aux,ib)=tphi_aux(1:meshsz_aux,ib)*Grid1%r(1:meshsz_aux)
11905 : : ! proj_aux(1:meshsz_aux,ib)=proj_aux(1:meshsz_aux,ib)*Grid1%r(1:meshsz_aux)
11906 : : ! Enddo
11907 : : ! call vdborth(irc_aux,tphi_aux,proj_aux)
11908 : : ! Do ib=1,PAW%nbase
11909 : : ! tphi_aux(2:meshsz_aux,ib)=tphi_aux(2:meshsz_aux,ib)/Grid1%r(2:meshsz_aux)
11910 : : ! call extrapolate(tphi_aux(1:meshsz_aux,ib))
11911 : : ! proj_aux(2:meshsz_aux,ib)=proj_aux(2:meshsz_aux,ib)/Grid1%r(2:meshsz_aux)
11912 : : ! call extrapolate(proj_aux(1:meshsz_aux,ib))
11913 : : ! Enddo
11914 : : ! end if
11915 : : !-- Writing
11916 [ # # ]: 0 : Do ib=1,PAW%nbase
11917 : 0 : call mkname(ib,char4)
11918 : 0 : char20=stripchar('"'//AEPot%sym//char4//'"')
11919 : : WRITE(unit_xml,'("<ae_partial_wave state=",a6," grid=""",a,i1,""">")') &
11920 : 0 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11921 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (phi_aux(ii,ib),ii=meshst_aux,meshsz_aux)
11922 : 0 : WRITE(unit_xml,'("</ae_partial_wave>")')
11923 : : WRITE(unit_xml,'("<pseudo_partial_wave state=",a6," grid=""",a,i1,""">")')&
11924 : 0 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11925 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (tphi_aux(ii,ib),ii=meshst_aux,meshsz_aux)
11926 : 0 : WRITE(unit_xml,'("</pseudo_partial_wave>")')
11927 : : WRITE(unit_xml,'("<projector_function state=",a6," grid=""",a,i1,""">")') &
11928 : 0 : & TRIM(char20),gridt(mesh_data%iprjmesh),mesh_data%iprjmesh
11929 : 0 : WRITE(unit_xml,'(3(1x,es23.16))') (proj_aux(ii,ib),ii=meshst_aux,meshsz_aux)
11930 : 0 : WRITE(unit_xml,'("</projector_function>")')
11931 : : !do ic=1,PAW%nbase
11932 : : ! write(std_out,*) "splined", ib,ic
11933 : : ! dum(meshst_aux:meshsz_aux)=tphi_aux(meshst_aux:meshsz_aux,ib)*proj_aux(meshst_aux:meshsz_aux,ic)*dudr(meshst_aux:meshsz_aux)
11934 : : ! dum(meshst_aux:meshsz_aux)=dum(meshst_aux:meshsz_aux)*rad_aux(meshst_aux:meshsz_aux)*rad_aux(meshst_aux:meshsz_aux)
11935 : : ! xx=overint(meshsz_aux-meshst_aux+1,logstp0,dum(meshst_aux:meshsz_aux),-1)
11936 : : ! write(std_out,*) "ORTHO", ib,xx/logstp0
11937 : : !end do
11938 : : Enddo
11939 : : !-- Release memory
11940 [ # # ]: 0 : LIBPAW_DEALLOCATE(phi_aux)
11941 [ # # ]: 0 : LIBPAW_DEALLOCATE(proj_aux)
11942 [ # # ]: 0 : LIBPAW_DEALLOCATE(tphi_aux)
11943 : :
11944 : : !Kinetic terms
11945 : 0 : WRITE(unit_xml,'("<kinetic_energy_differences>")')
11946 [ # # # # : 0 : WRITE(unit_xml,'(3(1x,es23.16))')((PAW%kij(ib,ic)/2,ic=1,PAW%nbase),ib=1,PAW%nbase)
# # # # ]
11947 : 0 : WRITE(unit_xml,'("</kinetic_energy_differences>")')
11948 : :
11949 : : !!Core-valence exchange terms
11950 : : ! WRITE(unit_xml,'("<exact_exchange_X_matrix>")')
11951 : : ! WRITE(unit_xml,'(3(1x,es23.16))')((PAW%TXVC(ib,ic)/2,ic=1,PAW%nbase),ib=1,PAW%nbase)
11952 : : ! WRITE(unit_xml,'("</exact_exchange_X_matrix>")')
11953 : : !
11954 : : !!Core-core exchange terms
11955 : : ! WRITE(unit_xml,'("<exact_exchange core-core=""", 1x,es23.16,"""/>")') &
11956 : : !& PAW%XCORECORE/2
11957 : : !
11958 : : !!Lamb shielding
11959 : : ! WRITE(unit_xml,'("<lamb_shielding shielding=""", 1x,es23.16,"""/>")') &
11960 : : !& PAW%lambshielding
11961 : : !
11962 : : !! Input file
11963 : 0 : WRITE(unit_xml,'("<!-- Program: atompaw - input data follows: ")')
11964 : 0 : WRITE(unit_xml,'(a)') trim(input_string)
11965 : 0 : WRITE(unit_xml,'(a)') "END"
11966 : 0 : WRITE(unit_xml,'(" Program: atompaw - input end -->")')
11967 : 0 : WRITE(unit_xml,'("</paw_dataset>")')
11968 : :
11969 : : !Close file and end
11970 : 0 : CLOSE(unit_xml)
11971 : 0 : WRITE(STD_OUT,'(/,2x,a)') 'XML atomic dataset created.'
11972 : :
11973 [ # # ]: 0 : if(nsplgrid>0) call destroygrid(Grid1)
11974 [ # # ]: 0 : LIBPAW_DEALLOCATE(rad_aux)
11975 [ # # ]: 0 : LIBPAW_DEALLOCATE(dum_aux)
11976 [ # # # # ]: 0 : LIBPAW_DEALLOCATE(dum)
11977 : :
11978 : : CONTAINS
11979 : : !**************************************************
11980 : : ! If an interpolation on an auxiliary grid is
11981 : : ! requested, give index of input radius
11982 : : ! on this auxiliary grid
11983 : : !**************************************************
11984 : : integer function index_on_splgrid(input_radius)
11985 : : real(dp),intent(in) :: input_radius
11986 : : if (nsplgrid>0) then
11987 : : if (logstp_spl>0.d0) then
11988 : : index_on_splgrid=int(tol8+log(1.d0+input_radius/radstp_spl)/logstp_spl)+1
11989 : : else if (radstp_spl>0.d0) then
11990 : : index_on_splgrid=int(tol8+input_radius/radstp_spl)+1
11991 : : end if
11992 : : else
11993 : : index_on_splgrid=FindGridIndex(Grid,input_radius)
11994 : : end if
11995 : : end function index_on_splgrid
11996 : :
11997 : : !**************************************************
11998 : : ! If an interpolation on an auxiliary grid is
11999 : : ! requested, match input radius on this auxiliary
12000 : : ! grid (defined by radstp_spl, logstp_spl)
12001 : : !**************************************************
12002 : 0 : real(dp) function match_on_splgrid(input_radius)
12003 : : real(dp),intent(in) :: input_radius
12004 : : integer :: indx
12005 : 0 : match_on_splgrid=input_radius
12006 [ # # ]: 0 : if (nsplgrid>0) then
12007 [ # # ]: 0 : if (logstp_spl>0.d0) then
12008 : 0 : indx=int(tol8+log(1.d0+input_radius/radstp_spl)/logstp_spl)+1
12009 : 0 : match_on_splgrid=radstp_spl*(exp(logstp_spl*(indx-1))-1.d0)
12010 [ # # ]: 0 : else if (radstp_spl>0.d0) then
12011 : 0 : indx=int(tol8+input_radius/radstp_spl)+1
12012 : 0 : match_on_splgrid=radstp_spl*(indx-1)
12013 : : end if
12014 : : end if
12015 : 0 : end function match_on_splgrid
12016 : :
12017 : : !**************************************************
12018 : : ! If an interpolation on an auxiliary grid is
12019 : : ! requested, inerpolate an input function on
12020 : : ! this auxiliary grid.
12021 : : ! Also filter the input function (put zero below
12022 : : ! a given threshold)
12023 : : !**************************************************
12024 [ # # # # ]: 0 : subroutine interp_and_filter(func_in,func_out)
12025 : : real(dp),intent(in) :: func_in(:)
12026 : : real(dp),intent(out) :: func_out(:)
12027 : : integer :: jj,msz_in,msz_out,msz_spl
12028 : : logical :: extra
12029 : 0 : msz_in=size(func_in) ; msz_out=size(func_out)
12030 [ # # ]: 0 : func_out=zero
12031 [ # # ]: 0 : if (nsplgrid>0) then
12032 [ # # ]: 0 : if (msz_out/=nsplgrid) stop ' Bug (1) in interp_and_filter: msz_out/=nsplgrid!'
12033 : 0 : extra=(Grid%r(msz_in)<Grid1%r(msz_out))
12034 [ # # ]: 0 : msz_spl=merge(msz_out-1,msz_out,extra)
12035 : 0 : call interpfunc(msz_in,Grid%r,func_in,msz_spl,Grid1%r,func_out)
12036 : : else
12037 [ # # ]: 0 : if (msz_out>msz_in) stop ' Bug (2) in interp_and_filter: msz_out>msz_in!'
12038 [ # # ]: 0 : func_out(1:msz_out)=func_in(1:msz_out)
12039 : : end if
12040 [ # # ]: 0 : do jj=1,msz_out
12041 [ # # ]: 0 : if (abs(func_out(jj))<tol_zero) func_out(jj)=0.d0
12042 : : end do
12043 : :
12044 : 0 : end subroutine interp_and_filter
12045 : :
12046 : : !***********************************************************************
12047 : : !* In case of interpolation on an auxiliary grid, a
12048 : : !* reorthonomalisation of projector and pseudo wavefunctions
12049 : : !* is necessary. This is done thanks to a Vanderbilt orthonormalisation
12050 : : !************************************************************************
12051 : : ! subroutine vdborth(irc_aux,tphi_aux,proj_aux)
12052 : : !
12053 : : ! real(dp),intent(in) :: tphi_aux(:,:)
12054 : : ! real(dp),intent(inout) :: proj_aux(:,:)
12055 : : ! integer :: irc_aux
12056 : : !
12057 : : ! integer :: i,icount,io,irc,j,jo,l,lmax,nbase
12058 : : ! real(dp), allocatable :: aa(:,:),ai(:,:),omap(:),proj_aux1(:,:)
12059 : : !
12060 : : ! allocate(proj_aux1(size(proj_aux,1),PAW%nbase))
12061 : : ! lmax=PAW%lmax
12062 : : ! nbase=PAW%nbase
12063 : : ! irc=irc_aux
12064 : : ! do l=0,lmax
12065 : : ! icount=0
12066 : : ! do io=1,nbase
12067 : : ! if (PAW%l(io)==l) icount=icount+1
12068 : : ! enddo
12069 : : ! if (icount==0) cycle
12070 : : ! allocate(aa(icount,icount),ai(icount,icount),omap(icount))
12071 : : ! aa=0;icount=0
12072 : : ! do io=1,nbase
12073 : : ! if (PAW%l(io)==l) then
12074 : : ! icount=icount+1
12075 : : ! omap(icount)=io
12076 : : ! endif
12077 : : ! enddo
12078 : : ! do i=1,icount
12079 : : ! io=omap(i)
12080 : : ! do j=1,icount
12081 : : ! jo=omap(j)
12082 : : ! aa(i,j)=overlap(Grid1,tphi_aux(:,io),proj_aux(:,jo),1,irc)
12083 : : ! enddo
12084 : : ! enddo
12085 : : ! ai=aa;call minverse(ai,icount,icount,icount)
12086 : : !
12087 : : ! do i=1,icount
12088 : : ! io=omap(i)
12089 : : ! proj_aux1(:,io)=0
12090 : : ! do j=1,icount
12091 : : ! jo=omap(j)
12092 : : ! proj_aux1(:,io)=proj_aux1(:,io)+proj_aux(:,jo)*ai(j,i)
12093 : : ! enddo
12094 : : ! enddo
12095 : : ! deallocate(aa,ai,omap)
12096 : : ! enddo
12097 : : ! proj_aux=proj_aux1
12098 : : ! deallocate(proj_aux1)
12099 : : ! end subroutine vdborth
12100 : :
12101 : : END SUBROUTINE xmloutput
12102 : :
12103 : :
12104 : : !!=================================================================
12105 : : !! NAME
12106 : : !! get_xc_data
12107 : : !!
12108 : : !! FUNCTION
12109 : : !! Get XC data in a suitable form for XML printing
12110 : : !!
12111 : : !! INPUTS
12112 : : !! exctype= string containing XC type
12113 : : !!
12114 : : !! OUTPUT
12115 : : !! xc_name= name of XC functional
12116 : : !! xc_type= LDA or GGA
12117 : : !!
12118 : : !! PARENTS
12119 : : !! xmlout,xmlprtcore
12120 : : !!
12121 : : !!=================================================================
12122 : :
12123 : 0 : subroutine get_xc_data(atp,xctype,xcname)
12124 : : type(atompaw_type),intent(in) :: atp
12125 : : character(len=*),intent(out) :: xctype,xcname
12126 : :
12127 : : !------------------------------------------------------------------
12128 : : !---- Executable code
12129 : : !------------------------------------------------------------------
12130 : :
12131 [ # # ]: 0 : if (trim(ADJUSTL(atp%exctype))=="LDA-PW") then
12132 [ # # # # ]: 0 : xctype="LDA"
12133 [ # # # # ]: 0 : xcname="PW"
12134 [ # # ]: 0 : elseif (trim(ADJUSTL(atp%exctype))=="GGA-PBE") then
12135 [ # # # # ]: 0 : xctype="GGA"
12136 [ # # # # ]: 0 : xcname="PBE"
12137 [ # # ]: 0 : elseif (trim(ADJUSTL(atp%exctype))=="GGA-PBESOL") then
12138 [ # # # # ]: 0 : xctype="GGA"
12139 [ # # # # ]: 0 : xcname="PBESOL"
12140 [ # # ]: 0 : else if(atp%itype==LIBXC) then
12141 [ # # ]: 0 : if (libxc_functionals_ismgga(atp%xc_functionals)) then
12142 [ # # # # ]: 0 : xctype="MGGA"
12143 [ # # ]: 0 : else if (libxc_functionals_isgga(atp%xc_functionals)) then
12144 [ # # # # ]: 0 : xctype="GGA"
12145 : : else
12146 [ # # # # ]: 0 : xctype="LDA"
12147 : : end if
12148 [ # # # # ]: 0 : xcname=trim(atp%exctype)
12149 : : else
12150 : 0 : LIBPAW_ERROR("Unknown XC type")
12151 : : end if
12152 : :
12153 : 0 : end subroutine get_xc_data
12154 : :
12155 : :
12156 : :
12157 : : !!=================================================================
12158 : : !! NAME
12159 : : !! get_xc_alias
12160 : : !!
12161 : : !! FUNCTION
12162 : : !! Get XC name alias (following PAW-XML specification)
12163 : : !! from a libXC functional name
12164 : : !!
12165 : : !! INPUTS
12166 : : !! xc_name= string containing long XC name
12167 : : !!
12168 : : !! OUTPUT
12169 : : !! xc_alias= alias of XC functional
12170 : : !!
12171 : : !! PARENTS
12172 : : !! xmlout,xmlprtcore
12173 : : !!
12174 : : !!=================================================================
12175 : :
12176 : 0 : subroutine get_xc_alias(xc_name,xc_alias)
12177 : :
12178 : : character(len=*),intent(in) :: xc_name
12179 : : character(len=*),intent(out) :: xc_alias
12180 : :
12181 : : !------------------------------------------------------------------
12182 : : !---- Executable code
12183 : : !------------------------------------------------------------------
12184 : :
12185 : 0 : select case(trim(xc_name))
12186 : : case('LDA_X+LDA_C_PW')
12187 [ # # # # ]: 0 : xc_alias='PW'
12188 : : case('GGA_X_PBE+GGA_C_PBE')
12189 [ # # # # ]: 0 : xc_alias='PBE'
12190 : : case('LDA_X+LDA_C_PZ')
12191 [ # # # # ]: 0 : xc_alias='PZ'
12192 : : case('LDA_X+LDA_C_WIGNER')
12193 [ # # # # ]: 0 : xc_alias='W'
12194 : : case('LDA_X+LDA_C_HL')
12195 [ # # # # ]: 0 : xc_alias='HL'
12196 : : case('LDA_X+LDA_C_GL')
12197 [ # # # # ]: 0 : xc_alias='GL'
12198 : : case('LDA_X+LDA_C_VWN')
12199 [ # # # # ]: 0 : xc_alias='VWN'
12200 : : case('GGA_X_PBE_R+GGA_C_PBE')
12201 [ # # # # ]: 0 : xc_alias='revPBE'
12202 : : case('GGA_X_RPBE+GGA_C_PBE')
12203 [ # # # # ]: 0 : xc_alias='RPBE'
12204 : : case('GGA_X_PW91+GGA_C_PW91')
12205 [ # # # # ]: 0 : xc_alias='PW91'
12206 : : case('GGA_X_B88+GGA_C_LYP')
12207 [ # # # # ]: 0 : xc_alias='BLYP'
12208 : : case DEFAULT
12209 [ # # # # ]: 0 : xc_alias=xc_name
12210 : : end select
12211 : :
12212 [ # # # # : 0 : end subroutine get_xc_alias
# # # # #
# # # ]
12213 : :
12214 : :
12215 : :
12216 : : !!=================================================================
12217 : : !! NAME
12218 : : !! read_inputstring
12219 : : !!
12220 : : !! FUNCTION
12221 : : !! Read the file echoing the atompaw input file
12222 : : !! and transfer it into a character string
12223 : : !!
12224 : : !! OUTPUT
12225 : : !! input_string=character string containing the file
12226 : : !!
12227 : : !! PARENTS
12228 : : ! xml2abinit
12229 : : !!=================================================================
12230 : :
12231 : 4 : subroutine read_inputstring(input_string,echofile)
12232 : :
12233 : : character(len=*),intent(inout) :: input_string
12234 : : character(len=*),intent(in) :: echofile
12235 : :
12236 : : !------------------------------------------------------------------
12237 : : !---- Local variables
12238 : : !------------------------------------------------------------------
12239 : :
12240 : : integer :: OK,input_unit=5
12241 : : character(len=132) :: inputline
12242 : :
12243 : : !------------------------------------------------------------------
12244 : : !---- Executable code
12245 : : !------------------------------------------------------------------
12246 : :
12247 : 4 : open(input_unit,file=trim(echofile),form='formatted')
12248 [ + - ]: 4 : read(input_unit,'(a)',iostat=OK,end=10) inputline
12249 [ + - ]: 4 : if (OK/=0) return
12250 [ + - + - ]: 4 : input_string=trim(inputline)
12251 : 165 : do
12252 [ + + ]: 169 : read(input_unit,'(a)',iostat=OK,end=10) inputline
12253 [ + - ]: 165 : if (OK/=0) exit
12254 : 165 : write(unit=input_string,fmt='(3a)') trim(input_string),char(10),trim(inputline)
12255 : : enddo
12256 : : return
12257 : : 10 continue
12258 : 4 : close(input_unit)
12259 : :
12260 : 4 : end subroutine read_inputstring
12261 : :
12262 : :
12263 [ # # # # : 0 : end module m_paw_atom_solve
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
12264 : : !!***
|
