Line data Source code
1 : !!****m* ABINIT/m_cgtools
2 : !! NAME
3 : !! m_cgtools
4 : !!
5 : !! FUNCTION
6 : !! This module defines wrappers for BLAS routines. The arguments are stored
7 : !! using the "cg" convention, namely real array of shape cg(2,...)
8 : !!
9 : !! COPYRIGHT
10 : !! Copyright (C) 1992-2026 ABINIT group (MG, MT, XG, DCA, GZ, FB, MVer, DCA, GMR, FF)
11 : !! This file is distributed under the terms of the
12 : !! GNU General Public License, see ~abinit/COPYING
13 : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt .
15 : !!
16 : !! NOTES
17 : !! 1) The convention about names of interfaced routine is: cg_<name>,
18 : !! where <name> is equal to the name of the standard BLAS routine
19 : !!
20 : !! 2) Blas routines are called without an explicit interface on purpose since
21 : !!
22 : !! a) The compiler should pass the base address of the array to the F77 BLAS
23 : !!
24 : !! b) Any compiler would complain about type mismatch (REAL,COMPLEX)
25 : !! if an explicit interface is given.
26 : !!
27 : !! 3) The use of mpi_type is not allowed here. MPI parallelism should be handled in a generic
28 : !! way by passing the MPI communicator so that the caller can decide how to handle MPI.
29 : !!
30 :
31 : #if defined HAVE_CONFIG_H
32 : #include "config.h"
33 : #endif
34 :
35 : #include "abi_common.h"
36 :
37 : module m_cgtools
38 :
39 : use, intrinsic :: iso_c_binding, only: c_size_t, c_loc
40 : use defs_basis
41 : use m_abicore
42 : use m_errors
43 : use m_xmpi
44 : use m_xomp
45 : use m_gputk
46 : use m_abi_linalg
47 : use m_linalg_interfaces
48 :
49 : use m_fstrings, only : toupper, itoa, sjoin
50 : use m_time, only : timab, cwtime, cwtime_report
51 : use m_numeric_tools, only : hermit, rhophi
52 : use m_pawcprj, only : pawcprj_type,pawcprj_axpby,pawcprj_zaxpby
53 :
54 : implicit none
55 :
56 : private
57 :
58 : real(dp),public,parameter :: cg_czero(2) = (/0._dp,0._dp/)
59 : real(dp),public,parameter :: cg_cone(2) = (/1._dp,0._dp/)
60 :
61 : ! Helper functions.
62 : public :: cg_tocplx
63 : public :: cg_fromcplx
64 : public :: cg_kfilter
65 : public :: cg_setaug_zero
66 : public :: cg_to_reim
67 : public :: cg_from_reim
68 :
69 : ! Blas1
70 : public :: cg_zcopy
71 : public :: cg_zscal
72 : public :: cg_dznrm2
73 : public :: cg_zdotc
74 : public :: cg_real_zdotc
75 : public :: cg_zdotu
76 : public :: cg_zaxpy
77 : public :: cg_zaxpby
78 :
79 : ! Blas2
80 : public :: cg_zgemv ! alpha*A*x + beta*y,
81 :
82 : ! Blas3
83 : public :: cg_zgemm
84 :
85 : ! Helper functions for DFT calculations.
86 : public :: set_istwfk ! Returns the value of istwfk associated to the input k-point.
87 : public :: sqnorm_g ! Square of the norm in reciprocal space.
88 : public :: dotprod_g ! Scalar product <vec1|vect2> of complex vectors vect1 and vect2 (can be the same)
89 : public :: dotprod_g_batch_half ! Scalar product <vec1|vect2> of complex vectors vect1 and vect2 (can be the same)
90 : public :: dotprod_g_batch_full ! Scalar product <vec1|vect2> of complex vectors vect1 and vect2 (can be the same)
91 : public :: matrixelmt_g ! matrix element <wf1|O|wf2> of two wavefunctions, in reciprocal space,
92 : ! for an operator diagonal in G-space.
93 : public :: dotprod_v ! Dot product of two potentials (integral over FFT grid).
94 : public :: dotprod_vn
95 : public :: sqnorm_v ! Compute square of the norm of a potential (integral over FFT grid).
96 : public :: mean_fftr ! Compute the mean of an arraysp(nfft,nspden), over the FFT grid.
97 : public :: cg_getspin ! Sandwich a single wave function on the Pauli matrices
98 : public :: cg_gsph2box ! Transfer data from the G-sphere to the FFT box.
99 : public :: cg_box2gsph ! Transfer data from the FFT box to the G-sphere
100 : public :: cg_addtorho ! Add |ur|**2 to the ground-states density rho.
101 : public :: cg_vlocpsi ! Apply the local part of the potential to the wavefunction in real space.
102 : public :: cgnc_cholesky ! Cholesky orthonormalization (version optimized for NC wavefunctions).
103 : public :: cgpaw_cholesky ! Cholesky orthonormalization of PAW wavefunctions.
104 : public :: cgnc_normalize ! Normalize NC wavefunctions.
105 : public :: cgnc_gramschmidt ! Gram-Schmidt orthogonalization for NC wavefunctions.
106 : public :: cgpaw_normalize ! Normalize PAW wavefunctions.
107 : public :: cgpaw_gramschmidt ! Gram-Schmidt orthogonalization for PAW wavefuncion
108 : public :: projbd ! Project out vector "direc" onto the bands i.e.
109 : ! direc=direc-$sum_{j/=i} { <cg_{j}|direc>.|cg_{j}> }$
110 : public :: cg_envlop ! Multiply random number values in cg by envelope function to lower initial kinetic energy.
111 : public :: cg_normev ! Normalize a set of num eigenvectors of complex length ndim
112 : public :: cg_precon ! precondition $<G|(H-e_{n,k})|C_{n,k}>$
113 : public :: cg_precon_block ! precondition $<G|(H-e_{n,k})|C_{n,k}>$ for a block of band
114 : ! in the case of real WFs (istwfk/=1)
115 : public :: cg_zprecon_block ! precondition $<G|(H-e_{n,k})|C_{n,k}>$ for a block of band
116 : public :: fxphas_seq ! Fix phase of all bands. Keep normalization but maximize real part
117 : public :: fxphas_and_cmp ! Fix phase and compare two set of wavefunctions
118 : public :: overlap_g ! Compute the scalar product between WF at two different k-points
119 : public :: subdiago ! Diagonalizes the Hamiltonian in the eigenfunction subspace
120 : public :: subdiago_low_memory ! Diagonalizes the Hamiltonian in the eigenfunction subspace
121 : ! G components are updated block by block to save memory.
122 : public :: pw_orthon ! Normalize nvec complex vectors each of length nelem and then
123 : ! orthogonalize by modified Gram-Schmidt.
124 : public :: pw_orthon_cprj ! Normalize nvec complex vectors each of length nelem and then
125 : ! orthogonalize by modified Gram-Schmidt. Also update cprj coeffs.
126 : public :: cg_hprotate_and_get_diag
127 : public :: cg_hrotate_and_get_diag
128 : public :: cg_get_eigens ! Compute <i|H|i> / <i|S|i> for ndat states.
129 : public :: cg_get_residvecs ! Compute (H - eS) |psi> for ndat states.
130 : public :: cg_norm2g ! Compute <psi|psi> for ndat states distributed inside communicator comm.
131 : public :: cg_zdotg_zip ! Compute <cg1|cg2> for ndat states
132 : public :: cg_precon_many
133 : public :: cg_zaxpy_many_areal
134 : public :: cg_set_imag0_to_zero
135 : public :: cg_randomize ! Initialize cg_k with random numbers.
136 : public :: cg_copy_spin
137 : public :: cg_put_spin
138 : public :: cg_p_psi ! Compute <g|-i\Nabla|psi_nk>.
139 : !***
140 :
141 : CONTAINS !========================================================================================
142 : !!***
143 :
144 : !----------------------------------------------------------------------
145 :
146 : !!****f* m_cgtools/cg_tocplx
147 : !! NAME
148 : !! cg_tocplx
149 : !!
150 : !! FUNCTION
151 : !! Convert a real array with (real,imag) part to complex.
152 : !!
153 : !! INPUTS
154 : !! n = Specifies the number of elements in cg and ocplx
155 : !! cg(2*n)=Input array with real and imaginary part.
156 : !!
157 : !! OUTPUT
158 : !! ocplx(n)=Output complex array.
159 : !!
160 : !! SOURCE
161 :
162 0 : subroutine cg_tocplx(n, cg, ocplx)
163 :
164 : !Arguments ------------------------------------
165 : !scalars
166 : integer,intent(in) :: n
167 : !arrays
168 : real(dp),intent(in) :: cg(2*n)
169 : complex(dp),intent(out) :: ocplx(n)
170 :
171 : !Local variables ------------------------------
172 : !scalars
173 : integer :: ii,idx
174 : ! *************************************************************************
175 :
176 : !$OMP PARALLEL DO PRIVATE(idx)
177 0 : do ii=1,n
178 0 : idx = 2*ii-1
179 0 : ocplx(ii) = DCMPLX(cg(idx),cg(idx+1))
180 : end do
181 :
182 0 : end subroutine cg_tocplx
183 : !!***
184 :
185 : !----------------------------------------------------------------------
186 :
187 : !!****f* m_cgtools/cg_fromcplx
188 : !! NAME
189 : !! cg_fromcplx
190 : !!
191 : !! FUNCTION
192 : !! Convert a complex array to a real array with (real,imag) part
193 : !!
194 : !! INPUTS
195 : !! n = Specifies the number of elements in icplx and ocg.
196 : !! icplx(n)=Input complex array.
197 : !!
198 : !! OUTPUT
199 : !! ocg(2*n)=Output array with real and imaginary part.
200 : !!
201 : !! SOURCE
202 :
203 0 : subroutine cg_fromcplx(n, icplx, ocg)
204 :
205 : !Arguments ------------------------------------
206 : !scalars
207 : integer,intent(in) :: n
208 : !arrays
209 : real(dp),intent(out) :: ocg(2*n)
210 : complex(dp),intent(in) :: icplx(n)
211 :
212 : !Local variables ------------------------------
213 : !scalars
214 : integer :: ii,idx
215 : ! *************************************************************************
216 :
217 : !$OMP PARALLEL DO PRIVATE(idx)
218 0 : do ii=1,n
219 0 : idx = 2*ii-1
220 0 : ocg(idx ) = DBLE (icplx(ii))
221 0 : ocg(idx+1) = AIMAG(icplx(ii))
222 : end do
223 :
224 0 : end subroutine cg_fromcplx
225 : !!***
226 :
227 : !----------------------------------------------------------------------
228 :
229 : !!****f* m_cgtools/cg_kfilter
230 : !! NAME
231 : !! cg_kfilter
232 : !!
233 : !! FUNCTION
234 : !!
235 : !! INPUTS
236 : !! nband=Number of vectors in icg1
237 : !!
238 : !! SOURCE
239 :
240 0 : pure subroutine cg_kfilter(npw_k, my_nspinor, nband_k, kinpw, cg)
241 :
242 : !Arguments ------------------------------------
243 : !scalars
244 : integer,intent(in) :: npw_k, my_nspinor, nband_k
245 : !arrays
246 : real(dp), intent(in) :: kinpw(npw_k)
247 : real(dp),intent(inout) :: cg(2,npw_k*my_nspinor*nband_k)
248 :
249 : !Local variables-------------------------------
250 : integer :: ispinor, iband, igs, iwavef, ipw
251 : ! *************************************************************************
252 :
253 : ! Filter the WFs when modified kinetic energy is too large (see routine mkkin.f)
254 : ! !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(igs, iwavef)
255 0 : do ispinor=1,my_nspinor
256 0 : igs=(ispinor-1)*npw_k
257 0 : do iband=1,nband_k
258 0 : iwavef=(iband-1)*npw_k*my_nspinor
259 0 : do ipw=1+igs,npw_k+igs
260 0 : if (kinpw(ipw-igs)>huge(zero)*1.d-11) cg(:,ipw+iwavef)=zero
261 : end do
262 : end do
263 : end do
264 :
265 0 : end subroutine cg_kfilter
266 : !!***
267 :
268 : !----------------------------------------------------------------------
269 :
270 : !!****f* m_cgtools/cg_setaug_zero
271 : !! NAME
272 : !! cg_setaug_zero
273 : !!
274 : !! FUNCTION
275 : !! Set to zero all elements of the array that are not in the FFT box.
276 : !!
277 : !! INPUTS
278 : !! nx,ny,nz=physical dimensions of the FFT box
279 : !! ldx,ldy,ldx=memory dimension of arr
280 : !! ndat=number of FFTs
281 : !!
282 : !! SIDE EFFECT
283 : !! arr(2,ldx,ldy,ldz*ndat)= all entries in the augmented region are set to zero
284 : !!
285 : !! SOURCE
286 :
287 96 : pure subroutine cg_setaug_zero(cplex,nx,ny,nz,ldx,ldy,ldz,ndat,arr)
288 :
289 : !Arguments ------------------------------------
290 : !scalars
291 : integer,intent(in) :: cplex,nx,ny,nz,ldx,ldy,ldz,ndat
292 : !arrays
293 : real(dp),intent(inout) :: arr(cplex,ldx,ldy,ldz*ndat)
294 :
295 : !Local variables-------------------------------
296 : integer :: iy,iz,dat,padat
297 : ! *************************************************************************
298 :
299 96 : if (nx /= ldx) then
300 1312 : do iz=1,ldz*ndat
301 26052 : do iy=1,ldy
302 125670 : arr(:,nx+1:ldx,iy,iz) = zero
303 : end do
304 : end do
305 : end if
306 :
307 96 : if (ny /= ldy) then
308 1004 : do iz=1,ldz*ndat
309 63354 : arr(:,:,ny+1:ldy,iz) = zero
310 : end do
311 : end if
312 :
313 96 : if (nz /= ldz) then
314 84 : do dat=1,ndat
315 60 : padat = ldz*(dat-1)
316 184 : do iz=nz+1,ldz
317 72560 : arr(:,:,:,iz+padat) = zero
318 : end do
319 : end do
320 : end if
321 :
322 96 : end subroutine cg_setaug_zero
323 : !!***
324 :
325 : !----------------------------------------------------------------------
326 :
327 : !!****f* m_cgtools/cg_to_reim
328 : !! NAME
329 : !! cg_to_reim
330 : !!
331 : !! FUNCTION
332 : !!
333 : !! INPUTS
334 : !!
335 : !! SOURCE
336 :
337 0 : subroutine cg_to_reim(npw, ndat, cg, factor, reim)
338 :
339 : !Arguments ------------------------------------
340 : !scalars
341 : integer,intent(in) :: npw,ndat
342 : real(dp),intent(in) :: factor
343 : !arrays
344 : real(dp),intent(in) :: cg(2*npw,ndat)
345 : real(dp),intent(out) :: reim(npw*2,ndat)
346 :
347 : !Local variables-------------------------------
348 : integer :: idat
349 : ! *************************************************************************
350 :
351 : ! Pack real and imaginary part of the wavefunctions.
352 : ! and multiply by scale factor if factor /= one.
353 0 : do idat=1,ndat
354 0 : call dcopy(npw, cg(1, idat), 2, reim(1, idat), 1)
355 0 : call dcopy(npw, cg(2, idat), 2, reim(npw+1, idat), 1)
356 0 : if (factor /= one) call dscal(2*npw, factor, reim(1, idat), 1)
357 : end do
358 :
359 0 : end subroutine cg_to_reim
360 : !!***
361 :
362 : !----------------------------------------------------------------------
363 :
364 : !!****f* m_cgtools/cg_from_reim
365 : !! NAME
366 : !! cg_from_reim
367 : !!
368 : !! FUNCTION
369 : !!
370 : !! INPUTS
371 : !!
372 : !! SOURCE
373 :
374 0 : subroutine cg_from_reim(npw, ndat, reim, factor, cg)
375 :
376 : !Arguments ------------------------------------
377 : !scalars
378 : integer,intent(in) :: npw,ndat
379 : real(dp),intent(in) :: factor
380 : !arrays
381 : real(dp),intent(in) :: reim(npw*2, ndat)
382 : real(dp),intent(out) :: cg(2*npw, ndat)
383 :
384 : !Local variables-------------------------------
385 : integer :: idat
386 : ! *************************************************************************
387 :
388 : ! UnPack real and imaginary part and multiply by scale factor if /= one.
389 0 : do idat=1,ndat
390 0 : call dcopy(npw, reim(1, idat), 1, cg(1, idat), 2)
391 0 : call dcopy(npw, reim(npw+1, idat), 1, cg(2, idat), 2)
392 0 : if (factor /= one) call dscal(2*npw, factor, cg(1, idat), 1)
393 : end do
394 :
395 0 : end subroutine cg_from_reim
396 : !!***
397 :
398 : !----------------------------------------------------------------------
399 :
400 : !!****f* m_cgtools/cg_zcopy
401 : !! NAME
402 : !! cg_zcopy
403 : !!
404 : !! FUNCTION
405 : !! Perform y = x, where x and y are vectors.
406 : !!
407 : !! INPUTS
408 : !! n = Specifies the number of elements in vectors x and y.
409 : !! x = Input Array
410 : !!
411 : !! OUTPUT
412 : !! y = In output, y contains a copy of the values of x.
413 : !!
414 : !! SOURCE
415 :
416 73115982 : subroutine cg_zcopy(n, x, y)
417 :
418 : !Arguments ------------------------------------
419 : !scalars
420 : integer,intent(in) :: n
421 : !arrays
422 : real(dp),intent(in) :: x(2*n)
423 : real(dp),intent(out) :: y(2*n)
424 : ! *************************************************************************
425 :
426 73115982 : call zcopy(n, x, 1, y, 1)
427 :
428 73115982 : end subroutine cg_zcopy
429 : !!***
430 :
431 : !----------------------------------------------------------------------
432 :
433 : !!****f* m_cgtools/cg_zscal
434 : !! NAME
435 : !! cg_zscal
436 : !!
437 : !! FUNCTION
438 : !! Perform x = a*x
439 : !!
440 : !! INPUTS
441 : !! n = Specifies the number of elements in vector x.
442 : !! a(2)= The scalar a. If a(2) is zero, x = a*x is computed via zdscal
443 : !!
444 : !! OUTPUT
445 : !! x = Updated vector.
446 : !!
447 : !! SOURCE
448 :
449 10400309 : subroutine cg_zscal(n, a, x)
450 :
451 : !Arguments ------------------------------------
452 : !scalars
453 : integer,intent(in) :: n
454 : real(dp),intent(in) :: a(2)
455 : !arrays
456 : real(dp),intent(inout) :: x(2*n)
457 : ! *************************************************************************
458 :
459 10400309 : if (a(2) == zero) then
460 10400309 : call dscal(2*n, a(1), x, 1)
461 : else
462 0 : call zscal(n, a, x, 1)
463 : end if
464 :
465 10400309 : end subroutine cg_zscal
466 : !!***
467 :
468 : !----------------------------------------------------------------------
469 :
470 : !!****f* m_cgtools/cg_dznrm2
471 : !! NAME
472 : !! cg_dznrm2
473 : !!
474 : !! FUNCTION
475 : !! returns the euclidean norm of a vector via the function name, so that
476 : !! DZNRM2 := sqrt( x**H*x )
477 : !!
478 : !! INPUTS
479 : !! n = Specifies the number of elements in vector x.
480 : !! x(2*x) = Input array.
481 : !!
482 : !! OUTPUT
483 : !!
484 : !! SOURCE
485 :
486 35204279 : function cg_dznrm2(n, x) result(res)
487 :
488 : !Arguments ------------------------------------
489 : !scalars
490 : integer,intent(in) :: n
491 : real(dp) :: res
492 : !arrays
493 : real(dp),intent(in) :: x(2*n)
494 : real(dp),external :: dznrm2
495 : ! *************************************************************************
496 :
497 35174271 : res = dznrm2(n, x, 1)
498 :
499 1320 : end function cg_dznrm2
500 : !!***
501 : !----------------------------------------------------------------------
502 :
503 : !!****f* m_cgtools/cg_zdotc
504 : !! NAME
505 : !! cg_zdotc
506 : !!
507 : !! FUNCTION
508 : !! Perform a vector-vector operation defined as res = \Sigma (conjg(x)*y) where x and y are n-element vectors.
509 : !!
510 : !! INPUTS
511 : !! n = Specifies the number of elements in vector x and y
512 : !! x,y = Input arrays.
513 : !!
514 : !! OUTPUT
515 : !! res(2)=Real and Imaginary part of the scalar product.
516 : !!
517 : !! SOURCE
518 :
519 31633028 : function cg_zdotc(n, x, y) result(res)
520 :
521 : !Arguments ------------------------------------
522 : !scalars
523 : integer,intent(in) :: n
524 : !arrays
525 : real(dp),intent(in) :: x(2,n), y(2,n)
526 : real(dp) :: res(2)
527 :
528 : !Local variables-------------------------------
529 : #ifdef HAVE_LINALG_ZDOTC_BUG
530 : integer :: ii
531 : #else
532 : complex(dp) :: cres
533 : complex(dp),external :: zdotc
534 : #endif
535 : ! *************************************************************************
536 :
537 : #ifdef HAVE_LINALG_ZDOTC_BUG
538 : ! Workaround for veclib on MacOSx
539 : res = zero
540 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:res)
541 : do ii=1,n
542 : res(1) = res(1) + x(1,ii)*y(1,ii) + x(2,ii)*y(2,ii)
543 : res(2) = res(2) + x(1,ii)*y(2,ii) - x(2,ii)*y(1,ii)
544 : end do
545 :
546 : #else
547 31633028 : cres = zdotc(n, x, 1, y, 1)
548 31633028 : res(1) = REAL(cres)
549 31633028 : res(2) = AIMAG(cres)
550 : #endif
551 :
552 31633028 : end function cg_zdotc
553 : !!***
554 :
555 : !----------------------------------------------------------------------
556 :
557 : !!****f* m_cgtools/cg_real_zdotc
558 : !! NAME
559 : !! cg_real_zdotc
560 : !!
561 : !! FUNCTION
562 : !! Perform a vector-vector operation defined as res = REAL (\Sigma (conjg(x)*y)) where x and y are n-element vectors.
563 : !!
564 : !! INPUTS
565 : !! n = Specifies the number of elements in vector x and y
566 : !! x,y = Input arrays.
567 : !!
568 : !! OUTPUT
569 : !! res=Real part of the scalar product.
570 : !!
571 : !! SOURCE
572 :
573 134806871 : function cg_real_zdotc(n,x,y) result(res)
574 :
575 : !Arguments ------------------------------------
576 : !scalars
577 : integer,intent(in) :: n
578 : !arrays
579 : real(dp),intent(in) :: x(2,n)
580 : real(dp),intent(in) :: y(2,n)
581 : real(dp) :: res
582 :
583 : !Local variables-------------------------------
584 : real(dp),external :: ddot
585 : ! *************************************************************************
586 :
587 134806871 : res = ddot(2*n, x, 1, y, 1)
588 :
589 134806871 : end function cg_real_zdotc
590 : !!***
591 :
592 : !----------------------------------------------------------------------
593 :
594 : !!****f* m_cgtools/cg_zdotu
595 : !! NAME
596 : !! cg_zdotu
597 : !!
598 : !! FUNCTION
599 : !! Perform a vector-vector operation defined as res = \Sigma (x*y) where x and y are n-element vectors.
600 : !! Note that x is unconjugated.
601 : !!
602 : !! INPUTS
603 : !! n = Specifies the number of elements in vector x and y
604 : !! x,y = Input arrays.
605 : !!
606 : !! OUTPUT
607 : !! res(2)=Real and Imaginary part of the scalar product.
608 : !!
609 : !! SOURCE
610 :
611 0 : function cg_zdotu(n, x, y) result(res)
612 :
613 : !Arguments ------------------------------------
614 : !scalars
615 : integer,intent(in) :: n
616 : !arrays
617 : real(dp),intent(in) :: x(2,n)
618 : real(dp),intent(in) :: y(2,n)
619 : real(dp) :: res(2)
620 :
621 : !Local variables-------------------------------
622 : #ifdef HAVE_LINALG_ZDOTU_BUG
623 : integer :: ii
624 : #else
625 : complex(dp) :: cres
626 : complex(dp),external :: zdotu
627 : #endif
628 : ! *************************************************************************
629 :
630 : #ifdef HAVE_LINALG_ZDOTU_BUG
631 : ! Workaround for veclib on MacOSx
632 : res = zero
633 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:res)
634 : do ii=1,n
635 : res(1) = res(1) + x(1,ii)*y(1,ii) - x(2,ii)*y(2,ii)
636 : res(2) = res(2) + x(1,ii)*y(2,ii) + x(2,ii)*y(1,ii)
637 : end do
638 : #else
639 0 : cres = zdotu(n, x, 1, y, 1)
640 0 : res(1) = REAL(cres)
641 0 : res(2) = AIMAG(cres)
642 : #endif
643 :
644 0 : end function cg_zdotu
645 : !!***
646 :
647 : !----------------------------------------------------------------------
648 :
649 : !!****f* m_cgtools/cg_zaxpy
650 : !! NAME
651 : !! cg_zaxpy
652 : !!
653 : !! FUNCTION
654 : !! Computes y = alpha*x + y
655 : !!
656 : !! INPUTS
657 : !! n = Specifies the number of elements in vectors x and y.
658 : !! alpha = Specifies the scalar alpha.
659 : !! x = Array
660 : !!
661 : !! SIDE EFFECTS
662 : !! y = Array. In output, y contains the updated vector.
663 : !!
664 : !! SOURCE
665 :
666 55365521 : subroutine cg_zaxpy(n, alpha, x, y)
667 :
668 : !Arguments ------------------------------------
669 : !scalars
670 : integer,intent(in) :: n
671 : real(dp),intent(in) :: alpha(2)
672 : !arrays
673 : real(dp),intent(in) :: x(2*n)
674 : real(dp),intent(inout) :: y(2*n)
675 : ! *************************************************************************
676 :
677 55365521 : if (alpha(2) == zero) then
678 54763886 : call daxpy(2*n, alpha(1), x, 1, y, 1)
679 : else
680 601635 : call zaxpy(n, alpha, x, 1, y, 1)
681 : end if
682 :
683 55365521 : end subroutine cg_zaxpy
684 : !!***
685 :
686 : !----------------------------------------------------------------------
687 :
688 : !!****f* m_cgtools/cg_zaxpby
689 : !! NAME
690 : !! cg_zaxpby
691 : !!
692 : !! FUNCTION
693 : !! Scales two vectors, adds them to one another and stores result in the vector.
694 : !! y := a*x + b*y
695 : !!
696 : !! INPUTS
697 : !! n = the number of elements in vectors x and y.
698 : !! a = Specifies the scalar a.
699 : !! x = Array.
700 : !! b = Specifies the scalar b.
701 : !! y = Array
702 : !!
703 : !! OUTPUT
704 : !! y Contains the updated vector y.
705 : !!
706 : !! SOURCE
707 :
708 0 : subroutine cg_zaxpby(n, a, x, b, y)
709 :
710 : !Arguments ------------------------------------
711 : !scalars
712 : integer,intent(in) :: n
713 : real(dp),intent(in) :: a(2),b(2)
714 : !arrays
715 : real(dp),intent(in) :: x(2*n)
716 : real(dp),intent(inout) :: y(2*n)
717 : ! *************************************************************************
718 :
719 : #ifdef HAVE_LINALG_AXPBY
720 0 : call zaxpby(n, a, x, 1, b, y, 1)
721 : #else
722 : call zscal(n, b, y, 1)
723 : call zaxpy(n, a, x, 1, y,1)
724 : #endif
725 :
726 0 : end subroutine cg_zaxpby
727 : !!***
728 :
729 : !----------------------------------------------------------------------
730 :
731 : !!****f* m_cgtools/cg_zgemv
732 : !! NAME
733 : !! cg_zgemv
734 : !!
735 : !! FUNCTION
736 : !! The cg_zgemv routines perform a **complex** matrix-vector operation defined as:
737 : !!
738 : !! y := alpha*A*x + beta*y,
739 : !! or
740 : !! y := alpha*A'*x + beta*y,
741 : !! or
742 : !! y := alpha*conjg(A')*x + beta*y,
743 : !!
744 : !! where: alpha and beta are COMPLEX scalars, x and y are COMPLEX vectors, A is a m-by-n COMPLEX matrix.
745 : !! Default is: alpha = 1 and beta = 0.
746 : !!
747 : !! INPUTS
748 : !!
749 : !! OUTPUT
750 : !!
751 : !! SOURCE
752 :
753 115860950 : subroutine cg_zgemv(trans, nrows, ncols, cgmat, vec, matvec, alpha, beta, gpu_option)
754 :
755 : !Arguments ------------------------------------
756 : !scalars
757 : integer,intent(in) :: nrows, ncols
758 : real(dp),optional,intent(in) :: alpha(2), beta(2)
759 : character(len=1),intent(in) :: trans
760 : integer,optional,intent(in) :: gpu_option
761 : !arrays
762 : real(dp),intent(in), target :: cgmat(2,nrows*ncols), vec(2,*)
763 : real(dp),intent(inout), target :: matvec(2,*)
764 :
765 : !Local variables-------------------------------
766 : !scalars
767 : integer :: mm, nn, kk, lda, ldb, ldc, my_gpu_option
768 : real(dp) :: my_alpha(2), my_beta(2)
769 : complex(dp) :: my_calpha, my_cbeta
770 : ! *************************************************************************
771 :
772 115860950 : my_alpha = cg_cone; if (present(alpha)) my_alpha = alpha
773 115860950 : my_beta = cg_czero; if (present(beta)) my_beta = beta
774 115860950 : my_gpu_option = ABI_GPU_DISABLED; if (present(gpu_option)) my_gpu_option = gpu_option
775 :
776 115860950 : lda = nrows; mm = nrows; nn = 1; kk = ncols
777 115860950 : if (toupper(trans) /= 'N') then
778 173616877 : mm = ncols; kk = nrows
779 : end if
780 115860950 : ldb = kk; ldc = mm
781 :
782 : ! ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
783 :
784 115860950 : my_calpha = DCMPLX(my_alpha(1), my_alpha(2))
785 115860950 : my_cbeta = DCMPLX(my_beta(1), my_beta(2))
786 : call abi_xgemm(trans, "N", mm, nn, kk, my_calpha,&
787 : & cgmat, lda, &
788 : & vec, ldb, my_cbeta, &
789 : & matvec, ldc, &
790 115860950 : & x_cplx=2, gpu_option=my_gpu_option)
791 :
792 115860950 : end subroutine cg_zgemv
793 : !!***
794 :
795 : !----------------------------------------------------------------------
796 :
797 : !!****f* m_cgtools/cg_zgemm
798 : !! NAME
799 : !! cg_zgemm
800 : !!
801 : !! FUNCTION
802 : !! The cg_zgemm routines perform a matrix-matrix operation with general matrices.
803 : !! The operation is defined as C := alpha*op(A)*op(B) + beta*C, where:
804 : !!
805 : !! op(x) is one of op(x) = x, or op(x) = x', or op(x) = conjg(x'),
806 : !!
807 : !! alpha and beta are scalars,
808 : !! A, B and C are matrices:
809 : !! op(A) is an m-by-k matrix,
810 : !! op(B) is a k-by-n matrix,
811 : !! C is an m-by-n matrix.
812 : !!
813 : !! INPUTS
814 : !!
815 : !! OUTPUT
816 : !!
817 : !! SOURCE
818 :
819 38852 : subroutine cg_zgemm(transa, transb, npwsp, ncola, ncolb, cg_a, cg_b, cg_c, &
820 : alpha, beta) ! optional
821 :
822 : !Arguments ------------------------------------
823 : !scalars
824 : integer,intent(in) :: npwsp,ncola,ncolb
825 : character(len=1),intent(in) :: transa, transb
826 : real(dp),optional,intent(in) :: alpha(2), beta(2)
827 : !arrays
828 : real(dp),intent(in) :: cg_a(2,npwsp*ncola), cg_b(2,npwsp*ncolb)
829 : real(dp),intent(inout) :: cg_c(2,*)
830 :
831 : !Local variables-------------------------------
832 : !scalars
833 : integer :: mm,nn,kk,lda,ldb,ldc
834 : !real(dp) :: my_alpha(2),my_beta(2)
835 : complex(dp) :: my_calpha, my_cbeta
836 : ! *************************************************************************
837 :
838 38852 : lda = npwsp
839 38852 : ldb = npwsp
840 :
841 38852 : mm = npwsp
842 38852 : nn = ncolb
843 38852 : kk = ncola
844 :
845 38852 : if (toupper(transa) /= 'N') then
846 5745 : mm = ncola
847 44597 : kk = npwsp
848 : end if
849 38852 : if (toupper(transb) /= 'N') nn = npwsp
850 :
851 38852 : ldc = mm
852 :
853 : !my_alpha = cg_cone; if (PRESENT(alpha)) my_alpha = alpha
854 : !my_beta = cg_czero; if (PRESENT(beta)) my_beta = beta
855 : !call ZGEMM(transa, transb, mm, nn, kk, my_alpha, cg_a, lda, cg_b, ldb, my_beta, cg_c, ldc)
856 : !call ZGEMM3M(transa, transb, mm, nn, kk, my_alpha, cg_a, lda, cg_b, ldb, my_beta, cg_c, ldc)
857 :
858 38852 : my_calpha = cone; if (PRESENT(alpha)) my_calpha = DCMPLX(alpha(1), alpha(2))
859 38852 : my_cbeta = czero; if (PRESENT(beta)) my_cbeta = DCMPLX(beta(1), beta(2))
860 :
861 38852 : call abi_zgemm_2r(transa, transb, mm, nn, kk, my_calpha, cg_a, lda, cg_b, ldb, my_cbeta, cg_c, ldc)
862 :
863 38852 : end subroutine cg_zgemm
864 : !!***
865 :
866 : !!****f* m_cgtools/set_istwfk
867 : !! NAME
868 : !! set_istwfk
869 : !!
870 : !! FUNCTION
871 : !! Returns the value of istwfk associated to the input k-point.
872 : !!
873 : !! INPUTS
874 : !! kpoint(3)=The k-point in reduced coordinates.
875 : !!
876 : !! OUTPUT
877 : !! istwfk= Integer flag internally used in the code to define the storage mode of the wavefunctions.
878 : !! It also define the algorithm used to apply an operator in reciprocal space as well as the FFT
879 : !! algorithm used to go from G- to r-space and vice versa.
880 : !!
881 : !! 1 => time-reversal cannot be used
882 : !! 2 => use time-reversal at the Gamma point.
883 : !! 3 => use time-reversal symmetry for k=(1/2, 0 , 0 )
884 : !! 4 => use time-reversal symmetry for k=( 0 , 0 ,1/2)
885 : !! 5 => use time-reversal symmetry for k=(1/2, 0 ,1/2)
886 : !! 6 => use time-reversal symmetry for k=( 0 ,1/2, 0 )
887 : !! 7 => use time-reversal symmetry for k=(1/2,1/2, 0 )
888 : !! 8 => use time-reversal symmetry for k=( 0 ,1/2,1/2)
889 : !! 9 => use time-reversal symmetry for k=(1/2,1/2,1/2)
890 : !!
891 : !! Useful relations:
892 : !! u_k(G) = u_{k+G0}(G-G0); u_{-k}(-G) = u_k(G)^*
893 : !! and therefore:
894 : !! u_{G0/2}(G) = u_{G0/2}(-G-G0)^*.
895 : !!
896 : !! SOURCE
897 :
898 48638 : integer pure function set_istwfk(kpoint) result(istwfk)
899 :
900 : !Arguments ------------------------------------
901 : real(dp),intent(in) :: kpoint(3)
902 :
903 : !Local variables-------------------------------
904 : !scalars
905 : integer :: bit0,ii
906 : !arrays
907 : integer :: bit(3)
908 : ! *************************************************************************
909 :
910 48638 : bit0=1
911 :
912 194552 : do ii=1,3
913 194552 : if (DABS(kpoint(ii))<tol10) then
914 36698 : bit(ii)=0
915 109216 : else if (DABS(kpoint(ii)-half)<tol10 ) then
916 14409 : bit(ii)=1
917 : else
918 : bit0=0
919 : end if
920 : end do
921 :
922 48638 : if (bit0==0) then
923 : istwfk=1
924 : else
925 7674 : istwfk=2+bit(1)+4*bit(2)+2*bit(3) ! Note the inversion between bit(2) and bit(3)
926 : end if
927 :
928 48638 : end function set_istwfk
929 : !!***
930 :
931 : !!****f* m_cgtools/sqnorm_g
932 : !! NAME
933 : !! sqnorm_g
934 : !!
935 : !! FUNCTION
936 : !! Compute the square of the norm of one complex vector vecti, in reciprocal space
937 : !! Take into account the storage mode of the vector (istwf_k)
938 : !!
939 : !! INPUTS
940 : !! istwf_k=option parameter that describes the storage of wfs
941 : !! npwsp= (effective) number of planewaves at this k point.
942 : !! vect(2,npwsp)=the vector in reciprocal space (npw*nspinor, usually)
943 : !! me_g0=1 if this processors treats G=0, 0 otherwise.
944 : !! comm=MPI communicator for MPI sum.
945 : !!
946 : !! OUTPUT
947 : !! dotr= <vect|vect>
948 : !!
949 : !! SOURCE
950 :
951 36635488 : subroutine sqnorm_g(dotr, istwf_k, npwsp, vect, me_g0, comm)
952 :
953 : !Arguments ------------------------------------
954 : !scalars
955 : integer,intent(in) :: istwf_k,npwsp,me_g0,comm
956 : real(dp),intent(out) :: dotr
957 : !arrays
958 : real(dp),intent(in) :: vect(2,npwsp)
959 :
960 : !Local variables-------------------------------
961 : !scalars
962 : integer :: ierr
963 : ! *************************************************************************
964 :
965 36635488 : if (istwf_k==1) then ! General k-point
966 : !dotr = cg_real_zdotc(npwsp,vect,vect)
967 35172951 : dotr = cg_dznrm2(npwsp, vect)
968 35172951 : dotr = dotr * dotr
969 :
970 : else
971 1462537 : if (istwf_k == 2 .and. me_g0 == 1) then
972 : ! Gamma k-point and I have G=0
973 705476 : dotr=half*vect(1,1)**2
974 705476 : dotr = dotr + cg_real_zdotc(npwsp-1, vect(1,2), vect(1,2))
975 : else
976 : ! Other TR k-points
977 757061 : dotr = cg_real_zdotc(npwsp, vect, vect)
978 : end if
979 1462537 : dotr=two*dotr
980 : end if
981 :
982 36635488 : if (xmpi_comm_size(comm)>1) call xmpi_sum(dotr,comm,ierr)
983 :
984 36635488 : end subroutine sqnorm_g
985 : !!***
986 :
987 : !----------------------------------------------------------------------
988 :
989 : !!****f* m_cgtools/dotprod_g
990 : !! NAME
991 : !! dotprod_g
992 : !!
993 : !! FUNCTION
994 : !! Compute scalar product <vec1|vect2> of complex vectors vect1 and vect2 (can be the same)
995 : !! Take into account the storage mode of the vectors (istwf_k)
996 : !! If option=1, compute only real part, if option=2 compute also imaginary part.
997 : !! If the number of calls to the dot product scales quadratically
998 : !! with the volume of the system, it is preferable not to
999 : !! call the present routine, but but to write a specially
1000 : !! optimized routine, that will avoid many branches related to
1001 : !! the existence of 'option' and 'istwf_k'.
1002 : !!
1003 : !! INPUTS
1004 : !! istwf_k=option parameter that describes the storage of wfs
1005 : !! vect1(2,npw)=first vector (one should take its complex conjugate)
1006 : !! vect2(2,npw)=second vector
1007 : !! npw= (effective) number of planewaves at this k point (including spinorial level)
1008 : !! option= 1 if only real part to be computed,
1009 : !! 2 if both real and imaginary.
1010 : !! 3 if in case istwf_k==1 must compute real and imaginary parts,
1011 : !! but if istwf_k >1 must compute only real part
1012 : !! me_g0=1 if this processor treats G=0, 0 otherwise
1013 : !! comm=MPI communicator used to reduce the results.
1014 : !!
1015 : !! OUTPUT
1016 : !! $doti=\Im ( <vect1|vect2> )$ , output only if option=2 and eventually option=3.
1017 : !! $dotr=\Re ( <vect1|vect2> )$
1018 : !!
1019 : !! SOURCE
1020 :
1021 158437632 : subroutine dotprod_g(dotr, doti, istwf_k, npw, option, vect1, vect2, me_g0, comm)
1022 :
1023 : !Arguments ------------------------------------
1024 : !scalars
1025 : integer,intent(in) :: istwf_k,npw,option,me_g0,comm
1026 : real(dp),intent(out) :: doti,dotr
1027 : !arrays
1028 : real(dp),intent(in) :: vect1(2,npw),vect2(2,npw)
1029 :
1030 : !Local variables-------------------------------
1031 : integer :: ierr
1032 : real(dp) :: dotarr(2)
1033 : ! *************************************************************************
1034 :
1035 : ! Init results independently of option.
1036 158437632 : dotr = zero
1037 158437632 : doti = zero
1038 :
1039 158437632 : if (istwf_k==1) then
1040 : ! General k-point
1041 :
1042 154197038 : if(option==1)then
1043 127979561 : dotr = cg_real_zdotc(npw,vect1,vect2)
1044 : else
1045 26217477 : dotarr = cg_zdotc(npw,vect1,vect2)
1046 26217477 : dotr = dotarr(1)
1047 26217477 : doti = dotarr(2)
1048 : end if
1049 :
1050 4240594 : else if (istwf_k==2 .and. me_g0==1) then
1051 : ! Gamma k-point and I have G=0
1052 1969296 : dotr=half*vect1(1,1)*vect2(1,1)
1053 1969296 : dotr = dotr + cg_real_zdotc(npw-1,vect1(1,2),vect2(1,2))
1054 1969296 : dotr = two*dotr
1055 1969296 : if (option==2) doti=zero
1056 :
1057 : else
1058 : ! Other TR k-points
1059 2271298 : dotr = cg_real_zdotc(npw,vect1,vect2)
1060 2271298 : dotr=two*dotr
1061 2271298 : if (option==2) doti=zero
1062 : end if
1063 :
1064 : !Reduction in case of parallelism
1065 158437632 : if (xmpi_comm_size(comm) > 1) then
1066 1152 : if (option==1.or.istwf_k/=1) then
1067 1152 : call xmpi_sum(dotr,comm,ierr)
1068 : else
1069 0 : dotarr(1)=dotr ; dotarr(2)=doti
1070 0 : call xmpi_sum(dotarr,comm,ierr)
1071 0 : dotr=dotarr(1) ; doti=dotarr(2)
1072 : end if
1073 : end if
1074 :
1075 158437632 : end subroutine dotprod_g
1076 : !!***
1077 :
1078 : !----------------------------------------------------------------------
1079 :
1080 : !!****f* m_cgtools/dotprod_g_batch
1081 : !! NAME
1082 : !! dotprod_g_batch
1083 : !!
1084 : !! FUNCTION
1085 : !! Compute scalar product <vec1|vect2> of complex vectors vect1 and vect2 (can be the same)
1086 : !! Take into account the storage mode of the vectors (istwf_k)
1087 : !! If option=1, compute only real part, if option=2 compute also imaginary part.
1088 : !! If the number of calls to the dot product scales quadratically
1089 : !! with the volume of the system, it is preferable not to
1090 : !! call the present routine, but but to write a specially
1091 : !! optimized routine, that will avoid many branches related to
1092 : !! the existence of 'option' and 'istwf_k'.
1093 : !!
1094 : !! INPUTS
1095 : !! istwf_k=option parameter that describes the storage of wfs
1096 : !! vect1(2,npw)=first vector (one should take its complex conjugate)
1097 : !! vect2(2,npw)=second vector
1098 : !! npw= (effective) number of planewaves at this k point (including spinorial level)
1099 : !! option= 1 if only real part to be computed,
1100 : !! 2 if both real and imaginary.
1101 : !! 3 if in case istwf_k==1 must compute real and imaginary parts,
1102 : !! but if istwf_k >1 must compute only real part
1103 : !! me_g0=1 if this processor treats G=0, 0 otherwise
1104 : !! comm=MPI communicator used to reduce the results.
1105 : !!
1106 : !! OUTPUT
1107 : !! $doti=\Im ( <vect1|vect2> )$ , output only if option=2 and eventually option=3.
1108 : !! $dotr=\Re ( <vect1|vect2> )$
1109 : !!
1110 : !! SOURCE
1111 :
1112 250126 : subroutine dotprod_g_batch_half(dotr, doti, istwf_k, npw, ndat, option, vect1, vect2, me_g0, comm, gpu_option)
1113 :
1114 : !Arguments ------------------------------------
1115 : !scalars
1116 : integer,intent(in) :: istwf_k,npw,ndat,option,me_g0,comm
1117 : integer,optional,intent(in) :: gpu_option
1118 : real(dp),target,intent(out) :: doti(ndat),dotr(ndat)
1119 : !arrays
1120 : real(dp),target,intent(in) :: vect1(2,npw),vect2(2,npw,ndat)
1121 :
1122 : !Local variables-------------------------------
1123 : integer :: ierr,idat,ii,l_gpu_option
1124 : real(dp) :: dotarr(2)
1125 : ! *************************************************************************
1126 :
1127 250126 : l_gpu_option=ABI_GPU_DISABLED; if(present(gpu_option)) l_gpu_option = gpu_option
1128 : ! Init results independently of option.
1129 250126 : if(l_gpu_option==ABI_GPU_DISABLED) then
1130 4596124 : dotr = zero; doti = zero
1131 : else if(l_gpu_option==ABI_GPU_OPENMP) then
1132 : #ifdef HAVE_OPENMP_OFFLOAD
1133 : call gpu_set_to_zero(dotr,int(ndat,c_size_t))
1134 : call gpu_set_to_zero(doti,int(ndat,c_size_t))
1135 : #endif
1136 : end if
1137 :
1138 250126 : if (istwf_k==1) then
1139 : ! General k-point
1140 :
1141 249990 : if(option==1)then
1142 : #ifdef HAVE_OPENMP_OFFLOAD
1143 : !$OMP TARGET TEAMS DISTRIBUTE PRIVATE(idat,dotarr) MAP(to:vect1,vect2,dotr) &
1144 : !$OMP& IF(l_gpu_option==ABI_GPU_OPENMP)
1145 : #endif
1146 0 : do idat=1,ndat
1147 0 : dotarr = zero
1148 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotarr)
1149 0 : do ii=1,npw
1150 0 : dotarr(1) = dotarr(1) + vect1(1,ii)*vect2(1,ii,idat) + vect1(2,ii)*vect2(2,ii,idat)
1151 : end do
1152 0 : dotr(idat) = dotarr(1)
1153 : end do
1154 : else
1155 : #ifdef HAVE_OPENMP_OFFLOAD
1156 : !$OMP TARGET TEAMS DISTRIBUTE PRIVATE(idat,dotarr) MAP(to:vect1,vect2,dotr,doti) &
1157 : !$OMP& IF(l_gpu_option==ABI_GPU_OPENMP)
1158 : #endif
1159 2297790 : do idat=1,ndat
1160 : dotarr = zero
1161 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotarr)
1162 403324894 : do ii=1,npw
1163 401277094 : dotarr(1) = dotarr(1) + vect1(1,ii)*vect2(1,ii,idat) + vect1(2,ii)*vect2(2,ii,idat)
1164 403324894 : dotarr(2) = dotarr(2) + vect1(1,ii)*vect2(2,ii,idat) - vect1(2,ii)*vect2(1,ii,idat)
1165 : end do
1166 2047800 : dotr(idat) = dotarr(1)
1167 2297790 : doti(idat) = dotarr(2)
1168 : end do
1169 : end if
1170 :
1171 136 : else if (istwf_k==2 .and. me_g0==1) then
1172 : ! Gamma k-point and I have G=0
1173 : #ifdef HAVE_OPENMP_OFFLOAD
1174 : !$OMP TARGET TEAMS DISTRIBUTE PRIVATE(idat,dotarr) MAP(to:vect1,vect2,dotr) &
1175 : !$OMP& IF(l_gpu_option==ABI_GPU_OPENMP)
1176 : #endif
1177 272 : do idat=1,ndat
1178 136 : dotarr = zero
1179 136 : dotr(idat)=half*vect1(1,1)*vect2(1,1,idat)
1180 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotarr)
1181 410176 : do ii=2,npw
1182 410176 : dotarr(1) = dotarr(1) + vect1(1,ii)*vect2(1,ii,idat) + vect1(2,ii)*vect2(2,ii,idat)
1183 : end do
1184 272 : dotr(idat) = + two * (dotr(idat)+dotarr(1))
1185 : end do
1186 408 : if (option==2) doti=zero
1187 :
1188 : else
1189 : ! Other TR k-points
1190 : #ifdef HAVE_OPENMP_OFFLOAD
1191 : !$OMP TARGET TEAMS DISTRIBUTE PRIVATE(idat,dotarr) MAP(to:vect1,vect2,dotr) &
1192 : !$OMP& IF(l_gpu_option==ABI_GPU_OPENMP)
1193 : #endif
1194 0 : do idat=1,ndat
1195 0 : dotarr = zero
1196 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotarr)
1197 0 : do ii=1,npw
1198 0 : dotarr(1) = dotarr(1) + vect1(1,ii)*vect2(1,ii,idat) + vect1(2,ii)*vect2(2,ii,idat)
1199 : end do
1200 0 : dotr(idat) = two * dotarr(1)
1201 : end do
1202 0 : if (option==2) doti=zero
1203 : end if
1204 :
1205 : !Reduction in case of parallelism
1206 250126 : if (xmpi_comm_size(comm) > 1) then
1207 0 : if (option==1.or.istwf_k/=1) then
1208 : #ifdef HAVE_OPENMP_OFFLOAD
1209 : !$OMP TARGET UPDATE FROM(dotr) IF(l_gpu_option==ABI_GPU_OPENMP)
1210 : #endif
1211 0 : call xmpi_sum(dotr,comm,ierr)
1212 : #ifdef HAVE_OPENMP_OFFLOAD
1213 : !$OMP TARGET UPDATE TO(dotr) IF(l_gpu_option==ABI_GPU_OPENMP)
1214 : #endif
1215 : else
1216 : #ifdef HAVE_OPENMP_OFFLOAD
1217 : !$OMP TARGET UPDATE FROM(dotr,doti) IF(l_gpu_option==ABI_GPU_OPENMP)
1218 : #endif
1219 0 : call xmpi_sum(dotr,comm,ierr)
1220 0 : call xmpi_sum(doti,comm,ierr)
1221 : #ifdef HAVE_OPENMP_OFFLOAD
1222 : !$OMP TARGET UPDATE TO(dotr,doti) IF(l_gpu_option==ABI_GPU_OPENMP)
1223 : #endif
1224 : end if
1225 : end if
1226 :
1227 250126 : end subroutine dotprod_g_batch_half
1228 : !!***
1229 :
1230 :
1231 798444 : subroutine dotprod_g_batch_full(dotr, doti, istwf_k, npw, ndat, option, vect1, vect2, me_g0, comm, gpu_option)
1232 :
1233 : !Arguments ------------------------------------
1234 : !scalars
1235 : integer,intent(in) :: istwf_k,npw,ndat,option,me_g0,comm
1236 : integer,optional,intent(in) :: gpu_option
1237 : real(dp),target,intent(out) :: doti(ndat),dotr(ndat)
1238 : !arrays
1239 : real(dp),target,intent(in) :: vect1(2,npw,ndat),vect2(2,npw,ndat)
1240 :
1241 : !Local variables-------------------------------
1242 : integer :: ierr,idat,ii,l_gpu_option
1243 : real(dp) :: dotarr(2)
1244 : ! *************************************************************************
1245 :
1246 798444 : l_gpu_option=ABI_GPU_DISABLED; if(present(gpu_option)) l_gpu_option = gpu_option
1247 : ! Init results independently of option.
1248 798444 : if(l_gpu_option==ABI_GPU_DISABLED) then
1249 3359820 : dotr = zero; doti = zero
1250 : else if(l_gpu_option==ABI_GPU_OPENMP) then
1251 : #ifdef HAVE_OPENMP_OFFLOAD
1252 : call gpu_set_to_zero(dotr,int(ndat,c_size_t))
1253 : call gpu_set_to_zero(doti,int(ndat,c_size_t))
1254 : #endif
1255 : end if
1256 :
1257 798444 : if (istwf_k==1) then
1258 : ! General k-point
1259 :
1260 798006 : if(option==1)then
1261 : #ifdef HAVE_OPENMP_OFFLOAD
1262 : !$OMP TARGET TEAMS DISTRIBUTE PRIVATE(idat,dotarr) MAP(to:vect1,vect2,dotr) &
1263 : !$OMP& IF(l_gpu_option==ABI_GPU_OPENMP)
1264 : #endif
1265 2850 : do idat=1,ndat
1266 1284852 : dotarr = zero
1267 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotarr)
1268 1284852 : do ii=1,npw
1269 1284852 : dotarr(1) = dotarr(1) + vect1(1,ii,idat)*vect2(1,ii,idat) + vect1(2,ii,idat)*vect2(2,ii,idat)
1270 : end do
1271 2850 : dotr(idat) = dotarr(1)
1272 : end do
1273 : else
1274 : #ifdef HAVE_OPENMP_OFFLOAD
1275 : !$OMP TARGET TEAMS DISTRIBUTE PRIVATE(idat,dotarr) MAP(to:vect1,vect2,dotr,doti) &
1276 : !$OMP& IF(l_gpu_option==ABI_GPU_OPENMP)
1277 : #endif
1278 1675842 : do idat=1,ndat
1279 : dotarr = zero
1280 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotarr)
1281 177579132 : do ii=1,npw
1282 176700162 : dotarr(1) = dotarr(1) + vect1(1,ii,idat)*vect2(1,ii,idat) + vect1(2,ii,idat)*vect2(2,ii,idat)
1283 177579132 : dotarr(2) = dotarr(2) + vect1(1,ii,idat)*vect2(2,ii,idat) - vect1(2,ii,idat)*vect2(1,ii,idat)
1284 : end do
1285 878970 : dotr(idat) = dotarr(1)
1286 1675842 : doti(idat) = dotarr(2)
1287 : end do
1288 : end if
1289 :
1290 438 : else if (istwf_k==2 .and. me_g0==1) then
1291 : ! Gamma k-point and I have G=0
1292 : #ifdef HAVE_OPENMP_OFFLOAD
1293 : !$OMP TARGET TEAMS DISTRIBUTE PRIVATE(idat,dotarr) MAP(to:vect1,vect2,dotr) &
1294 : !$OMP& IF(l_gpu_option==ABI_GPU_OPENMP)
1295 : #endif
1296 738 : do idat=1,ndat
1297 540 : dotarr = zero
1298 540 : dotr(idat)=half*vect1(1,1,idat)*vect2(1,1,idat)
1299 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotarr)
1300 466188 : do ii=2,npw
1301 466188 : dotarr(1) = dotarr(1) + vect1(1,ii,idat)*vect2(1,ii,idat) + vect1(2,ii,idat)*vect2(2,ii,idat)
1302 : end do
1303 738 : dotr(idat) = + two * (dotr(idat)+dotarr(1))
1304 : end do
1305 198 : if (option==2) doti=zero
1306 :
1307 : else
1308 : ! Other TR k-points
1309 : #ifdef HAVE_OPENMP_OFFLOAD
1310 : !$OMP TARGET TEAMS DISTRIBUTE PRIVATE(idat,dotarr) MAP(to:vect1,vect2,dotr) &
1311 : !$OMP& IF(l_gpu_option==ABI_GPU_OPENMP)
1312 : #endif
1313 480 : do idat=1,ndat
1314 66480 : dotarr = zero
1315 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotarr)
1316 66480 : do ii=1,npw
1317 66480 : dotarr(1) = dotarr(1) + vect1(1,ii,idat)*vect2(1,ii,idat) + vect1(2,ii,idat)*vect2(2,ii,idat)
1318 : end do
1319 480 : dotr(idat) = two * dotarr(1)
1320 : end do
1321 240 : if (option==2) doti=zero
1322 : end if
1323 :
1324 : !Reduction in case of parallelism
1325 798444 : if (xmpi_comm_size(comm) > 1) then
1326 0 : if (option==1.or.istwf_k/=1) then
1327 : #ifdef HAVE_OPENMP_OFFLOAD
1328 : !$OMP TARGET UPDATE FROM(dotr) IF(l_gpu_option==ABI_GPU_OPENMP)
1329 : #endif
1330 0 : call xmpi_sum(dotr,comm,ierr)
1331 : #ifdef HAVE_OPENMP_OFFLOAD
1332 : !$OMP TARGET UPDATE TO(dotr) IF(l_gpu_option==ABI_GPU_OPENMP)
1333 : #endif
1334 : else
1335 : #ifdef HAVE_OPENMP_OFFLOAD
1336 : !$OMP TARGET UPDATE FROM(dotr,doti) IF(l_gpu_option==ABI_GPU_OPENMP)
1337 : #endif
1338 0 : call xmpi_sum(dotr,comm,ierr)
1339 0 : call xmpi_sum(doti,comm,ierr)
1340 : #ifdef HAVE_OPENMP_OFFLOAD
1341 : !$OMP TARGET UPDATE TO(dotr,doti) IF(l_gpu_option==ABI_GPU_OPENMP)
1342 : #endif
1343 : end if
1344 : end if
1345 :
1346 798444 : end subroutine dotprod_g_batch_full
1347 : !!***
1348 :
1349 : !----------------------------------------------------------------------
1350 :
1351 : !!****f* m_cgtools/matrixelmt_g
1352 : !! NAME
1353 : !! matrixelmt_g
1354 : !!
1355 : !! FUNCTION
1356 : !! Compute a matrix element of two wavefunctions, in reciprocal space,
1357 : !! for an operator that is diagonal in reciprocal space: <wf1|op|wf2>
1358 : !! For the time being, only spin-independent operators are treated.
1359 : !!
1360 : !! INPUTS
1361 : !! diag(npw)=diagonal operator (real, spin-independent !)
1362 : !! istwf_k=storage mode of the vectors
1363 : !! needimag=0 if the imaginary part is not needed ; 1 if the imaginary part is needed
1364 : !! npw=number of planewaves of the first vector
1365 : !! nspinor=number of spinor components
1366 : !! vect1(2,npw*nspinor)=first vector
1367 : !! vect2(2,npw*nspinor)=second vector
1368 : !! comm_fft=MPI communicator for the FFT
1369 : !! me_g0=1 if this processors treats the G=0 component.
1370 : !!
1371 : !! OUTPUT
1372 : !! ai=imaginary part of the matrix element
1373 : !! ar=real part of the matrix element
1374 : !!
1375 : !! SOURCE
1376 :
1377 961896 : subroutine matrixelmt_g(ai,ar,diag,istwf_k,needimag,npw,nspinor,vect1,vect2,me_g0,comm_fft)
1378 :
1379 : !Arguments ------------------------------------
1380 : !scalars
1381 : integer,intent(in) :: istwf_k,needimag,npw,nspinor,me_g0,comm_fft
1382 : real(dp),intent(out) :: ai,ar
1383 : !arrays
1384 : real(dp),intent(in) :: diag(npw),vect1(2,npw*nspinor),vect2(2,npw*nspinor)
1385 :
1386 : !Local variables-------------------------------
1387 : !scalars
1388 : integer :: i1,ierr,ipw
1389 : character(len=500) :: msg
1390 : !arrays
1391 : real(dp) :: buffer2(2)
1392 : !real(dp),allocatable :: re_prod(:), im_prod(:)
1393 : ! *************************************************************************
1394 :
1395 961896 : if (nspinor==2 .and. istwf_k/=1) then
1396 : write(msg,'(a,a,a,i6,a,i6)')&
1397 0 : 'When istwf_k/=1, nspinor must be 1,',ch10,&
1398 0 : 'however, nspinor=',nspinor,', and istwf_k=',istwf_k
1399 0 : ABI_BUG(msg)
1400 : end if
1401 :
1402 : #if 0
1403 : !TODO
1404 : ABI_MALLOC(re_prod,(npw*nspinor))
1405 : do ipw=1,npw*nspinor
1406 : re_prod(ipw) = vect1(1,ipw)*vect2(1,ipw) + vect1(2,ipw)*vect2(2,ipw)
1407 : end do
1408 :
1409 : if (needimag == 1) then
1410 : ABI_MALLOC(im_prod,(npw*nspinor))
1411 : do ipw=1,npw*nspinor
1412 : im_prod(ipw) = vect1(1,ipw)*vect2(2,ipw) - vect1(2,ipw)*vect2(1,ipw)
1413 : end do
1414 : end if
1415 : #endif
1416 :
1417 961896 : ar=zero
1418 961896 : if(needimag==1)ai=zero
1419 :
1420 : !Normal storage mode
1421 961896 : if(istwf_k==1)then
1422 :
1423 : ! Need only real part
1424 961896 : if(needimag==0)then
1425 :
1426 136152688 : do ipw=1,npw
1427 136152688 : ar=ar+diag(ipw)*(vect1(1,ipw)*vect2(1,ipw)+vect1(2,ipw)*vect2(2,ipw))
1428 : end do
1429 :
1430 961896 : if(nspinor==2)then
1431 6365472 : do ipw=1+npw,2*npw
1432 6365472 : ar=ar+diag(ipw-npw)*(vect1(1,ipw)*vect2(1,ipw)+vect1(2,ipw)*vect2(2,ipw))
1433 : end do
1434 : end if
1435 :
1436 : else ! Need also the imaginary part
1437 :
1438 0 : do ipw=1,npw
1439 0 : ar=ar+diag(ipw)*(vect1(1,ipw)*vect2(1,ipw)+vect1(2,ipw)*vect2(2,ipw))
1440 0 : ai=ai+diag(ipw)*(vect1(1,ipw)*vect2(2,ipw)-vect1(2,ipw)*vect2(1,ipw))
1441 : end do
1442 :
1443 0 : if(nspinor==2)then
1444 0 : do ipw=1+npw,2*npw
1445 0 : ar=ar+diag(ipw-npw)*(vect1(1,ipw)*vect2(1,ipw)+vect1(2,ipw)*vect2(2,ipw))
1446 0 : ai=ai+diag(ipw-npw)*(vect1(1,ipw)*vect2(2,ipw)-vect1(2,ipw)*vect2(1,ipw))
1447 : end do
1448 : end if
1449 :
1450 : end if ! needimag
1451 :
1452 0 : else if(istwf_k>=2)then
1453 :
1454 : ! XG030513 : MPIWF need to know which proc has G=0
1455 :
1456 0 : i1=1
1457 0 : if(istwf_k==2 .and. me_g0==1)then
1458 0 : ar=half*diag(1)*vect1(1,1)*vect2(1,1) ; i1=2
1459 : end if
1460 :
1461 : ! Need only real part
1462 0 : if(needimag==0)then
1463 :
1464 0 : do ipw=i1,npw
1465 0 : ar=ar+diag(ipw)*(vect1(1,ipw)*vect2(1,ipw)+vect1(2,ipw)*vect2(2,ipw))
1466 : end do
1467 0 : ar=two*ar
1468 :
1469 : else ! Need also the imaginary part
1470 :
1471 0 : do ipw=i1,npw
1472 0 : ar=ar+diag(ipw)*(vect1(1,ipw)*vect2(1,ipw)+vect1(2,ipw)*vect2(2,ipw))
1473 0 : ai=ai+diag(ipw)*(vect1(1,ipw)*vect2(2,ipw)-vect1(2,ipw)*vect2(1,ipw))
1474 : end do
1475 0 : ar=two*ar ; ai=two*ai
1476 :
1477 : end if
1478 :
1479 : end if ! istwf_k
1480 :
1481 : #if 0
1482 : ABI_FREE(re_prod)
1483 : if (needimag == 1) then
1484 : ABI_FREE(im_prod)
1485 : end if
1486 : #endif
1487 :
1488 : !MPIWF need to make reduction on ar and ai .
1489 961896 : if (xmpi_comm_size(comm_fft)>1) then
1490 0 : buffer2(1)=ai
1491 0 : buffer2(2)=ar
1492 0 : call xmpi_sum(buffer2,comm_fft ,ierr)
1493 0 : ai=buffer2(1)
1494 0 : ar=buffer2(2)
1495 : end if
1496 :
1497 961896 : end subroutine matrixelmt_g
1498 : !!***
1499 :
1500 : !----------------------------------------------------------------------
1501 :
1502 : !!****f* m_cgtools/dotprod_v
1503 : !! NAME
1504 : !! dotprod_v
1505 : !!
1506 : !! FUNCTION
1507 : !! Compute dot product of two potentials (integral over FFT grid), to obtain
1508 : !! a square residual-like quantity (so the sum of product of values
1509 : !! is NOT divided by the number of FFT points, and NOT multiplied by the primitive cell volume).
1510 : !! Take into account the spin components of the potentials (nspden), and sum over them.
1511 : !!
1512 : !! INPUTS
1513 : !! cplex=if 1, real space functions on FFT grid are REAL, if 2, COMPLEX
1514 : !! nfft= (effective) number of FFT grid points (for this processor)
1515 : !! nspden=number of spin-density components
1516 : !! opt_storage: 0, if potentials are stored as V^up-up, V^dn-dn, Re[V^up-dn], Im[V^up-dn]
1517 : !! 1, if potentials are stored as V, B_x, B_y, Bz (B=magn. field)
1518 : !! pot1(cplex*nfft,nspden)=first real space potential on FFT grid
1519 : !! pot2(cplex*nfft,nspden)=second real space potential on FFT grid
1520 : !! comm=MPI communicator in which results will be reduced.
1521 : !!
1522 : !! OUTPUT
1523 : !! dotr= value of the dot product
1524 : !!
1525 : !! SOURCE
1526 :
1527 55 : subroutine dotprod_v(cplex,dotr,nfft,nspden,opt_storage,pot1,pot2,comm)
1528 :
1529 : !Arguments ------------------------------------
1530 : !scalars
1531 : integer,intent(in) :: cplex,nfft,nspden,opt_storage,comm
1532 : real(dp),intent(out) :: dotr
1533 : !arrays
1534 : real(dp),intent(in) :: pot1(cplex*nfft,nspden),pot2(cplex*nfft,nspden)
1535 :
1536 : !Local variables-------------------------------
1537 : !scalars
1538 : integer :: ierr,ifft,ispden
1539 : real(dp) :: ar
1540 : !arrays
1541 : ! *************************************************************************
1542 :
1543 : !Real or complex inputs are coded
1544 :
1545 55 : dotr=zero
1546 : !$OMP PARALLEL DO COLLAPSE(2) REDUCTION(+:dotr)
1547 110 : do ispden=1,min(nspden,2)
1548 1085038 : do ifft=1,cplex*nfft
1549 1084983 : dotr =dotr + pot1(ifft,ispden)*pot2(ifft,ispden)
1550 : end do
1551 : end do
1552 :
1553 55 : if (nspden==4) then
1554 : ar=zero
1555 : !$OMP PARALLEL DO COLLAPSE(2) REDUCTION(+:ar)
1556 0 : do ispden=3,4
1557 0 : do ifft=1,cplex*nfft
1558 0 : ar = ar + pot1(ifft,ispden)*pot2(ifft,ispden)
1559 : end do
1560 : end do
1561 :
1562 0 : if (opt_storage==0) then
1563 0 : if (cplex==1) then
1564 0 : dotr = dotr+two*ar
1565 : else
1566 0 : dotr = dotr+ar
1567 : end if
1568 : else
1569 0 : dotr = half*(dotr+ar)
1570 : end if
1571 : end if
1572 :
1573 : !MPIWF reduction (addition) on dotr is needed here
1574 55 : if (xmpi_comm_size(comm)>1) then
1575 0 : call xmpi_sum(dotr,comm,ierr)
1576 : end if
1577 :
1578 55 : end subroutine dotprod_v
1579 : !!***
1580 :
1581 : !!****f* m_cgtools/dotprod_vn
1582 : !! NAME
1583 : !! dotprod_vn
1584 : !!
1585 : !! FUNCTION
1586 : !! Compute dot product of potential and density (integral over FFT grid), to obtain
1587 : !! an energy-like quantity (so the usual dotproduct is divided
1588 : !! by the number of FFT points, and multiplied by the primitive cell volume).
1589 : !! Take into account the spin components of the density and potentials (nspden),
1590 : !! and sum correctly over them. Note that the storage of densities and
1591 : !! potentials is different : for potential, one stores the matrix components,
1592 : !! while for the density, one stores the trace, and then, either the
1593 : !! up component (if nspden=2), or the magnetization vector (if nspden=4).
1594 : !!
1595 : !! INPUTS
1596 : !! cplex=if 1, real space functions on FFT grid are REAL, if 2, COMPLEX
1597 : !! dens(cplex*nfft,nspden)=real space density on FFT grid
1598 : !! mpi_enreg=information about MPI parallelization
1599 : !! nfft= (effective) number of FFT grid points (for this processor)
1600 : !! nfftot= total number of FFT grid points
1601 : !! nspden=number of spin-density components
1602 : !! option= if 1, only the real part is computed
1603 : !! if 2, both real and imaginary parts are computed (not yet coded)
1604 : !! pot(cplex*nfft,nspden)=real space potential on FFT grid
1605 : !! (will be complex conjugated if cplex=2 and option=2)
1606 : !! ucvol=unit cell volume (Bohr**3)
1607 : !!
1608 : !! OUTPUT
1609 : !! doti= imaginary part of the dot product, output only if option=2 (and cplex=2).
1610 : !! dotr= real part
1611 : !!
1612 : !! NOTES
1613 : !! Concerning storage when nspden=4:
1614 : !! cplex=1:
1615 : !! V is stored as : V^11, V^22, Re[V^12], Im[V^12] (complex, hermitian)
1616 : !! N is stored as : n, m_x, m_y, m_z (real)
1617 : !! cplex=2:
1618 : !! V is stored as : V^11, V^22, V^12, i.V^21 (complex)
1619 : !! N is stored as : n, m_x, m_y, mz (complex)
1620 : !!
1621 : !! SOURCE
1622 :
1623 224776 : subroutine dotprod_vn(cplex,dens,dotr,doti,nfft,nfftot,nspden,option,pot,ucvol, &
1624 : mpi_comm_sphgrid) ! Optional
1625 :
1626 : !Arguments ------------------------------------
1627 : !scalars
1628 : integer,intent(in) :: cplex,nfft,nfftot,nspden,option
1629 : integer,intent(in),optional :: mpi_comm_sphgrid
1630 : real(dp),intent(in) :: ucvol
1631 : real(dp),intent(out) :: doti,dotr
1632 : !arrays
1633 : real(dp),intent(in) :: dens(cplex*nfft,nspden),pot(cplex*nfft,nspden)
1634 :
1635 : !Local variables-------------------------------
1636 : !scalars
1637 : integer :: ierr,ifft,jfft
1638 : real(dp) :: dim11,dim12,dim21,dim22,dim_dn,dim_up,dre11,dre12,dre21,dre22
1639 : real(dp) :: dre_dn,dre_up,factor,nproc_sphgrid,pim11,pim12,pim21,pim22,pim_dn,pim_up,pre11
1640 : real(dp) :: pre12,pre21,pre22,pre_dn,pre_up
1641 : real(dp) :: bx_re,bx_im,by_re,by_im,bz_re,bz_im,v0_re,v0_im
1642 : !arrays
1643 : real(dp) :: buffer2(2)
1644 : ! *************************************************************************
1645 :
1646 : !Real or complex inputs are coded
1647 : DBG_CHECK(ANY(cplex==(/1,2/)),"Wrong cplex")
1648 : DBG_CHECK(ANY(nspden==(/1,2,4/)),"Wrong nspden")
1649 :
1650 : !Real or complex output are coded
1651 : DBG_CHECK(ANY(option==(/1,2/)),"Wrong option")
1652 :
1653 224776 : dotr=zero; doti=zero
1654 :
1655 224776 : if(nspden==1)then
1656 :
1657 216070 : if(option==1 .or. cplex==1 )then
1658 : !$OMP PARALLEL DO REDUCTION(+:dotr)
1659 4437007528 : do ifft=1,cplex*nfft
1660 4437007528 : dotr=dotr + pot(ifft,1)*dens(ifft,1)
1661 : end do
1662 : ! dotr = ddot(cplex*nfft,pot,1,dens,1)
1663 :
1664 : else ! option==2 and cplex==2 : one builds the imaginary part, from complex den/pot
1665 :
1666 : !$OMP PARALLEL DO PRIVATE(jfft) REDUCTION(+:dotr,doti)
1667 63849666 : do ifft=1,nfft
1668 63842316 : jfft=2*ifft
1669 63842316 : dotr=dotr + pot(jfft-1,1)*dens(jfft-1,1) + pot(jfft,1)*dens(jfft ,1)
1670 63849666 : doti=doti + pot(jfft-1,1)*dens(jfft ,1) - pot(jfft,1)*dens(jfft-1,1)
1671 : end do
1672 :
1673 : end if
1674 :
1675 8706 : else if(nspden==2)then
1676 :
1677 6672 : if(option==1 .or. cplex==1 )then
1678 : !$OMP PARALLEL DO REDUCTION(+:dotr)
1679 117100369 : do ifft=1,cplex*nfft
1680 : dotr=dotr + pot(ifft,1)* dens(ifft,2) & ! This is the spin up contribution
1681 117100369 : & + pot(ifft,2)*(dens(ifft,1)-dens(ifft,2)) ! This is the spin down contribution
1682 : end do
1683 :
1684 : else ! option==2 and cplex==2 : one builds the imaginary part, from complex den/pot
1685 :
1686 : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(nfft,dens,pot) REDUCTION(+:dotr,doti)
1687 289248 : do ifft=1,nfft
1688 :
1689 289188 : jfft=2*ifft
1690 289188 : dre_up=dens(jfft-1,2)
1691 289188 : dim_up=dens(jfft ,2)
1692 289188 : dre_dn=dens(jfft-1,1)-dre_up
1693 289188 : dim_dn=dens(jfft ,1)-dim_up
1694 289188 : pre_up=pot(jfft-1,1)
1695 289188 : pim_up=pot(jfft ,1)
1696 289188 : pre_dn=pot(jfft-1,2)
1697 289188 : pim_dn=pot(jfft ,2)
1698 :
1699 : dotr=dotr + pre_up * dre_up &
1700 : & + pim_up * dim_up &
1701 : & + pre_dn * dre_dn &
1702 289188 : & + pim_dn * dim_dn
1703 : doti=doti + pre_up * dim_up &
1704 : & - pim_up * dre_up &
1705 : & + pre_dn * dim_dn &
1706 289248 : & - pim_dn * dre_dn
1707 :
1708 : end do
1709 : end if
1710 :
1711 2034 : else if(nspden==4)then
1712 : ! \rho{\alpha,\beta} V^{\alpha,\beta} =
1713 : ! rho*(V^{11}+V^{22})/2$
1714 : ! + m_x Re(V^{12})- m_y Im{V^{12}}+ m_z(V^{11}-V^{22})/2
1715 2034 : if (cplex==1) then
1716 : !$OMP PARALLEL DO PRIVATE(ifft) SHARED(nfft,dens,pot) REDUCTION(+:dotr)
1717 16638775 : do ifft=1,nfft
1718 : dotr=dotr + &
1719 : & (pot(ifft,1) + pot(ifft,2))*half*dens(ifft,1) & ! This is the density contrib
1720 : & + pot(ifft,3) *dens(ifft,2) & ! This is the m_x contrib
1721 : & - pot(ifft,4) *dens(ifft,3) & ! This is the m_y contrib
1722 16638775 : & +(pot(ifft,1) - pot(ifft,2))*half*dens(ifft,4) ! This is the m_z contrib
1723 : end do
1724 : else ! cplex=2
1725 : ! Note concerning storage when cplex=2:
1726 : ! V is stored as : v^11, v^22, V^12, i.V^21 (each are complex)
1727 : ! N is stored as : n, m_x, m_y, mZ (each are complex)
1728 528 : if (option==1) then
1729 : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(nfft,dens,pot) REDUCTION(+:dotr)
1730 1732830 : do ifft=1,nfft
1731 1732608 : jfft=2*ifft
1732 1732608 : dre11=half*(dens(jfft-1,1)+dens(jfft-1,4))
1733 1732608 : dim11=half*(dens(jfft ,1)+dens(jfft-1,4))
1734 1732608 : dre22=half*(dens(jfft-1,1)-dens(jfft-1,4))
1735 1732608 : dim22=half*(dens(jfft ,1)-dens(jfft-1,4))
1736 1732608 : dre12=half*(dens(jfft-1,2)+dens(jfft ,3))
1737 1732608 : dim12=half*(dens(jfft ,2)-dens(jfft-1,3))
1738 1732608 : dre21=half*(dens(jfft-1,2)-dens(jfft ,3))
1739 1732608 : dim21=half*(dens(jfft ,2)+dens(jfft-1,3))
1740 1732608 : pre11= pot(jfft-1,1)
1741 1732608 : pim11= pot(jfft ,1)
1742 1732608 : pre22= pot(jfft-1,2)
1743 1732608 : pim22= pot(jfft ,2)
1744 1732608 : pre12= pot(jfft-1,3)
1745 1732608 : pim12= pot(jfft ,3)
1746 1732608 : pre21= pot(jfft ,4)
1747 1732608 : pim21=-pot(jfft-1,4)
1748 :
1749 1732608 : v0_re=half*(pre11+pre22)
1750 1732608 : v0_im=half*(pim11+pim22)
1751 1732608 : bx_re=half*(pre12+pre21)
1752 1732608 : bx_im=half*(pim12+pim21)
1753 1732608 : by_re=half*(-pim12+pim21)
1754 1732608 : by_im=half*(pre12-pre21)
1755 1732608 : bz_re=half*(pre11-pre22)
1756 1732608 : bz_im=half*(pim11-pim22)
1757 : dotr=dotr+v0_re * dens(jfft-1,1)&
1758 : & + v0_im * dens(jfft ,1) &
1759 : & + bx_re * dens(jfft-1,2) &
1760 : & + bx_im * dens(jfft ,2) &
1761 : & + by_re * dens(jfft-1,3) &
1762 : & + by_im * dens(jfft ,3) &
1763 : & + bz_re * dens(jfft-1,4) &
1764 1732830 : & + bz_im * dens(jfft ,4)
1765 : ! dotr=dotr + pre11 * dre11 &
1766 : !& + pim11 * dim11 &
1767 : !& + pre22 * dre22 &
1768 : !& + pim22 * dim22 &
1769 : !& + pre12 * dre12 &
1770 : !& + pim12 * dim12 &
1771 : !& + pre21 * dre21 &
1772 : !& + pim21 * dim21
1773 : end do
1774 : else ! option=2
1775 : !$OMP PARALLEL DO DEFAULT(PRIVATE) SHARED(nfft,dens,pot) REDUCTION(+:dotr,doti)
1776 1004850 : do ifft=1,nfft
1777 1004544 : jfft=2*ifft
1778 1004544 : dre11=half*(dens(jfft-1,1)+dens(jfft-1,4))
1779 1004544 : dim11=half*(dens(jfft ,1)+dens(jfft-1,4))
1780 1004544 : dre22=half*(dens(jfft-1,1)-dens(jfft-1,4))
1781 1004544 : dim22=half*(dens(jfft ,1)-dens(jfft-1,4))
1782 1004544 : dre12=half*(dens(jfft-1,2)+dens(jfft ,3))
1783 1004544 : dim12=half*(dens(jfft ,2)-dens(jfft-1,3))
1784 1004544 : dre21=half*(dens(jfft-1,2)-dens(jfft ,3))
1785 1004544 : dim21=half*(dens(jfft ,2)+dens(jfft-1,3))
1786 1004544 : pre11= pot(jfft-1,1)
1787 1004544 : pim11= pot(jfft ,1)
1788 1004544 : pre22= pot(jfft-1,2)
1789 1004544 : pim22= pot(jfft ,2)
1790 1004544 : pre12= pot(jfft-1,3)
1791 1004544 : pim12= pot(jfft ,3)
1792 1004544 : pre21= pot(jfft ,4)
1793 1004544 : pim21=-pot(jfft-1,4)
1794 1004544 : v0_re=half*(pre11+pre22)
1795 1004544 : v0_im=half*(pim11+pim22)
1796 1004544 : bx_re=half*(pre12+pre21)
1797 1004544 : bx_im=half*(pim12+pim21)
1798 1004544 : by_re=half*(-pim12+pim21)
1799 1004544 : by_im=half*(pre12-pre21)
1800 1004544 : bz_re=half*(pre11-pre22)
1801 1004544 : bz_im=half*(pim11-pim22)
1802 :
1803 : dotr=dotr+v0_re * dens(jfft-1,1)&
1804 : & + v0_im * dens(jfft ,1) &
1805 : & + bx_re * dens(jfft-1,2) &
1806 : & + bx_im * dens(jfft ,2) &
1807 : & + by_re * dens(jfft-1,3) &
1808 : & + by_im * dens(jfft ,3) &
1809 : & + bz_re * dens(jfft-1,4) &
1810 1004544 : & + bz_im * dens(jfft ,4)
1811 :
1812 : doti=doti+ v0_re * dens(jfft ,1)&
1813 : & - v0_im * dens(jfft-1,1) &
1814 : & + bx_re * dens(jfft ,2) &
1815 : & - bx_im * dens(jfft-1,2) &
1816 : & + by_re * dens(jfft ,3) &
1817 : & - by_im * dens(jfft-1,3) &
1818 : & + bz_re * dens(jfft ,4) &
1819 1004850 : & - bz_im * dens(jfft-1,4)
1820 :
1821 : ! dotr=dotr + pre11 * dre11 &
1822 : !& + pim11 * dim11 &
1823 : !& + pre22 * dre22 &
1824 : !& + pim22 * dim22 &
1825 : !& + pre12 * dre12 &
1826 : !& + pim12 * dim12 &
1827 : !& + pre21 * dre21 &
1828 : !& + pim21 * dim21
1829 : ! doti=doti + pre11 * dim11 &
1830 : !& - pim11 * dre11 &
1831 : !& + pre22 * dim22 &
1832 : !& - pim22 * dre22 &
1833 : !& + pre12 * dim12 &
1834 : !& - pim12 * dre12 &
1835 : !& + pre21 * dim21 &
1836 : !& - pim21 * dre21
1837 : end do
1838 : end if ! option
1839 : end if ! cplex
1840 : end if ! nspden
1841 :
1842 224776 : factor=ucvol/dble(nfftot)
1843 224776 : dotr=factor*dotr
1844 224776 : doti=factor*doti
1845 :
1846 : !MPIWF reduction (addition) on dotr, doti is needed here
1847 224776 : if(present(mpi_comm_sphgrid)) then
1848 118428 : nproc_sphgrid=xmpi_comm_size(mpi_comm_sphgrid)
1849 118428 : if(nproc_sphgrid>1) then
1850 6340 : buffer2(1)=dotr
1851 6340 : buffer2(2)=doti
1852 6340 : call xmpi_sum(buffer2,mpi_comm_sphgrid,ierr)
1853 6340 : dotr=buffer2(1)
1854 6340 : doti=buffer2(2)
1855 : end if
1856 : end if
1857 :
1858 224776 : end subroutine dotprod_vn
1859 : !!***
1860 :
1861 : !----------------------------------------------------------------------
1862 :
1863 : !!****f* m_cgtools/sqnorm_v
1864 : !! NAME
1865 : !! sqnorm_v
1866 : !!
1867 : !! FUNCTION
1868 : !! Compute square of the norm of a potential (integral over FFT grid), to obtain
1869 : !! a square residual-like quantity (so the sum of product of values
1870 : !! is NOT divided by the number of FFT points, and NOT multiplied by the primitive cell volume).
1871 : !! Take into account the spin components of the potentials (nspden),
1872 : !! and sum over them.
1873 : !!
1874 : !! INPUTS
1875 : !! cplex=if 1, real space function on FFT grid is REAL, if 2, COMPLEX
1876 : !! nfft= (effective) number of FFT grid points (for this processor)
1877 : !! nspden=number of spin-density components
1878 : !! opt_storage: 0, if potential is stored as V^up-up, V^dn-dn, Re[V^up-dn], Im[V^up-dn]
1879 : !! 1, if potential is stored as V, B_x, B_y, Bz (B=magn. field)
1880 : !! pot(cplex*nfft,nspden)=real space potential on FFT grid
1881 : !!
1882 : !! OUTPUT
1883 : !! norm2= value of the square of the norm
1884 : !!
1885 : !! SOURCE
1886 :
1887 65193 : subroutine sqnorm_v(cplex,nfft,norm2,nspden,opt_storage,pot,mpi_comm_sphgrid)
1888 :
1889 : !Arguments ------------------------------------
1890 : !scalars
1891 : integer,intent(in) :: cplex,nfft,nspden,opt_storage
1892 : integer,intent(in),optional :: mpi_comm_sphgrid
1893 : real(dp),intent(out) :: norm2
1894 : !arrays
1895 : real(dp),intent(in) :: pot(cplex*nfft,nspden)
1896 :
1897 : !Local variables-------------------------------
1898 : !scalars
1899 : integer :: ierr,ifft,ispden,nproc_sphgrid
1900 : real(dp) :: ar
1901 : ! *************************************************************************
1902 :
1903 : !Real or complex inputs are coded
1904 :
1905 65193 : norm2=zero
1906 139672 : do ispden=1,min(nspden,2)
1907 : !$OMP PARALLEL DO PRIVATE(ifft) SHARED(cplex,ispden,nfft,pot) REDUCTION(+:norm2)
1908 1591062665 : do ifft=1,cplex*nfft
1909 1590997472 : norm2=norm2 + pot(ifft,ispden)**2
1910 : end do
1911 : end do
1912 65193 : if (nspden==4) then
1913 : ar=zero
1914 8034 : do ispden=3,4
1915 : !$OMP PARALLEL DO PRIVATE(ifft) SHARED(cplex,ispden,nfft,pot) REDUCTION(+:ar)
1916 65085984 : do ifft=1,cplex*nfft
1917 65083306 : ar=ar + pot(ifft,ispden)**2
1918 : end do
1919 : end do
1920 2678 : if (opt_storage==0) then
1921 1634 : if (cplex==1) then
1922 1554 : norm2=norm2+two*ar
1923 : else
1924 80 : norm2=norm2+ar
1925 : end if
1926 : else
1927 1044 : norm2=half*(norm2+ar)
1928 : end if
1929 : end if
1930 :
1931 : !MPIWF reduction (addition) on norm2 is needed here
1932 65193 : if(present(mpi_comm_sphgrid)) then
1933 46812 : nproc_sphgrid=xmpi_comm_size(mpi_comm_sphgrid)
1934 46812 : if(nproc_sphgrid>1)then
1935 2580 : call xmpi_sum(norm2,mpi_comm_sphgrid,ierr)
1936 : end if
1937 : end if
1938 :
1939 65193 : end subroutine sqnorm_v
1940 : !!***
1941 :
1942 : !----------------------------------------------------------------------
1943 :
1944 : !!****f* m_cgtools/mean_fftr
1945 : !! NAME
1946 : !! mean_fftr
1947 : !!
1948 : !! FUNCTION
1949 : !! Compute the mean of an arraysp(nfft,nspden), over the FFT grid, for each component nspden,
1950 : !! and return it in meansp(nspden).
1951 : !! Take into account the spread of the array due to parallelism: the actual number of fft
1952 : !! points is nfftot, but the number of points on this proc is nfft only.
1953 : !! So : for ispden from 1 to nspden
1954 : !! meansp(ispden) = sum(ifft=1,nfftot) arraysp(ifft,ispden) / nfftot
1955 : !!
1956 : !! INPUTS
1957 : !! arraysp(nfft,nspden)=the array whose average has to be computed
1958 : !! nfft=number of FFT points stored by one proc
1959 : !! nfftot=total number of FFT points
1960 : !! nspden=number of spin-density components
1961 : !!
1962 : !! OUTPUT
1963 : !! meansp(nspden)=mean value for each nspden component
1964 : !!
1965 : !! SOURCE
1966 :
1967 209439 : subroutine mean_fftr(arraysp,meansp,nfft,nfftot,nspden,mpi_comm_sphgrid,gpu_thread_limit)
1968 :
1969 : !Arguments ------------------------------------
1970 : !scalars
1971 : integer,intent(in) :: nfft,nfftot,nspden
1972 : integer,intent(in),optional:: mpi_comm_sphgrid,gpu_thread_limit
1973 : !arrays
1974 : real(dp),intent(in) :: arraysp(nfft,nspden)
1975 : real(dp),intent(out) :: meansp(nspden)
1976 :
1977 : !Local variables-------------------------------
1978 : !scalars
1979 : integer :: ierr,ifft,ispden,nproc_sphgrid,l_gpu_thread_limit,nthreads_bak
1980 : real(dp) :: invnfftot,tmean
1981 : ! *************************************************************************
1982 :
1983 209439 : l_gpu_thread_limit=0; if(present(gpu_thread_limit)) l_gpu_thread_limit=gpu_thread_limit
1984 209439 : invnfftot=one/(dble(nfftot))
1985 :
1986 209439 : if(l_gpu_thread_limit /= 0) then
1987 0 : nthreads_bak=xomp_get_max_threads()
1988 0 : call xomp_set_num_threads(min(l_gpu_thread_limit,nthreads_bak))
1989 : end if
1990 :
1991 456808 : do ispden=1,nspden
1992 : tmean=zero
1993 : !$OMP PARALLEL DO REDUCTION(+:tmean)
1994 5012354763 : do ifft=1,nfft
1995 5012354763 : tmean=tmean+arraysp(ifft,ispden)
1996 : end do
1997 456808 : meansp(ispden)=tmean*invnfftot
1998 : end do
1999 :
2000 : !XG030514 : MPIWF The values of meansp(ispden) should
2001 : !now be summed across processors in the same WF group, and spread on all procs.
2002 209439 : if(present(mpi_comm_sphgrid)) then
2003 209172 : nproc_sphgrid=xmpi_comm_size(mpi_comm_sphgrid)
2004 209172 : if(nproc_sphgrid>1) then
2005 9884 : call xmpi_sum(meansp,nspden,mpi_comm_sphgrid,ierr)
2006 : end if
2007 : end if
2008 :
2009 209439 : if(l_gpu_thread_limit /= 0) then
2010 0 : call xomp_set_num_threads(nthreads_bak)
2011 : end if
2012 :
2013 209439 : end subroutine mean_fftr
2014 : !!***
2015 :
2016 : !!****f* m_cgtools/cg_getspin
2017 : !! NAME
2018 : !! cg_getspin
2019 : !!
2020 : !! FUNCTION
2021 : !! Sandwich a single wave function on the Pauli matrices
2022 : !!
2023 : !! INPUTS
2024 : !! npw_k = number of plane waves
2025 : !! cgcband = coefficients of spinorial wave function
2026 : !!
2027 : !! OUTPUT
2028 : !! spin = 3-vector of spin components for this state
2029 : !! cgcmat = outer spin product of spinorial wf with itself
2030 : !!
2031 : !! SOURCE
2032 :
2033 300 : subroutine cg_getspin(cgcband, npw_k, spin, cgcmat)
2034 :
2035 : !Arguments ------------------------------------
2036 : !scalars
2037 : integer, intent(in) :: npw_k
2038 : real(dp), intent(in) :: cgcband(2,2*npw_k)
2039 : complex(dp), intent(out),optional :: cgcmat(2,2)
2040 : real(dp), intent(out) :: spin(3)
2041 :
2042 : !Local variables-------------------------------
2043 : !scalars
2044 : complex(dp) :: cspin(0:3), cgcmat_(2,2)
2045 : ! ***********************************************************************
2046 :
2047 : ! cgcmat_ = cgcband * cgcband^T* i.e. 2x2 matrix of spin components (dpcomplex)
2048 300 : cgcmat_ = czero
2049 300 : call zgemm('n','c',2,2,npw_k,cone,cgcband,2,cgcband,2,czero,cgcmat_,2)
2050 :
2051 : ! spin(*) = sum_{si sj pi} cgcband(si,pi)^* pauli_mat*(si,sj) cgcband(sj,pi)
2052 : cspin(0) = cgcmat_(1,1)*pauli_mat(1,1,0) + cgcmat_(2,1)*pauli_mat(2,1,0) &
2053 300 : & + cgcmat_(1,2)*pauli_mat(1,2,0) + cgcmat_(2,2)*pauli_mat(2,2,0)
2054 : cspin(1) = cgcmat_(1,1)*pauli_mat(1,1,1) + cgcmat_(2,1)*pauli_mat(2,1,1) &
2055 300 : & + cgcmat_(1,2)*pauli_mat(1,2,1) + cgcmat_(2,2)*pauli_mat(2,2,1)
2056 : cspin(2) = cgcmat_(1,1)*pauli_mat(1,1,2) + cgcmat_(2,1)*pauli_mat(2,1,2) &
2057 300 : & + cgcmat_(1,2)*pauli_mat(1,2,2) + cgcmat_(2,2)*pauli_mat(2,2,2)
2058 : cspin(3) = cgcmat_(1,1)*pauli_mat(1,1,3) + cgcmat_(2,1)*pauli_mat(2,1,3) &
2059 300 : & + cgcmat_(1,2)*pauli_mat(1,2,3) + cgcmat_(2,2)*pauli_mat(2,2,3)
2060 : !write(std_out,*) 'cgmat: ', cgcmat_
2061 : !write(std_out,*) 'real(spin): ', real(cspin)
2062 : !write(std_out,*) 'aimag(spin): ', aimag(cspin)
2063 :
2064 1200 : spin = real(cspin(1:3))
2065 300 : if (present(cgcmat)) cgcmat = cgcmat_
2066 :
2067 300 : end subroutine cg_getspin
2068 : !!***
2069 :
2070 : !----------------------------------------------------------------------
2071 :
2072 : !!****f* m_cgtools/cg_gsph2box
2073 : !! NAME
2074 : !! cg_gsph2box
2075 : !!
2076 : !! FUNCTION
2077 : !! Array iarrsph is defined in sphere with npw_k points. Insert iarrsph inside box
2078 : !! of nx*ny*nz points to define array oarrbox for fft box. rest of oarrbox is filled with 0 s.
2079 : !!
2080 : !! INPUTS
2081 : !! iarrsph(2,npw_k*ndat)= contains values for npw_k G vectors in basis sphere
2082 : !! ndat=number of FFT to perform.
2083 : !! npw_k=number of G vectors in basis at this k point
2084 : !! oarrbox(2,ldx*ldy*ldz*ndat) = fft box
2085 : !! nx,ny,nz=physical dimension of the box (oarrbox)
2086 : !! ldx,ldy,ldz=memory dimension of oarrbox
2087 : !! kg_k(3,npw_k)=integer coordinates of G vectors in basis sphere
2088 : !! istwf_k=option parameter that describes the storage of wfs
2089 : !!
2090 : !! OUTPUT
2091 : !! oarrbox(ldx*ldy*ldz*ndat)
2092 : !!
2093 : !! NOTES
2094 : !! If istwf_k differs from 1, then special storage modes must be taken
2095 : !! into account, for symmetric wavefunctions coming from k=(0 0 0) or other
2096 : !! special k points.
2097 : !!
2098 : !! SOURCE
2099 :
2100 0 : subroutine cg_gsph2box(nx,ny,nz,ldx,ldy,ldz,ndat,npw_k,istwf_k,kg_k,iarrsph,oarrbox)
2101 :
2102 : !Arguments ------------------------------------
2103 : !scalars
2104 : integer,intent(in) :: istwf_k,nx,ny,nz,ldx,ldy,ldz,ndat,npw_k
2105 : !arrays
2106 : integer,intent(in) :: kg_k(3,npw_k)
2107 : real(dp),intent(in) :: iarrsph(2,npw_k*ndat)
2108 : real(dp),intent(out) :: oarrbox(2,ldx*ldy*ldz*ndat)
2109 :
2110 : !Local variables-------------------------------
2111 : !scalars
2112 : integer,parameter :: me_g0=1
2113 : integer :: ix,ixinv,iy,iyinv,iz,izinv,dat,ipw,npwmin,pad_box,pad_sph,ifft,ifft_inv,ldxyz
2114 : character(len=500) :: msg
2115 : !arrays
2116 0 : integer,allocatable :: ixinver(:),iyinver(:),izinver(:)
2117 : ! *************************************************************************
2118 :
2119 : !In the case of special k-points, invariant under time-reversal,
2120 : !but not Gamma, initialize the inverse coordinates
2121 : !Remember indeed that
2122 : !u_k(G) = u_{k+G0}(G-G0); u_{-k}(-G) = u_k(G)^*
2123 : !and therefore:
2124 : !u_{G0/2}(G) = u_{G0/2}(-G-G0)^*.
2125 0 : if (istwf_k>=2) then
2126 0 : ABI_MALLOC(ixinver,(nx))
2127 0 : ABI_MALLOC(iyinver,(ny))
2128 0 : ABI_MALLOC(izinver,(nz))
2129 0 : if ( ANY(istwf_k==(/2,4,6,8/)) ) then
2130 0 : ixinver(1)=1
2131 0 : do ix=2,nx
2132 0 : ixinver(ix)=nx+2-ix
2133 : end do
2134 : else
2135 0 : do ix=1,nx
2136 0 : ixinver(ix)=nx+1-ix
2137 : end do
2138 : end if
2139 0 : if (istwf_k>=2 .and. istwf_k<=5) then
2140 0 : iyinver(1)=1
2141 0 : do iy=2,ny
2142 0 : iyinver(iy)=ny+2-iy
2143 : end do
2144 : else
2145 0 : do iy=1,ny
2146 0 : iyinver(iy)=ny+1-iy
2147 : end do
2148 : end if
2149 0 : if ( ANY(istwf_k==(/2,3,6,7/)) ) then
2150 0 : izinver(1)=1
2151 0 : do iz=2,nz
2152 0 : izinver(iz)=nz+2-iz
2153 : end do
2154 : else
2155 0 : do iz=1,nz
2156 0 : izinver(iz)=nz+1-iz
2157 : end do
2158 : end if
2159 : end if
2160 :
2161 0 : ldxyz = ldx*ldy*ldz
2162 :
2163 0 : if (istwf_k==1) then
2164 :
2165 : !$OMP PARALLEL DO PRIVATE(pad_sph,pad_box,ix,iy,iz,ifft)
2166 0 : do dat=1,ndat
2167 0 : pad_sph = (dat-1)*npw_k
2168 0 : pad_box = (dat-1)*ldxyz
2169 0 : oarrbox(:,1+pad_box:ldxyz+pad_box) = zero ! zero the sub-array
2170 0 : do ipw=1,npw_k
2171 0 : ix=kg_k(1,ipw); if (ix<0) ix=ix+nx; ix=ix+1
2172 0 : iy=kg_k(2,ipw); if (iy<0) iy=iy+ny; iy=iy+1
2173 0 : iz=kg_k(3,ipw); if (iz<0) iz=iz+nz; iz=iz+1
2174 0 : ifft = ix + (iy-1)*ldx + (iz-1)*ldx*ldy
2175 : #if (defined FC_NVHPC) || (defined __INTEL_COMPILER && defined HAVE_OPENMP)
2176 : if (ifft<0) stop "prevent from miscompiling this section"
2177 : #endif
2178 0 : oarrbox(1,ifft+pad_box) = iarrsph(1,ipw+pad_sph)
2179 0 : oarrbox(2,ifft+pad_box) = iarrsph(2,ipw+pad_sph)
2180 : end do
2181 : end do
2182 :
2183 0 : else if (istwf_k>=2) then
2184 : !
2185 0 : npwmin=1
2186 0 : if(istwf_k==2 .and. me_g0==1) then ! If gamma point, then oarrbox must be completed
2187 0 : do dat=1,ndat
2188 0 : pad_sph = (dat-1)*npw_k
2189 0 : pad_box = (dat-1)*ldxyz
2190 0 : oarrbox(1,1+pad_box) = iarrsph(1,1+pad_sph)
2191 0 : oarrbox(2,1+pad_box) = zero
2192 : end do
2193 : npwmin=2
2194 : end if
2195 :
2196 : !$OMP PARALLEL DO PRIVATE(pad_sph,pad_box,ix,iy,iz,ixinv,iyinv,izinv,ifft,ifft_inv)
2197 0 : do dat=1,ndat
2198 0 : pad_sph = (dat-1)*npw_k
2199 0 : pad_box = (dat-1)*ldxyz
2200 0 : oarrbox(:,npwmin+pad_box:ldxyz+pad_box) = zero
2201 0 : do ipw=npwmin,npw_k
2202 0 : ix=kg_k(1,ipw); if(ix<0)ix=ix+nx; ix=ix+1
2203 0 : iy=kg_k(2,ipw); if(iy<0)iy=iy+ny; iy=iy+1
2204 0 : iz=kg_k(3,ipw); if(iz<0)iz=iz+nz; iz=iz+1
2205 0 : ifft = ix + (iy-1)*ldx + (iz-1)*ldx*ldy
2206 : #if defined FC_NVHPC
2207 : if (ifft<0) stop "prevent from miscompiling this section"
2208 : #endif
2209 : ! Construct the coordinates of -k-G
2210 0 : ixinv=ixinver(ix); iyinv=iyinver(iy); izinv=izinver(iz)
2211 0 : ifft_inv = ixinv + (iyinv-1)*ldx + (izinv-1)*ldx*ldy
2212 :
2213 0 : oarrbox(:,ifft +pad_box) = iarrsph(:,ipw+pad_sph)
2214 0 : oarrbox(1,ifft_inv+pad_box) = iarrsph(1,ipw+pad_sph)
2215 0 : oarrbox(2,ifft_inv+pad_box) = -iarrsph(2,ipw+pad_sph)
2216 : end do
2217 : end do
2218 : !
2219 : else
2220 0 : write(msg,'(a,i0)')"Wrong istwfk ",istwf_k
2221 0 : ABI_ERROR(msg)
2222 : end if
2223 :
2224 0 : if (istwf_k>=2) then
2225 0 : ABI_FREE(ixinver)
2226 0 : ABI_FREE(iyinver)
2227 0 : ABI_FREE(izinver)
2228 : end if
2229 :
2230 0 : end subroutine cg_gsph2box
2231 : !!***
2232 :
2233 : !----------------------------------------------------------------------
2234 :
2235 : !!****f* m_cgtools/cg_box2gsph
2236 : !! NAME
2237 : !! cg_box2gsph
2238 : !!
2239 : !! FUNCTION
2240 : !!
2241 : !! INPUTS
2242 : !! nx,ny,nz=physical dimension of the FFT box.
2243 : !! ldx,ldy,ldz=Logical dimensions of the arrays.
2244 : !! ndat=number of data in iarrbox
2245 : !! npw_k=Number of planewaves in the G-sphere.
2246 : !! kg_k(3,npw_k)=Reduced coordinates of the G-vectoes.
2247 : !! iarrbox(2,ldx,ldy,ldz*ndat)=Input arrays on the FFT box.
2248 : !! [rscal] = Scaling factor
2249 : !!
2250 : !! OUTPUT
2251 : !! oarrsph(2,npw_k*ndat)=Data defined on the G-sphere.
2252 : !!
2253 : !! SOURCE
2254 :
2255 28521 : subroutine cg_box2gsph(nx,ny,nz,ldx,ldy,ldz,ndat,npw_k,kg_k,iarrbox,oarrsph,rscal)
2256 :
2257 : !Arguments ------------------------------------
2258 : !scalars
2259 : integer,intent(in) :: npw_k,nx,ny,nz,ldx,ldy,ldz,ndat
2260 : real(dp),optional,intent(in) :: rscal
2261 : !arrays
2262 : integer,intent(in) :: kg_k(3,npw_k)
2263 : real(dp),intent(in) :: iarrbox(2,ldx*ldy*ldz*ndat)
2264 : real(dp),intent(out) :: oarrsph(2,npw_k*ndat)
2265 :
2266 : !Local variables-------------------------------
2267 : !scalars
2268 : integer :: ig,ix,iy,iz,idat,sph_pad,box_pad,ifft
2269 : ! *************************************************************************
2270 :
2271 28521 : if (.not. PRESENT(rscal)) then
2272 : !
2273 51 : if (ndat==1) then
2274 : !$OMP PARALLEL DO PRIVATE(ix,iy,iz,ifft)
2275 669787 : do ig=1,npw_k
2276 669736 : ix=kg_k(1,ig); if (ix<0) ix=ix+nx; ix=ix+1
2277 669736 : iy=kg_k(2,ig); if (iy<0) iy=iy+ny; iy=iy+1
2278 669736 : iz=kg_k(3,ig); if (iz<0) iz=iz+nz; iz=iz+1
2279 669736 : ifft = ix + (iy-1)*ldx + (iz-1)*ldx*ldy
2280 : #if defined FC_NVHPC
2281 : if (ifft<0) stop "prevent from miscompiling this section"
2282 : #endif
2283 669736 : oarrsph(1,ig) = iarrbox(1,ifft)
2284 669787 : oarrsph(2,ig) = iarrbox(2,ifft)
2285 : end do
2286 : else
2287 : !$OMP PARALLEL DO PRIVATE(sph_pad,box_pad,ix,iy,iz,ifft)
2288 0 : do idat=1,ndat
2289 0 : sph_pad = (idat-1)*npw_k
2290 0 : box_pad = (idat-1)*ldx*ldy*ldz
2291 0 : do ig=1,npw_k
2292 0 : ix=kg_k(1,ig); if (ix<0) ix=ix+nx; ix=ix+1
2293 0 : iy=kg_k(2,ig); if (iy<0) iy=iy+ny; iy=iy+1
2294 0 : iz=kg_k(3,ig); if (iz<0) iz=iz+nz; iz=iz+1
2295 0 : ifft = ix + (iy-1)*ldx + (iz-1)*ldx*ldy
2296 : #if defined FC_NVHPC
2297 : if (ifft<0) stop "prevent from miscompiling this section"
2298 : #endif
2299 0 : oarrsph(1,ig+sph_pad) = iarrbox(1,ifft+box_pad)
2300 0 : oarrsph(2,ig+sph_pad) = iarrbox(2,ifft+box_pad)
2301 : end do
2302 : end do
2303 : end if
2304 : !
2305 : else
2306 28470 : if (ndat==1) then
2307 : !$OMP PARALLEL DO PRIVATE(ix,iy,iz,ifft)
2308 12097072 : do ig=1,npw_k
2309 12068616 : ix=kg_k(1,ig); if (ix<0) ix=ix+nx; ix=ix+1
2310 12068616 : iy=kg_k(2,ig); if (iy<0) iy=iy+ny; iy=iy+1
2311 12068616 : iz=kg_k(3,ig); if (iz<0) iz=iz+nz; iz=iz+1
2312 12068616 : ifft = ix + (iy-1)*ldx + (iz-1)*ldx*ldy
2313 : #if defined FC_NVHPC
2314 : if (ifft<0) stop "prevent from miscompiling this section"
2315 : #endif
2316 12068616 : oarrsph(1,ig) = iarrbox(1,ifft) * rscal
2317 12097072 : oarrsph(2,ig) = iarrbox(2,ifft) * rscal
2318 : end do
2319 : else
2320 : !$OMP PARALLEL DO PRIVATE(sph_pad,box_pad,ix,iy,iz,ifft)
2321 70 : do idat=1,ndat
2322 56 : sph_pad = (idat-1)*npw_k
2323 56 : box_pad = (idat-1)*ldx*ldy*ldz
2324 3514574 : do ig=1,npw_k
2325 3514504 : ix=kg_k(1,ig); if (ix<0) ix=ix+nx; ix=ix+1
2326 3514504 : iy=kg_k(2,ig); if (iy<0) iy=iy+ny; iy=iy+1
2327 3514504 : iz=kg_k(3,ig); if (iz<0) iz=iz+nz; iz=iz+1
2328 3514504 : ifft = ix + (iy-1)*ldx + (iz-1)*ldx*ldy
2329 : #if defined FC_NVHPC
2330 : if (ifft<0) stop "prevent from miscompiling this section"
2331 : #endif
2332 3514504 : oarrsph(1,ig+sph_pad) = iarrbox(1,ifft+box_pad) * rscal
2333 3514560 : oarrsph(2,ig+sph_pad) = iarrbox(2,ifft+box_pad) * rscal
2334 : end do
2335 : end do
2336 : end if
2337 : end if
2338 :
2339 28521 : end subroutine cg_box2gsph
2340 : !!***
2341 :
2342 : !----------------------------------------------------------------------
2343 :
2344 : !!****f* m_cgtools/cg_addtorho
2345 : !! NAME
2346 : !! cg_addtorho
2347 : !!
2348 : !! FUNCTION
2349 : !! Add |ur|**2 to the ground-states density rho.
2350 : !! rho = rho + weight_r * Re[ur]**2 + weight_i * Im[ur]**2
2351 : !!
2352 : !! INPUTS
2353 : !! nx,ny,nz=physical dimension of the FFT box.
2354 : !! ldx,ldy,ldz=leading dimensions of the arrays.
2355 : !! ndat=number of contributions to accumulate.
2356 : !! weight_r=weight used for the accumulation of the density in real space
2357 : !! weight_i=weight used for the accumulation of the density in real space
2358 : !! ur(2,ldx,ldy,ldz*ndat)=wavefunctions in real space
2359 : !!
2360 : !! SIDE EFFECTS
2361 : !! rho(ldx,ldy,ldz) = contains the input density at input,
2362 : !! modified in input with the contribution given by ur.
2363 : !!
2364 : !! SOURCE
2365 :
2366 234 : subroutine cg_addtorho(nx,ny,nz,ldx,ldy,ldz,ndat,weight_r,weight_i,ur,rho)
2367 :
2368 : !Arguments ------------------------------------
2369 : !scalars
2370 : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat
2371 : real(dp),intent(in) :: weight_i,weight_r
2372 : !arrays
2373 : real(dp),intent(in) :: ur(2,ldx,ldy,ldz*ndat)
2374 : real(dp),intent(inout) :: rho(ldx,ldy,ldz)
2375 :
2376 : !Local variables-------------------------------
2377 : !scalars
2378 : integer :: ix,iy,iz,idat,izdat
2379 : ! *************************************************************************
2380 :
2381 234 : if (ndat==1) then
2382 : !$OMP PARALLEL DO
2383 11100 : do iz=1,nz
2384 720162 : do iy=1,ny
2385 56309590 : do ix=1,nx
2386 : rho(ix,iy,iz) = rho(ix,iy,iz) + weight_r * ur(1,ix,iy,iz)**2 &
2387 56298720 : & + weight_i * ur(2,ix,iy,iz)**2
2388 : end do
2389 : end do
2390 : end do
2391 :
2392 : else
2393 : ! It would be nice to use $OMP PARALLEL DO PRIVATE(izdat) REDUCTION(+:rho)
2394 : ! but it's risky as the private rho is allocated on the stack of the thread.
2395 : !$OMP PARALLEL PRIVATE(izdat)
2396 20 : do idat=1,ndat
2397 : !$OMP DO
2398 1620 : do iz=1,nz
2399 1600 : izdat = iz + (idat-1)*ldz
2400 161616 : do iy=1,ny
2401 16161600 : do ix=1,nx
2402 : rho(ix,iy,iz) = rho(ix,iy,iz) + weight_r * ur(1,ix,iy,izdat)**2 &
2403 16160000 : & + weight_i * ur(2,ix,iy,izdat)**2
2404 : end do
2405 : end do
2406 : end do
2407 : !$OMP END DO NOWAIT
2408 : end do
2409 : !$OMP END PARALLEL
2410 : end if
2411 :
2412 234 : end subroutine cg_addtorho
2413 : !!***
2414 :
2415 : !----------------------------------------------------------------------
2416 :
2417 : !!****f* m_cgtools/cg_vlocpsi
2418 : !! NAME
2419 : !! cg_vlocpsi
2420 : !!
2421 : !! FUNCTION
2422 : !! Apply the local part of the potentatil to the wavefunction in real space.
2423 : !!
2424 : !! INPUTS
2425 : !! nx,ny,nz=physical dimension of the FFT box.
2426 : !! ldx,ldy,ldz=leading dimensions of the arrays.
2427 : !! ndat=number of wavefunctions.
2428 : !! cplex= 1 if vloc is real, 2 for complex
2429 : !! vloc(cplex*ldx,ldy,ldz)=Local potential on the FFT box.
2430 : !!
2431 : !! SIDE EFFECTS
2432 : !! ur(2,ldx,ldy,ldz*ndat)=
2433 : !! Input = wavefunctions in real space.
2434 : !! Output= vloc |ur>
2435 : !!
2436 : !! SOURCE
2437 :
2438 0 : subroutine cg_vlocpsi(nx,ny,nz,ldx,ldy,ldz,ndat,cplex,vloc,ur)
2439 :
2440 : !Arguments ------------------------------------
2441 : !scalars
2442 : integer,intent(in) :: nx,ny,nz,ldx,ldy,ldz,ndat,cplex
2443 : !arrays
2444 : real(dp),intent(in) :: vloc(cplex*ldx,ldy,ldz)
2445 : real(dp),intent(inout) :: ur(2,ldx,ldy,ldz*ndat)
2446 :
2447 : !Local variables-------------------------------
2448 : !scalars
2449 : integer :: idat,ix,iy,iz,padat
2450 : real(dp) :: fim,fre
2451 : ! *************************************************************************
2452 :
2453 0 : if (cplex==1) then
2454 : !
2455 0 : if (ndat==1) then
2456 : !$OMP PARALLEL DO
2457 0 : do iz=1,nz
2458 0 : do iy=1,ny
2459 0 : do ix=1,nx
2460 0 : ur(1,ix,iy,iz) = vloc(ix,iy,iz) * ur(1,ix,iy,iz)
2461 0 : ur(2,ix,iy,iz) = vloc(ix,iy,iz) * ur(2,ix,iy,iz)
2462 : end do
2463 : end do
2464 : end do
2465 : !
2466 : else
2467 : !
2468 : !$OMP PARALLEL DO PRIVATE(padat)
2469 0 : do idat=1,ndat
2470 0 : padat = ldz*(idat-1)
2471 0 : do iz=1,nz
2472 0 : do iy=1,ny
2473 0 : do ix=1,nx
2474 0 : ur(1,ix,iy,iz+padat) = vloc(ix,iy,iz) * ur(1,ix,iy,iz+padat)
2475 0 : ur(2,ix,iy,iz+padat) = vloc(ix,iy,iz) * ur(2,ix,iy,iz+padat)
2476 : end do
2477 : end do
2478 : end do
2479 : end do
2480 : !
2481 : end if
2482 : !
2483 0 : else if (cplex==2)then
2484 : !
2485 0 : if (ndat==1) then
2486 : !$OMP PARALLEL DO PRIVATE(fre,fim)
2487 0 : do iz=1,nz
2488 0 : do iy=1,ny
2489 0 : do ix=1,nx
2490 0 : fre = ur(1,ix,iy,iz)
2491 0 : fim = ur(2,ix,iy,iz)
2492 0 : ur(1,ix,iy,iz) = vloc(2*ix-1,iy,iz)*fre - vloc(2*ix,iy,iz)*fim
2493 0 : ur(2,ix,iy,iz) = vloc(2*ix-1,iy,iz)*fim + vloc(2*ix,iy,iz)*fre
2494 : end do
2495 : end do
2496 : end do
2497 : else
2498 : !$OMP PARALLEL DO PRIVATE(padat,fre,fim)
2499 0 : do idat=1,ndat
2500 0 : padat = ldz*(idat-1)
2501 0 : do iz=1,nz
2502 0 : do iy=1,ny
2503 0 : do ix=1,nx
2504 0 : fre = ur(1,ix,iy,iz+padat)
2505 0 : fim = ur(2,ix,iy,iz+padat)
2506 0 : ur(1,ix,iy,iz+padat) = vloc(2*ix-1,iy,iz)*fre - vloc(2*ix,iy,iz)*fim
2507 0 : ur(2,ix,iy,iz+padat) = vloc(2*ix-1,iy,iz)*fim + vloc(2*ix,iy,iz)*fre
2508 : end do
2509 : end do
2510 : end do
2511 : end do
2512 : end if
2513 : !
2514 : else
2515 0 : ur = huge(one)
2516 : !ABI_BUG("Wrong cplex")
2517 : end if
2518 :
2519 0 : end subroutine cg_vlocpsi
2520 : !!***
2521 :
2522 : !----------------------------------------------------------------------
2523 :
2524 : !!****f* m_cgtools/cgnc_cholesky
2525 : !! NAME
2526 : !! cgnc_cholesky
2527 : !!
2528 : !! FUNCTION
2529 : !! Cholesky orthonormalization of the vectors stored in cg (version optimized for NC wavefunctions).
2530 : !!
2531 : !! INPUTS
2532 : !! npwsp=Size of each vector (usually npw*nspinor)
2533 : !! nband=Number of band in cg
2534 : !! istwfk=Storage mode for the wavefunctions. 1 for standard full mode
2535 : !! me_g0=1 if this node has G=0.
2536 : !! comm_pw=MPI communicator for the planewave group. Set to xmpi_comm_self for sequential mode.
2537 : !!
2538 : !! SIDE EFFECTS
2539 : !! cg(2*npwsp*nband)
2540 : !! input: Input set of vectors.
2541 : !! output: Orthonormalized set.
2542 : !!
2543 : !! OUTPUT
2544 : !! [umat]=Cholesky upper triangle matrix.
2545 : !!
2546 : !! SOURCE
2547 :
2548 620 : subroutine cgnc_cholesky(npwsp, nband, cg, istwfk, me_g0, comm_pw, use_gemm, umat)
2549 :
2550 : !Arguments ------------------------------------
2551 : !scalars
2552 : integer,intent(in) :: npwsp, nband, istwfk, comm_pw, me_g0
2553 : logical,optional,intent(in) :: use_gemm
2554 : !arrays
2555 : real(dp),intent(inout) :: cg(2*npwsp*nband)
2556 : real(dp),optional,allocatable,intent(out) :: umat(:,:,:)
2557 :
2558 : !Local variables ------------------------------
2559 : !scalars
2560 : integer :: ierr,b1,b2
2561 : #ifdef DEBUG_MODE
2562 : integer :: ptr
2563 : character(len=500) :: msg
2564 : #endif
2565 : !real(dp) :: max_absimag
2566 : logical :: my_usegemm
2567 : !arrays
2568 1240 : real(dp) :: rcg0(nband)
2569 620 : real(dp),allocatable :: r_ovlp(:,:), c_ovlp(:,:,:)
2570 : ! *************************************************************************
2571 :
2572 : #ifdef DEBUG_MODE
2573 : if (istwfk == 2 .and. me_g0 == 1) then
2574 : ierr = 0
2575 : do b1=1,nband
2576 : ptr = 2 + 2*(b1-1)*npwsp
2577 : if (abs(cg(ptr)) > zero) then
2578 : ierr = ierr + 1
2579 : write(msg,'(a,i0,es13.6)')" Input b1, Im u(g=0) should be zero ",b1,cg(ptr)
2580 : call wrtout(std_out, msg)
2581 : !cg(ptr) = zero
2582 : end if
2583 : end do
2584 : ABI_CHECK(ierr == 0, "Non zero imag part")
2585 : end if
2586 : #endif
2587 :
2588 : ! In matrix notation O = PSI^H PSI = U^H U where PSI is a (ng,nb) matrix with the input wavefunctions
2589 : ! The new orthogonalized states PHI is given by: PHI = PSI U^{-1}
2590 :
2591 620 : my_usegemm = .FALSE.; if (PRESENT(use_gemm)) my_usegemm = use_gemm
2592 :
2593 620 : if (istwfk /= 1) then
2594 : ! Version optimized for real wavefunctions.
2595 496 : ABI_MALLOC(r_ovlp, (nband, nband))
2596 :
2597 : !call cg_set_imag0_to_zero(istwfk, me_g0, npwsp, nband, cg, max_absimag)
2598 :
2599 : ! 1) Calculate O_ij = <phi_i|phi_j> (real symmetric matrix)
2600 124 : if (my_usegemm) then
2601 0 : call DGEMM("T", "N", nband, nband, 2*npwsp, one, cg, 2*npwsp, cg, 2*npwsp, zero, r_ovlp, nband)
2602 : else
2603 124 : call DSYRK("U", "T", nband, 2*npwsp, one, cg, 2*npwsp, zero, r_ovlp, nband)
2604 : end if
2605 :
2606 107356 : r_ovlp = two * r_ovlp
2607 124 : if (istwfk == 2 .and. me_g0 == 1) then
2608 : ! Extract the real part at G=0 and subtract its contribution to the overlap.
2609 31 : call dcopy(nband, cg, 2*npwsp, rcg0, 1)
2610 919 : do b2=1,nband
2611 14323 : do b1=1,b2
2612 14292 : r_ovlp(b1, b2) = r_ovlp(b1, b2) - rcg0(b1) * rcg0(b2)
2613 : end do
2614 : end do
2615 : end if
2616 :
2617 : ! Sum the overlap if PW are distributed.
2618 124 : if (comm_pw /= xmpi_comm_self) call xmpi_sum(r_ovlp, comm_pw, ierr)
2619 :
2620 : ! 2) Cholesky factorization: O = U^H U with U upper triangle matrix.
2621 124 : call DPOTRF('U', nband, r_ovlp, nband, ierr)
2622 124 : ABI_CHECK(ierr == 0, sjoin('DPOTRF returned info:', itoa(ierr)))
2623 :
2624 : ! 3) Solve X U = cg. On exit cg is orthonormalized.
2625 124 : call DTRSM('R', 'U', 'N', 'N', 2*npwsp, nband, one, r_ovlp, nband, cg, 2*npwsp)
2626 :
2627 124 : if (present(umat)) then
2628 372 : ABI_REMALLOC(umat, (1, nband, nband))
2629 107356 : umat(1,:,:) = r_ovlp
2630 : end if
2631 :
2632 124 : ABI_FREE(r_ovlp)
2633 :
2634 : else
2635 : ! Version for complex wavefunctions.
2636 1984 : ABI_MALLOC(c_ovlp, (2, nband, nband))
2637 :
2638 : ! 1) Calculate O_ij = <phi_i|phi_j> (complex Hermitean)
2639 496 : if (my_usegemm) then
2640 0 : call abi_zgemm_2r("C", "N", nband, nband, npwsp, cone, cg, npwsp, cg, npwsp, czero, c_ovlp, nband)
2641 : else
2642 496 : call ZHERK("U", "C", nband, npwsp, cone, cg, npwsp, czero, c_ovlp, nband)
2643 : end if
2644 :
2645 : ! Sum the overlap if PW are distributed.
2646 496 : if (comm_pw /= xmpi_comm_self) call xmpi_sum(c_ovlp, comm_pw, ierr)
2647 :
2648 : ! 2) Cholesky factorization: O = U^H U with U upper triangle matrix.
2649 496 : call ZPOTRF('U', nband, c_ovlp, nband, ierr)
2650 496 : ABI_CHECK(ierr == 0, sjoin('ZPOTRF returned info:', itoa(ierr)))
2651 :
2652 : ! 3) Solve X U = cg. On exit cg is orthonormalized.
2653 496 : call ZTRSM('R', 'U', 'N', 'N', npwsp, nband, cone, c_ovlp, nband, cg, npwsp)
2654 :
2655 496 : if (present(umat)) then
2656 1107 : ABI_REMALLOC(umat, (2, nband, nband))
2657 534762 : umat = c_ovlp
2658 : end if
2659 :
2660 496 : ABI_FREE(c_ovlp)
2661 : end if
2662 :
2663 : #ifdef DEBUG_MODE
2664 : if (istwfk == 2) then
2665 : ierr = 0
2666 : do b1=1,nband
2667 : ptr = 2 + 2*(b1-1)*npwsp
2668 : if (ABS(cg(ptr)) > zero) then
2669 : ierr = ierr + 1
2670 : write(msg,'(a,i0,es13.6)')" Output b1, Im u(g=0) should be zero ",b1,cg(ptr)
2671 : end if
2672 : end do
2673 : ABI_CHECK(ierr == 0, "Non zero imag part")
2674 : end if
2675 : #endif
2676 :
2677 620 : end subroutine cgnc_cholesky
2678 : !!***
2679 :
2680 : !----------------------------------------------------------------------
2681 :
2682 : !!****f* m_cgtools/cgpaw_cholesky
2683 : !! NAME
2684 : !! cgpaw_cholesky
2685 : !!
2686 : !! FUNCTION
2687 : !! Cholesky orthonormalization of the vectors stored in cg. (version for PAW wavefunctions).
2688 : !!
2689 : !! INPUTS
2690 : !! npwsp=Size of each vector (usually npw*nspinor)
2691 : !! nband=Number of band in cg and gsc
2692 : !! istwfk=Storage mode for the wavefunctions. 1 for standard full mode
2693 : !! me_g0=1 if this node has G=0.
2694 : !! comm_pw=MPI communicator for the planewave group. Set to xmpi_comm_self for sequential mode.
2695 : !!
2696 : !! SIDE EFFECTS
2697 : !! cg(2*npwsp*nband)
2698 : !! input: Input set of vectors |C>, S|C>
2699 : !! output: Orthonormalized set such as <C|S|C> = 1
2700 : !! gsc(2*npwsp*nband): destroyed in output.
2701 : !!
2702 : !! OUTPUT
2703 : !! [umat]=Cholesky upper triangle matrix.
2704 : !!
2705 : !! SOURCE
2706 :
2707 160 : subroutine cgpaw_cholesky(npwsp, nband, cg, gsc, istwfk, me_g0, comm_pw, umat)
2708 :
2709 : !Arguments ------------------------------------
2710 : !scalars
2711 : integer,intent(in) :: npwsp, nband, istwfk, me_g0, comm_pw
2712 : !arrays
2713 : real(dp),intent(inout) :: cg(2*npwsp*nband), gsc(2*npwsp*nband)
2714 : real(dp),optional,allocatable,intent(out) :: umat(:,:,:)
2715 :
2716 : !Local variables ------------------------------
2717 : !scalars
2718 : integer :: ierr, b1, b2
2719 : !real(dp) :: max_absimag
2720 : !character(len=500) :: msg
2721 : !arrays
2722 320 : real(dp) :: rcg0(nband), rg0sc(nband)
2723 160 : real(dp),allocatable :: r_ovlp(:,:), c_ovlp(:,:,:)
2724 : ! *************************************************************************
2725 :
2726 160 : if (istwfk /= 1) then
2727 : ! Version optimized for real wavefunctions.
2728 128 : ABI_MALLOC(r_ovlp, (nband, nband))
2729 :
2730 : !call cg_set_imag0_to_zero(istwfk, me_g0, npwsp, nband, cg, max_absimag)
2731 : !call cg_set_imag0_to_zero(istwfk, me_g0, npwsp, nband, gsc, max_absimag)
2732 :
2733 : #ifdef HAVE_LINALG_GEMMT
2734 : ! Use zgemmt extension BLAS3 provided by e.g. MKL
2735 10148 : r_ovlp = zero
2736 32 : call DGEMMT("U", "T", "N", nband, 2*npwsp, one, cg, 2*npwsp, gsc, 2*npwsp, zero, r_ovlp, nband)
2737 : #else
2738 : call DGEMM("T", "N", nband, nband, 2*npwsp, one, cg, 2*npwsp, gsc, 2*npwsp, zero, r_ovlp, nband)
2739 : #endif
2740 10148 : r_ovlp = two * r_ovlp
2741 :
2742 32 : if (istwfk == 2 .and. me_g0 == 1) then
2743 : ! Extract the real part at G=0 and subtract its contribution to the overlap.
2744 10 : call dcopy(nband, cg, 2*npwsp, rcg0, 1)
2745 10 : call dcopy(nband, gsc, 2*npwsp, rg0sc, 1)
2746 174 : do b2=1,nband
2747 1836 : do b1=1,b2
2748 1826 : r_ovlp(b1,b2) = r_ovlp(b1,b2) - rcg0(b1) * rg0sc(b2)
2749 : end do
2750 : end do
2751 : end if
2752 :
2753 : ! Sum the overlap if PW are distributed.
2754 32 : if (comm_pw /= xmpi_comm_self) call xmpi_sum(r_ovlp, comm_pw, ierr)
2755 :
2756 : ! 2) Cholesky factorization: O = U^H U with U upper triangle matrix.
2757 32 : call DPOTRF('U', nband, r_ovlp, nband, ierr)
2758 32 : ABI_CHECK(ierr == 0, sjoin('DPOTRF returned info:', itoa(ierr)))
2759 :
2760 : ! 3) Solve X U = cg.
2761 32 : call DTRSM('R', 'U', 'N', 'N', 2*npwsp, nband, one, r_ovlp, nband, cg, 2*npwsp)
2762 :
2763 : ! 4) Solve Y U = gsc. On exit <cg|gsc> = 1
2764 32 : call DTRSM('R', 'U', 'N', 'N', 2*npwsp, nband, one, r_ovlp, nband, gsc, 2*npwsp)
2765 :
2766 : !call cg_set_imag0_to_zero(istwfk, me_g0, npwsp, nband, cg, max_absimag)
2767 : !call cg_set_imag0_to_zero(istwfk, me_g0, npwsp, nband, gsc, max_absimag)
2768 :
2769 32 : if (present(umat)) then
2770 96 : ABI_REMALLOC(umat, (1, nband, nband))
2771 10148 : umat(1,:,:) = r_ovlp
2772 : end if
2773 :
2774 32 : ABI_FREE(r_ovlp)
2775 :
2776 : else
2777 : ! 1) Calculate O_ij = <phi_i|S|phi_j> (complex Hermitean)
2778 512 : ABI_MALLOC(c_ovlp, (2, nband, nband))
2779 :
2780 : #ifdef HAVE_LINALG_GEMMT
2781 63948 : c_ovlp = zero
2782 128 : call ZGEMMT("U", "C", "N", nband, npwsp, cone, cg, npwsp, gsc, npwsp, czero, c_ovlp, nband)
2783 : #else
2784 : call abi_zgemm_2r("C", "N", nband, nband, npwsp, cone, cg, npwsp, gsc, npwsp, czero, c_ovlp, nband)
2785 : #endif
2786 :
2787 : ! Sum the overlap if PW are distributed.
2788 128 : if (comm_pw /= xmpi_comm_self) call xmpi_sum(c_ovlp, comm_pw, ierr)
2789 : !
2790 : ! 2) Cholesky factorization: O = U^H U with U upper triangle matrix.
2791 128 : call ZPOTRF('U', nband, c_ovlp, nband, ierr)
2792 128 : ABI_CHECK(ierr == 0, sjoin('ZPOTRF returned info:', itoa(ierr)))
2793 :
2794 : ! 3) Solve X U = cg.
2795 128 : call ZTRSM('R', 'U', 'N', 'N', npwsp, nband, cone, c_ovlp, nband, cg, npwsp)
2796 :
2797 : ! 4) Solve Y U = gsc. On exit <cg|gsc> = 1
2798 128 : call ZTRSM('R', 'U', 'N', 'N', npwsp, nband, cone, c_ovlp, nband, gsc, npwsp)
2799 :
2800 128 : if (present(umat)) then
2801 384 : ABI_REMALLOC(umat, (2, nband, nband))
2802 64076 : umat = c_ovlp
2803 : end if
2804 :
2805 128 : ABI_FREE(c_ovlp)
2806 : end if
2807 :
2808 : !call cgpaw_normalize(npwsp, nband, cg, gsc, istwfk, me_g0, comm_pw)
2809 :
2810 160 : end subroutine cgpaw_cholesky
2811 : !!***
2812 :
2813 : !----------------------------------------------------------------------
2814 :
2815 : !!****f* m_cgtools/cgnc_normalize
2816 : !! NAME
2817 : !! cgnc_normalize
2818 : !!
2819 : !! FUNCTION
2820 : !!
2821 : !! INPUTS
2822 : !! npwsp=Size of each vector (usually npw*nspinor)
2823 : !! nband=Number of vectors in icg1
2824 : !!
2825 : !! SIDE EFFECTS
2826 : !!
2827 : !! SOURCE
2828 :
2829 1719 : subroutine cgnc_normalize(npwsp, nband, cg, istwfk, me_g0, comm_pw)
2830 :
2831 : !Arguments ------------------------------------
2832 : !scalars
2833 : integer,intent(in) :: npwsp,nband,istwfk,me_g0,comm_pw
2834 : !arrays
2835 : real(dp),intent(inout) :: cg(2*npwsp*nband)
2836 :
2837 : !Local variables ------------------------------
2838 : !scalars
2839 : integer :: ptr,ierr,band
2840 : !character(len=500) :: msg
2841 : !arrays
2842 3438 : real(dp) :: norm(nband),alpha(2)
2843 : ! *************************************************************************
2844 :
2845 : !$OMP PARALLEL DO PRIVATE(ptr) IF (nband > 1)
2846 31727 : do band=1,nband
2847 30008 : ptr = 1 + 2*npwsp*(band-1)
2848 30008 : norm(band) = cg_dznrm2(npwsp, cg(ptr))
2849 31727 : norm(band) = norm(band) ** 2
2850 : !norm(band) = cg_real_zdotc(npwsp, cg(ptr), cg(ptr))
2851 : end do
2852 :
2853 1719 : if (istwfk > 1) then
2854 10928 : norm = two * norm
2855 560 : if (istwfk == 2 .and. me_g0 == 1) then
2856 : !$OMP PARALLEL DO PRIVATE(ptr) IF (nband >1)
2857 2732 : do band=1,nband
2858 2592 : ptr = 1 + 2*npwsp*(band-1)
2859 2732 : norm(band) = norm(band) - cg(ptr)**2
2860 : end do
2861 : end if
2862 : end if
2863 :
2864 1719 : if (comm_pw /= xmpi_comm_self) call xmpi_sum(norm, comm_pw, ierr)
2865 :
2866 1719 : ierr = 0
2867 31727 : do band=1,nband
2868 31727 : if (norm(band) > zero) then
2869 30008 : norm(band) = SQRT(norm(band))
2870 : else
2871 0 : ierr = ierr + 1
2872 : end if
2873 : end do
2874 :
2875 1719 : if (ierr /= 0) then
2876 0 : ABI_ERROR(sjoin("Found ", itoa(ierr)," vectors with norm <= zero!"))
2877 : end if
2878 :
2879 : !$OMP PARALLEL DO PRIVATE(ptr,alpha) IF (nband > 1)
2880 31727 : do band=1,nband
2881 30008 : ptr = 1 + 2*npwsp*(band-1)
2882 90024 : alpha = [one / norm(band), zero]
2883 31727 : call cg_zscal(npwsp, alpha, cg(ptr))
2884 : end do
2885 :
2886 1719 : end subroutine cgnc_normalize
2887 : !!***
2888 :
2889 : !----------------------------------------------------------------------
2890 :
2891 : !!****f* m_cgtools/cgnc_gsortho
2892 : !! NAME
2893 : !! cgnc_gsortho
2894 : !!
2895 : !! FUNCTION
2896 : !!
2897 : !! INPUTS
2898 : !! npwsp=Size of each vector (usually npw*nspinor)
2899 : !! nband1=Number of vectors in icg1
2900 : !! nband1=Number of vectors in cg2
2901 : !! comm_pw=MPI communicator.
2902 : !!
2903 : !! SIDE EFFECTS
2904 : !! cg2(2*npwsp*nband2)
2905 : !! icg1(2*npwsp*nband1)
2906 : !! input: Input set of vectors.
2907 : !! output: Orthonormalized set.
2908 : !!
2909 : !! SOURCE
2910 :
2911 0 : subroutine cgnc_gsortho(npwsp, nband1, icg1, nband2, iocg2, istwfk, normalize, me_g0, comm_pw)
2912 :
2913 : !Arguments ------------------------------------
2914 : !scalars
2915 : integer,intent(in) :: npwsp,nband1,nband2,istwfk,me_g0
2916 : integer,optional,intent(in) :: comm_pw
2917 : logical,intent(in) :: normalize
2918 : !arrays
2919 : real(dp),intent(in) :: icg1(2*npwsp*nband1)
2920 : real(dp),intent(inout) :: iocg2(2*npwsp*nband2)
2921 :
2922 : !Local variables ------------------------------
2923 : !scalars
2924 : integer :: ierr,b1,b2
2925 : !arrays
2926 0 : real(dp) :: r_icg1(nband1),r_iocg2(nband2)
2927 : real(dp),allocatable :: proj(:,:,:)
2928 : ! *************************************************************************
2929 :
2930 0 : ABI_MALLOC(proj, (2, nband1, nband2))
2931 : !proj = zero
2932 :
2933 : ! 1) Calculate <cg1|cg2>
2934 0 : call cg_zgemm("C", "N", npwsp, nband1, nband2, icg1, iocg2, proj)
2935 :
2936 0 : if (istwfk>1) then
2937 : ! nspinor is always 1 in this case.
2938 : ! Account for the missing G and set the imaginary part to zero since wavefunctions are real.
2939 0 : proj(1,:,:) = two * proj(1,:,:)
2940 0 : proj(2,:,:) = zero
2941 : !
2942 0 : if (istwfk==2 .and. me_g0==1) then
2943 : ! Extract the real part at G=0 and subtract its contribution.
2944 0 : call dcopy(nband1,icg1, 2*npwsp,r_icg1, 1)
2945 0 : call dcopy(nband2,iocg2,2*npwsp,r_iocg2,1)
2946 0 : do b2=1,nband2
2947 0 : do b1=1,nband1
2948 0 : proj(1,b1,b2) = proj(1,b1,b2) - r_icg1(b1) * r_iocg2(b2)
2949 : end do
2950 : end do
2951 : end if
2952 : !
2953 : end if
2954 : !
2955 : ! This is for the MPI version
2956 0 : if (comm_pw /= xmpi_comm_self) call xmpi_sum(proj,comm_pw,ierr)
2957 :
2958 : ! 2) cg2 = cg2 - <cg1|cg2> cg1
2959 0 : call cg_zgemm("N","N",npwsp,nband1,nband2,icg1,proj,iocg2,alpha=-cg_cone,beta=cg_cone)
2960 :
2961 0 : ABI_FREE(proj)
2962 :
2963 : ! 3) Normalize iocg2 if required.
2964 0 : if (normalize) call cgnc_normalize(npwsp,nband2,iocg2,istwfk,me_g0,comm_pw)
2965 :
2966 0 : end subroutine cgnc_gsortho
2967 : !!***
2968 :
2969 : !----------------------------------------------------------------------
2970 :
2971 : !!****f* m_cgtools/cgnc_gramschmidt
2972 : !! NAME
2973 : !! cgnc_grortho
2974 : !!
2975 : !! FUNCTION
2976 : !! Gram-Schmidt orthonormalization of the vectors stored in cg
2977 : !!
2978 : !! INPUTS
2979 : !! npwsp=Size of each vector (usually npw*nspinor)
2980 : !! nband=Number of band in cg
2981 : !! istwfk=Storage mode for the wavefunctions. 1 for standard full mode
2982 : !! me_g0=1 if this node has G=0.
2983 : !! comm_pw=MPI communicator for the planewave group. Set to xmpi_comm_self for sequential mode.
2984 : !!
2985 : !! SIDE EFFECTS
2986 : !! cg(2*npwsp*nband)
2987 : !! input: Input set of vectors.
2988 : !! output: Orthonormalized set.
2989 : !!
2990 : !! SOURCE
2991 :
2992 0 : subroutine cgnc_gramschmidt(npwsp, nband, cg, istwfk, me_g0, comm_pw)
2993 :
2994 : !Arguments ------------------------------------
2995 : !scalars
2996 : integer,intent(in) :: npwsp, nband, istwfk, comm_pw, me_g0
2997 : !arrays
2998 : real(dp),intent(inout) :: cg(2*npwsp*nband)
2999 :
3000 : !Local variables ------------------------------
3001 : !scalars
3002 : integer :: b1,nb2,opt
3003 : logical :: normalize
3004 : ! *************************************************************************
3005 :
3006 : ! Normalize the first vector.
3007 0 : call cgnc_normalize(npwsp,1,cg(1),istwfk,me_g0,comm_pw)
3008 0 : if (nband == 1) RETURN
3009 :
3010 : ! Orthogonaluze b1 wrt to the bands in [1,b1-1].
3011 0 : normalize = .TRUE.
3012 0 : do b1=2,nband
3013 0 : opt = 1 + 2*npwsp*(b1-1)
3014 0 : nb2=b1-1
3015 0 : call cgnc_gsortho(npwsp,nb2,cg(1),1,cg(opt),istwfk,normalize,me_g0,comm_pw)
3016 : end do
3017 :
3018 : end subroutine cgnc_gramschmidt
3019 : !!***
3020 :
3021 : !----------------------------------------------------------------------
3022 :
3023 : !!****f* m_cgtools/cgpaw_normalize
3024 : !! NAME
3025 : !! cgpaw_normalize
3026 : !!
3027 : !! FUNCTION
3028 : !! Normalize a set of PAW pseudo wavefunctions.
3029 : !!
3030 : !! INPUTS
3031 : !! npwsp=Size of each vector (usually npw*nspinor)
3032 : !! nband=Number of band in cg and gsc
3033 : !! istwfk=Storage mode for the wavefunctions. 1 for standard full mode
3034 : !! me_g0=1 if this node has G=0.
3035 : !! comm_pw=MPI communicator for the planewave group. Set to xmpi_comm_self for sequential mode.
3036 : !!
3037 : !! SIDE EFFECTS
3038 : !! cg(2*npwsp*nband)
3039 : !! input: Input set of vectors |C>
3040 : !! output: Normalized set such as <C|S|C> = 1
3041 : !! gsc(2*npwsp*nband)
3042 : !! input: Input set of vectors S|C>
3043 : !! output: New S|C> compute with the new |C>
3044 : !!
3045 : !! SOURCE
3046 :
3047 991 : subroutine cgpaw_normalize(npwsp, nband, cg, gsc, istwfk, me_g0, comm_pw)
3048 :
3049 : !Arguments ------------------------------------
3050 : !scalars
3051 : integer,intent(in) :: npwsp, nband, istwfk, me_g0, comm_pw
3052 : !arrays
3053 : real(dp),intent(inout) :: cg(2*npwsp*nband), gsc(2*npwsp*nband)
3054 :
3055 : !Local variables ------------------------------
3056 : !scalars
3057 : integer :: ptr,ierr,band
3058 : character(len=500) :: msg
3059 : !arrays
3060 1982 : real(dp) :: norm(nband),alpha(2)
3061 : ! *************************************************************************
3062 :
3063 : !$OMP PARALLEL DO PRIVATE(ptr) IF (nband > 1)
3064 8631 : do band=1,nband
3065 7640 : ptr = 1 + 2*npwsp*(band-1)
3066 8631 : norm(band) = cg_real_zdotc(npwsp, gsc(ptr), cg(ptr))
3067 : end do
3068 :
3069 991 : if (istwfk>1) then
3070 2187 : norm = two * norm
3071 255 : if (istwfk==2 .and. me_g0==1) then
3072 : !$OMP PARALLEL DO PRIVATE(ptr) IF (nband > 1)
3073 711 : do band=1,nband
3074 628 : ptr = 1 + 2*npwsp*(band-1)
3075 711 : norm(band) = norm(band) - gsc(ptr) * cg(ptr)
3076 : end do
3077 : end if
3078 : end if
3079 :
3080 991 : if (comm_pw /= xmpi_comm_self) call xmpi_sum(norm, comm_pw, ierr)
3081 :
3082 991 : ierr = 0
3083 8631 : do band=1,nband
3084 8631 : if (norm(band) > zero) then
3085 7640 : norm(band) = SQRT(norm(band))
3086 : else
3087 0 : ierr = ierr + 1
3088 : end if
3089 : end do
3090 :
3091 991 : if (ierr/=0) then
3092 0 : write(msg,'(a,i0,a)')" Found ",ierr," vectors with norm <= zero!"
3093 0 : ABI_ERROR(msg)
3094 : end if
3095 :
3096 : ! Scale |C> and S|C>.
3097 : !$OMP PARALLEL DO PRIVATE(ptr,alpha) IF (nband > 1)
3098 8631 : do band=1,nband
3099 7640 : ptr = 1 + 2*npwsp*(band-1)
3100 22920 : alpha = [one / norm(band), zero]
3101 7640 : call cg_zscal(npwsp, alpha, cg(ptr))
3102 8631 : call cg_zscal(npwsp, alpha, gsc(ptr))
3103 : end do
3104 :
3105 991 : end subroutine cgpaw_normalize
3106 : !!***
3107 :
3108 : !----------------------------------------------------------------------
3109 :
3110 : !!****f* m_cgtools/cgpaw_gsortho
3111 : !! NAME
3112 : !! cgpaw_gsortho
3113 : !!
3114 : !! FUNCTION
3115 : !! This routine uses the Gram-Schmidt method to orthogonalize a set of PAW wavefunctions.
3116 : !! with respect to an input block of states.
3117 : !!
3118 : !! INPUTS
3119 : !! npwsp=Size of each vector (usually npw*nspinor)
3120 : !! nband1=Number of vectors in the input block icg1
3121 : !! icg1(2*npwsp*nband1)=Input block of vectors.
3122 : !! igsc1(2*npwsp*nband1)= S|C> for C in icg1.
3123 : !! nband2=Number of vectors to orthogonalize
3124 : !! normalize=True if output wavefunction must be normalized.
3125 : !! istwfk=Storage mode for the wavefunctions. 1 for standard full mode
3126 : !! me_g0=1 if this node has G=0.
3127 : !! comm_pw=MPI communicator for the planewave group. Set to xmpi_comm_self for sequential mode.
3128 : !!
3129 : !! SIDE EFFECTS
3130 : !! iocg2(2*npwsp*nband2), iogsc2(2*npwsp*nband1)
3131 : !! input: set of |C> and S|C> where |C> is the set of states to orthogonalize
3132 : !! output: Orthonormalized set.
3133 : !!
3134 : !! SOURCE
3135 :
3136 0 : subroutine cgpaw_gsortho(npwsp, nband1, icg1, igsc1, nband2, iocg2, iogsc2, istwfk, normalize, me_g0, comm_pw)
3137 :
3138 : !Arguments ------------------------------------
3139 : !scalars
3140 : integer,intent(in) :: npwsp, nband1, nband2, istwfk, me_g0
3141 : integer,optional,intent(in) :: comm_pw
3142 : logical,intent(in) :: normalize
3143 : !arrays
3144 : real(dp),intent(in) :: icg1(2*npwsp*nband1),igsc1(2*npwsp*nband1)
3145 : real(dp),intent(inout) :: iocg2(2*npwsp*nband2),iogsc2(2*npwsp*nband2)
3146 :
3147 : !Local variables ------------------------------
3148 : !scalars
3149 : integer :: ierr,b1,b2
3150 : !arrays
3151 0 : real(dp) :: r_icg1(nband1),r_iocg2(nband2)
3152 : real(dp),allocatable :: proj(:,:,:)
3153 : ! *************************************************************************
3154 :
3155 0 : ABI_MALLOC(proj,(2,nband1,nband2))
3156 :
3157 : ! 1) Calculate <cg1|cg2>
3158 0 : call cg_zgemm("C","N",npwsp,nband1,nband2,igsc1,iocg2,proj)
3159 :
3160 0 : if (istwfk>1) then
3161 : ! nspinor is always 1 in this case.
3162 : ! Account for the missing G and set the imaginary part to zero since wavefunctions are real.
3163 0 : proj(1,:,:) = two * proj(1,:,:)
3164 0 : proj(2,:,:) = zero
3165 : !
3166 0 : if (istwfk==2 .and. me_g0==1) then
3167 : ! Extract the real part at G=0 and subtract its contribution.
3168 0 : call dcopy(nband1,igsc1,2*npwsp,r_icg1, 1)
3169 0 : call dcopy(nband2,iocg2,2*npwsp,r_iocg2,1)
3170 0 : do b2=1,nband2
3171 0 : do b1=1,nband1
3172 0 : proj(1,b1,b2) = proj(1,b1,b2) - r_icg1(b1) * r_iocg2(b2)
3173 : end do
3174 : end do
3175 : end if
3176 :
3177 : end if
3178 :
3179 : ! This is for the MPI version
3180 0 : if (comm_pw /= xmpi_comm_self) call xmpi_sum(proj,comm_pw,ierr)
3181 :
3182 : ! 2)
3183 : ! cg2 = cg2 - <Scg1|cg2> cg1
3184 : ! S cg2 = S cg2 - <Scg1|cg2> S cg1
3185 0 : call cg_zgemm("N","N",npwsp,nband1,nband2,icg1,proj,iocg2,alpha=-cg_cone,beta=cg_cone)
3186 0 : call cg_zgemm("N","N",npwsp,nband1,nband2,igsc1,proj,iogsc2,alpha=-cg_cone,beta=cg_cone)
3187 :
3188 0 : ABI_FREE(proj)
3189 :
3190 : ! 3) Normalize iocg2 and iogsc2 if required.
3191 0 : if (normalize) call cgpaw_normalize(npwsp, nband2, iocg2, iogsc2, istwfk, me_g0, comm_pw)
3192 :
3193 0 : end subroutine cgpaw_gsortho
3194 : !!***
3195 :
3196 : !----------------------------------------------------------------------
3197 :
3198 : !!****f* m_cgtools/cgpaw_gramschmidt
3199 : !! NAME
3200 : !! cgpaw_gramschmidt
3201 : !!
3202 : !! FUNCTION
3203 : !! Gram-Schmidt orthonormalization of the vectors stored in cg
3204 : !!
3205 : !! INPUTS
3206 : !! npwsp=Size of each vector (usually npw*nspinor)
3207 : !! nband=Number of bands in cg
3208 : !! istwfk=Storage mode for the wavefunctions. 1 for standard full mode
3209 : !! me_g0=1 if this node has G=0.
3210 : !! comm_pw=MPI communicator for the planewave group. Set to xmpi_comm_self for sequential mode.
3211 : !!
3212 : !! SIDE EFFECTS
3213 : !! cg(2*npwsp*nband), gsc(2*npwsp*nband)
3214 : !! input: Input set of vectors.
3215 : !! output: Orthonormalized set.
3216 : !!
3217 : !! SOURCE
3218 :
3219 0 : subroutine cgpaw_gramschmidt(npwsp, nband, cg, gsc, istwfk, me_g0, comm_pw)
3220 :
3221 : !Arguments ------------------------------------
3222 : !scalars
3223 : integer,intent(in) :: npwsp,nband,istwfk,comm_pw,me_g0
3224 : !arrays
3225 : real(dp),intent(inout) :: cg(2*npwsp*nband),gsc(2*npwsp*nband)
3226 :
3227 : !Local variables ------------------------------
3228 : !scalars
3229 : integer :: b1,nb2,opt
3230 : logical :: normalize
3231 : ! *************************************************************************
3232 :
3233 : ! Normalize the first vector.
3234 0 : call cgpaw_normalize(npwsp,1,cg(1),gsc(1),istwfk,me_g0,comm_pw)
3235 0 : if (nband == 1) RETURN
3236 :
3237 : ! Orthogonalize b1 wrt to the bands in [1,b1-1].
3238 0 : normalize = .TRUE.
3239 0 : do b1=2,nband
3240 0 : opt = 1 + 2*npwsp*(b1-1)
3241 0 : nb2=b1-1
3242 0 : call cgpaw_gsortho(npwsp,nb2,cg(1),gsc(1),1,cg(opt),gsc(opt),istwfk,normalize,me_g0,comm_pw)
3243 : end do
3244 :
3245 : end subroutine cgpaw_gramschmidt
3246 : !!***
3247 :
3248 : !----------------------------------------------------------------------
3249 :
3250 : !!****f* m_cgtools/projbd
3251 : !!
3252 : !! NAME
3253 : !! projbd
3254 : !!
3255 : !! FUNCTION
3256 : !! Project out vector "direc" onto the bands contained in "cg".
3257 : !! if useoverlap==0
3258 : !! New direc=direc-$sum_{j/=i} { <cg_{j}|direc>.|cg_{j}> }$
3259 : !! if useoverlap==1 (use of overlap matrix S)
3260 : !! New direc=direc-$sum_{j/=i} { <cg_{j}|S|direc>.|cg_{j}> }$
3261 : !! (index i can be set to -1 to sum over all bands)
3262 : !!
3263 : !! INPUTS
3264 : !! cg(2,mcg)=wavefunction coefficients for ALL bands
3265 : !! iband0=which particular band we are interested in ("i" in the above formula)
3266 : !! Can be set to -1 to sum over all bands...
3267 : !! icg=shift to be given to the location of the data in cg
3268 : !! iscg=shift to be given to the location of the data in scg
3269 : !! istwf_k=option parameter that describes the storage of wfs
3270 : !! mcg=maximum size of second dimension of cg
3271 : !! mscg=maximum size of second dimension of scg
3272 : !! nband=number of bands
3273 : !! npw=number of planewaves
3274 : !! nspinor=number of spinorial components (on current proc)
3275 : !! scg(2,mscg*useoverlap)=<G|S|band> for ALL bands,
3276 : !! where S is an overlap matrix
3277 : !! scprod_io=0 if scprod array has to be computed; 1 if it is input (already in memory)
3278 : !! tim_projbd=timing code of the calling subroutine(can be set to 0 if not attributed)
3279 : !! useoverlap=describe the overlap of wavefunctions:
3280 : !! 0: no overlap (S=Identity_matrix)
3281 : !! 1: wavefunctions are overlapping
3282 : !! me_g0=1 if this processors treats G=0, 0 otherwise.
3283 : !! comm=MPI communicator (used if G vectors are distributed.
3284 : !!
3285 : !! SIDE EFFECTS
3286 : !! direc(2,npw)= input: vector to be orthogonalised with respect to cg (and S)
3287 : !! output: vector that has been orthogonalized wrt cg (and S)
3288 : !!
3289 : !! scprod(2,nband)=scalar_product
3290 : !! if useoverlap==0: scalar_product_i=$<cg_{j}|direc_{i}>$
3291 : !! if useoverlap==1: scalar_product_i=$<cg_{j}|S|direc_{i}>$
3292 : !! if scprod_io=0, scprod is output
3293 : !! if scprod_io=1, scprod is input
3294 : !!
3295 : !! NOTES
3296 : !! 1) MPIWF Might have to be recoded for efficient parallelism
3297 : !!
3298 : !! 2) The new version employs BLAS2 routine so that the OMP parallelism is delegated to BLAS library.
3299 : !! May use BLAS3 if multiple wavefunctions are optimized at the same time.
3300 : !!
3301 : !! 3) Note for PAW: ref.= PRB 73, 235101 (2006) [[cite:Audouze2006]], equations (71) and (72):
3302 : !! in normal use, projbd applies P_c projector
3303 : !! if cg and scg are inverted, projbd applies P_c+ projector
3304 : !!
3305 : !! 4) cg_zgemv wraps ZGEMM whose implementation is more efficient, especially in the threaded case.
3306 : !!
3307 : !! SOURCE
3308 :
3309 58071159 : subroutine projbd(cg,direc,iband0,icg,iscg,istwf_k,mcg,mscg,nband,&
3310 58071159 : npw,nspinor,scg,scprod,scprod_io,tim_projbd,useoverlap,me_g0,comm,gpu_option)
3311 :
3312 : !Arguments ------------------------------------
3313 : !scalars
3314 : integer,intent(in) :: iband0,icg,iscg,istwf_k,mcg,mscg,nband,npw,nspinor
3315 : integer,intent(in) :: scprod_io,tim_projbd,useoverlap,me_g0,comm
3316 : integer,optional,intent(in) :: gpu_option
3317 : !arrays
3318 : real(dp),intent(in) :: cg(2,mcg),scg(2,mscg*useoverlap)
3319 : real(dp),intent(inout) :: direc(2,npw*nspinor)
3320 : real(dp),intent(inout) :: scprod(2,nband)
3321 :
3322 : !Local variables-------------------------------
3323 : !scalars
3324 : integer :: nbandm,npw_sp,ierr, my_gpu_option
3325 : !arrays
3326 : real(dp) :: tsec(2),bkp_scprod(2),bkp_dirg0(2)
3327 : ! *************************************************************************
3328 :
3329 58071159 : call timab(210+tim_projbd,1,tsec)
3330 :
3331 58071159 : my_gpu_option = ABI_GPU_DISABLED; if (present(gpu_option)) my_gpu_option = gpu_option
3332 :
3333 58071159 : npw_sp=npw*nspinor
3334 :
3335 58071159 : nbandm=nband
3336 :
3337 58071159 : if (istwf_k==1) then
3338 :
3339 56820618 : if (scprod_io==0) then
3340 56505386 : if (useoverlap==1) then
3341 8866568 : call cg_zgemv("C",npw_sp,nbandm,scg(1,iscg+1),direc,scprod,gpu_option=my_gpu_option)
3342 : else
3343 47638818 : call cg_zgemv("C",npw_sp,nbandm,cg(1,icg+1), direc,scprod,gpu_option=my_gpu_option)
3344 : end if
3345 56505386 : call xmpi_sum(scprod,comm,ierr)
3346 : end if
3347 :
3348 56820618 : if (iband0>0.and.iband0<=nbandm) then
3349 : #ifdef HAVE_OPENMP_OFFLOAD
3350 : !$OMP TARGET MAP(to:bkp_scprod,scprod) IF(my_gpu_option==ABI_GPU_OPENMP)
3351 : #endif
3352 4926 : bkp_scprod(:) = scprod(:,iband0)
3353 4926 : scprod(:,iband0) = zero
3354 : #ifdef HAVE_OPENMP_OFFLOAD
3355 : !$OMP END TARGET
3356 : #endif
3357 : end if
3358 :
3359 56820618 : call cg_zgemv("N",npw_sp,nbandm,cg(1,icg+1),scprod,direc,alpha=-cg_cone,beta=cg_cone,gpu_option=my_gpu_option)
3360 :
3361 56820618 : if (iband0>0.and.iband0<=nbandm) then
3362 : ! Restore previous value as scprod is output.
3363 : #ifdef HAVE_OPENMP_OFFLOAD
3364 : !$OMP TARGET MAP(to:bkp_scprod,scprod) IF(my_gpu_option==ABI_GPU_OPENMP)
3365 : #endif
3366 4926 : scprod(:,iband0) = bkp_scprod(:)
3367 : #ifdef HAVE_OPENMP_OFFLOAD
3368 : !$OMP END TARGET
3369 : #endif
3370 : end if
3371 :
3372 1250541 : else if (istwf_k>=2) then
3373 1250541 : if(my_gpu_option/=ABI_GPU_DISABLED) ABI_BUG("Use case not handled with OpenMP GPU (use_gpu_cuda==2)")
3374 : !
3375 : ! u_{G0/2}(G) = u_{G0/2}(-G-G0)^*; k = G0/2
3376 : ! hence:
3377 : ! sum_G f*(G) g(G) = 2 REAL sum_G^{IZONE} w(G) f*(G)g(G)
3378 : ! where
3379 : ! w(G) = 1 except for k=0 and G=0 where w(G=0) = 1/2.
3380 : !
3381 1250541 : if (scprod_io==0) then
3382 :
3383 1250541 : if (useoverlap==1) then
3384 :
3385 272349 : if (istwf_k==2 .and. me_g0==1) then
3386 333504 : bkp_dirg0 = direc(:,1)
3387 111168 : direc(1,1) = half * direc(1,1)
3388 111168 : direc(2,1) = zero
3389 : end if
3390 :
3391 272349 : call cg_zgemv("C",npw_sp,nbandm,scg(1,iscg+1),direc,scprod,gpu_option=my_gpu_option)
3392 22617195 : scprod = two * scprod
3393 7720631 : scprod(2,:) = zero
3394 :
3395 605853 : if(istwf_k==2 .and. me_g0==1) direc(:,1) = bkp_dirg0
3396 :
3397 : else
3398 :
3399 978192 : if (istwf_k==2 .and. me_g0==1) then
3400 1494270 : bkp_dirg0 = direc(:,1)
3401 498090 : direc(1,1) = half * direc(1,1)
3402 498090 : direc(2,1) = zero
3403 : end if
3404 :
3405 978192 : call cg_zgemv("C",npw_sp,nbandm,cg(1,icg+1),direc,scprod,gpu_option=my_gpu_option)
3406 52301952 : scprod = two * scprod
3407 18086112 : scprod(2,:) = zero
3408 :
3409 2472462 : if (istwf_k==2 .and. me_g0==1) direc(:,1) = bkp_dirg0
3410 : end if ! useoverlap
3411 :
3412 1250541 : call xmpi_sum(scprod,comm,ierr)
3413 : end if
3414 :
3415 1250541 : if (iband0>0.and.iband0<=nbandm) then
3416 0 : bkp_scprod = scprod(:,iband0)
3417 0 : scprod(:,iband0) = zero
3418 : end if
3419 :
3420 1250541 : call cg_zgemv("N",npw_sp,nbandm,cg(1,icg+1),scprod,direc,alpha=-cg_cone,beta=cg_cone,gpu_option=my_gpu_option)
3421 :
3422 1250541 : if (iband0>0.and.iband0<=nbandm) scprod(:,iband0) = bkp_scprod ! Restore previous value as scprod is output.
3423 :
3424 : end if ! Test on istwf_k
3425 :
3426 58071159 : call timab(210+tim_projbd,2,tsec)
3427 :
3428 58071159 : end subroutine projbd
3429 : !!***
3430 :
3431 : !----------------------------------------------------------------------
3432 :
3433 : !!****f* m_cgtools/cg_envlop
3434 : !!
3435 : !! NAME
3436 : !! cg_envlop
3437 : !!
3438 : !! FUNCTION
3439 : !! Multiply random number values in cg by envelope function to lower initial kinetic energy.
3440 : !! Envelope $\left( 1-\left( G/G_{\max }\right) ^2\right) ^{power}$ for |G|<= Gmax.
3441 : !! Near G=0, little scaling, and goes to zero flatly near Gmax.
3442 : !!
3443 : !! INPUTS
3444 : !! cg(2,mcg)=initial random number wavefunctions
3445 : !! ecut=kinetic energy cutoff in Ha
3446 : !! gmet(3,3)=reciprocal space metric (bohr^-2)
3447 : !! icgmod=shift to be given to the location of data in cg
3448 : !! kg(3,npw)=reduced coordinates of G vectors in basis sphere
3449 : !! kpoint(3)=reduced coordinates of k point
3450 : !! mcg=maximum second dimension of cg (at least npw*nband*nspinor)
3451 : !! nband=number of bands being considered
3452 : !! npw=number of planewaves in basis sphere
3453 : !! nspinor=number of spinorial components of the wavefunctions
3454 : !!
3455 : !! OUTPUT
3456 : !! cg(2,mcg)=revised values (not orthonormalized)
3457 : !!
3458 : !! SOURCE
3459 :
3460 38538 : subroutine cg_envlop(cg, ecut, gmet, icgmod, kg, kpoint, mcg, nband, npw, nspinor)
3461 :
3462 : !Arguments ------------------------------------
3463 : !scalars
3464 : integer,intent(in) :: icgmod,mcg,nband,npw,nspinor
3465 : real(dp),intent(in) :: ecut
3466 : !arrays
3467 : integer,intent(in) :: kg(3,npw)
3468 : real(dp),intent(in) :: gmet(3,3),kpoint(3)
3469 : real(dp),intent(inout) :: cg(2,mcg)
3470 :
3471 : !Local variables-------------------------------
3472 : !scalars
3473 : integer,parameter :: re=1,im=2,power=12
3474 : integer :: i1,i2,i3,ig,igs,ispinor,nn,spad
3475 : real(dp) :: cutoff,gs,kpgsqc
3476 : !character(len=500) :: msg
3477 : !arrays
3478 38538 : real(dp),allocatable :: cut_pws(:)
3479 : ! *************************************************************************
3480 :
3481 : !$(k+G)^2$ cutoff from $(1/2)(2 Pi (k+G))^2 = ecut$
3482 38538 : kpgsqc=ecut/(2.0_dp*pi**2)
3483 38538 : cutoff = kpgsqc
3484 :
3485 115614 : ABI_MALLOC(cut_pws,(npw))
3486 :
3487 : !Run through G vectors in basis
3488 : !$OMP PARALLEL DO PRIVATE(gs,i1,i2,i3)
3489 8121709 : do ig=1,npw
3490 8083171 : i1=kg(1,ig) ; i2=kg(2,ig) ; i3=kg(3,ig)
3491 : !(k+G)^2 evaluated using metric and kpoint
3492 : gs = gmet(1,1)*(kpoint(1)+dble(i1))**2+&
3493 : & gmet(2,2)*(kpoint(2)+dble(i2))**2+&
3494 : & gmet(3,3)*(kpoint(3)+dble(i3))**2+&
3495 : & 2.0_dp*(gmet(2,1)*(kpoint(2)+dble(i2))*(kpoint(1)+dble(i1))+&
3496 : & gmet(3,2)*(kpoint(3)+dble(i3))*(kpoint(2)+dble(i2))+&
3497 8083171 : & gmet(1,3)*(kpoint(1)+dble(i1))*(kpoint(3)+dble(i3)))
3498 8121709 : if (gs>cutoff) then
3499 152828 : cut_pws(ig) = zero
3500 : else
3501 7930343 : cut_pws(ig) = (1.0_dp-(gs/cutoff))**power
3502 : end if
3503 : end do
3504 :
3505 : !Run through bands (real and imaginary components)
3506 : !$OMP PARALLEL DO PRIVATE(spad,igs)
3507 291454 : do nn=1,nband
3508 252916 : spad = (nn-1)*npw*nspinor+icgmod
3509 568930 : do ispinor=1,nspinor
3510 71952933 : do ig=1,npw
3511 71422541 : igs=ig+(ispinor-1)*npw
3512 71422541 : cg(1,igs+spad) = cg(1,igs+spad) * cut_pws(ig)
3513 71700017 : cg(2,igs+spad) = cg(2,igs+spad) * cut_pws(ig)
3514 : end do
3515 : end do
3516 : end do
3517 :
3518 38538 : ABI_FREE(cut_pws)
3519 :
3520 38538 : end subroutine cg_envlop
3521 : !!***
3522 :
3523 : !----------------------------------------------------------------------
3524 :
3525 : !!****f* m_cgtools/cg_normev
3526 : !! NAME
3527 : !! cg_normev
3528 : !!
3529 : !! FUNCTION
3530 : !! Normalize a set of nband eigenvectors of complex length npw
3531 : !! (real length 2*npw) and set phases to make cg(i,i) real and positive.
3532 : !! Near convergence, cg(i,j) approaches delta(i,j).
3533 : !!
3534 : !! INPUTS
3535 : !! cg(2*npw,nband)=unnormalized eigenvectors
3536 : !! npw=dimension of cg as shown
3537 : !! nband=number of eigenvectors and complex length thereof.
3538 : !!
3539 : !! OUTPUT
3540 : !! cg(2*npw,nband)=nband normalized eigenvectors
3541 : !!
3542 : !! SOURCE
3543 :
3544 445643 : subroutine cg_normev(cg, npw, nband)
3545 :
3546 : !Arguments ------------------------------------
3547 : !scalars
3548 : integer,intent(in) :: npw,nband
3549 : !arrays
3550 : real(dp),intent(inout) :: cg(2*npw,nband)
3551 :
3552 : !Local variables-------------------------------
3553 : !scalars
3554 : integer :: ii,jj
3555 : real(dp) :: den,evim,evre,phim,phre,xnorm
3556 : character(len=500) :: msg
3557 : ! *************************************************************************
3558 :
3559 : !Loop over vectors
3560 3634626 : do ii=1,nband
3561 : ! find norm
3562 3188983 : xnorm=0.0d0
3563 119926157 : do jj=1,2*npw
3564 119926157 : xnorm=xnorm+cg(jj,ii)**2
3565 : end do
3566 :
3567 3188983 : if((xnorm-one)**2>tol6)then
3568 0 : write(msg,'(6a,i6,a,es16.6,3a)' )ch10,&
3569 0 : 'normev: ',ch10,&
3570 0 : 'Starting xnorm should be close to one (tol is tol6).',ch10,&
3571 0 : 'However, for state number',ii,', xnorm=',xnorm,ch10,&
3572 0 : 'It might be that your LAPACK library has not been correctly installed.'
3573 0 : ABI_BUG(msg)
3574 : end if
3575 :
3576 3188983 : xnorm=1.0d0/sqrt(xnorm)
3577 : ! Set up phase
3578 3188983 : phre=cg(2*ii-1,ii)
3579 3188983 : phim=cg(2*ii,ii)
3580 3188983 : if (phim/=0.0d0) then
3581 2527414 : den=1.0d0/sqrt(phre**2+phim**2)
3582 2527414 : phre=phre*xnorm*den
3583 2527414 : phim=phim*xnorm*den
3584 : else
3585 : ! give xnorm the same sign as phre (negate if negative)
3586 661569 : phre=sign(xnorm,phre)
3587 661569 : phim=0.0d0
3588 : end if
3589 : ! normalize with phase change
3590 3634626 : do jj=1,2*npw,2
3591 58368587 : evre=cg(jj,ii)
3592 58368587 : evim=cg(jj+1,ii)
3593 58368587 : cg(jj,ii)=phre*evre+phim*evim
3594 58368587 : cg(jj+1,ii)=phre*evim-phim*evre
3595 : end do
3596 : end do
3597 :
3598 445643 : end subroutine cg_normev
3599 : !!***
3600 :
3601 : !----------------------------------------------------------------------
3602 :
3603 : !!****f* m_cgtools/cg_precon
3604 : !!
3605 : !! NAME
3606 : !! cg_precon
3607 : !!
3608 : !! FUNCTION
3609 : !! precondition <G|(H-e)|C>
3610 : !!
3611 : !! INPUTS
3612 : !! cg(2,npw)=<G|C>.
3613 : !! eval=current band eigenvalue = <C|H|C>.
3614 : !! istwf_k=option parameter that describes the storage of wfs
3615 : !! kinpw(npw)=(modified) kinetic energy for each plane wave (Hartree)
3616 : !! nspinor=number of spinorial components of the wavefunctions
3617 : !! vect(2,npw)=<G|H|C>.
3618 : !! npw=number of planewaves at this k point.
3619 : !! optekin= 1 if the kinetic energy used in preconditionning is modified
3620 : !! according to Kresse, Furthmuller, PRB 54, 11169 (1996) [[cite:Kresse1996]]
3621 : !! 0 otherwise
3622 : !! mg_g0=1 if the node treats G=0.
3623 : !! comm=MPI communicator
3624 : !!
3625 : !! OUTPUT
3626 : !! pcon(npw)=preconditioning matrix
3627 : !! vect(2,npw*nspinor)=<G|(H-eval)|C_{n,k}>*(polynomial ratio)
3628 : !!
3629 : !! SOURCE
3630 :
3631 43550422 : subroutine cg_precon(cg, eval, istwf_k, kinpw, npw, nspinor, me_g0, optekin, pcon, vect, comm)
3632 :
3633 : !Arguments ------------------------------------
3634 : !scalars
3635 : integer,intent(in) :: istwf_k,npw,nspinor,optekin,me_g0,comm
3636 : real(dp),intent(in) :: eval
3637 : !arrays
3638 : real(dp),intent(in) :: cg(2,npw*nspinor),kinpw(npw)
3639 : real(dp),intent(out) :: pcon(npw)
3640 : real(dp),intent(inout) :: vect(2,npw*nspinor)
3641 :
3642 : !Local variables-------------------------------
3643 : !scalars
3644 : integer :: ierr,ig,igs,ipw1,ispinor
3645 : real(dp) :: ek0,ek0_inv,fac,poly,xx
3646 : !character(len=500) :: msg
3647 : !arrays
3648 : real(dp) :: tsec(2)
3649 : ! *************************************************************************
3650 :
3651 : !Compute mean kinetic energy of band
3652 21775211 : if(istwf_k==1)then
3653 21195075 : ek0=zero
3654 43622381 : do ispinor=1,nspinor
3655 22427306 : igs=(ispinor-1)*npw
3656 6432103456 : do ig=1+igs,npw+igs
3657 6410908381 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
3658 6331263585 : ek0=ek0+kinpw(ig-igs)*(cg(1,ig)**2+cg(2,ig)**2)
3659 : end if
3660 : end do
3661 : end do
3662 :
3663 580136 : else if (istwf_k>=2)then
3664 580136 : if (istwf_k==2 .and. me_g0 == 1)then
3665 283976 : ek0=zero ; ipw1=2
3666 283976 : if(kinpw(1)<huge(zero)*1.d-11)ek0=0.5_dp*kinpw(1)*cg(1,1)**2
3667 : else
3668 296160 : ek0=zero ; ipw1=1
3669 : end if
3670 1160272 : do ispinor=1,nspinor
3671 580136 : igs=(ispinor-1)*npw
3672 360203415 : do ig=ipw1+igs,npw+igs
3673 359623279 : if(kinpw(ig)<huge(zero)*1.d-11)then
3674 351941633 : ek0=ek0+kinpw(ig)*(cg(1,ig)**2+cg(2,ig)**2)
3675 : end if
3676 : end do
3677 : end do
3678 580136 : ek0=2.0_dp*ek0
3679 : end if
3680 :
3681 21775211 : call timab(48,1,tsec)
3682 21775211 : call xmpi_sum(ek0,comm,ierr)
3683 21775211 : call timab(48,2,tsec)
3684 :
3685 21775211 : if(ek0<1.0d-10)then
3686 1 : ABI_WARNING('The mean kinetic energy of a wavefunction vanishes. It is reset to 0.1 Ha.')
3687 1 : ek0=0.1_dp
3688 : end if
3689 :
3690 21775211 : if (optekin==1) then
3691 1255439 : ek0_inv=2.0_dp/(3._dp*ek0)
3692 : else
3693 20519772 : ek0_inv=1.0_dp/ek0
3694 : end if
3695 :
3696 : !Carry out preconditioning
3697 44782653 : do ispinor=1,nspinor
3698 23007442 : igs=(ispinor-1)*npw
3699 : !$OMP PARALLEL DO PRIVATE(fac,ig,poly,xx) SHARED(cg,ek0_inv,eval,kinpw,igs,npw,vect,pcon)
3700 6792590847 : do ig=1+igs,npw+igs
3701 6770815636 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
3702 6683489194 : xx=kinpw(ig-igs)*ek0_inv
3703 : ! Teter polynomial ratio
3704 6683489194 : poly=27._dp+xx*(18._dp+xx*(12._dp+xx*8._dp))
3705 6683489194 : fac=poly/(poly+16._dp*xx**4)
3706 6683489194 : if (optekin==1) fac=two*fac
3707 6683489194 : pcon(ig-igs)=fac
3708 6683489194 : vect(1,ig)=( vect(1,ig)-eval*cg(1,ig) )*fac
3709 6683489194 : vect(2,ig)=( vect(2,ig)-eval*cg(2,ig) )*fac
3710 : else
3711 64319000 : pcon(ig-igs)=zero
3712 64319000 : vect(1,ig)=zero
3713 64319000 : vect(2,ig)=zero
3714 : end if
3715 : end do
3716 : end do
3717 :
3718 21775211 : end subroutine cg_precon
3719 : !!***
3720 :
3721 : !!****f* m_cgtools/cg_precon_block
3722 : !!
3723 : !! NAME
3724 : !! cg_precon_block
3725 : !!
3726 : !! FUNCTION
3727 : !! precondition $<G|(H-e_{n,k})|C_{n,k}>$ for a block of band (band-FFT parallelisation)
3728 : !! in the case of real WFs (istwfk/=1)
3729 : !!
3730 : !! INPUTS
3731 : !! blocksize= size of blocks of bands
3732 : !! cg(vectsize,blocksize)=<G|C_{n,k}> for a block of bands.
3733 : !! eval(blocksize,blocksize)=current block of bands eigenvalues=<C_{n,k}|H|C_{n,k}>.
3734 : !! ghc(vectsize,blocksize)=<G|H|C_{n,k}> for a block of bands.
3735 : !! iterationnumber=number of iterative minimizations in LOBPCG
3736 : !! kinpw(npw)=(modified) kinetic energy for each plane wave (Hartree)
3737 : !! nspinor=number of spinorial components of the wavefunctions (on current proc)
3738 : !! $vect(vectsize,blocksize)=<G|H|C_{n,k}> for a block of bands$.
3739 : !! npw=number of planewaves at this k point.
3740 : !! optekin= 1 if the kinetic energy used in preconditionning is modified
3741 : !! according to Kresse, Furthmuller, PRB 54, 11169 (1996) [[cite:Kresse1996]]
3742 : !! 0 otherwise
3743 : !! optpcon= 0 the TPA preconditionning matrix does not depend on band
3744 : !! 1 the TPA preconditionning matrix (not modified)
3745 : !! 2 the TPA preconditionning matrix is independent of iteration number
3746 : !! vectsize= size of vectors
3747 : !! mg_g0=1 if this node has Gamma, 0 otherwise.
3748 : !!
3749 : !! OUTPUT
3750 : !! vect(2,npw)=<g|(h-eval)|c_{n,k}>*(polynomial ratio)
3751 : !!
3752 : !! SIDE EFFECTS
3753 : !! pcon(npw,blocksize)=preconditionning matrix
3754 : !! input if optpcon=0,2 and iterationnumber/=1
3755 : !! output if optpcon=0,2 and iterationnumber==1
3756 : !!
3757 : !! SOURCE
3758 :
3759 2079 : subroutine cg_precon_block(cg,eval,blocksize,iterationnumber,kinpw,&
3760 2079 : & npw,nspinor,me_g0,optekin,optpcon,pcon,ghc,vect,vectsize,comm)
3761 :
3762 : !Arguments ------------------------------------
3763 : !scalars
3764 : integer,intent(in) :: blocksize,iterationnumber,npw,nspinor,optekin
3765 : integer,intent(in) :: optpcon,vectsize,me_g0,comm
3766 : !arrays
3767 : real(dp),intent(in) :: cg(vectsize,blocksize),eval(blocksize,blocksize)
3768 : real(dp),intent(in) :: ghc(vectsize,blocksize),kinpw(npw)
3769 : real(dp),intent(inout) :: pcon(npw,blocksize),vect(vectsize,blocksize)
3770 :
3771 : !Local variables-------------------------------
3772 : !scalars
3773 : integer :: iblocksize,ierr,ig,igs,ipw1,ispinor
3774 : real(dp) :: fac,poly,xx
3775 : character(len=500) :: msg
3776 : !arrays
3777 : real(dp) :: tsec(2)
3778 2079 : real(dp),allocatable :: ek0(:),ek0_inv(:)
3779 : ! *************************************************************************
3780 :
3781 2079 : call timab(536,1,tsec)
3782 :
3783 : !In this case, the Teter, Allan and Payne preconditioner is approximated:
3784 : !the factor xx=Ekin(G) and no more Ekin(G)/Ekin(iband)
3785 2079 : if (optpcon==0) then
3786 2588 : do ispinor=1,nspinor
3787 1294 : igs=(ispinor-1)*npw
3788 2588 : if (me_g0 == 1) then
3789 1034 : do ig=1+igs,1+igs !g=0
3790 1034 : if (iterationnumber==1) then
3791 66 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
3792 66 : xx=kinpw(ig-igs)
3793 : ! teter polynomial ratio
3794 66 : poly=27._dp+xx*(18._dp+xx*(12._dp+xx*8._dp))
3795 66 : fac=poly/(poly+16._dp*xx**4)
3796 66 : if (optekin==1) fac=two*fac
3797 66 : pcon(ig-igs,1)=fac
3798 594 : do iblocksize=1,blocksize
3799 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3800 594 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,1)
3801 : end do
3802 : else
3803 0 : pcon(ig-igs,1)=zero
3804 0 : vect(ig,:)=0.0_dp
3805 : end if
3806 : else
3807 4059 : do iblocksize=1,blocksize
3808 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3809 4059 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,1)
3810 : end do
3811 : end if
3812 : end do
3813 22464 : do ig=2+igs,npw+igs
3814 22464 : if (iterationnumber==1) then
3815 2805 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
3816 2805 : xx=kinpw(ig-igs)
3817 : ! teter polynomial ratio
3818 2805 : poly=27._dp+xx*(18._dp+xx*(12._dp+xx*8._dp))
3819 2805 : fac=poly/(poly+16._dp*xx**4)
3820 2805 : if (optekin==1) fac=two*fac
3821 2805 : pcon(ig-igs,1)=fac
3822 25245 : do iblocksize=1,blocksize
3823 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3824 22440 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,1)
3825 : vect(ig+npw-1,iblocksize)=(ghc(ig+npw-1,iblocksize)-&
3826 25245 : & eval(iblocksize,iblocksize)*cg(ig+npw-1,iblocksize))*pcon(ig-igs,1)
3827 : end do
3828 : else
3829 0 : pcon(ig-igs,1)=zero
3830 0 : vect(ig,:)=zero
3831 0 : vect(ig+npw-1,:)=zero
3832 : end if
3833 : else
3834 172278 : do iblocksize=1,blocksize
3835 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3836 153136 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,1)
3837 : vect(ig+npw-1,iblocksize)=(ghc(ig+npw-1,iblocksize)-&
3838 172278 : & eval(iblocksize,iblocksize)*cg(ig+npw-1,iblocksize))*pcon(ig-igs,1)
3839 : end do
3840 : end if
3841 : end do
3842 : else
3843 13986 : do ig=1+igs,npw+igs
3844 13986 : if (iterationnumber==1) then
3845 1683 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
3846 1683 : xx=kinpw(ig-igs)
3847 : ! teter polynomial ratio
3848 1683 : poly=27._dp+xx*(18._dp+xx*(12._dp+xx*8._dp))
3849 1683 : fac=poly/(poly+16._dp*xx**4)
3850 1683 : if (optekin==1) fac=two*fac
3851 1683 : pcon(ig-igs,1)=fac
3852 15147 : do iblocksize=1,blocksize
3853 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3854 13464 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,1)
3855 : vect(ig+npw,iblocksize)=(ghc(ig+npw,iblocksize)-&
3856 15147 : & eval(iblocksize,iblocksize)*cg(ig+npw,iblocksize))*pcon(ig-igs,1)
3857 : end do
3858 : else
3859 0 : pcon(ig-igs,:)=zero
3860 0 : vect(ig,:)=zero
3861 0 : vect(ig+npw,:)=zero
3862 : end if
3863 : else
3864 103734 : do iblocksize=1,blocksize
3865 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3866 92208 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,1)
3867 : vect(ig+npw,iblocksize)=(ghc(ig+npw,iblocksize)-&
3868 103734 : & eval(iblocksize,iblocksize)*cg(ig+npw,iblocksize))*pcon(ig-igs,1)
3869 : end do
3870 : end if
3871 : end do
3872 : end if
3873 : end do
3874 :
3875 785 : else if (optpcon>0) then
3876 : ! Compute mean kinetic energy of all bands
3877 2355 : ABI_MALLOC(ek0,(blocksize))
3878 1570 : ABI_MALLOC(ek0_inv,(blocksize))
3879 785 : if (iterationnumber==1.or.optpcon==1) then
3880 1570 : do iblocksize=1,blocksize
3881 1570 : if (me_g0 == 1)then
3882 785 : ek0(iblocksize)=0.0_dp ; ipw1=2
3883 785 : if(kinpw(1)<huge(zero)*1.d-11)ek0(iblocksize)=0.5_dp*kinpw(1)*cg(1,iblocksize)**2
3884 11775 : do ig=ipw1,npw
3885 11775 : if(kinpw(ig)<huge(zero)*1.d-11)then
3886 : ek0(iblocksize)=ek0(iblocksize)+&
3887 10990 : & kinpw(ig)*(cg(ig,iblocksize)**2+cg(ig+npw-1,iblocksize)**2)
3888 : end if
3889 : end do
3890 : else
3891 0 : ek0(iblocksize)=0.0_dp ; ipw1=1
3892 0 : do ig=ipw1,npw
3893 0 : if(kinpw(ig)<huge(zero)*1.d-11)then
3894 : ek0(iblocksize)=ek0(iblocksize)+&
3895 0 : & kinpw(ig)*(cg(ig,iblocksize)**2+cg(ig+npw,iblocksize)**2)
3896 : end if
3897 : end do
3898 : end if
3899 : end do
3900 :
3901 785 : call xmpi_sum(ek0,comm,ierr)
3902 :
3903 1570 : do iblocksize=1,blocksize
3904 1570 : if(ek0(iblocksize)<1.0d-10)then
3905 0 : write(msg, '(4a)' )ch10,&
3906 0 : 'cg_precon_block: the mean kinetic energy of a wavefunction vanishes.',ch10,&
3907 0 : 'it is reset to 0.1ha.'
3908 0 : ABI_WARNING(msg)
3909 0 : ek0(iblocksize)=0.1_dp
3910 : end if
3911 : end do
3912 785 : if (optekin==1) then
3913 0 : ek0_inv(:)=2.0_dp/(3._dp*ek0(:))
3914 : else
3915 1570 : ek0_inv(:)=1.0_dp/ek0(:)
3916 : end if
3917 : end if !iterationnumber==1.or.optpcon==1
3918 :
3919 : ! Carry out preconditioning
3920 1570 : do iblocksize=1,blocksize
3921 2355 : do ispinor=1,nspinor
3922 785 : igs=(ispinor-1)*npw
3923 1570 : if (me_g0 == 1) then
3924 1570 : do ig=1+igs,1+igs !g=0
3925 1570 : if (iterationnumber==1.or.optpcon==1) then
3926 785 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
3927 785 : xx=kinpw(ig-igs)*ek0_inv(iblocksize)
3928 : ! teter polynomial ratio
3929 785 : poly=27._dp+xx*(18._dp+xx*(12._dp+xx*8._dp))
3930 785 : fac=poly/(poly+16._dp*xx**4)
3931 785 : if (optekin==1) fac=two*fac
3932 785 : pcon(ig-igs,iblocksize)=fac
3933 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3934 785 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*fac
3935 : else
3936 0 : pcon(ig-igs,iblocksize)=zero
3937 0 : vect(ig,iblocksize)=0.0_dp
3938 : end if
3939 : else
3940 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3941 0 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,iblocksize)
3942 : end if
3943 : end do
3944 11775 : do ig=2+igs,npw+igs
3945 11775 : if (iterationnumber==1.or.optpcon==1) then
3946 10990 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
3947 10990 : xx=kinpw(ig-igs)*ek0_inv(iblocksize)
3948 : ! teter polynomial ratio
3949 10990 : poly=27._dp+xx*(18._dp+xx*(12._dp+xx*8._dp))
3950 10990 : fac=poly/(poly+16._dp*xx**4)
3951 10990 : if (optekin==1) fac=two*fac
3952 10990 : pcon(ig-igs,iblocksize)=fac
3953 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3954 10990 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*fac
3955 : vect(ig+npw-1,iblocksize)=(ghc(ig+npw-1,iblocksize)-&
3956 10990 : & eval(iblocksize,iblocksize)*cg(ig+npw-1,iblocksize))*fac
3957 : else
3958 0 : pcon(ig-igs,iblocksize)=zero
3959 0 : vect(ig,iblocksize)=zero
3960 0 : vect(ig+npw-1,iblocksize)=zero
3961 : end if
3962 : else
3963 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3964 0 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,iblocksize)
3965 : vect(ig+npw-1,iblocksize)=(ghc(ig+npw-1,iblocksize)-&
3966 0 : & eval(iblocksize,iblocksize)*cg(ig+npw-1,iblocksize))*pcon(ig-igs,iblocksize)
3967 : end if
3968 : end do
3969 : else
3970 0 : do ig=1+igs,npw+igs
3971 0 : if (iterationnumber==1.or.optpcon==1) then
3972 0 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
3973 0 : xx=kinpw(ig-igs)*ek0_inv(iblocksize)
3974 : ! teter polynomial ratio
3975 0 : poly=27._dp+xx*(18._dp+xx*(12._dp+xx*8._dp))
3976 0 : fac=poly/(poly+16._dp*xx**4)
3977 0 : if (optekin==1) fac=two*fac
3978 0 : pcon(ig-igs,iblocksize)=fac
3979 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3980 0 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*fac
3981 : vect(ig+npw,iblocksize)=(ghc(ig+npw,iblocksize)-&
3982 0 : & eval(iblocksize,iblocksize)*cg(ig+npw,iblocksize))*fac
3983 : else
3984 0 : pcon(ig-igs,iblocksize)=zero
3985 0 : vect(ig,iblocksize)=zero
3986 0 : vect(ig+npw,iblocksize)=zero
3987 : end if
3988 : else
3989 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
3990 0 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,iblocksize)
3991 : vect(ig+npw,iblocksize)=(ghc(ig+npw,iblocksize)-&
3992 0 : & eval(iblocksize,iblocksize)*cg(ig+npw,iblocksize))*pcon(ig-igs,iblocksize)
3993 : end if
3994 : end do
3995 : end if
3996 : end do
3997 : end do
3998 785 : ABI_FREE(ek0)
3999 785 : ABI_FREE(ek0_inv)
4000 : end if !optpcon
4001 :
4002 2079 : call timab(536,2,tsec)
4003 :
4004 2079 : end subroutine cg_precon_block
4005 : !!***
4006 :
4007 : !!****f* m_cgtools/cg_zprecon_block
4008 : !!
4009 : !! NAME
4010 : !! cg_zprecon_block
4011 : !!
4012 : !! FUNCTION
4013 : !! precondition $<G|(H-e_{n,k})|C_{n,k}>$ for a block of band (band-FFT parallelisation)
4014 : !!
4015 : !! INPUTS
4016 : !! blocksize= size of blocks of bands
4017 : !! $cg(vectsize,blocksize)=<G|C_{n,k}> for a block of bands$.
4018 : !! $eval(blocksize,blocksize)=current block of bands eigenvalues=<C_{n,k}|H|C_{n,k}>$.
4019 : !! $ghc(vectsize,blocksize)=<G|H|C_{n,k}> for a block of bands$.
4020 : !! iterationnumber=number of iterative minimizations in LOBPCG
4021 : !! kinpw(npw)=(modified) kinetic energy for each plane wave (Hartree)
4022 : !! nspinor=number of spinorial components of the wavefunctions (on current proc)
4023 : !! $vect(vectsize,blocksize)=<G|H|C_{n,k}> for a block of bands$.
4024 : !! npw=number of planewaves at this k point.
4025 : !! optekin= 1 if the kinetic energy used in preconditionning is modified
4026 : !! according to Kresse, Furthmuller, PRB 54, 11169 (1996) [[cite:Kresse1996]]
4027 : !! 0 otherwise
4028 : !! optpcon= 0 the TPA preconditionning matrix does not depend on band
4029 : !! 1 the TPA preconditionning matrix (not modified)
4030 : !! 2 the TPA preconditionning matrix is independent of iteration number
4031 : !! vectsize= size of vectors
4032 : !! comm=MPI communicator.
4033 : !!
4034 : !! OUTPUT
4035 : !! vect(2,npw)=<g|(h-eval)|c_{n,k}>*(polynomial ratio)
4036 : !!
4037 : !! SIDE EFFECTS
4038 : !! pcon(npw,blocksize)=preconditionning matrix
4039 : !! input if optpcon=0,2 and iterationnumber/=1
4040 : !! output if optpcon=0,2 and iterationnumber==1
4041 : !!
4042 : !! SOURCE
4043 :
4044 32472 : subroutine cg_zprecon_block(cg,eval,blocksize,iterationnumber,kinpw,&
4045 32472 : & npw,nspinor,optekin,optpcon,pcon,ghc,vect,vectsize,comm)
4046 :
4047 : !Arguments ------------------------------------
4048 : !scalars
4049 : integer,intent(in) :: blocksize,iterationnumber,npw,nspinor,optekin
4050 : integer,intent(in) :: optpcon,vectsize,comm
4051 : !arrays
4052 : real(dp),intent(in) :: kinpw(npw)
4053 : real(dp),intent(inout) :: pcon(npw,blocksize)
4054 : complex(dp),intent(in) :: cg(vectsize,blocksize),eval(blocksize,blocksize)
4055 : complex(dp),intent(in) :: ghc(vectsize,blocksize)
4056 : complex(dp),intent(inout) :: vect(vectsize,blocksize)
4057 :
4058 : !Local variables-------------------------------
4059 : !scalars
4060 : integer :: iblocksize,ierr,ig,igs,ispinor
4061 : real(dp) :: fac,poly,xx
4062 : !character(len=500) :: msg
4063 : !arrays
4064 : real(dp) :: tsec(2)
4065 32472 : real(dp),allocatable :: ek0(:),ek0_inv(:)
4066 : ! *************************************************************************
4067 :
4068 32472 : call timab(536,1,tsec)
4069 :
4070 : !In this case, the Teter, Allan and Payne preconditioner is approximated:
4071 : !the factor xx=Ekin(G) and no more Ekin(G)/Ekin(iband)
4072 32472 : if (optpcon==0) then
4073 36353 : do ispinor=1,nspinor
4074 20765 : igs=(ispinor-1)*npw
4075 1226695 : do ig=1+igs,npw+igs
4076 1211107 : if (iterationnumber==1) then
4077 152075 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
4078 152075 : xx=kinpw(ig-igs)
4079 : ! teter polynomial ratio
4080 152075 : poly=27._dp+xx*(18._dp+xx*(12._dp+xx*8._dp))
4081 152075 : fac=poly/(poly+16._dp*xx**4)
4082 152075 : if (optekin==1) fac=two*fac
4083 152075 : pcon(ig-igs,1)=fac
4084 1658899 : do iblocksize=1,blocksize
4085 1658899 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,1)
4086 : end do
4087 : else
4088 0 : pcon(ig-igs,1)=zero
4089 0 : vect(ig,:)=dcmplx(0.0_dp,0.0_dp)
4090 : end if
4091 : else
4092 11266179 : do iblocksize=1,blocksize
4093 11266179 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,1)
4094 : end do
4095 : end if
4096 : end do
4097 : end do
4098 :
4099 16884 : else if (optpcon>0) then
4100 : ! Compute mean kinetic energy of all bands
4101 50652 : ABI_MALLOC(ek0,(blocksize))
4102 33768 : ABI_MALLOC(ek0_inv,(blocksize))
4103 16884 : if (iterationnumber==1.or.optpcon==1) then
4104 50192 : do iblocksize=1,blocksize
4105 33308 : ek0(iblocksize)=0.0_dp
4106 83500 : do ispinor=1,nspinor
4107 33308 : igs=(ispinor-1)*npw
4108 7882840 : do ig=1+igs,npw+igs
4109 7849532 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
4110 : ek0(iblocksize)=ek0(iblocksize)+kinpw(ig-igs)*&
4111 7816224 : & (real(cg(ig,iblocksize))**2+aimag(cg(ig,iblocksize))**2)
4112 : end if
4113 : end do
4114 : end do
4115 : end do
4116 :
4117 16884 : call xmpi_sum(ek0,comm,ierr)
4118 :
4119 50192 : do iblocksize=1,blocksize
4120 50192 : if(ek0(iblocksize)<1.0d-10)then
4121 0 : ABI_WARNING('the mean kinetic energy of a wavefunction vanishes. it is reset to 0.1ha.')
4122 0 : ek0(iblocksize)=0.1_dp
4123 : end if
4124 : end do
4125 16884 : if (optekin==1) then
4126 0 : ek0_inv(:)=2.0_dp/(3._dp*ek0(:))
4127 : else
4128 50192 : ek0_inv(:)=1.0_dp/ek0(:)
4129 : end if
4130 : end if !iterationnumber==1.or.optpcon==1
4131 :
4132 : ! Carry out preconditioning
4133 50192 : do iblocksize=1,blocksize
4134 83500 : do ispinor=1,nspinor
4135 33308 : igs=(ispinor-1)*npw
4136 7882840 : do ig=1+igs,npw+igs
4137 7849532 : if (iterationnumber==1.or.optpcon==1) then
4138 7816224 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
4139 7816224 : xx=kinpw(ig-igs)*ek0_inv(iblocksize)
4140 : ! teter polynomial ratio
4141 7816224 : poly=27._dp+xx*(18._dp+xx*(12._dp+xx*8._dp))
4142 7816224 : fac=poly/(poly+16._dp*xx**4)
4143 7816224 : if (optekin==1) fac=two*fac
4144 7816224 : pcon(ig-igs,iblocksize)=fac
4145 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
4146 7816224 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,iblocksize)
4147 : else
4148 0 : pcon(ig-igs,iblocksize)=zero
4149 0 : vect(ig,iblocksize)=dcmplx(0.0_dp,0.0_dp)
4150 : end if
4151 : else
4152 : vect(ig,iblocksize)=(ghc(ig,iblocksize)-&
4153 0 : & eval(iblocksize,iblocksize)*cg(ig,iblocksize))*pcon(ig-igs,iblocksize)
4154 : end if
4155 : end do
4156 : end do
4157 : end do
4158 16884 : ABI_FREE(ek0)
4159 16884 : ABI_FREE(ek0_inv)
4160 : end if !optpcon
4161 :
4162 32472 : call timab(536,2,tsec)
4163 :
4164 32472 : end subroutine cg_zprecon_block
4165 : !!***
4166 :
4167 : !!****f* m_cgtools/fxphas_seq
4168 : !!
4169 : !! NAME
4170 : !! fxphas_seq
4171 : !!
4172 : !! FUNCTION
4173 : !! Fix phase of all bands. Keep normalization but maximize real part (minimize imag part).
4174 : !! Also fix the sign of real part by setting the first non-zero element to be positive.
4175 : !!
4176 : !! This version has been stripped of all the mpi_enreg junk by MJV
4177 : !! Use cgtk_fixphase if you need a routine that works with mpi_enreg and paral_kgb
4178 : !!
4179 : !! INPUTS
4180 : !! cg(2,mcg)= contains the wavefunction |c> coefficients.
4181 : !! gsc(2,mgsc)= if useoverlap==1, contains the S|c> coefficients,
4182 : !! where S is an overlap matrix.
4183 : !! icg=shift to be applied on the location of data in the array cg
4184 : !! igsc=shift to be applied on the location of data in the array gsc
4185 : !! istwfk=input option parameter that describes the storage of wfs
4186 : !! (set to 1 if usual complex vectors)
4187 : !! mcg=size of second dimension of cg
4188 : !! mgsc=size of second dimension of gsc
4189 : !! nband_k=number of bands
4190 : !! npw_k=number of planewaves
4191 : !! useoverlap=describe the overlap of wavefunctions:
4192 : !! 0: no overlap (S=Identity_matrix)
4193 : !! 1: PAW wavefunctions
4194 : !!
4195 : !! OUTPUT
4196 : !! cg(2,mcg)=same array with altered phase.
4197 : !! gsc(2,mgsc)= same array with altered phase.
4198 : !!
4199 : !! SOURCE
4200 :
4201 373055 : subroutine fxphas_seq(cg, gsc, icg, igsc, istwfk, mcg, mgsc, nband_k, npw_k, useoverlap)
4202 :
4203 : !Arguments ------------------------------------
4204 : !scalars
4205 : integer,intent(in) :: icg,igsc,istwfk,mcg,mgsc,nband_k,npw_k,useoverlap
4206 : !arrays
4207 : real(dp),intent(inout) :: cg(2,mcg),gsc(2,mgsc*useoverlap)
4208 :
4209 : !Local variables-------------------------------
4210 : !scalars
4211 : integer :: iband,ii,indx
4212 : real(dp) :: cim,cre,gscim,gscre,quotient,root1,root2,saa,sab,sbb,theta
4213 : real(dp) :: thppi,xx,yy
4214 : character(len=500) :: msg
4215 : !arrays
4216 373055 : real(dp),allocatable :: cimb(:),creb(:),saab(:),sabb(:),sbbb(:) !,sarr(:,:)
4217 : ! *************************************************************************
4218 :
4219 : !The general case, where a complex phase indeterminacy is present
4220 373055 : if(istwfk==1)then
4221 :
4222 1119165 : ABI_MALLOC(cimb,(nband_k))
4223 746110 : ABI_MALLOC(creb,(nband_k))
4224 746110 : ABI_MALLOC(saab,(nband_k))
4225 746110 : ABI_MALLOC(sabb,(nband_k))
4226 746110 : ABI_MALLOC(sbbb,(nband_k))
4227 5337587 : cimb(:)=zero ; creb(:)=zero
4228 :
4229 : ! Loop over bands
4230 : ! TODO: MG store saa arrays in sarr(3,nband_k) to reduce false sharing.
4231 2855321 : do iband=1,nband_k
4232 2482266 : indx=icg+(iband-1)*npw_k
4233 :
4234 : ! Compute several sums over Re, Im parts of c
4235 2482266 : saa=0.0_dp ; sbb=0.0_dp ; sab=0.0_dp
4236 26878422 : do ii=1+indx,npw_k+indx
4237 24396156 : saa=saa+cg(1,ii)*cg(1,ii)
4238 24396156 : sbb=sbb+cg(2,ii)*cg(2,ii)
4239 26878422 : sab=sab+cg(1,ii)*cg(2,ii)
4240 : end do
4241 2482266 : saab(iband)=saa
4242 2482266 : sbbb(iband)=sbb
4243 2855321 : sabb(iband)=sab
4244 : end do ! iband
4245 :
4246 :
4247 2855321 : do iband=1,nband_k
4248 :
4249 2482266 : indx=icg+(iband-1)*npw_k
4250 :
4251 2482266 : saa=saab(iband)
4252 2482266 : sbb=sbbb(iband)
4253 2482266 : sab=sabb(iband)
4254 :
4255 : ! Get phase angle theta
4256 2482266 : if (sbb+saa>tol8)then
4257 2482266 : if(abs(sbb-saa)>tol8*(sbb+saa) .or. 2*abs(sab)>tol8*(sbb+saa))then
4258 2481157 : if (abs(sbb-saa)>tol8*abs(sab)) then
4259 2480794 : quotient=sab/(sbb-saa)
4260 2480794 : theta=0.5_dp*atan(2.0_dp*quotient)
4261 : else
4262 : ! Taylor expansion of the atan in terms of inverse of its argument. Correct up to 1/x2, included.
4263 363 : theta=0.25_dp*(pi-(sbb-saa)/sab)
4264 : end if
4265 : ! Check roots to get theta for max Re part
4266 2481157 : root1=cos(theta)**2*saa+sin(theta)**2*sbb-2.0_dp*cos(theta)*sin(theta)*sab
4267 2481157 : thppi=theta+0.5_dp*pi
4268 2481157 : root2=cos(thppi)**2*saa+sin(thppi)**2*sbb-2.0_dp*cos(thppi)*sin(thppi)*sab
4269 2481157 : if (root2>root1) theta=thppi
4270 : else
4271 : ! The real part vector and the imaginary part vector are orthogonal, and of same norm. Strong indeterminacy.
4272 : ! Will determine the first non-zero coefficient, and fix its phase
4273 1746 : do ii=1+indx,npw_k+indx
4274 1746 : cre=cg(1,ii)
4275 1746 : cim=cg(2,ii)
4276 1746 : if(cre**2+cim**2>tol8**2*(saa+sbb))then
4277 1109 : if(cre**2>tol8**2**cim**2)then
4278 916 : theta=atan(cim/cre)
4279 : else
4280 : ! Taylor expansion of the atan in terms of inverse of its argument. Correct up to 1/x2, included.
4281 193 : theta=pi/2-cre/cim
4282 : end if
4283 : exit
4284 : end if
4285 : end do
4286 : end if
4287 : else
4288 : write(msg,'(a,i0,5a)')&
4289 0 : 'The eigenvector with band ',iband,' has zero norm.',ch10,&
4290 0 : 'This usually happens when the number of bands (nband) is comparable to the number of planewaves (mpw)',ch10,&
4291 0 : 'Action: Check the parameters of the calculation. If nband ~ mpw, then decrease nband or, alternatively, increase ecut'
4292 0 : ABI_ERROR(msg)
4293 : end if
4294 :
4295 2482266 : xx=cos(theta)
4296 2482266 : yy=sin(theta)
4297 :
4298 : ! Here, set the first non-zero element to be positive
4299 3112150 : do ii=1+indx,npw_k+indx
4300 3112150 : cre=cg(1,ii)
4301 3112150 : cim=cg(2,ii)
4302 3112150 : cre=xx*cre-yy*cim
4303 3112150 : if(abs(cre)>tol8)exit
4304 : end do
4305 2482266 : if(cre<zero)then
4306 1217696 : xx=-xx ; yy=-yy
4307 : end if
4308 :
4309 2482266 : creb(iband)=xx
4310 2855321 : cimb(iband)=yy
4311 :
4312 : end do
4313 :
4314 2855321 : do iband=1,nband_k
4315 :
4316 2482266 : indx=icg+(iband-1)*npw_k
4317 :
4318 2482266 : xx=creb(iband)
4319 2482266 : yy=cimb(iband)
4320 26878422 : do ii=1+indx,npw_k+indx
4321 24396156 : cre=cg(1,ii)
4322 24396156 : cim=cg(2,ii)
4323 24396156 : cg(1,ii)=xx*cre-yy*cim
4324 26878422 : cg(2,ii)=xx*cim+yy*cre
4325 : end do
4326 :
4327 : ! Alter phase of array S|cg>
4328 2855321 : if (useoverlap==1) then
4329 0 : indx=igsc+(iband-1)*npw_k
4330 0 : do ii=1+indx,npw_k+indx
4331 0 : gscre=gsc(1,ii)
4332 0 : gscim=gsc(2,ii)
4333 0 : gsc(1,ii)=xx*gscre-yy*gscim
4334 0 : gsc(2,ii)=xx*gscim+yy*gscre
4335 : end do
4336 : end if
4337 :
4338 : end do ! iband
4339 :
4340 373055 : ABI_FREE(cimb)
4341 373055 : ABI_FREE(creb)
4342 373055 : ABI_FREE(saab)
4343 373055 : ABI_FREE(sabb)
4344 373055 : ABI_FREE(sbbb)
4345 :
4346 : else ! if istwfk/=1
4347 : ! Storages that take into account the time-reversal symmetry: the freedom is only a sign freedom
4348 :
4349 0 : ABI_MALLOC(creb,(nband_k))
4350 0 : creb(:)=zero
4351 : ! Loop over bands
4352 0 : do iband=1,nband_k
4353 :
4354 0 : indx=icg+(iband-1)*npw_k
4355 :
4356 : ! Here, set the first non-zero real element to be positive
4357 0 : do ii=1+indx,npw_k+indx
4358 0 : cre=cg(1,ii)
4359 0 : if(abs(cre)>tol8)exit
4360 : end do
4361 0 : creb(iband)=cre
4362 :
4363 : end do ! iband
4364 :
4365 0 : do iband=1,nband_k
4366 :
4367 0 : cre=creb(iband)
4368 0 : if(cre<zero)then
4369 0 : indx=icg+(iband-1)*npw_k
4370 0 : do ii=1+indx,npw_k+indx
4371 0 : cg(1,ii)=-cg(1,ii)
4372 0 : cg(2,ii)=-cg(2,ii)
4373 : end do
4374 0 : if(useoverlap==1)then
4375 0 : indx=igsc+(iband-1)*npw_k
4376 0 : do ii=1+indx,npw_k+indx
4377 0 : gsc(1,ii)=-gsc(1,ii)
4378 0 : gsc(2,ii)=-gsc(2,ii)
4379 : end do
4380 : end if
4381 : end if
4382 :
4383 : end do ! iband
4384 :
4385 0 : ABI_FREE(creb)
4386 :
4387 : end if ! istwfk
4388 :
4389 373055 : end subroutine fxphas_seq
4390 : !!***
4391 :
4392 : !----------------------------------------------------------------------
4393 :
4394 : !!****f* m_cgtools/fxphas_and_cmp
4395 : !! NAME
4396 : !! fxphas_and_cmp
4397 : !!
4398 : !! FUNCTION
4399 : !! Fix phase and compare two set of wavefunctions
4400 : !!
4401 : !! OUTPUT
4402 : !!
4403 : !! SOURCE
4404 :
4405 0 : logical function fxphas_and_cmp(npw_k, nspinor, nband_k, istwfk, cg1, cg2, eig_k, msg, atol_rho, atol_dphi) result(ok)
4406 :
4407 : !Arguments ------------------------------------
4408 : integer,intent(in) :: npw_k, nspinor, nband_k, istwfk
4409 : real(dp),intent(inout) :: cg1(2, npw_k*nspinor, nband_k), cg2(2, npw_k*nspinor, nband_k)
4410 : real(dp),intent(in) :: eig_k(nband_k)
4411 : character(len=*),intent(out) :: msg
4412 : real(dp),optional,intent(in) :: atol_rho, atol_dphi
4413 :
4414 : !Local variables-------------------------------
4415 : integer, parameter :: useoverlap0 = 0, mgsc = 0
4416 : integer :: ipw, mcg, band, ipwsp, isp
4417 : real(dp) :: phi1, rho1, phi2, rho2, max_rho_adiff, atol_rho__, phi_diff_ref, max_dphi_adiff, atol_dphi__, gsc(0,0)
4418 : character(len=500) :: btype
4419 : ! ***********************************************************************
4420 :
4421 0 : atol_rho__ = tol6; if (present(atol_rho)) atol_rho__ = atol_rho
4422 0 : atol_dphi__ = tol3; if (present(atol_dphi)) atol_dphi__ = atol_dphi
4423 0 : max_rho_adiff = zero; max_dphi_adiff = zero; phi_diff_ref = huge(one)
4424 :
4425 0 : mcg = npw_k * nspinor * nband_k
4426 0 : call fxphas_seq(cg1, gsc, 1, 1, istwfk, mcg, mgsc, nband_k, npw_k * nspinor, useoverlap0)
4427 0 : call fxphas_seq(cg2, gsc, 1, 1, istwfk, mcg, mgsc, nband_k, npw_k * nspinor, useoverlap0)
4428 :
4429 0 : do band=1,nband_k
4430 0 : call band_type(band, btype)
4431 0 : if (btype == "degenerate") cycle
4432 : !write(234, *)"band: ", band, "istwfk: ", istwfk, trim(btype)
4433 : !write(235, *)"band: ", band, "istwfk:", istwfk, trim(btype)
4434 : !write(234, *)"cg1:"; write(235, *)"cg2:"
4435 : !write(234, *)"cg1 rho:"; write(235, *)"cg2 rho phi:"
4436 0 : do isp=1,nspinor
4437 0 : do ipw=1,npw_k
4438 0 : ipwsp = ipw + (isp - 1) * npw_k
4439 : !if (npw_k > 15 .and. ipw > 15 .and. ipw < npw_k - 15) cycle
4440 : !write(234, *)ipwsp, cg1(1, ipwsp, band); write(234, *)ipwsp, cg1(2, ipwsp, band)
4441 : !write(235, *)ipwsp, cg2(1, ipwsp, band); write(235, *)ipwsp, cg2(2, ipwsp, band)
4442 0 : call rhophi(cg1(:, ipwsp, band), phi1, rho1)
4443 0 : call rhophi(cg2(:, ipwsp, band), phi2, rho2)
4444 : !write(234, *)ipwsp, rho1!; write(234, *)ipwsp, phi1
4445 : !write(235, *)ipwsp, rho2!; write(235, *)ipwsp, phi2
4446 : end do
4447 : end do
4448 : end do
4449 :
4450 0 : do band=1,nband_k
4451 0 : do ipw=1,npw_k * nspinor
4452 0 : call rhophi(cg1(:, ipw, band), phi1, rho1)
4453 0 : call rhophi(cg2(:, ipw, band), phi2, rho2)
4454 0 : max_rho_adiff = max(max_rho_adiff, abs(rho1 - rho2))
4455 0 : if (rho1 > atol_rho__ ** 2) then
4456 : if (phi_diff_ref /= huge(one)) phi_diff_ref = phi1 - phi2
4457 0 : max_dphi_adiff = max(max_dphi_adiff, abs(phi_diff_ref - (phi1 - phi2)))
4458 : end if
4459 : end do
4460 : end do
4461 :
4462 0 : write(msg, "(2(a,es12.4))")"max_rho_adiff: ", max_rho_adiff, ", max_dphi_adiff: ", max_dphi_adiff
4463 0 : ok = (max_rho_adiff < atol_rho__ .and. max_dphi_adiff < atol_dphi__)
4464 :
4465 : contains
4466 0 : subroutine band_type(band, btype)
4467 : integer,intent(in) :: band
4468 : character(len=*),intent(out) :: btype
4469 : real(dp) :: e0
4470 :
4471 0 : e0 = eig_k(band)
4472 :
4473 0 : if (band == 1) then
4474 0 : btype = "last_state"
4475 0 : if (nband_k > 1) then
4476 0 : btype = "non-degenerate"
4477 0 : if (abs(e0 - eig_k(band + 1)) < tol6) btype = "degenerate"
4478 : end if
4479 :
4480 0 : else if (band == nband_k) then
4481 0 : btype = "last_state"
4482 0 : if (band - 1 > 0) then
4483 0 : if (abs(e0 - eig_k(band - 1)) < tol6) btype = "degenerate"
4484 : end if
4485 :
4486 : else
4487 0 : btype = "non-degenerate"
4488 0 : if (abs(e0 - eig_k(band - 1)) < tol6 .or. abs(e0 - eig_k(band + 1)) < tol6) btype = "degenerate"
4489 : end if
4490 :
4491 0 : end subroutine band_type
4492 :
4493 : end function fxphas_and_cmp
4494 : !!***
4495 :
4496 : !!****f* m_cgtools/overlap_g
4497 : !! NAME
4498 : !! overlap_g
4499 : !!
4500 : !! FUNCTION
4501 : !! Compute the scalar product between WF at two different k-points
4502 : !! < u_{n,k1} | u_{n,k2}>
4503 : !!
4504 : !! INPUTS
4505 : !! mpw = maximum dimensioned size of npw
4506 : !! npw_k1 = number of plane waves at k1
4507 : !! npw_k2 = number of plane waves at k2
4508 : !! nspinor = 1 for scalar, 2 for spinor wavefunctions
4509 : !! pwind_k = array required to compute the scalar product (see initberry.f)
4510 : !! vect1 = wavefunction at k1: | u_{n,k1} >
4511 : !! vect2 = wavefunction at k1: | u_{n,k2} >
4512 : !!
4513 : !! OUTPUT
4514 : !! doti = imaginary part of the scalarproduct
4515 : !! dotr = real part of the scalarproduct
4516 : !!
4517 : !! NOTES
4518 : !! In case a G-vector of the basis sphere of plane waves at k1
4519 : !! does not belong to the basis sphere of plane waves at k2,
4520 : !! pwind = 0. Therefore, the dimensions of vect1 &
4521 : !! vect2 are (1:2,0:mpw) and the element (1:2,0) MUST be set to zero.
4522 : !!
4523 : !! The current implementation if not compatible with TR-symmetry (i.e. istwfk/=1) !
4524 : !!
4525 : !! SOURCE
4526 :
4527 137044504 : subroutine overlap_g(doti,dotr,mpw,npw_k1,npw_k2,nspinor,pwind_k,vect1,vect2)
4528 :
4529 : !Arguments ------------------------------------
4530 : !scalars
4531 : integer,intent(in) :: mpw,npw_k1,npw_k2,nspinor
4532 : real(dp),intent(out) :: doti,dotr
4533 : !arrays
4534 : integer,intent(in) :: pwind_k(mpw)
4535 : real(dp),intent(in) :: vect1(1:2,0:mpw*nspinor),vect2(1:2,0:mpw*nspinor)
4536 :
4537 : !Local variables-------------------------------
4538 : !scalars
4539 : integer :: ipw,ispinor,jpw,spnshft1,spnshft2
4540 : ! *************************************************************************
4541 :
4542 : !Check if vect1(:,0) = 0 and vect2(:,0) = 0
4543 : if ((abs(vect1(1,0)) > tol12).or.(abs(vect1(2,0)) > tol12).or. &
4544 137044504 : & (abs(vect2(1,0)) > tol12).or.(abs(vect2(2,0)) > tol12)) then
4545 0 : ABI_BUG('vect1(:,0) and/or vect2(:,0) are not equal to zero')
4546 : end if
4547 :
4548 : !Compute the scalar product
4549 137044504 : dotr = zero; doti = zero
4550 276437008 : do ispinor = 1, nspinor
4551 139392504 : spnshft1 = (ispinor-1)*npw_k1
4552 139392504 : spnshft2 = (ispinor-1)*npw_k2
4553 : !$OMP PARALLEL DO PRIVATE(jpw) REDUCTION(+:doti,dotr)
4554 23151736580 : do ipw = 1, npw_k1
4555 22875299572 : jpw = pwind_k(ipw)
4556 22875299572 : dotr = dotr + vect1(1,spnshft1+ipw)*vect2(1,spnshft2+jpw) + vect1(2,spnshft1+ipw)*vect2(2,spnshft2+jpw)
4557 23014692076 : doti = doti + vect1(1,spnshft1+ipw)*vect2(2,spnshft2+jpw) - vect1(2,spnshft1+ipw)*vect2(1,spnshft2+jpw)
4558 : end do
4559 : end do
4560 :
4561 137044504 : end subroutine overlap_g
4562 : !!***
4563 :
4564 : !!****f* ABINIT/subdiago
4565 : !! NAME
4566 : !! subdiago
4567 : !!
4568 : !! FUNCTION
4569 : !! This routine diagonalizes the Hamiltonian in the trial subspace.
4570 : !!
4571 : !! INPUTS
4572 : !! icg=shift to be applied on the location of data in the array cg
4573 : !! igsc=shift to be applied on the location of data in the array gsc
4574 : !! istwf_k=input parameter that describes the storage of wfs
4575 : !! mcg=second dimension of the cg array
4576 : !! mgsc=second dimension of the gsc array
4577 : !! nband_k=number of bands at this k point for that spin polarization
4578 : !! npw_k=number of plane waves at this k point
4579 : !! my_nspinor=number of spinorial components of the wavefunctions (on current proc)
4580 : !! use_subovl=1 if the overlap matrix is not identity in WFs subspace
4581 : !! usepaw= 0 for non paw calculation; =1 for paw calculation
4582 : !! me_g0=1 if this processor has G=0, 0 otherwise.
4583 : !!
4584 : !! OUTPUT
4585 : !! eig_k(nband_k)=array for holding eigenvalues (hartree)
4586 : !! evec(2*nband_k,nband_k)=array for holding eigenvectors
4587 : !!
4588 : !! SIDE EFFECTS
4589 : !! subham(nband_k*(nband_k+1))=Hamiltonian expressed in the WFs subspace. Hermitianized in output.
4590 : !! subovl(nband_k*(nband_k+1)*use_subovl)=overlap matrix expressed in the WFs subspace. Hermitianized in output.
4591 : !! cg(2,mcg)=wavefunctions
4592 : !! gsc(2,mgsc)=<g|S|c> matrix elements (S=overlap)
4593 : !!
4594 : !! SOURCE
4595 :
4596 445643 : subroutine subdiago(cg, eig_k, evec, gsc, icg, igsc, istwf_k, mcg, mgsc, nband_k, npw_k, my_nspinor, paral_kgb, &
4597 445643 : subham, subovl, use_subovl, usepaw, me_g0)
4598 :
4599 : !Arguments ------------------------------------
4600 : integer,intent(in) :: icg,igsc,istwf_k,mcg,mgsc,nband_k,npw_k,me_g0
4601 : integer,intent(in) :: my_nspinor,paral_kgb,use_subovl,usepaw
4602 : real(dp),intent(inout) :: subham(nband_k*(nband_k+1)),subovl(nband_k*(nband_k+1)*use_subovl)
4603 : real(dp),intent(out) :: eig_k(nband_k),evec(2*nband_k,nband_k)
4604 : real(dp),intent(inout) :: cg(2,mcg),gsc(2,mgsc)
4605 :
4606 : !Local variables-------------------------------
4607 : integer :: iband,ii,ierr,rvectsize,vectsize,use_slk
4608 : !real(dp) :: cpu, wall, gflops
4609 : character(len=500) :: msg
4610 : ! real(dp) :: tsec(2)
4611 445643 : real(dp),allocatable :: evec_re(:,:),subovl_re(:),subham_tmp(:), work(:,:)
4612 445643 : real(dp),allocatable :: blockvectora(:,:),blockvectorb(:,:),blockvectorc(:,:)
4613 :
4614 : ! *********************************************************************
4615 :
4616 445643 : if (paral_kgb<0) then
4617 0 : ABI_BUG('paral_kgb should be positive ')
4618 : end if
4619 :
4620 : ! 1 if Scalapack version is used.
4621 : ! MG TODO: This should not be bound to paral_kgb
4622 445643 : use_slk = paral_kgb
4623 :
4624 445643 : rvectsize=npw_k*my_nspinor
4625 445643 : vectsize=2*rvectsize;if (me_g0==1) vectsize=vectsize-1
4626 : !call cwtime(cpu, wall, gflops, "start")
4627 :
4628 : !Impose Hermiticity on diagonal elements of subham (and subovl, if needed)
4629 : ! MG FIXME: In these two calls we are aliasing the args
4630 445643 : call hermit(subham, subham, ierr, nband_k)
4631 445643 : if (use_subovl==1) call hermit(subovl, subovl, ierr, nband_k)
4632 : !call cwtime_report(" hermit", cpu, wall, gflops)
4633 :
4634 : ! Diagonalize the Hamitonian matrix
4635 445643 : if (istwf_k==2) then
4636 2230598 : ABI_CALLOC(evec_re, (nband_k,nband_k))
4637 50355 : ABI_MALLOC(subham_tmp, (nband_k*(nband_k+1)/2))
4638 1115299 : subham_tmp=subham(1:nband_k*(nband_k+1):2)
4639 16785 : if (use_subovl==1) then
4640 0 : ABI_MALLOC(subovl_re, (nband_k*(nband_k+1)/2))
4641 0 : subovl_re=subovl(1:nband_k*(nband_k+1):2)
4642 : ! TODO: Not sure this one has been fully tested
4643 0 : call abi_xhpgv(1,'V','U',nband_k,subham_tmp,subovl_re,eig_k,evec_re,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4644 0 : ABI_FREE(subovl_re)
4645 : else
4646 16785 : call abi_xhpev('V','U',nband_k,subham_tmp,eig_k,evec_re,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4647 : end if
4648 6392466 : evec(:,:)=zero; evec(1:2*nband_k:2,:) = evec_re
4649 16785 : ABI_FREE(evec_re)
4650 16785 : ABI_FREE(subham_tmp)
4651 : else
4652 428858 : if (use_subovl==1) then
4653 0 : call abi_xhpgv(1,'V','U',nband_k,subham,subovl,eig_k,evec,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4654 : else
4655 428858 : call abi_xhpev('V','U',nband_k,subham,eig_k,evec,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4656 : end if
4657 : end if
4658 : !call cwtime_report(" hdiago", cpu, wall, gflops)
4659 :
4660 : ! Normalize each eigenvector and set phase:
4661 : ! this is because of the simultaneous diagonalisation of this
4662 : ! matrix by different processors, allowing to get different unitary transforms, thus breaking the
4663 : ! coherency of parts of cg stored on different processors).
4664 : !
4665 : ! The problem with minus/plus signs might be present also if .not. use_subovl
4666 : !
4667 : !if(use_subovl == 0) then
4668 445643 : call cg_normev(evec, nband_k, nband_k)
4669 : !end if
4670 :
4671 445643 : if(istwf_k==2)then
4672 131478 : do iband=1,nband_k
4673 2180243 : do ii=1,nband_k
4674 2163458 : if(abs(evec(2*ii,iband))>1.0d-10)then
4675 0 : write(msg,'(3a,2i0,2es16.6,a,a)')ch10,&
4676 0 : ' For istwf_k=2, observed the following element of evec:',ch10,&
4677 0 : iband,ii,evec(2*ii-1,iband),evec(2*ii,iband),ch10,' with a non-negligible imaginary part.'
4678 0 : ABI_BUG(msg)
4679 : end if
4680 : end do
4681 : end do
4682 : end if
4683 : !call cwtime_report(" normev", cpu, wall, gflops)
4684 :
4685 : !=====================================================
4686 : ! Carry out rotation of bands C(G,n) according to evecs
4687 : ! ZGEMM if istwfk==1, DGEMM if istwfk==2
4688 : !=====================================================
4689 891286 : if (istwf_k==2) then
4690 :
4691 67140 : ABI_MALLOC_OR_DIE(blockvectora, (vectsize, nband_k), ierr)
4692 67140 : ABI_MALLOC_OR_DIE(blockvectorb, (nband_k, nband_k), ierr)
4693 50355 : ABI_MALLOC_OR_DIE(blockvectorc, (vectsize, nband_k), ierr)
4694 :
4695 131478 : do iband=1,nband_k
4696 114693 : if (me_g0 == 1) then
4697 111733 : call abi_xcopy(1,cg(1,cgindex_subd(iband)),1,blockvectora(1,iband),1)
4698 111733 : call abi_xcopy(rvectsize-1,cg(1,cgindex_subd(iband)+1),2,blockvectora(2,iband),1)
4699 111733 : call abi_xcopy(rvectsize-1,cg(2,cgindex_subd(iband)+1),2,blockvectora(rvectsize+1,iband),1)
4700 : else
4701 2960 : call abi_xcopy(rvectsize,cg(1,cgindex_subd(iband)),2,blockvectora(1,iband),1)
4702 2960 : call abi_xcopy(rvectsize,cg(2,cgindex_subd(iband)),2,blockvectora(rvectsize+1,iband),1)
4703 : end if
4704 131478 : call abi_xcopy(nband_k,evec(2*iband-1,1),2*nband_k,blockvectorb(iband,1),nband_k)
4705 : end do
4706 :
4707 : !MG TODO: This one is a DGEMM.
4708 : call abi_xgemm('N','N',vectsize,nband_k,nband_k,&
4709 16785 : cone,blockvectora,vectsize,blockvectorb,nband_k,czero,blockvectorc,vectsize)
4710 :
4711 131478 : do iband=1,nband_k
4712 131478 : if (me_g0 == 1) then
4713 111733 : call abi_xcopy(1,blockvectorc(1,iband),1,cg(1,cgindex_subd(iband)),1)
4714 111733 : call abi_xcopy(rvectsize-1,blockvectorc(2,iband),1,cg(1,cgindex_subd(iband)+1),2)
4715 111733 : call abi_xcopy(rvectsize-1,blockvectorc(rvectsize+1,iband),1,cg(2,cgindex_subd(iband)+1),2)
4716 : else
4717 2960 : call abi_xcopy(rvectsize,blockvectorc(1,iband),1,cg(1,cgindex_subd(iband)),2)
4718 2960 : call abi_xcopy(rvectsize,blockvectorc(rvectsize+1,iband),1,cg(2,cgindex_subd(iband)),2)
4719 : end if
4720 : end do
4721 :
4722 16785 : if (usepaw==1) then
4723 : ! If paw, must also rotate S.C(G,n):
4724 :
4725 35013 : do iband=1,nband_k
4726 31287 : if (me_g0 == 1) then
4727 30799 : call abi_xcopy(1,gsc(1,gscindex_subd(iband)),1,blockvectora(1,iband),1)
4728 30799 : call abi_xcopy(rvectsize-1,gsc(1,gscindex_subd(iband)+1),2,blockvectora(2,iband),1)
4729 30799 : call abi_xcopy(rvectsize-1,gsc(2,gscindex_subd(iband)+1),2,blockvectora(rvectsize+1,iband),1)
4730 : else
4731 488 : call abi_xcopy(rvectsize ,gsc(1,gscindex_subd(iband)),2,blockvectora(1,iband),1)
4732 488 : call abi_xcopy(rvectsize ,gsc(2,gscindex_subd(iband)),2,blockvectora(rvectsize+1,iband),1)
4733 : end if
4734 35013 : call abi_xcopy(nband_k,evec(2*iband-1,1),2*nband_k,blockvectorb(iband,1),nband_k)
4735 : end do
4736 :
4737 : call abi_xgemm('N','N',vectsize,nband_k,nband_k,&
4738 3726 : cone,blockvectora,vectsize,blockvectorb,nband_k,czero,blockvectorc,vectsize)
4739 :
4740 35013 : do iband=1,nband_k
4741 35013 : if (me_g0 == 1) then
4742 30799 : call abi_xcopy(1,blockvectorc(1,iband),1,gsc(1,gscindex_subd(iband)),1)
4743 30799 : call abi_xcopy(rvectsize-1,blockvectorc(2,iband),1,gsc(1,gscindex_subd(iband)+1),2)
4744 30799 : call abi_xcopy(rvectsize-1,blockvectorc(rvectsize+1,iband),1,gsc(2,gscindex_subd(iband)+1),2)
4745 : else
4746 488 : call abi_xcopy(rvectsize,blockvectorc(1,iband),1,gsc(1,gscindex_subd(iband)),2)
4747 488 : call abi_xcopy(rvectsize,blockvectorc(rvectsize+1,iband),1,gsc(2,gscindex_subd(iband)),2)
4748 : end if
4749 : end do
4750 :
4751 : end if
4752 :
4753 16785 : ABI_FREE(blockvectora)
4754 16785 : ABI_FREE(blockvectorb)
4755 16785 : ABI_FREE(blockvectorc)
4756 :
4757 : else
4758 : ! istwf_k /= 2
4759 1286574 : ABI_MALLOC_OR_DIE(work, (2,npw_k*my_nspinor*nband_k), ierr)
4760 :
4761 : ! MG: Do not remove this initialization.
4762 : ! telast_06 stops in fxphase on inca_debug and little_buda (very very strange, due to atlas?)
4763 : !work=zero
4764 :
4765 : call abi_xgemm('N','N',npw_k*my_nspinor,nband_k,nband_k,cone, &
4766 : cg(:,icg+1:npw_k*my_nspinor*nband_k+icg),npw_k*my_nspinor, &
4767 428858 : evec,nband_k,czero,work,npw_k*my_nspinor,x_cplx=2)
4768 :
4769 428858 : call abi_xcopy(npw_k*my_nspinor*nband_k,work(1,1),1,cg(1,1+icg),1,x_cplx=2)
4770 :
4771 428858 : if (usepaw==1) then
4772 : ! If paw, must also rotate S.C(G,n):
4773 : call abi_xgemm('N','N',npw_k*my_nspinor,nband_k,nband_k,cone, &
4774 : gsc(:,1+igsc:npw_k*my_nspinor*nband_k+igsc),npw_k*my_nspinor, &
4775 95575 : evec,nband_k,czero,work,npw_k*my_nspinor,x_cplx=2)
4776 95575 : call abi_xcopy(npw_k*my_nspinor*nband_k, work(1,1),1,gsc(1,1+igsc),1,x_cplx=2)
4777 : end if
4778 :
4779 428858 : ABI_FREE(work)
4780 : end if
4781 : !call cwtime_report(" rotation", cpu, wall, gflops)
4782 :
4783 : contains
4784 :
4785 682238 : function cgindex_subd(iband)
4786 : integer :: iband,cgindex_subd
4787 682238 : cgindex_subd=npw_k*my_nspinor*(iband-1)+icg+1
4788 682238 : end function cgindex_subd
4789 :
4790 186746 : function gscindex_subd(iband)
4791 : integer :: iband,gscindex_subd
4792 186746 : gscindex_subd=npw_k*my_nspinor*(iband-1)+igsc+1
4793 186746 : end function gscindex_subd
4794 :
4795 : end subroutine subdiago
4796 : !!***
4797 :
4798 : !!****f* ABINIT/subdiago_low_memory
4799 : !! NAME
4800 : !! subdiago_low_memory
4801 : !!
4802 : !! FUNCTION
4803 : !! This routine diagonalizes the Hamiltonian in the eigenfunction subspace
4804 : !! Separate the computation in blocks of plane waves to save memory
4805 : !!
4806 : !! INPUTS
4807 : !! icg=shift to be applied on the location of data in the array cg
4808 : !! istwf_k=input parameter that describes the storage of wfs
4809 : !! mcg=second dimension of the cg array
4810 : !! nband_k=number of bands at this k point for that spin polarization
4811 : !! npw_k=number of plane waves at this k point
4812 : !! nspinor=number of spinorial components of the wavefunctions (on current proc)
4813 : !! subham(nband_k*(nband_k+1))=Hamiltonian expressed in the WFs subspace
4814 : !!
4815 : !! OUTPUT
4816 : !! eig_k(nband_k)=array for holding eigenvalues (hartree)
4817 : !! evec(2*nband_k,nband_k)=array for holding eigenvectors
4818 : !!
4819 : !! SIDE EFFECTS
4820 : !! cg(2,mcg)=wavefunctions
4821 : !!
4822 : !! SOURCE
4823 :
4824 0 : subroutine subdiago_low_memory(cg,eig_k,evec,icg,istwf_k,&
4825 : & mcg,nband_k,npw_k,nspinor,paral_kgb,&
4826 0 : & subham)
4827 :
4828 : !Arguments ------------------------------------
4829 : integer,intent(in) :: icg,istwf_k,mcg,nband_k,npw_k
4830 : integer,intent(in) :: nspinor,paral_kgb
4831 : real(dp),intent(inout) :: subham(nband_k*(nband_k+1))
4832 : real(dp),intent(out) :: eig_k(nband_k),evec(2*nband_k,nband_k)
4833 : real(dp),intent(inout),target :: cg(2,mcg)
4834 :
4835 : !Local variables-------------------------------
4836 : integer :: ig,igfirst,block_size,iblock,nblock,block_size_tmp,wfsize
4837 : integer :: iband,ii,ierr,vectsize,use_slk
4838 : character(len=500) :: message
4839 : ! real(dp) :: tsec(2)
4840 0 : real(dp),allocatable :: evec_tmp(:,:),subham_tmp(:), work(:,:)
4841 0 : real(dp),allocatable :: blockvectora(:,:),blockvectorb(:,:),blockvectorc(:,:)
4842 0 : real(dp), contiguous, pointer :: cg_block(:,:)
4843 : ! *********************************************************************
4844 :
4845 0 : if (paral_kgb<0) then
4846 0 : ABI_BUG('paral_kgb should be positive ')
4847 : end if
4848 :
4849 : ! 1 if Scalapack version is used.
4850 0 : use_slk = paral_kgb
4851 :
4852 : !Impose Hermiticity on diagonal elements of subham (and subovl, if needed)
4853 : ! MG FIXME: In these two calls we are aliasing the args
4854 0 : call hermit(subham,subham,ierr,nband_k)
4855 :
4856 : !Diagonalize the Hamitonian matrix
4857 0 : if(istwf_k==2) then
4858 0 : ABI_MALLOC(evec_tmp,(nband_k,nband_k))
4859 0 : ABI_MALLOC(subham_tmp,(nband_k*(nband_k+1)/2))
4860 0 : subham_tmp=subham(1:nband_k*(nband_k+1):2)
4861 0 : evec_tmp=zero
4862 0 : call abi_xhpev('V','U',nband_k,subham_tmp,eig_k,evec_tmp,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4863 0 : evec(:,:)=zero;evec(1:2*nband_k:2,:) =evec_tmp
4864 0 : ABI_FREE(evec_tmp)
4865 0 : ABI_FREE(subham_tmp)
4866 : else
4867 0 : call abi_xhpev('V','U',nband_k,subham,eig_k,evec,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4868 : end if
4869 :
4870 : !Normalize each eigenvector and set phase:
4871 : !The problem with minus/plus signs might be present also if .not. use_subovl
4872 : !if(use_subovl == 0) then
4873 0 : call cg_normev(evec,nband_k,nband_k)
4874 : !end if
4875 :
4876 0 : if(istwf_k==2)then
4877 0 : do iband=1,nband_k
4878 0 : do ii=1,nband_k
4879 0 : if(abs(evec(2*ii,iband))>1.0d-10)then
4880 0 : write(message,'(3a,2i0,2es16.6,a,a)')ch10,&
4881 0 : & ' subdiago: For istwf_k=2, observed the following element of evec :',ch10,&
4882 0 : & iband,ii,evec(2*ii-1,iband),evec(2*ii,iband),ch10,' with a non-negligible imaginary part.'
4883 0 : ABI_BUG(message)
4884 : end if
4885 : end do
4886 : end do
4887 : end if
4888 :
4889 : !=====================================================
4890 : !Carry out rotation of bands C(G,n) according to evecs
4891 : ! ZGEMM if istwfk==1, DGEMM if istwfk==2
4892 : !=====================================================
4893 0 : wfsize=npw_k*nspinor
4894 :
4895 0 : block_size=100
4896 :
4897 0 : if (wfsize<block_size) block_size=wfsize
4898 :
4899 0 : nblock=wfsize/block_size
4900 0 : if (mod(wfsize,block_size)/=0) nblock=nblock+1
4901 :
4902 0 : if (istwf_k>1) then ! evec is real
4903 :
4904 0 : vectsize=2*block_size
4905 :
4906 0 : ABI_MALLOC_OR_DIE(blockvectora,(vectsize,nband_k), ierr)
4907 0 : ABI_MALLOC_OR_DIE(blockvectorb,(nband_k,nband_k), ierr)
4908 0 : ABI_MALLOC_OR_DIE(blockvectorc,(vectsize,nband_k), ierr)
4909 :
4910 0 : do iband=1,nband_k
4911 0 : call abi_xcopy(nband_k,evec(2*iband-1,1),2*nband_k,blockvectorb(iband,1),nband_k)
4912 : end do
4913 :
4914 0 : do iblock=1,nblock
4915 :
4916 0 : igfirst=(iblock-1)*block_size
4917 0 : block_size_tmp=block_size
4918 0 : if (igfirst+block_size>wfsize) then
4919 0 : block_size_tmp=wfsize-igfirst
4920 : end if
4921 :
4922 0 : do iband=1,nband_k
4923 0 : call abi_xcopy(block_size_tmp,cg(1,1+cgindex_subd(iblock,iband)),2,blockvectora(1,iband),1)
4924 0 : call abi_xcopy(block_size_tmp,cg(2,1+cgindex_subd(iblock,iband)),2,blockvectora(block_size+1,iband),1)
4925 0 : if (block_size_tmp<block_size) then
4926 0 : blockvectora(block_size_tmp+1:block_size,iband) = zero
4927 0 : blockvectora(block_size+block_size_tmp+1:2*block_size,iband) = zero
4928 : end if
4929 : end do
4930 :
4931 : call abi_xgemm('N','N',vectsize,nband_k,nband_k,&
4932 0 : & cone,blockvectora,vectsize,blockvectorb,nband_k,czero,blockvectorc,vectsize)
4933 :
4934 0 : do iband=1,nband_k
4935 0 : call abi_xcopy(block_size_tmp,blockvectorc(1,iband),1,cg(1,1+cgindex_subd(iblock,iband)),2)
4936 0 : call abi_xcopy(block_size_tmp,blockvectorc(block_size+1,iband),1,cg(2,1+cgindex_subd(iblock,iband)),2)
4937 : end do
4938 :
4939 : end do
4940 :
4941 0 : ABI_FREE(blockvectora)
4942 0 : ABI_FREE(blockvectorb)
4943 0 : ABI_FREE(blockvectorc)
4944 :
4945 : else ! evec is complex
4946 :
4947 0 : ABI_MALLOC_OR_DIE(work,(2,block_size*nband_k), ierr)
4948 0 : if (nblock==1) then
4949 0 : cg_block => cg(:,icg+1:icg+nband_k*wfsize)
4950 : else
4951 0 : ABI_MALLOC_OR_DIE(cg_block,(2,block_size*nband_k), ierr)
4952 : end if
4953 :
4954 0 : do iblock=1,nblock
4955 0 : igfirst=(iblock-1)*block_size
4956 0 : block_size_tmp=block_size
4957 0 : if (igfirst+block_size>wfsize) then
4958 0 : block_size_tmp=wfsize-igfirst
4959 : end if
4960 0 : if (nblock/=1) then
4961 0 : do iband=1,nband_k
4962 0 : do ig=1,block_size_tmp
4963 0 : cg_block(:,ig+(iband-1)*block_size) = cg(:,ig+cgindex_subd(iblock,iband))
4964 : end do
4965 0 : if (block_size_tmp<block_size) then
4966 0 : do ig=block_size_tmp+1,block_size
4967 0 : cg_block(:,ig+(iband-1)*block_size) = zero
4968 : end do
4969 : end if
4970 : end do
4971 : end if
4972 : call abi_xgemm('N','N',block_size,nband_k,nband_k,cone,cg_block,block_size,evec,nband_k,czero,work,&
4973 0 : & block_size,x_cplx=2)
4974 0 : do iband=1,nband_k
4975 0 : do ig=1,block_size_tmp
4976 0 : cg(:,ig+cgindex_subd(iblock,iband)) = work(:,ig+(iband-1)*block_size)
4977 : end do
4978 : end do
4979 : end do
4980 :
4981 0 : ABI_FREE(work)
4982 0 : if (nblock/=1) then
4983 0 : ABI_FREE(cg_block)
4984 : end if
4985 :
4986 : end if
4987 :
4988 : contains
4989 :
4990 0 : function cgindex_subd(iblock,iband)
4991 :
4992 : integer :: iband,iblock,cgindex_subd
4993 0 : cgindex_subd=(iblock-1)*block_size+(iband-1)*wfsize+icg
4994 : end function cgindex_subd
4995 :
4996 : end subroutine subdiago_low_memory
4997 : !!***
4998 :
4999 : !!****f* m_cgtools/pw_orthon
5000 : !! NAME
5001 : !! pw_orthon
5002 : !!
5003 : !! FUNCTION
5004 : !! Normalize nvec complex vectors each of length nelem and then orthogonalize by modified Gram-Schmidt.
5005 : !! Two orthogonality conditions are available:
5006 : !!
5007 : !! 1) Simple orthogonality: ${<Vec_{i}|Vec_{j}>=Delta_ij}$
5008 : !! 2) Orthogonality with overlap S: ${<Vec_{i}|S|Vec_{j}>=Delta_ij}$
5009 : !!
5010 : !! INPUTS
5011 : !! icg=shift to be given to the location of the data in cg(=vecnm)
5012 : !! igsc=shift to be given to the location of the data in gsc(=ovl_vecnm)
5013 : !! istwf_k=option parameter that describes the storage of wfs
5014 : !! mcg=maximum size of second dimension of cg(=vecnm)
5015 : !! mgsc=maximum size of second dimension of gsc(=ovl_vecnm)
5016 : !! nelem=number of complex elements in each vector
5017 : !! nvec=number of vectors to be orthonormalized
5018 : !! ortalgo= option for the choice of the algorithm
5019 : !! -1: no orthogonalization (direct return)
5020 : !! 0 or 2: old algorithm (use of buffers)
5021 : !! 1: new algorithm (use of blas)
5022 : !! 3: new new algorithm (use of lapack without copy)
5023 : !! useoverlap=select the orthogonality condition
5024 : !! 0: no overlap between vectors
5025 : !! 1: vectors are overlapping
5026 : !! me_g0=1 if this processor has G=0, 0 otherwise
5027 : !! comm=MPI communicator
5028 : !!
5029 : !! SIDE EFFECTS
5030 : !! vecnm= input: vectors to be orthonormalized; array of nvec column
5031 : !! vectors,each of length nelem,shifted by icg
5032 : !! This array is complex or else real(dp) of twice length
5033 : !! output: orthonormalized set of vectors
5034 : !! if (useoverlap==1) only:
5035 : !! ovl_vecnm= input: product of overlap and input vectors:
5036 : !! S|vecnm>,where S is the overlap operator
5037 : !! output: updated S|vecnm> according to vecnm
5038 : !!
5039 : !! NOTES
5040 : !! Note that each vector has an arbitrary phase which is not fixed in this routine.
5041 : !!
5042 : !! WARNING: not yet suited for nspinor=2 with istwfk/=1
5043 : !!
5044 : !! SOURCE
5045 :
5046 493069 : subroutine pw_orthon(icg, igsc, istwf_k, mcg, mgsc, nelem, nvec, ortalgo, ovl_vecnm, useoverlap, vecnm, me_g0, comm)
5047 :
5048 : !Arguments ------------------------------------
5049 : !scalars
5050 : integer,intent(in) :: icg,igsc,istwf_k,mcg,mgsc,nelem,nvec,ortalgo,useoverlap,me_g0,comm
5051 : !arrays
5052 : real(dp),intent(inout) :: ovl_vecnm(2,mgsc*useoverlap),vecnm(2,mcg)
5053 :
5054 : !Local variables-------------------------------
5055 : !scalars
5056 : integer :: ierr,ii,ii0,ii1,ii2,ivec,ivec2
5057 : integer :: rvectsiz,vectsize,cg_idx,gsc_idx
5058 : real(dp) :: doti,dotr,sum,xnorm
5059 : !real(dp) :: cpu, wall, gflops
5060 : #ifdef DEBUG_MODE
5061 : character(len=500) :: msg
5062 : #endif
5063 : !arrays
5064 0 : integer :: cgindex(nvec), gscindex(nvec)
5065 : real(dp) :: buffer2(2),tsec(2)
5066 493069 : real(dp),allocatable :: rblockvectorbx(:,:),rblockvectorx(:,:),rgramxbx(:,:)
5067 493069 : complex(dp),allocatable :: cblockvectorbx(:,:),cblockvectorx(:,:), cgramxbx(:,:)
5068 : ! *************************************************************************
5069 :
5070 : #ifdef DEBUG_MODE
5071 : !Make sure imaginary part at G=0 vanishes
5072 : if (istwf_k == 2 .and. me_g0 == 1) then
5073 : do ivec=1,nvec
5074 : if(abs(vecnm(2,1+nelem*(ivec-1)+icg))>zero)then
5075 : ! if(abs(vecnm(2,1+nelem*(ivec-1)+icg))>tol16)then
5076 : write(msg,'(2a,3i0,2es16.6,a,a)')&
5077 : ' For istwf_k = 2, observed the following element of vecnm :',ch10,&
5078 : nelem,ivec,icg,vecnm(1:2,1+nelem*(ivec-1)+icg), ch10,' with a non-negligible imaginary part.'
5079 : ABI_BUG(msg)
5080 : end if
5081 : end do
5082 : end if
5083 : #endif
5084 :
5085 : ! Nothing to do if ortalgo=-1
5086 493069 : if(ortalgo==-1) return
5087 :
5088 : !call wrtout(std_out, sjoin(" Begin wavefunction orthogonalization with ortalgo:", itoa(ortalgo)))
5089 : !call cwtime(cpu, wall, gflops, "start")
5090 :
5091 3966649 : do ivec=1,nvec
5092 3473580 : cgindex(ivec)=nelem*(ivec-1)+icg+1
5093 3966649 : gscindex(ivec)=nelem*(ivec-1)+igsc+1
5094 : end do
5095 :
5096 : if (ortalgo==3) then
5097 : ! =========================
5098 : ! First (new new) algorithm
5099 : ! =========================
5100 : ! NEW VERSION: avoid copies, use ZHERK for NC
5101 127 : cg_idx = cgindex(1)
5102 127 : if (useoverlap == 1) then
5103 0 : gsc_idx = gscindex(1)
5104 0 : call cgpaw_cholesky(nelem, nvec, vecnm(1,cg_idx), ovl_vecnm(1,gsc_idx), istwf_k, me_g0, comm)
5105 : else
5106 127 : call cgnc_cholesky(nelem, nvec, vecnm(1,cg_idx), istwf_k, me_g0, comm, use_gemm=.FALSE.)
5107 : end if
5108 :
5109 : else if (ortalgo==1) then
5110 : ! =======================
5111 : ! Second (new) algorithm
5112 : ! =======================
5113 : ! This first algorithm seems to be more efficient especially in the parallel band-FFT mode.
5114 :
5115 32 : if(istwf_k==1) then
5116 32 : vectsize=nelem
5117 128 : ABI_MALLOC(cgramxbx,(nvec,nvec))
5118 128 : ABI_MALLOC(cblockvectorx,(vectsize,nvec))
5119 96 : ABI_MALLOC(cblockvectorbx,(vectsize,nvec))
5120 32 : call abi_xcopy(nvec*vectsize,vecnm(:,cgindex(1):cgindex(nvec)-1),1,cblockvectorx,1,x_cplx=2)
5121 32 : if (useoverlap == 1) then
5122 32 : call abi_xcopy(nvec*vectsize,ovl_vecnm(:,gscindex(1):gscindex(nvec)-1),1,cblockvectorbx,1,x_cplx=2)
5123 : else
5124 0 : call abi_xcopy(nvec*vectsize,vecnm(:,cgindex(1):cgindex(nvec)-1),1,cblockvectorbx,1,x_cplx=2)
5125 : end if
5126 32 : call abi_xorthonormalize(cblockvectorx,cblockvectorbx,nvec,comm,cgramxbx,vectsize)
5127 32 : call abi_xcopy(nvec*vectsize,cblockvectorx,1,vecnm(:,cgindex(1):cgindex(nvec)-1),1,x_cplx=2)
5128 32 : if (useoverlap == 1) then
5129 32 : call abi_xtrsm('r','u','n','n',vectsize,nvec,cone,cgramxbx,nvec,cblockvectorbx,vectsize)
5130 32 : call abi_xcopy(nvec*vectsize,cblockvectorbx,1,ovl_vecnm(:,gscindex(1):gscindex(nvec)-1),1,x_cplx=2)
5131 : end if
5132 32 : ABI_FREE(cgramxbx)
5133 32 : ABI_FREE(cblockvectorx)
5134 32 : ABI_FREE(cblockvectorbx)
5135 :
5136 0 : else if (istwf_k==2) then
5137 : ! Pack real and imaginary part of the wavefunctions.
5138 0 : rvectsiz=nelem
5139 0 : vectsize=2*nelem; if(me_g0==1) vectsize=vectsize-1
5140 0 : ABI_MALLOC(rgramxbx,(nvec,nvec))
5141 0 : ABI_MALLOC(rblockvectorx,(vectsize,nvec))
5142 0 : ABI_MALLOC(rblockvectorbx,(vectsize,nvec))
5143 0 : do ivec=1,nvec
5144 0 : if (me_g0 == 1) then
5145 0 : call abi_xcopy(1,vecnm(1,cgindex(ivec)),1,rblockvectorx (1,ivec),1)
5146 0 : call abi_xcopy(rvectsiz-1,vecnm(1,cgindex(ivec)+1),2,rblockvectorx(2,ivec),1)
5147 0 : call abi_xcopy(rvectsiz-1,vecnm(2,cgindex(ivec)+1),2,rblockvectorx(rvectsiz+1,ivec),1)
5148 0 : if (useoverlap == 1) then
5149 0 : call abi_xcopy(1,ovl_vecnm(1,gscindex(ivec)),1,rblockvectorbx(1,ivec),1)
5150 0 : call abi_xcopy(rvectsiz-1,ovl_vecnm(1,gscindex(ivec)+1),2,rblockvectorbx(2,ivec),1)
5151 0 : call abi_xcopy(rvectsiz-1,ovl_vecnm(2,gscindex(ivec)+1),2,rblockvectorbx(rvectsiz+1,ivec),1)
5152 : else
5153 0 : call abi_xcopy(1,vecnm(1,cgindex(ivec)),1,rblockvectorbx(1,ivec),1)
5154 0 : call abi_xcopy(rvectsiz-1,vecnm(1,cgindex(ivec)+1),2,rblockvectorbx(2,ivec),1)
5155 0 : call abi_xcopy(rvectsiz-1,vecnm(2,cgindex(ivec)+1),2,rblockvectorbx(rvectsiz+1,ivec),1)
5156 : end if
5157 0 : rblockvectorx (2:vectsize,ivec)=rblockvectorx (2:vectsize,ivec)*sqrt2
5158 0 : rblockvectorbx(2:vectsize,ivec)=rblockvectorbx(2:vectsize,ivec)*sqrt2
5159 : else
5160 0 : call abi_xcopy(rvectsiz,vecnm(1,cgindex(ivec)),2,rblockvectorx(1,ivec),1)
5161 0 : call abi_xcopy(rvectsiz,vecnm(2,cgindex(ivec)),2,rblockvectorx(rvectsiz+1,ivec),1)
5162 0 : if (useoverlap == 1) then
5163 0 : call abi_xcopy(rvectsiz,ovl_vecnm(1,gscindex(ivec)),2,rblockvectorbx(1,ivec),1)
5164 0 : call abi_xcopy(rvectsiz,ovl_vecnm(2,gscindex(ivec)),2,rblockvectorbx(rvectsiz+1,ivec),1)
5165 : else
5166 0 : call abi_xcopy(rvectsiz,vecnm(1,cgindex(ivec)),2,rblockvectorbx(1,ivec),1)
5167 0 : call abi_xcopy(rvectsiz,vecnm(2,cgindex(ivec)),2,rblockvectorbx(rvectsiz+1,ivec),1)
5168 : end if
5169 0 : rblockvectorx (1:vectsize,ivec)=rblockvectorx (1:vectsize,ivec)*sqrt2
5170 0 : rblockvectorbx(1:vectsize,ivec)=rblockvectorbx(1:vectsize,ivec)*sqrt2
5171 : end if
5172 : end do
5173 :
5174 0 : call ortho_reim(rblockvectorx,rblockvectorbx,nvec,comm,rgramxbx,vectsize)
5175 :
5176 0 : do ivec=1,nvec
5177 : ! Unpack results
5178 0 : if (me_g0 == 1) then
5179 0 : call abi_xcopy(1,rblockvectorx(1,ivec),1,vecnm(1,cgindex(ivec)),1)
5180 0 : vecnm(2,cgindex(ivec))=zero
5181 0 : rblockvectorx(2:vectsize,ivec)=rblockvectorx(2:vectsize,ivec)/sqrt2
5182 0 : call abi_xcopy(rvectsiz-1,rblockvectorx(2,ivec),1,vecnm(1,cgindex(ivec)+1),2)
5183 0 : call abi_xcopy(rvectsiz-1,rblockvectorx(rvectsiz+1,ivec),1,vecnm(2,cgindex(ivec)+1),2)
5184 : else
5185 0 : rblockvectorx(1:vectsize,ivec)=rblockvectorx(1:vectsize,ivec)/sqrt2
5186 0 : call abi_xcopy(rvectsiz,rblockvectorx(1,ivec),1,vecnm(1,cgindex(ivec)),2)
5187 0 : call abi_xcopy(rvectsiz,rblockvectorx(rvectsiz+1,ivec),1,vecnm(2,cgindex(ivec)),2)
5188 : end if
5189 :
5190 0 : if(useoverlap == 1) then
5191 0 : call abi_xtrsm('r','u','n','n',vectsize,nvec,one,rgramxbx,nvec,rblockvectorbx,vectsize)
5192 0 : if (me_g0 == 1) then
5193 0 : call abi_xcopy(1,rblockvectorbx(1,ivec),1,ovl_vecnm(1,gscindex(ivec)),1)
5194 0 : ovl_vecnm(2,gscindex(ivec))=zero
5195 0 : rblockvectorbx(2:vectsize,ivec)=rblockvectorbx(2:vectsize,ivec)/sqrt2
5196 0 : call abi_xcopy(rvectsiz-1,rblockvectorbx(2,ivec),1,ovl_vecnm(1,gscindex(ivec)+1),2)
5197 0 : call abi_xcopy(rvectsiz-1,rblockvectorbx(rvectsiz+1,ivec),1,ovl_vecnm(2,gscindex(ivec)+1),2)
5198 : else
5199 0 : rblockvectorbx(1:vectsize,ivec)=rblockvectorbx(1:vectsize,ivec)/sqrt2
5200 0 : call abi_xcopy(rvectsiz,rblockvectorbx(1,ivec),1,ovl_vecnm(1,gscindex(ivec)),2)
5201 0 : call abi_xcopy(rvectsiz,rblockvectorbx(rvectsiz+1,ivec),1,ovl_vecnm(2,gscindex(ivec)),2)
5202 : end if
5203 : end if
5204 : end do
5205 0 : ABI_FREE(rgramxbx)
5206 0 : ABI_FREE(rblockvectorx)
5207 0 : ABI_FREE(rblockvectorbx)
5208 : end if
5209 :
5210 : else if (ortalgo==4) then
5211 : ! else if (ANY(ortalgo==(/0,2/))) then
5212 :
5213 0 : cg_idx = cgindex(1)
5214 0 : if (useoverlap==0) then
5215 0 : call cgnc_gramschmidt(nelem,nvec,vecnm(1,cg_idx),istwf_k,me_g0,comm)
5216 : else
5217 0 : gsc_idx = gscindex(1)
5218 0 : call cgpaw_gramschmidt(nelem,nvec,vecnm(1,cg_idx),ovl_vecnm(1,gsc_idx),istwf_k,me_g0,comm)
5219 : end if
5220 :
5221 : else if (ANY(ortalgo==(/0,2/))) then
5222 : ! =======================
5223 : ! Third (old) algorithm
5224 : ! =======================
5225 : ! TODO: This algo should be removed. Ref files should be updated though.
5226 :
5227 3957804 : do ivec=1,nvec
5228 : ! Normalize each vecnm(n,m) in turn:
5229 :
5230 3464894 : if (useoverlap==1) then ! Using overlap S...
5231 1243486 : if(istwf_k/=2)then
5232 1213123 : sum=zero;ii0=1
5233 : else
5234 30363 : if (me_g0 ==1) then
5235 30363 : sum=half*ovl_vecnm(1,1+nelem*(ivec-1)+igsc)*vecnm(1,1+nelem*(ivec-1)+icg)
5236 30363 : ii0=2
5237 : else
5238 0 : sum=zero;ii0=1
5239 : end if
5240 : end if
5241 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:sum) SHARED(icg,ivec,nelem,vecnm)
5242 427485747 : do ii=ii0+nelem*(ivec-1),nelem*ivec
5243 427485747 : sum=sum+vecnm(1,ii+icg)*ovl_vecnm(1,ii+igsc)+vecnm(2,ii+icg)*ovl_vecnm(2,ii+igsc)
5244 : end do
5245 :
5246 : else ! Without overlap...
5247 2221408 : if(istwf_k/=2)then
5248 2132603 : sum=zero;ii0=1
5249 : else
5250 88805 : if (me_g0 ==1) then
5251 88805 : sum=half*vecnm(1,1+nelem*(ivec-1)+icg)**2
5252 88805 : ii0=2
5253 : else
5254 0 : sum=zero;ii0=1
5255 : end if
5256 : end if
5257 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:sum) SHARED(icg,ivec,nelem,vecnm)
5258 727403488 : do ii=ii0+nelem*(ivec-1)+icg,nelem*ivec+icg
5259 727403488 : sum=sum+vecnm(1,ii)**2+vecnm(2,ii)**2
5260 : end do
5261 : end if
5262 :
5263 3464894 : call timab(48,1,tsec)
5264 3464894 : call xmpi_sum(sum,comm,ierr)
5265 3464894 : call timab(48,2,tsec)
5266 :
5267 3464894 : if(istwf_k>=2)sum=two*sum
5268 3464894 : xnorm = sqrt(abs(sum)) ; sum=1.0_dp/xnorm
5269 : !$OMP PARALLEL DO PRIVATE(ii) SHARED(icg,ivec,nelem,sum,vecnm)
5270 1155008403 : do ii=1+nelem*(ivec-1)+icg,nelem*ivec+icg
5271 1151543509 : vecnm(1,ii)=vecnm(1,ii)*sum
5272 1155008403 : vecnm(2,ii)=vecnm(2,ii)*sum
5273 : end do
5274 3464894 : if (useoverlap==1) then
5275 : !$OMP PARALLEL DO PRIVATE(ii) SHARED(icg,ivec,nelem,sum,ovl_vecnm)
5276 427516110 : do ii=1+nelem*(ivec-1)+igsc,nelem*ivec+igsc
5277 426272624 : ovl_vecnm(1,ii)=ovl_vecnm(1,ii)*sum
5278 427516110 : ovl_vecnm(2,ii)=ovl_vecnm(2,ii)*sum
5279 : end do
5280 : end if
5281 :
5282 : ! Remove projection in all higher states.
5283 7422698 : if (ivec<nvec) then
5284 :
5285 2971984 : if(istwf_k==1)then
5286 : ! Cannot use time-reversal symmetry
5287 :
5288 2744937 : if (useoverlap==1) then ! Using overlap.
5289 11636647 : do ivec2=ivec+1,nvec
5290 : ! First compute scalar product
5291 10560222 : dotr=zero ; doti=zero
5292 10560222 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+igsc
5293 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:doti,dotr) SHARED(ii1,ii2,nelem,vecnm)
5294 3641452686 : do ii=1,nelem
5295 3630892464 : dotr=dotr+vecnm(1,ii1+ii)*ovl_vecnm(1,ii2+ii)+vecnm(2,ii1+ii)*ovl_vecnm(2,ii2+ii)
5296 3641452686 : doti=doti+vecnm(1,ii1+ii)*ovl_vecnm(2,ii2+ii)-vecnm(2,ii1+ii)*ovl_vecnm(1,ii2+ii)
5297 : end do
5298 :
5299 10560222 : call timab(48,1,tsec)
5300 10560222 : buffer2(1)=doti;buffer2(2)=dotr
5301 10560222 : call xmpi_sum(buffer2,comm,ierr)
5302 10560222 : call timab(48,2,tsec)
5303 10560222 : doti=buffer2(1)
5304 10560222 : dotr=buffer2(2)
5305 :
5306 : ! Then subtract the appropriate amount of the lower state
5307 10560222 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5308 : #ifdef FC_INTEL
5309 : ! DIR$ ivdep
5310 : #endif
5311 : !$OMP PARALLEL DO PRIVATE(ii) SHARED(doti,dotr,ii1,ii2,nelem,vecnm)
5312 3641452686 : do ii=1,nelem
5313 3630892464 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)+doti*vecnm(2,ii1+ii)
5314 3641452686 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-doti*vecnm(1,ii1+ii)-dotr*vecnm(2,ii1+ii)
5315 : end do
5316 :
5317 10560222 : ii1=nelem*(ivec-1)+igsc;ii2=nelem*(ivec2-1)+igsc
5318 3642529111 : do ii=1,nelem
5319 : ovl_vecnm(1,ii2+ii)=ovl_vecnm(1,ii2+ii)&
5320 : & -dotr*ovl_vecnm(1,ii1+ii)&
5321 3630892464 : & +doti*ovl_vecnm(2,ii1+ii)
5322 : ovl_vecnm(2,ii2+ii)=ovl_vecnm(2,ii2+ii)&
5323 : -doti*ovl_vecnm(1,ii1+ii)&
5324 3641452686 : & -dotr*ovl_vecnm(2,ii1+ii)
5325 : end do
5326 : end do
5327 : else
5328 : ! ----- No overlap -----
5329 17431701 : do ivec2=ivec+1,nvec
5330 : ! First compute scalar product
5331 15763189 : dotr=zero ; doti=zero
5332 15763189 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5333 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:doti,dotr) SHARED(ii1,ii2,nelem,vecnm)
5334 6368777193 : do ii=1,nelem
5335 : dotr=dotr+vecnm(1,ii1+ii)*vecnm(1,ii2+ii)+&
5336 6353014004 : & vecnm(2,ii1+ii)*vecnm(2,ii2+ii)
5337 : doti=doti+vecnm(1,ii1+ii)*vecnm(2,ii2+ii)-&
5338 6368777193 : & vecnm(2,ii1+ii)*vecnm(1,ii2+ii)
5339 : end do
5340 : ! Init mpi_comm
5341 15763189 : buffer2(1)=doti
5342 15763189 : buffer2(2)=dotr
5343 15763189 : call timab(48,1,tsec)
5344 15763189 : call xmpi_sum(buffer2,comm,ierr)
5345 : ! call xmpi_sum(doti,spaceComm,ierr)
5346 : ! call xmpi_sum(dotr,spaceComm,ierr)
5347 15763189 : call timab(48,2,tsec)
5348 15763189 : doti=buffer2(1)
5349 15763189 : dotr=buffer2(2)
5350 :
5351 : ! Then subtract the appropriate amount of the lower state
5352 : #ifdef FC_INTEL
5353 : ! DIR$ ivdep
5354 : #endif
5355 : !$OMP PARALLEL DO PRIVATE(ii) SHARED(doti,dotr,ii1,ii2,nelem,vecnm)
5356 6370445705 : do ii=1,nelem
5357 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)+&
5358 6353014004 : & doti*vecnm(2,ii1+ii)
5359 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-doti*vecnm(1,ii1+ii)-&
5360 6368777193 : & dotr*vecnm(2,ii1+ii)
5361 : end do
5362 : end do
5363 :
5364 : end if ! Test on useoverlap
5365 :
5366 227047 : else if(istwf_k==2)then
5367 : ! At gamma point use of time-reversal symmetry saves cpu time.
5368 :
5369 101215 : if (useoverlap==1) then
5370 : ! ----- Using overlap -----
5371 349663 : do ivec2=ivec+1,nvec
5372 : ! First compute scalar product
5373 322921 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+igsc
5374 322921 : if (me_g0 ==1) then
5375 322921 : dotr=half*vecnm(1,ii1+1)*ovl_vecnm(1,ii2+1)
5376 : ! Avoid double counting G=0 contribution
5377 : ! Imaginary part of vecnm at G=0 should be zero,so only take real part
5378 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5379 334515967 : do ii=2,nelem
5380 : dotr=dotr+vecnm(1,ii1+ii)*ovl_vecnm(1,ii2+ii)+&
5381 334515967 : & vecnm(2,ii1+ii)*ovl_vecnm(2,ii2+ii)
5382 : end do
5383 : else
5384 0 : dotr=0._dp
5385 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5386 0 : do ii=1,nelem
5387 : dotr=dotr+vecnm(1,ii1+ii)*ovl_vecnm(1,ii2+ii)+&
5388 0 : & vecnm(2,ii1+ii)*ovl_vecnm(2,ii2+ii)
5389 : end do
5390 : end if
5391 :
5392 322921 : dotr=two*dotr
5393 :
5394 322921 : call timab(48,1,tsec)
5395 322921 : call xmpi_sum(dotr,comm,ierr)
5396 322921 : call timab(48,2,tsec)
5397 :
5398 : ! Then subtract the appropriate amount of the lower state
5399 322921 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5400 : #ifdef FC_INTEL
5401 : ! DIR$ ivdep
5402 : #endif
5403 : !$OMP PARALLEL DO PRIVATE(ii) SHARED(dotr,ii1,ii2,nelem,vecnm)
5404 334838888 : do ii=1,nelem
5405 334515967 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)
5406 334838888 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-dotr*vecnm(2,ii1+ii)
5407 : end do
5408 322921 : ii1=nelem*(ivec-1)+igsc;ii2=nelem*(ivec2-1)+igsc
5409 335188551 : do ii=1,nelem
5410 334515967 : ovl_vecnm(1,ii2+ii)=ovl_vecnm(1,ii2+ii)-dotr*ovl_vecnm(1,ii1+ii)
5411 334838888 : ovl_vecnm(2,ii2+ii)=ovl_vecnm(2,ii2+ii)-dotr*ovl_vecnm(2,ii1+ii)
5412 : end do
5413 : end do
5414 : else
5415 : ! ----- No overlap -----
5416 771810 : do ivec2=ivec+1,nvec
5417 : ! First compute scalar product
5418 697337 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5419 697337 : if (me_g0 ==1) then
5420 : ! Avoid double counting G=0 contribution
5421 : ! Imaginary part of vecnm at G=0 should be zero,so only take real part
5422 697337 : dotr=half*vecnm(1,ii1+1)*vecnm(1,ii2+1)
5423 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5424 436551603 : do ii=2,nelem
5425 436551603 : dotr=dotr+vecnm(1,ii1+ii)*vecnm(1,ii2+ii)+vecnm(2,ii1+ii)*vecnm(2,ii2+ii)
5426 : end do
5427 : else
5428 0 : dotr=0._dp
5429 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5430 0 : do ii=1,nelem
5431 0 : dotr=dotr+vecnm(1,ii1+ii)*vecnm(1,ii2+ii)+vecnm(2,ii1+ii)*vecnm(2,ii2+ii)
5432 : end do
5433 : end if
5434 697337 : dotr=two*dotr
5435 :
5436 697337 : call timab(48,1,tsec)
5437 697337 : call xmpi_sum(dotr,comm,ierr)
5438 697337 : call timab(48,2,tsec)
5439 :
5440 : ! Then subtract the appropriate amount of the lower state
5441 : #ifdef FC_INTEL
5442 : ! DIR$ ivdep
5443 : #endif
5444 : !$OMP PARALLEL DO PRIVATE(ii) SHARED(dotr,ii1,ii2,nelem,vecnm)
5445 437323413 : do ii=1,nelem
5446 436551603 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)
5447 437248940 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-dotr*vecnm(2,ii1+ii)
5448 : end do
5449 : end do
5450 : end if ! Test on useoverlap
5451 :
5452 : else
5453 : ! At other special points,use of time-reversal symmetry saves cpu time.
5454 :
5455 125832 : if (useoverlap==1) then
5456 : ! ----- Using overlap -----
5457 690726 : do ivec2=ivec+1,nvec
5458 : ! First compute scalar product
5459 648020 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+igsc
5460 : ! Avoid double counting G=0 contribution
5461 : ! Imaginary part of vecnm at G=0 should be zero,so only take real part
5462 648020 : dotr=zero
5463 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5464 598498339 : do ii=1,nelem
5465 598498339 : dotr=dotr+vecnm(1,ii1+ii)*ovl_vecnm(1,ii2+ii)+vecnm(2,ii1+ii)*ovl_vecnm(2,ii2+ii)
5466 : end do
5467 648020 : dotr=two*dotr
5468 :
5469 648020 : call timab(48,1,tsec)
5470 648020 : call xmpi_sum(dotr,comm,ierr)
5471 648020 : call timab(48,2,tsec)
5472 :
5473 : ! Then subtract the appropriate amount of the lower state
5474 648020 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5475 : #ifdef FC_INTEL
5476 : ! DIR$ ivdep
5477 : #endif
5478 : !$OMP PARALLEL DO PRIVATE(ii) SHARED(dotr,ii1,ii2,nelem,vecnm)
5479 598498339 : do ii=1,nelem
5480 597850319 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)
5481 598498339 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-dotr*vecnm(2,ii1+ii)
5482 : end do
5483 648020 : ii1=nelem*(ivec-1)+igsc;ii2=nelem*(ivec2-1)+igsc
5484 599189065 : do ii=1,nelem
5485 597850319 : ovl_vecnm(1,ii2+ii)=ovl_vecnm(1,ii2+ii)-dotr*ovl_vecnm(1,ii1+ii)
5486 598498339 : ovl_vecnm(2,ii2+ii)=ovl_vecnm(2,ii2+ii)-dotr*ovl_vecnm(2,ii1+ii)
5487 : end do
5488 : end do
5489 : else
5490 : ! ----- No overlap -----
5491 1178817 : do ivec2=ivec+1,nvec
5492 : ! First compute scalar product
5493 1095691 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5494 : ! Avoid double counting G=0 contribution
5495 : ! Imaginary part of vecnm at G=0 should be zero,so only take real part
5496 1095691 : dotr=zero
5497 : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5498 574788833 : do ii=1,nelem
5499 574788833 : dotr=dotr+vecnm(1,ii1+ii)*vecnm(1,ii2+ii)+vecnm(2,ii1+ii)*vecnm(2,ii2+ii)
5500 : end do
5501 1095691 : dotr=two*dotr
5502 :
5503 1095691 : call timab(48,1,tsec)
5504 1095691 : call xmpi_sum(dotr,comm,ierr)
5505 1095691 : call timab(48,2,tsec)
5506 :
5507 : ! Then subtract the appropriate amount of the lower state
5508 : !$OMP PARALLEL DO PRIVATE(ii) SHARED(dotr,ii1,ii2,nelem,vecnm)
5509 574871959 : do ii=1,nelem
5510 573693142 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)
5511 574788833 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-dotr*vecnm(2,ii1+ii)
5512 : end do
5513 : end do
5514 : end if
5515 :
5516 : end if ! End use of time-reversal symmetry
5517 : end if ! Test on "ivec"
5518 : end do ! end loop over vectors (or bands) with index ivec :
5519 :
5520 : else
5521 0 : ABI_ERROR(sjoin("Wrong value for ortalgo:", itoa(ortalgo)))
5522 : end if
5523 :
5524 : !call cwtime_report(sjoin(" pw_orthon with ortalgo: ", itoa(ortalgo)), cpu, wall, gflops)
5525 :
5526 493069 : end subroutine pw_orthon
5527 : !!***
5528 :
5529 : !!****f* m_cgtools/pw_orthon_paw
5530 : !! NAME
5531 : !! pw_orthon_paw
5532 : !!
5533 : !! FUNCTION
5534 : !! Normalize nvec complex vectors each of length nelem and then orthogonalize by modified Gram-Schmidt.
5535 : !! The overlap matrix <c_m|S|c_n> (S can be identity) has to be provided as input, and is overwritten.
5536 : !!
5537 : !! INPUTS
5538 : !! icg=shift to be given to the location of the data in cg(=vecnm)
5539 : !! mcg=maximum size of second dimension of cg(=vecnm)
5540 : !! nelem=number of complex elements in each vector
5541 : !! nspinor=number of spinorial components of the wavefunctions (on current proc)
5542 : !! nvec=number of vectors to be orthonormalized
5543 : !! ortalgo= option for the choice of the algorithm
5544 : !! -1: no orthogonalization (direct return)
5545 : !! 0: do orthogonalization
5546 : !! comm=MPI communicator
5547 : !!
5548 : !! SIDE EFFECTS
5549 : !! cprj(optional)=<p_i|c_n> coefficients, updated to keep them consistent with the WF at output
5550 : !! ovl_mat=overlap matrix <c_m|S|c_n> for m<=n
5551 : !! vecnm= input: vectors to be orthonormalized; array of nvec column
5552 : !! vectors,each of length nelem,shifted by icg
5553 : !! This array is complex or else real(dp) of twice length
5554 : !! output: orthonormalized set of vectors
5555 : !!
5556 : !! NOTES
5557 : !! Note that each vector has an arbitrary phase which is not fixed in this routine.
5558 : !!
5559 : !! SOURCE
5560 :
5561 0 : subroutine pw_orthon_cprj(icg,mcg,nelem,nspinor,nvec,ortalgo,ovl_mat,vecnm,cprj)
5562 :
5563 : !Arguments ------------------------------------
5564 : !scalars
5565 : integer,intent(in) :: icg,mcg,nelem,nspinor,nvec,ortalgo
5566 : !arrays
5567 : real(dp),intent(inout) :: ovl_mat(nvec*(nvec+1)),vecnm(2,mcg)
5568 : type(pawcprj_type),intent(inout),optional,target :: cprj(:,:)
5569 :
5570 : !Local variables-------------------------------
5571 : !scalars
5572 : logical :: do_cprj
5573 : integer :: ii,ii1,ii2,ivec,ivec2,ivec3,iv1l,iv2l,iv3l,iv1r,iv2r,iv3r,ncprj
5574 : real(dp) :: doti,dotr,summ,xnorm
5575 : !arrays
5576 0 : real(dp) :: ovl_row_tmp(2*nvec),ovl_col_tmp(2*nvec)
5577 : real(dp) :: re,im
5578 : ! *************************************************************************
5579 :
5580 : !Nothing to do if ortalgo=-1
5581 0 : if(ortalgo==-1) return
5582 :
5583 0 : do_cprj=.false.
5584 0 : if (present(cprj)) then
5585 0 : do_cprj=.true.
5586 0 : ncprj = size(cprj,2)
5587 0 : if (ncprj/=nspinor*nvec) then
5588 0 : ABI_ERROR('bad size for cprj')
5589 : end if
5590 : end if
5591 :
5592 : ! The overlap matrix is : ovl(i,j) = <psi_i|S|psi_j> = (<psi_j|S|psi_i>)^*
5593 : ! The row index stands for the "left" band index
5594 : ! The column index stands for the "right" band index
5595 : ! Only the upper triangular part of the (complex) overlap matrix is stored, so only elements with i<=j.
5596 : ! They are stored in the following order: ovl(1,1),ovl(1,2),ovl(2,2),ovl(1,3),ovl(2,3),...
5597 : ! so:
5598 : ! -- shift for the ith row : 2.(i.(i-1)/2) = i.(i-1)
5599 : ! -- shift for the ith column : 2.(i-1)+1 = 2.i-1
5600 : ! => index of real part of elem in the jth column and ith row (=ovl(i,j)) : 2.i-1+j.(j-1) (for i<=j)
5601 : ! => index of imaginary part = index of real part + 1
5602 : ! After orthogonalizing the first n vectors, we have:
5603 : ! for i<=n, i<=j : ovl(i,j) = delta_ij
5604 :
5605 0 : do ivec=1,nvec
5606 :
5607 : ! First we normalize the current vector
5608 0 : iv1r = ivec*(ivec-1) ! ith row
5609 0 : iv1l = 2*ivec-1 ! ith column
5610 : ! ovl(i1,i1) = <psi_i1|S|psi_i1>
5611 0 : summ = ovl_mat(iv1r+iv1l)
5612 0 : xnorm = sqrt(abs(summ)) ; summ=1.0_dp/xnorm
5613 : !$OMP PARALLEL DO PRIVATE(ii) SHARED(icg,ivec,nelem,summ,vecnm)
5614 0 : do ii=1+nelem*(ivec-1)+icg,nelem*ivec+icg
5615 0 : vecnm(1,ii)=vecnm(1,ii)*summ
5616 0 : vecnm(2,ii)=vecnm(2,ii)*summ
5617 : end do
5618 : ! Apply the normalization to cprj coeffs
5619 0 : if (do_cprj) call pawcprj_axpby(zero,summ,cprj(:,nspinor*(ivec-1)+1:nspinor*ivec),cprj(:,nspinor*(ivec-1)+1:nspinor*ivec))
5620 :
5621 : ! As the norm of |psi_i1> changed, we update the overlap matrix accordingly.
5622 : ! From previous iterations, we already have:
5623 : ! ovl(i2,i1) = <psi_i2|S|psi_i1> = 0 for i2<i1
5624 : ! so we need to change only:
5625 : ! ovl(i1,i2) = <psi_i1|S|psi_i2> for i1<=i2
5626 0 : do ivec2=ivec,nvec
5627 0 : iv2r=ivec2*(ivec2-1)
5628 0 : if (ivec<ivec2) then
5629 0 : ovl_mat(iv2r+iv1l ) = ovl_mat(iv2r+iv1l )*summ
5630 0 : ovl_mat(iv2r+iv1l+1) = ovl_mat(iv2r+iv1l+1)*summ
5631 0 : else if (ivec==ivec2) then
5632 0 : ovl_mat(iv2r+iv1l ) = ovl_mat(iv2r+iv1l )*summ*summ
5633 0 : ovl_mat(iv2r+iv1l+1) = ovl_mat(iv2r+iv1l+1)*summ*summ
5634 0 : re = ovl_mat(iv2r+iv1l )
5635 0 : im = ovl_mat(iv2r+iv1l+1)
5636 0 : if (abs(re-1)>tol10.or.abs(im)>tol10) then
5637 0 : write(std_out,'(a,es21.10e3)') '(pw_ortho) ovl (re)',re
5638 0 : write(std_out,'(a,es21.10e3)') '(pw_ortho) ovl (im)',im
5639 0 : ABI_WARNING('In pw_orthon_cprj: the result should be equal to one!')
5640 : end if
5641 : end if
5642 : end do
5643 :
5644 : ! Remove projection in all higher states.
5645 0 : if (ivec<nvec) then
5646 :
5647 0 : do ivec2=ivec+1,nvec
5648 :
5649 0 : iv2r = ivec2*(ivec2-1)
5650 0 : iv2l = 2*ivec2-1
5651 : ! (dotr,doti) = <psi_i1|S|psi_i2>
5652 0 : dotr = ovl_mat(iv2r+iv1l )
5653 0 : doti = ovl_mat(iv2r+iv1l+1)
5654 :
5655 : ! Then subtract the appropriate amount of the lower state
5656 0 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5657 : ! |psi'_i2> = |psi_i2> - <psi_i1|S|psi_i2> |psi_i1>
5658 : !$OMP PARALLEL DO PRIVATE(ii) SHARED(doti,dotr,ii1,ii2,nelem,vecnm)
5659 0 : do ii=1,nelem
5660 0 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)+doti*vecnm(2,ii1+ii)
5661 0 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-doti*vecnm(1,ii1+ii)-dotr*vecnm(2,ii1+ii)
5662 : end do
5663 0 : if (do_cprj) call pawcprj_zaxpby((/-dotr,-doti/),(/one,zero/),cprj(:,nspinor*(ivec-1)+1:nspinor*ivec),&
5664 0 : cprj(:,nspinor*(ivec2-1)+1:nspinor*ivec2))
5665 : ! As |psi_i2> changed, we update the overlap matrix accordingly.
5666 : ! We have: <psi'_i3|S|psi'_i2> = <psi'_i3|S|psi_i2> - <psi_i1|S|psi_i2> <psi'_i3|S|psi_i1>
5667 : ! Remember that i2>i1.
5668 : ! For i3<=i2, we compute the new column i2.
5669 : ! For i3<i1:
5670 : ! (1) <psi'_i3|S|psi'_i2> = <psi_i3|S|psi_i2> - <psi_i1|S|psi_i2> <psi_i3|S|psi_i1>
5671 : ! = <psi_i3|S|psi_i2>
5672 : ! as for i3<i1 we have <psi_i3|S|psi_i1> = 0
5673 : ! For i1<=i3<i2:
5674 : ! (2) <psi'_i3|S|psi'_i2> = <psi_i3|S|psi_i2> - <psi_i1|S|psi_i2> <psi_i3|S|psi_i1>
5675 : ! = <psi_i3|S|psi_i2> - <psi_i1|S|psi_i2> (<psi_i1|S|psi_i3>)^*
5676 : ! For i3=i2:
5677 : ! (3) <psi'_i3|S|psi'_i2> = <psi'_i2|S|psi_i2> - <psi_i1|S|psi_i2> <psi'_i2|S|psi_i1>
5678 : ! = <psi_i2|S|psi_i2> - <psi_i1|S|psi_i2> <psi_i2|S|psi_i1>
5679 : ! - <psi_i1|S|psi_i2> <psi_i2|S|psi_i1> + <psi_i1|S|psi_i2> <psi_1|S|psi_1> <psi_i2|S|psi_i1>
5680 : ! = <psi_i2|S|psi_i2> - <psi_i1|S|psi_i2> <psi_i2|S|psi_i1>
5681 : ! = <psi_i2|S|psi_i2> - <psi_i1|S|psi_i2> (<psi_i1|S|psi_i2>)^*
5682 : ! so the case i3=i2 (3) is equivalent to the case i1<=i3<i2 (2) with i3=i2.
5683 : ! Here we compute (2) and (3) in a temporary array:
5684 0 : do ivec3=ivec,ivec2
5685 0 : iv3r=ivec3*(ivec3-1)
5686 0 : iv3l=2*ivec3-1
5687 0 : ovl_col_tmp(iv3l ) = ovl_mat(iv2r+iv3l ) - dotr*ovl_mat(iv3r+iv1l) - doti*ovl_mat(iv3r+iv1l+1)
5688 0 : ovl_col_tmp(iv3l+1) = ovl_mat(iv2r+iv3l+1) - doti*ovl_mat(iv3r+iv1l) + dotr*ovl_mat(iv3r+iv1l+1)
5689 : end do
5690 : ! For i2<i3, we compute the new row i2.
5691 : ! (4) <psi'_i2|S|psi_i3> = <psi_i2|S|psi_i3> - <psi_i2|S|psi_i1> <psi_i1|S|psi_i3>
5692 : ! = <psi_i2|S|psi_i3> - (<psi_i1|S|psi_i2>)^* <psi_i1|S|psi_i3>
5693 : ! Here we compute (4) in a temporary array:
5694 0 : do ivec3=ivec2+1,nvec
5695 0 : iv3r=ivec3*(ivec3-1)
5696 0 : iv3l=2*ivec3-1
5697 0 : ovl_row_tmp(iv3l ) = ovl_mat(iv3r+iv2l ) - dotr*ovl_mat(iv3r+iv1l) - doti*ovl_mat(iv3r+iv1l+1)
5698 0 : ovl_row_tmp(iv3l+1) = ovl_mat(iv3r+iv2l+1) + doti*ovl_mat(iv3r+iv1l) - dotr*ovl_mat(iv3r+iv1l+1)
5699 : end do
5700 : ! We update the column i2 (starting from ivec and not 1, thanks to (1))
5701 0 : do ivec3=ivec,ivec2
5702 0 : iv3l=2*ivec3-1
5703 0 : ovl_mat(iv2r+iv3l ) = ovl_col_tmp(iv3l )
5704 0 : ovl_mat(iv2r+iv3l+1) = ovl_col_tmp(iv3l+1)
5705 : end do
5706 : ! We update the row i2
5707 0 : do ivec3=ivec2+1,nvec
5708 0 : iv3r=ivec3*(ivec3-1)
5709 0 : iv3l=2*ivec3-1
5710 0 : ovl_mat(iv3r+iv2l ) = ovl_row_tmp(iv3l )
5711 0 : ovl_mat(iv3r+iv2l+1) = ovl_row_tmp(iv3l+1)
5712 : end do
5713 : end do
5714 :
5715 : end if ! Test on "ivec"
5716 :
5717 : !end loop over vectors (or bands) with index ivec :
5718 : end do
5719 :
5720 : end subroutine pw_orthon_cprj
5721 : !!***
5722 :
5723 : !!****f* m_cgtools/cg_hprotate_and_get_diag
5724 : !! NAME
5725 : !! cg_hprotate_and_get_diag
5726 : !!
5727 : !! FUNCTION
5728 : !! Compute the diagonal elements of E^H VNLX E
5729 : !! where VNLX is an Hermitean matrixin packed form and E is the matrix with eigenvectors as column vectors.
5730 : !! Mainly used to rotate the matrix elements of an operator after the subspace diagonalization.
5731 : !!
5732 : !! INPUTS
5733 : !!
5734 : !! OUTPUT
5735 : !!
5736 : !! SOURCE
5737 :
5738 223339 : subroutine cg_hprotate_and_get_diag(nband_k, subvnlx, evec, enlx_k)
5739 :
5740 : !Arguments ------------------------------------
5741 : !scalars
5742 : integer,intent(in) :: nband_k
5743 : !arrays
5744 : real(dp),intent(in) :: subvnlx(nband_k*(nband_k+1))
5745 : real(dp),intent(in) :: evec(2*nband_k,nband_k)
5746 : real(dp), intent(out) :: enlx_k(nband_k)
5747 :
5748 : !Local variables ------------------------------
5749 : !scalars
5750 : integer :: ii,jj,pidx,iband
5751 223339 : real(dp),allocatable :: mat1(:,:,:),matvnl(:,:,:)
5752 : ! *************************************************************************
5753 :
5754 893356 : ABI_MALLOC(matvnl,(2,nband_k,nband_k))
5755 670017 : ABI_MALLOC(mat1,(2,nband_k,nband_k))
5756 :
5757 : ! Construct upper triangle of matvnl from subvnlx using full storage mode.
5758 1335682 : pidx=0
5759 1335682 : do jj=1,nband_k
5760 9825017 : do ii=1,jj
5761 8489335 : pidx=pidx+1
5762 8489335 : matvnl(1,ii,jj)=subvnlx(2*pidx-1)
5763 9601678 : matvnl(2,ii,jj)=subvnlx(2*pidx )
5764 : end do
5765 : end do
5766 :
5767 223339 : call zhemm('L','U',nband_k,nband_k,cone,matvnl,nband_k,evec,nband_k,czero,mat1,nband_k)
5768 :
5769 : !$OMP PARALLEL DO
5770 1335682 : do iband=1,nband_k
5771 1335682 : enlx_k(iband) = cg_real_zdotc(nband_k,evec(:,iband),mat1(:,:,iband))
5772 : end do
5773 :
5774 223339 : ABI_FREE(matvnl)
5775 223339 : ABI_FREE(mat1)
5776 :
5777 223339 : end subroutine cg_hprotate_and_get_diag
5778 : !!***
5779 :
5780 : !!****f* m_cgtools/cg_hrotate_and_get_diag
5781 : !! NAME
5782 : !! cg_hrotate_and_get_diag
5783 : !!
5784 : !! FUNCTION
5785 : !! Compute the diagonal elements of E^H VNLX E
5786 : !! where VNLX is an Hermitean matrix.
5787 : !! Mainly used to rotate the matrix elements of an operator after the subspace diagonalization.
5788 : !!
5789 : !! INPUTS
5790 : !!
5791 : !! OUTPUT
5792 : !!
5793 : !! SOURCE
5794 :
5795 612 : subroutine cg_hrotate_and_get_diag(istwf_k, nband_k, totvnlx, evec, enlx_k)
5796 :
5797 : !Arguments ------------------------------------
5798 : !scalars
5799 : integer,intent(in) :: istwf_k, nband_k
5800 : !arrays
5801 : real(dp),intent(in) :: totvnlx(2*nband_k,nband_k)
5802 : real(dp),intent(in) :: evec(2*nband_k,nband_k)
5803 : real(dp),intent(out) :: enlx_k(nband_k)
5804 :
5805 : !Local variables ------------------------------
5806 : !scalars
5807 : real(dp),external :: ddot
5808 : integer :: jj,iband
5809 612 : real(dp),allocatable :: mat_loc(:,:),mat1(:,:,:),matvnl(:,:,:), evec_loc(:,:)
5810 : ! *************************************************************************
5811 :
5812 2448 : ABI_MALLOC(matvnl, (2,nband_k, nband_k))
5813 1836 : ABI_MALLOC(mat1, (2, nband_k, nband_k))
5814 118540 : mat1=zero
5815 :
5816 5404 : enlx_k(1:nband_k)=zero
5817 :
5818 612 : if (istwf_k==1) then
5819 536 : call zhemm('l','l',nband_k,nband_k,cone,totvnlx,nband_k,evec,nband_k,czero,mat1,nband_k)
5820 4732 : do iband=1,nband_k
5821 4732 : enlx_k(iband)= cg_real_zdotc(nband_k,evec(:,iband),mat1(:,:,iband))
5822 : end do
5823 :
5824 76 : else if (istwf_k==2) then
5825 304 : ABI_MALLOC(evec_loc,(nband_k,nband_k))
5826 228 : ABI_MALLOC(mat_loc,(nband_k,nband_k))
5827 672 : do iband=1,nband_k
5828 5368 : do jj=1,nband_k
5829 5292 : evec_loc(iband,jj)=evec(2*iband-1,jj)
5830 : end do
5831 : end do
5832 76 : call dsymm('l','l',nband_k,nband_k,one,totvnlx,nband_k,evec_loc,nband_k,zero,mat_loc,nband_k)
5833 672 : do iband=1,nband_k
5834 672 : enlx_k(iband)=ddot(nband_k,evec_loc(:,iband),1,mat_loc(:,iband),1)
5835 : end do
5836 76 : ABI_FREE(evec_loc)
5837 76 : ABI_FREE(mat_loc)
5838 : end if
5839 :
5840 612 : ABI_FREE(matvnl)
5841 612 : ABI_FREE(mat1)
5842 :
5843 612 : end subroutine cg_hrotate_and_get_diag
5844 : !!***
5845 :
5846 : !!****f* m_cgtools/cg_get_eigens
5847 : !! NAME
5848 : !! cg_get_eigens
5849 : !!
5850 : !! FUNCTION
5851 : !! Helper functions to compute <i|H|i> / <i|S|i> for ndat states.
5852 : !! Assume normalized input wavefunctions.
5853 : !!
5854 : !! INPUTS
5855 : !!
5856 : !! OUTPUT
5857 : !!
5858 : !! SOURCE
5859 :
5860 2758 : subroutine cg_get_eigens(usepaw, istwf_k, npwsp, ndat, cg, ghc, gsc, eig, me_g0, comm)
5861 :
5862 : integer,intent(in) :: usepaw, istwf_k, npwsp, ndat, me_g0, comm
5863 : real(dp),intent(in) :: ghc(2*npwsp, ndat), cg(2*npwsp, ndat), gsc(2*npwsp, ndat*usepaw)
5864 : real(dp),intent(out) :: eig(ndat)
5865 :
5866 : !Local variables-------------------------------
5867 : integer,parameter :: option1 = 1
5868 : integer :: idat, ierr
5869 5516 : real(dp) :: doti, dots_r(ndat)
5870 : ! *************************************************************************
5871 :
5872 : ! <psi|H|psi> / <psi|S|psi>
5873 : !$OMP PARALLEL DO IF (ndat > 1)
5874 40790 : do idat=1,ndat
5875 38032 : call dotprod_g(eig(idat), doti, istwf_k, npwsp, option1, ghc(:,idat), cg(:,idat), me_g0, xmpi_comm_self)
5876 40790 : if (usepaw == 1) then
5877 7640 : call dotprod_g(dots_r(idat), doti, istwf_k, npwsp, option1, gsc(:,idat), cg(:,idat), me_g0, xmpi_comm_self)
5878 : end if
5879 : end do
5880 :
5881 2758 : if (xmpi_comm_size(comm) > 1) then
5882 1548 : call xmpi_sum(eig, comm, ierr)
5883 1548 : if (usepaw == 1) call xmpi_sum(dots_r, comm, ierr)
5884 : end if
5885 :
5886 11389 : if (usepaw == 1) eig(:) = eig(:) / dots_r(:)
5887 :
5888 2758 : end subroutine cg_get_eigens
5889 : !!***
5890 :
5891 : !!****f* m_cgtools/cg_get_residvecs
5892 : !! NAME
5893 : !! cg_get_residvecs
5894 : !!
5895 : !! FUNCTION
5896 : !! Compute residual vectors (H - eS) |psi> for ndat states.
5897 : !!
5898 : !! INPUTS
5899 : !!
5900 : !! OUTPUT
5901 : !!
5902 : !! SOURCE
5903 :
5904 4496 : subroutine cg_get_residvecs(usepaw, npwsp, ndat, eig, cg, ghc, gsc, residvecs)
5905 :
5906 : integer,intent(in) :: usepaw, npwsp, ndat
5907 : real(dp),intent(in) :: eig(ndat)
5908 : real(dp),intent(in) :: ghc(2*npwsp, ndat), cg(2*npwsp, ndat), gsc(2*npwsp, ndat*usepaw)
5909 : real(dp),intent(out) :: residvecs(2*npwsp, ndat)
5910 :
5911 : !Local variables-------------------------------
5912 : integer :: idat
5913 : ! *************************************************************************
5914 :
5915 4496 : if (usepaw == 1) then
5916 : ! (H - e) |psi>
5917 : !$OMP PARALLEL DO IF (ndat > 1)
5918 13047 : do idat=1,ndat
5919 7426151 : residvecs(:,idat) = ghc(:,idat) - eig(idat) * gsc(:,idat)
5920 : end do
5921 : else
5922 : ! (H - eS) |psi>
5923 : !$OMP PARALLEL DO IF (ndat > 1)
5924 54073 : do idat=1,ndat
5925 126221017 : residvecs(:,idat) = ghc(:,idat) - eig(idat) * cg(:,idat)
5926 : end do
5927 : end if
5928 :
5929 4496 : end subroutine cg_get_residvecs
5930 : !!***
5931 :
5932 : !!****f* m_cgtools/cg_norm2g
5933 : !! NAME
5934 : !! cg_norm2g
5935 : !!
5936 : !! FUNCTION
5937 : !! Compute <psi|psi> for ndat states distributed inside communicator comm.
5938 : !!
5939 : !! INPUTS
5940 : !!
5941 : !! OUTPUT
5942 : !!
5943 : !! SOURCE
5944 :
5945 4496 : subroutine cg_norm2g(istwf_k, npwsp, ndat, cg, norms, me_g0, comm)
5946 :
5947 : integer,intent(in) :: istwf_k, npwsp, ndat, me_g0, comm
5948 : real(dp),intent(in) :: cg(2*npwsp, ndat)
5949 : real(dp),intent(out) :: norms(ndat)
5950 :
5951 : !Local variables-------------------------------
5952 : integer :: idat, ierr
5953 : ! *************************************************************************
5954 :
5955 : !$OMP PARALLEL DO IF (ndat > 1)
5956 67120 : do idat=1,ndat
5957 67120 : call sqnorm_g(norms(idat), istwf_k, npwsp, cg(:,idat), me_g0, xmpi_comm_self)
5958 : end do
5959 4496 : if (xmpi_comm_size(comm) > 1) call xmpi_sum(norms, comm, ierr)
5960 :
5961 4496 : end subroutine cg_norm2g
5962 : !!***
5963 :
5964 : !!****f* m_cgtools/cg_zdotg_zip
5965 : !! NAME
5966 : !! cg_zdotg_zip
5967 : !!
5968 : !! FUNCTION
5969 : !! Compute <cg1|cg2> for ndat states
5970 : !!
5971 : !! INPUTS
5972 : !!
5973 : !! OUTPUT
5974 : !!
5975 : !! SOURCE
5976 :
5977 2575 : subroutine cg_zdotg_zip(istwf_k, npwsp, ndat, option, cg1, cg2, dots, me_g0, comm)
5978 :
5979 : integer,intent(in) :: istwf_k, npwsp, ndat, option, me_g0, comm
5980 : real(dp),intent(in) :: cg1(2*npwsp,ndat), cg2(2*npwsp,ndat)
5981 : real(dp),intent(out) :: dots(2,ndat)
5982 :
5983 : !Local variables-------------------------------
5984 : integer :: idat, ierr
5985 5150 : real(dp) :: dotr, doti, re_dots(ndat)
5986 : ! *************************************************************************
5987 :
5988 : !$OMP PARALLEL DO IF (ndat > 1) PRIVATE(dotr, doti)
5989 51143 : do idat=1,ndat
5990 48568 : call dotprod_g(dotr, doti, istwf_k, npwsp, option, cg1(:,idat), cg2(:,idat), me_g0, xmpi_comm_self)
5991 51143 : if (istwf_k == 2) then
5992 14096 : re_dots(idat) = dotr
5993 : else
5994 103416 : dots(:, idat) = [dotr, doti]
5995 : end if
5996 : end do
5997 :
5998 2575 : if (xmpi_comm_size(comm) > 1) then
5999 1660 : if (istwf_k == 2) then
6000 476 : call xmpi_sum(re_dots, comm, ierr)
6001 : else
6002 1184 : call xmpi_sum(dots, comm, ierr)
6003 : end if
6004 : end if
6005 :
6006 2575 : if (istwf_k == 2) then
6007 14648 : do idat=1,ndat
6008 14096 : dots(1,idat) = re_dots(idat)
6009 14648 : dots(2,idat) = zero
6010 : end do
6011 : end if
6012 :
6013 2575 : end subroutine cg_zdotg_zip
6014 : !!***
6015 :
6016 : !!****f* m_cgtools/cg_precon_many
6017 : !! NAME
6018 : !! cg_precon_many
6019 : !!
6020 : !! FUNCTION
6021 : !!
6022 : !! INPUTS
6023 : !!
6024 : !! OUTPUT
6025 : !!
6026 : !! SOURCE
6027 :
6028 2454 : subroutine cg_precon_many(istwf_k, npw, nspinor, ndat, cg, optekin, kinpw, vect, me_g0, comm)
6029 :
6030 : integer,intent(in) :: istwf_k, npw, nspinor, optekin, ndat, me_g0, comm
6031 : real(dp),intent(in) :: cg(2*npw*nspinor,ndat), kinpw(npw)
6032 : real(dp),intent(inout) :: vect(2*npw*nspinor,ndat)
6033 :
6034 : !Local variables-------------------------------
6035 : integer :: idat
6036 2454 : real(dp),allocatable :: pcon(:)
6037 : ! *************************************************************************
6038 :
6039 : ! TODO: Optimized version for MPI with ndat > 1
6040 7362 : ABI_MALLOC(pcon, (npw))
6041 :
6042 : !$OMP PARALLEL DO IF (ndat > 1)
6043 38150 : do idat=1,ndat
6044 38150 : call cg_precon(cg(:,idat), zero, istwf_k, kinpw, npw, nspinor, me_g0, optekin, pcon, vect(:,idat), comm)
6045 : end do
6046 2454 : ABI_FREE(pcon)
6047 :
6048 : !call cg_kinene(istwf_k, npw, nspinor, ndat, cg, me_g0, comm)
6049 : !call cg_zprecon_block(cg,eval,blocksize,iterationnumber,kinpw, npw,nspinor,optekin,optpcon,pcon,ghc,vect,vectsize,comm)
6050 :
6051 2454 : end subroutine cg_precon_many
6052 : !!***
6053 :
6054 : !----------------------------------------------------------------------
6055 :
6056 : !!****f* m_cgtools/cg_zaxpy_many_areal
6057 : !! NAME
6058 : !! cg_zaxpy_many_areal
6059 : !!
6060 : !! FUNCTION
6061 : !! Computes y = alpha*x + y
6062 : !!
6063 : !! INPUTS
6064 : !! n = Specifies the number of elements in vectors x and y.
6065 : !! ndat
6066 : !! alpha(ndat) = Specifies the scalar alpha.
6067 : !! x = Array
6068 : !!
6069 : !! SIDE EFFECTS
6070 : !! y = Array. In output, y contains the updated vector.
6071 : !!
6072 : !! SOURCE
6073 :
6074 1561 : subroutine cg_zaxpy_many_areal(npwsp, ndat, alphas, x, y)
6075 :
6076 : !Arguments ------------------------------------
6077 : !scalars
6078 : integer,intent(in) :: npwsp, ndat
6079 : real(dp),intent(in) :: alphas(ndat)
6080 : !arrays
6081 : real(dp),intent(in) :: x(2*npwsp, ndat)
6082 : real(dp),intent(inout) :: y(2*npwsp, ndat)
6083 :
6084 : !Local variables-------------------------------
6085 : integer :: idat
6086 : ! *************************************************************************
6087 :
6088 : !$OMP PARALLEL DO IF (ndat > 1)
6089 24769 : do idat=1,ndat
6090 24769 : call daxpy(2*npwsp, alphas(idat), x(1,idat), 1, y(1,idat), 1)
6091 : end do
6092 :
6093 1561 : end subroutine cg_zaxpy_many_areal
6094 : !!***
6095 :
6096 : !----------------------------------------------------------------------
6097 :
6098 : !!****f* m_cgtools/cg_set_imag0_to_zero
6099 : !! NAME
6100 : !! cg_set_imag0_to_zero
6101 : !!
6102 : !! FUNCTION
6103 : !! Set the imaginary part at G=0 to zero if istwfk == 2 and this proc has the gamma point
6104 : !!
6105 : !! INPUTS
6106 : !! npwsp=Size of each vector (usually npw*nspinor)
6107 : !! istwfk=Storage mode for the wavefunctions. 1 for standard full mode
6108 : !! me_g0=1 if this node has G=0.
6109 : !!
6110 : !! SIDE EFFECTS
6111 : !! cg(2*npwsp*nband)
6112 : !! input: Input set of vectors.
6113 : !! output: Orthonormalized set.
6114 : !!
6115 : !! SOURCE
6116 :
6117 0 : pure subroutine cg_set_imag0_to_zero(istwfk, me_g0, npwsp, nband, cg, max_absimag)
6118 :
6119 : !Arguments ------------------------------------
6120 : !scalars
6121 : integer,intent(in) :: istwfk, me_g0, npwsp, nband
6122 : !arrays
6123 : real(dp),intent(inout) :: cg(2,npwsp*nband)
6124 : real(dp),intent(out) :: max_absimag
6125 :
6126 : !Local variables ------------------------------
6127 : integer :: ib, ii
6128 : ! *************************************************************************
6129 :
6130 0 : max_absimag = zero
6131 0 : if (istwfk == 2 .and. me_g0 == 1) then
6132 0 : do ib=1,nband
6133 0 : ii = 1 + (ib - 1) * npwsp
6134 0 : max_absimag = max(max_absimag, abs(cg(2, ii)))
6135 0 : cg(2, ii) = zero
6136 : end do
6137 : end if
6138 :
6139 0 : end subroutine cg_set_imag0_to_zero
6140 : !!***
6141 :
6142 : !----------------------------------------------------------------------
6143 :
6144 : !!****f* m_cgtools/cg_randomize
6145 : !! NAME
6146 : !! cg_randomize
6147 : !!
6148 : !! FUNCTION
6149 : !! Initialize block of wavefunctions with random numbers. See wfconv
6150 : !!
6151 : !! INPUTS
6152 : !!
6153 : !! SOURCE
6154 :
6155 44 : subroutine cg_randomize(istwf_k, npw_k, nspinor, nband_k, me_g0, cg_k)
6156 :
6157 : !Arguments ------------------------------------
6158 : !scalars
6159 : integer,intent(in) :: istwf_k, npw_k, nspinor, nband_k, me_g0
6160 : !arrays
6161 : real(dp),intent(inout) :: cg_k(2,npw_k*nspinor,nband_k)
6162 :
6163 : !Local variables ------------------------------
6164 : integer :: ipw, ispinor, index
6165 : integer, parameter :: int64 = selected_int_kind(18)
6166 : integer(KIND=int64) :: seed
6167 : integer :: fold1,fold2,foldim,foldre,iband
6168 : ! *************************************************************************
6169 :
6170 836 : do iband=1,nband_k
6171 : index = 0
6172 1628 : do ispinor=1,nspinor
6173 1017378 : do ipw=1,npw_k
6174 1015794 : index=index+1
6175 1015794 : seed=(iband-1)*npw_k*nspinor + (ispinor-1)*npw_k + ipw
6176 :
6177 : ! For portability, use only integer numbers
6178 : ! The series of couples (fold1,fold2) is periodic with a period of
6179 : ! 3x5x7x11x13x17x19x23x29x31, that is, larger than 2**32, the largest integer*4
6180 : ! fold1 is between 0 and 34, fold2 is between 0 and 114. As sums of five
6181 : ! uniform random variables, their distribution is close to a gaussian
6182 1015794 : fold1=modulo(seed,3)+modulo(seed,5)+modulo(seed,7)+modulo(seed,11)+modulo(seed,13)
6183 1015794 : fold2=modulo(seed,17)+modulo(seed,19)+modulo(seed,23)+modulo(seed,29)+modulo(seed,31)
6184 :
6185 : ! The gaussian distributions are folded, in order to be back to a uniform distribution
6186 : ! foldre is between 0 and 20, foldim is between 0 and 18
6187 1015794 : foldre=mod(fold1+fold2,21)
6188 1015794 : foldim=mod(3*fold1+2*fold2,19)
6189 :
6190 1015794 : cg_k(1,index,iband) = dble(foldre)
6191 1015794 : cg_k(2,index,iband) = dble(foldim)
6192 :
6193 : ! XG030513: Time-reversal symmetry for k=gamma imposes zero imaginary part at G=0
6194 : ! XG: I do not know what happens for spin-orbit here.
6195 1016586 : if (istwf_k == 2 .and. me_g0 == 1) cg_k(2,1,iband)=zero
6196 : end do ! ipw
6197 : end do ! ispinor
6198 : end do ! iband
6199 :
6200 44 : end subroutine cg_randomize
6201 : !!***
6202 :
6203 : !----------------------------------------------------------------------
6204 :
6205 : !!****f* m_cgtools/cg_copy_spin
6206 : !! NAME
6207 : !! cg_copy_spin
6208 : !!
6209 : !! FUNCTION
6210 : !!
6211 : !! INPUTS
6212 : !!
6213 : !! SOURCE
6214 :
6215 281148 : subroutine cg_copy_spin(spin, npw_k, nspinor, ndat, in_cg, out_cg)
6216 :
6217 : !Arguments ------------------------------------
6218 : !scalars
6219 : integer,intent(in) :: spin, npw_k, nspinor, ndat
6220 : !arrays
6221 : real(dp),intent(inout) :: in_cg(2,npw_k,nspinor,ndat)
6222 : real(dp),intent(out) :: out_cg(2,npw_k,ndat)
6223 :
6224 : !Local variables ------------------------------
6225 : integer :: idat
6226 : ! *************************************************************************
6227 :
6228 : !$OMP PARALLEL DO IF (ndat > 1)
6229 562296 : do idat=1,ndat
6230 192742308 : out_cg(:,:,idat) = in_cg(:,:,spin,idat)
6231 : end do
6232 :
6233 281148 : end subroutine cg_copy_spin
6234 : !!***
6235 :
6236 : !----------------------------------------------------------------------
6237 :
6238 : !!****f* m_cgtools/cg_put_spin
6239 : !! NAME
6240 : !! cg_put_spin
6241 : !!
6242 : !! FUNCTION
6243 : !!
6244 : !! INPUTS
6245 : !!
6246 : !! SOURCE
6247 :
6248 278238 : subroutine cg_put_spin(spin, npw_k, nspinor, ndat, in_cg, out_cg)
6249 :
6250 : !Arguments ------------------------------------
6251 : !scalars
6252 : integer,intent(in) :: spin, npw_k, nspinor, ndat
6253 : !arrays
6254 : real(dp),intent(inout) :: in_cg(2,npw_k,ndat)
6255 : real(dp),intent(out) :: out_cg(2,npw_k,nspinor,ndat)
6256 :
6257 : !Local variables ------------------------------
6258 : integer :: idat
6259 : ! *************************************************************************
6260 :
6261 : !$OMP PARALLEL DO IF (ndat > 1)
6262 556476 : do idat=1,ndat
6263 190909440 : out_cg(:,:,spin, idat) = in_cg(:,:,idat)
6264 : end do
6265 :
6266 278238 : end subroutine cg_put_spin
6267 : !!***
6268 :
6269 : !----------------------------------------------------------------------
6270 :
6271 : !!****f* m_cgtools/cg_p_psi
6272 : !! NAME
6273 : !! cg_g_psi
6274 : !!
6275 : !! FUNCTION
6276 : !! Compute <g|-i\Nabla |psi_nk>.
6277 : !!
6278 : !! INPUTS
6279 : !!
6280 : !! SOURCE
6281 :
6282 0 : subroutine cg_p_psi(npw_k, nspinor, ndat, kk, kg_k, cg_k, p_cg_k)
6283 :
6284 : !Arguments ------------------------------------
6285 : !scalars
6286 : integer,intent(in) :: npw_k, nspinor, ndat
6287 : !arrays
6288 : real(dp),intent(in) :: kk(3)
6289 : integer,intent(in) :: kg_k(3,npw_k)
6290 : real(dp),intent(in) :: cg_k(2,npw_k*nspinor,ndat)
6291 : real(dp),intent(out) :: p_cg_k(2,npw_k*nspinor,ndat,3)
6292 :
6293 : !Local variables ------------------------------
6294 : integer :: idir, ig, ispinor, idat, spad, ipwsp
6295 : ! *************************************************************************
6296 :
6297 : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(spad, ipwsp)
6298 0 : do idir=1,3
6299 0 : do idat=1,ndat
6300 0 : do ispinor=1,nspinor
6301 0 : spad = (ispinor - 1) * npw_k
6302 0 : do ig=1,npw_k
6303 0 : ipwsp = ig + spad
6304 0 : p_cg_k(:, ipwsp, idat, idir) = cg_k(:, ipwsp, idat) * (kg_k(idir, ig) + kk(idir))
6305 : end do ! ig
6306 : end do ! ispinor
6307 : end do ! idir
6308 : end do ! idat
6309 :
6310 0 : end subroutine cg_p_psi
6311 : !!**
6312 :
6313 : end module m_cgtools
6314 : !!***
|
