Line data Source code
1 : !!****m* ABINIT/m_paw_atom_solve
2 : !! NAME
3 : !! m_paw_atom_solve
4 : !!
5 : !! FUNCTION
6 : !! This module provides routines of the ATOMPAW code (created by NAWH, MT, FJ), modified for relaxed core paw purposes.
7 : !!
8 : !! COPYRIGHT
9 : !! Copyright (C) 2013-2026 ABINIT group (MT, NBrouwer, JBoust)
10 : !! This file is distributed under the terms of the
11 : !! GNU General Public License, see ~abinit/COPYING
12 : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : !!
14 : !! NOTES
15 : !! FOR DEVELOPPERS: in order to preserve the portability of libPAW library,
16 : !! please consult ~abinit/src/??_libpaw/libpaw-coding-rules.txt
17 : !!
18 : !! Several functions and types in this module are declared to be private to avoid
19 : !! problems with the rest of libpaw while maintaining as much of atompaw code as possible.
20 : !!
21 : !! SOURCE
22 :
23 : #include "libpaw.h"
24 :
25 : module m_paw_atom_solve
26 :
27 : USE_DEFS
28 : USE_MSG_HANDLING
29 : USE_MPI_WRAPPERS
30 : USE_MEMORY_PROFILING
31 :
32 : USE ieee_arithmetic
33 : use m_libpaw_libxc
34 : use m_pawtab
35 : use m_pawrad
36 : use m_paw_atomorb
37 : use m_pawpsp
38 : use m_paw_atom, only : atompaw_ehnzc,atompaw_dij0,atompaw_kij,atompaw_vhnzc
39 : use m_paw_numeric
40 : use m_pawpsp
41 : use m_libpaw_tools, only : libpaw_get_free_unit
42 :
43 : implicit none
44 : private
45 :
46 :
47 :
48 :
49 :
50 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
51 : ! PRIVATE PARAMETERS IMPORTED FROM ATOMPAW
52 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
53 :
54 :
55 : ! Numerics
56 : logical,private,save :: has_to_print
57 : real(dp),private,save :: machine_zero,machine_precision,machine_infinity,practical_zero
58 : real(dp), PRIVATE,save :: minlog,maxlog,minexp,maxexp
59 : real(dp), PRIVATE,save :: minlogarg,maxlogarg,minexparg,maxexparg
60 : real(dp), PARAMETER, PRIVATE :: MaxMix=0.3_dp,seterr=tol11,settoosmall=tol16
61 : REAL(dp), parameter :: seterrmg=1.d-9,settoosmallmg=1.d-10
62 : integer, parameter, private :: MaxIter=2000
63 : ! Grid
64 : INTEGER, PARAMETER, PRIVATE :: lineargrid=1 ! r(i)=h*(i-1)
65 : INTEGER, PARAMETER, PRIVATE :: loggrid=2 ! r(i)=r0*(exp(h*(i-1))-1)
66 : real(dp),PRIVATE, PARAMETER :: coretailtol=tol12
67 : real(dp), PARAMETER, PRIVATE ::linrange=50._dp,linh=0.0025_dp,mxgridlin=20001
68 : real(dp), PARAMETER, PRIVATE ::logrange=80._dp,logh=0.020_dp,mxgridlog=2001
69 : real(dp), PARAMETER, PRIVATE :: v4logrange=100._dp,lor00=tol5
70 : real(dp), PARAMETER, PRIVATE :: rmax_vloc=10._dp
71 : ! Constants
72 : real(dp), parameter :: ifsalpha2=InvFineStruct**2
73 : real(dp), parameter :: fsalpha2=1._dp/InvFineStruct**2
74 : ! PS scheme
75 : INTEGER,PRIVATE,PARAMETER :: BLOECHL=1, VANDERBILT=2, CUSTOM=3, MODRRKJ=7,HFPROJ=8
76 : INTEGER,PRIVATE,PARAMETER :: BLOECHLPS=0, POLYNOM=1,POLYNOM2=2,RRKJ=3,MARSMAN=6
77 : INTEGER,PRIVATE,PARAMETER :: VANDERBILTORTHO=0, GRAMSCHMIDTORTHO=1
78 : INTEGER,PRIVATE,PARAMETER :: SVDORTHO=2, HFORTHO=-13
79 : INTEGER,PRIVATE,PARAMETER :: MTROULLIER=1, ULTRASOFT=2, BESSEL=3, KERKER_E=4,KERKER_P=5
80 : INTEGER,PRIVATE,PARAMETER :: HARTREE_FOCK=6, SETVLOC=7, VPSMATCHNC=8,VPSMATCHNNC=9
81 : INTEGER,PARAMETER,PRIVATE :: norbit_max=50,nbasis_add_max=25
82 : real(dp),PARAMETER,PRIVATE :: logder_min=-5._dp,logder_max=4.95_dp,logder_pts=200
83 : real(dp),PARAMETER,PRIVATE :: polynom2_pdeg_def=4
84 : real(dp),PARAMETER,PRIVATE :: polynom2_qcut_def=10._dp
85 : real(dp),PARAMETER,PRIVATE :: gausstol_def=tol4
86 : real(dp),PARAMETER,PRIVATE :: hf_coretol_def=tol4
87 : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_BLOECHL = 1
88 : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_VANDERBILT= 2
89 : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_CUSTOM = 3
90 : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_MODRRKJ = 4
91 : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_HF = 5
92 : INTEGER,PARAMETER,PRIVATE :: PROJECTOR_TYPE_MARSMAN = 6
93 : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_BLOECHL = 1
94 : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_POLYNOM = 2
95 : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_POLYNOM2 = 3
96 : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_RRKJ = 4
97 : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_BLOECHL_K = 5
98 : INTEGER,PARAMETER,PRIVATE :: PSEUDO_TYPE_HF = 6
99 : INTEGER,PARAMETER,PRIVATE :: ORTHO_TYPE_GRAMSCHMIDT = 1
100 : INTEGER,PARAMETER,PRIVATE :: ORTHO_TYPE_VANDERBILT = 2
101 : INTEGER,PARAMETER,PRIVATE :: ORTHO_TYPE_SVD = 3
102 : INTEGER,PARAMETER,PRIVATE :: ORTHO_TYPE_HF = 4
103 : INTEGER,PARAMETER,PRIVATE :: SHAPEFUNC_TYPE_GAUSSIAN = 1
104 : INTEGER,PARAMETER,PRIVATE :: SHAPEFUNC_TYPE_SINC = 2
105 : INTEGER,PARAMETER,PRIVATE :: SHAPEFUNC_TYPE_BESSEL = 3
106 : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_MTROULLIER = 1
107 : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_ULTRASOFT = 2
108 : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_BESSEL = 3
109 : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_SETVLOC = 4
110 : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_KERKER_EXPF = 5
111 : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_KERKER_POLY = 6
112 : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_VPSMATCHNC = 7
113 : INTEGER,PARAMETER,PRIVATE :: VLOC_TYPE_VPSMATCHNNC = 8
114 : INTEGER,PARAMETER,PRIVATE :: UNKNOWN_TYPE =-1
115 : ! XC
116 : INTEGER, PRIVATE, PARAMETER :: LDA_PW=14
117 : INTEGER, PRIVATE, PARAMETER :: GGA_PBE=16
118 : INTEGER, PRIVATE, PARAMETER :: GGA_PBESOL=18
119 : INTEGER, PRIVATE, PARAMETER :: MGGA_R2SCAN_001=13001
120 : INTEGER, PRIVATE, PARAMETER :: MGGA_R2SCAN_01=1301
121 : INTEGER, PRIVATE, PARAMETER :: LIBXC=-1
122 : REAL(dp), PRIVATE, PARAMETER :: kappa= 0.804_dp
123 : REAL(dp), PRIVATE, PARAMETER :: muorig = 0.2195149727645171_dp
124 : REAL(dp), PRIVATE, PARAMETER :: betorig = 0.06672455060314922_dp
125 : REAL(dp), PRIVATE, PARAMETER :: gamm = 0.03109069086965489503494086371273_dp
126 : REAL(dp), PRIVATE, PARAMETER :: musol = 0.123456790123456_dp
127 : REAL(dp), PRIVATE, PARAMETER :: betsol = 0.046_dp
128 : REAL(dp), PRIVATE, PARAMETER :: AA=0.0310907_dp
129 : REAL(dp), PRIVATE, PARAMETER :: a1=0.21370_dp
130 : REAL(dp), PRIVATE, PARAMETER :: b1=7.59570_dp
131 : REAL(dp), PRIVATE, PARAMETER :: b2=3.58760_dp
132 : REAL(dp), PRIVATE, PARAMETER :: b3=1.63820_dp
133 : REAL(dp), PRIVATE, PARAMETER :: b4=0.49294_dp
134 : REAL(dp), PRIVATE, PARAMETER :: cx0 = 1._dp
135 : REAL(dp), PRIVATE, PARAMETER :: cx1 = -0.667_dp
136 : REAL(dp), PRIVATE, PARAMETER :: cx2 = -0.4445555_dp
137 : REAL(dp), PRIVATE, PARAMETER :: cx3 = -0.663086601049_dp
138 : REAL(dp), PRIVATE, PARAMETER :: cx4 = 1.451297044490_dp
139 : REAL(dp), PRIVATE, PARAMETER :: cx5 = -0.887998041597_dp
140 : REAL(dp), PRIVATE, PARAMETER :: cx6 = 0.234528941479_dp
141 : REAL(dp), PRIVATE, PARAMETER :: cx7 = -0.023185843322_dp
142 : REAL(dp), PRIVATE, PARAMETER :: SCANc1x = 0.667_dp
143 : REAL(dp), PRIVATE, PARAMETER :: SCANc2x = 0.8_dp
144 : REAL(dp), PRIVATE, PARAMETER :: SCANdx = 1.24_dp
145 : REAL(dp), PRIVATE, PARAMETER :: k0 = 0.174_dp
146 : REAL(dp), PRIVATE, PARAMETER :: k1 = 0.065_dp
147 : REAL(dp), PRIVATE, PARAMETER :: mu = 10._dp/81._dp
148 : REAL(dp), PRIVATE, PARAMETER :: SCANa1 = 4.9479_dp
149 : REAL(dp) :: eta
150 : REAL(dp), PRIVATE, PARAMETER :: dp2 = 0.361_dp
151 : REAL(dp) :: C2Ceta
152 : REAL(dp), PRIVATE, PARAMETER :: cc0 = 1._dp
153 : REAL(dp), PRIVATE, PARAMETER :: cc1 = -0.64_dp
154 : REAL(dp), PRIVATE, PARAMETER :: cc2 = -0.4352_dp
155 : REAL(dp), PRIVATE, PARAMETER :: cc3 = -1.535685604549_dp
156 : REAL(dp), PRIVATE, PARAMETER :: cc4 = 3.061560252175_dp
157 : REAL(dp), PRIVATE, PARAMETER :: cc5 = -1.915710236206_dp
158 : REAL(dp), PRIVATE, PARAMETER :: cc6 = 0.516884468372_dp
159 : REAL(dp), PRIVATE, PARAMETER :: cc7 = -0.051848879792_dp
160 : REAL(dp), PRIVATE, PARAMETER :: SCANc1c = 0.64_dp
161 : REAL(dp), PRIVATE, PARAMETER :: SCANc2c = 1.5_dp
162 : REAL(dp), PRIVATE, PARAMETER :: SCANdc = 0.7_dp
163 : REAL(dp), PRIVATE, PARAMETER :: b1c = 0.0285764_dp
164 : REAL(dp), PRIVATE, PARAMETER :: b2c = 0.0889_dp
165 : REAL(dp), PRIVATE, PARAMETER :: b3c = 0.125541_dp
166 : REAL(dp), PRIVATE, PARAMETER :: betaMB = 0.066725_dp
167 : REAL(dp), PRIVATE, PARAMETER :: chiinfinity = 0.12802585262625815_dp
168 : REAL(dp), PRIVATE, PARAMETER :: Sgam = 0.031090690869655_dp
169 : REAL(dp), PRIVATE, PARAMETER :: Dfc2=cc1+2*cc2+3*cc3+4*cc4+5*cc5+6*cc6+7*cc7
170 : ! Parameters for the Perdew-Wang (PRB 45,13244 (1992)) LDA correlation
171 : REAL(dp), PRIVATE, PARAMETER :: LDAA = 0.03109070_dp
172 : REAL(dp), PRIVATE, PARAMETER :: LDAa1 = 0.21370_dp
173 : REAL(dp), PRIVATE, PARAMETER :: LDAb1 = 7.59570_dp
174 : REAL(dp), PRIVATE, PARAMETER :: LDAb2 = 3.58760_dp
175 : REAL(dp), PRIVATE, PARAMETER :: LDAb3 = 1.63820_dp
176 : REAL(dp), PRIVATE, PARAMETER :: LDAb4 = 0.49294_dp
177 :
178 :
179 :
180 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
181 : ! PRIVATE DATA TYPES IMPORTED FROM ATOMPAW
182 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
183 :
184 :
185 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
186 : !! mesh_data
187 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
188 : type mesh_data_type
189 : integer :: mesh_type ! Default type of meshes (lin. or log.)
190 : integer :: nmesh ! Number of meshes
191 : integer :: iwavmesh ! Index of mesh for partial waves
192 : integer :: iprjmesh ! Index of mesh for projectors
193 : integer :: icoremesh ! Index of mesh for core density
194 : integer :: itaumesh ! Index of mesh for kinetic energy core density
195 : integer :: ivionmesh ! Index of mesh for vion potential
196 : integer :: ivbaremesh ! Index of mesh for vbare potential
197 : integer :: ivlda12mesh ! Index of mesh for LDA-1/2 potential
198 : integer :: ivalemesh ! Index of mesh for valence density
199 : integer :: wav_meshsz ! Size of mesh for partial waves
200 : integer :: sph_meshsz ! Size of mesh for partial waves
201 : integer :: prj_meshsz ! Size of mesh for projectors
202 : integer :: core_meshsz ! Size of mesh for core density
203 : integer :: tau_meshsz ! Size of mesh for kinetic energy core density
204 : integer :: vion_meshsz ! Size of mesh for vion potential
205 : integer :: vbare_meshsz ! Size of mesh for vbare potential
206 : integer :: vlda12_meshsz ! Size of mesh for LDA-1/2 potential
207 : integer :: vale_meshsz ! Size of mesh for valence density
208 : integer :: prj_msz_max ! Maximum size for projector (used for RSO)
209 : real(dp) :: rad_step ! Default value for radial step
210 : real(dp) :: log_step ! Default value for log step
211 : integer,allocatable :: meshtp(:) ! Array storing mesh type for all meshes
212 : integer,allocatable :: meshsz(:) ! Array storing mesh size for all meshes
213 : real(dp),allocatable :: radstp(:) ! Array storing radial step for all meshes
214 : real(dp),allocatable :: logstp(:) ! Array storing log step for all meshes
215 : end type mesh_data_type
216 :
217 :
218 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
219 : !! GridInfo
220 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
221 : type,private :: GridInfo
222 : integer :: type
223 : integer :: n
224 : integer :: ishift
225 : real(dp) :: h,r0,range
226 : real(dp), pointer :: r(:) => null()
227 : real(dp), pointer :: drdu(:) => null() ! for loggrid -- dr/du
228 : real(dp), pointer :: pref(:) => null() ! for loggrid -- r0*exp(u/2)
229 : real(dp), pointer :: rr02(:) => null() ! for loggrid -- (r+r0)**2
230 : end type GridInfo
231 :
232 :
233 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
234 : !! OrbitInfo
235 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
236 : type,private :: OrbitInfo
237 : character(132) :: exctype
238 : integer :: nps, npp, npd ,npf, npg, norbit
239 : integer :: npsc, nppc, npdc ,npfc, npgc
240 : INTEGER, POINTER :: np(:) => null()
241 : INTEGER, POINTER :: l(:) => null()
242 : INTEGER, POINTER :: kappa(:) => null()
243 : real(dp), POINTER :: eig(:) => null()
244 : real(dp), POINTER :: occ(:) => null()
245 : real(dp), POINTER :: wfn(:,:) => null()
246 : real(dp), POINTER :: lwfn(:,:) => null()
247 : real(dp), POINTER :: otau(:,:) => null() ! kinetic energy density for orbital
248 : real(dp), POINTER :: lqp(:,:) => null() ! only used for HF
249 : real(dp), POINTER :: X(:,:) => null() ! identical to HF%SumY(:,:)
250 : LOGICAL, POINTER :: iscore(:) => null()
251 : LOGICAL, POINTER :: issemicore(:) => null()
252 : real(dp),POINTER :: den(:) => null() ! accumulated over states
253 : real(dp),POINTER :: tau(:) => null() ! accumulated over states
254 : real(dp),POINTER :: deltatau(:) => null() !tau-tauW (tauW==Weizsacker)
255 : ! LIBPAW specific
256 : real(dp),POINTER :: coreden(:) => null()
257 : real(dp),POINTER :: valeden(:) => null()
258 : real(dp) :: qval
259 : logical :: frozencorecalculation
260 : logical :: frozenvalecalculation
261 : logical :: diracrelativistic
262 : logical :: scalarrelativistic
263 : end type OrbitInfo
264 :
265 :
266 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
267 : !! PotentialInfo
268 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
269 : type,private :: PotentialInfo
270 : character(2) :: sym
271 : integer :: nz ! nz is nuclear charge
272 : real(dp) :: zz ! zz=nz is nuclear charge
273 : real(dp) :: q,v0,v0p ! q is total electron charge
274 : ! v0,v0p are potential value and deriv at r=0
275 : real(dp) :: Nv0,Nv0p ! finite nucleus value and deriv at 0
276 : real(dp) , pointer :: rv(:) => null()
277 : real(dp) , pointer :: rvn(:) => null()
278 : real(dp) , pointer :: rvh(:) => null()
279 : real(dp) , pointer :: rvx(:) => null()
280 : ! rv(n) is veff * r
281 : ! rvh is hartree potential for den
282 : ! rvn is nuclear potential
283 : ! rvx is exchange-correlation potential
284 : real(dp) , pointer :: vtau(:) => null() !for meta-gga
285 : integer :: finitenucleusmodel
286 : ! Based on models 2, 3, 4, 5 discussed by Dirk Anrae ,
287 : ! Physics Reports 336 (2000) 413-525
288 : ! default is 0 for previous Gaussian model
289 : ! for finitenucleusmodel<0, finite nucleus is false
290 : ! LIBPAW specific
291 : logical :: finitenucleus
292 : logical :: needvtau
293 : real(dp),allocatable :: ww(:)
294 : real(dp), allocatable :: jj(:)
295 : end type PotentialInfo
296 :
297 :
298 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
299 : !! SCFInfo
300 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
301 : type,private :: SCFInfo
302 : integer :: iter
303 : real(dp) :: delta,eone,ekin,estatic,ecoul,eexc,oepcs,etot
304 : real(dp) :: valekin,valecoul,valeexc,corekin,evale ! used in frozencore only
305 : end type SCFInfo
306 :
307 :
308 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
309 : !! Anderson_Context
310 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
311 : TYPE,private :: Anderson_Context !** Anderson Mixing context
312 : real(dp) :: NewMix !** Amount of new vectors to mix, ie beta in paper.
313 : INTEGER :: Nmax !** Max number of vectors to keep
314 : INTEGER :: N !** Current number of vectors in list
315 : INTEGER :: Slot !** New fill Slot
316 : INTEGER :: VecSize !** Size of each vector
317 : INTEGER :: Err_Unit !** Error unit
318 : INTEGER :: MaxIter !** MaxIter
319 : INTEGER :: CurIter !** Running iteration index
320 : real(dp) :: err !** residue convergence tolerance
321 : real(dp) :: toosmall !** solution obviously converged
322 : real(dp) :: res !** Running convergence error
323 : Logical :: writelots
324 : real(dp), POINTER :: Matrix(:,:)
325 : real(dp), POINTER :: Gamma(:) !** Gamma as defined in 7.6
326 : real(dp), POINTER :: DF(:,:) !** Delta F
327 : real(dp), POINTER :: Fprev(:)
328 : real(dp), POINTER :: DX(:,:)
329 : real(dp), POINTER :: Xprev(:)
330 : ! temporary constants and arrays needed for each call to Anderson_Mix
331 : INTEGER, POINTER :: IPIV(:)
332 : real(dp), POINTER :: S(:)
333 : real(dp), POINTER :: RWork(:)
334 : real(dp), POINTER :: U(:,:)
335 : real(dp), POINTER :: VT(:,:)
336 : real(dp), POINTER :: Work(:)
337 : real(dp), POINTER :: DupMatrix(:,:)
338 : INTEGER :: Lwork
339 : INTEGER :: LRwork
340 : real(dp) :: ConditionNo
341 : real(dp) :: MachAccur
342 : END TYPE Anderson_Context
343 :
344 :
345 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
346 : !! PseudoInfo
347 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
348 : TYPE,private :: Pseudoinfo
349 : CHARACTER(132) :: exctype
350 : INTEGER :: lmax,irc,irc_shap,irc_vloc,irc_core,coretailpoints,mesh_size
351 : INTEGER :: ivale,itau,ivion,mxbase
352 : CHARACTER(15) :: orthogonalization_scheme
353 : CHARACTER(132) :: Vloc_description
354 : CHARACTER(132) :: Proj_description
355 : CHARACTER(132) :: Comp_description
356 : LOGICAL :: multi_rc,poscorenhat
357 : real(dp) :: rc,rc_shap,rc_vloc,rc_core,energyoflmax,gausslength
358 : real(dp), POINTER :: rcio(:) => null()
359 : real(dp), POINTER :: vloc(:) => null()
360 : real(dp), POINTER :: abinitvloc(:) => null()
361 : real(dp), POINTER :: abinitnohat(:) => null()
362 : real(dp), POINTER :: rveff(:) => null()
363 : real(dp), POINTER :: AErefrv(:) => null()
364 : real(dp), POINTER :: rvx(:) => null()
365 : real(dp), POINTER :: trvx(:) => null()
366 : real(dp), POINTER :: Ktvtau(:) => null()
367 : real(dp), POINTER :: Krveff(:) => null()
368 : real(dp), POINTER :: Kunscreen(:) => null() ! Kresse form
369 : real(dp), POINTER :: projshape(:) => null()
370 : real(dp), POINTER :: hatshape(:) => null()
371 : real(dp), POINTER :: hatden(:) => null()
372 : real(dp), POINTER :: hatpot(:) => null()
373 : real(dp), POINTER :: den(:) => null()
374 : real(dp), POINTER :: tden(:) => null()
375 : real(dp), POINTER :: core(:) => null()
376 : real(dp), POINTER :: tcore(:) => null()
377 : real(dp), POINTER :: nhatv(:) => null()
378 : real(dp), POINTER :: coretau(:) => null()
379 : real(dp), POINTER :: tcoretau(:) => null()
380 : real(dp), POINTER :: valetau(:) => null()
381 : real(dp), POINTER :: tvaletau(:) => null()
382 : real(dp), POINTER :: vtau(:) => null()
383 : real(dp), POINTER :: tvtau(:) => null()
384 : INTEGER :: nbase,ncoreshell
385 : INTEGER, POINTER :: np(:) => null()
386 : INTEGER, POINTER :: l(:) => null()
387 : INTEGER, POINTER :: nodes(:) => null()
388 : INTEGER, POINTER :: kappa(:) => null()
389 : INTEGER, POINTER :: rng(:) => null() ! rng particularly of continuum states
390 : CHARACTER(8), POINTER :: label(:) => null()
391 : real(dp), POINTER :: phi(:,:) => null()
392 : real(dp), POINTER :: tphi(:,:) => null()
393 : real(dp), POINTER :: tp(:,:) => null() ! before orthog
394 : real(dp), POINTER :: ophi(:,:) => null()
395 : real(dp), POINTER :: otphi(:,:) => null()
396 : real(dp), POINTER :: otp(:,:) => null() ! after orthog
397 : real(dp), POINTER :: Kop(:,:) => null() ! for storing K|phi>
398 : real(dp), POINTER :: eig(:) => null()
399 : real(dp), POINTER :: occ(:) => null()
400 : real(dp), POINTER :: ck(:) => null()
401 : real(dp), POINTER :: vrc(:) => null()
402 : real(dp), POINTER :: oij(:,:) => null()
403 : real(dp), POINTER :: dij(:,:) => null()
404 : real(dp), POINTER :: wij(:,:) => null()
405 : !********** modified parameters for use with KS and HF
406 : real(dp), POINTER :: rVf(:) => null()
407 : real(dp), POINTER :: rtVf(:) => null()
408 : real(dp), POINTER :: g(:,:) => null()
409 : real(dp), POINTER :: Kij(:,:) => null()
410 : real(dp), POINTER :: Vfij(:,:) => null()
411 : real(dp), POINTER :: mLij(:,:,:) => null()
412 : real(dp), POINTER :: DR(:,:,:,:,:) => null()
413 : real(dp), POINTER :: DRVC(:,:,:) => null()
414 : real(dp), POINTER :: TXVC(:,:) => null() ! now output for DFT also
415 : real(dp) :: lambshielding
416 : real(dp) :: XCORECORE ! output for DFT
417 : INTEGER, POINTER :: valencemap(:) => null() ! valencemap({occ. states})={basis}
418 : Type(OrbitInfo), POINTER :: OCCwfn => null()
419 : Type(OrbitInfo), POINTER :: TOCCwfn => null()
420 : real(dp) :: tkin,tion,tvale,txc,Ea,Etotal,Eaion,Eaionhat,Eaxc
421 : real(dp) :: VlocCoef,VlocRad
422 : !***********for HF only
423 : real(dp), POINTER :: lmbd(:,:) => null() !(Eq. 72) lmbd({occ. states},{basis states})
424 : real(dp), POINTER :: DRC(:,:,:,:) => null()
425 : real(dp), POINTER :: mLic(:,:,:) => null()
426 : real(dp), POINTER :: DRCC(:,:,:,:) => null()
427 : real(dp), POINTER :: DRCjkl(:,:,:,:,:) => null()
428 : real(dp), POINTER :: mLcc(:,:,:) => null()
429 : real(dp), POINTER :: Dcj(:,:) => null()
430 : real(dp) :: coretol
431 : END TYPE Pseudoinfo
432 :
433 :
434 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
435 : !! PseudoInfo
436 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
437 : TYPE,private :: splinesolvinfo
438 : INTEGER :: ns ! # spline nodes, not including origin
439 : REAL(dp) :: r0,h
440 : real(dp),allocatable :: u(:)
441 : real(dp),allocatable :: pref(:)
442 : real(dp),allocatable :: rr1(:)
443 : real(dp),allocatable :: rr2(:)
444 : real(dp),allocatable :: srv(:)
445 : real(dp),allocatable :: svtau(:)
446 : real(dp),allocatable :: sdvt(:)
447 : real(dp),allocatable :: soneplusvt(:)
448 : real(dp),allocatable :: fvtau(:)
449 : real(dp),allocatable :: fdvtaudr(:)
450 : real(dp),allocatable :: frvx(:)
451 : real(dp),allocatable :: fden(:)
452 : real(dp),allocatable :: ftau(:)
453 : type(GridInfo) :: Grids
454 : type(GridInfo) :: Gridf
455 : END TYPE splinesolvinfo
456 :
457 :
458 :
459 :
460 :
461 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
462 : ! PUBLIC DATATYPES
463 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
464 :
465 :
466 : !----------------------------------------------------------------------
467 : !!***
468 : !!****t* m_paw_atom_solve/atompaw_type
469 : !! NAME
470 : !! atompaw_type
471 : !!
472 : !! FUNCTION
473 : !! Stores data in atompaw format, including:
474 : !! -Input that was used to create the original PAW potentials
475 : !! -Current spherical average of the valence band electron density
476 : !! -Previous core charge density to be used as starting point
477 : !! -All data needed for solving the atomic problem
478 : !! -All data needed for pseudoization
479 : !!
480 : !! COPYRIGHT
481 : !! This module is
482 : !!
483 : !! SOURCE
484 : type,public :: atompaw_type
485 : !!! Initialized in read input roughly in this order
486 : ! Atom
487 : CHARACTER(2) :: atomic_symbol ! Atomic symbol
488 : INTEGER :: atomic_charge
489 : ! Algo
490 : logical :: scalarrelativistic
491 : logical :: diracrelativistic
492 : logical :: usespline
493 : INTEGER :: splns=400 ! Spline interpolation grid length
494 : real(dp) :: splr0=0.1_dp ! Spline interpolation r0 value
495 : logical :: BDsolve
496 : logical :: HFpostprocess
497 : logical :: finitenucleus
498 : integer :: finitenucleusmodel
499 : ! Grid
500 : CHARACTER(10) :: gridkey
501 : INTEGER :: gridpoints ! Number of points of the radial grid
502 : real(dp) :: gridrange ! Range of the radial grid
503 : real(dp) :: gridmatch ! A matching radius in the radial grid
504 : real(dp) :: minlogderiv
505 : real(dp) :: maxlogderiv
506 : integer :: nlogderiv
507 : ! XC
508 : CHARACTER(132) :: exctype ! Exchange-correlation type (string)
509 : real(dp) :: temp ! temeprature
510 : LOGICAL :: needvtau ! TRUE if Calculation is performed with full kinetic energy functional
511 : logical :: localizedcoreexchange
512 : LOGICAL :: fixed_zero ! Flag activating the "fixed zero" exact exchange potential calculation
513 : INTEGER :: fixed_zero_index ! Option for "fixed zero" calculation in the exact exchange potential
514 : type(libxc_functional_type) :: xc_functionals(2)
515 : ! Electronic config
516 : INTEGER :: np(5) ! Electronic configuration: number of s,p,d,f,g shells
517 : INTEGER :: norbit ! Electronic configuration: number of orbitals
518 : INTEGER :: norbit_mod ! Electronic configuration: number of orbitals with modified occupations
519 : INTEGER,ALLOCATABLE :: orbit_mod_n(:) ! Electronic config.: n number of the modified orbital
520 : INTEGER,ALLOCATABLE :: orbit_mod_l(:) ! Electronic config.: l number of the modified orbital
521 : INTEGER,ALLOCATABLE :: orbit_mod_k(:) ! Electronic config.: kappa number of the modified orbital
522 : real(dp),ALLOCATABLE :: orbit_mod_occ(:) ! Electronic config.: occupation of the modified orbital
523 : LOGICAL,ALLOCATABLE :: orbit_iscore(:) ! Electronic configuration: TRUE for the core orbitals
524 : INTEGER :: norbit_val ! Electronic configuration: number of valence orbitals
525 : INTEGER,ALLOCATABLE :: orbit_val_n(:) ! Electronic config.: n number of the valence orbital
526 : INTEGER,ALLOCATABLE :: orbit_val_l(:) ! Electronic config.: l number of the valence orbital
527 : INTEGER,ALLOCATABLE :: orbit_val_k(:) ! Electronic config.: kappa number of the valence orbital
528 : INTEGER :: lmax=-1 ! PAW Basis: maximum l value
529 : ! Cutoff radii
530 : real(dp) :: rc=0._dp ! PAW basis: cut-off radius for the augmentation regions
531 : real(dp) :: rc_shap=0._dp ! PAW basis: cut-off radius of the compensation charge shape function
532 : real(dp) :: rc_vloc=0._dp ! PAW basis: matching radius for the local potential
533 : real(dp) :: rc_core=0._dp ! PAW basis: matching radius for the pseudo-core density
534 : ! Additional basis functions
535 : INTEGER :: nbasis ! PAW basis : number of basis functions
536 : INTEGER :: nbasis_add ! PAW basis: number of additional basis functions (unbound states)
537 : INTEGER,ALLOCATABLE :: basis_add_l(:) ! PAW basis: l number for the additional basis func.
538 : INTEGER,ALLOCATABLE :: basis_add_k(:) ! PAW basis: kappa number for the additional basis func.
539 : real(dp),ALLOCATABLE :: basis_add_energy(:) ! PAW basis: ref. energy for the additional basis func.
540 : real(dp),ALLOCATABLE :: basis_func_rc(:) ! PAW basis: rcut for the additional basis func.
541 : ! Projectors
542 : INTEGER :: projector_type ! Type of projectors (Bloechl, Vanderbilt,...)
543 : INTEGER :: pseudo_type ! Type of pseudization scheme (Bessel,polynom, ...)
544 : INTEGER :: ortho_type ! Type of orthogonalization scheme(Gram-Schmidt, ...)
545 : INTEGER :: pseudo_polynom2_pdeg ! Polynom2 projectors: degree of the polynom
546 : real(dp) :: pseudo_polynom2_qcut ! Polynom2 projectors: q-value for Fourier filtering
547 : INTEGER :: shapefunc_type ! Compensation shape function type (sinc2, gaussian, ...)
548 : real(dp) :: shapefunc_gaussian_param ! Compensation shape function: parameter for gaussian type
549 : real(dp) :: hf_coretol ! Tolerance for core density (Hartree-Fock only)
550 : LOGICAL :: shapetcore ! Flag activating building of tcore cancelling a negative compensation charge
551 : ! Local Psp
552 : INTEGER :: vloc_type ! Type of local potential pseudization
553 : INTEGER :: vloc_l ! Local potential: l quantum number (MTrouillier, Ultrasoft)
554 : real(dp) :: vloc_ene ! Local potential: reference energy (MTrouillier, Ultrasoft)
555 : real(dp) :: vloc_setvloc_coef ! "SetVloc" local potential: coefficient
556 : real(dp) :: vloc_setvloc_rad ! "SetVloc" local potential: radius
557 : INTEGER :: vloc_kerker_power(4) ! "Kerker" locazl potential: polynomial powers
558 : ! LIBPAW specific
559 : logical :: frozencorecalculation
560 : logical :: frozenvalecalculation
561 : logical :: setupfrozencore
562 : logical :: gaussianshapefunction
563 : logical :: besselshapefunction
564 : logical :: ColleSalvetti
565 : integer :: itype
566 : integer :: ixc
567 : integer :: xclevel
568 : integer :: npsc,nppc,npdc,npfc,npgc
569 : integer :: vhtnzc_mode, tpaw_mode, elin_mode
570 : real(dp) :: electrons
571 : real(dp) :: pot_ref
572 : real(dp), allocatable :: pot_refo(:)
573 : type(GridInfo) :: Grid
574 : TYPE(OrbitInfo) :: Orbit
575 : TYPE(PotentialInfo) :: Pot
576 : TYPE(SCFInfo) :: SCF
577 : TYPE(Pseudoinfo) :: PAW
578 : type(splinesolvinfo) :: spline
579 : character*(10000) :: input_string
580 : logical :: prtpaw
581 : end type atompaw_type
582 : !!***
583 :
584 :
585 :
586 :
587 :
588 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
589 : ! PUBLIC SUBROUTINES
590 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
591 :
592 :
593 : !!***
594 : public :: atompaw_solve ! Solve the atomic problem at fixed valence
595 : public :: atompaw_init ! Init the atompaw solver
596 : public :: atompaw_destroy ! Destroy the atomic solver
597 : !!***
598 :
599 :
600 : CONTAINS !===========================================================
601 : !!***
602 :
603 :
604 : !!****f* m_paw_atom_solve/atompaw_solve
605 : !! NAME
606 : !! atompaw_solve
607 : !!
608 : !! FUNCTION
609 : !! Solve the atomic problem (at fixed valence) and update relevant quantities
610 : !!
611 : !! OUTPUT
612 : !!
613 : !! SIDE EFFECTS
614 : !!
615 : !! NOTES
616 : !!
617 : !! SOURCE
618 : !! Inspired from atompaw program
619 :
620 19 : subroutine atompaw_solve(atp,pawrad,pawtab,&
621 19 : & nval,tnval,mqgrid_vl,qgrid_vl,epsatm,vlspl,&
622 : & zion,update_paw,update_tnc,atm)
623 :
624 : ! TODO : vtau,dirac
625 : implicit none
626 :
627 : !Arguments ------------------------------------
628 : !scalars
629 : integer, intent(in) :: mqgrid_vl
630 : logical,intent(in) :: update_paw,update_tnc
631 : real(dp), intent(inout) :: epsatm
632 : real(dp), intent(inout) :: zion
633 : type(atompaw_type), intent(inout) :: atp
634 : type(pawrad_type),intent(in) :: pawrad
635 : type(pawtab_type),intent(inout) :: pawtab
636 : type(atomorb_type), intent(inout) :: atm
637 : !arrays
638 : real(dp), intent(in) :: nval(:),tnval(:)
639 : real(dp), intent(in) :: qgrid_vl(mqgrid_vl)
640 : real(dp),intent(out) :: vlspl(mqgrid_vl,2)
641 : !Local variables-------------------------------
642 : !scalars
643 : character*(132) :: file_xml
644 : integer :: io,ir,icor,io2,irc_max,vlocopt,irc
645 : logical :: success,paw_proj
646 : character(len=500) :: msg
647 : real(dp) :: insph,norm,potshift,ovl,f1,fp1,dx,c4,c2
648 : real(dp) :: yp1,ypn,ekin,delta_zcore,int_pot
649 19 : type(mesh_data_type) :: mesh_data
650 : !arrays
651 19 : real(dp),ALLOCATABLE:: coredens(:),tcoredens(:),vhnzc_tmp(:)
652 19 : real(dp),ALLOCATABLE:: ff(:)
653 19 : type(pawrad_type) :: radmesh,vloc_mesh
654 19 : real(dp) , allocatable :: nhatc(:),vhatc(:)
655 :
656 : ! *************************************************************************
657 :
658 : ! Put valence density and core occupations to atompaw objects
659 57 : LIBPAW_ALLOCATE(coredens,(size(atp%Orbit%coreden)))
660 38038 : atp%Orbit%valeden=zero
661 38038 : atp%PAW%den=zero
662 38038 : atp%PAW%tden=zero
663 26913 : do io=1,pawtab%mesh_size
664 26894 : atp%PAW%den(io)=nval(io)
665 26894 : atp%Orbit%valeden(io)=nval(io)
666 26913 : atp%PAW%tden(io)=tnval(io)
667 : enddo
668 38038 : if(any(atp%PAW%tden<zero)) then
669 0 : write(std_out,*) 'atompaw_solve : tden is negative for some r ! Smoothening den instead'
670 0 : call smoothpower(atp%Grid,2,atp%PAW%den,atp%PAW%tden,atp%PAW)
671 : endif
672 38038 : atp%Orbit%den=atp%Orbit%valeden+atp%Orbit%coreden
673 38057 : coredens=atp%Orbit%coreden
674 19 : delta_zcore=zero
675 19 : icor=0
676 131 : do io=1,atp%Orbit%norbit
677 131 : if(atp%Orbit%iscore(io)) then
678 58 : icor=icor+1
679 58 : delta_zcore=delta_zcore-atp%Orbit%occ(io)
680 58 : atp%Orbit%occ(io)=atm%occ(icor,1)
681 58 : delta_zcore=delta_zcore+atp%Orbit%occ(io)
682 : endif
683 : enddo
684 :
685 : ! ! Solve atomic problem
686 19 : if(.not.atm%nc_conv) then
687 19 : call SCFatom(atp,.false.)
688 : endif
689 :
690 : ! update core wfs and eigen energies
691 19 : icor=0
692 131 : do io=1,atp%Orbit%norbit
693 131 : if(atp%Orbit%iscore(io)) then
694 58 : icor=icor+1
695 58 : if(.not.atm%nc_conv) then
696 116 : atm%eig(icor,:)=atp%Orbit%eig(io)*half
697 : endif
698 82170 : do ir=1,pawtab%mesh_size
699 82170 : atm%phi(ir,icor,1)=atp%Orbit%wfn(ir,io)
700 : enddo
701 : endif
702 : enddo
703 :
704 19 : if(.not.atp%diracrelativistic) then
705 18 : call pawrad_init(radmesh,atp%Grid%n,pawrad%mesh_type,pawrad%rstep,pawrad%lstep)
706 54 : LIBPAW_ALLOCATE(ff,(atp%grid%n))
707 : ! Compute new core density
708 18 : write(msg,'(a)') 'atompaw_solve: orbital,%out sphere'
709 18 : call wrtout(std_out,msg,'COLL')
710 36036 : atp%Orbit%coreden=zero
711 18 : icor=0
712 120 : do io=1,atp%Orbit%norbit
713 120 : if(atp%Orbit%iscore(io)) then
714 54 : icor=icor+1
715 54 : norm=overlap(atp%Grid,atp%Orbit%wfn(1:atp%Grid%n,io),atp%Orbit%wfn(1:atp%Grid%n,io),1,atp%Grid%n)
716 54 : insph=overlap(atp%Grid,atp%Orbit%wfn(1:atp%PAW%irc,io),atp%Orbit%wfn(1:atp%PAW%irc,io),1,atp%PAW%irc)
717 54 : write(msg,*)io,(one -insph/norm)*100.0_dp
718 54 : call wrtout(std_out,msg,'COLL')
719 108108 : atp%Orbit%coreden=atp%Orbit%coreden+atp%Orbit%occ(io)*(atp%Orbit%wfn(:,io))**2
720 : endif
721 : enddo
722 :
723 : ! Compute residue
724 18 : if(.not.atm%nc_conv) then
725 36036 : ff(1:atp%Grid%n)=(atp%Orbit%coreden(1:atp%Grid%n)-coredens(1:atp%Grid%n))**2
726 18 : atm%nresid_c=sqrt(integrator(atp%Grid,ff)/atp%grid%r(atp%grid%n))
727 36036 : ff(1:atp%Grid%n)=atp%Orbit%coreden(1:atp%Grid%n)
728 18 : if(integrator(atp%Grid,ff)/=zero) then
729 18 : atm%nresid_c=atm%nresid_c/integrator(atp%Grid,ff)
730 : else
731 0 : atm%nresid_c=one
732 : endif
733 18 : write(msg,*) 'atompaw_solve: nc residue',atm%nresid_c
734 18 : call wrtout(std_out,msg,'COLL')
735 : endif
736 :
737 : ! Update core dens
738 36018 : do ir=2,atp%Grid%n
739 36018 : coredens(ir)=atp%Orbit%coreden(ir)/(four*pi*atp%Grid%r(ir)**2)
740 : enddo
741 18 : call extrapolate(coredens)
742 25482 : do ir=1,size(pawtab%coredens)
743 25482 : pawtab%coredens(ir)=coredens(ir)
744 : enddo
745 :
746 : ! Update vhnzc
747 54 : LIBPAW_ALLOCATE(vhnzc_tmp,(radmesh%mesh_size))
748 36036 : vhnzc_tmp=zero
749 18 : call atompaw_vhnzc(coredens,radmesh,vhnzc_tmp,atm%znucl)
750 25482 : do ir=1,size(pawtab%vhnzc)
751 25482 : pawtab%vhnzc(ir)=vhnzc_tmp(ir)
752 : enddo
753 18 : LIBPAW_DEALLOCATE(vhnzc_tmp)
754 :
755 : ! Update edcc
756 36036 : ff=zero
757 36018 : ff(2:atp%Grid%n)=atp%Pot%rv(2:atp%Grid%n)*coredens(2:atp%Grid%n)*atp%Grid%r(2:atp%Grid%n)*four_pi
758 18 : CALL extrapolate(ff)
759 18 : atm%edcc=integrator(atp%Grid,ff)/two
760 18 : LIBPAW_DEALLOCATE(ff)
761 :
762 : ! Update ehnzc
763 18 : call atompaw_ehnzc(coredens,radmesh,atm%ehnzc,atm%znucl)
764 :
765 : ! update core kinetic energy
766 18 : atm%ekinc=zero
767 18 : atm%eeigc=zero
768 18 : icor=0
769 120 : do io=1,atp%Orbit%norbit
770 120 : if(atp%Orbit%iscore(io)) then
771 54 : icor=icor+1
772 54 : CALL altkinetic(atp%Grid,atp%Orbit%wfn(:,io),atp%Orbit%eig(io),atp%Pot%rv,ekin)
773 54 : atm%ekinc=atm%ekinc+ekin/two*atp%Orbit%occ(io)
774 54 : atm%eeigc=atm%eeigc+atp%Orbit%eig(io)*half*atp%Orbit%occ(io)
775 : endif
776 : enddo
777 :
778 : ! Update tnc
779 18 : if(update_tnc) then
780 : ! Compute new tnc
781 18 : call setcoretail(atp%Grid,atp%Orbit%coreden,atp%PAW,atp%needvtau)
782 54 : LIBPAW_ALLOCATE(tcoredens,(atp%Grid%n))
783 36018 : do ir=2,atp%Grid%n
784 36018 : tcoredens(ir)=atp%PAW%tcore(ir)/(four*pi*atp%Grid%r(ir)**2)
785 : enddo
786 18 : call extrapolate(tcoredens)
787 : ! Update tnc
788 25482 : do ir=1,pawtab%mesh_size
789 25482 : pawtab%tcoredens(ir,1)=tcoredens(ir)
790 : enddo
791 18 : call pawpsp_cg(pawtab%dncdq0,pawtab%d2ncdq0,mqgrid_vl,qgrid_vl,pawtab%tcorespl(:,1),radmesh,tcoredens,yp1,ypn)
792 18 : call paw_spline(qgrid_vl,pawtab%tcorespl(:,1),mqgrid_vl,yp1,ypn,pawtab%tcorespl(:,2))
793 18 : LIBPAW_DEALLOCATE(tcoredens)
794 : endif
795 :
796 : ! Update PAW stuff
797 18 : if(update_paw.or.atp%vhtnzc_mode==2) then
798 : ! Compute potential shift
799 2 : if(atp%elin_mode==1) then
800 2839 : call simp_gen(int_pot,atp%Pot%rv(1:pawtab%mesh_size)*pawrad%rad(1:pawtab%mesh_size)*pawtab%shapefunc(1:pawtab%mesh_size,1),pawrad)
801 2 : potshift=int_pot-atp%pot_ref
802 : else
803 0 : LIBPAW_ERROR('NOT ready yet')
804 : endif
805 4004 : do io=1,atp%Grid%n
806 4002 : atp%Pot%rvh(io)=atp%Pot%rvh(io)-potshift*atp%Grid%r(io)
807 4004 : atp%Pot%rv(io)=atp%Pot%rv(io)-potshift*atp%Grid%r(io)
808 : enddo
809 2 : atp%Pot%v0=atp%Pot%v0-potshift
810 2 : call setbasis(atp%Grid,atp%Pot,atp%Orbit,atp%PAW,atp,potshift)
811 2 : call SetPAWOptions2(atp,success)
812 : ! Update PAW transform
813 2 : if(update_paw) then
814 2 : if(atp%tpaw_mode>1) then
815 0 : if(atp%scalarrelativistic.or.atp%diracrelativistic) then
816 0 : LIBPAW_ERROR('tpaw>1 not compatible with relativstic calculation.')
817 : endif
818 0 : LIBPAW_ALLOCATE(ff,(atp%PAW%irc))
819 0 : do io=1,pawtab%basis_size
820 0 : paw_proj=.true.
821 0 : do io2=1,atp%Orbit%norbit
822 0 : if(atp%PAW%valencemap(io2)==io) then
823 0 : if(atp%orbit%issemicore(io2).and.atp%tpaw_mode==2) then
824 0 : paw_proj=.false.
825 : endif
826 : endif
827 : enddo
828 0 : if(paw_proj) then
829 0 : atp%PAW%ophi(:,io)=zero
830 0 : atp%PAW%otphi(:,io)=zero
831 0 : do ir=1,pawtab%mesh_size
832 0 : atp%PAW%ophi(ir,io)=pawtab%phi(ir,io)
833 0 : atp%PAW%otphi(ir,io)=pawtab%tphi(ir,io)
834 : enddo
835 0 : do io2=1,atp%Orbit%norbit
836 0 : if(atp%Orbit%iscore(io2).and.atp%orbit%l(io2)==atp%PAW%l(io)) then
837 0 : irc_max=atp%PAW%irc-5
838 0 : ff=zero
839 0 : ff(1:irc_max)=atp%orbit%wfn(1:irc_max,io2)
840 0 : f1=atp%orbit%wfn(irc_max,io2)
841 0 : fp1=Gfirstderiv(atp%Grid,irc_max,atp%orbit%wfn(:,io2))
842 0 : dx=-(atp%grid%r(atp%PAW%irc)-atp%grid%r(irc_max))
843 0 : c4=(-two*dx*f1+dx**2*fp1)/(two*dx**5)
844 0 : c2=(four*dx**3*f1-dx**4*fp1)/(two*dx**5)
845 0 : do ir=irc_max+1,atp%PAW%irc
846 : ff(ir)=c4*(atp%grid%r(ir)-atp%grid%r(atp%PAW%irc))**4+c2*(atp%grid%r(ir)-&
847 0 : & atp%grid%r(atp%PAW%irc))**2
848 : enddo
849 0 : ovl=overlap(atp%grid,atp%PAW%ophi(1:atp%PAW%irc,io),ff(1:atp%PAW%irc),1,atp%PAW%irc)
850 : atp%PAW%ophi(1:atp%PAW%irc,io)=atp%PAW%ophi(1:atp%PAW%irc,io)-&
851 0 : & ovl*ff(1:atp%PAW%irc)
852 : endif
853 : enddo
854 : endif
855 : enddo
856 0 : LIBPAW_DEALLOCATE(ff)
857 : endif
858 20 : do io=1,pawtab%basis_size
859 25484 : do ir=1,pawtab%mesh_size
860 25464 : pawtab%phi(ir,io)=atp%PAW%ophi(ir,io)
861 25482 : pawtab%tphi(ir,io)=atp%PAW%otphi(ir,io)
862 : enddo
863 : enddo
864 : ! Update Kij
865 2 : if(.not.allocated(pawtab%kij)) then
866 0 : LIBPAW_ALLOCATE(pawtab%kij,(pawtab%lmn2_size))
867 : endif
868 : call calc_kij(atp%PAW,atp%Grid,pawtab%kij,pawtab,&
869 2 : & atp%scalarrelativistic,atp%needvtau)
870 : endif
871 : endif
872 :
873 : ! Update vhtnzc, zion and epsatm
874 18 : if(abs(delta_zcore)<tol15*atm%zcore) atm%zcore_conv=.true.
875 18 : if(.not.atm%zcore_conv) then
876 6 : zion=atm%znucl-atm%zcore
877 6 : delta_zcore=atm%zcore-atm%zcore_orig
878 6 : write(msg,*) 'atompaw_solve: delta_zcore',delta_zcore
879 6 : call wrtout(std_out,msg,'COLL')
880 : call pawrad_init(vloc_mesh,mesh_size=size(pawtab%vhtnzc),mesh_type=pawrad%mesh_type,&
881 6 : & rstep=pawrad%rstep,lstep=pawrad%lstep)
882 6 : if(atp%vhtnzc_mode==2) then
883 0 : LIBPAW_ERROR('Vhtnzc_mode>1 is work in progress')
884 0 : call FindVlocfromVeff(atp%Grid,atp%PAW,atp,potshift)
885 0 : if(pawtab%usexcnhat==1) then
886 0 : pawtab%vhtnzc(1:size(pawtab%vhtnzc))=half*atp%PAW%abinitvloc(1:size(pawtab%vhtnzc))
887 : else
888 0 : pawtab%vhtnzc(1:size(pawtab%vhtnzc))=half*atp%PAW%abinitnohat(1:size(pawtab%vhtnzc))
889 : endif
890 6 : elseif(atp%vhtnzc_mode==1) then
891 : ! Compute nhatc=shapefunction*delta_zcore
892 18 : LIBPAW_ALLOCATE(nhatc,(size(pawtab%vhtnzc)))
893 12012 : nhatc=zero
894 8448 : do ir=1,size(pawtab%shapefunc(:,1))
895 8448 : nhatc(ir)=delta_zcore*pawtab%shapefunc(ir,1)*vloc_mesh%rad(ir)**2
896 : enddo
897 12 : LIBPAW_ALLOCATE(vhatc,(size(pawtab%vhtnzc)))
898 6 : call poisson(nhatc,0,vloc_mesh,vhatc)
899 12006 : do ir=2,vloc_mesh%mesh_size
900 12006 : vhatc(ir)=vhatc(ir)/vloc_mesh%rad(ir)
901 : enddo
902 6 : call pawrad_deducer0(vhatc,vloc_mesh%mesh_size,vloc_mesh)
903 6 : LIBPAW_DEALLOCATE(nhatc)
904 : ! Add it to original vhtnzc
905 12018 : pawtab%vhtnzc=atm%vhtnzc_orig+vhatc
906 6 : LIBPAW_DEALLOCATE(vhatc)
907 : endif
908 : call pawpsp_lo(epsatm,mqgrid_vl,qgrid_vl,vlspl(:,1),&
909 : & vloc_mesh,pawtab%vhtnzc,yp1,ypn,&
910 6 : & zion)
911 6 : call paw_spline(qgrid_vl,vlspl(:,1),mqgrid_vl,yp1,ypn,vlspl(:,2))
912 6 : write(msg,*) 'atompaw_solve: nc epsatm',epsatm
913 6 : call wrtout(std_out,msg,'COLL')
914 6 : call pawrad_free(vloc_mesh)
915 : endif
916 :
917 : ! update dij0
918 : call atompaw_dij0(pawtab%indlmn,pawtab%kij,pawtab%lmn_size,coredens,0,pawtab,pawrad,radmesh,&
919 18 : & pawrad,pawtab%vhtnzc,atp%Pot%zz)
920 :
921 : ! Write the new paw data
922 18 : if(update_paw.and.atp%prtpaw.and..not.atp%diracrelativistic) then
923 : if (pawtab%usexcnhat==1) then
924 : vlocopt=1
925 : else
926 : vlocopt=2
927 : end if
928 0 : atp%Orbit%coreden=zero
929 0 : atp%SCF%corekin=zero
930 0 : icor=0
931 0 : do io=1,atp%Orbit%norbit
932 0 : if(atp%Orbit%iscore(io)) then
933 0 : icor=icor+1
934 0 : atp%Orbit%occ(io)=atm%max_occ(icor,1)
935 0 : atp%Orbit%coreden=atp%Orbit%coreden+atp%Orbit%occ(io)*(atp%Orbit%wfn(:,io))**2
936 0 : CALL altkinetic(atp%Grid,atp%Orbit%wfn(:,io),atp%Orbit%eig(io),atp%Pot%rv,ekin)
937 0 : atp%SCF%corekin=atp%SCF%corekin+ekin*atp%Orbit%occ(io)
938 : endif
939 : enddo
940 0 : atp%PAW%abinitnohat(1:size(pawtab%vhtnzc))=atm%vhtnzc_orig(1:size(pawtab%vhtnzc))*two
941 0 : do io=1,pawtab%basis_size
942 0 : irc=FindGridIndex(atp%Grid,atp%basis_func_rc(io))
943 0 : irc=min(atp%PAW%irc,irc)
944 0 : atp%PAW%rcio(io)=atp%grid%r(irc)
945 : enddo
946 0 : call build_mesh_data(mesh_data,atp%Grid,atp%PAW%irc,0,0,0,0)
947 0 : file_xml=trim(atp%pot%sym)//'-rcpaw.xml'
948 : call xmloutput(trim(file_xml),atp%Grid,atp%SCF,atp%Pot,atp%Orbit,atp%PAW,mesh_data,&
949 0 : & atp%PAW%otp,2,atp%input_string,"","",-1,atm%zcore_orig,atp)
950 0 : file_xml=TRIM(atp%pot%sym)//'-rcpaw.corewf.xml'
951 0 : call xmlprtcore(trim(file_xml),atp,atm%zcore_orig,mesh_data,atp%input_string)
952 0 : call destroy_mesh_data(mesh_data)
953 : endif
954 :
955 : ! update tcoretau : TODO : tau
956 : ! Clean up
957 18 : if(update_paw.or.atp%vhtnzc_mode==2) then
958 4004 : do io=1,atp%Grid%n
959 4002 : atp%Pot%rvh(io)=atp%Pot%rvh(io)+potshift*atp%Grid%r(io)
960 4004 : atp%Pot%rv(io)=atp%Pot%rv(io)+potshift*atp%Grid%r(io)
961 : enddo
962 2 : atp%Pot%v0=atp%Pot%v0+potshift
963 : endif
964 : endif
965 19 : LIBPAW_DEALLOCATE(coredens)
966 19 : call pawrad_free(radmesh)
967 19 : end subroutine atompaw_solve
968 : !!***
969 :
970 : !----------------------------------------------------------------------
971 :
972 : !!****f* m_paw_atom_solve/atompaw_init
973 : !! NAME
974 : !! atompaw_init
975 : !!
976 : !! FUNCTION
977 : !! Initialize an atompaw type
978 : !!
979 : !! OUTPUT
980 : !!
981 : !! SIDE EFFECTS
982 : !!
983 : !! NOTES
984 : !!
985 : !! SOURCE
986 : !! Inspired from SCFatom_init in atompaw
987 :
988 4 : subroutine atompaw_init(pawtab,pawrad,atp,atm,sctol,elin_mode,vhtnzc_mode,tpaw_mode,dirac,filename,prtpaw)
989 : ! TODO : BDsolve
990 : implicit none
991 : !Arguments ------------------------------------
992 : !scalars
993 : integer, intent(in) :: elin_mode,vhtnzc_mode,tpaw_mode,prtpaw
994 : real(dp), intent(in) :: sctol
995 : logical,intent(in) :: dirac
996 : CHARACTER(len=*),intent(in) :: filename
997 : type(pawtab_type), intent(inout) :: pawtab
998 : type(pawrad_type), intent(in) :: pawrad
999 : type(atompaw_type), intent(inout) :: atp
1000 : type(atomorb_type), intent(inout) :: atm
1001 : !arrays
1002 : !Local variables-------------------------------
1003 : !scalars
1004 : CHARACTER(len=500) :: input_file
1005 : character(len=500) :: msg
1006 : character(len=fnlen) :: file_xml_core
1007 : logical :: rcpaw_core_file,ex
1008 : REAL(dp) :: a1,a2,a3,hval,r0,zcore
1009 : INTEGER :: ii,jj,icor,ir,io,fnln,ios
1010 : logical :: fmt_xml
1011 : real(dp) :: ekin,insph,norm
1012 4 : type(pawrad_type) :: radmesh
1013 4 : type(mesh_data_type) :: mesh_data
1014 : !arrays
1015 4 : real(dp), allocatable :: ff(:)
1016 :
1017 : ! *************************************************************************
1018 :
1019 : ! File to read
1020 4 : input_file=trim(filename)
1021 4 : fnln=len(trim(filename))
1022 4 : fmt_xml=.false.
1023 4 : if (fnln>3) then
1024 4 : fmt_xml=(input_file(fnln-3:fnln)=='.xml')
1025 : endif
1026 4 : if(.not.fmt_xml) then
1027 0 : LIBPAW_ERROR('RCPAW ONLY COMPATIBLE WITH XML COREWF FILE')
1028 : endif
1029 4 : input_file=input_file(1:fnln-3)//'corewf.xml'
1030 4 : inquire(file=trim(input_file),iostat=ios,exist=ex)
1031 4 : if (ios/=0) then
1032 0 : write(msg,'(2a)') 'INQUIRE returns an error for file ',trim(input_file)
1033 0 : LIBPAW_ERROR(msg)
1034 : end if
1035 4 : if (.not.ex) then
1036 0 : write(msg,'(3a)') 'This file does not exist: ',trim(input_file),'!'
1037 0 : LIBPAW_ERROR(msg)
1038 : end if
1039 :
1040 : ! Initialize global constants
1041 4 : machine_precision = zero
1042 4 : a1 = 4._dp/3._dp
1043 8 : DO WHILE (machine_precision == 0._dp)
1044 4 : a2 = a1 - 1._dp
1045 4 : a3 = a2 + a2 + a2
1046 4 : machine_precision = ABS(a3 - 1._dp)
1047 : ENDDO
1048 4 : machine_zero= machine_precision**5
1049 4 : machine_infinity = 1._dp/machine_zero
1050 4 : practical_zero=machine_precision**2
1051 4 : minlogarg=machine_precision; minlog=LOG(minlogarg)
1052 4 : maxlogarg=1._dp/machine_precision; maxlog=LOG(maxlogarg)
1053 4 : minexparg=LOG(machine_precision); minexp=0._dp
1054 4 : maxexparg=-LOG(machine_precision); maxexp=EXP(maxexparg)
1055 4 : has_to_print=.false.
1056 :
1057 : ! Read atp input and initialize
1058 4 : atp%elin_mode=elin_mode
1059 4 : atp%vhtnzc_mode=vhtnzc_mode
1060 4 : atp%tpaw_mode=tpaw_mode
1061 4 : atp%prtpaw=(prtpaw>0)
1062 :
1063 4 : call input_dataset_read(atp,input_file,dirac,.true.)
1064 :
1065 4 : rcpaw_core_file=.false.
1066 4 : if((.not.dirac).and.atp%diracrelativistic) then
1067 1 : atp%scalarrelativistic=.true.
1068 1 : atp%diracrelativistic=.false.
1069 1 : rcpaw_core_file=.true.
1070 : endif
1071 4 : atp%npsc=0
1072 4 : atp%nppc=1
1073 4 : atp%npdc=2
1074 4 : atp%npfc=3
1075 4 : atp%npgc=4
1076 4 : atp%frozenvalecalculation=.false.
1077 4 : atp%frozencorecalculation=.false.
1078 4 : atp%setupfrozencore=.false.
1079 4 : atp%gaussianshapefunction=.false.
1080 4 : atp%besselshapefunction=.false.
1081 4 : atp%collesalvetti=.false.
1082 4 : IF (TRIM(atp%gridkey)=='LINEAR') THEN
1083 0 : hval=atp%gridmatch/(atp%gridpoints-1)
1084 0 : CALL InitGrid(atp%Grid,hval,atp%gridrange)
1085 4 : ELSEIF (TRIM(atp%gridkey)=='LOGGRID') THEN
1086 4 : hval=logh
1087 4 : CALL findh(real(atp%atomic_charge,kind=dp),atp%gridmatch,atp%gridpoints,hval,r0)
1088 4 : CALL InitGrid(atp%Grid,pawrad%lstep,atp%gridrange,r0=pawrad%rstep)
1089 0 : ELSEIF (TRIM(atp%gridkey)=='LOGGRID4') THEN
1090 : hval=logh
1091 : CALL findh_given_r0(real(atp%atomic_charge,kind=dp),atp%gridmatch,lor00,&
1092 0 : & atp%gridpoints,hval)
1093 0 : CALL InitGrid(atp%Grid,hval,atp%gridrange,r0=lor00/atp%atomic_charge)
1094 : ENDIF
1095 4 : call print_check_atompaw_params(atp)
1096 4 : call read_inputstring(atp%input_string)
1097 :
1098 : ! Init potentials
1099 4 : CALL InitPot(atp%Pot,atp%Grid%n)
1100 4 : atp%Pot%sym=atp%atomic_symbol
1101 : atp%Pot%zz=0._dp
1102 4 : atp%Pot%q=0._dp;
1103 4 : atp%Pot%v0=0._dp
1104 4 : atp%Pot%v0p=0._dp
1105 4 : atp%Pot%Nv0=0
1106 4 : atp%Pot%Nv0p=0
1107 4 : atp%Pot%nz=atp%atomic_charge
1108 4 : atp%Pot%zz=atp%Pot%nz
1109 4 : atp%Pot%needvtau=atp%needvtau
1110 4 : atp%Pot%finitenucleus=atp%finitenucleus
1111 4 : atp%Pot%finitenucleusmodel=atp%finitenucleusmodel
1112 4 : CALL Get_Nuclearpotential(atp%Grid,atp%Pot)
1113 :
1114 : ! Init XC
1115 : ! atp%temp=temp
1116 4 : call initexch(atp)
1117 :
1118 : ! Init orbitals
1119 24 : ii=maxval(atp%np)
1120 4 : jj=atp%np(1)
1121 4 : IF(atp%np(2)>0) jj=jj+atp%np(2)-1
1122 : IF(atp%np(3)>0) jj=jj+atp%np(3)-2
1123 : IF(atp%np(4)>0) jj=jj+atp%np(4)-3
1124 : IF(atp%np(5)>0) jj=jj+atp%np(5)-4
1125 : If (atp%diracrelativistic) jj=jj+jj ! need more orbitals
1126 : CALL InitOrbit(atp%Orbit,atp%norbit,atp%Grid%n,atp%exctype,atp%diracrelativistic,atp%scalarrelativistic,&
1127 4 : & atp%frozencorecalculation,atp%frozenvalecalculation)
1128 4 : atp%Orbit%nps=atp%np(1);atp%Orbit%npp=atp%np(2);atp%Orbit%npd=atp%np(3)
1129 4 : atp%Orbit%npf=atp%np(4);atp%Orbit%npg=atp%np(5)
1130 4 : CALL Prepare_Orbit(atp,ii,atp%norbit)
1131 4 : atp%Orbit%npsc=atp%npsc;atp%Orbit%nppc=atp%nppc;atp%Orbit%npdc=atp%npdc
1132 4 : atp%Orbit%npfc=atp%npfc;atp%Orbit%npgc=atp%npgc
1133 4 : atp%Pot%q=atp%electrons
1134 :
1135 : ! Init SCF
1136 4 : CALL InitSCF(atp%SCF)
1137 4 : IF (atp%needvtau) then
1138 0 : atp%usespline=.true.
1139 : endif
1140 4 : if(atp%usespline) CALL initsplinesolver(atp%Grid,atp%splns,atp%splr0,atp%needvtau,atp%spline)
1141 :
1142 : ! Init PAW
1143 4 : atp%PAW%irc=FindGridIndex(atp%Grid,atp%rc)
1144 4 : atp%PAW%irc_shap=FindGridIndex(atp%Grid,atp%rc_shap)
1145 4 : atp%PAW%irc_vloc=FindGridIndex(atp%Grid,atp%rc_vloc)
1146 4 : atp%PAW%irc_core=FindGridIndex(atp%Grid,atp%rc_core)
1147 4 : atp%PAW%rc=atp%Grid%r(atp%PAW%irc)
1148 4 : atp%PAW%rc_shap=atp%Grid%r(atp%PAW%irc_shap)
1149 4 : atp%PAW%rc_vloc=atp%Grid%r(atp%PAW%irc_vloc)
1150 4 : atp%PAW%rc_core=atp%Grid%r(atp%PAW%irc_core)
1151 4 : atp%PAW%lmax=atp%lmax
1152 4 : call InitPAW(atp%PAW,atp%Grid,atp%Orbit)
1153 :
1154 : ! Re-solve (temporary, this should be added to atompaw)
1155 4 : call SCFatom(atp,.true.)
1156 :
1157 4 : if(rcpaw_core_file) then
1158 1 : call build_mesh_data(mesh_data,atp%Grid,atp%PAW%irc,0,0,0,0)
1159 1 : zcore=zero
1160 8 : do io=1,atp%norbit
1161 8 : if(atp%orbit%iscore(io)) then
1162 3 : zcore=zcore+atp%orbit%occ(io)
1163 : endif
1164 : enddo
1165 1 : file_xml_core=TRIM(atp%pot%sym)//'-tmp.corewf.xml'
1166 1 : call xmlprtcore(trim(file_xml_core),atp,zcore,mesh_data,atp%input_string)
1167 1 : file_xml_core=trim(atp%pot%sym)//'-tmp.xml'
1168 1 : call destroy_mesh_data(mesh_data)
1169 : else
1170 3 : file_xml_core=filename
1171 : endif
1172 : ! define atom
1173 4 : call pawpsp_init_core(atm,psp_filename=trim(file_xml_core))
1174 5678 : call simp_gen(atp%pot_ref,atp%Pot%rv(1:pawtab%mesh_size)*pawrad%rad(1:pawtab%mesh_size)*pawtab%shapefunc(1:pawtab%mesh_size,1),pawrad)
1175 4 : write(msg,'(a)') 'atompaw_init: orbital, %out of sphere, core, semicore'
1176 4 : call wrtout(std_out,msg,'COLL')
1177 31 : do io=1,atp%Orbit%norbit
1178 27 : norm=overlap(atp%Grid,atp%Orbit%wfn(1:atp%Grid%n,io),atp%Orbit%wfn(1:atp%Grid%n,io),1,atp%Grid%n)
1179 27 : insph=overlap(atp%Grid,atp%Orbit%wfn(1:atp%PAW%irc,io),atp%Orbit%wfn(1:atp%PAW%irc,io),1,atp%PAW%irc)
1180 27 : if(.not.atp%Orbit%iscore(io).and.(one-insph/norm)*100.0_dp<sctol) atp%Orbit%issemicore(io)=.true.
1181 27 : write(msg,*)io,(one-insph/norm)*100.0_dp,atp%Orbit%iscore(io),atp%Orbit%issemicore(io)
1182 31 : call wrtout(std_out,msg,'COLL')
1183 : enddo
1184 : !!!
1185 :
1186 12 : LIBPAW_ALLOCATE(atp%pot_refo,(pawtab%basis_size))
1187 12 : LIBPAW_ALLOCATE(ff,(pawtab%mesh_size))
1188 5674 : ff(2:pawtab%mesh_size)=atp%Pot%rv(2:pawtab%mesh_size)/atp%grid%r(2:pawtab%mesh_size)
1189 4 : call extrapolate(ff)
1190 40 : do io=1,pawtab%basis_size
1191 50968 : call simp_gen(atp%pot_refo(io),ff(1:pawtab%mesh_size)*(pawtab%phi(1:pawtab%mesh_size,io))**2,pawrad)
1192 : enddo
1193 4 : LIBPAW_DEALLOCATE(ff)
1194 :
1195 : ! Densities
1196 8008 : atp%Orbit%valeden=zero
1197 8008 : atp%Orbit%coreden=zero
1198 31 : do io=1,atp%Orbit%norbit
1199 31 : if(atp%Orbit%iscore(io)) then
1200 26026 : atp%Orbit%coreden=atp%Orbit%coreden+atp%Orbit%occ(io)*(atp%Orbit%wfn(:,io))**2
1201 : else
1202 28028 : atp%Orbit%valeden(:)=atp%Orbit%valeden(:)+atp%Orbit%occ(io)*(atp%Orbit%wfn(:,io))**2
1203 : endif
1204 : enddo
1205 : ! Core energies
1206 4 : atm%edcc=zero
1207 4 : atm%ekinc=zero
1208 4 : atm%eeigc=zero
1209 4 : icor=0
1210 31 : do io=1,atp%Orbit%norbit
1211 31 : if(atp%Orbit%iscore(io)) then
1212 13 : icor=icor+1
1213 13 : CALL altkinetic(atp%Grid,atp%Orbit%wfn(:,io),atp%Orbit%eig(io),atp%Pot%rv,ekin)
1214 13 : atm%ekinc=atm%ekinc+ekin/two*atp%Orbit%occ(io)
1215 13 : atm%eeigc=atm%eeigc+atp%Orbit%eig(io)*atp%Orbit%occ(io)/two
1216 : endif
1217 : enddo
1218 12 : LIBPAW_ALLOCATE(ff,(atp%grid%n))
1219 8008 : ff=zero
1220 : ff(2:atp%Grid%n)=atp%Pot%rv(2:atp%Grid%n)*&
1221 8004 : & atp%Orbit%coreden(2:atp%Grid%n)/atp%Grid%r(2:atp%Grid%n)
1222 4 : CALL extrapolate(ff)
1223 4 : atm%edcc=integrator(atp%Grid,ff)/two
1224 8004 : ff(2:atp%Grid%n)=atp%Orbit%coreden(2:atp%Grid%n)/(four*pi*atp%Grid%r(2:atp%Grid%n)**2)
1225 4 : CALL extrapolate(ff)
1226 4 : call pawrad_init(radmesh,atp%Grid%n,pawrad%mesh_type,pawrad%rstep,pawrad%lstep)
1227 4 : call atompaw_ehnzc(ff,radmesh,atm%ehnzc,atm%znucl)
1228 4 : LIBPAW_DEALLOCATE(ff)
1229 35 : atm%min_eigv=half*minval(atp%Orbit%eig,mask=.not.atp%Orbit%iscore)
1230 4 : call pawrad_free(radmesh)
1231 :
1232 : ! Prepare for frozen val calculation
1233 4 : atp%frozenvalecalculation=.true.
1234 4 : atp%Orbit%frozenvalecalculation=.true.
1235 4 : atp%projector_type=PROJECTOR_TYPE_MARSMAN
1236 148152 : atp%PAW%otp=zero
1237 40 : do io=1,pawtab%basis_size
1238 50788 : do ir=1,atp%PAW%irc
1239 50784 : atp%PAW%otp(ir,io)=pawtab%tproj(ir,io)
1240 : enddo
1241 : enddo
1242 :
1243 : ! atp%SCF%corekin=two*atm%ekinc
1244 : ! call setcoretail(atp%Grid,atp%Orbit%coreden,atp%PAW,atp%needvtau)
1245 : ! call setbasis(atp%Grid,atp%Pot,atp%Orbit,atp%PAW,atp,0.0_dp)
1246 : ! call SetPAWOptions2(atp,fmt_xml)
1247 : ! atp%PAW%abinitnohat(1:size(pawtab%vhtnzc))=pawtab%vhtnzc(1:size(pawtab%vhtnzc))*two
1248 : ! atp%PAW%otp=zero
1249 : ! do io=1,pawtab%basis_size
1250 : ! do ir=1,atp%PAW%irc
1251 : ! atp%PAW%otp(ir,io)=pawtab%tproj(ir,io)
1252 : ! enddo
1253 : ! enddo
1254 : ! do io=1,pawtab%basis_size
1255 : ! irc=FindGridIndex(atp%Grid,atp%basis_func_rc(io))
1256 : ! irc=min(atp%PAW%irc,irc)
1257 : ! atp%PAW%rcio(io)=atp%grid%r(irc)
1258 : ! enddo
1259 : ! atp%PAW%abinitnohat(1:size(pawtab%vhtnzc))=pawtab%vhtnzc(1:size(pawtab%vhtnzc))*two
1260 : ! call build_mesh_data(mesh_data,atp%Grid,atp%PAW%irc,0,0,0,0)
1261 : ! if(.not.allocated(pawtab%kij)) then
1262 : ! LIBPAW_ALLOCATE(pawtab%kij,(pawtab%lmn2_size))
1263 : ! endif
1264 : ! call calc_kij(atp%PAW,atp%Grid,pawtab%kij,pawtab,&
1265 : !& atp%scalarrelativistic,atp%needvtau)
1266 : ! file_xml_core=trim(atp%pot%sym)//'-rcpaw.xml'
1267 : ! call xmloutput(trim(file_xml_core),atp%Grid,atp%SCF,atp%Pot,atp%Orbit,atp%PAW,mesh_data,&
1268 : !& atp%PAW%otp,2,atp%input_string,"","",-1,atm%zcore,atp)
1269 : ! file_xml_core=TRIM(atp%pot%sym)//'-rcpaw.corewf.xml'
1270 : ! call xmlprtcore(trim(file_xml_core),atp,atm%zcore,mesh_data,atp%input_string)
1271 :
1272 8 : end subroutine atompaw_init
1273 : !!***
1274 :
1275 : !----------------------------------------------------------------------
1276 :
1277 : !!****f* m_paw_atom_solve/atompaw_destroy
1278 : !! NAME
1279 : !! atompaw_destroy
1280 : !!
1281 : !! FUNCTION
1282 : !! Destroy an atompaw type
1283 : !!
1284 : !! OUTPUT
1285 : !!
1286 : !! SIDE EFFECTS
1287 : !!
1288 : !! NOTES
1289 : !!
1290 : !! SOURCE
1291 :
1292 4 : subroutine atompaw_destroy(atp)
1293 :
1294 : implicit none
1295 : !Arguments ------------------------------------
1296 : !scalars
1297 : type(atompaw_type), intent(inout) :: atp
1298 :
1299 : ! *********************************************************************
1300 :
1301 4 : if(allocated(atp%orbit_mod_n)) then
1302 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_n)
1303 : endif
1304 4 : if(allocated(atp%orbit_mod_l)) then
1305 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_l)
1306 : endif
1307 4 : if(allocated(atp%orbit_mod_k)) then
1308 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_k)
1309 : endif
1310 4 : if(allocated(atp%orbit_mod_occ)) then
1311 4 : LIBPAW_DEALLOCATE(atp%orbit_mod_occ)
1312 : endif
1313 4 : if(allocated(atp%orbit_iscore)) then
1314 4 : LIBPAW_DEALLOCATE(atp%orbit_iscore)
1315 : endif
1316 4 : if(allocated(atp%orbit_val_n)) then
1317 4 : LIBPAW_DEALLOCATE(atp%orbit_val_n)
1318 : endif
1319 4 : if(allocated(atp%orbit_val_l)) then
1320 4 : LIBPAW_DEALLOCATE(atp%orbit_val_l)
1321 : endif
1322 4 : if(allocated(atp%orbit_val_k)) then
1323 4 : LIBPAW_DEALLOCATE(atp%orbit_val_k)
1324 : endif
1325 4 : if(allocated(atp%basis_add_l)) then
1326 4 : LIBPAW_DEALLOCATE(atp%basis_add_l)
1327 : endif
1328 4 : if(allocated(atp%basis_add_k)) then
1329 4 : LIBPAW_DEALLOCATE(atp%basis_add_k)
1330 : endif
1331 4 : if(allocated(atp%basis_add_energy)) then
1332 4 : LIBPAW_DEALLOCATE(atp%basis_add_energy)
1333 : endif
1334 4 : if(allocated(atp%basis_func_rc)) then
1335 4 : LIBPAW_DEALLOCATE(atp%basis_func_rc)
1336 : endif
1337 4 : if(allocated(atp%pot_refo)) then
1338 4 : LIBPAW_DEALLOCATE(atp%pot_refo)
1339 : endif
1340 4 : call DestroyGrid(atp%Grid)
1341 4 : call DestroyOrbit(atp%Orbit)
1342 4 : call DestroyPot(atp%Pot)
1343 4 : call DestroyPAW(atp%PAW)
1344 4 : call deallocatesplinesolver(atp%spline,atp%needvtau)
1345 :
1346 4 : end subroutine atompaw_destroy
1347 : !!***
1348 :
1349 :
1350 :
1351 :
1352 :
1353 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1354 : ! BELOW THIS ARE PRIVATE ROUTINES MOSTLY IMPORTED FROM ATOMPAW
1355 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1356 :
1357 :
1358 :
1359 :
1360 :
1361 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1362 : ! 0. Developped for RCPAW
1363 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1364 :
1365 :
1366 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1367 : !! makebasis_marsman
1368 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1369 2 : subroutine makebasis_marsman(atp)
1370 : type(atompaw_type),intent(inout) :: atp
1371 : integer :: ns,np,nd,nf,ng,io,l
1372 : real(dp):: v0,v0p
1373 2 : integer, allocatable :: map(:)
1374 6 : LIBPAW_ALLOCATE(map,(atp%PAW%nbase))
1375 2 : ns=0
1376 2 : np=0
1377 2 : nd=0
1378 2 : nf=0
1379 2 : ng=0
1380 20 : map=0
1381 2 : call zeropot(atp%Grid,atp%PAW%rveff,v0,v0p)
1382 20 : do io=1,atp%PAW%nbase
1383 18 : l=atp%PAW%l(io)
1384 18 : if(l==0) then
1385 5 : ns=ns+1
1386 5 : map(io)=ns
1387 : endif
1388 18 : if(l==1) then
1389 5 : np=np+1
1390 5 : map(io)=np
1391 : endif
1392 18 : if(l==2) then
1393 5 : nd=nd+1
1394 5 : map(io)=nd
1395 : endif
1396 18 : if(l==3) then
1397 3 : nf=nf+1
1398 3 : map(io)=nf
1399 : endif
1400 20 : if(l==4) then
1401 0 : ng=ng+1
1402 0 : map(io)=ng
1403 : endif
1404 : enddo
1405 2 : if(ns>0) call marsman_tphi(atp,map,0,ns)
1406 2 : if(np>0) call marsman_tphi(atp,map,1,np)
1407 2 : if(nd>0) call marsman_tphi(atp,map,2,nd)
1408 2 : if(nf>0) call marsman_tphi(atp,map,3,nf)
1409 2 : if(ng>0) call marsman_tphi(atp,map,4,ng)
1410 : ! renormalize phis
1411 20 : do io=1,atp%PAW%nbase
1412 36036 : atp%PAW%otphi(:,io)=atp%PAW%tphi(:,io)
1413 36036 : atp%PAW%ophi(:,io)=atp%PAW%phi(:,io)*atp%PAW%otphi(atp%PAW%irc,io)/atp%PAW%phi(atp%PAW%irc,io)
1414 10680 : atp%PAW%otphi(atp%PAW%irc:atp%Grid%n,io)=atp%PAW%ophi(atp%PAW%irc:atp%Grid%n,io)
1415 18 : atp%PAW%Kop(1,io)=zero
1416 : atp%PAW%Kop(2:atp%Grid%n,io)=(atp%PAW%eig(io)-atp%Pot%rv(2:atp%Grid%n)/&
1417 36020 : & atp%Grid%r(2:atp%Grid%n))*atp%PAW%ophi(2:atp%Grid%n,io)
1418 : enddo
1419 2 : LIBPAW_DEALLOCATE(map)
1420 2 : end subroutine makebasis_marsman
1421 :
1422 :
1423 :
1424 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1425 : !! marsman_tphi
1426 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1427 7 : subroutine marsman_tphi(atp,map,l_in,n)
1428 : integer, intent(in) :: l_in
1429 : integer, intent(in) :: n
1430 : type(atompaw_type),intent(inout) :: atp
1431 : integer, intent(in) :: map(atp%PAW%nbase)
1432 : integer :: io,nodes,ii,match,irc
1433 : integer :: io2,l2,jj,ioj,kk,l,ir,ir1
1434 : real(dp):: energy,v0,v0p,zeroval
1435 7 : real(dp), allocatable :: ksi_i0(:,:),ksi_ij(:,:,:)
1436 7 : real(dp), allocatable :: ksi_i0_0(:),ksi_ij_0(:,:)
1437 : REAL(dp), ALLOCATABLE :: p1(:),p2(:)
1438 7 : real(dp), allocatable :: AA(:,:), BB(:)
1439 14 : real(dp) :: dp1(atp%PAW%irc),dp2(atp%PAW%irc)
1440 : real(dp) :: x1,y1,y2,a,b,c,r1,r2
1441 : logical :: need_fit
1442 7 : irc=atp%PAW%irc
1443 7 : CALL zeropot(atp%Grid,atp%PAW%rveff,v0,v0p)
1444 21 : LIBPAW_ALLOCATE(p1,(atp%Grid%n))
1445 14 : LIBPAW_ALLOCATE(p2,(atp%Grid%n))
1446 28 : LIBPAW_ALLOCATE(ksi_i0,(atp%Grid%n,n))
1447 35 : LIBPAW_ALLOCATE(ksi_ij,(atp%Grid%n,n,n))
1448 21 : LIBPAW_ALLOCATE(ksi_i0_0,(n))
1449 28 : LIBPAW_ALLOCATE(ksi_ij_0,(n,n))
1450 36043 : ksi_i0=zero
1451 96121 : ksi_ij=zero
1452 7 : ii=0
1453 73 : do io=1,atp%PAW%nbase
1454 66 : l=atp%PAW%l(io)
1455 73 : if(l==l_in) then
1456 18 : ii=ii+1
1457 18 : energy=atp%PAW%eig(io)
1458 18 : CALL ClassicalTurningPoint(atp%Grid,atp%PAW%rveff,l,energy,match)
1459 18 : if(match>irc) match=2
1460 : ! !! backward Not used anymore
1461 : ! p2=zero
1462 : ! p2(irc:atp%Grid%n)=atp%PAW%phi(irc:atp%Grid%n,io)
1463 : ! CALL backward_numerov(atp%Grid,l,2,energy,atp%PAW%rveff,p2,nend=irc+1)
1464 : !! forward
1465 36036 : p1=zero
1466 18 : p1(2)=wfninit(-0.5_dp*atp%PAW%rveff(1),l,v0,v0p,energy,atp%Grid%r(2))
1467 18 : zeroval=zero
1468 18 : IF (l==0) zeroval=atp%PAW%rveff(1)
1469 18 : IF (l==1) zeroval=2
1470 18 : CALL forward_numerov(atp%Grid,l,irc+5,energy,atp%PAW%rveff,zeroval,p1,nodes)!,p3val=p1(3))
1471 36036 : ksi_i0(:,ii)=p1(:)
1472 25392 : dp1=zero
1473 18 : call derivative(atp%grid,p1,dp1,1,irc)
1474 : ! p2(2:size(p2))=p2(2:size(p2))*atp%grid%r(2:size(p2))**l_in
1475 : ! call extrapolate(p2)
1476 18 : ksi_i0_0(ii)=dp1(irc)
1477 18 : jj=0
1478 198 : do io2=1,atp%PAW%nbase
1479 180 : l2=atp%PAW%l(io2)
1480 198 : if(l2==l) then
1481 48 : jj=jj+1
1482 48 : match=2
1483 : ! p2=zero
1484 : ! p2(irc:atp%Grid%n)=atp%PAW%phi(irc:atp%Grid%n,io)
1485 : ! CALL backward_numerov(atp%Grid,l,match,energy,atp%PAW%rveff,p2,nend=irc+1,proj=atp%PAW%otp(:,io2))
1486 96096 : p1=zero
1487 48 : p1(2)=wfninit(-0.5_dp*atp%PAW%rveff(1),l,v0,v0p,energy,atp%Grid%r(2))
1488 48 : CALL forward_numerov(atp%Grid,l,irc+5,energy,atp%PAW%rveff,zeroval,p1,nodes,proj=atp%PAW%otp(:,io2))!,p3val=p1(3))
1489 96096 : ksi_ij(:,ii,jj)=p1(:)
1490 : ! p2(2:size(p2))=p2(2:size(p2))*atp%grid%r(2:size(p2))**l_in
1491 : ! call extrapolate(p2)
1492 67620 : dp1=zero
1493 48 : call derivative(atp%grid,p1,dp1,1,irc)
1494 48 : ksi_ij_0(ii,jj)=dp1(irc)
1495 : endif
1496 : enddo
1497 : endif
1498 : enddo
1499 28 : LIBPAW_ALLOCATE(AA,(n+1,n+1))
1500 21 : LIBPAW_ALLOCATE(BB,(n+1))
1501 73 : do ioj=1,atp%PAW%nbase
1502 66 : l=atp%PAW%l(ioj)
1503 73 : if(l==l_in) then
1504 18 : jj=map(ioj)
1505 330 : AA=zero
1506 84 : BB=zero
1507 : ! get derivative of phi
1508 25392 : dp1=zero
1509 18 : call derivative(atp%grid,atp%PAW%phi(:,ioj),dp1,1,irc)
1510 18 : ii=0
1511 198 : do io=1,atp%PAW%nbase
1512 180 : l2=atp%PAW%l(io)
1513 198 : if(l==l2) then
1514 48 : ii=ii+1
1515 48 : if(ii==jj) BB(ii)=one
1516 96096 : p2(:)=ksi_i0(:,jj)*atp%PAW%otp(:,io)
1517 48 : AA(ii,n+1)=integrator(atp%Grid,p2)
1518 180 : do kk=1,n
1519 264264 : p2(:)=ksi_ij(:,jj,kk)*atp%PAW%otp(:,io)
1520 180 : AA(ii,kk)=integrator(atp%Grid,p2)
1521 : enddo
1522 : endif
1523 : enddo
1524 66 : do kk=1,n
1525 66 : AA(n+1,kk)=ksi_ij_0(jj,kk)-dp1(irc)*ksi_ij(irc,jj,kk)/atp%PAW%phi(irc,ioj)
1526 : enddo
1527 18 : AA(n+1,n+1)=ksi_i0_0(jj)-dp1(irc)*ksi_i0(irc,jj)/atp%PAW%phi(irc,ioj)
1528 18 : call SolveAXeqBM(n+1,AA,BB,n+1)
1529 36036 : atp%PAW%tphi(:,ioj)=zero
1530 66 : do kk=1,n
1531 96114 : atp%PAW%tphi(:,ioj)=atp%PAW%tphi(:,ioj)+BB(kk)*ksi_ij(:,jj,kk)
1532 : enddo
1533 36036 : atp%PAW%tphi(:,ioj)=atp%PAW%tphi(:,ioj)+BB(n+1)*ksi_i0(:,jj)
1534 : ! In some cases, numerical error => need to fit tail of the orbital
1535 : ! Check if low lying orbital
1536 18 : if(atp%basis_func_rc(ioj)<atp%rc) then
1537 : ! Check if tphi is close to 0 at irc
1538 4006 : if(abs(atp%PAW%tphi(irc,ioj))/maxval(abs(atp%PAW%tphi(:,ioj)))<tol2) then
1539 : ! Check if tphi is non-decreasing at irc
1540 0 : need_fit=.false.
1541 0 : call derivative(atp%grid,abs(atp%PAW%tphi(:,ioj)),dp2,1,irc)
1542 0 : ir1=FindGridIndex(atp%Grid,atp%basis_func_rc(ioj))
1543 0 : do ir=ir1,irc+5
1544 0 : if(dp2(ir)>zero) then
1545 : need_fit=.true.
1546 : exit
1547 : endif
1548 : enddo
1549 0 : if(need_fit) then
1550 0 : x1=atp%PAW%tphi(ir1,ioj)
1551 0 : call derivative(atp%grid,atp%PAW%tphi(:,ioj),dp2,1,ir1)
1552 0 : y1=dp2(ir1)/x1
1553 0 : call derivative(atp%grid,atp%PAW%phi(:,ioj),dp1,1,irc)
1554 0 : y2=dp1(irc)/atp%PAW%phi(irc,ioj)
1555 0 : r1=atp%grid%r(ir1)
1556 0 : r2=atp%grid%r(irc)
1557 0 : c=(y1-y2)/(one/r1-one/r2)
1558 0 : b=c/r1-y1
1559 0 : a=x1/(r1**c*exp(-b*r1))
1560 0 : do ir=ir1,irc+5
1561 0 : atp%PAW%tphi(ir,ioj)=a*atp%grid%r(ir)**c*exp(-b*atp%grid%r(ir))
1562 : enddo
1563 : endif
1564 : endif
1565 : endif
1566 : endif
1567 : enddo
1568 7 : LIBPAW_DEALLOCATE(AA)
1569 7 : LIBPAW_DEALLOCATE(BB)
1570 7 : LIBPAW_DEALLOCATE(p1)
1571 7 : LIBPAW_DEALLOCATE(p2)
1572 7 : LIBPAW_DEALLOCATE(ksi_i0)
1573 7 : LIBPAW_DEALLOCATE(ksi_ij)
1574 7 : LIBPAW_DEALLOCATE(ksi_i0_0)
1575 7 : LIBPAW_DEALLOCATE(ksi_ij_0)
1576 7 : end subroutine marsman_tphi
1577 :
1578 :
1579 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1580 : !! calc_kij
1581 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1582 2 : subroutine calc_kij(PAW,grid,kij,pawtab,scalarrelativistic,needvtau)
1583 : logical, intent(in) :: scalarrelativistic,needvtau
1584 : type(gridinfo), intent(in) :: grid
1585 : type(pseudoinfo), intent(in) :: PAW
1586 : type(pawtab_type), intent(in) :: pawtab
1587 : real(dp), intent(inout) :: kij(pawtab%lmn2_size)
1588 : integer :: nbase,l,ib,jb
1589 : integer :: jlmn,j0lmn,jlm,jln,ilmn,klmn,ilm,iln
1590 : real(dp) :: x, y
1591 2 : nbase=PAW%nbase
1592 20 : DO ib=1,nbase
1593 18 : l=PAW%l(ib)
1594 200 : DO jb=1,nbase
1595 198 : IF (PAW%l(jb)==l) THEN
1596 48 : If (scalarrelativistic) then
1597 12 : call altdtij(Grid,PAW,ib,jb,x,needvtau)
1598 : Else
1599 : CALL deltakinetic_ij(Grid,PAW%ophi(:,ib),PAW%ophi(:,jb), &
1600 36 : & PAW%otphi(:,ib),PAW%otphi(:,jb),l,x,PAW%irc)
1601 : Endif
1602 48 : if(has_to_print) WRITE(STD_OUT,'(" Kinetic ", 3i5, 1p,3e15.7)') ib,jb,l,x
1603 48 : PAW%Kij(ib,jb)=x
1604 : ENDIF
1605 : ENDDO
1606 : ENDDO
1607 : ! Average equivalent terms
1608 20 : DO ib=1,nbase
1609 119 : DO jb=ib,nbase
1610 117 : IF(jb>ib) THEN
1611 81 : x=PAW%Kij(ib,jb); y=PAW%Kij(jb,ib)
1612 81 : x=0.5_dp*(x+y)
1613 81 : PAW%Kij(ib,jb)=x; PAW%Kij(jb,ib)=x
1614 : ENDIF
1615 : ENDDO
1616 : ENDDO
1617 : ! convert from atompaw to libpaw
1618 1349 : kij=zero
1619 68 : do jlmn=1,pawtab%lmn_size
1620 66 : j0lmn=jlmn*(jlmn-1)/2
1621 66 : jlm=pawtab%indlmn(4,jlmn);jln=pawtab%indlmn(5,jlmn)
1622 1415 : do ilmn=1,jlmn
1623 1347 : klmn=j0lmn+ilmn
1624 1347 : ilm=pawtab%indlmn(4,ilmn);iln=pawtab%indlmn(5,ilmn)
1625 1413 : if (ilm==jlm) kij(klmn)=half*PAW%Kij(iln,jln) ! Conversion Ry->Ha
1626 : enddo
1627 : enddo
1628 2 : end subroutine calc_kij
1629 :
1630 :
1631 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1632 : !! Prepare_Orbit
1633 : !! Inspired from SCFatom_Init
1634 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1635 4 : SUBROUTINE Prepare_Orbit(atp,ii,jj)
1636 : integer, intent(in) :: ii,jj
1637 : type(atompaw_type), intent(inout) :: atp
1638 : INTEGER :: icount,id,is,ip,jf,ig,io,l,nfix,kappa,i
1639 : real(dp) :: xocc
1640 4 : INTEGER, ALLOCATABLE :: nl(:,:)
1641 4 : icount=0
1642 4 : if(.not.atp%diracrelativistic) then
1643 87 : LIBPAW_ALLOCATE(nl,(ii,jj));nl=0
1644 3 : IF (atp%Orbit%nps.GT.0) THEN
1645 13 : DO is=1,atp%Orbit%nps
1646 10 : icount=icount+1
1647 10 : nl(is,1)=icount
1648 10 : atp%Orbit%occ(icount)=2._dp
1649 10 : atp%Orbit%np(icount)=is
1650 10 : atp%Orbit%l(icount)=0
1651 13 : if(atp%orbit_iscore(icount)) atp%npsc=is
1652 : ENDDO
1653 : ENDIF
1654 3 : IF (atp%Orbit%npp.GT.1) THEN
1655 9 : DO ip=2,atp%Orbit%npp
1656 6 : icount=icount+1
1657 6 : nl(ip,2)=icount
1658 6 : atp%Orbit%occ(icount)=6._dp
1659 6 : atp%Orbit%np(icount)=ip
1660 6 : atp%Orbit%l(icount)=1
1661 9 : if(atp%orbit_iscore(icount)) atp%nppc=ip
1662 : ENDDO
1663 : ENDIF
1664 3 : IF (atp%Orbit%npd.GT.2) THEN
1665 2 : DO id=3,atp%Orbit%npd
1666 1 : icount=icount+1
1667 1 : nl(id,3)=icount
1668 1 : atp%Orbit%occ(icount)=10._dp
1669 1 : atp%Orbit%np(icount)=id
1670 1 : atp%Orbit%l(icount)=2
1671 2 : if(atp%orbit_iscore(icount)) atp%npdc=id
1672 : ENDDO
1673 : ENDIF
1674 3 : IF (atp%Orbit%npf.GT.3) THEN
1675 0 : DO jf=4,atp%Orbit%npf
1676 0 : icount=icount+1
1677 0 : nl(jf,4)=icount
1678 0 : atp%Orbit%occ(icount)=14._dp
1679 0 : atp%Orbit%np(icount)=jf
1680 0 : atp%Orbit%l(icount)=3
1681 0 : if(atp%orbit_iscore(icount)) atp%npfc=jf
1682 : ENDDO
1683 : ENDIF
1684 3 : IF(atp%Orbit%npg.GT.4) THEN
1685 0 : DO ig=5,atp%Orbit%npg
1686 0 : icount=icount+1
1687 0 : nl(ig,5)=icount
1688 0 : atp%Orbit%occ(icount)=18._dp
1689 0 : atp%Orbit%np(icount)=ig
1690 0 : atp%Orbit%l(icount)=4
1691 0 : if(atp%orbit_iscore(icount)) atp%npgc=ig
1692 : ENDDO
1693 : ENDIF
1694 3 : atp%Orbit%norbit=icount
1695 3 : if(has_to_print) write(std_out,*)' Below are listed the default occupations '
1696 3 : if(has_to_print) write(std_out,"(' n l occupancy')")
1697 20 : DO io=1,atp%Orbit%norbit
1698 17 : if(has_to_print) WRITE(std_out,'(i2,1x,i2,4x,1p,1e15.7)') &
1699 3 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%occ(io)
1700 : ENDDO
1701 20 : atp%Orbit%iscore=atp%orbit_iscore
1702 7 : DO io=1,atp%norbit_mod
1703 4 : l=atp%orbit_mod_l(io)
1704 4 : ip=atp%orbit_mod_n(io)
1705 4 : xocc=atp%orbit_mod_occ(io)
1706 4 : nfix=nl(ip,l+1)
1707 4 : IF (nfix<=0.OR.nfix>atp%Orbit%norbit) THEN
1708 0 : LIBPAW_ERROR('error in occupations')
1709 : ENDIF
1710 7 : atp%Orbit%occ(nfix)=xocc
1711 : END DO
1712 3 : if(has_to_print) WRITE(STD_OUT,*) ' Corrected occupations are: '
1713 3 : if(has_to_print) WRITE(STD_OUT,"(' n l occupancy')")
1714 3 : atp%electrons=0._dp
1715 20 : DO io=1,atp%Orbit%norbit
1716 17 : if(has_to_print) WRITE(STD_OUT,'(i2,1x,i2,4x,1p,1e15.7)') &
1717 0 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%occ(io)
1718 17 : atp%electrons=atp%electrons+atp%Orbit%occ(io)
1719 20 : if(.not.atp%Orbit%iscore(io)) atp%Orbit%qval=atp%Orbit%qval+atp%Orbit%occ(io)
1720 : ENDDO
1721 : ENDIF ! scalarrelativistic
1722 :
1723 4 : If (atp%diracrelativistic) then
1724 1 : i=MAX(atp%Orbit%nps,atp%Orbit%npp,atp%Orbit%npd,atp%Orbit%npf,atp%Orbit%npg)
1725 3 : LIBPAW_ALLOCATE(nl,(i,-5:5))
1726 56 : nl=0
1727 1 : IF (atp%Orbit%nps.GT.0) THEN
1728 5 : DO is=1,atp%Orbit%nps
1729 4 : icount=icount+1
1730 4 : nl(is,-1)=icount
1731 4 : atp%Orbit%occ(icount)=2._dp
1732 4 : atp%Orbit%np(icount)=is
1733 4 : atp%Orbit%l(icount)=0
1734 4 : atp%Orbit%kappa(icount)=-1
1735 5 : if(atp%orbit_iscore(icount)) atp%npsc=is
1736 : ENDDO
1737 : ENDIF
1738 1 : IF (atp%Orbit%npp.GT.1) THEN
1739 3 : DO ip=2,atp%Orbit%npp
1740 2 : icount=icount+1
1741 2 : nl(ip,1)=icount
1742 2 : atp%Orbit%occ(icount)=2._dp
1743 2 : atp%Orbit%np(icount)=ip
1744 2 : atp%Orbit%l(icount)=1
1745 2 : atp%Orbit%kappa(icount)=1
1746 3 : if(atp%orbit_iscore(icount)) atp%nppc=ip
1747 : ENDDO
1748 3 : DO ip=2,atp%Orbit%npp
1749 2 : icount=icount+1
1750 2 : nl(ip,-2)=icount
1751 2 : atp%Orbit%occ(icount)=4._dp
1752 2 : atp%Orbit%np(icount)=ip
1753 2 : atp%Orbit%l(icount)=1
1754 2 : atp%Orbit%kappa(icount)=-2
1755 3 : if(atp%orbit_iscore(icount)) atp%nppc=ip
1756 : ENDDO
1757 : ENDIF
1758 1 : IF (atp%Orbit%npd.GT.2) THEN
1759 2 : DO id=3,atp%Orbit%npd
1760 1 : icount=icount+1
1761 1 : nl(id,2)=icount
1762 1 : atp%Orbit%occ(icount)=4._dp
1763 1 : atp%Orbit%np(icount)=id
1764 1 : atp%Orbit%l(icount)=2
1765 1 : atp%Orbit%kappa(icount)=2
1766 2 : if(atp%orbit_iscore(icount)) atp%npdc=id
1767 : ENDDO
1768 2 : DO id=3,atp%Orbit%npd
1769 1 : icount=icount+1
1770 1 : nl(id,-3)=icount
1771 1 : atp%Orbit%occ(icount)=6._dp
1772 1 : atp%Orbit%np(icount)=id
1773 1 : atp%Orbit%l(icount)=2
1774 1 : atp%Orbit%kappa(icount)=-3
1775 2 : if(atp%orbit_iscore(icount)) atp%npdc=id
1776 : ENDDO
1777 : ENDIF
1778 1 : IF (atp%Orbit%npf.GT.3) THEN
1779 0 : DO jf=4,atp%Orbit%npf
1780 0 : icount=icount+1
1781 0 : nl(jf,3)=icount
1782 0 : atp%Orbit%occ(icount)=6._dp
1783 0 : atp%Orbit%np(icount)=jf
1784 0 : atp%Orbit%l(icount)=3
1785 0 : atp%Orbit%kappa(icount)=3
1786 0 : if(atp%orbit_iscore(icount)) atp%npfc=jf
1787 : ENDDO
1788 0 : DO jf=4,atp%Orbit%npf
1789 0 : icount=icount+1
1790 0 : nl(jf,-4)=icount
1791 0 : atp%Orbit%occ(icount)=8._dp
1792 0 : atp%Orbit%np(icount)=jf
1793 0 : atp%Orbit%l(icount)=3
1794 0 : atp%Orbit%kappa(icount)=-4
1795 0 : if(atp%orbit_iscore(icount)) atp%npfc=jf
1796 : ENDDO
1797 : ENDIF
1798 1 : IF(atp%Orbit%npg.GT.4) THEN
1799 0 : DO ig=5,atp%Orbit%npg
1800 0 : icount=icount+1
1801 0 : nl(ig,4)=icount
1802 0 : atp%Orbit%occ(icount)=8._dp
1803 0 : atp%Orbit%np(icount)=ig
1804 0 : atp%Orbit%l(icount)=4
1805 0 : atp%Orbit%kappa(icount)=4
1806 0 : if(atp%orbit_iscore(icount)) atp%npgc=ig
1807 : ENDDO
1808 0 : DO ig=5,atp%Orbit%npg
1809 0 : icount=icount+1
1810 0 : nl(ig,-5)=icount
1811 0 : atp%Orbit%occ(icount)=10._dp
1812 0 : atp%Orbit%np(icount)=ig
1813 0 : atp%Orbit%l(icount)=4
1814 0 : atp%Orbit%kappa(icount)=-5
1815 0 : if(atp%orbit_iscore(icount)) atp%npgc=ig
1816 : ENDDO
1817 : ENDIF
1818 1 : atp%Orbit%norbit=icount
1819 1 : if(has_to_print) write(std_out,*)' Below are listed the default occupations '
1820 1 : if(has_to_print) write(std_out,"(' n l kappa occupancy')")
1821 11 : DO io=1,atp%Orbit%norbit
1822 10 : if(has_to_print) write(std_out,'(i2,1x,i2,3x,i2,4x,1p,1e15.7)') &
1823 1 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%kappa(io),atp%Orbit%occ(io)
1824 : ENDDO
1825 : !Corrected occupations (from input dataset)
1826 11 : atp%Orbit%iscore=atp%orbit_iscore
1827 4 : DO io=1,atp%norbit_mod
1828 3 : l=atp%orbit_mod_l(io)
1829 3 : ip=atp%orbit_mod_n(io)
1830 3 : kappa=atp%orbit_mod_k(io)
1831 3 : xocc=atp%orbit_mod_occ(io)
1832 3 : nfix=nl(ip,kappa)
1833 3 : IF (nfix<=0.OR.nfix>atp%Orbit%norbit) THEN
1834 0 : WRITE(STD_OUT,*) 'error in occupations -- ip,l,kappa,xocc:',&
1835 0 : & ip,l,kappa,xocc,nfix,atp%Orbit%norbit
1836 0 : STOP
1837 : ENDIF
1838 4 : atp%Orbit%occ(nfix)=xocc
1839 : END DO
1840 1 : if(has_to_print)WRITE(STD_OUT,*) ' Corrected occupations are: '
1841 1 : if(has_to_print) WRITE(STD_OUT,"(' n l kappa occupancy')")
1842 1 : atp%electrons=0.0_dp
1843 11 : DO io=1,atp%Orbit%norbit
1844 10 : if(has_to_print) WRITE(STD_OUT,'(i2,1x,i2,3x,i2,4x,1p,1e15.7)') &
1845 0 : & atp%Orbit%np(io),atp%Orbit%l(io),atp%Orbit%kappa(io),atp%Orbit%occ(io)
1846 10 : atp%electrons=atp%electrons+atp%Orbit%occ(io)
1847 11 : if(.not.atp%Orbit%iscore(io)) atp%Orbit%qval=atp%Orbit%qval+atp%Orbit%occ(io)
1848 : ENDDO
1849 : ENDIF ! completed occupations
1850 4 : LIBPAW_DEALLOCATE(nl)
1851 4 : end subroutine Prepare_Orbit
1852 :
1853 :
1854 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1855 : !! subroutine print_atompaw_params(atp)
1856 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1857 4 : subroutine print_check_atompaw_params(atp)
1858 : type(atompaw_type),intent(in) :: atp
1859 : integer :: norb,io
1860 4 : if(atp%scalarrelativistic.and.atp%tpaw_mode>1) then
1861 0 : LIBPAW_ERROR('tpaw_mode>1 and scalarrelativistic not compatible')
1862 : endif
1863 4 : if(atp%finitenucleus) then
1864 0 : LIBPAW_ERROR('Finitenucleus not implemented')
1865 : endif
1866 4 : if(atp%HFpostprocess) then
1867 0 : LIBPAW_ERROR('HFpostprocess not implemented')
1868 : endif
1869 4 : if(atp%localizedcoreexchange) then
1870 0 : LIBPAW_ERROR('Localized core exchange not implemented')
1871 : endif
1872 4 : if(atp%BDsolve) then
1873 0 : LIBPAW_ERROR('BD solver not implemented')
1874 : endif
1875 4 : if(atp%fixed_zero) then
1876 0 : LIBPAW_ERROR('Fixed zero not implemented')
1877 : endif
1878 4 : if(atp%shapetcore) then
1879 0 : LIBPAW_ERROR('Shapetcore not implemented')
1880 : endif
1881 4 : if(atp%ColleSalvetti) then
1882 0 : LIBPAW_ERROR('ColleSalvetti not implemented')
1883 : endif
1884 4 : if(.not.atp%ortho_type==ORTHO_TYPE_VANDERBILT) then
1885 0 : LIBPAW_ERROR('RCPAW only possible with Vanderbilt ortho scheme')
1886 : endif
1887 4 : if(has_to_print) then
1888 0 : WRITE(STD_OUT,'(/,3x,a)') "===== Atompaw parameters ====="
1889 : ! Atom
1890 0 : WRITE(STD_OUT,'(3x,a,a2)') "Atomic symbol : ",atp%atomic_symbol
1891 0 : WRITE(STD_OUT,'(3x,a,i0)') "Atomic charge : ",atp%atomic_charge
1892 : ! Algo
1893 0 : WRITE(STD_OUT,'(3x,2a)') "Scalar-relativistic calculation:",MERGE("YES"," NO",atp%scalarrelativistic)
1894 0 : WRITE(STD_OUT,'(3x,2a)') "Dirac-relativistic calculation:",MERGE("YES"," NO",atp%diracrelativistic)
1895 0 : WRITE(STD_OUT,'(3x,2a)') "Frozen core calculation:",MERGE("YES"," NO",atp%frozencorecalculation)
1896 0 : WRITE(STD_OUT,'(3x,2a)') "Frozen vale calculation:",MERGE("YES"," NO",atp%frozenvalecalculation)
1897 0 : IF (atp%usespline) THEN
1898 0 : WRITE(STD_OUT,'(3x,a)') " - Use a spline solver"
1899 : END IF
1900 0 : WRITE(STD_OUT,'(3x,2a)') "Exchange-correlation functional:",TRIM(atp%exctype)
1901 0 : WRITE(STD_OUT,'(3x,3a)') " (mGGA kinetic energy functional:",MERGE("YES"," NO",atp%needvtau),")"
1902 0 : WRITE(STD_OUT,'(3x,2a)') "Finite-nucleus calculation:",MERGE("YES"," NO",atp%finitenucleus)
1903 0 : IF (atp%finitenucleus) THEN
1904 0 : WRITE(STD_OUT,'(3x,a,i0)') " - Finite-nucleus model:",atp%finitenucleusmodel
1905 : END IF
1906 0 : WRITE(STD_OUT,'(3x,2a)') "Block-Davidson calculation:",MERGE("YES"," NO",atp%BDsolve)
1907 : ! Grid
1908 0 : WRITE(STD_OUT,'(3x,a,i0)') "Grid type:",atp%Grid%type
1909 0 : WRITE(STD_OUT,'(3x,a,i0)') "Grid size:",atp%Grid%n
1910 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Grid maximum value:",atp%Grid%r(atp%Grid%n)
1911 0 : if(atp%usespline) then
1912 0 : WRITE(STD_OUT,'(3x,a,f7.3,2x,i0)') "Spline grid r0, ns :",&
1913 0 : & atp%splr0,atp%splns
1914 : endif
1915 : ! XC
1916 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, post-processing:",MERGE("YES"," NO",atp%HFpostprocess)
1917 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, localized coreex.:",MERGE("YES"," NO",atp%localizedcoreexchange)
1918 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, fixed zero:",MERGE("YES"," NO",atp%fixed_zero)
1919 0 : IF (atp%fixed_zero) THEN
1920 0 : WRITE(STD_OUT,'(3x,a,i0)') " - HF fixed zero index:",atp%fixed_zero_index
1921 : END IF
1922 0 : IF (atp%BDsolve.and.atp%gridkey=='LINEAR') THEN
1923 0 : WRITE(STD_OUT,'(/,3x,a)') "WARNING: BlockDavidson solver works very slowlywith linear grid!"
1924 : END IF
1925 0 : WRITE(STD_OUT,'(3x,a,5(1x,i0))') "Max. quantum numbers (s,p,d,f,g):",atp%np(1:5)
1926 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of orbitals: ",atp%norbit
1927 0 : WRITE(STD_OUT,'(3x,a)') "Core and valence orbitals:"
1928 0 : IF (.NOT.atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') "n l : type"
1929 0 : IF (atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') "n l kappa :type"
1930 : ! io=0
1931 : ! DO ll=0,4
1932 : ! nn=atp%np(ll+1)
1933 : ! IF (nn>0) THEN
1934 : ! IF (.NOT.atp%diracrelativistic) THEN
1935 : ! DO ii=1+ll,nn
1936 : ! io=io+1
1937 : ! WRITE(STD_OUT,'(7x,i1,1x,i1,2a)') ii,ll," : ", &
1938 : !& MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
1939 : ! END DO
1940 : ! ELSE
1941 : ! DO ik=1,nkappa(ll+1)
1942 : ! kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
1943 : ! DO ii=1+ll,nn
1944 : ! io=io+1
1945 : ! WRITE(STD_OUT,'(7x,i1,1x,i1,2x,i2,2x,2a)') ii,ll,kk," : ", &
1946 : ! & MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
1947 : ! END DO
1948 : ! END DO
1949 : ! END IF
1950 : ! END IF
1951 : ! END DO
1952 0 : WRITE(STD_OUT,'(3x,a,i0)') "Basis, maximum L : ",atp%lmax
1953 : !cutoff radii
1954 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Augmentation region radius : ",atp%rc
1955 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Core dens. matching radius : ",atp%rc_core
1956 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Local pot. matching radius : ",atp%rc_vloc
1957 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Compens. shape func radius : ",atp%rc_shap
1958 : !Additional basis
1959 0 : WRITE(STD_OUT,'(3x,a,i0)') "Initial number of basis functions:",atp%nbasis-atp%nbasis_add
1960 0 : WRITE(STD_OUT,'(3x,a,i0)') "Number of additional basis functions:",atp%nbasis_add
1961 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of basis functions:",atp%nbasis
1962 0 : WRITE(STD_OUT,'(3x,a)') "Additional basis functions:"
1963 0 : IF (.NOT.atp%diracrelativistic) THEN
1964 0 : WRITE(STD_OUT,'(7x,a)') "l : energy"
1965 0 : DO io=1,atp%nbasis_add
1966 0 : WRITE(STD_OUT,'(7x,i1,a,f7.4)') atp%basis_add_l(io),":",atp%basis_add_energy(io)
1967 : END DO
1968 : ELSE
1969 0 : WRITE(STD_OUT,'(7x,a)') "l kappa : energy"
1970 0 : DO io=1,atp%nbasis_add
1971 0 : WRITE(STD_OUT,'(7x,i1,2x,i2,2x,a,f7.4)') atp%basis_add_l(io), &
1972 0 : & atp%basis_add_k(io)," : " ,atp%basis_add_energy(io)
1973 : END DO
1974 : END IF
1975 : !Projectors
1976 0 : WRITE(STD_OUT,'(3x,a)') "Projectors description:"
1977 0 : IF (atp%projector_type==PROJECTOR_TYPE_BLOECHL) &
1978 0 : & WRITE(STD_OUT,'(7x,a)') "Type : BLOECHL"
1979 0 : IF (atp%projector_type==PROJECTOR_TYPE_VANDERBILT) &
1980 0 : & WRITE(STD_OUT,'(7x,a)') "Type : VANDERBILT"
1981 0 : IF (atp%projector_type==PROJECTOR_TYPE_MODRRKJ) &
1982 0 : & WRITE(STD_OUT,'(7x,a)') "Type : MODRRKJ"
1983 0 : IF (atp%projector_type==PROJECTOR_TYPE_CUSTOM) &
1984 0 : & WRITE(STD_OUT,'(7x,a)') "Type : CUSTOM"
1985 0 : IF (atp%projector_type==PROJECTOR_TYPE_HF) &
1986 0 : & WRITE(STD_OUT,'(7x,a)') "Type : HARTREE-FOCK"
1987 0 : IF (atp%projector_type/=PROJECTOR_TYPE_HF) THEN
1988 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL) &
1989 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL"
1990 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM) &
1991 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : POLYNOM"
1992 0 : IF (atp%pseudo_type==PSEUDO_TYPE_RRKJ) &
1993 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : RRKJ"
1994 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
1995 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL KERKER"
1996 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM2) &
1997 0 : & WRITE(STD_OUT,'(7x,a,i0,a,es9.3)') "Pseudization : POLYNOM2,pdeg=",&
1998 0 : & atp%pseudo_polynom2_pdeg,", qcut=",atp%pseudo_polynom2_qcut
1999 0 : IF (atp%ortho_type==ORTHO_TYPE_GRAMSCHMIDT) &
2000 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : GRAM-SCHMIDT"
2001 0 : IF (atp%ortho_type==ORTHO_TYPE_VANDERBILT) &
2002 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : VANDERBILT"
2003 0 : IF (atp%ortho_type==ORTHO_TYPE_SVD) &
2004 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : SVD"
2005 : END IF
2006 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_GAUSSIAN) &
2007 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Compensation charge shape function: GAUSSIAN,tol=",&
2008 0 : & atp%shapefunc_gaussian_param
2009 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_SINC) &
2010 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : SINC2"
2011 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_BESSEL) &
2012 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : BESSEL"
2013 0 : IF (atp%hf_coretol>0) &
2014 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Core tolerance for Hartree-Fock:",atp%hf_coretol
2015 0 : WRITE(STD_OUT,'(3x,2a)') "Smooth tcore shape (no negative nhat):",MERGE("YES"," NO",atp%shapetcore)
2016 : !Local Psp
2017 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER) &
2018 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type:MTROULLIER,l=",&
2019 0 : & atp%vloc_l,", energy=",atp%vloc_ene
2020 0 : IF (atp%vloc_type==VLOC_TYPE_ULTRASOFT) &
2021 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type:ULTRASOFT,l=",&
2022 0 : & atp%vloc_l,", energy=",atp%vloc_ene
2023 0 : IF (atp%vloc_type==VLOC_TYPE_BESSEL) &
2024 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : BESSEL"
2025 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNC) &
2026 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
2027 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNNC) &
2028 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNNC"
2029 0 : IF (atp%vloc_type==VLOC_TYPE_SETVLOC) THEN
2030 0 : WRITE(STD_OUT,'(7x,a,es9.4,a,es9.4)') "Local pseudopotential type:SETVLOC,coef=",&
2031 0 : & atp%vloc_setvloc_coef,", rad=",atp%vloc_setvloc_rad
2032 0 : IF (atp%needvtau) THEN
2033 0 : LIBPAW_ERROR('SETVLOC option not available for MGGA')
2034 : ENDIF
2035 : ENDIF
2036 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_EXPF) &
2037 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER EXPF,powers=",&
2038 0 : & atp%vloc_kerker_power(1:4)
2039 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_POLY) &
2040 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER POLY,powers=",&
2041 0 : & atp%vloc_kerker_power(1:4)
2042 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.AND.atp%needvtau) THEN
2043 0 : WRITE(STD_OUT,'(7x,a)') 'NOTE: MTROULLIER Vloc not available for mGGA!'
2044 0 : WRITE(STD_OUT,'(7x,a)') ' Calling VPSmatch with norm conservation instead.'
2045 0 : WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
2046 : END IF
2047 0 : WRITE(STD_OUT,'(3x,a)') "Matching radius for basis functions:"
2048 0 : IF (.NOT.atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') " # - n l : radius"
2049 0 : IF (atp%diracrelativistic) WRITE(STD_OUT,'(7x,a)') " # - n l kappa :radius"
2050 : norb=0
2051 : ! DO ll=0,atp%lmax
2052 : ! DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic)
2053 : ! kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
2054 : ! IF (.NOT.atp%diracrelativistic) kk=0
2055 : ! DO io=1,atp%norbit_val
2056 : ! IF (atp%orbit_val_l(io)==ll.AND. &
2057 : ! & ((.NOT.atp%diracrelativistic).OR.atp%orbit_val_k(io)==kk))THEN
2058 : ! norb=norb+1
2059 : ! IF (.NOT.atp%diracrelativistic) &
2060 : ! & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,a,f7.4)') &
2061 : ! & norb," - ",atp%orbit_val_n(io),ll," :",atp%basis_func_rc(norb)
2062 : ! IF (atp%diracrelativistic) &
2063 : ! & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,2x,i2,2x,a,f7.4)') &
2064 : ! & norb," - ",atp%orbit_val_n(io),ll,kk," :",atp%basis_func_rc(norb)
2065 : ! END IF
2066 : ! END DO
2067 : ! IF (atp%nbasis_add>0) THEN
2068 : ! DO io=1,atp%nbasis_add
2069 : ! IF (atp%basis_add_l(io)==ll.AND. &
2070 : ! & ((.NOT.atp%diracrelativistic).OR.atp%basis_add_k(io)==kk))THEN
2071 : ! norb=norb+1
2072 : ! IF (.NOT.atp%diracrelativistic) &
2073 : ! & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,a,f7.4)') &
2074 : ! & norb," - ",".",ll," : ",atp%basis_func_rc(norb)
2075 : ! IF (atp%diracrelativistic) &
2076 : ! & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,2x,i2,2x,a,f7.4)') &
2077 : ! & norb," - ",".",ll,kk," : ",atp%basis_func_rc(norb)
2078 : ! END IF
2079 : ! END DO
2080 : ! END IF
2081 : ! END DO
2082 : ! END DO
2083 : endif
2084 4 : end subroutine print_check_atompaw_params
2085 :
2086 :
2087 :
2088 :
2089 :
2090 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2091 : ! 1. aeatom
2092 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2093 :
2094 :
2095 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2096 : !! Potential_Init
2097 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2098 23 : SUBROUTINE Potential_Init(Orbit,Pot,Grid)
2099 : IMPLICIT NONE
2100 : TYPE(OrbitInfo),INTENT(IN) :: Orbit
2101 : TYPE(PotentialInfo),INTENT(INOUT) :: Pot
2102 : TYPE(GridInfo),INTENT(IN) :: Grid
2103 : real(dp) :: ecoul,v0
2104 23 : CALL atompaw_poisson(Grid,Pot%q,Orbit%den,Pot%rvh,ecoul,v0)
2105 23 : if(has_to_print) write(std_out,*) 'In Potential_Init', Pot%q,ecoul
2106 23 : END SUBROUTINE Potential_Init
2107 :
2108 :
2109 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2110 : !! SCFatom
2111 : !! Main atomic SCF routine to calculate the all electron atomic solution.
2112 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2113 23 : subroutine SCFatom(atp,initialize)
2114 : implicit none
2115 : logical, intent(in) :: initialize
2116 : type(atompaw_type),target, intent(inout) :: atp
2117 23 : if(initialize) then
2118 4 : call Orbit_Init(atp%Orbit,atp%Pot,atp)
2119 : endif
2120 23 : call Potential_Init(atp%Orbit,atp%Pot,atp%Grid)
2121 23 : if(atp%Orbit%frozenvalecalculation) atp%Pot%q=atp%electrons
2122 23 : call LDAGGA_SCF(atp)
2123 23 : end subroutine SCFatom
2124 :
2125 :
2126 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2127 : !! Orbit_Init
2128 : !! From nuclear charge -- generate hydrogenic-like initial wfns
2129 : !! and densities --
2130 : !! fill AEOrbit%wfn, AEOrbit%eig, and AEOrbit%den and AEOrbit%q
2131 : !! also AEOrbit%otau and AEOrbit%tau
2132 : !! Note that both den and tau need to be divided by 4 \pi r^2
2133 : !! Note that tau is only correct for non-relativistic case
2134 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2135 4 : SUBROUTINE Orbit_Init(Orbit,Pot,atp)
2136 : IMPLICIT NONE
2137 : TYPE(PotentialInfo),INTENT(INOUT) :: Pot
2138 : TYPE(OrbitInfo),INTENT(INOUT) :: Orbit
2139 : type(atompaw_type), intent(in) :: atp
2140 : INTEGER :: io,ir,l,np,kappa
2141 : real(dp) :: qcal,rescale,zeff,xocc,fpi
2142 4 : REAL(dp),allocatable :: d(:)
2143 : INTEGER :: initialconfig=0
2144 4 : IF (initialconfig/=0) STOP 'Error in aeatom -- Orbit_Init already called'
2145 : ! calculate initial charge density from hydrogen-like functions
2146 : ! also initial energies
2147 4 : zeff=Pot%nz
2148 4 : If (.not.atp%diracrelativistic) then
2149 20 : DO io=1,Orbit%norbit
2150 17 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
2151 17 : np=Orbit%np(io)
2152 17 : l=Orbit%l(io)
2153 17 : xocc=Orbit%occ(io)
2154 17 : if(.not.Orbit%frozenvalecalculation) Orbit%eig(io)=-(zeff/(np))**2!/2.0!Hartree
2155 17 : if(has_to_print) WRITE(std_out,*) io,np,l,xocc,Orbit%eig(io),zeff
2156 34034 : DO ir=1,atp%Grid%n
2157 34017 : Orbit%wfn(ir,io)=hwfn(zeff,np,l,atp%Grid%r(ir))
2158 34034 : IF (ABS(Orbit%wfn(ir,io))<machine_zero) Orbit%wfn(ir,io)=0._dp
2159 : ENDDO
2160 17 : zeff=zeff-0.5_dp*xocc
2161 20 : zeff=MAX(zeff,1._dp)
2162 : ENDDO
2163 : endif
2164 4 : If (atp%diracrelativistic) then
2165 11 : DO io=1,Orbit%norbit
2166 10 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
2167 10 : np=Orbit%np(io)
2168 10 : l=Orbit%l(io)
2169 10 : kappa=Orbit%kappa(io)
2170 10 : xocc=Orbit%occ(io)
2171 10 : if(.not.Orbit%frozenvalecalculation) Orbit%eig(io)=-(zeff/(np))**2!/2.0
2172 20020 : DO ir=1,atp%Grid%n
2173 : call dirachwfn(np,kappa,zeff,atp%Grid%r(ir),Orbit%eig(io) &
2174 20010 : & ,Orbit%wfn(ir,io),Orbit%lwfn(ir,io))
2175 20010 : IF (ABS(Orbit%wfn(ir,io))<machine_zero) Orbit%wfn(ir,io)=0._dp
2176 20020 : IF (ABS(Orbit%lwfn(ir,io))<machine_zero) Orbit%lwfn(ir,io)=0._dp
2177 : ENDDO
2178 10 : zeff=zeff-0.5_dp*xocc
2179 11 : zeff=MAX(zeff,1._dp)
2180 : ENDDO
2181 : endif
2182 : ! check charge and rescale
2183 8008 : Orbit%den=0._dp
2184 8008 : Orbit%tau=0._dp
2185 31 : DO io=1,Orbit%norbit
2186 27 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
2187 : CALL taufromwfn(Orbit%otau(:,io),atp%Grid,Orbit%wfn(:,io),Orbit%l(io),&
2188 27 : & energy=Orbit%eig(io),rPot=Pot%rv)
2189 27 : xocc=Orbit%occ(io)
2190 54058 : DO ir=1,atp%Grid%n
2191 54027 : Orbit%den(ir)=Orbit%den(ir)+(Orbit%wfn(ir,io)**2)*xocc
2192 54027 : Orbit%tau(ir)=Orbit%tau(ir)+xocc*Orbit%otau(ir,io)
2193 54027 : If (atp%diracrelativistic) Orbit%den(ir)=Orbit%den(ir) + &
2194 20037 : & xocc*((Orbit%lwfn(ir,io))**2)
2195 : ENDDO
2196 : ENDDO
2197 : ! Note that kinetic energy density (tau) is in Rydberg units ???
2198 : ! Note that kinetic energy density is only correct for non-relativistic
2199 : ! formulation
2200 4 : qcal=integrator(atp%Grid,Orbit%den)
2201 4 : if(Orbit%frozenvalecalculation) qcal=qcal+atp%Orbit%qval
2202 4 : if(Orbit%frozenvalecalculation) Orbit%den=Orbit%den+Orbit%valeden
2203 : !rescale density
2204 4 : rescale=atp%electrons/qcal
2205 8008 : Orbit%den(1:atp%Grid%n)=Orbit%den(1:atp%Grid%n)*rescale
2206 8008 : Orbit%tau(1:atp%Grid%n)=Orbit%tau(1:atp%Grid%n)*rescale
2207 : ! determine difference with tauW (Weizsaker)
2208 12 : LIBPAW_ALLOCATE(d,(atp%Grid%n)); fpi=4*pi
2209 8004 : d(2:atp%Grid%n)=Orbit%den(2:atp%Grid%n)/(fpi*atp%Grid%r(2:atp%Grid%n)**2)
2210 4 : call extrapolate(d)
2211 4 : CALL derivative(atp%Grid,d,Orbit%deltatau)
2212 8008 : Do ir=1,atp%Grid%n
2213 8008 : if (d(ir)>machine_zero) then
2214 6639 : Orbit%deltatau(ir)=0.25_dp*(Orbit%deltatau(ir)**2)/d(ir)
2215 : else
2216 1365 : Orbit%deltatau(ir)=0.0_dp
2217 : endif
2218 : enddo
2219 8004 : d(2:atp%Grid%n)=Orbit%tau(2:atp%Grid%n)/(fpi*atp%Grid%r(2:atp%Grid%n)**2)
2220 4 : call extrapolate(d)
2221 8008 : Orbit%deltatau=d-Orbit%deltatau
2222 4 : LIBPAW_DEALLOCATE(d)
2223 4 : END SUBROUTINE Orbit_Init
2224 :
2225 :
2226 :
2227 :
2228 :
2229 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2230 : ! 2. atomdata
2231 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2232 :
2233 :
2234 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2235 : !! Subroutine InitOrbit -- used in CopyOrbit
2236 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2237 362 : subroutine InitOrbit(Orbit,norbit,n,exctype,diracrelativistic,scalarrelativistic,frozencorecalculation,frozenvalecalculation)
2238 : type (OrbitInfo), intent(inout) :: Orbit
2239 : logical, intent(in) :: diracrelativistic
2240 : logical, intent(in) :: scalarrelativistic
2241 : logical, intent(in) :: frozencorecalculation,frozenvalecalculation
2242 : integer, intent(in) :: n,norbit
2243 : character(*),intent(in) :: exctype
2244 362 : CALL DestroyOrbit(Orbit)
2245 362 : Orbit%norbit=norbit;Orbit%exctype=trim(exctype)
2246 362 : Orbit%nps=0;Orbit%npp=0;Orbit%npd=0;Orbit%npf=0;Orbit%npg=0
2247 362 : Orbit%npsc=0;Orbit%nppc=0;Orbit%npdc=0;Orbit%npfc=0;Orbit%npgc=0
2248 362 : Orbit%qval=0._dp
2249 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%np,(norbit))
2250 724 : LIBPAW_POINTER_ALLOCATE(Orbit%l,(norbit))
2251 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%eig,(norbit))
2252 724 : LIBPAW_POINTER_ALLOCATE(Orbit%occ,(norbit))
2253 724 : LIBPAW_POINTER_ALLOCATE(Orbit%iscore,(norbit))
2254 724 : LIBPAW_POINTER_ALLOCATE(Orbit%issemicore,(norbit))
2255 2588 : Orbit%iscore=.false.
2256 2588 : Orbit%issemicore=.false.
2257 4814 : Orbit%np=0;Orbit%l=0
2258 4814 : Orbit%eig=0._dp;Orbit%occ=0._dp
2259 1448 : LIBPAW_POINTER_ALLOCATE(Orbit%wfn,(n,norbit))
2260 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%otau,(n,norbit))
2261 1086 : LIBPAW_POINTER_ALLOCATE(Orbit%den,(n))
2262 724 : LIBPAW_POINTER_ALLOCATE(Orbit%tau,(n))
2263 724 : LIBPAW_POINTER_ALLOCATE(Orbit%coreden,(n))
2264 724 : LIBPAW_POINTER_ALLOCATE(Orbit%valeden,(n))
2265 724 : LIBPAW_POINTER_ALLOCATE(Orbit%deltatau,(n))
2266 10361990 : Orbit%wfn=0._dp;Orbit%den=0._dp;Orbit%tau=0._dp;Orbit%otau=0._dp
2267 724724 : Orbit%deltatau=0._dp
2268 1449086 : Orbit%coreden=0._dp ; Orbit%valeden=0._dp
2269 362 : Orbit%scalarrelativistic=scalarrelativistic
2270 362 : Orbit%frozencorecalculation=frozencorecalculation
2271 362 : Orbit%frozenvalecalculation=frozenvalecalculation
2272 362 : Orbit%diracrelativistic=diracrelativistic
2273 362 : If (Orbit%diracrelativistic) then
2274 132 : LIBPAW_POINTER_ALLOCATE(Orbit%lwfn,(n,norbit))
2275 88 : LIBPAW_POINTER_ALLOCATE(Orbit%kappa,(norbit))
2276 880924 : Orbit%lwfn=0._dp
2277 484 : Orbit%kappa=0._dp
2278 : else
2279 318 : nullify(Orbit%lwfn,Orbit%kappa)
2280 : endif
2281 362 : if (exctype == "HF".or.exctype == "EXXKLI") then
2282 0 : LIBPAW_POINTER_ALLOCATE(Orbit%lqp,(norbit,norbit))
2283 0 : LIBPAW_POINTER_ALLOCATE(Orbit%X,(n,norbit))
2284 : else
2285 362 : nullify(Orbit%lqp,Orbit%X)
2286 : endif
2287 362 : end subroutine InitOrbit
2288 :
2289 :
2290 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2291 : !! Subroutine DestroyOrbit
2292 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2293 728 : subroutine DestroyOrbit(Orbit)
2294 : type (OrbitInfo), intent(inout) :: Orbit
2295 728 : if (associated(Orbit%np)) then
2296 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%np)
2297 : endif
2298 728 : if (associated(Orbit%l)) then
2299 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%l)
2300 : endif
2301 728 : if (associated(Orbit%kappa)) then
2302 44 : LIBPAW_POINTER_DEALLOCATE(Orbit%kappa)
2303 : endif
2304 728 : if (associated(Orbit%iscore)) then
2305 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%iscore)
2306 : endif
2307 728 : if (associated(Orbit%issemicore)) then
2308 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%issemicore)
2309 : endif
2310 728 : if (associated(Orbit%eig)) then
2311 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%eig)
2312 : endif
2313 728 : if (associated(Orbit%occ)) then
2314 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%occ)
2315 : endif
2316 728 : if (associated(Orbit%wfn)) then
2317 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%wfn)
2318 : endif
2319 728 : if (associated(Orbit%otau)) then
2320 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%otau)
2321 : endif
2322 728 : if (associated(Orbit%lwfn)) then
2323 44 : LIBPAW_POINTER_DEALLOCATE(Orbit%lwfn)
2324 : endif
2325 728 : if (associated(Orbit%den)) then
2326 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%den)
2327 : endif
2328 728 : if (associated(Orbit%tau)) then
2329 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%tau)
2330 : endif
2331 728 : IF (ASSOCIATED(Orbit%deltatau)) then
2332 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%deltatau)
2333 : endif
2334 728 : if (associated(Orbit%lqp)) then
2335 0 : LIBPAW_POINTER_DEALLOCATE(Orbit%lqp)
2336 : endif
2337 728 : if (associated(Orbit%X)) then
2338 0 : LIBPAW_POINTER_DEALLOCATE(Orbit%X)
2339 : endif
2340 728 : if(associated(Orbit%coreden)) then
2341 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%coreden)
2342 : endif
2343 728 : if(associated(Orbit%valeden)) then
2344 362 : LIBPAW_POINTER_DEALLOCATE(Orbit%valeden)
2345 : endif
2346 728 : end subroutine DestroyOrbit
2347 :
2348 :
2349 : !!!!!!!!!!!!!!!!!!!!!!!!!
2350 : !! CopyOrbit(source,copy)
2351 : !!!!!!!!!!!!!!!!!!!!!!!!!
2352 358 : subroutine CopyOrbit(SOrbit,COrbit)
2353 : type(OrbitInfo),intent(inout)::SOrbit
2354 : type(OrbitInfo),intent(inout)::COrbit
2355 : integer::n
2356 358 : n=size(SOrbit%den,1)
2357 : call InitOrbit(COrbit,SOrbit%norbit,n,SOrbit%exctype,SOrbit%diracrelativistic,SOrbit%scalarrelativistic,&
2358 358 : & SOrbit%frozencorecalculation,SOrbit%frozenvalecalculation)
2359 358 : COrbit%nps=SOrbit%nps
2360 358 : COrbit%npp=SOrbit%npp
2361 358 : COrbit%npd=SOrbit%npd
2362 358 : COrbit%npf=SOrbit%npf
2363 358 : COrbit%npg=SOrbit%npg
2364 358 : COrbit%npsc=SOrbit%npsc
2365 358 : COrbit%nppc=SOrbit%nppc
2366 358 : COrbit%npdc=SOrbit%npdc
2367 358 : COrbit%npfc=SOrbit%npfc
2368 358 : COrbit%npgc=SOrbit%npgc
2369 358 : COrbit%qval=SOrbit%qval
2370 2557 : COrbit%np(1:SOrbit%norbit)=SOrbit%np(1:SOrbit%norbit)
2371 2557 : COrbit%l(1:SOrbit%norbit)=SOrbit%l(1:SOrbit%norbit)
2372 2557 : COrbit%eig(1:SOrbit%norbit)=SOrbit%eig(1:SOrbit%norbit)
2373 2557 : COrbit%occ(1:SOrbit%norbit)=SOrbit%occ(1:SOrbit%norbit)
2374 4402756 : COrbit%wfn(:,1:SOrbit%norbit)=SOrbit%wfn(:,1:SOrbit%norbit)
2375 4402756 : COrbit%otau(:,1:SOrbit%norbit)=SOrbit%otau(:,1:SOrbit%norbit)
2376 2557 : COrbit%iscore(1:SOrbit%norbit)=SOrbit%iscore(1:SOrbit%norbit)
2377 2557 : COrbit%issemicore(1:SOrbit%norbit)=SOrbit%issemicore(1:SOrbit%norbit)
2378 716716 : COrbit%den=SOrbit%den
2379 716716 : COrbit%coreden=SOrbit%coreden
2380 716716 : COrbit%valeden=SOrbit%valeden
2381 716716 : COrbit%tau=SOrbit%tau
2382 716716 : COrbit%deltatau=SOrbit%deltatau
2383 358 : if (SOrbit%diracrelativistic) then
2384 860903 : COrbit%lwfn(:,1:SOrbit%norbit)=SOrbit%lwfn(:,1:SOrbit%norbit)
2385 473 : COrbit%kappa(1:SOrbit%norbit)=SOrbit%kappa(1:SOrbit%norbit)
2386 : endif
2387 358 : if (SOrbit%exctype == "HF".or.SOrbit%exctype == "EXXKLI") then
2388 0 : COrbit%X(:,1:SOrbit%norbit)=SOrbit%X(:,1:SOrbit%norbit)
2389 0 : COrbit%lqp(1:SOrbit%norbit,1:SOrbit%norbit)=SOrbit%lqp(1:SOrbit%norbit,1:SOrbit%norbit)
2390 : endif
2391 358 : end subroutine CopyOrbit
2392 :
2393 :
2394 : !!!!!!!!!!!!!!!!!!!!!!!!!
2395 : !! InitPot
2396 : !!!!!!!!!!!!!!!!!!!!!!!!!
2397 358 : subroutine InitPot(Pot,n)
2398 : integer, intent(in) :: n
2399 : type (PotentialInfo), intent(inout) :: Pot
2400 358 : CALL DestroyPot(Pot)
2401 1074 : LIBPAW_POINTER_ALLOCATE(Pot%rv,(n))
2402 716 : LIBPAW_POINTER_ALLOCATE(Pot%rvn,(n))
2403 716 : LIBPAW_POINTER_ALLOCATE(Pot%rvh,(n))
2404 716 : LIBPAW_POINTER_ALLOCATE(Pot%rvx,(n))
2405 716 : LIBPAW_POINTER_ALLOCATE(Pot%vtau,(n))
2406 716 : LIBPAW_POINTER_ALLOCATE(Pot%ww,(n))
2407 716 : LIBPAW_POINTER_ALLOCATE(Pot%jj,(n))
2408 3583580 : Pot%rv=0._dp;Pot%rvn=0._dp;Pot%rvh=0._dp;Pot%rvx=0._dp;Pot%vtau=0._dp
2409 1433432 : Pot%ww=0._dp;Pot%jj=0._dp
2410 358 : end subroutine InitPot
2411 :
2412 :
2413 : !!!!!!!!!!!!!!!!!!!!!!!!!
2414 : !! DestroyPot
2415 : !!!!!!!!!!!!!!!!!!!!!!!!!
2416 716 : subroutine DestroyPot(Pot)
2417 : type (PotentialInfo), intent(inout) :: Pot
2418 716 : if (associated(Pot%rv)) then
2419 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rv)
2420 : endif
2421 716 : if (associated(Pot%rvn)) then
2422 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rvn)
2423 : endif
2424 716 : if (associated(Pot%rvh)) then
2425 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rvh)
2426 : endif
2427 716 : if (associated(Pot%rvx)) then
2428 358 : LIBPAW_POINTER_DEALLOCATE(Pot%rvx)
2429 : endif
2430 716 : if (associated(Pot%vtau)) then
2431 358 : LIBPAW_POINTER_DEALLOCATE(Pot%vtau)
2432 : endif
2433 716 : if (allocated(Pot%ww)) then
2434 358 : LIBPAW_DEALLOCATE(Pot%ww)
2435 : endif
2436 716 : if (allocated(Pot%jj)) then
2437 358 : LIBPAW_DEALLOCATE(Pot%jj)
2438 : endif
2439 716 : end subroutine DestroyPot
2440 :
2441 :
2442 : !!!!!!!!!!!!!!!!!!!!!!!!!
2443 : ! CopyPot(source,copy)
2444 : !!!!!!!!!!!!!!!!!!!!!!!!!
2445 354 : subroutine CopyPot(SPot,CPot)
2446 : type(PotentialInfo),intent(in) :: SPot
2447 : type(PotentialInfo),intent(inout) :: CPot
2448 : integer :: n
2449 354 : n=SIZE(SPot%rv,1)
2450 354 : CALL InitPot(CPot,n)
2451 354 : CPot%nz=SPot%nz
2452 354 : CPot%zz=SPot%zz
2453 354 : CPot%sym=SPot%sym
2454 354 : CPot%q=SPot%q
2455 354 : CPot%v0=SPot%v0
2456 354 : CPot%v0p=SPot%v0p
2457 354 : CPot%finitenucleusmodel=SPot%finitenucleusmodel
2458 354 : CPot%finitenucleus=SPot%finitenucleus
2459 354 : CPot%Nv0=SPot%Nv0
2460 354 : CPot%Nv0p=SPot%Nv0p
2461 708708 : CPot%rv(1:n)=SPot%rv(1:n)
2462 708708 : CPot%rvn(1:n)=SPot%rvn(1:n)
2463 708708 : CPot%rvh(1:n)=SPot%rvh(1:n)
2464 708708 : CPot%rvx(1:n)=SPot%rvx(1:n)
2465 708708 : CPot%vtau(1:n)=SPot%vtau(1:n)
2466 708708 : CPot%ww(1:n)=SPot%ww(1:n)
2467 708708 : CPot%jj(1:n)=SPot%jj(1:n)
2468 354 : CPot%needvtau=SPot%needvtau
2469 354 : end subroutine CopyPot
2470 :
2471 :
2472 : !!!!!!!!!!!!!!!!!!!!!!!!!
2473 : ! InitSCF
2474 : !!!!!!!!!!!!!!!!!!!!!!!!!
2475 4 : subroutine InitSCF(SCF)
2476 : type(SCFInfo),intent(inout)::SCF
2477 4 : SCF%iter=0
2478 4 : SCF%delta=0._dp;SCF%eone=0._dp;SCF%ekin=0._dp;SCF%estatic=0._dp
2479 4 : SCF%ecoul=0._dp;SCF%eexc=0._dp;SCF%oepcs=0._dp;SCF%etot=0._dp
2480 4 : SCF%valekin=0._dp;SCF%valecoul=0._dp;SCF%valeexc=0._dp
2481 4 : SCF%corekin=0._dp;SCF%evale=0._dp
2482 : end subroutine InitSCF
2483 :
2484 :
2485 :
2486 :
2487 :
2488 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2489 : ! 3. ldagga_mod
2490 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2491 :
2492 :
2493 : !!!!!!!!!!!!!!!!!!!!!!!!!
2494 : ! LDAGGA_SCF
2495 : !!!!!!!!!!!!!!!!!!!!!!!!!
2496 23 : SUBROUTINE LDAGGA_SCF(atp)
2497 : TYPE(atompaw_type), INTENT(inout) :: atp
2498 : TYPE(Anderson_context):: AC
2499 : INTEGER :: n
2500 : real(dp) :: en1,etxc,eex,x,y
2501 : real(dp), ALLOCATABLE :: arg(:)
2502 : LOGICAL :: success
2503 : character(132):: exctypesave
2504 23 : n=atp%Grid%n
2505 69 : LIBPAW_ALLOCATE(arg,(n))
2506 23 : if(atp%needvtau) then ! first converge LDA
2507 0 : atp%needvtau=.false.
2508 0 : atp%Pot%needvtau=.false.
2509 0 : exctypesave=atp%exctype
2510 0 : atp%exctype="LDA-PW"
2511 0 : call initexch(atp)
2512 : CALL exch(atp%Grid,atp%Orbit%den,atp%Pot%rvx,etxc,eex,itype=atp%itype,&
2513 0 : & tau=atp%Orbit%tau,vtau=atp%Pot%vtau,xc_functionals=atp%xc_functionals)
2514 0 : arg=atp%Pot%rvh+atp%Pot%rvx ! iterating only on electronic part of pot
2515 0 : atp%Pot%rv=atp%Pot%rvh+atp%Pot%rvx-atp%Pot%rvx(1)
2516 0 : CALL zeropot(atp%Grid,atp%Pot%rv,atp%Pot%v0,atp%Pot%v0p)
2517 0 : atp%Pot%rv=atp%Pot%rv+atp%Pot%rvn+atp%Pot%rvx(1)
2518 0 : CALL InitAnderson_dr(AC,6,5,n,0.2_dp,1.d3,100,seterr,settoosmall,.true.)
2519 0 : CALL DoAndersonMix(AC,arg,en1,LDAGGAsub,success,atp)
2520 0 : if(has_to_print) WRITE(STD_OUT,*) 'Anderson Mix with LDA',AC%res ,' iter = ',AC%CurIter
2521 0 : CALL FreeAnderson(AC)
2522 0 : if(has_to_print) write(STD_OUT,*) 'Completed initial iteration '
2523 0 : atp%needvtau=.true.
2524 0 : atp%Pot%needvtau=.true.
2525 0 : atp%exctype=exctypesave
2526 0 : call initexch(atp)
2527 : endif
2528 : CALL exch(atp%Grid,atp%Orbit%den,atp%Pot%rvx,etxc,eex,itype=atp%itype,&
2529 : & needvtau=atp%Pot%needvtau,tau=atp%Orbit%tau,vtau=atp%Pot%vtau,&
2530 23 : & xc_functionals=atp%xc_functionals)
2531 46046 : atp%Pot%rv=atp%Pot%rvh+atp%Pot%rvx-atp%Pot%rvx(1)
2532 23 : CALL zeropot(atp%Grid,atp%Pot%rv,atp%Pot%v0,atp%Pot%v0p)
2533 46046 : atp%Pot%rv=atp%Pot%rv+atp%Pot%rvn+atp%Pot%rvx(1)
2534 23 : atp%SCF%iter=0
2535 23 : atp%SCF%delta=0
2536 23 : If (atp%needvtau) then
2537 0 : x=seterrmg; y=settoosmallmg
2538 : else
2539 23 : x=seterr; y=settoosmall
2540 : endif
2541 23 : CALL InitAnderson_dr(AC,6,5,n,0.6_dp,1.d3,MaxIter,x,y,has_to_print)
2542 23 : If (atp%needvtau) then
2543 0 : arg=atp%Orbit%den ! iterating on density
2544 0 : CALL DoAndersonMix(AC,arg,en1,DENITERsub,success,atp)
2545 : !!!! evaluate vxc and vtau on universal grid
2546 : !!!! because it may be bumpy at intermediate range from spline
2547 : !!!! evaluation
2548 : CALL exch(atp%Grid,atp%Orbit%den,atp%Pot%rvx,etxc,eex,itype=atp%itype,&
2549 0 : & tau=atp%Orbit%tau,vtau=atp%Pot%vtau)
2550 0 : atp%Pot%rv=atp%Pot%rvn+atp%Pot%rvh+atp%Pot%rvx
2551 : else
2552 46069 : arg=atp%Pot%rvh+atp%Pot%rvx
2553 23 : CALL DoAndersonMix(AC,arg,en1,LDAGGAsub,success,atp)
2554 : endif
2555 23 : atp%SCF%iter=AC%CurIter
2556 23 : atp%SCF%delta=AC%res
2557 23 : if(has_to_print) WRITE(STD_OUT,*) 'Anderson Mix ',success,AC%res ,' iter = ',AC%CurIter
2558 23 : if (AC%res>1._dp) then
2559 0 : LIBPAW_ERROR('Sadly the program has not converged, Consider trying splineinterp')
2560 : endif
2561 23 : CALL FreeAnderson(AC)
2562 23 : if(has_to_print) write(std_out,*) 'Finished Anderson Mix', en1 ,' success = ', success
2563 23 : LIBPAW_DEALLOCATE(arg)
2564 23 : END SUBROUTINE LDAGGA_SCF
2565 :
2566 :
2567 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2568 : !!!!! LDAGGASub
2569 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2570 354 : SUBROUTINE LDAGGASub(w,energy,residue,err,success,update,atp)
2571 : real(dp), INTENT(INOUT) :: w(:)
2572 : real(dp), INTENT(OUT) :: energy
2573 : real(dp), INTENT(OUT) :: residue(:)
2574 : real(dp), INTENT(OUT) :: err
2575 : LOGICAL, INTENT(OUT) :: success
2576 : LOGICAL, INTENT(IN) :: update
2577 : type(atompaw_type), intent(inout) :: atp
2578 : INTEGER :: i,j,n,io,nw
2579 354 : real(dp),ALLOCATABLE :: dum(:)
2580 : real(dp) :: x
2581 : TYPE (OrbitInfo) :: tmpOrbit
2582 354 : TYPE (PotentialInfo) :: tmpPot
2583 354 : n=atp%Grid%n
2584 354 : nw=SIZE(w)
2585 1062 : LIBPAW_ALLOCATE(dum,(nw))
2586 354 : CALL CopyOrbit(atp%Orbit,tmpOrbit)
2587 354 : CALL CopyPot(atp%Pot,tmpPot)
2588 354 : CALL Updatewfn(atp%Grid,tmpPot,tmpOrbit,w,success,atp%BDsolve,atp%usespline,atp%spline,atp%itype)
2589 354 : if(has_to_print) write(std_out,*) 'completed updatewfn with success ', success
2590 354 : If (.not.success) then ! attempt to stablize solution
2591 : !w=w+tmpPot%rvn
2592 17 : if(has_to_print) write(std_out,*) 'Current eigs', (atp%Orbit%eig(io),io=1,atp%Orbit%norbit)
2593 : j=n
2594 17 : x=atp%Orbit%eig(1)
2595 17 : if (atp%Orbit%norbit>1) then
2596 114 : do io = 2, atp%Orbit%norbit
2597 97 : if (atp%Orbit%eig(io)<0._dp.and.x<atp%Orbit%eig(io)) &
2598 70 : & x=atp%Orbit%eig(io)
2599 : enddo
2600 : endif
2601 17 : x=1._dp/sqrt(abs(x))
2602 17 : j=FindGridIndex(atp%Grid,x)
2603 17 : if(has_to_print) write(std_out,*) 'index', x,j,atp%Grid%r(j)
2604 17 : if (j<10)j=10
2605 17 : if (j>n-10) j=n-10
2606 17 : w(j+1)=(-1._dp+w(j+1)/2)
2607 15945 : do i=j+2,n
2608 15945 : w(i)=-2._dp
2609 : enddo
2610 17 : if(has_to_print) write(std_out,*) 'Reset tmpPot ', j
2611 17 : if(has_to_print) write(std_out,*) ' Last points '
2612 17 : if(has_to_print) write(std_out,'(1p,20e15.7)') atp%Grid%r(n),w(n)
2613 : !w=w-tmpPot%rvn
2614 17 : CALL Updatewfn(atp%Grid,tmpPot,tmpOrbit,w,success,atp%BDsolve,atp%usespline,atp%spline,atp%itype)
2615 17 : if(has_to_print) write(std_out,*) 'after updatwfn from reset ',success;
2616 : Endif
2617 354 : IF (.NOT.success) THEN
2618 0 : if(has_to_print) write(std_out,*) 'Bad luck in Sub'
2619 : ENDIF
2620 354 : CALL Get_KinCoul(atp%Grid,tmpPot,tmpOrbit,atp%SCF,atp%usespline)
2621 354 : CALL Get_EXC(atp,tmpPot,tmpOrbit)
2622 708708 : dum(1:n)=tmpPot%rvh(1:n)+tmpPot%rvx(1:n)-w(1:n)
2623 708708 : residue=dum
2624 708708 : err=Dot_Product(residue,residue)
2625 354 : energy=atp%SCF%etot
2626 354 : IF (update) THEN
2627 708708 : atp%Pot%rv=w+tmpPot%rvn
2628 708708 : atp%Pot%rvh=tmpPot%rvh
2629 708708 : atp%Pot%rvx=tmpPot%rvx
2630 354 : if (atp%needvtau) atp%Pot%vtau=tmpPot%vtau
2631 4354704 : atp%Orbit%wfn=tmpOrbit%wfn
2632 861214 : If(atp%diracrelativistic) atp%Orbit%lwfn=tmpOrbit%lwfn
2633 2529 : atp%Orbit%eig=tmpOrbit%eig
2634 708708 : atp%Orbit%den=tmpOrbit%den
2635 4354704 : atp%Orbit%otau=tmpOrbit%otau
2636 708708 : atp%Orbit%tau=tmpOrbit%tau
2637 708708 : atp%Orbit%deltatau=tmpOrbit%deltatau
2638 : ENDIF
2639 354 : CALL DestroyPot(tmpPot)
2640 354 : CALL DestroyOrbit(tmpOrbit)
2641 354 : LIBPAW_DEALLOCATE (dum)
2642 708 : END SUBROUTINE LDAGGASub
2643 :
2644 :
2645 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2646 : !!!! DENITERSub -- w is the electron density
2647 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2648 0 : SUBROUTINE DENITERSub(w,energy,residue,err,success,update,atp)
2649 : REAL(dp), INTENT(INOUT) :: w(:)
2650 : REAL(dp), INTENT(OUT) :: energy
2651 : REAL(dp), INTENT(OUT) :: residue(:)
2652 : REAL(dp), INTENT(OUT) :: err
2653 : type(atompaw_type), intent(inout) :: atp
2654 : LOGICAL, INTENT(OUT) :: success
2655 : LOGICAL, INTENT(IN) :: update
2656 : INTEGER :: n,nw
2657 0 : REAL(dp),ALLOCATABLE :: dum(:)
2658 : REAL(dp) :: x,y
2659 : TYPE (OrbitInfo) :: tmpOrbit
2660 0 : TYPE (PotentialInfo) :: tmpPot
2661 0 : n=atp%Grid%n
2662 0 : nw=SIZE(w)
2663 0 : if(n/=nw) then
2664 0 : write(std_out,*) 'problem in DENITERsub n,nw', n,nw
2665 0 : stop
2666 : endif
2667 0 : LIBPAW_ALLOCATE(dum,(nw))
2668 0 : CALL CopyOrbit(atp%Orbit,tmpOrbit)
2669 0 : CALL CopyPot(atp%Pot,tmpPot)
2670 : ! w enters subroutine as next iteration density
2671 : ! It needs to be renormalized
2672 : ! tmpPot%rvh, tmpPot%rvx, tmpPot%vtau need to be generated
2673 0 : x=integrator(atp%Grid,w)
2674 0 : if(has_to_print) write(std_out,*) 'In DENITERsub norm(m) adjust ', x,atp%Pot%q
2675 0 : w=w*tmpPot%q/x
2676 0 : call atompaw_poisson(atp%Grid,x,w,tmpPot%rvh,y)
2677 0 : if(has_to_print) write(std_out,*) 'after poisson q,ecoul ',x,y
2678 0 : call exch(atp%Grid,w,tmpPot%rvx,x,y,itype=atp%itype,tau=tmpOrbit%tau,vtau=tmpPot%vtau,xc_functionals=atp%xc_functionals)
2679 0 : if(has_to_print) write(std_out,*) 'after exch exvct, eexc ',x,y
2680 0 : tmpPot%rv=tmpPot%rvn+tmpPot%rvh+tmpPot%rvx
2681 0 : tmpOrbit%den=w
2682 0 : CALL Updatewfnwden(atp%Grid,tmpPot,tmpOrbit,success,atp%usespline,atp%spline,atp%itype)
2683 0 : if(has_to_print) write(std_out,*) 'completed updatewfnwden with success ', success
2684 0 : IF (.NOT.success) THEN
2685 0 : WRITE(STD_OUT,*) 'Bad luck in Sub'
2686 : ENDIF
2687 0 : CALL Get_KinCoul(atp%Grid,tmpPot,tmpOrbit,atp%SCF,atp%usespline)
2688 0 : if(has_to_print) write(std_out,*) 'Check tau ', integrator(atp%Grid,tmpOrbit%tau)
2689 0 : CALL Get_EXC(atp,tmpPot,tmpOrbit)
2690 0 : dum(1:n)=tmpOrbit%den(1:n)-w(1:n)
2691 0 : residue=dum
2692 0 : err=Dot_Product(residue,residue)
2693 0 : if(has_to_print) write(STD_OUT,*) 'in DENITERSub err ', err
2694 0 : energy=atp%SCF%etot
2695 0 : IF (update) THEN
2696 0 : atp%Pot%rv=tmpPot%rv
2697 0 : atp%Pot%rvh=tmpPot%rvh
2698 0 : atp%Pot%rvx=tmpPot%rvx
2699 0 : if (atp%needvtau) atp%Pot%vtau=tmpPot%vtau
2700 0 : atp%Orbit%wfn=tmpOrbit%wfn
2701 0 : If(atp%diracrelativistic)atp%Orbit%lwfn=tmpOrbit%lwfn
2702 0 : atp%Orbit%eig=tmpOrbit%eig
2703 0 : atp%Orbit%den=w
2704 0 : atp%Orbit%otau=tmpOrbit%otau
2705 0 : atp%Orbit%tau=tmpOrbit%tau
2706 0 : atp%Orbit%deltatau=tmpOrbit%deltatau
2707 : ENDIF
2708 0 : CALL DestroyOrbit(tmpOrbit)
2709 0 : CALL DestroyPot(tmpPot)
2710 0 : LIBPAW_DEALLOCATE(dum)
2711 0 : END SUBROUTINE DENITERSub
2712 :
2713 :
2714 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2715 : !! Get_EXC
2716 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2717 354 : SUBROUTINE Get_EXC(atp,Pot,Orbit)
2718 : ! program to calculate exc energy and potential
2719 : ! assumes Orbit%den already known
2720 : ! also assume kinetic and coulomb energies
2721 : ! calculated and stored in SCF
2722 : TYPE(Potentialinfo), INTENT(INOUT) :: Pot
2723 : TYPE(Orbitinfo), INTENT(INOUT) :: Orbit
2724 : TYPE(atompaw_type), INTENT(inout) :: atp
2725 : real(dp) :: eex,etot,etxc
2726 354 : real(dp), ALLOCATABLE :: dum(:)
2727 : INTEGER :: n,fin
2728 354 : n=atp%Grid%n
2729 354 : fin=atp%grid%n
2730 354 : if(atp%frozenvalecalculation) fin=atp%PAW%irc+5
2731 : CALL exch(atp%Grid,Orbit%den,Pot%rvx,etxc,eex,itype=atp%itype,&
2732 354 : & needvtau=Pot%needvtau,tau=Orbit%tau,vtau=Pot%vtau,fin=fin,xc_functionals=atp%xc_functionals)
2733 354 : atp%SCF%eexc=eex
2734 354 : etot = atp%SCF%ekin+atp%SCF%estatic+atp%SCF%eexc
2735 354 : atp%SCF%etot=etot
2736 354 : if(has_to_print) WRITE(STD_OUT,*) ' Total : ',etot
2737 1062 : LIBPAW_ALLOCATE(dum,(n))
2738 708708 : dum=0
2739 708354 : dum(2:n)=Pot%rvx(2:n)*Orbit%den(2:n)/atp%Grid%r(2:n)
2740 354 : if (Pot%needvtau) then
2741 0 : dum=dum+Orbit%tau*Pot%vtau !Kinetic energy correction
2742 : endif
2743 354 : if(has_to_print) then
2744 0 : WRITE(STD_OUT,*) ' Total (DC form) : ',&
2745 0 : & atp%SCF%eone-atp%SCF%ecoul+eex-integrator(atp%Grid,dum)
2746 : endif
2747 354 : LIBPAW_DEALLOCATE(dum)
2748 354 : END SUBROUTINE Get_EXC
2749 :
2750 :
2751 :
2752 :
2753 :
2754 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2755 : ! 4. excor
2756 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2757 :
2758 :
2759 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2760 : !! SUBROUTINE initexch(atp)
2761 : !! choose form of exchange-correlation potential
2762 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2763 4 : SUBROUTINE initexch(atp)
2764 : type(atompaw_type), intent(inout) :: atp
2765 : integer :: id(2),i_plus,ii
2766 : character*50 :: xcstrg(2)
2767 4 : CALL Uppercase(atp%exctype)
2768 4 : if(has_to_print) WRITE(STD_OUT,*) atp%exctype
2769 6 : SELECT CASE(TRIM(atp%exctype))
2770 : CASE default
2771 2 : atp%itype = LIBXC
2772 2 : i_plus=index(atp%exctype,'+')
2773 2 : if (i_plus<=0) then
2774 0 : xcstrg(1)=trim(atp%exctype)
2775 0 : xcstrg(2)=""
2776 : else
2777 2 : xcstrg(1)=trim(atp%exctype(1:i_plus-1))
2778 2 : xcstrg(2)=trim(atp%exctype(i_plus+1:))
2779 : end if
2780 6 : do ii=1,2
2781 6 : id(ii)=libxc_functionals_getid(xcstrg(ii))
2782 : enddo
2783 2 : atp%ixc=-(id(1)*1000+id(2))
2784 2 : if(has_to_print)WRITE(STD_OUT,*) 'Using Libxc --',TRIM(atp%exctype),atp%ixc
2785 2 : call libxc_functionals_init(atp%ixc,1,atp%xc_functionals,el_temp=zero)
2786 2 : if(atp%needvtau.and.(.not.libxc_functionals_ismgga(atp%xc_functionals))) then
2787 0 : WRITE(STD_OUT,*) 'Problem with XC functional choice -- need mgga form for vtau '
2788 0 : WRITE(STD_OUT,*) ' Program stopping '
2789 0 : stop
2790 : endif
2791 2 : write(std_out,*) 'END INITEXCH'
2792 : CASE('LDA-PW')
2793 0 : atp%itype = LDA_PW
2794 0 : if(has_to_print) WRITE(STD_OUT,*) 'Perdew-Wang correlation'
2795 : CASE('GGA-PBE')
2796 2 : atp%itype = GGA_PBE
2797 2 : if(has_to_print) WRITE(STD_OUT,*) 'Perdew-Burke-Ernzerhof GGA'
2798 : CASE('GGA-PBESOL')
2799 0 : atp%itype = GGA_PBESOL
2800 0 : if(has_to_print) WRITE(STD_OUT,*) 'Perdew-Burke-Ernzerhof modified (PBEsol) GGA'
2801 : CASE ('MGGA-R2SCAN-001')
2802 0 : atp%itype = MGGA_R2SCAN_001
2803 0 : if(has_to_print) WRITE(STD_OUT,*) 'R2SCAN MGGA with eta=0.001'
2804 0 : call r2scaninit(0.001_dp)
2805 0 : atp%needvtau=.true.
2806 : CASE ('MGGA-R2SCAN-01')
2807 0 : atp%itype = MGGA_R2SCAN_01
2808 0 : if(has_to_print) WRITE(STD_OUT,*) 'R2SCAN MGGA with eta=0.01'
2809 0 : call r2scaninit(0.01_dp)
2810 4 : atp%needvtau=.true.
2811 : !CASE ('HF')
2812 : ! itype = NO_XC
2813 : ! WRITE(STD_OUT,*) 'No XC'
2814 : END SELECT
2815 4 : END SUBROUTINE initexch
2816 :
2817 :
2818 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2819 : !! Logofterm
2820 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2821 712964 : FUNCTION Logofterm(term)
2822 : real(dp) :: term, Logofterm
2823 712964 : IF (ABS(term)>machine_precision) THEN
2824 706094 : Logofterm=ddlog(1._dp+term)
2825 : ELSE
2826 : Logofterm=term
2827 : ENDIF
2828 : RETURN
2829 : END FUNCTION Logofterm
2830 :
2831 :
2832 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2833 : ! Subroutine radialexcpbe
2834 : ! Density(:) input on a uniform radial mesh of Npts
2835 : ! Grid%r(:) input mesh points
2836 : ! Exc - output integrated exchange correlation energy -- in Rydberg units
2837 : ! vxc(:) -- output exchange correlation potential -- in Rydberg units
2838 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2839 230 : SUBROUTINE radialexcpbe(Grid,density,Exc,vxc,mu,beta,fin)
2840 : IMPLICIT NONE
2841 : TYPE (GridInfo), INTENT(IN) :: Grid
2842 : real(dp), intent(in) :: mu,beta
2843 : REAL(dp), INTENT(IN) :: density(:)
2844 : REAL(dp), INTENT(OUT) :: Exc, vxc(:)
2845 : INTEGER, INTENT(IN), OPTIONAL :: fin
2846 : INTEGER :: i,Npts
2847 230 : REAL(dp),ALLOCATABLE :: gradient(:),gradmag(:),gxc(:),dgxcdr(:),fxc(:)
2848 : REAL(dp) :: dfxcdn,dfxcdgbg
2849 230 : Npts=Grid%n
2850 230 : IF (PRESENT(fin)) Npts=fin
2851 690 : LIBPAW_ALLOCATE(gradient,(Npts))
2852 460 : LIBPAW_ALLOCATE(gradmag,(Npts))
2853 460 : LIBPAW_ALLOCATE(gxc,(Npts))
2854 460 : LIBPAW_ALLOCATE(dgxcdr,(Npts))
2855 460 : LIBPAW_ALLOCATE(fxc,(Npts))
2856 230 : CALL derivative(Grid,density(1:Npts),gradient(1:Npts),1,Npts)
2857 362680 : gradmag=ABS(gradient)
2858 362450 : DO i=1,Npts
2859 362220 : CALL pbefunc(density(i),gradmag(i),fxc(i),dfxcdn,dfxcdgbg,mu,beta)
2860 362220 : vxc(i)=dfxcdn
2861 362450 : gxc(i)=dfxcdgbg*gradient(i)
2862 : ENDDO
2863 230 : CALL derivative(Grid,gxc(1:Npts),dgxcdr(1:Npts),1,Npts)
2864 362220 : DO i=2,Npts
2865 361990 : fxc(i)=2*fxc(i)*4*pi*(Grid%r(i)**2) !2* changes from Har to Ryd
2866 362220 : vxc(i)=2*vxc(i)-2*dgxcdr(i)-4*gxc(i)/Grid%r(i) ! Correction thanks
2867 : ! to Marc Torrent and Francois Jollet
2868 : ENDDO
2869 230 : fxc(1)=zero
2870 230 : CALL extrapolate(vxc)
2871 230 : Exc = integrator(Grid,fxc,1,Npts)
2872 230 : LIBPAW_DEALLOCATE(gradient)
2873 230 : LIBPAW_DEALLOCATE(gradmag)
2874 230 : LIBPAW_DEALLOCATE(gxc)
2875 230 : LIBPAW_DEALLOCATE(dgxcdr)
2876 230 : LIBPAW_DEALLOCATE(fxc)
2877 230 : RETURN
2878 : END SUBROUTINE radialexcpbe
2879 :
2880 :
2881 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2882 : !! exch
2883 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2884 377 : SUBROUTINE exch(Grid,den,rvxc,etxc,eexc,itype,fin,v0,v0p,needvtau,tau,vtau,xc_functionals)
2885 : ! calculate exchange correlation potentials and energies
2886 : ! for density functional theory from electron density
2887 : ! den(n) is electron density * (4*pi*r**2)
2888 : ! rvxc(n) is returned as vxc * r
2889 : ! eexc is the total exchange energy (int(den*exc))
2890 : ! etxc is eexc - int(den*vxc)
2891 : ! icx id of the exchange-correlation functional
2892 : ! xclevel level of the exchange-correlation functional used
2893 : ! fin (optional) is integer range of densities and potentials
2894 : ! v0 (optional) is extrapolated value of vxc for r=0
2895 : ! v0p (optional) is extrapolated value of dvxc/dr for r=0
2896 : ! needvtau (optional) is logical .true. if mgga
2897 : ! tau(n) (optional) is kinetic energy density * (4*pi*r**2)
2898 : ! vtau(n) (optional) is kinetic energy contribution for mgga
2899 : TYPE (GridInfo), INTENT(IN) :: Grid
2900 : REAL(dp), INTENT(IN) :: den(:)
2901 : REAL(dp), INTENT(INOUT) :: rvxc(:),etxc,eexc
2902 : type(libxc_functional_type),intent(inout),optional :: xc_functionals(2)
2903 : integer, intent(in) :: itype
2904 : INTEGER, INTENT(IN), OPTIONAL :: fin
2905 : REAL(dp), INTENT(OUT), OPTIONAL :: v0,v0p
2906 : LOGICAL, INTENT(OUT), OPTIONAL :: needvtau
2907 : REAL(dp), INTENT(IN),OPTIONAL :: tau(:)
2908 : REAL(dp), INTENT(INOUT),OPTIONAL :: vtau(:)
2909 377 : REAL(dp), ALLOCATABLE :: tmpd(:),tmpv(:),dum(:)
2910 377 : REAL(dp), ALLOCATABLE :: exci(:),dfxcdgbg(:,:),gxc(:),dgxcdr(:)
2911 377 : REAL(dp), ALLOCATABLE :: grad(:),gradmag(:),dum1(:),sigma(:),tmpvt(:)
2912 377 : REAL(dp), ALLOCATABLE :: tmpt(:),tmpl(:),dgxcdl(:),dexcdn(:),dexcds(:)
2913 : REAL(dp) :: fpi,beta,mu
2914 : INTEGER :: i,n,order,nspden,ndvxc,nd2vxc
2915 : REAL(dp) :: r,r2,exc,vxc
2916 377 : n=Grid%n
2917 377 : IF (PRESENT(fin)) n=fin
2918 : fpi=four*pi
2919 754754 : rvxc=0;etxc=0;eexc=0
2920 377 : if (PRESENT(v0)) v0=0
2921 377 : if (PRESENT(v0p)) v0p=0
2922 377 : if (PRESENT(needvtau)) then
2923 377 : if (needvtau.and.(PRESENT(vtau).eqv..false.)) then
2924 0 : if(has_to_print) write(std_out,*) 'exch: Inconsistency in mgga ', needvtau,PRESENT(vtau)
2925 0 : LIBPAW_ERROR('exch: stopping execution ')
2926 : endif
2927 : endif
2928 754754 : if (PRESENT(vtau)) vtau=0._dp
2929 377 : If (itype==GGA_PBE.or.itype==GGA_PBESOL) then
2930 690 : LIBPAW_ALLOCATE(tmpd,(n))
2931 460 : LIBPAW_ALLOCATE(tmpv,(n))
2932 362450 : tmpd=zero
2933 230 : if(itype==GGA_PBE) then
2934 230 : mu=muorig;beta=betorig
2935 : else
2936 0 : mu=musol;beta=betsol
2937 : endif
2938 362220 : DO i=2,n
2939 362220 : tmpd(i)=den(i)/(fpi*(Grid%r(i)**2))
2940 : ENDDO
2941 230 : CALL extrapolate(tmpd)
2942 230 : IF (PRESENT(fin)) THEN
2943 216 : CALL radialexcpbe(Grid,tmpd,eexc,tmpv,mu,beta,fin)
2944 : ELSE
2945 14 : CALL radialexcpbe(Grid,tmpd,eexc,tmpv,mu,beta)
2946 : ENDIF
2947 230 : IF (PRESENT(v0).AND.PRESENT(v0p)) THEN
2948 0 : CALL derivative(Grid,tmpv,tmpd,1,15)
2949 0 : v0=tmpv(1)
2950 0 : v0p=tmpd(1)
2951 : ENDIF
2952 362450 : DO i=1,n
2953 362220 : rvxc(i)=tmpv(i)*Grid%r(i)
2954 362450 : tmpv(i)=tmpv(i)*den(i)
2955 : ENDDO
2956 230 : etxc=eexc-integrator(Grid,tmpv(1:n),1,n)
2957 230 : LIBPAW_DEALLOCATE(tmpd)
2958 230 : LIBPAW_DEALLOCATE(tmpv)
2959 147 : ELSE IF (itype==LDA_PW) then !!! ! Perdew-Wang LDA !!!!
2960 0 : LIBPAW_ALLOCATE(tmpd,(n))
2961 0 : LIBPAW_ALLOCATE(tmpv,(n))
2962 0 : LIBPAW_ALLOCATE(dum,(n))
2963 0 : tmpd=0;tmpv=0;rvxc=0;dum=0
2964 0 : DO i=2,n
2965 0 : r=Grid%r(i)
2966 0 : r2=r*r
2967 0 : tmpd(i)=den(i)/(fpi*r2)
2968 : ENDDO
2969 0 : CALL extrapolate(tmpd)
2970 0 : DO i=1,n
2971 0 : CALL pwldafunc(tmpd(i),exc,vxc)
2972 0 : tmpd(i)=den(i)*(exc-vxc)
2973 0 : tmpv(i)=den(i)*exc
2974 0 : rvxc(i)=Grid%r(i)*vxc
2975 0 : IF (PRESENT(v0).AND.PRESENT(v0p)) THEN
2976 0 : IF (i==1) v0=vxc
2977 0 : dum(i)=vxc
2978 : ENDIF
2979 : ENDDO
2980 0 : etxc=integrator(Grid,tmpd(1:n),1,n)
2981 0 : eexc=integrator(Grid,tmpv(1:n),1,n)
2982 0 : IF (PRESENT(v0).AND.PRESENT(v0p)) THEN
2983 0 : CALL derivative(Grid,dum,tmpd,1,15)
2984 0 : v0p=tmpd(1)
2985 : ENDIF
2986 0 : LIBPAW_DEALLOCATE(tmpd)
2987 0 : LIBPAW_DEALLOCATE(tmpv)
2988 0 : LIBPAW_DEALLOCATE(dum)
2989 147 : ELSE IF (itype==MGGA_R2SCAN_001.or.itype==MGGA_R2SCAN_01) then !!r2scan
2990 0 : LIBPAW_ALLOCATE(tmpd,(n))
2991 0 : LIBPAW_ALLOCATE(tmpv,(n))
2992 0 : LIBPAW_ALLOCATE(exci,(n))
2993 0 : LIBPAW_ALLOCATE(tmpt,(n))
2994 0 : LIBPAW_ALLOCATE(dum,(n))
2995 0 : LIBPAW_ALLOCATE(dum1,(n))
2996 0 : tmpd=0._dp; tmpv=0._dp; exci=0._dp;tmpt=0._dp
2997 0 : dum1=0._dp
2998 0 : tmpd(2:n)=den(2:n)/(fpi*(Grid%r(2:n)**2))
2999 0 : call extrapolate(tmpd)
3000 0 : LIBPAW_ALLOCATE(grad,(n))
3001 0 : LIBPAW_ALLOCATE(sigma,(n))
3002 0 : LIBPAW_ALLOCATE(dexcdn,(n))
3003 0 : LIBPAW_ALLOCATE(dexcds,(n))
3004 0 : grad=0._dp;sigma=0._dp;dexcdn=0._dp;dexcds=0._dp
3005 0 : do i=1,n
3006 0 : dum1(i)=ddlog(tmpd(i))
3007 : enddo
3008 0 : call derivative(Grid,dum1,grad,1,n)
3009 0 : grad(1:n)=grad(1:n)*tmpd(1:n) ! perhaps more accurate???
3010 0 : sigma=grad**2
3011 : ! Prepare kinetic energy input tau -- used for most mgga
3012 0 : tmpt(2:n)=tau(2:n)/(fpi*(Grid%r(2:n)**2))
3013 0 : call extrapolate(tmpt)
3014 : ! convert to Hartree units
3015 0 : tmpt=0.5_dp*tmpt
3016 0 : do i=1,n
3017 : call r2scanfun(tmpd(i),grad(i),tmpt(i),&
3018 0 : & exci(i),vtau(i),dexcdn(i),dexcds(i))
3019 : enddo
3020 : ! convert to Rydberg units
3021 0 : exci=two*exci
3022 0 : dexcdn=two*dexcdn
3023 0 : dexcds=four*dexcds !extra factor of two due to sigma=grad**2
3024 0 : rvxc=0._dp
3025 0 : rvxc=dexcdn
3026 0 : dum(1:n)=dexcds(1:n)
3027 0 : call derivative(Grid,dum,dum1,1,n)
3028 0 : dum(2:n)=two*dum(2:n)/(Grid%r(2:n))
3029 0 : call extrapolate(dum)
3030 0 : rvxc=rvxc-dum1-dum
3031 0 : dum(1:n)=exci(1:n)*fpi*(Grid%r(1:n)**2)
3032 0 : eexc=integrator(Grid,dum(1:n),1,n)
3033 0 : dum(1:n)=rvxc(1:n)*den(1:n)
3034 0 : etxc=eexc-integrator(Grid,dum(1:n),1,n)
3035 0 : rvxc(1:n)=(dexcdn(1:n)-dum1(1:n))*Grid%r(1:n)-two*dexcds(1:n)
3036 0 : LIBPAW_DEALLOCATE(grad)
3037 0 : LIBPAW_DEALLOCATE(sigma)
3038 0 : LIBPAW_DEALLOCATE(dexcdn)
3039 0 : LIBPAW_DEALLOCATE(dexcds)
3040 0 : LIBPAW_DEALLOCATE(tmpd)
3041 0 : LIBPAW_DEALLOCATE(tmpv)
3042 0 : LIBPAW_DEALLOCATE(exci)
3043 0 : LIBPAW_DEALLOCATE(tmpt)
3044 0 : LIBPAW_DEALLOCATE(dum)
3045 0 : LIBPAW_DEALLOCATE(dum1)
3046 147 : ELSE IF (itype==LIBXC) then
3047 : ! Parameters
3048 147 : if(.not.libxc_functionals_islda(xc_functionals).and..not.libxc_functionals_isgga(xc_functionals)) then
3049 0 : STOP
3050 : endif
3051 147 : order=1
3052 147 : nspden=1
3053 147 : ndvxc=0
3054 147 : nd2vxc=0
3055 : ! Allocations
3056 441 : LIBPAW_ALLOCATE(tmpd,(n))
3057 294 : LIBPAW_ALLOCATE(tmpv,(n))
3058 294 : LIBPAW_ALLOCATE(exci,(n))
3059 294 : LIBPAW_ALLOCATE(tmpt,(n))
3060 294 : LIBPAW_ALLOCATE(grad,(n))
3061 294 : LIBPAW_ALLOCATE(gradmag,(n))
3062 294 : LIBPAW_ALLOCATE(gxc,(n))
3063 294 : LIBPAW_ALLOCATE(dgxcdr,(n))
3064 441 : LIBPAW_ALLOCATE(dfxcdgbg,(n,3))
3065 294 : LIBPAW_ALLOCATE(tmpl,(n))
3066 294 : LIBPAW_ALLOCATE(dgxcdl,(n))
3067 294 : LIBPAW_ALLOCATE(tmpvt,(n))
3068 294 : LIBPAW_ALLOCATE(dum,(n))
3069 294 : LIBPAW_ALLOCATE(dum1,(n))
3070 1016855 : tmpd=0._dp; tmpv=0._dp; exci=0._dp;tmpt=0._dp
3071 1779827 : grad=0._dp;gradmag=0._dp;gxc=0._dp;dgxcdr=0._dp;dfxcdgbg=0._dp
3072 1271032 : tmpl=0._dp; dgxcdl=0._dp;tmpvt=0._dp;dum=0._dp;dum1=0._dp
3073 : ! Density
3074 254177 : tmpd(2:n)=den(2:n)/(fpi*(Grid%r(2:n)**2))
3075 147 : call extrapolate(tmpd)
3076 : ! Grad
3077 254324 : tmpv=0._dp
3078 254324 : do i=1,n
3079 254324 : tmpv(i)=ddlog(tmpd(i))
3080 : enddo
3081 147 : call derivative(Grid,tmpv,grad,1,n)
3082 254324 : grad(1:n)=grad(1:n)*tmpd(1:n) ! perhaps more accurate???
3083 254324 : tmpv=0._dp
3084 254471 : gradmag=ABS(grad)*ABS(grad)
3085 : ! Tau
3086 254177 : tmpt(2:n)=tau(2:n)/(fpi*(Grid%r(2:n)**2))
3087 147 : call extrapolate(tmpt)
3088 : ! Laplacian
3089 147 : call derivative(Grid,grad,tmpl,1,n)
3090 254177 : tmpl(2:n)=tmpl(2:n)+2._dp*grad(2:n)/Grid%r(2:n)
3091 147 : call extrapolate(tmpl)
3092 : ! calc
3093 254324 : tmpd=tmpd/two
3094 254324 : gradmag=gradmag/four
3095 : call libxc_functionals_getvxc(ndvxc,nd2vxc,n,nspden,order,tmpd,exci,tmpv,&
3096 : & grho2=gradmag,lrho=tmpl,vxcgr=dfxcdgbg,vxclrho=dgxcdl,tau=tmpt,vxctau=tmpvt,&
3097 147 : & xc_functionals=xc_functionals)
3098 254324 : tmpd=tmpd*two
3099 254324 : gradmag=gradmag*four
3100 : ! Units
3101 254324 : exci=two*exci
3102 254324 : tmpv=two*tmpv
3103 763119 : dfxcdgbg=dfxcdgbg*two
3104 : ! Post-process
3105 254324 : gxc(1:n)=dfxcdgbg(1:n,3)*grad(1:n)
3106 147 : call derivative(Grid,gxc,dgxcdr,1,n)
3107 254177 : tmpv(2:n)=tmpv(2:n)-dgxcdr(2:n)-2._dp*gxc(2:n)/Grid%r(2:n)
3108 147 : call extrapolate(tmpv)
3109 : ! dum=0._dp
3110 : ! call derivative(Grid,dgxcdl,dum,1,n)
3111 : ! dum1=0._dp
3112 : ! call derivative(Grid,dum,dum1,1,n)
3113 : ! tmpv(2:n)=tmpv(2:n)+dum1(2:n)+2._dp*dum(2:n)/Grid%r(2:n)
3114 : ! call extrapolate(tmpv)
3115 : ! if (needvtau) vtau=tmpvt
3116 254324 : do i=1,n
3117 254177 : if (.not.ieee_is_normal(tmpv(i)).or.abs(tmpv(i)).lt.practical_zero) tmpv(i)=0._dp
3118 254177 : if (.not.ieee_is_normal(exci(i)).or.abs(exci(i)).lt.practical_zero)exci(i)=0._dp
3119 254177 : if (.not.ieee_is_normal(vtau(i)).or.abs(vtau(i)).lt.practical_zero)vtau(i)=0._dp
3120 254324 : if (.not.ieee_is_normal(tmpd(i)).or.abs(tmpd(i)).lt.practical_zero)tmpd(i)=0._dp
3121 : enddo
3122 294294 : rvxc=0._dp
3123 254324 : rvxc(1:n)=tmpv(1:n)*Grid%r(1:n)
3124 254324 : exci(1:n)=exci(1:n)*tmpd(1:n)*fpi*Grid%r(1:n)**2
3125 147 : eexc=integrator(Grid,exci,1,n)
3126 147 : if (present(v0).and.present(v0p)) then
3127 0 : call derivative(Grid,tmpv,tmpd,1,15)
3128 0 : v0=tmpv(1);v0p=tmpd(1)
3129 : endif
3130 254324 : tmpv(1:n)=tmpv(1:n)*den(1:n)
3131 147 : etxc=eexc-integrator(Grid,tmpv(1:n),1,n)
3132 147 : if(has_to_print) WRITE(STD_OUT,*) 'etxc,eexc = ',etxc,eexc
3133 : ! DEALLOCATE
3134 147 : LIBPAW_DEALLOCATE(tmpd)
3135 147 : LIBPAW_DEALLOCATE(tmpv)
3136 147 : LIBPAW_DEALLOCATE(exci)
3137 147 : LIBPAW_DEALLOCATE(tmpt)
3138 147 : LIBPAW_DEALLOCATE(grad)
3139 147 : LIBPAW_DEALLOCATE(gradmag)
3140 147 : LIBPAW_DEALLOCATE(gxc)
3141 147 : LIBPAW_DEALLOCATE(dgxcdr)
3142 147 : LIBPAW_DEALLOCATE(dfxcdgbg)
3143 147 : LIBPAW_DEALLOCATE(tmpl)
3144 147 : LIBPAW_DEALLOCATE(dgxcdl)
3145 147 : LIBPAW_DEALLOCATE(tmpvt)
3146 147 : LIBPAW_DEALLOCATE(dum)
3147 147 : LIBPAW_DEALLOCATE(dum1)
3148 : else
3149 0 : WRITE(STD_OUT,*) 'Warning (EXCOR): ', itype,' no results returned !'
3150 0 : STOP
3151 : END if
3152 377 : END SUBROUTINE exch
3153 :
3154 :
3155 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3156 : !! pwldafunc
3157 : !! Subroutine to calculate the LDA exchange correlation functionals
3158 : !! using the form of Perdew and Wang (PRB 45, 13244 (1992)
3159 : !! assuming no spin polarization
3160 : !! Inside this routine, energies are in Hartree units
3161 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3162 0 : SUBROUTINE pwldafunc(den,exc,vxc)
3163 : real(dp), INTENT(IN) :: den !density
3164 : real(dp), INTENT(OUT) :: exc,vxc
3165 : real(dp), PARAMETER :: AA=0.0310907_dp
3166 : real(dp), PARAMETER :: a1=0.21370_dp
3167 : real(dp), PARAMETER :: b1=7.59570_dp
3168 : real(dp), PARAMETER :: b2=3.58760_dp
3169 : real(dp), PARAMETER :: b3=1.63820_dp
3170 : real(dp), PARAMETER :: b4=0.49294_dp
3171 : ! Variables depending on den
3172 : real(dp) :: n,kf,rs,ks
3173 : real(dp) :: ex,ec,pprs,decdrs
3174 : real(dp) :: term
3175 0 : n=den
3176 0 : IF (n < machine_zero) THEN
3177 0 : exc=0._dp; vxc=0._dp
3178 0 : RETURN
3179 : ENDIF
3180 0 : kf=(3._dp*(pi**2)*n)**0.3333333333333333333333333333_dp
3181 0 : rs=(3._dp/(4._dp*pi*n))**0.3333333333333333333333333333_dp
3182 : ks=SQRT(4._dp*kf/pi)
3183 0 : ex=-3._dp*kf/(4._dp*pi)
3184 0 : pprs=SQRT(rs)*(b1+b3*rs)+rs*(b2+b4*rs)
3185 0 : term=Logofterm(1._dp/(2._dp*AA*pprs))
3186 0 : ec=-2._dp*AA*(1._dp+a1*rs)*term
3187 0 : exc=ex+ec
3188 : decdrs=-(2._dp*AA*a1)*term &
3189 : & +((1._dp+a1*rs)*((b1+3*b3*rs)/(2._dp*SQRT(rs))+&
3190 0 : & b2+2*b4*rs))/(pprs*(pprs+1._dp/(2._dp*AA)))
3191 0 : vxc = (4._dp/3._dp)*ex+ec-(decdrs*rs)/3._dp
3192 0 : IF ((ABS(exc).GT.1.d65).OR.(ABS(vxc).GT.1.d65)) THEN
3193 0 : if(has_to_print) WRITE(STD_OUT,*) 'Problem in PW',n,rs,ec
3194 : ENDIF
3195 0 : exc=2*exc; vxc=2*vxc ! change to Rydberg units
3196 0 : RETURN
3197 : END SUBROUTINE pwldafunc
3198 :
3199 :
3200 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3201 : ! Subroutine to calculate the exchange correlation functionals
3202 : ! using the form of Perdew, Burke, and Ernzerhof (PRL 77, 3865 (1996))
3203 : ! assuming no spin polarization
3204 : ! Inside this routine, energies are in Hartree units
3205 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3206 362220 : SUBROUTINE pbefunc(den,grad,fxc,dfxcdn,dfxcdgbg,mu,beta)
3207 : REAL(dp), INTENT(IN) :: den,grad,mu,beta !density, magnitude of grad(density)
3208 : REAL(dp), INTENT(OUT) :: fxc,dfxcdn,dfxcdgbg
3209 : REAL(dp) :: n,g,kf,rs,ks,s,t,betabygamm
3210 : REAL(dp) :: ex,ec,Fx,H,A,pprs,ppt,At2,dFds,dHdt,decdrs,dHdrs,dHdA,dAdrs
3211 : REAL(dp) :: term,dHdtbg,dFdsbg
3212 362220 : betabygamm=beta/gamm
3213 362220 : n=den
3214 362220 : IF (n < machine_zero) THEN
3215 5738 : fxc=0.0_dp; dfxcdn=0.0_dp; dfxcdgbg=0.0_dp
3216 5738 : RETURN
3217 : ENDIF
3218 356482 : g=grad
3219 356482 : IF (g < machine_zero) g=machine_zero
3220 356482 : kf=(3.0_dp*(pi**2)*n)**0.3333333333333333333333333333_dp
3221 356482 : rs=(3.0_dp/(4.0_dp*pi*n))**0.3333333333333333333333333333_dp
3222 356482 : ks=SQRT(4.0_dp*kf/pi)
3223 356482 : s=g/(2.0_dp*kf*n)
3224 356482 : t=g/(2.0_dp*ks*n)
3225 356482 : IF (s*s > machine_infinity .or. t*t > machine_infinity) THEN
3226 0 : fxc=0.0_dp; dfxcdn=0.0_dp; dfxcdgbg=0.0_dp
3227 0 : RETURN
3228 : ENDIF
3229 356482 : ex=-3.0_dp*kf/(4.0_dp*pi)
3230 356482 : pprs=SQRT(rs)*(b1+b3*rs)+rs*(b2+b4*rs)
3231 356482 : term=Logofterm(1.0_dp/(2.0_dp*AA*pprs))
3232 356482 : ec=-2.0_dp*AA*(1.0_dp+a1*rs)*term
3233 356482 : Fx=1.0_dp+kappa -kappa/(1.0_dp+(mu/kappa)*s*s)
3234 356482 : A=Aofec(ec,betabygamm,beta)
3235 356482 : At2=A*t*t
3236 356482 : ppt=(1.0_dp+At2*(1.0_dp+At2))
3237 356482 : H=gamm*Logofterm((betabygamm)*(t*t)*((1._dp+At2)/ppt))
3238 356482 : fxc=n*(ex*Fx+ec+H)
3239 356482 : dFds = (2.0_dp*mu*s)/(1.0_dp+(mu/kappa)*(s**2))**2
3240 356482 : dFdsbg = ((2.0_dp*mu)/(1.0_dp+(mu/kappa)*(s**2))**2)/(2._dp*kf*n)
3241 : dHdt = (2._dp*t*beta*gamm*(1._dp+2._dp*At2))/&
3242 356482 : & ((gamm*ppt+beta*t*t*(1._dp+At2))*ppt)
3243 : dHdtbg = ((2._dp*beta*gamm*(1._dp+ &
3244 356482 : & 2._dp*At2))/((gamm*ppt+beta*t*t*(1._dp+At2))*ppt))/(2._dp*ks*n)
3245 : decdrs=-(2._dp*AA*a1)*term &
3246 : & +((1._dp+a1*rs)*((b1+3*b3*rs)/(2._dp*SQRT(rs))+ &
3247 356482 : & b2+2*b4*rs))/(pprs*(pprs+1._dp/(2._dp*AA)))
3248 : dHdA=((2._dp+At2)*(At2*t*t*t*t*beta*gamm))/&
3249 356482 : & ((gamm*ppt+beta*t*t*(1._dp+At2))*ppt)
3250 356482 : dAdrs=-ddexp(-ec/gamm)*A*A*decdrs/beta
3251 356482 : dHdrs=dHdA*dAdrs
3252 : dfxcdn = (4._dp/3._dp)*ex*(Fx-dFds*s)+ec-(decdrs*rs)/3._dp+H-(dHdrs*rs)/3._dp &
3253 356482 : & - (7._dp/6._dp)*dHdt*t
3254 356482 : dfxcdgbg = ex*dFdsbg/(2._dp*kf) + dHdtbg/(2._dp*ks)
3255 356482 : IF ((ABS(fxc).GT.1.d65).OR.(ABS(dfxcdn).GT.1.d65).OR.&
3256 : & (ABS(dfxcdgbg).GT.1.d65)) THEN
3257 0 : if(has_to_print) WRITE(STD_OUT,*) 'Problem in PBE',n,g,rs,s,t,ec,A,H
3258 : ENDIF
3259 : RETURN
3260 : END SUBROUTINE pbefunc
3261 :
3262 :
3263 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3264 : !! Function Aofec -- needed to take care of behavior for small ec
3265 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3266 356482 : FUNCTION Aofec(ec,betabygamm,beta)
3267 : REAL(dp) :: ec, Aofec, betabygamm,beta
3268 356482 : IF (ABS(ec)>machine_precision) THEN
3269 354797 : Aofec=betabygamm/(ddexp(-ec/gamm)-1.0_dp)
3270 1685 : ELSEIF (ABS(ec)>machine_zero) THEN
3271 1685 : Aofec=beta/(-ec)
3272 : ELSE
3273 0 : Aofec=-beta*DSIGN(machine_infinity,ec)
3274 : ENDIF
3275 : RETURN
3276 : END FUNCTION Aofec
3277 :
3278 :
3279 :
3280 :
3281 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3282 : ! 5. r2scan
3283 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3284 :
3285 :
3286 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3287 : !! r2scaninit
3288 : !!
3289 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3290 0 : SUBROUTINE r2scaninit(etain)
3291 : REAL(dp), INTENT(IN) :: etain
3292 : REAL(dp) :: o
3293 0 : if(has_to_print) write(std_out,*) 'r2scan calculation with eta ', etain
3294 0 : eta=etain
3295 0 : o=cx1+two*cx2+three*cx3+four*cx4+five*cx5+six*cx6+seven*cx7
3296 0 : if(has_to_print) write(std_out,*) 'r2scan check C2' , o*k0
3297 0 : C2Ceta = (20.0_dp/27.0_dp + (5*eta)/three)*o*k0
3298 0 : END SUBROUTINE r2scaninit
3299 :
3300 :
3301 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3302 : !! r2scan functional
3303 : !! length units == Bohr
3304 : !! energy units -- Hartree
3305 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3306 0 : SUBROUTINE r2scanfun(rho,grad,tau,exc,vtau,vxcn,vxcs)
3307 : REAL(dp), INTENT(IN) :: rho,grad, tau
3308 : REAL(dp), INTENT(INOUT) :: exc,vtau,vxcn,vxcs
3309 : REAL(dp) :: rr,ss,tt,sigma
3310 : REAL(dp) :: kF,ks,rs,U,s,p,t,W,baralpha
3311 : REAL(dp) :: gx,x,h0x,h1x,fx,ffx,exarg,ddfx,vxtau,ex,vx
3312 : REAL(dp) :: ELDA,ELDA0,fc,ddfc,w1,w0,ginfinity,H0c,H1c,ec0,ec1,y
3313 : REAL(dp) :: beta,srs,ddLDA,difddLDA,gg,corarg,ddy,vctau
3314 : REAL(dp) :: alphadenom,dalphadn,dalphads
3315 : REAL(dp) :: gxp,dpdn,dgxdn,dpds,dgxds,drsdn,dt2ds,dt2dn,t2
3316 : REAL(dp) :: h1xx,xp,dh1xdn,dh1xds,vxn,vxs
3317 : REAL(dp) :: vcn,vcs,dLDA0dn,dH0cdn,dw0dn,dgindn,dw1dn
3318 : REAL(dp) :: dH0cds,dginds,dbetadn,dif2ddLDA,dLDAdn
3319 : REAL(dp) :: pp,dppds,dppdn,dyds,dydn,dUdn,dWds,dWdn
3320 : REAL(dp) :: term1,term4,dddyds,dddydnp,dddydnw,dddydnr,dH1cds
3321 : REAL(dp) :: stf1,stf2,stf3,stf4,stf5,stf6,stf7
3322 : REAL(dp) :: dddydnn,dddydn,dH1cdwn,dH1cdn,dec1dn,dec1ds
3323 : REAL(dp) :: dec0ds,dec0dn,bigdenom
3324 : REAL(dp) :: eex,eec,vtx,vtc,vvxn,vvcn,vvxs,vvcs
3325 0 : eex=0._dp;eec=0._dp;vtx=0._dp;vtc=0._dp;vvxn=0._dp;vvcn=0._dp;vvxs=0._dp;vvcs=0._dp
3326 0 : if(rho<(machine_zero**0.333333333333333333333333333333333_dp)) return
3327 0 : sigma=grad*grad
3328 0 : rr=rho;ss=sigma;tt=tau
3329 0 : rr=max(machine_zero,rr)
3330 0 : rr=min(machine_infinity,rr)
3331 0 : ss=max(machine_zero,ss)
3332 0 : ss=min(machine_infinity,ss)
3333 0 : tt=max(machine_zero,tt)
3334 0 : tt=min(machine_infinity,tt)
3335 : ! Note that all derivatives with respect to sigma are also multiplied
3336 : ! by grad
3337 0 : kF=3.0936677262801359310_dp*(rr**0.33333333333333333333333333333_dp)
3338 0 : ks=1.9846863952198559283_dp*(rr**0.16666666666666666666666666667_dp)
3339 0 : rs=0.62035049089940001665_dp/(rr**0.33333333333333333333333333333_dp)
3340 0 : drsdn=-rs/(3*rr)
3341 0 : srs=sqrt(rs)
3342 0 : U=2.8712340001881918160_dp*(rr**1.66666666666666666666666666667_dp)
3343 0 : dUdn=(1.666666666666666666666667_dp)*2.8712340001881918160_dp*(rr**0.66666666666666666666666666667_dp)
3344 0 : s=sqrt(ss)*0.16162045967399548133_dp/(rr**1.33333333333333333333333333333_dp)
3345 0 : p=s*s
3346 0 : dpdn=-2.666666666666666666666666667_dp*p/rr
3347 0 : dpds=0.026121172985233599568_dp*grad/(rr**2.666666666666666666666666666666667_dp)
3348 0 : t=sqrt(ss)*0.25192897034224488769_dp/(rr**1.166666666666666666666666666667_dp)
3349 0 : t2=t*t
3350 0 : dt2ds=0.063468206097703704205_dp*grad/(rr**2.3333333333333333333333333333_dp)
3351 0 : dt2dn=-t2*(2.333333333333333333333333333333333333_dp)/rr
3352 0 : W=0.125_dp*ss/rr
3353 0 : dWds=0.125_dp*grad/rr
3354 0 : dWdn=-W/rr
3355 0 : baralpha=(tt-W)/(U+eta*W)
3356 : !!!!!!exchange part
3357 0 : gx=1._dp-ddexp(-SCANa1/(p**0.25_dp))
3358 0 : x=(c2ceta*ddexp(-(p**2)/dp2**4)+mu)*p
3359 0 : xp=c2ceta*ddexp(-(p**2)/dp2**4)*(-2*(p**2)/dp2**4+1._dp)+mu
3360 0 : h0x=1+k0
3361 0 : h1x=1._dp+k1-k1/(1+x/k1)
3362 0 : if(baralpha<1.d-13) then
3363 0 : fx=ddexp(-SCANc1x*baralpha/(1._dp-baralpha))
3364 0 : elseif (baralpha.lt.2.5_dp) then
3365 : fx=cx0+baralpha*(cx1+baralpha*(cx2+baralpha*(cx3+baralpha*( &
3366 0 : & cx4+baralpha*(cx5+baralpha*(cx6+baralpha*cx7))))))
3367 0 : else if (baralpha.ge.2.5_dp) then
3368 0 : fx=-SCANdx*ddexp(SCANc2x/(1._dp-baralpha))
3369 : endif
3370 0 : if(baralpha<1.d-13) then
3371 0 : ddfx=-(SCANc1x/((1._dp-baralpha)**2))*ddexp(-SCANc1x*baralpha/(1._dp-baralpha))
3372 0 : else if (baralpha.lt.2.5_dp) then
3373 : ddfx=(cx1+baralpha*(2*cx2+baralpha*(3*cx3+baralpha*( &
3374 0 : & 4*cx4+baralpha*(5*cx5+baralpha*(6*cx6+baralpha*7*cx7))))))
3375 0 : else if (baralpha.ge.2.5_dp) then
3376 0 : ddfx=-(SCANdx*SCANc2x/((1._dp-baralpha)**2))*ddexp(SCANc2x/(1._dp-baralpha))
3377 : endif
3378 0 : ffx=(h1x+fx*(h0x-h1x))*gx
3379 0 : ex=-0.73855876638202240587_dp*(rr**1.3333333333333333333333333333333333_dp)
3380 0 : vx=-0.98474502184269654116_dp*(rr**0.3333333333333333333333333333333333_dp)
3381 0 : exarg=ex*ffx
3382 0 : vxtau=ex*ddfx*((h0x-h1x)*gx)/(U+eta*W)
3383 : ! density and sigma derivative terms
3384 0 : alphadenom=(U+eta*W)**2
3385 0 : dalphads=-(U+eta*tau)*dWds/alphadenom
3386 0 : dalphadn=-((U+eta*tau)*dWdn+(tt-W)*dUdn)/alphadenom
3387 0 : gxp=-0.25_dp*SCANa1*ddexp(-SCANa1/(p**0.25_dp))/(p**1.25_dp)
3388 0 : dgxdn=gxp*dpdn
3389 0 : dgxds=gxp*dpds
3390 0 : h1xx=1._dp/((1._dp+x/k1)**2)
3391 0 : dh1xdn=h1xx*xp*dpdn
3392 0 : dh1xds=h1xx*xp*dpds
3393 : vxn=vx*ffx+ex*(ddfx*dalphadn*gx*(h0x-h1x)+dgxdn*(h1x+fx*(h0x-h1x)) &
3394 0 : & +gx*dh1xdn*(1._dp-fx))
3395 : vxs=ex*(ddfx*dalphads*gx*(h0x-h1x)+dgxds*(h1x+fx*(h0x-h1x)) &
3396 0 : & +gx*dh1xds*(1._dp-fx))
3397 : !!!! correlation part
3398 : ELDA=-two*LDAA*(1._dp + LDAa1*rs)*ddlog(1._dp + 0.5_dp &
3399 0 : & /(LDAA*(sqrt(rs)*(LDAb1 + LDAb3*rs) + rs*(LDAb2 + LDAb4*rs))))
3400 0 : bigdenom=srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)
3401 : dLDAdn=((-two*LDAA*LDAa1*ddlog(1._dp + &
3402 : & 1._dp/(two*LDAA*bigdenom))) &
3403 : & + (LDAa1*rs + 1._dp)*((LDAb3*rs + LDAb1)/(two*srs) + srs*LDAb3 + &
3404 0 : & two*LDAb4*rs + LDAb2)/((bigdenom**2)+bigdenom/(two*LDAA)))*drsdn
3405 0 : ELDA0= -b1c/(1._dp + b2c*sqrt(rs) + b3c*rs)
3406 : dLDA0dn=b1c*(0.5_dp*b2c/sqrt(rs)+b3c)/((1._dp + b2c*sqrt(rs) + b3c*rs)**2) &
3407 0 : & *drsdn
3408 0 : ddLDA=ELDA0-ELDA
3409 0 : beta= betaMB*(1._dp + 0.1*rs)/(1._dp + 0.1778_dp*rs)
3410 0 : dbetadn=-(0.0778_dp*betaMB/(1._dp + 0.1778_dp*rs)**2)*drsdn
3411 0 : if(baralpha<1.d-13) then
3412 0 : fc=ddexp(-SCANc1c*baralpha/(1._dp-baralpha))
3413 0 : else if (baralpha.lt.2.5_dp) then
3414 : fc=cc0+baralpha*(cc1+baralpha*(cc2+baralpha*(cc3+baralpha*( &
3415 0 : & cc4+baralpha*(cc5+baralpha*(cc6+baralpha*cc7))))))
3416 0 : else if (baralpha.ge.2.5_dp) then
3417 0 : fc=-SCANdc*ddexp(SCANc2c/(1._dp-baralpha))
3418 : endif
3419 0 : if(baralpha<1.d-13) then
3420 0 : ddfc=-(SCANc1c/((1._dp-baralpha)**2))*ddexp(-SCANc1c*baralpha/(1._dp-baralpha))
3421 0 : else if (baralpha.lt.2.5_dp) then
3422 : ddfc=(cc1+baralpha*(2*cc2+baralpha*(3*cc3+baralpha*( &
3423 0 : & 4*cc4+baralpha*(5*cc5+baralpha*(6*cc6+baralpha*7*cc7))))))
3424 0 : else if (baralpha.ge.2.5_dp) then
3425 0 : ddfc=-(SCANdc*SCANc2c/((1._dp-baralpha)**2))*ddexp(SCANc2c/(1._dp-baralpha))
3426 : endif
3427 0 : w1= ddexp(-ELDA/Sgam) - 1._dp
3428 0 : dw1dn=-(ddexp(-ELDA/Sgam)/Sgam)*dLDAdn
3429 0 : w0= ddexp(-ELDA0/b1c) - 1._dp
3430 0 : dw0dn=-(ddexp(-ELDA0/b1c)/b1c)*dLDA0dn
3431 0 : ginfinity= 1._dp/(1._dp + 4*chiinfinity*(p))**0.25_dp
3432 0 : dgindn=-(chiinfinity*ginfinity/(1._dp + four*chiinfinity*(p)))*dpdn
3433 0 : dginds=-(chiinfinity*ginfinity/(1._dp + four*chiinfinity*(p)))*dpds
3434 0 : H0c= b1c*ddlog(1._dp + w0*(1._dp - ginfinity))
3435 0 : dH0cdn=(b1c/(1._dp+w0*(1._dp-ginfinity)))*((1._dp-ginfinity)*dw0dn-w0*dgindn)
3436 0 : dH0cds=(-b1c*w0*dginds/(1._dp+w0*(1._dp-ginfinity)))
3437 0 : ec0= ELDA0 + H0c
3438 0 : dec0dn=dLDA0dn+dH0cdn
3439 0 : dec0ds=dH0cds
3440 : difddLDA=b1c*(b2c/(two*srs) + b3c)/(1._dp + b2c*srs + b3c*rs)**2 + &
3441 : & two*LDAA*LDAa1*ddlog(1._dp + &
3442 : & 1._dp/(2*LDAA*(srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)))) &
3443 : & - (LDAa1*rs + 1._dp)*((LDAb3*rs + LDAb1)/(two*srs) + srs*LDAb3 + &
3444 : & two*LDAb4*rs + LDAb2)/(((srs*(LDAb3*rs + LDAb1) + &
3445 : & rs*(LDAb4*rs + LDAb2))**2)*(1._dp + 1._dp &
3446 0 : & /(two*LDAA*(srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)))))
3447 0 : y=beta*(t2)/(Sgam*w1)
3448 0 : dyds=beta*dt2ds/(Sgam*w1)
3449 0 : dydn=(1._dp/(Sgam*w1))*(dbetadn*t2+beta*dt2dn-beta*t2*dw1dn/w1)
3450 : ddy=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*p&
3451 0 : & *ddexp(-(p**2)/(dp2**4))
3452 0 : gg=1._dp/(1._dp+4*(y-ddy))**0.25_dp
3453 0 : H1c=Sgam*ddlog(1._dp+w1*(1._dp-gg))
3454 0 : ec1=ELDA+H1c
3455 0 : pp=p*ddexp(-(p**2)/(dp2**4))
3456 0 : dppds=((ddexp(-p**2/dp2**4))*(dp2**4 - two*p**2)/dp2**4)*dpds
3457 0 : dppdn=((ddexp(-p**2/dp2**4))*(dp2**4 - two*p**2)/dp2**4)*dpdn
3458 0 : term1=1._dp+4*(y-ddy)
3459 0 : term4=term1**0.25_dp
3460 0 : dddyds=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*dppds
3461 0 : dddydnp=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*dppdn
3462 0 : dddydnw=-(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*difddLDA-45.0_dp*eta*ddLDA)*pp*dw1dn/w1
3463 0 : dddydnr=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*difddLDA)*pp*drsdn
3464 0 : dH1cds=(Sgam*w1/(term1*(term4*(1._dp+w1)-w1)))*(dyds-dddyds)
3465 : stf1=-b1c*(8.0_dp*srs*rs*(b3c**2) + 9.0_dp*b2c*b3c*rs + 3.0_dp*srs*(b2c**2) + b2c)&
3466 0 : & /(4.0_dp*rs*srs*((1._dp + b2c*srs + b3c*rs)**3))
3467 0 : stf2=srs*(LDAb3*rs + LDAb1) + rs*(LDAb4*rs + LDAb2)
3468 0 : stf3=1._dp+1._dp/(2*LDAA*stf2)
3469 : stf4=(two*LDAa1*((LDAb3*rs+LDAb1)/(two*srs)+srs*LDAb3+two*LDAb4*rs+LDAb2)) &
3470 0 : & /((stf2**2)*stf3)
3471 : stf5=(two*(LDAa1*rs+1._dp)*(((LDAb3*rs+LDAb1)/(two*srs)+srs*LDAb3+ &
3472 0 : & two*LDAb4*rs + LDAb2)**2))/((stf2**3)*stf3)
3473 : stf6=(LDAa1*rs+1._dp)*(-(LDAb3*rs+LDAb1)/(four*srs*rs)+LDAb3/srs + two*LDAb4) &
3474 0 : & /((stf2**2)*stf3)
3475 : stf7=(LDAa1*rs+1._dp)*&
3476 : & (((LDAb3*rs+LDAb1)/(two*srs)+srs*LDAb3+two*LDAb4*rs+LDAb2)**2) &
3477 0 : & /(two*LDAA*(stf2**4)*(stf3**2))
3478 0 : dif2ddLDA=stf1-stf4+stf5-stf6-stf7
3479 0 : dddydnn=(Dfc2/(27.0_dp*Sgam*w1))*(20.0_dp*rs*dif2ddLDA-45.0_dp*eta*difddLDA)*pp*drsdn
3480 0 : dddydn=dddydnw+dddydnp+dddydnr+dddydnn
3481 0 : dH1cdwn=Sgam*((term4-1._dp)/(term4*(w1+1._dp)-w1))*dw1dn
3482 0 : dH1cdn=dH1cdwn+(Sgam*w1/(term1*(term4*(1._dp+w1)-w1)))*(dydn-dddydn)
3483 0 : dec1dn=dLDAdn+dH1cdn
3484 0 : dec1ds=dH1cds
3485 0 : corarg=rr*(ec1 + fc*(ec0 - ec1))
3486 0 : vctau=rr*ddfc*(ec0 - ec1)/(U + eta*W)
3487 : ! density and sigma derivative terms
3488 0 : vcn=ec1+fc*(ec0-ec1)+ddfc*dalphadn*rr*(ec0-ec1)+dec0dn*rr*fc+dec1dn*rr*(1._dp-fc)
3489 0 : vcs=ddfc*dalphads*rr*(ec0-ec1)+dec0ds*rr*fc+dec1ds*rr*(1._dp-fc)
3490 0 : eex=exarg;eec=corarg; exc=exarg+corarg
3491 0 : vtx=vxtau;vtc=vctau; vtau=vxtau+vctau
3492 0 : vvxn=vxn; vvcn=vcn; vxcn=vxn+vcn
3493 0 : vvxs=vxs; vvcs=vcs; vxcs=vxs+vcs
3494 : END SUBROUTINE r2scanfun
3495 :
3496 :
3497 :
3498 :
3499 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3500 : ! 5. general_mod
3501 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3502 :
3503 :
3504 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3505 : !! Updatewfn(Grid,Pot,Orbit,rvin,success)
3506 : !! Given new potential rvin, generate new Orbit%wfn,Orbit%eig,Pot%den
3507 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3508 371 : SUBROUTINE Updatewfn(Grid,Pot,Orbit,rvin,success,BDsolve,usespline,spline,itype)
3509 : ! TODO : BDsolve
3510 : logical,intent(in) :: usespline
3511 : integer, intent(in) :: itype
3512 : TYPE (GridInfo), INTENT(INOUT) :: Grid
3513 : TYPE (PotentialInfo), INTENT(INOUT) :: Pot
3514 : TYPE (OrbitInfo), INTENT(INOUT) :: Orbit
3515 : type(splinesolvinfo),intent(inout) :: spline
3516 : logical, intent(in) :: bdsolve
3517 : real(dp), INTENT(IN) :: rvin(:)
3518 : LOGICAL :: success,calc_s,calc_p,calc_d,calc_f,calc_g
3519 : INTEGER :: icount,n,it,start,ierr,nroot,s1,s2,s2t
3520 : INTEGER :: io,l,jierr,nz,kappa
3521 : real(dp) :: h,emin,zz
3522 : real(dp), ALLOCATABLE :: dum(:)
3523 : LOGICAL :: OK
3524 371 : n=Grid%n; h=Grid%h; nz=Pot%nz; zz=Pot%zz
3525 371 : success=.TRUE.
3526 1113 : LIBPAW_ALLOCATE(dum,(n))
3527 742742 : Pot%rv=rvin+Pot%rvn(1:n)
3528 743113 : dum=rvin
3529 371 : if (Pot%needvtau) dum(1)=dum(1)-Pot%rvx(1)
3530 371 : CALL zeropot(Grid,dum,Pot%v0,Pot%v0p)
3531 371 : IF (ABS(Pot%v0)> 1.d6) Pot%v0=0
3532 371 : IF (ABS(Pot%v0p)> 1.d6) Pot%v0p=0
3533 371 : IF (Pot%finitenucleus) then
3534 0 : Pot%v0=Pot%v0+Pot%Nv0
3535 0 : Pot%v0p=Pot%v0p+Pot%Nv0p
3536 : Endif
3537 371 : if(usespline) call initpotforsplinesolver(Grid,Pot,Orbit%den,Orbit%tau,spline,itype)
3538 : ! solve for bound states of Schroedinger equation
3539 371 : calc_s=.true.
3540 371 : calc_p=.true.
3541 371 : calc_d=.true.
3542 371 : calc_f=.true.
3543 371 : calc_g=.true.
3544 371 : icount=0
3545 371 : jierr=0
3546 371 : it=0
3547 : ! s states :
3548 371 : IF (Orbit%nps.GT.0) THEN
3549 371 : it=it+1
3550 371 : emin=-nz*nz-0.1_dp
3551 371 : l=0
3552 371 : nroot=Orbit%nps
3553 371 : start=1;s1=start;s2t=start+nroot-1
3554 371 : if (Orbit%frozenvalecalculation) then
3555 235 : nroot=Orbit%npsc
3556 540 : do io=s1+Orbit%npsc,s2t
3557 540 : if(Orbit%issemicore(io)) nroot=nroot+1
3558 : enddo
3559 235 : if(nroot.LT.1) calc_s=.false.
3560 : endif
3561 742 : s2=s1+nroot-1
3562 : if(calc_s) then
3563 371 : IF (Orbit%scalarrelativistic) THEN
3564 : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3565 102 : & l,nroot,emin,ierr,OK)
3566 269 : ELSE IF (Orbit%diracrelativistic) THEN
3567 46 : kappa=-1
3568 : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3569 46 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3570 223 : ELSE IF (Pot%needvtau) THEN
3571 : Call Boundsplinesolver(Grid,l,nroot, &
3572 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3573 : ELSE
3574 223 : if(usespline) then
3575 : Call Boundsplinesolver(Grid,l,nroot, &
3576 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3577 : else
3578 : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3579 223 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3580 : endif
3581 : ENDIF
3582 371 : IF (.NOT.OK) THEN
3583 2 : success=.FALSE.
3584 : ENDIF
3585 : endif
3586 : ENDIF
3587 : ! p states :
3588 371 : IF (Orbit%npp.GT.1) then
3589 371 : it=it+1
3590 371 : emin=-nz*nz/4._dp-0.5_dp
3591 371 : l=1
3592 371 : nroot=Orbit%npp-1
3593 371 : s1=s2t+1;s2t=s1+nroot-1
3594 371 : if (Orbit%frozenvalecalculation) then
3595 235 : nroot=Orbit%nppc-1
3596 470 : do io=s1+Orbit%nppc-1,s2t
3597 470 : if(Orbit%issemicore(io)) nroot=nroot+1
3598 : enddo
3599 235 : if(nroot.LT.1) calc_p=.false.
3600 : endif
3601 371 : s2=s1+nroot-1
3602 371 : if(calc_p) then
3603 371 : IF (Orbit%scalarrelativistic) THEN
3604 : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3605 102 : & l,nroot,emin,ierr,OK)
3606 269 : ELSE IF (Orbit%diracrelativistic) THEN
3607 46 : kappa=1
3608 : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3609 46 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3610 46 : s1=s2t+1;s2=s1+nroot-1
3611 46 : kappa=-2
3612 46 : emin=-nz*nz/4._dp-0.5_dp
3613 : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3614 46 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3615 46 : nroot=Orbit%npp-1
3616 46 : s2t=s1+nroot-1
3617 223 : ELSE IF (Pot%needvtau) THEN
3618 : Call Boundsplinesolver(Grid,l,nroot, &
3619 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3620 : ELSE
3621 223 : if(usespline) then
3622 : Call Boundsplinesolver(Grid,l,nroot, &
3623 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3624 : else
3625 : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3626 223 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3627 : endif
3628 : ENDIF
3629 371 : IF (.NOT.OK) THEN
3630 9 : success=.FALSE.
3631 : ENDIF
3632 : endif
3633 : ENDIF
3634 : ! d states :
3635 371 : IF (Orbit%npd.GT.2) THEN
3636 148 : it=it+1
3637 148 : emin=-nz*nz/9._dp-0.5_dp
3638 148 : l=2
3639 148 : nroot=Orbit%npd-2
3640 148 : s1=s2t+1;s2t=s1+nroot-1
3641 148 : if (Orbit%frozenvalecalculation) then
3642 70 : nroot=Orbit%npdc-2
3643 140 : do io=s1+Orbit%npdc-2,s2t
3644 140 : if(Orbit%issemicore(io)) nroot=nroot+1
3645 : enddo
3646 70 : if(nroot.LT.1) calc_d=.false.
3647 : endif
3648 148 : s2=s1+nroot-1
3649 148 : if(calc_d) then
3650 78 : IF (Orbit%scalarrelativistic) THEN
3651 : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3652 44 : & l,nroot,emin,ierr,OK)
3653 34 : ELSE IF (Orbit%diracrelativistic) THEN
3654 34 : kappa=2
3655 : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3656 34 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3657 34 : kappa=-3
3658 34 : s1=s2t+1;s2=s1+nroot-1
3659 34 : emin=-nz*nz/9._dp-0.5_dp
3660 : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3661 34 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3662 34 : nroot=Orbit%npd-1
3663 34 : s2t=s1+nroot-1
3664 0 : ELSE IF (Pot%needvtau) THEN
3665 : Call Boundsplinesolver(Grid,l,nroot, &
3666 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3667 : ELSE! CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3668 0 : if(usespline) then
3669 : Call Boundsplinesolver(Grid,l,nroot, &
3670 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3671 : else
3672 : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3673 0 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3674 : endif
3675 : ENDIF
3676 78 : IF (.NOT.OK) THEN
3677 10 : success=.FALSE.
3678 : ENDIF
3679 : endif
3680 : ENDIF
3681 : ! f states :
3682 371 : IF (Orbit%npf.GT.3) THEN
3683 0 : it=it+1
3684 0 : emin=-nz*nz/16._dp-0.5_dp
3685 0 : l=3
3686 0 : nroot=Orbit%npf-3
3687 0 : s1=s2t+1;s2t=s1+nroot-1
3688 0 : if (Orbit%frozenvalecalculation) then
3689 0 : nroot=Orbit%npfc-3
3690 0 : do io=s1+Orbit%npfc-3,s2t
3691 0 : if(Orbit%issemicore(io)) nroot=nroot+1
3692 : enddo
3693 0 : if(nroot.LT.1) calc_f=.false.
3694 : endif
3695 0 : s2=s1+nroot-1
3696 0 : if (calc_f) then
3697 0 : IF (Orbit%scalarrelativistic) THEN
3698 : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3699 0 : & l,nroot,emin,ierr,OK)
3700 0 : ELSE IF (Orbit%diracrelativistic) THEN
3701 0 : kappa=3
3702 : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3703 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3704 0 : kappa=-4
3705 0 : s1=s2t+1;s2=s1+nroot-1
3706 0 : emin=-nz*nz/16._dp-0.5_dp
3707 : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3708 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3709 0 : nroot=Orbit%npf-1
3710 0 : s2t=s1+nroot-1
3711 0 : ELSE IF (Pot%needvtau) THEN
3712 : Call Boundsplinesolver(Grid,l,nroot, &
3713 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3714 : ELSE
3715 0 : if(usespline) then
3716 : Call Boundsplinesolver(Grid,l,nroot, &
3717 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3718 : else
3719 : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3720 0 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3721 : endif
3722 : ENDIF
3723 0 : IF (.NOT.OK) THEN
3724 0 : success=.FALSE.
3725 : ENDIF
3726 : endif
3727 : ENDIF
3728 : ! g states :
3729 371 : IF (Orbit%npg.GT.4) THEN
3730 0 : it=it+1
3731 0 : emin=-nz*nz/25._dp-0.5_dp
3732 0 : l=4
3733 0 : nroot=Orbit%npg-4
3734 0 : s1=s2t+1;s2t=s1+nroot-1
3735 0 : if (Orbit%frozenvalecalculation) then
3736 0 : nroot=Orbit%npgc-4
3737 0 : do io=s1+Orbit%npgc-4,s2t
3738 0 : if(Orbit%issemicore(io)) nroot=nroot+1
3739 : enddo
3740 0 : if(nroot.LT.1) calc_g=.false.
3741 : endif
3742 0 : s2=s1+nroot-1
3743 0 : if(calc_g) then
3744 0 : IF (Orbit%scalarrelativistic) THEN
3745 : Call Boundsr(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3746 0 : & l,nroot,emin,ierr,OK)
3747 0 : ELSE IF (Orbit%diracrelativistic) THEN
3748 0 : kappa=4
3749 : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3750 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3751 0 : kappa=-5
3752 0 : s1=s2t+1;s2=s1+nroot-1
3753 0 : emin=-nz*nz/25._dp-0.5_dp
3754 : Call BoundD(Grid,Pot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),&
3755 0 : & Orbit%lwfn(:,s1:s2),kappa,nroot,emin,ierr,OK)
3756 0 : nroot=Orbit%npg-1
3757 0 : s2t=s1+nroot-1
3758 0 : ELSE IF (Pot%needvtau) THEN
3759 : Call Boundsplinesolver(Grid,l,nroot, &
3760 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3761 : ELSE
3762 0 : if(usespline) then
3763 : Call Boundsplinesolver(Grid,l,nroot, &
3764 0 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3765 : else
3766 : CALL BoundNumerov(Grid,Pot%rv,Pot%v0,Pot%v0p,Pot%nz,&
3767 0 : & l,nroot,Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),BDsolve,OK)
3768 : endif
3769 : ENDIF
3770 0 : IF (.NOT.OK) THEN
3771 0 : success=.FALSE.
3772 : ENDIF
3773 : endif
3774 : ENDIF
3775 : !Update otau according to wfn
3776 2660 : DO io=1,Orbit%norbit
3777 2289 : IF(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
3778 : CALL taufromwfn(Orbit%otau(:,io),Grid,Orbit%wfn(:,io),Orbit%l(io), &
3779 2660 : & energy=Orbit%eig(io),rPot=Pot%rv)
3780 : ENDDO
3781 371 : LIBPAW_DEALLOCATE(dum)
3782 371 : END SUBROUTINE Updatewfn
3783 :
3784 :
3785 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3786 : !! SUBROUTINE Updatewfnwden(Grid,Pot,Orbit,w,success)
3787 : !! Given new den and consistent Pot%rv
3788 : !! generate new Orbit%wfn,Orbit%eig,Orbit%otau
3789 : !! Orbit%den=w on input
3790 : !! only splinesolver works for now
3791 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3792 0 : SUBROUTINE Updatewfnwden(Grid,Pot,Orbit,success,usespline,spline,itype)
3793 : integer, intent(in) :: itype
3794 : type(splinesolvinfo),intent(inout) :: spline
3795 : TYPE (GridInfo), INTENT(INOUT) :: Grid
3796 : TYPE (PotentialInfo), INTENT(INOUT) :: Pot
3797 : TYPE (OrbitInfo), INTENT(INOUT) :: Orbit
3798 : LOGICAL,intent(inout) :: success
3799 : LOGICAL,intent(in) :: usespline
3800 : INTEGER :: icount,n,it,start,nroot,s1,s2,s2t
3801 : INTEGER :: io,l,jierr,nz
3802 : LOGICAL :: calc_s,calc_p,calc_d,calc_f,calc_g
3803 : REAL(dp) :: h,emin,zz
3804 0 : REAL(dp), ALLOCATABLE :: dum(:)
3805 : LOGICAL :: OK
3806 : !!!since programmed only for splinesolver case, check
3807 0 : If (Orbit%scalarrelativistic.or.Orbit%diracrelativistic) then
3808 0 : write(std_out,*) 'Program Updatewfnwden not written '
3809 0 : write(std_out,*) ' for relativistic solver -- error stop '
3810 0 : stop
3811 : ENDIF
3812 0 : If (.not.usespline) THEN
3813 0 : write(std_out,*) 'Program Updatewfnwden only written '
3814 0 : write(std_out,*) ' for usespline case -- error stop '
3815 0 : stop
3816 : ENDIF
3817 0 : n=Grid%n; h=Grid%h; nz=Pot%nz; zz=Pot%zz
3818 0 : success=.TRUE.
3819 0 : LIBPAW_ALLOCATE(dum,(n))
3820 0 : call initpotforsplinesolver(Grid,Pot,Orbit%den,Orbit%tau,spline,itype)
3821 : ! solve for bound states of Schroedinger equation
3822 0 : icount=0
3823 0 : jierr=0
3824 0 : it=0
3825 : ! s states :
3826 0 : IF (Orbit%nps.GT.0) THEN
3827 : it=it+1
3828 : emin=-nz*nz-0.1_dp
3829 : l=0
3830 : nroot=Orbit%nps
3831 : start=1;s1=start;s2t=start+nroot-1
3832 : if (Orbit%frozenvalecalculation) then
3833 : nroot=Orbit%npsc
3834 : do io=s1+Orbit%npsc,s2t
3835 : if(Orbit%issemicore(io)) nroot=nroot+1
3836 : enddo
3837 : if(nroot.LT.1) calc_s=.false.
3838 : endif
3839 : s2=s1+nroot-1
3840 : if(calc_s) then
3841 : Call Boundsplinesolver(Grid,l,nroot, &
3842 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3843 : IF (.NOT.OK) THEN
3844 : success=.FALSE.
3845 : ENDIF
3846 : endif
3847 : ENDIF
3848 : ! p states :
3849 0 : IF (Orbit%npp.GT.1) then
3850 : it=it+1
3851 : emin=-nz*nz/4._dp-0.5_dp
3852 : l=1
3853 : nroot=Orbit%npp-1
3854 : s1=s2t+1;s2t=s1+nroot-1
3855 : if (Orbit%frozenvalecalculation) then
3856 : nroot=Orbit%nppc-1
3857 : do io=s1+Orbit%nppc-1,s2t
3858 : if(Orbit%issemicore(io)) nroot=nroot+1
3859 : enddo
3860 : if(nroot.LT.1) calc_p=.false.
3861 : endif
3862 : s2=s1+nroot-1
3863 : if(calc_p) then
3864 : Call Boundsplinesolver(Grid,l,nroot, &
3865 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3866 : IF (.NOT.OK) THEN
3867 : success=.FALSE.
3868 : ENDIF
3869 : endif
3870 : ENDIF
3871 : ! d states :
3872 0 : IF (Orbit%npd.GT.2) THEN
3873 : it=it+1
3874 : emin=-nz*nz/9._dp-0.5_dp
3875 : l=2
3876 : nroot=Orbit%npd-2
3877 : s1=s2t+1;s2t=s1+nroot-1
3878 : if (Orbit%frozenvalecalculation) then
3879 : nroot=Orbit%npdc-2
3880 : do io=s1+Orbit%npdc-2,s2t
3881 : if(Orbit%issemicore(io)) nroot=nroot+1
3882 : enddo
3883 : if(nroot.LT.1) calc_d=.false.
3884 : endif
3885 : s2=s1+nroot-1
3886 : if(calc_d) then
3887 : Call Boundsplinesolver(Grid,l,nroot, &
3888 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3889 : IF (.NOT.OK) THEN
3890 : success=.FALSE.
3891 : ENDIF
3892 : endif
3893 : ENDIF
3894 : ! f states :
3895 0 : IF (Orbit%npf.GT.3) THEN
3896 : it=it+1
3897 : emin=-nz*nz/16._dp-0.5_dp
3898 : l=3
3899 : nroot=Orbit%npf-3
3900 : s1=s2t+1;s2t=s1+nroot-1
3901 : if (Orbit%frozenvalecalculation) then
3902 : nroot=Orbit%npfc-3
3903 : do io=s1+Orbit%npfc-3,s2t
3904 : if(Orbit%issemicore(io)) nroot=nroot+1
3905 : enddo
3906 : if(nroot.LT.1) calc_f=.false.
3907 : endif
3908 : s2=s1+nroot-1
3909 : if (calc_f) then
3910 : Call Boundsplinesolver(Grid,l,nroot, &
3911 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3912 : IF (.NOT.OK) THEN
3913 : success=.FALSE.
3914 : ENDIF
3915 : endif
3916 : ENDIF
3917 : ! g states :
3918 0 : IF (Orbit%npg.GT.4) THEN
3919 : it=it+1
3920 : emin=-nz*nz/25._dp-0.5_dp
3921 : l=4
3922 : nroot=Orbit%npg-4
3923 : s1=s2t+1;s2t=s1+nroot-1
3924 : if (Orbit%frozenvalecalculation) then
3925 : nroot=Orbit%npgc-4
3926 : do io=s1+Orbit%npgc-4,s2t
3927 : if(Orbit%issemicore(io)) nroot=nroot+1
3928 : enddo
3929 : if(nroot.LT.1) calc_g=.false.
3930 : endif
3931 : s2=s1+nroot-1
3932 : if(calc_g) then
3933 : Call Boundsplinesolver(Grid,l,nroot, &
3934 : & Orbit%eig(s1:s2),Orbit%wfn(:,s1:s2),Orbit%otau(:,s1:s2),OK,spline)
3935 : IF (.NOT.OK) THEN
3936 : success=.FALSE.
3937 : ENDIF
3938 : endif
3939 : ENDIF
3940 0 : LIBPAW_DEALLOCATE(dum)
3941 0 : END SUBROUTINE Updatewfnwden
3942 :
3943 :
3944 :
3945 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3946 : !! Get_KinCoul
3947 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3948 354 : SUBROUTINE Get_KinCoul(Grid,Pot,Orbit,SCF,usespline,noalt)
3949 : ! program to calculate Kinetic energy and Coulomb Energies from Orbit%wfn
3950 : ! also update Pot%rvh
3951 : logical,intent(in) :: usespline
3952 : TYPE(GridInfo), INTENT(INOUT) :: Grid
3953 : TYPE(PotentialInfo), INTENT(INOUT) :: Pot
3954 : TYPE(OrbitInfo), INTENT(INOUT) :: Orbit
3955 : TYPE(SCFInfo), INTENT(INOUT) :: SCF
3956 : LOGICAL, OPTIONAL :: noalt
3957 : real(dp) :: ecoul,ekin,eone,h,x,qcal,small,rescale
3958 : real(dp) :: electrons,xocc
3959 : INTEGER :: i,n,io
3960 354 : real(dp), ALLOCATABLE :: dum(:)
3961 : real(dp) :: small0=tol6,fpi
3962 : INTEGER :: counter=1
3963 354 : n=Grid%n; h=Grid%h
3964 354 : small=small0
3965 1062 : LIBPAW_ALLOCATE(dum,(n))
3966 : !update density
3967 1417062 : Orbit%den=0._dp;Orbit%tau=0._dp
3968 2529 : DO io=1,Orbit%norbit
3969 2175 : IF(Orbit%frozenvalecalculation.and.(.not.Orbit%iscore(io))) cycle
3970 1895 : IF (Orbit%occ(io).GT.small) THEN
3971 3067064 : DO i=1,Grid%n
3972 3065532 : IF (ABS(Orbit%wfn(i,io))<machine_zero)Orbit%wfn(i,io)=0
3973 3067064 : IF (Orbit%diracrelativistic) then
3974 716358 : IF (ABS(Orbit%lwfn(i,io))<machine_zero)Orbit%lwfn(i,io)=0
3975 : ENDIF
3976 : ENDDO
3977 1532 : if(.not.usespline) then
3978 : CALL taufromwfn(Orbit%otau(:,io),Grid,Orbit%wfn(:,io),Orbit%l(io), &
3979 1532 : & energy=Orbit%eig(io),rPot=Pot%rv)
3980 : endif
3981 1532 : xocc=Orbit%occ(io)
3982 3067064 : Do i=1,Grid%n
3983 3065532 : Orbit%tau(i)=Orbit%tau(i)+xocc*Orbit%otau(i,io)
3984 3065532 : Orbit%den(i)=Orbit%den(i)+xocc*(Orbit%wfn(i,io)**2)
3985 3067064 : IF (Orbit%diracrelativistic) then
3986 716358 : Orbit%den(i)=Orbit%den(i)+xocc*((Orbit%lwfn(i,io))**2)
3987 : ENDIF
3988 : ENDDO
3989 : ENDIF
3990 : ENDDO
3991 354 : qcal=integrator(Grid,Orbit%den)
3992 354 : if(has_to_print) WRITE(STD_OUT,*) 'qcal = ', qcal
3993 354 : IF(Orbit%frozenvalecalculation) qcal=qcal+Orbit%qval
3994 470589 : IF(Orbit%frozenvalecalculation) Orbit%den=Orbit%den+Orbit%valeden
3995 354 : electrons=Pot%q
3996 354 : IF(Orbit%frozenvalecalculation) electrons=qcal
3997 354 : rescale=electrons/qcal
3998 708708 : Orbit%den(1:n)=Orbit%den(1:n)*rescale
3999 708708 : Orbit%tau(1:n)=Orbit%tau(1:n)*rescale
4000 : ! Determine difference with tauW (Weizsaker)
4001 354 : fpi=4*pi
4002 708354 : dum(2:Grid%n)=Orbit%den(2:Grid%n)/(fpi*Grid%r(2:Grid%n)**2)
4003 354 : CALL extrapolate(dum)
4004 354 : CALL derivative(Grid,dum,Orbit%deltatau)
4005 708708 : Do i=1,Grid%n
4006 708708 : if (dum(i)>machine_zero) then
4007 648887 : Orbit%deltatau(i)=0.25_dp*(Orbit%deltatau(i)**2)/dum(i)
4008 : else
4009 59467 : Orbit%deltatau(i)=0.0_dp
4010 : endif
4011 : enddo
4012 708354 : dum(2:Grid%n)=Orbit%tau(2:Grid%n)/(fpi*Grid%r(2:Grid%n)**2)
4013 354 : call extrapolate(dum)
4014 708708 : Orbit%deltatau=dum-Orbit%deltatau
4015 354 : call poisson_marc(Grid,Pot%q,Orbit%den,Pot%rvh,ecoul)
4016 : ! call atompaw_poisson(Grid,Pot%q,Orbit%den,Pot%rvh,ecoul)
4017 708708 : dum=zero
4018 708354 : dum(2:n)=Pot%rvn(2:n)*Orbit%den(2:n)/Grid%r(2:n)
4019 354 : SCF%estatic=integrator(Grid,dum)+ecoul
4020 354 : if(has_to_print) then
4021 0 : WRITE(STD_OUT,*) ' n l occupancy energy'
4022 0 : do io=1,Orbit%norbit
4023 0 : write(std_out,*) Orbit%np(io), Orbit%l(io),Orbit%occ(io),Orbit%eig(io)
4024 : enddo
4025 : endif
4026 354 : ekin=0.0_dp; if (Orbit%frozencorecalculation) ekin=SCF%corekin
4027 354 : eone=0.0_dp
4028 2529 : DO io=1,Orbit%norbit
4029 : if(.not.Orbit%frozencorecalculation &
4030 2529 : & .or.Orbit%frozencorecalculation.and.(.not.Orbit%iscore(io))) then
4031 2175 : eone=eone+Orbit%occ(io)*Orbit%eig(io)
4032 2175 : IF (counter>1.and..not.present(noalt)) THEN
4033 2163 : CALL altkinetic(Grid,Orbit%wfn(:,io),Orbit%eig(io),Pot%rv,x)
4034 : ELSE
4035 12 : x=integrator(Grid,Orbit%otau(:,io))
4036 : ENDIF
4037 2175 : ekin=ekin+Orbit%occ(io)*x
4038 : endif
4039 : ENDDO
4040 354 : if(has_to_print) write(std_out,*) 'KinCoul check ekin ',ekin,integrator(Grid,Orbit%tau)
4041 354 : SCF%eone=eone
4042 354 : SCF%ekin=ekin
4043 354 : SCF%ecoul=ecoul
4044 354 : counter=counter+1
4045 354 : LIBPAW_DEALLOCATE(dum)
4046 354 : END SUBROUTINE Get_KinCoul
4047 :
4048 :
4049 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4050 : !! Get_Nuclearpotential
4051 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4052 4 : SUBROUTINE Get_Nuclearpotential(Grid,Pot)
4053 : ! TODO : finitenucleus
4054 : TYPE(GridInfo), INTENT(INOUT) :: Grid
4055 : TYPE(PotentialInfo), INTENT(INOUT) :: Pot
4056 : ! Various finite nuclear models follow the manuscript of Andrae
4057 : ! Physics Reports 336 (2000) 413-525
4058 : ! finitenucleusmodel 2,3,4,5 correspond to the options
4059 : ! described in that paper while finitenucleusmodel 0 corresponds to
4060 : ! Gaussian model originally programmed
4061 : ! Note that logarithmic grid is reset to be compatible with
4062 : ! nuclear model with approximately NN integration points within
4063 : ! finite nucleus
4064 : INTEGER :: i
4065 : INTEGER, PARAMETER :: NN=651 ! number of grid points within RR
4066 : real(dp), PARAMETER :: gridrange=100._dp
4067 : real(dp), PARAMETER :: bohr=0.529177249_dp !Ang/Bohr from Andrae
4068 4 : IF (.NOT.Pot%finitenucleus) THEN
4069 : ! grid already set
4070 8008 : DO i=1,Grid%n
4071 8008 : Pot%rvn(i)=-2*Pot%nz!*0.5!Hartree
4072 : ENDDO
4073 : ELSE
4074 0 : STOP
4075 : ! write(std_out,*) 'Finite nucleus model -- readjusting integration grid'
4076 : ! a=bohr*10._dp**(-5)*(0.57_dp+0.836* &
4077 : ! & (-1.168_dp+Pot%nz*(2.163_dp+Pot%nz*0.004467_dp)))
4078 : ! ! From Eqs. A.3 and 51 in Andrae paper
4079 : ! write(std_out,*) 'a parameter calculated to be', a
4080 : ! call destroygrid(Grid)
4081 : ! SELECT CASE(Pot%finitenucleusmodel)
4082 : ! CASE DEFAULT
4083 : ! write(std_out,*) 'Error in finitenucleusmodel',Pot%finitenucleusmodel
4084 : ! write(std_out,*) ' Exiting '
4085 : ! Stop
4086 : ! CASE(0)
4087 : ! write(std_out,*) 'Original Gaussian model'
4088 : ! RR=Pot%nz
4089 : ! RR=2.9*10._dp**(-5)*(RR**0.3333333333333333333333333_dp)
4090 : ! h=log(FLOAT(NN))/(NN-1)
4091 : ! r0=RR/(NN-1)
4092 : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4093 : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4094 : ! write(std_out,*) 'New Grid ', Grid%n
4095 : ! Call DestroyPot(Pot)
4096 : ! Call InitPot(Pot,Grid%n)
4097 : ! DO i=1,Grid%n
4098 : ! Pot%rvn(i)=-2*Pot%nz*derf(Grid%r(i)/RR)
4099 : ! ENDDO
4100 : ! Pot%Nv0=-2*Pot%nz*sqrt(4._dp/pi)
4101 : ! Pot%Nv0p=0._dp
4102 : ! CASE(2)
4103 : ! write(std_out,*) 'Model 2 -- Breit'
4104 : ! RR=sqrt(2._dp)*a
4105 : ! h=log(FLOAT(NN))/(NN-1)
4106 : ! r0=RR/(NN-1)
4107 : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4108 : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4109 : ! write(std_out,*) 'New Grid ', Grid%n
4110 : ! Call DestroyPot(Pot)
4111 : ! Call InitPot(Pot,Grid%n)
4112 : ! DO i=1,Grid%n
4113 : ! if (Grid%r(i)<RR) then
4114 : ! Pot%rvn(i)=-2*Pot%nz*Grid%r(i)*(2._dp-Grid%r(i)/RR)/RR
4115 : ! else
4116 : ! Pot%rvn(i)=-2*Pot%nz
4117 : ! endif
4118 : ! ENDDO
4119 : ! Pot%Nv0=-2*Pot%nz*2.0_dp/RR
4120 : ! Pot%Nv0p=2*Pot%nz/(RR**2)
4121 : ! CASE(3)
4122 : ! write(std_out,*) 'Model 3 -- uniform'
4123 : ! RR=sqrt(5._dp/3._dp)*a
4124 : ! h=log(FLOAT(NN))/(NN-1)
4125 : ! r0=RR/(NN-1)
4126 : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4127 : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4128 : ! write(std_out,*) 'New Grid ', Grid%n
4129 : ! Call DestroyPot(Pot)
4130 : ! Call InitPot(Pot,Grid%n)
4131 : ! DO i=1,Grid%n
4132 : ! if (Grid%r(i)<RR) then
4133 : ! Pot%rvn(i)=-3*Pot%nz*Grid%r(i)*&
4134 : ! & (1._dp-(Grid%r(i)/RR)**2/3)/RR
4135 : ! else
4136 : ! Pot%rvn(i)=-2*Pot%nz
4137 : ! endif
4138 : ! ENDDO
4139 : ! Pot%Nv0=-3*Pot%nz/RR
4140 : ! Pot%Nv0p=0._dp
4141 : ! CASE(4)
4142 : ! write(std_out,*) 'Model 4 -- exponential'
4143 : ! RR=sqrt(1._dp/12._dp)*a
4144 : ! h=log(FLOAT(NN))/(NN-1)
4145 : ! r0=RR/(NN-1)
4146 : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4147 : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4148 : ! write(std_out,*) 'New Grid ', Grid%n
4149 : ! Call DestroyPot(Pot)
4150 : ! Call InitPot(Pot,Grid%n)
4151 : ! DO i=1,Grid%n
4152 : ! Pot%rvn(i)=-2*Pot%nz* &
4153 : ! & (1._dp-exp(-grid%r(i)/RR)*(1._dp+0.5_dp*Grid%r(i)/RR))
4154 : ! ENDDO
4155 : ! Pot%Nv0=-Pot%nz/RR
4156 : ! Pot%Nv0p=0._dp
4157 : ! CASE(5)
4158 : ! write(std_out,*) 'Model 5 -- Gaussian'
4159 : ! RR=sqrt(2._dp/3._dp)*a
4160 : ! h=log(FLOAT(NN))/(NN-1)
4161 : ! r0=RR/(NN-1)
4162 : ! write(std_out,*) 'calling InitGrid with h, r0 =',h,r0
4163 : ! Call InitGrid(Grid,h,gridrange,r0=r0)
4164 : ! write(std_out,*) 'New Grid ', Grid%n
4165 : ! Call DestroyPot(Pot)
4166 : ! Call InitPot(Pot,Grid%n)
4167 : ! DO i=1,Grid%n
4168 : ! Pot%rvn(i)=-2*Pot%nz*erf(Grid%r(i)/RR)
4169 : ! ENDDO
4170 : ! Pot%Nv0=-2*Pot%nz/RR*(sqrt(4._dp/pi))
4171 : ! Pot%Nv0p=0._dp
4172 : ! END SELECT
4173 : ENDIF
4174 4 : END SUBROUTINE Get_Nuclearpotential
4175 :
4176 :
4177 :
4178 :
4179 :
4180 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4181 : ! 6. radialsr
4182 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4183 :
4184 :
4185 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4186 : !! Subroutine Azeroexpand(Grid,Pot,l,energy)
4187 : !! If finitenucleus==.true. assumes potential is non-singular
4188 : !! at origin and Pot%v0 and Pot%v0p are properly set
4189 : !! Otherwise, assumes nuclear potential is -2*Z/r
4190 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4191 18142 : Subroutine Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB,nr)
4192 : Type(GridInfo), INTENT(IN) :: Grid
4193 : Type(PotentialInfo), INTENT(INout) :: Pot
4194 : Integer, INTENT(IN) :: l
4195 : real(dp), INTENT(IN) :: energy
4196 : real(dp), intent(inout) :: qq,gamma,c1,c2,MA,MB
4197 : Integer, optional, INTENT(IN) :: nr
4198 : Integer :: n
4199 : real(dp) :: nz,angm,alpha2,balpha2
4200 : real(dp) :: Tm10,Tm11,T00,Tm21,Tm22,term
4201 : n=Grid%n
4202 18142 : if (present(nr)) n=min(n,nr)
4203 : ! check for possible ionic charge
4204 18142 : n=Grid%n
4205 18142 : qq=pot%zz-pot%q!-Pot%rv(n)/2
4206 18142 : if(qq<0.001_dp) qq=0
4207 18142 : nz=Pot%nz
4208 72622426 : Pot%ww=0; Pot%jj=0;
4209 18142 : balpha2=InvFineStruct**2
4210 18142 : alpha2=1._dp/balpha2
4211 : Pot%jj(1:n)=(Grid%r(1:n) + &
4212 36320284 : & 0.25_dp*alpha2*(energy*Grid%r(1:n)-Pot%rv(1:n)))!hartree
4213 18142 : angm=l*(l+1)
4214 : Pot%ww(2:n)=(Pot%rv(2:n)/Grid%r(2:n)-energy) & !*2.0 &
4215 36302142 : & + angm/(Grid%r(2:n)*Pot%jj(2:n))!hartree
4216 18142 : Pot%ww(1)=0
4217 18142 : if (.not.Pot%finitenucleus) then
4218 18142 : gamma=sqrt(angm+1._dp-alpha2*nz**2)
4219 18142 : term=1._dp+0.25_dp*alpha2*(energy-Pot%v0)!*2.0!hartree
4220 18142 : Tm21=2*gamma+1; Tm22=2*(2*gamma+2)
4221 : !hartree!hartree!hartree
4222 18142 : Tm10=nz*(2._dp+alpha2*(energy-Pot%v0))-(2*balpha2/nz)*term*(gamma-1._dp)
4223 18142 : Tm11=nz*(2._dp+alpha2*(energy-Pot%v0))-(2*balpha2/nz)*term*(gamma)
4224 : T00=-alpha2*nz*Pot%v0p+term*(energy-Pot%v0) + &
4225 18142 : & (Pot%v0p/nz+(4*balpha2**2/(nz*nz))*term**2)*(gamma-1._dp)
4226 18142 : c1=-Tm10/Tm21
4227 18142 : c2=-(Tm11*C1+T00)/Tm22
4228 18142 : MA=0; MB=0
4229 : else ! version for finite nuclear size
4230 0 : gamma=l+1._dp
4231 0 : term=1._dp+0.25_dp*alpha2*(energy-Pot%v0)
4232 0 : Tm21=2*l+2; Tm22=2*(2*l+3)
4233 0 : Tm10=(0.25_dp*alpha2*Pot%v0p/term)*(l)
4234 0 : Tm11=(0.25_dp*alpha2*Pot%v0p/term)*(l+1)
4235 0 : T00=(energy-Pot%v0)*term+l*((0.25_dp*alpha2*Pot%v0p/term)**2)
4236 0 : c1=-Tm10/Tm21
4237 0 : c2=-(Tm11*C1+T00)/Tm22
4238 0 : MA=0; MB=0
4239 : endif
4240 18142 : end subroutine Azeroexpand
4241 :
4242 :
4243 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4244 : !! SUBROUTINE wfnsrinit(Grid,l,wfn,lwfn,istart)
4245 : !! returns the solution of the scalar relativistic equations near r=0
4246 : !! using power series expansion
4247 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4248 18142 : SUBROUTINE wfnsrinit(Grid,l,wfn,lwfn,istart,finitenucleus,gamma,c1,c2,MA,MB,jj)
4249 : Type(GridInfo), INTENT(IN) :: Grid
4250 : INTEGER, INTENT(IN) :: l
4251 : real(dp),intent(in) :: gamma,c1,c2,MA,MB
4252 : real(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
4253 : real(dp),intent(in) :: jj(:)
4254 : INTEGER, INTENT(OUT) :: istart
4255 : logical, intent(in) :: finitenucleus
4256 : real(dp) :: rr,M
4257 : INTEGER :: i
4258 72621172 : wfn=0; lwfn=0
4259 18142 : istart=6
4260 126994 : do i=1,istart
4261 108852 : rr=Grid%r(i+1)
4262 126994 : if (.not.finitenucleus) then
4263 108852 : wfn(i+1)=1+rr*(c1+rr*c2)
4264 108852 : lwfn(i+1)=(gamma-1)+rr*(c1*gamma+rr*c2*(gamma+1))
4265 108852 : wfn(i+1)=wfn(i+1)*(rr**gamma)
4266 108852 : lwfn(i+1)=lwfn(i+1)*(rr**gamma)/jj(i+1)
4267 : else ! finite nucleus case
4268 0 : M=MA-MB*rr
4269 0 : wfn(i+1)=(1+rr*(c1+rr*c2))*(rr**(l+1))
4270 0 : lwfn(i+1)=(l+rr*((l+1)*c1+rr*(l+2)*c2))*(rr**(l+1))/M
4271 : endif
4272 : enddo
4273 18142 : End SUBROUTINE wfnsrinit
4274 :
4275 :
4276 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4277 : !! SUBROUTINE wfnsrasym(Grid,wfn,lwfn,energy,iend)
4278 : !! returns the solution of the scalar relativistic equations near r=inf
4279 : !! using exp(-x*r) for upper component
4280 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4281 17889 : subroutine wfnsrasym(Grid,wfn,lwfn,energy,iend,qq,jj)
4282 : ! returns the solution of the scalar relativistic equations near r=inf
4283 : ! using exp(-x*r) for upper component
4284 : Type(GridInfo), INTENT(IN) :: Grid
4285 : real(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
4286 : real(dp), INTENT(IN) :: energy,qq
4287 : real(dp),intent(in) :: jj(:)
4288 : INTEGER, INTENT(OUT) :: iend
4289 : real(dp) :: rr,x,m,qx
4290 : INTEGER :: i,n
4291 17889 : if (energy>0._dp) then
4292 0 : LIBPAW_ERROR('Error in wfnsrasym -- energy > 0')
4293 : endif
4294 71609667 : wfn=0; lwfn=0;
4295 17889 : n=Grid%n
4296 17889 : m=1._dp+0.25_dp*energy/(InvFineStruct**2)!Hartree
4297 17889 : x=sqrt(-m*energy)!Hartree
4298 17889 : qx=qq ! Possible net ionic charge
4299 17889 : qx=(qx/x)*(1._dp+0.5_dp*energy/(InvFineStruct**2))!Hartree
4300 17889 : iend=5
4301 125223 : do i=n-iend,n
4302 107334 : wfn(i)=exp(-x*(Grid%r(i)-Grid%r(n-iend)))
4303 107334 : if (qx>0._dp) then
4304 0 : rr=(Grid%r(i)/Grid%r(n-iend))**qx
4305 0 : wfn(i)=wfn(i)*rr
4306 : endif
4307 125223 : lwfn(i)=-wfn(i)*(x*Grid%r(i)+(1._dp-qx))/jj(i)
4308 : enddo
4309 17889 : end subroutine wfnsrasym
4310 :
4311 :
4312 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4313 : !! subroutine unboundsr(Grid,Pot,nr,l,energy,wfn,nodes)
4314 : !! pgm to solve radial scalar relativistic equation for unbound states
4315 : !! at energy 'energy' and at angular momentum l
4316 : !!
4317 : !! with potential rv/r, given in uniform linear or log mesh of n points
4318 : !! assuming p(r)=C*r**(l+1)*polynomial(r) for r==0;
4319 : !!
4320 : !! nz=nuclear charge
4321 : !!
4322 : !! Does not use Noumerov algorithm -- but uses coupled first-order
4323 : !! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
4324 : !!
4325 : !! also returns node == number of nodes for calculated state
4326 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4327 5 : SUBROUTINE unboundsr(Grid,Pot,nr,l,energy,wfn,nodes)
4328 : TYPE(GridInfo), INTENT(IN) :: Grid
4329 : TYPE(PotentialInfo), INTENT(INout) :: Pot
4330 : INTEGER, INTENT(IN) :: nr,l
4331 : real(dp), INTENT(IN) :: energy
4332 : real(dp), INTENT(INOUT) :: wfn(:)
4333 : INTEGER, INTENT(INOUT) :: nodes
4334 : INTEGER :: n,istart
4335 : real(dp) :: scale,gamma,c1,c2,MA,MB,qq
4336 : real(dp), allocatable :: lwfn(:),zz(:,:,:),yy(:,:)
4337 5 : n=Grid%n
4338 5 : IF (nr > n) THEN
4339 0 : LIBPAW_ERROR('Error in unboundsr')
4340 : ENDIF
4341 5 : call Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB,nr)
4342 15 : LIBPAW_ALLOCATE(lwfn,(nr))
4343 15 : LIBPAW_ALLOCATE(zz,(2,2,nr))
4344 15 : LIBPAW_ALLOCATE(yy,(2,nr))
4345 103163 : lwfn=0;zz=0;yy=0;
4346 5 : call wfnsrinit(Grid,l,wfn,lwfn,istart,Pot%finitenucleus,gamma,c1,c2,MA,MB,Pot%jj)
4347 5 : call prepareforcfdsol(Grid,1,istart,nr,wfn,lwfn,yy,zz,Pot%ww,Pot%jj)
4348 5 : call cfdsol(Grid,zz,yy,istart,nr)
4349 5 : call getwfnfromcfdsol(1,nr,yy,wfn)
4350 5 : nodes=countnodes(2,nr,wfn)
4351 : ! normalize to unity within integration range
4352 5 : scale=1._dp/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr)
4353 5 : scale=SIGN(SQRT(scale),wfn(nr-2))
4354 9383 : wfn(1:nr)=wfn(1:nr)*scale
4355 5 : LIBPAW_DEALLOCATE(lwfn)
4356 5 : LIBPAW_DEALLOCATE(yy)
4357 5 : LIBPAW_DEALLOCATE(zz)
4358 5 : END SUBROUTINE unboundsr
4359 :
4360 :
4361 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4362 : !! SUBROUTINE boundsr(Grid,Pot,eig,wfn,l,nroot,emin,ierr,success)
4363 : !! pgm to solve radial scalar relativistic equation for nroot bound state
4364 : !! energies and wavefunctions for angular momentum l
4365 : !! with potential rv/r, given in uniform linear or log mesh of n points
4366 : !! nz=nuclear charge
4367 : !! emin=is estimate of lowest eigenvalue; used if nz=0
4368 : !! otherwise, set to the value of -(nz/(l+1))**2
4369 : !!
4370 : !! It is assumed that the wavefunction has np-l-1 nodes, where
4371 : !! np is the principle quantum number-- np=1,2,..nroot
4372 : !!
4373 : !! Does not use Noumerov algorithm -- but uses coupled first-order
4374 : !! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
4375 : !!
4376 : !! Corrections are also needed for r>n*h, depending on:
4377 : !! e0 (current guess of energy eigenvalue
4378 : !! the extrapolated value of rv == r * v
4379 : !!
4380 : !! ierr=an nroot digit number indicating status of each root
4381 : !! a digit of 1 indicates success in converging root
4382 : !! 2 indicates near success in converging root
4383 : !! 9 indicates that root not found
4384 : !!
4385 : !! first check how many roots expected = ntroot (returned as argument)
4386 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4387 248 : SUBROUTINE boundsr(Grid,Pot,eig,wfn,l,nroot,emin,ierr,success)
4388 : TYPE(GridInfo), INTENT(IN) :: Grid
4389 : TYPE(PotentialInfo), INTENT(INout) :: Pot
4390 : real(dp), INTENT(INOUT) :: eig(:),wfn(:,:)
4391 : INTEGER, INTENT(IN) :: l,nroot
4392 : INTEGER, INTENT(INOUT) :: ierr
4393 : real(dp), INTENT(INOUT) :: emin
4394 : LOGICAL, INTENT(INOUT) :: success
4395 : real(dp), PARAMETER :: convre=tol10,vlrg=10._dp**30
4396 : INTEGER, PARAMETER :: niter=1000
4397 248 : real(dp), POINTER :: rv(:)
4398 248 : real(dp), ALLOCATABLE :: p1(:),p2(:),dd(:)
4399 : INTEGER :: n
4400 : real(dp) :: nz,h,v0,v0p
4401 : real(dp) :: err,convrez,energy,gamma,c1,c2,MA,MB
4402 : real(dp) :: scale,emax,best,rout,qq
4403 : real(dp) :: rin,dele,x
4404 : INTEGER :: iter,i,j,node,match,mxroot,ntroot,ir,iroot
4405 : INTEGER :: ifac,istart,iend
4406 : LOGICAL :: ok
4407 : real(dp), allocatable :: lwfn(:),zz(:,:,:),yy(:,:)
4408 248 : n=Grid%n
4409 248 : h=Grid%h
4410 744 : LIBPAW_ALLOCATE(p1,(n))
4411 496 : LIBPAW_ALLOCATE(p2,(n))
4412 496 : LIBPAW_ALLOCATE(dd,(n))
4413 248 : success=.true.
4414 496 : LIBPAW_ALLOCATE(lwfn,(n))
4415 744 : LIBPAW_ALLOCATE(zz,(2,2,n))
4416 744 : LIBPAW_ALLOCATE(yy,(2,n))
4417 248 : nz=Pot%nz
4418 248 : v0=Pot%v0
4419 248 : v0p=Pot%v0p
4420 248 : rv=>Pot%rv
4421 248 : err=n*nz*(h**4)!*0.5!hartree
4422 248 : convrez=convre
4423 248 : IF (nz>0.001_dp) convrez=convre*nz
4424 248 : ierr=0
4425 248 : if(has_to_print) write(std_out,*) 'z , l = ',nz,l
4426 : ! check how many roots expected by integration outward at
4427 : ! energy = 0
4428 248 : energy = 0
4429 248 : call Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB)
4430 5458976 : lwfn=0;zz=0;yy=0;
4431 248 : call wfnsrinit(Grid,l,p1,lwfn,istart,Pot%finitenucleus,gamma,c1,c2,MA,MB,Pot%jj)
4432 : !start outward integration
4433 248 : call prepareforcfdsol(Grid,1,istart,n,p1,lwfn,yy,zz,Pot%ww,Pot%jj)
4434 248 : call cfdsoliter(Grid,zz,yy,istart,n)
4435 248 : call getwfnfromcfdsol(1,n,yy,p1)
4436 248 : node=countnodes(2,n,p1)
4437 248 : if(has_to_print) write(std_out,*) ' nodes at e=0 ', node
4438 248 : mxroot=node+1
4439 248 : ntroot=node
4440 248 : IF (mxroot.LT.nroot) THEN
4441 0 : if(has_to_print) write(std_out,*)'error in boundsr - for l = ',l
4442 0 : if(has_to_print) write(std_out,*) nroot,' states requested but only',mxroot,' possible'
4443 0 : DO ir=mxroot+1,nroot
4444 0 : ierr=ierr+9*(10**(ir-1))
4445 : ENDDO
4446 0 : success=.false.
4447 : ENDIF
4448 248 : mxroot=min0(mxroot,nroot)
4449 248 : IF (nz.EQ.0) energy=-ABS(emin)
4450 248 : IF (nz.NE.0) energy=-(1.1_dp*(nz/(l+1._dp))**2)!*0.5!Hartree
4451 248 : emin=energy-err
4452 248 : emax=0._dp
4453 846 : DO iroot=1,mxroot
4454 598 : best=1.d10; dele=1.d10
4455 598 : energy=emin+err
4456 598 : IF (energy.LT.emin) energy=emin
4457 598 : IF (energy.GT.emax) energy=emax
4458 17898 : ok=.FALSE.
4459 17898 : BigIter: DO iter=1,niter
4460 : ! start inward integration
4461 : ! start integration at n
4462 17889 : call Azeroexpand(Grid,Pot,l,energy,qq,gamma,c1,c2,MA,MB)
4463 : ! find classical turning point
4464 17889 : call ClassicalTurningPoint(Grid,Pot%rv,l,energy,match)
4465 17889 : match=max(match,10); match=min(match,n-20)
4466 17889 : call wfnsrasym(Grid,p2,lwfn,energy,iend,qq,Pot%jj)
4467 17889 : call prepareforcfdsol(Grid,n-iend,n,n,p2,lwfn,yy,zz,Pot%ww,Pot%jj)
4468 17889 : call cfdsoliter(Grid,zz,yy,n-iend,match)
4469 17889 : call getwfnfromcfdsol(match,n,yy,p2)
4470 17889 : match=match+6
4471 17889 : rin=Gfirstderiv(Grid,match,p2)/p2(match)
4472 17889 : call wfnsrinit(Grid,l,p1,lwfn,istart,Pot%finitenucleus,gamma,c1,c2,MA,MB,Pot%jj)
4473 17889 : call prepareforcfdsol(Grid,1,istart,n,p1,lwfn,yy,zz,Pot%ww,Pot%jj)
4474 17889 : call cfdsoliter(Grid,zz,yy,istart,match+6)
4475 17889 : call getwfnfromcfdsol(1,match+6,yy,p1)
4476 17889 : node= countnodes(2,match+6,p1)
4477 17889 : rout=Gfirstderiv(Grid,match,p1)/p1(match)
4478 : ! check whether node = (iroot-1)
4479 : ! not enough nodes -- raise energy
4480 53676 : IF (node.LT.iroot-1) THEN
4481 744 : emin=MAX(emin,energy)-err
4482 744 : energy=emax-(emax-energy)*ranx()
4483 744 : ifac=9
4484 : ! too many nodes -- lower energy
4485 17145 : ELSEIF (node.GT.iroot-1) THEN
4486 496 : IF (energy.LE.emin) THEN
4487 0 : ierr=ierr+9*(10**(iroot-1))
4488 0 : if(has_to_print) write(std_out,*) 'boundsr error -- emin too high',l,nz,emin,energy
4489 0 : IF (energy.LE.emin-tol10) THEN
4490 0 : STOP
4491 : ENDIF
4492 : ENDIF
4493 496 : emax=MIN(emax,energy+err)
4494 496 : energy=emin+(energy-emin)*ranx()
4495 : ! correct number of nodes -- estimate correction
4496 16649 : ELSEIF (node.EQ.iroot-1) THEN
4497 10690262 : DO j=1,match
4498 10690262 : p1(j)=p1(j)/p1(match)
4499 : ENDDO
4500 22674334 : DO j=match,n
4501 22674334 : p1(j)=p2(j)/p2(match)
4502 : ENDDO
4503 16649 : scale=1._dp/overlap(Grid,p1,p1)
4504 16649 : dele=(rout-rin)*scale
4505 16649 : x=ABS(dele)
4506 16649 : IF (x.LT.best) THEN
4507 4577 : scale=SQRT(scale)
4508 9163154 : p1(1:n)=p1(1:n)*scale
4509 4577 : call filter(n,p1,machine_zero)
4510 9163154 : wfn(1:n,iroot)=p1(1:n)
4511 4577 : eig(iroot)=energy
4512 4577 : best=x
4513 : ENDIF
4514 16649 : IF (ABS(dele).LE.convrez) THEN
4515 589 : ok=.TRUE.
4516 : ! eigenvalue found
4517 589 : ierr=ierr+10**(iroot-1)
4518 589 : IF (iroot+1.LE.mxroot) THEN
4519 350 : emin=energy+err
4520 350 : emax=0
4521 350 : energy=(emin+emax)/2
4522 350 : IF (energy.LT.emin) energy=emin
4523 350 : IF (energy.GT.emax) energy=emax
4524 : best=1.d10
4525 : ENDIF
4526 : EXIT BigIter
4527 : ENDIF
4528 16060 : IF (ABS(dele).GT.convrez) THEN
4529 16060 : energy=energy+dele!*0.5!hartree
4530 : ! if energy is out of range, pick random energy in correct range
4531 16060 : IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) &
4532 11494 : energy=emin+(emax-emin)*ranx()
4533 : ifac=2
4534 : ENDIF
4535 : ENDIF
4536 : ENDDO BigIter !iter
4537 248 : IF (.NOT.ok) THEN
4538 9 : success=.false.
4539 9 : ierr=ierr+ifac*(10**(iroot-1))
4540 9 : if(has_to_print) write(std_out,*) 'no convergence in boundsr',iroot,l,dele,energy
4541 9 : if(has_to_print) write(std_out,*) ' best guess of eig, dele = ',eig(iroot),best
4542 9 : IF (iroot.LT.mxroot) THEN
4543 0 : DO ir=iroot+1,mxroot
4544 0 : ierr=ierr+9*(10**(ir-1))
4545 : ENDDO
4546 : ENDIF
4547 : ! reset wfn with hydrogenic form
4548 9 : j=iroot+l+1
4549 18018 : wfn(:,iroot)=0
4550 9 : x=(j)*sqrt(abs(eig(iroot)*2.0))
4551 18009 : do i=2,n
4552 18009 : wfn(i,iroot)=hwfn(x,j,l,Grid%r(i))
4553 : enddo
4554 : ENDIF
4555 : ENDDO !iroot
4556 248 : LIBPAW_DEALLOCATE(p1)
4557 248 : LIBPAW_DEALLOCATE(p2)
4558 248 : LIBPAW_DEALLOCATE(dd)
4559 248 : LIBPAW_DEALLOCATE(lwfn)
4560 248 : LIBPAW_DEALLOCATE(yy)
4561 248 : LIBPAW_DEALLOCATE(zz)
4562 496 : END SUBROUTINE Boundsr
4563 :
4564 :
4565 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4566 : !! prepareforcfdsol
4567 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4568 36031 : subroutine prepareforcfdsol(Grid,i1,i2,n,wfn,lwfn,yy,zz,ww,jj)
4569 : Type(gridinfo), INTENT(IN) :: Grid
4570 : INTEGER, INTENT(IN) :: i1,i2,n
4571 : real(dp), INTENT(IN) :: wfn(:),lwfn(:)
4572 : real(dp), INTENT(OUT) :: yy(:,:),zz(:,:,:)
4573 : real(dp),intent(in) :: ww(:),jj(:)
4574 : INTEGER :: i
4575 721046102 : yy=0;zz=0
4576 252217 : yy(1,i1:i2)=wfn(i1:i2)
4577 252217 : yy(2,i1:i2)=lwfn(i1:i2)
4578 72097404 : do i=2,n
4579 72061373 : zz(1,1,i)=1._dp/Grid%r(i)
4580 72061373 : zz(1,2,i)=jj(i)/Grid%r(i)
4581 72061373 : zz(2,2,i)=-1._dp/Grid%r(i)
4582 72097404 : zz(2,1,i)=ww(i)
4583 : enddo
4584 36031 : end subroutine prepareforcfdsol
4585 :
4586 :
4587 :
4588 :
4589 :
4590 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4591 : ! 7. anderson_driver
4592 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4593 :
4594 :
4595 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4596 : !! Anderson_Mix
4597 : !! Performs the actual mixing of the input vector with the
4598 : !! history and retuns the result.
4599 : !!
4600 : !! AC - Anderson context
4601 : !! X - Current vector on input and new guess on output
4602 : !! F - F(X) - X. Nonlinear mixing of input vector
4603 : !!
4604 : !! Modified to call SVD routines
4605 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4606 331 : SUBROUTINE Anderson_Mix(AC, X, F)
4607 : SAVE
4608 : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4609 : real(dp), INTENT(INOUT) :: X(:)
4610 : real(dp), INTENT(IN) :: F(:)
4611 : INTEGER :: i, slot, currentdim , n ,j
4612 : real(dp) :: term
4613 : real(dp) :: tmp
4614 : !First determine where to store the new correction vectors ***
4615 331 : AC%slot = AC%slot + 1
4616 331 : IF (AC%Slot>AC%Nmax) AC%Slot = 1
4617 331 : IF ((AC%N < 0) .OR. (AC%Nmax == 0)) THEN !** Simple mixing for 1st time ***
4618 46046 : AC%Xprev = X
4619 46046 : X = X + AC%NewMix*F
4620 : ELSE
4621 308 : slot = AC%Slot
4622 616616 : AC%DF(:,slot) = F - AC%Fprev !** Make new DF vector
4623 616616 : AC%DX(:,slot) = X - AC%Xprev !** Make new DX vector
4624 308 : currentdim=MIN(AC%N+1,AC%Nmax)
4625 1624 : DO i=1, currentdim !*** Add row/col to matrix
4626 2634632 : term = DOT_PRODUCT(AC%DF(:,i), AC%DF(:,slot))
4627 1316 : AC%Matrix(i,slot) = term
4628 1316 : IF (i /= slot) AC%Matrix(slot,i) = (term)
4629 2634940 : AC%Gamma(i) = DOT_PRODUCT(AC%DF(:,i), F)
4630 : END DO
4631 9548 : AC%DupMatrix = AC%Matrix
4632 308 : n = AC%Nmax; j= currentdim
4633 : CALL DGESDD('A',j,j,AC%DupMatrix(1,1),n,AC%S(1), &
4634 308 : AC%U(1,1),n,AC%VT(1,1),n,AC%Work(1),AC%Lwork, AC%IPIV(1),i)
4635 308 : IF (i /= 0) THEN
4636 0 : LIBPAW_ERROR('Anderson_Mix: Error in DGESDD.')
4637 : END IF
4638 1624 : AC%Work(1:j) = AC%Gamma(1:j)
4639 1848 : AC%Gamma = 0
4640 308 : tmp=MAX(ABS(AC%S(1))/AC%ConditionNo,AC%Machaccur)
4641 1624 : DO i=1,j
4642 1624 : IF (ABS(AC%S(i)).GT.tmp) THEN
4643 : AC%Gamma(1:j)=AC%Gamma(1:j)+&
4644 5045 : (AC%VT(i,1:j))*DOT_PRODUCT(AC%U(1:j,i),AC%Work(1:j))/AC%S(i)
4645 : ENDIF
4646 : ENDDO
4647 616616 : AC%Xprev = X
4648 : !*** Now calculate the new vector ***
4649 616616 : X = X + AC%NewMix*F
4650 1624 : DO i=1, currentdim ! updated vector
4651 2634940 : X = X - AC%Gamma(i)*(AC%DX(:,i) + AC%NewMix*AC%DF(:,i))
4652 : END DO
4653 : END IF
4654 662662 : AC%Fprev = F
4655 331 : AC%N = AC%N + 1
4656 331 : IF (AC%N > AC%Nmax) AC%N = AC%Nmax
4657 331 : RETURN
4658 : END SUBROUTINE Anderson_Mix
4659 :
4660 :
4661 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4662 : !! Anderson_ResetMix - Resets the mixing history to None
4663 : !! AC - Anderson context to reset
4664 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4665 0 : SUBROUTINE Anderson_ResetMix(AC)
4666 : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4667 0 : AC%N = -1
4668 0 : AC%Slot = -1
4669 0 : AC%CurIter=0
4670 : RETURN
4671 : END SUBROUTINE Anderson_ResetMix
4672 :
4673 :
4674 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4675 : !! FreeAnderson - Frees all the data associated with the AC data structure
4676 : !! AC -Pointer to the Anderson context to free
4677 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4678 23 : SUBROUTINE FreeAnderson(AC)
4679 : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4680 23 : IF (ASSOCIATED(AC%Matrix)) then
4681 23 : LIBPAW_POINTER_DEALLOCATE(AC%Matrix)
4682 : endif
4683 23 : IF (ASSOCIATED(AC%Gamma)) then
4684 23 : LIBPAW_POINTER_DEALLOCATE(AC%Gamma)
4685 : endif
4686 23 : IF (ASSOCIATED(AC%DF)) then
4687 23 : LIBPAW_POINTER_DEALLOCATE(AC%DF)
4688 : endif
4689 23 : IF (ASSOCIATED(AC%Fprev)) then
4690 23 : LIBPAW_POINTER_DEALLOCATE(AC%Fprev)
4691 : endif
4692 23 : IF (ASSOCIATED(AC%DX)) then
4693 23 : LIBPAW_POINTER_DEALLOCATE(AC%DX)
4694 : endif
4695 23 : IF (ASSOCIATED(AC%Xprev)) then
4696 23 : LIBPAW_POINTER_DEALLOCATE(AC%Xprev)
4697 : endif
4698 23 : IF (ASSOCIATED(AC%IPIV)) then
4699 23 : LIBPAW_POINTER_DEALLOCATE(AC%IPIV)
4700 : endif
4701 23 : IF (ASSOCIATED(AC%S)) then
4702 23 : LIBPAW_POINTER_DEALLOCATE(AC%S)
4703 : endif
4704 23 : IF (ASSOCIATED(AC%RWork)) then
4705 23 : LIBPAW_POINTER_DEALLOCATE(AC%RWork)
4706 : endif
4707 23 : IF (ASSOCIATED(AC%U)) then
4708 23 : LIBPAW_POINTER_DEALLOCATE(AC%U)
4709 : endif
4710 23 : IF (ASSOCIATED(AC%VT)) then
4711 23 : LIBPAW_POINTER_DEALLOCATE(AC%VT)
4712 : endif
4713 23 : IF (ASSOCIATED(AC%Work)) then
4714 23 : LIBPAW_POINTER_DEALLOCATE(AC%Work)
4715 : endif
4716 23 : IF (ASSOCIATED(AC%DupMatrix)) then
4717 23 : LIBPAW_POINTER_DEALLOCATE(AC%DupMatrix)
4718 : endif
4719 23 : RETURN
4720 : END SUBROUTINE FreeAnderson
4721 :
4722 :
4723 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4724 : !! InitAnderson_dr - Initializes and Anderson_Context data structure for use
4725 : !! AC - Anderson context created and returned
4726 : !! Err_Unit - Output error unit
4727 : !! Nmax - Max number of vectors to keep
4728 : !! VecSize - Size of each vector
4729 : !! NewMix - Mixing factor
4730 : !! CondNo - For matrix inversion
4731 : !! MaxIter - Maximum number of iterations
4732 : !! err - minimum residue convergence tolerance
4733 : !! toosmall - result obviously converged
4734 : !! verbose - if true -- write out results
4735 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4736 23 : SUBROUTINE InitAnderson_dr(AC,Err_Unit,Nmax,VecSize,NewMix,CondNo,&
4737 : & MaxIter,err,toosmall,verbose)
4738 : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4739 : INTEGER, INTENT(IN) :: Err_Unit
4740 : INTEGER, INTENT(IN) :: Nmax
4741 : INTEGER, INTENT(IN) :: VecSize
4742 : real(dp), INTENT(IN) :: NewMix
4743 : real(dp), INTENT(IN) :: CondNo
4744 : INTEGER, INTENT(IN) :: MaxIter
4745 : real(dp), INTENT(IN) :: err,toosmall
4746 : LOGICAL, INTENT(IN) :: verbose
4747 : real(dp) :: a1,a2,a3
4748 23 : AC%Nmax = Nmax !*** Store the contants
4749 23 : AC%VecSize = VecSize
4750 23 : AC%NewMix = NewMix
4751 23 : AC%Err_Unit = Err_Unit
4752 23 : AC%MaxIter = MaxIter
4753 23 : AC%err = err
4754 23 : AC%toosmall = toosmall
4755 23 : AC%writelots=verbose
4756 23 : AC%N = -1 !** Init the rest of the structure
4757 23 : AC%Slot = -1
4758 23 : AC%CurIter=0
4759 69 : LIBPAW_POINTER_ALLOCATE(AC%Xprev,(VecSize))
4760 46 : LIBPAW_POINTER_ALLOCATE(AC%Fprev,(VecSize))
4761 92 : LIBPAW_POINTER_ALLOCATE(AC%DX,(VecSize,Nmax))
4762 69 : LIBPAW_POINTER_ALLOCATE(AC%DF,(VecSize,Nmax))
4763 92 : LIBPAW_POINTER_ALLOCATE(AC%Matrix,(Nmax,Nmax))
4764 69 : LIBPAW_POINTER_ALLOCATE(AC%Gamma,(Nmax))
4765 23 : AC%Lwork=5*Nmax*Nmax+10*Nmax
4766 23 : AC%LRwork= 5*Nmax*Nmax+7*Nmax
4767 23 : AC%ConditionNo= CondNo
4768 : ! Calculate machine accuracy
4769 23 : AC%Machaccur = 0
4770 23 : a1 = 4._dp/3._dp
4771 46 : DO WHILE (AC%Machaccur == 0._dp)
4772 23 : a2 = a1 - 1._dp
4773 23 : a3 = a2 + a2 + a2
4774 23 : AC%Machaccur = ABS(a3 - 1._dp)
4775 : ENDDO
4776 69 : LIBPAW_POINTER_ALLOCATE(AC%DupMatrix,(Nmax,Nmax))
4777 69 : LIBPAW_POINTER_ALLOCATE(AC%U,(Nmax, Nmax))
4778 69 : LIBPAW_POINTER_ALLOCATE(AC%VT,(Nmax,Nmax))
4779 69 : LIBPAW_POINTER_ALLOCATE(AC%Work,(AC%Lwork))
4780 69 : LIBPAW_POINTER_ALLOCATE(AC%RWork,(AC%LRWork))
4781 69 : LIBPAW_POINTER_ALLOCATE(AC%IPIV,(8*Nmax))
4782 46 : LIBPAW_POINTER_ALLOCATE(AC%S,(Nmax))
4783 713 : AC%Matrix = 0
4784 23 : RETURN
4785 : END SUBROUTINE InitAnderson_dr
4786 :
4787 :
4788 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4789 : !! DoAndersonMix
4790 : !! Note residue can be wout-w or more general residue that tends --> 0
4791 : !! at convergence
4792 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4793 23 : SUBROUTINE DoAndersonMix(AC,w,E,Esub,success,atp)
4794 : TYPE (Anderson_Context), INTENT(INOUT) :: AC
4795 : real(dp), INTENT(INOUT) :: E,w(:)
4796 : ! External :: Esub
4797 : LOGICAL, INTENT(OUT) :: success
4798 : type(atompaw_type), intent(inout) :: atp
4799 23 : real(dp), ALLOCATABLE :: residue(:),tmp(:)
4800 : real(dp) :: err,v1,v2,v3,v4
4801 : INTEGER :: i,n
4802 : real(dp), PARAMETER :: conv1=4.d13,conv2=3.d13,conv3=2.d13,conv4=1.d13
4803 : LOGICAL :: OK
4804 : INTERFACE
4805 : SUBROUTINE Esub(w,energy,residue,err,OK,update,atp)
4806 : USE_DEFS
4807 : import atompaw_type
4808 : real(dp), INTENT(INOUT) :: w(:)
4809 : real(dp), INTENT(OUT) :: energy
4810 : real(dp), INTENT(OUT) :: residue(:)
4811 : real(dp), INTENT(OUT) :: err
4812 : LOGICAL, INTENT(OUT) :: OK
4813 : LOGICAL, INTENT(IN) :: update
4814 : type(atompaw_type), intent(inout) :: atp
4815 : END SUBROUTINE Esub
4816 : END INTERFACE
4817 23 : n=SIZE(w);success=.FALSE.
4818 69 : LIBPAW_ALLOCATE(residue,(n))
4819 46 : LIBPAW_ALLOCATE(tmp,(n))
4820 23 : err=1.0d10
4821 46046 : v1=conv1;v2=conv2;v3=conv3;v4=conv4;tmp=0
4822 354 : DO i=1,AC%MaxIter
4823 354 : AC%CurIter=i
4824 354 : CALL Esub(w,E,residue,err,OK,.TRUE.,atp)
4825 354 : AC%res=err
4826 354 : if (err<AC%toosmall) THEN
4827 23 : If(AC%writelots)&
4828 : write(std_out,&
4829 : & '("AndersonMix converged in ",i5," iterations with err = ",1p,1e15.7)')&
4830 0 : & i, err
4831 : EXIT
4832 : endif
4833 331 : CALL shift4(v1,v2,v3,v4,err)
4834 263 : IF (i>=4.AND.OK) THEN
4835 : IF ((.NOT.(v4.LE.v3.AND.v3.LE.v2 &
4836 263 : & .AND.v2.LE.v1).AND.v4.LE.AC%err).OR.err<AC%toosmall) THEN
4837 : ! converged result
4838 0 : success=.TRUE.
4839 0 : If(AC%writelots)&
4840 : write(std_out,&
4841 : & '("AndersonMix converged in ",i5," iterations with err = ",1p,1e15.7)')&
4842 0 : & i, err
4843 : EXIT
4844 : ENDIF
4845 : ENDIF
4846 331 : If(AC%writelots)write(std_out,'("AndersonMixIter ",i7,2x,1p,2e20.12)') i,E,err
4847 331 : IF (.NOT.OK) THEN
4848 0 : CALL Anderson_ResetMix(AC)
4849 0 : IF (i>1) THEN
4850 0 : w=tmp
4851 0 : AC%NewMix=MAX(0.00001_dp,AC%NewMix/2)
4852 0 : IF (AC%NewMix<=0.00001_dp) THEN
4853 0 : write(std_out,*) 'Sorry -- this is not working '
4854 0 : STOP
4855 : ENDIF
4856 : ENDIF
4857 : ELSE
4858 331 : AC%NewMix=MIN(max(MaxMix,AC%NewMix),AC%NewMix*2)
4859 : ENDIF
4860 662993 : tmp=w
4861 331 : CALL Anderson_Mix(AC,w,residue)
4862 : ENDDO
4863 23 : If (AC%CurIter.ge.AC%MaxIter) then
4864 0 : if(has_to_print) WRITE(STD_OUT,*) 'Anderson Mix reached MaxIter without success',AC%MaxIter
4865 : Endif
4866 23 : LIBPAW_DEALLOCATE(residue)
4867 23 : LIBPAW_DEALLOCATE(tmp)
4868 23 : END SUBROUTINE DoAndersonMix
4869 :
4870 :
4871 :
4872 :
4873 :
4874 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4875 : ! 8. global_math
4876 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4877 :
4878 :
4879 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4880 : !! subroutine shapebes(al,ql,ll,rc)
4881 : !! Find al and ql parameters for a "Bessel" shape function:
4882 : !! Shape(r)=al1.jl(ql1.r)+al2.jl(ql2.r)
4883 : !! such as Shape(r) and 2 derivatives are zero at r=rc
4884 : !! Intg_0_rc[Shape(r).r^(l+2).dr]=1
4885 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4886 0 : SUBROUTINE shapebes(al,ql,ll,rc)
4887 : INTEGER,INTENT(IN) :: ll
4888 : REAL(dp),INTENT(IN) :: rc
4889 : REAL(dp),INTENT(OUT) :: al(2),ql(2)
4890 : INTEGER :: i
4891 : REAL(dp) :: alpha,beta,det,qr,jbes,jbesp,jbespp,amat(2,2),bb(2)
4892 0 : alpha=1.D0;beta=0.D0
4893 0 : CALL solvbes(ql,alpha,beta,ll,2)
4894 0 : ql(1:2)=ql(1:2)/rc
4895 0 : DO i=1,2
4896 0 : qr=ql(i)*rc
4897 0 : CALL jbessel(jbes,jbesp,jbespp,ll,1,qr)
4898 0 : amat(1,i)=jbesp*ql(i)
4899 0 : CALL jbessel(jbes,jbesp,jbespp,ll+1,0,qr)
4900 0 : amat(2,i)=jbes*rc**(ll+2)/ql(i) ! Intg_0_rc[jl(qr).r^(l+2).dr]
4901 : ENDDO
4902 0 : bb(1)=0._dp;bb(2)=1._dp
4903 0 : det=amat(1,1)*amat(2,2)-amat(1,2)*amat(2,1)
4904 0 : al(1)=(amat(2,2)*bb(1)-amat(1,2)*bb(2))/det
4905 0 : al(2)=(amat(1,1)*bb(2)-amat(2,1)*bb(1))/det
4906 0 : END SUBROUTINE shapebes
4907 :
4908 :
4909 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4910 : !! ddexp
4911 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4912 827568 : FUNCTION ddexp(arg)
4913 : real(dp) :: arg,ddexp
4914 827568 : IF (arg>maxexparg) THEN
4915 0 : ddexp=maxexp
4916 827568 : ELSE IF (arg<minexparg) THEN
4917 15766 : ddexp=minexp
4918 : ELSE
4919 811802 : ddexp=EXP(arg)
4920 : ENDIF
4921 : RETURN
4922 : END FUNCTION ddexp
4923 :
4924 :
4925 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4926 : !! ddlog
4927 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4928 960271 : FUNCTION ddlog(arg)
4929 : real(dp) :: arg,ddlog
4930 960271 : IF (arg>maxlogarg) THEN
4931 0 : ddlog=maxlog
4932 960271 : ELSE IF (arg<minlogarg) THEN
4933 20700 : ddlog=minlog
4934 : ELSE
4935 939571 : ddlog=LOG(arg)
4936 : ENDIF
4937 : RETURN
4938 : END FUNCTION ddlog
4939 :
4940 :
4941 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4942 : !! ranx
4943 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4944 28429 : FUNCTION ranx()
4945 : real(dp) :: ranx
4946 : INTEGER, PARAMETER :: konst=125
4947 : INTEGER :: m=100001
4948 28429 : m=m*konst
4949 28429 : m=m-2796203*(m/2796203)
4950 12734 : ranx=m/2796203._dp
4951 : RETURN
4952 : END FUNCTION ranx
4953 :
4954 :
4955 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4956 : !! factorial
4957 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4958 198041 : FUNCTION factorial(n)
4959 : real(dp) :: factorial
4960 : INTEGER, INTENT(IN) :: n
4961 : INTEGER :: i
4962 198041 : factorial=one
4963 198041 : IF (n.LT.2) RETURN
4964 486077 : DO i=2,n
4965 486077 : factorial=factorial*i
4966 : ENDDO
4967 : END FUNCTION factorial
4968 :
4969 :
4970 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4971 : !! FUNCTION hwfn(z,np,l,r)
4972 : !! function to calculate the radial H wfn for nuclear charge z
4973 : !! (note in this version z is real and need not be integral)
4974 : !! principal qn np
4975 : !! orbital qn l
4976 : !! r*(radial H wfn) is returned
4977 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4978 66017 : FUNCTION hwfn(z,np,l,r)
4979 : real(dp) :: hwfn
4980 : real(dp), INTENT(IN) :: z,r
4981 : INTEGER, INTENT(IN) :: np,l
4982 : INTEGER :: node,k
4983 : real(dp) :: scale_,rho,pref,term,sum_
4984 66017 : node=np-l-1
4985 66017 : scale_=2._dp*z/np
4986 66017 : rho=scale_*r
4987 126031 : pref=scale_*SQRT(scale_*factorial(np+l)/(2*np*factorial(node)))
4988 66017 : if(rho==zero.and.l==0) then
4989 : term=one/factorial(2*l+1)
4990 : else
4991 110014 : term=(rho**l)/factorial(2*l+1)
4992 : endif
4993 66017 : sum_=term
4994 66017 : IF (node.GT.0) THEN
4995 136025 : DO k=1,node
4996 84015 : term=-term*(node-k+1)*rho/(k*(2*l+1+k))
4997 136025 : sum_=sum_+term
4998 : ENDDO
4999 : ENDIF
5000 66017 : hwfn=r*pref*ddexp(-0.5_dp*rho)*sum_
5001 66017 : END FUNCTION hwfn
5002 :
5003 :
5004 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5005 : !! subroutine dirachwfn(np,kappa,z,r,eig,g,f)
5006 : !! Subroutine to calculate eigenenergy and radial wavefunctions*r
5007 : !! for bound state solutions to the Hydrogenic Dirac equation
5008 : !! for nuclear charge z. Energy in Rydberg atomic units
5009 : !! np is principal quantum number --
5010 : !! np=abs(kappa), abs(kappa)+1, abs(kappa)+2 ..
5011 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5012 40010 : subroutine dirachwfn(np,kappa,z,r,eig,g,f)
5013 : INTEGER, INTENT(IN) :: np, kappa
5014 : real(dp), INTENT(IN) :: z,r
5015 : real(dp), INTENT(INOUT) :: eig,g,f
5016 : INTEGER :: ak,nr
5017 : real(dp) :: norm,s,rho,ne, term1, term2, term0,x
5018 40010 : ak=abs(kappa)
5019 40010 : nr=np-ak
5020 40010 : s=sqrt(ak**2-(z**2)*(fsalpha2))
5021 40010 : ne=sqrt(np**2-2*nr*(ak-s))
5022 40010 : rho=2*z*r/ne
5023 40010 : norm=gammafunc(2*s+nr+1._dp)/(gammafunc(nr+1._dp)*4*ne*(ne-kappa))
5024 40010 : norm=sqrt(norm*2*z/ne)/gammafunc(2*s+1._dp)
5025 40010 : term1=0._dp
5026 40010 : if(nr>0) term1=nr*kummer(-nr+1,2*s+1._dp,rho)
5027 40010 : term2=(ne-kappa)*kummer(-nr,2*s+1._dp,rho)
5028 40010 : term0=norm*ddexp(-0.5_dp*rho)*(rho**s)
5029 40010 : eig=1._dp + ((z**2)*(fsalpha2))/(np - ak +s)**2
5030 40010 : eig=2*ifsalpha2*(1._dp/sqrt(eig) - 1._dp)
5031 40010 : x=0.5_dp*fsalpha2*eig
5032 40010 : g=sqrt(2._dp+x)*term0*(term2-term1)
5033 40010 : f=-sqrt(-x)*term0*(term2+term1)
5034 40010 : end subroutine dirachwfn
5035 :
5036 :
5037 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5038 : ! subroutine filter(n,func,small)
5039 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5040 13881 : SUBROUTINE filter(n,func,small)
5041 : INTEGER, INTENT(IN) :: n
5042 : real(dp), INTENT(INOUT) :: func(:)
5043 : real(dp), INTENT(IN) :: small
5044 : INTEGER :: i
5045 27789762 : DO i=1,n
5046 27789762 : IF (ABS(func(i)).LT.small) func(i)=0._dp
5047 : ENDDO
5048 13881 : END SUBROUTINE filter
5049 :
5050 :
5051 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5052 : ! subroutine conthomas(n,o,d,sol)
5053 : ! use Thomas's algorithm for inverting matrix
5054 : ! Dale U. von Rosenberg, "Methods for the Numerical Solution of
5055 : ! Partial Differential Equations,
5056 : ! Am. Elsevier Pub., 1969, pg. 113
5057 : ! On input, sol contains the RHS of the equation
5058 : ! On ouput, sol contains the solution of the equation
5059 : ! Equation: o*sol(i-1)+d*sol(i)+o*sol(i+1) = RHS(i)
5060 : ! sol(1)==sol(n+1)==0
5061 : ! simplified version for constant tridiagonal terms --
5062 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5063 25 : SUBROUTINE conthomas(n,o,d,sol)
5064 : INTEGER, INTENT(IN) :: n
5065 : real(dp), INTENT(IN) :: o,d
5066 : real(dp), INTENT(INOUT) :: sol(:)
5067 25 : real(dp), ALLOCATABLE :: a(:),b(:)
5068 : real(dp) :: ss2
5069 : INTEGER :: i
5070 75 : LIBPAW_ALLOCATE(a,(n))
5071 50 : LIBPAW_ALLOCATE(b,(n))
5072 25 : a(2)=d
5073 25 : ss2=o*o
5074 50000 : DO i=3,n
5075 50000 : a(i)=d-ss2/a(i-1)
5076 : ENDDO
5077 25 : b(2)=sol(2)/d
5078 50000 : DO i=3,n
5079 50000 : b(i)=(sol(i)-o*b(i-1))/a(i)
5080 : ENDDO
5081 25 : sol(n)=b(n)
5082 50000 : DO i=n-1,2,-1
5083 50000 : sol(i)=b(i)-o*sol(i+1)/a(i)
5084 : ENDDO
5085 25 : sol(1)=0
5086 25 : LIBPAW_DEALLOCATE(a)
5087 25 : LIBPAW_DEALLOCATE(b)
5088 25 : END SUBROUTINE conthomas
5089 :
5090 :
5091 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5092 : ! function kummer(n,b,z)
5093 : ! function to return confluent hypergeometric function (Kummer)
5094 : ! as defined in Handbook of mathematical functions pg. 504
5095 : ! assumes n=0, -1, -2, .. for polymomials of order 0, 1, 2, etc.
5096 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5097 74017 : FUNCTION kummer(n,b,z)
5098 : real(dp) :: kummer
5099 : INTEGER, INTENT(IN) :: n
5100 : real(dp), INTENT(IN) :: b,z
5101 : INTEGER :: i,k,j,nn
5102 : real(dp) :: num,den,fac,bb
5103 74017 : if (n>0) then
5104 0 : LIBPAW_ERROR('Error in kummer function -- n>0')
5105 : endif
5106 74017 : kummer=1._dp
5107 74017 : if (n==0) return
5108 54010 : j=-n
5109 54010 : k=1
5110 54010 : nn=n
5111 54010 : bb=b
5112 54010 : num=n
5113 54010 : den=b
5114 54010 : fac=z*nn/(bb*k)
5115 54010 : kummer=kummer+fac
5116 54010 : if (j>1) then
5117 62009 : do i=1,j-1
5118 36005 : nn=nn+1
5119 36005 : bb=bb+1
5120 36005 : k=k+1
5121 36005 : fac=fac*z*nn/(bb*k)
5122 62009 : kummer=kummer+fac
5123 : enddo
5124 : endif
5125 : END FUNCTION kummer
5126 :
5127 :
5128 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5129 : ! Gamma function function obtained from netlib.org
5130 : ! This routine calculates the GAMMA function for a real argument X
5131 : ! Computation is based on an algorithm outlined in reference 1
5132 : ! The program uses rational functions that approximate the GAMM
5133 : ! function to at least 20 significant decimal digits. Coefficient
5134 : ! for the approximation over the interval (1,2) are unpublished
5135 : ! Those for the approximation for X .GE. 12 are from reference 2
5136 : ! The accuracy achieved depends on the arithmetic system, th
5137 : ! compiler, the intrinsic functions, and proper selection of th
5138 : ! machine-dependent constants
5139 : !
5140 : !******************************************************************
5141 : !
5142 : ! Explanation of machine-dependent constant
5143 : !
5144 : ! beta - radix for the floating-point representatio
5145 : ! maxexp - the smallest positive power of beta that overflow
5146 : ! XBIG - the largest argument for which GAMMA(X) is representabl
5147 : ! in the machine, i.e., the solution to the equatio
5148 : ! GAMMA(XBIG) = beta**maxex
5149 : ! XINF - the largest machine representable floating-point number
5150 : ! approximately beta**maxex
5151 : ! EPS - the smallest positive floating-point number such tha
5152 : ! 1.0+EPS .GT. 1.
5153 : ! XMININ - the smallest positive floating-point number such tha
5154 : ! 1/XMININ is machine representabl
5155 : !
5156 : ! Approximate values for some important machines are
5157 : !
5158 : ! beta maxexp XBI
5159 : !
5160 : ! CRAY-1 (S.P.) 2 8191 966.96
5161 : ! Cyber 180/85
5162 : ! under NOS (S.P.) 2 1070 177.80
5163 : ! IEEE (IBM/XT
5164 : ! SUN, etc.) (S.P.) 2 128 35.04
5165 : ! IEEE (IBM/XT
5166 : ! SUN, etc.) (D.P.) 2 1024 171.62
5167 : ! IBM 3033 (D.P.) 16 63 57.57
5168 : ! VAX D-Format (D.P.) 2 127 34.84
5169 : ! VAX G-Format (D.P.) 2 1023 171.48
5170 : !
5171 : ! XINF EPS XMINI
5172 : !
5173 : ! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-246
5174 : ! Cyber 180/85
5175 : ! under NOS (S.P.) 1.26E+322 3.55E-15 3.14E-29
5176 : ! IEEE (IBM/XT
5177 : ! SUN, etc.) (S.P.) 3.40E+38 1.19E-7 1.18E-3
5178 : ! IEEE (IBM/XT
5179 : ! SUN, etc.) (D.P.) 1.79D+308 2.22D-16 2.23D-30
5180 : ! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-7
5181 : ! VAX D-Format (D.P.) 1.70D+38 1.39D-17 5.88D-3
5182 : ! VAX G-Format (D.P.) 8.98D+307 1.11D-16 1.12D-30
5183 : !
5184 : !******************************************************************
5185 : ! Error return
5186 : !
5187 : ! The program returns the value XINF for singularities o
5188 : ! when overflow would occur. The computation is believe
5189 : ! to be free of underflow and overflow
5190 : !
5191 : !
5192 : ! Intrinsic functions required are
5193 : !
5194 : ! INT, DBLE, EXP, LOG, REAL, SI
5195 : !
5196 : !
5197 : ! References: "An Overview of Software Development for Specia
5198 : ! Functions", W. J. Cody, Lecture Notes in Mathematics
5199 : ! 506, Numerical Analysis Dundee, 1975, G. A. Watso
5200 : ! (ed.), Springer Verlag, Berlin, 1976
5201 : !
5202 : ! Computer Approximations, Hart, Et. Al., Wiley an
5203 : ! sons, New York, 1968
5204 : !
5205 : ! Latest modification: October 12, 1989
5206 : !
5207 : ! Authors: W. J. Cody and L. StoltZ
5208 : ! Applied Mathematics DivisioN
5209 : ! Argonne National LaboratorY
5210 : ! Argonne, IL 60439
5211 : !
5212 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5213 120030 : FUNCTION GAMMAFUNC(X)
5214 : real(dp) :: GAMMAFUNC,X
5215 : INTEGER:: I,N
5216 : real(dp) :: &
5217 : & CONV,EPS,FACT,HALF,ONE,RES,SQRTPI,SUM,TWELVE, &
5218 : & TWO,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
5219 : real(dp) :: C(7),P(8),Q(8)
5220 : LOGICAL :: PARITY
5221 : !---------------------------------------------------------------------
5222 : ! Mathematical constants
5223 : !---------------------------------------------------------------------
5224 : DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/, &
5225 : & SQRTPI/0.9189385332046727417803297D0/
5226 : !!!!& PI/3.1415926535897932384626434D0/ (already defined)
5227 : !---------------------------------------------------------------------
5228 : ! Machine dependent parameter
5229 : !---------------------------------------------------------------------
5230 : DATA XBIG,XMININ,EPS,XINF/171.624D0,2.23D-308,2.22D-16,1.79D308/
5231 : !---------------------------------------------------------------------
5232 : ! Numerator and denominator coefficients for rational minima
5233 : ! approximation over (1,2)
5234 : !---------------------------------------------------------------------
5235 : DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1, &
5236 : & -3.79804256470945635097577D+2,6.29331155312818442661052D+2, &
5237 : & 8.66966202790413211295064D+2,-3.14512729688483675254357D+4, &
5238 : & -3.61444134186911729807069D+4,6.64561438202405440627855D+4/
5239 : DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2, &
5240 : & -1.01515636749021914166146D+3,-3.10777167157231109440444D+3, &
5241 : & 2.25381184209801510330112D+4,4.75584627752788110767815D+3, &
5242 : & -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/
5243 : !---------------------------------------------------------------------
5244 : ! Coefficients for minimax approximation over (12, INF)
5245 : !---------------------------------------------------------------------
5246 : DATA C/-1.910444077728D-03,8.4171387781295D-04 , &
5247 : & -5.952379913043012D-04,7.93650793500350248D-04 , &
5248 : & -2.777777777777681622553D-03,8.333333333333333331554247D-02 , &
5249 : & 5.7083835261D-03/
5250 : !---------------------------------------------------------------------
5251 : ! Statement functions for conversion between integer and floa
5252 : !---------------------------------------------------------------------
5253 : CONV(I) = DBLE(I)
5254 120030 : PARITY = .FALSE.
5255 120030 : FACT = ONE
5256 120030 : N = 0
5257 120030 : Y = X
5258 120030 : IF (Y .LE. ZERO) THEN
5259 : !---------------------------------------------------------------------
5260 : ! Argument is negative
5261 : !---------------------------------------------------------------------
5262 0 : Y = -X
5263 0 : Y1 = AINT(Y)
5264 0 : RES = Y - Y1
5265 0 : IF (RES .NE. ZERO) THEN
5266 0 : IF (Y1 .NE. AINT(Y1*HALF)*TWO) PARITY = .TRUE.
5267 0 : FACT = -PI / SIN(PI*RES)
5268 0 : Y = Y + ONE
5269 : ELSE
5270 0 : RES = XINF
5271 0 : GO TO 900
5272 : END IF
5273 : END IF
5274 : !---------------------------------------------------------------------
5275 : ! Argument is positiv
5276 : !---------------------------------------------------------------------
5277 120030 : IF (Y .LT. EPS) THEN
5278 : !---------------------------------------------------------------------
5279 : ! Argument .LT. EPS
5280 : !---------------------------------------------------------------------
5281 0 : IF (Y .GE. XMININ) THEN
5282 0 : RES = ONE / Y
5283 : ELSE
5284 0 : RES = XINF
5285 0 : GO TO 900
5286 : END IF
5287 120030 : ELSE IF (Y .LT. TWELVE) THEN
5288 120030 : Y1 = Y
5289 120030 : IF (Y .LT. ONE) THEN
5290 : !---------------------------------------------------------------------
5291 : ! 0.0 .LT. argument .LT. 1.
5292 : !---------------------------------------------------------------------
5293 0 : Z = Y
5294 0 : Y = Y + ONE
5295 : ELSE
5296 : !---------------------------------------------------------------------
5297 : ! 1.0 .LT. argument .LT. 12.0, reduce argument if necessar
5298 : !---------------------------------------------------------------------
5299 120030 : N = INT(Y) - 1
5300 120030 : Y = Y - CONV(N)
5301 120030 : Z = Y - ONE
5302 : END IF
5303 : !---------------------------------------------------------------------
5304 : ! Evaluate approximation for 1.0 .LT. argument .LT. 2.
5305 : !---------------------------------------------------------------------
5306 120030 : XNUM = ZERO
5307 120030 : XDEN = ONE
5308 1080270 : DO 260 I = 1, 8
5309 960240 : XNUM = (XNUM + P(I)) * Z
5310 960240 : XDEN = XDEN * Z + Q(I)
5311 120030 : 260 CONTINUE
5312 120030 : RES = XNUM / XDEN + ONE
5313 120030 : IF (Y1 .LT. Y) THEN
5314 : !---------------------------------------------------------------------
5315 : ! Adjust result for case 0.0 .LT. argument .LT. 1.
5316 : !---------------------------------------------------------------------
5317 0 : RES = RES / Y1
5318 120030 : ELSE IF (Y1 .GT. Y) THEN
5319 : !---------------------------------------------------------------------
5320 : ! Adjust result for case 2.0 .LT. argument .LT. 12.
5321 : !---------------------------------------------------------------------
5322 446089 : DO 290 I = 1, N
5323 332062 : RES = RES * Y
5324 332062 : Y = Y + ONE
5325 114027 : 290 CONTINUE
5326 : END IF
5327 : ELSE
5328 : !---------------------------------------------------------------------
5329 : ! Evaluate for argument .GE. 12.0
5330 : !---------------------------------------------------------------------
5331 0 : IF (Y .LE. XBIG) THEN
5332 0 : YSQ = Y * Y
5333 0 : SUM = C(7)
5334 0 : DO 350 I = 1,6
5335 0 : SUM = SUM / YSQ + C(I)
5336 0 : 350 CONTINUE
5337 0 : SUM = SUM/Y - Y + SQRTPI
5338 0 : SUM = SUM + (Y-HALF)*LOG(Y)
5339 0 : RES = EXP(SUM)
5340 : ELSE
5341 0 : RES = XINF
5342 0 : GO TO 900
5343 : END IF
5344 : END IF
5345 : !---------------------------------------------------------------------
5346 : ! Final adjustments and retur
5347 : !---------------------------------------------------------------------
5348 120030 : IF (PARITY) RES = -RES
5349 120030 : IF (FACT .NE. ONE) RES = FACT / RES
5350 120030 : 900 GAMMAFUNC = RES
5351 : RETURN
5352 : ! ---------- Last line of GAMMA ---------
5353 : END FUNCTION GAMMAFUNC
5354 :
5355 :
5356 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5357 : !! SUBROUTINE shift4(v1,v2,v3,v4,NEW)
5358 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5359 331 : SUBROUTINE shift4(v1,v2,v3,v4,NEW)
5360 : real(dp), INTENT(IN) :: NEW
5361 : real(dp), INTENT(INOUT) :: v1,v2,v3,v4
5362 331 : v1=v2
5363 331 : v2=v3
5364 331 : v3=v4
5365 331 : v4=NEW
5366 : RETURN
5367 : END SUBROUTINE shift4
5368 :
5369 :
5370 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5371 : ! subroutine jbessel(bes,besp,bespp,ll,order,xx)
5372 : ! Spherical bessel function and derivatives
5373 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5374 0 : SUBROUTINE jbessel(bes,besp,bespp,ll,order,xx)
5375 : INTEGER,INTENT(IN) :: ll,order
5376 : real(dp),INTENT(IN) :: xx
5377 : real(dp),INTENT(OUT) :: bes,besp,bespp
5378 : INTEGER,PARAMETER :: imax=40
5379 : real(dp),PARAMETER :: prec=tol15
5380 : INTEGER :: ii,il
5381 : real(dp) :: besp1,fact,factp,factpp,jn,jnp,jnpp,jr,xx2,xxinv
5382 0 : IF (order>2) STOP "Wrong order in jbessel !"
5383 0 : IF (ABS(xx)<prec) THEN
5384 0 : bes=0._dp;IF (ll==0) bes=1._dp
5385 0 : IF (order>=1) THEN
5386 0 : besp=0._dp;IF (ll==1) besp=1._dp/3._dp
5387 : ENDIF
5388 0 : IF (order==2) THEN
5389 0 : bespp=0._dp
5390 0 : IF (ll==0) bespp=-1._dp/3._dp
5391 0 : IF (ll==2) bespp=2._dp/15._dp
5392 : ENDIF
5393 0 : RETURN
5394 : ENDIF
5395 0 : xxinv=1._dp/xx
5396 0 : IF (xx<1._dp) THEN
5397 0 : xx2=0.5_dp*xx*xx
5398 0 : fact=1.D0;DO il=1,ll;fact=fact*xx/DBLE(2*il+1);ENDDO
5399 : jn=1.D0;jr=1.D0;ii=0
5400 0 : DO WHILE(ABS(jr)>=prec.AND.ii<imax)
5401 0 : ii=ii+1;jr=-jr*xx2/DBLE(ii*(2*(ll+ii)+1))
5402 0 : jn=jn+jr
5403 : ENDDO
5404 0 : bes=jn*fact
5405 0 : IF (ABS(jr)>prec) STOP 'Error: Bessel function did not converge !'
5406 0 : IF (order>=1) THEN
5407 0 : factp=fact*xx/DBLE(2*ll+3)
5408 0 : jnp=1.D0;jr=1.D0;ii=0
5409 0 : DO WHILE(ABS(jr)>=prec.AND.ii<imax)
5410 0 : ii=ii+1;jr=-jr*xx2/DBLE(ii*(2*(ll+ii)+3))
5411 0 : jnp=jnp+jr
5412 : ENDDO
5413 0 : besp=-jnp*factp+jn*fact*xxinv*DBLE(ll)
5414 0 : IF (ABS(jr)>prec) STOP 'Error: 1st der. of Bessel function did not converge !'
5415 : ENDIF
5416 0 : IF (order==2) THEN
5417 0 : factpp=factp*xx/DBLE(2*ll+5)
5418 0 : jnpp=1.D0;jr=1.D0;ii=0
5419 0 : DO WHILE(ABS(jr)>=prec.AND.ii<imax)
5420 0 : ii=ii+1;jr=-jr*xx2/DBLE(ii*(2*(ll+ii)+5))
5421 0 : jnpp=jnpp+jr
5422 : ENDDO
5423 0 : besp1=-jnpp*factpp+jnp*factp*xxinv*DBLE(ll+1)
5424 0 : IF (ABS(jr)>prec) STOP 'Error: 2nd der. of Bessel function did not converge !'
5425 : ENDIF
5426 : ELSE
5427 0 : jn =SIN(xx)*xxinv
5428 0 : jnp=(-COS(xx)+jn)*xxinv
5429 0 : DO il=2,ll+1
5430 0 : jr=-jn+DBLE(2*il-1)*jnp*xxinv
5431 0 : jn=jnp;jnp=jr
5432 : ENDDO
5433 0 : bes=jn
5434 0 : IF (order>=1) besp =-jnp+jn *xxinv*DBLE(ll)
5435 0 : IF (order==2) besp1= jn -jnp*xxinv*DBLE(ll+2)
5436 : ENDIF
5437 0 : IF (order==2) bespp=-besp1+besp*ll*xxinv-bes*ll*xxinv*xxinv
5438 : END SUBROUTINE jbessel
5439 :
5440 :
5441 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5442 : ! subroutine solvbes(root,alpha,l,nq)
5443 : ! Find nq first roots of instrinsic equation:
5444 : ! alpha.jl(Q) + beta.Q.djl/dr(Q) = 0
5445 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5446 0 : SUBROUTINE solvbes(root,alpha,beta,ll,nq)
5447 : INTEGER,INTENT(IN) :: ll,nq
5448 : real(dp),INTENT(IN) :: alpha,beta
5449 : real(dp),INTENT(OUT) :: root(nq)
5450 : real(dp),PARAMETER :: dh=1.D-1, tol=1.D-14
5451 : INTEGER :: nroot
5452 : real(dp) :: dum,y1,y2,jbes,jbesp,qq,qx,hh
5453 0 : qq=dh;nroot=0
5454 0 : DO WHILE (nroot<nq)
5455 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qq)
5456 0 : y1=alpha*jbes+beta*qq*jbesp
5457 0 : qq=qq+dh
5458 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qq)
5459 0 : y2=alpha*jbes+beta*qq*jbesp
5460 0 : DO WHILE (y1*y2>=0.D0)
5461 0 : qq=qq+dh
5462 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qq)
5463 0 : y2=alpha*jbes+beta*qq*jbesp
5464 : ENDDO
5465 0 : hh=dh;qx=qq
5466 0 : DO WHILE (hh>tol)
5467 0 : hh=0.5D0*hh
5468 0 : IF (y1*y2<0) THEN
5469 0 : qx=qx-hh
5470 : ELSE
5471 0 : qx=qx+hh
5472 : ENDIF
5473 0 : CALL jbessel(jbes,jbesp,dum,ll,1,qx)
5474 0 : y2=alpha*jbes+beta*qx*jbesp
5475 : ENDDO
5476 0 : nroot=nroot+1
5477 0 : root(nroot)=qx
5478 : ENDDO
5479 0 : END SUBROUTINE solvbes
5480 :
5481 :
5482 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5483 : !! SUBROUTINE linsol(a,b,kk,la,ra,lb,det)
5484 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5485 3920 : SUBROUTINE linsol(a,b,kk,la,ra,lb,det)
5486 : INTEGER, INTENT(IN) :: kk,la,ra,lb
5487 : real(dp), INTENT(INOUT) :: a(la,ra),b(lb)
5488 : real(dp), OPTIONAL, INTENT(OUT) :: det
5489 : real(dp) :: d,s,r
5490 : INTEGER :: kkm,i,j,k,l,ipo,n,kmo
5491 3920 : d = 1._dp
5492 3920 : if (kk>min(la,ra,lb)) then
5493 0 : LIBPAW_ERROR('Dimension error in linsol ')
5494 : endif
5495 3920 : kkm=kk-1
5496 3920 : IF (kkm == 0) THEN
5497 0 : b(1)=b(1)/a(1,1)
5498 3920 : ELSE IF (kkm > 0) THEN
5499 23520 : DO i=1, kkm
5500 : s = 0.0_dp
5501 : l=i
5502 98000 : DO j=i,kk
5503 78400 : r=ABS(a(j,i))
5504 98000 : IF(r > s) THEN
5505 43120 : s=r
5506 43120 : l=j
5507 : ENDIF
5508 : ENDDO
5509 19600 : IF(l /= i) THEN
5510 86240 : DO j=i,kk
5511 70560 : s=a(i,j)
5512 70560 : a(i,j)=a(l,j)
5513 86240 : a(l,j)=s
5514 : ENDDO
5515 15680 : s=b(i)
5516 15680 : b(i)=b(l)
5517 15680 : b(l)=s
5518 15680 : d = -d
5519 : ENDIF
5520 23520 : IF (a(i,i) /= 0.0_dp) THEN
5521 19600 : ipo=i+1
5522 78400 : DO j=ipo,kk
5523 78400 : IF (a(j,i) /= 0.0_dp) THEN
5524 50960 : s=a(j,i)/a(i,i)
5525 50960 : a(j,i) = 0.0_dp
5526 227360 : DO k=ipo,kk
5527 227360 : a(j,k)=a(j,k)-a(i,k)*s
5528 : ENDDO
5529 50960 : b(j)=b(j)-b(i)*s
5530 : ENDIF
5531 : ENDDO
5532 : ENDIF
5533 : ENDDO
5534 27440 : DO i=1,kk
5535 27440 : d=d*a(i,i)
5536 : ENDDO
5537 3920 : kmo=kk-1
5538 3920 : b(kk)=b(kk)/a(kk,kk)
5539 23520 : DO i=1,kmo
5540 19600 : n=kk-i
5541 78400 : DO j=n,kmo
5542 78400 : b(n)=b(n)-a(n,j+1)*b(j+1)
5543 : ENDDO
5544 23520 : b(n)=b(n)/a(n,n)
5545 : ENDDO
5546 : ENDIF
5547 : !write(std_out,*) 'determinant from linsol ' , d
5548 3920 : IF(ABS(d).LT.tol10.and.has_to_print) then
5549 0 : WRITE(STD_OUT,*) '**warning from linsol --',&
5550 0 : & 'determinant too small --',d
5551 : endif
5552 3920 : If (present(det)) det=d
5553 3920 : END SUBROUTINE linsol
5554 :
5555 :
5556 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5557 : !! subroutine SolveAXeqB
5558 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5559 : SUBROUTINE SolveAXeqB(n,A,B,conditionNo)
5560 : ! General purpose AX=B solver for A, B real.
5561 : ! On return, B stores X
5562 : INTEGER, INTENT(IN) :: n
5563 : REAL(dp), INTENT(IN) :: A(:,:)
5564 : REAL(dp), INTENT(INOUT) :: B(:)
5565 : REAL(dp), INTENT(IN), OPTIONAL :: conditionNo
5566 : REAL(dp), ALLOCATABLE :: C(:,:),U(:,:),VT(:,:),X(:)
5567 : REAL(dp), ALLOCATABLE :: WORK(:)
5568 : REAL(dp), ALLOCATABLE :: S(:)
5569 : REAL(dp), PARAMETER :: rtol=1.d-9
5570 : INTEGER :: i,LWORK
5571 : REAL(dp) :: xx,tol
5572 : REAL(dp), PARAMETER :: one=1,zero=0
5573 : IF (n == 1) THEN
5574 : B(1)=B(1)/A(1,1)
5575 : RETURN
5576 : ENDIF
5577 : LWORK=MAX(200,n*n)
5578 : LIBPAW_ALLOCATE(C,(n,n))
5579 : LIBPAW_ALLOCATE(X,(n))
5580 : LIBPAW_ALLOCATE(U,(n,n))
5581 : LIBPAW_ALLOCATE(VT,(n,n))
5582 : LIBPAW_ALLOCATE(WORK,(LWORK))
5583 : LIBPAW_ALLOCATE(S,(n))
5584 : tol=rtol
5585 : IF (PRESENT(conditionNo)) tol=1._dp/conditionNo
5586 : C(1:n,1:n)=A(1:n,1:n)
5587 : CALL DGESVD('A','A',n,n,C,n,S,U,n,VT,n,WORK,LWORK,i)
5588 : tol=tol*S(1)
5589 : X=0
5590 : DO i=1,n
5591 : if(has_to_print) write(std_out,*) 'Solver, tol ',i,S(i),tol
5592 : IF (S(i)>tol) THEN
5593 : xx=DOT_PRODUCT(U(1:n,i),B(1:n))/S(i)
5594 : X(1:n)=X(1:n)+xx*(VT(i,1:n))
5595 : ENDIF
5596 : ENDDO
5597 : B=X
5598 : LIBPAW_DEALLOCATE(C)
5599 : LIBPAW_DEALLOCATE(X)
5600 : LIBPAW_DEALLOCATE(U)
5601 : LIBPAW_DEALLOCATE(VT)
5602 : LIBPAW_DEALLOCATE(WORK)
5603 : LIBPAW_DEALLOCATE(S)
5604 : END SUBROUTINE SolveAXeqB
5605 :
5606 :
5607 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5608 : !! subroutine SolveAXeqBM(n,A,B,many)
5609 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5610 18 : subroutine SolveAXeqBM(n,A,B,many)
5611 : integer, intent(in) :: n,many
5612 : real(dp), intent(in) :: A(:,:)
5613 : real(dp), intent(inout) :: B(:)
5614 : integer :: i,LWORK
5615 : real(dp), parameter :: rtol=tol9
5616 : real(dp), parameter :: one=1,zero=0
5617 : real(dp) :: xx
5618 18 : real(dp), allocatable :: C(:,:),U(:,:),VT(:,:),X(:)
5619 18 : real(dp), allocatable :: WORK(:)
5620 18 : real(dp), allocatable :: S(:)
5621 18 : if (many<1.or.many>n) then
5622 0 : LIBPAW_ERROR('Error in paw_SolveAXeqBM')
5623 : endif
5624 18 : if (n == 1) then
5625 0 : B(1)=B(1)/A(1,1)
5626 : return
5627 : endif
5628 18 : LWORK=max(200,n*n)
5629 72 : LIBPAW_ALLOCATE(C,(n,n))
5630 54 : LIBPAW_ALLOCATE(X,(n))
5631 54 : LIBPAW_ALLOCATE(U,(n,n))
5632 54 : LIBPAW_ALLOCATE(VT,(n,n))
5633 54 : LIBPAW_ALLOCATE(WORK,(LWORK))
5634 36 : LIBPAW_ALLOCATE(S,(n))
5635 330 : C(1:n,1:n)=A(1:n,1:n)
5636 18 : call DGESVD('A','A',n,n,C,n,S,U,n,VT,n,WORK,LWORK,i)
5637 84 : X=0
5638 84 : do i=1,n
5639 84 : if (i<=many) then
5640 312 : xx=DOT_PRODUCT(U(1:n,i),B(1:n))/S(i)
5641 312 : X(1:n)=X(1:n)+xx*(VT(i,1:n))
5642 : endif
5643 : enddo
5644 84 : B=X
5645 18 : LIBPAW_DEALLOCATE(C)
5646 18 : LIBPAW_DEALLOCATE(X)
5647 18 : LIBPAW_DEALLOCATE(U)
5648 18 : LIBPAW_DEALLOCATE(VT)
5649 18 : LIBPAW_DEALLOCATE(WORK)
5650 18 : LIBPAW_DEALLOCATE(S)
5651 : end subroutine SolveAXeqBM
5652 :
5653 :
5654 :
5655 :
5656 :
5657 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5658 : ! 9. Gridmod
5659 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5660 :
5661 :
5662 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5663 : ! SUBROUTINE taufromwfn(otau,Grid,wfn,l,energy,rv)
5664 : ! input radial wfn and output its kinetic energy density
5665 : ! note that total wavefunction is wfn/r * Ylm
5666 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5667 3214 : SUBROUTINE taufromwfn(otau,Grid,wfn,l,energy,rPot)
5668 : TYPE(GridInfo), INTENT(IN) :: Grid
5669 : REAL(dp), INTENT(IN) :: wfn(:)
5670 : REAL(dp), INTENT(IN), OPTIONAL :: rPot(:),energy
5671 : INTEGER, INTENT(IN) :: l
5672 : REAL(dp), INTENT(OUT) :: otau(:)
5673 : LOGICAL,PARAMETER :: from_e=.false.
5674 : INTEGER :: n
5675 : REAL(dp) :: fac
5676 3214 : REAL(dp), allocatable:: pbr(:),dpdr(:),d2pdr(:)
5677 3214 : n=Grid%n
5678 3214 : fac=l*(l+1)
5679 : !Note: Psi(r) = Yl.Wfn(r)/r
5680 : ! Tau(r) given in Rydberg units
5681 : !Note: there are several kinetic energy formulas
5682 : ! differing by something*Laplacian(rho(r))
5683 : IF (.not.from_e) THEN
5684 : ! Standard tau formula:
5685 : ! 4pir^2* Tau(r) = [r.d/dr(Wfn/r)]^2 + l(l+1) [Wfn/r]^2
5686 9642 : LIBPAW_ALLOCATE(pbr,(n))
5687 6428 : LIBPAW_ALLOCATE(dpdr,(n))
5688 12868856 : dpdr=0._dp;pbr=0._dp
5689 6431214 : pbr(2:n)=wfn(2:n)/Grid%r(2:n)
5690 3214 : CALL derivative(Grid,pbr,dpdr,2,n)
5691 6431214 : otau(2:n)=(Grid%r(2:n)*dpdr(2:n))**2 + fac*pbr(2:n)**2
5692 3214 : CALL extrapolate(otau) ; if (l>0) otau(1)=0._dp
5693 3214 : LIBPAW_DEALLOCATE(pbr)
5694 3214 : LIBPAW_DEALLOCATE(dpdr)
5695 : ELSEIF (from_e) THEN
5696 : IF (.NOT.(PRESENT(energy).AND.PRESENT(rPot))) then
5697 : STOP 'Error in taufromwfn: rPot and energy should be present!'
5698 : END IF
5699 : ! For testing purpose:
5700 : ! Another formula for the kinetic energy density
5701 : ! 4pir^2* Tau(r) = [Eigenvalue - Veff(r)]*Wfn^2
5702 : IF (.TRUE.) THEN
5703 : otau(2:n)=(energy-rPot(2:n)/Grid%r(2:n))*wfn(2:n)**2
5704 : CALL extrapolate(otau) ; if (l>0) otau(1)=0._dp
5705 : ! Another one:
5706 : ! From energy + correction
5707 : ELSE
5708 : LIBPAW_ALLOCATE(pbr,(n))
5709 : LIBPAW_ALLOCATE(dpdr,(n))
5710 : LIBPAW_ALLOCATE(d2pdr,(n))
5711 : pbr(2:n)=wfn(2:n)/Grid%r(2:n)
5712 : CALL derivative(Grid,pbr,dpdr,2,n)
5713 : otau(2:n)=dpdr(2:n)**2 *Grid%r(2:n)**2
5714 : d2pdr(2:n)=pbr(2:n)**2
5715 : call derivative(Grid,d2pdr,dpdr,2,n)
5716 : call derivative(Grid,dpdr,d2pdr,2,n)
5717 : d2pdr(2:n)=d2pdr(2:n)+2.*dpdr(2:n)/Grid%r(2:n)
5718 : otau(2:n)=0.5_dp*d2pdr(2:n)*Grid%r(2:n)**2 &
5719 : & +(energy-rPot(2:n)/Grid%r(2:n))*wfn(2:n)**2
5720 : otau(2:n)=otau(2:n) + fac*pbr(2:n)**2
5721 : CALL extrapolate(otau) ; if (l>0) otau(1)=0._dp
5722 : LIBPAW_DEALLOCATE(pbr)
5723 : LIBPAW_DEALLOCATE(dpdr)
5724 : LIBPAW_DEALLOCATE(d2pdr)
5725 : ENDIF
5726 : ENDIF
5727 3214 : call filter(n,otau,machine_zero)
5728 3214 : END SUBROUTINE taufromwfn
5729 :
5730 :
5731 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5732 : !! deltakinetic_ij(Grid,wfn1,wfn2,twfn1,twfn2,l,ekin,last)
5733 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5734 36 : SUBROUTINE deltakinetic_ij(Grid,wfn1,wfn2,twfn1,twfn2,l,ekin,last)
5735 : TYPE (GridInfo), INTENT(IN) :: Grid
5736 : real(dp), INTENT(IN) :: wfn1(:),wfn2(:),twfn1(:),twfn2(:)
5737 : INTEGER, INTENT(IN) :: l
5738 : real(dp), INTENT(OUT) :: ekin
5739 : INTEGER, INTENT(IN), OPTIONAL :: last
5740 36 : real(dp), ALLOCATABLE :: dfdr1(:),dfdr2(:),arg1(:),arg2(:)
5741 36 : real(dp), ALLOCATABLE :: tdfdr1(:),tdfdr2(:),targ1(:),targ2(:)
5742 : INTEGER :: i,n
5743 36 : n=Grid%n
5744 36 : if (present(last)) n=last
5745 108 : LIBPAW_ALLOCATE(dfdr1,(n))
5746 72 : LIBPAW_ALLOCATE(arg1,(n))
5747 72 : LIBPAW_ALLOCATE(dfdr2,(n))
5748 72 : LIBPAW_ALLOCATE(arg2,(n))
5749 72 : LIBPAW_ALLOCATE(tdfdr1,(n))
5750 72 : LIBPAW_ALLOCATE(targ1,(n))
5751 72 : LIBPAW_ALLOCATE(tdfdr2,(n))
5752 72 : LIBPAW_ALLOCATE(targ2,(n))
5753 36 : CALL derivative(Grid,wfn1,dfdr1,1,n)
5754 36 : CALL derivative(Grid,wfn2,dfdr2,1,n)
5755 36 : CALL derivative(Grid,twfn1,tdfdr1,1,n)
5756 36 : CALL derivative(Grid,twfn2,tdfdr2,1,n)
5757 202032 : arg1=0; arg2=0; targ1=0; targ2=0
5758 50472 : DO i=2,n
5759 50436 : arg1(i)=wfn1(i)/Grid%r(i)
5760 50436 : arg2(i)=wfn2(i)/Grid%r(i)
5761 50436 : targ1(i)=twfn1(i)/Grid%r(i)
5762 50472 : targ2(i)=twfn2(i)/Grid%r(i)
5763 : ENDDO
5764 50508 : DO i=1,n
5765 : arg1(i)=(dfdr1(i)*dfdr2(i)-tdfdr1(i)*tdfdr2(i))&
5766 50508 : & +(l*(l+1))*(arg1(i)*arg2(i)-targ1(i)*targ2(i))
5767 : ENDDO
5768 36 : ekin=integrator(Grid,arg1,1,n)
5769 36 : LIBPAW_DEALLOCATE(dfdr1)
5770 36 : LIBPAW_DEALLOCATE(arg1)
5771 36 : LIBPAW_DEALLOCATE(dfdr2)
5772 36 : LIBPAW_DEALLOCATE(arg2)
5773 36 : LIBPAW_DEALLOCATE(tdfdr1)
5774 36 : LIBPAW_DEALLOCATE(targ1)
5775 36 : LIBPAW_DEALLOCATE(tdfdr2)
5776 36 : LIBPAW_DEALLOCATE(targ2)
5777 36 : END SUBROUTINE deltakinetic_ij
5778 :
5779 :
5780 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5781 : !! SUBROUTINE atompaw_poisson(Grid,q,den,rv,ecoul,v00)
5782 : !! Use Numerov algorithm to solve poisson equation
5783 : !! den(n) is electron density * (4*pi*r**2)
5784 : !! rv(n) is returned as electrostatic potential * r
5785 : !! ecoul is the coulomb interaction energy
5786 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5787 25 : SUBROUTINE atompaw_poisson(Grid,q,den,rv,ecoul,v00)
5788 : TYPE (GridInfo), INTENT(IN) :: Grid
5789 : real(dp), INTENT(IN):: den(:)
5790 : real(dp), INTENT(INOUT) :: rv(:),ecoul,q
5791 : real(dp), OPTIONAL, INTENT(OUT) :: v00
5792 25 : real(dp), ALLOCATABLE :: a(:),b(:)
5793 : real(dp) :: sd,sl,h,h2
5794 : INTEGER :: i,n
5795 25 : n=Grid%n
5796 25 : h=Grid%h
5797 50050 : rv=0._dp
5798 25 : q=integrator(Grid,den)
5799 75 : LIBPAW_ALLOCATE(a,(n))
5800 50 : LIBPAW_ALLOCATE(b,(n))
5801 25 : IF (Grid%type==lineargrid) THEN
5802 0 : sd=2
5803 0 : sl=-1
5804 0 : a(1)=0
5805 0 : DO i=2,n
5806 0 : a(i)=h*den(i)/(6*(i-1))
5807 : ENDDO
5808 0 : rv(1)=0
5809 0 : rv(2)=10*a(2)+a(3)
5810 0 : DO i=3,n-1
5811 0 : rv(i)=10*a(i)+a(i+1)+a(i-1)
5812 : ENDDO
5813 0 : rv(n)=10*a(n)+a(n-1)+2*q
5814 25 : ELSEIF (Grid%type==loggrid) THEN
5815 25 : sd=2+10*h*h/48
5816 25 : sl=-1+h*h/48
5817 25 : a(1)=0
5818 25 : h2=h*h
5819 50025 : DO i=2,n
5820 50025 : a(i)=h2*Grid%rr02(i)*den(i)/(6*Grid%r(i))/Grid%pref(i)
5821 : ENDDO
5822 25 : rv(1)=0
5823 25 : rv(2)=10*a(2)+a(3)
5824 49975 : DO i=3,n-1
5825 49975 : rv(i)=10*a(i)+a(i+1)+a(i-1)
5826 : ENDDO
5827 : ! last term is boundary value at point n+1
5828 25 : rv(n)=10*a(n)+a(n-1)-2*q*sl/(Grid%pref(n)*EXP(h/2))
5829 : ENDIF
5830 25 : CALL conthomas(n,sl,sd,rv)
5831 50050 : IF (Grid%type==loggrid) rv=rv*Grid%pref
5832 : ! calculate ecoul
5833 50025 : DO i=2,n
5834 50025 : a(i)=den(i)*rv(i)/Grid%r(i)
5835 : ENDDO
5836 25 : a(1)=0
5837 25 : ecoul=integrator(Grid,a)*0.5_dp
5838 25 : IF (PRESENT(v00)) THEN
5839 46046 : a=0
5840 46023 : a(2:n)=den(2:n)/Grid%r(2:n)
5841 23 : v00=2*integrator(Grid,a)
5842 : ENDIF
5843 25 : LIBPAW_DEALLOCATE(a)
5844 25 : LIBPAW_DEALLOCATE(b)
5845 25 : END SUBROUTINE atompaw_poisson
5846 :
5847 :
5848 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5849 : !! SUBROUTINE poisson_marc(Grid,q,den,rv,ecoul)
5850 : !! use Numerov algorithm to solve poisson equation
5851 : !! den(n) is electron density * (4*pi*r**2)
5852 : !! rv(n) is returned as electrostatic potential * r
5853 : !! ecoul is the coulomb interation energy
5854 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5855 354 : SUBROUTINE poisson_marc(Grid,q,den,rv,ecoul)
5856 : TYPE (GridInfo), INTENT(IN) :: Grid
5857 : real(dp), INTENT(IN):: den(:)
5858 : real(dp), INTENT(INOUT) :: rv(:),ecoul,q
5859 354 : real(dp), ALLOCATABLE :: aa(:),bb(:),cc(:),dd(:)
5860 : real(dp) :: h
5861 : INTEGER :: i,n,ir,jr
5862 354 : n=Grid%n
5863 354 : h=Grid%h
5864 708708 : rv=0._dp
5865 354 : q=integrator(Grid,den)
5866 1062 : LIBPAW_ALLOCATE(aa,(n))
5867 708 : LIBPAW_ALLOCATE(bb,(n))
5868 708 : LIBPAW_ALLOCATE(cc,(n))
5869 708 : LIBPAW_ALLOCATE(dd,(n))
5870 708354 : DO jr=n,2,-1
5871 708000 : ir=n-jr+1
5872 708000 : aa(ir)=den(jr)*Grid%drdu(jr)
5873 708354 : bb(ir)=den(jr)*Grid%drdu(jr)/Grid%r(jr)
5874 : END DO
5875 708708 : cc=0._dp
5876 354 : cc(5)=aa(n-4);cc(4)=aa(n-3);cc(3)=aa(n-2);cc(2)=aa(n-1)
5877 354 : cc(1)=cc(4)+3._dp*(cc(2)-cc(3)) !call extrapolate(Grid,cc)
5878 354 : aa(n)=cc(1)
5879 354 : cc(5)=bb(n-4);cc(4)=bb(n-3);cc(3)=bb(n-2);cc(2)=bb(n-1)
5880 354 : cc(1)=cc(4)+3._dp*(cc(2)-cc(3)) !call extrapolate(Grid,cc)
5881 354 : bb(n)=cc(1)
5882 354 : cc(1)=0._dp;dd(1)=0._dp
5883 354 : DO ir=3,n,2
5884 354000 : cc(ir) =cc(ir-2)+h/3._dp*(aa(ir-2)+4._dp*aa(ir-1)+aa(ir))
5885 354000 : cc(ir-1)=cc(ir-2)+h/3._dp*(1.25_dp*aa(ir-2)+2.0_dp*aa(ir-1)-0.25_dp*aa(ir))
5886 354000 : dd(ir) =dd(ir-2)+h/3._dp*(bb(ir-2)+4._dp*bb(ir-1)+bb(ir))
5887 354000 : dd(ir-1)=dd(ir-2)+h/3._dp*(1.25_dp*bb(ir-2)+2._dp*bb(ir-1)-0.25_dp*bb(ir))
5888 : END DO
5889 354 : IF (MOD(n,2)==0) THEN
5890 0 : cc(n)=cc(n-1)+h/3._dp*(1.25_dp*aa(n-2)+2._dp*aa(n-1)-0.25_dp*aa(n))
5891 0 : dd(n)=dd(n-1)+h/3._dp*(1.25_dp*bb(n-2)+2._dp*bb(n-1)-0.25_dp*bb(n))
5892 : END IF
5893 354 : rv(1)=0._dp
5894 708354 : DO ir=2,n
5895 708000 : jr=n-ir+1
5896 708354 : rv(ir)=2._dp*(dd(jr)*Grid%r(ir)+(cc(n)-cc(jr))) !Ha->Ry
5897 : END DO
5898 354 : if (n<Grid%n) rv(n+1:Grid%n)=rv(n)
5899 : ! calculate ecoul
5900 354 : aa(1)=0._dp
5901 708354 : do i=2,n
5902 708354 : aa(i)=den(i)*rv(i)/Grid%r(i)
5903 : end do
5904 354 : ecoul=0.5_dp*integrator(Grid,aa)
5905 354 : LIBPAW_DEALLOCATE(aa)
5906 354 : LIBPAW_DEALLOCATE(bb)
5907 354 : LIBPAW_DEALLOCATE(cc)
5908 354 : LIBPAW_DEALLOCATE(dd)
5909 354 : END SUBROUTINE poisson_marc
5910 :
5911 :
5912 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5913 : !! zeropot(Grid,rv,v0,v0p)
5914 : !! extrapolate potential to value at r=0
5915 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5916 403 : SUBROUTINE zeropot(Grid,rv,v0,v0p)
5917 : TYPE (GridInfo), INTENT(IN):: Grid
5918 : real(dp), INTENT(IN) :: rv(:) ! Note: rv(1) corresponds to r=0
5919 : real(dp), INTENT(OUT) :: v0,v0p
5920 : real(dp) :: tmp(15),tmp1(15)
5921 6045 : tmp(2:15)=rv(2:15)/Grid%r(2:15)
5922 403 : CALL extrapolate(tmp(1:15))
5923 403 : v0=tmp(1)
5924 403 : CALL derivative(Grid,tmp(1:15),tmp1(1:15),2,15)
5925 403 : CALL extrapolate(tmp1(1:15))
5926 403 : v0p=tmp1(1)
5927 403 : END SUBROUTINE zeropot
5928 :
5929 :
5930 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5931 : !! subroutine kinetic(Grid,wfn,l,ekin)
5932 : !! calculates expectation value of kinetic energy for wfn
5933 : !! with orbital angular momentum l
5934 : !! wfn == r*radialwfn in Schroedinger Equation
5935 : !! assumes wfn=(constant)*r^(l+1) at small r
5936 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5937 : SUBROUTINE kinetic(Grid,wfn,l,ekin)
5938 : TYPE (GridInfo), INTENT(IN) :: Grid
5939 : real(dp), INTENT(IN) :: wfn(:)
5940 : INTEGER, INTENT(IN) :: l
5941 : real(dp), INTENT(OUT) :: ekin
5942 : real(dp), ALLOCATABLE :: dfdr(:),arg(:)
5943 : INTEGER :: i,n
5944 : n=Grid%n
5945 : LIBPAW_ALLOCATE(dfdr,(n))
5946 : LIBPAW_ALLOCATE(arg,(n))
5947 : CALL derivative(Grid,wfn,dfdr)
5948 : arg=0
5949 : DO i=2,n
5950 : arg(i)=wfn(i)/Grid%r(i)
5951 : ENDDO
5952 : DO i=1,n
5953 : arg(i)=(dfdr(i))**2+(l*(l+1))*(arg(i))**2
5954 : ENDDO
5955 : ekin=integrator(Grid,arg)!*0.5!Hartree
5956 : LIBPAW_DEALLOCATE(dfdr)
5957 : LIBPAW_DEALLOCATE(arg)
5958 : END SUBROUTINE kinetic
5959 :
5960 :
5961 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5962 : !! subroutine altkinetic(Grid,wfn,energy,rv,ekin)
5963 : !! calculates expectation value of kinetic energy for wfn
5964 : !! with orbital wfn by integrating
5965 : !! int(wfn**2 * (energy-rv/r), r=0..rmax)
5966 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5967 2230 : SUBROUTINE altkinetic(Grid,wfn,energy,rv,ekin)
5968 : TYPE (GridInfo), INTENT(IN) :: Grid
5969 : real(dp), INTENT(IN) :: wfn(:),rv(:),energy
5970 : real(dp), INTENT(OUT) :: ekin
5971 2230 : real(dp), ALLOCATABLE :: arg(:)
5972 : INTEGER :: i,n
5973 2230 : n=Grid%n
5974 6690 : LIBPAW_ALLOCATE(arg,(n))
5975 4464460 : arg=0
5976 4462230 : DO i=2,n
5977 4462230 : arg(i)=(wfn(i)**2)*(energy-rv(i)/Grid%r(i))
5978 : ENDDO
5979 2230 : ekin=integrator(Grid,arg)
5980 2230 : LIBPAW_DEALLOCATE(arg)
5981 2230 : END SUBROUTINE altkinetic
5982 :
5983 :
5984 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5985 : !! overint(n,h,f1,icorr)
5986 : !! function to calculate the integral of one vectors f1
5987 : !! using simpsons rule assuming a regular grid with
5988 : !! spacing of h and n total points
5989 : !! icorr: optional parameter: used only when n is even
5990 : !! if icorr<0, a trapezoidal correction is applied
5991 : !! at the start of interval
5992 : !! if icorr>=0, a trapezoidal correction is applied
5993 : !! at the end of interval
5994 : !! default (if missing) is icorr=0
5995 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5996 61574 : FUNCTION overint(n,h,f1,icorr)
5997 : real(dp) :: overint
5998 : INTEGER, INTENT(IN) :: n
5999 : real(dp), INTENT(IN) :: h,f1(:)
6000 : INTEGER, OPTIONAL :: icorr
6001 : real(dp),PARAMETER :: tol=1.D-14
6002 : INTEGER :: i,j,istart,m
6003 61574 : overint=0
6004 : !Eliminate zeros at end of interval
6005 13957174 : i=n;DO WHILE(ABS(f1(i))<machine_zero.AND.i>2);i=i-1;ENDDO
6006 61574 : m=MIN(i+1,n)
6007 61574 : IF (m<=1) THEN
6008 : RETURN
6009 61574 : ELSEIF (m==2) THEN
6010 0 : overint=(f1(1)+f1(2))*(h/2) ! Trapezoidal rule
6011 0 : RETURN
6012 : ENDIF
6013 61574 : istart=1
6014 61574 : IF (PRESENT(icorr)) THEN
6015 61574 : IF (icorr<0.AND.MOD(m,2)==0) istart=2
6016 : ENDIF
6017 61574 : overint=f1(istart)+4*f1(istart+1)+f1(istart+2)
6018 61574 : j=((m-istart)/2)*2+istart
6019 61574 : IF (j>=istart+4) THEN
6020 61571 : DO i=istart+4,j,2
6021 53715109 : overint=overint+f1(i-2)+4*f1(i-1)+f1(i)
6022 : ENDDO
6023 : ENDIF
6024 61574 : overint=overint*(h/3)
6025 61574 : IF (m>j) overint=overint+(f1(j)+f1(m))*(h/2)
6026 61574 : IF (istart==2) overint=overint+(f1(1)+f1(2))*(h/2)
6027 : RETURN
6028 : END FUNCTION overint
6029 :
6030 :
6031 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6032 : !! function integrator(Grid,arg)
6033 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6034 61574 : FUNCTION integrator(Grid,arg,str,fin)
6035 : real(dp) :: integrator
6036 : TYPE(GridInfo), INTENT(IN) :: Grid
6037 : real(dp), INTENT(IN) :: arg(:)
6038 : INTEGER, INTENT(IN), OPTIONAL :: str,fin
6039 61574 : real(dp), ALLOCATABLE :: dum(:)
6040 : INTEGER :: n,i1,i2
6041 61574 : n=Grid%n
6042 61574 : i1=1;i2=n
6043 61574 : IF (PRESENT(str).AND.PRESENT(fin)) THEN
6044 57565 : i1=str; i2=fin; n=i2-i1+1
6045 : ENDIF
6046 61574 : SELECT CASE(Grid%type)
6047 : CASE default
6048 0 : LIBPAW_ERROR('Error in integrator')
6049 : CASE(lineargrid)
6050 0 : integrator=overint(n,Grid%h,arg(i1:i2))
6051 : CASE(loggrid)
6052 184722 : LIBPAW_BOUND1_ALLOCATE(dum,BOUNDS(i1,i2))
6053 121547557 : dum(i1:i2)=arg(i1:i2)*Grid%drdu(i1:i2)
6054 61574 : integrator=overint(n,Grid%h,dum(i1:i2),-1)
6055 123148 : LIBPAW_DEALLOCATE(dum)
6056 : END SELECT
6057 61574 : END FUNCTION integrator
6058 :
6059 :
6060 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6061 : !! function FindGridIndex(Grid,rpoint)
6062 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6063 40085 : FUNCTION FindGridIndex(Grid,rpoint)
6064 : INTEGER :: FindGridIndex
6065 : TYPE (GridInfo), INTENT(IN) :: Grid
6066 : real(dp), INTENT(IN) :: rpoint
6067 : real(dp) :: r0
6068 40085 : FindGridIndex=0
6069 40085 : IF (Grid%type==lineargrid) THEN
6070 0 : FindGridIndex=rpoint/Grid%h+1
6071 0 : IF (Grid%h*(FindGridIndex-1)<rpoint-tol10) FindGridIndex=FindGridIndex+1
6072 40085 : ELSEIF (Grid%type==loggrid) THEN
6073 40085 : r0=Grid%drdu(1)
6074 40085 : FindGridIndex=LOG(rpoint/r0+1)/Grid%h+1
6075 40085 : IF (r0*EXP(Grid%h*(FindGridIndex-1))<rpoint-tol10) &
6076 40078 : & FindGridIndex=FindGridIndex+1
6077 : ENDIF
6078 40085 : END FUNCTION FindGridIndex
6079 :
6080 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6081 : !! function gridindex(Grid,r)
6082 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6083 : FUNCTION gridindex(Grid,r)
6084 : INTEGER :: gridindex
6085 : TYPE (GridInfo), INTENT(IN) :: Grid
6086 : REAL(dp), INTENT(IN) :: r
6087 : gridindex=0
6088 : IF (Grid%type==lineargrid) THEN
6089 : gridindex=r/Grid%h +0.1d0 +1
6090 : ELSEIF (Grid%type==loggrid) THEN
6091 : gridindex=LOG(1.d0+r/Grid%drdu(1))/Grid%h +0.1d0 +1
6092 : ENDIF
6093 : END FUNCTION gridindex
6094 :
6095 :
6096 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6097 : !! ClassicalTurningPoint(Grid,rv,l,energy,turningpoint)
6098 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6099 40052 : SUBROUTINE ClassicalTurningPoint(Grid,rv,l,energy,turningpoint)
6100 : TYPE(GridInfo), INTENT(IN) :: Grid
6101 : real(dp), INTENT(IN) :: rv(:)
6102 : INTEGER, INTENT(IN) :: l
6103 : real(dp), INTENT(IN) :: energy
6104 : INTEGER, INTENT(OUT) :: turningpoint
6105 : INTEGER :: i,n
6106 40052 : real(dp), ALLOCATABLE :: v(:)
6107 40052 : n=Grid%n
6108 120156 : LIBPAW_ALLOCATE(v,(n))
6109 80184104 : v=0
6110 80144052 : v(2:n)=rv(2:n)/Grid%r(2:n)+l*(l+1)/(Grid%r(2:n)**2)!hartree
6111 : turningpoint=n
6112 51997607 : DO i=n,2,-1
6113 51997607 : IF (v(i)<energy) EXIT
6114 : ENDDO
6115 : turningpoint=i
6116 40052 : turningpoint=MIN(turningpoint,FindGridIndex(Grid,10.0_dp))
6117 40052 : LIBPAW_DEALLOCATE(v)
6118 40052 : END SUBROUTINE ClassicalTurningPoint
6119 :
6120 :
6121 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6122 : !! getwfnfromcfdsol(start,finish,yy,wfn)
6123 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6124 36031 : subroutine getwfnfromcfdsol(start,finish,yy,wfn)
6125 : INTEGER, INTENT(IN) :: start,finish
6126 : real(dp), INTENT(IN) :: yy(:,:)
6127 : real(dp), INTENT(INOUT) :: wfn(:)
6128 : INTEGER :: i
6129 72133435 : wfn=0
6130 36570103 : do i=start,finish
6131 36570103 : wfn(i)=yy(1,i)
6132 : enddo
6133 36031 : end subroutine getwfnfromcfdsol
6134 :
6135 :
6136 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6137 : !! countnodes(start,finish,wfn,filter)
6138 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6139 35362 : INTEGER function countnodes(start,finish,wfn,filter)
6140 : INTEGER, INTENT(IN) :: start,finish
6141 : real(dp), INTENT(IN) :: wfn(:)
6142 : real(dp), INTENT(IN), OPTIONAL :: filter
6143 : INTEGER :: i,nodes
6144 35362 : nodes=0
6145 23105223 : do i=start+1,finish
6146 23069861 : if (wfn(i)*wfn(i-1)<0._dp) nodes=nodes+1
6147 23105223 : if (PRESENT(filter)) then
6148 0 : If((abs(wfn(i))+abs(wfn(i-1)))<filter) exit
6149 : endif
6150 : enddo
6151 35362 : countnodes=nodes
6152 35362 : end function countnodes
6153 :
6154 :
6155 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6156 : !! extrapolate(Grid,v)
6157 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6158 5853 : SUBROUTINE extrapolate(v)
6159 : ! extrapolate array v to r=0 at v(1)
6160 : real(dp), INTENT(INOUT) :: v(:) ! assume v(2),v(3)... given
6161 5853 : v(1)=5._dp*v(2)-10._dp*v(3)+10._dp*v(4)-5._dp*v(5)+v(6) ! fourth order formula
6162 5853 : END SUBROUTINE extrapolate
6163 :
6164 :
6165 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6166 : !! subroutine derivative(Grid,f,dfdr,begin,bend)
6167 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6168 15426 : SUBROUTINE derivative(Grid,f,dfdr,begin,bend)
6169 : TYPE(GridInfo), INTENT(IN) :: Grid
6170 : real(dp), INTENT(IN) :: f(:)
6171 : real(dp), INTENT(OUT) :: dfdr(:)
6172 : INTEGER, OPTIONAL, INTENT(IN) :: begin,bend
6173 : INTEGER :: i,n,i1,i2
6174 15426 : i1=1;i2=Grid%n;n=i2-i1+1
6175 15426 : IF (PRESENT(begin).OR.PRESENT(bend)) THEN
6176 15008 : IF (begin>=1.AND.bend<= Grid%n) THEN
6177 15008 : i1=begin;i2=bend;n=i2-i1+1
6178 : ELSE
6179 0 : LIBPAW_ERROR('Error in derivative')
6180 : ENDIF
6181 : ENDIF
6182 15426 : SELECT CASE(Grid%type)
6183 : CASE default
6184 0 : LIBPAW_ERROR('Error in derivative')
6185 : CASE(lineargrid)
6186 0 : CALL nderiv(Grid%h,f(i1:i2),dfdr(i1:i2),n,i)
6187 0 : IF (i/=0) THEN
6188 0 : LIBPAW_ERROR('Error in derivative -nderiv problem')
6189 : ENDIF
6190 : CASE(loggrid)
6191 15426 : CALL nderiv(Grid%h,f(i1:i2),dfdr(i1:i2),n,i)
6192 15426 : IF (i/=0) THEN
6193 0 : LIBPAW_ERROR('Error in derivative -nderiv problem')
6194 : ENDIF
6195 9220973 : dfdr(i1:i2)=dfdr(i1:i2)/Grid%drdu(i1:i2)
6196 : END SELECT
6197 15426 : END SUBROUTINE derivative
6198 :
6199 :
6200 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6201 : !! nderiv(h,y,z,ndim,ierr)
6202 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6203 15426 : SUBROUTINE nderiv(h,y,z,ndim,ierr)
6204 : INTEGER, INTENT(IN) :: ndim
6205 : INTEGER, INTENT(INOUT) :: ierr
6206 : real(dp) , INTENT(IN) :: h,y(:)
6207 : real(dp) , INTENT(INOUT) :: z(:)
6208 : real(dp) :: hh,yy,a,b,c
6209 : INTEGER :: i
6210 15426 : ierr=-1
6211 15426 : IF (ndim.LT.5) RETURN
6212 : ! prepare differentiation loop
6213 15426 : hh=.08333333333333333_dp/h
6214 15426 : yy=y(ndim-4)
6215 15426 : b=hh*(-25._dp*y(1)+48._dp*y(2)-36._dp*y(3)+16._dp*y(4)-3._dp*y(5))
6216 15426 : c=hh*(-3._dp*y(1)-10._dp*y(2)+18._dp*y(3)-6._dp*y(4)+y(5))
6217 : ! start differentiation loop
6218 9143843 : DO i=5,ndim
6219 9128417 : a=b
6220 9128417 : b=c
6221 9128417 : c=hh*(y(i-4)-y(i)+8._dp*(y(i-1)-y(i-3)))
6222 9143843 : z(i-4)=a
6223 : ENDDO
6224 : ! end of differentiation loop
6225 : ! normal exit
6226 : a=hh*(-yy+6._dp*y(ndim-3)-18._dp*y(ndim-2)+10._dp*y(ndim-1) &
6227 15426 : & +3._dp*y(ndim))
6228 : z(ndim)=hh*(3._dp*yy-16._dp*y(ndim-3)+36._dp*y(ndim-2) &
6229 15426 : & -48._dp*y(ndim-1)+25._dp*y(ndim))
6230 15426 : z(ndim-1)=a
6231 15426 : z(ndim-2)=c
6232 15426 : z(ndim-3)=b
6233 15426 : ierr=0
6234 15426 : RETURN
6235 : END SUBROUTINE nderiv
6236 :
6237 :
6238 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6239 : !! Second derivative for general grid
6240 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6241 2 : FUNCTION Gsecondderiv(Grid,index,g)
6242 : real(dp) :: Gsecondderiv
6243 : TYPE (GridInfo), INTENT(IN) :: Grid
6244 : INTEGER, INTENT(IN) :: index
6245 : real(dp), INTENT(IN) :: g(:)
6246 2 : Gsecondderiv=0
6247 2 : IF (Grid%type==lineargrid) THEN
6248 0 : Gsecondderiv=secondderiv(index,g,Grid%h)
6249 2 : ELSEIF (Grid%type==loggrid) THEN
6250 : Gsecondderiv=(secondderiv(index,g,Grid%h)&
6251 2 : & -firstderiv(index,g,Grid%h))/Grid%rr02(index)
6252 : ENDIF
6253 2 : END FUNCTION Gsecondderiv
6254 :
6255 :
6256 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6257 : !! First derivative for general grid
6258 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6259 35784 : FUNCTION Gfirstderiv(Grid,index,g)
6260 : real(dp) :: Gfirstderiv
6261 : TYPE (GridInfo), INTENT(IN) :: Grid
6262 : INTEGER, INTENT(IN) :: index
6263 : real(dp), INTENT(IN) :: g(:)
6264 35784 : Gfirstderiv=0
6265 35784 : IF (Grid%type==lineargrid) THEN
6266 0 : Gfirstderiv=firstderiv(index,g,Grid%h)
6267 35784 : ELSEIF (Grid%type==loggrid) THEN
6268 35784 : Gfirstderiv=firstderiv(index,g,Grid%h)/Grid%drdu(index)
6269 : ENDIF
6270 35784 : END FUNCTION Gfirstderiv
6271 :
6272 :
6273 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6274 : !! finite difference second derivative
6275 : !! based on 5 point formula
6276 : !! Ref. Engeln-Mullges & Uhlig (1996)
6277 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6278 2 : FUNCTION secondderiv(index,f,h)
6279 : real(dp) :: secondderiv
6280 : INTEGER, INTENT(IN) :: index
6281 : real(dp), INTENT(IN) :: f(:),h
6282 : INTEGER :: n
6283 2 : n=SIZE(f)
6284 2 : secondderiv=0
6285 2 : if (index==1.and.n>=5) THEN
6286 0 : secondderiv=(70*f(1)-208*f(2)+228*f(3)-112*f(4)+22*f(5))/(24*h*h)
6287 2 : else if (index==2.and.n>=5) THEN
6288 0 : secondderiv=(22*f(1)-40*f(2)+12*f(3)+8*f(4)-2*f(5))/(24*h*h)
6289 2 : else if (index>2.and.index<=n-2) THEN
6290 : secondderiv=-(f(index-2)+f(index+2))/12 + &
6291 2 : & 4*(f(index-1)+f(index+1))/3 - 5*f(index)/2
6292 2 : secondderiv=secondderiv/(h*h)
6293 0 : else if (index>=5.and.index==n-1) THEN
6294 0 : secondderiv=(-2*f(n-4)+8*f(n-3)+12*f(n-2)-40*f(n-1)+22*f(n))/(24*h*h)
6295 0 : else if (index>=5.and.index==n) THEN
6296 0 : secondderiv=(22*f(n-4)-112*f(n-3)+228*f(n-2)-208*f(n-1)+70*f(n))/(24*h*h)
6297 : else
6298 0 : LIBPAW_ERROR('Error in secondderiv')
6299 : ENDIF
6300 2 : END FUNCTION secondderiv
6301 :
6302 :
6303 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6304 : !! finite difference first derivative
6305 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6306 35786 : FUNCTION firstderiv(index,f,h)
6307 : real(dp) :: firstderiv
6308 : INTEGER, INTENT(IN) :: index
6309 : real(dp), INTENT(IN) :: f(:),h
6310 : INTEGER :: n
6311 35786 : n=SIZE(f)
6312 35786 : firstderiv=0
6313 35786 : if (index==1.and.n>=5) THEN
6314 0 : firstderiv=(-25*f(1)+48*f(2)-36*f(3)+16*f(4)-3*f(5))/(12*h)
6315 35786 : else if (index==2.and.n>=5) THEN
6316 0 : firstderiv=(-3*f(1)-10*f(2)+18*f(3)-6*f(4)+f(5))/(12*h)
6317 35786 : else if (index>2.and.index<=n-2) THEN
6318 35786 : firstderiv=(f(index-2)-8*f(index-1)+8*f(index+1)-f(index+2))/(12*h)
6319 0 : else if (index>=5.and.index==n-1) THEN
6320 0 : firstderiv=(-f(n-4)+6*f(n-3)-18*f(n-2)+10*f(n-1)+3*f(n))/(12*h)
6321 0 : else if (index>=5.and.index==n) THEN
6322 0 : firstderiv=(3*f(n-4)-16*f(n-3)+36*f(n-2)-48*f(n-1)+25*f(n))/(12*h)
6323 : else
6324 0 : LIBPAW_ERROR('Error in firstderiv')
6325 : ENDIF
6326 35786 : END FUNCTION firstderiv
6327 :
6328 :
6329 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6330 : !! function to calculate the overlap between two vectors f1 and f2
6331 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6332 54317 : FUNCTION overlap(Grid,f1,f2,str,fin)
6333 : real(dp) :: overlap
6334 : TYPE(GridInfo), INTENT(IN) :: Grid
6335 : real(dp), INTENT(IN) :: f1(:),f2(:)
6336 : INTEGER, INTENT(IN), OPTIONAL :: str,fin
6337 54317 : real(dp), ALLOCATABLE :: dum(:)
6338 : INTEGER :: n,i1,i2
6339 54317 : n=Grid%n
6340 54317 : i1=1;i2=n
6341 54317 : IF (PRESENT(str).AND.PRESENT(fin)) THEN
6342 182 : i1=str; i2=fin; n=i2-i1+1
6343 : ENDIF
6344 162951 : LIBPAW_BOUND1_ALLOCATE(dum,BOUNDS(i1,i2))
6345 108686480 : dum(1:n)=f1(i1:i2)*f2(i1:i2)
6346 54317 : overlap=integrator(Grid,dum(1:n),1,n)
6347 54317 : LIBPAW_DEALLOCATE(dum)
6348 54317 : END FUNCTION overlap
6349 :
6350 :
6351 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6352 : !! Subroutine from David Vanderbilt's USPS code, modified by Marc
6353 : !! Torrent and Francois Jollet, further modified by NAWH
6354 : !!===========================================================================
6355 : !! subroutine cfdsol(zz,yy,jj1,jj2,mesh)
6356 : !!===========================================================================
6357 : !! routine for solving coupled first order differential equations
6358 : !!
6359 : !! d yy(x,1)
6360 : !! --------- = zz(x,1,1) * yy(x,1) + zz(x,1,2) * yy(2,1)
6361 : !! dx
6362 : !!
6363 : !! d yy(x,2)
6364 : !! --------- = zz(x,2,1) * yy(x,1) + zz(x,2,2) * yy(2,1)
6365 : !! dx
6366 : !!
6367 : !!
6368 : !! using fifth order predictor corrector algorithm
6369 : !!
6370 : !! routine integrates from jj1 to jj2 and can cope with both cases
6371 : !! jj1 < jj2 and jj1 > jj2. first five starting values of yy must
6372 : !! be provided by the calling program.
6373 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6374 5 : SUBROUTINE cfdsol(Grid,zz,yy,jj1,jj2)
6375 : TYPE(gridinfo), INTENT(IN) :: Grid
6376 : real(dp), INTENT(IN):: zz(:,:,:)
6377 : real(dp), INTENT(INOUT):: yy(:,:)
6378 : INTEGER, INTENT(IN) :: jj1,jj2
6379 : real(dp):: fa(0:5),fb(0:5),abp(1:5),amc(0:4)
6380 : INTEGER :: isgn,i,j,ip,mesh
6381 : real(dp):: arp,brp
6382 5 : real(dp), ALLOCATABLE :: tmpz(:,:,:)
6383 : real(dp), PARAMETER :: verylarge=1.d30
6384 : real(dp) :: scale
6385 5 : mesh=SIZE(yy(2,:))
6386 5 : IF (SIZE(zz(2,2,:))/=mesh) THEN
6387 0 : LIBPAW_ERROR('cfdsol error - incompatible arrays')
6388 : ENDIF
6389 5 : isgn = ( jj2 - jj1 ) / iabs( jj2 - jj1 )
6390 5 : IF ( isgn .EQ. + 1 ) THEN
6391 5 : IF ( jj1 .LE. 5 .OR. jj2 .GT. mesh ) THEN
6392 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6393 : ENDIF
6394 : ELSEIF ( isgn .EQ. - 1 ) THEN
6395 0 : IF ( jj1 .GE. ( mesh - 4 ) .OR. jj2 .LT. 1 ) THEN
6396 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6397 : ENDIF
6398 : ELSE
6399 : if(has_to_print) write(std_out,*) isgn,jj1,jj2,mesh
6400 : ENDIF
6401 15 : LIBPAW_ALLOCATE(tmpz,(2,2,mesh))
6402 65656 : tmpz=zz
6403 15 : DO i=1,2
6404 35 : DO j=1,2
6405 37532 : tmpz(i,j,:)=tmpz(i,j,:)*Grid%h
6406 37542 : if (Grid%TYPE==loggrid) tmpz(i,j,1:mesh)=tmpz(i,j,1:mesh)*Grid%drdu(1:mesh)
6407 : ENDDO
6408 : ENDDO
6409 5 : abp(1) = 1901._dp / 720._dp
6410 5 : abp(2) = -1387._dp / 360._dp
6411 5 : abp(3) = 109._dp / 30._dp
6412 5 : abp(4) = -637._dp / 360._dp
6413 5 : abp(5) = 251._dp / 720._dp
6414 5 : amc(0) = 251._dp / 720._dp
6415 5 : amc(1) = 323._dp / 360._dp
6416 5 : amc(2) = -11._dp / 30._dp
6417 5 : amc(3) = 53._dp / 360._dp
6418 5 : amc(4) = -19._dp / 720._dp
6419 30 : DO j = 1,5
6420 25 : ip = jj1 - isgn * j
6421 25 : fa(j) = tmpz(1,1,ip) * yy(1,ip) + tmpz(1,2,ip) * yy(2,ip)
6422 30 : fb(j) = tmpz(2,1,ip) * yy(1,ip) + tmpz(2,2,ip) * yy(2,ip)
6423 : ENDDO
6424 5 : DO j = jj1,jj2,isgn
6425 9353 : arp = yy(1,j-isgn)
6426 9353 : brp = yy(2,j-isgn)
6427 9353 : IF (ABS(arp)>verylarge.OR.brp>verylarge) THEN
6428 2 : scale=1._dp/(ABS(arp)+ABS(brp))
6429 2 : arp=arp*scale
6430 2 : brp=brp*scale
6431 28 : fa(:)=fa(:)*scale; fb(:)=fb(:)*scale
6432 21359 : yy=yy*scale
6433 : ENDIF
6434 56118 : DO i = 1,5
6435 46765 : arp = arp + DBLE(isgn) * abp(i) * fa(i)
6436 56118 : brp = brp + DBLE(isgn) * abp(i) * fb(i)
6437 : ENDDO
6438 9353 : fa(0) = tmpz(1,1,j) * arp + tmpz(1,2,j) * brp
6439 9353 : fb(0) = tmpz(2,1,j) * arp + tmpz(2,2,j) * brp
6440 9353 : yy(1,j) = yy(1,j-isgn)
6441 9353 : yy(2,j) = yy(2,j-isgn)
6442 56118 : DO i = 0,4,1
6443 46765 : yy(1,j) = yy(1,j) + DBLE(isgn) * amc(i) * fa(i)
6444 56118 : yy(2,j) = yy(2,j) + DBLE(isgn) * amc(i) * fb(i)
6445 : ENDDO
6446 46765 : DO i = 5,2,-1
6447 37412 : fa(i) = fa(i-1)
6448 46765 : fb(i) = fb(i-1)
6449 : ENDDO
6450 9353 : fa(1) = tmpz(1,1,j) * yy(1,j) + tmpz(1,2,j) * yy(2,j)
6451 9353 : fb(1) = tmpz(2,1,j) * yy(1,j) + tmpz(2,2,j) * yy(2,j)
6452 : ENDDO
6453 5 : LIBPAW_DEALLOCATE(tmpz)
6454 5 : END SUBROUTINE cfdsol
6455 :
6456 :
6457 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6458 : !! SUBROUTINE cfdsoliter(Grid,zz,yy,jj1,jj2)
6459 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6460 70260 : SUBROUTINE cfdsoliter(Grid,zz,yy,jj1,jj2)
6461 : TYPE(gridinfo), INTENT(IN) :: Grid
6462 : real(dp), INTENT(IN):: zz(:,:,:)
6463 : real(dp), INTENT(INOUT):: yy(:,:)
6464 : INTEGER, INTENT(IN) :: jj1,jj2
6465 : real(dp):: fa(0:5),fb(0:5),abp(1:5),amc(0:4),yprev(2),ycorr(2)
6466 : INTEGER :: isgn,i,j,ip,mesh,k
6467 : INTEGER, PARAMETER :: CORRITER=5
6468 : real(dp):: arp,brp
6469 70260 : real(dp), ALLOCATABLE :: tmpz(:,:,:)
6470 : real(dp), PARAMETER :: verylarge=10._dp, smallenough=tol5
6471 : real(dp) :: scale,small
6472 70260 : mesh=SIZE(yy(2,:))
6473 70260 : IF (SIZE(zz(2,2,:))/=mesh) THEN
6474 0 : LIBPAW_ERROR('cfdsol error - incompatible arrays')
6475 : ENDIF
6476 70260 : isgn = ( jj2 - jj1 ) / iabs( jj2 - jj1 )
6477 70260 : IF ( isgn .EQ. + 1 ) THEN
6478 35357 : IF ( jj1 .LE. 5 .OR. jj2 .GT. mesh ) THEN
6479 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6480 : ENDIF
6481 : ELSEIF ( isgn .EQ. - 1 ) THEN
6482 34903 : IF ( jj1 .GE. ( mesh - 4 ) .OR. jj2 .LT. 1 ) THEN
6483 0 : LIBPAW_ERROR(' ***error in subroutine difsol')
6484 : ENDIF
6485 : ELSE
6486 : if(has_to_print) WRITE(STD_OUT,*) isgn,jj1,jj2,mesh
6487 : ENDIF
6488 210780 : LIBPAW_ALLOCATE(tmpz,(2,2,mesh))
6489 984272340 : tmpz=zz
6490 210780 : DO i=1,2
6491 491820 : DO j=1,2
6492 562642080 : tmpz(i,j,:)=tmpz(i,j,:)*Grid%h
6493 562782600 : if (Grid%TYPE==loggrid) tmpz(i,j,1:mesh)=tmpz(i,j,1:mesh)*Grid%drdu(1:mesh)
6494 : ENDDO
6495 : ENDDO
6496 70260 : abp(1) = 1901._dp / 720._dp
6497 70260 : abp(2) = -1387._dp / 360._dp
6498 70260 : abp(3) = 109._dp / 30._dp
6499 70260 : abp(4) = -637._dp / 360._dp
6500 70260 : abp(5) = 251._dp / 720._dp
6501 : amc(0) = 251._dp / 720._dp
6502 70260 : amc(1) = 323._dp / 360._dp
6503 70260 : amc(2) = -11._dp / 30._dp
6504 70260 : amc(3) = 53._dp / 360._dp
6505 70260 : amc(4) = -19._dp / 720._dp
6506 421560 : DO j = 1,5
6507 351300 : ip = jj1 - isgn * j
6508 351300 : fa(j) = tmpz(1,1,ip) * yy(1,ip) + tmpz(1,2,ip) * yy(2,ip)
6509 421560 : fb(j) = tmpz(2,1,ip) * yy(1,ip) + tmpz(2,2,ip) * yy(2,ip)
6510 : ENDDO
6511 70260 : DO j = jj1,jj2,isgn
6512 70851796 : arp = yy(1,j-isgn)
6513 70851796 : brp = yy(2,j-isgn)
6514 70851796 : IF (ABS(arp)>verylarge.OR.brp>verylarge) THEN
6515 3534670 : scale=1._dp/(ABS(arp)+ABS(brp))
6516 3534670 : arp=arp*scale
6517 3534670 : brp=brp*scale
6518 49485380 : fa(:)=fa(:)*scale; fb(:)=fb(:)*scale
6519 21289475806 : yy=yy*scale
6520 : ENDIF
6521 425110776 : DO i = 1,5
6522 354258980 : arp = arp + DBLE(isgn) * abp(i) * fa(i)
6523 425110776 : brp = brp + DBLE(isgn) * abp(i) * fb(i)
6524 : ENDDO
6525 70851796 : fa(0) = tmpz(1,1,j) * arp + tmpz(1,2,j) * brp
6526 70851796 : fb(0) = tmpz(2,1,j) * arp + tmpz(2,2,j) * brp
6527 70851796 : yprev(1) = arp
6528 70851796 : yprev(2) = brp
6529 70851796 : ycorr(1) = yy(1,j-isgn)
6530 70851796 : ycorr(2) = yy(2,j-isgn)
6531 354258980 : DO i = 1,4,1
6532 283407184 : ycorr(1) = ycorr(1) + DBLE(isgn) * amc(i) * fa(i)
6533 354258980 : ycorr(2) = ycorr(2) + DBLE(isgn) * amc(i) * fb(i)
6534 : ENDDO
6535 122991676 : DO k=1,CORRITER
6536 115269584 : yy(1,j)=ycorr(1) + DBLE(isgn) * amc(0) * fa(0)
6537 115269584 : yy(2,j)=ycorr(2) + DBLE(isgn) * amc(0) * fb(0)
6538 115269584 : small=abs(yprev(1))+abs(yprev(2))
6539 115269584 : small=(abs(yprev(1)-yy(1,j))+abs(yprev(2)-yy(2,j)))/small
6540 115269584 : if(small.le.smallenough) exit
6541 52139880 : yprev(1)= yy(1,j)
6542 52139880 : yprev(2)= yy(2,j)
6543 52139880 : fa(0) = tmpz(1,1,j) * yprev(1) + tmpz(1,2,j) * yprev(2)
6544 122991676 : fb(0) = tmpz(2,1,j) * yprev(1) + tmpz(2,2,j) * yprev(2)
6545 : ENDDO
6546 354258980 : DO i = 5,2,-1
6547 283407184 : fa(i) = fa(i-1)
6548 354258980 : fb(i) = fb(i-1)
6549 : ENDDO
6550 70851796 : fa(1) = tmpz(1,1,j) * yy(1,j) + tmpz(1,2,j) * yy(2,j)
6551 70851796 : fb(1) = tmpz(2,1,j) * yy(1,j) + tmpz(2,2,j) * yy(2,j)
6552 : ENDDO
6553 70260 : LIBPAW_DEALLOCATE(tmpz)
6554 70260 : END SUBROUTINE cfdsoliter
6555 :
6556 :
6557 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6558 : !! subroutine findh_given_r0(Z,range,r0,n,hval)
6559 : !! find hval for fixed number of input grid points n in loggrid case
6560 : !! assumes form r(i)=(r0/Z)*(exp(h*(i-1))-1);
6561 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6562 0 : SUBROUTINE findh_given_r0(Z,range,r0,n,hval)
6563 : INTEGER, INTENT(IN) :: n
6564 : real(dp), INTENT(IN) :: Z,range,r0
6565 : real(dp), INTENT(INOUT) :: hval
6566 0 : hval=log((Z*range/r0 + 1._dp))/(n-1)
6567 0 : end subroutine findh_given_r0
6568 :
6569 :
6570 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6571 : !! subroutine findh(Z,range,n,hval,r0)
6572 : !! find hval for fixed number of input grid points n in loggrid case
6573 : !! assumes form r(i)=(h/Z)*(exp(h*(i-1))-1); r0=h/Z
6574 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6575 4 : SUBROUTINE findh(Z,range,n,hval,r0)
6576 : real(dp), INTENT(IN) :: Z
6577 : INTEGER, INTENT(IN) :: n
6578 : real(dp), INTENT(IN) :: range
6579 : real(dp), INTENT(INOUT) :: hval,r0
6580 : real(dp) :: h0,dh,f,df
6581 : INTEGER :: i
6582 : INTEGER, parameter :: iter=1000
6583 : real(dp), parameter :: eps=1.e-15
6584 : LOGICAL :: success
6585 4 : h0=hval
6586 4 : success=.false.
6587 34 : do i=1,iter
6588 34 : f=LOG(Z*range/h0+1._dp)/h0
6589 34 : df=-f/h0-(Z*range/h0**3)/(Z*range/h0+1._dp)
6590 34 : dh=(n-1-f)/df
6591 34 : if (ABS(dh)< eps) then
6592 : success=.true.
6593 : exit
6594 : endif
6595 30 : if (h0+dh<0._dp) then
6596 4 : h0=h0/2
6597 : else
6598 26 : h0=h0+dh
6599 : endif
6600 : enddo
6601 4 : if (.not.success) then
6602 0 : if(has_to_print) write(std_out,*) 'Warning in findh -- dh > eps ', dh,h0
6603 : endif
6604 4 : hval=h0
6605 4 : r0=hval/Z
6606 4 : end subroutine findh
6607 :
6608 :
6609 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6610 : !! subroutine initgrid(Grid,h,range,r0)
6611 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6612 4 : SUBROUTINE InitGrid(Grid,h,range,r0,do_not_print,pawrad)
6613 : TYPE (GridInfo), INTENT(INOUT) :: Grid
6614 : real(dp), INTENT(IN) :: range
6615 : real(dp), INTENT(IN) :: h
6616 : real(dp), OPTIONAL, INTENT(IN) :: r0
6617 : LOGICAL, OPTIONAL, INTENT(IN) :: do_not_print
6618 : TYPE(pawrad_type),optional, INTENT(IN) :: pawrad
6619 : INTEGER :: i,n
6620 : LOGICAL :: do_print
6621 4 : do_print=.false.;if (present(do_not_print)) do_print=.not.do_not_print
6622 4 : if (present(pawrad)) then
6623 0 : if (pawrad%mesh_type/=2) then
6624 0 : LIBPAW_ERROR("Error wrong pawrad grid")
6625 0 : STOP
6626 : end if
6627 0 : Grid%n=pawrad%mesh_size
6628 0 : LIBPAW_POINTER_ALLOCATE(Grid%r,(Grid%n))
6629 0 : LIBPAW_POINTER_ALLOCATE(Grid%drdu,(Grid%n))
6630 0 : LIBPAW_POINTER_ALLOCATE(Grid%pref,(Grid%n))
6631 0 : LIBPAW_POINTER_ALLOCATE(Grid%rr02,(Grid%n))
6632 0 : Grid%r(:)=pawrad%rad(:)
6633 0 : Grid%drdu(:)=pawrad%radfact(:)
6634 0 : Grid%rr02(:)=pawrad%radfact(:)**2
6635 0 : Grid%pref(:)=(pawrad%radfact(:)*pawrad%rstep)**2
6636 0 : Grid%r0=pawrad%rstep
6637 0 : Grid%range=pawrad%rmax
6638 0 : Grid%h=pawrad%lstep
6639 0 : Grid%type=loggrid
6640 0 : Grid%ishift=5
6641 : else
6642 4 : IF (PRESENT(r0)) THEN
6643 4 : Grid%h=h
6644 4 : Grid%r0=r0
6645 4 : Grid%type=loggrid
6646 4 : Grid%range=range
6647 4 : n=LOG(range/r0+1)/h+1
6648 4 : Grid%ishift=5
6649 4 : IF (r0*(EXP(h*(n-1))-1)<range-tol5) n=n+1
6650 4 : Grid%n=n
6651 4 : if (do_print) write(std_out,*) 'InitGrid: -- logarithmic ',n, h,range,r0
6652 12 : LIBPAW_POINTER_ALLOCATE(Grid%r,(n))
6653 8 : LIBPAW_POINTER_ALLOCATE(Grid%drdu,(n))
6654 8 : LIBPAW_POINTER_ALLOCATE(Grid%pref,(n))
6655 8 : LIBPAW_POINTER_ALLOCATE(Grid%rr02,(n))
6656 8008 : DO i=1,n
6657 8004 : Grid%r(i)=r0*(EXP(Grid%h*(i-1))-1)
6658 8004 : Grid%drdu(i)=r0*EXP(Grid%h*(i-1))
6659 8004 : Grid%pref(i)=r0*EXP(Grid%h*(i-1)/2._dp)
6660 8008 : Grid%rr02(i)=(Grid%r(i)+r0)**2
6661 : ENDDO
6662 : ELSE
6663 0 : Grid%h=h
6664 0 : Grid%r0=0._dp
6665 0 : Grid%type=lineargrid
6666 0 : Grid%range=range
6667 0 : n=range/h+1
6668 0 : Grid%ishift=25
6669 0 : IF (h*(n-1)<range-tol5) n=n+1
6670 0 : Grid%n=n
6671 0 : if (do_print) write(std_out,*) 'InitGrid: -- linear ', n,h,range
6672 0 : LIBPAW_POINTER_ALLOCATE(Grid%r,(n))
6673 0 : LIBPAW_POINTER_ALLOCATE(Grid%drdu,(n))
6674 0 : LIBPAW_POINTER_ALLOCATE(Grid%pref,(n))
6675 0 : LIBPAW_POINTER_ALLOCATE(Grid%rr02,(n))
6676 0 : DO i=1,n
6677 0 : Grid%r(i)=(Grid%h*(i-1))
6678 0 : Grid%drdu(i)=1._dp
6679 0 : Grid%pref(i)=1._dp
6680 0 : Grid%rr02(i)=1._dp
6681 : ENDDO
6682 : ENDIF
6683 : endif
6684 4 : END SUBROUTINE InitGrid
6685 :
6686 :
6687 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6688 : !! subroutine destroygrid(Grid)
6689 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6690 8 : SUBROUTINE DestroyGrid(Grid)
6691 : TYPE (GridInfo), INTENT(INOUT) :: Grid
6692 8 : IF (ASSOCIATED(Grid%r)) then
6693 4 : LIBPAW_POINTER_DEALLOCATE(Grid%r)
6694 : endif
6695 8 : IF (ASSOCIATED(Grid%drdu)) then
6696 4 : LIBPAW_POINTER_DEALLOCATE(Grid%drdu)
6697 : endif
6698 8 : IF (ASSOCIATED(Grid%pref)) then
6699 4 : LIBPAW_POINTER_DEALLOCATE(Grid%pref)
6700 : endif
6701 8 : IF (ASSOCIATED(Grid%rr02)) then
6702 4 : LIBPAW_POINTER_DEALLOCATE(Grid%rr02)
6703 : endif
6704 8 : END SUBROUTINE DestroyGrid
6705 :
6706 :
6707 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6708 : !! subroutine nullifygrid(Grid)
6709 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6710 : SUBROUTINE NullifyGrid(Grid)
6711 : TYPE (GridInfo), INTENT(INOUT) :: Grid
6712 : NULLIFY(Grid%r)
6713 : NULLIFY(Grid%drdu)
6714 : NULLIFY(Grid%pref)
6715 : NULLIFY(Grid%rr02)
6716 : END SUBROUTINE NullifyGrid
6717 :
6718 :
6719 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6720 : !! SUBROUTINE backward_numerov(Grid,l,match,energy,rv,wfn,wgt,nend,proj)
6721 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6722 5131 : SUBROUTINE backward_numerov(Grid,l,match,energy,rv,wfn,wgt,nend,proj)
6723 : TYPE (GridInfo), INTENT(IN) :: Grid
6724 : INTEGER, INTENT(IN) :: l,match
6725 : real(dp), INTENT(IN) :: energy,rv(:)
6726 : real(dp), INTENT(INOUT) :: wfn(:) ! on input wfn(n-1) and wfn(n) given
6727 : real(dp), INTENT(IN), OPTIONAL :: wgt(:)
6728 : real(dp), intent(in), optional :: proj(:)
6729 : integer, intent(in), optional :: nend
6730 5131 : real(dp), ALLOCATABLE :: a(:),b(:),p(:),c(:)
6731 : real(dp) :: angm,h,h2,scale
6732 : real(dp), PARAMETER :: vlarg=1.d30
6733 : INTEGER :: i,n
6734 : LOGICAL :: withwgt
6735 5131 : withwgt=.false.
6736 5131 : If (PRESENT(wgt)) withwgt=.true.
6737 5131 : n=Grid%n
6738 5131 : if(present(nend)) n=nend
6739 15393 : LIBPAW_ALLOCATE(a,(n))
6740 10262 : LIBPAW_ALLOCATE(b,(n))
6741 10262 : LIBPAW_ALLOCATE(p,(n))
6742 10262 : LIBPAW_ALLOCATE(c,(n))
6743 5131 : p(n)=wfn(n)
6744 5131 : p(n-1)=wfn(n-1)
6745 5131 : angm=l*(l+1)
6746 10272262 : a=0
6747 10272262 : b=0
6748 10272262 : c=0
6749 5131 : h=Grid%h; h2=h*h
6750 3788043 : DO i=match,n
6751 3788043 : if(withwgt) then
6752 0 : a(i)=rv(i)/Grid%r(i)-energy*wgt(i)+angm/(Grid%r(i)**2)
6753 : else
6754 3782912 : a(i)=rv(i)/Grid%r(i)-energy+angm/(Grid%r(i)**2)
6755 : endif
6756 : ENDDO
6757 5131 : if(present(proj)) b(match:n)=0.1_dp*h2*proj(match:n)
6758 5131 : IF (Grid%type==loggrid) THEN
6759 15393 : p(n-1:n)=p(n-1:n)/Grid%pref(n-1:n)
6760 3788043 : a(match:n)=0.25_dp+Grid%rr02(match:n)*a(match:n)
6761 5131 : if(present(proj)) b(match:n)=Grid%rr02(match:n)*b(match:n)/Grid%pref(match:n)
6762 : ENDIF
6763 0 : if(present(proj)) then
6764 0 : do i=match+1,n-1
6765 0 : c(i)=10*b(i)+b(i-1)+b(i+1)
6766 : enddo
6767 : endif
6768 3788043 : b(match:n)=2.4_dp+h2*a(match:n)
6769 3788043 : a(match:n)=1.2_dp-0.1_dp*h2*a(match:n)
6770 3777781 : DO i=n-2,match,-1
6771 3772650 : p(i)=(b(i+1)*p(i+1)-a(i+2)*p(i+2)-c(i+1))/a(i)
6772 : !renormalize if necessary
6773 3772650 : scale=ABS(p(i))
6774 3777781 : IF (scale > vlarg) THEN
6775 15262 : scale=1._dp/scale
6776 2634457 : p(i:n)=scale*p(i:n)
6777 : ENDIF
6778 : ENDDO
6779 3788043 : wfn(match:n)=p(match:n)
6780 5131 : IF (Grid%type==loggrid) THEN
6781 3788043 : wfn(match:n)=wfn(match:n)*Grid%pref(match:n)
6782 : ENDIF
6783 5131 : LIBPAW_DEALLOCATE(a)
6784 5131 : LIBPAW_DEALLOCATE(b)
6785 5131 : LIBPAW_DEALLOCATE(p)
6786 5131 : LIBPAW_DEALLOCATE(c)
6787 5131 : END SUBROUTINE backward_numerov
6788 :
6789 :
6790 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6791 : !! SUBROUTINE
6792 : !forward_numerov(Grid,l,many,energy,rv,zeroval,wfn,nodes,wgt,proj,p3val)
6793 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6794 5210 : SUBROUTINE forward_numerov(Grid,l,many,energy,rv,zeroval,wfn,nodes,wgt,proj,p3val)
6795 : TYPE (GridInfo), INTENT(IN) :: Grid
6796 : INTEGER, INTENT(IN) :: l,many
6797 : real(dp), INTENT(IN) :: energy,zeroval,rv(:)
6798 : real(dp), INTENT(INOUT) :: wfn(:) ! on input wfn(1) and wfn(2) given
6799 : INTEGER, INTENT(OUT) :: nodes
6800 : real(dp), INTENT(IN), OPTIONAL :: wgt(:)
6801 : real(dp), intent(in), optional :: p3val
6802 : real(dp), intent(in), optional :: proj(:)
6803 5210 : real(dp), ALLOCATABLE :: a(:),b(:),p(:),c(:)
6804 : real(dp) :: xx,angm,h,h2,scale
6805 : real(dp), PARAMETER :: vlarg=1.d30
6806 : INTEGER :: i
6807 : LOGICAL :: withwgt
6808 5210 : withwgt=.false.
6809 5210 : If (PRESENT(wgt)) withwgt=.true.
6810 15630 : LIBPAW_ALLOCATE(a,(many))
6811 10420 : LIBPAW_ALLOCATE(b,(many))
6812 10420 : LIBPAW_ALLOCATE(p,(many))
6813 10420 : LIBPAW_ALLOCATE(c,(many))
6814 5210 : p(1)=wfn(1)
6815 5210 : p(2)=wfn(2)
6816 5210 : xx=zeroval
6817 5210 : angm=l*(l+1)
6818 6668839 : a=0
6819 6668839 : c=0
6820 5210 : h=Grid%h; h2=h*h
6821 6663629 : DO i=2,many
6822 6663629 : if (withwgt) then
6823 0 : a(i)=rv(i)/Grid%r(i)-energy*wgt(i)+angm/(Grid%r(i)**2)
6824 : else
6825 6658419 : a(i)=rv(i)/Grid%r(i)-energy+angm/(Grid%r(i)**2)
6826 : endif
6827 : ENDDO
6828 73022 : if(present(proj)) b(1:many)=0.1_dp*h2*proj(1:many)
6829 5210 : IF (Grid%type==loggrid) THEN
6830 15630 : p(1:2)=wfn(1:2)/Grid%pref(1:2)
6831 5210 : xx=Grid%rr02(1)*xx/Grid%pref(1)
6832 6674049 : a=0.25_dp+Grid%rr02(1:many)*a
6833 73070 : if(present(proj)) b(1:many)=Grid%rr02(1:many)*b(1:many)/Grid%pref(1:many)
6834 : ENDIF
6835 48 : if(present(proj)) then
6836 67764 : do i=2,many-1
6837 67764 : c(i)=10*b(i)+b(i-1)+b(i+1)
6838 : enddo
6839 : endif
6840 6674049 : b=2.4_dp+h2*a
6841 6668839 : a=1.2_dp-0.1_dp*h2*a
6842 5210 : p(3)=(b(2)*p(2)+0.1_dp*h2*xx)/a(3)
6843 5210 : if(present(p3val)) then
6844 0 : p(3)=p3val
6845 0 : IF (Grid%type==loggrid) p(3)=p3val/Grid%pref(3)
6846 : endif
6847 5210 : nodes=0
6848 6653209 : DO i=4,many
6849 6647999 : p(i)=(b(i-1)*p(i-1)-a(i-2)*p(i-2)-c(i-1))/a(i)
6850 6647999 : IF (p(i)*p(i-1) < 0._dp) nodes=nodes+1
6851 : !renormalize if necessary
6852 6647999 : scale=ABS(p(i))
6853 6653209 : IF (scale > vlarg) THEN
6854 0 : scale=1._dp/scale
6855 0 : p(1:i)=scale*p(1:i)
6856 : ENDIF
6857 : ENDDO
6858 6668839 : wfn(1:many)=p(1:many)
6859 5210 : IF (Grid%type==loggrid) THEN
6860 6668839 : wfn(1:many)=wfn(1:many)*Grid%pref(1:many)
6861 : ENDIF
6862 5210 : LIBPAW_DEALLOCATE(a)
6863 5210 : LIBPAW_DEALLOCATE(b)
6864 5210 : LIBPAW_DEALLOCATE(p)
6865 5210 : LIBPAW_DEALLOCATE(c)
6866 5210 : END SUBROUTINE forward_numerov
6867 :
6868 :
6869 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6870 : !! subroutine initgridwithn(Grid,type,n,r0,h)
6871 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6872 0 : SUBROUTINE initgridwithn(Grid,type,n,r0,h)
6873 : TYPE (GridInfo), INTENT(INOUT) :: Grid
6874 : INTEGER, INTENT(IN) :: type,n !type=1 lin,2 log
6875 : REAL(dp), INTENT(IN) :: r0,h
6876 : INTEGER :: i
6877 0 : IF (type==loggrid) THEN
6878 0 : Grid%h=h
6879 0 : Grid%r0=r0
6880 0 : Grid%type=loggrid
6881 0 : Grid%ishift=5
6882 0 : Grid%n=n
6883 0 : LIBPAW_ALLOCATE(Grid%r,(n))
6884 0 : LIBPAW_ALLOCATE(Grid%drdu,(n))
6885 0 : LIBPAW_ALLOCATE(Grid%pref,(n))
6886 0 : LIBPAW_ALLOCATE(Grid%rr02,(n))
6887 0 : DO i=1,n
6888 0 : Grid%r(i)=r0*(EXP(Grid%h*(i-1))-1)
6889 0 : Grid%drdu(i)=r0*EXP(Grid%h*(i-1))
6890 0 : Grid%pref(i)=r0*EXP(Grid%h*(i-1)/2._dp)
6891 0 : Grid%rr02(i)=(Grid%r(i)+r0)**2
6892 : ENDDO
6893 0 : Grid%range=Grid%r(n)
6894 0 : if(has_to_print)WRITE(STD_OUT,*) 'InitGridwithn: -- logarithmic ',n, h,Grid%range,r0
6895 0 : ELSEIF (type==lineargrid) THEN
6896 0 : Grid%h=h
6897 0 : Grid%r0=0._dp
6898 0 : Grid%type=lineargrid
6899 0 : Grid%ishift=25
6900 0 : Grid%n=n
6901 0 : LIBPAW_ALLOCATE(Grid%r,(n))
6902 0 : LIBPAW_ALLOCATE(Grid%drdu,(n))
6903 0 : LIBPAW_ALLOCATE(Grid%pref,(n))
6904 0 : LIBPAW_ALLOCATE(Grid%rr02,(n))
6905 0 : DO i=1,n
6906 0 : Grid%r(i)=(Grid%h*(i-1))
6907 0 : Grid%drdu(i)=1._dp
6908 0 : Grid%pref(i)=1._dp
6909 0 : Grid%rr02(i)=1._dp
6910 : ENDDO
6911 0 : Grid%range=Grid%r(n)
6912 0 : if(has_to_print) WRITE(STD_OUT,*) 'InitGridwithn: -- linear ',n, h,Grid%range,r0
6913 : ELSE
6914 0 : write(std_out,*) 'error in initgridwithn -- type =',type
6915 0 : stop
6916 : ENDIF
6917 0 : END SUBROUTINE initgridwithn
6918 :
6919 :
6920 :
6921 :
6922 :
6923 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6924 : ! 10. pseudo
6925 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6926 :
6927 :
6928 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6929 : !! SUBROUTINE sethat(Grid,PAW,gaussparam,besselopt)
6930 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6931 :
6932 :
6933 2 : SUBROUTINE sethat(Grid,PAW,gaussparam,besselopt)
6934 : TYPE(GridInfo), INTENT(IN) :: Grid
6935 : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
6936 : INTEGER,INTENT(IN), OPTIONAL :: besselopt
6937 : REAL(dp),INTENT(IN), OPTIONAL :: gaussparam
6938 : INTEGER :: n,irc,irc_shap,i
6939 2 : REAL(dp), POINTER :: r(:)
6940 : REAL(dp) :: h,con,rc,rc_shap,selfen,d,dd,jbes1,jbes2,qr
6941 : REAL(dp) :: al(2),ql(2)
6942 2 : n=Grid%n
6943 2 : h=Grid%h
6944 2 : irc=PAW%irc
6945 2 : rc=PAW%rc
6946 2 : irc_shap=PAW%irc_shap
6947 2 : rc_shap=PAW%rc_shap
6948 2 : r=>Grid%r
6949 4004 : PAW%hatden=0
6950 4004 : PAW%projshape=0
6951 4004 : PAW%hatshape=0
6952 2 : PAW%projshape(1)=1
6953 2 : PAW%hatshape(1)=1
6954 2825 : DO i=2,irc-1
6955 2825 : PAW%projshape(i)=(SIN(pi*r(i)/rc)/(pi*r(i)/rc))**2
6956 : ENDDO
6957 2 : if(present(gaussparam)) then
6958 0 : d=rc_shap/SQRT(LOG(1._dp/gaussparam))
6959 0 : PAW%gausslength=d
6960 0 : DO i=2,irc
6961 0 : PAW%hatshape(i)=EXP(-(r(i)/d)**2)
6962 : ENDDO
6963 0 : PAW%irc_shap=PAW%irc
6964 0 : PAW%rc_shap=PAW%rc
6965 2 : else if(present(besselopt)) then
6966 0 : call shapebes(al,ql,0,rc_shap)
6967 0 : DO i=1,irc_shap-1
6968 0 : qr=ql(1)*r(i);CALL jbessel(jbes1,d,dd,0,0,qr)
6969 0 : qr=ql(2)*r(i);CALL jbessel(jbes2,d,dd,0,0,qr)
6970 0 : PAW%hatshape(i)=al(1)*jbes1+al(2)*jbes2
6971 : ENDDO
6972 : else
6973 2809 : DO i=2,irc_shap-1
6974 2809 : PAW%hatshape(i)=(SIN(pi*r(i)/rc_shap)/(pi*r(i)/rc_shap))**2
6975 : ENDDO
6976 : endif
6977 2829 : PAW%hatden(1:irc)=PAW%hatshape(1:irc)*(r(1:irc)**2)
6978 : ! normalize
6979 2 : if (.not.present(besselopt)) then
6980 2 : con=integrator(Grid,PAW%hatden,1,PAW%irc_shap)
6981 2 : if(has_to_print) WRITE(STD_OUT,*) ' check hatden normalization', con
6982 4004 : PAW%hatden=PAW%hatden/con
6983 : endif
6984 2 : CALL atompaw_poisson(Grid,con,PAW%hatden,PAW%hatpot,selfen)
6985 2 : if(has_to_print) WRITE(STD_OUT,*) 'Self energy for L=0 hat density ', selfen
6986 2 : if(has_to_print) WRITE(STD_OUT,*) 'hatden charge ', con
6987 2 : END SUBROUTINE sethat
6988 :
6989 :
6990 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6991 : !! SUBROUTINE FindVlocfromVeff(Grid,Orbit,PAW)
6992 : ! Assumes prior call to SUBROUTINE calculate_tvtau
6993 : ! which now fills PAW%tden and PAW%ttau
6994 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6995 0 : SUBROUTINE FindVlocfromVeff(Grid,PAW,atp,potshift)
6996 : ! TODO : needvtau,allocates
6997 : TYPE(GridInfo), INTENT(INOUT) :: Grid
6998 : type(atompaw_type),intent(inout) :: atp
6999 : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
7000 : real(dp),intent(in) :: potshift
7001 0 : REAL(dp), POINTER :: r(:)
7002 : REAL(dp) :: h,tq,rat,q00,etxc,eexc
7003 : INTEGER :: n,irc,nbase
7004 : REAL(dp), allocatable :: d(:),v(:),vxB(:),vxK(:)
7005 : REAL(dp), allocatable :: t(:),vt(:),vthat(:)
7006 0 : CALL FillHat(Grid,PAW,atp%besselshapefunction)
7007 : !if (Vlocalindex == SETVLOC) then
7008 : ! write(std_out,*) 'Vloc == VlocCoef*shapefunc '
7009 : ! return
7010 : !endif
7011 0 : n=Grid%n;irc=PAW%irc
7012 0 : nbase=PAW%nbase
7013 0 : h=Grid%h ; r=>Grid%r
7014 0 : irc=max(PAW%irc,PAW%irc_shap,PAW%irc_vloc,PAW%irc_core)
7015 : ! Recalculate den and tau
7016 0 : PAW%valetau=0._dp;PAW%tvaletau=0._dp
7017 0 : LIBPAW_ALLOCATE(d,(n))
7018 0 : LIBPAW_ALLOCATE(vxB,(n))
7019 0 : LIBPAW_ALLOCATE(v,(n))
7020 0 : LIBPAW_ALLOCATE(vxK,(n))
7021 0 : LIBPAW_ALLOCATE(t,(n))
7022 0 : LIBPAW_ALLOCATE(vt,(n))
7023 0 : LIBPAW_ALLOCATE(vthat,(n))
7024 0 : d=PAW%den-PAW%tden
7025 0 : tq=integrator(Grid,d,1,irc)
7026 0 : if(has_to_print) write(std_out,*) ' Delta Qval = ', tq
7027 : ! Compute VH(tDEN+hatDEN)
7028 0 : d=PAW%tden+tq*PAW%hatden
7029 0 : call poisson_marc(Grid,q00,d,v,rat)
7030 0 : if(has_to_print) write(std_out,*) ' Completed Poisson with q00 = ', q00
7031 0 : if(has_to_print) write(std_out,*) ' Completed Poisson with v(n) = ', v(n)
7032 : ! Compute Blochl exc
7033 0 : d=PAW%tden+PAW%tcore
7034 0 : t=PAW%tcoretau+PAW%tvaletau
7035 : CALL exch(Grid,d,vxB,etxc,eexc,itype=atp%itype,needvtau=atp%Pot%needvtau,&
7036 0 : & tau=t,vtau=vt,xc_functionals=atp%xc_functionals)
7037 : ! Compute Kresse exc Vxc(tcore+tDEN+hatDEN)
7038 0 : d=PAW%tcore+PAW%tden+tq*PAW%hatden
7039 0 : t=PAW%tcoretau+PAW%tvaletau
7040 : CALL exch(Grid,d,vxK,etxc,eexc,itype=atp%itype,needvtau=atp%Pot%needvtau,&
7041 0 : & tau=t,vtau=vthat,xc_functionals=atp%xc_functionals)
7042 0 : PAW%abinitvloc=zero; PAW%abinitnohat=zero
7043 0 : PAW%abinitnohat(2:n)=(PAW%rveff(2:n)-v(2:n)-vxB(2:n))/r(2:n)+potshift
7044 0 : call extrapolate(PAW%abinitnohat)
7045 0 : PAW%abinitvloc(2:n)=(PAW%rveff(2:n)-v(2:n)-vxK(2:n))/r(2:n)+potshift
7046 0 : call extrapolate(PAW%abinitvloc)
7047 : ! Reassess poscorenhat
7048 : ! check if PAW%tcore+PAW%tden+tq*PAW%hatden is positive
7049 0 : PAW%poscorenhat=.true.
7050 0 : LIBPAW_DEALLOCATE(v)
7051 0 : LIBPAW_DEALLOCATE(vxB)
7052 0 : LIBPAW_DEALLOCATE(vxK)
7053 0 : LIBPAW_DEALLOCATE(d)
7054 0 : LIBPAW_DEALLOCATE(vt)
7055 0 : LIBPAW_DEALLOCATE(vthat)
7056 0 : END SUBROUTINE FindVlocfromVeff
7057 :
7058 :
7059 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7060 : !! SUBROUTINE SetPAWOptions2(Grid,Orbit,Pot,success,atp)
7061 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7062 2 : SUBROUTINE SetPAWOptions2(atp,success)
7063 : LOGICAL , INTENT(OUT) :: success
7064 : type(atompaw_type), intent(inout) :: atp
7065 : INTEGER :: l
7066 : integer :: Projectorindex,Vlocalindex
7067 : real(dp) :: e
7068 2 : success=.true.
7069 : IF (atp%projector_type==PROJECTOR_TYPE_MARSMAN) Projectorindex=MARSMAN
7070 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER) Vlocalindex=MTROULLIER
7071 2 : IF (atp%vloc_type==VLOC_TYPE_ULTRASOFT) Vlocalindex=ULTRASOFT
7072 2 : IF (atp%vloc_type==VLOC_TYPE_BESSEL) Vlocalindex=BESSEL
7073 2 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNC) Vlocalindex=VPSMATCHNC
7074 2 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNNC) Vlocalindex=VPSMATCHNNC
7075 : !Store the description of Vloc scheme in a string
7076 2 : if (Vlocalindex==MTROULLIER) then
7077 2 : l=atp%vloc_l ; e=atp%vloc_ene
7078 2 : if(has_to_print) then
7079 : WRITE(atp%PAW%Vloc_description,&
7080 0 : & '("Vloc: Norm-conserving Troullier-Martins with l=",i1,";e=",1p,1e12.4)')l,e
7081 : endif
7082 : endif
7083 2 : if (Vlocalindex==ULTRASOFT) then
7084 0 : l=atp%vloc_l ; e=atp%vloc_ene
7085 0 : if(has_to_print) then
7086 : WRITE(atp%PAW%Vloc_description,&
7087 0 : & '("Vloc: Non norm-conserving form with l= ",i1,";e= ",1p,1e12.4)')l,e
7088 : endif
7089 : endif
7090 2 : if (Vlocalindex==BESSEL) then
7091 0 : if(has_to_print) then
7092 : WRITE(atp%PAW%Vloc_description,&
7093 0 : & '("Vloc: truncated form - Vps(r)=A.sin(qr)/r for r<rc")')
7094 : endif
7095 : endif
7096 : !Shape function parameters (from input dataset)
7097 2 : if (atp%shapefunc_type==SHAPEFUNC_TYPE_GAUSSIAN) then
7098 0 : atp%gaussianshapefunction=.true.
7099 0 : CALL sethat(atp%Grid,atp%PAW,gaussparam=atp%shapefunc_gaussian_param) !Gaussian shape function
7100 2 : else if (atp%shapefunc_type==SHAPEFUNC_TYPE_BESSEL) then
7101 0 : atp%besselshapefunction=.true.
7102 0 : CALL sethat(atp%Grid,atp%PAW,besselopt=0) ! Bessel shape function
7103 : else
7104 2 : CALL sethat(atp%Grid,atp%PAW) ! sinc^2 shape function
7105 : endif
7106 : !Call the routine computing Vloc - Not mGGA
7107 2 : IF (.NOT.atp%needvtau) THEN
7108 2 : IF (Vlocalindex==MTROULLIER.and.Projectorindex/=HFPROJ) THEN
7109 2 : CALL troullier(atp%Grid,atp%Pot,atp%PAW,l,e,atp%needvtau,atp%scalarrelativistic)
7110 : ENDIF
7111 2 : IF (Vlocalindex==ULTRASOFT) CALL nonncps(atp%Grid,atp%Pot,atp%PAW,l,e,atp%scalarrelativistic)
7112 2 : IF (Vlocalindex==BESSEL) CALL besselps(atp%Grid,atp%Pot,atp%PAW)
7113 2 : call makebasis_marsman(atp)
7114 : ENDIF
7115 : !Call the routine computing Vloc - mGGA case
7116 : ! IF (atp%needvtau) THEN
7117 : ! !All compatibility checks in input_dataset_read routine
7118 : ! if(has_to_print) WRITE(STD_OUT,*) 'Sequence of dataset construction modified for MGGA'
7119 : ! if(has_to_print) WRITE(STD_OUT,*) ' Not all possibilites tested carefully yet.... '
7120 : ! if(has_to_print) WRITE(STD_OUT,*) ' Some possibilites not yet programmed.... '
7121 : ! !Calculate PAW%vtau and PAW%tvtau
7122 : ! CALL calculate_tvtau(atp%Grid,atp%PAW,atp%itype)
7123 : ! !Set pseudoptentials
7124 : ! ! IF (Vlocalindex==MTROULLIER.and.(TRIM(atp%Orbit%exctype)/='HF')) then
7125 : ! ! if(has_to_print) WRITE(STD_OUT,*) 'TROULLIER PS not available for MGGA '
7126 : ! ! if(has_to_print) WRITE(STD_OUT,*) ' calling VPSmatch with norm conservation instead '
7127 : ! ! CALL VPSmatch(atp%Grid,atp%Pot,atp%PAW,l,e,.true.,atp%scalarrelativistic)
7128 : ! ! ENDIF
7129 : ! IF (Vlocalindex==VPSMATCHNNC) CALL VPSmatch(atp%Grid,atp%Pot,atp%PAW,l,e,.false.,atp%scalarrelativistic)
7130 : ! IF (Vlocalindex==VPSMATCHNC) CALL VPSmatch(atp%Grid,atp%Pot,atp%PAW,l,e,.true.,atp%scalarrelativistic)
7131 : ! IF (Vlocalindex==ULTRASOFT) CALL nonncps(atp%Grid,atp%Pot,atp%PAW,l,e,atp%scalarrelativistic)
7132 : ! IF (Vlocalindex==BESSEL) CALL besselps(atp%Grid,atp%Pot,atp%PAW)
7133 : ! !Calculate projectors
7134 : ! call makebasis_marsman(atp)
7135 : ! ENDIF
7136 : !Output in summary file
7137 2 : IF (atp%needvtau) THEN
7138 0 : if(has_to_print) WRITE(std_out,*) 'Sequence of dataset construction steps modified for mGGA'
7139 0 : if(has_to_print) WRITE(std_out,*) 'Only projectors from Vanderbilt scheme available'
7140 : ENDIF
7141 2 : CALL StoreTOCCWFN(atp%PAW)
7142 2 : END SUBROUTINE SetPAWOptions2
7143 :
7144 :
7145 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7146 : !! SUBROUTINE Troullier(Grid,Pot,PAW,l,e,needvtau,scalarrelativistic)
7147 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7148 2 : SUBROUTINE Troullier(Grid,Pot,PAW,l,e,needvtau,scalarrelativistic)
7149 : TYPE(Gridinfo), INTENT(IN) :: Grid
7150 : TYPE(Potentialinfo), INTENT(INout) :: Pot
7151 : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
7152 : INTEGER,INTENT(IN) :: l
7153 : logical,intent(in) :: needvtau,scalarrelativistic
7154 : real(dp),INTENT(IN) :: e
7155 2 : real(dp), ALLOCATABLE :: VNC(:)
7156 : real(dp) :: A0,A,B,B0,C,C0,D,F,S
7157 : real(dp) :: Coef(6),Coef0,Coef0old
7158 : real(dp) :: h,rc,delta,x,dpp,ddpp,dddpp,ddddpp
7159 : INTEGER :: i,n,iter,nr,nodes,irc
7160 : INTEGER, PARAMETER :: niter=5000
7161 : real(dp), PARAMETER :: small=tol9
7162 2 : real(dp), ALLOCATABLE :: wfn(:),p(:),dum(:),aux(:)
7163 2 : real(dp), POINTER :: r(:),rv(:)
7164 2 : n=Grid%n
7165 2 : h=Grid%h
7166 2 : r=>Grid%r
7167 2 : rv=>Pot%rv
7168 2 : nr=min(PAW%irc_vloc+5,n)
7169 2 : irc=PAW%irc_vloc
7170 2 : rc=PAW%rc_vloc
7171 6 : LIBPAW_ALLOCATE(VNC,(n))
7172 6 : LIBPAW_ALLOCATE(wfn,(nr))
7173 4 : LIBPAW_ALLOCATE(p,(nr))
7174 4 : LIBPAW_ALLOCATE(dum,(nr))
7175 4 : LIBPAW_ALLOCATE(aux,(nr))
7176 2 : if (scalarrelativistic) then
7177 1 : CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes)
7178 1 : else if (needvtau) then
7179 0 : CALL unboundked(Grid,Pot,nr,l,e,wfn,nodes)
7180 : else
7181 1 : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,nr,l,e,wfn,nodes)
7182 : endif
7183 2 : IF (wfn(irc)<0) wfn=-wfn
7184 2773 : dum(1:irc)=(wfn(1:irc)**2)
7185 2 : S=integrator(Grid,dum(1:irc),1,irc)
7186 2 : A0=LOG(wfn(irc)/(rc**(l+1)))
7187 2 : B0=(rc*Gfirstderiv(Grid,irc,wfn)/wfn(irc)-(l+1))
7188 2 : C0=rc*(rv(irc)-rc*e)-B0*(B0+2*l+2)
7189 2 : D=-rc*(rv(irc)-rc*Gfirstderiv(Grid,irc,rv))-2*B0*C0-2*(l+1)*(C0-B0)
7190 : F=rc*(2*rv(irc)-rc*(2*Gfirstderiv(Grid,irc,rv) &
7191 : & -rc*Gsecondderiv(Grid,irc,rv)))+&
7192 2 : & 4*(l+1)*(C0-B0)-2*(l+1)*D-2*C0**2-2*B0*D
7193 2 : if(has_to_print) WRITE(STD_OUT,*) 'In troullier -- matching parameters',S,A0,B0,C0,D,F
7194 2 : delta=1.d10
7195 2 : iter=0
7196 2 : Coef0=0
7197 973 : DO WHILE(delta>small.AND.iter<=niter)
7198 971 : iter=iter+1
7199 971 : A=A0-Coef0
7200 971 : B=B0
7201 971 : C=C0
7202 971 : CALL EvaluateTp(l,A,B,C,D,F,coef)
7203 1343969 : dum=0
7204 1339114 : DO i=1,irc
7205 1338143 : x=(r(i)/rc)**2
7206 : p(i)=x*(Coef(1)+x*(Coef(2)+x*(Coef(3)+&
7207 1338143 : & x*(Coef(4)+x*(Coef(5)+x*Coef(6))))))
7208 1339114 : dum(i)=((r(i)**(l+1))*EXP(p(i)))**2
7209 : ENDDO
7210 971 : Coef0old=Coef0
7211 971 : x=integrator(Grid,dum(1:irc),1,irc)
7212 971 : Coef0=(LOG(S/x))/2
7213 971 : delta=ABS(Coef0-Coef0old)
7214 : ENDDO
7215 2 : if(has_to_print) WRITE(STD_OUT,*) ' VNC converged in ', iter,' iterations'
7216 2 : if(has_to_print) WRITE(STD_OUT,*) ' Coefficients -- ', Coef0,Coef(1:6)
7217 : ! Now calculate VNC
7218 2 : if (needvtau) then
7219 0 : aux=0._dp
7220 0 : call derivative(Grid,PAW%tvtau,aux,1,nr)
7221 : endif
7222 4004 : VNC=0
7223 2781 : DO i=2,nr
7224 2779 : x=(r(i)/rc)**2
7225 : p(i)=Coef0+x*(Coef(1)+x*(Coef(2)+&
7226 2779 : & x*(Coef(3)+x*(Coef(4)+x*(Coef(5)+x*Coef(6))))))
7227 : dpp=2*r(i)/(rc**2)*(Coef(1)+x*(2*Coef(2)+x*(3*Coef(3)+&
7228 2779 : & x*(4*Coef(4)+x*(5*Coef(5)+x*6*Coef(6))))))
7229 : ddpp=(1/(rc**2))*(2*Coef(1)+x*(12*Coef(2)+x*(30*Coef(3)+&
7230 2779 : & x*(56*Coef(4)+x*(90*Coef(5)+x*132*Coef(6))))))
7231 : dddpp=(r(i)/rc**4)*(24*Coef(2)+x*(120*Coef(3)+x*(336*Coef(4)+&
7232 2779 : & x*(720*Coef(5)+x*1320*Coef(6)))))
7233 : ddddpp=(1/(rc**4)*(24*Coef(2)+x*(360*Coef(3)+x*(1680*Coef(4)+&
7234 2779 : & x*(5040*Coef(5)+x*11880*Coef(6))))))
7235 2779 : IF (i==irc) THEN
7236 2 : if(has_to_print) WRITE(STD_OUT,*) 'check dp ', dpp, B0/rc
7237 2 : if(has_to_print) WRITE(STD_OUT,*) 'check ddp ', ddpp, C0/rc**2
7238 2 : if(has_to_print) WRITE(STD_OUT,*) 'check dddp', dddpp, D/rc**3
7239 2 : if(has_to_print) WRITE(STD_OUT,*) 'check ddddp', ddddpp, F/rc**4
7240 : ENDIF
7241 2779 : if (needvtau) then
7242 : VNC(i)=e+(1._dp+PAW%tvtau(i))*(ddpp+dpp*(dpp+2*(l+1)/r(i))) &
7243 0 : & +aux(i)*(dpp+l/r(i))
7244 : else
7245 2779 : VNC(i)=e+ddpp+dpp*(dpp+2*(l+1)/r(i))
7246 : endif
7247 2781 : dum(i)=(r(i)**(l+1))*EXP(p(i))
7248 : ENDDO
7249 2 : x=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7250 2 : if(has_to_print) WRITE(STD_OUT,*) 'check norm ',x,S
7251 1235 : VNC(irc:n)=rv(irc:n)/r(irc:n)
7252 4004 : PAW%rveff(1:n)=VNC(1:n)*r(1:n)
7253 2 : LIBPAW_DEALLOCATE(VNC)
7254 2 : LIBPAW_DEALLOCATE(wfn)
7255 2 : LIBPAW_DEALLOCATE(p)
7256 2 : LIBPAW_DEALLOCATE(dum)
7257 2 : LIBPAW_DEALLOCATE(aux)
7258 2 : END SUBROUTINE troullier
7259 :
7260 :
7261 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7262 : !! StoreTOCCWFN(PAW)
7263 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7264 2 : SUBROUTINE StoreTOCCWFN(PAW)
7265 : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
7266 : INTEGER :: io,ib
7267 14 : do io=1,PAW%TOCCWFN%norbit
7268 14 : if (PAW%valencemap(io)>0) then
7269 6 : ib=PAW%valencemap(io)
7270 12012 : PAW%TOCCWFN%wfn(:,io)=PAW%tphi(:,ib)
7271 : endif
7272 : enddo
7273 2 : END SUBROUTINE StoreTOCCWFN
7274 :
7275 :
7276 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7277 : !! SUBROUTINE setbasis(Grid,Pot,Orbit,PAW,atp)
7278 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7279 2 : SUBROUTINE setbasis(Grid,Pot,Orbit,PAW,atp,potshift)
7280 : TYPE(GridInfo), INTENT(IN) :: Grid
7281 : real(dp), intent(in) :: potshift
7282 : TYPE(PotentialInfo), INTENT(INout) :: Pot
7283 : TYPE(OrbitInfo), INTENT(INOUT) :: Orbit
7284 : TYPE(PseudoInfo), intent(inout) :: PAW
7285 : TYPE(atompaw_type), intent(in) :: atp
7286 : INTEGER :: n,irc,nbase,l,lmax,mxbase,currentnode
7287 : INTEGER :: i,k,io,nbl,nr,nodes,ibasis_add
7288 : real(dp) :: h,rc,energy,rat,range
7289 2 : real(dp),allocatable :: checkden(:),valden(:)
7290 2 : real(dp), POINTER :: r(:)
7291 2 : n=Grid%n
7292 2 : h=Grid%h
7293 2 : r=>Grid%r
7294 2 : irc=PAW%irc
7295 2 : nr=MIN(irc+100,n-100)
7296 2 : rc=PAW%rc
7297 2 : lmax=PAW%lmax
7298 6 : LIBPAW_ALLOCATE(checkden,(n))
7299 4 : LIBPAW_ALLOCATE(valden,(n))
7300 8006 : checkden=0._dp;valden=0._dp
7301 : !Check beginning valence density
7302 14 : DO io=1,Orbit%norbit
7303 14 : if (.not.Orbit%iscore(io)) then
7304 12018 : valden=valden+Orbit%occ(io)*(Orbit%wfn(:,io)**2)
7305 : endif
7306 : ENDDO
7307 : ! set AErefrv
7308 4004 : PAW%AErefrv=Pot%rv
7309 4004 : PAW%rvx=Pot%rvx
7310 2 : PAW%exctype=Orbit%exctype
7311 2 : nbase=PAW%nbase
7312 2 : mxbase=PAW%mxbase
7313 : ! "filter" occupied states for long-range noise
7314 14 : DO io=1,Orbit%norbit
7315 14 : Call Filter(n,Orbit%wfn(:,io),machine_zero)
7316 : ENDDO
7317 2 : call CopyOrbit(Orbit,PAW%OCCwfn)
7318 2 : call CopyOrbit(Orbit,PAW%TOCCwfn)
7319 14 : PAW%valencemap=-13
7320 2 : IF (Orbit%exctype=='HF') THEN
7321 0 : range=r(n)
7322 0 : rat=-1.d30; k=1
7323 0 : do io=1,Orbit%norbit
7324 0 : if ((Orbit%occ(io)>tol5).and.Orbit%eig(io)>rat) then
7325 0 : rat=Orbit%eig(io)
7326 0 : k=io
7327 : endif
7328 : enddo
7329 0 : do i=n,irc+1,-1
7330 0 : if (ABS(Orbit%wfn(i,k))>tol4) then
7331 0 : range=r(i)
7332 0 : exit
7333 : endif
7334 : enddo
7335 0 : if(has_to_print) write(std_out,*) 'range ', k,range!; call flush_unit(std_out)
7336 : ENDIF
7337 2 : if(has_to_print) WRITE(STD_OUT,*) ' basis functions:'
7338 2 : if(has_to_print) WRITE(STD_OUT,*)' No. n l energy occ '
7339 2 : nbase=0 ; ibasis_add=1
7340 9 : DO l=0,lmax
7341 7 : currentnode=-1
7342 7 : nbl=0
7343 48 : DO io=1,Orbit%norbit ! cycle through all configuration
7344 48 : IF (Orbit%l(io).EQ.l) THEN
7345 12 : currentnode=Orbit%np(io)-l-1
7346 12 : IF (.NOT.Orbit%iscore(io)) THEN
7347 6 : nbl=nbl+1
7348 6 : nbase=nbase+1
7349 6 : PAW%np(nbase)=Orbit%np(io)
7350 6 : PAW%l(nbase)=l
7351 6 : PAW%nodes(nbase)=PAW%np(nbase)-l-1
7352 6 : if(has_to_print) write(std_out,*) 'l,nbase,node',l,nbase,currentnode
7353 6 : PAW%eig(nbase)=Orbit%eig(io)
7354 6 : if(Orbit%issemicore(io)) PAW%eig(nbase)=PAW%eig(nbase)-potshift
7355 6 : PAW%occ(nbase)=Orbit%occ(io)
7356 6 : if(Orbit%frozenvalecalculation.and.(.not.Orbit%issemicore(io))) then
7357 4 : energy=PAW%eig(nbase)
7358 8008 : Orbit%wfn(:,io)=zero
7359 4 : if (Orbit%scalarrelativistic) then
7360 2 : CALL unboundsr(Grid,Pot,n,l,energy,Orbit%wfn(:,io),nodes)
7361 : else
7362 : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,&
7363 2 : & nr,l,energy,Orbit%wfn(:,io),nodes)
7364 : endif
7365 : endif
7366 12012 : PAW%phi(:,nbase)=Orbit%wfn(:,io)
7367 6 : if(Orbit%diracrelativistic) then
7368 0 : STOP 'Error -- setbasis subroutine not ready for diracrelativistic!'
7369 : endif
7370 6 : PAW%valencemap(io)=nbase
7371 6 : if(has_to_print) WRITE(STD_OUT,'(3i6,1p,2e15.6)') nbase,PAW%np(nbase),l,&
7372 0 : & PAW%eig(nbase),PAW%occ(nbase)!; call flush_unit(std_out)
7373 : ENDIF
7374 : ENDIF
7375 : ENDDO
7376 2 : generalizedloop: DO
7377 19 : IF (ibasis_add>atp%nbasis_add) EXIT generalizedloop
7378 17 : IF (atp%basis_add_l(ibasis_add)/=l) EXIT generalizedloop
7379 12 : energy=atp%basis_add_energy(ibasis_add)
7380 12 : IF (energy<0._dp.and.has_to_print) then
7381 0 : WRITE(STD_OUT,*) 'energy is negative',energy,' -- WARNING WARNING !!!'
7382 : endif
7383 12 : nbase=nbase+1
7384 12 : IF (nbase > mxbase ) THEN
7385 0 : LIBPAW_ERROR('Error in setbasis -- too many functions ')
7386 : ENDIF
7387 12 : PAW%l(nbase)=l
7388 12 : PAW%np(nbase)=999
7389 12 : PAW%nodes(nbase)=currentnode+1
7390 12 : currentnode=PAW%nodes(nbase)
7391 12 : if(has_to_print) write(std_out,*) 'l,nbase,node',l,nbase,currentnode
7392 12 : PAW%eig(nbase)=energy
7393 12 : PAW%occ(nbase)=0._dp
7394 24024 : PAW%phi(1:n,nbase)=0._dp
7395 12 : if (Orbit%scalarrelativistic) then
7396 2 : CALL unboundsr(Grid,Pot,n,l,energy,PAW%phi(:,nbase),nodes)
7397 10 : else if (Pot%needvtau) then
7398 0 : CALL unboundked(Grid,Pot,n,l,energy,PAW%phi(:,nbase),nodes)
7399 : else
7400 : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,&
7401 10 : & nr,l,energy,PAW%phi(:,nbase),nodes)
7402 : endif
7403 12 : rat=MAX(ABS(PAW%phi(irc,nbase)),ABS(PAW%phi(irc+1,nbase)))
7404 12 : rat=DSIGN(rat,PAW%phi(irc,nbase))
7405 24024 : PAW%phi(1:n,nbase)=PAW%phi(1:n,nbase)/rat
7406 12 : if(has_to_print) write(std_out,*) 'MAX PHI=',nbase,maxval(PAW%phi(:,nbase))
7407 12 : if(has_to_print) then
7408 0 : WRITE(STD_OUT,'(3i6,1p,2e15.6)') nbase,PAW%np(nbase),l, &
7409 0 : & PAW%eig(nbase),PAW%occ(nbase)
7410 : endif
7411 12 : nbl=nbl+1
7412 17 : ibasis_add=ibasis_add+1
7413 : ENDDO generalizedloop
7414 : ENDDO ! end lmax loop
7415 2 : if(has_to_print) WRITE(std_out,*) 'completed phi basis with ',nbase,' functions '
7416 2 : PAW%nbase=nbase ! reset nbase
7417 2 : LIBPAW_DEALLOCATE(checkden)
7418 2 : LIBPAW_DEALLOCATE(valden)
7419 2 : END SUBROUTINE setbasis
7420 :
7421 :
7422 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7423 : !! SUBROUTINE smoothcore(Grid,orig,PAW)
7424 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7425 18 : SUBROUTINE smoothcore(Grid,orig,PAW)
7426 : TYPE(GridInfo), INTENT(IN) :: Grid
7427 : real(dp), INTENT(IN) :: orig(:)
7428 : type(pseudoInfo), intent(inout) :: PAW
7429 : real(dp) :: rc,h,x,y,z,u0,u2,u4
7430 18 : real(dp), allocatable :: d1(:),d2(:)
7431 : INTEGER :: i,n,irc
7432 18 : n=Grid%n
7433 18 : h=Grid%h
7434 18 : irc=PAW%irc_core
7435 18 : rc=PAW%rc_core
7436 18 : if(has_to_print) write(std_out,*) 'In smoothcore ', irc,rc
7437 54 : LIBPAW_ALLOCATE(d1,(n))
7438 36 : LIBPAW_ALLOCATE(d2,(n))
7439 18 : CALL derivative(Grid,orig,d1)
7440 18 : CALL derivative(Grid,d1,d2)
7441 18 : x=orig(irc)
7442 18 : y=d1(irc)*rc
7443 18 : z=d2(irc)*(rc*rc)
7444 18 : if(has_to_print) write(std_out,*) 'smoothcore: x,y,z = ', x,y,z
7445 18 : u0=3*x - 9*y/8 + z/8
7446 18 : u2=-3*x + 7*y/4 - z/4
7447 18 : u4=x - 5*y/8 + z/8
7448 18 : if(has_to_print) write(std_out,*) 'smoothcore: u0,u2,u4 = ', u0,u2,u4
7449 36036 : PAW%tcore=orig
7450 24282 : do i=1,irc
7451 24264 : x=(Grid%r(i)/rc)**2
7452 24282 : PAW%tcore(i)= x*(u0+x*(u2+x*u4))
7453 : enddo
7454 18 : LIBPAW_DEALLOCATE(d1)
7455 18 : LIBPAW_DEALLOCATE(d2)
7456 18 : END SUBROUTINE smoothcore
7457 :
7458 :
7459 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7460 : !! SUBROUTINE smoothpower
7461 : !! program to take array orig (all electron tau or den)
7462 : !! and return smooth polynomial function for 0 \le r \le rc_core
7463 : !! matching 4 points less than and equal to rc_core
7464 : !! power could be 2 or 4, representing the leading power
7465 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7466 0 : SUBROUTINE smoothpower(Grid,power,orig,smooth,PAW)
7467 : TYPE(GridInfo), INTENT(IN) :: Grid
7468 : type(pseudoInfo), intent(in) :: PAW
7469 : INTEGER, INTENT(IN) :: power
7470 : REAL(dp), INTENT(IN) :: orig(:)
7471 : REAL(dp), INTENT(INOUT) :: smooth(:)
7472 : INTEGER, parameter :: terms=5
7473 : REAL(dp) :: rc,h,x
7474 : REAL(dp) :: aa(terms,terms),Ci(terms)
7475 : INTEGER :: i,j,n,irc
7476 0 : n=Grid%n
7477 0 : h=Grid%h
7478 0 : irc=PAW%irc_core
7479 0 : rc=Grid%r(irc)
7480 0 : if(has_to_print) write(std_out,*) 'smoothpower -- ', power,irc,rc
7481 0 : aa=zero; Ci=zero
7482 0 : do i=1,terms
7483 0 : x=Grid%r(irc-terms+i)
7484 0 : Ci(i)=orig(irc-terms+i)/x**power
7485 0 : do j=1,terms
7486 0 : aa(i,j)=x**(2*(j-1))
7487 : enddo
7488 : enddo
7489 0 : call SolveAXeqBM(terms,aa,Ci,terms-1)
7490 0 : if(has_to_print) write(std_out,*) 'Completed SolveAXeqB with coefficients'
7491 0 : if(has_to_print) write(std_out,'(1p,10e15.7)') (Ci(i),i=1,terms)
7492 0 : smooth=orig
7493 0 : do i=1,irc-1
7494 0 : smooth(i)=0
7495 0 : x=Grid%r(i)
7496 0 : do j=1,terms
7497 0 : smooth(i)=smooth(i)+Ci(j)*(x**(power+2*(j-1)))
7498 : enddo
7499 : enddo
7500 0 : END SUBROUTINE smoothpower
7501 :
7502 :
7503 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7504 : !! SUBROUTINE setcoretail(Grid,coreden,PAW)
7505 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7506 18 : SUBROUTINE setcoretail(Grid,coreden,PAW,needvtau)
7507 : type(logical),intent(in) :: needvtau
7508 : TYPE(GridInfo), INTENT(IN) :: Grid
7509 : real(dp), INTENT(IN) :: coreden(:)
7510 : type(pseudoInfo), intent(inout) :: PAW
7511 : real(dp) :: rc,h,z
7512 : INTEGER :: i,n,irc
7513 18 : n=Grid%n
7514 18 : h=Grid%h
7515 18 : irc=PAW%irc_core
7516 18 : rc=PAW%rc_core
7517 18 : If(.not.needvtau) then
7518 18 : CALL smoothcore(Grid,coreden,PAW)
7519 : else
7520 0 : CALL smoothpower(Grid,2,coreden,PAW%tcore,PAW)
7521 : endif
7522 36036 : PAW%core=coreden
7523 : ! Find coretailpoints
7524 18 : z = integrator(Grid,coreden)
7525 18 : PAW%coretailpoints=PAW%irc+Grid%ishift !! coretailpoints should be>=PAW%irc
7526 1471 : do i=PAW%irc+Grid%ishift,n
7527 1471 : if(ABS(z-integrator(Grid,coreden,1,i))<coretailtol) then
7528 18 : PAW%coretailpoints=i
7529 18 : exit
7530 : endif
7531 : enddo
7532 18 : if(has_to_print) write(std_out,*) 'coretailpoints = ',PAW%coretailpoints
7533 18 : END SUBROUTINE setcoretail
7534 :
7535 :
7536 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7537 : !! SUBROUTINE nonncps(lmax,Grid,Pot)
7538 : !! Creates screened pseudopotential by inverting Schroedinger
7539 : !! equation from a pseudized radial wave function of the form:
7540 : !! Psi(r) = r**(l+1) * exp (a + b*r**2 + c*r**4 + d*r**6)
7541 : !! No norm-conserving condition is imposed on Psi
7542 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7543 0 : SUBROUTINE nonncps(Grid,Pot,PAW,l,e,scalarrelativistic)
7544 : logical, intent(in) :: scalarrelativistic
7545 : TYPE(Gridinfo), INTENT(IN) :: Grid
7546 : TYPE(Potentialinfo), INTENT(INout) :: Pot
7547 : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
7548 : INTEGER,INTENT(IN) :: l
7549 : REAL(dp),INTENT(IN) :: e
7550 : INTEGER :: i,irc,n,nr,nodes,i1,i2,i3,i4
7551 : REAL(dp) :: rc,x,y1,y2,y3,p0,p1,p2,p3,sgn
7552 : REAL(dp) :: b(4),c(4),d(4),amat(4,4)
7553 0 : REAL(dp),ALLOCATABLE :: VNC(:),wfn(:),aux(:)
7554 0 : REAL(dp),POINTER :: r(:),rv(:)
7555 : !Polynomial definitions
7556 : p0(x,y1,y2,y3)=(x-y1)*(x-y2)*(x-y3)
7557 : p1(x,y1,y2,y3)=(x-y2)*(x-y3)+(x-y1)*(x-y3)+(x-y1)*(x-y2)
7558 : p2(x,y1,y2,y3)=two*((x-y1)+(x-y2)+(x-y3))
7559 : p3(x,y1,y2,y3)=six
7560 0 : n=Grid%n
7561 0 : r=>Grid%r
7562 0 : rv=>Pot%rv
7563 0 : nr=min(PAW%irc_vloc+10,n)
7564 0 : irc=PAW%irc_vloc
7565 0 : rc=PAW%rc_vloc
7566 0 : LIBPAW_ALLOCATE(VNC,(n))
7567 0 : LIBPAW_ALLOCATE(wfn,(nr))
7568 0 : LIBPAW_ALLOCATE(aux,(nr))
7569 0 : if (scalarrelativistic) then
7570 0 : CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes)
7571 0 : else if (Pot%needvtau) then
7572 0 : CALL unboundked(Grid,Pot,nr,l,e,wfn,nodes)
7573 : else
7574 0 : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,nr,l,e,wfn,nodes)
7575 : endif
7576 0 : IF (wfn(irc)<0) wfn=-wfn
7577 0 : DO i=2,nr
7578 0 : wfn(i)=wfn(i)/r(i)**dble(l+1)
7579 : ENDDO
7580 0 : i1=irc-1;i2=i1+1;i3=i2+1;i4=i3+1
7581 0 : c(1)=wfn(i1)/p0(r(i1),r(i2),r(i3),r(i4))
7582 0 : c(2)=wfn(i2)/p0(r(i2),r(i3),r(i4),r(i1))
7583 0 : c(3)=wfn(i3)/p0(r(i3),r(i4),r(i1),r(i2))
7584 0 : c(4)=wfn(i4)/p0(r(i4),r(i1),r(i2),r(i3))
7585 : d(1)=c(1)*p0(rc,r(i2),r(i3),r(i4)) + c(2)*p0(rc,r(i3),r(i4),r(i1)) + &
7586 0 : & c(3)*p0(rc,r(i4),r(i1),r(i2)) + c(4)*p0(rc,r(i1),r(i2),r(i3))
7587 : d(2)=c(1)*p1(rc,r(i2),r(i3),r(i4)) + c(2)*p1(rc,r(i3),r(i4),r(i1)) + &
7588 0 : & c(3)*p1(rc,r(i4),r(i1),r(i2)) + c(4)*p1(rc,r(i1),r(i2),r(i3))
7589 : d(3)=c(1)*p2(rc,r(i2),r(i3),r(i4)) + c(2)*p2(rc,r(i3),r(i4),r(i1)) + &
7590 0 : & c(3)*p2(rc,r(i4),r(i1),r(i2)) + c(4)*p2(rc,r(i1),r(i2),r(i3))
7591 : d(4)=c(1)*p3(rc,r(i2),r(i3),r(i4)) + c(2)*p3(rc,r(i3),r(i4),r(i1)) + &
7592 0 : & c(3)*p3(rc,r(i4),r(i1),r(i2)) + c(4)*p3(rc,r(i1),r(i2),r(i3))
7593 0 : sgn=d(1)/abs(d(1));d(1:4)=d(1:4)*sgn
7594 0 : b(1)=log(d(1));b(2:4)=d(2:4)
7595 0 : amat(1,1)= 1.0_dp
7596 0 : amat(2:4,1)= 0.0_dp
7597 0 : amat(1,2)= rc**2
7598 0 : amat(2,2)= 2.0_dp*d(1)*rc
7599 0 : amat(3,2)= 2.0_dp*d(1) +2.0_dp*d(2)*rc
7600 0 : amat(4,2)= 4.0_dp*d(2) +2.0_dp*d(3)*rc
7601 0 : amat(1,3)= rc**4
7602 0 : amat(2,3)= 4.0_dp*d(1)*rc**3
7603 0 : amat(3,3)= 12.0_dp*d(1)*rc**2+ 4.0_dp*d(2)*rc**3
7604 0 : amat(4,3)= 24.0_dp*d(1)*rc +24.0_dp*d(2)*rc**2+4.0_dp*d(3)*rc**3
7605 0 : amat(1,4)= rc**6
7606 0 : amat(2,4)= 6.0_dp*d(1)*rc**5
7607 0 : amat(3,4)= 30.0_dp*d(1)*rc**4+ 6.0_dp*d(2)*rc**5
7608 0 : amat(4,4)= 120.0_dp*d(1)*rc**3+60.0_dp*d(2)*rc**4+6.0_dp*d(3)*rc**5
7609 0 : CALL linsol(amat,b,4,4,4,4)
7610 0 : if (Pot%needvtau) then
7611 0 : aux=zero
7612 0 : call derivative(Grid,PAW%tvtau,aux,1,nr)
7613 : endif
7614 0 : PAW%rveff(1)=0._dp
7615 0 : DO i=2,irc-1
7616 0 : c(1)=2.0_dp*b(2)*r(i)+ 4.0_dp*b(3)*r(i)**3+ 6.0_dp*b(4)*r(i)**5
7617 0 : c(2)=2.0_dp*b(2) +12.0_dp*b(3)*r(i)**2+30.0_dp*b(4)*r(i)**4
7618 0 : if (pot%needvtau) then
7619 : PAW%rveff(i)=r(i)*(e+(dble(2*l+2)*c(1)/r(i)+c(1)**2+&
7620 0 : & c(2))*(1._dp+PAW%tvtau(i))+aux(i)*(c(1)+dble(l)/r(i)))
7621 : else
7622 0 : PAW%rveff(i)=r(i)*(e+dble(2*l+2)*c(1)/r(i)+c(1)**2+c(2))
7623 : endif
7624 : ENDDO
7625 0 : PAW%rveff(irc:n)=rv(irc:n)
7626 0 : LIBPAW_DEALLOCATE(VNC)
7627 0 : LIBPAW_DEALLOCATE(wfn)
7628 0 : LIBPAW_DEALLOCATE(aux)
7629 0 : END SUBROUTINE nonncps
7630 :
7631 :
7632 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7633 : ! SUBROUTINE VPSmatch(lmax,Grid,Pot,NC)
7634 : ! Creates screened norm-conserving pseudopotential similar to the
7635 : ! approach of N. Troullier and J. L. Martins, PRB 43, 1993 (1991)
7636 : ! Uses p(r)=a0+f(r); f(r)=SUMm(Coef(m)*r^(2*m), where
7637 : ! m=1,2..6
7638 : ! Psi(r) = r^(l+1)*exp(p(r))
7639 : ! Modified for MGGA case and norm conserving condition is optional
7640 : ! norm conservation controlled with optional variable NC
7641 : ! defaults to no norm conservation
7642 : ! Note this program assumes that wfn keeps the same sign for
7643 : ! all matching points r(irc-match+1)....r(irc)
7644 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7645 : SUBROUTINE VPSmatch(Grid,Pot,PAW,l,e,NC,scalarrelativistic)
7646 : logical,intent(in) :: scalarrelativistic
7647 : TYPE(Gridinfo), INTENT(IN) :: Grid
7648 : TYPE(Potentialinfo), INTENT(INout) :: Pot
7649 : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
7650 : INTEGER,INTENT(IN) :: l
7651 : REAL(dp),INTENT(IN) :: e
7652 : LOGICAL,INTENT(IN), OPTIONAL :: NC
7653 : REAL(dp), ALLOCATABLE :: VNC(:)
7654 : REAL(dp) :: C0,S
7655 : REAL(dp) :: Coef0,Coef0old
7656 : REAL(dp) :: h,rc,delta,x
7657 : INTEGER :: i,j,n,iter,nr,nodes,irc
7658 : INTEGER, parameter :: match=6
7659 : REAL(dp) :: AAA(match,match),BBB(match)
7660 : REAL(dp) :: AAAA(match-1,match-1),BBBB(match-1)
7661 : INTEGER, PARAMETER :: niter=5000
7662 : REAL(dp), PARAMETER :: small=1.0d-9
7663 : REAL(dp), ALLOCATABLE :: wfn(:),p(:),dum(:),aux(:),Kaux(:),v(:),dp1(:),ddp(:)
7664 : REAL(dp), POINTER :: r(:),rv(:)
7665 : LOGICAL :: normcons
7666 : normcons=.false.
7667 : if(PRESENT(NC)) normcons=NC
7668 : if(has_to_print) write(std_out,*) 'Entering VPSmatch with normcons ', normcons
7669 : n=Grid%n
7670 : h=Grid%h
7671 : r=>Grid%r
7672 : rv=>Pot%rv
7673 : nr=min(PAW%irc_vloc+10,n)
7674 : irc=PAW%irc_vloc
7675 : rc=PAW%rc_vloc
7676 : LIBPAW_ALLOCATE(VNC,(n))
7677 : LIBPAW_ALLOCATE(wfn,(n))
7678 : LIBPAW_ALLOCATE(p,(n))
7679 : LIBPAW_ALLOCATE(dum,(n))
7680 : LIBPAW_ALLOCATE(aux,(n))
7681 : LIBPAW_ALLOCATE(dp1,(n))
7682 : LIBPAW_ALLOCATE(ddp,(n))
7683 : LIBPAW_ALLOCATE(Kaux,(n))
7684 : LIBPAW_ALLOCATE(v,(n))
7685 : wfn=zero
7686 : if (scalarrelativistic) then
7687 : CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes)
7688 : else if (Pot%needvtau) then
7689 : CALL unboundked(Grid,Pot,nr,l,e,wfn,nodes)
7690 : else
7691 : CALL unboundsch(Grid,Pot%rv,Pot%v0,Pot%v0p,nr,l,e,wfn,nodes)
7692 : endif
7693 : IF (wfn(irc)<0) wfn=-wfn
7694 : ! first solve non-norm conserving results
7695 : AAA=zero;BBB=zero
7696 : Do i=1,match
7697 : x=r(irc-match+i)
7698 : BBB(i)=log(wfn(irc-match+i)/(x**(l+1)))
7699 : do j=1,match
7700 : AAA(i,j)=x**(2*(j-1))
7701 : enddo
7702 : Enddo
7703 : CALL SolveAXeqB(match,AAA,BBB,1.d20)
7704 : if(has_to_print) write(std_out,*) 'Returned from SolveAXeqB in VPSmatch with Coefficients '
7705 : if(has_to_print) write(std_out,'(1p,50e16.7)') (BBB(i),i=1,match)
7706 : ! Now calculate VNC
7707 : if (Pot%needvtau) then
7708 : aux=0._dp
7709 : call derivative(Grid,PAW%tvtau,aux,1,nr)
7710 : Kaux=0._dp
7711 : call derivative(Grid,PAW%Ktvtau,Kaux,1,nr) ! Kresse form
7712 : endif
7713 : VNC=zero;p=zero;dp1=zero;ddp=zero;dum=zero
7714 : !specific for match=6
7715 : DO i=2,nr
7716 : x=(r(i))**2
7717 : p(i)=BBB(1)+x*(BBB(2)+x*(BBB(3)+x*(BBB(4)+x*(BBB(5)+x*BBB(6)))))
7718 : dp1(i)=two*r(i)*(BBB(2)+x*(two*BBB(3)+x*(three*BBB(4)+x*(four*BBB(5)+five*x*BBB(6)))))
7719 : ddp(i)=2.0_dp*(BBB(2)+x*(6.0_dp*BBB(3)+x*(15.0_dp*BBB(4)+x*(28.0_dp*BBB(5)+45.0_dp*x*BBB(6)))))
7720 : if (Pot%needvtau) then
7721 : VNC(i)=e+(1._dp+PAW%tvtau(i))*(ddp(i)+ &
7722 : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7723 : & +aux(i)*(dp1(i)+l/r(i))
7724 : v(i)=e+(1._dp+PAW%Ktvtau(i))*(ddp(i)+ &
7725 : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7726 : & +Kaux(i)*(dp1(i)+l/r(i))
7727 : else
7728 : VNC(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7729 : v(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7730 : endif
7731 : dum(i)=(r(i)**(l+1))*EXP(p(i))
7732 : ENDDO
7733 : S=overlap(Grid,wfn(1:irc),wfn(1:irc),1,irc)
7734 : C0=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7735 : if(has_to_print) WRITE(STD_OUT,*) 'check norm ',C0,S
7736 : VNC(irc:n)=rv(irc:n)/r(irc:n)
7737 : v(irc:n)=rv(irc:n)/r(irc:n)
7738 : PAW%rveff(1:n)=VNC(1:n)*r(1:n)
7739 : PAW%Krveff(1:n)=v(1:n)*r(1:n)
7740 : if(has_to_print) write(std_out,*) 'Completed non-norm-conserving PS '
7741 : if(.not.normcons) return
7742 : ! Iterate to find norm conserving results
7743 : C0=C0/(EXP(2*BBB(1)))
7744 : delta=1.d10
7745 : iter=zero
7746 : Coef0=0.5_dp*log(S/C0)
7747 : DO WHILE(delta>small.AND.iter<=niter)
7748 : Coef0old=Coef0
7749 : iter=iter+1
7750 : AAAA=zero;BBBB=zero
7751 : Do i=1,match-1
7752 : x=r(irc-match+1+i)
7753 : BBBB(i)=log(wfn(irc-match+1+i)/(x**(l+1)))-Coef0old
7754 : do j=1,match-1
7755 : AAAA(i,j)=x**(2*(j))
7756 : enddo
7757 : Enddo
7758 : CALL SolveAXeqB(match-1,AAAA,BBBB,1.d20)
7759 : if(has_to_print) write(std_out,*) 'Returned from SolveAXeqB in VPSmatch with Coefficients'
7760 : if(has_to_print) write(std_out,'(1p,50e16.7)') (BBBB(i),i=1,match-1)
7761 : !specific for match-1=5
7762 : p=zero;dum=zero
7763 : DO i=2,nr
7764 : x=(r(i))**2
7765 : p(i)=x*(BBBB(1)+x*(BBBB(2)+x*(BBBB(3)+x*(BBBB(4)+x*BBBB(5)))))
7766 : dum(i)=(r(i)**(l+1))*EXP(Coef0+p(i))
7767 : ENDDO
7768 : C0=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7769 : if(has_to_print) WRITE(std_out,*) 'check norm ',C0,S
7770 : Coef0=0.5_dp*log(S/C0)
7771 : delta=ABS(Coef0-Coef0old)
7772 : if(has_to_print) WRITE(std_out,'(" VNC: iter Coef0 delta",i5,1p,2e15.7)') iter,Coef0,delta
7773 : ENDDO
7774 : if(has_to_print) WRITE(std_out,*) ' VNC converged in ', iter,' iterations'
7775 : if(has_to_print) WRITE(std_out,*) ' Coefficients -- ', Coef0,BBBB(1:match-1)
7776 : ! Now calculate VNC
7777 : if (Pot%needvtau) then
7778 : aux=0._dp
7779 : call derivative(Grid,PAW%tvtau,aux,1,nr)
7780 : Kaux=0._dp
7781 : call derivative(Grid,PAW%Ktvtau,Kaux,1,nr)
7782 : endif
7783 : VNC=zero;p=zero;dp1=zero;ddp=zero;v=zero
7784 : DO i=2,nr
7785 : x=(r(i))**2
7786 : p(i)=x*(BBBB(1)+x*(BBBB(2)+x*(BBBB(3)+x*(BBBB(4)+x*BBBB(5)))))
7787 : dp1(i)=two*r(i)*(BBBB(1)+x*(two*BBBB(2)+x*(three*BBBB(3)+x*(four*BBBB(4)+five*x*BBBB(5)))))
7788 : ddp(i)=2.0_dp*(BBBB(1)+x*(6.0_dp*BBBB(2)+x*(15.0_dp*BBBB(3)+x*(28.0_dp*BBBB(4)+45.0_dp*x*BBBB(5)))))
7789 : if (Pot%needvtau) then
7790 : VNC(i)=e+(1._dp+PAW%tvtau(i))*(ddp(i)+ &
7791 : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7792 : & +aux(i)*(dp1(i)+l/r(i))
7793 : v(i)=e+(1._dp+PAW%Ktvtau(i))*(ddp(i)+ &
7794 : & dp1(i)*(dp1(i)+two*(l+1)/r(i))) &
7795 : & +Kaux(i)*(dp1(i)+l/r(i))
7796 : else
7797 : VNC(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7798 : v(i)=e+ddp(i)+dp1(i)*(dp1(i)+two*(l+1)/r(i))
7799 : endif
7800 : dum(i)=(r(i)**(l+1))*EXP(Coef0+p(i))
7801 : ENDDO
7802 : C0=overlap(Grid,dum(1:irc),dum(1:irc),1,irc)
7803 : if(has_to_print) WRITE(std_out,*) 'check norm ',C0,S
7804 : VNC(irc:n)=rv(irc:n)/r(irc:n)
7805 : v(irc:n)=rv(irc:n)/r(irc:n)
7806 : PAW%rveff(1:n)=VNC(1:n)*r(1:n)
7807 : PAW%Krveff(1:n)=v(1:n)*r(1:n)
7808 : if(has_to_print)write(std_out,*) 'Completed norm-conserving PS '
7809 : if (iter.ge.niter) then
7810 : write(std_out,*) 'Failed to converged norm-conserving VPS '
7811 : stop
7812 : endif
7813 : LIBPAW_DEALLOCATE(VNC)
7814 : LIBPAW_DEALLOCATE(wfn)
7815 : LIBPAW_DEALLOCATE(p)
7816 : LIBPAW_DEALLOCATE(dp1)
7817 : LIBPAW_DEALLOCATE(ddp)
7818 : LIBPAW_DEALLOCATE(dum)
7819 : LIBPAW_DEALLOCATE(aux)
7820 : LIBPAW_DEALLOCATE(Kaux)
7821 : LIBPAW_DEALLOCATE(v)
7822 : END SUBROUTINE VPSmatch
7823 :
7824 :
7825 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7826 : ! calculate_tvtau for MGGA case
7827 : ! Assume valence pseudo wavefunctions known
7828 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7829 : SUBROUTINE calculate_tvtau(Grid,PAW,itype)
7830 : TYPE(GridInfo), INTENT(IN) :: Grid
7831 : type(pseudoInfo),intent(inout) :: PAW
7832 : integer,intent(in) :: itype
7833 : INTEGER :: i
7834 : REAL(dp), allocatable :: dp1(:),ddp(:),vxc(:),tvxc(:),locald(:),localtd(:)
7835 : REAL(dp), allocatable :: Ktvxc(:),Kd(:)
7836 : REAL(dp) :: exc,texc,sum,tsum
7837 : REAL(dp), parameter :: small=1.d-5
7838 : LIBPAW_ALLOCATE(dp1,(Grid%n))
7839 : LIBPAW_ALLOCATE(ddp,(Grid%n))
7840 : LIBPAW_ALLOCATE(vxc,(Grid%n))
7841 : LIBPAW_ALLOCATE(tvxc,(Grid%n))
7842 : LIBPAW_ALLOCATE(locald,(Grid%n))
7843 : LIBPAW_ALLOCATE(localtd,(Grid%n))
7844 : LIBPAW_ALLOCATE(Ktvxc,(Grid%n))
7845 : LIBPAW_ALLOCATE(Kd,(Grid%n))
7846 : locald=PAW%core
7847 : localtd=PAW%tcore
7848 : PAW%valetau=0._dp
7849 : PAW%tvaletau=0._dp
7850 : do i=1,PAW%nbase
7851 : if(has_to_print) write(std_out,*) 'tvtau -- ', i,PAW%l(i),PAW%occ(i),PAW%eig(i)
7852 : if (PAW%occ(i).gt.small) then
7853 : locald=locald+PAW%occ(i)*(PAW%phi(:,i)**2)
7854 : localtd=localtd+PAW%occ(i)*(PAW%tphi(:,i)**2)
7855 : CALL taufromwfn(dp1,Grid,PAW%phi(:,i),PAW%l(i))
7856 : CALL taufromwfn(ddp,Grid,PAW%tphi(:,i),PAW%l(i))
7857 : PAW%valetau=PAW%valetau+PAW%occ(i)*dp1
7858 : PAW%tvaletau=PAW%tvaletau+PAW%occ(i)*ddp
7859 : endif
7860 : enddo
7861 : dp1=PAW%coretau+PAW%valetau
7862 : ddp=PAW%tcoretau+PAW%tvaletau
7863 : CALL exch(Grid,locald,vxc,sum,exc,itype,&
7864 : & tau=dp1,vtau=PAW%vtau)
7865 : CALL exch(Grid,localtd,tvxc,tsum,texc,itype,&
7866 : & tau=ddp,vtau=PAW%tvtau)
7867 : if(has_to_print) write(std_out,*) 'tvtau exc texc ', exc, texc
7868 : ! Kresse form
7869 : Kd=locald-PAW%core-localtd+PAW%tcore
7870 : sum=integrator(Grid,Kd)
7871 : if(has_to_print) write(std_out,*) 'compensation charge in Ktvtau ', sum
7872 : Kd=localtd+sum*PAW%hatden
7873 : CALL exch(Grid,Kd,Ktvxc,tsum,texc,itype,&
7874 : & tau=ddp,vtau=PAW%Ktvtau)
7875 : LIBPAW_DEALLOCATE(dp1)
7876 : LIBPAW_DEALLOCATE(ddp)
7877 : LIBPAW_DEALLOCATE(vxc)
7878 : LIBPAW_DEALLOCATE(tvxc)
7879 : LIBPAW_DEALLOCATE(locald)
7880 : LIBPAW_DEALLOCATE(localtd)
7881 : LIBPAW_DEALLOCATE(Kd)
7882 : LIBPAW_DEALLOCATE(Ktvxc)
7883 : END SUBROUTINE calculate_tvtau
7884 :
7885 :
7886 :
7887 :
7888 :
7889 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7890 : ! 11. Pseudo_sub
7891 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7892 :
7893 :
7894 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7895 : !! subroutine hatL
7896 : !! Calculates density associated with L component
7897 : !! normalized to unity
7898 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7899 0 : SUBROUTINE hatL(Grid,PAW,l,dhat,besselshapefunction)
7900 : TYPE(GridInfo), INTENT(IN) :: Grid
7901 : TYPE(PseudoInfo), INTENT(IN) :: PAW
7902 : INTEGER, INTENT(IN) :: l
7903 : logical, intent(in) :: besselshapefunction
7904 : REAL(dp), INTENT(OUT) :: dhat(:)
7905 : INTEGER :: n,irc,i
7906 0 : REAL(dp), POINTER :: r(:)
7907 0 : REAL(dp), ALLOCATABLE :: den(:),a(:)
7908 : REAL(dp) :: h,con
7909 : REAL(dp) :: qr,jbes1,jbes2,dum1,dum2,al(2),ql(2)
7910 0 : n=Grid%n
7911 0 : h=Grid%h
7912 0 : r=>Grid%r
7913 0 : irc=PAW%irc
7914 0 : LIBPAW_ALLOCATE(den,(n))
7915 0 : LIBPAW_ALLOCATE(a,(n))
7916 0 : IF (besselshapefunction) THEN
7917 0 : CALL shapebes(al,ql,l,PAW%rc_shap)
7918 0 : DO i=1,PAW%irc_shap
7919 0 : qr=ql(1)*r(i);CALL jbessel(jbes1,dum1,dum2,l,0,qr)
7920 0 : qr=ql(2)*r(i);CALL jbessel(jbes2,dum1,dum2,l,0,qr)
7921 0 : den(i)=(al(1)*jbes1+al(2)*jbes2)*r(i)**2
7922 : ENDDO
7923 0 : IF (n>PAW%irc_shap) den(PAW%irc_shap+1:n)=0._dp
7924 : ELSE
7925 0 : DO i=1,n
7926 0 : den(i)=(r(i)**l)*PAW%hatden(i)
7927 : ENDDO
7928 0 : a(1:n)=den(1:n)*(r(1:n)**l)
7929 0 : con=integrator(Grid,a,1,PAW%irc_shap)
7930 0 : den=den/con
7931 : ENDIF
7932 0 : dhat=zero
7933 0 : dhat(1:n)=den(1:n)
7934 0 : LIBPAW_DEALLOCATE(den)
7935 0 : LIBPAW_DEALLOCATE(a)
7936 0 : END SUBROUTINE hatL
7937 :
7938 :
7939 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7940 : !! SUBROUTINE FillHat(Grid,PAW)
7941 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7942 0 : SUBROUTINE FillHat(Grid,PAW,besselshape)
7943 : logical,intent(in) :: besselshape
7944 : TYPE(GridInfo) , INTENT(IN):: Grid
7945 : TYPE(PseudoInfo), INTENT(INOUT) :: PAW
7946 : INTEGER :: ll,n,l
7947 0 : ll=MAXVAL(PAW%TOCCWFN%l(:)); ll=MAX(ll,PAW%lmax); ll=2*ll
7948 0 : n=Grid%n
7949 0 : LIBPAW_ALLOCATE(PAW%g,(n,ll+1))
7950 0 : DO l=0,ll
7951 0 : CALL hatL(Grid,PAW,l,PAW%g(:,l+1),besselshape)
7952 : ENDDO
7953 0 : END SUBROUTINE FillHat
7954 :
7955 :
7956 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7957 : ! SUBROUTINE altdtij
7958 : ! on input: f1(i) and f2(i) are radial wfn * r for angular momentum l
7959 : ! on input: t1(i) and t2(i) are smooth radial wfn * r for angular momentum l
7960 : ! for r > rc, f1=t1, f2=t2
7961 : ! on output: tij is difference kinetic energy matrix element in Rydberg units
7962 : ! tij =<f1|T|f2>-<t1|T|t2>
7963 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7964 12 : SUBROUTINE altdtij(Grid,PAW,ib,ic,tij,needvtau)
7965 : logical, intent(in) :: needvtau
7966 : TYPE(GridInfo), INTENT(IN) :: Grid
7967 : TYPE(PseudoInfo), INTENT(IN) :: PAW
7968 : INTEGER, INTENT(IN) :: ib,ic
7969 : REAL(dp), INTENT(OUT) :: tij
7970 : INTEGER :: n,i,l,irc
7971 : REAL(dp) :: angm
7972 12 : REAL(dp), POINTER :: r(:)
7973 12 : REAL(dp), ALLOCATABLE :: dum(:),tdel1(:),tdel2(:),aux(:),auxp(:)
7974 12 : tij=0
7975 12 : IF (PAW%l(ib)/=PAW%l(ic)) RETURN
7976 12 : n=Grid%n; r=>Grid%r; l=PAW%l(ib); irc=PAW%irc
7977 36 : LIBPAW_ALLOCATE(dum,(n))
7978 24 : LIBPAW_ALLOCATE(tdel1,(n))
7979 24 : LIBPAW_ALLOCATE(tdel2,(n))
7980 24 : LIBPAW_ALLOCATE(aux,(n))
7981 24 : LIBPAW_ALLOCATE(auxp,(n))
7982 24024 : dum=zero
7983 17100 : DO i=2,irc
7984 17100 : dum(i)=PAW%ophi(i,ib)*PAW%Kop(i,ic) !Corrected 6/6/2023 Thanks to MT
7985 : ENDDO
7986 12 : CALL derivative(Grid,PAW%otphi(:,ic),tdel1)
7987 12 : CALL derivative(Grid,tdel1,tdel2)
7988 48036 : aux=1.0_dp;auxp=0.0_dp
7989 12 : if(needvtau) then
7990 0 : aux=1._dp+PAW%tvtau
7991 0 : call derivative(Grid,PAW%tvtau,auxp)
7992 : endif
7993 12 : angm=l*(l+1)
7994 17100 : DO i=2,irc
7995 : dum(i)=dum(i)+PAW%otphi(i,ib)*(aux(i)*(tdel2(i)-&
7996 : & angm*PAW%otphi(i,ic)/(Grid%r(i)**2))+auxp(i)*&
7997 17100 : & (tdel1(i)-PAW%otphi(i,ic)/Grid%r(i)))
7998 : ENDDO
7999 12 : tij=integrator(Grid,dum,1,irc)
8000 12 : LIBPAW_DEALLOCATE(dum)
8001 12 : LIBPAW_DEALLOCATE(tdel1)
8002 12 : LIBPAW_DEALLOCATE(tdel2)
8003 12 : LIBPAW_DEALLOCATE(aux)
8004 12 : LIBPAW_DEALLOCATE(auxp)
8005 12 : END SUBROUTINE altdtij
8006 :
8007 :
8008 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8009 : !! SUBROUTINE besselps(Grid,Pot,PAW)
8010 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8011 0 : SUBROUTINE besselps(Grid,Pot,PAW)
8012 : TYPE(Gridinfo), INTENT(IN) :: Grid
8013 : TYPE(Potentialinfo), INTENT(IN) :: Pot
8014 : TYPE(Pseudoinfo), INTENT(INOUT) :: PAW
8015 : INTEGER :: i,irc,n
8016 : real(dp) :: rc,alpha,beta,vv,vvp,AA,QQ,xx(1)
8017 0 : real(dp),POINTER :: r(:),rv(:)
8018 0 : n=Grid%n
8019 0 : r=>Grid%r
8020 0 : rv=>Pot%rv
8021 0 : irc=PAW%irc_vloc
8022 0 : rc=PAW%rc_vloc
8023 0 : vv=rv(irc);vvp=Gfirstderiv(Grid,irc,rv)
8024 0 : alpha=1.D0-rc*vvp/vv;beta=1.D0
8025 0 : call solvbes(xx,alpha,beta,0,1);QQ=xx(1)
8026 0 : AA=vv/sin(QQ);QQ=QQ/rc
8027 0 : PAW%rveff(1)=0._dp
8028 0 : PAW%rveff(irc+1:n)=rv(irc+1:n)
8029 0 : do i=2,irc
8030 0 : PAW%rveff(i)=AA*sin(QQ*r(i))
8031 : enddo
8032 0 : END SUBROUTINE besselps
8033 :
8034 :
8035 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8036 : !! SUBROUTINE EvaluateTp
8037 : !! Inverts 5x5 matrix used by troullier subroutine
8038 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8039 971 : SUBROUTINE EvaluateTp(l,A,B,C,D,F,coef)
8040 : INTEGER, INTENT(IN) :: l
8041 : real(dp), INTENT(IN) :: A,B,C,D,F
8042 : real(dp), INTENT(OUT) :: coef(6)
8043 : real(dp) :: t(6,6),coef10,old
8044 : real(dp), PARAMETER :: small=1.e-10
8045 : INTEGER :: i,n,iter
8046 : INTEGER, PARAMETER :: niter=1000
8047 971 : old=-1.e30; Coef10=-1; iter=-1
8048 4891 : DO WHILE (iter < niter .AND. ABS(old-coef10)> small)
8049 3920 : iter=iter+1
8050 3920 : t=0
8051 3920 : Coef(1)=A-Coef10; Coef(2)=B-2*Coef10; Coef(3)=C-2*Coef10;
8052 3920 : Coef(4)=D; Coef(5)=F
8053 3920 : Coef(6)=-Coef10**2
8054 27440 : DO i=1,6
8055 23520 : t(1,i)=1
8056 23520 : t(2,i)=2*i
8057 23520 : t(3,i)=2*i*(2*i-1)
8058 23520 : t(4,i)=2*i*(2*i-1)*(2*i-2)
8059 27440 : t(5,i)=2*i*(2*i-1)*(2*i-2)*(2*i-3)
8060 : ENDDO
8061 3920 : t(6,1)=2*Coef10; t(6,2)=2*l+5
8062 3920 : n=6
8063 3920 : CALL linsol(t,Coef,n,6,6,6)
8064 3920 : old=Coef10; Coef10=Coef10+Coef(1)
8065 4891 : Coef(1)=Coef10
8066 : ENDDO
8067 971 : IF (iter >= niter) THEN
8068 0 : LIBPAW_ERROR('Error in EvaluateTP -- no convergence')
8069 : ENDIF
8070 971 : END SUBROUTINE EvaluateTp
8071 :
8072 :
8073 :
8074 :
8075 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8076 : ! 12. Pseudo_data
8077 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8078 :
8079 :
8080 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8081 : !! SUBROUTINE InitPAW(PAW,Grid,Orbit)
8082 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8083 4 : SUBROUTINE InitPAW(PAW,Grid,Orbit)
8084 : TYPE(GridInfo), INTENT(IN) :: Grid
8085 : TYPE(OrbitInfo), INTENT(IN) :: Orbit
8086 : Type(PseudoInfo), INTENT(INOUT) :: PAW
8087 : INTEGER :: io,l,n,mxbase,nbase
8088 : !Initialize logical variables
8089 4 : PAW%multi_rc=.false.
8090 4 : PAW%poscorenhat=.true.
8091 4 : CALL DestroyPAW(PAW)
8092 : !Compute initial size of basis
8093 4 : n=Grid%n
8094 4 : nbase=0
8095 18 : DO l=0,PAW%lmax
8096 109 : DO io=1,Orbit%norbit ! cycle through all configurations
8097 105 : IF (Orbit%l(io).EQ.l.AND.(.NOT.Orbit%iscore(io))) THEN
8098 14 : nbase=nbase+1
8099 : ENDIF
8100 : ENDDO
8101 : ENDDO
8102 4 : PAW%mxbase=nbase+6*max(1,PAW%lmax)
8103 4 : mxbase=PAW%mxbase !Estimate excess
8104 4 : PAW%nbase=nbase
8105 4 : if(has_to_print) WRITE(STD_OUT,*) 'Found ', nbase,' valence basis functions '
8106 4 : if(has_to_print) WRITE(STD_OUT,*) 'Allocating for ', mxbase, ' total basis functions'
8107 12 : LIBPAW_POINTER_ALLOCATE(PAW%projshape,(n))
8108 8 : LIBPAW_POINTER_ALLOCATE(PAW%hatden,(n))
8109 8 : LIBPAW_POINTER_ALLOCATE(PAW%hatpot,(n))
8110 8 : LIBPAW_POINTER_ALLOCATE(PAW%hatshape,(n))
8111 8 : LIBPAW_POINTER_ALLOCATE(PAW%vloc,(n))
8112 8 : LIBPAW_POINTER_ALLOCATE(PAW%rveff,(n))
8113 8 : LIBPAW_POINTER_ALLOCATE(PAW%abinitvloc,(n))
8114 8 : LIBPAW_POINTER_ALLOCATE(PAW%abinitnohat,(n))
8115 8 : LIBPAW_POINTER_ALLOCATE(PAW%AErefrv,(n))
8116 8 : LIBPAW_POINTER_ALLOCATE(PAW%rvx,(n))
8117 8 : LIBPAW_POINTER_ALLOCATE(PAW%trvx,(n))
8118 8 : LIBPAW_POINTER_ALLOCATE(PAW%den,(n))
8119 8 : LIBPAW_POINTER_ALLOCATE(PAW%tden,(n))
8120 8 : LIBPAW_POINTER_ALLOCATE(PAW%core,(n))
8121 8 : LIBPAW_POINTER_ALLOCATE(PAW%tcore,(n))
8122 8 : LIBPAW_POINTER_ALLOCATE(PAW%coretau,(n))
8123 8 : LIBPAW_POINTER_ALLOCATE(PAW%tcoretau,(n))
8124 8 : LIBPAW_POINTER_ALLOCATE(PAW%valetau,(n))
8125 8 : LIBPAW_POINTER_ALLOCATE(PAW%tvaletau,(n))
8126 8 : LIBPAW_POINTER_ALLOCATE(PAW%vtau,(n))
8127 8 : LIBPAW_POINTER_ALLOCATE(PAW%tvtau,(n))
8128 8 : LIBPAW_POINTER_ALLOCATE(PAW%nhatv,(n))
8129 8 : LIBPAW_POINTER_ALLOCATE(PAW%Ktvtau,(n))
8130 8 : LIBPAW_POINTER_ALLOCATE(PAW%Krveff,(n))
8131 8 : LIBPAW_POINTER_ALLOCATE(PAW%Kunscreen,(n))
8132 24016 : PAW%projshape=0._dp;PAW%hatden=0._dp;PAW%hatpot=0._dp
8133 24016 : PAW%hatshape=0._dp;PAW%vloc=0._dp;PAW%rveff=0._dp
8134 16012 : PAW%abinitvloc=0._dp;PAW%abinitnohat=0._dp
8135 24016 : PAW%AErefrv=0._dp;PAW%rvx=0._dp;PAW%trvx=0._dp
8136 32020 : PAW%den=0._dp;PAW%tden=0._dp;PAW%core=0._dp;PAW%tcore=0._dp
8137 8008 : PAW%XCORECORE=0._dp;PAW%nhatv=0._dp
8138 16012 : PAW%coretau=0._dp;PAW%tcoretau=0._dp
8139 16012 : PAW%valetau=0._dp;PAW%tvaletau=0._dp
8140 16012 : PAW%vtau=0._dp;PAW%tvtau=0._dp
8141 24016 : PAW%Ktvtau=0._dp;PAW%Krveff=0._dp;PAW%Kunscreen=0._dp
8142 16 : LIBPAW_POINTER_ALLOCATE(PAW%phi,(n,mxbase))
8143 12 : LIBPAW_POINTER_ALLOCATE(PAW%tphi,(n,mxbase))
8144 12 : LIBPAW_POINTER_ALLOCATE(PAW%tp,(n,mxbase))
8145 12 : LIBPAW_POINTER_ALLOCATE(PAW%ophi,(n,mxbase))
8146 12 : LIBPAW_POINTER_ALLOCATE(PAW%otphi,(n,mxbase))
8147 12 : LIBPAW_POINTER_ALLOCATE(PAW%otp,(n,mxbase))
8148 12 : LIBPAW_POINTER_ALLOCATE(PAW%np,(mxbase))
8149 8 : LIBPAW_POINTER_ALLOCATE(PAW%l,(mxbase))
8150 12 : LIBPAW_POINTER_ALLOCATE(PAW%eig,(mxbase))
8151 8 : LIBPAW_POINTER_ALLOCATE(PAW%occ,(mxbase))
8152 8 : LIBPAW_POINTER_ALLOCATE(PAW%ck,(mxbase))
8153 8 : LIBPAW_POINTER_ALLOCATE(PAW%vrc,(mxbase))
8154 12 : LIBPAW_POINTER_ALLOCATE(PAW%Kop,(n,mxbase))
8155 8 : LIBPAW_POINTER_ALLOCATE(PAW%rng,(mxbase))
8156 8 : LIBPAW_POINTER_ALLOCATE(PAW%rcio,(mxbase))
8157 8 : LIBPAW_POINTER_ALLOCATE(PAW%nodes,(mxbase))
8158 444448 : PAW%phi=0._dp;PAW%tphi=0._dp;PAW%tp=0._dp
8159 444448 : PAW%ophi=0._dp;PAW%otphi=0._dp;PAW%otp=0._dp
8160 148448 : PAW%eig=0._dp;PAW%occ=0._dp;PAW%vrc=0._dp;PAW%ck=0._dp;PAW%Kop=0._dp
8161 226 : PAW%rcio=0._dp;PAW%np=0;PAW%l=0
8162 4 : if(Orbit%diracrelativistic) then
8163 2 : LIBPAW_POINTER_ALLOCATE(PAW%kappa,(mxbase))
8164 19 : PAW%kappa=0
8165 : endif
8166 78 : PAW%rng=Grid%n
8167 16 : LIBPAW_POINTER_ALLOCATE(PAW%oij,(mxbase,mxbase))
8168 12 : LIBPAW_POINTER_ALLOCATE(PAW%dij,(mxbase,mxbase))
8169 12 : LIBPAW_POINTER_ALLOCATE(PAW%wij,(mxbase,mxbase))
8170 4366 : PAW%oij=0._dp;PAW%dij=0._dp;PAW%wij=0._dp
8171 8 : LIBPAW_POINTER_ALLOCATE(PAW%rVf,(n))
8172 8 : LIBPAW_POINTER_ALLOCATE(PAW%rtVf,(n))
8173 12 : LIBPAW_POINTER_ALLOCATE(PAW%Kij,(mxbase,mxbase))
8174 12 : LIBPAW_POINTER_ALLOCATE(PAW%Vfij,(mxbase,mxbase))
8175 18920 : PAW%rVf=0._dp;PAW%rtVf=0._dp;PAW%Kij=0._dp;PAW%Vfij=0._dp
8176 4 : IF (Orbit%exctype=='HF') THEN
8177 0 : LIBPAW_POINTER_ALLOCATE(PAW%lmbd,(Orbit%norbit,mxbase))
8178 0 : PAW%lmbd=0._dp
8179 : ELSE
8180 4 : nullify(PAW%lmbd)
8181 : ENDIF
8182 12 : LIBPAW_POINTER_ALLOCATE(PAW%valencemap,(Orbit%norbit))
8183 4 : LIBPAW_DATATYPE_ALLOCATE(PAW%OCCwfn,)
8184 4 : LIBPAW_DATATYPE_ALLOCATE(PAW%TOCCwfn,)
8185 4 : END SUBROUTINE InitPAW
8186 :
8187 :
8188 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8189 : !! Subroutine DestroyPAW(PAW)
8190 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8191 8 : Subroutine DestroyPAW(PAW)
8192 : Type(PseudoInfo), INTENT(INOUT) :: PAW
8193 8 : IF(associated(PAW%Ktvtau)) then
8194 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Ktvtau)
8195 : endif
8196 8 : IF(associated(PAW%Krveff)) then
8197 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Krveff)
8198 : endif
8199 8 : if(associated(PAW%Kunscreen)) then
8200 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Kunscreen)
8201 : endif
8202 8 : IF (ASSOCIATED(PAW%rcio)) then
8203 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rcio)
8204 : endif
8205 8 : If (ASSOCIATED(PAW%vloc)) then
8206 4 : LIBPAW_POINTER_DEALLOCATE(PAW%vloc)
8207 : endif
8208 8 : If (ASSOCIATED(PAW%abinitvloc)) then
8209 4 : LIBPAW_POINTER_DEALLOCATE(PAW%abinitvloc)
8210 : endif
8211 8 : If (ASSOCIATED(PAW%abinitnohat)) then
8212 4 : LIBPAW_POINTER_DEALLOCATE(PAW%abinitnohat)
8213 : endif
8214 8 : If (ASSOCIATED(PAW%rveff)) then
8215 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rveff)
8216 : endif
8217 8 : If (ASSOCIATED(PAW%AErefrv)) then
8218 4 : LIBPAW_POINTER_DEALLOCATE(PAW%AErefrv)
8219 : endif
8220 8 : If (ASSOCIATED(PAW%rvx)) then
8221 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rvx)
8222 : endif
8223 8 : If (ASSOCIATED(PAW%trvx)) then
8224 4 : LIBPAW_POINTER_DEALLOCATE(PAW%trvx)
8225 : endif
8226 8 : If (ASSOCIATED(PAW%projshape)) then
8227 4 : LIBPAW_POINTER_DEALLOCATE(PAW%projshape)
8228 : endif
8229 8 : If (ASSOCIATED(PAW%hatshape)) then
8230 4 : LIBPAW_POINTER_DEALLOCATE(PAW%hatshape)
8231 : endif
8232 8 : If (ASSOCIATED(PAW%hatden)) then
8233 4 : LIBPAW_POINTER_DEALLOCATE(PAW%hatden)
8234 : endif
8235 8 : If (ASSOCIATED(PAW%hatpot)) then
8236 4 : LIBPAW_POINTER_DEALLOCATE(PAW%hatpot)
8237 : endif
8238 8 : If (ASSOCIATED(PAW%den)) then
8239 4 : LIBPAW_POINTER_DEALLOCATE(PAW%den)
8240 : endif
8241 8 : If (ASSOCIATED(PAW%tden)) then
8242 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tden)
8243 : endif
8244 8 : If (ASSOCIATED(PAW%core)) then
8245 4 : LIBPAW_POINTER_DEALLOCATE(PAW%core)
8246 : endif
8247 8 : If (ASSOCIATED(PAW%tcore)) then
8248 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tcore)
8249 : endif
8250 8 : If (ASSOCIATED(PAW%coretau)) then
8251 4 : LIBPAW_POINTER_DEALLOCATE(PAW%coretau)
8252 : endif
8253 8 : If (ASSOCIATED(PAW%tcoretau)) then
8254 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tcoretau)
8255 : endif
8256 8 : If (ASSOCIATED(PAW%valetau)) then
8257 4 : LIBPAW_POINTER_DEALLOCATE(PAW%valetau)
8258 : endif
8259 8 : If (ASSOCIATED(PAW%tvaletau)) then
8260 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tvaletau)
8261 : endif
8262 8 : If (ASSOCIATED(PAW%vtau)) then
8263 4 : LIBPAW_POINTER_DEALLOCATE(PAW%vtau)
8264 : endif
8265 8 : If (ASSOCIATED(PAW%tvtau)) then
8266 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tvtau)
8267 : endif
8268 8 : If (ASSOCIATED(PAW%nhatv)) then
8269 4 : LIBPAW_POINTER_DEALLOCATE(PAW%nhatv)
8270 : endif
8271 8 : If (ASSOCIATED(PAW%np)) then
8272 4 : LIBPAW_POINTER_DEALLOCATE(PAW%np)
8273 : endif
8274 8 : If (ASSOCIATED(PAW%l)) then
8275 4 : LIBPAW_POINTER_DEALLOCATE(PAW%l)
8276 : endif
8277 8 : If (ASSOCIATED(PAW%nodes)) then
8278 4 : LIBPAW_POINTER_DEALLOCATE(PAW%nodes)
8279 : endif
8280 8 : If (ASSOCIATED(PAW%kappa)) then
8281 1 : LIBPAW_POINTER_DEALLOCATE(PAW%kappa)
8282 : endif
8283 8 : If (ASSOCIATED(PAW%rng)) then
8284 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rng)
8285 : endif
8286 8 : If (ASSOCIATED(PAW%label)) then
8287 0 : LIBPAW_POINTER_DEALLOCATE(PAW%label)
8288 : endif
8289 8 : If (ASSOCIATED(PAW%phi)) then
8290 4 : LIBPAW_POINTER_DEALLOCATE(PAW%phi)
8291 : endif
8292 8 : If (ASSOCIATED(PAW%tphi)) then
8293 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tphi)
8294 : endif
8295 8 : If (ASSOCIATED(PAW%tp)) then
8296 4 : LIBPAW_POINTER_DEALLOCATE(PAW%tp)
8297 : endif
8298 8 : If (ASSOCIATED(PAW%ophi)) then
8299 4 : LIBPAW_POINTER_DEALLOCATE(PAW%ophi)
8300 : endif
8301 8 : If (ASSOCIATED(PAW%otphi)) then
8302 4 : LIBPAW_POINTER_DEALLOCATE(PAW%otphi)
8303 : endif
8304 8 : If (ASSOCIATED(PAW%otp)) then
8305 4 : LIBPAW_POINTER_DEALLOCATE(PAW%otp)
8306 : endif
8307 8 : If (ASSOCIATED(PAW%Kop)) then
8308 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Kop)
8309 : endif
8310 8 : If (ASSOCIATED(PAW%eig)) then
8311 4 : LIBPAW_POINTER_DEALLOCATE(PAW%eig)
8312 : endif
8313 8 : If (ASSOCIATED(PAW%occ)) then
8314 4 : LIBPAW_POINTER_DEALLOCATE(PAW%occ)
8315 : endif
8316 8 : If (ASSOCIATED(PAW%ck)) then
8317 4 : LIBPAW_POINTER_DEALLOCATE(PAW%ck)
8318 : endif
8319 8 : If (ASSOCIATED(PAW%vrc)) then
8320 4 : LIBPAW_POINTER_DEALLOCATE(PAW%vrc)
8321 : endif
8322 8 : If (ASSOCIATED(PAW%oij)) then
8323 4 : LIBPAW_POINTER_DEALLOCATE(PAW%oij)
8324 : endif
8325 8 : If (ASSOCIATED(PAW%dij)) then
8326 4 : LIBPAW_POINTER_DEALLOCATE(PAW%dij)
8327 : endif
8328 8 : If (ASSOCIATED(PAW%wij)) then
8329 4 : LIBPAW_POINTER_DEALLOCATE(PAW%wij)
8330 : endif
8331 8 : If (ASSOCIATED(PAW%rVf)) then
8332 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rVf)
8333 : endif
8334 8 : If (ASSOCIATED(PAW%rtVf)) then
8335 4 : LIBPAW_POINTER_DEALLOCATE(PAW%rtVf)
8336 : endif
8337 8 : If (ASSOCIATED(PAW%g)) then
8338 0 : LIBPAW_POINTER_DEALLOCATE(PAW%g)
8339 : endif
8340 8 : If (ASSOCIATED(PAW%Kij)) then
8341 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Kij)
8342 : endif
8343 8 : If (ASSOCIATED(PAW%Vfij)) then
8344 4 : LIBPAW_POINTER_DEALLOCATE(PAW%Vfij)
8345 : endif
8346 8 : If (ASSOCIATED(PAW%mLij)) then
8347 0 : LIBPAW_POINTER_DEALLOCATE(PAW%mLij)
8348 : endif
8349 8 : If (ASSOCIATED(PAW%DR)) then
8350 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DR)
8351 : endif
8352 8 : If (ASSOCIATED(PAW%DRVC)) then
8353 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRVC)
8354 : endif
8355 8 : If (ASSOCIATED(PAW%TXVC)) then
8356 0 : LIBPAW_POINTER_DEALLOCATE(PAW%TXVC)
8357 : endif
8358 8 : If (ASSOCIATED(PAW%valencemap)) then
8359 4 : LIBPAW_POINTER_DEALLOCATE(PAW%valencemap)
8360 : endif
8361 8 : If (ASSOCIATED(PAW%lmbd)) then
8362 0 : LIBPAW_POINTER_DEALLOCATE(PAW%lmbd)
8363 : endif
8364 8 : If (ASSOCIATED(PAW%DRC)) then
8365 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRC)
8366 : endif
8367 8 : If (ASSOCIATED(PAW%DRCC)) then
8368 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRCC)
8369 : endif
8370 8 : If (ASSOCIATED(PAW%DRCjkl)) then
8371 0 : LIBPAW_POINTER_DEALLOCATE(PAW%DRCjkl)
8372 : endif
8373 8 : If (ASSOCIATED(PAW%mLic)) then
8374 0 : LIBPAW_POINTER_DEALLOCATE(PAW%mLic)
8375 : endif
8376 8 : If (ASSOCIATED(PAW%mLcc)) then
8377 0 : LIBPAW_POINTER_DEALLOCATE(PAW%mLcc)
8378 : endif
8379 8 : If (ASSOCIATED(PAW%Dcj)) then
8380 0 : LIBPAW_POINTER_DEALLOCATE(PAW%Dcj)
8381 : endif
8382 8 : If (ASSOCIATED(PAW%OCCwfn)) then
8383 4 : call DestroyOrbit(PAW%OCCwfn)
8384 4 : LIBPAW_DATATYPE_DEALLOCATE(PAW%OCCwfn)
8385 : end if
8386 8 : If (ASSOCIATED(PAW%TOCCwfn)) then
8387 4 : call DestroyOrbit(PAW%TOCCwfn)
8388 4 : LIBPAW_DATATYPE_DEALLOCATE(PAW%TOCCwfn)
8389 : end if
8390 8 : End Subroutine DestroyPAW
8391 :
8392 :
8393 :
8394 :
8395 :
8396 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8397 : ! 13. Numerov
8398 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8399 :
8400 :
8401 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8402 : !! SUBROUTINE BoundNumerov(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,BDsolve,success)
8403 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8404 446 : SUBROUTINE BoundNumerov(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,BDsolve,success)
8405 : TYPE(GridInfo), INTENT(IN) :: Grid
8406 : real(dp), INTENT(IN) :: rv(:),v0,v0p
8407 : INTEGER, INTENT(IN) :: nz,l,nroot
8408 : real(dp), INTENT(INOUT) :: Eig(:), Psi(:,:)
8409 : LOGICAL, INTENT(IN) :: BDsolve
8410 : LOGICAL, INTENT(INOUT) :: success
8411 : INTEGER, PARAMETER :: repeat=4
8412 : INTEGER :: j
8413 : ! TODO : BDsolve
8414 446 : if(BDsolve) then
8415 0 : STOP
8416 : endif
8417 446 : if(has_to_print) write(std_out,*) 'Before newboundsch',l,nroot, Eig(1:nroot)
8418 446 : CALL newboundsch(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,success)
8419 446 : if(has_to_print) write(std_out,*) 'After newboundsch',l,nroot, Eig(1:nroot)
8420 : ! adjust sign
8421 1231 : Do j=1,nroot
8422 549779 : if (Psi(3,j)<0._dp) Psi(:,j)=-Psi(:,j)
8423 : Enddo
8424 446 : END SUBROUTINE BoundNumerov
8425 :
8426 :
8427 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8428 : !! SUBROUTINE newboundsch(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,ok)
8429 : !! pgm to solve radial schroedinger equation for nroot bound state
8430 : !! energies and wavefunctions for angular momentum l
8431 : !! with potential rv/r
8432 : !!
8433 : !! Assymptotic from of wfn:
8434 : !! Psi(r) = const*(r**q/kappa)*EXP(-kappa*r), where eig=-kappa**2
8435 : !! uses Noumerov algorithm
8436 : !!
8437 : !! For l=0,1 corrections are needed to approximate wfn(r=0)
8438 : !! These depend upon:
8439 : !! e0 (current guess of energy eigenvalue)
8440 : !! l,nz
8441 : !! v(0) == v0 electronic potential at r=0
8442 : !! v'(0) == v0p derivative of electronic potential at r=0
8443 : !!
8444 : !! Corrections are also needed for r>n*h, depending on:
8445 : !! e0 (current guess of energy eigenvalue
8446 : !! the extrapolated value of rv == r * v
8447 : !!
8448 : !! ierr=an nroot digit number indicating status of each root
8449 : !! a digit of 1 indicates success in converging root
8450 : !! 2 indicates near success in converging root
8451 : !! 9 indicates that root not found
8452 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8453 446 : SUBROUTINE newboundsch(Grid,rv,v0,v0p,nz,l,nroot,Eig,Psi,ok)
8454 : TYPE(GridInfo), INTENT(IN) :: Grid
8455 : real(dp), INTENT(IN) :: rv(:),v0,v0p
8456 : INTEGER, INTENT(IN) :: nz,l,nroot
8457 : real(dp), INTENT(INOUT) :: Eig(:), Psi(:,:)
8458 : LOGICAL, INTENT(OUT) :: ok
8459 : real(dp), PARAMETER :: convre=tol10,vlrg=10._dp**30
8460 : INTEGER, PARAMETER :: niter=300
8461 446 : real(dp), ALLOCATABLE :: p1(:),p2(:),dd(:)
8462 : INTEGER :: n,ierr
8463 : real(dp) :: h,qq
8464 : real(dp) :: err,convrez,energy,zeroval,zz
8465 : real(dp) :: scale,emin,emax,best,rout,ppp
8466 : real(dp) :: rin,dele,x
8467 : INTEGER :: iter,i,j,node,match,ir,iroot
8468 : INTEGER :: ifac
8469 446 : ifac=0
8470 446 : n=Grid%n
8471 446 : h=Grid%h
8472 1338 : LIBPAW_ALLOCATE(p1,(n))
8473 892 : LIBPAW_ALLOCATE(p2,(n))
8474 892 : LIBPAW_ALLOCATE(dd,(n))
8475 446 : zz=nz
8476 : qq=-rv(n)/2
8477 : IF (qq<0.001_dp) qq=0._dp
8478 446 : qq=zero
8479 446 : err=n*nz*(h**4); if (err<tol6) err=tol6
8480 446 : convrez=convre
8481 446 : IF (nz.GT.0) convrez=convre*nz
8482 446 : ierr=0
8483 446 : emin=(-REAL((nz)**2)/(l+1)**2-0.5_dp)
8484 446 : emax=0._dp
8485 1231 : DO iroot=1,nroot
8486 785 : best=1.d10; dele=1.d10
8487 785 : energy=Eig(iroot)
8488 785 : IF (energy.LT.emin) energy=emin
8489 785 : IF (energy.GT.emax) energy=emax
8490 785 : ok=.FALSE.
8491 5138 : BigIter: DO iter=1,niter
8492 : ! start inward integration
8493 : ! start integration at n
8494 : ! find classical turning point
8495 5131 : CALL ClassicalTurningPoint(Grid,rv,l,energy,match)
8496 5131 : match=MAX(5,match)
8497 5131 : match=MIN(n-15,match)
8498 5131 : ppp=SQRT(ABS(-energy))
8499 10272262 : p2=0
8500 5131 : p2(n)=wfnend(l,energy,Grid%r(n),Grid%r(n),qq)
8501 5131 : p2(n-1)=wfnend(l,energy,Grid%r(n-1),Grid%r(n),qq)
8502 5131 : CALL backward_numerov(Grid,l,match,energy,rv,p2)
8503 5131 : match=match+6
8504 5131 : CALL derivative(Grid,p2,dd,match-5,match+5)
8505 5131 : rin=dd(match)/p2(match)
8506 : ! start outward integration
8507 : ! correct behavior near r=0
8508 : ! initialize p1
8509 10272262 : p1=0
8510 5131 : p1(2)=wfninit(-0.5_dp*rv(1),l,v0,v0p,energy,Grid%r(2))
8511 5131 : zeroval=0
8512 5131 : IF (l==0) zeroval=rv(1)
8513 5131 : IF (l==1) zeroval=2
8514 5131 : CALL forward_numerov(Grid,l,match+6,energy,rv,zeroval,p1,node)
8515 5131 : CALL derivative(Grid,p1,dd,match-5,match+5)
8516 5131 : rout=dd(match)/p1(match)
8517 : ! check whether node = (iroot-1)
8518 : ! not enough nodes -- raise energy
8519 5138 : IF (node.LT.iroot-1) THEN
8520 122 : emin=MAX(emin,energy)-tol5
8521 122 : energy=emax-(emax-energy)*ranx()
8522 122 : ifac=9
8523 : ! too many nodes -- lower energy
8524 5009 : ELSEIF (node.GT.iroot-1) THEN
8525 111 : IF (energy.LT.emin) THEN
8526 0 : ierr=ierr+9*(10**(iroot-1))
8527 0 : if(has_to_print) WRITE(STD_OUT,*) 'newboundsch error -- emin too high',l,nz,emin,energy
8528 : RETURN
8529 : ENDIF
8530 111 : emax=MIN(emax,energy+tol5)
8531 111 : energy=emin+(energy-emin)*ranx()
8532 : ! correct number of nodes -- estimate correction
8533 4898 : ELSEIF (node.EQ.iroot-1) THEN
8534 6216179 : DO j=1,match
8535 6216179 : p1(j)=p1(j)/p1(match)
8536 : ENDDO
8537 3599413 : DO j=match,n
8538 3599413 : p1(j)=p2(j)/p2(match)
8539 : ENDDO
8540 4898 : scale=1._dp/overlap(Grid,p1,p1)
8541 4898 : dele=(rout-rin)*scale
8542 4898 : x=ABS(dele)
8543 4898 : IF (x.LT.best) THEN
8544 2273 : scale=SQRT(scale)
8545 4550546 : p1(1:n)=p1(1:n)*scale
8546 4550546 : Psi(1:n,iroot)=p1(1:n)
8547 2273 : Eig(iroot)=energy
8548 2273 : best=x
8549 : ENDIF
8550 4898 : IF (ABS(dele).LE.convrez) THEN
8551 778 : if(has_to_print) WRITE(STD_OUT,*) 'converged iter with dele' , iter,dele
8552 778 : ok=.TRUE.
8553 : ! eigenvalue found
8554 778 : ierr=ierr+10**(iroot-1)
8555 778 : IF (iroot+1.LE.nroot) THEN
8556 339 : emin=energy+tol5
8557 339 : emax=0
8558 339 : energy=(emin+emax)/2
8559 339 : IF (energy.LT.emin) energy=emin
8560 339 : IF (energy.GT.emax) energy=emax
8561 339 : best=1.d10
8562 : ENDIF
8563 : EXIT BigIter
8564 : ENDIF
8565 4120 : IF (ABS(dele).GT.convrez) THEN
8566 4120 : energy=energy+dele
8567 : ! if energy is out of range, pick random energy in correct range
8568 4120 : IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) &
8569 2029 : & energy=emin+(emax-emin)*ranx()
8570 : ifac=2
8571 : ENDIF
8572 : ENDIF
8573 : ENDDO BigIter !iter
8574 1231 : IF (.NOT.ok) THEN
8575 7 : ierr=ierr+ifac*(10**(iroot-1))
8576 7 : if(has_to_print) WRITE(STD_OUT,*) 'no convergence in newboundsch',iroot,l,dele,energy
8577 7 : if(has_to_print) WRITE(STD_OUT,*) ' best guess of eig, dele = ',Eig(iroot),best
8578 7 : IF (iroot.LT.nroot) THEN
8579 0 : DO ir=iroot+1,nroot
8580 0 : ierr=ierr+9*(10**(ir-1))
8581 : ENDDO
8582 : ENDIF
8583 : ! reset wfn with hydrogenic form
8584 7 : j=iroot+l+1
8585 14014 : Psi(:,iroot)=0
8586 7 : ppp=(j)*SQRT(ABS(Eig(iroot)))
8587 14007 : DO i=2,n
8588 14007 : Psi(i,iroot)=hwfn(ppp,j,l,Grid%r(i))
8589 : ENDDO
8590 : ENDIF
8591 : ENDDO !iroot
8592 446 : if(has_to_print) WRITE(STD_OUT,'("finish boundsch with eigenvalues -- ",1p,20e15.7)') &
8593 0 : & Eig(1:nroot)
8594 446 : LIBPAW_DEALLOCATE(p1)
8595 446 : LIBPAW_DEALLOCATE(p2)
8596 446 : LIBPAW_DEALLOCATE(dd)
8597 446 : if(has_to_print) WRITE(STD_OUT,*) 'returning from newboundsch -- ierr=',ierr
8598 0 : END SUBROUTINE newboundsch
8599 :
8600 :
8601 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8602 : !! FUNCTION wfninit(nz,l,v0,v0p,energy,r)
8603 : !! returns the solution of the Schroedinger equation near r=0
8604 : !! using power series expansion
8605 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8606 5210 : FUNCTION wfninit(nz,l,v0,v0p,energy,r)
8607 : real(dp) :: wfninit
8608 : INTEGER, INTENT(IN) :: l
8609 : real(dp), INTENT(IN) :: nz,v0,v0p,energy,r
8610 : real(dp) :: c1,c2,c3
8611 5210 : c1=-REAL(nz)/(l+1._dp)
8612 5210 : c2=((v0-energy)-2*nz*c1)/(4*l+6._dp)
8613 5210 : c3=(v0p+(v0-energy)*c1-2*nz*c2)/(6*l+12._dp)
8614 5210 : wfninit=(r**(l+1))*(1+r*(c1+r*(c2+r*c3)))
8615 5210 : END FUNCTION wfninit
8616 :
8617 :
8618 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8619 : !! FUNCTION wfnend(l,energy,r,rN)
8620 : !!
8621 : !! Find asymptotic form of wavefunction
8622 : !! assuming equations has form
8623 : !! (- d^2 +l(l+1) -2q +b^2 )
8624 : !! ( --- ------ --- ) P(r) = 0
8625 : !! ( dr^2 r^2 r )
8626 : !! where b^2=-energy
8627 : !!
8628 : !! P(r) = exp(-b*(r-rN))*r^(q/b)(1+(l*(l+1)-q/b)*(q/b-1)/(2*b)/r + ...)
8629 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8630 10262 : FUNCTION wfnend(l,energy,r,rN,qq)
8631 : real(dp) :: wfnend
8632 : INTEGER, INTENT(IN) :: l
8633 : real(dp), INTENT(IN) :: energy,r,rN,qq
8634 : real(dp) :: qbb,b,wfn,cn,term,fac
8635 : INTEGER :: i
8636 : INTEGER, PARAMETER :: last=5
8637 10262 : IF (energy>=0._dp) THEN
8638 10262 : wfnend=zero
8639 : RETURN
8640 : ENDIF
8641 10262 : b=SQRT(-energy)
8642 10262 : qbb=qq/b
8643 10262 : cn=l*(l+1)
8644 10262 : fac=DDEXP(-b*(r-rN))*(r**qbb)
8645 10262 : term=1._dp; wfn=zero
8646 61572 : DO i=1,last
8647 51310 : wfn=wfn+term
8648 61572 : IF (i<last) THEN
8649 41048 : term=-term*((qbb-i+1)*(qbb-i)-cn)/(2*b*i)/r
8650 : ENDIF
8651 : ENDDO
8652 10262 : wfnend=fac*wfn
8653 10262 : END FUNCTION wfnend
8654 :
8655 :
8656 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8657 : !! subroutine unboundsch(Grid,rv,v0,v0p,nr,l,energy,wfn,nodes)
8658 : !! pgm to solve radial schroedinger equation for unbound states
8659 : !! at energy 'energy' and at angular momentum l
8660 : !!
8661 : !! with potential rv/r, given in uniform mesh of n points
8662 : !! r=i*h, i=1,...n-1 ;assuming p(r)=C*r**(l+1)*polynomial(r) for r==0;
8663 : !! p((n+1)*h)=0
8664 : !! nz=nuclear charge
8665 : !!
8666 : !! uses Noumerov algorithm
8667 : !!
8668 : !! For l=0,1 corrections are needed to approximate wfn(r=0)
8669 : !! These depend upon:
8670 : !! e0 (current guess of energy eigenvalue)
8671 : !! l,nz
8672 : !! v(0) == v0 electronic potential at r=0
8673 : !! v'(0) == v0p derivative of electronic potential at r=0
8674 : !!
8675 : !! also returns node == number of nodes for calculated state
8676 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8677 13 : SUBROUTINE unboundsch(Grid,rv,v0,v0p,nr,l,energy,wfn,nodes)
8678 : TYPE(GridInfo), INTENT(IN) :: Grid
8679 : real(dp), INTENT(IN) :: rv(:),v0,v0p
8680 : INTEGER, INTENT(IN) :: nr,l
8681 : real(dp), INTENT(IN) :: energy
8682 : real(dp), INTENT(INOUT) :: wfn(:)
8683 : INTEGER, INTENT(INOUT) :: nodes
8684 : INTEGER :: n
8685 : real(dp) :: zeroval,scale
8686 13 : n=Grid%n
8687 13 : IF (nr > n) THEN
8688 0 : LIBPAW_ERROR('Error in unboundsch -- nr > n')
8689 : ENDIF
8690 : ! initialize wfn
8691 25432 : wfn=0
8692 13 : wfn(2)=wfninit(-0.5_dp*rv(1),l,v0,v0p,energy,Grid%r(2))
8693 13 : zeroval=0
8694 13 : if (l==0) zeroval=rv(1)
8695 13 : if (l==1) zeroval=2
8696 13 : call forward_numerov(Grid,l,nr,energy,rv,zeroval,wfn,nodes)
8697 : ! normalize to unity within integration range
8698 13 : scale=1._dp/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr)
8699 13 : scale=SIGN(SQRT(scale),wfn(nr-2))
8700 19444 : wfn(1:nr)=wfn(1:nr)*scale
8701 13 : END SUBROUTINE unboundsch
8702 :
8703 :
8704 :
8705 :
8706 :
8707 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8708 : ! 14. tools_mod
8709 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8710 :
8711 :
8712 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8713 : !! SUBROUTINE extractword(wordindex,stringin,stringout)
8714 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8715 30 : SUBROUTINE extractword(wordindex,stringin,stringout)
8716 : INTEGER, INTENT(IN) :: wordindex
8717 : CHARACTER(*), INTENT(IN) :: stringin
8718 : CHARACTER(*), INTENT(OUT) :: stringout
8719 : INTEGER :: i,j,n,str,fin,icount
8720 30 : stringout=''
8721 30 : n=LEN(stringin)
8722 30 : i=INDEX(stringin,'!');IF (i==0) i=n
8723 30 : j=INDEX(stringin,'#');IF (j==0) j=n
8724 30 : n=MIN(i,j,n)
8725 30 : str=1;fin=n
8726 74 : DO icount=1,MAX(1,wordindex-1)
8727 58 : DO i=str,n
8728 58 : IF (stringin(i:i)/=' ') EXIT
8729 : ENDDO
8730 44 : str=i
8731 44 : IF (n>str) THEN
8732 152 : DO i=str+1,n
8733 152 : IF(stringin(i:i)==' ') EXIT
8734 : ENDDO
8735 : fin=i
8736 : ENDIF
8737 74 : IF (wordindex>2) THEN
8738 24 : IF (fin<n) THEN
8739 24 : str=fin+1
8740 : ELSE
8741 : EXIT
8742 : ENDIF
8743 : ENDIF
8744 : ENDDO
8745 30 : IF (wordindex>1) THEN
8746 20 : IF (fin>=n) RETURN
8747 1180 : DO i=fin+1,n
8748 1180 : IF (stringin(i:i)/=' ') EXIT
8749 : ENDDO
8750 20 : str=i
8751 20 : IF (n>str) THEN
8752 44 : DO i=str+1,n
8753 44 : IF(stringin(i:i)==' ') EXIT
8754 : ENDDO
8755 : fin=i
8756 : ENDIF
8757 : ENDIF
8758 30 : stringout=stringin(str:fin)
8759 30 : END SUBROUTINE extractword
8760 :
8761 :
8762 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8763 : !! SUBROUTINE UpperCase(str)
8764 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8765 20 : SUBROUTINE UpperCase(str)
8766 : CHARACTER(*), INTENT(INOUT) :: str
8767 : INTEGER :: i, j, k
8768 20 : j = LEN(Str)
8769 3972 : DO i=1, j
8770 3952 : k = IACHAR(str(i:i))
8771 3972 : IF ((k>96) .AND. (k<123)) str(i:i) = ACHAR(k-32)
8772 : END DO
8773 20 : RETURN
8774 : END SUBROUTINE UpperCase
8775 :
8776 :
8777 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8778 : !! FUNCTION checkline2(inputline,in1,in2)
8779 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8780 : LOGICAL FUNCTION checkline2(inputline,in1,in2)
8781 : CHARACTER(*), INTENT(IN) :: inputline
8782 : CHARACTER(*), INTENT(IN) :: in1,in2
8783 : INTEGER :: leninput,len1,len2
8784 : CHARACTER(120) :: inputline_u,in1_u,in2_u
8785 : inputline_u=trim(inputline) ; call UpperCase(inputline_u)
8786 : in1_u=trim(in1) ; call UpperCase(in1_u)
8787 : in2_u=trim(in2) ; call UpperCase(in2_u)
8788 : leninput=len(trim(inputline));len1=len(trim(in1));len2=len(trim(in2))
8789 : checkline2=.false.
8790 : if (leninput==len1) checkline2=(inputline_u(1:len1)==trim(in1))
8791 : if ((.not.checkline2).and.leninput==len2) checkline2=(inputline_u(1:len2)==trim(in2))
8792 : RETURN
8793 : END FUNCTION checkline2
8794 :
8795 :
8796 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8797 : ! eliminate_comment - Eliminate comment on the right of a line (! or #)
8798 : ! line - string to convert (output replaces input)
8799 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8800 169 : SUBROUTINE eliminate_comment(line)
8801 : CHARACTER(*), INTENT(INOUT) :: line
8802 : INTEGER :: i,i0
8803 169 : i0=-1 ; i=1
8804 29606 : DO WHILE (i0<0.AND.i<LEN(line))
8805 29437 : i=i+1
8806 29606 : IF (line(i:i)=="!".OR.line(i:i)=="#") i0=i
8807 : END DO
8808 169 : IF (i0 >1) line=line(1:i0-1)
8809 : IF (i0==1) line=""
8810 169 : END SUBROUTINE eliminate_comment
8811 :
8812 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8813 : !! stripchar - Eliminate blanks
8814 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8815 6 : FUNCTION stripchar(inputchar)
8816 : CHARACTER(20) :: stripchar
8817 : CHARACTER*(*), INTENT(IN) :: inputchar
8818 : INTEGER :: i,j,n
8819 6 : n=LEN(inputchar)
8820 126 : DO i=1,20
8821 126 : stripchar(i:i)=''
8822 : ENDDO
8823 : j=0
8824 72 : DO i=1,n
8825 72 : IF (inputchar(i:i) /= '') THEN
8826 48 : j=j+1
8827 48 : stripchar(j:j)=inputchar(i:i)
8828 : ENDIF
8829 : ENDDO
8830 6 : END FUNCTION stripchar
8831 :
8832 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8833 : !! mkname - Subroutine to take an integer (.le. 4 digits) and return it
8834 : !! in the form of a character string
8835 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8836 6 : SUBROUTINE mkname(i,stuff)
8837 : CHARACTER(4) stuff
8838 : INTEGER i,i1,i10,i100,i1000
8839 6 : stuff='?'
8840 6 : IF (i.GT.9999) i=MOD(i,10000)
8841 6 : i1000=i/1000
8842 6 : i100=(i-1000*i1000)/100
8843 6 : i10=(i-1000*i1000-100*i100)/10
8844 6 : i1=(i-1000*i1000-100*i100-10*i10)
8845 6 : IF (i.GE.1000) THEN
8846 0 : stuff=CHAR(i1000+48)//CHAR(i100+48)//CHAR(i10+48)//CHAR(i1+48)
8847 0 : RETURN
8848 : ENDIF
8849 6 : IF (i.GE.100) THEN
8850 0 : stuff=CHAR(i100+48)//CHAR(i10+48)//CHAR(i1+48)
8851 0 : RETURN
8852 : ENDIF
8853 6 : IF (i.GE.10) THEN
8854 0 : stuff=CHAR(i10+48)//CHAR(i1+48)
8855 0 : RETURN
8856 : ENDIF
8857 6 : IF (i.GE.0) stuff=CHAR(i1+48)
8858 : RETURN
8859 : END SUBROUTINE mkname
8860 :
8861 :
8862 :
8863 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8864 : ! 15. radialked
8865 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8866 :
8867 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8868 : ! subroutine unboundked(Grid,Pot,nr,l,energy,wfn,nodes)
8869 : ! pgm to solve radial kinetic energy derivative equations for unbound states
8870 : ! at energy 'energy' and at angular momentum l
8871 : ! with potential rv/r, given in uniform linear or log mesh of n points
8872 : ! assuming p(r)=C*r**(l+1)*polynomial(r) for r==0;
8873 : ! nz=nuclear chargedd
8874 : ! Does not use Noumerov algorithm -- but uses coupled first-order
8875 : ! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
8876 : ! also returns node == number of nodes for calculated state
8877 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8878 0 : SUBROUTINE unboundked(Grid,Pot,nr,l,energy,wfn,nodes)
8879 : TYPE(GridInfo), INTENT(IN) :: Grid
8880 : TYPE(PotentialInfo), INTENT(IN) :: Pot
8881 : INTEGER, INTENT(IN) :: nr,l
8882 : REAL(dp), INTENT(IN) :: energy
8883 : REAL(dp), INTENT(INOUT) :: wfn(:)
8884 : INTEGER, INTENT(INOUT) :: nodes
8885 : INTEGER :: n,istart
8886 0 : REAL(dp) :: oneplusvtau(Grid%n),dvtaudr(Grid%n)
8887 : REAL(dp) :: scale,qq,zxc
8888 0 : REAL(dp), allocatable :: lwfn(:),zz(:,:,:),yy(:,:)
8889 0 : n=Grid%n
8890 0 : IF (nr > n) THEN
8891 0 : write(std_out,*) 'Error in unboundked -- nr > n', nr,n
8892 0 : STOP
8893 : ENDIF
8894 0 : call Set_Pot(Grid,Pot,qq,zxc,oneplusvtau,dvtaudr)
8895 0 : LIBPAW_ALLOCATE(lwfn,(nr))
8896 0 : LIBPAW_ALLOCATE(zz,(2,2,nr))
8897 0 : LIBPAW_ALLOCATE(yy,(2,nr))
8898 0 : lwfn=0;zz=0;yy=0;
8899 0 : call wfnkedinit(Grid,l,Pot%nz,wfn,lwfn,istart,zxc,oneplusvtau,dvtaudr)
8900 0 : call setupforcfdsol(Grid,Pot%rv,1,istart,nr,l,energy,wfn,lwfn,yy,zz,oneplusvtau,dvtaudr)
8901 0 : call cfdsoliter(Grid,zz,yy,istart,nr)
8902 0 : call getwfnfromcfdsol(1,nr,yy,wfn)
8903 0 : nodes=countnodes(2,nr,wfn)
8904 : ! normalize to unity within integration range
8905 0 : scale=1._dp/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr)
8906 0 : scale=SIGN(SQRT(scale),wfn(nr-2))
8907 0 : wfn(1:nr)=wfn(1:nr)*scale
8908 0 : LIBPAW_DEALLOCATE(lwfn)
8909 0 : LIBPAW_DEALLOCATE(yy)
8910 0 : LIBPAW_DEALLOCATE(zz)
8911 0 : END SUBROUTINE unboundked
8912 :
8913 :
8914 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8915 : ! Set_Pot
8916 : ! Version with polynomial fitting of vtau for 0<=r<=0.001
8917 : ! and corresponding reseting of oneplusvtau and dvtaudr in that range
8918 : ! NAWH 4/6/2021
8919 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8920 0 : Subroutine Set_Pot(Grid,Pot,qq,zxc,oneplusvtau,dvtaudr)
8921 : real(dp),intent(inout) :: qq,zxc
8922 : real(dp),intent(inout) :: oneplusvtau(:),dvtaudr(:)
8923 : Type(GridInfo), INTENT(IN) :: Grid
8924 : TYPE(PotentialInfo), INTENT(IN) :: Pot
8925 : INTEGER :: n
8926 : REAL(dp),parameter :: smallr=0.001_dp
8927 : INTEGER, parameter :: order=4
8928 0 : n=Grid%n
8929 : ! check for possible ionic charge
8930 0 : qq=-Pot%rv(n)/two
8931 0 : if(qq<0.001_dp) qq=zero
8932 0 : oneplusvtau=0._dp; dvtaudr=0._dp
8933 0 : oneplusvtau=1._dp+Pot%vtau
8934 0 : call derivative(Grid,Pot%vtau,dvtaudr)
8935 0 : zxc=Pot%rvx(1)
8936 0 : END Subroutine Set_Pot
8937 :
8938 :
8939 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8940 : ! SUBROUTINE wfnkedinit(Grid,l,nz,v0,wfn,lwfn,istart)
8941 : ! returns the solution of the modified KS equations near r=0
8942 : ! using power series expansion assuming including vtau contributions
8943 : ! wfn=P(r) lwfn=(1+vtau)*dP/dr
8944 : ! P(r)~~(r**(l+1))*(1+c1*r)
8945 : ! Assumes v(r) ~~ -2*nz/r+zxc/r for r-->0
8946 : ! Assumes vtau(r) -- t0 +t1*r for r-->0
8947 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8948 0 : SUBROUTINE wfnkedinit(Grid,l,nz,wfn,lwfn,istart,zxc,oneplusvtau,dvtaudr)
8949 : real(dp),intent(in) :: zxc
8950 : real(dp),intent(in) :: oneplusvtau(:),dvtaudr(:)
8951 : Type(GridInfo), INTENT(IN) :: Grid
8952 : INTEGER, INTENT(IN) :: l,nz
8953 : REAL(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
8954 : INTEGER, INTENT(OUT) :: istart
8955 : REAL(dp) :: rr,c1,t1,t0
8956 : INTEGER :: i
8957 0 : t0=oneplusvtau(1);t1=dvtaudr(1)
8958 0 : wfn=zero; lwfn=zero
8959 0 : c1=-(two*nz-zxc+l*t1)/(two*(l+1)*(oneplusvtau(1)))
8960 0 : istart=6
8961 0 : do i=1,istart
8962 0 : rr=Grid%r(i)
8963 0 : wfn(i)=1+rr*c1
8964 0 : lwfn(i)=(rr**l)*((l+1)*wfn(i)+rr*(c1))
8965 0 : lwfn(i)=(t0+t1*rr)*lwfn(i)
8966 0 : wfn(i)=wfn(i)*(rr**(l+1))
8967 : enddo
8968 0 : End SUBROUTINE wfnkedinit
8969 :
8970 :
8971 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8972 : !! subroutine setupforcfdsol(Grid,rv,i1,i2,n,l,energy,wfn,lwfn,yy,zz)
8973 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8974 0 : subroutine setupforcfdsol(Grid,rv,i1,i2,n,l,energy,wfn,lwfn,yy,zz,oneplusvtau,dvtaudr)
8975 : Type(gridinfo), INTENT(IN) :: Grid
8976 : real(dp),intent(in) :: oneplusvtau(:),dvtaudr(:)
8977 : INTEGER, INTENT(IN) :: i1,i2,n,l
8978 : REAL(dp), INTENT(IN) :: energy
8979 : REAL(dp), INTENT(IN) :: wfn(:),lwfn(:),rv(:)
8980 : REAL(dp), INTENT(INOUT) :: yy(:,:),zz(:,:,:)
8981 : INTEGER :: i
8982 : REAL(dp) :: x
8983 0 : x=l*(l+1)
8984 0 : yy=zero;zz=zero
8985 0 : yy(1,i1:i2)=wfn(i1:i2)
8986 0 : yy(2,i1:i2)=lwfn(i1:i2)
8987 0 : do i=1,n
8988 0 : zz(1,2,i)=1._dp/oneplusvtau(i)
8989 0 : if(i==1) then
8990 0 : zz(2,1,i)=0._dp
8991 : else
8992 : zz(2,1,i)=oneplusvtau(i)*x/(Grid%r(i)*Grid%r(i))+&
8993 0 : & dvtaudr(i)/Grid%r(i)+(rv(i)/Grid%r(i)-energy)
8994 : endif
8995 : enddo
8996 0 : end subroutine setupforcfdsol
8997 :
8998 :
8999 :
9000 :
9001 :
9002 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9003 : ! 16. splinesolver
9004 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9005 :
9006 :
9007 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9008 : ! Program uses two grids -- "universal grid" Grid
9009 : ! and modified grid Grids, with fixed Grids%n=401 and ns=400
9010 : ! and Grids%r0=0.1 which are found to work well for splinesolver
9011 : ! Internally need to omit origin and so ns=Grids%n-1
9012 : ! For MGGA case (needvtau=.true.) also need fine linear grid
9013 : ! Gridf
9014 : ! Setup local private grid
9015 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9016 0 : SUBROUTINE initsplinesolver(Grid,splns,splr0,needvtau,spline)
9017 : type(splinesolvinfo),intent(inout) :: spline
9018 : logical,intent(in) :: needvtau
9019 : Type(GridInfo), INTENT(IN) :: Grid !Input universal grid
9020 : INTEGER, INTENT(IN) :: splns !spline grid
9021 : REAL(dp), INTENT(IN) :: splr0 !spline r0
9022 : INTEGER :: i,nf
9023 : REAL(dp) :: hf
9024 0 : spline%r0=splr0
9025 0 : spline%ns=splns
9026 0 : spline%h=log(1._dp+Grid%r(Grid%n)/spline%r0)/spline%ns
9027 0 : call initgridwithn(spline%Grids,2,spline%ns+1,spline%r0,spline%h) !local loggrid
9028 0 : if(has_to_print) write(std_out,*) 'initsplinesolve ', spline%r0,spline%ns,spline%h
9029 0 : LIBPAW_ALLOCATE(spline%u,(spline%ns+1))
9030 0 : LIBPAW_ALLOCATE(spline%pref,(spline%ns+1))
9031 0 : LIBPAW_ALLOCATE(spline%rr1,(spline%ns+1))
9032 0 : LIBPAW_ALLOCATE(spline%rr2,(spline%ns+1))
9033 0 : LIBPAW_ALLOCATE(spline%srv,(spline%ns+1))
9034 0 : LIBPAW_ALLOCATE(spline%svtau,(spline%ns+1))
9035 0 : LIBPAW_ALLOCATE(spline%sdvt,(spline%ns+1))
9036 0 : LIBPAW_ALLOCATE(spline%soneplusvt,(spline%ns+1))
9037 0 : do i=1,spline%ns+1
9038 0 : spline%u(i)=(i-1)*spline%h
9039 0 : spline%pref(i)=exp(0.5_dp*spline%u(i))
9040 0 : spline%rr1(i)=((spline%Grids%r(i)+spline%r0))
9041 0 : spline%rr2(i)=((spline%Grids%r(i)+spline%r0)**2)
9042 : enddo
9043 0 : if(needvtau) then ! set up fine linear grid
9044 0 : nf=20001
9045 0 : hf=Grid%r(Grid%n)/(nf-1)
9046 0 : call initgridwithn(spline%Gridf,1,nf,0._dp,hf) !local fine linear grid
9047 0 : LIBPAW_ALLOCATE(spline%fvtau,(nf))
9048 0 : LIBPAW_ALLOCATE(spline%fdvtaudr,(nf))
9049 0 : LIBPAW_ALLOCATE(spline%frvx,(nf))
9050 0 : LIBPAW_ALLOCATE(spline%fden,(nf))
9051 0 : LIBPAW_ALLOCATE(spline%ftau,(nf))
9052 0 : spline%fvtau=0._dp;spline%fdvtaudr=0._dp;spline%frvx=0._dp
9053 0 : spline%fden=0._dp;spline%ftau=0._dp
9054 : endif
9055 0 : spline%soneplusvt=1._dp;
9056 0 : spline%svtau=0._dp;spline%sdvt=0._dp
9057 0 : END SUBROUTINE initsplinesolver
9058 :
9059 :
9060 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9061 : !!
9062 : !! SUBROUTINE initpotforsplinesolver
9063 : !!
9064 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9065 0 : SUBROUTINE initpotforsplinesolver(Grid,Pot,den,tau,spline,itype)
9066 : type(splinesolvinfo),intent(inout) :: spline
9067 : Type(GridInfo), INTENT(IN) :: Grid
9068 : integer,intent(in) :: itype
9069 : Type(Potentialinfo), INTENT(INOUT) :: Pot !Universal grid
9070 : REAL(dp), INTENT(IN) :: den(:),tau(:) !Universal grid
9071 : INTEGER :: i,n
9072 0 : REAL(dp), allocatable :: dum(:),dum1(:)
9073 : REAL(dp) :: etxc,eexc
9074 0 : n=Grid%n
9075 0 : if(has_to_print) write(std_out,*) 'initpot ', n,spline%ns
9076 0 : If (Pot%needvtau) then
9077 0 : LIBPAW_ALLOCATE(dum,(spline%ns+1))
9078 0 : LIBPAW_ALLOCATE(dum1,(spline%ns+1))
9079 0 : call interpfunc(n,Grid%r,den,spline%Gridf%n,spline%Gridf%r,spline%fden)
9080 0 : call interpfunc(n,Grid%r,tau,spline%Gridf%n,spline%Gridf%r,spline%ftau)
9081 0 : call exch(spline%Gridf,spline%fden,spline%frvx,etxc,eexc,itype=itype,tau=spline%ftau,vtau=spline%fvtau)
9082 0 : if(has_to_print) write(std_out,*) 'called exch from splinesolver ', eexc
9083 0 : call nderiv(spline%Gridf%h,spline%fvtau,spline%fdvtaudr,spline%Gridf%n,i)
9084 0 : dum=Pot%rvn+Pot%rvh ! presumably these are smooth
9085 0 : call interpfunc(n,Grid%r,dum,spline%ns+1,spline%Grids%r,spline%srv)
9086 0 : call interpfunc(spline%Gridf%n,spline%Gridf%r,spline%frvx,spline%Grids%n,spline%Grids%r,dum1)
9087 0 : spline%srv=spline%srv+dum1
9088 0 : call interpfunc(spline%Gridf%n,spline%Gridf%r,spline%fvtau,spline%Grids%n,spline%Grids%r,spline%svtau)
9089 0 : call interpfunc(spline%Gridf%n,spline%Gridf%r,spline%fdvtaudr,spline%Grids%n,spline%Grids%r,spline%sdvt)
9090 0 : spline%soneplusvt=1._dp+spline%svtau
9091 0 : spline%sdvt=spline%sdvt*spline%Grids%drdu ! needed in algorithm
9092 0 : LIBPAW_DEALLOCATE(dum)
9093 0 : LIBPAW_DEALLOCATE(dum1)
9094 : else ! finegrid not needed
9095 0 : call interpfunc(n,Grid%r,Pot%rv,spline%ns+1,spline%Grids%r,spline%srv)
9096 0 : spline%soneplusvt=1._dp;
9097 0 : spline%svtau=0._dp;spline%sdvt=0._dp
9098 : endif
9099 0 : END SUBROUTINE initpotforsplinesolver
9100 :
9101 :
9102 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9103 : !! SUBROUTINE Boundsplinesolver(Grid,l,neig,eig,wfn,otau,OK)
9104 : !! Note that although the universal Grid and the local Grids
9105 : !! have the same range, they differ by the number of points and
9106 : !! the r0 parameter.
9107 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9108 0 : SUBROUTINE Boundsplinesolver(Grid,l,neig,eig,wfn,otau,OK,spline)
9109 : type(splinesolvinfo),intent(inout) :: spline
9110 : Type(GridInfo), INTENT(IN) :: Grid
9111 : INTEGER, INTENT(IN) :: l,neig
9112 : REAL(dp), INTENT(INOUT) :: eig(:),wfn(:,:),otau(:,:)
9113 : LOGICAL, INTENT(OUT) :: OK
9114 0 : real(dp), allocatable :: A(:,:),B(:,:),G(:,:),D(:),DL(:),DU(:),work(:)
9115 0 : real(dp), allocatable :: vl(:,:),vr(:,:),wr(:),wi(:)
9116 0 : integer, allocatable :: lut(:)
9117 0 : REAL(dp), allocatable :: P(:),MP(:)
9118 0 : REAL(dp), allocatable :: dum(:),dP1(:)
9119 0 : REAL(dp), allocatable :: F1(:,:),F2(:,:),S(:),E(:),V(:)
9120 : integer :: i,m,n, info,lwork,nu
9121 : real(dp) :: ol,x
9122 0 : if(has_to_print) write(std_out,*) 'entering boundspline with l,neig ', l, neig
9123 0 : if(has_to_print) write(std_out,*) 'in splinesolver '
9124 0 : OK=.false.
9125 0 : n=spline%ns+1 !Grids%n within this routine only
9126 0 : nu=Grid%n ! Universal grid
9127 0 : ol=l*(l+1)
9128 0 : lwork=spline%ns**2
9129 0 : LIBPAW_ALLOCATE(A,(spline%ns,spline%ns))
9130 0 : LIBPAW_ALLOCATE(B,(spline%ns,spline%ns))
9131 0 : LIBPAW_ALLOCATE(G,(spline%ns,spline%ns))
9132 0 : LIBPAW_ALLOCATE(D,(spline%ns))
9133 0 : LIBPAW_ALLOCATE(DL,(spline%ns))
9134 0 : LIBPAW_ALLOCATE(DU,(spline%ns))
9135 0 : LIBPAW_ALLOCATE(work,(lwork))
9136 0 : LIBPAW_ALLOCATE(vl,(spline%ns,spline%ns))
9137 0 : LIBPAW_ALLOCATE(vr,(spline%ns,spline%ns))
9138 0 : LIBPAW_ALLOCATE(wr,(spline%ns))
9139 0 : LIBPAW_ALLOCATE(wi,(spline%ns))
9140 0 : LIBPAW_ALLOCATE(lut,(spline%ns))
9141 0 : LIBPAW_ALLOCATE(P,(n))
9142 0 : LIBPAW_ALLOCATE(MP,(n))
9143 0 : LIBPAW_ALLOCATE(dum,(nu))
9144 0 : LIBPAW_ALLOCATE(dP1,(nu))
9145 0 : LIBPAW_ALLOCATE(F1,(spline%ns,spline%ns))
9146 0 : LIBPAW_ALLOCATE(F2,(spline%ns,spline%ns))
9147 0 : LIBPAW_ALLOCATE(S,(n))
9148 0 : LIBPAW_ALLOCATE(E,(n))
9149 0 : LIBPAW_ALLOCATE(V,(n))
9150 0 : D(1:spline%ns)=2._dp
9151 0 : DL(1:spline%ns-1)=0.5_dp
9152 0 : DU(1:spline%ns-1)=0.5_dp
9153 : !correct first row assuming wfn=r^(l+1)*(W0+r*W1)
9154 0 : D(1)=0.5_dp*(5._dp+two*l)/(1._dp+l)
9155 0 : B=0._dp
9156 0 : do i=1,spline%ns
9157 0 : B(i,i)=1._dp
9158 : enddo
9159 0 : call dgtsv(spline%ns,spline%ns,DL,D,DU,B,spline%ns,info)
9160 0 : if(has_to_print) write(std_out,*) 'Completed dgtsv with info = '
9161 0 : A=0._dp
9162 0 : do i=1,spline%ns
9163 0 : A(i,i)=-2._dp
9164 : enddo
9165 0 : do i=1,spline%ns-1
9166 0 : A(i,i+1)=1._dp
9167 0 : A(i+1,i)=1._dp
9168 : enddo
9169 : ! correct first row values
9170 0 : A(1,1)=-0.5_dp*(l+4._dp);
9171 0 : A=3.0_dp*A/(spline%h**2)
9172 0 : G=0._dp
9173 0 : G=MATMUL(B,A) ! G stores transformation to find M=G*y
9174 : ! Calculate full matrix
9175 0 : A=0.0_dp;S=0.0_dp;E=0.0_dp;V=0.0_dp
9176 : ! These arrays have the full range 1..n
9177 0 : S=-spline%soneplusvt/spline%rr2
9178 0 : E=-spline%sdvt/spline%rr2
9179 0 : V=0.5_dp*E-0.25_dp*S !Including only non diverging term
9180 0 : do i=2,n
9181 : V(i)=V(i)+spline%soneplusvt(i)*ol/(spline%Grids%r(i)**2)&
9182 : & +spline%sdvt(i)/(spline%Grids%r(i)*spline%rr1(i)) &
9183 0 : & +spline%srv(i)/spline%Grids%r(i)
9184 : enddo
9185 0 : F1=0._dp;F2=0._dp
9186 0 : do i=1,spline%ns
9187 0 : F1(i,i)=S(i+1)-E(i+1)*spline%h/three
9188 0 : F1(i,i+1)=-E(i+1)*spline%h/six
9189 0 : F2(i,i)=V(i+1)-E(i+1)/spline%h
9190 0 : F2(i,i+1)=E(i+1)/spline%h
9191 : ENDDO
9192 0 : A=MATMUL(F1,G)+F2
9193 0 : call dgeev('N','V',spline%ns,A,spline%ns,wr,wi,vl,spline%ns,vr,spline%ns,work,lwork,info)
9194 0 : if(has_to_print) write(std_out,*) 'dgeev completed with info = ',info
9195 0 : if (info/=0) then
9196 0 : OK=.false.
9197 0 : return
9198 : endif
9199 0 : call real_InsSort(wr,lut,.true.)
9200 0 : if(has_to_print) write(std_out,*) 'Results for l = ', l, (wr(lut(i)),i=1,10)
9201 0 : if(has_to_print) write(std_out,*) 'enumeration for neig solutions ', neig
9202 0 : do m=1,neig
9203 0 : if(has_to_print) write(std_out,'(1p,2e20.8)') wr(lut(m)),wi(lut(m))
9204 0 : eig(m)=wr(lut(m))
9205 0 : D=vr(:,lut(m)) !Q
9206 0 : DL=MATMUL(G,D) !MQ
9207 : ! now extend grid to r=0 Still Q and MQ
9208 0 : P=0.0_dp;MP=0.0_dp
9209 0 : P(2:spline%ns+1)=D(1:spline%ns)
9210 0 : MP(2:spline%ns+1)=DL(1:spline%ns)
9211 0 : if(l==0) then
9212 0 : dum=0
9213 0 : do i=2,10
9214 0 : dum(i)=P(i)/spline%Grids%r(i)
9215 : enddo
9216 0 : call extrapolate(dum)
9217 0 : x=1._dp/(S(1)-E(1)*spline%h/three)
9218 0 : MP(1)=(E(1)*(MP(2)*spline%h/six-P(2))-(spline%sdvt(1)/spline%rr1(1)+spline%srv(1))*dum(1))*x
9219 0 : if(has_to_print) write(std_out,*) 'MP(1) for l=0',MP(1),dum(1)
9220 : endif
9221 0 : if(l==1) then
9222 0 : dum=0.0_dp
9223 0 : do i=2,10
9224 0 : dum(i)=P(i)/(spline%Grids%r(i)**2)
9225 : enddo
9226 0 : call extrapolate(dum)
9227 0 : x=1._dp/(S(1)-E(1)*spline%h/three)
9228 0 : MP(1)=(E(1)*(MP(2)*spline%h/six-P(2))-(two*spline%soneplusvt(1))*dum(1))*x
9229 0 : if(has_to_print) write(std_out,*) 'MP(1) for l=1',MP(1),dum(1)
9230 : endif
9231 0 : MP=spline%pref*(MP-0.25_dp*P)/spline%rr2
9232 0 : P=spline%pref*P
9233 0 : call specialinterp(n,spline%Grids%r,P,MP,Grid%n,Grid%r,wfn(:,m),dP1(:))
9234 0 : dum=0._dp; dum(2:nu)=wfn(2:nu,m)/Grid%r(2:nu)
9235 0 : call extrapolate(dum)
9236 0 : do i=1,nu
9237 0 : otau(i,m)= (dP1(i)-dum(i))**2+l*(l+1)*(dum(i))**2
9238 : enddo
9239 0 : x=overlap(Grid,wfn(:,m),wfn(:,m))
9240 0 : if(has_to_print) write(std_out,*) 'overlap integral ', x
9241 0 : x=1._dp/x
9242 0 : otau(:,m)=x*otau(:,m)
9243 0 : x=sqrt(x)
9244 0 : wfn(:,m)=x*wfn(:,m) ! should be normalized now
9245 : enddo
9246 0 : OK=.true.
9247 0 : LIBPAW_DEALLOCATE(A)
9248 0 : LIBPAW_DEALLOCATE(B)
9249 0 : LIBPAW_DEALLOCATE(G)
9250 0 : LIBPAW_DEALLOCATE(D)
9251 0 : LIBPAW_DEALLOCATE(DL)
9252 0 : LIBPAW_DEALLOCATE(DU)
9253 0 : LIBPAW_DEALLOCATE(work)
9254 0 : LIBPAW_DEALLOCATE(vl)
9255 0 : LIBPAW_DEALLOCATE(vr)
9256 0 : LIBPAW_DEALLOCATE(wr)
9257 0 : LIBPAW_DEALLOCATE(wi)
9258 0 : LIBPAW_DEALLOCATE(lut)
9259 0 : LIBPAW_DEALLOCATE(P)
9260 0 : LIBPAW_DEALLOCATE(MP)
9261 0 : LIBPAW_DEALLOCATE(dP1)
9262 0 : LIBPAW_DEALLOCATE(dum)
9263 0 : LIBPAW_DEALLOCATE(F1)
9264 0 : LIBPAW_DEALLOCATE(F2)
9265 0 : LIBPAW_DEALLOCATE(S)
9266 0 : LIBPAW_DEALLOCATE(E)
9267 0 : LIBPAW_DEALLOCATE(V)
9268 0 : end SUBROUTINE Boundsplinesolver
9269 :
9270 :
9271 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9272 : !! SUBROUTINE deallocatesplinesolver
9273 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9274 4 : SUBROUTINE deallocatesplinesolver(spline,needvtau)
9275 : type(splinesolvinfo),intent(inout) :: spline
9276 : logical,intent(in) :: needvtau
9277 4 : if (allocated(spline%u)) then
9278 0 : LIBPAW_DEALLOCATE(spline%u)
9279 : endif
9280 4 : if (allocated(spline%pref)) then
9281 0 : LIBPAW_DEALLOCATE(spline%pref)
9282 : endif
9283 4 : if (allocated(spline%rr1)) then
9284 0 : LIBPAW_DEALLOCATE(spline%rr1)
9285 : endif
9286 4 : if (allocated(spline%rr2)) then
9287 0 : LIBPAW_DEALLOCATE(spline%rr2)
9288 : endif
9289 4 : if (allocated(spline%srv)) then
9290 0 : LIBPAW_DEALLOCATE(spline%srv)
9291 : endif
9292 4 : if (allocated(spline%svtau)) then
9293 0 : LIBPAW_DEALLOCATE(spline%svtau)
9294 : endif
9295 4 : if (allocated(spline%soneplusvt)) then
9296 0 : LIBPAW_DEALLOCATE(spline%soneplusvt)
9297 : endif
9298 4 : call destroygrid(spline%Grids)
9299 4 : if(needvtau) then
9300 0 : LIBPAW_DEALLOCATE(spline%fvtau)
9301 0 : LIBPAW_DEALLOCATE(spline%fdvtaudr)
9302 0 : LIBPAW_DEALLOCATE(spline%frvx)
9303 0 : LIBPAW_DEALLOCATE(spline%fden)
9304 0 : LIBPAW_DEALLOCATE(spline%ftau)
9305 0 : call destroygrid(spline%Gridf)
9306 : endif
9307 4 : END SUBROUTINE deallocatesplinesolver
9308 :
9309 :
9310 :
9311 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9312 : ! 17. radialdirac
9313 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9314 :
9315 :
9316 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9317 : !! SUBROUTINE boundD(Grid,Pot,eig,wfn,lwfn,kappa,nroot,emin,ierr,success)
9318 : !! pgm to solve radial Dirac relativistic equation for nroot bound state
9319 : !! energies and wavefunctions for spin orbit parameter kappa
9320 : !! with potential rv/r, given in uniform linear or log mesh of n points
9321 : !! nz=nuclear charge
9322 : !! emin=is estimate of lowest eigenvalue; used if nz=0
9323 : !! otherwise, set to the value of -(nz/(l+1))**2
9324 : !! It is assumed that the wavefunction has np-l-1 nodes, where
9325 : !! np is the principal quantum number-- np=1,2,..nroot
9326 : !! Does not use Noumerov algorithm -- but uses coupled first-order
9327 : !! equations from David Vanderbilt, Marc Torrent, and Francois Jollet
9328 : !! Corrections are also needed for r>n*h, depending on:
9329 : !! e0 (current guess of energy eigenvalue
9330 : !! the extrapolated value of rv == r * v
9331 : !! ierr=an nroot digit number indicating status of each root
9332 : !! a digit of 1 indicates success in converging root
9333 : !! 2 indicates near success in converging root
9334 : !! 9 indicates that root not found
9335 : !! first check how many roots expected = ntroot (returned as argument)
9336 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9337 206 : SUBROUTINE boundD(Grid,Pot,eig,wfn,lwfn,kappa,nroot,emin,ierr,success)
9338 : TYPE(GridInfo), INTENT(IN) :: Grid
9339 : TYPE(PotentialInfo), INTENT(INout) :: Pot
9340 : REAL(dp), INTENT(INOUT) :: eig(:),wfn(:,:),lwfn(:,:)
9341 : INTEGER, INTENT(IN) :: kappa,nroot
9342 : INTEGER, INTENT(INOUT) :: ierr
9343 : REAL(dp), INTENT(INOUT) :: emin
9344 : LOGICAL, INTENT(INOUT) :: success
9345 : REAL(dp), PARAMETER :: convre=1.d-10,vlrg=1.d30
9346 : REAL(dp), PARAMETER :: ftr=0.5_dp/InvFineStruct
9347 : INTEGER, PARAMETER :: niter=1000
9348 206 : REAL(dp), POINTER :: rv(:)
9349 206 : REAL(dp), ALLOCATABLE :: p1(:),lp1(:),p2(:),lp2(:),dd(:)
9350 : INTEGER :: n
9351 : REAL(dp) :: nz,h,v0,v0p
9352 : REAL(dp) :: err,convrez,energy
9353 : REAL(dp) :: scale,emax,best,rout
9354 : REAL(dp) :: arg,rin,dele,x
9355 : INTEGER :: iter,i,j,node,match,mxroot,ntroot,ir,iroot,l
9356 : INTEGER :: ifac,istart,iend
9357 : LOGICAL :: ok
9358 : Real(dp) :: A0,B0,A1,B1,s
9359 : REAL(dp), allocatable :: zz(:,:,:),yy(:,:)
9360 206 : n=Grid%n
9361 206 : h=Grid%h
9362 126 : if (kappa<0) l=-kappa-1
9363 206 : if (kappa>0) l=kappa
9364 618 : LIBPAW_ALLOCATE(p1,(n))
9365 412 : LIBPAW_ALLOCATE(lp1,(n))
9366 412 : LIBPAW_ALLOCATE(p2,(n))
9367 412 : LIBPAW_ALLOCATE(lp2,(n))
9368 412 : LIBPAW_ALLOCATE(dd,(n))
9369 618 : LIBPAW_ALLOCATE(zz,(2,2,n))
9370 618 : LIBPAW_ALLOCATE(yy,(2,n))
9371 206 : success=.true.
9372 206 : nz=Pot%nz
9373 206 : v0=Pot%v0
9374 206 : v0p=Pot%v0p
9375 206 : rv=>Pot%rv
9376 206 : err=n*nz*(h**4)
9377 206 : convrez=convre
9378 206 : IF (nz>0.001_dp) convrez=convre*nz
9379 206 : ierr=0
9380 206 : if(has_to_print) WRITE(STD_OUT,*) 'z ,kappa, l = ',nz,kappa,l
9381 : ! check how many roots expected by integration outward at
9382 : ! energy = 0
9383 206 : energy = zero
9384 206 : call Dzeroexpand(Grid,Pot,kappa,energy,A0,A1,B0,B1,s)
9385 4122266 : zz=zero;yy=zero
9386 206 : call wfnDinit(Grid,p1,lp1,istart,A0,A1,B0,B1,s,Pot%finitenucleus)
9387 : !start outward integration
9388 206 : call prepareforcfdsolD(Grid,1,istart,n,kappa,p1,lp1,yy,zz,Pot%ww,Pot%jj)
9389 206 : call cfdsoliter(Grid,zz,yy,istart,n)
9390 206 : call getwfnfromcfdsolD(1,n,yy,p1,lp1)
9391 206 : node=countnodes(2,n,p1)
9392 206 : if(has_to_print) WRITE(STD_OUT,*) ' nodes at e=0 ', node
9393 206 : mxroot=node+1
9394 206 : ntroot=node
9395 206 : IF (mxroot.LT.nroot) THEN
9396 0 : if(has_to_print) WRITE(STD_OUT,*)'error in boundD - for l = ',l
9397 0 : if(has_to_print) WRITE(STD_OUT,*) nroot,' states requested but only',mxroot,' possible'
9398 0 : DO ir=mxroot+1,nroot
9399 0 : ierr=ierr+9*(10**(ir-1))
9400 : ENDDO
9401 0 : success=.false.
9402 : ENDIF
9403 206 : mxroot=min0(mxroot,nroot)
9404 206 : IF (nz.EQ.0) energy=-ABS(emin)
9405 206 : IF (nz.NE.0) energy=-1.1_dp*(nz/(l+1._dp))**2
9406 206 : emin=energy-err
9407 206 : emax=0._dp
9408 630 : DO iroot=1,mxroot
9409 424 : best=1.d10; dele=1.d10
9410 424 : energy=emin+err
9411 424 : IF (energy.LT.emin) energy=emin
9412 424 : IF (energy.GT.emax) energy=emax
9413 17024 : ok=.FALSE.
9414 17024 : BigIter: DO iter=1,niter
9415 : ! start inward integration
9416 : ! start integration at n
9417 17014 : call Dzeroexpand(Grid,Pot,kappa,energy,A0,A1,B0,B1,s)
9418 : ! find classical turning point
9419 17014 : call ClassicalTurningPoint(Grid,Pot%rv,l,energy,match)
9420 17014 : match=max(match,10); match=min(match,n-20)
9421 17014 : call wfnDasym(Grid,p2,lp2,energy,iend)
9422 17014 : call prepareforcfdsolD(Grid,n-iend,n,n,kappa,p2,lp2,yy,zz,Pot%ww,Pot%jj)
9423 17014 : call cfdsoliter(Grid,zz,yy,n-iend,match)
9424 17014 : call getwfnfromcfdsolD(match,n,yy,p2,lp2)
9425 17014 : match=match+6
9426 17014 : rin=lp2(match)/p2(match)
9427 17014 : call wfnDinit(Grid,p1,lp1,istart,A0,A1,B0,B1,s,Pot%finitenucleus)
9428 17014 : call prepareforcfdsolD(Grid,1,istart,n,kappa,p1,lp1,yy,zz,Pot%ww,Pot%jj)
9429 17014 : call cfdsoliter(Grid,zz,yy,istart,match+6)
9430 17014 : call getwfnfromcfdsolD(1,match+6,yy,p1,lp1)
9431 17014 : node= countnodes(2,match+6,p1)
9432 17014 : rout=lp1(match)/p1(match)
9433 : ! check whether node = (iroot-1)
9434 : ! not enough nodes -- raise energy
9435 51052 : IF (node.LT.iroot-1) THEN
9436 439 : emin=MAX(emin,energy)-err
9437 439 : energy=emax-(emax-energy)*ranx()
9438 439 : ifac=9
9439 : ! too many nodes -- lower energy
9440 16575 : ELSEIF (node.GT.iroot-1) THEN
9441 281 : IF (energy.LE.emin) THEN
9442 0 : ierr=ierr+9*(10**(iroot-1))
9443 0 : if(has_to_print) WRITE(STD_OUT,*) 'boundD error -- emin too high',l,nz,emin,energy
9444 0 : IF (energy.LE.emin-1.d-10) THEN
9445 0 : STOP
9446 : ENDIF
9447 : ENDIF
9448 281 : emax=MIN(emax,energy+err)
9449 281 : energy=emin+(energy-emin)*ranx()
9450 : ! correct number of nodes -- estimate correction
9451 16294 : ELSEIF (node.EQ.iroot-1) THEN
9452 9003011 : DO j=1,match
9453 8986717 : p1(j)=p1(j)/p1(match)
9454 9003011 : lp1(j)=ftr*lp1(j)/p1(match)
9455 : ENDDO
9456 23650165 : DO j=match,n
9457 23633871 : p1(j)=p2(j)/p2(match)
9458 23650165 : lp1(j)=ftr*lp2(j)/p2(match)
9459 : ENDDO
9460 16294 : scale=overlap(Grid,p1,p1)+overlap(Grid,lp1,lp1)
9461 16294 : dele=(rout-rin)/scale
9462 16294 : x=ABS(dele)
9463 16294 : IF (x.LT.best) THEN
9464 3039 : scale=1._dp/SQRT(scale)
9465 6084078 : p1(1:n)=p1(1:n)*scale
9466 6084078 : lp1(1:n)=lp1(1:n)*scale
9467 3039 : call filter(n,p1,machine_zero)
9468 3039 : call filter(n,lp1,machine_zero)
9469 6084078 : wfn(1:n,iroot)=p1(1:n)
9470 6084078 : lwfn(1:n,iroot)=lp1(1:n)
9471 3039 : eig(iroot)=energy
9472 3039 : best=x
9473 : ENDIF
9474 16294 : IF (ABS(dele).LE.convrez) THEN
9475 414 : ok=.TRUE.
9476 : ! eigenvalue found
9477 414 : ierr=ierr+10**(iroot-1)
9478 414 : IF (iroot+1.LE.mxroot) THEN
9479 218 : emin=energy+err
9480 218 : emax=zero
9481 218 : energy=(emin+emax)/2
9482 218 : IF (energy.LT.emin) energy=emin
9483 218 : IF (energy.GT.emax) energy=emax
9484 218 : best=1.d10
9485 : ENDIF
9486 : EXIT BigIter
9487 : ENDIF
9488 15880 : IF (ABS(dele).GT.convrez) THEN
9489 15880 : energy=energy+dele
9490 : ! if energy is out of range, pick random energy in correct range
9491 15880 : IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) then
9492 12713 : energy=emin+(emax-emin)*ranx()
9493 : endif
9494 : ifac=2
9495 : ENDIF
9496 : ENDIF
9497 : ENDDO BigIter !iter
9498 206 : IF (.NOT.ok) THEN
9499 10 : success=.false.
9500 10 : ierr=ierr+ifac*(10**(iroot-1))
9501 10 : if(has_to_print) WRITE(STD_OUT,*) 'no convergence in boundD',iroot,l,dele,energy
9502 10 : if(has_to_print) WRITE(STD_OUT,*) ' best guess of eig, dele = ',eig(iroot),best
9503 10 : IF (iroot.LT.mxroot) THEN
9504 0 : DO ir=iroot+1,mxroot
9505 0 : ierr=ierr+9*(10**(ir-1))
9506 : ENDDO
9507 : ENDIF
9508 : ! reset wfn with hydrogenic form
9509 10 : j=iroot+l+1
9510 20020 : wfn(:,iroot)=zero
9511 20020 : lwfn(:,iroot)=zero
9512 10 : x=(j)*sqrt(abs(eig(iroot)))
9513 20010 : do i=2,n
9514 20010 : call dirachwfn(j,kappa,x,Grid%r(i),arg,wfn(i,iroot),lwfn(i,iroot))
9515 : enddo
9516 : ENDIF
9517 : ENDDO !iroot
9518 206 : LIBPAW_DEALLOCATE(p1)
9519 206 : LIBPAW_DEALLOCATE(lp1)
9520 206 : LIBPAW_DEALLOCATE(p2)
9521 206 : LIBPAW_DEALLOCATE(lp2)
9522 206 : LIBPAW_DEALLOCATE(dd)
9523 206 : LIBPAW_DEALLOCATE(yy)
9524 206 : LIBPAW_DEALLOCATE(zz)
9525 206 : if(has_to_print) write(std_out,*) 'returning from boundD -- ierr=',ierr
9526 412 : END SUBROUTINE BoundD
9527 :
9528 :
9529 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9530 : !! subroutine prepareforcfdsolD(Grid,i1,i2,n,kappa,wfn,lwfn,yy,zz)
9531 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9532 34234 : subroutine prepareforcfdsolD(Grid,i1,i2,n,kappa,wfn,lwfn,yy,zz,ww,jj)
9533 : real(dp),intent(in) :: ww(:),jj(:)
9534 : Type(gridinfo), INTENT(IN) :: Grid
9535 : INTEGER, INTENT(IN) :: i1,i2,n,kappa
9536 : REAL(dp), INTENT(IN) :: wfn(:),lwfn(:)
9537 : REAL(dp), INTENT(OUT) :: yy(:,:),zz(:,:,:)
9538 : INTEGER :: i
9539 685090808 : yy=zero;zz=zero
9540 239638 : yy(1,i1:i2)=wfn(i1:i2)
9541 239638 : yy(2,i1:i2)=lwfn(i1:i2)
9542 68502234 : do i=2,n
9543 68468000 : zz(1,1,i)=-kappa/Grid%r(i)
9544 68468000 : zz(1,2,i)=jj(i)
9545 68468000 : zz(2,2,i)=kappa/Grid%r(i)
9546 68502234 : zz(2,1,i)=-ww(i)
9547 : enddo
9548 34234 : end subroutine prepareforcfdsolD
9549 :
9550 :
9551 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9552 : !! Subroutine Dzeroexpand(Grid,Pot,kappa,energy)
9553 : !! If finitenucleus==.true. assumes potential is non-singular
9554 : !! at origin and Pot%v0 and Pot%v0p are properly set
9555 : !! -- actually not programmed yet
9556 : !! Otherwise, assumes nuclear potential is -2*Z/r
9557 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9558 17220 : Subroutine Dzeroexpand(Grid,Pot,kappa,energy,A0,A1,B0,B1,s,nr)
9559 : Real(dp), intent(inout) :: A0,B0,A1,B1,s
9560 : Type(GridInfo), INTENT(IN) :: Grid
9561 : Type(PotentialInfo), INTENT(INout) :: Pot
9562 : Integer, INTENT(IN) :: kappa
9563 : Real(dp), INTENT(IN) :: energy
9564 : Integer, optional, INTENT(IN) :: nr
9565 : Integer :: n
9566 : Real(dp) :: nz,alpha2,balpha2
9567 : Real(dp) :: x,y,z
9568 17220 : n=Grid%n
9569 17220 : if (present(nr)) n=min(n,nr)
9570 17220 : nz=Pot%nz
9571 68931660 : Pot%ww=zero; Pot%jj=zero
9572 17220 : balpha2=InvFineStruct**2
9573 17220 : alpha2=1._dp/balpha2
9574 34457220 : Pot%ww(2:n)=energy-Pot%rv(2:n)/Grid%r(2:n)
9575 34457220 : Pot%jj(2:n)=(1._dp + 0.25_dp*alpha2*Pot%ww(2:n))
9576 17220 : if (.not.Pot%finitenucleus) then
9577 17220 : s=sqrt(kappa*kappa-alpha2*nz**2)
9578 17220 : A0=1._dp
9579 17220 : B0=2._dp*(s+kappa)*balpha2/nz
9580 17220 : z=two*s+one
9581 17220 : x=alpha2*(nz**2)
9582 17220 : y=four*alpha2+energy-Pot%v0
9583 17220 : A1=(four*alpha2*x+y*(s+kappa-two*x))/(two*nz*z)
9584 17220 : y=two*alpha2+energy-Pot%v0
9585 17220 : B1=-(y*(two*(s+kappa)+energy-Pot%v0))/z
9586 : else ! version for finite nuclear size
9587 0 : write(std_out,*) 'Dirac case not yet programmed for finite nucleus'
9588 0 : stop
9589 : endif
9590 17220 : end subroutine Dzeroexpand
9591 :
9592 :
9593 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9594 : !! SUBROUTINE wfnDinit(Grid,kappa,wfn,lwfn,istart)
9595 : !! returns the solution of the Dirac relativistic equations near r=0
9596 : !! using power series expansion
9597 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9598 17220 : SUBROUTINE wfnDinit(Grid,wfn,lwfn,istart,A0,A1,B0,B1,s,finitenucleus)
9599 : logical,intent(in) :: finitenucleus
9600 : Real(dp), intent(in) :: A0,B0,A1,B1,s
9601 : Type(GridInfo), INTENT(IN) :: Grid
9602 : REAL(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
9603 : INTEGER, INTENT(OUT) :: istart
9604 : REAL(dp) :: rr
9605 : INTEGER :: i
9606 68931660 : wfn=zero; lwfn=zero
9607 17220 : istart=6
9608 120540 : do i=1,istart
9609 103320 : rr=Grid%r(i+1)
9610 120540 : if (.not.finitenucleus) then
9611 103320 : wfn(i+1)=(rr**s)*(A0+A1*rr)
9612 103320 : lwfn(i+1)=(rr**s)*(B0+B1*rr)
9613 : else ! finite nucleus case
9614 0 : write(std_out,*) 'Dirac case not programmed for finite nucleus'
9615 0 : STOP
9616 : endif
9617 : enddo
9618 17220 : End SUBROUTINE wfnDinit
9619 :
9620 :
9621 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9622 : !! subroutine wfnDasym(Grid,wfn,lwfn,energy,iend)
9623 : !! returns the solution of the Dirac relativistic equations near r=inf
9624 : !! using exp(-x*r) for upper component
9625 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9626 17014 : subroutine wfnDasym(Grid,wfn,lwfn,energy,iend)
9627 : Type(GridInfo), INTENT(IN) :: Grid
9628 : REAL(dp),INTENT(INOUT) :: wfn(:),lwfn(:)
9629 : REAL(dp), INTENT(IN) :: energy
9630 : INTEGER, INTENT(OUT) :: iend
9631 : REAL(dp) :: rr,x,m
9632 : INTEGER :: i,n
9633 17014 : if (energy>0._dp) then
9634 0 : write(std_out,*) 'Error in wfnDasym -- energy > 0', energy
9635 0 : stop
9636 : endif
9637 68107042 : wfn=zero; lwfn=zero
9638 17014 : n=Grid%n
9639 17014 : m=1._dp+0.25_dp*energy/(InvFineStruct**2)
9640 17014 : x=sqrt(-m*energy)
9641 17014 : rr=energy/x
9642 17014 : iend=5
9643 119098 : do i=n-iend,n
9644 102084 : wfn(i)=exp(-x*(Grid%r(i)-Grid%r(n-iend)))
9645 119098 : lwfn(i)=rr*wfn(i)
9646 : enddo
9647 17014 : end subroutine wfnDasym
9648 :
9649 :
9650 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9651 : !! subroutine getwfnfromcfdsolD(start,finish,yy,wfn,lwfn)
9652 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9653 34234 : subroutine getwfnfromcfdsolD(start,finish,yy,wfn,lwfn)
9654 : INTEGER, INTENT(IN) :: start,finish
9655 : REAL(dp), INTENT(IN) :: yy(:,:)
9656 : REAL(dp), INTENT(INOUT) :: wfn(:),lwfn(:)
9657 : INTEGER :: i
9658 68536468 : wfn=0
9659 34712636 : do i=start,finish
9660 34678402 : wfn(i)=yy(1,i)
9661 34712636 : lwfn(i)=yy(2,i)
9662 : enddo
9663 34234 : end subroutine getwfnfromcfdsolD
9664 :
9665 :
9666 :
9667 :
9668 :
9669 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9670 : ! 18. interpolation_mod
9671 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9672 :
9673 :
9674 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9675 : ! cubic spline interpolation for nin>2
9676 : ! linear interpolation for nin=2
9677 : ! error end if rout points are not within range of rin
9678 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9679 0 : SUBROUTINE interpfunc(nin,rin,fin,nout,rout,fout)
9680 : INTEGER, INTENT(IN) :: nin,nout
9681 : REAL(dp), INTENT(IN) :: rin(:),fin(:),rout(:)
9682 : REAL(dp), INTENT(INOUT) :: fout(:)
9683 0 : REAL(dp), ALLOCATABLE :: c(:,:)
9684 : INTEGER :: i,j
9685 : REAL(dp) :: x,s
9686 : LOGICAL :: leftin,lefton,leftout,rightin,righton,rightout
9687 : ! check if grid is within interpolation range
9688 0 : call checkrange(rin(1),rout(1),leftin,lefton,leftout)
9689 0 : call checkrange(rout(nout),rin(nin),rightin,righton,rightout)
9690 0 : if (leftout.or.rightout) then
9691 0 : write(std_out,*) 'Grid error in interpfunc',rin(1),rout(1),rin(nin),rout(nout)
9692 0 : stop
9693 : endif
9694 0 : fout=0
9695 : ! linear interpolation if nin=2
9696 0 : if (nin==2) then
9697 0 : s=(fin(2)-fin(1))/(rin(2)-rin(1))
9698 0 : do i=1,nout
9699 0 : fout(i)=fin(1)+(rout(i)-rin(1))*s
9700 : enddo
9701 : return
9702 : endif
9703 0 : LIBPAW_ALLOCATE(c,(4,nin))
9704 0 : c=zero;
9705 0 : c(1,1:nin)=fin(1:nin)
9706 0 : call cubspl(rin,c,nin,0,0)
9707 0 : do i=1,nout
9708 0 : do j=1,nin-1
9709 0 : call checkrange(rin(j),rout(i),leftin,lefton,leftout)
9710 0 : call checkrange(rout(i),rin(j+1),rightin,righton,rightout)
9711 0 : if ((leftin.or.lefton).and.(rightin.or.righton)) then
9712 0 : x=rout(i)-rin(j)
9713 0 : fout(i)=c(1,j)+x*(c(2,j)+x*(c(3,j)+x*c(4,j)/3)/2)
9714 0 : exit
9715 : endif
9716 : enddo
9717 : enddo
9718 0 : LIBPAW_DEALLOCATE(c)
9719 0 : END SUBROUTINE interpfunc
9720 :
9721 :
9722 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9723 : !! cubspl
9724 : !! from webpage
9725 : !! http://pages.cs.wisc.edu/~deboor/pgs/cubspl.f
9726 : !! Transformed into fortran 90 and REAL(8)
9727 : !! from * a practical guide to splines * by c. de boor
9728 : !! ************************ input ***************************
9729 : !! n = number of data points. assumed to be .ge. 2.
9730 : !! (tau(i), c(1,i), i=1,...,n) = abscissae and ordinates of the
9731 : !! data points. tau is assumed to be strictly increasing.
9732 : !! ibcbeg, ibcend = boundary condition indicators, and
9733 : !! c(2,1), c(2,n) = boundary condition information. specifically,
9734 : !! ibcbeg = 0 means no boundary condition at tau(1) is given.
9735 : !! in this case, the not-a-knot condition is used, i.e. the
9736 : !! jump in the third derivative across tau(2) is forced to
9737 : !! zero, thus the first and the second cubic polynomial pieces
9738 : !! are made to coincide.)
9739 : !! ibcbeg = 1 means that the slope at tau(1) is made to equal
9740 : !! c(2,1), supplied by input.
9741 : !! ibcbeg = 2 means that the second derivative at tau(1) is
9742 : !! made to equal c(2,1), supplied by input.
9743 : !! ibcend = 0, 1, or 2 has analogous meaning concerning the
9744 : !! boundary condition at tau(n), with the additional infor-
9745 : !! mation taken from c(2,n).
9746 : !! *********************** output **************************
9747 : !! c(j,i), j=1,...,4; i=1,...,l (= n-1) = the polynomial coefficients
9748 : !! of the cubic interpolating spline with interior knots (or
9749 : !! joints) tau(2), ..., tau(n-1). precisely, in the interval
9750 : !! (tau(i), tau(i+1)), the spline f is given by
9751 : !! f(x) = c(1,i)+h*(c(2,i)+h*(c(3,i)+h*c(4,i)/3.)/2.)
9752 : !! where h = x - tau(i). the function program *ppvalu* may be
9753 : !! used to evaluate f or its derivatives from tau,c, l = n-1,
9754 : !! and k=4.
9755 : !! A tridiagonal linear system for the unknown slopes s(i) of
9756 : !! f at tau(i), i=1,...,n, is generated and then solved by gauss elim-
9757 : !! ination, with s(i) ending up in c(2,i), all i.
9758 : !! c(3,.) and c(4,.) are used initially for temporary storage.
9759 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9760 0 : subroutine cubspl ( tau, c, n, ibcbeg, ibcend )
9761 : integer :: ibcbeg,ibcend,n, i,j,l,m
9762 : real(dp) :: c(4,n),tau(n), divdf1,divdf3,dtau,g
9763 0 : l = n-1
9764 : !compute first differences of tau sequence and store in c(3,.). also,
9765 : !compute first divided difference of data and store in c(4,.).
9766 0 : do m=2,n
9767 0 : c(3,m) = tau(m) - tau(m-1)
9768 0 : c(4,m) = (c(1,m) - c(1,m-1))/c(3,m)
9769 : enddo
9770 : !construct first equation from the boundary condition, of the form
9771 : ! c(4,1)*s(1) + c(3,1)*s(2) = c(2,1)
9772 0 : if (ibcbeg-1 <0) go to 11
9773 0 : if (ibcbeg-1==0) go to 15
9774 : if (ibcbeg-1 >0) go to 16
9775 0 : 11 if (n .gt. 2) go to 12
9776 : ! no condition at left end and n = 2.
9777 0 : c(4,1) = 1._dp
9778 0 : c(3,1) = 1._dp
9779 0 : c(2,1) = 2._dp*c(4,2)
9780 0 : go to 25
9781 : ! not-a-knot condition at left end and n .gt. 2.
9782 0 : 12 c(4,1) = c(3,3)
9783 0 : c(3,1) = c(3,2) + c(3,3)
9784 0 : c(2,1) =((c(3,2)+2._dp*c(3,1))*c(4,2)*c(3,3)+c(3,2)**2*c(4,3))/c(3,1)
9785 0 : go to 19
9786 : ! slope prescribed at left end.
9787 0 : 15 c(4,1) = 1._dp
9788 0 : c(3,1) = 0._dp
9789 0 : go to 18
9790 : ! second derivative prescribed at left end.
9791 0 : 16 c(4,1) = 2._dp
9792 0 : c(3,1) = 1._dp
9793 0 : c(2,1) = 3._dp*c(4,2) - c(3,2)/2._dp*c(2,1)
9794 0 : 18 if(n .eq. 2) go to 25
9795 : ! if there are interior knots, generate the corresp. equations and car-
9796 : ! ry out the forward pass of gauss elimination, after which the m-th
9797 : ! equation reads c(4,m)*s(m) + c(3,m)*s(m+1) = c(2,m).
9798 0 : 19 do m=2,l
9799 0 : g = -c(3,m+1)/c(4,m-1)
9800 0 : c(2,m) = g*c(2,m-1) + 3._dp*(c(3,m)*c(4,m+1)+c(3,m+1)*c(4,m))
9801 0 : c(4,m) = g*c(3,m-1) + 2._dp*(c(3,m) + c(3,m+1))
9802 : enddo
9803 : !construct last equation from the second boundary condition, of the form
9804 : ! (-g*c(4,n-1))*s(n-1) + c(4,n)*s(n) = c(2,n)
9805 : ! if slope is prescribed at right end, one can go directly to back-
9806 : ! substitution, since c array happens to be set up just right for it
9807 : ! at this point.
9808 0 : if (ibcend-1 <0) go to 21
9809 0 : if (ibcend-1==0) go to 30
9810 : if (ibcend-1 >0) go to 24
9811 0 : 21 if (n .eq. 3 .and. ibcbeg .eq. 0) go to 22
9812 : ! not-a-knot and n .ge. 3, and either n.gt.3 or also not-a-knot at
9813 : ! left end point.
9814 0 : g = c(3,n-1) + c(3,n)
9815 : c(2,n) = ((c(3,n)+2._dp*g)*c(4,n)*c(3,n-1) &
9816 0 : & + c(3,n)**2*(c(1,n-1)-c(1,n-2))/c(3,n-1))/g
9817 0 : g = -g/c(4,n-1)
9818 0 : c(4,n) = c(3,n-1)
9819 0 : go to 29
9820 : ! either (n=3 and not-a-knot also at left) or (n=2 and not not-a-
9821 : ! knot at left end point).
9822 0 : 22 c(2,n) = 2._dp*c(4,n)
9823 0 : c(4,n) = 1._dp
9824 0 : go to 28
9825 : ! second derivative prescribed at right endpoint.
9826 0 : 24 c(2,n) = 3._dp*c(4,n) + c(3,n)/2._dp*c(2,n)
9827 0 : c(4,n) = 2._dp
9828 0 : go to 28
9829 : 25 continue
9830 0 : if (ibcend-1 <0) go to 26
9831 0 : if (ibcend-1==0) go to 30
9832 : if (ibcend-1 >0) go to 24
9833 0 : 26 if (ibcbeg .gt. 0) go to 22
9834 : ! not-a-knot at right endpoint and at left endpoint and n = 2.
9835 0 : c(2,n) = c(4,n)
9836 0 : go to 30
9837 0 : 28 g = -1._dp/c(4,n-1)
9838 : !complete forward pass of gauss elimination.
9839 0 : 29 c(4,n) = g*c(3,n-1) + c(4,n)
9840 0 : c(2,n) = (g*c(2,n-1) + c(2,n))/c(4,n)
9841 : !carry out back substitution
9842 0 : 30 j = l
9843 0 : 40 c(2,j) = (c(2,j) - c(3,j)*c(2,j+1))/c(4,j)
9844 0 : j = j - 1
9845 0 : if (j .gt. 0) go to 40
9846 : !****** generate cubic coefficients in each interval, i.e., the deriv.s
9847 : ! at its left endpoint, from value and slope at its endpoints.
9848 0 : do i=2,n
9849 0 : dtau = c(3,i)
9850 0 : divdf1 = (c(1,i) - c(1,i-1))/dtau
9851 0 : divdf3 = c(2,i-1) + c(2,i) - 2._dp*divdf1
9852 0 : c(3,i-1) = 2._dp*(divdf1 - c(2,i-1) - divdf3)/dtau
9853 0 : c(4,i-1) = (divdf3/dtau)*(6._dp/dtau)
9854 : enddo
9855 0 : END subroutine cubspl
9856 :
9857 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
9858 : ! Subroutine to use input from Ahlberg spline interpolation
9859 : ! for node points rin(1..nin) and function values yin and
9860 : ! second derivative values Min to interpolate to radial grid
9861 : ! rout with values yout. For the range 0 \le r \le rin(1)
9862 : ! it is assumed that yout=r**(l+1)(W0+W1*r) where l denotes
9863 : ! the angular momentum of the function
9864 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
9865 0 : subroutine specialinterp(nin,rin,yin,MMin,nout,rout,yout,ypout)
9866 : integer, intent(IN) :: nin,nout
9867 : real(dp), intent(IN) :: rin(:),yin(:),MMin(:),rout(:)
9868 : real(dp), intent(INOUT) :: yout(:),ypout(:)
9869 0 : real(dp), allocatable :: h(:),C(:,:)
9870 : real(dp) :: x
9871 : integer :: i,j
9872 : LOGICAL :: leftin,lefton,leftout,rightin,righton,rightout
9873 0 : LIBPAW_ALLOCATE(h,(nin))
9874 0 : LIBPAW_ALLOCATE(C,(4,nin))
9875 0 : h=0
9876 0 : do i=2,nin
9877 0 : h(i)=rin(i)-rin(i-1)
9878 : enddo
9879 : !h(1) is hopefully not used
9880 0 : C=0
9881 0 : C(1,1:nin)=yin(1:nin)
9882 0 : C(3,1:nin)=MMin(1:nin)
9883 0 : do i=1,nin-1
9884 0 : C(4,i)=(MMin(i+1)-MMin(i))/h(i+1)
9885 0 : C(2,i)=((yin(i+1)-yin(i))/h(i+1)-(MMin(i+1)+2*MMin(i))*h(i+1)/6)
9886 : enddo
9887 0 : yout=0;ypout=0
9888 : ! check if grid is within interpolation range
9889 0 : call checkrange(rin(1),rout(1),leftin,lefton,leftout)
9890 0 : call checkrange(rout(nout),rin(nin),rightin,righton,rightout)
9891 0 : if (leftout.or.rightout) then
9892 0 : write(std_out,*) 'Grid error in specialint',rin(1),rout(1),rin(nin),rout(nout)
9893 0 : stop
9894 : endif
9895 0 : do i=1,nout
9896 0 : do j=1,nin-1
9897 0 : call checkrange(rin(j),rout(i),leftin,lefton,leftout)
9898 0 : call checkrange(rout(i),rin(j+1),rightin,righton,rightout)
9899 0 : if ((leftin.or.lefton).and.(rightin.or.righton)) then
9900 0 : x=rout(i)-rin(j)
9901 0 : yout(i)=c(1,j)+x*(c(2,j)+x*(c(3,j)+x*c(4,j)/3)/2)
9902 0 : ypout(i)=c(2,j)+x*(c(3,j)+0.5_dp*x*c(4,j))
9903 0 : exit
9904 : endif
9905 : enddo
9906 : enddo
9907 0 : LIBPAW_DEALLOCATE(h)
9908 0 : LIBPAW_DEALLOCATE(C)
9909 0 : end subroutine specialinterp
9910 :
9911 :
9912 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9913 : !! checkrange
9914 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9915 0 : subroutine checkrange(rin,rout,inrange,onrange,outofbounds)
9916 : LOGICAL, INTENT(OUT) :: inrange,onrange,outofbounds
9917 : REAL(dp), INTENT(IN) :: rin,rout
9918 : REAL(dp), parameter :: tol=1.d-7
9919 0 : inrange=.false.;onrange=.false.;outofbounds=.false.
9920 0 : if (rout>=rin) then
9921 0 : inrange=.true.
9922 : return
9923 : endif
9924 0 : if (abs(rout-rin).le.tol) then
9925 0 : onrange=.true.
9926 : return
9927 : endif
9928 0 : outofbounds=.true.
9929 : end subroutine checkrange
9930 :
9931 :
9932 :
9933 :
9934 :
9935 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9936 : ! 19. search_sort
9937 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9938 :
9939 :
9940 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9941 : !! SUBROUTINE Real_InsSort(A, LUT, Ascending)
9942 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9943 0 : SUBROUTINE Real_InsSort(A, LUT, Ascending)
9944 : REAL(dp), INTENT(IN) :: A(:)
9945 : INTEGER, INTENT(INOUT) :: LUT(:)
9946 : LOGICAL, INTENT(IN) :: Ascending
9947 : INTEGER :: i, j, k, A_Size
9948 : REAL(dp) :: CurrVal
9949 0 : A_Size = SIZE(A)
9950 0 : DO i=1, A_Size
9951 0 : LUT(i) = i
9952 : END DO
9953 0 : DO i = 2, A_Size
9954 0 : CurrVal = A(LUT(i))
9955 0 : j = i - 1
9956 0 : DO WHILE ((CurrVal < A(LUT(j))) .AND. (j>1))
9957 0 : LUT(j+1) = LUT(j)
9958 0 : j = j - 1
9959 : END DO
9960 0 : IF (CurrVal < A(LUT(j))) THEN
9961 0 : LUT(j+1) = LUT(j)
9962 0 : j = j - 1
9963 : END IF
9964 0 : LUT(j+1) = i
9965 : END DO
9966 0 : IF (.NOT. Ascending) THEN
9967 0 : j = A_Size / 2
9968 0 : DO i = 1, j
9969 0 : k = LUT(i)
9970 0 : LUT(i) = LUT(A_Size - i + 1)
9971 0 : LUT(A_Size - i + 1) = k
9972 : END DO
9973 : END IF
9974 0 : RETURN
9975 : END SUBROUTINE Real_InsSort
9976 :
9977 :
9978 :
9979 :
9980 :
9981 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9982 : ! 20. input_dataset_mod
9983 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9984 :
9985 :
9986 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9987 : !! NAME
9988 : !! input_dataset_read
9989 : !!
9990 : !! FUNCTION
9991 : !! Initialize an input_dataset datastructure by reading it from
9992 : !! a file. If file is omitted, then read from standard input.
9993 : !! Note: we only read here data used to generate the PAW dataset,
9994 : !! not data used for the post-processing (output, explore, scfpaw, ...)
9995 : !!
9996 : !! INPUTS (all optionals)
9997 : !! [inputfile]= name of input file to be read
9998 : !! [echofile]= name of a file to echo input file content
9999 : !! [read_global_data]= if TRUE, read global data (atom, XC, grid, ...) -
10000 : !Default TRUE
10001 : !! [read_elec_data]= if TRUE, read electronic configuration (orbital &
10002 : !occupations) - Default TRUE
10003 : !! [read_coreval_data]= if TRUE, read electronic config (core and valence) -
10004 : !Default TRUE
10005 : !! [read_basis_data]= if TRUE, read basis data (radii, pseudo scheme, ...) -
10006 : !Default TRUE
10007 : !!
10008 : !! OUTPUT
10009 : !! [input_dt]= datastructure containing the complete input file.
10010 : !! If omitted, then the global public `input_dataset`
10011 : !! is used.
10012 : !!
10013 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
10014 4 : SUBROUTINE input_dataset_read(atp,inputfile,dirac,has_to_echo,&
10015 : &read_global_data,read_elec_data,read_coreval_data,read_basis_data)
10016 : !---- Arguments
10017 : CHARACTER*(*),INTENT(IN) :: inputfile
10018 : logical,intent(in) :: has_to_echo
10019 : logical,intent(in) :: dirac
10020 : LOGICAL,INTENT(IN),OPTIONAL :: read_global_data,read_elec_data,&
10021 : & read_coreval_data,read_basis_data
10022 : TYPE(atompaw_type),INTENT(INOUT) :: atp
10023 : !---- Local variables
10024 : CHARACTER(132) :: echofile
10025 : INTEGER :: ifunit
10026 : INTEGER,PARAMETER :: ecunit=222
10027 : INTEGER,PARAMETER :: nkappa(5)=(/1,2,2,2,2/)
10028 : INTEGER :: input_unit
10029 : integer :: i_usexcnhat,i_logspline,i_rsoptim,i_lda12
10030 : INTEGER :: ii,io,nadd,norb,nval,nbl,nn,ik,kk,jdirac
10031 : INTEGER :: ilin,ilog,inrl,iscl,ipnt,ifin,iend,ihfpp,ilcex,itau
10032 : INTEGER :: igrid,irelat,ilogder,ilogv4,ibd,idirac,ifixz,ll,nstart
10033 : INTEGER :: ispline,isplr0,isplns
10034 : LOGICAL :: read_global_data_,read_elec_data_,read_coreval_data_,read_basis_data_
10035 : CHARACTER(200) :: inputline,inputword
10036 : !CHARACTER(128) :: exchangecorrelationandgridline
10037 : CHARACTER(256) :: exchangecorrelationandgridline
10038 : CHARACTER(1) :: CHR
10039 : integer,parameter :: XML_RECL=50000
10040 : character (len=XML_RECL) :: line,readline
10041 : logical :: found
10042 : real(dp) :: x1,x2,xocc
10043 : INTEGER :: basis_add_l(nbasis_add_max)
10044 : INTEGER :: basis_add_k(nbasis_add_max)
10045 : real(dp) :: basis_add_energy(nbasis_add_max)
10046 : INTEGER :: tmp_n(norbit_max),tmp_l(norbit_max),tmp_k(norbit_max)
10047 : real(dp) :: tmp_occ(norbit_max)
10048 4 : ifunit=libpaw_get_free_unit()
10049 4 : input_unit=ifunit
10050 4 : OPEN(ifunit,file=trim(inputfile),form='formatted',action="read")
10051 : !Select which components have to be read
10052 4 : read_global_data_=.true.;if (PRESENT(read_global_data))read_global_data_=read_global_data
10053 4 : read_elec_data_=.true.;if (PRESENT(read_elec_data))read_elec_data_=read_elec_data
10054 4 : read_coreval_data_=.true.;if (PRESENT(read_coreval_data))read_coreval_data_=read_coreval_data
10055 4 : read_basis_data_=.true.;if (PRESENT(read_basis_data))read_basis_data_=read_basis_data
10056 : !Print a title
10057 4 : IF(read_global_data_.OR.read_elec_data_.OR.read_coreval_data_.OR.read_basis_data_)THEN
10058 4 : if(has_to_print) WRITE(STD_OUT,'(/,3x,a)') "===== READING OF INPUT FILE ====="
10059 : END IF
10060 :
10061 : found=.false.
10062 : do while (.not.found)
10063 20160 : read(input_unit,'(a)',err=10,end=10) readline
10064 20160 : line=adjustl(readline);goto 20
10065 0 : 10 write(std_out,*) 'ERROR in reading atp file' ; stop
10066 : 20 continue
10067 20160 : if (line(1:22)=='<!-- Program: atompaw') then
10068 : found=.true.
10069 : end if
10070 : enddo
10071 : if(.not.found) then
10072 : LIBPAW_ERROR('XML COREWF FILE NOT CORRECT')
10073 : endif
10074 :
10075 : !------------------------------------------------------------------
10076 : !Start reading of AE data
10077 4 : IF (read_global_data_) THEN
10078 : !------------------------------------------------------------------
10079 : !=== 1st line: read atomic symbol, atomic number
10080 4 : READ(input_unit,'(a)') inputline
10081 4 : CALL eliminate_comment(inputline)
10082 4 : READ(inputline,*) atp%atomic_symbol,atp%atomic_charge
10083 4 : echofile=trim(atp%atomic_symbol)//'_atp_echofile'
10084 4 : IF (has_to_echo) THEN
10085 4 : OPEN(ecunit,file=trim(echofile),form='formatted')
10086 : END IF
10087 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10088 : !Print read data
10089 4 : IF (has_to_print) THEN
10090 0 : WRITE(STD_OUT,'(3x,a,a2)') "Atomic symbol : ",atp%atomic_symbol
10091 0 : WRITE(STD_OUT,'(3x,a,i0)') "Atomic charge : ",atp%atomic_charge
10092 : END IF
10093 : !------------------------------------------------------------------
10094 : !=== 2nd line: read XC type, grid data, relativistic,point-nucleus,
10095 : ! logderiv data, HF data, Block-Davidson keyword
10096 : !Read full line
10097 4 : READ(input_unit,'(a)') exchangecorrelationandgridline
10098 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(exchangecorrelationandgridline)
10099 4 : CALL eliminate_comment(exchangecorrelationandgridline)
10100 4 : CALL Uppercase(exchangecorrelationandgridline)
10101 : exchangecorrelationandgridline=trim(exchangecorrelationandgridline)
10102 : !Retrieve keyword indexes
10103 4 : ilin=0;ilin=0;ilog=0;ilogv4=0;inrl=0;iscl=0;ipnt=0;ifin=0
10104 4 : ihfpp=0;ilcex=0;igrid=0;irelat=0;ilogder=0;ibd=0;idirac=0
10105 4 : ispline=0;isplr0=0;isplns=0
10106 4 : ilin=INDEX(exchangecorrelationandgridline,'LINEARGRID')
10107 4 : ilog=INDEX(exchangecorrelationandgridline,'LOGGRID')
10108 4 : ilogv4=INDEX(exchangecorrelationandgridline,'LOGGRIDV4')
10109 4 : ibd=INDEX(exchangecorrelationandgridline,'BDSOLVE')
10110 4 : inrl=INDEX(exchangecorrelationandgridline,'NONRELATIVISTIC')
10111 4 : iscl=INDEX(exchangecorrelationandgridline,'SCALARRELATIVISTIC')
10112 4 : idirac=INDEX(exchangecorrelationandgridline,'DIRACRELATIVISTIC')
10113 4 : ipnt=INDEX(exchangecorrelationandgridline,'POINT-NUCLEUS')
10114 4 : ifin=INDEX(exchangecorrelationandgridline,'FINITE-NUCLEUS')
10115 4 : ilogder=INDEX(exchangecorrelationandgridline,'LOGDERIVRANGE')
10116 4 : ihfpp=INDEX(exchangecorrelationandgridline,'HFPOSTPROCESS')
10117 4 : ilcex=INDEX(exchangecorrelationandgridline,'LOCALIZEDCOREEXCHANGE')
10118 4 : ifixz=INDEX(exchangecorrelationandgridline,'FIXED_ZERO')
10119 4 : itau=INDEX(exchangecorrelationandgridline,'WTAU')
10120 4 : ispline=INDEX(exchangecorrelationandgridline,'SPLINEINTERP')
10121 4 : isplr0=INDEX(exchangecorrelationandgridline,'SPLR0')
10122 4 : isplns=INDEX(exchangecorrelationandgridline,'SPLNS')
10123 4 : igrid=max(ilin,ilog) !This line may need attention....
10124 4 : irelat=max(inrl,iscl) !This line may need attention....
10125 : !!Treat simple logical variables
10126 4 : atp%scalarrelativistic=(iscl>0.and.inrl==0)
10127 4 : atp%diracrelativistic=(idirac>0.and.inrl==0)
10128 4 : atp%usespline=(itau>0.or.ispline>0.and.inrl==0)
10129 4 : atp%finitenucleus=(ifin>0.and.ipnt==0)
10130 4 : atp%BDsolve=(ibd>0)
10131 4 : atp%HFpostprocess=(ihfpp>0)
10132 : !!Treat finite nucleus option
10133 4 : atp%finitenucleusmodel=-1
10134 4 : IF (atp%finitenucleus) THEN
10135 0 : READ(exchangecorrelationandgridline(ifin+14:ifin+14),'(a)') CHR
10136 0 : IF (CHR=="2") atp%finitenucleusmodel=2
10137 0 : IF (CHR=="3") atp%finitenucleusmodel=3
10138 0 : IF (CHR=="4") atp%finitenucleusmodel=4
10139 0 : IF (CHR=="5") atp%finitenucleusmodel=5
10140 : END IF
10141 : !Treat possible changes to spline grid
10142 4 : if (isplr0>0) then
10143 0 : READ(exchangecorrelationandgridline(isplr0+5:),*) atp%splr0
10144 : end if
10145 4 : if (isplns>0) then
10146 0 : READ(exchangecorrelationandgridline(isplns+5:),*) atp%splns
10147 : end if
10148 : !!Treat grid data
10149 4 : atp%gridkey='LINEAR'
10150 4 : atp%gridpoints=mxgridlin
10151 4 : atp%gridrange=linrange
10152 4 : atp%gridmatch=linrange
10153 4 : IF (ilog>0.and.ilin==0.and.ilogv4==0) THEN
10154 4 : atp%gridkey='LOGGRID'
10155 4 : atp%gridpoints=mxgridlog;
10156 4 : atp%gridrange=logrange
10157 4 : atp%gridmatch=logrange
10158 : END IF
10159 4 : IF (ilog>0.and.ilin==0.and.ilogv4>0) THEN
10160 0 : atp%gridkey='LOGGRID4'
10161 0 : atp%gridpoints=mxgridlog;
10162 0 : atp%gridrange=v4logrange
10163 0 : atp%gridmatch=v4logrange
10164 : END IF
10165 4 : IF (igrid>0) THEN
10166 4 : iend=256
10167 4 : IF (irelat >igrid.and.irelat-1 <iend) iend=irelat -1
10168 4 : IF (ilogder>igrid.and.ilogder-1<iend) iend=ilogder-1
10169 4 : IF (ibd>igrid.and.ibd-1<iend) iend=ibd-1
10170 4 : inputline=""
10171 4 : IF (ilog>0.and.ilogv4==0.and.iend>igrid+7) &
10172 4 : & inputline=TRIM(exchangecorrelationandgridline(igrid+7:iend))
10173 4 : IF (ilog>0.and.ilogv4>0.and.iend>igrid+9) &
10174 0 : & inputline=TRIM(exchangecorrelationandgridline(igrid+9:iend))
10175 4 : IF (ilin>0.and.iend>igrid+10) &
10176 0 : & inputline=TRIM(exchangecorrelationandgridline(igrid+10:iend))
10177 4 : IF (inputline/="") THEN
10178 4 : CALL extractword(1,inputline,inputword);inputword=trim(inputword)
10179 4 : IF (inputword/="") THEN
10180 4 : READ(inputword,*) atp%gridpoints
10181 4 : CALL extractword(2,inputline,inputword);inputword=trim(inputword)
10182 4 : IF (inputword/="") THEN
10183 0 : READ(inputword,*) atp%gridrange
10184 0 : atp%gridmatch=atp%gridrange
10185 0 : CALL extractword(3,inputline,inputword);inputword=trim(inputword)
10186 0 : IF (inputword/="") read(inputword,*) atp%gridmatch
10187 : END IF
10188 : END IF
10189 : END IF
10190 4 : IF (atp%gridpoints<=0) STOP "input_dataset: error -- number of grid points should be >0!"
10191 : END IF
10192 : !Treat logderiv data
10193 4 : atp%minlogderiv=logder_min
10194 4 : atp%maxlogderiv=logder_max
10195 4 : atp%nlogderiv=logder_pts
10196 4 : IF (ilogder>0) THEN
10197 2 : iend=256
10198 2 : IF (igrid >ilogder.and.igrid-1 <iend) iend=igrid -1
10199 2 : IF (irelat>ilogder.and.irelat-1<iend) iend=irelat-1
10200 2 : inputline=""
10201 2 : IF (iend>ilogder+13)inputline=trim(exchangecorrelationandgridline(ilogder+13:iend))
10202 2 : IF (inputline/="") THEN
10203 2 : CALL extractword(1,inputline,inputword);inputword=trim(inputword)
10204 2 : IF (inputword/="") THEN
10205 2 : READ(inputword,*) atp%minlogderiv
10206 2 : CALL extractword(2,inputline,inputword);inputword=trim(inputword)
10207 2 : IF (inputword/="") THEN
10208 2 : READ(inputword,*) atp%maxlogderiv
10209 2 : CALL extractword(3,inputline,inputword);inputword=trim(inputword)
10210 2 : IF (inputword/="") READ(inputword,*) atp%nlogderiv
10211 : END IF
10212 : END IF
10213 : END IF
10214 : END IF
10215 : !Treat XC/HF
10216 4 : if (itau>0) then
10217 0 : READ(unit=exchangecorrelationandgridline(itau+5:),fmt=*) atp%exctype
10218 : else
10219 4 : READ(unit=exchangecorrelationandgridline(1:),fmt=*) atp%exctype
10220 : endif
10221 4 : atp%needvtau=(itau>0.or.TRIM(atp%exctype)=='MGGA-R2SCAN-001'.or.TRIM(atp%exctype)=='MGGA-R2SCAN-01')
10222 4 : atp%localizedcoreexchange=(ilcex>0)
10223 4 : atp%fixed_zero=(ifixz>0) ; atp%fixed_zero_index=-1
10224 4 : IF (atp%fixed_zero) &
10225 0 : & READ(unit=exchangecorrelationandgridline(ifixz+10:),fmt=*)atp%fixed_zero_index
10226 : !Print read data
10227 4 : IF (has_to_print) THEN
10228 0 : WRITE(STD_OUT,'(3x,2a)') "Scalar-relativistic calculation:",MERGE("YES"," NO",atp%scalarrelativistic)
10229 0 : WRITE(STD_OUT,'(3x,2a)') "Dirac-relativistic calculation:",MERGE("YES"," NO",atp%diracrelativistic)
10230 0 : IF (atp%usespline) THEN
10231 0 : WRITE(STD_OUT,'(3x,a)') " - Use a spline solver"
10232 : END IF
10233 0 : WRITE(STD_OUT,'(3x,2a)') "Exchange-correlation functional:",TRIM(atp%exctype)
10234 0 : WRITE(STD_OUT,'(3x,3a)') " (mGGA kinetic energy functional:",MERGE("YES"," NO",atp%needvtau),")"
10235 0 : WRITE(STD_OUT,'(3x,2a)') "Finite-nucleus calculation:",MERGE("YES"," NO",atp%finitenucleus)
10236 0 : IF (atp%finitenucleus) THEN
10237 0 : WRITE(STD_OUT,'(3x,a,i0)') " - Finite-nucleus model:",atp%finitenucleusmodel
10238 : END IF
10239 0 : WRITE(STD_OUT,'(3x,2a)') "Block-Davidson calculation:",MERGE("YES"," NO",atp%BDsolve)
10240 0 : WRITE(STD_OUT,'(3x,2a)') "Grid type:",TRIM(atp%gridkey)
10241 0 : WRITE(STD_OUT,'(3x,a,i0)') "Grid size:",atp%gridpoints
10242 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Grid maximum value:",atp%gridrange
10243 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Grid imposed value:",atp%gridmatch
10244 0 : if(atp%usespline) then
10245 0 : WRITE(STD_OUT,'(3x,a,f7.3,2x,i0)') "Spline grid r0, ns :",&
10246 0 : & atp%splr0,atp%splns
10247 : endif
10248 0 : WRITE(STD_OUT,'(3x,a,i0)') "Log. derivative, number of pts:",atp%nlogderiv
10249 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Log. derivative, min. energy:",atp%minlogderiv
10250 0 : WRITE(STD_OUT,'(3x,a,f7.3)') "Log. derivative, max. energy:",atp%maxlogderiv
10251 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, post-processing:",MERGE("YES"," NO",atp%HFpostprocess)
10252 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, localized coreex.:",MERGE("YES"," NO",atp%localizedcoreexchange)
10253 0 : WRITE(STD_OUT,'(3x,2a)') "Hartree-Fock, fixed zero:",MERGE("YES"," NO",atp%fixed_zero)
10254 0 : IF (atp%fixed_zero) THEN
10255 0 : WRITE(STD_OUT,'(3x,a,i0)') " - HF fixed zero index:",atp%fixed_zero_index
10256 : END IF
10257 0 : IF (atp%BDsolve.and.atp%gridkey=='LINEAR') THEN
10258 0 : WRITE(STD_OUT,'(/,3x,a)') "WARNING: BlockDavidson solver works very slowlywith linear grid!"
10259 : END IF
10260 : END IF
10261 : !------------------------------------------------------------------
10262 : !End reading of global data. Start reading of electronic configuration data
10263 : ENDIF
10264 4 : IF (read_elec_data_) THEN
10265 : !------------------------------------------------------------------
10266 : !=== 3rd line and following: electronic configuration of atom
10267 4 : READ(input_unit,'(a)') inputline
10268 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10269 4 : CALL eliminate_comment(inputline)
10270 4 : READ(inputline,*) atp%np(1:5)
10271 24 : DO ll=1,5
10272 24 : IF(atp%np(ll)<0) atp%np(ll)=0
10273 : END DO
10274 : atp%norbit=atp%np(1)+max(atp%np(2)-1,0)+max(atp%np(3)-2,0) &
10275 4 : & +max(atp%np(4)-3,0)+max(atp%np(5)-4,0)
10276 4 : IF (atp%diracrelativistic.and.dirac) atp%norbit=2*atp%norbit-atp%np(1)
10277 : !Print read data
10278 4 : IF (has_to_print) THEN
10279 0 : WRITE(STD_OUT,'(3x,a,5(1x,i0))') "Max. quantum numbers(s,p,d,f,g):",atp%np(1:5)
10280 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of orbitals: ",atp%norbit
10281 : END IF
10282 : ! CALL input_dataset_read_occ(dataset%norbit_mod,dataset%orbit_mod_l,&
10283 : !&dataset%orbit_mod_n,dataset%orbit_mod_k,dataset%orbit_mod_occ,&
10284 : !& dataset%np,dataset%diracrelativistic,&
10285 : !& inputfile_unit=input_unit,echofile_unit=ecunit)
10286 4 : atp%norbit_mod=0
10287 4 : kk=0
10288 : DO
10289 12 : READ(input_unit,'(a)') inputline
10290 12 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10291 12 : CALL eliminate_comment(inputline)
10292 12 : if (.not.atp%diracrelativistic) READ(inputline,*) nn,ll,xocc
10293 12 : if (atp%diracrelativistic) READ(inputline,*) nn,ll,kk,xocc
10294 12 : IF (nn<=0) EXIT
10295 : IF (xocc<0._dp.OR.&
10296 8 : & ((.NOT.atp%diracrelativistic).AND.(xocc>2._dp*(2*ll+1))).OR.&
10297 : & (( atp%diracrelativistic).AND.(xocc>2._dp*ABS(kk)))) THEN
10298 0 : LIBPAW_ERROR('input_dataset: error in occupations')
10299 : END IF
10300 8 : atp%norbit_mod=atp%norbit_mod+1
10301 8 : if(atp%diracrelativistic.and.(.not.dirac).and.atp%norbit_mod>1) then
10302 2 : if(ll==tmp_l(atp%norbit_mod-1)) then
10303 1 : atp%norbit_mod=atp%norbit_mod-1
10304 1 : tmp_occ(atp%norbit_mod)=tmp_occ(atp%norbit_mod)+xocc
10305 1 : go to 30
10306 : endif
10307 : endif
10308 7 : if (atp%norbit_mod>norbit_max) stop 'input_dataset_occ: error -- to many occupation lines!'
10309 7 : tmp_l(atp%norbit_mod)=ll
10310 7 : tmp_n(atp%norbit_mod)=nn
10311 7 : tmp_k(atp%norbit_mod)=kk
10312 7 : tmp_occ(atp%norbit_mod)=xocc
10313 4 : 30 continue
10314 : END DO
10315 4 : IF(ALLOCATED(atp%orbit_mod_l)) then
10316 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_l)
10317 : endif
10318 4 : IF(ALLOCATED(atp%orbit_mod_n)) then
10319 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_n)
10320 : endif
10321 4 : IF(ALLOCATED(atp%orbit_mod_k)) then
10322 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_k)
10323 : endif
10324 4 : IF(ALLOCATED(atp%orbit_mod_occ)) then
10325 0 : LIBPAW_DEALLOCATE(atp%orbit_mod_occ)
10326 : endif
10327 12 : LIBPAW_ALLOCATE(atp%orbit_mod_l,(atp%norbit_mod))
10328 8 : LIBPAW_ALLOCATE(atp%orbit_mod_n,(atp%norbit_mod))
10329 8 : LIBPAW_ALLOCATE(atp%orbit_mod_k,(atp%norbit_mod))
10330 12 : LIBPAW_ALLOCATE(atp%orbit_mod_occ,(atp%norbit_mod))
10331 11 : atp%orbit_mod_l(1:atp%norbit_mod)=tmp_l(1:atp%norbit_mod)
10332 11 : atp%orbit_mod_n(1:atp%norbit_mod)=tmp_n(1:atp%norbit_mod)
10333 11 : atp%orbit_mod_k(1:atp%norbit_mod)=tmp_k(1:atp%norbit_mod)
10334 11 : atp%orbit_mod_occ(1:atp%norbit_mod)=tmp_occ(1:atp%norbit_mod)
10335 : !------------------------------------------------------------------
10336 : !End reading of electronic data. Start reading of core/valence data
10337 : ENDIF
10338 4 : IF (read_coreval_data_) THEN
10339 : !------------------------------------------------------------------
10340 : !=== Core and valence states
10341 : !Read core and valence states
10342 4 : IF (ALLOCATED(atp%orbit_iscore)) then
10343 0 : LIBPAW_DEALLOCATE(atp%orbit_iscore)
10344 : endif
10345 12 : LIBPAW_ALLOCATE(atp%orbit_iscore,(atp%norbit))
10346 4 : jdirac=1
10347 31 : DO io=1,atp%norbit
10348 0 : DO
10349 27 : if(atp%diracrelativistic.and.(.not.dirac)) then
10350 7 : if(jdirac==atp%np(1)+max(atp%np(2)-1,0)) then
10351 3 : do ii=1,max(atp%np(2)-1,0)
10352 2 : READ(input_unit,'(a)') inputline
10353 3 : jdirac=jdirac+1
10354 : enddo
10355 : endif
10356 7 : if(jdirac==atp%np(1)+2*max(atp%np(2)-1,0)+max(atp%np(3)-2,0)) then
10357 2 : do ii=1,max(atp%np(3)-2,0)
10358 1 : READ(input_unit,'(a)') inputline
10359 2 : jdirac=jdirac+1
10360 : enddo
10361 : endif
10362 7 : if(jdirac==atp%np(1)+2*max(atp%np(2)-1,0)+2*max(atp%np(3)-2,0) &
10363 : & +max(atp%np(4)-3,0)) then
10364 1 : do ii=1,max(atp%np(4)-3,0)
10365 0 : READ(input_unit,'(a)') inputline
10366 1 : jdirac=jdirac+1
10367 : enddo
10368 : endif
10369 : endif
10370 27 : READ(input_unit,'(a)') inputline
10371 27 : jdirac=jdirac+1
10372 27 : CALL eliminate_comment(inputline)
10373 27 : READ(inputline,*) CHR
10374 : IF (CHR=='c'.OR.CHR=='C'.OR.&
10375 27 : & CHR=='v'.OR.CHR=='V') THEN
10376 27 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10377 : EXIT
10378 : ELSE
10379 0 : LIBPAW_ERROR('Please input c or v!')
10380 : END IF
10381 : END DO
10382 31 : atp%orbit_iscore(io)=(CHR=='c'.OR.CHR=='C')
10383 : END DO
10384 : !Store valence states
10385 31 : atp%norbit_val=atp%norbit-COUNT(atp%orbit_iscore(:))
10386 4 : IF (ALLOCATED(atp%orbit_val_n)) then
10387 0 : LIBPAW_DEALLOCATE(atp%orbit_val_n)
10388 : endif
10389 4 : IF (ALLOCATED(atp%orbit_val_l)) then
10390 0 : LIBPAW_DEALLOCATE(atp%orbit_val_l)
10391 : endif
10392 4 : IF (ALLOCATED(atp%orbit_val_k)) then
10393 0 : LIBPAW_DEALLOCATE(atp%orbit_val_k)
10394 : endif
10395 12 : LIBPAW_ALLOCATE(atp%orbit_val_n,(atp%norbit_val))
10396 8 : LIBPAW_ALLOCATE(atp%orbit_val_l,(atp%norbit_val))
10397 8 : LIBPAW_ALLOCATE(atp%orbit_val_k,(atp%norbit_val))
10398 4 : kk=0
10399 4 : io=0;nval=0
10400 24 : DO ll=0,4
10401 20 : nn=atp%np(ll+1)
10402 24 : IF (nn>0) THEN
10403 29 : DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic.and.dirac)
10404 14 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10405 12 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) kk=0
10406 49 : DO ii=1+ll,nn
10407 27 : io=io+1
10408 39 : IF (.NOT.atp%orbit_iscore(io)) THEN
10409 14 : nval=nval+1
10410 14 : atp%orbit_val_n(nval)=ii
10411 14 : atp%orbit_val_l(nval)=ll
10412 14 : atp%orbit_val_k(nval)=kk
10413 : END IF
10414 : END DO
10415 : END DO
10416 : END IF
10417 : END DO
10418 4 : IF (atp%norbit_val/=nval) STOP 'input_dataset: bug -- wrong nval!'
10419 : !Print read data
10420 4 : IF (has_to_print) THEN
10421 0 : WRITE(STD_OUT,'(3x,a)') "Core and valence orbitals:"
10422 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) WRITE(STD_OUT,'(7x,a)') "n l : type"
10423 0 : IF (atp%diracrelativistic.and.dirac) WRITE(STD_OUT,'(7x,a)') "n l kappa :type"
10424 0 : io=0
10425 0 : DO ll=0,4
10426 0 : nn=atp%np(ll+1)
10427 0 : IF (nn>0) THEN
10428 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) THEN
10429 0 : DO ii=1+ll,nn
10430 0 : io=io+1
10431 0 : WRITE(STD_OUT,'(7x,i1,1x,i1,2a)') ii,ll," : ", &
10432 0 : & MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
10433 : END DO
10434 : ELSE
10435 0 : DO ik=1,nkappa(ll+1)
10436 0 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10437 0 : DO ii=1+ll,nn
10438 0 : io=io+1
10439 0 : WRITE(STD_OUT,'(7x,i1,1x,i1,2x,i2,2x,2a)') ii,ll,kk," : ", &
10440 0 : & MERGE("CORE ","VALENCE",atp%orbit_iscore(io))
10441 : END DO
10442 : END DO
10443 : END IF
10444 : END IF
10445 : END DO
10446 : END IF
10447 : !------------------------------------------------------------------
10448 : !End reading of AE data. Start reading of basis data
10449 : ENDIF
10450 4 : IF (read_basis_data_) THEN
10451 : !------------------------------------------------------------------
10452 : !=== Maximum L for basis functions
10453 4 : READ(input_unit,'(a)') inputline
10454 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10455 4 : CALL eliminate_comment(inputline)
10456 4 : READ(inputline,*) atp%lmax
10457 : !Print read data
10458 4 : IF (has_to_print) THEN
10459 0 : WRITE(STD_OUT,'(3x,a,i0)') "Basis, maximum L : ",atp%lmax
10460 : END IF
10461 : !------------------------------------------------------------------
10462 : !=== Cut-off radii
10463 4 : READ(input_unit,'(a)') inputline
10464 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10465 4 : CALL eliminate_comment(inputline)
10466 4 : CALL extractword(1,inputline,inputword);inputword=trim(inputword)
10467 4 : IF (inputword/="") READ(inputword,*) atp%rc
10468 4 : IF (atp%rc<=tol12) THEN
10469 0 : LIBPAW_ERROR('input_dataset: error -- rc too small ')
10470 : END IF
10471 4 : CALL extractword(2,inputline,inputword);inputword=trim(inputword)
10472 4 : IF (inputword/="") THEN
10473 4 : READ(inputword,*) atp%rc_shap
10474 4 : CALL extractword(3,inputline,inputword);inputword=trim(inputword)
10475 4 : IF (inputword/="") THEN
10476 4 : READ(inputword,*) atp%rc_vloc
10477 4 : CALL extractword(4,inputline,inputword);inputword=trim(inputword)
10478 4 : IF (inputword/="") THEN
10479 4 : READ(inputword,*) atp%rc_core
10480 : ELSE
10481 0 : LIBPAW_ERROR('input_dataset: error -- rc(core) is missing!')
10482 : END IF
10483 : ELSE
10484 0 : LIBPAW_ERROR('input_dataset: error -- rc(Vloc) is missing!')
10485 : END IF
10486 4 : IF (atp%rc_shap<=tol12.OR.atp%rc_vloc<=tol12.OR.&
10487 : & atp%rc_core<=tol12) THEN
10488 0 : LIBPAW_ERROR('input_dataset: error -- one rc is too small!')
10489 : END IF
10490 4 : IF (atp%rc_shap>atp%rc.OR.atp%rc_vloc>atp%rc.OR.&
10491 : & atp%rc_core>atp%rc) THEN
10492 0 : LIBPAW_ERROR('input_dataset: error -- rc_shape, rc_vloc and rc_core must be <rc!')
10493 : END IF
10494 : ENDIF
10495 4 : IF(atp%rc_shap==zero) atp%rc_shap=atp%rc
10496 4 : IF(atp%rc_vloc==zero) atp%rc_vloc=atp%rc
10497 4 : IF(atp%rc_core==zero) atp%rc_core=atp%rc
10498 : !Print read data
10499 4 : IF (has_to_print) THEN
10500 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Augmentation region radius : ",atp%rc
10501 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Core dens. matching radius : ",atp%rc_core
10502 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Local pot. matching radius : ",atp%rc_vloc
10503 0 : WRITE(STD_OUT,'(3x,a,f7.4)') "Compens. shape func radius : ",atp%rc_shap
10504 : END IF
10505 :
10506 : !------------------------------------------------------------------
10507 : !=== Additional basis functions
10508 4 : nstart=0 ; atp%nbasis_add=0 ; basis_add_k(:)=0
10509 18 : DO ll=0,atp%lmax
10510 14 : nbl=0
10511 14 : nadd = MERGE(nkappa(ll+1),1,atp%diracrelativistic.and.dirac)
10512 : IF (atp%np(ll+1)>0) THEN
10513 14 : nbl=COUNT(.NOT.atp%orbit_iscore(nstart+1:nstart+atp%np(ll+1)-ll))
10514 14 : nstart=nstart+atp%np(ll+1)-ll
10515 : END IF
10516 28 : DO
10517 38 : READ(input_unit,'(a)') inputline
10518 38 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10519 38 : CALL eliminate_comment(inputline)
10520 38 : READ(inputline,*) CHR
10521 38 : IF (CHR/='y'.AND.CHR/='Y') THEN
10522 14 : IF (CHR/='n'.AND.CHR/='N') STOP 'input_dataset: error -- Please enter Y or N!'
10523 : EXIT
10524 : END IF
10525 24 : atp%nbasis_add=atp%nbasis_add+nadd
10526 24 : IF (atp%nbasis_add>nbasis_add_max) STOP 'Too many additional basis functions!'
10527 50 : basis_add_l(atp%nbasis_add-nadd+1:atp%nbasis_add)=ll
10528 24 : IF (atp%diracrelativistic.and.dirac) THEN
10529 2 : basis_add_k(atp%nbasis_add)=-1
10530 2 : IF (ll/=0) THEN
10531 2 : basis_add_k(atp%nbasis_add-1)=ll
10532 2 : basis_add_k(atp%nbasis_add)=-(ll+1)
10533 : END IF
10534 : END IF
10535 24 : READ(input_unit,'(a)') inputline
10536 24 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10537 24 : CALL eliminate_comment(inputline)
10538 24 : READ(inputline,*) basis_add_energy(atp%nbasis_add-nadd+1:atp%nbasis_add)
10539 : END DO
10540 : END DO
10541 4 : IF (ALLOCATED(atp%basis_add_l)) then
10542 0 : LIBPAW_DEALLOCATE(atp%basis_add_l)
10543 : endif
10544 4 : IF (ALLOCATED(atp%basis_add_k)) then
10545 0 : LIBPAW_DEALLOCATE(atp%basis_add_k)
10546 : endif
10547 4 : IF (ALLOCATED(atp%basis_add_energy)) then
10548 0 : LIBPAW_DEALLOCATE(atp%basis_add_energy)
10549 : endif
10550 12 : LIBPAW_ALLOCATE(atp%basis_add_l,(atp%nbasis_add))
10551 8 : LIBPAW_ALLOCATE(atp%basis_add_k,(atp%nbasis_add))
10552 12 : LIBPAW_ALLOCATE(atp%basis_add_energy,(atp%nbasis_add))
10553 4 : IF (atp%nbasis_add>0) THEN
10554 30 : atp%basis_add_l(1:atp%nbasis_add)=basis_add_l(1:atp%nbasis_add)
10555 30 : atp%basis_add_k(1:atp%nbasis_add)=basis_add_k(1:atp%nbasis_add)
10556 30 : atp%basis_add_energy(1:atp%nbasis_add)=basis_add_energy(1:atp%nbasis_add)
10557 : END IF
10558 31 : atp%nbasis=COUNT(.NOT.atp%orbit_iscore(:))+atp%nbasis_add
10559 : !Print read data
10560 4 : IF (has_to_print) THEN
10561 0 : WRITE(STD_OUT,'(3x,a,i0)') "Initial number of basis functions:",atp%nbasis-atp%nbasis_add
10562 0 : WRITE(STD_OUT,'(3x,a,i0)') "Number of additional basis functions:",atp%nbasis_add
10563 0 : WRITE(STD_OUT,'(3x,a,i0)') "Total number of basis functions:",atp%nbasis
10564 0 : WRITE(STD_OUT,'(3x,a)') "Additional basis functions:"
10565 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) THEN
10566 0 : WRITE(STD_OUT,'(7x,a)') "l : energy"
10567 0 : DO io=1,atp%nbasis_add
10568 0 : WRITE(STD_OUT,'(7x,i1,a,f7.4)') atp%basis_add_l(io)," :",atp%basis_add_energy(io)
10569 : END DO
10570 : ELSE
10571 0 : WRITE(STD_OUT,'(7x,a)') "l kappa : energy"
10572 0 : DO io=1,atp%nbasis_add
10573 0 : WRITE(STD_OUT,'(7x,i1,2x,i2,2x,a,f7.4)') atp%basis_add_l(io), &
10574 0 : & atp%basis_add_k(io)," : " ,atp%basis_add_energy(io)
10575 : END DO
10576 : END IF
10577 : END IF
10578 : !------------------------------------------------------------------
10579 : !=== Projectors, compensation charge shape function, core tolerance
10580 4 : READ(input_unit,'(a)') inputline
10581 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10582 4 : CALL eliminate_comment(inputline)
10583 4 : CALL Uppercase(inputline)
10584 : inputline=TRIM(inputline)
10585 4 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL
10586 4 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10587 4 : atp%pseudo_polynom2_pdeg=polynom2_pdeg_def
10588 4 : atp%pseudo_polynom2_qcut=polynom2_qcut_def
10589 4 : atp%shapefunc_type=SHAPEFUNC_TYPE_SINC
10590 4 : atp%shapefunc_gaussian_param=gausstol_def
10591 4 : atp%hf_coretol=hf_coretol_def
10592 4 : READ(unit=inputline,fmt=*) inputword
10593 4 : IF (TRIM(inputword)=='BLOECHL'.OR.TRIM(inputword)=='VNCT') THEN
10594 0 : atp%projector_type=PROJECTOR_TYPE_BLOECHL
10595 0 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL
10596 0 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10597 4 : ELSE IF (TRIM(inputword)=='VNCK') THEN
10598 0 : atp%projector_type=PROJECTOR_TYPE_BLOECHL
10599 0 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL_K
10600 0 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10601 4 : ELSE IF (TRIM(inputword)=='VANDERBILT'.OR.TRIM(inputword)=='VNCTV') THEN
10602 2 : atp%projector_type=PROJECTOR_TYPE_VANDERBILT
10603 2 : atp%pseudo_type=PSEUDO_TYPE_POLYNOM
10604 2 : atp%ortho_type=ORTHO_TYPE_VANDERBILT
10605 2 : ELSE IF(TRIM(inputword)=='MODRRKJ') THEN
10606 0 : atp%projector_type=PROJECTOR_TYPE_MODRRKJ
10607 0 : atp%pseudo_type=PSEUDO_TYPE_RRKJ
10608 0 : atp%ortho_type=ORTHO_TYPE_VANDERBILT
10609 : IF (INDEX(inputline,'VANDERBILTORTHO')>0)atp%ortho_type=ORTHO_TYPE_VANDERBILT
10610 0 : IF (INDEX(inputline,'GRAMSCHMIDTORTHO')>0)atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10611 0 : IF (INDEX(inputline,'SVDORTHO')>0) atp%ortho_type=ORTHO_TYPE_SVD
10612 2 : ELSE IF (TRIM(inputword)=='CUSTOM') THEN
10613 2 : atp%projector_type=PROJECTOR_TYPE_CUSTOM
10614 2 : IF (INDEX(inputline,'BLOECHLPS')>0) THEN
10615 0 : atp%pseudo_type=PSEUDO_TYPE_BLOECHL
10616 0 : atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10617 2 : ELSE IF (INDEX(inputline,'POLYNOM2')>0) THEN
10618 0 : atp%pseudo_type=PSEUDO_TYPE_POLYNOM2
10619 0 : nstart=INDEX(inputline,'POLYNOM2')
10620 : READ(unit=inputline(nstart+8:),fmt=*,err=111,end=111,iostat=io) &
10621 0 : & atp%pseudo_polynom2_pdeg,atp%pseudo_polynom2_qcut
10622 : 111 CONTINUE
10623 2 : ELSE IF (INDEX(inputline,'POLYNOM')>0) THEN
10624 0 : atp%pseudo_type=PSEUDO_TYPE_POLYNOM
10625 2 : ELSE IF (INDEX(inputline,'RRKJ')>0) THEN
10626 2 : atp%pseudo_type=PSEUDO_TYPE_RRKJ
10627 : END IF
10628 2 : IF (INDEX(inputline,'VANDERBILTORTHO')>0)atp%ortho_type=ORTHO_TYPE_VANDERBILT
10629 2 : IF (INDEX(inputline,'GRAMSCHMIDTORTHO')>0)atp%ortho_type=ORTHO_TYPE_GRAMSCHMIDT
10630 : END IF
10631 4 : IF (TRIM(atp%exctype)=='HF') THEN
10632 0 : atp%projector_type=PROJECTOR_TYPE_HF
10633 0 : atp%pseudo_type=PSEUDO_TYPE_HF
10634 0 : atp%ortho_type=ORTHO_TYPE_HF
10635 0 : if(has_to_print) WRITE(STD_OUT,'(3x,a)') '>> You are using HF XC type: pseudo and orthogonalization line will be ignored!'
10636 : END IF
10637 : IF ((atp%pseudo_type==PSEUDO_TYPE_BLOECHL.OR. &
10638 : & atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10639 4 : & .AND.atp%ortho_type==ORTHO_TYPE_VANDERBILT) STOP &
10640 0 : & 'input_dataset: error -- Vanderbilt orthogonalization not compatible with Bloechls projector scheme!'
10641 : IF ((atp%pseudo_type==PSEUDO_TYPE_BLOECHL.OR. &
10642 : & atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10643 4 : & .AND.atp%ortho_type==ORTHO_TYPE_VANDERBILT) STOP &
10644 0 : & 'input_dataset: error -- Vanderbilt orthogonalization not compatible with Bloechls projector scheme!'
10645 : IF ((atp%projector_type==PROJECTOR_TYPE_BLOECHL) &
10646 4 : & .AND.atp%needvtau) STOP &
10647 0 : & 'input_dataset: error -- mGGA not compatible the Bloechl projector scheme!'
10648 : !!!! Hopefully this will never happen
10649 : IF ((atp%projector_type==PROJECTOR_TYPE_HF) &
10650 4 : & .AND.atp%needvtau) STOP &
10651 0 : & 'input_dataset: error -- mGGA and Hartree-Fock are not compatible!'
10652 : IF ((atp%pseudo_type==PSEUDO_TYPE_BLOECHL.OR. &
10653 : & atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10654 4 : & .AND.atp%needvtau) STOP &
10655 0 : & 'input_dataset: error -- mGGA not compatible the Bloechl pseudization scheme!'
10656 4 : IF (INDEX(inputline,'SINC2')>0) THEN
10657 0 : atp%shapefunc_type=SHAPEFUNC_TYPE_SINC
10658 4 : ELSE IF (INDEX(inputline,'GAUSSIAN')>0) THEN
10659 0 : atp%shapefunc_type=SHAPEFUNC_TYPE_GAUSSIAN
10660 0 : nstart=INDEX(inputline,'GAUSSIAN')
10661 : READ(unit=inputline(nstart+8:),fmt=*,err=222,end=222,iostat=io) &
10662 0 : & atp%shapefunc_gaussian_param
10663 : 222 CONTINUE
10664 4 : ELSE IF (INDEX(inputline,'BESSELSHAPE')>0) THEN
10665 0 : atp%shapefunc_type=SHAPEFUNC_TYPE_BESSEL
10666 : END IF
10667 4 : nstart=INDEX(inputline,'CORETOL')
10668 4 : IF (nstart>0) THEN
10669 0 : READ(unit=inputline(nstart+7:),fmt=*) atp%hf_coretol
10670 : END IF
10671 4 : atp%shapetcore=(INDEX(inputline,'SHAPETCORE')>0)
10672 : !Print read data
10673 4 : IF (has_to_print) THEN
10674 0 : WRITE(STD_OUT,'(3x,a)') "Projectors description:"
10675 0 : IF (atp%projector_type==PROJECTOR_TYPE_BLOECHL) &
10676 0 : & WRITE(STD_OUT,'(7x,a)') "Type : BLOECHL"
10677 0 : IF (atp%projector_type==PROJECTOR_TYPE_VANDERBILT) &
10678 0 : & WRITE(STD_OUT,'(7x,a)') "Type : VANDERBILT"
10679 0 : IF (atp%projector_type==PROJECTOR_TYPE_MODRRKJ) &
10680 0 : & WRITE(STD_OUT,'(7x,a)') "Type : MODRRKJ"
10681 0 : IF (atp%projector_type==PROJECTOR_TYPE_CUSTOM) &
10682 0 : & WRITE(STD_OUT,'(7x,a)') "Type : CUSTOM"
10683 0 : IF (atp%projector_type==PROJECTOR_TYPE_HF) &
10684 0 : & WRITE(STD_OUT,'(7x,a)') "Type : HARTREE-FOCK"
10685 0 : IF (atp%projector_type/=PROJECTOR_TYPE_HF) THEN
10686 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL) &
10687 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL"
10688 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM) &
10689 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : POLYNOM"
10690 0 : IF (atp%pseudo_type==PSEUDO_TYPE_RRKJ) &
10691 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : RRKJ"
10692 0 : IF (atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) &
10693 0 : & WRITE(STD_OUT,'(7x,a)') "Pseudization : BLOECHL KERKER"
10694 0 : IF (atp%pseudo_type==PSEUDO_TYPE_POLYNOM2) &
10695 0 : & WRITE(STD_OUT,'(7x,a,i0,a,es9.3)') "Pseudization : POLYNOM2,pdeg=",&
10696 0 : & atp%pseudo_polynom2_pdeg,", qcut=",atp%pseudo_polynom2_qcut
10697 0 : IF (atp%ortho_type==ORTHO_TYPE_GRAMSCHMIDT) &
10698 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : GRAM-SCHMIDT"
10699 0 : IF (atp%ortho_type==ORTHO_TYPE_VANDERBILT) &
10700 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : VANDERBILT"
10701 0 : IF (atp%ortho_type==ORTHO_TYPE_SVD) &
10702 0 : & WRITE(STD_OUT,'(7x,a)') "Orthogonalisation : SVD"
10703 : END IF
10704 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_GAUSSIAN) &
10705 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Compensation charge shape function : GAUSSIAN, tol=",&
10706 0 : & atp%shapefunc_gaussian_param
10707 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_SINC) &
10708 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : SINC2"
10709 0 : IF (atp%shapefunc_type==SHAPEFUNC_TYPE_BESSEL) &
10710 0 : & WRITE(STD_OUT,'(3x,a)') "Compensation charge shape function : BESSEL"
10711 0 : IF (INDEX(inputline,'CORETOL')>0) &
10712 0 : & WRITE(STD_OUT,'(3x,a,es9.3)') "Core tolerance for Hartree-Fock:",atp%hf_coretol
10713 0 : WRITE(STD_OUT,'(3x,2a)') "Smooth tcore shape (no negative nhat):",MERGE("YES"," NO",atp%shapetcore)
10714 : END IF
10715 : !------------------------------------------------------------------
10716 : !=== Local pseudopotential
10717 4 : READ(input_unit,'(a)') inputline
10718 4 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10719 4 : CALL eliminate_comment(inputline)
10720 4 : call Uppercase(inputline)
10721 : inputline=TRIM(inputline)
10722 4 : atp%vloc_type=VLOC_TYPE_MTROULLIER
10723 4 : atp%vloc_l=-1
10724 4 : atp%vloc_ene=0._dp
10725 4 : atp%vloc_setvloc_coef=0._dp
10726 4 : atp%vloc_setvloc_rad=atp%rc
10727 20 : atp%vloc_kerker_power(:)=0
10728 4 : IF (INDEX(inputline,'MTROULLIER')>0) THEN
10729 : atp%vloc_type=VLOC_TYPE_MTROULLIER
10730 4 : ELSE IF (INDEX(inputline,'ULTRASOFT')>0) THEN
10731 0 : atp%vloc_type=VLOC_TYPE_ULTRASOFT
10732 4 : ELSE IF (INDEX(inputline,'BESSEL')>0) THEN
10733 0 : atp%vloc_type=VLOC_TYPE_BESSEL
10734 4 : ELSE IF (INDEX(inputline,'VPSMATCHNC')>0) THEN
10735 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNC
10736 4 : ELSE IF (INDEX(inputline,'VPSMATCHNNC')>0) THEN
10737 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNNC
10738 4 : ELSE IF (INDEX(inputline,'SETVLOC')>0) THEN
10739 0 : atp%vloc_type=VLOC_TYPE_SETVLOC
10740 0 : nstart=INDEX(inputline,'SETVLOC')
10741 0 : READ(unit=inputline(nstart+8:),fmt=*,err=333,end=333,iostat=io) x1,x2
10742 0 : IF (x1<10._dp**3.AND.x1>-10._dp**3) atp%vloc_setvloc_coef=x1
10743 0 : IF (x2>tol8.AND.x2<atp%rc) atp%vloc_setvloc_rad=x2
10744 : 333 CONTINUE
10745 4 : ELSE IF (INDEX(inputline,'KERKER')>0.OR.atp%pseudo_type==PSEUDO_TYPE_BLOECHL_K) THEN
10746 0 : IF (INDEX(inputline,'EXPF')>0) THEN
10747 0 : atp%vloc_type=VLOC_TYPE_KERKER_EXPF
10748 0 : nstart=INDEX(inputline,'EXPF')
10749 0 : ELSE IF (INDEX(inputline,'POLY')>0) THEN
10750 0 : atp%vloc_type=VLOC_TYPE_KERKER_POLY
10751 0 : nstart=INDEX(inputline,'POLY')
10752 : ELSE
10753 0 : STOP "EXPF or POLY keyword missing!"
10754 : END IF
10755 : READ(unit=inputline(nstart+5:),fmt=*,err=334,end=334,iostat=io) &
10756 0 : & atp%vloc_kerker_power(1:4)
10757 : 334 CONTINUE
10758 : END IF
10759 : IF ((atp%vloc_type==VLOC_TYPE_SETVLOC.OR. &
10760 : & atp%vloc_type==VLOC_TYPE_KERKER_EXPF.OR. &
10761 : & atp%vloc_type==VLOC_TYPE_KERKER_POLY) &
10762 4 : & .AND.atp%needvtau) STOP &
10763 0 : & 'input_dataset: error -- mGGA not compatible the chosen Vloc scheme!'
10764 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.OR. &
10765 : & atp%vloc_type==VLOC_TYPE_VPSMATCHNC.OR. &
10766 4 : & atp%vloc_type==VLOC_TYPE_VPSMATCHNNC.OR. &
10767 : & atp%vloc_type==VLOC_TYPE_ULTRASOFT) THEN
10768 4 : READ(unit=inputline,fmt=*,err=444,end=444,iostat=io) atp%vloc_l,atp%vloc_ene
10769 : 444 CONTINUE
10770 4 : IF (atp%vloc_l<0.or.atp%vloc_l>10) STOP 'input_dataset: error while reading Vloc parameters!'
10771 : END IF
10772 4 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.AND.atp%needvtau) then
10773 0 : if(has_to_print) WRITE(STD_OUT,'(7x,a)') 'NOTE: MTROULLIER Vloc not available for mGGA!'
10774 0 : if(has_to_print) WRITE(STD_OUT,'(7x,a)') ' Calling VPSmatch with norm conservation instead.'
10775 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNC
10776 : ENDIF
10777 : !Print read data
10778 4 : IF (has_to_print) THEN
10779 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER) &
10780 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type : MTROULLIER,l=",&
10781 0 : & atp%vloc_l,", energy=",atp%vloc_ene
10782 0 : IF (atp%vloc_type==VLOC_TYPE_ULTRASOFT) &
10783 0 : & WRITE(STD_OUT,'(7x,a,i0,a,f7.4)') "Local pseudopotential type : ULTRASOFT,l=",&
10784 0 : & atp%vloc_l,", energy=",atp%vloc_ene
10785 0 : IF (atp%vloc_type==VLOC_TYPE_BESSEL) &
10786 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : BESSEL"
10787 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNC) &
10788 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
10789 0 : IF (atp%vloc_type==VLOC_TYPE_VPSMATCHNNC) &
10790 0 : & WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNNC"
10791 0 : IF (atp%vloc_type==VLOC_TYPE_SETVLOC) THEN
10792 0 : WRITE(STD_OUT,'(7x,a,es9.4,a,es9.4)') "Local pseudopotential type :SETVLOC, coef=",&
10793 0 : & atp%vloc_setvloc_coef,", rad=",atp%vloc_setvloc_rad
10794 0 : IF (atp%needvtau) THEN
10795 0 : LIBPAW_ERROR('SETVLOC option not available for MGGA')
10796 : ENDIF
10797 : ENDIF
10798 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_EXPF) &
10799 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER EXPF,powers=",&
10800 0 : & atp%vloc_kerker_power(1:4)
10801 0 : IF (atp%vloc_type==VLOC_TYPE_KERKER_POLY) &
10802 0 : & WRITE(STD_OUT,'(7x,a,4(1x,i0))') "Local pseudopotential type : KERKER POLY,powers=",&
10803 0 : & atp%vloc_kerker_power(1:4)
10804 0 : IF (atp%vloc_type==VLOC_TYPE_MTROULLIER.AND.atp%needvtau) THEN
10805 0 : WRITE(STD_OUT,'(7x,a)') 'NOTE: MTROULLIER Vloc not available for mGGA!'
10806 0 : WRITE(STD_OUT,'(7x,a)') ' Calling VPSmatch with norm conservation instead.'
10807 0 : atp%vloc_type=VLOC_TYPE_VPSMATCHNC
10808 0 : WRITE(STD_OUT,'(7x,a)') "Local pseudopotential type : VPS MATCHNC"
10809 : END IF
10810 : END IF
10811 :
10812 :
10813 :
10814 :
10815 :
10816 :
10817 :
10818 : !------------------------------------------------------------------
10819 : !=== Matching radii for the basis functions
10820 : !Not for all choice of projectors
10821 : IF (atp%projector_type==PROJECTOR_TYPE_CUSTOM.OR.&
10822 : & atp%projector_type==PROJECTOR_TYPE_VANDERBILT.OR.&
10823 4 : & atp%projector_type==PROJECTOR_TYPE_MODRRKJ.OR.&
10824 : & atp%projector_type==PROJECTOR_TYPE_HF.AND.atp%vloc_type==VLOC_TYPE_MTROULLIER)THEN
10825 4 : IF (ALLOCATED(atp%basis_func_rc)) then
10826 0 : LIBPAW_DEALLOCATE(atp%basis_func_rc)
10827 : endif
10828 12 : LIBPAW_ALLOCATE(atp%basis_func_rc,(atp%nbasis))
10829 4 : norb=0
10830 18 : DO ll=0,atp%lmax
10831 44 : DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic)
10832 18 : if((.not.dirac).and.(ik>1)) cycle
10833 18 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10834 16 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) kk=0
10835 74 : DO io=1,atp%norbit_val
10836 58 : IF (atp%orbit_val_l(io)==ll.AND. &
10837 16 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%orbit_val_k(io)==kk)) THEN
10838 14 : norb=norb+1
10839 14 : READ(input_unit,'(a)') inputline
10840 14 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10841 14 : CALL eliminate_comment(inputline)
10842 14 : READ(inputline,*) atp%basis_func_rc(norb)
10843 : END IF
10844 : END DO
10845 30 : IF (atp%nbasis_add>0) THEN
10846 122 : DO io=1,atp%nbasis_add
10847 106 : IF (atp%basis_add_l(io)==ll.AND. &
10848 16 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%basis_add_k(io)==kk)) THEN
10849 26 : norb=norb+1
10850 26 : READ(input_unit,'(a)') inputline
10851 26 : IF (has_to_echo) WRITE(ecunit,'(a)') TRIM(inputline)
10852 26 : CALL eliminate_comment(inputline)
10853 26 : READ(inputline,*) atp%basis_func_rc(norb)
10854 : END IF
10855 : END DO
10856 : END IF
10857 : END DO
10858 : END DO
10859 4 : IF (atp%nbasis/=norb) STOP 'input_dataset: error -- inconsistency in the number of basis functions!'
10860 : ! Print read data
10861 4 : IF (has_to_print) THEN
10862 0 : WRITE(STD_OUT,'(3x,a)') "Matching radius for basis functions:"
10863 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) WRITE(STD_OUT,'(7x,a)') " # - n l : radius"
10864 0 : IF (atp%diracrelativistic.and.dirac) WRITE(STD_OUT,'(7x,a)') " # - n l kappa : radius"
10865 0 : norb=0
10866 0 : DO ll=0,atp%lmax
10867 0 : DO ik=1,MERGE(nkappa(ll+1),1,atp%diracrelativistic.and.dirac)
10868 0 : kk=MERGE(ll,-(ll+1),ik==1);IF (ll==0) kk=-1
10869 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) kk=0
10870 0 : DO io=1,atp%norbit_val
10871 0 : IF (atp%orbit_val_l(io)==ll.AND. &
10872 0 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%orbit_val_k(io)==kk))THEN
10873 0 : norb=norb+1
10874 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) &
10875 : & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,a,f7.4)') &
10876 0 : & norb," - ",atp%orbit_val_n(io),ll," :",atp%basis_func_rc(norb)
10877 0 : IF (atp%diracrelativistic.and.dirac) &
10878 : & WRITE(STD_OUT,'(7x,i2,a,i1,1x,i1,2x,i2,2x,a,f7.4)') &
10879 0 : & norb," - ",atp%orbit_val_n(io),ll,kk," :",atp%basis_func_rc(norb)
10880 : END IF
10881 : END DO
10882 0 : IF (atp%nbasis_add>0) THEN
10883 0 : DO io=1,atp%nbasis_add
10884 0 : IF (atp%basis_add_l(io)==ll.AND. &
10885 0 : & (((.NOT.atp%diracrelativistic).or.(.not.dirac)).OR.atp%basis_add_k(io)==kk))THEN
10886 0 : norb=norb+1
10887 0 : IF ((.NOT.atp%diracrelativistic).or.(.not.dirac)) &
10888 : & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,a,f7.4)') &
10889 0 : & norb," - ",".",ll," : ",atp%basis_func_rc(norb)
10890 0 : IF (atp%diracrelativistic.and.dirac) &
10891 : & WRITE(STD_OUT,'(7x,i2,a,a1,1x,i1,2x,i2,2x,a,f7.4)') &
10892 0 : & norb," - ",".",ll,kk," : ",atp%basis_func_rc(norb)
10893 : END IF
10894 : END DO
10895 : END IF
10896 : END DO
10897 : END DO
10898 : END IF
10899 : ELSE ! Other projectors
10900 0 : IF (ALLOCATED(atp%basis_func_rc)) then
10901 0 : LIBPAW_DEALLOCATE(atp%basis_func_rc)
10902 : endif
10903 0 : LIBPAW_ALLOCATE(atp%basis_func_rc,(0))
10904 : END IF
10905 : !------------------------------------------------------------------
10906 : !End reading of basis data
10907 : ENDIF
10908 : !Final message
10909 4 : IF(read_global_data_.OR.read_elec_data_.OR.read_coreval_data_.OR.read_basis_data_)THEN
10910 4 : if(has_to_print) WRITE(STD_OUT,'(3x,a)') "===== END READING OF INPUT FILE ====="
10911 : END IF
10912 4 : if(has_to_print) WRITE(STD_OUT,'(2/)')
10913 : !------------------------------------------------------------------
10914 : ! Checks
10915 4 : READ(input_unit,'(a)') inputline
10916 4 : READ(input_unit,'(a)') inputline
10917 4 : CALL Uppercase(inputline)
10918 4 : i_usexcnhat=INDEX(inputline,'USEXCNHAT')
10919 4 : i_logspline=INDEX(inputline,'WITHSPLGRID')
10920 4 : i_rsoptim =INDEX(inputline,'RSOPTIM')
10921 4 : i_lda12 =INDEX(inputline,'LDA12')
10922 4 : if(i_usexcnhat>0.or.i_logspline>0.or.i_rsoptim>0.or.i_lda12>0) then
10923 0 : LIBPAW_ERROR('RCPAW not compatible with usexcnhat, logspline, rsoptim, lda12')
10924 : endif
10925 : !Close files
10926 4 : CLOSE(ifunit)
10927 4 : IF (has_to_echo) THEN
10928 4 : CLOSE(ecunit)
10929 : END IF
10930 4 : END SUBROUTINE input_dataset_read
10931 :
10932 :
10933 :
10934 :
10935 :
10936 :
10937 :
10938 :
10939 :
10940 :
10941 :
10942 :
10943 :
10944 :
10945 :
10946 :
10947 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! xmlinterface !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
10948 :
10949 :
10950 : !!=================================================================
10951 : !! NAME
10952 : !! xmlprtcore
10953 : !!
10954 : !! FUNCTION
10955 : !! Write the core wave functions in XML format
10956 : !!
10957 : !! INPUTS
10958 : !! fname=file name (with .xml suffixe)
10959 : !! mesh_data= datatructure containing the definition of
10960 : !! all the radial meshes used in the XML file
10961 : !!
10962 : !! PARENTS
10963 : !! atompaw2xml
10964 : !!
10965 : !! CHILDREN
10966 : !!
10967 : !!=================================================================
10968 :
10969 1 : SUBROUTINE xmlprtcore(fname,atp,zcore,mesh_data,input_string)
10970 :
10971 : character(len=*),intent(in) :: fname
10972 : type(atompaw_type),intent(in) :: atp
10973 : real(dp) ,intent(in) :: zcore
10974 : TYPE(mesh_data_type),intent(in) :: mesh_data
10975 : character(len=*), intent(in) :: input_string
10976 :
10977 : !------------------------------------------------------------------
10978 : !---- Local variables
10979 : !------------------------------------------------------------------
10980 :
10981 : integer :: core_size,corewf_meshsz,ib,icor,ii,ir,nmesh,nsppol
10982 : integer :: unit_xml_core
10983 : real(dp) :: radstp0,logstp0
10984 2 : character(len=3) :: gridt(mesh_data%nmesh)
10985 : character(len=4) :: char4
10986 : character(len=5) :: char5a
10987 : character(len=20) :: char20,char21
10988 : character(len=1) :: char_orb(4)
10989 1 : integer,allocatable :: irwf(:)
10990 1 : real(dp),allocatable :: dum(:)
10991 :
10992 : !------------------------------------------------------------------
10993 : !---- Executable code
10994 : !------------------------------------------------------------------
10995 1 : unit_xml_core=1113
10996 : !Hard-coded values, spin unrestricted
10997 : !Spinors or collinear magnetism not yet supported
10998 1 : nsppol=1
10999 1 : char_orb(1)="s";char_orb(2)="p";char_orb(3)="d";char_orb(4)="f"
11000 : !Open file for writing
11001 1 : OPEN(unit_xml_core,file=TRIM(fname),form='formatted')
11002 :
11003 : !Write XML header
11004 1 : WRITE(unit_xml_core,'("<?xml version=""1.0""?>")')
11005 1 : WRITE(unit_xml_core,'("<paw_setup version=""0.7"">")')
11006 :
11007 : !Write title
11008 1 : WRITE(unit_xml_core,'(/,"<!-- All-electron core wavefunctions for ",a," -->")')trim(ADJUSTL(atp%Pot%sym))
11009 :
11010 : !Write Atompaw information
11011 1 : WRITE(unit_xml_core,'("<!-- ",a)') trim('GENERATED by RC-PAW')
11012 1 : WRITE(unit_xml_core,'(" Energy units=Hartree, length units=bohr")')
11013 1 : WRITE(unit_xml_core,'("-->",/)')
11014 :
11015 : !Write atom definition
11016 1 : WRITE(unit=char5a,fmt='(f5.2)') atp%Pot%zz
11017 : WRITE(unit_xml_core,'("<atom symbol=""",a,""" Z=""",a)',ADVANCE='NO') &
11018 1 : & trim(ADJUSTL(atp%Pot%sym)),trim(ADJUSTL(char5a))
11019 1 : WRITE(unit=char5a,fmt='(f5.2)') zcore
11020 1 : WRITE(unit_xml_core,'(""" core=""",a,"""/>")')trim(ADJUSTL(char5a))
11021 :
11022 :
11023 : !!Write XC definition
11024 : ! call get_xc_data(xc_type,xc_name)
11025 : ! if (have_libxc.and.xc_type/="UNKNOWN") then
11026 : ! call libxc_getshortname(xc_name,xcname_short)
11027 : ! call get_xc_alias(xcname_short,xc_name)
11028 : ! endif
11029 : ! WRITE(unit_xml_core,'("<xc_functional type=""",a,""" name=""",a,"""/>")') &
11030 : !& TRIM(xc_type),TRIM(xc_name)
11031 :
11032 :
11033 : !Generator data
11034 1 : if (atp%scalarrelativistic) then
11035 1 : WRITE(unit_xml_core,'("<generator type=""scalar-relativistic"" name=""atompaw"">")')
11036 0 : else if (atp%diracrelativistic) then
11037 0 : WRITE(unit_xml_core,'("<generator type=""dirac-relativistic"" name=""atompaw"">")')
11038 : else
11039 0 : WRITE(unit_xml_core,'("<generator type=""non-relativistic"" name=""atompaw"">")')
11040 : endif
11041 1 : WRITE(unit_xml_core,'("</generator>)")')
11042 :
11043 : !Number of core orbitals (not needed)
11044 8 : core_size=count(atp%Orbit%iscore(1:atp%Orbit%norbit))
11045 : !WRITE(unit_xml_core,'("<orbitals norbs=""",i2,"""/>")') core_size
11046 :
11047 : !Read mesh size
11048 1 : ii=0
11049 3 : LIBPAW_ALLOCATE(irwf,(core_size))
11050 4 : irwf(:)=mesh_data%meshsz(mesh_data%iwavmesh)
11051 8 : do ib=1,atp%Orbit%norbit
11052 8 : if (atp%Orbit%iscore(ib)) then
11053 3 : ii=ii+1;ir=mesh_data%meshsz(mesh_data%iwavmesh)+1
11054 1688 : do while (ir>1)
11055 1688 : ir=ir-1
11056 1688 : if (abs(atp%Orbit%wfn(ir,ib))>tol10) then
11057 3 : irwf(ii)=min(ir+1,mesh_data%meshsz(mesh_data%iwavmesh));ir=1
11058 : end if
11059 : end do
11060 : end if
11061 : end do
11062 1 : corewf_meshsz=maxval(irwf(1:core_size))
11063 1 : LIBPAW_DEALLOCATE(irwf)
11064 5 : corewf_meshsz=maxval(mesh_data%meshsz(1:mesh_data%nmesh))
11065 : !Electronic configuration
11066 1 : WRITE(unit_xml_core,'("<core_states>")')
11067 1 : icor=0
11068 8 : do ib=1,atp%Orbit%norbit
11069 8 : if (atp%Orbit%iscore(ib)) then
11070 3 : icor=icor+1;if (icor>core_size) stop ' Bug (1) in xmlprtcore!'
11071 3 : call mkname(icor,char4)
11072 3 : char20=stripchar('"'//atp%Pot%sym//'_core'//char4//'"')
11073 3 : if(atp%diracrelativistic) then
11074 : WRITE(unit_xml_core,'(" <state n=""",i2,""" l=""",i1,""" kappa=""",i2,""" f=""",1pe14.7)',ADVANCE='NO')&
11075 0 : & atp%Orbit%np(ib),atp%Orbit%l(ib),atp%Orbit%kappa(ib),atp%Orbit%occ(ib)
11076 : else
11077 : WRITE(unit_xml_core,'(" <state n=""",i2,""" l=""",i1,""" f=""",1pe14.7)',ADVANCE='NO')&
11078 3 : & atp%Orbit%np(ib),atp%Orbit%l(ib),atp%Orbit%occ(ib)
11079 : endif
11080 : WRITE(unit_xml_core,'(""" e=""",1pe14.7,""" id=",a11,"/>")')&
11081 3 : & atp%Orbit%eig(ib)*0.5d0,TRIM(char20)
11082 : end if
11083 : enddo
11084 1 : WRITE(unit_xml_core,'("</core_states>")')
11085 :
11086 : !Radial meshes definitions
11087 1 : nmesh=1
11088 2 : do ii=1,nmesh
11089 3 : LIBPAW_ALLOCATE(dum,(corewf_meshsz))
11090 1 : select case(mesh_data%meshtp(ii))
11091 : case(1)
11092 0 : char21='r=d*i'
11093 0 : gridt(ii)="lin"
11094 0 : radstp0=zero
11095 0 : logstp0=mesh_data%radstp(ii)
11096 0 : dum(:)=logstp0
11097 : case(2)
11098 1 : char21='r=a*(exp(d*i)-1)'
11099 1 : gridt(ii)="log"
11100 1 : radstp0=mesh_data%radstp(ii)
11101 1 : logstp0=mesh_data%logstp(ii)
11102 2002 : dum(1:corewf_meshsz)=logstp0*(radstp0+atp%Grid%r(1:corewf_meshsz))
11103 : case default
11104 1 : stop ' Bug (2) in xmlprtcore: mesh type not implemented in Atompaw!'
11105 : end select
11106 1 : WRITE(unit_xml_core,'("<radial_grid eq=""",a,""" a=""",es23.16)',ADVANCE='NO')trim(char21),radstp0
11107 : WRITE(unit_xml_core,'(""" d=""",es23.16,""" istart=""0"" iend=""",i5)',ADVANCE='NO') &
11108 1 : & logstp0,corewf_meshsz-1
11109 1 : WRITE(unit_xml_core,'(""" id=""",a,i1,"""/>")') gridt(ii),ii
11110 1 : WRITE(unit_xml_core,'(" <values>")')
11111 2002 : WRITE(unit_xml_core,'(3(1x,es23.16))') (atp%Grid%r(ir),ir=1,corewf_meshsz)
11112 1 : WRITE(unit_xml_core,'(" </values>")')
11113 1 : WRITE(unit_xml_core,'(" <derivatives>")')
11114 1 : WRITE(unit_xml_core,'(3(1x,es23.16))') (dum(ir),ir=1,corewf_meshsz)
11115 1 : WRITE(unit_xml_core,'(" </derivatives>")')
11116 2 : LIBPAW_DEALLOCATE(dum)
11117 : end do
11118 :
11119 : !Write the core wave functions
11120 1 : icor=0
11121 8 : do ib=1,atp%Orbit%norbit
11122 8 : if (atp%Orbit%iscore(ib)) then
11123 3 : icor=icor+1;if (icor>core_size) stop 'Bug (3) in xmlprtcore!'
11124 3 : call mkname(atp%Orbit%np(ib),char4)
11125 3 : char20=stripchar('"'//atp%Pot%sym//char4//char_orb(atp%Orbit%l(ib)+1)//'"')
11126 : WRITE(unit_xml_core,'("<ae_core_wavefunction state=",a6," grid=""",a,i1,""">")') &
11127 3 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11128 9 : LIBPAW_ALLOCATE(dum,(mesh_data%meshsz(mesh_data%iwavmesh)))
11129 6006 : dum=zero
11130 : dum(2:mesh_data%meshsz(mesh_data%iwavmesh))= &
11131 : & atp%Orbit%wfn(2:mesh_data%meshsz(mesh_data%iwavmesh),ib) &
11132 6003 : & /atp%Grid%r(2:mesh_data%meshsz(mesh_data%iwavmesh))
11133 3 : call extrapolate(dum)
11134 3 : WRITE(unit_xml_core,'(3(1x,es23.16))') (dum(ir),ir=1,corewf_meshsz)
11135 3 : LIBPAW_DEALLOCATE(dum)
11136 3 : WRITE(unit_xml_core,'("</ae_core_wavefunction>")')
11137 : end if ! if icore
11138 : end do !ib
11139 :
11140 : !Write the core lwave functions
11141 1 : if(atp%diracrelativistic) then
11142 0 : icor=0
11143 0 : do ib=1,atp%Orbit%norbit
11144 0 : if (atp%Orbit%iscore(ib)) then
11145 0 : icor=icor+1;if (icor>core_size) stop ' Bug (4) in xmlprtcore!'
11146 0 : call mkname(atp%Orbit%np(ib),char4)
11147 0 : char20=stripchar('"'//atp%Pot%sym//char4//char_orb(atp%Orbit%l(ib)+1)//'"')
11148 : WRITE(unit_xml_core,'("<ae_core_lwavefunction state=",a6," grid=""",a,i1,""">")') &
11149 0 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11150 0 : LIBPAW_ALLOCATE(dum,(mesh_data%meshsz(mesh_data%iwavmesh)))
11151 0 : dum=zero
11152 : dum(2:mesh_data%meshsz(mesh_data%iwavmesh))= &
11153 : & atp%Orbit%lwfn(2:mesh_data%meshsz(mesh_data%iwavmesh),ib) &
11154 0 : & /atp%Grid%r(2:mesh_data%meshsz(mesh_data%iwavmesh))
11155 0 : call extrapolate(dum)
11156 0 : WRITE(unit_xml_core,'(3(1x,es23.16))') (dum(ir),ir=1,corewf_meshsz)
11157 0 : LIBPAW_DEALLOCATE(dum)
11158 0 : WRITE(unit_xml_core,'("</ae_core_lwavefunction>")')
11159 : end if ! if icore
11160 : end do !ib
11161 : end if ! diracrelativistic
11162 :
11163 : !Echi input file content
11164 1 : WRITE(unit_xml_core,'("<!-- Program: atompaw - input data follows: ")')
11165 1 : WRITE(unit_xml_core,'(a)') trim(input_string)
11166 1 : WRITE(unit_xml_core,'(a)') "XMLOUT"
11167 1 : WRITE(unit_xml_core,'(a)') "prtcorewf"
11168 1 : WRITE(unit_xml_core,'(a)') "END"
11169 1 : WRITE(unit_xml_core,'(" Program: atompaw - input end -->")')
11170 1 : WRITE(unit_xml_core,'("</paw_setup>")')
11171 :
11172 : !Close the file
11173 1 : close(unit_xml_core)
11174 1 : WRITE(STD_OUT,'(/,2x,a)') 'XML core orbitals file created.'
11175 :
11176 1 : end subroutine xmlprtcore
11177 :
11178 :
11179 : !!=================================================================
11180 : !! NAME
11181 : !! build_mesh_data
11182 : !!
11183 : !! FUNCTION
11184 : !! Determine meshes definitions
11185 : !! (if necessary define a logarithmic radial grid)
11186 : !!
11187 : !! INPUTS
11188 : !! Grid=grid datastructure in AtomPAW format
11189 : !! irc=index of rc in Grid
11190 : !!
11191 : !! OUTPUT
11192 : !! mesh_data
11193 : !! Data defining various meshes
11194 : !!
11195 : !! PARENTS
11196 : !!
11197 : !!=================================================================
11198 :
11199 1 : subroutine build_mesh_data(mesh_data,Grid,irc,ivion,ivale,coretailpoints,itau)
11200 :
11201 : type(mesh_data_type),intent(out) :: mesh_data
11202 : type(GridInfo),intent(in) :: Grid
11203 : integer, optional, intent(in) :: irc,ivion,ivale,coretailpoints,itau
11204 :
11205 : !------------------------------------------------------------------
11206 : !---- Local variables
11207 : !------------------------------------------------------------------
11208 :
11209 : integer, parameter :: nmesh_max=10
11210 : integer :: ii1
11211 : logical :: aeonly=.true.
11212 :
11213 : !------------------------------------------------------------------
11214 : !---- Executable code
11215 : !------------------------------------------------------------------
11216 :
11217 1 : LIBPAW_ALLOCATE(mesh_data%meshtp,(nmesh_max))
11218 1 : LIBPAW_ALLOCATE(mesh_data%meshsz,(nmesh_max))
11219 1 : LIBPAW_ALLOCATE(mesh_data%radstp,(nmesh_max))
11220 1 : LIBPAW_ALLOCATE(mesh_data%logstp,(nmesh_max))
11221 :
11222 : !Mesh definition
11223 1 : if (Grid%type==loggrid) then
11224 1 : mesh_data%mesh_type=2
11225 1 : mesh_data%rad_step=Grid%drdu(1)
11226 1 : mesh_data%log_step=Grid%h
11227 : else
11228 0 : mesh_data%mesh_type=1
11229 0 : mesh_data%rad_step=Grid%h
11230 0 : mesh_data%log_step=zero
11231 : end if
11232 :
11233 1 : if (PRESENT(irc).and.PRESENT(ivion).and.PRESENT(ivale).and.PRESENT(coretailpoints).and.PRESENT(itau)) then
11234 1 : aeonly=.false.
11235 : endif
11236 :
11237 : !Various mesh sizes
11238 1 : if (Grid%type==loggrid) then
11239 1 : mesh_data%wav_meshsz=Grid%n
11240 1 : if (.not.aeonly) then
11241 1 : mesh_data%sph_meshsz=min(1+nint(log(one+Grid%r(irc)/mesh_data%rad_step)/mesh_data%log_step),mesh_data%wav_meshsz)
11242 : else
11243 0 : mesh_data%sph_meshsz=Grid%n
11244 : endif
11245 : else
11246 0 : if (.not.aeonly) then
11247 0 : mesh_data%wav_meshsz=irc+Grid%ishift
11248 0 : mesh_data%sph_meshsz=min(1+nint(Grid%r(irc)/mesh_data%rad_step),mesh_data%wav_meshsz)
11249 : else
11250 0 : mesh_data%wav_meshsz=Grid%n
11251 0 : mesh_data%sph_meshsz=Grid%n
11252 : endif
11253 : endif
11254 1 : mesh_data%prj_meshsz=mesh_data%sph_meshsz ! To be modified by RSO
11255 :
11256 1 : if (.not.aeonly) then
11257 1 : mesh_data%core_meshsz=coretailpoints
11258 1 : mesh_data%vale_meshsz=ivale
11259 1 : mesh_data%tau_meshsz=itau
11260 1 : mesh_data%vion_meshsz=ivion
11261 : else
11262 0 : mesh_data%core_meshsz=Grid%n
11263 0 : mesh_data%vale_meshsz=Grid%n
11264 0 : mesh_data%tau_meshsz=Grid%n
11265 0 : mesh_data%vion_meshsz=Grid%n
11266 : endif
11267 :
11268 1 : if (mesh_data%vion_meshsz<=0) then
11269 1 : if (mesh_data%mesh_type==1) then
11270 0 : ii1=int(one+rmax_vloc/mesh_data%rad_step)
11271 : else
11272 1 : ii1=int(log(one+rmax_vloc/mesh_data%rad_step)/mesh_data%log_step)+1
11273 : endif
11274 1 : mesh_data%vion_meshsz=max(mesh_data%sph_meshsz,mesh_data%core_meshsz,ii1)
11275 : endif
11276 :
11277 1 : mesh_data%vlda12_meshsz=max(mesh_data%vale_meshsz,mesh_data%vion_meshsz)
11278 :
11279 : !Mesh for vbare should be inside augmentation region
11280 : !For compatibility with other codes, could put it to the same mesh
11281 : !as ionic potential
11282 : !mesh_data%vbare_meshsz=mesh_data%vion_meshsz
11283 1 : mesh_data%vbare_meshsz=mesh_data%sph_meshsz
11284 :
11285 1 : mesh_data%prj_msz_max=four*mesh_data%sph_meshsz
11286 :
11287 : !=== Build mesh definitions ===
11288 :
11289 21 : mesh_data%meshtp=-1;mesh_data%meshsz=0
11290 21 : mesh_data%radstp=zero;mesh_data%logstp=zero
11291 :
11292 : !Partial waves
11293 1 : mesh_data%nmesh=1
11294 1 : mesh_data%iwavmesh=1
11295 1 : mesh_data%meshtp(1)=mesh_data%mesh_type
11296 1 : mesh_data%meshsz(1)=mesh_data%wav_meshsz
11297 1 : mesh_data%radstp(1)=mesh_data%rad_step
11298 1 : mesh_data%logstp(1)=mesh_data%log_step
11299 : !Projectors
11300 1 : if (mesh_data%wav_meshsz/=mesh_data%prj_meshsz) then
11301 1 : mesh_data%nmesh=mesh_data%nmesh+1
11302 1 : mesh_data%iprjmesh=mesh_data%nmesh
11303 1 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11304 1 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%prj_meshsz
11305 1 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11306 1 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11307 : else
11308 0 : mesh_data%iprjmesh=mesh_data%iwavmesh
11309 : endif
11310 : !Core density
11311 1 : if (mesh_data%wav_meshsz/=mesh_data%core_meshsz) then
11312 1 : if (mesh_data%prj_meshsz/=mesh_data%core_meshsz) then
11313 1 : mesh_data%nmesh=mesh_data%nmesh+1
11314 1 : mesh_data%icoremesh=mesh_data%nmesh
11315 1 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11316 1 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%core_meshsz
11317 1 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11318 1 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11319 : else
11320 0 : mesh_data%icoremesh=mesh_data%iprjmesh
11321 : endif
11322 : else
11323 0 : mesh_data%icoremesh=mesh_data%iwavmesh
11324 : endif
11325 : !Local ionic potential
11326 1 : if (mesh_data%wav_meshsz/=mesh_data%vion_meshsz) then
11327 1 : if(mesh_data%prj_meshsz/=mesh_data%vion_meshsz) then
11328 1 : if(mesh_data%core_meshsz/=mesh_data%vion_meshsz) then
11329 1 : mesh_data%nmesh=mesh_data%nmesh+1
11330 1 : mesh_data%ivionmesh=mesh_data%nmesh
11331 1 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11332 1 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vion_meshsz
11333 1 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11334 1 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11335 : else
11336 0 : mesh_data%ivionmesh=mesh_data%icoremesh
11337 : endif
11338 : else
11339 0 : mesh_data%ivionmesh=mesh_data%iprjmesh
11340 : endif
11341 : else
11342 0 : mesh_data%ivionmesh=mesh_data%iwavmesh
11343 : endif
11344 : !Local vbare potential
11345 1 : if (mesh_data%wav_meshsz/=mesh_data%vbare_meshsz) then
11346 : if(mesh_data%prj_meshsz/=mesh_data%vbare_meshsz) then
11347 : if(mesh_data%core_meshsz/=mesh_data%vbare_meshsz) then
11348 : if(mesh_data%vion_meshsz/=mesh_data%vbare_meshsz) then
11349 : mesh_data%nmesh=mesh_data%nmesh+1
11350 : mesh_data%ivbaremesh=mesh_data%nmesh
11351 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11352 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vbare_meshsz
11353 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11354 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11355 : else
11356 : mesh_data%ivbaremesh=mesh_data%ivionmesh
11357 : endif
11358 : else
11359 : mesh_data%ivbaremesh=mesh_data%icoremesh
11360 : endif
11361 : else
11362 1 : mesh_data%ivbaremesh=mesh_data%iprjmesh
11363 : endif
11364 : else
11365 0 : mesh_data%ivbaremesh=mesh_data%iwavmesh
11366 : endif
11367 : !Valence density
11368 1 : if (mesh_data%wav_meshsz/=mesh_data%vale_meshsz) then
11369 1 : if(mesh_data%prj_meshsz/=mesh_data%vale_meshsz) then
11370 1 : if(mesh_data%core_meshsz/=mesh_data%vale_meshsz) then
11371 0 : if(mesh_data%vion_meshsz/=mesh_data%vale_meshsz) then
11372 : if(mesh_data%vbare_meshsz/=mesh_data%vale_meshsz) then
11373 0 : mesh_data%nmesh=mesh_data%nmesh+1
11374 0 : mesh_data%ivalemesh=mesh_data%nmesh
11375 0 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11376 0 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vale_meshsz
11377 0 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11378 0 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11379 : else
11380 : mesh_data%ivalemesh=mesh_data%ivbaremesh
11381 : endif
11382 : else
11383 0 : mesh_data%ivalemesh=mesh_data%ivionmesh
11384 : endif
11385 : else
11386 1 : mesh_data%ivalemesh=mesh_data%icoremesh
11387 : endif
11388 : else
11389 0 : mesh_data%ivalemesh=mesh_data%iprjmesh
11390 : endif
11391 : else
11392 0 : mesh_data%ivalemesh=mesh_data%iwavmesh
11393 : endif
11394 : !Kinetic energy density
11395 1 : if (mesh_data%wav_meshsz/=mesh_data%tau_meshsz) then
11396 1 : if(mesh_data%prj_meshsz/=mesh_data%tau_meshsz) then
11397 1 : if(mesh_data%core_meshsz/=mesh_data%tau_meshsz) then
11398 0 : if(mesh_data%vion_meshsz/=mesh_data%tau_meshsz) then
11399 : if(mesh_data%vbare_meshsz/=mesh_data%tau_meshsz) then
11400 0 : if(mesh_data%vale_meshsz/=mesh_data%tau_meshsz) then
11401 0 : mesh_data%nmesh=mesh_data%nmesh+1
11402 0 : mesh_data%itaumesh=mesh_data%nmesh
11403 0 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11404 0 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%tau_meshsz
11405 0 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11406 0 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11407 : else
11408 0 : mesh_data%itaumesh=mesh_data%ivalemesh
11409 : endif
11410 : else
11411 : mesh_data%itaumesh=mesh_data%ivbaremesh
11412 : endif
11413 : else
11414 0 : mesh_data%itaumesh=mesh_data%ivionmesh
11415 : endif
11416 : else
11417 1 : mesh_data%itaumesh=mesh_data%icoremesh
11418 : endif
11419 : else
11420 0 : mesh_data%itaumesh=mesh_data%iprjmesh
11421 : endif
11422 : else
11423 0 : mesh_data%itaumesh=mesh_data%iwavmesh
11424 : endif
11425 : !LDA-1/2 potential
11426 1 : if (mesh_data%wav_meshsz/=mesh_data%vlda12_meshsz) then
11427 1 : if(mesh_data%prj_meshsz/=mesh_data%vlda12_meshsz) then
11428 1 : if(mesh_data%core_meshsz/=mesh_data%vlda12_meshsz) then
11429 1 : if(mesh_data%vion_meshsz/=mesh_data%vlda12_meshsz) then
11430 : if(mesh_data%vbare_meshsz/=mesh_data%vlda12_meshsz) then
11431 : if(mesh_data%vale_meshsz/=mesh_data%vlda12_meshsz) then
11432 : if(mesh_data%tau_meshsz/=mesh_data%vlda12_meshsz) then
11433 : mesh_data%nmesh=mesh_data%nmesh+1
11434 : mesh_data%ivlda12mesh=mesh_data%nmesh
11435 : mesh_data%meshtp(mesh_data%nmesh)=mesh_data%mesh_type
11436 : mesh_data%meshsz(mesh_data%nmesh)=mesh_data%vlda12_meshsz
11437 : mesh_data%radstp(mesh_data%nmesh)=mesh_data%rad_step
11438 : mesh_data%logstp(mesh_data%nmesh)=mesh_data%log_step
11439 : else
11440 : mesh_data%ivlda12mesh=mesh_data%itaumesh
11441 : endif
11442 : else
11443 0 : mesh_data%ivlda12mesh=mesh_data%ivalemesh
11444 : endif
11445 : else
11446 : mesh_data%ivlda12mesh=mesh_data%ivbaremesh
11447 : endif
11448 : else
11449 1 : mesh_data%ivlda12mesh=mesh_data%ivionmesh
11450 : endif
11451 : else
11452 0 : mesh_data%ivlda12mesh=mesh_data%icoremesh
11453 : endif
11454 : else
11455 0 : mesh_data%ivlda12mesh=mesh_data%iprjmesh
11456 : endif
11457 : else
11458 0 : mesh_data%ivlda12mesh=mesh_data%iwavmesh
11459 : endif
11460 :
11461 1 : end subroutine build_mesh_data
11462 :
11463 :
11464 1 : subroutine destroy_mesh_data(mesh_data)
11465 :
11466 : type(mesh_data_type),intent(inout) :: mesh_data
11467 :
11468 : !------------------------------------------------------------------
11469 : !---- Executable code
11470 : !------------------------------------------------------------------
11471 :
11472 1 : if (allocated(mesh_data%meshtp)) then
11473 1 : LIBPAW_DEALLOCATE(mesh_data%meshtp)
11474 : endif
11475 1 : if (allocated(mesh_data%meshsz)) then
11476 1 : LIBPAW_DEALLOCATE(mesh_data%meshsz)
11477 : endif
11478 1 : if (allocated(mesh_data%radstp)) then
11479 1 : LIBPAW_DEALLOCATE(mesh_data%radstp)
11480 : endif
11481 1 : if (allocated(mesh_data%logstp)) then
11482 1 : LIBPAW_DEALLOCATE(mesh_data%logstp)
11483 : endif
11484 :
11485 1 : end subroutine destroy_mesh_data
11486 :
11487 :
11488 :
11489 : !!=================================================================
11490 : !! NAME
11491 : !! xmloutput
11492 : !!
11493 : !! FUNCTION
11494 : !! Write the PAW data file in XML format
11495 : !!
11496 : !! INPUTS
11497 : !! fname=file name (with .xml suffixe)
11498 : !! Grid= Grid datastructure from atompaw
11499 : !! AESCF= AESCF datastructure from atompaw
11500 : !! AEPOT= AEPOT datastructure from atompaw
11501 : !! PAW= PAW datastructure from atompaw
11502 : !! ORB= ORB datastructure from atompaw
11503 : !! mesh_data= datatructure containing the definition of
11504 : !! all the radial meshes used in the XML file
11505 : !! tproj(prj_msz_max,nbase)= PAW projectors
11506 : !! (might be modified by real space optimization)
11507 : !! vlocopt= option for local potential (1=Blochl, 2=Kresse)
11508 : !! input_string= string containing a copy of atompaw input file
11509 : !! author= string containing the author(s) name
11510 : !! comment= additional comment line to be printed in the header (usually table
11511 : !version)
11512 : !! nsplgrid=if >0, size of a (reduced) grid on which interpolate all data in XML
11513 : !file
11514 : !! pawlda12
11515 : !! %uselda12=TRUE if LDA-1/2 potential calculation is required
11516 : !! %rcut=LDA-1/2 parameter: cut-off radius (in bohr)
11517 : !! %pot(:)=LDA-1/2 parameter: local potential used to apply LDA-1/2 method
11518 : !!
11519 : !! PARENTS
11520 : !! atompaw2xml
11521 : !!
11522 : !! CHILDREN
11523 : !!
11524 : !!=================================================================
11525 0 : subroutine xmloutput(fname,Grid,AESCF,AEPot,Orb,PAW,mesh_data,tproj,&
11526 : & vlocopt,input_string,author,comment,nsplgrid,zcore,atp)
11527 : integer,intent(in) :: vlocopt,nsplgrid
11528 : character(len=*),intent(in) :: input_string,author,comment,fname
11529 : real(dp), intent(in) :: zcore
11530 : TYPE(Gridinfo),intent(in) :: Grid
11531 : TYPE (SCFInfo),intent(in) :: AESCF
11532 : TYPE(Potentialinfo),intent(in) :: AEPot
11533 : TYPE (OrbitInfo),intent(in) :: Orb
11534 : TYPE(Pseudoinfo),intent(in) :: PAW
11535 : type(atompaw_type),intent(in) :: atp
11536 : ! TYPE(pawlda12_type),intent(in) :: pawlda12
11537 : TYPE(mesh_data_type),intent(inout) :: mesh_data
11538 : real(dp),intent(in) :: tproj(:,:)
11539 : !------------------------------------------------------------------
11540 : !---- Local variables
11541 : !------------------------------------------------------------------
11542 : real(dp), parameter :: tol_zero=1.d-50 ! Threshold below which quantities are zero
11543 : integer :: ib,ic,ii,n,n_aux,ir,irc_aux,meshsz,meshsz_aux,meshst_aux,nmesh
11544 0 : integer :: mesh_start(mesh_data%nmesh),mesh_size(mesh_data%nmesh)
11545 : integer :: unit_xml=1234
11546 : logical :: extra1
11547 : character(len=4) :: char4
11548 : character(len=5) :: char5a,char5b,xc_type
11549 : character(len=20) :: char20
11550 : character(len=132) :: xc_name,xcname_short,code_name
11551 : real(dp) :: sqr4pi,radstp0,logstp0,radstp_spl,logstp_spl
11552 0 : character(len=3) :: gridt(mesh_data%nmesh)
11553 0 : real(dp),allocatable :: dum(:),dum_aux(:),rad_aux(:),dudr(:)
11554 0 : real(dp),allocatable :: phi_aux(:,:),tphi_aux(:,:),proj_aux(:,:)
11555 : TYPE(Gridinfo) :: Grid1
11556 : !------------------------------------------------------------------
11557 : !---- Executable code
11558 : !------------------------------------------------------------------
11559 : !Some defs
11560 0 : sqr4pi=sqrt(4*pi)
11561 0 : n=Grid%n
11562 0 : LIBPAW_ALLOCATE(dum,(n))
11563 0 : extra1=.false.
11564 :
11565 : !In a change of grid has been requested, determine new grid data
11566 0 : radstp_spl=-1.d0 ; logstp_spl=-1.d0
11567 0 : if (nsplgrid>0) then
11568 0 : write(std_out,'(/,2x,a,/,2x,a,i5,a)') 'Atompaw2XML info:',&
11569 0 : & ' All quantities will be interpolated on a ',nsplgrid,'-point log. grid.'
11570 0 : n_aux=nsplgrid
11571 0 : logstp_spl=0.02d0
11572 0 : call findh(AEPot%zz,Grid%r(mesh_data%meshsz(1)-1),nsplgrid,logstp_spl,radstp_spl)
11573 0 : irc_aux=int(tol8+log(1.d0+PAW%rc/radstp_spl)/logstp_spl)+1
11574 0 : radstp_spl= PAW%rc/(exp(logstp_spl*(irc_aux-1))-1.d0)
11575 0 : extra1=(Grid%r(mesh_data%meshsz(1))<radstp_spl*(exp(logstp_spl*(nsplgrid-1))-1.d0))
11576 0 : if (extra1) then
11577 0 : n_aux=n_aux+1
11578 0 : logstp_spl=0.02d0
11579 0 : call findh(AEPot%zz,Grid%r(mesh_data%meshsz(1)-1),nsplgrid+1,logstp_spl,radstp_spl)
11580 0 : irc_aux=int(tol8+log(1.d0+PAW%rc/radstp_spl)/logstp_spl)+1
11581 0 : radstp_spl= PAW%rc/(exp(logstp_spl*(irc_aux-1))-1.d0)
11582 : end if
11583 0 : LIBPAW_ALLOCATE(rad_aux,(n_aux))
11584 0 : LIBPAW_ALLOCATE(dum_aux,(n_aux))
11585 0 : call InitGrid(Grid1,logstp_spl,Grid%range,r0=radstp_spl,do_not_print=.true.)
11586 0 : rad_aux(1:nsplgrid)=Grid1%r(1:nsplgrid)
11587 : else
11588 0 : LIBPAW_ALLOCATE(rad_aux,(n))
11589 0 : LIBPAW_ALLOCATE(dum_aux,(n))
11590 0 : rad_aux(1:n)=Grid%r(1:n)
11591 0 : irc_aux=PAW%irc
11592 : end if
11593 :
11594 : !Open file for writing
11595 0 : OPEN(unit_xml,file=TRIM(fname),form='formatted')
11596 :
11597 : !Write XML header
11598 0 : WRITE(unit_xml,'("<?xml version=""1.0""?>")')
11599 0 : WRITE(unit_xml,'("<paw_dataset version=""0.7"">")')
11600 0 : WRITE(unit_xml,'("<!-- PAW-XML specification: http://esl.cecam.org/Paw-xml-->")')
11601 :
11602 : !Write title
11603 0 : WRITE(unit_xml,'(/,"<!-- PAW atomic dataset for ",a," -->")')trim(ADJUSTL(AEPot%sym))
11604 :
11605 : !Write additional comment line (usually table version)
11606 0 : if (trim(comment)/="") WRITE(unit_xml,'("<!-- ",a," -->")') trim(comment)
11607 :
11608 : !Write Atompaw information
11609 0 : WRITE(unit_xml,'(/,"<!-- ",a)')
11610 0 : WRITE(unit_xml,'(" Energy units=Hartree, length units=bohr")')
11611 0 : if (trim(author)/="") WRITE(unit_xml,'(a,a)') ' by ',trim(author)
11612 0 : WRITE(unit_xml,'(" The input file is available at the end of this file")')
11613 0 : WRITE(unit_xml,'("-->",/)')
11614 :
11615 : !Write atom definition
11616 0 : WRITE(unit=char5a,fmt='(f5.2)') AEPot%zz
11617 : WRITE(unit_xml,'("<atom symbol=""",a,""" Z=""",a)',ADVANCE='NO') &
11618 0 : & trim(ADJUSTL(AEPot%sym)),trim(ADJUSTL(char5a))
11619 0 : WRITE(unit=char5a,fmt='(f5.2)') zcore
11620 0 : WRITE(unit=char5b,fmt='(f5.2)') AEPot%nz-zcore
11621 : WRITE(unit_xml,'(""" core=""",a,""" valence=""",a,"""/>")') &
11622 0 : & trim(ADJUSTL(char5a)),trim(ADJUSTL(char5b))
11623 :
11624 : !Write XC definition
11625 0 : call get_xc_data(atp,xc_type,xc_name)
11626 0 : if (atp%itype==LIBXC.and.xc_type/="UNKNOWN") then
11627 0 : xcname_short= libxc_functionals_fullname(atp%xc_functionals)
11628 0 : call uppercase(xcname_short)
11629 0 : call get_xc_alias(xcname_short,xc_name)
11630 : endif
11631 : WRITE(unit_xml,'("<xc_functional type=""",a,""" name=""",a,"""/>")') &
11632 0 : & TRIM(xc_type),TRIM(xc_name)
11633 0 : code_name="rcpaw"
11634 :
11635 : !Generator data
11636 0 : if (atp%scalarrelativistic) then
11637 : WRITE(unit_xml,'("<generator type=""scalar-relativistic"" name=""",a,""" orthogonalisation=""", a,"""/>")')&
11638 0 : & TRIM(code_name),"marsman"
11639 : ! else if (diracrelativistic) then
11640 : ! WRITE(unit_xml,'("<generator type=""dirac-relativistic"" name=""",a,""" orthogonalisation=""", a,"""/>")')&
11641 : !& TRIM(code_name),trim(PAW%orthogonalization_scheme)
11642 : else
11643 : WRITE(unit_xml,'("<generator type=""non-relativistic"" name=""",a,""" orthogonalisation=""", a,"""/>")')&
11644 0 : & TRIM(code_name),"marsman"
11645 : endif
11646 :
11647 : !Energies
11648 : WRITE(unit_xml,'("<ae_energy kinetic=""",1pe25.17,""" xc=""",1pe25.17,"""")') &
11649 0 : & AESCF%ekin/2,AESCF%eexc/2
11650 : WRITE(unit_xml,'(" electrostatic=""",1pe25.17,""" total=""",1pe25.17,"""/>")')&
11651 0 : & AESCF%estatic/2,AESCF%etot/2
11652 0 : WRITE(unit_xml,'("<core_energy kinetic=""",1pe25.17,"""/>")') AESCF%corekin*0.5d0
11653 :
11654 : !PAW radius
11655 0 : WRITE(unit_xml,'("<paw_radius rc=""",f17.14,"""/>")') match_on_splgrid(PAW%rc)
11656 :
11657 : !Electronic configuration
11658 0 : WRITE(unit_xml,'("<valence_states>")')
11659 0 : do ib=1,PAW%nbase
11660 0 : call mkname(ib,char4)
11661 0 : char20=stripchar('"'//AEPot%sym//char4//'"')
11662 0 : ii=min(ABS(PAW%np(ib)),100)
11663 0 : if (ii<100) then
11664 : ! if(diracrelativistic) then
11665 : ! WRITE(unit_xml,'(" <state n=""",i2,""" l=""",i1,""" kappa=""",i2,""" f=""",1pe14.7)',ADVANCE='NO')&
11666 : !& ii,PAW%l(ib),PAW%kappa(ib),Orb%occ(ib)
11667 : ! else
11668 : WRITE(unit_xml,'(" <state n=""",i2,""" l=""",i1,""" f=""",1pe14.7)',ADVANCE='NO')&
11669 0 : & ii,PAW%l(ib),PAW%occ(ib)
11670 : ! end if
11671 : WRITE(unit_xml,'(""" rc=""",f13.10,""" e=""",1pe14.7,""" id=",a6,"/>")')&
11672 0 : & match_on_splgrid(PAW%rcio(ib)),PAW%eig(ib)*0.5d0,TRIM(char20)
11673 : else
11674 : ! if(diracrelativistic) then
11675 : ! WRITE(unit_xml,'(" <state l=""",i1,""" kappa=""",i2)',ADVANCE='NO')PAW%l(ib),PAW%kappa(ib)
11676 : ! else
11677 0 : WRITE(unit_xml,'(" <state l=""",i1)',ADVANCE='NO') PAW%l(ib)
11678 : ! end if
11679 : WRITE(unit_xml,'(""" rc=""",f13.10,""" e=""",1pe14.7,""" id=",a6,"/>")')&
11680 0 : & match_on_splgrid(PAW%rcio(ib)),PAW%eig(ib)*0.5d0,TRIM(char20)
11681 : end if
11682 : enddo
11683 0 : WRITE(unit_xml,'("</valence_states>")')
11684 :
11685 : !Radial meshes definitions
11686 0 : nmesh=mesh_data%nmesh
11687 0 : if(maxval(mesh_data%meshtp(1:mesh_data%nmesh))==minval(mesh_data%meshtp(1:mesh_data%nmesh)))then
11688 0 : mesh_data%meshsz(1:mesh_data%nmesh)=maxval(mesh_data%meshsz(1:mesh_data%nmesh))
11689 0 : nmesh=1
11690 0 : mesh_data%icoremesh=1
11691 0 : mesh_data%itaumesh=1
11692 0 : mesh_data%iprjmesh=1
11693 0 : mesh_data%iwavmesh=1
11694 0 : mesh_data%ivionmesh=1
11695 0 : mesh_data%ivalemesh=1
11696 0 : mesh_data%ivbaremesh=1
11697 0 : mesh_data%ivlda12mesh=1
11698 : endif
11699 0 : if (nmesh>1.and.nsplgrid>0) stop ' Bug (1) in xmlinterface: nmesh>1 and nsplgrid>0!'
11700 :
11701 0 : do ii=1,nmesh
11702 0 : LIBPAW_ALLOCATE(dudr,(mesh_data%meshsz(ii)))
11703 0 : select case(mesh_data%meshtp(ii))
11704 : case(1)
11705 0 : char20='r=d*i'
11706 0 : gridt(ii)="lin"
11707 0 : mesh_start(ii)=1
11708 0 : mesh_size(ii)=mesh_data%meshsz(ii)
11709 0 : radstp0=zero
11710 0 : logstp0=mesh_data%radstp(ii)
11711 0 : dudr(1:mesh_data%meshsz(ii))=logstp0
11712 :
11713 : case(2)
11714 0 : char20='r=a*(exp(d*i)-1)'
11715 0 : gridt(ii)="log"
11716 0 : mesh_start(ii)=1
11717 0 : if (nsplgrid<=0) then
11718 0 : mesh_size(ii)=mesh_data%meshsz(ii)
11719 0 : radstp0=mesh_data%radstp(ii)
11720 0 : logstp0=mesh_data%logstp(ii)
11721 : else
11722 0 : mesh_size(ii)=nsplgrid
11723 0 : radstp0=radstp_spl
11724 0 : logstp0=logstp_spl
11725 : end if
11726 0 : dudr(1:mesh_size(ii))=logstp0*(radstp0+rad_aux(1:mesh_size(ii)))
11727 :
11728 : case default
11729 0 : stop ' Bug (2) in xmlinterface: mesh type not implemented in Atompaw!'
11730 : end select
11731 :
11732 0 : WRITE(unit_xml,'("<radial_grid eq=""",a,""" a=""",es23.16)',ADVANCE='NO')trim(char20),radstp0
11733 0 : WRITE(unit_xml,'(""" d=""",es23.16,""" istart=""0"" iend=""",i5)',ADVANCE='NO')logstp0,mesh_size(ii)-mesh_start(ii)
11734 0 : WRITE(unit_xml,'(""" id=""",a,i1,""">")') gridt(ii),ii
11735 0 : WRITE(unit_xml,'(" <values>")')
11736 0 : WRITE(unit_xml,'(3(1x,es23.16))') (rad_aux(ir),ir=mesh_start(ii),mesh_size(ii))
11737 0 : WRITE(unit_xml,'(" </values>")')
11738 0 : WRITE(unit_xml,'(" <derivatives>")')
11739 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dudr(ir),ir=mesh_start(ii),mesh_size(ii))
11740 0 : WRITE(unit_xml,'(" </derivatives>")')
11741 0 : WRITE(unit_xml,'("</radial_grid>")')
11742 0 : LIBPAW_DEALLOCATE(dudr)
11743 :
11744 : end do
11745 :
11746 : !Compensation charge shape function
11747 0 : if (atp%gaussianshapefunction) then
11748 0 : WRITE(unit_xml,'("<shape_function type=""gauss"" rc=""",f19.16,"""/>")')match_on_splgrid(PAW%gausslength)
11749 0 : else if (atp%besselshapefunction) then
11750 0 : WRITE(unit_xml,'("<shape_function type=""bessel"" rc=""",f19.16,"""/>")')match_on_splgrid(PAW%rc_shap)
11751 : else
11752 0 : WRITE(unit_xml,'("<shape_function type=""sinc"" rc=""",f19.16,"""/>")')match_on_splgrid(PAW%rc_shap)
11753 : endif
11754 :
11755 : !Core densities
11756 0 : meshsz=mesh_data%meshsz(mesh_data%icoremesh)
11757 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%icoremesh),extra1)
11758 0 : meshst_aux=mesh_start(mesh_data%icoremesh)
11759 0 : dum(2:meshsz)=sqr4pi*Orb%coreden(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11760 0 : call extrapolate(dum(1:meshsz))
11761 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11762 : WRITE(unit_xml,'("<ae_core_density grid=""",a,i1,""">")') &
11763 0 : & gridt(mesh_data%icoremesh),mesh_data%icoremesh
11764 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11765 0 : WRITE(unit_xml,'("</ae_core_density>")')
11766 0 : dum(2:meshsz)=sqr4pi*PAW%tcore(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11767 0 : call extrapolate(dum(1:meshsz))
11768 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11769 : WRITE(unit_xml,'("<pseudo_core_density grid=""",a,i1,""" rc=""",f19.16,""">")')&
11770 0 : & gridt(mesh_data%icoremesh),mesh_data%icoremesh,match_on_splgrid(PAW%rc_core)
11771 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11772 0 : WRITE(unit_xml,'("</pseudo_core_density>")')
11773 :
11774 : !!Kinetic energy core densities
11775 : !!Available in scalar relativistic (although approximate)
11776 : ! if (.true.) then
11777 : ! meshsz=mesh_data%meshsz(mesh_data%itaumesh)
11778 : ! meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%itaumesh),extra1)
11779 : ! meshst_aux=mesh_start(mesh_data%itaumesh)
11780 : ! dum(2:meshsz)= half*sqr4pi*FC%coretau(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11781 : ! call extrapolate(Grid,dum(1:meshsz))
11782 : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11783 : ! WRITE(unit_xml,'("<ae_core_kinetic_energy_density grid=""",a,i1,""" rc=""",f19.16,""">")') &
11784 : !& gridt(mesh_data%itaumesh),mesh_data%itaumesh,match_on_splgrid(PAW%rc_core)
11785 : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11786 : ! WRITE(unit_xml,'("</ae_core_kinetic_energy_density>")')
11787 : ! dum(2:meshsz)= half*sqr4pi*PAW%tcoretau(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11788 : ! call extrapolate(Grid,dum(1:meshsz))
11789 : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11790 : ! WRITE(unit_xml,'("<pseudo_core_kinetic_energy_density grid=""",a,i1,""" rc=""",f19.16,""">")') &
11791 : !& gridt(mesh_data%itaumesh),mesh_data%itaumesh,match_on_splgrid(PAW%rc_core)
11792 : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11793 : ! WRITE(unit_xml,'("</pseudo_core_kinetic_energy_density>")')
11794 : ! else
11795 : ! write(std_out,'(5(/,2x,a))') 'Atompaw2XML WARNING!!!!!',&
11796 : !& ' Kinetic energy core density is not available',&
11797 : !& ' within scalar relativistic scheme!',&
11798 : !& ' Will not be present in the XML dataset.',&
11799 : !& ' This is temporary, sorry!'
11800 : ! end if
11801 :
11802 : !!Valence density
11803 : ! meshsz=mesh_data%meshsz(mesh_data%ivalemesh)
11804 : ! meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivalemesh),extra1)
11805 : ! meshst_aux=mesh_start(mesh_data%ivalemesh)
11806 : ! dum(2:meshsz)=sqr4pi*PAW%tden(2:meshsz)/(4*pi*Grid%r(2:meshsz)**2)
11807 : ! call extrapolate(dum(1:meshsz))
11808 : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11809 : ! rad=maxval(PAW%rcio(1:PAW%nbase))
11810 : ! WRITE(unit_xml,'("<pseudo_valence_density grid=""",a,i1,""" rc=""",f19.16,""">")') &
11811 : !& gridt(mesh_data%ivalemesh),mesh_data%ivalemesh,match_on_splgrid(rad)
11812 : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11813 : ! WRITE(unit_xml,'("</pseudo_valence_density>")')
11814 :
11815 : !Vbare potential
11816 0 : meshsz=mesh_data%meshsz(mesh_data%ivbaremesh)
11817 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivbaremesh),extra1)
11818 0 : meshst_aux=mesh_start(mesh_data%ivbaremesh)
11819 0 : dum(1:meshsz)=sqr4pi*half*PAW%vloc(1:meshsz)
11820 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11821 0 : dum_aux(irc_aux:meshsz_aux)=0.d0 ! Vbare has to be zero at rc
11822 : WRITE(unit_xml,'("<zero_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11823 0 : & gridt(mesh_data%ivbaremesh),mesh_data%ivbaremesh,match_on_splgrid(PAW%rc)
11824 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11825 0 : WRITE(unit_xml,'("</zero_potential>")')
11826 :
11827 : !Local ionic potential
11828 0 : if (vlocopt==1) then
11829 0 : meshsz=mesh_data%meshsz(mesh_data%ivionmesh)
11830 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivionmesh),extra1)
11831 0 : meshst_aux=mesh_start(mesh_data%ivionmesh)
11832 0 : dum(1:meshsz)=sqr4pi*half*PAW%abinitvloc(1:meshsz)
11833 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11834 : WRITE(unit_xml,'("<kresse_joubert_local_ionic_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11835 0 : & gridt(mesh_data%ivionmesh),mesh_data%ivionmesh,match_on_splgrid(PAW%rc)
11836 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11837 0 : WRITE(unit_xml,'("</kresse_joubert_local_ionic_potential>")')
11838 : end if
11839 :
11840 : !Local Blochl''s potential
11841 0 : if(vlocopt==2) then
11842 0 : meshsz=mesh_data%meshsz(mesh_data%ivionmesh)
11843 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivionmesh),extra1)
11844 0 : meshst_aux=mesh_start(mesh_data%ivionmesh)
11845 0 : dum(1:meshsz)=sqr4pi*half*PAW%abinitnohat(1:meshsz)
11846 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11847 : WRITE(unit_xml,'("<blochl_local_ionic_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11848 0 : & gridt(mesh_data%ivionmesh),mesh_data%ivionmesh,match_on_splgrid(PAW%rc)
11849 0 : WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11850 0 : WRITE(unit_xml,'("</blochl_local_ionic_potential>")')
11851 : endif
11852 :
11853 : !Local LDA-1/2 potential
11854 : ! if (pawlda12%uselda12) then
11855 : ! meshsz=mesh_data%meshsz(mesh_data%ivlda12mesh)
11856 : ! meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%ivlda12mesh),extra1)
11857 : ! meshst_aux=mesh_start(mesh_data%ivlda12mesh)
11858 : ! dum(1:meshsz)=pawlda12%pot(1:meshsz)
11859 : ! call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11860 : ! ir=index_on_splgrid(pawlda12%rcut)
11861 : ! dum_aux(ir+1:meshsz_aux)=0.d0 ! V_lda12 has to be zero for r>rc
11862 : ! WRITE(unit_xml,'("<LDA_minus_half_potential grid=""",a,i1,""" rc=""",f19.16,""">")') &
11863 : !& gridt(mesh_data%ivlda12mesh),mesh_data%ivlda12mesh,match_on_splgrid(pawlda12%rcut)
11864 : ! WRITE(unit_xml,'(3(1x,es23.16))') (dum_aux(ii),ii=meshst_aux,meshsz_aux)
11865 : ! WRITE(unit_xml,'("</LDA_minus_half_potential>")')
11866 : ! end if
11867 :
11868 : !Partial waves and projectors
11869 : !-- Partial waves
11870 0 : meshsz=mesh_data%meshsz(mesh_data%iwavmesh)
11871 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%iwavmesh),extra1)
11872 0 : meshst_aux=mesh_start(mesh_data%iwavmesh)
11873 0 : LIBPAW_ALLOCATE(phi_aux,(meshsz_aux-meshst_aux+1,PAW%nbase))
11874 0 : LIBPAW_ALLOCATE(tphi_aux,(meshsz_aux-meshst_aux+1,PAW%nbase))
11875 0 : Do ib=1,PAW%nbase
11876 0 : dum(2:meshsz)=PAW%ophi(2:meshsz,ib)/Grid%r(2:meshsz)
11877 0 : call extrapolate(dum(1:meshsz))
11878 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11879 0 : phi_aux(1:meshsz_aux,ib)=dum_aux(1:meshsz_aux)
11880 0 : dum(2:meshsz)=PAW%otphi(2:meshsz,ib)/Grid%r(2:meshsz)
11881 0 : call extrapolate(dum(1:meshsz))
11882 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11883 0 : if(nsplgrid>0) dum_aux(irc_aux:meshsz_aux)=phi_aux(irc_aux:meshsz_aux,ib)
11884 0 : tphi_aux(meshst_aux:meshsz_aux,ib)=dum_aux(meshst_aux:meshsz_aux)
11885 : Enddo
11886 : !-- Projectors
11887 0 : meshsz=mesh_data%meshsz(mesh_data%iprjmesh)
11888 0 : meshsz_aux=merge(nsplgrid,mesh_size(mesh_data%iprjmesh),extra1)
11889 0 : meshst_aux=mesh_start(mesh_data%iprjmesh)
11890 0 : LIBPAW_ALLOCATE(proj_aux,(meshsz_aux-meshst_aux+1,PAW%nbase))
11891 0 : Do ib=1,PAW%nbase
11892 0 : dum(2:meshsz)=tproj(2:meshsz,ib)/Grid%r(2:meshsz)
11893 0 : call extrapolate(dum(1:meshsz))
11894 0 : call interp_and_filter(dum(1:meshsz),dum_aux(1:meshsz_aux))
11895 0 : if(nsplgrid>0) dum_aux(irc_aux:meshsz_aux)=zero
11896 0 : proj_aux(meshst_aux:meshsz_aux,ib)=dum_aux(meshst_aux:meshsz_aux)
11897 : Enddo
11898 : !-- In case of a spline, re-orthogonalize projectors
11899 : ! if (nsplgrid >0) then
11900 : ! Do ib=1,PAW%nbase
11901 : ! tphi_aux(1:meshsz_aux,ib)=tphi_aux(1:meshsz_aux,ib)*Grid1%r(1:meshsz_aux)
11902 : ! proj_aux(1:meshsz_aux,ib)=proj_aux(1:meshsz_aux,ib)*Grid1%r(1:meshsz_aux)
11903 : ! Enddo
11904 : ! call vdborth(irc_aux,tphi_aux,proj_aux)
11905 : ! Do ib=1,PAW%nbase
11906 : ! tphi_aux(2:meshsz_aux,ib)=tphi_aux(2:meshsz_aux,ib)/Grid1%r(2:meshsz_aux)
11907 : ! call extrapolate(tphi_aux(1:meshsz_aux,ib))
11908 : ! proj_aux(2:meshsz_aux,ib)=proj_aux(2:meshsz_aux,ib)/Grid1%r(2:meshsz_aux)
11909 : ! call extrapolate(proj_aux(1:meshsz_aux,ib))
11910 : ! Enddo
11911 : ! end if
11912 : !-- Writing
11913 0 : Do ib=1,PAW%nbase
11914 0 : call mkname(ib,char4)
11915 0 : char20=stripchar('"'//AEPot%sym//char4//'"')
11916 : WRITE(unit_xml,'("<ae_partial_wave state=",a6," grid=""",a,i1,""">")') &
11917 0 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11918 0 : WRITE(unit_xml,'(3(1x,es23.16))') (phi_aux(ii,ib),ii=meshst_aux,meshsz_aux)
11919 0 : WRITE(unit_xml,'("</ae_partial_wave>")')
11920 : WRITE(unit_xml,'("<pseudo_partial_wave state=",a6," grid=""",a,i1,""">")')&
11921 0 : & TRIM(char20),gridt(mesh_data%iwavmesh),mesh_data%iwavmesh
11922 0 : WRITE(unit_xml,'(3(1x,es23.16))') (tphi_aux(ii,ib),ii=meshst_aux,meshsz_aux)
11923 0 : WRITE(unit_xml,'("</pseudo_partial_wave>")')
11924 : WRITE(unit_xml,'("<projector_function state=",a6," grid=""",a,i1,""">")') &
11925 0 : & TRIM(char20),gridt(mesh_data%iprjmesh),mesh_data%iprjmesh
11926 0 : WRITE(unit_xml,'(3(1x,es23.16))') (proj_aux(ii,ib),ii=meshst_aux,meshsz_aux)
11927 0 : WRITE(unit_xml,'("</projector_function>")')
11928 : !do ic=1,PAW%nbase
11929 : ! write(std_out,*) "splined", ib,ic
11930 : ! dum(meshst_aux:meshsz_aux)=tphi_aux(meshst_aux:meshsz_aux,ib)*proj_aux(meshst_aux:meshsz_aux,ic)*dudr(meshst_aux:meshsz_aux)
11931 : ! dum(meshst_aux:meshsz_aux)=dum(meshst_aux:meshsz_aux)*rad_aux(meshst_aux:meshsz_aux)*rad_aux(meshst_aux:meshsz_aux)
11932 : ! xx=overint(meshsz_aux-meshst_aux+1,logstp0,dum(meshst_aux:meshsz_aux),-1)
11933 : ! write(std_out,*) "ORTHO", ib,xx/logstp0
11934 : !end do
11935 : Enddo
11936 : !-- Release memory
11937 0 : LIBPAW_DEALLOCATE(phi_aux)
11938 0 : LIBPAW_DEALLOCATE(proj_aux)
11939 0 : LIBPAW_DEALLOCATE(tphi_aux)
11940 :
11941 : !Kinetic terms
11942 0 : WRITE(unit_xml,'("<kinetic_energy_differences>")')
11943 0 : WRITE(unit_xml,'(3(1x,es23.16))')((PAW%kij(ib,ic)/2,ic=1,PAW%nbase),ib=1,PAW%nbase)
11944 0 : WRITE(unit_xml,'("</kinetic_energy_differences>")')
11945 :
11946 : !!Core-valence exchange terms
11947 : ! WRITE(unit_xml,'("<exact_exchange_X_matrix>")')
11948 : ! WRITE(unit_xml,'(3(1x,es23.16))')((PAW%TXVC(ib,ic)/2,ic=1,PAW%nbase),ib=1,PAW%nbase)
11949 : ! WRITE(unit_xml,'("</exact_exchange_X_matrix>")')
11950 : !
11951 : !!Core-core exchange terms
11952 : ! WRITE(unit_xml,'("<exact_exchange core-core=""", 1x,es23.16,"""/>")') &
11953 : !& PAW%XCORECORE/2
11954 : !
11955 : !!Lamb shielding
11956 : ! WRITE(unit_xml,'("<lamb_shielding shielding=""", 1x,es23.16,"""/>")') &
11957 : !& PAW%lambshielding
11958 : !
11959 : !! Input file
11960 0 : WRITE(unit_xml,'("<!-- Program: atompaw - input data follows: ")')
11961 0 : WRITE(unit_xml,'(a)') trim(input_string)
11962 0 : WRITE(unit_xml,'(a)') "END"
11963 0 : WRITE(unit_xml,'(" Program: atompaw - input end -->")')
11964 0 : WRITE(unit_xml,'("</paw_dataset>")')
11965 :
11966 : !Close file and end
11967 0 : CLOSE(unit_xml)
11968 0 : WRITE(STD_OUT,'(/,2x,a)') 'XML atomic dataset created.'
11969 :
11970 0 : if(nsplgrid>0) call destroygrid(Grid1)
11971 0 : LIBPAW_DEALLOCATE(rad_aux)
11972 0 : LIBPAW_DEALLOCATE(dum_aux)
11973 0 : LIBPAW_DEALLOCATE(dum)
11974 :
11975 : CONTAINS
11976 : !**************************************************
11977 : ! If an interpolation on an auxiliary grid is
11978 : ! requested, give index of input radius
11979 : ! on this auxiliary grid
11980 : !**************************************************
11981 : integer function index_on_splgrid(input_radius)
11982 : real(dp),intent(in) :: input_radius
11983 : if (nsplgrid>0) then
11984 : if (logstp_spl>0.d0) then
11985 : index_on_splgrid=int(tol8+log(1.d0+input_radius/radstp_spl)/logstp_spl)+1
11986 : else if (radstp_spl>0.d0) then
11987 : index_on_splgrid=int(tol8+input_radius/radstp_spl)+1
11988 : end if
11989 : else
11990 : index_on_splgrid=FindGridIndex(Grid,input_radius)
11991 : end if
11992 : end function index_on_splgrid
11993 :
11994 : !**************************************************
11995 : ! If an interpolation on an auxiliary grid is
11996 : ! requested, match input radius on this auxiliary
11997 : ! grid (defined by radstp_spl, logstp_spl)
11998 : !**************************************************
11999 0 : real(dp) function match_on_splgrid(input_radius)
12000 : real(dp),intent(in) :: input_radius
12001 : integer :: indx
12002 0 : match_on_splgrid=input_radius
12003 0 : if (nsplgrid>0) then
12004 0 : if (logstp_spl>0.d0) then
12005 0 : indx=int(tol8+log(1.d0+input_radius/radstp_spl)/logstp_spl)+1
12006 0 : match_on_splgrid=radstp_spl*(exp(logstp_spl*(indx-1))-1.d0)
12007 0 : else if (radstp_spl>0.d0) then
12008 0 : indx=int(tol8+input_radius/radstp_spl)+1
12009 0 : match_on_splgrid=radstp_spl*(indx-1)
12010 : end if
12011 : end if
12012 0 : end function match_on_splgrid
12013 :
12014 : !**************************************************
12015 : ! If an interpolation on an auxiliary grid is
12016 : ! requested, inerpolate an input function on
12017 : ! this auxiliary grid.
12018 : ! Also filter the input function (put zero below
12019 : ! a given threshold)
12020 : !**************************************************
12021 0 : subroutine interp_and_filter(func_in,func_out)
12022 : real(dp),intent(in) :: func_in(:)
12023 : real(dp),intent(out) :: func_out(:)
12024 : integer :: jj,msz_in,msz_out,msz_spl
12025 : logical :: extra
12026 0 : msz_in=size(func_in) ; msz_out=size(func_out)
12027 0 : func_out=zero
12028 0 : if (nsplgrid>0) then
12029 0 : if (msz_out/=nsplgrid) stop ' Bug (1) in interp_and_filter: msz_out/=nsplgrid!'
12030 0 : extra=(Grid%r(msz_in)<Grid1%r(msz_out))
12031 0 : msz_spl=merge(msz_out-1,msz_out,extra)
12032 0 : call interpfunc(msz_in,Grid%r,func_in,msz_spl,Grid1%r,func_out)
12033 : else
12034 0 : if (msz_out>msz_in) stop ' Bug (2) in interp_and_filter: msz_out>msz_in!'
12035 0 : func_out(1:msz_out)=func_in(1:msz_out)
12036 : end if
12037 0 : do jj=1,msz_out
12038 0 : if (abs(func_out(jj))<tol_zero) func_out(jj)=0.d0
12039 : end do
12040 :
12041 0 : end subroutine interp_and_filter
12042 :
12043 : !***********************************************************************
12044 : !* In case of interpolation on an auxiliary grid, a
12045 : !* reorthonomalisation of projector and pseudo wavefunctions
12046 : !* is necessary. This is done thanks to a Vanderbilt orthonormalisation
12047 : !************************************************************************
12048 : ! subroutine vdborth(irc_aux,tphi_aux,proj_aux)
12049 : !
12050 : ! real(dp),intent(in) :: tphi_aux(:,:)
12051 : ! real(dp),intent(inout) :: proj_aux(:,:)
12052 : ! integer :: irc_aux
12053 : !
12054 : ! integer :: i,icount,io,irc,j,jo,l,lmax,nbase
12055 : ! real(dp), allocatable :: aa(:,:),ai(:,:),omap(:),proj_aux1(:,:)
12056 : !
12057 : ! allocate(proj_aux1(size(proj_aux,1),PAW%nbase))
12058 : ! lmax=PAW%lmax
12059 : ! nbase=PAW%nbase
12060 : ! irc=irc_aux
12061 : ! do l=0,lmax
12062 : ! icount=0
12063 : ! do io=1,nbase
12064 : ! if (PAW%l(io)==l) icount=icount+1
12065 : ! enddo
12066 : ! if (icount==0) cycle
12067 : ! allocate(aa(icount,icount),ai(icount,icount),omap(icount))
12068 : ! aa=0;icount=0
12069 : ! do io=1,nbase
12070 : ! if (PAW%l(io)==l) then
12071 : ! icount=icount+1
12072 : ! omap(icount)=io
12073 : ! endif
12074 : ! enddo
12075 : ! do i=1,icount
12076 : ! io=omap(i)
12077 : ! do j=1,icount
12078 : ! jo=omap(j)
12079 : ! aa(i,j)=overlap(Grid1,tphi_aux(:,io),proj_aux(:,jo),1,irc)
12080 : ! enddo
12081 : ! enddo
12082 : ! ai=aa;call minverse(ai,icount,icount,icount)
12083 : !
12084 : ! do i=1,icount
12085 : ! io=omap(i)
12086 : ! proj_aux1(:,io)=0
12087 : ! do j=1,icount
12088 : ! jo=omap(j)
12089 : ! proj_aux1(:,io)=proj_aux1(:,io)+proj_aux(:,jo)*ai(j,i)
12090 : ! enddo
12091 : ! enddo
12092 : ! deallocate(aa,ai,omap)
12093 : ! enddo
12094 : ! proj_aux=proj_aux1
12095 : ! deallocate(proj_aux1)
12096 : ! end subroutine vdborth
12097 :
12098 : END SUBROUTINE xmloutput
12099 :
12100 :
12101 : !!=================================================================
12102 : !! NAME
12103 : !! get_xc_data
12104 : !!
12105 : !! FUNCTION
12106 : !! Get XC data in a suitable form for XML printing
12107 : !!
12108 : !! INPUTS
12109 : !! exctype= string containing XC type
12110 : !!
12111 : !! OUTPUT
12112 : !! xc_name= name of XC functional
12113 : !! xc_type= LDA or GGA
12114 : !!
12115 : !! PARENTS
12116 : !! xmlout,xmlprtcore
12117 : !!
12118 : !!=================================================================
12119 :
12120 0 : subroutine get_xc_data(atp,xctype,xcname)
12121 : type(atompaw_type),intent(in) :: atp
12122 : character(len=*),intent(out) :: xctype,xcname
12123 :
12124 : !------------------------------------------------------------------
12125 : !---- Executable code
12126 : !------------------------------------------------------------------
12127 :
12128 0 : if (trim(ADJUSTL(atp%exctype))=="LDA-PW") then
12129 0 : xctype="LDA"
12130 0 : xcname="PW"
12131 0 : elseif (trim(ADJUSTL(atp%exctype))=="GGA-PBE") then
12132 0 : xctype="GGA"
12133 0 : xcname="PBE"
12134 0 : elseif (trim(ADJUSTL(atp%exctype))=="GGA-PBESOL") then
12135 0 : xctype="GGA"
12136 0 : xcname="PBESOL"
12137 0 : else if(atp%itype==LIBXC) then
12138 0 : if (libxc_functionals_ismgga(atp%xc_functionals)) then
12139 0 : xctype="MGGA"
12140 0 : else if (libxc_functionals_isgga(atp%xc_functionals)) then
12141 0 : xctype="GGA"
12142 : else
12143 0 : xctype="LDA"
12144 : end if
12145 0 : xcname=trim(atp%exctype)
12146 : else
12147 0 : LIBPAW_ERROR("Unknown XC type")
12148 : end if
12149 :
12150 0 : end subroutine get_xc_data
12151 :
12152 :
12153 :
12154 : !!=================================================================
12155 : !! NAME
12156 : !! get_xc_alias
12157 : !!
12158 : !! FUNCTION
12159 : !! Get XC name alias (following PAW-XML specification)
12160 : !! from a libXC functional name
12161 : !!
12162 : !! INPUTS
12163 : !! xc_name= string containing long XC name
12164 : !!
12165 : !! OUTPUT
12166 : !! xc_alias= alias of XC functional
12167 : !!
12168 : !! PARENTS
12169 : !! xmlout,xmlprtcore
12170 : !!
12171 : !!=================================================================
12172 :
12173 0 : subroutine get_xc_alias(xc_name,xc_alias)
12174 :
12175 : character(len=*),intent(in) :: xc_name
12176 : character(len=*),intent(out) :: xc_alias
12177 :
12178 : !------------------------------------------------------------------
12179 : !---- Executable code
12180 : !------------------------------------------------------------------
12181 :
12182 0 : select case(trim(xc_name))
12183 : case('LDA_X+LDA_C_PW')
12184 0 : xc_alias='PW'
12185 : case('GGA_X_PBE+GGA_C_PBE')
12186 0 : xc_alias='PBE'
12187 : case('LDA_X+LDA_C_PZ')
12188 0 : xc_alias='PZ'
12189 : case('LDA_X+LDA_C_WIGNER')
12190 0 : xc_alias='W'
12191 : case('LDA_X+LDA_C_HL')
12192 0 : xc_alias='HL'
12193 : case('LDA_X+LDA_C_GL')
12194 0 : xc_alias='GL'
12195 : case('LDA_X+LDA_C_VWN')
12196 0 : xc_alias='VWN'
12197 : case('GGA_X_PBE_R+GGA_C_PBE')
12198 0 : xc_alias='revPBE'
12199 : case('GGA_X_RPBE+GGA_C_PBE')
12200 0 : xc_alias='RPBE'
12201 : case('GGA_X_PW91+GGA_C_PW91')
12202 0 : xc_alias='PW91'
12203 : case('GGA_X_B88+GGA_C_LYP')
12204 0 : xc_alias='BLYP'
12205 : case DEFAULT
12206 0 : xc_alias=xc_name
12207 : end select
12208 :
12209 0 : end subroutine get_xc_alias
12210 :
12211 :
12212 :
12213 : !!=================================================================
12214 : !! NAME
12215 : !! read_inputstring
12216 : !!
12217 : !! FUNCTION
12218 : !! Read the file echoing the atompaw input file
12219 : !! and transfer it into a character string
12220 : !!
12221 : !! OUTPUT
12222 : !! input_string=character string containing the file
12223 : !!
12224 : !! PARENTS
12225 : ! xml2abinit
12226 : !!=================================================================
12227 :
12228 4 : subroutine read_inputstring(input_string)
12229 :
12230 : character(len=*) :: input_string
12231 :
12232 : !------------------------------------------------------------------
12233 : !---- Local variables
12234 : !------------------------------------------------------------------
12235 :
12236 : integer :: OK,input_unit
12237 : character(len=132) :: inputline
12238 :
12239 : !------------------------------------------------------------------
12240 : !---- Executable code
12241 : !------------------------------------------------------------------
12242 :
12243 4 : open(input_unit,file='dummy',form='formatted')
12244 4 : read(input_unit,'(a)',iostat=OK,end=10) inputline
12245 0 : if (OK/=0) return
12246 0 : input_string=trim(inputline)
12247 0 : do
12248 0 : read(input_unit,'(a)',iostat=OK,end=10) inputline
12249 0 : if (OK/=0) exit
12250 0 : write(unit=input_string,fmt='(3a)') trim(input_string),char(10),trim(inputline)
12251 : enddo
12252 : return
12253 : 10 continue
12254 4 : close(input_unit)
12255 :
12256 4 : end subroutine read_inputstring
12257 :
12258 :
12259 0 : end module m_paw_atom_solve
12260 : !!***
|
