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 309 : do ii=1,nline
3626 309 : read(unt0,'(A)',iostat=ios) line(1:fnlen)
3627 309 : if (ios/=0) exit
3628 304 : inxh=index(line,'#')
3629 304 : 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 : !!***
|
