Branch data Line data Source code
1 : : !!****m* ABINIT/m_bader
2 : : !! NAME
3 : : !! m_bader
4 : : !!
5 : : !! FUNCTION
6 : : !! Procedures used by AIM code.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2008-2026 ABINIT group (PCasek,FF,XG)
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 : : !! SOURCE
15 : :
16 : : #if defined HAVE_CONFIG_H
17 : : #include "config.h"
18 : : #endif
19 : :
20 : : #include "abi_common.h"
21 : :
22 : : module m_bader
23 : :
24 : : use defs_basis
25 : : use m_errors
26 : : use m_abicore
27 : : use m_xmpi
28 : : use m_sort
29 : : use m_hdr
30 : : use m_splines
31 : : use netcdf
32 : :
33 : : use m_time, only : timein
34 : : use m_geometry, only : metric
35 : : use m_parser, only : inread
36 : : use m_numeric_tools, only : coeffs_gausslegint
37 : : use m_hide_lapack, only : jacobi, lubksb, ludcmp
38 : :
39 : : implicit none
40 : :
41 : : !private
42 : : public
43 : : !!***
44 : :
45 : : !!****t* m_bader/aim_dataset_type
46 : : !! NAME
47 : : !! aim_dataset_type
48 : : !!
49 : : !! FUNCTION
50 : : !! The aim_dataset_type structured datatype
51 : : !! gathers all the input variables for the aim code
52 : : !!
53 : : !! SOURCE
54 : :
55 : : type aim_dataset_type
56 : :
57 : : ! Since all these input variables are described in the aim_help.html
58 : : ! file, they are not described in length here ...
59 : :
60 : : ! Integer
61 : : integer :: crit
62 : : integer :: denout
63 : : integer :: dltyp
64 : : integer :: gpsurf
65 : : integer :: irho
66 : : integer :: ivol
67 : : integer :: lapout
68 : : integer :: nsa
69 : : integer :: nsb
70 : : integer :: nsc
71 : :
72 : : integer :: batom ! Warning : corresponds to the input variable atom
73 : : integer :: foll ! Warning : corresponds to the input variable follow
74 : : integer :: isurf ! Warning : corresponds to the input variable surf
75 : : integer :: irsur ! Warning : corresponds to the input variable rsurf
76 : : integer :: nph ! Warning : corresponds to the input variable nphi
77 : : integer :: npt ! Warning : corresponds to the input variable inpt
78 : : integer :: nth ! Warning : corresponds to the input variable ntheta
79 : : integer :: plden ! Warning : not documented in help file ?!
80 : :
81 : : integer :: ngrid(3)
82 : :
83 : : ! Real
84 : : real(dp) :: atrad
85 : : real(dp) :: coff1
86 : : real(dp) :: coff2
87 : : real(dp) :: dpclim
88 : : real(dp) :: folstp
89 : : real(dp) :: lgrad
90 : : real(dp) :: lgrad2
91 : : real(dp) :: lstep
92 : : real(dp) :: lstep2
93 : : real(dp) :: maxatd
94 : : real(dp) :: maxcpd
95 : : real(dp) :: phimax
96 : : real(dp) :: phimin
97 : :
98 : : real(dp) :: dr0 ! Warning : correspond to the input variable radstp
99 : : real(dp) :: phi0 ! Warning : correspond to the input variable rsurdir(2)
100 : : real(dp) :: rmin ! Warning : correspond to the input variable ratmin
101 : : real(dp) :: th0 ! Warning : correspond to the input variable rsurdir(1)
102 : : real(dp) :: themax ! Warning : correspond to the input variable thetamax
103 : : real(dp) :: themin ! Warning : correspond to the input variable thetamin
104 : :
105 : : real(dp) :: foldep(3)
106 : : real(dp) :: scal(3)
107 : : real(dp) :: vpts(3,4)
108 : :
109 : : end type aim_dataset_type
110 : : !!***
111 : :
112 : : public :: adini
113 : : public :: drvaim
114 : : public :: inpar
115 : : public :: defad
116 : : public :: aim_shutdown
117 : :
118 : : ! Global from defs_aimfields
119 : : integer, save :: ngfft(3),nmax
120 : : integer, allocatable, save :: ndat(:)
121 : : real(dp), allocatable, target, save :: dig1(:),llg1(:),dig2(:),llg2(:),dig3(:),llg3(:)
122 : : real(dp), allocatable, target, save :: cdig1(:),cdig2(:),cdig3(:)
123 : : real(dp), save :: dix(3)
124 : : real(dp), allocatable, target, save :: dvl(:,:,:),ddx(:,:,:),ddy(:,:,:),ddz(:,:,:),rval(:,:,:)
125 : : real(dp), allocatable, save :: rrad(:,:),crho(:,:),sp2(:,:),sp3(:,:),sp4(:,:),pdd(:),pd(:)
126 : :
127 : : ! Global from defs_aimprom
128 : :
129 : : ! UNITS
130 : : integer, save :: unt0,unto,unt,untc,unts,untd,untl,untg,unta,untad,untp,untout
131 : : integer,save :: aim_iomode
132 : : ! DRIVER VARIABLES
133 : : real(dp), save :: maxatdst,maxcpdst
134 : : integer, parameter :: ndif=45,ngaus=200,npos=1000
135 : : integer, allocatable, save :: typat(:), corlim(:)
136 : : integer, save :: ntypat,nnpos,natom
137 : : integer, save :: nsimax,batcell,npc,nbcp,nrcp,nccp
138 : : integer, save :: icpc(npos*ndif),npcm3,slc
139 : : real(dp), save :: rprimd(3,3),ivrprim(3,3),trivrp(3,3)
140 : : real(dp), allocatable, save :: xred(:,:),xatm(:,:),rminl(:)
141 : : real(dp), save :: tpi,sqfp,fpi,sqpi,sqtpi,atp(3,npos)
142 : : real(dp), save :: h0,hmin,r0,ttsrf,ttcp,tttot
143 : : real(dp), save :: cth(ngaus),th(ngaus),ph(ngaus),wcth(ngaus),wph(ngaus),rs(ngaus,ngaus)
144 : : real(dp), save :: pc(3,npos*ndif), evpc(3,npos*ndif),zpc(3,3,npos*ndif), pcrb(3,npos*ndif)
145 : : logical, save :: deb,ldeb
146 : : !!! interface chgbas
147 : : !!! subroutine bschg1(vv,dir)
148 : : !!! implicit none
149 : : !!! integer, intent(in) :: dir
150 : : !!! real(dp),intent(inout) :: vv(3)
151 : : !!! end subroutine bschg1
152 : : !!! subroutine bschg2(aa,dir)
153 : : !!! implicit none
154 : : !!! integer, intent(in) :: dir
155 : : !!! real(dp),intent(inout) :: aa(3,3)
156 : : !!! end subroutine bschg2
157 : : !!! end interface chgbas
158 : :
159 : : !- Set of parameters for the aim utility -----------------------------------
160 : : real(dp), parameter :: aim_rhocormin=1.d-10 ! the minimal core density
161 : : real(dp), parameter :: aim_epstep=0.5
162 : : real(dp), parameter :: aim_rhomin=1.d-5,aim_dgmin=1.d-9,aim_dmaxcrit=5.d-2
163 : : real(dp), parameter :: aim_dmin=1.d-3,aim_hmax=2.d7,aim_fac0=2.1_dp,aim_facmin=1.d-3
164 : : real(dp), parameter :: aim_hmult=15._dp,aim_tiny=1.d-4,aim_snull=1.d-6
165 : : real(dp), parameter :: aim_deltarmin=1.d-7
166 : : !the minimal length of one step following the gradient line
167 : : real(dp), parameter :: aim_fac=1.2_dp,aim_drmin=1.d-5
168 : : real(dp), parameter :: aim_dlimit=1.d-4,aim_dmaxcs=3.d-1
169 : : real(dp), parameter :: aim_dpc0=1.d-2
170 : : integer, parameter :: aim_maxstep=100
171 : : real(dp), parameter :: aim_xymin=1.d-10
172 : : integer, parameter :: aim_npmaxin=17
173 : : real(dp), parameter :: aim_stmax=0.05
174 : : real(dp), parameter :: aim_dmaxc1=1.d-1, aim_dmaxcl=5.d-2
175 : :
176 : : !----------------------------------------------------------------------
177 : :
178 : : !!****t* m_bader/bcp_type
179 : : !! NAME
180 : : !! bcp_type
181 : : !!
182 : : !! FUNCTION
183 : : !! a "bonding critical point" for aim
184 : : !!
185 : : !! SOURCE
186 : :
187 : : type, private :: bcp_type
188 : :
189 : : ! Integer
190 : : integer :: iat ! number of the bonding atom inside a primitive cell
191 : : integer :: ipos ! number of the primitive cell of the bonding atom
192 : :
193 : : ! Real
194 : : real(dp) :: chg ! charge at the critical point
195 : : real(dp) :: diff(3) ! three distances : AT-CP,BAT-CP,AT-BAT
196 : : real(dp) :: ev(3) ! eigenvalues of the Hessian
197 : : real(dp) :: pom(3) ! position of the bonding atom
198 : : real(dp) :: rr(3) ! position of the bcp
199 : : real(dp) :: vec(3,3) ! eigenvectors of the Hessian
200 : : real(dp) :: vv(3) ! position of the bcp relative to the central atom
201 : :
202 : : end type bcp_type
203 : : !!***
204 : :
205 : : contains
206 : : !!***
207 : :
208 : : !----------------------------------------------------------------------
209 : :
210 : : !!****f* defs_aimprom/aim_shutdown
211 : : !! NAME
212 : : !! aim_shutdown
213 : : !!
214 : : !! FUNCTION
215 : : !! Free memory allocated in the module. Close units. Mainly used to pass the abirules
216 : : !!
217 : : !! SOURCE
218 : :
219 : 5 : subroutine aim_shutdown()
220 : :
221 : : !Local variables-------------------------------
222 : : integer :: ii
223 : : logical :: is_open
224 : : integer :: all_units(12)
225 : :
226 : : ! *********************************************************************
227 : :
228 : : !if (allocated(typat)) then
229 : : ! ABI_FREE(typat)
230 : : !end if
231 : : !if (allocated(corlim)) then
232 : : ! ABI_FREE(corlim)
233 : : !end if
234 : : !if (allocated(xred)) then
235 : : ! ABI_FREE(xred)
236 : : !end if
237 : : !if (allocated(xatm)) then
238 : : ! ABI_FREE(rminl)
239 : : !end if
240 : :
241 [ + + ]: 65 : all_units(:) = [unt0,unto,unt,untc,unts,untd,untl,untg,unta,untad,untp,untout]
242 [ + + ]: 65 : do ii=1,size(all_units)
243 : 60 : inquire(unit=all_units(ii), opened=is_open)
244 [ + + ]: 65 : if (is_open) close(all_units(ii))
245 : : end do
246 : :
247 : 5 : end subroutine aim_shutdown
248 : : !!***
249 : :
250 : : !!****f* m_bader/adini
251 : : !! NAME
252 : : !! adini
253 : : !!
254 : : !! FUNCTION
255 : : !! Analysis of the input string "inpstr" (the content of input file)
256 : : !! and setting of the corresponding input variables
257 : : !!
258 : : !! INPUTS
259 : : !! inpstr=character string containing the input data, to be treated
260 : : !! lenstr=actual length of the string contained in inpstr
261 : : !!
262 : : !! OUTPUT
263 : : !! aim_dtset=the structured entity containing all input variables
264 : : !!
265 : : !! SOURCE
266 : :
267 : 5 : subroutine adini(aim_dtset,inpstr,lenstr)
268 : :
269 : : !Arguments ------------------------------------
270 : : !scalars
271 : : integer,intent(in) :: lenstr
272 : : character(len=*),intent(in) :: inpstr
273 : : !no_abirules
274 : : type(aim_dataset_type), intent(inout) :: aim_dtset !vz_i
275 : :
276 : : !Local variables ------------------------------
277 : : !scalars
278 : : integer :: errcod,ii,inxh,ipos,jj,lenc,ll,outi,tstngr=0,tstvpt=0 !vz_z
279 : : real(dp) :: outr
280 : : logical :: nbtst,try
281 : : character(len=20) :: cmot
282 : :
283 : : ! *********************************************************************
284 : :
285 [ + - ]: 5 : if (iachar(inpstr(1:1)) < 32) then
286 : : ipos=2
287 : : else
288 : 5 : ipos=1
289 : : end if
290 : :
291 : 5 : write(std_out,*) 'ECHO of the INPUT'
292 : 5 : write(std_out,*) '************************'
293 : 5 : write(untout,*) 'ECHO of the INPUT'
294 : 5 : write(untout,*) '************************'
295 : :
296 [ + - ]: 78 : mread: do ii=1,lenstr
297 : 78 : try=.false.
298 : 78 : nbtst=.true.
299 : 78 : inxh=index(inpstr(ipos:lenstr),' ')
300 [ + + ]: 78 : if ((ipos >= lenstr)) exit
301 [ + + ]: 73 : if ((inxh==2).or.(inxh==1)) then
302 : 2 : ipos=ipos+inxh
303 : 2 : cycle
304 : : end if
305 : 71 : lenc=inxh-1
306 [ + - - + ]: 71 : cmot(1:lenc)=inpstr(ipos:ipos+inxh-2)
307 : 71 : ipos=ipos+inxh
308 : : ! write(std_out,*) cmot(1:lenc), lenc
309 : :
310 : 5 : select case (cmot(1:lenc))
311 : :
312 : : ! DRIVER SPECIFICATIONS
313 : :
314 : : case ('SURF')
315 : 5 : inxh=index(inpstr(ipos:lenstr),' ')
316 [ - + - - ]: 5 : if ((inxh /= 2).and.(inpstr(ipos:ipos)/='-')) then
317 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
318 : 0 : ABI_ERROR("Aborting now")
319 : : end if
320 : 5 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
321 : 5 : aim_dtset%isurf=outi
322 : 5 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%isurf
323 : 5 : write(untout,*) cmot(1:lenc),' ', aim_dtset%isurf
324 : 5 : ipos=ipos+inxh
325 : :
326 : : case ('CRIT')
327 : 5 : inxh=index(inpstr(ipos:lenstr),' ')
328 [ - + - - ]: 5 : if ((inxh /= 2).and.(inpstr(ipos:ipos)/='-')) then
329 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
330 : 0 : ABI_ERROR("Aborting now")
331 : : end if
332 : 5 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
333 : 5 : aim_dtset%crit=outi
334 : 5 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%crit
335 : 5 : write(untout,*) cmot(1:lenc),' ', aim_dtset%crit
336 : 5 : ipos=ipos+inxh
337 : :
338 : : case ('RSURF')
339 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
340 [ # # ]: 0 : if (inxh /= 2) then
341 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
342 : 0 : ABI_ERROR("Aborting now")
343 : : end if
344 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
345 : 0 : aim_dtset%irsur=outi
346 : 0 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%irsur
347 : 0 : write(untout,*) cmot(1:lenc),' ', aim_dtset%irsur
348 : 0 : ipos=ipos+inxh
349 : :
350 : : case ('FOLLOW')
351 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
352 [ # # ]: 0 : if (inxh /= 2) then
353 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
354 : 0 : ABI_ERROR("Aborting now")
355 : : end if
356 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
357 : 0 : aim_dtset%foll=outi
358 : 0 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%foll
359 : 0 : write(untout,*) cmot(1:lenc),' ', aim_dtset%foll
360 : 0 : ipos=ipos+inxh
361 : :
362 : : case ('IRHO')
363 : 5 : inxh=index(inpstr(ipos:lenstr),' ')
364 [ - + ]: 5 : if (inxh /= 2) then
365 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
366 : 0 : ABI_ERROR("Aborting now")
367 : : end if
368 : 5 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
369 : 5 : aim_dtset%irho=outi
370 : 5 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%irho
371 : 5 : write(untout,*) cmot(1:lenc),' ', aim_dtset%irho
372 : 5 : ipos=ipos+inxh
373 : :
374 : : case ('PLDEN')
375 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
376 [ # # ]: 0 : if (inxh /= 2) then
377 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
378 : 0 : ABI_ERROR("Aborting now")
379 : : end if
380 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
381 : 0 : aim_dtset%plden=outi
382 : 0 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%plden
383 : 0 : write(untout,*) cmot(1:lenc),' ', aim_dtset%plden
384 : 0 : ipos=ipos+inxh
385 : :
386 : :
387 : : case ('IVOL')
388 : 1 : inxh=index(inpstr(ipos:lenstr),' ')
389 [ - + ]: 1 : if (inxh /= 2) then
390 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
391 : 0 : ABI_ERROR("Aborting now")
392 : : end if
393 : 1 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
394 : 1 : aim_dtset%ivol=outi
395 : 1 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%ivol
396 : 1 : write(untout,*) cmot(1:lenc),' ', aim_dtset%ivol
397 : 1 : ipos=ipos+inxh
398 : :
399 : : case ('DENOUT')
400 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
401 [ # # ]: 0 : if (inxh /= 2) then
402 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
403 : 0 : ABI_ERROR("Aborting now")
404 : : end if
405 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
406 : 0 : aim_dtset%denout=outi
407 [ # # ]: 0 : if ((aim_dtset%denout < -1).or.(aim_dtset%denout>3)) then
408 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
409 : 0 : ABI_ERROR("Aborting now")
410 : : end if
411 : 0 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%denout
412 : 0 : write(untout,*) cmot(1:lenc),' ', aim_dtset%denout
413 : 0 : ipos=ipos+inxh
414 : :
415 : : case ('LAPOUT')
416 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
417 [ # # ]: 0 : if (inxh /= 2) then
418 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
419 : 0 : ABI_ERROR("Aborting now")
420 : : end if
421 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
422 : 0 : aim_dtset%lapout=outi
423 [ # # ]: 0 : if ((aim_dtset%lapout < -1).or.(aim_dtset%lapout>3)) then
424 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
425 : 0 : ABI_ERROR("Aborting now")
426 : : end if
427 : 0 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%lapout
428 : 0 : write(untout,*) cmot(1:lenc),' ', aim_dtset%lapout
429 : 0 : ipos=ipos+inxh
430 : :
431 : : case ('DLTYP')
432 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
433 [ # # ]: 0 : if (inxh /= 2) then
434 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
435 : 0 : ABI_ERROR("Aborting now")
436 : : end if
437 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
438 : 0 : aim_dtset%dltyp=outi
439 : 0 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%dltyp
440 : 0 : write(untout,*) cmot(1:lenc),' ', aim_dtset%dltyp
441 : 0 : ipos=ipos+inxh
442 : :
443 : : case ('GPSURF')
444 : 5 : inxh=index(inpstr(ipos:lenstr),' ')
445 [ - + ]: 5 : if (inxh /= 2) then
446 : 0 : write(std_out,*) 'ERROR in specif. of ', cmot(1:lenc)
447 : 0 : ABI_ERROR("Aborting now")
448 : : end if
449 : 5 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
450 : 5 : aim_dtset%gpsurf=outi
451 : 5 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%gpsurf
452 : 5 : write(untout,*) cmot(1:lenc),' ', aim_dtset%gpsurf
453 : 5 : ipos=ipos+inxh
454 : :
455 : :
456 : : ! END OF THE DRIVER SPECIFICATIONS
457 : :
458 : : case ('ATOM')
459 : 5 : inxh=index(inpstr(ipos:lenstr),' ')
460 : 5 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
461 : 5 : aim_dtset%batom=outi
462 : 5 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%batom
463 : 5 : write(untout,*) cmot(1:lenc),' ', aim_dtset%batom
464 : 5 : ipos=ipos+inxh
465 : :
466 : : case ('NSA')
467 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
468 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
469 : 0 : aim_dtset%nsa=outi
470 : 0 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%nsa
471 : 0 : write(untout,*) cmot(1:lenc),' ', aim_dtset%nsa
472 : 0 : ipos=ipos+inxh
473 : :
474 : : case ('NSB')
475 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
476 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
477 : 0 : aim_dtset%nsb=outi
478 : 0 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%nsb
479 : 0 : write(untout,*) cmot(1:lenc),' ', aim_dtset%nsb
480 : 0 : ipos=ipos+inxh
481 : :
482 : : case ('NSC')
483 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
484 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
485 : 0 : aim_dtset%nsc=outi
486 : 0 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%nsc
487 : 0 : write(untout,*) cmot(1:lenc),' ', aim_dtset%nsc
488 : 0 : ipos=ipos+inxh
489 : :
490 : : case ('INPT')
491 : 5 : inxh=index(inpstr(ipos:lenstr),' ')
492 : 5 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
493 : 5 : aim_dtset%npt=outi
494 : 5 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%npt
495 : 5 : write(untout,*) cmot(1:lenc),' ', aim_dtset%npt
496 : 5 : ipos=ipos+inxh
497 : :
498 : : case ('NTHETA')
499 : 5 : inxh=index(inpstr(ipos:lenstr),' ')
500 : 5 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
501 : 5 : aim_dtset%nth=outi
502 : 5 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%nth
503 : 5 : write(untout,*) cmot(1:lenc),' ', aim_dtset%nth
504 : 5 : ipos=ipos+inxh
505 : :
506 : : case ('NPHI')
507 : 5 : inxh=index(inpstr(ipos:lenstr),' ')
508 : 5 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
509 : 5 : aim_dtset%nph=outi
510 : 5 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%nph
511 : 5 : write(untout,*) cmot(1:lenc),' ', aim_dtset%nph
512 : 5 : ipos=ipos+inxh
513 : :
514 : : case ('THETAMIN')
515 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
516 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
517 : 0 : aim_dtset%themin=outr
518 : 0 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%themin
519 : 0 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%themin
520 : 0 : ipos=ipos+inxh
521 : :
522 : : case ('THETAMAX')
523 : 4 : inxh=index(inpstr(ipos:lenstr),' ')
524 : 4 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
525 : 4 : aim_dtset%themax=outr
526 : 4 : write(std_out, '(1x,a,a,es17.10)' ) cmot(1:lenc),' ', aim_dtset%themax
527 : 4 : write(untout,'(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%themax
528 : 4 : ipos=ipos+inxh
529 : :
530 : : case ('PHIMIN')
531 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
532 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
533 : 0 : aim_dtset%phimin=outr
534 : 0 : write(std_out, '(1x,a,a,es17.10)' ) cmot(1:lenc),' ', aim_dtset%phimin
535 : 0 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%phimin
536 : 0 : ipos=ipos+inxh
537 : :
538 : : case ('PHIMAX')
539 : 4 : inxh=index(inpstr(ipos:lenstr),' ')
540 : 4 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
541 : 4 : aim_dtset%phimax=outr
542 : 4 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%phimax
543 : 4 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%phimax
544 : 4 : ipos=ipos+inxh
545 : :
546 : : case ('ATRAD')
547 : 2 : inxh=index(inpstr(ipos:lenstr),' ')
548 : 2 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
549 : 2 : aim_dtset%atrad=outr
550 : 2 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%atrad
551 : 2 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%atrad
552 : 2 : ipos=ipos+inxh
553 : :
554 : : case ('RADSTP')
555 : 2 : inxh=index(inpstr(ipos:lenstr),' ')
556 : 2 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
557 : 2 : aim_dtset%dr0=outr
558 : 2 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%dr0
559 : 2 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%dr0
560 : 2 : ipos=ipos+inxh
561 : :
562 : : case ('FOLSTP')
563 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
564 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
565 : 0 : aim_dtset%folstp=outr
566 : 0 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%folstp
567 : 0 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%folstp
568 : 0 : ipos=ipos+inxh
569 : :
570 : : case ('RATMIN')
571 : 2 : inxh=index(inpstr(ipos:lenstr),' ')
572 : 2 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
573 : 2 : aim_dtset%rmin=outr
574 : 2 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%rmin
575 : 2 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%rmin
576 : 2 : ipos=ipos+inxh
577 : :
578 : : case ('COFF1')
579 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
580 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
581 : 0 : aim_dtset%coff1=outr
582 : 0 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%coff1
583 : 0 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%coff1
584 : 0 : ipos=ipos+inxh
585 : :
586 : : case ('COFF2')
587 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
588 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
589 : 0 : aim_dtset%coff2=outr
590 : 0 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%coff2
591 : 0 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%coff2
592 : 0 : ipos=ipos+inxh
593 : :
594 : : case ('DPCLIM')
595 : 1 : inxh=index(inpstr(ipos:lenstr),' ')
596 : 1 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
597 : 1 : aim_dtset%dpclim=outr
598 : 1 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%dpclim
599 : 1 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%dpclim
600 : 1 : ipos=ipos+inxh
601 : :
602 : : case ('LGRAD')
603 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
604 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
605 : 0 : aim_dtset%lgrad=outr
606 : 0 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%lgrad
607 : 0 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%lgrad
608 : 0 : ipos=ipos+inxh
609 : :
610 : : case ('LGRAD2')
611 : 3 : inxh=index(inpstr(ipos:lenstr),' ')
612 : 3 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
613 : 3 : aim_dtset%lgrad2=outr
614 : 3 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%lgrad2
615 : 3 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%lgrad2
616 : 3 : ipos=ipos+inxh
617 : :
618 : : case ('LSTEP')
619 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
620 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
621 : 0 : aim_dtset%lstep=outr
622 : 0 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%lstep
623 : 0 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%lstep
624 : 0 : ipos=ipos+inxh
625 : :
626 : : case ('LSTEP2')
627 : 3 : inxh=index(inpstr(ipos:lenstr),' ')
628 : 3 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
629 : 3 : aim_dtset%lstep2=outr
630 : 3 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%lstep2
631 : 3 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%lstep2
632 : 3 : ipos=ipos+inxh
633 : :
634 : : case ('RSURDIR')
635 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
636 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
637 : 0 : aim_dtset%th0=outr
638 : 0 : ipos=ipos+inxh
639 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
640 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
641 : 0 : aim_dtset%phi0=outr
642 : 0 : ipos=ipos+inxh
643 : 0 : write(std_out, '(1x,a,a,2es17.10)') cmot(1:lenc),' ', aim_dtset%th0, aim_dtset%phi0
644 : 0 : write(untout, '(1x,a,a,2es17.10)') cmot(1:lenc),' ', aim_dtset%th0, aim_dtset%phi0
645 : :
646 : : case ('FOLDEP')
647 [ # # ]: 0 : do jj=1,3
648 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
649 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
650 : 0 : aim_dtset%foldep(jj)=outr
651 : 0 : ipos=ipos+inxh
652 : : end do
653 : 0 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%foldep
654 : 0 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%foldep
655 : :
656 : : case ('SCAL')
657 [ # # ]: 0 : do jj=1,3
658 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
659 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
660 : 0 : aim_dtset%scal(jj)=outr
661 : 0 : ipos=ipos+inxh
662 : : end do
663 : 0 : write(std_out,*) cmot(1:lenc),' ', aim_dtset%scal
664 : 0 : write(untout,*) cmot(1:lenc),' ', aim_dtset%scal
665 : :
666 : : case ('NGRID')
667 : 0 : try=.true.
668 [ # # ]: 0 : do jj=1,3
669 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
670 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"INT",outi,outr,errcod)
671 : 0 : aim_dtset%ngrid(jj)=outi
672 : : if (.not.nbtst) then
673 : : tstngr=jj-1
674 : : cycle mread
675 : : end if
676 [ # # ]: 0 : if (inxh==0) then
677 : 0 : tstvpt=jj
678 : 0 : exit mread
679 : : end if
680 : 0 : ipos=ipos+inxh
681 [ # # ]: 0 : if (ipos==lenstr-1) then
682 : 0 : tstngr=jj
683 : 0 : exit mread
684 : : end if
685 : : end do
686 : : ! Why no echo ?? XG 030218
687 : 0 : tstngr=3
688 : :
689 : : case ('VPTS')
690 [ # # ]: 0 : do jj=1,4
691 [ # # ]: 0 : do ll=1,3
692 : 0 : try=.true.
693 : 0 : inxh=index(inpstr(ipos:lenstr),' ')
694 : 0 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
695 : 0 : aim_dtset%vpts(ll,jj)=outr
696 : : if (.not.nbtst) then
697 : : tstvpt=jj-1
698 : : cycle mread
699 : : end if
700 : 0 : ipos=ipos+inxh
701 [ # # ]: 0 : if (ipos>=lenstr) then
702 : 0 : tstvpt=jj
703 : 0 : exit mread
704 : : end if
705 : : end do
706 : : end do
707 : : ! Why no echo ?? XG 030218
708 : 0 : tstvpt=4
709 : :
710 : : case ('MAXATD')
711 : 5 : inxh=index(inpstr(ipos:lenstr),' ')
712 : 5 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
713 : 5 : aim_dtset%maxatd=outr
714 : 5 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%maxatd
715 : 5 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%maxatd
716 : 5 : ipos=ipos+inxh
717 : :
718 : : case ('MAXCPD')
719 : 4 : inxh=index(inpstr(ipos:lenstr),' ')
720 : 4 : call inread(inpstr(ipos:ipos+inxh-2),inxh-1,"DPR",outi,outr,errcod)
721 : 4 : aim_dtset%maxcpd=outr
722 : 4 : write(std_out, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%maxcpd
723 : 4 : write(untout, '(1x,a,a,es17.10)') cmot(1:lenc),' ', aim_dtset%maxcpd
724 : 4 : ipos=ipos+inxh
725 : :
726 : : case default
727 [ + + - - : 71 : write(std_out,*) 'ERROR Bad key word ! ',cmot(1:lenc)
+ - + - -
- + + - -
- + + + -
+ - + + +
- + - - +
- + - + -
- - - - +
+ - ]
728 : : end select
729 : : end do mread
730 : :
731 : 5 : write(std_out,*) '************************'
732 : :
733 : 5 : call consist(aim_dtset,tstngr,tstvpt)
734 : :
735 : 5 : end subroutine adini
736 : : !!***
737 : :
738 : : !!****f* m_bader/addout
739 : : !! NAME
740 : : !! addout
741 : : !!
742 : : !! FUNCTION
743 : : !! Output density and laplacian (see input variables denout and lapout)
744 : : !!
745 : : !! INPUTS
746 : : !! aim_dtset=the structured entity containing all input variables
747 : : !! also, uses the variables saved in the module "defs_aimprom"
748 : : !!
749 : : !! OUTPUT
750 : : !! (print)
751 : : !!
752 : : !! WARNING
753 : : !! This file does not follow the ABINIT coding rules (yet) : the use
754 : : !! of a module to transfer data should be avoided
755 : : !!
756 : : !! SOURCE
757 : :
758 : 0 : subroutine addout(aim_dtset)
759 : :
760 : : !Arguments ------------------------------------
761 : : !scalars
762 : : type(aim_dataset_type),intent(in) :: aim_dtset
763 : :
764 : : !Local variables ------------------------------
765 : : !scalars
766 : : integer :: cod,dims,iat,ii,ipos,jj,nn,tgrd
767 : : real(dp) :: alfa,rho,rr,xx,yy
768 : : !arrays
769 : : real(dp) :: grho(3),hrho(3,3),orig(3),vv(3)
770 : 0 : real(dp),allocatable :: dfld(:),lfld(:),nr(:),stp(:),uu(:,:)
771 : :
772 : : !************************************************************************
773 [ # # ]: 0 : orig(:)=aim_dtset%vpts(:,1)
774 [ # # ]: 0 : if (aim_dtset%denout > 0) then
775 : : dims=aim_dtset%denout
776 [ # # ]: 0 : elseif (aim_dtset%lapout > 0) then
777 : 0 : dims=aim_dtset%lapout
778 : : end if
779 : :
780 : 0 : select case (aim_dtset%dltyp)
781 : : case (1)
782 : 0 : cod=1
783 : : case (2)
784 : 0 : cod=2
785 : : case default
786 [ # # # ]: 0 : cod=0
787 : : end select
788 : :
789 [ # # # # : 0 : ABI_MALLOC(uu,(3,dims))
# # # # #
# ]
790 [ # # # # : 0 : ABI_MALLOC(nr,(dims))
# # # # #
# ]
791 [ # # # # : 0 : ABI_MALLOC(stp,(dims))
# # # # ]
792 : :
793 : 0 : write(std_out,*) 'grid:', aim_dtset%ngrid(1:dims)
794 : 0 : write(std_out,*) 'kod :', cod
795 : 0 : tgrd=1
796 [ # # ]: 0 : do ii=1,dims
797 : 0 : tgrd=tgrd*aim_dtset%ngrid(ii)
798 [ # # ]: 0 : uu(:,ii)=aim_dtset%vpts(:,ii+1)-aim_dtset%vpts(:,1)
799 : 0 : nr(ii)=vnorm(uu(:,ii),0)
800 : 0 : stp(ii)=nr(ii)/(aim_dtset%ngrid(ii)-1)
801 [ # # ]: 0 : uu(:,ii)=uu(:,ii)/nr(ii)
802 : : end do
803 : 0 : write(std_out,*) 'tgrd :', tgrd
804 [ # # ]: 0 : do ii=1,dims
805 : 0 : write(std_out,*) 'uu :', uu(1:3,ii)
806 : : end do
807 : :
808 [ # # ]: 0 : if (aim_dtset%denout > 0) then
809 [ # # # # : 0 : ABI_MALLOC(dfld,(tgrd+1))
# # # # #
# # # #
# ]
810 [ # # ]: 0 : dfld(:)=0._dp
811 : : end if
812 [ # # ]: 0 : if (aim_dtset%lapout > 0) then
813 [ # # # # : 0 : ABI_MALLOC(lfld,(tgrd+1))
# # # # #
# # # #
# ]
814 : : end if
815 : :
816 : 0 : select case (dims)
817 : : case (1)
818 : 0 : nn=0
819 [ # # ]: 0 : do ii=0,aim_dtset%ngrid(1)-1
820 : 0 : nn=nn+1
821 [ # # ]: 0 : vv(:)=orig(:)+ii*stp(1)*uu(:,1)
822 : 0 : call vgh_rho(vv,rho,grho,hrho,rr,iat,ipos,cod)
823 [ # # ]: 0 : if (aim_dtset%denout > 0) dfld(nn)=rho
824 [ # # ]: 0 : if (aim_dtset%lapout > 0) lfld(nn)=hrho(1,1)+hrho(2,2)+hrho(3,3)
825 : : end do
826 [ # # ]: 0 : if (aim_dtset%denout==1) then
827 [ # # ]: 0 : do ii=0,aim_dtset%ngrid(1)-1
828 : 0 : xx=ii*stp(1)
829 : 0 : write(untd,'(2E16.8)') xx, dfld(ii+1)
830 : : end do
831 : : end if
832 [ # # ]: 0 : if (aim_dtset%lapout==1) then
833 [ # # ]: 0 : do ii=0,aim_dtset%ngrid(1)-1
834 : 0 : xx=ii*stp(1)
835 : 0 : write(untl,'(2E16.8)') xx, lfld(ii+1)
836 : : end do
837 : : end if
838 : : case (2)
839 : 0 : nn=0
840 [ # # ]: 0 : alfa=dot_product(uu(:,1),uu(:,2))
841 : 0 : alfa=acos(alfa)
842 [ # # ]: 0 : do ii=0,aim_dtset%ngrid(2)-1
843 [ # # ]: 0 : do jj=0,aim_dtset%ngrid(1)-1
844 : 0 : nn=nn+1
845 [ # # ]: 0 : vv(:)=orig(:)+jj*uu(:,2)*stp(2)+ii*stp(1)*uu(:,1)
846 : 0 : call vgh_rho(vv,rho,grho,hrho,rr,iat,ipos,cod)
847 [ # # ]: 0 : if (aim_dtset%denout > 0) dfld(nn)=rho
848 [ # # ]: 0 : if (aim_dtset%lapout > 0) lfld(nn)=hrho(1,1)+hrho(2,2)+hrho(3,3)
849 : : end do
850 : : end do
851 : 0 : write(std_out,*) 'generace hotova', nn
852 : 0 : nn=0
853 [ # # ]: 0 : if (aim_dtset%denout==2) then
854 [ # # ]: 0 : do ii=0,aim_dtset%ngrid(2)-1
855 [ # # ]: 0 : do jj=0,aim_dtset%ngrid(1)-1
856 : 0 : nn=nn+1
857 : 0 : xx=jj*stp(1)+cos(alfa)*ii*stp(2)
858 : 0 : yy=sin(alfa)*ii*stp(2)
859 : 0 : write(untd,'(3E16.8)') xx, yy, dfld(nn)
860 : : end do
861 : 0 : write(untd,*) ' '
862 : : end do
863 : : end if
864 : 0 : nn=0
865 [ # # # # : 0 : if (aim_dtset%lapout==2) then
# ]
866 : 0 : write(std_out,*) 'lezes sem?'
867 [ # # ]: 0 : do ii=0,aim_dtset%ngrid(2)-1
868 [ # # ]: 0 : do jj=0,aim_dtset%ngrid(1)-1
869 : 0 : nn=nn+1
870 : 0 : xx=jj*stp(1)+cos(alfa)*ii*stp(2)
871 : 0 : yy=sin(alfa)*ii*stp(2)
872 : 0 : write(untl,'(3E16.8)') xx, yy, lfld(nn)
873 : : end do
874 : 0 : write(untl,*) ' '
875 : : end do
876 : : end if
877 : : end select
878 [ # # ]: 0 : ABI_FREE(uu)
879 [ # # ]: 0 : ABI_FREE(stp)
880 [ # # ]: 0 : ABI_FREE(nr)
881 [ # # ]: 0 : if(aim_dtset%denout>0) then
882 [ # # ]: 0 : ABI_FREE(dfld)
883 : : end if
884 [ # # ]: 0 : if(aim_dtset%lapout>0) then
885 [ # # ]: 0 : ABI_FREE(lfld)
886 : : end if
887 : :
888 [ # # # # ]: 0 : end subroutine addout
889 : : !!***
890 : :
891 : : !!****f* m_bader/aim_follow
892 : : !! NAME
893 : : !! aim_follow
894 : : !!
895 : : !! FUNCTION
896 : : !! This routine follows the gradient line starting from the point
897 : : !! vv. It stop when it arrives to the atom (nearer than rminl(iat))
898 : : !! or - if srch=true - also if it arrives under the already known
899 : : !! part of Bader surface
900 : : !!
901 : : !! INPUTS
902 : : !! aim_dtset= the structured entity containing all input variables
903 : : !! iatinit,iposinit= indexes of initial atom
904 : : !! npmax= maximum number of division in each step
905 : : !!
906 : : !! OUTPUT
907 : : !! iat,ipos= index of final atom
908 : : !! nstep= returns the number of step needed
909 : : !!
910 : : !! SIDE EFFECTS
911 : : !! srch= (true/false) check if the line is outside or
912 : : !! inside the atomic surface.
913 : : !! vv(3)= initial point in orthogonal coordinates
914 : : !!
915 : : !! SOURCE
916 : :
917 : 9342 : subroutine aim_follow(aim_dtset,vv,npmax,srch,iatinit,iposinit,iat,ipos,nstep)
918 : :
919 : : !Arguments ------------------------------------
920 : : !scalars
921 : : integer,intent(in) :: iatinit,iposinit,npmax
922 : : integer,intent(out) :: iat,ipos,nstep
923 : : logical,intent(inout) :: srch
924 : : type(aim_dataset_type),intent(in) :: aim_dtset
925 : : !arrays
926 : : real(dp),intent(inout) :: vv(3)
927 : :
928 : : !Local variables ------------------------------
929 : : !scalars
930 : : integer :: i1,i2,i3,ii,iph,ires,ith,jj,kk,nit,np,nph,nsi,nth
931 : : real(dp) :: deltar,dg,dist,dph,dth,fac2,facf,h0old,hh,hold,rho,rr,rsmed
932 : : real(dp) :: t1,t2,t3,vcth,vph,vth,wall,xy,xyz
933 : : logical :: fin,ldebold,srchold,stemp,stemp2
934 : : character(len=50) :: formpc
935 : : character(len=500) :: msg
936 : : !arrays
937 : : real(dp) :: ev(3),grho(3),hrho(3,3),pom(3),vold(3),vt(3),vt1(3)
938 : : real(dp) :: zz(3,3)
939 : :
940 : : !************************************************************************
941 : 3114 : formpc='(":CP",2I5,3F12.8,3E12.4,I4,2E12.4)'
942 : :
943 : :
944 : 3114 : fin=.false.
945 : :
946 : 3114 : srchold=srch
947 : 3114 : ldebold=ldeb
948 : 3114 : h0old=h0
949 : :
950 : 3114 : nth=aim_dtset%nth
951 : 3114 : nph=aim_dtset%nph
952 : :
953 [ - + ]: 3114 : if (slc==0) then
954 [ # # ]: 0 : rminl(:)=aim_dtset%rmin
955 : : end if
956 : :
957 [ - + ]: 3114 : if (deb) then
958 : 0 : ldeb=.true.
959 : : end if
960 : :
961 : 3114 : call vgh_rho(vv,rho,grho,hrho,rr,iat,ipos,slc)
962 : :
963 : : !Initial tests
964 : :
965 [ + + ]: 3114 : if (iat/=0) then
966 [ + - ]: 68 : if (rr<rminl(iat)) then
967 : 68 : fin=.true.
968 : 68 : write(std_out,*) 'rr < rmin iat=',iat,' ipos=',ipos
969 [ # # ]: 0 : elseif (rho<aim_rhomin) then
970 : 0 : fin=.true.
971 : 0 : write(std_out,*) 'CHARGE LT rhomin ',rho,' < ',aim_rhomin
972 [ # # ]: 0 : if (rho<zero) then
973 : 0 : ABI_ERROR('RHO < 0 !!!')
974 : : end if
975 : : end if
976 : : end if
977 : :
978 : 3114 : facf=aim_fac0
979 : 3114 : hh=aim_hmax
980 : :
981 : 3114 : call timein(t1,wall)
982 : 3114 : nstep=0
983 : 3114 : nsi=0
984 : :
985 : : !the principal cycle
986 : :
987 : 813964 : madw : do while(.not.fin)
988 : 203474 : hold=hh
989 : :
990 : 203474 : dg=vnorm(grho,0)
991 [ + - - + ]: 203474 : if (ldeb.or.deb) write(std_out,*) 'dg= ',dg
992 : :
993 : : ! the time test
994 : :
995 : 203474 : call timein(t3,wall)
996 : 203474 : t2=t3-t1
997 [ - + ]: 203474 : if (t2>300.0) then
998 : 0 : write(std_out,*) 'TIME EXCEEDED 5 min IN FOLLOW'
999 : 0 : write(std_out,*) 'h0 =',h0,' h =',hh,' h0old =',h0old,' dg =',dg
1000 : 0 : write(std_out,*) 'facf =',facf
1001 : 0 : msg = 'TIME EXCEEDED 5 min IN FOLLOW'
1002 : 0 : ABI_ERROR(msg)
1003 : : end if
1004 : :
1005 [ - + ]: 203474 : if (dg<aim_dgmin) then
1006 : 0 : write(std_out,*) 'gradient < dgmin ',dg,' < ',aim_dgmin
1007 : 0 : fin=.true.
1008 : 0 : iat=0
1009 : 0 : ipos=0
1010 : : ! testing for the CP
1011 [ # # ]: 0 : if (npc>0) then
1012 : 0 : call critic(aim_dtset,vv,ev,zz,aim_dmaxcrit,ires,0)
1013 [ # # ]: 0 : if (ires==0) then
1014 [ # # ]: 0 : do jj=1,npc
1015 [ # # ]: 0 : pom(:)=pc(:,jj)-vv(:)+xatm(:,aim_dtset%batom)
1016 : 0 : dist=vnorm(pom,0)
1017 [ # # ]: 0 : if (dist<aim_tiny) cycle madw
1018 : : end do
1019 : 0 : write(std_out,*) 'C.P. found !!'
1020 : 0 : npc=npc+1
1021 [ # # ]: 0 : do jj=1,3
1022 : 0 : pc(jj,npc)=vv(jj)
1023 : 0 : evpc(jj,npc)=ev(jj)
1024 [ # # ]: 0 : do kk=1,3
1025 : 0 : zpc(kk,jj,npc)=zz(kk,jj)
1026 : : end do
1027 : : end do
1028 : 0 : i1=ev(1)/abs(ev(1))
1029 : 0 : i2=ev(2)/abs(ev(2))
1030 : 0 : i3=ev(3)/abs(ev(3))
1031 : 0 : icpc(npc)=i1+i2+i3
1032 [ # # ]: 0 : if (icpc(npc)==-3) then ! pseudoatom handling
1033 : 0 : npcm3=npcm3+1
1034 : 0 : write(std_out,*) 'Pseudo-atom found !!'
1035 : : end if
1036 : :
1037 : 0 : call vgh_rho(vv,rho,grho,hrho,rr,iat,ipos,slc)
1038 : 0 : write(22,formpc) 0,0,(pcrb(jj,npc),jj=1,3),(ev(jj),jj=1,3),icpc(npc),&
1039 : 0 : & ev(1)+ev(2)+ev(3),rho
1040 : 0 : write(std_out,formpc) 0,0,(pcrb(jj,npc),jj=1,3),(ev(jj),jj=1,3),icpc(npc),&
1041 : 0 : & ev(1)+ev(2)+ev(3),rho
1042 : : else
1043 : 0 : write(std_out,*) 'C.P. not found !!'
1044 : : end if
1045 : : end if
1046 : :
1047 : : cycle madw
1048 : : end if
1049 : :
1050 : 203474 : hh=h0/dg
1051 [ + - - + ]: 203474 : if (ldeb.or.deb) write(std_out,*) 'h= ',hh,' h0= ',h0,' dg= ',dg
1052 [ - + ]: 203474 : if (hh>aim_hmax) hh=aim_hmax
1053 : : ! step modifications
1054 : :
1055 : 203474 : hh=hh*facf
1056 [ - + ]: 203474 : if (hh>(hold*aim_hmult)) then
1057 : 0 : hh=hold*aim_hmult
1058 : : end if
1059 : :
1060 [ + + ]: 813896 : do ii=1,3
1061 : 813896 : vold(ii)=vv(ii)
1062 : : end do
1063 : :
1064 : 203474 : nit=0
1065 : 203474 : hold=hh
1066 : :
1067 : : ! one step following the gradient line
1068 : : !
1069 : 203474 : call onestep(vv,rho,grho,hh,np,npmax,deltar)
1070 [ + + + + : 232463 : do while (((np>npmax).or.(deltar>aim_stmax)).and.(deltar>aim_dmin))
- + ]
1071 : 28989 : nit=nit+1
1072 [ - + ]: 28989 : if (nit>5) then
1073 [ # # ]: 0 : if (deltar>aim_stmax) then
1074 : 0 : write(std_out,*) 'nit > 5 and deltar > stmax nit=',nit
1075 : : else
1076 : 0 : write(std_out,*) 'nit > 5 and np > npmax nit=',nit
1077 : : end if
1078 : : end if
1079 [ + + ]: 115956 : do ii=1,3
1080 : 115956 : vv(ii)=vold(ii)
1081 : : end do
1082 : 28989 : hh=hh*0.3
1083 : 28989 : call onestep(vv,rho,grho,hh,np,npmax,deltar)
1084 : : end do
1085 : :
1086 : :
1087 : 203474 : nstep=nstep+1
1088 [ + - - + ]: 203474 : if (ldeb.or.deb) write(std_out,*) 'h= ',hh
1089 : :
1090 : 203474 : fac2=hh/hold
1091 [ + + ]: 203474 : if (fac2>=1._dp) then
1092 : 174540 : facf=facf*1.2
1093 : : else
1094 [ + - ]: 28934 : if (fac2>=aim_facmin) then
1095 : 28934 : facf=fac2
1096 : : else
1097 : 0 : facf=aim_facmin
1098 : : end if
1099 : : end if
1100 : :
1101 [ + - - + ]: 203474 : if (deb.or.ldeb) then
1102 : 0 : write(std_out,*) ':POS ',vv
1103 : 0 : write(std_out,*) ':RBPOS ',vt1
1104 : 0 : write(std_out,*) ':GRAD ',grho
1105 : : end if
1106 : :
1107 : 203474 : call vgh_rho(vv,rho,grho,hrho,rr,iat,ipos,slc)
1108 : 203474 : dg=vnorm(grho,0)
1109 [ + + ]: 813896 : pom(:)=vv(:)-xatm(:,iatinit)-atp(:,iposinit)
1110 : :
1111 [ + + ]: 203474 : if (iat /= 0) then
1112 : 3046 : fin=.true.
1113 : 3046 : write(std_out,*) 'r < rmin iat=',iat,' ipos=',ipos
1114 : : cycle madw
1115 : : end if
1116 : :
1117 [ - + ]: 200428 : if (rho<aim_rhomin) then
1118 : 0 : fin=.true.
1119 : 0 : write(std_out,*) 'charge < rhomin ',rho,' < ',aim_rhomin
1120 [ # # ]: 0 : if (rho<zero) then
1121 : 0 : ABI_ERROR('RHO < 0 !!!')
1122 : : end if
1123 : 0 : iat=0
1124 : 0 : ipos=0
1125 : : cycle madw
1126 : : end if
1127 : :
1128 [ - + ]: 200428 : if (npcm3>0) then
1129 [ # # ]: 0 : do jj=1,npc
1130 [ # # ]: 0 : if (icpc(jj)==(-3)) then
1131 [ # # ]: 0 : pom(:)=pc(:,jj)-vv(:)+xatm(:,aim_dtset%batom)
1132 : 0 : dist=vnorm(pom,0)
1133 [ # # ]: 0 : if (dist<(aim_dtset%rmin**2*0.1)) then
1134 : 0 : iat=0
1135 : 0 : ipos=0
1136 : 0 : fin=.true.
1137 : 0 : write(std_out,*) 'We are inside a pseudo-atom'
1138 : : cycle madw
1139 : : end if
1140 : : end if
1141 : : end do
1142 : : end if
1143 : :
1144 : 200428 : nsi=nsi+1
1145 : :
1146 : : ! surface checking
1147 : :
1148 [ + + - + ]: 200496 : if (srch.and.(nsi>=nsimax)) then
1149 : 703276 : nsi=0
1150 : 703276 : ith=0
1151 : 703276 : iph=0
1152 [ + + ]: 703276 : do ii=1,3
1153 : 703276 : vt(ii)=vv(ii)-xatm(ii,iatinit)
1154 : : end do
1155 : 175819 : xy=vt(1)*vt(1)+vt(2)*vt(2)
1156 : 175819 : xyz=xy+vt(3)*vt(3)
1157 : 175819 : xyz=sqrt(xyz)
1158 [ - + ]: 175819 : if (xy<aim_snull) then
1159 : 0 : vcth=1._dp
1160 [ # # ]: 0 : if (vt(3)<0._dp) vcth=-vcth
1161 : : vph=0._dp
1162 : : else
1163 : 175819 : vcth=vt(3)/xyz
1164 : 175819 : vph=atan2(vt(2),vt(1))
1165 : : end if
1166 : 175819 : vth=acos(vcth)
1167 [ + + ]: 175819 : if (vth<th(1)) then
1168 : : ith=0
1169 : : else
1170 [ + + ]: 159391 : if (vth>th(nth)) then
1171 : : ith=nth
1172 : : else
1173 [ + - ]: 458026 : do ii=2,nth
1174 [ + + ]: 458026 : if (vth<th(ii)) then
1175 : 137640 : ith=ii-1
1176 : 137640 : exit
1177 : : end if
1178 : : end do
1179 : : end if
1180 : : end if
1181 : :
1182 [ + + ]: 175819 : if (vph<ph(1)) then
1183 : : iph=0
1184 : : else
1185 [ + + ]: 137932 : if (vph>ph(nph)) then
1186 : : iph=nph
1187 : : else
1188 [ + - ]: 208006 : do ii=2,nph
1189 [ + + ]: 208006 : if (vph<ph(ii)) then
1190 : 104279 : iph=ii-1
1191 : 104279 : exit
1192 : : end if
1193 : : end do
1194 : : end if
1195 : : end if
1196 : :
1197 : 175819 : stemp=(iph>0).and.(iph<nph)
1198 [ + + + + ]: 175819 : stemp=stemp.and.(ith>0).and.(ith<nth)
1199 : :
1200 : : if (stemp) then
1201 : 81179 : stemp2=rs(ith,iph)>0._dp
1202 [ + + + + ]: 81179 : stemp2=stemp2.and.(rs(ith+1,iph)>0._dp)
1203 [ + + ]: 3504 : stemp2=stemp2.and.(rs(ith+1,iph+1)>0._dp)
1204 [ + + + - ]: 203593 : stemp2=stemp2.and.(rs(ith,iph+1)>0._dp)
1205 : : if (stemp2) then
1206 : 0 : dth=th(ith+1)-th(ith)
1207 : 0 : dph=ph(iph+1)-ph(iph)
1208 : 0 : rsmed=rs(ith,iph)*(th(ith+1)-vth)/dth*(ph(iph+1)-vph)/dph
1209 : 0 : rsmed=rsmed+rs(ith+1,iph)*(vth-th(ith))/dth*(ph(iph+1)-vph)/dph
1210 : 0 : rsmed=rsmed+rs(ith+1,iph+1)*(vth-th(ith))/dth*(vph-ph(iph))/dph
1211 : 0 : rsmed=rsmed+rs(ith,iph+1)*(th(ith+1)-vth)/dth*(vph-ph(iph))/dph
1212 [ # # ]: 0 : if (rsmed>xyz) then
1213 : 0 : write(std_out,*) 'We are inside the surface'
1214 : 0 : iat=iatinit
1215 : 0 : ipos=iposinit
1216 : : else
1217 : 0 : write(std_out,*) 'We are outside the surface'
1218 : 0 : iat=0
1219 : 0 : ipos=0
1220 : : end if
1221 : : fin=.true.
1222 : : cycle madw
1223 : : end if
1224 : : end if
1225 : : end if
1226 : :
1227 : : end do madw
1228 : :
1229 : :
1230 : 3114 : srch=srchold
1231 : 3114 : ldeb=ldebold
1232 : 3114 : h0=h0old
1233 : :
1234 : :
1235 : 3114 : end subroutine aim_follow
1236 : : !!***
1237 : :
1238 : : !!****f* m_bader/consist
1239 : : !! NAME
1240 : : !! consist
1241 : : !!
1242 : : !! FUNCTION
1243 : : !! Checking of the consistency between the values of input variables
1244 : : !!
1245 : : !! INPUTS
1246 : : !! aim_dtset= the structured entity containing all input variables
1247 : : !! tstngr= information about the test on the ngrid input variable
1248 : : !! tstvpt= information about the test on the vpts input variable
1249 : : !!
1250 : : !! OUTPUT
1251 : : !! (only checking : print error message and stop if there is a problem)
1252 : : !!
1253 : : !! WARNING
1254 : : !! This file does not follow the ABINIT coding rules (yet)
1255 : : !!
1256 : : !! SOURCE
1257 : :
1258 : 5 : subroutine consist(aim_dtset,tstngr,tstvpt)
1259 : :
1260 : : !Arguments ------------------------------------
1261 : : !scalars
1262 : : integer,intent(in) :: tstngr,tstvpt
1263 : : type(aim_dataset_type),intent(in) :: aim_dtset
1264 : :
1265 : : !Local variables ------------------------------
1266 : :
1267 : : ! *********************************************************************
1268 : :
1269 : : !write(std_out,*) tstngr, tstvpt
1270 : :
1271 [ + - - + : 5 : if (((aim_dtset%denout/=0).or.(aim_dtset%lapout/=0)).and.((tstngr < 1).or.(tstvpt < 2))) then
- - - - ]
1272 : 0 : ABI_ERROR('in input1 - I cannot do the output !')
1273 : : end if
1274 [ - + - - ]: 5 : if ((aim_dtset%denout > 0).and.(aim_dtset%lapout>0)) then
1275 [ # # ]: 0 : if (aim_dtset%denout/=aim_dtset%lapout) then
1276 : 0 : write(std_out,*) 'ERROR in input - when both denout and lapout are positive non-zero,'
1277 : 0 : write(std_out,*) 'they must be equal.'
1278 : 0 : ABI_ERROR("Aborting now")
1279 : : end if
1280 [ # # # # ]: 0 : if ((tstvpt < aim_dtset%denout+1).or.(tstngr < aim_dtset%denout)) then
1281 : 0 : write(std_out,*) 'ERROR in input2 - I cannot do the output !'
1282 : 0 : ABI_ERROR("Aborting now")
1283 : : end if
1284 [ - + ]: 5 : elseif (aim_dtset%denout > 0) then
1285 [ # # # # ]: 0 : if ((tstvpt < aim_dtset%denout+1).or.(tstngr < aim_dtset%denout)) then
1286 : 0 : write(std_out,*) 'ERROR in input - I cannot do the output !'
1287 : 0 : ABI_ERROR("Aborting now")
1288 : : end if
1289 [ - + ]: 5 : elseif (aim_dtset%lapout > 0) then
1290 [ # # # # ]: 0 : if ((tstvpt < aim_dtset%lapout+1).or.(tstngr < aim_dtset%lapout)) then
1291 : 0 : write(std_out,*) 'ERROR in input - I cannot do the output !'
1292 : 0 : ABI_ERROR("Aborting now")
1293 : : end if
1294 : : end if
1295 : :
1296 [ + - - + ]: 5 : if ((aim_dtset%isurf==1).and.(aim_dtset%crit==0)) then
1297 : 0 : write(std_out,*) 'ERROR in input - must have crit/=0 for isurf==1'
1298 : 0 : ABI_ERROR("Aborting now")
1299 : : end if
1300 : :
1301 [ + - - + ]: 5 : if (((aim_dtset%ivol/=0).or.(aim_dtset%irho/=0)).and.(aim_dtset%isurf==0)) then
1302 : 0 : ABI_ERROR('in input - I cannot integrate without surface !')
1303 : : end if
1304 : :
1305 : 5 : end subroutine consist
1306 : : !!***
1307 : :
1308 : : !!****f* m_bader/cpdrv
1309 : : !! NAME
1310 : : !! cpdrv
1311 : : !!
1312 : : !! FUNCTION
1313 : : !! Critical points (CPs) searching driver
1314 : : !! First Bond CPs are searched for each pair atom-its neighbor
1315 : : !! (distance cutoff=maxatdst)
1316 : : !! then Ring CPs for each pair of BCPs
1317 : : !! and finally Cage CPs for each pair of RCPs.
1318 : : !!
1319 : : !! INPUTS
1320 : : !! aim_dtset= the structured entity containing all input variables
1321 : : !!
1322 : : !! OUTPUT
1323 : : !!
1324 : : !! SIDE EFFECTS
1325 : : !! this routine treat information contained in the aim_prom module
1326 : : !!
1327 : : !! WARNING
1328 : : !! This file does not follow the ABINIT coding rules (yet)
1329 : : !!
1330 : : !! TODO
1331 : : !! Should combine parts of code that are similar ...
1332 : : !!
1333 : : !! SOURCE
1334 : :
1335 : 5 : subroutine cpdrv(aim_dtset)
1336 : :
1337 : : !Arguments ------------------------------------
1338 : : !scalars
1339 : : type(aim_dataset_type),intent(in) :: aim_dtset
1340 : :
1341 : : !Local variables ------------------------------
1342 : : !scalars
1343 : : integer :: iat,iatinit,ii,inxat,inxcell,ipair,ipos,iposinit,ires,jj,kk,nb,nb_now
1344 : : integer :: nn,nstep,nvs,me,nproc,ierr
1345 : : real(dp) :: candidate,chg,diff1,diff2,diff3,dist,prj,rtdiff,ss,tt0,wall
1346 : : logical :: srch=.false.
1347 : : !arrays
1348 : 10 : integer :: ibat(nnpos*natom),inatm(nnpos*natom),incell(nnpos*natom)
1349 : 10 : integer :: ipibat(nnpos*natom)
1350 : 5 : integer,allocatable :: indexcp(:),nr(:)
1351 : 15 : real(dp) :: bmin(natom),dif(3),dists(nnpos*natom),ev(3),evec(3,3),grho(3)
1352 : : real(dp) :: hrho(3,3),pom(3),rr(3),uu(3),vv(3),xorig(3)
1353 : 5 : real(dp),allocatable :: buffer(:,:),sortguide(:)
1354 : : !no_abirules
1355 : : !Warning : bcp_type should be transformed to cp_type
1356 : 5 : type(bcp_type),allocatable :: bcp(:),ccp(:),cp_tmp(:),rcp(:)
1357 : :
1358 : : !************************************************************************
1359 : :
1360 : 5 : me=xmpi_comm_rank(xmpi_world)
1361 : 5 : nproc=xmpi_comm_size(xmpi_world)
1362 : :
1363 : : !Consider the critical points starting from atom #batom
1364 : 5 : inxat=aim_dtset%batom
1365 : 5 : slc=-1
1366 [ + + ]: 28 : rminl(:)=aim_dtset%rmin
1367 [ + + ]: 28 : bmin(:)=0._dp
1368 : 5 : ttcp=0._dp
1369 : :
1370 : 5 : write(std_out,*)
1371 : 5 : write(std_out,*) "CRITICAL POINTS ANALYSIS"
1372 : 5 : write(std_out,*) "========================"
1373 : 5 : write(std_out,*)
1374 : :
1375 : 5 : write(untout,*)
1376 : 5 : write(untout,*) "CRITICAL POINTS ANALYSIS"
1377 : 5 : write(untout,*) "========================"
1378 : 5 : write(untout,*)
1379 : :
1380 : :
1381 [ + + ]: 20 : xorig(:)=xatm(:,inxat)
1382 : :
1383 : 5 : call timein(tt0,wall)
1384 : :
1385 : : !Searching the neighbouring atoms
1386 : :
1387 [ + - ]: 5 : if (aim_dtset%crit > 0) then
1388 : 5 : nvs=0
1389 [ + + ]: 1720 : do ii=1,nnpos
1390 [ + + ]: 9609 : do jj=1,natom
1391 : : dist=0._dp
1392 [ + + ]: 31556 : dif(:)=xatm(:,inxat)-xatm(:,jj)-atp(:,ii)
1393 [ + + ]: 31556 : dif(:)=dif(:)/aim_dtset%scal(:)
1394 : 7889 : dist=vnorm(dif,0)
1395 [ + + ]: 9604 : if (dist < tol6 ) then
1396 : 5 : inxcell=ii
1397 [ + + ]: 7884 : elseif (dist < maxatdst) then
1398 : 120 : nvs=nvs+1
1399 : 120 : dists(nvs)=dist
1400 : 120 : inatm(nvs)=jj
1401 : 120 : incell(nvs)=ii
1402 : : end if
1403 : : end do
1404 : : end do
1405 : :
1406 : 5 : write(std_out,*) "ATOM:"
1407 : 5 : write(std_out,*) 'inxat :', inxat, 'inxcell :', inxcell
1408 : 5 : write(std_out, '(3es16.6)' ) (xorig(ii),ii=1,3)
1409 : 5 : write(std_out,*)
1410 : :
1411 : 5 : write(untout,*) "ATOM:"
1412 : 5 : write(untout,*) 'inxat :', inxat, 'inxcell :', inxcell
1413 : 5 : write(untout, '(3es16.6)') (xorig(ii),ii=1,3)
1414 : 5 : write(untout,*)
1415 : :
1416 [ - + + - : 15 : ABI_MALLOC(nr,(nvs))
+ - + - -
+ - + ]
1417 [ + + ]: 125 : do ii=1,nvs
1418 : 125 : nr(ii)=ii
1419 : : end do
1420 : :
1421 : : ! Ordering of the nearest neighbouring atoms
1422 : 5 : call sort_dp(nvs,dists,nr,tol14)
1423 : :
1424 : 5 : nb=0
1425 : 5 : write(std_out,*) "NEIGHBORING ATOMS (atindex,cellindex,distance(in bohr)):"
1426 : 5 : write(untout,*) "NEIGHBORING ATOMS (atindex,cellindex,distance(in bohr)):"
1427 [ + + ]: 125 : do ii=1,nvs
1428 : 120 : nn=nr(ii)
1429 [ + - ]: 125 : if (dists(ii) < maxatdst) then
1430 : 120 : nb=nb+1
1431 : 120 : ibat(nb)=inatm(nn)
1432 : 120 : ipibat(nb)=incell(nn)
1433 : 120 : write(std_out,*) ':NEIG ',inatm(nn),incell(nn),dists(ii)
1434 : 120 : write(untout,'(" ",2I6,F16.8)')inatm(nn),incell(nn),dists(ii)
1435 : : else
1436 : : exit
1437 : : end if
1438 : : end do
1439 : :
1440 : : ! SEARCHING BCP
1441 [ - + + - : 15 : ABI_MALLOC(bcp,(nb))
+ - + - -
+ - + ]
1442 : 5 : nbcp=0
1443 : 5 : iatinit=inxat
1444 : 5 : iposinit=inxcell
1445 [ + + ]: 125 : bcp(:)%iat=0
1446 [ + + ]: 125 : bcp(:)%ipos=0
1447 : :
1448 : 5 : write(std_out,*)
1449 : 5 : write(std_out,*) "BONDING CRITICAL POINTS (BCP)"
1450 : 5 : write(std_out,*) "============================="
1451 : 5 : write(std_out,*)
1452 : :
1453 : 5 : write(untout,*)
1454 : 5 : write(untout,*) "BONDING CRITICAL POINTS (BCP)"
1455 : 5 : write(untout,*) "============================="
1456 : 5 : write(untout,*)
1457 : :
1458 [ + + ]: 125 : srbcp: do ii=1,nb
1459 : :
1460 : : ! Start the search for BCP from the midistance between the atom
1461 : : ! and his neighbor.
1462 [ + + ]: 480 : vv(:)=(xatm(:,inxat)+xatm(:,ibat(ii))+atp(:,ipibat(ii)))/2._dp
1463 : :
1464 : 120 : call critic(aim_dtset,vv,ev,evec,aim_dmaxcs,ires,-1)
1465 : :
1466 [ + + ]: 125 : if (ires==0) then
1467 : : ! Testing if CP is already known
1468 [ + + ]: 116 : if (nbcp > 0) then
1469 [ + + ]: 772 : do jj=1,nbcp
1470 [ + + ]: 2680 : pom(:)=vv(:)-bcp(jj)%rr(:)-xorig(:)
1471 : 670 : dist=vnorm(pom,0)
1472 [ + + ]: 772 : if (dist < aim_dtset%dpclim) then
1473 : 9 : write(std_out,*) 'BCP already known !'
1474 : 9 : cycle srbcp
1475 : : end if
1476 : : end do
1477 : : end if
1478 [ + + ]: 428 : rr(:)=vv(:)-xorig(:)
1479 : 107 : ss=vnorm(rr,0)
1480 [ + + ]: 107 : if (ss > maxcpdst) then
1481 : 4 : write(std_out, '(a,es16.6,a,es16.6)' ) 'BCP distance from atom,',ss,', exceed maxcpdst =',maxcpdst
1482 : 4 : cycle srbcp
1483 : : end if
1484 : 103 : nn=0
1485 [ + + ]: 412 : do jj=1,3
1486 : 412 : nn=nn+ev(jj)/abs(ev(jj))
1487 : : end do
1488 : 103 : write(std_out, '(a,3es16.6,i4)') ' vv(1:3), nn',(vv(jj), jj=1,3), nn
1489 : 103 : write(std_out, '(a,3es16.6)') 'ev: ', (ev(jj), jj=1,3)
1490 [ + + ]: 103 : if (nn /= -1) then
1491 : 34 : write(std_out,*) ' The trial critical point is not a BCP !'
1492 : 34 : cycle srbcp
1493 : : end if
1494 : 69 : write(std_out, '(a,3es16.6)' ) 'evec(:,1): ',(evec(jj,1), jj=1,3)
1495 [ + + ]: 276 : pom(:)=evec(:,1)
1496 : 69 : dist=vnorm(pom,0)
1497 [ + + ]: 276 : prj=dot_product(evec(:,1),rr)
1498 : 69 : write(std_out,*) 'prj:', prj, vnorm(evec(:,1),0)
1499 : 69 : dist=vnorm(evec(:,1),0)
1500 [ + + ]: 276 : uu(:)=vv(:)-sign(aim_epstep,prj)*evec(:,1)/dist
1501 : :
1502 : : ! Testing whether this BCP "is bonded" to the considered atom
1503 : 69 : call aim_follow(aim_dtset,uu,aim_npmaxin,srch,iatinit,iposinit,iat,ipos,nstep)
1504 : : ! write(std_out,*) 'do', iat, ipos
1505 : : ! if ((iat==0).or.(ipos==0)) cycle
1506 : : ! write(std_out,*) 'APOS: ',(xatm(jj,iat)+atp(jj,ipos), jj=1,3)
1507 [ + + - + ]: 69 : if ((iat/=inxat).or.(inxcell/=ipos)) then
1508 : 35 : write(std_out,*) ' The trial BCP is not bonded to the Bader atom'
1509 : 35 : cycle srbcp
1510 : : end if
1511 : :
1512 : : ! A new BCP has been found !
1513 : 34 : nbcp=nbcp+1
1514 : :
1515 : : ! Searching for the second bonded atom
1516 : 34 : ss=vnorm(rr,0)
1517 : 34 : diff1=ss
1518 : 34 : diff3=dists(ii)
1519 [ + + ]: 136 : uu(:)=vv(:)+sign(aim_epstep,prj)*evec(:,1)/dist
1520 [ + + + + ]: 34 : if ((abs(bmin(iat))<1.0d-12).or.( ss<bmin(iat))) then
1521 : 8 : bmin(iat)=ss
1522 : : end if
1523 : 34 : call aim_follow(aim_dtset,uu,aim_npmaxin,srch,iatinit,iposinit,iat,ipos,nstep)
1524 [ + - - + ]: 34 : if ((iat==0).or.(ipos==0)) then
1525 : 0 : write(std_out,*) ' The trial BCP is not bonded to a bonding atom !'
1526 : : ! cycle srbcp
1527 : : end if
1528 [ + + ]: 136 : pom(:)=vv(:)-xatm(:,iat)-atp(:,ipos)
1529 : 34 : ss=vnorm(pom,0)
1530 : 34 : diff2=ss
1531 [ + + ]: 136 : pom(:)=xorig(:)-xatm(:,iat)-atp(:,ipos)
1532 : 34 : diff3=vnorm(pom,0)
1533 : 34 : rtdiff=diff1/diff3
1534 [ + + + + ]: 34 : if ((abs(bmin(iat))<1.0d-12).or.(ss<bmin(iat))) then
1535 : 7 : bmin(iat)=ss
1536 : : end if
1537 [ + + ]: 136 : pom(:)=xatm(:,iat)+atp(:,ipos)
1538 : :
1539 : : ! Store more results, for coherent, and portable output
1540 : 34 : bcp(nbcp)%iat=iat
1541 : 34 : bcp(nbcp)%ipos=ipos
1542 : 34 : bcp(nbcp)%chg=chg
1543 : 34 : bcp(nbcp)%diff(1)=diff1
1544 : 34 : bcp(nbcp)%diff(2)=diff2
1545 : 34 : bcp(nbcp)%diff(3)=diff3
1546 [ + + ]: 136 : bcp(nbcp)%ev(:)=ev(:)
1547 [ + + ]: 136 : bcp(nbcp)%pom(:)=pom(:)
1548 [ + + ]: 136 : bcp(nbcp)%rr(:)=rr(:)
1549 [ + + + + ]: 442 : bcp(nbcp)%vec(:,:)=evec(:,:)
1550 [ + + ]: 136 : bcp(nbcp)%vv(:)=vv(:)
1551 : : ! Warning : iat, ipos might be modified by this call
1552 : 34 : call vgh_rho(vv,chg,grho,hrho,dist,iat,ipos,0)
1553 : 34 : bcp(nbcp)%chg=chg
1554 : :
1555 : : end if ! ires==0
1556 : : end do srbcp
1557 : :
1558 [ + - ]: 5 : if(nbcp>0)then
1559 : :
1560 : : ! Order the BCP. CPs should appear by increasing values of x,y,z , the latter
1561 : : ! varying the fastest
1562 [ - + + - : 15 : ABI_MALLOC(sortguide,(nbcp))
+ - - + -
+ ]
1563 [ - + + - : 15 : ABI_MALLOC(indexcp,(nbcp))
+ - - + -
+ ]
1564 [ - + + - : 15 : ABI_MALLOC(cp_tmp,(nbcp))
+ - - + -
+ ]
1565 [ + + ]: 20 : do ii=3,1,-1
1566 : : ! DEBUG
1567 : : ! write(std_out,*)' cpdrv : sort on index ii=',ii
1568 : : ! ENDDEBUG
1569 : :
1570 [ + + ]: 117 : do jj=1,nbcp
1571 : : ! DEBUG
1572 : : ! write(std_out,*)bcp(jj)%vv(:)
1573 : : ! ENDDEBUG
1574 : 102 : sortguide(jj)=bcp(jj)%vv(ii)
1575 : 117 : indexcp(jj)=jj
1576 : : end do
1577 : :
1578 : : ! Try to be platform-independent. Might need a larger tolerance.
1579 : 15 : call sort_dp(nbcp,sortguide,indexcp,tol3)
1580 [ + + ]: 117 : do jj=1,nbcp
1581 : 117 : cp_tmp(jj)=bcp(indexcp(jj))
1582 : : end do
1583 [ + + ]: 122 : do jj=1,nbcp
1584 : 117 : bcp(jj)=cp_tmp(jj)
1585 : : end do
1586 : : end do
1587 : : ! DEBUG
1588 : : ! write(std_out,*)' cpdrv : after the sort '
1589 : : ! do jj=1,nbcp
1590 : : ! write(std_out,*)bcp(jj)%vv(:)
1591 : : ! end do
1592 : : ! ENDDEBUG
1593 : :
1594 : :
1595 : : ! Output the info about the BCP
1596 [ + + ]: 39 : do jj=1,nbcp
1597 : : write(untout,'(" Bonded atom (BAT) (indxatm,indxcell,position): ",/,2I6,3F16.8)')&
1598 [ + + ]: 136 : & bcp(jj)%iat,bcp(jj)%ipos,bcp(jj)%pom(:)
1599 [ + + ]: 136 : write(untout,'("%Bonding CP: ",3F16.8)') bcp(jj)%vv(:)
1600 [ + + ]: 136 : write(untout,'("%Eigenval. of Hessian: ",3F16.8)') bcp(jj)%ev(:)
1601 : : write(untout,'(a,a,a,3f16.8,a,a,3f16.8,a,a,3f16.8,a)') &
1602 : 34 : & ' Eigenvec. of Hessian:',char(10),&
1603 [ + + ]: 136 : & '-',bcp(jj)%vec(1,:),char(10),&
1604 [ + + ]: 136 : & '-',bcp(jj)%vec(2,:),char(10),&
1605 [ + + ]: 170 : & '-',bcp(jj)%vec(3,:),char(10)
1606 : : write(untout,'("%Density and laplacian in CP: ",2F16.8)') &
1607 : 34 : & bcp(jj)%chg, bcp(jj)%ev(1)+bcp(jj)%ev(2)+bcp(jj)%ev(3)
1608 : : write(untout,'("%Relative position of BCP (AT-CP,BAT-CP,AT-BAT,relative(AT): ",/,4F16.8)') &
1609 [ + + ]: 136 : & bcp(jj)%diff(:),bcp(jj)%diff(1)/bcp(jj)%diff(3)
1610 : 34 : write(untout,*) "********************************************************************"
1611 : : write(std_out,'(/," BCP: ",3F10.6,3E12.4,E12.4,/)') &
1612 [ + + + + ]: 238 : & bcp(jj)%rr(:),bcp(jj)%ev(:),bcp(jj)%ev(1)+bcp(jj)%ev(2)+bcp(jj)%ev(3)
1613 [ + + ]: 141 : write(std_out,'(":DISPC ",4F12.6)') bcp(jj)%diff(:),bcp(jj)%diff(1)/bcp(jj)%diff(3)
1614 : : end do
1615 : :
1616 [ - + ]: 5 : ABI_FREE(cp_tmp)
1617 [ - + ]: 5 : ABI_FREE(indexcp)
1618 [ - + ]: 5 : ABI_FREE(sortguide)
1619 : :
1620 : : end if ! nbcp>0
1621 : :
1622 [ + - ]: 5 : if (abs(bmin(inxat))>1.0d-12) then
1623 : 5 : rminl(inxat)=aim_dtset%coff1*bmin(inxat)
1624 : 5 : r0=bmin(inxat)
1625 : : else
1626 : 0 : r0=0._dp
1627 : : end if
1628 : :
1629 : : ! !AD-HOC PARAMETER
1630 : :
1631 [ + + ]: 28 : do ii=1,natom
1632 [ + + + + ]: 28 : if ((abs(bmin(ii))>1.0d-12).and.(ii /= inxat)) rminl(ii)=aim_dtset%coff2*bmin(ii)
1633 : : end do
1634 : :
1635 : : ! END WARNING
1636 : :
1637 : 5 : write(std_out,*) ' number of BCP:', nbcp
1638 : 5 : write(untout,'(" Number of BCP found: ",I4)') nbcp
1639 : 5 : nn=nbcp*(nbcp-1)*(nbcp-2)/6
1640 [ - + ]: 5 : if (bit_size(ii) <= nbcp+1) then
1641 : 0 : ABI_ERROR("b-test!")
1642 : : end if
1643 : :
1644 : : ! SEARCHING RCP
1645 : :
1646 : 5 : write(std_out,*)
1647 : 5 : write(std_out,*) "RING CRITICAL POINTS (RCP)"
1648 : 5 : write(std_out,*) "============================="
1649 : 5 : write(std_out,*)
1650 : :
1651 : 5 : write(untout,*)
1652 : 5 : write(untout,*) "RING CRITICAL POINTS (RCP)"
1653 : 5 : write(untout,*) "============================="
1654 : 5 : write(untout,*)
1655 : :
1656 : 5 : nrcp=0
1657 [ - + ]: 5 : if(aim_dtset%crit==1)nb_now=nbcp
1658 [ + - ]: 5 : if(aim_dtset%crit==2)nb_now=nb
1659 : : ! DEBUG
1660 : : ! nb_now=nbcp
1661 : : ! ENDDEBUG
1662 : 5 : nn=nb_now*(nb_now-1)/2
1663 [ - + + - : 15 : ABI_MALLOC(rcp,(nn))
+ - + - -
+ - + ]
1664 : :
1665 : : ! Loop on pairs of BCP or atoms
1666 : 5 : ipair=0
1667 [ - + + - : 15 : ABI_MALLOC(buffer,(16,nn))
+ - + - -
+ - + ]
1668 [ + + + + ]: 26593 : buffer=zero
1669 : :
1670 : : ! DEBUG
1671 : : ! write(std_out,*)ch10,ch10,' drvcpr : enter loop to search for RCPs,nb_now,nn=',nb_now,nn
1672 : : ! ENDDEBUG
1673 : :
1674 [ + + ]: 120 : do ii=1,nb_now-1
1675 [ + + ]: 1684 : srcp1: do jj=ii+1,nb_now
1676 : 1564 : ipair=ipair+1
1677 [ + - ]: 1679 : if(mod(ipair,nproc)==me)then
1678 [ - + ]: 1564 : if (aim_dtset%crit==1) then
1679 [ # # ]: 0 : vv(:)=xorig(:)+(bcp(ii)%rr(:)+bcp(jj)%rr(:))/2._dp
1680 [ + - ]: 1564 : else if (aim_dtset%crit==2) then
1681 [ + + ]: 6256 : vv(:)=xorig(:)*half+(xatm(:,ibat(ii))+atp(:,ipibat(ii))+xatm(:,ibat(jj))+atp(:,ipibat(jj)))*quarter
1682 : : end if
1683 : :
1684 : 1564 : call critic(aim_dtset,vv,ev,evec,aim_dmaxcs,ires,1)
1685 : :
1686 [ + + ]: 1564 : if(ires==1)then
1687 : : cycle srcp1
1688 : : end if
1689 : :
1690 : : ! Check that it is within the maximum allowed distance for a CP
1691 [ + + ]: 5768 : rr(:)=vv(:)-xorig(:)
1692 : 1442 : ss=vnorm(rr,0)
1693 [ - + ]: 1442 : if (ss > maxcpdst) then
1694 : 0 : write(std_out,*) 'RCP distance from atom exceed maxcpdst !'
1695 : 0 : cycle srcp1
1696 : : end if
1697 : : ! Check that it is a RCP
1698 : 1442 : nn=0
1699 [ + + ]: 5768 : do kk=1,3
1700 : 5768 : nn=nn+ev(kk)/abs(ev(kk))
1701 : : end do
1702 [ + + ]: 1442 : if (nn /= 1) then
1703 : 118 : write(std_out,*) ' the critical point that is found is not a RCP '
1704 : 118 : cycle srcp1
1705 : : end if
1706 : : ! Might be the same RCP than one already found on the same processor
1707 [ + + ]: 1324 : if (nrcp > 0) then
1708 [ + + ]: 8730 : do kk=1,nrcp
1709 [ + + ]: 33568 : pom(:)=vv(:)-rcp(kk)%rr(:)-xorig(:)
1710 : 8392 : dist=vnorm(pom,0)
1711 [ + + ]: 8730 : if (dist < aim_dtset%dpclim) then
1712 : 972 : write(std_out,*) ':RCP already known'
1713 : 972 : cycle srcp1
1714 : : end if
1715 : : end do
1716 : : end if
1717 : : ! If crit==2, check that it is on the Bader surface
1718 [ + - ]: 352 : if (aim_dtset%crit==2) then
1719 [ + + ]: 1408 : uu(:)=vv(:)-aim_epstep*rr(:)/ss
1720 : 352 : call aim_follow(aim_dtset,uu,aim_npmaxin,srch,iatinit,iposinit,iat,ipos,nstep)
1721 [ + + + + ]: 352 : if ((iat/=inxat).or.(inxcell/=ipos))then
1722 : 300 : write(std_out,*) ' RCP is not on the Bader surface (outside of it)'
1723 : 300 : cycle srcp1
1724 : : end if
1725 : : end if
1726 : 52 : nrcp=nrcp+1
1727 [ + + ]: 208 : rcp(nrcp)%rr(:)=vv(:)-xorig(:)
1728 : :
1729 [ + + ]: 208 : buffer(1:3,ipair)=vv
1730 [ + + ]: 208 : buffer(4:6,ipair)=ev
1731 [ + + ]: 208 : buffer(7:9,ipair)=evec(:,1)
1732 [ + + ]: 208 : buffer(10:12,ipair)=evec(:,2)
1733 [ + + ]: 208 : buffer(13:15,ipair)=evec(:,3)
1734 : 52 : buffer(16,ipair)=one
1735 : :
1736 : : ! DEBUG
1737 : : ! write(std_out,*)ch10,ch10,' drvcpr : ipair,candidate=',ipair,candidate
1738 : : ! ENDDEBUG
1739 : : end if
1740 : : end do srcp1
1741 : : end do
1742 : 5 : call xmpi_sum(buffer,xmpi_world,ierr)
1743 : :
1744 : 5 : nrcp=0
1745 : 5 : ipair=0
1746 [ + + ]: 120 : do ii=1,nb_now-1
1747 [ + + ]: 1684 : srcp: do jj=ii+1,nb_now
1748 : 1564 : ipair=ipair+1
1749 : 1564 : candidate=buffer(16,ipair)
1750 : :
1751 : : ! One CP has been found, must make tests to see whether it is a new RCP
1752 [ + + ]: 1679 : if (nint(candidate)==1) then
1753 : :
1754 [ + + ]: 208 : vv=buffer(1:3,ipair)
1755 [ + + ]: 208 : ev=buffer(4:6,ipair)
1756 [ + + ]: 208 : evec(:,1)=buffer(7:9,ipair)
1757 [ + + ]: 208 : evec(:,2)=buffer(10:12,ipair)
1758 [ + + ]: 208 : evec(:,3)=buffer(13:15,ipair)
1759 : :
1760 : : ! Check that it is not the same as a previous one
1761 [ + + ]: 52 : if (nrcp > 0) then
1762 [ + + ]: 429 : do kk=1,nrcp
1763 [ + + ]: 1528 : pom(:)=vv(:)-rcp(kk)%rr(:)-xorig(:)
1764 : 382 : dist=vnorm(pom,0)
1765 [ - + ]: 429 : if (dist < aim_dtset%dpclim) then
1766 : 0 : write(std_out,*) ':RCP already known'
1767 : 0 : cycle srcp
1768 : : end if
1769 : : end do
1770 : : end if
1771 : :
1772 : : ! A new RCP has been found !
1773 : 52 : nrcp=nrcp+1
1774 : :
1775 : : ! DEBUG
1776 : : ! write(std_out,*)' drvcpr : A new RCP has been found, for kk=',kk
1777 : : ! ENDDEBUG
1778 : :
1779 : :
1780 : 52 : rcp(nrcp)%iat=iat
1781 : 52 : rcp(nrcp)%ipos=ipos
1782 [ + + ]: 208 : rcp(nrcp)%rr(:)=vv(:)-xorig(:)
1783 [ + + + + ]: 676 : rcp(nrcp)%vec(:,:)=evec(:,:)
1784 [ + + ]: 208 : rcp(nrcp)%ev(:)=ev(:)
1785 [ + + ]: 208 : rcp(nrcp)%vv(:)=vv(:)
1786 : 52 : call vgh_rho(vv,chg,grho,hrho,dist,iat,ipos,0)
1787 : 52 : rcp(nrcp)%chg=chg
1788 : :
1789 : : end if ! ires==0
1790 : : end do srcp ! jj=ii+2,nb_now
1791 : : end do ! ii=1,nb_now-1
1792 : :
1793 [ - + ]: 5 : ABI_FREE(buffer)
1794 : :
1795 [ + - ]: 5 : if(nrcp>0)then
1796 : :
1797 : : ! Order the RCP. CPs should appear by increasing values of x,y,z , the latter
1798 : : ! varying the fastest
1799 [ - + + - : 15 : ABI_MALLOC(sortguide,(nrcp))
+ - - + -
+ ]
1800 [ - + + - : 15 : ABI_MALLOC(indexcp,(nrcp))
+ - - + -
+ ]
1801 [ - + + - : 15 : ABI_MALLOC(cp_tmp,(nrcp))
+ - - + -
+ ]
1802 [ + + ]: 20 : do ii=3,1,-1
1803 : : ! DEBUG
1804 : : ! write(std_out,*)' cpdrv : sort on index ii=',ii
1805 : : ! ENDDEBUG
1806 [ + + ]: 171 : do jj=1,nrcp
1807 : :
1808 : : ! DEBUG
1809 : : ! write(std_out,*)rcp(jj)%vv(:)
1810 : : ! ENDDEBUG
1811 : :
1812 : : ! Try to be platform-independent. Might need a larger tolerance.
1813 : 156 : sortguide(jj)=rcp(jj)%vv(ii)
1814 : 171 : indexcp(jj)=jj
1815 : : end do
1816 : 15 : call sort_dp(nrcp,sortguide,indexcp,tol3)
1817 [ + + ]: 171 : do jj=1,nrcp
1818 : 171 : cp_tmp(jj)=rcp(indexcp(jj))
1819 : : end do
1820 [ + + ]: 176 : do jj=1,nrcp
1821 : 171 : rcp(jj)=cp_tmp(jj)
1822 : : end do
1823 : : end do
1824 : :
1825 : : ! DEBUG
1826 : : ! write(std_out,*)' cpdrv : after the sort '
1827 : : ! do jj=1,nrcp
1828 : : ! write(std_out,*)rcp(jj)%vv(:)
1829 : : ! end do
1830 : : ! ENDDEBUG
1831 : :
1832 : :
1833 : : ! Write the Ring Critical Point information
1834 [ + + ]: 57 : do jj=1,nrcp
1835 [ + + ]: 208 : write(untout,'(";Ring CP: ",3F16.8)') rcp(jj)%vv(:)
1836 [ + + ]: 208 : write(untout,'("%Eigenval. of Hessian: ",3F16.8)') rcp(jj)%ev(:)
1837 : : write(untout,'(a,a,a,3f16.8,a,a,3f16.8,a,a,3f16.8,a)') &
1838 : 52 : & ' Eigenvec. of Hessian:',char(10),&
1839 [ + + ]: 208 : & '-',rcp(jj)%vec(1,:),char(10),&
1840 [ + + ]: 208 : & '-',rcp(jj)%vec(2,:),char(10),&
1841 [ + + ]: 260 : & '-',rcp(jj)%vec(3,:),char(10)
1842 : : write(untout,'("%Density and laplacian in CP: ",2F16.8)') &
1843 : 52 : & rcp(jj)%chg, rcp(jj)%ev(1)+rcp(jj)%ev(2)+rcp(jj)%ev(3)
1844 : 52 : write(untout,*) "********************************************************************"
1845 : : write(std_out,'(/," RCP: ",3F10.6,3E12.4,E12.4,/)') &
1846 [ + + + + ]: 369 : & rcp(jj)%rr(:),rcp(jj)%ev(:),rcp(jj)%ev(1)+rcp(jj)%ev(2)+rcp(jj)%ev(3)
1847 : : end do
1848 : :
1849 [ - + ]: 5 : ABI_FREE(cp_tmp)
1850 [ - + ]: 5 : ABI_FREE(indexcp)
1851 [ - + ]: 5 : ABI_FREE(sortguide)
1852 : :
1853 : : end if ! nrcp>0
1854 : :
1855 : 5 : write(untout,'(" Number of RCP found: ",I4)') nrcp
1856 : 5 : write(std_out,*) ' Number of RCP:', nrcp
1857 : :
1858 : : ! SEARCHING CCP
1859 : :
1860 : 5 : write(std_out,*)
1861 : 5 : write(std_out,*) "CAGE CRITICAL POINTS (CCP)"
1862 : 5 : write(std_out,*) "============================="
1863 : 5 : write(std_out,*)
1864 : :
1865 : 5 : write(untout,*)
1866 : 5 : write(untout,*) "CAGE CRITICAL POINTS (CCP)"
1867 : 5 : write(untout,*) "============================="
1868 : 5 : write(untout,*)
1869 : :
1870 : :
1871 : 5 : nn=nrcp*(nrcp-1)/2
1872 [ - + + - : 15 : ABI_MALLOC(ccp,(nn))
+ - + - -
+ - + ]
1873 : :
1874 : 5 : nccp=0
1875 [ + + ]: 52 : do ii=1,nrcp-1
1876 [ + + ]: 434 : srccp: do jj=ii+1,nrcp
1877 [ + + ]: 1528 : vv(:)=xorig(:)+(rcp(ii)%rr(:)+rcp(jj)%rr(:))/2._dp
1878 : 382 : call critic(aim_dtset,vv,ev,evec,aim_dmaxcs,ires,3)
1879 [ + + ]: 429 : if (ires==0) then
1880 [ + + ]: 1524 : rr(:)=vv(:)-xorig(:)
1881 : 381 : ss=vnorm(rr,0)
1882 [ + + ]: 381 : if (ss > maxcpdst) then
1883 : 5 : write(std_out,*) 'CCP distance from atom exceed maxcpdst !'
1884 : 5 : cycle srccp
1885 : : end if
1886 : 376 : nn=0
1887 [ + + ]: 1504 : do kk=1,3
1888 : 1504 : nn=nn+ev(kk)/abs(ev(kk))
1889 : : end do
1890 [ + + ]: 376 : if (nn /= 3) then
1891 : 33 : write(std_out,*) ' the critical point that is found is not a CCP '
1892 : 33 : cycle srccp
1893 : : end if
1894 : :
1895 [ + + ]: 343 : if (nccp > 0) then
1896 [ + + ]: 1523 : do kk=1,nccp
1897 [ + + ]: 6000 : pom(:)=vv(:)-ccp(kk)%rr(:)-xorig(:)
1898 : 1500 : dist=vnorm(pom,0)
1899 [ + + ]: 1523 : if (dist < aim_dtset%dpclim) then
1900 : 315 : write(std_out,*) ':CCP already known'
1901 : 315 : cycle srccp
1902 : : end if
1903 : : end do
1904 : : end if
1905 [ + - ]: 28 : if (aim_dtset%crit==2) then
1906 [ + + ]: 112 : uu(:)=vv(:)-aim_epstep*rr(:)/ss
1907 : 28 : call aim_follow(aim_dtset,uu,aim_npmaxin,srch,iatinit,iposinit,iat,ipos,nstep)
1908 [ + + - + ]: 28 : if ((iat/=inxat).or.(inxcell/=ipos)) then
1909 : 1 : write(std_out,*) ' This CCP is not on the Bader surface (outside of it)'
1910 : 1 : cycle srccp
1911 : : end if
1912 : : end if
1913 : :
1914 : 27 : nccp=nccp+1
1915 : :
1916 : 27 : ccp(nccp)%iat=iat
1917 : 27 : ccp(nccp)%ipos=ipos
1918 [ + + ]: 108 : ccp(nccp)%rr(:)=vv(:)-xorig(:)
1919 [ + + + + ]: 351 : ccp(nccp)%vec(:,:)=evec(:,:)
1920 [ + + ]: 108 : ccp(nccp)%ev(:)=ev(:)
1921 [ + + ]: 108 : ccp(nccp)%vv(:)=vv(:)
1922 : 27 : call vgh_rho(vv,chg,grho,hrho,dist,iat,ipos,0)
1923 : 27 : ccp(nccp)%chg=chg
1924 : :
1925 : : end if
1926 : : end do srccp
1927 : : end do
1928 : :
1929 [ + + ]: 5 : if(nccp>0)then
1930 : :
1931 : : ! Order the CCP. CPs should appear by increasing values of x,y,z , the latter
1932 : : ! varying the fastest
1933 [ - + + - : 12 : ABI_MALLOC(sortguide,(nccp))
+ - - + -
+ ]
1934 [ - + + - : 12 : ABI_MALLOC(indexcp,(nccp))
+ - - + -
+ ]
1935 [ - + + - : 12 : ABI_MALLOC(cp_tmp,(nccp))
+ - - + -
+ ]
1936 [ + + ]: 16 : do ii=3,1,-1
1937 [ + + ]: 93 : do jj=1,nccp
1938 : : ! Try to be platform-independent. Might need a larger tolerance.
1939 : 81 : sortguide(jj)=ccp(jj)%vv(ii)
1940 : 93 : indexcp(jj)=jj
1941 : : end do
1942 : 12 : call sort_dp(nccp,sortguide,indexcp,tol3)
1943 [ + + ]: 93 : do jj=1,nccp
1944 : 93 : cp_tmp(jj)=ccp(indexcp(jj))
1945 : : end do
1946 [ + + ]: 97 : do jj=1,nccp
1947 : 93 : ccp(jj)=cp_tmp(jj)
1948 : : end do
1949 : : end do
1950 : :
1951 : : ! Write the Cage Critical Point information
1952 [ + + ]: 31 : do jj=1,nccp
1953 [ + + ]: 108 : write(untout,'("%Cage CP: ",3F16.8)') ccp(jj)%vv(:)
1954 [ + + ]: 108 : write(untout,'("%Eigenval. of Hessian: ",3F16.8)') ccp(jj)%ev(:)
1955 : : write(untout,'(a,a,a,3f16.8,a,a,3f16.8,a,a,3f16.8,a)') &
1956 : 27 : & ' Eigenvec. of Hessian:',char(10),&
1957 [ + + ]: 108 : & '-',ccp(jj)%vec(1,:),char(10),&
1958 [ + + ]: 108 : & '-',ccp(jj)%vec(2,:),char(10),&
1959 [ + + ]: 135 : & '-',ccp(jj)%vec(3,:),char(10)
1960 : : write(untout,'("%Density and laplacian in CP: ",2F16.8)') &
1961 : 27 : & ccp(jj)%chg, ccp(jj)%ev(1)+ccp(jj)%ev(2)+ccp(jj)%ev(3)
1962 : 27 : write(untout,*) "********************************************************************"
1963 : : write(std_out,'(/," CCP: ",3F10.6,3E12.4,E12.4,/)') &
1964 [ + + + + ]: 193 : & ccp(jj)%rr(:),ccp(jj)%ev(:),ccp(jj)%ev(1)+ccp(jj)%ev(2)+ccp(jj)%ev(3)
1965 : : end do
1966 : :
1967 [ - + ]: 4 : ABI_FREE(sortguide)
1968 [ - + ]: 4 : ABI_FREE(indexcp)
1969 [ - + ]: 4 : ABI_FREE(cp_tmp)
1970 : :
1971 : : end if ! nccp>0
1972 : :
1973 : 5 : write(untout,'(" Number of CCP found: ",I4)') nccp
1974 : 5 : write(std_out,*) 'Number of CCP:', nccp
1975 : 5 : write(std_out,*)
1976 : 5 : write(untout,*)
1977 : 5 : write(std_out, '(a,3i8)' ) 'BCP-RCP-CCP', nbcp,nrcp,nccp
1978 : 5 : write(untout, '(a,3i8)' ) 'BCP-RCP-CCP', nbcp,nrcp,nccp
1979 : :
1980 : 5 : write(std_out,*)
1981 : 5 : write(std_out,*) "==============================="
1982 : 5 : write(std_out,*) "END OF CRITICAL POINTS ANALYSIS"
1983 : 5 : write(std_out,*)
1984 : :
1985 : 5 : write(untout,*)
1986 : 5 : write(untout,*) "==============================="
1987 : 5 : write(untout,*) "END OF CRITICAL POINTS ANALYSIS"
1988 : 5 : write(untout,*)
1989 : :
1990 : :
1991 : : ! Output of the CPs
1992 : :
1993 : 5 : write(untc,'(I4, " :BCP''s, coordinates, laplacian eigs, type of bonding at., sum of lap.eigs., density")') nbcp
1994 [ + + ]: 39 : do ii=1,nbcp
1995 : : write(untc,'(3F10.6,3E12.4,I4,2E12.4)') &
1996 [ + + + + ]: 243 : & bcp(ii)%rr(:),bcp(ii)%ev(:),bcp(ii)%iat,bcp(ii)%ev(1)+bcp(ii)%ev(2)+bcp(ii)%ev(3),bcp(ii)%chg
1997 : : end do
1998 : :
1999 : 5 : write(untc,'(I4, " :RCP''s, coordinates, laplacian eigenvalues, sum of these, density")') nrcp
2000 [ + + ]: 57 : do ii=1,nrcp
2001 [ + + ]: 208 : vv(:)=rcp(ii)%rr(:)+xorig(:)
2002 : 52 : call vgh_rho(vv,chg,grho,hrho,dist,iat,ipos,0)
2003 : : write(untc,'(3F10.6,3E12.4,2E12.4)') &
2004 [ + + + + ]: 369 : & rcp(ii)%rr(:),rcp(ii)%ev(:),rcp(ii)%ev(1)+rcp(ii)%ev(2)+rcp(ii)%ev(3),rcp(ii)%chg
2005 : : end do
2006 : :
2007 : 5 : write(untc,'(I4, " :CCP''s coordinates, laplacian eigenvalues, sum of these, density")') nccp
2008 [ + + ]: 32 : do ii=1,nccp
2009 [ + + ]: 108 : vv(:)=ccp(ii)%rr(:)+xorig(:)
2010 : 27 : call vgh_rho(vv,chg,grho,hrho,dist,iat,ipos,0)
2011 : : write(untc,'(3F10.6,3E12.4,2E12.4)') &
2012 [ + + + + ]: 194 : & ccp(ii)%rr(:),ccp(ii)%ev(:),ccp(ii)%ev(1)+ccp(ii)%ev(2)+ccp(ii)%ev(3),ccp(ii)%chg
2013 : : end do
2014 : :
2015 : : end if ! End the condition on aim_dtset%crit > 0
2016 : :
2017 : : !Reading of the CPs from the file
2018 : :
2019 [ - + ]: 5 : if (aim_dtset%crit==-1) then
2020 : 0 : read(untc,*) nbcp
2021 [ # # # # : 0 : ABI_MALLOC(bcp,(nbcp))
# # # # #
# # # #
# ]
2022 [ # # ]: 0 : do ii=1,nbcp
2023 [ # # ]: 0 : read(untc,*) bcp(ii)%rr(:)
2024 : : end do
2025 : 0 : read(untc,*) nrcp
2026 [ # # # # : 0 : ABI_MALLOC(rcp,(nrcp))
# # # # #
# # # #
# ]
2027 [ # # ]: 0 : do ii=1,nrcp
2028 [ # # ]: 0 : read(untc,*) rcp(ii)%rr(:)
2029 : : end do
2030 : 0 : read(untc,*) nccp
2031 [ # # # # : 0 : ABI_MALLOC(ccp,(nccp))
# # # # #
# # # #
# ]
2032 [ # # ]: 0 : do ii=1,nccp
2033 [ # # ]: 0 : read(untc,*) ccp(ii)%rr(:)
2034 : : end do
2035 : : end if
2036 : :
2037 [ + + ]: 39 : do ii=1,nbcp
2038 [ + + ]: 136 : pc(:,ii)=bcp(ii)%rr(:)
2039 : 39 : icpc(ii)=-1
2040 : : end do
2041 [ + + ]: 57 : do ii=1,nrcp
2042 [ + + ]: 208 : pc(:,nbcp+ii)=rcp(ii)%rr(:)
2043 : 57 : icpc(nbcp+ii)=1
2044 : : end do
2045 [ + + ]: 32 : do ii=1,nccp
2046 [ + + ]: 108 : pc(:,nbcp+nrcp+ii)=ccp(ii)%rr(:)
2047 : 32 : icpc(nbcp+nrcp+ii)=3
2048 : : end do
2049 : 5 : npc=nbcp+nrcp+nccp
2050 : :
2051 : : !Checking
2052 : :
2053 [ + - ]: 5 : if (allocated(bcp)) then
2054 [ + + ]: 39 : do ii=1,nbcp
2055 [ + + ]: 1209 : do jj=1,npc
2056 : 1170 : iat=bcp(ii)%iat
2057 : 1170 : ipos=bcp(ii)%ipos
2058 [ + - + - ]: 1204 : if ((iat/=0).and.(ipos/=0)) then
2059 [ + + ]: 4680 : pom(:)=pc(:,jj)+xorig(:)-xatm(:,iat)-atp(:,ipos)
2060 : 1170 : ss=aim_dtset%coff2*vnorm(pom,0)
2061 [ + + ]: 1170 : if (rminl(iat) >= ss) rminl(iat)=ss
2062 : : end if
2063 : : end do
2064 : : end do
2065 : 5 : ABI_FREE(bcp)
2066 : : end if
2067 [ + + ]: 28 : do ii=1,natom
2068 : 28 : write(std_out,*) 'atom: ', ii, rminl(ii)
2069 : : end do
2070 : :
2071 [ + - ]: 5 : if(allocated(rcp)) then
2072 : 5 : ABI_FREE(rcp)
2073 : : end if
2074 [ + - ]: 5 : if(allocated(ccp)) then
2075 : 5 : ABI_FREE(ccp)
2076 : : end if
2077 : :
2078 : : !END CP ANALYSIS
2079 : :
2080 : 5 : call timein(ttcp,wall)
2081 : 5 : ttcp=ttcp-tt0
2082 : :
2083 [ + - - + ]: 5 : end subroutine cpdrv
2084 : : !!***
2085 : :
2086 : : !!****f* m_bader/critic
2087 : : !! NAME
2088 : : !! critic
2089 : : !!
2090 : : !! FUNCTION
2091 : : !! Search for a critical point starting from point vv
2092 : : !!
2093 : : !! INPUTS
2094 : : !! aim_dtset= the structured entity containing all input variables
2095 : : !! dmax= maximal step
2096 : : !! sort= 0(default) general CP searching (Newton-Raphson)
2097 : : !! -1,1,3 searching of specific type CP (Popelier)
2098 : : !!
2099 : : !! OUTPUT
2100 : : !! ev= eigenvalues (ordered) of the Hessian in the final point
2101 : : !! zz= eigenvectors of the Hessian in the final point
2102 : : !! ires= if ires==0 => CP found
2103 : : !! if ires==1 => CP not found within the maximum steps
2104 : : !!
2105 : : !! SIDE EFFECTS
2106 : : !! vv(3)= starting point and final point
2107 : : !!
2108 : : !! SOURCE
2109 : :
2110 : 2066 : subroutine critic(aim_dtset,vv,ev,zz,dmax,ires,sort)
2111 : :
2112 : : !Arguments ------------------------------------
2113 : : !scalars
2114 : : integer,intent(in) :: sort
2115 : : integer,intent(out) :: ires
2116 : : real(dp),intent(in) :: dmax
2117 : : !arrays
2118 : : real(dp),intent(inout) :: vv(3)
2119 : : real(dp),intent(out) :: ev(3),zz(3,3)
2120 : : !no_abirules
2121 : : type(aim_dataset_type), intent(in) :: aim_dtset
2122 : :
2123 : : !Local variables ------------------------------
2124 : : !scalars
2125 : : integer :: iat,id,ii,info,ipos,istep,jii,jj,nrot
2126 : : real(dp),parameter :: evol=1.d-3
2127 : : real(dp) :: chg,dg,dltcmax,dv,dvold,rr,ss
2128 : : logical :: oscl,outof
2129 : : !arrays
2130 : : integer :: ipiv(3)
2131 : : real(dp) :: dc(3),ff(3),grho(3),hrho(3,3),lp(3),vold(3),vt(3),yy(3,3)
2132 : 2066 : real(dp),allocatable :: lamb(:),pom(:,:),pom2(:,:)
2133 : :
2134 : : !************************************************************************
2135 : :
2136 : : !DEBUG
2137 : : !write(std_out,*)' critic : enter '
2138 : : !ENDDEBUG
2139 : 2066 : oscl=.false.
2140 [ + + ]: 2066 : if (sort==3) then
2141 [ - + ]: 382 : ABI_MALLOC(pom,(4,4))
2142 [ - + ]: 382 : ABI_MALLOC(pom2,(4,4))
2143 [ - + ]: 382 : ABI_MALLOC(lamb,(4))
2144 [ + - ]: 1684 : elseif (sort/=0) then
2145 [ - + ]: 1684 : ABI_MALLOC(pom,(3,3))
2146 [ - + ]: 1684 : ABI_MALLOC(pom2,(3,3))
2147 [ - + ]: 1684 : ABI_MALLOC(lamb,(3))
2148 : : end if
2149 : :
2150 : :
2151 : 2066 : deb=.false.
2152 : 2066 : istep=0
2153 : 2066 : ires=0
2154 : :
2155 : : !DEBUG
2156 : : !write(std_out,'(":POSIN ",3F16.8)') vv
2157 : : !do jj=1,3
2158 : : !vt(jj)=rprimd(1,jj)*vv(1)+rprimd(2,jj)*vv(2)+rprimd(3,jj)*vv(3)
2159 : : !end do
2160 : : !write(std_out,'(":RBPOSIN ",3F16.8)') vt
2161 : : !ENDDEBUG
2162 : :
2163 : 2066 : call vgh_rho(vv,chg,grho,hrho,rr,iat,ipos,0)
2164 : :
2165 : : !write(std_out,'(":GRAD ",3F16.8)') grho
2166 : : !write(std_out,'(":HESSIAN ",/,3F16.8,/,3F16.8,/,3F16.8)') ((hrho(ii,jj),jj=1,3),ii=1,3)
2167 : :
2168 : : dg=1.0_dp
2169 : 2066 : dv=1.0_dp
2170 : 2066 : dg = vnorm(grho,0)
2171 : :
2172 [ - + ]: 2066 : if (chg < aim_rhomin) then
2173 : 0 : ires=1
2174 : : ! DEBUG
2175 : : ! write(std_out,*)' critic : exit, ires=1'
2176 : : ! ENDDEBUG
2177 : 0 : return
2178 : : end if
2179 : :
2180 : : !main cycle => limits (adhoc):
2181 : : !aim_dtset%lstep - minimal step
2182 : : !aim_dtset%lgrad - minimal norm of gradient
2183 : : !aim_maxstep - max number of steps
2184 : :
2185 [ + + + + : 92632 : do while ((dv>aim_dtset%lstep).and.(dg>aim_dtset%lgrad).and.(istep<aim_maxstep))
+ + ]
2186 : 90566 : istep=istep+1
2187 : 90566 : vold(:)=vv(:)
2188 : 90566 : dvold=dv
2189 : 90566 : ev(:)=0._dp
2190 : 90566 : yy(:,:)=0._dp
2191 : 90566 : call jacobi(hrho,3,3,ev,yy,nrot) ! eigenval of Hessian
2192 : 90566 : call ordr(ev,yy,3,-1) ! ordering
2193 : :
2194 : : ! modification of the Newton-Raphson step to searching
2195 : : ! specific type of CP (Popelier algorithm)
2196 : :
2197 : 90566 : ff(:)=0._dp
2198 : 90566 : lp(:)=0._dp
2199 : 90566 : dc(:)=0._dp
2200 : 90566 : outof=.false.
2201 [ + + ]: 362264 : do ii=1,3
2202 [ + + ]: 1177358 : do jj=1,3
2203 : 1086792 : ff(ii)=ff(ii)+yy(jj,ii)*grho(jj)
2204 : : end do
2205 : : end do
2206 : 90566 : id=sign(1._dp,ev(1))+sign(1._dp,ev(2))+sign(1._dp,ev(3))
2207 [ + + ]: 90566 : if (id /= sort) then
2208 : 26687 : outof=.true.
2209 : 488 : select case (sort)
2210 : : case (-1)
2211 : 488 : lp(3)=0.5_dp*(ev(3)-sqrt(ev(3)*ev(3)+4._dp*ff(3)*ff(3)))
2212 [ + + + + ]: 6344 : pom(:,:)=0._dp
2213 [ + + + + ]: 6344 : pom2(:,:)=0._dp
2214 [ + + ]: 1952 : lamb(:)=0._dp
2215 [ + + ]: 1464 : do ii=1,2
2216 : 976 : pom(ii,ii)=ev(ii)
2217 : 976 : pom(ii,3)=ff(ii)
2218 : 1464 : pom(3,ii)=ff(ii)
2219 : : end do
2220 : 488 : call jacobi(pom,3,3,lamb,pom2,nrot)
2221 : 488 : call ordr(lamb,pom2,3,1)
2222 [ + - ]: 488 : do ii=1,3
2223 : 488 : lp(1)=lamb(ii)
2224 [ - + ]: 488 : if (abs(pom2(3,ii))>1.0d-24) exit
2225 : : end do
2226 : 488 : lp(2)=lp(1)
2227 : :
2228 : : ! write(std_out,*) (ev(ii),ii=1,3)
2229 : : ! write(std_out,*) (lamb(ii),ii=1,3)
2230 : : ! write(std_out,*) ':ID ',id,lp(1),lp(3)
2231 : :
2232 : : case (1)
2233 : 20471 : lp(1)=0.5_dp*(ev(1)+sqrt(ev(1)*ev(1)+4._dp*ff(1)*ff(1)))
2234 [ + + + + ]: 266123 : pom(:,:)=0._dp
2235 [ + + + + ]: 266123 : pom2(:,:)=0._dp
2236 [ + + ]: 81884 : lamb(:)=0._dp
2237 [ + + ]: 61413 : do ii=2,3
2238 : 40942 : pom(ii-1,ii-1)=ev(ii)
2239 : 40942 : pom(ii-1,3)=ff(ii)
2240 : 61413 : pom(3,ii-1)=ff(ii)
2241 : : end do
2242 : 20471 : call jacobi(pom,3,3,lamb,pom2,nrot)
2243 : 20471 : call ordr(lamb,pom2,3,1)
2244 [ + - ]: 20471 : do ii=3,1,-1
2245 : 20471 : lp(2)=lamb(ii)
2246 [ - + ]: 20471 : if (abs(pom2(3,ii))>1.0d-24) exit
2247 : : end do
2248 : 20471 : lp(3)=lp(2)
2249 : :
2250 : : case (3)
2251 [ + + + + ]: 120288 : pom(:,:)=0._dp
2252 [ + + + + ]: 120288 : pom2(:,:)=0._dp
2253 [ + + ]: 28640 : lamb(:)=0._dp
2254 [ + + ]: 22912 : do ii=1,3
2255 : 17184 : pom(ii,ii)=ev(ii)
2256 : 17184 : pom(ii,4)=ff(ii)
2257 : 22912 : pom(4,ii)=ff(ii)
2258 : : end do
2259 : 5728 : call jacobi(pom,4,4,lamb,pom2,nrot)
2260 : 5728 : call ordr(lamb,pom2,4,1)
2261 [ + - ]: 5728 : do ii=4,1,-1
2262 : 5728 : lp(1)=lamb(ii)
2263 [ - + ]: 5728 : if (abs(pom2(4,ii))>1.0d-24) exit
2264 : : end do
2265 : 5728 : lp(2)=lp(1); lp(3)=lp(1)
2266 : : case default
2267 [ + + + - ]: 26687 : lp(:)=0._dp
2268 : : end select
2269 : : end if
2270 : :
2271 [ + + ]: 345123 : do ii=1,3
2272 [ + + ]: 345123 : if (abs(ev(ii)-lp(ii))<1.0d-24) then
2273 : : outof=.false.
2274 : : exit
2275 : : end if
2276 : : end do
2277 [ + + ]: 362264 : do ii=1,3 ! SEARCHING STEP
2278 [ + + ]: 1177358 : do jj=1,3
2279 [ + + ]: 1086792 : if (outof) then
2280 : 184815 : dc(ii)=dc(ii)+ff(jj)*yy(ii,jj)/(ev(jj)-lp(jj))
2281 [ + - ]: 630279 : elseif (abs(ev(jj))>1.0d-24) then
2282 : 630279 : dc(ii)=dc(ii)+ff(jj)*yy(ii,jj)/ev(jj)
2283 : : else
2284 : 0 : ABI_ERROR("zero eigval of Hessian")
2285 : : end if
2286 : : end do
2287 : : end do
2288 : :
2289 : 90566 : dltcmax = vnorm(dc,0)
2290 [ + + ]: 90566 : if (dltcmax>dmax) then ! STEP RESTRICTION
2291 [ + + ]: 148936 : do ii=1,3
2292 : 148936 : dc(ii)=dc(ii)*dmax/dltcmax
2293 : : end do
2294 : : end if ! primitive handling of oscillations
2295 : 90566 : ss=vnorm(dc,0) ! usually not needed
2296 : 90566 : ss=abs(ss-dv)/ss
2297 [ + + + + ]: 90566 : if ((ss < evol).and.(oscl)) then
2298 [ + + ]: 77684 : dc(:)=dc(:)/2._dp
2299 : : end if
2300 : :
2301 : :
2302 [ + + ]: 362264 : do ii=1,3
2303 : 362264 : vv(ii) = vv(ii) - dc(ii)
2304 : : end do
2305 : :
2306 : : ! DEBUG
2307 : : ! write(std_out,'(":POSIN ",3F16.8)') vv
2308 : : ! ENDDEBUG
2309 : :
2310 : 90566 : call vgh_rho(vv,chg,grho,hrho,rr,iat,ipos,0)
2311 : 90566 : dg = vnorm(grho,0)
2312 : :
2313 [ - + ]: 90566 : if (deb) then ! DEBUGG OUTPUT
2314 : 0 : write(std_out,'("AFTER STEP ===================================")')
2315 [ # # # # ]: 0 : write(std_out,'(":HESSIAN^(-1) ",/,3F16.8,/,3F16.8,/,3F16.8)') ((yy(ii,jii),jii=1,3),ii=1,3)
2316 : 0 : write(std_out,'(":DC ",3F16.8)') dc
2317 : 0 : write(std_out,*) 'STEP ',istep
2318 : 0 : write(std_out,'(":POS ",3F16.8)') vv
2319 : 0 : write(std_out,'(":GRAD ",3F16.8)') grho
2320 : 0 : write(std_out,*) ':DGRAD,CHG ',dg,chg
2321 [ # # # # ]: 0 : write(std_out,'(":HESSIAN ",/,3F16.8,/,3F16.8,/,3F16.8)') ((hrho(ii,jii),jii=1,3),ii=1,3)
2322 : : end if
2323 [ + + ]: 362264 : vt(:)=vv(:)-vold(:)
2324 : 90566 : dv=vnorm(vt,0)
2325 : 90566 : ss=abs(dvold-dv)/dv
2326 [ + + ]: 92632 : if (ss < evol) oscl=.true.
2327 : : end do
2328 : :
2329 : : !end of main cycle
2330 : :
2331 : : !the final output
2332 : :
2333 : 2066 : write(std_out,*) 'iste:',istep, dv, dg
2334 [ + + ]: 2066 : if (istep>=aim_maxstep)then
2335 : 347 : write(std_out,*) ' istep=MAXSTEP ! Examine lstep2 and lgrad2 .'
2336 [ + + + + ]: 347 : if ( (dv>aim_dtset%lstep2) .and. (dg>aim_dtset%lgrad2 )) then
2337 : 127 : write(std_out,'(":POSOUT ",3F16.8)') vv
2338 : 127 : ires=1
2339 : : end if
2340 : : end if
2341 : :
2342 : 2066 : vt(:)=vv(:)
2343 : :
2344 : : !write(std_out,'(":POSOUT ",3F16.8)') vv
2345 : : !write(std_out,'(":RBPOSOUT ",3F16.8)') vt
2346 : :
2347 : 2066 : call vgh_rho(vv,chg,grho,hrho,rr,iat,ipos,0)
2348 : :
2349 : : !write(std_out,'(":GRAD ",3F16.8)') grho
2350 : : !write(std_out,'(":HESSIAN ",/,3F16.8,/,3F16.8,/,3F16.8)')&
2351 : : !& ((hrho(ii,jii),jii=1,3),ii=1,3)
2352 : :
2353 : :
2354 : : !FINAL INVERSION OF HESSIAN
2355 : :
2356 : 2066 : call ludcmp(hrho,3,3,ipiv,id,info)
2357 [ - + ]: 2066 : if (info /= 0) then
2358 : 0 : write(std_out,*) 'Error inverting hrho:'
2359 [ # # ]: 0 : do ii=1,3
2360 : 0 : write(std_out,*) (hrho(ii,jii),jii=1,3)
2361 : : end do
2362 : 0 : ires=1
2363 : : ! DEBUG
2364 : : ! write(std_out,*)' critic : exit, ires=1'
2365 : : ! ENDDEBUG
2366 : 0 : return
2367 : : ! stop 'ERROR INVERTING HESSIAN'
2368 : : end if
2369 [ + + ]: 8264 : do ii=1,3
2370 [ + + ]: 24792 : yy(ii,1:3)=0.
2371 : 8264 : yy(ii,ii)=1.
2372 : : end do
2373 [ + + ]: 8264 : do jii=1,3
2374 : 8264 : call lubksb(hrho,3,3,ipiv,yy(1,jii))
2375 : : end do
2376 : :
2377 : :
2378 : : !write(std_out,'(":HESSIAN^(-1) ",/,3F16.8,/,3F16.8,/,3F16.8)') ((y(ii,jii),jii=1,3),ii=1,3)
2379 : :
2380 : 2066 : call vgh_rho(vv,chg,grho,hrho,rr,iat,ipos,0)
2381 : :
2382 : : !write(std_out,'("LAPLAC:",F16.8)') hrho(1,1)+hrho(2,2)+hrho(3,3)
2383 : :
2384 : 2066 : call jacobi(hrho,3,3,ev,yy,nrot)
2385 : 2066 : call ordr(ev,yy,3,1)
2386 : 2066 : zz(:,:)=yy(:,:)
2387 : :
2388 : : !do ii=1,3
2389 : : !do jii=1,3
2390 : : !zz(ii,jii)=yy(jii,ii)
2391 : : !end do
2392 : : !end do
2393 : :
2394 : : !write(std_out,'(":AUTOVAL ",3F16.8)') (ev(ii),ii=1,3)
2395 : : !write(std_out,'(":AUTOVEC ",/,3F16.8,/,3F16.8,/,3F16.8)') ((zz(ii,jii),ii=1,3),jii=1,3)
2396 : :
2397 [ + - ]: 2066 : if (sort/=0) then
2398 [ - + ]: 2066 : ABI_FREE(pom)
2399 [ - + ]: 2066 : ABI_FREE(pom2)
2400 [ - + ]: 2066 : ABI_FREE(lamb)
2401 : : end if
2402 : :
2403 : : !DEBUG
2404 : : !write(std_out,*)' critic : exit, ires= ',ires
2405 : : !ENDDEBUG
2406 [ - + - + : 2066 : end subroutine critic
- + - - -
- - - ]
2407 : : !!***
2408 : :
2409 : : !!****f* m_bader/ordr
2410 : : !! NAME
2411 : : !! ordr
2412 : : !!
2413 : : !! FUNCTION
2414 : : !!
2415 : : !! INPUTS
2416 : : !! (to be filled)
2417 : : !!
2418 : : !! OUTPUT
2419 : : !! (to be filled)
2420 : : !!
2421 : : !! SOURCE
2422 : : !!
2423 : :
2424 : 119319 : subroutine ordr(aa,dd,nn,cff)
2425 : :
2426 : : !Arguments ----------------------------
2427 : : !scalars
2428 : : integer,intent(in) :: cff,nn
2429 : : !arrays
2430 : : real(dp),intent(inout) :: aa(nn),dd(nn,nn)
2431 : :
2432 : : !Local variables ----------------------
2433 : : !scalars
2434 : : integer :: ii,jj,kk
2435 : : real(dp) :: uu
2436 : :
2437 : : ! *********************************************************************
2438 : :
2439 [ + + ]: 363685 : do ii=1,nn-1
2440 : 244366 : kk=ii
2441 : 244366 : uu=aa(ii)
2442 [ + + ]: 619507 : do jj=ii+1,nn
2443 [ + + ]: 619507 : if (cff==1) then
2444 [ + + ]: 103443 : if (aa(jj) >= uu+tol12) then
2445 : 375141 : kk=jj
2446 : 375141 : uu=aa(jj)
2447 : : end if
2448 : : else
2449 [ + + ]: 271698 : if (aa(jj) <= uu-tol12) then
2450 : 375141 : kk=jj
2451 : 375141 : uu=aa(jj)
2452 : : end if
2453 : : end if
2454 : : end do
2455 [ + + ]: 363685 : if (kk /= ii) then
2456 : 138553 : aa(kk)=aa(ii)
2457 : 138553 : aa(ii)=uu
2458 [ + + ]: 568065 : do jj=1,nn
2459 : 429512 : uu=dd(jj,ii)
2460 : 429512 : dd(jj,ii)=dd(jj,kk)
2461 : 568065 : dd(jj,kk)=uu
2462 : : end do
2463 : : end if
2464 : : end do
2465 : 119319 : end subroutine ordr
2466 : : !!***
2467 : :
2468 : : !!****f* m_bader/critics
2469 : : !! NAME
2470 : : !! critics
2471 : : !!
2472 : : !! FUNCTION
2473 : : !! Search for critical points starting between
2474 : : !! atom inxat and its neighbors.
2475 : : !!
2476 : : !! INPUTS
2477 : : !! aim_dtset= the structured entity containing all input variables
2478 : : !! dstmax=maximum distance to search for neighbors
2479 : : !! stwo, sthree, sfour: logical switches (TRUE/FALSE) indicating
2480 : : !! to search CP starting in the middle point
2481 : : !! of two, three or four atoms. One of these
2482 : : !! atoms is inxat.
2483 : : !!
2484 : : !! OUTPUT
2485 : : !! (see side effects)
2486 : : !!
2487 : : !! SIDE EFFECTS
2488 : : !! This routines acts primarily on the data contained in the aim_prom module
2489 : : !!
2490 : : !! WARNING
2491 : : !! This file does not follow the ABINIT coding rules (yet)
2492 : : !!
2493 : : !! SOURCE
2494 : :
2495 : 0 : subroutine critics(aim_dtset,inxat,stwo,sthree,sfour,dstmax)
2496 : :
2497 : : !Arguments ------------------------------------
2498 : : !scalars
2499 : : integer,intent(in) :: inxat
2500 : : real(dp),intent(in) :: dstmax
2501 : : logical,intent(in) :: sfour,sthree,stwo
2502 : : !no_abirules
2503 : : type(aim_dataset_type), intent(in) :: aim_dtset
2504 : :
2505 : : !Local variables ------------------------------
2506 : : !scalars
2507 : : integer :: i1,i2,i3,iat,ii,ipos,ires,jii,jj,kjj,kk,ll,n1,n2,n3,nb,nc
2508 : : integer :: nshell
2509 : : real(dp) :: chg,dif1,dif2,diff,dist,olddist,rr
2510 : : ! real(dp) :: ss,uu
2511 : : logical :: found,inter
2512 : : !arrays
2513 : 0 : integer :: ibat(nnpos*natom),inat(nnpos*natom),ipibat(nnpos*natom)
2514 : 0 : integer :: nnat(nnpos*natom),nr(nnpos*natom)
2515 : 0 : real(dp) :: dif(3),dists(nnpos*natom),ev(3),grho(3),hrho(3,3)
2516 : : real(dp) :: pom(3),v1(3),v2(3),v3(3),v4(3),vi(3),vt(3),zz(3,3)
2517 : :
2518 : : !************************************************************************
2519 [ # # ]: 0 : vi(:)=xatm(:,inxat)
2520 : :
2521 : 0 : nc=0
2522 [ # # ]: 0 : do jii=1,nnpos
2523 [ # # ]: 0 : do kjj=1,natom
2524 : 0 : dist=0._dp
2525 [ # # ]: 0 : dif(:)=xatm(:,inxat)-xatm(:,kjj)-atp(:,jii)
2526 : :
2527 : : ! do ii=1,3
2528 : : ! dif(ii)=xatm(ii,inxat)-xatm(ii,kjj)-atp(ii,jii)
2529 : : ! end do
2530 : 0 : dist=vnorm(dif,0)
2531 [ # # # # ]: 0 : if (.not.((dist>dstmax).or.(dist<0.001))) then
2532 : 0 : nc=nc+1
2533 : 0 : dists(nc)=dist
2534 : 0 : nnat(nc)=kjj
2535 : 0 : inat(nc)=jii
2536 : : end if
2537 : : end do
2538 : : end do
2539 [ # # ]: 0 : do n1=1,nc
2540 : 0 : nr(n1)=n1
2541 : : end do
2542 : 0 : call sort_dp(nc,dists,nr,tol14)
2543 : 0 : nb=0
2544 : 0 : olddist=0._dp
2545 : 0 : nshell=0
2546 : : !write(std_out,*) ':ORIAT ', (xatm(ii,inxat),ii=1,3)
2547 [ # # ]: 0 : do n1=1,nc
2548 : 0 : n2=nr(n1)
2549 : 0 : n3=nnat(n2)
2550 [ # # ]: 0 : if (dists(n1)<(2*dists(1))) then
2551 [ # # ]: 0 : if ((dists(n1)-olddist)>aim_dlimit) then
2552 : 0 : nshell=nshell+1
2553 : 0 : olddist=dists(n1)
2554 [ # # ]: 0 : if (nshell==5) exit
2555 : : end if
2556 : 0 : nb=nb+1
2557 : 0 : ibat(nb)=n3
2558 : 0 : ipibat(nb)=inat(n2)
2559 : 0 : write(std_out,*) ':NEIG ',inxat,n3,inat(n2),dists(n1)
2560 : : ! write(std_out,*) ':POSAT',(xatm(ii,ibat(nb))+atp(ii,ipibat(nb)),ii=1,3)
2561 : : else
2562 : : exit
2563 : : end if
2564 : : end do
2565 : :
2566 : 0 : npc=0
2567 : 0 : npcm3=0
2568 : :
2569 : : !
2570 : : !.....SEARCH BETWEEN EACH PAIR OF ATOMS
2571 : : !
2572 : :
2573 [ # # ]: 0 : if (stwo) then
2574 [ # # ]: 0 : do jii=1,nb
2575 [ # # ]: 0 : do ii=1,3
2576 : 0 : v1(ii)=xatm(ii,inxat)
2577 : 0 : v2(ii)=xatm(ii,ibat(jii))+atp(ii,ipibat(jii))
2578 : 0 : vt(ii)=(v1(ii)+v2(ii))/2._dp
2579 : : end do
2580 : 0 : inter=.true.
2581 : 0 : diff=0._dp
2582 : 0 : pom(:)=vt(:)
2583 [ # # ]: 0 : pom(:)=pom(:)-vi(:)
2584 : 0 : diff=vnorm(pom,0)
2585 [ # # ]: 0 : if (diff > maxcpdst) inter=.false.
2586 : 0 : if (inter) then
2587 : 0 : call critic(aim_dtset,vt,ev,zz,aim_dmaxcs,ires,0)
2588 [ # # ]: 0 : if (ires==0) then
2589 : 0 : found=.false.
2590 [ # # ]: 0 : if (npc > 0) then
2591 [ # # ]: 0 : do jj=1,npc
2592 [ # # ]: 0 : pom(:)=vt(:)-pc(:,jj)
2593 : 0 : dist=vnorm(pom,0)
2594 [ # # ]: 0 : if (dist < aim_dtset%dpclim) found=.true.
2595 : : end do
2596 : : end if
2597 [ # # ]: 0 : if (.not.found) then
2598 : 0 : pom(:)=vt(:)
2599 : 0 : call bschg1(pom,-1)
2600 [ # # ]: 0 : pcrb(:,npc+1)=pom(:)
2601 [ # # ]: 0 : pom(:)=pom(:)-vi(:)
2602 : 0 : diff=vnorm(pom,0)
2603 [ # # ]: 0 : if (abs(diff) > maxcpdst) found=.true.
2604 : : end if
2605 : : if (.not.found) then
2606 : 0 : npc=npc+1
2607 [ # # ]: 0 : do jj=1,3
2608 : 0 : pc(jj,npc)=vt(jj)
2609 : 0 : evpc(jj,npc)=ev(jj)
2610 [ # # ]: 0 : do kk=1,3
2611 : 0 : zpc(kk,jj,npc)=zz(kk,jj)
2612 : : end do
2613 : : end do
2614 : 0 : i1=ev(1)/abs(ev(1))
2615 : 0 : i2=ev(2)/abs(ev(2))
2616 : 0 : i3=ev(3)/abs(ev(3))
2617 : 0 : icpc(npc)=i1+i2+i3
2618 [ # # ]: 0 : if (icpc(npc)==-3) then
2619 : 0 : npcm3=npcm3+1
2620 : : end if
2621 : 0 : write(std_out,*) 'New critical point found'
2622 : 0 : write(std_out,'("POS: ",3F16.8)') (pc(ii,npc),ii=1,3)
2623 : 0 : write(std_out,'("POS in base: ",3F16.8)') (pcrb(ii,npc),ii=1,3)
2624 : 0 : write(std_out,'("AUTOVAL: ",3F16.8)') ev
2625 : : write(std_out,'("AUTOVEC: ",/,3F16.8,/,3F16.8,/,3F16.8)') &
2626 : 0 : & ((zpc(ii,jj,npc),ii=1,3),jj=1,3)
2627 : 0 : call vgh_rho(vt,chg,grho,hrho,rr,iat,ipos,0)
2628 : : write(22,'(":PC2",3F10.6,3E12.4,I4,2E12.4)') &
2629 : 0 : & (pc(jj,npc),jj=1,3),(ev(jj),jj=1,3),icpc(npc),ev(1)+ev(2)+ev(3),chg
2630 : : write(std_out,'(":PC2",3F10.6,3E12.4,I4,2E12.4)') &
2631 : 0 : & (pc(jj,npc),jj=1,3),(ev(jj),jj=1,3),icpc(npc),ev(1)+ev(2)+ev(3),chg
2632 [ # # ]: 0 : pom(:)=vt(:)-v1(:)
2633 : 0 : dif1=vnorm(pom,0)
2634 [ # # ]: 0 : pom(:)=vt(:)-v2(:)
2635 : 0 : dif2=vnorm(pom,0)
2636 : 0 : write(std_out,'(":DISPC ",2F12.8)') dif1,dif2
2637 : : end if
2638 : : end if
2639 : : end if
2640 : : end do
2641 : : end if
2642 : : !
2643 : : !.....SEARCH BETWEEN EACH THREE ATOMS
2644 : : !
2645 [ # # ]: 0 : if(sthree) then
2646 : 0 : do jii=1,nb
2647 [ # # ]: 0 : do kjj=jii+1,nb
2648 [ # # ]: 0 : do ii=1,3
2649 : 0 : v1(ii)=xatm(ii,inxat)
2650 : 0 : v2(ii)=xatm(ii,ibat(jii))+atp(ii,ipibat(jii))
2651 : 0 : v3(ii)=xatm(ii,ibat(kjj))+atp(ii,ipibat(kjj))
2652 : 0 : vt(ii)=(v1(ii)+v2(ii)+v3(ii))/3._dp
2653 : : end do
2654 : 0 : inter=.true.
2655 : 0 : pom(:)=vt(:)
2656 [ # # ]: 0 : pom(:)=pom(:)-vi(:)
2657 : 0 : dist=vnorm(pom,0)
2658 [ # # ]: 0 : if (abs(diff)>maxcpdst) then
2659 [ # # ]: 0 : inter=.false.
2660 : : exit
2661 : : end if
2662 : : if (inter) then
2663 [ # # ]: 0 : do jj=1,npc
2664 [ # # ]: 0 : pom(:)=pc(:,jj)-vt(:)
2665 : 0 : diff=vnorm(pom,0)
2666 [ # # ]: 0 : if (diff<aim_dpc0) then
2667 : : inter=.false.
2668 : : exit
2669 : : end if
2670 : : end do
2671 : : end if
2672 [ # # ]: 0 : if (inter) then
2673 : 0 : call critic(aim_dtset,vt,ev,zz,aim_dmaxcs,ires,0)
2674 [ # # ]: 0 : if (ires==0) then
2675 : 0 : found=.false.
2676 [ # # ]: 0 : if (npc>0) then
2677 [ # # ]: 0 : do jj=1,npc
2678 [ # # ]: 0 : pom(:)=vt(:)-pc(:,jj)
2679 : 0 : dist=vnorm(pom,0)
2680 [ # # ]: 0 : if (dist<aim_dtset%dpclim) then
2681 : : found=.true.
2682 : : exit
2683 : : end if
2684 : : end do
2685 : : end if
2686 [ # # ]: 0 : if (.not.found) then
2687 : 0 : pom(:)=vt(:)
2688 : 0 : call bschg1(pom,-1)
2689 [ # # ]: 0 : pcrb(:,npc+1)=pom(:)
2690 [ # # ]: 0 : pom(:)=pom(:)-vi(:)
2691 : 0 : diff=vnorm(pom,0)
2692 [ # # ]: 0 : if (abs(diff)>maxcpdst) found=.true.
2693 : : end if
2694 : : if (.not.found) then
2695 : 0 : npc=npc+1
2696 [ # # ]: 0 : do jj=1,3
2697 : 0 : pc(jj,npc)=vt(jj)
2698 : 0 : evpc(jj,npc)=ev(jj)
2699 [ # # ]: 0 : do kk=1,3
2700 : 0 : zpc(kk,jj,npc)=zz(kk,jj)
2701 : : end do
2702 : : end do
2703 : 0 : i1=ev(1)/abs(ev(1))
2704 : 0 : i2=ev(2)/abs(ev(2))
2705 : 0 : i3=ev(3)/abs(ev(3))
2706 : 0 : icpc(npc)=i1+i2+i3
2707 [ # # ]: 0 : if (icpc(npc)==-3) then
2708 : 0 : npcm3=npcm3+1
2709 : : end if
2710 : 0 : write(std_out,*) 'New critical point found'
2711 : 0 : write(std_out,'("POS: ",3F16.8)') (pc(ii,npc),ii=1,3)
2712 : 0 : write(std_out,'("POS in base: ",3F16.8)') (pcrb(ii,npc),ii=1,3)
2713 : 0 : write(std_out,'("AUTOVAL: ",3F16.8)') ev
2714 : : write(std_out,'("AUTOVEC: ",/,3F16.8,/,3F16.8,/,3F16.8)') &
2715 : 0 : & ((zpc(ii,jj,npc),ii=1,3),jj=1,3)
2716 : 0 : call vgh_rho(vt,chg,grho,hrho,rr,iat,ipos,0)
2717 : : write(22,'(":PC3",3F10.6,3E12.4,I4,2E12.4)') &
2718 : 0 : & (pc(jj,npc),jj=1,3),(ev(jj),jj=1,3),icpc(npc),ev(1)+ev(2)+ev(3),chg
2719 : : write(std_out,'(":PC3",3F10.6,3E12.4,I4,2E12.4)') &
2720 : 0 : & (pc(jj,npc),jj=1,3),(ev(jj),jj=1,3),icpc(npc),ev(1)+ev(2)+ev(3),chg
2721 : : end if
2722 : : end if
2723 : : end if
2724 : : end do
2725 : : end do
2726 : : end if
2727 : :
2728 : : !
2729 : : !.....SEARCH BETWEEN EACH FOUR ATOMS
2730 : : !
2731 [ # # ]: 0 : if (sfour) then
2732 [ # # ]: 0 : do jii=1,nb
2733 [ # # ]: 0 : do kjj=jii+1,nb
2734 [ # # ]: 0 : do ll=jii+1,nb
2735 [ # # ]: 0 : do ii=1,3
2736 : 0 : v1(ii)=xatm(ii,inxat)
2737 : 0 : v2(ii)=xatm(ii,ibat(jii))+atp(ii,ipibat(jii))
2738 : 0 : v3(ii)=xatm(ii,ibat(kjj))+atp(ii,ipibat(kjj))
2739 : 0 : v4(ii)=xatm(ii,ibat(ll))+atp(ii,ipibat(ll))
2740 : 0 : vt(ii)=(v1(ii)+v2(ii)+v3(ii)+v4(ii))/4._dp
2741 : : end do
2742 : 0 : inter=.true.
2743 : 0 : pom(:)=vt(:)
2744 [ # # ]: 0 : pom(:)=pom(:)-vi(:)
2745 : 0 : diff=vnorm(pom,0)
2746 [ # # ]: 0 : if (abs(diff)>maxcpdst) then
2747 : 0 : inter=.false.
2748 : : exit
2749 : : end if
2750 : : if (inter) then
2751 [ # # ]: 0 : do jj=1,npc
2752 [ # # ]: 0 : pom(:)=pc(:,jj)-vt(:)
2753 : 0 : diff=vnorm(pom,0)
2754 [ # # ]: 0 : if (diff < aim_dpc0) then
2755 : : inter=.false.
2756 : : exit
2757 : : end if
2758 : : end do
2759 : : end if
2760 [ # # ]: 0 : if (inter) then
2761 : 0 : call critic(aim_dtset,vt,ev,zz,aim_dmaxcs,ires,0)
2762 [ # # ]: 0 : if (ires==0) then
2763 : 0 : found=.false.
2764 [ # # ]: 0 : if (npc>0) then
2765 [ # # ]: 0 : do jj=1,npc
2766 [ # # ]: 0 : pom(:)=vt(:)-pc(:,jj)
2767 : 0 : dist=vnorm(pom,0)
2768 [ # # ]: 0 : if (dist < aim_dtset%dpclim) found=.true.
2769 : : end do
2770 : : end if
2771 [ # # ]: 0 : if (.not.found) then
2772 : 0 : pom(:)=vt(:)
2773 [ # # ]: 0 : pcrb(:,npc+1)=pom(:)
2774 [ # # ]: 0 : pom(:)=pom(:)-vi(:)
2775 : 0 : diff=vnorm(pom,0)
2776 [ # # ]: 0 : if (abs(diff)>maxcpdst) found=.true.
2777 : : end if
2778 : : if (.not.found) then
2779 : 0 : npc=npc+1
2780 [ # # ]: 0 : do jj=1,3
2781 : 0 : pc(jj,npc)=vt(jj)
2782 : 0 : evpc(jj,npc)=ev(jj)
2783 [ # # ]: 0 : do kk=1,3
2784 : 0 : zpc(kk,jj,npc)=zz(kk,jj)
2785 : : end do
2786 : : end do
2787 : 0 : i1=ev(1)/abs(ev(1))
2788 : 0 : i2=ev(2)/abs(ev(2))
2789 : 0 : i3=ev(3)/abs(ev(3))
2790 : 0 : icpc(npc)=i1+i2+i3
2791 [ # # ]: 0 : if (icpc(npc)==-3) then
2792 : 0 : npcm3=npcm3+1
2793 : : end if
2794 : 0 : write(std_out,*) 'New critical point found'
2795 : 0 : write(std_out,'("POS: ",3F16.8)') (pc(ii,npc),ii=1,3)
2796 : 0 : write(std_out,'("POS in base: ",3F16.8)') (pcrb(ii,npc),ii=1,3)
2797 : 0 : write(std_out,'("AUTOVAL: ",3F16.8)') ev
2798 : : write(std_out,'("AUTOVEC: ",/,3F16.8,/,3F16.8,/,3F16.8)') &
2799 : 0 : & ((zpc(ii,jj,npc),ii=1,3),jj=1,3)
2800 : 0 : call vgh_rho(vt,chg,grho,hrho,rr,iat,ipos,0)
2801 : : write(22,'(":PC4",3F10.6,3E12.4,I4,2E12.4)') &
2802 : 0 : & (pc(jj,npc),jj=1,3), (ev(jj),jj=1,3),icpc(npc),ev(1)+ev(2)+ev(3),chg
2803 : : write(std_out,'(":PC4",3F10.6,3E12.4,I4,2E12.4)') &
2804 : 0 : & (pc(jj,npc),jj=1,3), (ev(jj),jj=1,3),icpc(npc),ev(1)+ev(2)+ev(3),chg
2805 : : end if
2806 : : end if
2807 : : end if
2808 : : end do
2809 : : end do
2810 : : end do
2811 : : end if
2812 : :
2813 : 0 : write(std_out,*) npc
2814 : 0 : end subroutine critics
2815 : : !!***
2816 : :
2817 : : !!****f* m_bader/defad
2818 : : !! NAME
2819 : : !! defad
2820 : : !!
2821 : : !! FUNCTION
2822 : : !! Initialisation of aim input variables to their default values.
2823 : : !!
2824 : : !! INPUTS
2825 : : !! (no input : initialisation by default values)
2826 : : !!
2827 : : !! OUTPUT
2828 : : !! aim_dtset = the structured entity containing all input variables
2829 : : !!
2830 : : !! SOURCE
2831 : :
2832 : 5 : subroutine defad(aim_dtset)
2833 : :
2834 : : !Arguments ------------------------------------
2835 : : !scalars
2836 : : type(aim_dataset_type),intent(out) :: aim_dtset
2837 : :
2838 : : !Local variables ------------------------------
2839 : :
2840 : : ! *********************************************************************
2841 : :
2842 : 5 : aim_dtset%isurf=0
2843 : 5 : aim_dtset%crit=0
2844 : 5 : aim_dtset%irsur=0
2845 : 5 : aim_dtset%foll=0
2846 : 5 : aim_dtset%irho=0
2847 : 5 : aim_dtset%ivol=0
2848 : 5 : aim_dtset%denout=0
2849 : 5 : aim_dtset%lapout=0
2850 : 5 : aim_dtset%gpsurf=0
2851 : 5 : aim_dtset%plden=0
2852 : 5 : aim_dtset%dltyp=0
2853 : :
2854 : 5 : aim_dtset%batom=1
2855 : 5 : aim_dtset%nsa=3
2856 : 5 : aim_dtset%nsb=3
2857 : 5 : aim_dtset%nsc=3
2858 : 5 : aim_dtset%npt=100
2859 : 5 : aim_dtset%nth=32
2860 : 5 : aim_dtset%nph=48
2861 : :
2862 : 5 : aim_dtset%themax=pi
2863 : 5 : aim_dtset%themin=zero
2864 : 5 : aim_dtset%phimin=zero
2865 : 5 : aim_dtset%phimax=two_pi
2866 : 5 : aim_dtset%phi0=zero
2867 : 5 : aim_dtset%th0=zero
2868 : 5 : aim_dtset%folstp=5.d-2
2869 : 5 : aim_dtset%dr0=5.d-2
2870 : 5 : aim_dtset%atrad=one
2871 : 5 : aim_dtset%rmin=one
2872 : :
2873 [ + + ]: 20 : aim_dtset%foldep(:)=zero
2874 [ + + + + ]: 85 : aim_dtset%vpts(:,:)=zero
2875 [ + + ]: 20 : aim_dtset%ngrid(:)=30
2876 [ + + ]: 20 : aim_dtset%scal(:)=one
2877 : 5 : aim_dtset%maxatd=1.d1
2878 : 5 : aim_dtset%maxcpd=5.d1
2879 : :
2880 : 5 : aim_dtset%dpclim=1.d-2
2881 : 5 : aim_dtset%lstep=1.d-10
2882 : 5 : aim_dtset%lstep2=1.d-5
2883 : 5 : aim_dtset%lgrad=1.d-12
2884 : 5 : aim_dtset%lgrad2=1.d-5
2885 : 5 : aim_dtset%coff1=0.98_dp
2886 : 5 : aim_dtset%coff2=0.95_dp
2887 : :
2888 : 5 : end subroutine defad
2889 : : !!***
2890 : :
2891 : : !!****f* m_bader/drvaim
2892 : : !! NAME
2893 : : !! drvaim
2894 : : !!
2895 : : !! FUNCTION
2896 : : !! Main driver for the Bader analysis
2897 : : !! it looks the values of the input variables
2898 : : !! and calls corresponding procedures
2899 : : !!
2900 : : !! INPUTS
2901 : : !! aim_dtset = the structured entity containing all input variables
2902 : : !! tcpui=initial CPU time
2903 : : !! twalli=initial wall clock time
2904 : : !!
2905 : : !! OUTPUT
2906 : : !! (see side effects)
2907 : : !!
2908 : : !! SIDE EFFECTS
2909 : : !! this routine acts primarily on the data contained in the aimprom module
2910 : : !!
2911 : : !! WARNING
2912 : : !! This file does not follow the ABINIT coding rules (yet)
2913 : : !!
2914 : : !! SOURCE
2915 : :
2916 : 5 : subroutine drvaim(aim_dtset,tcpui,twalli)
2917 : :
2918 : : !Arguments ------------------------------------
2919 : : !scalars
2920 : : real(dp) :: tcpui,twalli
2921 : : type(aim_dataset_type),intent(in) :: aim_dtset
2922 : :
2923 : : !Local variables ------------------------------
2924 : : !scalars
2925 : : integer :: iat,iatinit,inxat,ipos,iposinit
2926 : : integer :: me,npmax,nproc,nstep
2927 : : real(dp) :: dstlim,rr,ss,t1,t2,tf,wall
2928 : : real(dp) :: tcpu,twall,znucl_batom
2929 : : logical :: debold,sfour,srch,sthree,stwo
2930 : : !arrays
2931 : : real(dp) :: tsec(2)
2932 : : real(dp) :: grho(3),xstart(3)
2933 : :
2934 : : ! *********************************************************************
2935 : :
2936 : 5 : me=xmpi_comm_rank(xmpi_world)
2937 : 5 : nproc=xmpi_comm_size(xmpi_world)
2938 : :
2939 : : !These input variables might be modified during what follows,
2940 : : !so, they are copied outside of aim_dtset.
2941 : 5 : inxat=aim_dtset%batom
2942 : 5 : r0=aim_dtset%atrad
2943 : 5 : h0=aim_dtset%folstp
2944 : 5 : maxatdst=aim_dtset%maxatd
2945 : 5 : maxcpdst=aim_dtset%maxcpd
2946 : :
2947 : 5 : dstlim=maxcpdst
2948 : :
2949 : : !Flags from the old version
2950 : : !to be remove later
2951 : 5 : deb=.false.
2952 : 5 : stwo=.true.
2953 : 5 : sthree=.true.
2954 : 5 : sfour=.false.
2955 : 5 : srch=.false.
2956 : :
2957 : 5 : npmax=aim_npmaxin
2958 : :
2959 : : !Main initialisation procedure -
2960 : : !- it reads ABINIT density file and files
2961 : : !with core densities and initialises the fields for
2962 : : !spline interpolation
2963 : :
2964 : 5 : call initaim(aim_dtset,znucl_batom)
2965 : :
2966 : :
2967 : : !CP SEARCHING
2968 : :
2969 [ + - ]: 5 : if (aim_dtset%crit /= 0) then
2970 : :
2971 : 5 : call timein(tcpu,twall)
2972 : 5 : tsec(1)=tcpu-tcpui ; tsec(2)=twall-twalli
2973 : : write(std_out, '(5a,f13.1,a,f13.1)' ) &
2974 : 5 : & '-',ch10,'- Before searching the CP ',ch10,&
2975 : 10 : & '- Proc. 0 individual time (sec): cpu=',tsec(1),' wall=',tsec(2)
2976 : :
2977 [ - + ]: 5 : if (aim_dtset%crit==3) then
2978 : : ! old version of the driver for searching CPs (original code)
2979 : 0 : call critics(aim_dtset,inxat,stwo,sthree,sfour,dstlim)
2980 : : else
2981 : : ! driver for searching CPs with Popellier algorithm
2982 : 5 : call cpdrv(aim_dtset)
2983 : : end if
2984 : :
2985 : 5 : call timein(tcpu,twall)
2986 : 5 : tsec(1)=tcpu-tcpui ; tsec(2)=twall-twalli
2987 : : write(std_out, '(5a,f13.1,a,f13.1)' ) &
2988 : 5 : & '-',ch10,'- After searching the CP ',ch10,&
2989 : 10 : & '- Proc. 0 individual time (sec): cpu=',tsec(1),' wall=',tsec(2)
2990 : :
2991 : : end if
2992 : :
2993 : : !
2994 : : !BADER SURFACE CALCULATION
2995 : : !
2996 : :
2997 [ + - ]: 5 : if (aim_dtset%isurf==1) then
2998 : : ! driver for determination of the Bader surface
2999 : :
3000 : 5 : call timein(tcpu,twall)
3001 : 5 : tsec(1)=tcpu-tcpui ; tsec(2)=twall-twalli
3002 : : write(std_out, '(5a,f13.1,a,f13.1)' ) &
3003 : 5 : & '-',ch10,'- Before determinating the Bader surface ',ch10,&
3004 : 10 : & '- Proc. 0 individual time (sec): cpu=',tsec(1),' wall=',tsec(2)
3005 : :
3006 : 5 : call surf(aim_dtset)
3007 : :
3008 : 5 : call timein(tcpu,twall)
3009 : 5 : tsec(1)=tcpu-tcpui ; tsec(2)=twall-twalli
3010 : : write(std_out, '(5a,f13.1,a,f13.1)' ) &
3011 : 5 : & '-',ch10,'- After determinating the Bader surface ',ch10,&
3012 : 10 : & '- Proc. 0 individual time (sec): cpu=',tsec(1),' wall=',tsec(2)
3013 : :
3014 : : end if
3015 : :
3016 : : !
3017 : : !CHARGE INTEGRATIOM
3018 : : !
3019 : :
3020 [ + - ]: 5 : if (aim_dtset%irho==1) then
3021 : 5 : call integrho(aim_dtset,znucl_batom)
3022 : : end if
3023 : :
3024 : : !
3025 : : !VOLUME INTEGRATION OF THE BADER ATOM
3026 : : !
3027 : :
3028 [ + + ]: 5 : if (aim_dtset%ivol==1) then
3029 : 1 : call integvol()
3030 : : end if
3031 : :
3032 : : !
3033 : : !ONE RADIUS OF THE BADER SURFACE
3034 : : !
3035 : :
3036 [ - + ]: 5 : if (aim_dtset%irsur==1) then
3037 [ # # ]: 0 : if (aim_dtset%isurf/=0) srch=.true.
3038 : 0 : iat=aim_dtset%batom
3039 : 0 : ss=r0
3040 : 0 : call timein(t1,wall)
3041 : 0 : call rsurf(aim_dtset,rr,grho,aim_dtset%th0,aim_dtset%phi0,ss,iat,npmax,srch)
3042 : 0 : call timein(t2,wall)
3043 : 0 : t2=t2-t1
3044 : 0 : write(unts,'(2F12.8,F15.10)') aim_dtset%th0,aim_dtset%phi0,rr
3045 : 0 : write(std_out,'(":RSUR ",2F12.8,2F15.10)') aim_dtset%th0,aim_dtset%phi0,rr,t2
3046 : : end if
3047 : :
3048 : : !
3049 : : !FOLLOW THE GRADIENT PATH FROM ONE POINT
3050 : : !
3051 : :
3052 [ - + ]: 5 : if (aim_dtset%foll==1) then
3053 : 0 : iatinit=aim_dtset%batom
3054 : 0 : iposinit=batcell
3055 [ # # ]: 0 : if (aim_dtset%isurf/=0) srch=.true.
3056 : 0 : debold=deb
3057 [ # # ]: 0 : xstart(:)=aim_dtset%foldep(:)
3058 : 0 : call timein(t1,wall)
3059 : 0 : call aim_follow(aim_dtset,xstart,npmax,srch,iatinit,iposinit,iat,ipos,nstep)
3060 : 0 : call timein(t2,wall)
3061 : 0 : tf=t2-t1
3062 : 0 : write(std_out,'(":TIME in aim_follow:", F12.4)') tf
3063 : : end if
3064 : :
3065 [ - + ]: 5 : if (aim_dtset%plden == 1) then
3066 : : ! profile of the density integrated in plane xy
3067 : : ! belong the z-axes - not finished - cut3d better !
3068 : 0 : call plint()
3069 : : end if
3070 : :
3071 [ + - - + ]: 5 : if ((aim_dtset%denout > 0).or.(aim_dtset%lapout > 0)) then
3072 : : ! additional outputs of density and laplacian fields
3073 : : ! in the plane or line
3074 : 0 : call addout(aim_dtset)
3075 : : end if
3076 : :
3077 [ + - ]: 5 : if (aim_dtset%gpsurf == 1) then
3078 : : ! script for gnuplot - simple demonstration of the
3079 : : ! computed surface
3080 : 5 : call graph(unts,untg)
3081 : : end if
3082 : :
3083 : : !Deallocation of global variables allocated in initaim
3084 : : !and declared in defs_aimfields.
3085 [ - + ]: 5 : ABI_FREE(dig1)
3086 [ - + ]: 5 : ABI_FREE(dig2)
3087 [ - + ]: 5 : ABI_FREE(dig3)
3088 [ - + ]: 5 : ABI_FREE(llg1)
3089 [ - + ]: 5 : ABI_FREE(llg2)
3090 [ - + ]: 5 : ABI_FREE(llg3)
3091 [ - + ]: 5 : ABI_FREE(cdig1)
3092 [ - + ]: 5 : ABI_FREE(cdig2)
3093 [ - + ]: 5 : ABI_FREE(cdig3)
3094 [ - + ]: 5 : ABI_FREE(ddx)
3095 [ - + ]: 5 : ABI_FREE(ddy)
3096 [ - + ]: 5 : ABI_FREE(ddz)
3097 [ - + ]: 5 : ABI_FREE(rrad)
3098 [ - + ]: 5 : ABI_FREE(crho)
3099 [ - + ]: 5 : ABI_FREE(sp2)
3100 [ - + ]: 5 : ABI_FREE(sp3)
3101 [ - + ]: 5 : ABI_FREE(sp4)
3102 [ - + ]: 5 : ABI_FREE(corlim)
3103 [ - + ]: 5 : ABI_FREE(dvl)
3104 [ - + ]: 5 : ABI_FREE(ndat)
3105 [ - + ]: 5 : ABI_FREE(rminl)
3106 : : !Deallocation of global variables allocated in initaim
3107 : : !and declared in defs_aimprom.
3108 [ - + ]: 5 : ABI_FREE(typat)
3109 [ - + ]: 5 : ABI_FREE(xred)
3110 [ - + ]: 5 : ABI_FREE(xatm)
3111 : :
3112 : 5 : end subroutine drvaim
3113 : : !!***
3114 : :
3115 : : !!****f* m_bader/graph
3116 : : !! NAME
3117 : : !! graph
3118 : : !!
3119 : : !! FUNCTION
3120 : : !! Writing of the gnuplot script to show the computed part
3121 : : !! of Bader surface with lines
3122 : : !!
3123 : : !! INPUTS
3124 : : !! untg = unit number of the file on which the info is written
3125 : : !! unts = unit number of the file from which the Bader surface is read
3126 : : !!
3127 : : !! OUTPUT
3128 : : !! (written in the untg file)
3129 : : !!
3130 : : !! SOURCE
3131 : :
3132 : 5 : subroutine graph(unts,untg)
3133 : :
3134 : : !Arguments ------------------------------------
3135 : : !scalars
3136 : : integer,intent(in) :: untg,unts
3137 : :
3138 : : !Local variables ------------------------------
3139 : : !scalars
3140 : : integer :: ii,indx,jj,nphi,nth
3141 : : real(dp),parameter :: snull=1.d-6
3142 : : real(dp) :: phimax,phimin,ss,thmax,thmin
3143 : : !arrays
3144 : : real(dp) :: xorig(3)
3145 : 5 : real(dp),allocatable :: phi(:),rr(:,:),th(:)
3146 : :
3147 : : ! *********************************************************************
3148 : :
3149 : 5 : rewind(unts)
3150 : 5 : read(unts,*) indx, xorig(1:3)
3151 : 5 : read(unts,*) nth, thmin, thmax
3152 : 5 : read(unts,*) nphi, phimin, phimax
3153 [ - + + - : 15 : ABI_MALLOC(th,(nth))
+ - + - -
+ - + ]
3154 [ - + + - : 15 : ABI_MALLOC(phi,(nphi))
+ - + - -
+ - + ]
3155 [ - + + - : 20 : ABI_MALLOC(rr,(nth,nphi))
- + + - +
- + - - +
+ - ]
3156 [ + + ]: 35 : do ii=1,nth
3157 [ + + ]: 165 : do jj=1,nphi
3158 : 160 : read(unts,*) th(ii),phi(jj),rr(ii,jj),ss
3159 : : end do
3160 : : end do
3161 : :
3162 : : !end of reading
3163 : :
3164 : 5 : write(untg,*) 'reset'
3165 : 5 : write(untg,*) 'set st d l'
3166 : 5 : write(untg,*) 'set ticslevel 0'
3167 : 5 : write(untg,*) 'set title ''Bader surface'' '
3168 : 5 : write(untg,*) 'splot ''-'' using ($3*sin($1)*cos($2)):($3*sin($1)*sin($2)):($3*cos($1)) notitle'
3169 [ + + ]: 35 : do ii=1,nth
3170 [ + + ]: 160 : do jj=1,nphi
3171 : 160 : write(untg,'(2F12.8,E16.8)') th(ii),phi(jj),rr(ii,jj)
3172 : : end do
3173 : 5 : if ((ii==nth).and.(jj==nphi)) then
3174 : : cycle
3175 : : else
3176 : 30 : write(untg,*)
3177 : : end if
3178 : : end do
3179 : :
3180 [ + - + - : 5 : end subroutine graph
+ - ]
3181 : : !!***
3182 : :
3183 : : !!****f* m_bader/initaim
3184 : : !! NAME
3185 : : !! initaim
3186 : : !!
3187 : : !! FUNCTION
3188 : : !! Initialization for the 3D interpolation for the AIM code:
3189 : : !! - this procedure reads the charge density of the electrons of valence on
3190 : : !! the equidistant 3D grid (*_DEN output file of ABINIT) and the core charge
3191 : : !! density of electrons from *.fc files (fhi package)
3192 : : !! - the Cholesky decomposition of the general matrix for
3193 : : !! the computation of the 1D spline coeficients in each direction is done.
3194 : : !! Warning - the procedure is modified to use periodic boundary conditions
3195 : : !! already during the decomposition
3196 : : !! - the second derivations of valence density in three directions are computed
3197 : : !! and stored in the real space grid of the density for interpolation.
3198 : : !! - the core density is stored separately in the radial grid together with th
3199 : : !! second radial derivation
3200 : : !!
3201 : : !! INPUTS
3202 : : !! aim_dtset= the structured entity containing all input variables
3203 : : !!
3204 : : !! OUTPUT
3205 : : !! znucl_batom= the nuclear charge of the Bader atom
3206 : : !! (see side effects)
3207 : : !!
3208 : : !! SIDE EFFECTS
3209 : : !! thie routine works on the data contained in the aim_fields and aim_prom modules
3210 : : !!
3211 : : !! WARNING
3212 : : !! This file does not follow the ABINIT coding rules (yet)
3213 : : !!
3214 : : !! SOURCE
3215 : :
3216 : 5 : subroutine initaim(aim_dtset,znucl_batom)
3217 : :
3218 : : !Arguments ------------------------------------
3219 : : !scalars
3220 : : type(aim_dataset_type),intent(in) :: aim_dtset
3221 : :
3222 : : !Local variables ------------------------------
3223 : : !scalars
3224 : : integer,parameter :: master=0
3225 : : integer :: fform0,id,ierr,ii,info,jj,kk,kod,mm,ndtmax,nn,nsa,nsb,nsc,nsym,me,nproc,npsp
3226 : : integer :: unth,comm
3227 : : integer :: den_id
3228 : : real(dp) :: ss,ucvol,znucl_batom
3229 : : real(dp) :: zz
3230 : 5 : type(hdr_type) :: hdr
3231 : : !arrays
3232 : : integer :: ipiv(3)
3233 : 5 : integer,allocatable :: symrel(:,:,:)
3234 : : real(dp) :: aa(3),bb(3),gmet(3,3),gprimd(3,3),rmet(3,3),yy(3,3)
3235 : 5 : real(dp),allocatable :: tnons(:,:),znucl(:),zionpsp(:)
3236 : 5 : real(dp),pointer :: ptc(:),ptd(:),ptf(:),ptp(:),ptsd(:)
3237 : :
3238 : : ! *********************************************************************
3239 : :
3240 : : !DEBUG
3241 : : !write(std_out,*) ' initaim : enter '
3242 : : !ENDDEBUG
3243 : :
3244 : 5 : comm = xmpi_world
3245 : 10 : me=xmpi_comm_rank(comm)
3246 : 5 : nproc=xmpi_comm_size(comm)
3247 : :
3248 : 5 : slc=0 ! code for follow
3249 : :
3250 : : !The use of the "hdr" routines is much better for the future
3251 : : !maintenance of the code. Indeed, the content of the header
3252 : : !will continue to change from time to time, and the associated
3253 : : !changes should be done in one place only.
3254 : :
3255 : : !Read ABINIT header ----------------------------------------------------------
3256 [ + - ]: 5 : if(me==master)then
3257 [ + - ]: 5 : if (aim_iomode == IO_MODE_ETSF) then
3258 : 5 : call hdr%ncread(untad, fform0)
3259 : : else
3260 : 0 : call hdr%fort_read(untad, fform0)
3261 : : end if
3262 : : end if
3263 [ - + ]: 5 : ABI_CHECK(fform0 /= 0, "hdr_read returned fform == 0")
3264 : 5 : call hdr%bcast(master, me, comm)
3265 : :
3266 : : !Echo part of the header
3267 : 5 : call hdr%echo(fform0, 4, unit=std_out)
3268 : 5 : call hdr%echo(fform0, 4, unit=untout)
3269 : :
3270 : 5 : natom=hdr%natom
3271 [ + + ]: 20 : ngfft(1:3)=hdr%ngfft(:)
3272 : 5 : nsym=hdr%nsym
3273 : 5 : npsp=hdr%npsp
3274 : 5 : ntypat=hdr%ntypat
3275 [ + + + + ]: 65 : rprimd(:,:)=hdr%rprimd(:,:)
3276 : :
3277 [ - + + - : 15 : ABI_MALLOC(zionpsp,(npsp))
+ - + - -
+ - + ]
3278 [ - + + - : 15 : ABI_MALLOC(znucl,(ntypat))
+ - + - -
+ - + ]
3279 [ - + + - : 15 : ABI_MALLOC(typat,(natom))
+ - + - -
+ - + -
+ ]
3280 [ - + + - : 15 : ABI_MALLOC(xred,(3,natom))
+ - + - -
+ - + -
+ ]
3281 [ - + + - : 15 : ABI_MALLOC(symrel,(3,3,nsym))
+ - + - -
+ - + ]
3282 [ - + + - : 15 : ABI_MALLOC(tnons,(3,nsym))
+ - + - -
+ - + ]
3283 [ - + + - : 10 : ABI_MALLOC(xatm,(3,natom))
- + - + -
+ ]
3284 : :
3285 [ + + + + : 1474 : symrel(:,:,:)=hdr%symrel(:,:,:)
+ + ]
3286 [ + + ]: 28 : typat(:)=hdr%typat(:)
3287 [ + + + + ]: 457 : tnons(:,:)=hdr%tnons(:,:)
3288 [ + + ]: 14 : znucl(:)=hdr%znucltypat(:)
3289 [ + + ]: 14 : zionpsp(:)=hdr%zionpsp(:)
3290 [ + + + + ]: 97 : xred(:,:)=hdr%xred(:,:)
3291 : :
3292 : 5 : call hdr%free()
3293 : :
3294 : : !-------------------------------------------------------------------------------
3295 : :
3296 [ - + + - : 25 : ABI_MALLOC(dvl,(ngfft(1),ngfft(2),ngfft(3)))
- + + - -
+ + - + -
+ - - + -
+ - + ]
3297 : :
3298 [ + - ]: 5 : if(me==master)then
3299 [ + - ]: 5 : if (aim_iomode == IO_MODE_ETSF) then
3300 : : ! netcdf array has shape [cplex, n1, n2, n3, nspden]), here we read only the total density.
3301 [ - + ]: 5 : NCF_CHECK(nf90_inq_varid(untad, "density", den_id))
3302 [ + + - + : 30 : NCF_CHECK(nf90_get_var(untad, den_id, dvl, start=[1,1,1,1], count=[1, ngfft(1), ngfft(2), ngfft(3), 1]))
- - ]
3303 : : else
3304 : 0 : read(untad,iostat=nn) dvl(1:ngfft(1),1:ngfft(2),1:ngfft(3))
3305 [ # # ]: 0 : ABI_CHECK(nn==0,"error of reading !")
3306 : : end if
3307 : : end if
3308 : 5 : call xmpi_bcast(dvl, master, comm, ierr)
3309 : :
3310 : 5 : write(std_out,*)ch10,' initaim : the valence density has been read' ,ch10
3311 : :
3312 : : !INITIALISATION OF SOME IMPORTANT FIELDS
3313 : :
3314 : : !Only interpolation is computed (inside vgh_rho) in reduced
3315 : : !coordinates. In all other routines the cart. coordinates (CC) are used.
3316 : :
3317 : : !transformation of the atom positions to CC
3318 [ + + ]: 28 : do ii=1,natom
3319 [ + + ]: 92 : xatm(:,ii)=xred(:,ii)
3320 : 28 : call bschg1(xatm(:,ii),1)
3321 : : end do
3322 : :
3323 : : !Generation of the neighbouring cells + transf to CC
3324 : 5 : nn=0
3325 : 5 : nsa=aim_dtset%nsa ; nsb=aim_dtset%nsb ; nsc=aim_dtset%nsc
3326 [ + + ]: 40 : do ii=-nsa,nsa
3327 [ + + ]: 285 : do jj=-nsb,nsb
3328 [ + + ]: 1995 : do kk=-nsc,nsc
3329 : 1715 : nn=nn+1
3330 : 1715 : atp(1,nn)=ii*1._dp
3331 : 1715 : atp(2,nn)=jj*1._dp
3332 : 1715 : atp(3,nn)=kk*1._dp
3333 : 1960 : call bschg1(atp(:,nn),1)
3334 : : end do
3335 : : end do
3336 : : end do
3337 : 5 : nnpos=nn
3338 : :
3339 : : !DEBUG
3340 : : !write(std_out,*)' initaim : nnpos=',nnpos
3341 : : !ENDDEBUG
3342 : :
3343 : 5 : batcell=nsa*(2*nsb+1)*(2*nsc+1)+(2*nsc+1)*nsb+nsc+1
3344 : 5 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
3345 : 5 : maxatdst=min(maxatdst, nsa*sqrt(rmet(1,1)), nsb*sqrt(rmet(2,2)), nsc*sqrt(rmet(3,3)) )
3346 [ + + ]: 5 : if (maxcpdst > maxatdst) maxcpdst=0.75*maxatdst
3347 : :
3348 : :
3349 : : !RPRIM ITS INVERSE AND TRANSPOSE
3350 : :
3351 [ + + ]: 20 : do ii=1,3
3352 [ + + ]: 65 : do jj=1,3
3353 : 60 : yy(ii,jj)=rprimd(ii,jj)
3354 : : end do
3355 : : end do
3356 : 5 : call ludcmp(yy,3,3,ipiv,id,info)
3357 [ - + ]: 5 : ABI_CHECK(info==0,'Error inverting rprimd')
3358 : :
3359 [ + + ]: 20 : do ii=1,3
3360 [ + + ]: 60 : do jj=1,3
3361 : 60 : ivrprim(ii,jj)=0._dp
3362 : : end do
3363 : 20 : ivrprim(ii,ii)=1._dp
3364 : : end do
3365 [ + + ]: 20 : do ii=1,3
3366 : 20 : call lubksb(yy,3,3,ipiv,ivrprim(:,ii))
3367 : : end do
3368 [ + + ]: 20 : do ii=1,3
3369 [ + + ]: 65 : do jj=1,3
3370 : 60 : trivrp(ii,jj)=ivrprim(jj,ii)
3371 : : end do
3372 : : end do
3373 : :
3374 : : write(std_out,'(" INVERSE OF RPRIMD: ",/,3F16.8,/,3F16.8,/,3F16.8,/)') &
3375 [ + - + + ]: 20 : & ((ivrprim(ii,jj), jj=1,3), ii=1,3)
3376 : : write(untout,'(" INVERSE OF RPRIMD: ",/,3F16.8,/,3F16.8,/,3F16.8,/)') &
3377 [ + - + + ]: 20 : & ((ivrprim(ii,jj), jj=1,3), ii=1,3)
3378 : :
3379 : 5 : write(std_out,*) "ATOMS (index,at.number,Zionic,position(xcart.))"
3380 : 5 : write(std_out,*) "======================================="
3381 [ + + ]: 28 : do ii=1,natom
3382 : 23 : jj=typat(ii)
3383 : 28 : write(std_out,'(I4,2F10.6,3F16.8)') ii, znucl(jj), zionpsp(jj), (xatm(kk,ii),kk=1,3)
3384 : : end do
3385 : 5 : write(untout,*) "ATOMS (index,at.number,Zionic,position(xcart.))"
3386 : 5 : write(untout,*) "======================================="
3387 [ + + ]: 28 : do ii=1,natom
3388 : 23 : jj=typat(ii)
3389 : 28 : write(untout,'(I4,2F10.6,3F16.8)') ii, znucl(jj), zionpsp(jj), (xatm(kk,ii),kk=1,3)
3390 : : end do
3391 : :
3392 : : !STEPS IN REAL SPACE GRID (REDUCED)
3393 [ + + ]: 20 : do ii=1,3
3394 : 20 : dix(ii)=1._dp/ngfft(ii)
3395 : : end do
3396 : :
3397 : : !READING OF THE CORE DENSITY
3398 : 5 : write(std_out,*)ch10,' initaim : will read the core densities' ,ch10
3399 : :
3400 [ - + + - : 15 : ABI_MALLOC(ndat,(ntypat))
+ - + - -
+ - + -
+ ]
3401 [ - + + - : 15 : ABI_MALLOC(rminl,(natom))
+ - + - -
+ - + -
+ ]
3402 : 5 : ndtmax=0
3403 [ + - ]: 5 : if(me==master)then
3404 [ + + ]: 14 : do ii=1,ntypat
3405 : 9 : unth=unt+ii
3406 : : ! DEBUG
3407 : : ! write(std_out,*)' read from unit ',unth
3408 : : ! call flush(std_out)
3409 : : ! stop
3410 : : ! ENDDEBUG
3411 : 9 : read(unth,*) ndat(ii),ss
3412 [ + - ]: 14 : if (ndat(ii)>ndtmax) ndtmax=ndat(ii)
3413 : : end do
3414 : : end if
3415 : 5 : call xmpi_bcast(ndat,master,comm,ierr)
3416 : 5 : call xmpi_bcast(ndtmax,master,comm,ierr)
3417 : 5 : call xmpi_bcast(ss,master,comm,ierr)
3418 : :
3419 : : !FIELDS FOR STORING CORE DENSITY
3420 : :
3421 [ - + + - : 20 : ABI_MALLOC(rrad,(ndtmax,ntypat))
- + + - +
- + - - +
- + - + ]
3422 [ - + + - : 15 : ABI_MALLOC(crho,(ndtmax,ntypat))
- + + - -
+ - + -
+ ]
3423 [ - + + - : 15 : ABI_MALLOC(sp2,(ndtmax,ntypat))
- + + - -
+ - + -
+ ]
3424 [ - + + - : 15 : ABI_MALLOC(sp3,(ndtmax,ntypat))
- + + - -
+ - + -
+ ]
3425 [ - + + - : 15 : ABI_MALLOC(sp4,(ndtmax,ntypat))
- + + - -
+ - + -
+ ]
3426 [ - + + - : 15 : ABI_MALLOC(corlim,(ntypat))
+ - + - -
+ - + -
+ ]
3427 : :
3428 [ + + + + ]: 3895 : sp2(:,:)=zero
3429 [ + + + + ]: 3895 : sp3(:,:)=zero
3430 [ + + + + ]: 3895 : sp4(:,:)=zero
3431 : :
3432 : : !Reading of the core densities
3433 [ + + ]: 14 : corlim(:)=0
3434 : 5 : kod=0
3435 [ + - ]: 5 : if(me==master)then
3436 [ + + ]: 14 : do ii=1,ntypat
3437 : 9 : unth=unt+ii
3438 [ + + ]: 3229 : do jj=1,ndat(ii)
3439 : 3220 : read(unth,*) rrad(jj,ii),crho(jj,ii),sp2(jj,ii),sp3(jj,ii)
3440 : : ! this is the integral of the core charge read in
3441 : 3220 : crho(jj,ii) = crho(jj,ii)/4._dp/pi
3442 [ + + + + ]: 3220 : if ((crho(jj,ii) < aim_rhocormin) .and. (corlim(ii)==0)) corlim(ii)=jj
3443 : 3220 : sp2(jj,ii)=sp2(jj,ii)/4._dp/pi
3444 : 3229 : sp3(jj,ii)=sp3(jj,ii)/4._dp/pi ! ATENTION!!! in sp3 is just second derivation
3445 : : end do
3446 [ + + ]: 3220 : do jj=1,ndat(ii)-1
3447 : 3220 : sp4(jj,ii)=(sp3(jj+1,ii)-sp3(jj,ii))/(6._dp*(rrad(jj+1,ii)-rrad(jj,ii)))
3448 : : end do
3449 : : !
3450 : 9 : zz = crho(1,ii) * rrad(1,ii)**2 * (rrad(2,ii)-rrad(1,ii))
3451 [ + + ]: 3211 : do jj=2,ndat(ii)-1
3452 : 3211 : zz = zz + crho(jj,ii) * rrad(jj,ii)**2 * (rrad(jj+1,ii)-rrad(jj-1,ii))
3453 : : end do
3454 : 9 : zz = zz * half * 4._dp * pi
3455 [ - + ]: 9 : if (corlim(ii)==0) corlim(ii)=ndat(ii)
3456 : :
3457 : : ! add check on zion wrt FHI .fc file
3458 : : ! compare zion to zionpsp(typat(aim_dtset%batom))
3459 [ - + ]: 14 : if (abs(znucl(ii) - zz - zionpsp(ii)) > 1.e-1_dp) then
3460 : 0 : write (std_out,*) 'error: your core charge ', zz, ' does not correspond to the correct number'
3461 : 0 : write (std_out,*) ' of valence electrons', zionpsp(ii), ' and the nuclear charge ', znucl(ii)
3462 : 0 : write (std_out,*) ' You have probably used a pseudopotential which has more valence electrons than the'
3463 : 0 : write (std_out,*) ' original FHI ones. ACTION: make a .fc file with the correct core charge'
3464 : 0 : stop
3465 : : end if
3466 : :
3467 : : end do
3468 : : end if
3469 : 5 : call xmpi_bcast(rrad,master,comm,ierr)
3470 : 5 : call xmpi_bcast(crho,master,comm,ierr)
3471 : 5 : call xmpi_bcast(sp2,master,comm,ierr)
3472 : 5 : call xmpi_bcast(sp3,master,comm,ierr)
3473 : 5 : call xmpi_bcast(sp4,master,comm,ierr)
3474 : 5 : call xmpi_bcast(corlim,master,comm,ierr)
3475 : :
3476 : 5 : write(std_out,*)ch10,' initaim : the core densities have been read' ,ch10
3477 : :
3478 : :
3479 : : !CORRECTION OF THE CORE DENSITY NORMALISATION
3480 [ + + + + ]: 3895 : crho(:,:)=1.0003*crho(:,:)
3481 [ + + + + ]: 3895 : sp2(:,:)=1.0003*sp2(:,:)
3482 [ + + + + ]: 3895 : sp3(:,:)=1.0003*sp3(:,:)
3483 [ + + + + ]: 3895 : sp4(:,:)=1.0003*sp4(:,:)
3484 : :
3485 : : !FIELDS FOR INTERPOLATIONS OF THE VALENCE DENSITY
3486 : :
3487 [ - + + - : 15 : ABI_MALLOC(dig1,(ngfft(1)))
+ - + - -
+ - + -
+ ]
3488 [ - + + - : 15 : ABI_MALLOC(dig2,(ngfft(2)))
+ - + - -
+ - + -
+ ]
3489 [ - + + - : 15 : ABI_MALLOC(dig3,(ngfft(3)))
+ - + - -
+ - + -
+ ]
3490 [ - + + - : 10 : ABI_MALLOC(llg1,(ngfft(1)))
- + - + -
+ ]
3491 [ - + + - : 10 : ABI_MALLOC(llg2,(ngfft(2)))
- + - + -
+ ]
3492 [ - + + - : 10 : ABI_MALLOC(llg3,(ngfft(3)))
- + - + -
+ ]
3493 [ + - - + : 15 : ABI_MALLOC(cdig1,(ngfft(1)-1))
+ - + - +
- - + - +
- + ]
3494 [ + - - + : 15 : ABI_MALLOC(cdig2,(ngfft(2)-1))
+ - + - +
- - + - +
- + ]
3495 [ + - - + : 15 : ABI_MALLOC(cdig3,(ngfft(3)-1))
+ - + - +
- - + - +
- + ]
3496 [ - + + - : 25 : ABI_MALLOC(ddx,(ngfft(1),ngfft(2),ngfft(3)))
- + + - -
+ + - + -
+ - - + -
+ - + ]
3497 [ - + + - : 20 : ABI_MALLOC(ddy,(ngfft(1),ngfft(2),ngfft(3)))
- + + - -
+ + - - +
- + - + ]
3498 [ - + + - : 20 : ABI_MALLOC(ddz,(ngfft(1),ngfft(2),ngfft(3)))
- + + - -
+ + - - +
- + - + ]
3499 : :
3500 : : !DECOMPOSITION OF THE MATRIX FOR THE DETERMINATION OF COEFFICIENTS
3501 : : !FOR CUBIC SPLINE INTERPOLATION (using the periodic boundary conditions)
3502 : :
3503 : : !MAIN DIAGONAL (aa) AND SECONDARY DIAGONAL (bb) MATRIX ELEMENTS
3504 : :
3505 : 5 : nmax=ngfft(1)
3506 [ + + ]: 15 : do ii=2,3
3507 [ + + ]: 15 : if (ngfft(ii) > nmax) nmax=ngfft(ii)
3508 : : end do
3509 : : nullify(ptf,ptsd)
3510 : 20 : nullify(ptd,ptc,ptp)
3511 [ + + ]: 20 : aa(:)=2.0*dix(:)**2/3.0
3512 [ + + ]: 20 : bb(:)=dix(:)**2/6.0
3513 : :
3514 [ + + ]: 20 : do ii=1,3
3515 [ + + ]: 15 : if(ii==1) then
3516 : 5 : ptd=>dig1;ptc=>cdig1;ptp=>llg1
3517 [ + + ]: 10 : elseif (ii==2) then
3518 : 5 : ptd=>dig2;ptc=>cdig2;ptp=>llg2
3519 : : else
3520 : 5 : ptd=>dig3;ptc=>cdig3;ptp=>llg3
3521 : : end if
3522 : 15 : ptd(1)=sqrt(aa(ii))
3523 : 15 : ptc(1)=bb(ii)/ptd(1)
3524 : 15 : ptp(1)=ptc(1)
3525 [ + - ]: 688 : do jj=2,ngfft(ii)-1
3526 : 688 : ptd(jj)=aa(ii)-ptc(jj-1)**2
3527 [ - + ]: 688 : if(ptd(jj)<zero) then
3528 : 0 : ABI_ERROR('Matrix is not positive definite !')
3529 : : end if
3530 : 688 : ptd(jj)=sqrt(ptd(jj))
3531 [ + + ]: 688 : if (jj==ngfft(ii)-1) then
3532 : 15 : ptc(jj)=(bb(ii)-ptp(jj-1)*ptc(jj-1))/ptd(jj)
3533 : 15 : ptp(jj)=ptc(jj)
3534 : 15 : exit
3535 : : end if
3536 : 673 : ptc(jj)=bb(ii)/ptd(jj)
3537 : 673 : ptp(jj)=-ptp(jj-1)*ptc(jj-1)/ptd(jj)
3538 : : end do
3539 : 15 : ss=0._dp
3540 [ + + ]: 718 : do jj=1,ngfft(ii)-1
3541 : 718 : ss=ss+ptp(jj)**2
3542 : : end do
3543 : 15 : ss=aa(ii)-ss
3544 [ - + ]: 15 : if(ss<zero) then
3545 : 0 : ABI_ERROR('Matrix is not positive definite !')
3546 : : end if
3547 : 15 : ptd(ngfft(ii))=sqrt(ss)
3548 : 15 : ptp(ngfft(ii))=ptd(ngfft(ii))
3549 : :
3550 : :
3551 : : ! INITIALISATION OF THE SECOND DERIVATIVE FIELDS
3552 : :
3553 : 15 : nn=ii+1
3554 [ + + ]: 15 : if (nn>3) nn=nn-3
3555 : 15 : mm=ii+2
3556 [ + + ]: 15 : if (mm>3) mm=mm-3
3557 [ + + ]: 733 : do jj=1,ngfft(nn)
3558 [ + + ]: 34857 : do kk=1,ngfft(mm)
3559 : : ! The calcul of the second derivations on the grid
3560 : 34842 : call inspln(ii,jj,kk)
3561 : : end do
3562 : : end do
3563 : 20 : nullify(ptd,ptc,ptp)
3564 : : end do
3565 : 5 : nullify(ptd,ptc,ptp)
3566 : :
3567 : 5 : znucl_batom=znucl(typat(aim_dtset%batom))
3568 : :
3569 : 5 : ABI_FREE(znucl)
3570 [ - + ]: 5 : ABI_FREE(zionpsp)
3571 [ - + ]: 5 : ABI_FREE(symrel)
3572 [ - + ]: 5 : ABI_FREE(tnons)
3573 : :
3574 : : !the pointers are obsolete - to remove later
3575 : :
3576 [ - + - + : 10 : end subroutine initaim
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - ]
3577 : : !!***
3578 : :
3579 : : !!****f* m_bader/inpar
3580 : : !! NAME
3581 : : !! inpar
3582 : : !!
3583 : : !! FUNCTION
3584 : : !! Parser for the aim utility (shorter than the one of ABINIT)
3585 : : !!
3586 : : !! INPUTS
3587 : : !! This routine uses data from the defs_aimprom module
3588 : : !!
3589 : : !! OUTPUT
3590 : : !! instr=string of character containing the input data
3591 : : !! lenstr=actual length of the character string
3592 : : !!
3593 : : !! WARNING
3594 : : !! This file does not follow the ABINIT coding rules (yet)
3595 : : !!
3596 : : !! SOURCE
3597 : :
3598 : 5 : subroutine inpar(instr,lenstr)
3599 : :
3600 : : !Arguments ------------------------------------
3601 : : !scalars
3602 : : integer,intent(out) :: lenstr
3603 : : character(len=*),intent(out) :: instr
3604 : :
3605 : : !Local variables ------------------------------
3606 : : character(len=1),parameter :: space=' '
3607 : : character(len=26),parameter :: uplett='ABCDEFGHIJKLMNOPQRSTUVWXYZ', lolett='abcdefghijklmnopqrstuvwxyz'
3608 : : !scalars
3609 : : integer,parameter :: nline=100
3610 : : integer :: ii,inxh,inxl,ios,jj,kk,ll
3611 : : character(len=fnlen) :: line
3612 : :
3613 : : ! *********************************************************************
3614 : :
3615 : 5 : lenstr=0
3616 : :
3617 [ + + ]: 135 : do ii=1,26
3618 : 130 : inxh=index(lolett,uplett(ii:ii))
3619 [ - + ]: 135 : if (inxh > 0) then
3620 : 0 : write(std_out,*) 'ERROR The ', uplett(ii:ii) ,' is considered come lowcase !'
3621 : 0 : ABI_ERROR("Aborting now")
3622 : : end if
3623 : : end do
3624 : 5 : rewind(unt0)
3625 [ + - ]: 302 : do ii=1,nline
3626 : 302 : read(unt0,'(A)',iostat=ios) line(1:fnlen)
3627 [ + + ]: 302 : if (ios/=0) exit
3628 : 297 : inxh=index(line,'#')
3629 [ + + ]: 297 : if (inxh == 1) then
3630 : : cycle
3631 [ + + ]: 99 : elseif (inxh > 0) then
3632 : 52 : inxl=inxh-1
3633 : 52 : line(inxh:inxh)=space
3634 : : else
3635 : 47 : inxl=len_trim(line)
3636 [ + + ]: 47 : if (inxl==0) cycle
3637 : : end if
3638 : 75 : inxh=index(line(1:inxl),char(9))
3639 [ - + ]: 75 : if (inxh/=0) line(inxh:inxh)=space
3640 [ + + ]: 1031 : do ll=1,inxl
3641 [ - + ]: 1031 : if (iachar(line(ll:ll)) < 32) line(ll:ll)=space
3642 : : end do
3643 : 75 : inxh=index(line(1:inxl),'- ')
3644 [ - + ]: 75 : if (inxh/=0) then
3645 : 0 : write(std_out,*) 'ERROR sign minus with white space in input file'
3646 : 0 : ABI_ERROR("Aborting now")
3647 : : end if
3648 [ + - ]: 75 : line(1:inxl)=adjustl(line(1:inxl))
3649 : 75 : inxl=len_trim(line(1:inxl))+1
3650 : 75 : jj=2;kk=0
3651 [ + - ]: 75 : line(1:inxl)=adjustl(line(1:inxl))
3652 : 75 : kk=len_trim(line(1:inxl))+1
3653 [ + - ]: 146 : do ll=1,inxl
3654 : 146 : inxh=index(line(jj:kk),space)
3655 [ + + - + ]: 146 : if ((inxh==0).or.((jj+inxh-1)==kk)) exit
3656 [ + - ]: 71 : line(inxh+jj:kk)=adjustl(line(inxh+jj:kk))
3657 : 71 : kk=len_trim(line(1:inxl))
3658 [ - + ]: 71 : if (kk == inxl) then
3659 : : exit
3660 : : end if
3661 : 146 : jj=jj+inxh
3662 : : end do
3663 : 75 : inxl=len_trim(line(1:inxl))+1
3664 [ + + ]: 761 : do ll=1,inxl-1
3665 : 686 : inxh=index(lolett,line(ll:ll))
3666 [ + + ]: 761 : if (inxh/=0) line(ll:ll)=uplett(inxh:inxh)
3667 : : end do
3668 [ - + ]: 80 : if ((lenstr+inxl) > strlen ) then
3669 : 0 : write(std_out,*) 'ERROR Too large input !'
3670 : 0 : ABI_ERROR("Aborting now")
3671 : : else
3672 [ + - - + ]: 75 : instr(lenstr+1:lenstr+inxl)=line(1:inxl)
3673 : 75 : lenstr=lenstr+inxl
3674 : : end if
3675 : : end do
3676 : 5 : end subroutine inpar
3677 : : !!***
3678 : :
3679 : : !!****f* m_bader/inspln
3680 : : !! NAME
3681 : : !! inspln
3682 : : !!
3683 : : !! FUNCTION
3684 : : !! This procedure gives the values of the spline coefficients
3685 : : !! (second derivatives) in the 1D grid with periodic boundary
3686 : : !! conditions at rsid - the values of the unknown functions specified
3687 : : !! in the vector valf of direction idir
3688 : : !!
3689 : : !! INPUTS
3690 : : !! idir= direction following which the derivatives are evaluated
3691 : : !! snn, tnn=remaining bi-dimensional coordinates of the line along which
3692 : : !! the derivative is to be computed
3693 : : !!
3694 : : !! OUTPUT
3695 : : !! (see side effects)
3696 : : !!
3697 : : !! SIDE EFFECTS
3698 : : !! This routine works on the data contained in the aimfields module
3699 : : !!
3700 : : !! WARNING
3701 : : !! This file does not follow the ABINIT coding rules (yet)
3702 : : !!
3703 : : !! SOURCE
3704 : :
3705 : 34124 : subroutine inspln(idir,snn,tnn)
3706 : :
3707 : : !Arguments ------------------------------------
3708 : : !scalars
3709 : : integer,intent(in) :: idir,snn,tnn
3710 : :
3711 : : !Local variables-------------------------------
3712 : : !scalars
3713 : : integer :: dim,ii
3714 : : real(dp) :: ss
3715 : : !arrays
3716 : 68248 : real(dp) :: rsid(ngfft(idir)),valf(ngfft(idir))
3717 : 34124 : real(dp),pointer :: ptc(:),ptd(:),ptp(:)
3718 : :
3719 : : ! *************************************************************************
3720 : :
3721 : : !POINTER INITIALIZATION
3722 : :
3723 : 34124 : if (idir==1) then
3724 [ + + ]: 549788 : valf(:)=dvl(:,snn,tnn)
3725 [ + + ]: 22216 : elseif (idir==2) then
3726 [ + + ]: 548924 : valf(:)=dvl(tnn,:,snn)
3727 : : else
3728 [ + + ]: 549052 : valf(:)=dvl(snn,tnn,:)
3729 : : end if
3730 : :
3731 : 34124 : nullify(ptd,ptc,ptp)
3732 [ + + ]: 34124 : if(idir==1) then
3733 : 11908 : ptd=>dig1;ptc=>cdig1;ptp=>llg1
3734 [ + + ]: 22216 : elseif (idir==2) then
3735 : 11044 : ptd=>dig2;ptc=>cdig2;ptp=>llg2
3736 : : else
3737 : 11172 : ptd=>dig3;ptc=>cdig3;ptp=>llg3
3738 : : end if
3739 : :
3740 : 34124 : dim=ngfft(idir)
3741 : :
3742 : : !FIRST CYCLE OF RECURRENCE
3743 : :
3744 : 34124 : rsid(1)=valf(2)+valf(dim)-2.*valf(1)
3745 : 34124 : rsid(1)=rsid(1)/ptd(1)
3746 [ + + ]: 1579516 : do ii=2,dim-1
3747 : 1545392 : rsid(ii)=valf(ii+1)+valf(ii-1)-2.*valf(ii)
3748 : 1579516 : rsid(ii)=(rsid(ii)-ptc(ii-1)*rsid(ii-1))/ptd(ii)
3749 : : end do
3750 : : ss=0._dp
3751 [ + + ]: 1613640 : do ii=1,dim-1
3752 : 1613640 : ss=ss+rsid(ii)*ptp(ii)
3753 : : end do
3754 : 34124 : rsid(dim)=valf(1)+valf(dim-1)-2.*valf(dim)
3755 : 34124 : rsid(dim)=(rsid(dim)-ss)/ptd(dim)
3756 : :
3757 : : !SECOND CYCLE WITH TRANSPOSED MATRIX
3758 : :
3759 : 34124 : rsid(dim)=rsid(dim)/ptd(dim)
3760 : 34124 : rsid(dim-1)=(rsid(dim-1)-ptc(dim-1)*rsid(dim))/ptd(dim-1)
3761 [ + + ]: 1579516 : do ii=dim-2,1,-1
3762 : 1579516 : rsid(ii)=(rsid(ii)-ptc(ii)*rsid(ii+1)-ptp(ii)*rsid(dim))/ptd(ii)
3763 : : end do
3764 : :
3765 [ + + ]: 34124 : if (idir==1) then
3766 [ + + ]: 549788 : ddx(:,snn,tnn)=rsid(:)
3767 [ + + ]: 22216 : elseif (idir==2) then
3768 [ + + ]: 548924 : ddy(tnn,:,snn)=rsid(:)
3769 : : else
3770 [ + + ]: 549052 : ddz(snn,tnn,:)=rsid(:)
3771 : : end if
3772 : :
3773 [ + + ]: 34124 : end subroutine inspln
3774 : : !!***
3775 : :
3776 : : !!****f* m_bader/integrho
3777 : : !! NAME
3778 : : !! integrho
3779 : : !!
3780 : : !! FUNCTION
3781 : : !! This routine integrates the electron density inside the
3782 : : !! atomic surface already calculated - it reads the file *.surf
3783 : : !! The radial integration is always performed with splines and
3784 : : !! the two angular integrations with Gauss quadrature
3785 : : !!
3786 : : !! INPUTS
3787 : : !! aim_dtset = the structured entity containing all input variables
3788 : : !! znucl_batom=the nuclear charge of the Bader atom
3789 : : !!
3790 : : !! OUTPUT
3791 : : !! (see side effects)
3792 : : !!
3793 : : !! SIDE EFFECTS
3794 : : !! This routine works primarily on the data contained in the aimfields and aimprom modules
3795 : : !!
3796 : : !! WARNING
3797 : : !! This file does not follow the ABINIT coding rules (yet)
3798 : : !!
3799 : : !! SOURCE
3800 : :
3801 : 5 : subroutine integrho(aim_dtset,znucl_batom)
3802 : :
3803 : : !Arguments ------------------------------------
3804 : : !scalars
3805 : : type(aim_dataset_type),intent(in) :: aim_dtset
3806 : :
3807 : : !Local variables ------------------------------
3808 : : !scalars
3809 : : integer :: batom,chs,iat,ii,inx,inxf,ipos,jj,kk,ll,nn,nph,nth
3810 : : real(dp) :: chg,chgint,cintr,ct1,ct2,lder,nsphe,phimax,phimin,rder
3811 : : real(dp) :: rsmax,rsmin,ss,stp,themax,themin,uu
3812 : : real(dp) :: znucl_batom,zz
3813 : : logical :: gaus,weit
3814 : : !arrays
3815 : : real(dp) :: grho(3),hrho(3,3),shift(3),unvec(3),vv(3)
3816 : 5 : real(dp),allocatable :: ncrho(:),nsp2(:),nsp3(:),nsp4(:),rdint(:,:),rr(:)
3817 : 5 : real(dp),allocatable :: vdd(:),vrho(:),wgrs(:,:),work(:)
3818 : :
3819 : : ! *********************************************************************
3820 : :
3821 : 5 : gaus=.true.
3822 : 5 : weit=.true.
3823 : :
3824 : 5 : write(std_out,*) 'npt = ',aim_dtset%npt
3825 : :
3826 : 5 : rewind(unts)
3827 : 5 : read(unts,*) batom,shift ! Warning : batom is read, instead of coming from aim_dtset
3828 : 5 : read(unts,*) nth,themin,themax ! Warning : these numbers are read, instead of coming from aim_dtset
3829 : 5 : read(unts,*) nph,phimin,phimax ! Warning : these numbers are read, instead of coming from aim_dtset
3830 : :
3831 : 5 : write(std_out,*) 'NTH NPH ',nth,nph
3832 : :
3833 [ - + + - : 20 : ABI_MALLOC(wgrs,(nth,nph))
- + + - +
- + - - +
- + ]
3834 [ - + + - : 15 : ABI_MALLOC(rdint,(nth,nph))
- + + - -
+ - + ]
3835 : :
3836 [ + + ]: 35 : do ii=1,nth
3837 [ + + ]: 165 : do jj=1,nph
3838 : 30 : if (weit) then
3839 : 130 : read(unts,*) th(ii),ph(jj),rs(ii,jj),wgrs(ii,jj)
3840 : : else
3841 : : read(unts,*) th(ii),ph(jj),rs(ii,jj)
3842 : : end if
3843 : : end do
3844 : : end do
3845 : 5 : read(unts,*) rsmin,rsmax
3846 : :
3847 : :
3848 : : if (gaus) then
3849 : 5 : ct1=cos(themin)
3850 : 5 : ct2=cos(themax)
3851 : 5 : call coeffs_gausslegint(ct1,ct2,cth,wcth,nth)
3852 : 5 : call coeffs_gausslegint(phimin,phimax,ph,wph,nph)
3853 : : end if
3854 : :
3855 : 5 : do ii=1,nth
3856 : 5 : do jj=1,nph
3857 : : if (.not.weit) then
3858 : : if (gaus) then
3859 : : wgrs(ii,jj)=wcth(ii)*wph(jj)
3860 : : else
3861 : : wgrs(ii,jj)=1._dp
3862 : : end if
3863 : : end if
3864 : : end do
3865 : : end do
3866 : :
3867 : :
3868 [ + + ]: 35 : do ii=1,nth
3869 [ + + ]: 165 : do jj=1,nph
3870 [ + + ]: 160 : if (rs(ii,jj) < rsmin) rsmin=rs(ii,jj)
3871 : : end do
3872 : : end do
3873 : :
3874 : :
3875 : : !INTEGRATION OF THE CORE DENSITY
3876 : :
3877 : 5 : nn=typat(batom)
3878 : 5 : kk=ndat(nn)
3879 : :
3880 : :
3881 : : !spherical integration of the core density in the sphere
3882 : : !of the minimal Bader radius
3883 : :
3884 : : !COEF. FOR SPHERICAL INTEGRATION
3885 : :
3886 [ - + + - : 15 : ABI_MALLOC(nsp2,(kk))
+ - + - -
+ - + ]
3887 [ - + + - : 10 : ABI_MALLOC(nsp3,(kk))
- + - + ]
3888 [ - + + - : 10 : ABI_MALLOC(nsp4,(kk))
- + - + ]
3889 [ - + + - : 10 : ABI_MALLOC(ncrho,(kk))
- + - + ]
3890 : :
3891 [ + + ]: 1557 : do ii=1,kk
3892 : 1552 : ncrho(ii)=crho(ii,nn)*4._dp*pi*rrad(ii,nn)*rrad(ii,nn)
3893 : : nsp3(ii)=4._dp*pi*(2._dp*crho(ii,nn)+2._dp*rrad(ii,nn)*sp2(ii,nn)+&
3894 : 1557 : & rrad(ii,nn)*rrad(ii,nn)*sp3(ii,nn))
3895 : : end do
3896 : :
3897 [ + + ]: 5 : if (rsmin < rrad(ndat(nn),nn)) then ! search index
3898 : 4 : inx=0
3899 [ - + ]: 4 : if (rsmin < rrad(1,nn)) then
3900 : 0 : ABI_ERROR('absurd')
3901 : : elseif (rsmin > rrad(ndat(nn),nn)) then
3902 : : inx=ndat(nn)
3903 : : else
3904 [ + + ]: 1348 : do while (rsmin >= rrad(inx+1,nn))
3905 : 4 : inx=inx+1
3906 : : end do
3907 : : end if
3908 : : else
3909 : : inx=ndat(nn)
3910 : : end if
3911 : :
3912 : 5 : cintr=4._dp/3._dp*pi*rrad(1,nn)**3*crho(1,nn)
3913 : :
3914 : : !spline integration
3915 : :
3916 [ + + ]: 1366 : do ii=1,inx-1
3917 : 1361 : uu=rrad(ii+1,nn)-rrad(ii,nn)
3918 : 1366 : cintr=cintr+(ncrho(ii)+ncrho(ii+1))*uu/2._dp-uu*uu*uu/2.4d1*(nsp3(ii)+nsp3(ii+1))
3919 : : end do
3920 [ + + ]: 5 : if (inx/=ndat(nn)) then
3921 : 4 : uu=rsmin-rrad(inx,nn)
3922 : 4 : zz=rrad(inx+1,nn)-rsmin
3923 : 4 : ss=rrad(inx+1,nn)-rrad(inx,nn)
3924 : : cintr=cintr+ncrho(inx)/2._dp*(ss-zz*zz/ss)+ncrho(inx+1)/2._dp*uu*uu/ss+&
3925 : : nsp3(inx)/1.2d1*(zz*zz*ss-zz*zz*zz*zz/2._dp/ss-ss*ss*ss/2._dp)+&
3926 : 4 : nsp3(inx+1)/1.2d1*(uu*uu*uu*uu/2._dp/ss-uu*uu*ss)
3927 : : end if
3928 : :
3929 : :
3930 : : !INTEGRATION OF THE REST OF THE CORE DENSITY
3931 : : !(for gauss quadrature)
3932 : : !For the Gauss quadrature it is added
3933 : : !to the radial integrated valence density
3934 : :
3935 [ + + + + ]: 157 : rdint(:,:)=0._dp
3936 : 5 : nsphe=0._dp
3937 [ + + ]: 35 : do ii=1,nth
3938 [ + + ]: 165 : do jj=1,nph
3939 [ + + ]: 130 : if (inx==ndat(nn)) cycle
3940 : 114 : inxf=inx
3941 [ - + ]: 114 : if (rs(ii,jj) < rsmin) then
3942 : 0 : write(std_out,*) rs(ii,jj),rsmin
3943 : 0 : ABI_ERROR('in surface')
3944 [ + + ]: 114 : elseif (rs(ii,jj) > rrad(ndat(nn),nn)) then
3945 : : inxf=ndat(nn)
3946 : : else
3947 [ + + ]: 1564 : do while (rs(ii,jj) >= rrad(inxf+1,nn))
3948 : 96 : inxf=inxf+1
3949 : : end do
3950 : : end if
3951 : :
3952 [ + + ]: 114 : if (inxf==inx) then
3953 : 12 : uu=rrad(inx+1,nn)-rs(ii,jj)
3954 : 12 : zz=rrad(inx+1,nn)-rsmin
3955 : 12 : ss=rrad(inx+1,nn)-rrad(inx,nn)
3956 : :
3957 : : rdint(ii,jj)=(ncrho(inx)/2._dp/ss-nsp3(inx)/1.2d1*ss)*(zz*zz-uu*uu)+&
3958 : 12 : nsp3(inx)/2.4d1/ss*(zz**4-uu**4)
3959 : 12 : uu=rs(ii,jj)-rrad(inx,nn)
3960 : 12 : zz=rsmin-rrad(inx,nn)
3961 : : rdint(ii,jj)=rdint(ii,jj)+(uu*uu-zz*zz)*(ncrho(inx+1)/2._dp/ss-nsp3(inx+1)/1.2d1*ss)+&
3962 : 12 : nsp3(inx+1)/2.4d1/ss*(uu**4-zz**4)
3963 : : else
3964 : 102 : uu=rrad(inx+1,nn)-rsmin
3965 : 102 : zz=rsmin-rrad(inx,nn)
3966 : :
3967 : : rdint(ii,jj)=ncrho(inx)/2._dp/ss*uu*uu+ncrho(inx+1)/2._dp*(ss-zz*zz/ss)+&
3968 : 102 : nsp3(inx)/1.2d1*(uu**4/2._dp/ss-uu*uu*ss)+nsp3(inx+1)/1.2d1*(zz*zz*ss-ss**3/2._dp-zz**4/2._dp/ss)
3969 [ + + ]: 102 : if (inxf > inx+1) then
3970 [ + + ]: 1914 : do kk=inx+1,inxf-1
3971 : 1816 : uu=rrad(kk+1,nn)-rrad(kk,nn)
3972 : 1914 : rdint(ii,jj)=rdint(ii,jj)+(ncrho(kk)+ncrho(kk+1))*uu/2._dp-uu*uu*uu/2.4d1*(nsp3(kk)+nsp3(kk+1))
3973 : : end do
3974 : : end if
3975 : :
3976 [ + + ]: 102 : if (inxf/=ndat(nn)) then
3977 : 84 : uu=rs(ii,jj)-rrad(inxf,nn)
3978 : 84 : zz=rrad(inxf+1,nn)-rs(ii,jj)
3979 : 84 : ss=rrad(inxf+1,nn)-rrad(inxf,nn)
3980 : : rdint(ii,jj)=rdint(ii,jj)+ncrho(inxf)/2._dp*(ss-zz*zz/ss)+ncrho(inxf+1)/2._dp*uu*uu/ss+&
3981 : : nsp3(inxf)/1.2d1*(zz*zz*ss-zz*zz*zz*zz/2._dp/ss-ss*ss*ss/2._dp)+&
3982 : 84 : nsp3(inxf+1)/1.2d1*(uu*uu*uu*uu/2._dp/ss-uu*uu*ss)
3983 : : end if
3984 : : end if
3985 : 114 : rdint(ii,jj)=rdint(ii,jj)/4._dp/pi
3986 : 160 : nsphe=nsphe+rdint(ii,jj)*wgrs(ii,jj)
3987 : : end do
3988 : : end do
3989 : 5 : nsphe=nsphe*(pi/(themin-themax))*(two_pi/(phimax-phimin))
3990 : :
3991 : 5 : write(untout,*)
3992 : 5 : write(untout,*) "CHARGE INTEGRATION"
3993 : 5 : write(untout,*) "=================="
3994 : 5 : write(untout,'(" Core density contribution: ",/,/," ",F16.8)') cintr+nsphe
3995 : :
3996 : 5 : write(std_out,*) ':INTECOR ', cintr+nsphe
3997 : :
3998 [ - + ]: 5 : ABI_FREE(ncrho)
3999 [ - + ]: 5 : ABI_FREE(nsp2)
4000 [ - + ]: 5 : ABI_FREE(nsp3)
4001 [ - + ]: 5 : ABI_FREE(nsp4)
4002 : :
4003 : : !INTEGRATION OF THE VALENCE DENSITY
4004 : :
4005 [ + - - + : 15 : ABI_MALLOC(rr,(aim_dtset%npt+1))
+ - + - +
- - + -
+ ]
4006 [ - + + - : 10 : ABI_MALLOC(vrho,(aim_dtset%npt+1))
- + - + ]
4007 [ - + + - : 10 : ABI_MALLOC(vdd,(aim_dtset%npt+1))
- + - + ]
4008 : :
4009 : : !in the case of the only irho appelation
4010 : :
4011 : 40 : nn=0
4012 [ + + ]: 40 : do ii=-3,3
4013 [ + + ]: 285 : do jj=-3,3
4014 [ + + ]: 1995 : do kk=-3,3
4015 : 1715 : nn=nn+1
4016 : 1715 : atp(1,nn)=ii*1._dp
4017 : 1715 : atp(2,nn)=jj*1._dp
4018 : 1715 : atp(3,nn)=kk*1._dp
4019 : 1715 : call bschg1(atp(:,nn),1)
4020 [ + + ]: 1960 : if ((ii==0).and.(jj==0).and.(kk==0)) ipos=nn
4021 : : end do
4022 : : end do
4023 : : end do
4024 : 5 : nnpos=nn
4025 : 5 : iat=batom
4026 : :
4027 : : !XG020629 There is a problem with this routine
4028 : : !(or vgh_rho), when one uses the PGI compiler :
4029 : : !The following line is needed, otherwise, iat and ipos
4030 : : !are set to 0 inside vgh_now. Why ????
4031 : 5 : write(std_out,*)' integrho : iat,ipos=',iat,ipos
4032 : : !
4033 : :
4034 : 5 : nsphe=0._dp
4035 [ - + + - : 10 : ABI_MALLOC(work,(aim_dtset%npt+1))
- + - + ]
4036 [ + + ]: 35 : do ii=1,nth
4037 [ + + ]: 165 : do jj=1,nph
4038 : :
4039 : 130 : stp=rs(ii,jj)/aim_dtset%npt
4040 : 130 : unvec(1)=sin(th(ii))*cos(ph(jj))
4041 : 130 : unvec(2)=sin(th(ii))*sin(ph(jj))
4042 : 130 : unvec(3)=cos(th(ii))
4043 [ + + ]: 6120 : do kk=0,aim_dtset%npt
4044 : 5990 : rr(kk+1)=kk*stp
4045 [ + + ]: 23960 : vv(:)=xatm(:,batom)+kk*stp*unvec(:)
4046 : 5990 : chs=-2
4047 : 5990 : call vgh_rho(vv,chg,grho,hrho,uu,iat,ipos,chs)
4048 : 5990 : vrho(kk+1)=chg*rr(kk+1)*rr(kk+1)
4049 [ + + ]: 6120 : if (kk==aim_dtset%npt) then
4050 : 130 : rder=0._dp
4051 [ + + ]: 520 : do ll=1,3
4052 : 520 : rder=rder+grho(ll)*unvec(ll)
4053 : : end do
4054 : 130 : rder=rder*rr(kk+1)*rr(kk+1)+2._dp*rr(kk+1)*chg
4055 : : end if
4056 : : end do
4057 : 130 : lder=0._dp
4058 : 130 : kk=aim_dtset%npt+1
4059 : 130 : call spline(rr,vrho,kk,lder,rder,vdd)
4060 : :
4061 : : ! INTEGRATION
4062 : :
4063 [ + + ]: 5990 : do kk=1,aim_dtset%npt
4064 : : rdint(ii,jj)=rdint(ii,jj)+stp/2._dp*(vrho(kk)+vrho(kk+1))&
4065 : 5990 : & -stp*stp*stp/24._dp*(vdd(kk)+vdd(kk+1))
4066 : : end do
4067 : 160 : nsphe=nsphe+rdint(ii,jj)*wgrs(ii,jj)
4068 : : end do
4069 : : end do
4070 [ - + ]: 5 : ABI_FREE(work)
4071 : :
4072 : : if (gaus.or.weit) then
4073 : 5 : nsphe=nsphe*(pi/(themin-themax))*(two_pi/(phimax-phimin))
4074 : : else
4075 : : nsphe=nsphe/(nth*nph)*2.0*two_pi
4076 : : end if
4077 : 5 : chgint=cintr+nsphe
4078 : :
4079 : : write(untout,'(/," Different density contributions: Core (only spherical part) and the rest ",/,/," ",2F16.8)') &
4080 : 5 : & cintr, nsphe
4081 : 5 : write(untout,'(/,a,i4,a,f14.8)') ' For atom number ',batom,', the number of electrons in the Bader volume is ',chgint
4082 : 5 : write(untout,'(a,f15.7,a,f17.8)') ' The nuclear charge is',znucl_batom,', so that the Bader charge is ',znucl_batom-chgint
4083 : 5 : write(untout,*)
4084 : 5 : write(std_out,*) ':INTEPAR ', cintr, nsphe
4085 : 5 : write(std_out,*) ':RHOTOT ',batom,chgint
4086 : :
4087 [ + - + - : 5 : end subroutine integrho
+ - + - +
- ]
4088 : : !!***
4089 : :
4090 : : !!****f* m_bader/integvol
4091 : : !! NAME
4092 : : !! integvol
4093 : : !!
4094 : : !! FUNCTION
4095 : : !! This routine integrates the volume of the Bader atom
4096 : : !!
4097 : : !! INPUTS
4098 : : !! (see side effects)
4099 : : !!
4100 : : !! OUTPUT
4101 : : !! (see side effects)
4102 : : !!
4103 : : !! SIDE EFFECTS
4104 : : !! This routine works on the data contained in the aimfields and aimprom modules
4105 : : !!
4106 : : !! WARNING
4107 : : !! This file does not follow the ABINIT coding rules (yet)
4108 : : !!
4109 : : !! SOURCE
4110 : :
4111 : 1 : subroutine integvol()
4112 : :
4113 : : !Arguments ------------------------------------
4114 : :
4115 : : !Local variables ------------------------------
4116 : : !scalars
4117 : : integer :: batom,ii,jj,nph,nth
4118 : : real(dp) :: chgint,ct1,ct2,nsphe,phimax,phimin
4119 : : real(dp) :: rsmax,rsmin,themax,themin
4120 : : logical :: gaus,weit
4121 : : !arrays
4122 : : real(dp) :: shift(3)
4123 : 1 : real(dp),allocatable :: rdint(:,:)
4124 : 1 : real(dp),allocatable :: wgrs(:,:)
4125 : :
4126 : : ! *********************************************************************
4127 : :
4128 : 1 : tpi=two_pi
4129 : 1 : gaus=.true.
4130 : 1 : weit=.true.
4131 : :
4132 : :
4133 : 1 : rewind(unts)
4134 : 1 : read(unts,*) batom,shift
4135 : 1 : read(unts,*) nth,themin,themax
4136 : 1 : read(unts,*) nph,phimin,phimax
4137 : :
4138 : 1 : write(std_out,*) 'NTH NPH ',nth,nph
4139 : :
4140 [ - + + - : 4 : ABI_MALLOC(wgrs,(nth,nph))
- + + - +
- + - - +
- + ]
4141 [ - + + - : 3 : ABI_MALLOC(rdint,(nth,nph))
- + + - -
+ - + ]
4142 : :
4143 [ + + ]: 5 : do ii=1,nth
4144 [ + + ]: 21 : do jj=1,nph
4145 : 4 : if (weit) then
4146 : 16 : read(unts,*) th(ii),ph(jj),rs(ii,jj),wgrs(ii,jj)
4147 : : else
4148 : : read(unts,*) th(ii),ph(jj),rs(ii,jj)
4149 : : end if
4150 : : end do
4151 : : end do
4152 : 1 : read(unts,*) rsmin,rsmax
4153 : :
4154 : :
4155 : : if (gaus) then
4156 : 1 : ct1=cos(themin)
4157 : 1 : ct2=cos(themax)
4158 : 1 : call coeffs_gausslegint(ct1,ct2,cth,wcth,nth)
4159 : 1 : call coeffs_gausslegint(phimin,phimax,ph,wph,nph)
4160 : : end if
4161 : :
4162 : 1 : do ii=1,nth
4163 : 1 : do jj=1,nph
4164 : : if (.not.weit) then
4165 : : if (gaus) then
4166 : : wgrs(ii,jj)=wcth(ii)*wph(jj)
4167 : : else
4168 : : wgrs(ii,jj)=1._dp
4169 : : end if
4170 : : end if
4171 : : end do
4172 : : end do
4173 : :
4174 : : nsphe=0._dp
4175 [ + + ]: 5 : do ii=1,nth
4176 [ + + ]: 21 : do jj=1,nph
4177 : 20 : nsphe=nsphe+rs(ii,jj)**3/3._dp*wgrs(ii,jj)
4178 : : end do
4179 : : end do
4180 : : if (gaus.or.weit) then
4181 : 1 : nsphe=nsphe*(pi/(themin-themax))*(tpi/(phimax-phimin))
4182 : : else
4183 : : nsphe=nsphe/(nth*nph)*2.0*tpi
4184 : : end if
4185 : 1 : chgint=nsphe
4186 : :
4187 : 1 : write(std_out,*) ':VOLTOT ',batom,chgint
4188 : 1 : write(untout,'("Volume of the Bader atom: ", I6, F16.8)') batom,chgint
4189 : :
4190 [ + - + - ]: 1 : end subroutine integvol
4191 : : !!***
4192 : :
4193 : : !!****f* m_bader/onestep
4194 : : !! NAME
4195 : : !! onestep
4196 : : !!
4197 : : !! FUNCTION
4198 : : !! Advance one step following the gradient from vv(3).
4199 : : !! It returns a new point in vv(3) and the value and gradient of the
4200 : : !! electron density at this point in chg and grho(3)
4201 : : !!
4202 : : !! INPUTS
4203 : : !! npmax= maximum number of divisions
4204 : : !! hh= determines the initial value of the step (to be multiplied by grho)
4205 : : !!
4206 : : !! OUTPUT
4207 : : !! chg= value of electron density
4208 : : !! deltar= the length of the step thaty was needed
4209 : : !! grho(3)= gradient of electron density
4210 : : !! np= returns the number of divisions that were needed
4211 : : !!
4212 : : !! SIDE EFFECTS
4213 : : !! vv(3)=starting and updated point
4214 : : !!
4215 : : !! WARNING
4216 : : !! This file does not follow the ABINIT coding rules (yet)
4217 : : !!
4218 : : !! SOURCE
4219 : :
4220 : 232463 : subroutine onestep(vv,chg,grho,hh,np,npmax,deltar)
4221 : :
4222 : : !Arguments ------------------------------------
4223 : : !scalars
4224 : : integer,intent(in) :: npmax
4225 : : integer,intent(out) :: np
4226 : : real(dp),intent(in) :: hh
4227 : : real(dp),intent(out) :: chg,deltar
4228 : : !arrays
4229 : : real(dp),intent(inout) :: vv(3)
4230 : : real(dp),intent(out) :: grho(3)
4231 : :
4232 : : !Local variables ------------------------------
4233 : : !scalars
4234 : : integer :: iat,ii,ipos,jj
4235 : : real(dp) :: dt,rr
4236 : : !arrays
4237 : : real(dp) :: hrho(3,3),pom(3),vinter(3,200),vk(3),vkold(3)
4238 : :
4239 : : !************************************************************************
4240 : 232463 : dt=hh
4241 : 232463 : np=1
4242 : 232463 : deltar=1._dp
4243 : 232463 : vk(1:3)=vv(1:3)
4244 : :
4245 : :
4246 [ + + + + : 801406 : do while((np<3).or.((np<=npmax).and.(deltar>aim_deltarmin)))
+ + ]
4247 : 568943 : np=np*2
4248 : 568943 : dt=dt*0.5_dp
4249 : 568943 : vkold(1:3)=vk(1:3)
4250 : 568943 : call vgh_rho(vk,chg,grho,hrho,rr,iat,ipos,0)
4251 [ + + ]: 2275772 : vinter(1:3,1)=vv(1:3)+dt*grho(1:3)
4252 [ + + ]: 2724090 : do jj=2,np
4253 : 2155147 : call vgh_rho(vinter(1,jj-1),chg,grho,hrho,rr,iat,ipos,0)
4254 [ + + ]: 2724090 : if(jj.eq.2) then
4255 [ + + ]: 2275772 : vinter(1:3,2)=vv(1:3)+2.0*dt*grho(1:3)
4256 : : else
4257 [ + + ]: 6344816 : vinter(1:3,jj)=vinter(1:3,jj-2)+2.0*dt*grho(1:3)
4258 : : end if
4259 : : end do
4260 : :
4261 : 568943 : call vgh_rho(vinter(1,np),chg,grho,hrho,rr,iat,ipos,0)
4262 [ + + ]: 2275772 : vinter(1:3,np+1)=vinter(1:3,np-1)+dt*grho(1:3)
4263 : :
4264 : 568943 : deltar=0._dp
4265 [ + + ]: 2508235 : do ii=1,3
4266 : 1706829 : vk(ii)=(vinter(ii,np)+vinter(ii,np+1))*0.5_dp
4267 : 2275772 : deltar=deltar+(vkold(ii)-vk(ii))*(vkold(ii)-vk(ii))
4268 : : end do
4269 : : end do
4270 : :
4271 [ + + ]: 929852 : pom(:)=vk(:)-vv(:)
4272 : 232463 : deltar=vnorm(pom,0)
4273 : 232463 : vv(1:3)=vk(1:3)
4274 : :
4275 : 232463 : call vgh_rho(vv,chg,grho,hrho,rr,iat,ipos,0)
4276 [ - + ]: 232463 : if(deb) write(std_out,*) ':VKf ',np,vk
4277 : :
4278 : 232463 : end subroutine onestep
4279 : : !!***
4280 : :
4281 : : !!****f* m_bader/plint
4282 : : !! NAME
4283 : : !! plint
4284 : : !!
4285 : : !! FUNCTION
4286 : : !! This simple routine gives the profile of the density
4287 : : !! integrated in xy plane belong the z-axes (it works only
4288 : : !! for orthogonal coordinates at present - it is better to use cut3d)
4289 : : !! integration in plane - with equilateral triangles (not really
4290 : : !! finished and not tested!)
4291 : : !!
4292 : : !! INPUTS
4293 : : !! (this routine works on the data in the aimprom module)
4294 : : !!
4295 : : !! OUTPUT
4296 : : !! (this routine works on the data in the aimprom module)
4297 : : !!
4298 : : !! WARNING
4299 : : !! This file does not follow the ABINIT coding rules (yet)
4300 : : !!
4301 : : !! SOURCE
4302 : :
4303 : 0 : subroutine plint()
4304 : :
4305 : : !Arguments ------------------------------------
4306 : :
4307 : : !Local variables ------------------------------
4308 : : !scalars
4309 : : integer,parameter :: nd=150,ng=300
4310 : : integer :: cod,iat,ii,ipos,jj,kk,nn
4311 : : real(dp) :: dd,ee,ff,gg,hh,igr,rho,ss
4312 : : logical :: prep
4313 : : !arrays
4314 : : real(dp) :: grho(3),hrho(3,3),vv(3),xl(nd+1),xs(nd)
4315 : 0 : real(dp),allocatable :: uu(:)
4316 : :
4317 : : ! *********************************************************************
4318 : :
4319 : 0 : ff=rprimd(1,1)/nd
4320 : 0 : ss=2._dp/sqrt(3._dp)*rprimd(2,2)/rprimd(1,1)*nd
4321 : 0 : nn=int(ss)
4322 : 0 : gg=sqrt(3._dp)/2.*ff
4323 : 0 : hh=rprimd(2,2)-nn/nd*sqrt(3._dp)/2.*rprimd(1,1)
4324 : 0 : ee=hh/sqrt(3._dp)
4325 : 0 : hh=hh/2.
4326 : 0 : ss=sqrt(3._dp)*ff*ff/4.
4327 : 0 : dd=ee*ff/2.
4328 : :
4329 [ # # ]: 0 : do ii=1,nd
4330 : 0 : xl(ii)=ii*ff
4331 : 0 : xs(ii)=ff/2.+ii*ff
4332 : : end do
4333 : : xl(nd+1)=rprimd(1,1)
4334 : :
4335 [ # # # # : 0 : ABI_MALLOC(uu,(nn+3))
# # # # #
# # # #
# ]
4336 : :
4337 : 0 : uu(1)=0._dp
4338 : 0 : uu(nn+3)=rprimd(2,2)
4339 [ # # ]: 0 : do ii=2,nn+2
4340 : 0 : uu(ii)=hh+(ii-1)*gg
4341 : : end do
4342 : : igr=0._dp
4343 : 0 : prep=.true.
4344 [ # # ]: 0 : do kk=1,ng
4345 : 0 : igr=0._dp
4346 : 0 : vv(3)=(kk-1)*rprimd(3,3)/ng
4347 [ # # ]: 0 : do ii=1,nn+3
4348 : 0 : vv(2)=uu(ii)
4349 [ # # ]: 0 : do jj=1,nd
4350 [ # # ]: 0 : if (prep) then
4351 : 0 : vv(1)=xl(jj)
4352 : 0 : prep=.false.
4353 : : else
4354 : 0 : vv(1)=xs(jj)
4355 : 0 : prep=.true.
4356 : : end if
4357 : 0 : call vgh_rho(vv,rho,grho,hrho,dd,iat,ipos,cod)
4358 [ # # # # ]: 0 : if ((ii==1).or.(ii==nn+3)) then
4359 : 0 : igr=igr+dd*rho
4360 [ # # # # ]: 0 : elseif ((ii==2).or.(ii==nn+2)) then
4361 : 0 : igr=igr+(dd+ss)*rho
4362 : : else
4363 : 0 : igr=igr+ss*2*rho
4364 : : end if
4365 : : end do
4366 : : end do
4367 : 0 : write(untp,'(2E16.8)') vv(3), igr
4368 : : end do
4369 : 0 : ABI_FREE(uu)
4370 : :
4371 : 0 : end subroutine plint
4372 : : !!***
4373 : :
4374 : : !!****f* m_bader/rsurf
4375 : : !! NAME
4376 : : !! rsurf
4377 : : !!
4378 : : !! FUNCTION
4379 : : !! Basic routine for determination of the radius of Bader surface
4380 : : !! for spherical rayon theta,phi
4381 : : !! the bassin is tested by following the gradient line
4382 : : !! If srch==true (in general for calls from surf) the routine aim_follow
4383 : : !! is called to stop when it arrives under already known part of surface
4384 : : !! Simple bissection method is used to obtain the radius
4385 : : !!
4386 : : !! WARNING
4387 : : !! This file does not follow the ABINIT coding rules (yet)
4388 : : !!
4389 : : !! INPUTS
4390 : : !! aim_dtset= the structured entity containing all input variables
4391 : : !! rr0= starting radius
4392 : : !! theta,phi = the spherical direction
4393 : : !! iatinit= the atom index
4394 : : !! srch= see above
4395 : : !! npmax= maximum number of divisions in one step for follow
4396 : : !!
4397 : : !! OUTPUT
4398 : : !! rr= radius
4399 : : !! grho(3)= gradient on the surface
4400 : : !!
4401 : : !! SOURCE
4402 : :
4403 : 130 : subroutine rsurf(aim_dtset,rr,grho,theta,phi,rr0,iatinit,npmax,srch)
4404 : :
4405 : : !Arguments ------------------------------------
4406 : : !scalars
4407 : : integer,intent(in) :: iatinit,npmax
4408 : : real(dp),intent(in) :: phi,rr0,theta
4409 : : real(dp),intent(out) :: rr
4410 : : logical,intent(in) :: srch
4411 : : !arrays
4412 : : real(dp),intent(out) :: grho(3)
4413 : : !no_abirules
4414 : : type(aim_dataset_type),intent(in) :: aim_dtset
4415 : :
4416 : : !Local variables ------------------------------
4417 : : !scalars
4418 : : integer :: iat,ii,ipos,iposinit,jj,nstep
4419 : : real(dp),parameter :: mfkt=1.d1
4420 : : real(dp) :: aa,dmax,dr,drr,rho,rr1,rr2,t1,t2,wall
4421 : : logical :: cross,deb_tmp,in,in1,in2,low,srch_tmp
4422 : : !arrays
4423 : : real(dp) :: hrho(3,3),unvec(3),vv(3)
4424 : :
4425 : : ! *********************************************************************
4426 : :
4427 : 130 : srch_tmp=srch
4428 : 130 : deb_tmp=deb
4429 : :
4430 : : !unity vecteur in the direction (theta,phi)
4431 : :
4432 : 130 : unvec(1)=sin(theta)*cos(phi)
4433 : 130 : unvec(2)=sin(theta)*sin(phi)
4434 : 130 : unvec(3)=cos(theta)
4435 : :
4436 : :
4437 : 130 : rr=rr0
4438 : 130 : rr1=rr
4439 : 130 : rr2=rr
4440 : 130 : drr=1._dp
4441 [ + + ]: 130 : if (abs(rr0-r0)<1.0d-12) then
4442 : 28 : dr=aim_dtset%dr0*mfkt
4443 : : else
4444 : 102 : dr=aim_dtset%dr0
4445 : : end if
4446 : :
4447 : 130 : vv(1)=xatm(1,aim_dtset%batom)
4448 : 130 : vv(2)=xatm(2,aim_dtset%batom)
4449 : 130 : vv(3)=xatm(3,aim_dtset%batom)
4450 : :
4451 : :
4452 : 130 : iposinit=batcell
4453 : 130 : write(std_out,'("ATOM iat=",i4," ipos=",i4)') aim_dtset%batom,batcell
4454 : 130 : jj=0
4455 : :
4456 : 130 : cross=.false.
4457 : :
4458 : 130 : in=.true.
4459 : 130 : low=.false.
4460 : :
4461 : 130 : dmax=h0
4462 : :
4463 : 130 : in1=.true.
4464 : 130 : in2=in1
4465 : :
4466 [ + + + + ]: 2761 : do while((drr>aim_drmin).or.(jj<2))
4467 : 2631 : call timein(t1,wall)
4468 : 2631 : jj=jj+1
4469 [ + + ]: 10524 : do ii=1,3
4470 : 10524 : vv(ii)=xatm(ii,aim_dtset%batom)+rr*unvec(ii)
4471 : : end do
4472 : :
4473 : : ! VACUUM CONDITION
4474 : :
4475 : 2631 : call vgh_rho(vv,rho,grho,hrho,aa,iat,ipos,0)
4476 [ - + ]: 2631 : if (rho < aim_rhomin) exit
4477 : :
4478 : 2631 : ldeb=.false.
4479 : :
4480 : 2631 : call aim_follow(aim_dtset,vv,npmax,srch_tmp,iatinit,iposinit,iat,ipos,nstep)
4481 : :
4482 : 2631 : call timein(t2,wall)
4483 : 2631 : t2=t2-t1
4484 : :
4485 : : write(std_out,'(a,i4,a,f12.8,a,i4,a,i4,a,f10.5,a,i4)') &
4486 : 2631 : & ' :STEP ',jj,' r=',rr,' iat=',iat,' ipos=',ipos,' time(sec)=',t2,' nstep=',nstep
4487 : :
4488 [ + + + + ]: 2631 : if ((iat.eq.iatinit).and.(ipos.eq.iposinit)) then
4489 : : in=.true.
4490 : : else
4491 : 1285 : in=.false.
4492 : : end if
4493 : :
4494 : : !
4495 : : ! NEW RADIUS
4496 : : !
4497 : :
4498 [ + + + + ]: 2631 : if ((jj.eq.1).or.((in1.eqv.in).and.(.not.cross))) then
4499 [ + + ]: 850 : if (in) then
4500 : 516 : rr2=rr1
4501 : 516 : rr1=rr
4502 : 516 : rr=rr+dr
4503 : : else
4504 : 334 : rr2=rr1
4505 : 334 : rr1=rr
4506 : 334 : rr=rr-dr
4507 : : end if
4508 [ + + + + ]: 850 : if ((jj>2).and.(dr<(0.6))) then
4509 : : ! modification of the step
4510 : 606 : dr=dr*aim_fac
4511 [ + - ]: 606 : if (deb_tmp) write(std_out,*) ':DR ',dr
4512 : : end if
4513 : : else
4514 [ + + ]: 1781 : if (.not.cross) then
4515 : 130 : cross=.true.
4516 : 130 : rr2=rr1
4517 : : else
4518 [ + + ]: 1651 : if (in2) then
4519 [ + + ]: 887 : if (in) then
4520 : 387 : rr2=rr1
4521 : : else
4522 : : in1=in2
4523 : : end if
4524 : : else
4525 [ + + ]: 764 : if (in) then
4526 : : in1=in2
4527 : : else
4528 : 368 : rr2=rr1
4529 : : end if
4530 : : end if
4531 : : end if
4532 : 1781 : rr1=rr
4533 : 1781 : rr=(rr2+rr1)/2.0
4534 : : end if
4535 : :
4536 : 2631 : in2=in1
4537 : 2631 : in1=in
4538 : 2631 : drr=abs(rr2-rr1)/rr
4539 [ + - ]: 2761 : if (deb_tmp) write(std_out,*) ':DRR ',jj,rr2,rr1,drr
4540 : : end do
4541 : :
4542 : 130 : end subroutine rsurf
4543 : : !!***
4544 : :
4545 : : !!****f* m_bader/surf
4546 : : !! NAME
4547 : : !! surf
4548 : : !!
4549 : : !! FUNCTION
4550 : : !! Determination of the Bader surface.
4551 : : !! Use rsurf to determine radius for one direction
4552 : : !! simple bisection method is used
4553 : : !! the bassin is tested following the gradient (follow) =
4554 : : !! = the most time consuming
4555 : : !! follow stops if the gradient line is near the atom
4556 : : !! or if it is under already known part of surface - this is why
4557 : : !! the surface is not computed row by row.
4558 : : !!
4559 : : !! INPUTS
4560 : : !! aim_dtset= the structured entity containing all input variables
4561 : : !!
4562 : : !! OUTPUT
4563 : : !! (see side effects)
4564 : : !!
4565 : : !! SIDE EFFECTS
4566 : : !! This routine works primarily on the data contained in the defs_aimprom module
4567 : : !!
4568 : : !! WARNING
4569 : : !! This file does not follow the ABINIT coding rules (yet)
4570 : : !!
4571 : : !! SOURCE
4572 : :
4573 : 5 : subroutine surf(aim_dtset)
4574 : :
4575 : : !Arguments ------------------------------------
4576 : : !scalars
4577 : : type(aim_dataset_type) :: aim_dtset
4578 : :
4579 : : !Local variables ------------------------------
4580 : : !scalars
4581 : : integer :: ierr,ii,ijj,ijj_exist,incr,init,iph,iph2,ith,ith2,jj,jj_exist,kk,level,me,mm,nn,nph,npmax,nproc,nth,comm
4582 : : real(dp) :: ct1,ct2,phi,rr,rsmax,rsmin,rthe,rthe0,t1,t2,theta,tt0,vcth,vph,vth
4583 : : real(dp) :: wall,xy,xyz
4584 : : logical :: srch,stemp
4585 : : !arrays
4586 : : real(dp) :: grho(3),vr(3),vv(3)
4587 : 5 : real(dp),allocatable :: rs_computed(:,:)
4588 : :
4589 : : !************************************************************************
4590 : :
4591 : 5 : comm = xmpi_world
4592 : 5 : me=xmpi_comm_rank(comm)
4593 : 5 : nproc=xmpi_comm_size(comm)
4594 : :
4595 : 5 : ttsrf=zero
4596 : :
4597 : 5 : rewind(unts)
4598 : :
4599 : 5 : nth=aim_dtset%nth
4600 : 5 : nph=aim_dtset%nph
4601 : :
4602 : : !Coefficients for spherical Gauss quadrature
4603 : :
4604 : 5 : ct1=cos(aim_dtset%themin)
4605 : 5 : ct2=cos(aim_dtset%themax)
4606 : 5 : call coeffs_gausslegint(ct1,ct2,cth,wcth,nth)
4607 : 5 : call coeffs_gausslegint(aim_dtset%phimin,aim_dtset%phimax,ph,wph,nph)
4608 : :
4609 : : !DEBUG
4610 : : !write(std_out,*)' surf : wcth=',wcth(1:nth)
4611 : : !write(std_out,*)' surf : wph=',wph(1:nth)
4612 : : !ENDDEBUG
4613 : :
4614 [ + + ]: 35 : do ijj=1,nth
4615 : 30 : th(ijj)=acos(cth(ijj))
4616 [ + - ]: 35 : if (aim_dtset%isurf/=-1) then
4617 [ + + ]: 160 : do jj=1,nph
4618 : 160 : rs(ijj,jj)=zero
4619 : : end do
4620 : : end if
4621 : : end do
4622 : :
4623 : 5 : npmax=aim_npmaxin
4624 : 5 : rsmax=0.0
4625 : 5 : rsmin=100.0
4626 : 5 : rthe0=r0
4627 : 5 : srch=.false.
4628 : :
4629 [ + + ]: 20 : do ijj=1,3
4630 : 20 : vv(ijj)=xatm(ijj,aim_dtset%batom)
4631 : : end do
4632 : :
4633 : :
4634 : 5 : write(std_out,*)
4635 : 5 : write(std_out,*) "BADER SURFACE DETERMINATION"
4636 : 5 : write(std_out,*) "==========================="
4637 : 5 : write(std_out,*)
4638 : :
4639 : 5 : write(untout,*)
4640 : 5 : write(untout,*) "BADER SURFACE DETERMINATION"
4641 : 5 : write(untout,*) "==========================="
4642 : 5 : write(untout,*)
4643 : :
4644 : 5 : write(std_out,'(" Atom: ",i3,3F15.10)') aim_dtset%batom,vv
4645 : 5 : write(std_out,'(" Theta: ",i3,2F15.10)') nth,aim_dtset%themin,aim_dtset%themax
4646 : 5 : write(std_out,'(" Phi: ",i3,2F15.10)') nph,aim_dtset%phimin,aim_dtset%phimax
4647 : :
4648 : 5 : write(untout,'(" Atom: ",i3,3F15.10)') aim_dtset%batom,vv
4649 : 5 : write(untout,'(" Theta: ",i3,2F15.10)') nth,aim_dtset%themin,aim_dtset%themax
4650 : 5 : write(untout,'(" Phi: ",i3,2F15.10)') nph,aim_dtset%phimin,aim_dtset%phimax
4651 : :
4652 : 5 : write(unts,'(i3,3F15.10)') aim_dtset%batom,vv
4653 : 5 : write(unts,'(i3,2F15.10)') nth,aim_dtset%themin,aim_dtset%themax
4654 : 5 : write(unts,'(i3,2F15.10)') nph,aim_dtset%phimin,aim_dtset%phimax
4655 : :
4656 : : !write(std_out,*) 'npmax in surf= ',npmax
4657 : :
4658 : 5 : ith=0
4659 : 5 : iph=0
4660 : : tt0=0._dp
4661 : 5 : call timein(tt0,wall)
4662 : :
4663 : 5 : write(untout,*)
4664 : 5 : write(untout,*) "DEVELOPMENT OF THE RADII DETERMINATIONS"
4665 : 5 : write(untout,*) "========================================"
4666 : 5 : write(untout,*)
4667 : 5 : write(untout,*) "Determination near the CPs:"
4668 : :
4669 : : !Determination of the CP neighbouring radii
4670 : :
4671 [ + - ]: 5 : if (aim_dtset%isurf/=-1) then
4672 : :
4673 : : ! Precomputation of the value of the radii (for parallelisation)
4674 : : ! To make the output independent of the number of processors, but still
4675 : : ! cut down the CPU time, use a multigrid technique
4676 : 5 : srch=.true.
4677 [ - + + - : 20 : ABI_MALLOC(rs_computed,(nth,nph))
- + + - +
- + - - +
- + ]
4678 : 5 : rs(:,:)=zero
4679 [ + + + + ]: 157 : rs_computed(:,:)=zero
4680 : 5 : kk=0 ; init=0
4681 [ + + ]: 25 : do level=3,0,-1
4682 : 20 : incr=2**level
4683 [ + + + + ]: 25 : if(incr<nth .and. incr<nph)then
4684 [ + + + + ]: 376 : rs_computed(:,:)=rs(1:nth,1:nph)
4685 [ + + + + ]: 376 : rs(1:nth,1:nph)=zero
4686 [ - + + + ]: 62 : do ijj=1,nth,incr
4687 [ - + + + ]: 238 : do jj=1,nph,incr
4688 [ + + ]: 226 : if(rs_computed(ijj,jj)<1.0d-12) then
4689 : 130 : kk=kk+1
4690 [ + - ]: 130 : if(mod(kk,nproc)==me)then
4691 : : ! Find an approximate starting radius, from the already computed ones
4692 [ + + ]: 130 : if(init==0)then
4693 : 28 : rthe=r0
4694 : : else
4695 [ + + ]: 102 : ijj_exist=ijj ; if(mod(ijj-1,2*incr)>=incr)ijj_exist=ijj-incr
4696 [ + + ]: 102 : jj_exist=jj ; if(mod(jj-1,2*incr)>=incr)jj_exist=jj-incr
4697 : 102 : rthe=rs_computed(ijj_exist,jj_exist)
4698 [ - + ]: 102 : if(rthe<1.0d-12)then
4699 : 0 : write(std_out,*)' surf : there is a bug ! rthe=',rthe
4700 : 0 : ABI_ERROR("Aborting now")
4701 : : end if
4702 : : end if
4703 : 130 : call timein(t1,wall) ; t2=zero
4704 : 130 : call rsurf(aim_dtset,rr,grho,th(ijj),ph(jj),rthe,aim_dtset%batom,npmax,srch)
4705 : 130 : rs(ijj,jj)=rr
4706 [ - + ]: 130 : if (deb) then
4707 : 0 : call timein(t2,wall) ; t2=t2-t1
4708 : 0 : write(std_out,*) ':CALCULATED NP',ijj,jj,th(ijj),ph(jj),rthe,npmax,rs(ijj,jj),t2
4709 : : end if
4710 : : end if
4711 : : end if
4712 : : end do ! jj
4713 : : end do ! ijj
4714 : 12 : call xmpi_sum(rs,comm,ierr)
4715 : : ! Combine the set of already computed radii and the set of the newly computed, to obtain all computed.
4716 [ + + + + ]: 376 : rs(1:nth,1:nph)=rs(1:nth,1:nph)+rs_computed(:,:)
4717 : : init=1
4718 : : end if
4719 : : end do
4720 [ - + ]: 5 : ABI_FREE(rs_computed)
4721 : :
4722 : 5 : srch=.true.
4723 : :
4724 [ + + ]: 39 : do ijj=1,nbcp
4725 : : ! if ((icpc(ijj) == -1)) then
4726 : 34 : rthe0=vnorm(pc(:,ijj),0)
4727 [ + + ]: 136 : do jj=1,3
4728 : 136 : vr(jj)=pc(jj,ijj)-vv(jj)+xatm(jj,aim_dtset%batom)
4729 : : end do
4730 : 34 : xy=vr(1)*vr(1)+vr(2)*vr(2)
4731 : 34 : xyz=xy+vr(3)*vr(3)
4732 : 34 : xyz=sqrt(xyz)
4733 : :
4734 [ + + ]: 34 : if (xy < aim_xymin) then
4735 : 4 : vcth=1._dp
4736 [ + + ]: 4 : if (vr(3) < 0._dp) vcth=-vcth
4737 : 4 : vph=0._dp
4738 : : else
4739 : 30 : vcth=vr(3)/xyz
4740 : 30 : vph=atan2(vr(2),vr(1))
4741 : : end if
4742 : :
4743 : 34 : vth=acos(vcth)
4744 : 34 : write(untout,'(/," BCP: (index,theta,phi)",I4,2E16.8)') ijj,vth,vph
4745 : :
4746 [ + + ]: 34 : if (vth < th(1)) then
4747 : : ith=0
4748 : : else
4749 [ + + ]: 30 : if (vth > th(nth)) then
4750 : : ith=nth
4751 : : else
4752 [ + - ]: 28 : do ii=2,nth
4753 [ + + ]: 28 : if (vth < th(ii)) then
4754 : 10 : ith=ii-1
4755 : 10 : exit
4756 : : end if
4757 : : end do
4758 : : end if
4759 : : end if
4760 : :
4761 [ + + ]: 34 : if (vph < ph(1)) then
4762 : : iph=0
4763 : : else
4764 [ + + ]: 15 : if (vph > ph(nph)) then
4765 : : iph=nph
4766 : : else
4767 [ + - ]: 8 : do ii=2,nph
4768 [ + + ]: 8 : if (vph < ph(ii)) then
4769 : 4 : iph=ii-1
4770 : 4 : exit
4771 : : end if
4772 : : end do
4773 : : end if
4774 : : end if
4775 : :
4776 : 34 : write(untout,*) "ATOMIC RADII (ith,iph,theta,phi,radius)"
4777 [ + + ]: 175 : do jj=-1,2
4778 [ + + ]: 714 : do kk=-1,2
4779 : 544 : ith2=ith+jj
4780 : 544 : iph2=iph+kk
4781 [ + + + + ]: 544 : stemp=(iph2 > 0).and.(iph2 < nph+1)
4782 [ + + + + ]: 736 : stemp=(stemp.and.((ith2 > 0).and.(ith2 < nth+1)))
4783 : 136 : if (stemp) then
4784 : 192 : theta=th(ith2)
4785 : 192 : phi=ph(iph2)
4786 [ - + ]: 192 : if (abs(rs(ith2,iph2))<1.0d-12) then
4787 : 0 : rthe=rthe0
4788 [ # # ]: 0 : if (deb) write(std_out,*) ':CALCULATING NP',theta,phi,rthe,npmax
4789 : 0 : call timein(t1,wall)
4790 : 0 : call rsurf(aim_dtset,rr,grho,theta,phi,rthe,aim_dtset%batom,npmax,srch)
4791 : 0 : call timein(t2,wall)
4792 : 0 : t2=t2-t1
4793 : 0 : rs(ith2,iph2)=rr
4794 : : end if
4795 : 192 : rr=rs(ith2,iph2)
4796 : : ! write(unts,'(2F12.8,2E16.8)') theta,phi,rr,wcth(ijj)*wph(jj)
4797 : 192 : write(std_out,'(":RSUR PC ",3i3,4E16.8,F10.4)') ijj,jj,kk,theta,phi,rr,wcth(ith2)*wph(iph2),t2
4798 : 192 : write(untout,'(a,2i3,3E16.8)') '- ',jj,kk,theta,phi,rr
4799 : 192 : rthe0=rr
4800 : : end if
4801 : :
4802 : : end do ! kk
4803 : : end do ! jj
4804 : :
4805 : : ! end if
4806 : :
4807 : : end do ! ijj (loop on BCP)
4808 : :
4809 : : ! DEBUG
4810 : : ! write(std_out,*)' surf : near BCP '
4811 : : ! do ijj=1,nth
4812 : : ! do jj=1,nph
4813 : : ! write(std_out,*)ijj,jj,rs(ijj,jj)
4814 : : ! end do
4815 : : ! end do
4816 : : ! ENDDEBUG
4817 : :
4818 : :
4819 : 5 : srch=.true.
4820 [ + + ]: 57 : do ijj=nbcp+1,nbcp+nrcp ! Loop on RCP
4821 : : ! if ((icpc(ijj) == 1)) then
4822 : 52 : rthe0=max(rminl(aim_dtset%batom),r0)
4823 [ + + ]: 208 : do jj=1,3
4824 : 208 : vr(jj)=pc(jj,ijj)-vv(jj)+xatm(jj,aim_dtset%batom)
4825 : : end do
4826 : 52 : xy=vr(1)*vr(1)+vr(2)*vr(2)
4827 : 52 : xyz=xy+vr(3)*vr(3)
4828 : 52 : xyz=sqrt(xyz)
4829 : :
4830 [ - + ]: 52 : if (xy < aim_xymin) then
4831 : 0 : vcth=1._dp
4832 [ # # ]: 0 : if (vr(3) < 0._dp) vcth=-vcth
4833 : 0 : vph=0._dp
4834 : : else
4835 : 52 : vcth=vr(3)/xyz
4836 : 52 : vph=atan2(vr(2),vr(1))
4837 : : end if
4838 : 52 : vth=acos(vcth)
4839 : 52 : write(untout,'(/,";RCP: (index,theta,phi)",I4,2E16.8)') ijj-nbcp,vth,vph
4840 : :
4841 [ + - ]: 52 : if (vth < th(1)) then
4842 : : ith=0
4843 : : else
4844 [ + + ]: 52 : if (vth > th(nth)) then
4845 : : ith=nth
4846 : : else
4847 [ + - ]: 84 : do ii=2,nth
4848 [ + + ]: 84 : if (vth < th(ii)) then
4849 : 28 : ith=ii-1
4850 : 28 : exit
4851 : : end if
4852 : : end do
4853 : : end if
4854 : : end if
4855 : :
4856 [ + + ]: 52 : if (vph < ph(1)) then
4857 : : iph=0
4858 : : else
4859 [ + + ]: 25 : if (vph > ph(nph)) then
4860 : : iph=nph
4861 : : else
4862 [ + - ]: 18 : do ii=2,nph
4863 [ + + ]: 18 : if (vph < ph(ii)) then
4864 : 8 : iph=ii-1
4865 : 8 : exit
4866 : : end if
4867 : : end do
4868 : : end if
4869 : : end if
4870 : :
4871 : 52 : write(untout,*) "ATOMIC RADIUS (ith,iph,theta,phi,radius)"
4872 [ + + ]: 265 : do jj=-1,2
4873 [ + + ]: 1092 : do kk=-1,2
4874 : 832 : ith2=ith+jj
4875 : 832 : iph2=iph+kk
4876 [ + + + + ]: 832 : stemp=(iph2 > 0).and.(iph2 < nph+1)
4877 [ + + + + ]: 1176 : stemp=stemp.and.(ith2 > 0).and.(ith2 < nth+1)
4878 : :
4879 : 208 : if (stemp) then
4880 : 344 : theta=th(ith2)
4881 : 344 : phi=ph(iph2)
4882 [ - + ]: 344 : if ((abs(rs(ith2,iph2))<1.0d-12)) then
4883 : 0 : rthe=rthe0
4884 [ # # ]: 0 : if (deb) write(std_out,*) ':CALCULATING NP',theta,phi,rthe,npmax
4885 : 0 : call timein(t1,wall)
4886 : 0 : call rsurf(aim_dtset,rr,grho,theta,phi,rthe,aim_dtset%batom,npmax,srch)
4887 : 0 : call timein(t2,wall)
4888 : 0 : t2=t2-t1
4889 : 0 : rs(ith2,iph2)=rr
4890 : : end if
4891 : 344 : rr=rs(ith2,iph2)
4892 : : ! write(unts,'(2F12.8,2E16.8)') theta,phi,rr,wcth(ijj)*wph(jj)
4893 : 344 : write(std_out,'(":RSUR PC ",3i3,4E16.8,F10.4)') ijj,jj,kk,theta,phi,rr,wcth(ith2)*wph(iph2),t2
4894 : 344 : write(untout,'(a,2i3,3E16.8)') '- ',jj,kk,theta,phi,rr
4895 : 344 : rthe0=rr
4896 : : end if
4897 : :
4898 : : end do ! kk
4899 : : end do ! jj
4900 : : ! end if
4901 : :
4902 : : end do ! ijj (Loop on RCP)
4903 : :
4904 : : ! DEBUG
4905 : : ! write(std_out,*)' surf : near RCP '
4906 : : ! do ijj=1,nth
4907 : : ! do jj=1,nph
4908 : : ! write(std_out,*)ijj,jj,rs(ijj,jj)
4909 : : ! end do
4910 : : ! end do
4911 : : ! ENDDEBUG
4912 : :
4913 : : ! Boundary angles
4914 : 5 : rthe0=r0
4915 : 5 : srch=.true.
4916 : 5 : write(untout,*)
4917 : 5 : write(untout,*) "The boundary angles:"
4918 : 5 : write(untout,*) "===================="
4919 : 5 : write(untout,*) "ATOMIC RADIUS (ith,iph,theta,phi,radius)"
4920 : :
4921 : : ! Must have sufficient angular sampling
4922 [ - + - - ]: 5 : if ((nth > 8).and.(nph > 8)) then
4923 : 0 : rthe=r0
4924 [ # # ]: 0 : do ijj=1,2
4925 : 0 : theta=th(ijj)
4926 [ # # ]: 0 : if (ijj==2) rthe=rs(1,1)
4927 [ # # ]: 0 : do jj=1,nph
4928 : 0 : phi=ph(jj)
4929 : 0 : call timein(t1,wall)
4930 [ # # ]: 0 : if (abs(rs(ijj,jj))<1.0d-12) then
4931 [ # # ]: 0 : if (deb) write(std_out,*) ':CALC NP',theta,phi,rthe,npmax
4932 : 0 : call rsurf(aim_dtset,rr,grho,theta,phi,rthe,aim_dtset%batom,npmax,srch)
4933 : 0 : rs(ijj,jj)=rr
4934 : : end if
4935 : 0 : rr=rs(ijj,jj)
4936 : 0 : call timein(t2,wall)
4937 : 0 : t2=t2-t1
4938 : 0 : write(std_out,'(":RSUR ",2F12.8,2E16.8,F10.4)') theta,phi,rr,wcth(ijj)*wph(jj),t2
4939 : 0 : write(untout,'(a,2i3,3E16.8)') '- ',ijj,jj,theta,phi,rr
4940 : 0 : rthe=rs(ijj,jj)
4941 : : end do ! jj
4942 : : end do ! ijj
4943 : :
4944 : 0 : write(untout,*)
4945 : :
4946 : 0 : rthe=rs(2,1)
4947 [ # # ]: 0 : do jj=1,2
4948 : 0 : phi=ph(jj)
4949 [ # # ]: 0 : if (jj==2) rthe=rs(2,2)
4950 [ # # ]: 0 : do ijj=3,nth
4951 : 0 : theta=th(ijj)
4952 : 0 : t2=0.0
4953 : 0 : call timein(t1,wall)
4954 [ # # ]: 0 : if (abs(rs(ijj,jj))<1.0d-12) then
4955 [ # # ]: 0 : if (deb) write(std_out,*) ':CALC NP',theta,phi,rthe,npmax
4956 : 0 : call rsurf(aim_dtset,rr,grho,theta,phi,rthe,aim_dtset%batom,npmax,srch)
4957 : 0 : rs(ijj,jj)=rr
4958 : : end if
4959 : 0 : rr=rs(ijj,jj)
4960 : 0 : call timein(t2,wall)
4961 : 0 : t2=t2-t1
4962 : 0 : write(std_out,'(":RSUR ",2F12.8,2E16.8,F10.4)') theta,phi,rr,wcth(ijj)*wph(jj),t2
4963 : 0 : write(untout,'(2i3,3E16.8)') ijj,jj,theta,phi,rr
4964 : 0 : rthe=rs(ijj,jj)
4965 : : end do ! ijj
4966 : : end do ! jj
4967 : :
4968 : 0 : write(untout,*)
4969 : :
4970 : 0 : rthe=rs(nth-1,2)
4971 [ # # ]: 0 : do ijj=nth-1,nth
4972 : 0 : theta=th(ijj)
4973 [ # # ]: 0 : if (ijj==nth) rthe=rs(nth,2)
4974 [ # # ]: 0 : do jj=3,nph
4975 : 0 : phi=ph(jj)
4976 : 0 : call timein(t1,wall)
4977 [ # # ]: 0 : if (abs(rs(ijj,jj))<1.0d-12) then
4978 [ # # ]: 0 : if (deb) write(std_out,*) ':CALC NP',theta,phi,rthe,npmax
4979 : 0 : call rsurf(aim_dtset,rr,grho,theta,phi,rthe,aim_dtset%batom,npmax,srch)
4980 : 0 : rs(ijj,jj)=rr
4981 : : end if
4982 : 0 : rr=rs(ijj,jj)
4983 : 0 : call timein(t2,wall)
4984 : 0 : t2=t2-t1
4985 : 0 : write(std_out,'(":RSUR ",2F12.8,2E16.8,F10.4)') theta,phi,rr,wcth(ijj)*wph(jj),t2
4986 : 0 : write(untout,'(2i3,3E16.8)') ijj,jj,theta,phi,rr
4987 : 0 : rthe=rs(ijj,jj)
4988 : : end do ! jj
4989 : : end do ! ijj
4990 : :
4991 : 0 : rthe=rs(2,nph-1)
4992 [ # # ]: 0 : do jj=nph-1,nph
4993 : 0 : phi=ph(jj)
4994 [ # # ]: 0 : if (jj==nph) rthe=rs(2,nph)
4995 [ # # ]: 0 : do ijj=3,nth-2
4996 : 0 : theta=th(ijj)
4997 : 0 : t2=0.0
4998 : 0 : call timein(t1,wall)
4999 [ # # ]: 0 : if (abs(rs(ijj,jj))<1.0d-12) then
5000 [ # # ]: 0 : if (deb) write(std_out,*) ':CALC NP',theta,phi,rthe,npmax
5001 : 0 : call rsurf(aim_dtset,rr,grho,theta,phi,rthe,aim_dtset%batom,npmax,srch)
5002 : 0 : rs(ijj,jj)=rr
5003 : : end if
5004 : 0 : rr=rs(ijj,jj)
5005 : 0 : call timein(t2,wall)
5006 : 0 : t2=t2-t1
5007 : 0 : write(std_out,'(":RSUR ",2F12.8,2E16.8,F10.4)') theta,phi,rr,wcth(ijj)*wph(jj),t2
5008 : 0 : write(untout,'(2i3,3E16.8)') ijj,jj,theta,phi,rr
5009 : 0 : rthe=rs(ijj,jj)
5010 : : end do ! ijj
5011 : : end do ! jj
5012 : 0 : write(untout,*)
5013 : :
5014 : : ! Complementary bands for boundary angles
5015 : 0 : nn=int(real(nth)/1.4d1)
5016 [ # # ]: 0 : if (nn > 1) then
5017 [ # # ]: 0 : do ii=1,nn-1
5018 : 0 : mm=int(nth/nn)*ii
5019 [ # # ]: 0 : do kk=0,1
5020 : 0 : mm=mm+kk
5021 : 0 : theta=th(mm)
5022 : 0 : rthe=rs(mm,2)
5023 [ # # ]: 0 : do jj=3,nph-2
5024 : 0 : phi=ph(jj)
5025 : 0 : call timein(t1,wall)
5026 [ # # ]: 0 : if (abs(rs(mm,jj))<1.0d-12) then
5027 [ # # ]: 0 : if (deb) write(std_out,*) ':CALC NP',theta,phi,rthe,npmax
5028 : 0 : call rsurf(aim_dtset,rr,grho,theta,phi,rthe,aim_dtset%batom,npmax,srch)
5029 : 0 : rs(mm,jj)=rr
5030 : : end if
5031 : 0 : rr=rs(mm,jj)
5032 : 0 : call timein(t2,wall)
5033 : 0 : t2=t2-t1
5034 : 0 : write(std_out,'(":RSUR ",2F12.8,2E16.8,F10.4)') theta,phi,rr,wcth(mm)*wph(jj),t2
5035 : 0 : write(untout,'(2i3,3E16.8)') mm,jj,theta,phi,rr
5036 : 0 : rthe=rs(mm,jj)
5037 : : end do ! jj
5038 : : end do ! kk
5039 : : end do ! ii
5040 : : end if ! nn>1
5041 : :
5042 : 0 : write(untout,*)
5043 : :
5044 : 0 : nn=nint(real(nph)/1.2d1)
5045 [ # # ]: 0 : if (nn > 1) then
5046 [ # # ]: 0 : do ii=1,nn-1
5047 : 0 : mm=int(nph/nn)*ii
5048 [ # # ]: 0 : do kk=0,1
5049 : 0 : mm=mm+kk
5050 : 0 : phi=ph(mm)
5051 : 0 : rthe=rs(2,mm)
5052 : :
5053 [ # # ]: 0 : do jj=3,nth-2
5054 : 0 : theta=th(jj)
5055 : 0 : call timein(t1,wall)
5056 [ # # ]: 0 : if (abs(rs(jj,mm))<1.0d-12) then
5057 [ # # ]: 0 : if (deb) write(std_out,*) ':CALC NP',theta,phi,rthe,npmax
5058 : 0 : call rsurf(aim_dtset,rr,grho,theta,phi,rthe,aim_dtset%batom,npmax,srch)
5059 : 0 : rs(jj,mm)=rr
5060 : : end if
5061 : 0 : rr=rs(mm,jj)
5062 : 0 : call timein(t2,wall)
5063 : 0 : t2=t2-t1
5064 : 0 : write(std_out,'(":RSUR ",2F12.8,2E16.8,F10.4)') theta,phi,rr,wcth(jj)*wph(mm),t2
5065 : 0 : write(untout,'(2i3,3E16.8)') jj,mm,theta,phi,rr
5066 : 0 : rthe=rs(jj,mm)
5067 : : end do ! jj
5068 : :
5069 : : end do ! kk
5070 : : end do ! ii
5071 : : end if ! nn>1
5072 : :
5073 : : end if ! sufficient sampling to determine boundary angles
5074 : :
5075 : 5 : write(untout,*)
5076 : :
5077 : : ! DEBUG
5078 : : ! write(std_out,*)' surf : after boundary angles '
5079 : : ! do ijj=1,nth
5080 : : ! do jj=1,nph
5081 : : ! write(std_out,*)ijj,jj,rs(ijj,jj)
5082 : : ! end do
5083 : : ! end do
5084 : : ! ENDDEBUG
5085 : :
5086 : : ! Output the complete Bader surface
5087 : :
5088 : 5 : write(untout,*) "The complete Bader surface:"
5089 : 5 : write(untout,*) "==========================="
5090 : 5 : write(untout,*) "ATOMIC RADIUS (ith,iph,theta,phi,radius)"
5091 : 5 : rthe0=r0
5092 : 5 : srch=.true.
5093 : :
5094 : : ! Write all the values
5095 : :
5096 [ + + ]: 35 : do ijj=1,nth
5097 : 30 : theta=th(ijj)
5098 [ + + ]: 165 : do jj=1,nph
5099 : 130 : phi=ph(jj)
5100 : 130 : rr=rs(ijj,jj)
5101 : 130 : write(unts,'(2F12.8,2E16.8)') theta,phi,rr,wcth(ijj)*wph(jj)
5102 : 130 : write(std_out,'(":RSUR ",2F12.8,2E16.8,F10.4)') theta,phi,rr,wcth(ijj)*wph(jj),t2
5103 : 130 : write(untout,'(a,2i3,3E16.8)') ' ',ijj,jj,theta,phi,rr
5104 [ + + ]: 130 : if (rr < rsmin) rsmin=rr
5105 [ + + ]: 160 : if (rr> rsmax) rsmax=rr
5106 : : end do ! jj
5107 : : end do ! ijj
5108 : 5 : write(unts,'(2F15.10)') rsmin,rsmax
5109 : 5 : write(untout,'(/," The minimal and maximal radii:",/,/," ",2F15.10)') rsmin,rsmax
5110 : :
5111 : : ! DEBUG
5112 : : ! write(std_out,*)' surf : final output '
5113 : : ! do ijj=1,nth
5114 : : ! do jj=1,nph
5115 : : ! write(std_out,*)ijj,jj,rs(ijj,jj)
5116 : : ! end do
5117 : : ! end do
5118 : : ! ENDDEBUG
5119 : :
5120 : : end if ! determination of the critical surface
5121 : :
5122 : 5 : call timein(ttsrf,wall)
5123 : 5 : ttsrf=ttsrf-tt0
5124 : :
5125 : 5 : end subroutine surf
5126 : : !!***
5127 : :
5128 : : !!****f* m_bader/vgh_rho
5129 : : !! NAME
5130 : : !! vgh_rho
5131 : : !!
5132 : : !! FUNCTION
5133 : : !! The general procedure to obtain the value, the gradient and the hessian
5134 : : !! of the density of electrons in the point vv (in cart.coord).
5135 : : !!
5136 : : !! WARNING
5137 : : !! This file does not follow the ABINIT coding rules (yet)
5138 : : !!
5139 : : !! INPUTS
5140 : : !! vv(3)=position
5141 : : !! chs 1 only valence density
5142 : : !! 2 only core density
5143 : : !! 0 total density
5144 : : !! -2 iat, ipos are nulify and ignored
5145 : : !! -1 iat,ipos = index of atom if vv is inside
5146 : : !! the "core sphere (rminl)", 0 otherwise
5147 : : !!
5148 : : !! OUTPUT
5149 : : !! rho,grho(3),hrho(3,3) - density, gradient of density, hessian of density
5150 : : !! (cart. coord)
5151 : : !! iat, ipos - index of the nearest atom (except chs < 0 see above)
5152 : : !! rdmin - the distance to the nearest atom
5153 : : !!
5154 : : !! SIDE EFFECTS
5155 : : !! This routine also works on the data contained in the defs_aimprom and defs_aimfields modules
5156 : : !!
5157 : : !! SOURCE
5158 : :
5159 : 3837661 : subroutine vgh_rho(vv,rho,grho,hrho,rdmin,iat,ipos,chs)
5160 : :
5161 : : !Arguments ------------------------------------
5162 : : !scalars
5163 : : integer,intent(in) :: chs
5164 : : integer,intent(inout) :: iat,ipos
5165 : : real(dp),intent(out) :: rdmin,rho
5166 : : !arrays
5167 : : real(dp),intent(in) :: vv(3)
5168 : : real(dp),intent(out) :: grho(3),hrho(3,3)
5169 : :
5170 : : !Local variables ------------------------------
5171 : : !scalars
5172 : : integer :: ii,inmax,inmin,inx,jj,kk,ll,nn,oii,omm,onn
5173 : : integer :: selct
5174 : : ! real(dp),save :: cumul_cpu=0.0_dp,cumul_cpu_old=0.0_dp
5175 : : real(dp),save :: tcpui,tcpuo,twalli
5176 : : real(dp),save :: twallo
5177 : : real(dp) :: aa,bb,cc,cgrad1_rr_inv,coeff,dd,rr,rr2,rr_inv
5178 : : real(dp) :: rrad2_nn,rrad_nn,ss,uu,uu_inv,val,vt1,vt2,vt3,vw1,vw2
5179 : : ! real(dp) :: ss_inv
5180 : : real(dp) :: vw3
5181 : : !arrays
5182 : : integer :: indx(3),inii(4,3)
5183 : : real(dp) :: cgrad(3),ches(3,3),cof(2,3),ddstar(6),ddu(2),grd(4)
5184 : : real(dp) :: hh(4,2),hrh(2),lder(4),pom2sq(2,3),pomsq(2,3)
5185 : : real(dp) :: rhstar(6),sqder(6,4),sqvlr(6,4),trsf(3,3),xx(3)
5186 : 3837661 : real(dp),pointer :: ptddx(:,:,:),ptddy(:,:,:),ptddz(:,:,:),ptrho(:,:,:)
5187 : :
5188 : : !************************************************************************
5189 : 3837661 : tcpui=0.0_dp
5190 : 3837661 : tcpuo=0.0_dp
5191 : 3837661 : twalli=0.0_dp
5192 : 3837661 : twallo=0.0_dp
5193 : :
5194 : 3837661 : nullify(ptddx,ptddy,ptddz,ptrho)
5195 : :
5196 : 3837661 : selct=chs
5197 : :
5198 : 3837661 : if (selct/=2) then
5199 : :
5200 : : ! call timein(tcpui,twalli)
5201 : :
5202 : : ! TRANSFORMATION TO THE REDUCED COORD.
5203 : :
5204 : 3837661 : xx(:)=vv(:)
5205 : 3837661 : call bschg1(xx,-1)
5206 : :
5207 : : ! call timein(tcpuo,twallo)
5208 : : ! cumul_cpu=cumul_cpu+(tcpuo-tcpui)
5209 : :
5210 : : ! REDUCTION TO THE PRIMITIVE CELL
5211 : :
5212 [ + + ]: 15350644 : do ii=1,3
5213 [ + + ]: 15350644 : if (xx(ii) >= one-tol12 ) then
5214 : 472338 : xx(ii)=xx(ii)-aint(xx(ii))
5215 [ + + ]: 11040645 : elseif (xx(ii) < -tol12 ) then
5216 [ + - ]: 1506735 : xx(ii)=xx(ii)-floor(xx(ii))
5217 : : end if
5218 : : end do
5219 : :
5220 : :
5221 : : ! DETERMINATION OF THE INDEX IN THE GRID
5222 : :
5223 [ + + ]: 15350644 : do ii=1,3
5224 : 11512983 : indx(ii)=aint(xx(ii)*ngfft(ii))
5225 : 11512983 : bb=(xx(ii)-indx(ii)*dix(ii))*ngfft(ii)
5226 [ - + ]: 11512983 : if (indx(ii)==ngfft(ii)) then
5227 : 0 : indx(ii)=1
5228 : 0 : xx(ii)=0._dp
5229 : : else
5230 : 11512983 : indx(ii)=indx(ii)+1
5231 : : end if
5232 : :
5233 : : ! Explicit handling to avoid numeric problems
5234 : :
5235 [ - + ]: 15350644 : if (bb > 1._dp+tol12 ) then
5236 : 0 : cof(1,ii)=0._dp
5237 : 0 : cof(2,ii)=1._dp
5238 [ + + ]: 11512983 : elseif (bb < -tol12 ) then
5239 : 222 : cof(1,ii)=1._dp
5240 : 222 : cof(2,ii)=0._dp
5241 : : else
5242 : 11512761 : cof(1,ii)=1._dp-bb
5243 : 11512761 : cof(2,ii)=bb
5244 : : end if
5245 : : end do
5246 : :
5247 : : ! 3D INTERPOLATION OF THE VALENCE DENSITY
5248 : :
5249 : : ! determination of the values of density and of its second derivative
5250 : : ! at the "star" = constructed at vv with primitive directions
5251 : : ! To interpolation the values at the faces of the grid cell are needed
5252 : :
5253 : 3837661 : rhstar(:)=0._dp
5254 : 3837661 : sqder(:,:)=0._dp
5255 : 3837661 : sqvlr(:,:)=0._dp
5256 : 3837661 : ddstar(:)=0._dp
5257 : 3837661 : pomsq(:,:)=0._dp
5258 : 3837661 : pom2sq(:,:)=0._dp
5259 : :
5260 : 3837661 : oii=1; onn=1; omm=1
5261 [ + + ]: 3837661 : if (indx(1)==ngfft(1)) oii=1-ngfft(1)
5262 [ + + ]: 3837661 : if (indx(2)==ngfft(2)) onn=1-ngfft(2)
5263 [ + + ]: 3837661 : if (indx(3)==ngfft(3)) omm=1-ngfft(3)
5264 : :
5265 : : ! the values in the corners of the grid cell
5266 : :
5267 : 3837661 : ptddx=>ddx(indx(1):indx(1)+oii:oii,indx(2):indx(2)+onn:onn,indx(3):indx(3)+omm:omm)
5268 : 3837661 : ptddy=>ddy(indx(1):indx(1)+oii:oii,indx(2):indx(2)+onn:onn,indx(3):indx(3)+omm:omm)
5269 : 3837661 : ptddz=>ddz(indx(1):indx(1)+oii:oii,indx(2):indx(2)+onn:onn,indx(3):indx(3)+omm:omm)
5270 : 3837661 : ptrho=>dvl(indx(1):indx(1)+oii:oii,indx(2):indx(2)+onn:onn,indx(3):indx(3)+omm:omm)
5271 : :
5272 : : ! the coefficients for spline interpolation of density and its derivation
5273 [ + + ]: 15350644 : do ii=1,3
5274 [ + + ]: 38376610 : do jj=1,2
5275 : 23025966 : pomsq(jj,ii)=(cof(jj,ii)*cof(jj,ii)*cof(jj,ii)-cof(jj,ii))/6._dp*dix(ii)*dix(ii)
5276 : 23025966 : pom2sq(jj,ii)=(3._dp*cof(jj,ii)*cof(jj,ii)-1._dp)/6._dp*dix(ii)
5277 [ + + ]: 34538949 : if (jj==1) pom2sq(jj,ii)=-pom2sq(jj,ii)
5278 : : end do
5279 : : end do
5280 : :
5281 : :
5282 [ + + ]: 11512983 : do ii=1,2
5283 [ + + ]: 26863627 : do jj=1,2
5284 [ + + ]: 53727254 : do kk=1,2
5285 : 30701288 : ddstar(ii)=ddstar(ii)+cof(jj,2)*cof(kk,3)*ptddx(ii,jj,kk)
5286 : 30701288 : ddstar(ii+2)=ddstar(ii+2)+cof(jj,3)*cof(kk,1)*ptddy(kk,ii,jj)
5287 : 30701288 : ddstar(ii+4)=ddstar(ii+4)+cof(jj,1)*cof(kk,2)*ptddz(jj,kk,ii)
5288 : 30701288 : sqder(ii,jj)=sqder(ii,jj)+cof(kk,2)*ptddz(ii,kk,jj)
5289 : 30701288 : sqder(ii,jj+2)=sqder(ii,jj+2)+cof(kk,3)*ptddy(ii,jj,kk)
5290 : 30701288 : sqder(ii+2,jj)=sqder(ii+2,jj)+cof(kk,3)*ptddx(jj,ii,kk)
5291 : 30701288 : sqder(ii+2,jj+2)=sqder(ii+2,jj+2)+cof(kk,1)*ptddz(kk,ii,jj)
5292 : 30701288 : sqder(ii+4,jj)=sqder(ii+4,jj)+cof(kk,1)*ptddy(kk,jj,ii)
5293 : 30701288 : sqder(ii+4,jj+2)=sqder(ii+4,jj+2)+cof(kk,2)*ptddx(jj,kk,ii)
5294 : 30701288 : sqvlr(ii,jj)=sqvlr(ii,jj)+cof(kk,2)*ptrho(ii,kk,jj)+pomsq(kk,2)*ptddy(ii,kk,jj)
5295 : 30701288 : sqvlr(ii,jj+2)=sqvlr(ii,jj+2)+cof(kk,3)*ptrho(ii,jj,kk)+pomsq(kk,3)*ptddz(ii,jj,kk)
5296 : 46051932 : sqvlr(ii+2,jj+2)=sqvlr(ii+2,jj+2)+cof(kk,1)*ptrho(kk,ii,jj)+pomsq(kk,1)*ptddx(kk,ii,jj)
5297 : : end do
5298 : : end do
5299 : : end do
5300 : :
5301 [ + + ]: 11512983 : do ii=1,2
5302 [ + + ]: 26863627 : do jj=1,2
5303 : 15350644 : sqvlr(ii+2,jj)=sqvlr(jj,ii+2)
5304 : 15350644 : sqvlr(ii+4,jj)=sqvlr(jj+2,ii+2)
5305 : 23025966 : sqvlr(ii+4,jj+2)=sqvlr(jj,ii)
5306 : : end do
5307 : : end do
5308 : :
5309 [ + + ]: 11512983 : do ii=1,2
5310 [ + + ]: 26863627 : do jj=1,2
5311 : : rhstar(ii)=rhstar(ii)+cof(jj,3)*sqvlr(ii,jj)+pomsq(jj,3)*sqder(ii,jj)+&
5312 : 15350644 : & cof(jj,2)*sqvlr(ii,jj+2)+pomsq(jj,2)*sqder(ii,jj+2)
5313 : : rhstar(ii+2)=rhstar(ii+2)+cof(jj,1)*sqvlr(ii+2,jj)+pomsq(jj,1)*sqder(ii+2,jj)+&
5314 : 15350644 : & cof(jj,3)*sqvlr(ii+2,jj+2)+pomsq(jj,3)*sqder(ii+2,jj+2)
5315 : : rhstar(ii+4)=rhstar(ii+4)+cof(jj,2)*sqvlr(ii+4,jj)+pomsq(jj,2)*sqder(ii+4,jj)+&
5316 : 23025966 : & cof(jj,1)*sqvlr(ii+4,jj+2)+pomsq(jj,1)*sqder(ii+4,jj+2)
5317 : : end do
5318 : : end do
5319 [ + + ]: 26863627 : rhstar(:)=rhstar(:)/2._dp
5320 : :
5321 : 3837661 : rho=0._dp
5322 : 3837661 : grho(:)=0._dp
5323 : 3837661 : hrho(:,:)=0._dp
5324 : 3837661 : kk=1; nn=1
5325 : 3837661 : do ii=1,5,2
5326 [ + + ]: 34538949 : do jj=1,2
5327 : 23025966 : nn=-nn
5328 : 23025966 : rho=rho+cof(jj,kk)*rhstar(ii+jj-1)+pomsq(jj,kk)*ddstar(ii+jj-1)
5329 : 23025966 : grho(kk)=grho(kk)+pom2sq(jj,kk)*ddstar(ii+jj-1)
5330 : 23025966 : hrho(kk,kk)=hrho(kk,kk)+cof(jj,kk)*ddstar(ii+jj-1)
5331 : 34538949 : grho(kk)=grho(kk)+nn*rhstar(ii+jj-1)/dix(kk)
5332 : : end do
5333 [ + + ]: 11512983 : kk=kk+1
5334 : : end do
5335 : 3837661 : rho=rho/3._dp
5336 : :
5337 : : ! Off-diagonal elements of the hessian
5338 : :
5339 : : ! for the speed reasons the polynomial interpolation
5340 : : ! for second derivation fields is used in this case
5341 : : ! but the last step is always done by spline interpolation.
5342 : :
5343 : :
5344 [ + + ]: 15350644 : do ii=1,3
5345 [ + + ]: 61402576 : do jj=-1,2
5346 : 46051932 : inii(jj+2,ii)=indx(ii)+jj
5347 [ + + ]: 46051932 : if (inii(jj+2,ii) < 1) inii(jj+2,ii)=inii(jj+2,ii)+ngfft(ii)
5348 [ + + ]: 57564915 : if (inii(jj+2,ii) > ngfft(ii)) inii(jj+2,ii)=inii(jj+2,ii)-ngfft(ii)
5349 : : end do
5350 : : end do
5351 : :
5352 : : ! Not very nice
5353 : :
5354 [ + + ]: 15350644 : do ii=1,3
5355 : : select case (ii)
5356 : : case (1)
5357 [ + + ]: 19188305 : do jj=1,4
5358 : 15350644 : ddu(1)=cof(1,2)*ddz(inii(jj,1),inii(2,2),inii(2,3))+cof(2,2)*ddz(inii(jj,1),inii(3,2),inii(2,3))
5359 : 15350644 : ddu(2)=cof(1,2)*ddz(inii(jj,1),inii(2,2),inii(3,3))+cof(2,2)*ddz(inii(jj,1),inii(3,2),inii(3,3))
5360 : : hrh(1)=cof(1,2)*dvl(inii(jj,1),inii(2,2),inii(2,3))+cof(2,2)*dvl(inii(jj,1),inii(3,2),inii(2,3))+&
5361 : 15350644 : & pomsq(1,2)*ddy(inii(jj,1),inii(2,2),inii(2,3))+pomsq(2,2)*ddy(inii(jj,1),inii(3,2),inii(2,3))
5362 : : hrh(2)=cof(1,2)*dvl(inii(jj,1),inii(2,2),inii(3,3))+cof(2,2)*dvl(inii(jj,1),inii(3,2),inii(3,3))+&
5363 : 15350644 : & pomsq(1,2)*ddy(inii(jj,1),inii(2,2),inii(3,3))+pomsq(2,2)*ddy(inii(jj,1),inii(3,2),inii(3,3))
5364 : 15350644 : hh(jj,2)=(hrh(2)-hrh(1))/dix(3)+pom2sq(1,3)*ddu(1)+pom2sq(2,3)*ddu(2)
5365 : :
5366 : 15350644 : ddu(1)=cof(1,3)*ddy(inii(jj,1),inii(2,2),inii(2,3))+cof(2,3)*ddy(inii(jj,1),inii(2,2),inii(3,3))
5367 : 15350644 : ddu(2)=cof(1,3)*ddy(inii(jj,1),inii(3,2),inii(2,3))+cof(2,3)*ddy(inii(jj,1),inii(3,2),inii(3,3))
5368 : : hrh(1)=cof(1,3)*dvl(inii(jj,1),inii(2,2),inii(2,3))+cof(2,3)*dvl(inii(jj,1),inii(2,2),inii(3,3))+&
5369 : 15350644 : & pomsq(1,3)*ddz(inii(jj,1),inii(2,2),inii(2,3))+pomsq(2,3)*ddz(inii(jj,1),inii(2,2),inii(3,3))
5370 : : hrh(2)=cof(1,3)*dvl(inii(jj,1),inii(3,2),inii(2,3))+cof(2,3)*dvl(inii(jj,1),inii(3,2),inii(3,3))+&
5371 : 15350644 : & pomsq(1,3)*ddz(inii(jj,1),inii(3,2),inii(2,3))+pomsq(2,3)*ddz(inii(jj,1),inii(3,2),inii(3,3))
5372 : 19188305 : hh(jj,1)=(hrh(2)-hrh(1))/dix(2)+pom2sq(1,2)*ddu(1)+pom2sq(2,2)*ddu(2)
5373 : : end do
5374 : : case (2)
5375 [ + + ]: 19188305 : do jj=1,4
5376 : 15350644 : ddu(1)=cof(1,3)*ddx(inii(2,1),inii(jj,2),inii(2,3))+cof(2,3)*ddx(inii(2,1),inii(jj,2),inii(3,3))
5377 : 15350644 : ddu(2)=cof(1,3)*ddx(inii(3,1),inii(jj,2),inii(2,3))+cof(2,3)*ddx(inii(3,1),inii(jj,2),inii(3,3))
5378 : : hrh(1)=cof(1,3)*dvl(inii(2,1),inii(jj,2),inii(2,3))+cof(2,3)*dvl(inii(2,1),inii(jj,2),inii(3,3))+&
5379 : 15350644 : & pomsq(1,3)*ddz(inii(2,1),inii(jj,2),inii(2,3))+pomsq(2,3)*ddz(inii(2,1),inii(jj,2),inii(3,3))
5380 : : hrh(2)=cof(1,3)*dvl(inii(3,1),inii(jj,2),inii(2,3))+cof(2,3)*dvl(inii(3,1),inii(jj,2),inii(3,3))+&
5381 : 15350644 : & pomsq(1,3)*ddz(inii(3,1),inii(jj,2),inii(2,3))+pomsq(2,3)*ddz(inii(3,1),inii(jj,2),inii(3,3))
5382 : 15350644 : hh(jj,2)=(hrh(2)-hrh(1))/dix(1)+pom2sq(1,1)*ddu(1)+pom2sq(2,1)*ddu(2)
5383 : :
5384 : 15350644 : ddu(1)=cof(1,1)*ddz(inii(2,1),inii(jj,2),inii(2,3))+cof(2,1)*ddz(inii(3,1),inii(jj,2),inii(2,3))
5385 : 15350644 : ddu(2)=cof(1,1)*ddz(inii(2,1),inii(jj,2),inii(3,3))+cof(2,1)*ddz(inii(3,1),inii(jj,2),inii(3,3))
5386 : : hrh(1)=cof(1,1)*dvl(inii(2,1),inii(jj,2),inii(2,3))+cof(2,1)*dvl(inii(3,1),inii(jj,2),inii(2,3))+&
5387 : 15350644 : & pomsq(1,1)*ddx(inii(2,1),inii(jj,2),inii(2,3))+pomsq(2,1)*ddx(inii(3,1),inii(jj,2),inii(2,3))
5388 : : hrh(2)=cof(1,1)*dvl(inii(2,1),inii(jj,2),inii(3,3))+cof(2,1)*dvl(inii(3,1),inii(jj,2),inii(3,3))+&
5389 : 15350644 : & pomsq(1,1)*ddx(inii(2,1),inii(jj,2),inii(3,3))+pomsq(2,1)*ddx(inii(3,1),inii(jj,2),inii(3,3))
5390 : 19188305 : hh(jj,1)=(hrh(2)-hrh(1))/dix(3)+pom2sq(1,3)*ddu(1)+pom2sq(2,3)*ddu(2)
5391 : : end do
5392 : : case (3)
5393 [ + + + + : 26863627 : do jj=1,4
+ ]
5394 : 15350644 : ddu(1)=cof(1,1)*ddy(inii(2,1),inii(2,2),inii(jj,3))+cof(2,1)*ddy(inii(3,1),inii(2,2),inii(jj,3))
5395 : 15350644 : ddu(2)=cof(1,1)*ddy(inii(2,1),inii(3,2),inii(jj,3))+cof(2,1)*ddy(inii(3,1),inii(3,2),inii(jj,3))
5396 : : hrh(1)=cof(1,1)*dvl(inii(2,1),inii(2,2),inii(jj,3))+cof(2,1)*dvl(inii(3,1),inii(2,2),inii(jj,3))+&
5397 : 15350644 : & pomsq(1,1)*ddx(inii(2,1),inii(2,2),inii(jj,3))+pomsq(2,1)*ddx(inii(3,1),inii(2,2),inii(jj,3))
5398 : : hrh(2)=cof(1,1)*dvl(inii(2,1),inii(3,2),inii(jj,3))+cof(2,1)*dvl(inii(3,1),inii(3,2),inii(jj,3))+&
5399 : 15350644 : & pomsq(1,1)*ddx(inii(2,1),inii(3,2),inii(jj,3))+pomsq(2,1)*ddx(inii(3,1),inii(3,2),inii(jj,3))
5400 : 15350644 : hh(jj,2)=(hrh(2)-hrh(1))/dix(2)+pom2sq(1,2)*ddu(1)+pom2sq(2,2)*ddu(2)
5401 : :
5402 : 15350644 : ddu(1)=cof(1,2)*ddx(inii(2,1),inii(2,2),inii(jj,3))+cof(2,2)*ddx(inii(2,1),inii(3,2),inii(jj,3))
5403 : 15350644 : ddu(2)=cof(1,2)*ddx(inii(3,1),inii(2,2),inii(jj,3))+cof(2,2)*ddx(inii(3,1),inii(3,2),inii(jj,3))
5404 : : hrh(1)=cof(1,2)*dvl(inii(2,1),inii(2,2),inii(jj,3))+cof(2,2)*dvl(inii(2,1),inii(3,2),inii(jj,3))+&
5405 : 15350644 : & pomsq(1,2)*ddy(inii(2,1),inii(2,2),inii(jj,3))+pomsq(2,2)*ddy(inii(2,1),inii(3,2),inii(jj,3))
5406 : : hrh(2)=cof(1,2)*dvl(inii(3,1),inii(2,2),inii(jj,3))+cof(2,2)*dvl(inii(3,1),inii(3,2),inii(jj,3))+&
5407 : 15350644 : & pomsq(1,2)*ddy(inii(3,1),inii(2,2),inii(jj,3))+pomsq(2,2)*ddy(inii(3,1),inii(3,2),inii(jj,3))
5408 : 19188305 : hh(jj,1)=(hrh(2)-hrh(1))/dix(1)+pom2sq(1,1)*ddu(1)+pom2sq(2,1)*ddu(2)
5409 : : end do
5410 : : end select
5411 [ + + ]: 57564915 : do jj=-2,1
5412 : 57564915 : grd(jj+3)=(indx(ii)+jj)*dix(ii)
5413 : : end do
5414 : :
5415 : : ! write(std_out,'("hh: ",/,4F16.8,/,4F16.8)') ((hh(kk,jj),kk=1,4),jj=1,2)
5416 : : ! write(std_out,'("grad: ",3F16.8)') (grho(kk),kk=1,3)
5417 : : ! write(std_out,'("dix: ",3F16.8)') (dix(kk),kk=1,3)
5418 : : ! write(std_out,'("grd: ",4F16.8)') (grd(kk),kk=1,4)
5419 : : ! write(std_out,'("inii: ",4I4)') (inii(kk,ii),kk=1,4)
5420 : :
5421 [ + + ]: 38376610 : do jj=1,2
5422 : :
5423 : : ! polynomial interpolation
5424 : :
5425 [ + + ]: 92103864 : do kk=1,3
5426 [ + + ]: 230259660 : do ll=4,kk+1,-1
5427 : 207233694 : hh(ll,jj)=(hh(ll,jj)-hh(ll-1,jj))/(grd(ll)-grd(ll-1))
5428 : : end do
5429 : : end do
5430 : 23025966 : lder(4)=hh(4,jj)
5431 [ + + ]: 92103864 : do kk=3,1,-1
5432 : 92103864 : lder(kk)=hh(kk,jj)+(xx(ii)-grd(kk))*lder(kk+1)
5433 : : end do
5434 [ + + ]: 69077898 : do kk=1,2
5435 [ + + ]: 138155796 : do ll=3,kk+1,-1
5436 : 115129830 : lder(ll)=lder(ll)+(xx(ii)-grd(ll-kk))*lder(ll+1)
5437 : : end do
5438 : : end do
5439 : 23025966 : nn=ii+jj
5440 [ + + ]: 23025966 : if (nn > 3) nn=nn-3
5441 : 23025966 : hrho(ii,nn)=hrho(ii,nn)+lder(2)
5442 : 34538949 : hrho(nn,ii)=hrho(nn,ii)+lder(2)
5443 : : end do
5444 : : end do
5445 : :
5446 : : ! averaging of the mixed derivations obtained in different order
5447 : :
5448 [ + + ]: 15350644 : do ii=1,3
5449 [ + + ]: 49889593 : do jj=1,3
5450 [ + + ]: 46051932 : if (ii /= jj) hrho(ii,jj)=hrho(ii,jj)/2._dp
5451 : : end do
5452 : : end do
5453 : :
5454 : :
5455 : : ! write(std_out,'("xx:",3F16.8)') (xx(ii),ii=1,3)
5456 : : ! write(std_out,'("hrho: ",/,3F16.8,/,3F16.8,/,3F16.8)') &
5457 : : ! & ((hrho(ii,jj),ii=1,3),jj=1,3)
5458 : : ! stop
5459 : : ! write(std_out,'("xx:",3F16.8)') (xx(ii),ii=1,3)
5460 : : ! write(std_out,'(":GRAD pred tr ",3F16.8)') grho
5461 : : ! write(std_out,'(":HESSIAN pred tr",/,3F16.8,/,3F16.8,/,3F16.8)') ((hrho(ii,jj),jj=1,3),ii=1,3)
5462 : :
5463 : :
5464 : : ! Transformation back to Cart. coordonnes
5465 : :
5466 : 3837661 : call bschg1(grho,2)
5467 : 3837661 : call bschg2(hrho,2)
5468 : :
5469 : : ! write(std_out,'("hrho: ",/,3F16.8,/,3F16.8,/,3F16.8)') &
5470 : : ! & ((hrho(ii,jj),ii=1,3),jj=1,3)
5471 : : ! stop
5472 : :
5473 : 3837661 : nullify(ptddx,ptddy,ptddz,ptrho)
5474 : :
5475 [ - + ]: 3837661 : if (selct==1) return
5476 : :
5477 : : end if
5478 : :
5479 : : !write(51,'(":GRADv ",3F16.8)') grho
5480 : : !write(52,'(":LAPv ",F16.8)') hrho(1,1)+hrho(2,2)+hrho(3,3)
5481 : : !write(52,'(":HESNv ",/,3F16.8,/,3F16.8,/,3F16.8)') ((hrho(ii,jj),jj=1,3),ii=1,3)
5482 : :
5483 : : !INTERPOLATION OF THE CORE DENSITY
5484 : :
5485 : : if (selct/=1) then
5486 : :
5487 [ - + ]: 3837661 : if (selct==2) then
5488 : 0 : grho(:)=0._dp
5489 : 0 : hrho(:,:)=0._dp
5490 : 0 : rho=0._dp
5491 : : end if
5492 : :
5493 : : ! SEARCH OF THE NEIGHBOUR ATOMS
5494 : :
5495 [ + + ]: 3837661 : if (selct /= -2) then
5496 : 3831671 : iat=0
5497 : 3831671 : ipos=0
5498 : : end if
5499 : 3837661 : rdmin=20._dp
5500 : :
5501 [ + + ]: 18674195 : do jj=1,natom
5502 : 14836534 : nn=typat(jj)
5503 : 14836534 : rrad_nn=rrad(corlim(nn),nn)
5504 : 14836534 : rrad2_nn=rrad_nn*rrad_nn
5505 : 14836534 : vw1=vv(1)-xatm(1,jj)
5506 : 14836534 : vw2=vv(2)-xatm(2,jj)
5507 : 14836534 : vw3=vv(3)-xatm(3,jj)
5508 : :
5509 [ + + ]: 5107605357 : do kk=1,nnpos
5510 : :
5511 : 5088931162 : vt1=vw1-atp(1,kk)
5512 : 5088931162 : vt2=vw2-atp(2,kk)
5513 : 5088931162 : vt3=vw3-atp(3,kk)
5514 : 5088931162 : rr2=vt1*vt1+vt2*vt2+vt3*vt3
5515 : :
5516 : : ! rr=vnorm(vt,0)
5517 : :
5518 : : ! Only contribution > rhocormin (adhoc.f90) are considered
5519 : :
5520 [ + + + + : 5088931162 : if (rr2 < rrad2_nn .and.(.not.((selct==-2).and.(iat==jj).and.(ipos==kk)))) then
+ + + + ]
5521 : : ! if (rr /= 0.0_dp) then ! XG020629 : never test a real number against zero (not portable)
5522 [ + + ]: 11652540 : if (rr2 > 1.0d-28) then ! SEARCH INDEX
5523 : :
5524 : 11652426 : rr=sqrt(rr2)
5525 : 11652426 : rr_inv=1.0_dp/rr
5526 : :
5527 [ + + ]: 11652426 : if (rr < rrad(1,nn)) then
5528 : : inx=-1
5529 [ + - ]: 11652340 : elseif (rr > rrad(ndat(nn),nn)) then
5530 : : inx=ndat(nn)
5531 : : else
5532 : : ! Find the index of the radius by bissection
5533 : : inmin=1
5534 : : inmax=ndat(nn)
5535 : 114265787 : inx=1
5536 : : do
5537 [ + + ]: 114265787 : if(inmax-inmin==1)exit
5538 : 102613447 : inx=(inmin+inmax)/2
5539 [ + + ]: 114265787 : if(rr>=rrad(inx,nn))then
5540 : : inmin=inx
5541 : : else
5542 : 49962771 : inmax=inx
5543 : : end if
5544 : : end do
5545 : : inx=inmin
5546 : :
5547 : : ! XG020629 : old coding, slower
5548 : : ! inx=0
5549 : : ! do while (rr >= rrad(inx+1,nn))
5550 : : ! inx=inx+1
5551 : : ! end do
5552 : :
5553 : : end if
5554 : :
5555 : : ! Transformation matrix radial -> cart. coord
5556 : 11652426 : ss=sqrt(vt1*vt1+vt2*vt2)
5557 : : ! if (ss /=0._dp) then ! XG020629 : never test a real number against zero (not portable)
5558 [ + + ]: 11652426 : if (ss*ss > 1.0d-28) then ! ss non-zero
5559 : : ! XG020629 : very strange : only trsf(:,1) is needed in what follows ? !
5560 : : ! ss_inv=1.0_dp/ss
5561 : 11651885 : trsf(1,1)=vt1*rr_inv
5562 : : ! trsf(1,2)=-vt2*ss_inv
5563 : : ! trsf(1,3)=vt3*vt1*rr_inv*ss_inv
5564 : 11651885 : trsf(2,1)=vt2*rr_inv
5565 : : ! trsf(2,2)=vt1*ss_inv
5566 : : ! trsf(2,3)=vt3*vt2*rr_inv*ss_inv
5567 : 11651885 : trsf(3,1)=vt3*rr_inv
5568 : : ! trsf(3,2)=0._dp
5569 : : ! trsf(3,3)=-ss*rr_inv
5570 : : ! XG020629 Not needed
5571 : : ! do ii=1,3
5572 : : ! do ll=1,3
5573 : : ! ches(ii,ll)=0._dp
5574 : : ! end do
5575 : : ! cgrad(ii)=0._dp
5576 : : ! end do
5577 : : else ! ss zero
5578 [ + + ]: 2164 : do ii=1,3
5579 [ + + ]: 6492 : do ll=1,3
5580 : 6492 : trsf(ii,ll)=0._dp
5581 : : end do
5582 : 2164 : trsf(ii,4-ii)=1._dp
5583 : : end do
5584 : : end if ! ss zero or non-zero
5585 : :
5586 [ + + ]: 11652426 : if (inx == -1) then ! LEFT EXTRAPOLATION y=a*x^2+b (a<0)
5587 : 86 : val=sp2(1,nn)*0.5_dp*rr*rr/rrad(1,nn)+crho(1,nn)-sp2(1,nn)*rrad(1,nn)*0.5_dp
5588 : 86 : cgrad(1)=sp2(1,nn)*rr/rrad(1,nn)
5589 : 86 : ches(1,1)=sp2(1,nn)/rrad(1,nn)
5590 [ - + ]: 11652340 : elseif (inx == ndat(nn) ) then ! RIGHT EXTRAPOLATION y=a*exp(b*x)
5591 : 0 : val=rrad(ndat(nn),nn)*exp(sp2(ndat(nn),nn)*(rr-rrad(ndat(nn),nn))/crho(ndat(nn),nn))
5592 : 0 : cgrad(1)=val*sp2(ndat(nn),nn)/crho(ndat(nn),nn)
5593 : 0 : ches(1,1)=cgrad(1)*sp2(ndat(nn),nn)/crho(ndat(nn),nn)
5594 : : else ! INTERPOLATION
5595 : 11652340 : uu=rrad(inx+1,nn)-rrad(inx,nn)
5596 : 11652340 : uu_inv=1.0_dp/uu
5597 : 11652340 : aa=(rrad(inx+1,nn)-rr)*uu_inv
5598 : 11652340 : bb=(rr-rrad(inx,nn))*uu_inv
5599 : 11652340 : cc=(aa*aa*aa-aa)*uu*uu*0.16666666666666666_dp
5600 : 11652340 : dd=(bb*bb*bb-bb)*uu*uu*0.16666666666666666_dp
5601 : 11652340 : val=aa*crho(inx,nn)+bb*crho(inx+1,nn)+cc*sp3(inx,nn)+dd*sp3(inx+1,nn)
5602 : : cgrad(1)=(crho(inx+1,nn)-crho(inx,nn))*uu_inv&
5603 : : & -(3._dp*aa*aa-1._dp)*uu*0.16666666666666666_dp*sp3(inx,nn)+&
5604 : 11652340 : & (3._dp*bb*bb-1._dp)*uu*0.16666666666666666_dp*sp3(inx+1,nn)
5605 : 11652340 : ches(1,1)=aa*sp3(inx,nn)+bb*sp3(inx+1,nn)
5606 : :
5607 : : end if ! TRANSFORMATION TO CARTEZ. COORD.
5608 : :
5609 : 11652426 : cgrad1_rr_inv=cgrad(1)*rr_inv
5610 : 11652426 : coeff=(ches(1,1)-cgrad1_rr_inv)*rr_inv*rr_inv
5611 : 11652426 : cgrad(3)=trsf(3,1)*cgrad(1)
5612 : 11652426 : cgrad(2)=trsf(2,1)*cgrad(1)
5613 : 11652426 : cgrad(1)=trsf(1,1)*cgrad(1)
5614 : 11652426 : ches(1,1)=coeff*vt1*vt1+cgrad1_rr_inv
5615 : 11652426 : ches(2,2)=coeff*vt2*vt2+cgrad1_rr_inv
5616 : 11652426 : ches(3,3)=coeff*vt3*vt3+cgrad1_rr_inv
5617 : 11652426 : ches(1,2)=coeff*vt1*vt2 ; ches(2,1)=coeff*vt1*vt2
5618 : 11652426 : ches(1,3)=coeff*vt1*vt3 ; ches(3,1)=coeff*vt1*vt3
5619 : 11652426 : ches(2,3)=coeff*vt2*vt3 ; ches(3,2)=coeff*vt2*vt3
5620 : :
5621 : : else ! case rr==0
5622 : :
5623 : 114 : val=crho(1,nn)-sp2(1,nn)*rrad(1,nn)/2._dp
5624 [ + + ]: 456 : do ii=1,3
5625 [ + + ]: 1368 : do ll=1,3
5626 : 1368 : ches(ii,ll)=0._dp
5627 : : end do
5628 : 342 : cgrad(ii)=0._dp
5629 : 456 : ches(ii,ii)=sp2(1,nn)/rrad(1,nn)
5630 : : end do
5631 : :
5632 : : end if ! rr>0 or rr==0
5633 : :
5634 [ + + ]: 46610160 : do ii=1,3
5635 [ + + ]: 139830480 : do ll=1,3
5636 : 139830480 : hrho(ii,ll)=hrho(ii,ll)+ches(ii,ll)
5637 : : end do
5638 : 46610160 : grho(ii)=grho(ii)+cgrad(ii)
5639 : : end do
5640 : 11652540 : rho=rho+val
5641 : :
5642 : : end if ! rr2< rrad_nn*rrad_nn
5643 : :
5644 [ + + ]: 5103767696 : if (selct==-1) then
5645 [ + + ]: 264538750 : if (rr2 < rminl(jj)*rminl(jj) ) then
5646 : 3114 : iat=jj
5647 : 3114 : ipos=kk
5648 : 3114 : rdmin=sqrt(rr2)
5649 : : end if
5650 [ + + ]: 4824392412 : elseif (selct==-2) then
5651 : : cycle
5652 : : else
5653 [ + + ]: 4819875445 : if (rr2 < rdmin*rdmin) then
5654 : 30825293 : iat=jj
5655 : 30825293 : ipos=kk
5656 : 30825293 : rdmin=sqrt(rr2)
5657 : : end if
5658 : : end if
5659 : :
5660 : : end do
5661 : : end do
5662 : :
5663 : : end if
5664 : :
5665 : : !write(51,'(":GRADt ",3F16.8)') grho
5666 : : !write(52,'(":LAPt ",F16.8)') hrho(1,1)+hrho(2,2)+hrho(3,3)
5667 : : !write(52,'(":HESNt ",/,3F16.8,/,3F16.8,/,3F16.8)') ((hrho(ii,jj),jj=1,3),ii=1,3)
5668 : :
5669 : : !if(abs(cumul_cpu-cumul_cpu_old)>0.499)then
5670 : : !write(std_out,'(a,f7.1)' )' vgh_rho : cumul_cpu=',cumul_cpu
5671 : : !cumul_cpu_old=cumul_cpu
5672 : : !end if
5673 : :
5674 [ + - ]: 3837661 : end subroutine vgh_rho
5675 : : !!***
5676 : :
5677 : : !!****f* m_bader/vnorm
5678 : : !! NAME
5679 : : !! vnorm
5680 : : !!
5681 : : !! FUNCTION
5682 : : !! Default declarations, and interfaces for the aim.f utility.
5683 : : !!
5684 : : !! INPUTS
5685 : : !! vector norm ->dir==1: vector in reduced coordinates
5686 : : !! dir==0: vector in cartes. coordinates
5687 : : !!
5688 : : !! OUTPUT
5689 : : !! (see side effects)
5690 : : !!
5691 : : !! SIDE EFFECTS
5692 : : !! vv = on entry, vector to normalized
5693 : : !! = on exit, normalized vector
5694 : : !!
5695 : : !! SOURCE
5696 : :
5697 : 1026017 : function vnorm(vv,dir)
5698 : :
5699 : : !Arguments ------------------------------------
5700 : : !scalars
5701 : : integer,intent(in) :: dir
5702 : : real(dp) :: vnorm
5703 : : !arrays
5704 : : real(dp),intent(in) :: vv(3)
5705 : :
5706 : : !Local variables-------------------------------
5707 : : !scalars
5708 : : integer :: ii
5709 : : !arrays
5710 : : real(dp) :: vt(3)
5711 : :
5712 : : ! *************************************************************************
5713 : :
5714 : 1026017 : vnorm=zero
5715 [ - + ]: 1026017 : if (dir==1) then
5716 [ # # ]: 0 : do ii=1,3
5717 : 0 : vt(ii)=rprimd(ii,1)*vv(1)+rprimd(ii,2)*vv(2)+rprimd(ii,3)*vv(3)
5718 : 0 : vnorm=vnorm+vt(ii)*vt(ii)
5719 : : end do
5720 [ + - ]: 1026017 : elseif (dir==0) then
5721 [ + + ]: 4104068 : do ii=1,3
5722 : 4104068 : vnorm=vnorm+vv(ii)*vv(ii)
5723 : : end do
5724 : : else
5725 : 0 : ABI_ERROR('vnorm calcul')
5726 : : end if
5727 : 1026017 : vnorm=sqrt(vnorm)
5728 : :
5729 : 1026017 : end function vnorm
5730 : : !!***
5731 : :
5732 : : !!****f* m_bader/vec_prod
5733 : : !! NAME
5734 : : !! vec_prod
5735 : : !!
5736 : : !! FUNCTION
5737 : : !! Vector product
5738 : : !!
5739 : : !! INPUTS
5740 : : !! vv,uu = vectors to compute vector product
5741 : : !!
5742 : : !! OUTPUT
5743 : : !! (return the value of the vector product)
5744 : : !!
5745 : : !! SOURCE
5746 : :
5747 [ # # ]: 0 : function vec_prod(uu,vv)
5748 : :
5749 : : !Arguments ------------------------------------
5750 : : !arrays
5751 : : real(dp) :: vec_prod(3)
5752 : : real(dp),intent(in) :: uu(3),vv(3)
5753 : :
5754 : : !Local variables-------------------------------
5755 : :
5756 : : ! *************************************************************************
5757 : :
5758 : 0 : vec_prod(1)=uu(2)*vv(3)-vv(2)*uu(3)
5759 : 0 : vec_prod(2)=uu(3)*vv(1)-vv(3)*uu(1)
5760 : 0 : vec_prod(3)=uu(1)*vv(2)-vv(1)*uu(2)
5761 : :
5762 : : end function vec_prod
5763 : : !!***
5764 : :
5765 : : !!****f* m_bader/mprod
5766 : : !! NAME
5767 : : !! mprod
5768 : : !!
5769 : : !! FUNCTION
5770 : : !! Matrix multiplication cc=aa*bb
5771 : : !!
5772 : : !! SOURCE
5773 : :
5774 : 7675322 : subroutine mprod(aa,bb,cc)
5775 : :
5776 : : !Arguments ------------------------------------
5777 : : !arrays
5778 : : real(dp),intent(in) :: aa(3,3),bb(3,3)
5779 : : real(dp),intent(out) :: cc(3,3)
5780 : :
5781 : : !Local variables-------------------------------
5782 : : !scalars
5783 : : integer :: ii,jj,kk
5784 : :
5785 : : ! *************************************************************************
5786 : :
5787 [ + + ]: 30701288 : do ii=1,3
5788 [ + + ]: 99779186 : do jj=1,3
5789 : 69077898 : cc(ii,jj)=0._dp
5790 [ + + ]: 299337558 : do kk=1,3
5791 : 276311592 : cc(ii,jj)=cc(ii,jj)+aa(ii,kk)*bb(kk,jj)
5792 : : end do
5793 : : end do
5794 : : end do
5795 : :
5796 : 7675322 : end subroutine mprod
5797 : : !!***
5798 : :
5799 : : !!****f* m_bader/bschg1
5800 : : !! NAME
5801 : : !! bschg1
5802 : : !!
5803 : : !! FUNCTION
5804 : : !! bschg1: Vector transformation of coordinates
5805 : : !!
5806 : : !! SOURCE
5807 : :
5808 : 7678775 : subroutine bschg1(vv,dir)
5809 : :
5810 : : !Arguments ------------------------------------
5811 : : !scalars
5812 : : integer,intent(in) :: dir
5813 : : !arrays
5814 : : real(dp),intent(inout) :: vv(3)
5815 : :
5816 : : !Local variables ------------------------------
5817 : : !scalars
5818 : : integer :: ii
5819 : : !arrays
5820 : : real(dp) :: vt(3)
5821 : :
5822 : : ! *********************************************************************
5823 : :
5824 [ + + ]: 7678775 : if (dir==1) then
5825 [ + + ]: 13812 : do ii=1,3
5826 : 13812 : vt(ii)=rprimd(ii,1)*vv(1)+rprimd(ii,2)*vv(2)+rprimd(ii,3)*vv(3)
5827 : : end do
5828 [ + + ]: 7675322 : elseif (dir==-1) then
5829 [ + + ]: 15350644 : do ii=1,3
5830 : 15350644 : vt(ii)=ivrprim(ii,1)*vv(1)+ivrprim(ii,2)*vv(2)+ivrprim(ii,3)*vv(3)
5831 : : end do
5832 [ + - ]: 3837661 : elseif (dir==2) then
5833 [ + + ]: 15350644 : do ii=1,3
5834 : 15350644 : vt(ii)=trivrp(ii,1)*vv(1)+trivrp(ii,2)*vv(2)+trivrp(ii,3)*vv(3)
5835 : : end do
5836 : : else
5837 : 0 : ABI_ERROR('Transformation of coordinates')
5838 : : end if
5839 : 7678775 : vv(:)=vt(:)
5840 : :
5841 : 7678775 : end subroutine bschg1
5842 : : !!***
5843 : :
5844 : : !!****f* m_bader/bschg2
5845 : : !! NAME
5846 : : !! bschg2
5847 : : !!
5848 : : !! FUNCTION
5849 : : !! bschg2: Matrix transformation of coordinates
5850 : : !!
5851 : : !! SOURCE
5852 : :
5853 : 3837661 : subroutine bschg2(aa,dir)
5854 : :
5855 : : !Arguments ------------------------------------
5856 : : !scalars
5857 : : integer,intent(in) :: dir
5858 : : !arrays
5859 : : real(dp),intent(inout) :: aa(3,3)
5860 : :
5861 : : !Local variables ------------------------------
5862 : : !arrays
5863 : : real(dp) :: bb(3,3)
5864 : :
5865 : : ! *********************************************************************
5866 : :
5867 [ - + ]: 3837661 : if (dir==1) then
5868 : 0 : call mprod(aa,ivrprim,bb)
5869 : 0 : call mprod(rprimd,bb,aa)
5870 [ + - ]: 3837661 : elseif (dir==2) then
5871 : 3837661 : call mprod(aa,ivrprim,bb)
5872 : 3837661 : call mprod(trivrp,bb,aa)
5873 [ # # ]: 0 : elseif (dir==-1) then
5874 : 0 : call mprod(aa,rprimd,bb)
5875 : 0 : call mprod(ivrprim,bb,aa)
5876 : : else
5877 : 0 : ABI_ERROR("transformation of coordinates")
5878 : : end if
5879 : 3837661 : end subroutine bschg2
5880 : : !!***
5881 : :
5882 : 0 : end module m_bader
5883 : : !!***
|
