Branch data 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 : 73585808 : 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 : 73585808 : call zcopy(n, x, 1, y, 1)
427 : :
428 : 73585808 : 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 : 10513915 : 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 [ + - ]: 10513915 : if (a(2) == zero) then
460 : 10513915 : call dscal(2*n, a(1), x, 1)
461 : : else
462 : 0 : call zscal(n, a, x, 1)
463 : : end if
464 : :
465 : 10513915 : 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 : 35402594 : 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 : 35372586 : 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 [ - + ]: 30301461 : 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 : 30301461 : cres = zdotc(n, x, 1, y, 1)
548 : 30301461 : res(1) = REAL(cres)
549 : 30301461 : res(2) = AIMAG(cres)
550 : : #endif
551 : :
552 : 30301461 : 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 : 135641053 : 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 : 135641053 : res = ddot(2*n, x, 1, y, 1)
588 : :
589 : 135641053 : 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 : 55552233 : 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 [ + + ]: 55552233 : if (alpha(2) == zero) then
678 : 54950598 : 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 : 55552233 : 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 : 116499538 : 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 [ + + ]: 116499538 : my_alpha = cg_cone; if (present(alpha)) my_alpha = alpha
773 [ + + ]: 116499538 : my_beta = cg_czero; if (present(beta)) my_beta = beta
774 [ + + ]: 116499538 : my_gpu_option = ABI_GPU_DISABLED; if (present(gpu_option)) my_gpu_option = gpu_option
775 : :
776 : 116499538 : lda = nrows; mm = nrows; nn = 1; kk = ncols
777 [ + + ]: 116499538 : if (toupper(trans) /= 'N') then
778 : 174570751 : mm = ncols; kk = nrows
779 : : end if
780 : 116499538 : ldb = kk; ldc = mm
781 : :
782 : : ! ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
783 : :
784 : 116499538 : my_calpha = DCMPLX(my_alpha(1), my_alpha(2))
785 : 116499538 : 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 : 116499538 : & x_cplx=2, gpu_option=my_gpu_option)
791 : :
792 : 116499538 : 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 : 48814 : 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 : 48814 : bit0=1
911 : :
912 [ + + ]: 195256 : do ii=1,3
913 [ + + ]: 195256 : if (DABS(kpoint(ii))<tol10) then
914 : 36868 : bit(ii)=0
915 [ + + ]: 109574 : else if (DABS(kpoint(ii)-half)<tol10 ) then
916 : 14543 : bit(ii)=1
917 : : else
918 : : bit0=0
919 : : end if
920 : : end do
921 : :
922 [ + + ]: 48814 : if (bit0==0) then
923 : : istwfk=1
924 : : else
925 : 7718 : istwfk=2+bit(1)+4*bit(2)+2*bit(3) ! Note the inversion between bit(2) and bit(3)
926 : : end if
927 : :
928 : 48814 : 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 : 36877984 : 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 [ + + ]: 36877984 : if (istwf_k==1) then ! General k-point
966 : : !dotr = cg_real_zdotc(npwsp,vect,vect)
967 : 35371266 : dotr = cg_dznrm2(npwsp, vect)
968 : 35371266 : dotr = dotr * dotr
969 : :
970 : : else
971 [ + + + + ]: 1506718 : if (istwf_k == 2 .and. me_g0 == 1) then
972 : : ! Gamma k-point and I have G=0
973 : 716269 : dotr=half*vect(1,1)**2
974 : 716269 : dotr = dotr + cg_real_zdotc(npwsp-1, vect(1,2), vect(1,2))
975 : : else
976 : : ! Other TR k-points
977 : 790449 : dotr = cg_real_zdotc(npwsp, vect, vect)
978 : : end if
979 : 1506718 : dotr=two*dotr
980 : : end if
981 : :
982 [ - + ]: 36877984 : if (xmpi_comm_size(comm)>1) call xmpi_sum(dotr,comm,ierr)
983 : :
984 : 36877984 : 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 : 159730843 : 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 : 159730843 : dotr = zero
1037 : 159730843 : doti = zero
1038 : :
1039 [ + + ]: 159730843 : if (istwf_k==1) then
1040 : : ! General k-point
1041 : :
1042 [ + + ]: 155243996 : if(option==1)then
1043 : 128509042 : dotr = cg_real_zdotc(npw,vect1,vect2)
1044 : : else
1045 : 26734954 : dotarr = cg_zdotc(npw,vect1,vect2)
1046 : 26734954 : dotr = dotarr(1)
1047 : 26734954 : doti = dotarr(2)
1048 : : end if
1049 : :
1050 [ + + + + ]: 4486847 : else if (istwf_k==2 .and. me_g0==1) then
1051 : : ! Gamma k-point and I have G=0
1052 : 2031307 : dotr=half*vect1(1,1)*vect2(1,1)
1053 : 2031307 : dotr = dotr + cg_real_zdotc(npw-1,vect1(1,2),vect2(1,2))
1054 : 2031307 : dotr = two*dotr
1055 [ + + ]: 2031307 : if (option==2) doti=zero
1056 : :
1057 : : else
1058 : : ! Other TR k-points
1059 : 2455540 : dotr = cg_real_zdotc(npw,vect1,vect2)
1060 : 2455540 : dotr=two*dotr
1061 [ + + ]: 2455540 : if (option==2) doti=zero
1062 : : end if
1063 : :
1064 : : !Reduction in case of parallelism
1065 [ + + ]: 159730843 : 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 : 159730843 : 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 : 257182 : 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 [ + + ]: 257182 : l_gpu_option=ABI_GPU_DISABLED; if(present(gpu_option)) l_gpu_option = gpu_option
1128 : : ! Init results independently of option.
1129 [ + - ]: 257182 : if(l_gpu_option==ABI_GPU_DISABLED) then
1130 [ + + + + ]: 5033596 : 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 [ + + ]: 257182 : if (istwf_k==1) then
1139 : : ! General k-point
1140 : :
1141 [ + - ]: 257046 : 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 [ + + ]: 2516526 : do idat=1,ndat
1160 : : dotarr = zero
1161 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotarr)
1162 [ + + ]: 506095534 : do ii=1,npw
1163 : 503836054 : dotarr(1) = dotarr(1) + vect1(1,ii)*vect2(1,ii,idat) + vect1(2,ii)*vect2(2,ii,idat)
1164 : 506095534 : dotarr(2) = dotarr(2) + vect1(1,ii)*vect2(2,ii,idat) - vect1(2,ii)*vect2(1,ii,idat)
1165 : : end do
1166 : 2259480 : dotr(idat) = dotarr(1)
1167 : 2516526 : 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 [ - + ]: 257182 : 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 : 257182 : end subroutine dotprod_g_batch_half
1228 : : !!***
1229 : :
1230 : :
1231 : 812412 : 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 [ + - ]: 812412 : l_gpu_option=ABI_GPU_DISABLED; if(present(gpu_option)) l_gpu_option = gpu_option
1247 : : ! Init results independently of option.
1248 [ + - ]: 812412 : if(l_gpu_option==ABI_GPU_DISABLED) then
1249 [ + + + + ]: 3415692 : 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 [ + + ]: 812412 : if (istwf_k==1) then
1258 : : ! General k-point
1259 : :
1260 [ + + ]: 811974 : 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 [ + + ]: 1703778 : do idat=1,ndat
1279 : : dotarr = zero
1280 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotarr)
1281 [ + + ]: 187475964 : do ii=1,npw
1282 : 186583026 : dotarr(1) = dotarr(1) + vect1(1,ii,idat)*vect2(1,ii,idat) + vect1(2,ii,idat)*vect2(2,ii,idat)
1283 : 187475964 : dotarr(2) = dotarr(2) + vect1(1,ii,idat)*vect2(2,ii,idat) - vect1(2,ii,idat)*vect2(1,ii,idat)
1284 : : end do
1285 : 892938 : dotr(idat) = dotarr(1)
1286 : 1703778 : 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 [ - + ]: 812412 : 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 : 812412 : 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 : 961968 : 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 [ + + - + ]: 961968 : 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 : 961968 : ar=zero
1418 [ - + ]: 961968 : if(needimag==1)ai=zero
1419 : :
1420 : : !Normal storage mode
1421 [ + - ]: 961968 : if(istwf_k==1)then
1422 : :
1423 : : ! Need only real part
1424 [ - + ]: 961968 : if(needimag==0)then
1425 : :
1426 [ + + ]: 137745328 : do ipw=1,npw
1427 : 137745328 : ar=ar+diag(ipw)*(vect1(1,ipw)*vect2(1,ipw)+vect1(2,ipw)*vect2(2,ipw))
1428 : : end do
1429 : :
1430 [ + + ]: 961968 : 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 [ - + ]: 961968 : 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 : 961968 : 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 : 226819 : 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 : 226819 : dotr=zero; doti=zero
1654 : :
1655 [ + + ]: 226819 : if(nspden==1)then
1656 : :
1657 [ + + + + ]: 217945 : if(option==1 .or. cplex==1 )then
1658 : : !$OMP PARALLEL DO REDUCTION(+:dotr)
1659 [ + + ]: 4921424029 : do ifft=1,cplex*nfft
1660 : 4921424029 : 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 [ + + ]: 8874 : else if(nspden==2)then
1676 : :
1677 [ + + + + ]: 6840 : if(option==1 .or. cplex==1 )then
1678 : : !$OMP PARALLEL DO REDUCTION(+:dotr)
1679 [ + + ]: 135679993 : do ifft=1,cplex*nfft
1680 : : dotr=dotr + pot(ifft,1)* dens(ifft,2) & ! This is the spin up contribution
1681 : 135679993 : & + 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 : 226819 : factor=ucvol/dble(nfftot)
1843 : 226819 : dotr=factor*dotr
1844 : 226819 : doti=factor*doti
1845 : :
1846 : : !MPIWF reduction (addition) on dotr, doti is needed here
1847 [ + + ]: 226819 : if(present(mpi_comm_sphgrid)) then
1848 : 119849 : nproc_sphgrid=xmpi_comm_size(mpi_comm_sphgrid)
1849 [ + + ]: 119849 : if(nproc_sphgrid>1) then
1850 : 6640 : buffer2(1)=dotr
1851 : 6640 : buffer2(2)=doti
1852 : 6640 : call xmpi_sum(buffer2,mpi_comm_sphgrid,ierr)
1853 : 6640 : dotr=buffer2(1)
1854 : 6640 : doti=buffer2(2)
1855 : : end if
1856 : : end if
1857 : :
1858 : 226819 : 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 : 65802 : 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 : 65802 : norm2=zero
1906 [ + + ]: 141032 : do ispden=1,min(nspden,2)
1907 : : !$OMP PARALLEL DO PRIVATE(ifft) SHARED(cplex,ispden,nfft,pot) REDUCTION(+:norm2)
1908 [ + + ]: 1737267692 : do ifft=1,cplex*nfft
1909 : 1737201890 : norm2=norm2 + pot(ifft,ispden)**2
1910 : : end do
1911 : : end do
1912 [ + + ]: 65802 : if (nspden==4) then
1913 : : ar=zero
1914 [ + + ]: 8220 : do ispden=3,4
1915 : : !$OMP PARALLEL DO PRIVATE(ifft) SHARED(cplex,ispden,nfft,pot) REDUCTION(+:ar)
1916 [ + + ]: 67526862 : do ifft=1,cplex*nfft
1917 : 67524122 : ar=ar + pot(ifft,ispden)**2
1918 : : end do
1919 : : end do
1920 [ + + ]: 2740 : if (opt_storage==0) then
1921 [ + + ]: 1696 : if (cplex==1) then
1922 : 1616 : 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 [ + + ]: 65802 : if(present(mpi_comm_sphgrid)) then
1933 : 47309 : nproc_sphgrid=xmpi_comm_size(mpi_comm_sphgrid)
1934 [ + + ]: 47309 : if(nproc_sphgrid>1)then
1935 : 2680 : call xmpi_sum(norm2,mpi_comm_sphgrid,ierr)
1936 : : end if
1937 : : end if
1938 : :
1939 : 65802 : 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 : 211109 : 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 [ + + ]: 211109 : l_gpu_thread_limit=0; if(present(gpu_thread_limit)) l_gpu_thread_limit=gpu_thread_limit
1984 : 211109 : invnfftot=one/(dble(nfftot))
1985 : :
1986 [ - + ]: 211109 : 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 [ + + ]: 460991 : do ispden=1,nspden
1992 : : tmean=zero
1993 : : !$OMP PARALLEL DO REDUCTION(+:tmean)
1994 [ + + ]: 5218815460 : do ifft=1,nfft
1995 : 5218815460 : tmean=tmean+arraysp(ifft,ispden)
1996 : : end do
1997 : 460991 : 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 [ + + ]: 211109 : if(present(mpi_comm_sphgrid)) then
2003 : 210842 : nproc_sphgrid=xmpi_comm_size(mpi_comm_sphgrid)
2004 [ + + ]: 210842 : if(nproc_sphgrid>1) then
2005 : 10184 : call xmpi_sum(meansp,nspden,mpi_comm_sphgrid,ierr)
2006 : : end if
2007 : : end if
2008 : :
2009 [ - + ]: 211109 : if(l_gpu_thread_limit /= 0) then
2010 : 0 : call xomp_set_num_threads(nthreads_bak)
2011 : : end if
2012 : :
2013 : 211109 : 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 : 58394461 : subroutine projbd(cg,direc,iband0,icg,iscg,istwf_k,mcg,mscg,nband,&
3310 : 58394461 : 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 : 58394461 : call timab(210+tim_projbd,1,tsec)
3330 : :
3331 [ + + ]: 58394461 : my_gpu_option = ABI_GPU_DISABLED; if (present(gpu_option)) my_gpu_option = gpu_option
3332 : :
3333 : 58394461 : npw_sp=npw*nspinor
3334 : :
3335 : 58394461 : nbandm=nband
3336 : :
3337 [ + + ]: 58394461 : if (istwf_k==1) then
3338 : :
3339 [ + + ]: 57102024 : if (scprod_io==0) then
3340 [ + + ]: 56778776 : if (useoverlap==1) then
3341 : 8982348 : call cg_zgemv("C",npw_sp,nbandm,scg(1,iscg+1),direc,scprod,gpu_option=my_gpu_option)
3342 : : else
3343 : 47796428 : call cg_zgemv("C",npw_sp,nbandm,cg(1,icg+1), direc,scprod,gpu_option=my_gpu_option)
3344 : : end if
3345 : 56778776 : call xmpi_sum(scprod,comm,ierr)
3346 : : end if
3347 : :
3348 [ + + + - ]: 57102024 : 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 : 57102024 : 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 [ + + + - ]: 57102024 : 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 [ + - ]: 1292437 : else if (istwf_k>=2) then
3373 [ - + ]: 1292437 : 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 [ + - ]: 1292437 : if (scprod_io==0) then
3382 : :
3383 [ + + ]: 1292437 : if (useoverlap==1) then
3384 : :
3385 [ + + + - ]: 309381 : if (istwf_k==2 .and. me_g0==1) then
3386 [ + + ]: 361950 : bkp_dirg0 = direc(:,1)
3387 : 120650 : direc(1,1) = half * direc(1,1)
3388 : 120650 : direc(2,1) = zero
3389 : : end if
3390 : :
3391 : 309381 : call cg_zgemv("C",npw_sp,nbandm,scg(1,iscg+1),direc,scprod,gpu_option=my_gpu_option)
3392 [ + + + + ]: 25862451 : scprod = two * scprod
3393 [ + + ]: 8827071 : scprod(2,:) = zero
3394 : :
3395 [ + + + - : 671331 : if(istwf_k==2 .and. me_g0==1) direc(:,1) = bkp_dirg0
+ + ]
3396 : :
3397 : : else
3398 : :
3399 [ + + + - ]: 983056 : if (istwf_k==2 .and. me_g0==1) then
3400 [ + + ]: 1496766 : bkp_dirg0 = direc(:,1)
3401 : 498922 : direc(1,1) = half * direc(1,1)
3402 : 498922 : direc(2,1) = zero
3403 : : end if
3404 : :
3405 : 983056 : call cg_zgemv("C",npw_sp,nbandm,cg(1,icg+1),direc,scprod,gpu_option=my_gpu_option)
3406 [ + + + + ]: 52423552 : scprod = two * scprod
3407 [ + + ]: 18129888 : scprod(2,:) = zero
3408 : :
3409 [ + + + - : 2479822 : if (istwf_k==2 .and. me_g0==1) direc(:,1) = bkp_dirg0
+ + ]
3410 : : end if ! useoverlap
3411 : :
3412 : 1292437 : call xmpi_sum(scprod,comm,ierr)
3413 : : end if
3414 : :
3415 [ - + - - ]: 1292437 : if (iband0>0.and.iband0<=nbandm) then
3416 [ # # ]: 0 : bkp_scprod = scprod(:,iband0)
3417 [ # # ]: 0 : scprod(:,iband0) = zero
3418 : : end if
3419 : :
3420 : 1292437 : 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 [ - + - - : 1292437 : 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 : 58394461 : call timab(210+tim_projbd,2,tsec)
3427 : :
3428 : 58394461 : 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 : 38798 : 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 : 38798 : real(dp),allocatable :: cut_pws(:)
3479 : : ! *************************************************************************
3480 : :
3481 : : !$(k+G)^2$ cutoff from $(1/2)(2 Pi (k+G))^2 = ecut$
3482 : 38798 : kpgsqc=ecut/(2.0_dp*pi**2)
3483 : 38798 : cutoff = kpgsqc
3484 : :
3485 [ - + + - : 116394 : ABI_MALLOC(cut_pws,(npw))
+ - + - -
+ - + ]
3486 : :
3487 : : !Run through G vectors in basis
3488 : : !$OMP PARALLEL DO PRIVATE(gs,i1,i2,i3)
3489 [ + + ]: 8204207 : do ig=1,npw
3490 : 8165409 : 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 : 8165409 : & gmet(1,3)*(kpoint(1)+dble(i1))*(kpoint(3)+dble(i3)))
3498 [ + + ]: 8204207 : if (gs>cutoff) then
3499 : 152828 : cut_pws(ig) = zero
3500 : : else
3501 : 8012581 : 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 [ + + ]: 294589 : do nn=1,nband
3508 : 255791 : spad = (nn-1)*npw*nspinor+icgmod
3509 [ + + ]: 575836 : do ispinor=1,nspinor
3510 [ + + ]: 73414852 : do ig=1,npw
3511 : 72877814 : igs=ig+(ispinor-1)*npw
3512 : 72877814 : cg(1,igs+spad) = cg(1,igs+spad) * cut_pws(ig)
3513 : 73159061 : cg(2,igs+spad) = cg(2,igs+spad) * cut_pws(ig)
3514 : : end do
3515 : : end do
3516 : : end do
3517 : :
3518 [ - + ]: 38798 : ABI_FREE(cut_pws)
3519 : :
3520 : 38798 : 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 : 447686 : 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 [ + + ]: 3670094 : do ii=1,nband
3561 : : ! find norm
3562 : 3222408 : xnorm=0.0d0
3563 [ + + ]: 121390764 : do jj=1,2*npw
3564 : 121390764 : xnorm=xnorm+cg(jj,ii)**2
3565 : : end do
3566 : :
3567 [ - + ]: 3222408 : 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 : 3222408 : xnorm=1.0d0/sqrt(xnorm)
3577 : : ! Set up phase
3578 : 3222408 : phre=cg(2*ii-1,ii)
3579 : 3222408 : phim=cg(2*ii,ii)
3580 [ + + ]: 3222408 : if (phim/=0.0d0) then
3581 : 2546993 : den=1.0d0/sqrt(phre**2+phim**2)
3582 : 2546993 : phre=phre*xnorm*den
3583 : 2546993 : phim=phim*xnorm*den
3584 : : else
3585 : : ! give xnorm the same sign as phre (negate if negative)
3586 : 675415 : phre=sign(xnorm,phre)
3587 : 675415 : phim=0.0d0
3588 : : end if
3589 : : ! normalize with phase change
3590 [ - + ]: 3670094 : do jj=1,2*npw,2
3591 : 59084178 : evre=cg(jj,ii)
3592 : 59084178 : evim=cg(jj+1,ii)
3593 : 59084178 : cg(jj,ii)=phre*evre+phim*evim
3594 [ + + ]: 59084178 : cg(jj+1,ii)=phre*evim-phim*evre
3595 : : end do
3596 : : end do
3597 : :
3598 : 447686 : 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 : 43843064 : 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 [ + + ]: 21921532 : if(istwf_k==1)then
3653 : 21328007 : ek0=zero
3654 [ + + ]: 43888245 : do ispinor=1,nspinor
3655 : 22560238 : igs=(ispinor-1)*npw
3656 [ + + ]: 6510485702 : do ig=1+igs,npw+igs
3657 [ + + ]: 6489157695 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
3658 : 6408240983 : ek0=ek0+kinpw(ig-igs)*(cg(1,ig)**2+cg(2,ig)**2)
3659 : : end if
3660 : : end do
3661 : : end do
3662 : :
3663 [ + - ]: 593525 : else if (istwf_k>=2)then
3664 [ + + + + ]: 593525 : if (istwf_k==2 .and. me_g0 == 1)then
3665 : 287201 : ek0=zero ; ipw1=2
3666 [ + - ]: 287201 : if(kinpw(1)<huge(zero)*1.d-11)ek0=0.5_dp*kinpw(1)*cg(1,1)**2
3667 : : else
3668 : 306324 : ek0=zero ; ipw1=1
3669 : : end if
3670 [ + + ]: 1187050 : do ispinor=1,nspinor
3671 : 593525 : igs=(ispinor-1)*npw
3672 [ + + ]: 363180513 : do ig=ipw1+igs,npw+igs
3673 [ + + ]: 362586988 : if(kinpw(ig)<huge(zero)*1.d-11)then
3674 : 354891953 : ek0=ek0+kinpw(ig)*(cg(1,ig)**2+cg(2,ig)**2)
3675 : : end if
3676 : : end do
3677 : : end do
3678 : 593525 : ek0=2.0_dp*ek0
3679 : : end if
3680 : :
3681 : 21921532 : call timab(48,1,tsec)
3682 : 21921532 : call xmpi_sum(ek0,comm,ierr)
3683 : 21921532 : call timab(48,2,tsec)
3684 : :
3685 [ + + ]: 21921532 : 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 [ + + ]: 21921532 : if (optekin==1) then
3691 : 1266396 : ek0_inv=2.0_dp/(3._dp*ek0)
3692 : : else
3693 : 20655136 : ek0_inv=1.0_dp/ek0
3694 : : end if
3695 : :
3696 : : !Carry out preconditioning
3697 [ + + ]: 45075295 : do ispinor=1,nspinor
3698 : 23153763 : igs=(ispinor-1)*npw
3699 : : !$OMP PARALLEL DO PRIVATE(fac,ig,poly,xx) SHARED(cg,ek0_inv,eval,kinpw,igs,npw,vect,pcon)
3700 [ + + ]: 6873953416 : do ig=1+igs,npw+igs
3701 [ + + ]: 6852031884 : if(kinpw(ig-igs)<huge(zero)*1.d-11)then
3702 : 6763420137 : xx=kinpw(ig-igs)*ek0_inv
3703 : : ! Teter polynomial ratio
3704 : 6763420137 : poly=27._dp+xx*(18._dp+xx*(12._dp+xx*8._dp))
3705 : 6763420137 : fac=poly/(poly+16._dp*xx**4)
3706 [ + + ]: 6763420137 : if (optekin==1) fac=two*fac
3707 : 6763420137 : pcon(ig-igs)=fac
3708 : 6763420137 : vect(1,ig)=( vect(1,ig)-eval*cg(1,ig) )*fac
3709 : 6763420137 : vect(2,ig)=( vect(2,ig)-eval*cg(2,ig) )*fac
3710 : : else
3711 : 65457984 : pcon(ig-igs)=zero
3712 : 65457984 : vect(1,ig)=zero
3713 : 65457984 : vect(2,ig)=zero
3714 : : end if
3715 : : end do
3716 : : end do
3717 : :
3718 : 21921532 : 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 : 288302 : 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 : 288302 : real(dp),allocatable :: cimb(:),creb(:),saab(:),sabb(:),sbbb(:) !,sarr(:,:)
4217 : : ! *************************************************************************
4218 : :
4219 : : !The general case, where a complex phase indeterminacy is present
4220 [ + + ]: 288302 : if(istwfk==1)then
4221 : :
4222 [ - + + - : 864876 : ABI_MALLOC(cimb,(nband_k))
+ - + - -
+ - + ]
4223 [ - + + - : 576584 : ABI_MALLOC(creb,(nband_k))
- + - + ]
4224 [ - + + - : 576584 : ABI_MALLOC(saab,(nband_k))
- + - + ]
4225 [ - + + - : 576584 : ABI_MALLOC(sabb,(nband_k))
- + - + ]
4226 [ - + + - : 576584 : ABI_MALLOC(sbbb,(nband_k))
- + - + ]
4227 [ + + + + ]: 3760894 : 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 [ + + ]: 2024593 : do iband=1,nband_k
4232 : 1736301 : indx=icg+(iband-1)*npw_k
4233 : :
4234 : : ! Compute several sums over Re, Im parts of c
4235 : 1736301 : saa=0.0_dp ; sbb=0.0_dp ; sab=0.0_dp
4236 [ + + ]: 16209788 : do ii=1+indx,npw_k+indx
4237 : 14473487 : saa=saa+cg(1,ii)*cg(1,ii)
4238 : 14473487 : sbb=sbb+cg(2,ii)*cg(2,ii)
4239 : 16209788 : sab=sab+cg(1,ii)*cg(2,ii)
4240 : : end do
4241 : 1736301 : saab(iband)=saa
4242 : 1736301 : sbbb(iband)=sbb
4243 : 2024593 : sabb(iband)=sab
4244 : : end do ! iband
4245 : :
4246 : :
4247 [ + + ]: 2024593 : do iband=1,nband_k
4248 : :
4249 : 1736301 : indx=icg+(iband-1)*npw_k
4250 : :
4251 : 1736301 : saa=saab(iband)
4252 : 1736301 : sbb=sbbb(iband)
4253 : 1736301 : sab=sabb(iband)
4254 : :
4255 : : ! Get phase angle theta
4256 [ + - ]: 1736301 : if (sbb+saa>tol8)then
4257 [ + + + + ]: 1736301 : if(abs(sbb-saa)>tol8*(sbb+saa) .or. 2*abs(sab)>tol8*(sbb+saa))then
4258 [ + + ]: 1735200 : if (abs(sbb-saa)>tol8*abs(sab)) then
4259 : 1734860 : quotient=sab/(sbb-saa)
4260 : 1734860 : 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 : 340 : theta=0.25_dp*(pi-(sbb-saa)/sab)
4264 : : end if
4265 : : ! Check roots to get theta for max Re part
4266 : 1735200 : root1=cos(theta)**2*saa+sin(theta)**2*sbb-2.0_dp*cos(theta)*sin(theta)*sab
4267 : 1735200 : thppi=theta+0.5_dp*pi
4268 : 1735200 : root2=cos(thppi)**2*saa+sin(thppi)**2*sbb-2.0_dp*cos(thppi)*sin(thppi)*sab
4269 [ + + ]: 1735200 : 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 [ - + ]: 1679 : do ii=1+indx,npw_k+indx
4274 : 1679 : cre=cg(1,ii)
4275 : 1679 : cim=cg(2,ii)
4276 [ + + ]: 1679 : if(cre**2+cim**2>tol8**2*(saa+sbb))then
4277 [ + + ]: 1101 : if(cre**2>tol8**2**cim**2)then
4278 : 907 : 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 : 194 : 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 : 1736301 : xx=cos(theta)
4296 : 1736301 : yy=sin(theta)
4297 : :
4298 : : ! Here, set the first non-zero element to be positive
4299 [ + - ]: 2303702 : do ii=1+indx,npw_k+indx
4300 : 2303702 : cre=cg(1,ii)
4301 : 2303702 : cim=cg(2,ii)
4302 : 2303702 : cre=xx*cre-yy*cim
4303 [ + + ]: 2303702 : if(abs(cre)>tol8)exit
4304 : : end do
4305 [ + + ]: 1736301 : if(cre<zero)then
4306 : 840006 : xx=-xx ; yy=-yy
4307 : : end if
4308 : :
4309 : 1736301 : creb(iband)=xx
4310 : 2024593 : cimb(iband)=yy
4311 : :
4312 : : end do
4313 : :
4314 [ + + ]: 2024593 : do iband=1,nband_k
4315 : :
4316 : 1736301 : indx=icg+(iband-1)*npw_k
4317 : :
4318 : 1736301 : xx=creb(iband)
4319 : 1736301 : yy=cimb(iband)
4320 [ + + ]: 16209788 : do ii=1+indx,npw_k+indx
4321 : 14473487 : cre=cg(1,ii)
4322 : 14473487 : cim=cg(2,ii)
4323 : 14473487 : cg(1,ii)=xx*cre-yy*cim
4324 : 16209788 : cg(2,ii)=xx*cim+yy*cre
4325 : : end do
4326 : :
4327 : : ! Alter phase of array S|cg>
4328 [ - + ]: 2024593 : 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 [ - + ]: 288292 : ABI_FREE(cimb)
4341 [ - + ]: 288292 : ABI_FREE(creb)
4342 [ - + ]: 288292 : ABI_FREE(saab)
4343 [ - + ]: 288292 : ABI_FREE(sabb)
4344 [ - + ]: 288292 : 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 [ - + + - : 30 : ABI_MALLOC(creb,(nband_k))
+ - + - -
+ - + ]
4350 [ + + ]: 50 : creb(:)=zero
4351 : : ! Loop over bands
4352 [ + + ]: 50 : do iband=1,nband_k
4353 : :
4354 : 40 : indx=icg+(iband-1)*npw_k
4355 : :
4356 : : ! Here, set the first non-zero real element to be positive
4357 [ + - ]: 64 : do ii=1+indx,npw_k+indx
4358 : 64 : cre=cg(1,ii)
4359 [ + + ]: 64 : if(abs(cre)>tol8)exit
4360 : : end do
4361 : 50 : creb(iband)=cre
4362 : :
4363 : : end do ! iband
4364 : :
4365 [ + + ]: 50 : do iband=1,nband_k
4366 : :
4367 : 40 : cre=creb(iband)
4368 [ + + ]: 50 : if(cre<zero)then
4369 : 5 : indx=icg+(iband-1)*npw_k
4370 [ + + ]: 715 : do ii=1+indx,npw_k+indx
4371 : 710 : cg(1,ii)=-cg(1,ii)
4372 : 715 : cg(2,ii)=-cg(2,ii)
4373 : : end do
4374 [ - + ]: 5 : 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 [ - + ]: 10 : ABI_FREE(creb)
4386 : :
4387 : : end if ! istwfk
4388 : :
4389 : 288302 : 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 the phase of each state with fxphas_seq and compare two sets of wavefunctions band by band:
4400 : : !! amplitudes must agree within atol_rho and, after removing the phase of the overlap <cg2|cg1>,
4401 : : !! the coefficients must agree within atol_cdiff (max norm).
4402 : : !! Degenerate states (eig_k within tol6) are skipped.
4403 : : !!
4404 : : !! OUTPUT
4405 : : !!
4406 : : !! SOURCE
4407 : :
4408 : 56 : logical function fxphas_and_cmp(npw_k, nspinor, nband_k, istwfk, cg1, cg2, eig_k, msg, atol_rho, atol_cdiff) result(ok)
4409 : :
4410 : : !Arguments ------------------------------------
4411 : : integer,intent(in) :: npw_k, nspinor, nband_k, istwfk
4412 : : real(dp),intent(inout) :: cg1(2, npw_k*nspinor, nband_k), cg2(2, npw_k*nspinor, nband_k)
4413 : : real(dp),intent(in) :: eig_k(nband_k)
4414 : : character(len=*),intent(out) :: msg
4415 : : real(dp),optional,intent(in) :: atol_rho, atol_cdiff
4416 : :
4417 : : !Local variables-------------------------------
4418 : : integer, parameter :: useoverlap0 = 0, mgsc = 0
4419 : : integer :: mcg, band, ipwsp
4420 : : real(dp) :: phi1, rho1, phi2, rho2, max_rho_adiff, atol_rho__, max_cdiff, atol_cdiff__, gsc(0,0)
4421 : : complex(dp) :: c1, c2, ovlp, phase
4422 : : character(len=500) :: btype
4423 : : ! ***********************************************************************
4424 : :
4425 [ - + ]: 56 : atol_rho__ = tol6; if (present(atol_rho)) atol_rho__ = atol_rho
4426 [ - + ]: 56 : atol_cdiff__ = tol6; if (present(atol_cdiff)) atol_cdiff__ = atol_cdiff
4427 : 56 : max_rho_adiff = zero; max_cdiff = zero
4428 : :
4429 : 56 : mcg = npw_k * nspinor * nband_k
4430 : 56 : call fxphas_seq(cg1, gsc, 0, 0, istwfk, mcg, mgsc, nband_k, npw_k * nspinor, useoverlap0)
4431 : 56 : call fxphas_seq(cg2, gsc, 0, 0, istwfk, mcg, mgsc, nband_k, npw_k * nspinor, useoverlap0)
4432 : :
4433 : : ! Two non-degenerate states differ at most by a phase factor: remove the phase given by the overlap
4434 : : ! <cg2|cg1> and compare the coefficients. States in a degenerate subspace can mix and are not compared.
4435 [ + + ]: 280 : do band=1,nband_k
4436 : 224 : call band_type(band, btype)
4437 [ + + ]: 224 : if (btype == "degenerate") cycle
4438 : : ovlp = czero
4439 [ + + ]: 47816 : do ipwsp=1,npw_k * nspinor
4440 : 47650 : c1 = cmplx(cg1(1, ipwsp, band), cg1(2, ipwsp, band), kind=dp)
4441 : 47650 : c2 = cmplx(cg2(1, ipwsp, band), cg2(2, ipwsp, band), kind=dp)
4442 : 47816 : ovlp = ovlp + conjg(c2) * c1
4443 : : end do
4444 [ + - ]: 166 : phase = cone; if (abs(ovlp) > tol12) phase = ovlp / abs(ovlp)
4445 [ + + ]: 47872 : do ipwsp=1,npw_k * nspinor
4446 : 47650 : call rhophi(cg1(:, ipwsp, band), phi1, rho1)
4447 : 47650 : call rhophi(cg2(:, ipwsp, band), phi2, rho2)
4448 : 47650 : max_rho_adiff = max(max_rho_adiff, abs(rho1 - rho2))
4449 : 47650 : c1 = cmplx(cg1(1, ipwsp, band), cg1(2, ipwsp, band), kind=dp)
4450 : 47650 : c2 = cmplx(cg2(1, ipwsp, band), cg2(2, ipwsp, band), kind=dp)
4451 : 47874 : max_cdiff = max(max_cdiff, abs(c1 - phase * c2))
4452 : : end do
4453 : : end do
4454 : :
4455 : 56 : write(msg, "(2(a,es12.4))")"max_rho_adiff: ", max_rho_adiff, ", max_cdiff: ", max_cdiff
4456 [ + - - + ]: 56 : ok = (max_rho_adiff < atol_rho__ .and. max_cdiff < atol_cdiff__)
4457 : :
4458 : : contains
4459 : 224 : subroutine band_type(band, btype)
4460 : : integer,intent(in) :: band
4461 : : character(len=*),intent(out) :: btype
4462 : : real(dp) :: e0
4463 : :
4464 : 224 : e0 = eig_k(band)
4465 : :
4466 : 224 : if (band == 1) then
4467 [ + - + - ]: 56 : btype = "last_state"
4468 [ + - ]: 56 : if (nband_k > 1) then
4469 [ + - + - ]: 56 : btype = "non-degenerate"
4470 [ + + + - : 56 : if (abs(e0 - eig_k(band + 1)) < tol6) btype = "degenerate"
+ - ]
4471 : : end if
4472 : :
4473 [ + + ]: 168 : else if (band == nband_k) then
4474 [ + - + - ]: 56 : btype = "last_state"
4475 [ + - ]: 56 : if (band - 1 > 0) then
4476 [ + + + - : 56 : if (abs(e0 - eig_k(band - 1)) < tol6) btype = "degenerate"
+ - ]
4477 : : end if
4478 : :
4479 : : else
4480 [ + - + - ]: 112 : btype = "non-degenerate"
4481 [ + + + + : 112 : if (abs(e0 - eig_k(band - 1)) < tol6 .or. abs(e0 - eig_k(band + 1)) < tol6) btype = "degenerate"
+ - + - ]
4482 : : end if
4483 : :
4484 [ + + ]: 224 : end subroutine band_type
4485 : :
4486 : : end function fxphas_and_cmp
4487 : : !!***
4488 : :
4489 : : !!****f* m_cgtools/overlap_g
4490 : : !! NAME
4491 : : !! overlap_g
4492 : : !!
4493 : : !! FUNCTION
4494 : : !! Compute the scalar product between WF at two different k-points
4495 : : !! < u_{n,k1} | u_{n,k2}>
4496 : : !!
4497 : : !! INPUTS
4498 : : !! mpw = maximum dimensioned size of npw
4499 : : !! npw_k1 = number of plane waves at k1
4500 : : !! npw_k2 = number of plane waves at k2
4501 : : !! nspinor = 1 for scalar, 2 for spinor wavefunctions
4502 : : !! pwind_k = array required to compute the scalar product (see initberry.f)
4503 : : !! vect1 = wavefunction at k1: | u_{n,k1} >
4504 : : !! vect2 = wavefunction at k1: | u_{n,k2} >
4505 : : !!
4506 : : !! OUTPUT
4507 : : !! doti = imaginary part of the scalarproduct
4508 : : !! dotr = real part of the scalarproduct
4509 : : !!
4510 : : !! NOTES
4511 : : !! In case a G-vector of the basis sphere of plane waves at k1
4512 : : !! does not belong to the basis sphere of plane waves at k2,
4513 : : !! pwind = 0. Therefore, the dimensions of vect1 &
4514 : : !! vect2 are (1:2,0:mpw) and the element (1:2,0) MUST be set to zero.
4515 : : !!
4516 : : !! The current implementation if not compatible with TR-symmetry (i.e. istwfk/=1) !
4517 : : !!
4518 : : !! SOURCE
4519 : :
4520 : 137044504 : subroutine overlap_g(doti,dotr,mpw,npw_k1,npw_k2,nspinor,pwind_k,vect1,vect2)
4521 : :
4522 : : !Arguments ------------------------------------
4523 : : !scalars
4524 : : integer,intent(in) :: mpw,npw_k1,npw_k2,nspinor
4525 : : real(dp),intent(out) :: doti,dotr
4526 : : !arrays
4527 : : integer,intent(in) :: pwind_k(mpw)
4528 : : real(dp),intent(in) :: vect1(1:2,0:mpw*nspinor),vect2(1:2,0:mpw*nspinor)
4529 : :
4530 : : !Local variables-------------------------------
4531 : : !scalars
4532 : : integer :: ipw,ispinor,jpw,spnshft1,spnshft2
4533 : : ! *************************************************************************
4534 : :
4535 : : !Check if vect1(:,0) = 0 and vect2(:,0) = 0
4536 : : if ((abs(vect1(1,0)) > tol12).or.(abs(vect1(2,0)) > tol12).or. &
4537 [ + - + - : 137044504 : & (abs(vect2(1,0)) > tol12).or.(abs(vect2(2,0)) > tol12)) then
+ - - + ]
4538 : 0 : ABI_BUG('vect1(:,0) and/or vect2(:,0) are not equal to zero')
4539 : : end if
4540 : :
4541 : : !Compute the scalar product
4542 : 137044504 : dotr = zero; doti = zero
4543 [ + + ]: 276437008 : do ispinor = 1, nspinor
4544 : 139392504 : spnshft1 = (ispinor-1)*npw_k1
4545 : 139392504 : spnshft2 = (ispinor-1)*npw_k2
4546 : : !$OMP PARALLEL DO PRIVATE(jpw) REDUCTION(+:doti,dotr)
4547 [ + + ]: 23151736580 : do ipw = 1, npw_k1
4548 : 22875299572 : jpw = pwind_k(ipw)
4549 : 22875299572 : dotr = dotr + vect1(1,spnshft1+ipw)*vect2(1,spnshft2+jpw) + vect1(2,spnshft1+ipw)*vect2(2,spnshft2+jpw)
4550 : 23014692076 : doti = doti + vect1(1,spnshft1+ipw)*vect2(2,spnshft2+jpw) - vect1(2,spnshft1+ipw)*vect2(1,spnshft2+jpw)
4551 : : end do
4552 : : end do
4553 : :
4554 : 137044504 : end subroutine overlap_g
4555 : : !!***
4556 : :
4557 : : !!****f* ABINIT/subdiago
4558 : : !! NAME
4559 : : !! subdiago
4560 : : !!
4561 : : !! FUNCTION
4562 : : !! This routine diagonalizes the Hamiltonian in the trial subspace.
4563 : : !!
4564 : : !! INPUTS
4565 : : !! icg=shift to be applied on the location of data in the array cg
4566 : : !! igsc=shift to be applied on the location of data in the array gsc
4567 : : !! istwf_k=input parameter that describes the storage of wfs
4568 : : !! mcg=second dimension of the cg array
4569 : : !! mgsc=second dimension of the gsc array
4570 : : !! nband_k=number of bands at this k point for that spin polarization
4571 : : !! npw_k=number of plane waves at this k point
4572 : : !! my_nspinor=number of spinorial components of the wavefunctions (on current proc)
4573 : : !! use_subovl=1 if the overlap matrix is not identity in WFs subspace
4574 : : !! usepaw= 0 for non paw calculation; =1 for paw calculation
4575 : : !! me_g0=1 if this processor has G=0, 0 otherwise.
4576 : : !!
4577 : : !! OUTPUT
4578 : : !! eig_k(nband_k)=array for holding eigenvalues (hartree)
4579 : : !! evec(2*nband_k,nband_k)=array for holding eigenvectors
4580 : : !!
4581 : : !! SIDE EFFECTS
4582 : : !! subham(nband_k*(nband_k+1))=Hamiltonian expressed in the WFs subspace. Hermitianized in output.
4583 : : !! subovl(nband_k*(nband_k+1)*use_subovl)=overlap matrix expressed in the WFs subspace. Hermitianized in output.
4584 : : !! cg(2,mcg)=wavefunctions
4585 : : !! gsc(2,mgsc)=<g|S|c> matrix elements (S=overlap)
4586 : : !!
4587 : : !! SOURCE
4588 : :
4589 : 447686 : subroutine subdiago(cg, eig_k, evec, gsc, icg, igsc, istwf_k, mcg, mgsc, nband_k, npw_k, my_nspinor, paral_kgb, &
4590 : 447686 : subham, subovl, use_subovl, usepaw, me_g0)
4591 : :
4592 : : !Arguments ------------------------------------
4593 : : integer,intent(in) :: icg,igsc,istwf_k,mcg,mgsc,nband_k,npw_k,me_g0
4594 : : integer,intent(in) :: my_nspinor,paral_kgb,use_subovl,usepaw
4595 : : real(dp),intent(inout) :: subham(nband_k*(nband_k+1)),subovl(nband_k*(nband_k+1)*use_subovl)
4596 : : real(dp),intent(out) :: eig_k(nband_k),evec(2*nband_k,nband_k)
4597 : : real(dp),intent(inout) :: cg(2,mcg),gsc(2,mgsc)
4598 : :
4599 : : !Local variables-------------------------------
4600 : : integer :: iband,ii,ierr,rvectsize,vectsize,use_slk
4601 : : !real(dp) :: cpu, wall, gflops
4602 : : character(len=500) :: msg
4603 : : ! real(dp) :: tsec(2)
4604 : 447686 : real(dp),allocatable :: evec_re(:,:),subovl_re(:),subham_tmp(:), work(:,:)
4605 : 447686 : real(dp),allocatable :: blockvectora(:,:),blockvectorb(:,:),blockvectorc(:,:)
4606 : :
4607 : : ! *********************************************************************
4608 : :
4609 [ - + ]: 447686 : if (paral_kgb<0) then
4610 : 0 : ABI_BUG('paral_kgb should be positive ')
4611 : : end if
4612 : :
4613 : : ! 1 if Scalapack version is used.
4614 : : ! MG TODO: This should not be bound to paral_kgb
4615 : 447686 : use_slk = paral_kgb
4616 : :
4617 : 447686 : rvectsize=npw_k*my_nspinor
4618 [ + + ]: 447686 : vectsize=2*rvectsize;if (me_g0==1) vectsize=vectsize-1
4619 : : !call cwtime(cpu, wall, gflops, "start")
4620 : :
4621 : : !Impose Hermiticity on diagonal elements of subham (and subovl, if needed)
4622 : : ! MG FIXME: In these two calls we are aliasing the args
4623 : 447686 : call hermit(subham, subham, ierr, nband_k)
4624 [ - + ]: 447686 : if (use_subovl==1) call hermit(subovl, subovl, ierr, nband_k)
4625 : : !call cwtime_report(" hermit", cpu, wall, gflops)
4626 : :
4627 : : ! Diagonalize the Hamitonian matrix
4628 [ + + ]: 447686 : if (istwf_k==2) then
4629 [ - + + - : 2316806 : ABI_CALLOC(evec_re, (nband_k,nband_k))
- + + - +
- + - - +
- + + + +
+ ]
4630 [ + - - + : 50763 : ABI_MALLOC(subham_tmp, (nband_k*(nband_k+1)/2))
+ - + - +
- - + -
+ ]
4631 [ + - - + : 1158403 : subham_tmp=subham(1:nband_k*(nband_k+1):2)
- - + + ]
4632 [ - + ]: 16921 : if (use_subovl==1) then
4633 [ # # # # : 0 : ABI_MALLOC(subovl_re, (nband_k*(nband_k+1)/2))
# # # # ]
4634 [ # # # # : 0 : subovl_re=subovl(1:nband_k*(nband_k+1):2)
# # # # ]
4635 : : ! TODO: Not sure this one has been fully tested
4636 : 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)
4637 [ # # ]: 0 : ABI_FREE(subovl_re)
4638 : : else
4639 : 16921 : call abi_xhpev('V','U',nband_k,subham_tmp,eig_k,evec_re,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4640 : : end if
4641 [ + + + + : 6646506 : evec(:,:)=zero; evec(1:2*nband_k:2,:) = evec_re
+ + + + ]
4642 [ - + ]: 16921 : ABI_FREE(evec_re)
4643 [ - + ]: 16921 : ABI_FREE(subham_tmp)
4644 : : else
4645 [ - + ]: 430765 : if (use_subovl==1) then
4646 : 0 : call abi_xhpgv(1,'V','U',nband_k,subham,subovl,eig_k,evec,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4647 : : else
4648 : 430765 : call abi_xhpev('V','U',nband_k,subham,eig_k,evec,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4649 : : end if
4650 : : end if
4651 : : !call cwtime_report(" hdiago", cpu, wall, gflops)
4652 : :
4653 : : ! Normalize each eigenvector and set phase:
4654 : : ! this is because of the simultaneous diagonalisation of this
4655 : : ! matrix by different processors, allowing to get different unitary transforms, thus breaking the
4656 : : ! coherency of parts of cg stored on different processors).
4657 : : !
4658 : : ! The problem with minus/plus signs might be present also if .not. use_subovl
4659 : : !
4660 : : !if(use_subovl == 0) then
4661 : 447686 : call cg_normev(evec, nband_k, nband_k)
4662 : : !end if
4663 : :
4664 [ + + ]: 447686 : if(istwf_k==2)then
4665 [ + + ]: 134702 : do iband=1,nband_k
4666 [ + + ]: 2266043 : do ii=1,nband_k
4667 [ - + ]: 2249122 : if(abs(evec(2*ii,iband))>1.0d-10)then
4668 : 0 : write(msg,'(3a,2i0,2es16.6,a,a)')ch10,&
4669 : 0 : ' For istwf_k=2, observed the following element of evec:',ch10,&
4670 : 0 : iband,ii,evec(2*ii-1,iband),evec(2*ii,iband),ch10,' with a non-negligible imaginary part.'
4671 : 0 : ABI_BUG(msg)
4672 : : end if
4673 : : end do
4674 : : end do
4675 : : end if
4676 : : !call cwtime_report(" normev", cpu, wall, gflops)
4677 : :
4678 : : !=====================================================
4679 : : ! Carry out rotation of bands C(G,n) according to evecs
4680 : : ! ZGEMM if istwfk==1, DGEMM if istwfk==2
4681 : : !=====================================================
4682 [ + + - + : 895372 : if (istwf_k==2) then
- + - + ]
4683 : :
4684 [ - + + - : 67684 : ABI_MALLOC_OR_DIE(blockvectora, (vectsize, nband_k), ierr)
- + + - +
- + - + -
- + - + ]
4685 [ - + + - : 67684 : ABI_MALLOC_OR_DIE(blockvectorb, (nband_k, nband_k), ierr)
- + + - +
- + - + -
- + - + ]
4686 [ - + + - : 50763 : ABI_MALLOC_OR_DIE(blockvectorc, (vectsize, nband_k), ierr)
- + + - +
- - + -
+ ]
4687 : :
4688 [ + + ]: 134702 : do iband=1,nband_k
4689 [ + + ]: 117781 : if (me_g0 == 1) then
4690 : 114821 : call abi_xcopy(1,cg(1,cgindex_subd(iband)),1,blockvectora(1,iband),1)
4691 : 114821 : call abi_xcopy(rvectsize-1,cg(1,cgindex_subd(iband)+1),2,blockvectora(2,iband),1)
4692 : 114821 : call abi_xcopy(rvectsize-1,cg(2,cgindex_subd(iband)+1),2,blockvectora(rvectsize+1,iband),1)
4693 : : else
4694 : 2960 : call abi_xcopy(rvectsize,cg(1,cgindex_subd(iband)),2,blockvectora(1,iband),1)
4695 : 2960 : call abi_xcopy(rvectsize,cg(2,cgindex_subd(iband)),2,blockvectora(rvectsize+1,iband),1)
4696 : : end if
4697 : 134702 : call abi_xcopy(nband_k,evec(2*iband-1,1),2*nband_k,blockvectorb(iband,1),nband_k)
4698 : : end do
4699 : :
4700 : : !MG TODO: This one is a DGEMM.
4701 : : call abi_xgemm('N','N',vectsize,nband_k,nband_k,&
4702 : 16921 : cone,blockvectora,vectsize,blockvectorb,nband_k,czero,blockvectorc,vectsize)
4703 : :
4704 [ + + ]: 134702 : do iband=1,nband_k
4705 [ + + ]: 134702 : if (me_g0 == 1) then
4706 : 114821 : call abi_xcopy(1,blockvectorc(1,iband),1,cg(1,cgindex_subd(iband)),1)
4707 : 114821 : call abi_xcopy(rvectsize-1,blockvectorc(2,iband),1,cg(1,cgindex_subd(iband)+1),2)
4708 : 114821 : call abi_xcopy(rvectsize-1,blockvectorc(rvectsize+1,iband),1,cg(2,cgindex_subd(iband)+1),2)
4709 : : else
4710 : 2960 : call abi_xcopy(rvectsize,blockvectorc(1,iband),1,cg(1,cgindex_subd(iband)),2)
4711 : 2960 : call abi_xcopy(rvectsize,blockvectorc(rvectsize+1,iband),1,cg(2,cgindex_subd(iband)),2)
4712 : : end if
4713 : : end do
4714 : :
4715 [ + + ]: 16921 : if (usepaw==1) then
4716 : : ! If paw, must also rotate S.C(G,n):
4717 : :
4718 [ + + ]: 37940 : do iband=1,nband_k
4719 [ + + ]: 34111 : if (me_g0 == 1) then
4720 : 33623 : call abi_xcopy(1,gsc(1,gscindex_subd(iband)),1,blockvectora(1,iband),1)
4721 : 33623 : call abi_xcopy(rvectsize-1,gsc(1,gscindex_subd(iband)+1),2,blockvectora(2,iband),1)
4722 : 33623 : call abi_xcopy(rvectsize-1,gsc(2,gscindex_subd(iband)+1),2,blockvectora(rvectsize+1,iband),1)
4723 : : else
4724 : 488 : call abi_xcopy(rvectsize ,gsc(1,gscindex_subd(iband)),2,blockvectora(1,iband),1)
4725 : 488 : call abi_xcopy(rvectsize ,gsc(2,gscindex_subd(iband)),2,blockvectora(rvectsize+1,iband),1)
4726 : : end if
4727 : 37940 : call abi_xcopy(nband_k,evec(2*iband-1,1),2*nband_k,blockvectorb(iband,1),nband_k)
4728 : : end do
4729 : :
4730 : : call abi_xgemm('N','N',vectsize,nband_k,nband_k,&
4731 : 3829 : cone,blockvectora,vectsize,blockvectorb,nband_k,czero,blockvectorc,vectsize)
4732 : :
4733 [ + + ]: 37940 : do iband=1,nband_k
4734 [ + + ]: 37940 : if (me_g0 == 1) then
4735 : 33623 : call abi_xcopy(1,blockvectorc(1,iband),1,gsc(1,gscindex_subd(iband)),1)
4736 : 33623 : call abi_xcopy(rvectsize-1,blockvectorc(2,iband),1,gsc(1,gscindex_subd(iband)+1),2)
4737 : 33623 : call abi_xcopy(rvectsize-1,blockvectorc(rvectsize+1,iband),1,gsc(2,gscindex_subd(iband)+1),2)
4738 : : else
4739 : 488 : call abi_xcopy(rvectsize,blockvectorc(1,iband),1,gsc(1,gscindex_subd(iband)),2)
4740 : 488 : call abi_xcopy(rvectsize,blockvectorc(rvectsize+1,iband),1,gsc(2,gscindex_subd(iband)),2)
4741 : : end if
4742 : : end do
4743 : :
4744 : : end if
4745 : :
4746 [ - + ]: 16921 : ABI_FREE(blockvectora)
4747 [ - + ]: 16921 : ABI_FREE(blockvectorb)
4748 [ - + ]: 16921 : ABI_FREE(blockvectorc)
4749 : :
4750 : : else
4751 : : ! istwf_k /= 2
4752 [ - + + - : 1292295 : ABI_MALLOC_OR_DIE(work, (2,npw_k*my_nspinor*nband_k), ierr)
+ - + - +
- - + -
+ ]
4753 : :
4754 : : ! MG: Do not remove this initialization.
4755 : : ! telast_06 stops in fxphase on inca_debug and little_buda (very very strange, due to atlas?)
4756 : : !work=zero
4757 : :
4758 : : call abi_xgemm('N','N',npw_k*my_nspinor,nband_k,nband_k,cone, &
4759 : : cg(:,icg+1:npw_k*my_nspinor*nband_k+icg),npw_k*my_nspinor, &
4760 : 430765 : evec,nband_k,czero,work,npw_k*my_nspinor,x_cplx=2)
4761 : :
4762 : 430765 : call abi_xcopy(npw_k*my_nspinor*nband_k,work(1,1),1,cg(1,1+icg),1,x_cplx=2)
4763 : :
4764 [ + + ]: 430765 : if (usepaw==1) then
4765 : : ! If paw, must also rotate S.C(G,n):
4766 : : call abi_xgemm('N','N',npw_k*my_nspinor,nband_k,nband_k,cone, &
4767 : : gsc(:,1+igsc:npw_k*my_nspinor*nband_k+igsc),npw_k*my_nspinor, &
4768 : 95865 : evec,nband_k,czero,work,npw_k*my_nspinor,x_cplx=2)
4769 : 95865 : call abi_xcopy(npw_k*my_nspinor*nband_k, work(1,1),1,gsc(1,1+igsc),1,x_cplx=2)
4770 : : end if
4771 : :
4772 [ - + ]: 430765 : ABI_FREE(work)
4773 : : end if
4774 : : !call cwtime_report(" rotation", cpu, wall, gflops)
4775 : :
4776 : : contains
4777 : :
4778 : 700766 : function cgindex_subd(iband)
4779 : : integer :: iband,cgindex_subd
4780 : 700766 : cgindex_subd=npw_k*my_nspinor*(iband-1)+icg+1
4781 : 700766 : end function cgindex_subd
4782 : :
4783 : 203690 : function gscindex_subd(iband)
4784 : : integer :: iband,gscindex_subd
4785 : 203690 : gscindex_subd=npw_k*my_nspinor*(iband-1)+igsc+1
4786 : 203690 : end function gscindex_subd
4787 : :
4788 : : end subroutine subdiago
4789 : : !!***
4790 : :
4791 : : !!****f* ABINIT/subdiago_low_memory
4792 : : !! NAME
4793 : : !! subdiago_low_memory
4794 : : !!
4795 : : !! FUNCTION
4796 : : !! This routine diagonalizes the Hamiltonian in the eigenfunction subspace
4797 : : !! Separate the computation in blocks of plane waves to save memory
4798 : : !!
4799 : : !! INPUTS
4800 : : !! icg=shift to be applied on the location of data in the array cg
4801 : : !! istwf_k=input parameter that describes the storage of wfs
4802 : : !! mcg=second dimension of the cg array
4803 : : !! nband_k=number of bands at this k point for that spin polarization
4804 : : !! npw_k=number of plane waves at this k point
4805 : : !! nspinor=number of spinorial components of the wavefunctions (on current proc)
4806 : : !! subham(nband_k*(nband_k+1))=Hamiltonian expressed in the WFs subspace
4807 : : !!
4808 : : !! OUTPUT
4809 : : !! eig_k(nband_k)=array for holding eigenvalues (hartree)
4810 : : !! evec(2*nband_k,nband_k)=array for holding eigenvectors
4811 : : !!
4812 : : !! SIDE EFFECTS
4813 : : !! cg(2,mcg)=wavefunctions
4814 : : !!
4815 : : !! SOURCE
4816 : :
4817 : 0 : subroutine subdiago_low_memory(cg,eig_k,evec,icg,istwf_k,&
4818 : : & mcg,nband_k,npw_k,nspinor,paral_kgb,&
4819 : 0 : & subham)
4820 : :
4821 : : !Arguments ------------------------------------
4822 : : integer,intent(in) :: icg,istwf_k,mcg,nband_k,npw_k
4823 : : integer,intent(in) :: nspinor,paral_kgb
4824 : : real(dp),intent(inout) :: subham(nband_k*(nband_k+1))
4825 : : real(dp),intent(out) :: eig_k(nband_k),evec(2*nband_k,nband_k)
4826 : : real(dp),intent(inout),target :: cg(2,mcg)
4827 : :
4828 : : !Local variables-------------------------------
4829 : : integer :: ig,igfirst,block_size,iblock,nblock,block_size_tmp,wfsize
4830 : : integer :: iband,ii,ierr,vectsize,use_slk
4831 : : character(len=500) :: message
4832 : : ! real(dp) :: tsec(2)
4833 : 0 : real(dp),allocatable :: evec_tmp(:,:),subham_tmp(:), work(:,:)
4834 : 0 : real(dp),allocatable :: blockvectora(:,:),blockvectorb(:,:),blockvectorc(:,:)
4835 : 0 : real(dp), contiguous, pointer :: cg_block(:,:)
4836 : : ! *********************************************************************
4837 : :
4838 : 0 : if (paral_kgb<0) then
4839 : 0 : ABI_BUG('paral_kgb should be positive ')
4840 : : end if
4841 : :
4842 : : ! 1 if Scalapack version is used.
4843 : 0 : use_slk = paral_kgb
4844 : :
4845 : : !Impose Hermiticity on diagonal elements of subham (and subovl, if needed)
4846 : : ! MG FIXME: In these two calls we are aliasing the args
4847 : 0 : call hermit(subham,subham,ierr,nband_k)
4848 : :
4849 : : !Diagonalize the Hamitonian matrix
4850 [ # # ]: 0 : if(istwf_k==2) then
4851 [ # # # # : 0 : ABI_MALLOC(evec_tmp,(nband_k,nband_k))
# # # # #
# # # # #
# # ]
4852 [ # # # # : 0 : ABI_MALLOC(subham_tmp,(nband_k*(nband_k+1)/2))
# # # # #
# # # #
# ]
4853 [ # # # # : 0 : subham_tmp=subham(1:nband_k*(nband_k+1):2)
# # # # ]
4854 [ # # # # ]: 0 : evec_tmp=zero
4855 : 0 : call abi_xhpev('V','U',nband_k,subham_tmp,eig_k,evec_tmp,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4856 [ # # # # : 0 : evec(:,:)=zero;evec(1:2*nband_k:2,:) =evec_tmp
# # # # ]
4857 [ # # ]: 0 : ABI_FREE(evec_tmp)
4858 [ # # ]: 0 : ABI_FREE(subham_tmp)
4859 : : else
4860 : 0 : call abi_xhpev('V','U',nband_k,subham,eig_k,evec,nband_k,istwf_k=istwf_k,use_slk=use_slk)
4861 : : end if
4862 : :
4863 : : !Normalize each eigenvector and set phase:
4864 : : !The problem with minus/plus signs might be present also if .not. use_subovl
4865 : : !if(use_subovl == 0) then
4866 : 0 : call cg_normev(evec,nband_k,nband_k)
4867 : : !end if
4868 : :
4869 [ # # ]: 0 : if(istwf_k==2)then
4870 [ # # ]: 0 : do iband=1,nband_k
4871 [ # # ]: 0 : do ii=1,nband_k
4872 [ # # ]: 0 : if(abs(evec(2*ii,iband))>1.0d-10)then
4873 : 0 : write(message,'(3a,2i0,2es16.6,a,a)')ch10,&
4874 : 0 : & ' subdiago: For istwf_k=2, observed the following element of evec :',ch10,&
4875 : 0 : & iband,ii,evec(2*ii-1,iband),evec(2*ii,iband),ch10,' with a non-negligible imaginary part.'
4876 : 0 : ABI_BUG(message)
4877 : : end if
4878 : : end do
4879 : : end do
4880 : : end if
4881 : :
4882 : : !=====================================================
4883 : : !Carry out rotation of bands C(G,n) according to evecs
4884 : : ! ZGEMM if istwfk==1, DGEMM if istwfk==2
4885 : : !=====================================================
4886 : 0 : wfsize=npw_k*nspinor
4887 : :
4888 : 0 : block_size=100
4889 : :
4890 [ # # ]: 0 : if (wfsize<block_size) block_size=wfsize
4891 : :
4892 : 0 : nblock=wfsize/block_size
4893 [ # # ]: 0 : if (mod(wfsize,block_size)/=0) nblock=nblock+1
4894 : :
4895 [ # # # # : 0 : if (istwf_k>1) then ! evec is real
# # # # ]
4896 : :
4897 : 0 : vectsize=2*block_size
4898 : :
4899 [ # # # # : 0 : ABI_MALLOC_OR_DIE(blockvectora,(vectsize,nband_k), ierr)
# # # # #
# # # # #
# # # # ]
4900 [ # # # # : 0 : ABI_MALLOC_OR_DIE(blockvectorb,(nband_k,nband_k), ierr)
# # # # #
# # # # #
# # # # ]
4901 [ # # # # : 0 : ABI_MALLOC_OR_DIE(blockvectorc,(vectsize,nband_k), ierr)
# # # # #
# # # #
# ]
4902 : :
4903 [ # # ]: 0 : do iband=1,nband_k
4904 : 0 : call abi_xcopy(nband_k,evec(2*iband-1,1),2*nband_k,blockvectorb(iband,1),nband_k)
4905 : : end do
4906 : :
4907 [ # # ]: 0 : do iblock=1,nblock
4908 : :
4909 : 0 : igfirst=(iblock-1)*block_size
4910 : 0 : block_size_tmp=block_size
4911 [ # # ]: 0 : if (igfirst+block_size>wfsize) then
4912 : 0 : block_size_tmp=wfsize-igfirst
4913 : : end if
4914 : :
4915 [ # # ]: 0 : do iband=1,nband_k
4916 : 0 : call abi_xcopy(block_size_tmp,cg(1,1+cgindex_subd(iblock,iband)),2,blockvectora(1,iband),1)
4917 : 0 : call abi_xcopy(block_size_tmp,cg(2,1+cgindex_subd(iblock,iband)),2,blockvectora(block_size+1,iband),1)
4918 [ # # ]: 0 : if (block_size_tmp<block_size) then
4919 [ # # ]: 0 : blockvectora(block_size_tmp+1:block_size,iband) = zero
4920 [ # # ]: 0 : blockvectora(block_size+block_size_tmp+1:2*block_size,iband) = zero
4921 : : end if
4922 : : end do
4923 : :
4924 : : call abi_xgemm('N','N',vectsize,nband_k,nband_k,&
4925 : 0 : & cone,blockvectora,vectsize,blockvectorb,nband_k,czero,blockvectorc,vectsize)
4926 : :
4927 [ # # ]: 0 : do iband=1,nband_k
4928 : 0 : call abi_xcopy(block_size_tmp,blockvectorc(1,iband),1,cg(1,1+cgindex_subd(iblock,iband)),2)
4929 : 0 : call abi_xcopy(block_size_tmp,blockvectorc(block_size+1,iband),1,cg(2,1+cgindex_subd(iblock,iband)),2)
4930 : : end do
4931 : :
4932 : : end do
4933 : :
4934 [ # # ]: 0 : ABI_FREE(blockvectora)
4935 [ # # ]: 0 : ABI_FREE(blockvectorb)
4936 [ # # ]: 0 : ABI_FREE(blockvectorc)
4937 : :
4938 : : else ! evec is complex
4939 : :
4940 [ # # # # : 0 : ABI_MALLOC_OR_DIE(work,(2,block_size*nband_k), ierr)
# # # # #
# # # #
# ]
4941 [ # # ]: 0 : if (nblock==1) then
4942 : 0 : cg_block => cg(:,icg+1:icg+nband_k*wfsize)
4943 : : else
4944 [ # # # # : 0 : ABI_MALLOC_OR_DIE(cg_block,(2,block_size*nband_k), ierr)
# # # # #
# ]
4945 : : end if
4946 : :
4947 [ # # ]: 0 : do iblock=1,nblock
4948 : 0 : igfirst=(iblock-1)*block_size
4949 : 0 : block_size_tmp=block_size
4950 [ # # ]: 0 : if (igfirst+block_size>wfsize) then
4951 : 0 : block_size_tmp=wfsize-igfirst
4952 : : end if
4953 [ # # ]: 0 : if (nblock/=1) then
4954 [ # # ]: 0 : do iband=1,nband_k
4955 [ # # ]: 0 : do ig=1,block_size_tmp
4956 [ # # # # ]: 0 : cg_block(:,ig+(iband-1)*block_size) = cg(:,ig+cgindex_subd(iblock,iband))
4957 : : end do
4958 [ # # ]: 0 : if (block_size_tmp<block_size) then
4959 [ # # ]: 0 : do ig=block_size_tmp+1,block_size
4960 [ # # ]: 0 : cg_block(:,ig+(iband-1)*block_size) = zero
4961 : : end do
4962 : : end if
4963 : : end do
4964 : : end if
4965 : : call abi_xgemm('N','N',block_size,nband_k,nband_k,cone,cg_block,block_size,evec,nband_k,czero,work,&
4966 : 0 : & block_size,x_cplx=2)
4967 [ # # ]: 0 : do iband=1,nband_k
4968 [ # # ]: 0 : do ig=1,block_size_tmp
4969 [ # # ]: 0 : cg(:,ig+cgindex_subd(iblock,iband)) = work(:,ig+(iband-1)*block_size)
4970 : : end do
4971 : : end do
4972 : : end do
4973 : :
4974 [ # # ]: 0 : ABI_FREE(work)
4975 [ # # ]: 0 : if (nblock/=1) then
4976 [ # # ]: 0 : ABI_FREE(cg_block)
4977 : : end if
4978 : :
4979 : : end if
4980 : :
4981 : : contains
4982 : :
4983 : 0 : function cgindex_subd(iblock,iband)
4984 : :
4985 : : integer :: iband,iblock,cgindex_subd
4986 : 0 : cgindex_subd=(iblock-1)*block_size+(iband-1)*wfsize+icg
4987 : : end function cgindex_subd
4988 : :
4989 : : end subroutine subdiago_low_memory
4990 : : !!***
4991 : :
4992 : : !!****f* m_cgtools/pw_orthon
4993 : : !! NAME
4994 : : !! pw_orthon
4995 : : !!
4996 : : !! FUNCTION
4997 : : !! Normalize nvec complex vectors each of length nelem and then orthogonalize by modified Gram-Schmidt.
4998 : : !! Two orthogonality conditions are available:
4999 : : !!
5000 : : !! 1) Simple orthogonality: ${<Vec_{i}|Vec_{j}>=Delta_ij}$
5001 : : !! 2) Orthogonality with overlap S: ${<Vec_{i}|S|Vec_{j}>=Delta_ij}$
5002 : : !!
5003 : : !! INPUTS
5004 : : !! icg=shift to be given to the location of the data in cg(=vecnm)
5005 : : !! igsc=shift to be given to the location of the data in gsc(=ovl_vecnm)
5006 : : !! istwf_k=option parameter that describes the storage of wfs
5007 : : !! mcg=maximum size of second dimension of cg(=vecnm)
5008 : : !! mgsc=maximum size of second dimension of gsc(=ovl_vecnm)
5009 : : !! nelem=number of complex elements in each vector
5010 : : !! nvec=number of vectors to be orthonormalized
5011 : : !! ortalgo= option for the choice of the algorithm
5012 : : !! -1: no orthogonalization (direct return)
5013 : : !! 0 or 2: old algorithm (use of buffers)
5014 : : !! 1: new algorithm (use of blas)
5015 : : !! 3: new new algorithm (use of lapack without copy)
5016 : : !! useoverlap=select the orthogonality condition
5017 : : !! 0: no overlap between vectors
5018 : : !! 1: vectors are overlapping
5019 : : !! me_g0=1 if this processor has G=0, 0 otherwise
5020 : : !! comm=MPI communicator
5021 : : !!
5022 : : !! SIDE EFFECTS
5023 : : !! vecnm= input: vectors to be orthonormalized; array of nvec column
5024 : : !! vectors,each of length nelem,shifted by icg
5025 : : !! This array is complex or else real(dp) of twice length
5026 : : !! output: orthonormalized set of vectors
5027 : : !! if (useoverlap==1) only:
5028 : : !! ovl_vecnm= input: product of overlap and input vectors:
5029 : : !! S|vecnm>,where S is the overlap operator
5030 : : !! output: updated S|vecnm> according to vecnm
5031 : : !!
5032 : : !! NOTES
5033 : : !! Note that each vector has an arbitrary phase which is not fixed in this routine.
5034 : : !!
5035 : : !! WARNING: not yet suited for nspinor=2 with istwfk/=1
5036 : : !!
5037 : : !! SOURCE
5038 : :
5039 : 495384 : subroutine pw_orthon(icg, igsc, istwf_k, mcg, mgsc, nelem, nvec, ortalgo, ovl_vecnm, useoverlap, vecnm, me_g0, comm)
5040 : :
5041 : : !Arguments ------------------------------------
5042 : : !scalars
5043 : : integer,intent(in) :: icg,igsc,istwf_k,mcg,mgsc,nelem,nvec,ortalgo,useoverlap,me_g0,comm
5044 : : !arrays
5045 : : real(dp),intent(inout) :: ovl_vecnm(2,mgsc*useoverlap),vecnm(2,mcg)
5046 : :
5047 : : !Local variables-------------------------------
5048 : : !scalars
5049 : : integer :: ierr,ii,ii0,ii1,ii2,ivec,ivec2
5050 : : integer :: rvectsiz,vectsize,cg_idx,gsc_idx
5051 : : real(dp) :: doti,dotr,sum,xnorm
5052 : : !real(dp) :: cpu, wall, gflops
5053 : : #ifdef DEBUG_MODE
5054 : : character(len=500) :: msg
5055 : : #endif
5056 : : !arrays
5057 : 0 : integer :: cgindex(nvec), gscindex(nvec)
5058 : : real(dp) :: buffer2(2),tsec(2)
5059 : 495384 : real(dp),allocatable :: rblockvectorbx(:,:),rblockvectorx(:,:),rgramxbx(:,:)
5060 : 495384 : complex(dp),allocatable :: cblockvectorbx(:,:),cblockvectorx(:,:), cgramxbx(:,:)
5061 : : ! *************************************************************************
5062 : :
5063 : : #ifdef DEBUG_MODE
5064 : : !Make sure imaginary part at G=0 vanishes
5065 : : if (istwf_k == 2 .and. me_g0 == 1) then
5066 : : do ivec=1,nvec
5067 : : if(abs(vecnm(2,1+nelem*(ivec-1)+icg))>zero)then
5068 : : ! if(abs(vecnm(2,1+nelem*(ivec-1)+icg))>tol16)then
5069 : : write(msg,'(2a,3i0,2es16.6,a,a)')&
5070 : : ' For istwf_k = 2, observed the following element of vecnm :',ch10,&
5071 : : nelem,ivec,icg,vecnm(1:2,1+nelem*(ivec-1)+icg), ch10,' with a non-negligible imaginary part.'
5072 : : ABI_BUG(msg)
5073 : : end if
5074 : : end do
5075 : : end if
5076 : : #endif
5077 : :
5078 : : ! Nothing to do if ortalgo=-1
5079 [ - + ]: 495384 : if(ortalgo==-1) return
5080 : :
5081 : : !call wrtout(std_out, sjoin(" Begin wavefunction orthogonalization with ortalgo:", itoa(ortalgo)))
5082 : : !call cwtime(cpu, wall, gflops, "start")
5083 : :
5084 [ + + ]: 4005632 : do ivec=1,nvec
5085 : 3510248 : cgindex(ivec)=nelem*(ivec-1)+icg+1
5086 : 4005632 : gscindex(ivec)=nelem*(ivec-1)+igsc+1
5087 : : end do
5088 : :
5089 : : if (ortalgo==3) then
5090 : : ! =========================
5091 : : ! First (new new) algorithm
5092 : : ! =========================
5093 : : ! NEW VERSION: avoid copies, use ZHERK for NC
5094 : 127 : cg_idx = cgindex(1)
5095 [ - + ]: 127 : if (useoverlap == 1) then
5096 : 0 : gsc_idx = gscindex(1)
5097 : 0 : call cgpaw_cholesky(nelem, nvec, vecnm(1,cg_idx), ovl_vecnm(1,gsc_idx), istwf_k, me_g0, comm)
5098 : : else
5099 : 127 : call cgnc_cholesky(nelem, nvec, vecnm(1,cg_idx), istwf_k, me_g0, comm, use_gemm=.FALSE.)
5100 : : end if
5101 : :
5102 : : else if (ortalgo==1) then
5103 : : ! =======================
5104 : : ! Second (new) algorithm
5105 : : ! =======================
5106 : : ! This first algorithm seems to be more efficient especially in the parallel band-FFT mode.
5107 : :
5108 [ + - ]: 32 : if(istwf_k==1) then
5109 : 32 : vectsize=nelem
5110 [ - + + - : 128 : ABI_MALLOC(cgramxbx,(nvec,nvec))
- + + - +
- + - - +
- + ]
5111 [ - + + - : 128 : ABI_MALLOC(cblockvectorx,(vectsize,nvec))
- + + - +
- + - - +
- + ]
5112 [ - + + - : 96 : ABI_MALLOC(cblockvectorbx,(vectsize,nvec))
- + + - -
+ - + ]
5113 : 32 : call abi_xcopy(nvec*vectsize,vecnm(:,cgindex(1):cgindex(nvec)-1),1,cblockvectorx,1,x_cplx=2)
5114 [ + - ]: 32 : if (useoverlap == 1) then
5115 : 32 : call abi_xcopy(nvec*vectsize,ovl_vecnm(:,gscindex(1):gscindex(nvec)-1),1,cblockvectorbx,1,x_cplx=2)
5116 : : else
5117 : 0 : call abi_xcopy(nvec*vectsize,vecnm(:,cgindex(1):cgindex(nvec)-1),1,cblockvectorbx,1,x_cplx=2)
5118 : : end if
5119 : 32 : call abi_xorthonormalize(cblockvectorx,cblockvectorbx,nvec,comm,cgramxbx,vectsize)
5120 : 32 : call abi_xcopy(nvec*vectsize,cblockvectorx,1,vecnm(:,cgindex(1):cgindex(nvec)-1),1,x_cplx=2)
5121 [ + - ]: 32 : if (useoverlap == 1) then
5122 : 32 : call abi_xtrsm('r','u','n','n',vectsize,nvec,cone,cgramxbx,nvec,cblockvectorbx,vectsize)
5123 : 32 : call abi_xcopy(nvec*vectsize,cblockvectorbx,1,ovl_vecnm(:,gscindex(1):gscindex(nvec)-1),1,x_cplx=2)
5124 : : end if
5125 [ - + ]: 32 : ABI_FREE(cgramxbx)
5126 [ - + ]: 32 : ABI_FREE(cblockvectorx)
5127 [ - + ]: 32 : ABI_FREE(cblockvectorbx)
5128 : :
5129 [ # # ]: 0 : else if (istwf_k==2) then
5130 : : ! Pack real and imaginary part of the wavefunctions.
5131 : 0 : rvectsiz=nelem
5132 [ # # ]: 0 : vectsize=2*nelem; if(me_g0==1) vectsize=vectsize-1
5133 [ # # # # : 0 : ABI_MALLOC(rgramxbx,(nvec,nvec))
# # # # #
# # # # #
# # ]
5134 [ # # # # : 0 : ABI_MALLOC(rblockvectorx,(vectsize,nvec))
# # # # #
# # # # #
# # ]
5135 [ # # # # : 0 : ABI_MALLOC(rblockvectorbx,(vectsize,nvec))
# # # # #
# # # ]
5136 [ # # ]: 0 : do ivec=1,nvec
5137 [ # # ]: 0 : if (me_g0 == 1) then
5138 : 0 : call abi_xcopy(1,vecnm(1,cgindex(ivec)),1,rblockvectorx (1,ivec),1)
5139 : 0 : call abi_xcopy(rvectsiz-1,vecnm(1,cgindex(ivec)+1),2,rblockvectorx(2,ivec),1)
5140 : 0 : call abi_xcopy(rvectsiz-1,vecnm(2,cgindex(ivec)+1),2,rblockvectorx(rvectsiz+1,ivec),1)
5141 [ # # ]: 0 : if (useoverlap == 1) then
5142 : 0 : call abi_xcopy(1,ovl_vecnm(1,gscindex(ivec)),1,rblockvectorbx(1,ivec),1)
5143 : 0 : call abi_xcopy(rvectsiz-1,ovl_vecnm(1,gscindex(ivec)+1),2,rblockvectorbx(2,ivec),1)
5144 : 0 : call abi_xcopy(rvectsiz-1,ovl_vecnm(2,gscindex(ivec)+1),2,rblockvectorbx(rvectsiz+1,ivec),1)
5145 : : else
5146 : 0 : call abi_xcopy(1,vecnm(1,cgindex(ivec)),1,rblockvectorbx(1,ivec),1)
5147 : 0 : call abi_xcopy(rvectsiz-1,vecnm(1,cgindex(ivec)+1),2,rblockvectorbx(2,ivec),1)
5148 : 0 : call abi_xcopy(rvectsiz-1,vecnm(2,cgindex(ivec)+1),2,rblockvectorbx(rvectsiz+1,ivec),1)
5149 : : end if
5150 [ # # ]: 0 : rblockvectorx (2:vectsize,ivec)=rblockvectorx (2:vectsize,ivec)*sqrt2
5151 [ # # ]: 0 : rblockvectorbx(2:vectsize,ivec)=rblockvectorbx(2:vectsize,ivec)*sqrt2
5152 : : else
5153 : 0 : call abi_xcopy(rvectsiz,vecnm(1,cgindex(ivec)),2,rblockvectorx(1,ivec),1)
5154 : 0 : call abi_xcopy(rvectsiz,vecnm(2,cgindex(ivec)),2,rblockvectorx(rvectsiz+1,ivec),1)
5155 [ # # ]: 0 : if (useoverlap == 1) then
5156 : 0 : call abi_xcopy(rvectsiz,ovl_vecnm(1,gscindex(ivec)),2,rblockvectorbx(1,ivec),1)
5157 : 0 : call abi_xcopy(rvectsiz,ovl_vecnm(2,gscindex(ivec)),2,rblockvectorbx(rvectsiz+1,ivec),1)
5158 : : else
5159 : 0 : call abi_xcopy(rvectsiz,vecnm(1,cgindex(ivec)),2,rblockvectorbx(1,ivec),1)
5160 : 0 : call abi_xcopy(rvectsiz,vecnm(2,cgindex(ivec)),2,rblockvectorbx(rvectsiz+1,ivec),1)
5161 : : end if
5162 [ # # ]: 0 : rblockvectorx (1:vectsize,ivec)=rblockvectorx (1:vectsize,ivec)*sqrt2
5163 [ # # ]: 0 : rblockvectorbx(1:vectsize,ivec)=rblockvectorbx(1:vectsize,ivec)*sqrt2
5164 : : end if
5165 : : end do
5166 : :
5167 : 0 : call ortho_reim(rblockvectorx,rblockvectorbx,nvec,comm,rgramxbx,vectsize)
5168 : :
5169 [ # # ]: 0 : do ivec=1,nvec
5170 : : ! Unpack results
5171 [ # # ]: 0 : if (me_g0 == 1) then
5172 : 0 : call abi_xcopy(1,rblockvectorx(1,ivec),1,vecnm(1,cgindex(ivec)),1)
5173 : 0 : vecnm(2,cgindex(ivec))=zero
5174 [ # # ]: 0 : rblockvectorx(2:vectsize,ivec)=rblockvectorx(2:vectsize,ivec)/sqrt2
5175 : 0 : call abi_xcopy(rvectsiz-1,rblockvectorx(2,ivec),1,vecnm(1,cgindex(ivec)+1),2)
5176 : 0 : call abi_xcopy(rvectsiz-1,rblockvectorx(rvectsiz+1,ivec),1,vecnm(2,cgindex(ivec)+1),2)
5177 : : else
5178 [ # # ]: 0 : rblockvectorx(1:vectsize,ivec)=rblockvectorx(1:vectsize,ivec)/sqrt2
5179 : 0 : call abi_xcopy(rvectsiz,rblockvectorx(1,ivec),1,vecnm(1,cgindex(ivec)),2)
5180 : 0 : call abi_xcopy(rvectsiz,rblockvectorx(rvectsiz+1,ivec),1,vecnm(2,cgindex(ivec)),2)
5181 : : end if
5182 : :
5183 [ # # ]: 0 : if(useoverlap == 1) then
5184 : 0 : call abi_xtrsm('r','u','n','n',vectsize,nvec,one,rgramxbx,nvec,rblockvectorbx,vectsize)
5185 [ # # ]: 0 : if (me_g0 == 1) then
5186 : 0 : call abi_xcopy(1,rblockvectorbx(1,ivec),1,ovl_vecnm(1,gscindex(ivec)),1)
5187 : 0 : ovl_vecnm(2,gscindex(ivec))=zero
5188 [ # # ]: 0 : rblockvectorbx(2:vectsize,ivec)=rblockvectorbx(2:vectsize,ivec)/sqrt2
5189 : 0 : call abi_xcopy(rvectsiz-1,rblockvectorbx(2,ivec),1,ovl_vecnm(1,gscindex(ivec)+1),2)
5190 : 0 : call abi_xcopy(rvectsiz-1,rblockvectorbx(rvectsiz+1,ivec),1,ovl_vecnm(2,gscindex(ivec)+1),2)
5191 : : else
5192 [ # # ]: 0 : rblockvectorbx(1:vectsize,ivec)=rblockvectorbx(1:vectsize,ivec)/sqrt2
5193 : 0 : call abi_xcopy(rvectsiz,rblockvectorbx(1,ivec),1,ovl_vecnm(1,gscindex(ivec)),2)
5194 : 0 : call abi_xcopy(rvectsiz,rblockvectorbx(rvectsiz+1,ivec),1,ovl_vecnm(2,gscindex(ivec)),2)
5195 : : end if
5196 : : end if
5197 : : end do
5198 [ # # ]: 0 : ABI_FREE(rgramxbx)
5199 [ # # ]: 0 : ABI_FREE(rblockvectorx)
5200 [ # # ]: 0 : ABI_FREE(rblockvectorbx)
5201 : : end if
5202 : :
5203 : : else if (ortalgo==4) then
5204 : : ! else if (ANY(ortalgo==(/0,2/))) then
5205 : :
5206 : 0 : cg_idx = cgindex(1)
5207 [ # # ]: 0 : if (useoverlap==0) then
5208 : 0 : call cgnc_gramschmidt(nelem,nvec,vecnm(1,cg_idx),istwf_k,me_g0,comm)
5209 : : else
5210 : 0 : gsc_idx = gscindex(1)
5211 : 0 : call cgpaw_gramschmidt(nelem,nvec,vecnm(1,cg_idx),ovl_vecnm(1,gsc_idx),istwf_k,me_g0,comm)
5212 : : end if
5213 : :
5214 : : else if (ANY(ortalgo==(/0,2/))) then
5215 : : ! =======================
5216 : : ! Third (old) algorithm
5217 : : ! =======================
5218 : : ! TODO: This algo should be removed. Ref files should be updated though.
5219 : :
5220 [ + + ]: 3996787 : do ivec=1,nvec
5221 : : ! Normalize each vecnm(n,m) in turn:
5222 : :
5223 [ + + ]: 3501562 : if (useoverlap==1) then ! Using overlap S...
5224 [ + + ]: 1254478 : if(istwf_k/=2)then
5225 : 1221291 : sum=zero;ii0=1
5226 : : else
5227 [ + - ]: 33187 : if (me_g0 ==1) then
5228 : 33187 : sum=half*ovl_vecnm(1,1+nelem*(ivec-1)+igsc)*vecnm(1,1+nelem*(ivec-1)+icg)
5229 : 33187 : ii0=2
5230 : : else
5231 : 0 : sum=zero;ii0=1
5232 : : end if
5233 : : end if
5234 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:sum) SHARED(icg,ivec,nelem,vecnm)
5235 [ + + ]: 430103915 : do ii=ii0+nelem*(ivec-1),nelem*ivec
5236 : 430103915 : sum=sum+vecnm(1,ii+icg)*ovl_vecnm(1,ii+igsc)+vecnm(2,ii+icg)*ovl_vecnm(2,ii+igsc)
5237 : : end do
5238 : :
5239 : : else ! Without overlap...
5240 [ + + ]: 2247084 : if(istwf_k/=2)then
5241 : 2157859 : sum=zero;ii0=1
5242 : : else
5243 [ + - ]: 89225 : if (me_g0 ==1) then
5244 : 89225 : sum=half*vecnm(1,1+nelem*(ivec-1)+icg)**2
5245 : 89225 : ii0=2
5246 : : else
5247 : 0 : sum=zero;ii0=1
5248 : : end if
5249 : : end if
5250 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:sum) SHARED(icg,ivec,nelem,vecnm)
5251 [ + + ]: 748614456 : do ii=ii0+nelem*(ivec-1)+icg,nelem*ivec+icg
5252 : 748614456 : sum=sum+vecnm(1,ii)**2+vecnm(2,ii)**2
5253 : : end do
5254 : : end if
5255 : :
5256 : 3501562 : call timab(48,1,tsec)
5257 : 3501562 : call xmpi_sum(sum,comm,ierr)
5258 : 3501562 : call timab(48,2,tsec)
5259 : :
5260 [ + + ]: 3501562 : if(istwf_k>=2)sum=two*sum
5261 : 3501562 : xnorm = sqrt(abs(sum)) ; sum=1.0_dp/xnorm
5262 : : !$OMP PARALLEL DO PRIVATE(ii) SHARED(icg,ivec,nelem,sum,vecnm)
5263 [ + + ]: 1178840783 : do ii=1+nelem*(ivec-1)+icg,nelem*ivec+icg
5264 : 1175339221 : vecnm(1,ii)=vecnm(1,ii)*sum
5265 : 1178840783 : vecnm(2,ii)=vecnm(2,ii)*sum
5266 : : end do
5267 [ + + ]: 3501562 : if (useoverlap==1) then
5268 : : !$OMP PARALLEL DO PRIVATE(ii) SHARED(icg,ivec,nelem,sum,ovl_vecnm)
5269 [ + + ]: 430137102 : do ii=1+nelem*(ivec-1)+igsc,nelem*ivec+igsc
5270 : 428882624 : ovl_vecnm(1,ii)=ovl_vecnm(1,ii)*sum
5271 : 430137102 : ovl_vecnm(2,ii)=ovl_vecnm(2,ii)*sum
5272 : : end do
5273 : : end if
5274 : :
5275 : : ! Remove projection in all higher states.
5276 [ + + ]: 7498349 : if (ivec<nvec) then
5277 : :
5278 [ + + ]: 3006337 : if(istwf_k==1)then
5279 : : ! Cannot use time-reversal symmetry
5280 : :
5281 [ + + ]: 2767077 : if (useoverlap==1) then ! Using overlap.
5282 [ + + ]: 11636647 : do ivec2=ivec+1,nvec
5283 : : ! First compute scalar product
5284 : 10560222 : dotr=zero ; doti=zero
5285 : 10560222 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+igsc
5286 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:doti,dotr) SHARED(ii1,ii2,nelem,vecnm)
5287 [ + + ]: 3641452686 : do ii=1,nelem
5288 : 3630892464 : dotr=dotr+vecnm(1,ii1+ii)*ovl_vecnm(1,ii2+ii)+vecnm(2,ii1+ii)*ovl_vecnm(2,ii2+ii)
5289 : 3641452686 : doti=doti+vecnm(1,ii1+ii)*ovl_vecnm(2,ii2+ii)-vecnm(2,ii1+ii)*ovl_vecnm(1,ii2+ii)
5290 : : end do
5291 : :
5292 : 10560222 : call timab(48,1,tsec)
5293 : 10560222 : buffer2(1)=doti;buffer2(2)=dotr
5294 : 10560222 : call xmpi_sum(buffer2,comm,ierr)
5295 : 10560222 : call timab(48,2,tsec)
5296 : 10560222 : doti=buffer2(1)
5297 : 10560222 : dotr=buffer2(2)
5298 : :
5299 : : ! Then subtract the appropriate amount of the lower state
5300 : 10560222 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5301 : : #ifdef FC_INTEL
5302 : : ! DIR$ ivdep
5303 : : #endif
5304 : : !$OMP PARALLEL DO PRIVATE(ii) SHARED(doti,dotr,ii1,ii2,nelem,vecnm)
5305 [ + + ]: 3641452686 : do ii=1,nelem
5306 : 3630892464 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)+doti*vecnm(2,ii1+ii)
5307 : 3641452686 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-doti*vecnm(1,ii1+ii)-dotr*vecnm(2,ii1+ii)
5308 : : end do
5309 : :
5310 : 10560222 : ii1=nelem*(ivec-1)+igsc;ii2=nelem*(ivec2-1)+igsc
5311 [ + + ]: 3642529111 : do ii=1,nelem
5312 : : ovl_vecnm(1,ii2+ii)=ovl_vecnm(1,ii2+ii)&
5313 : : & -dotr*ovl_vecnm(1,ii1+ii)&
5314 : 3630892464 : & +doti*ovl_vecnm(2,ii1+ii)
5315 : : ovl_vecnm(2,ii2+ii)=ovl_vecnm(2,ii2+ii)&
5316 : : -doti*ovl_vecnm(1,ii1+ii)&
5317 : 3641452686 : & -dotr*ovl_vecnm(2,ii1+ii)
5318 : : end do
5319 : : end do
5320 : : else
5321 : : ! ----- No overlap -----
5322 [ + + ]: 17656909 : do ivec2=ivec+1,nvec
5323 : : ! First compute scalar product
5324 : 15966257 : dotr=zero ; doti=zero
5325 : 15966257 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5326 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:doti,dotr) SHARED(ii1,ii2,nelem,vecnm)
5327 [ + + ]: 6590292929 : do ii=1,nelem
5328 : : dotr=dotr+vecnm(1,ii1+ii)*vecnm(1,ii2+ii)+&
5329 : 6574326672 : & vecnm(2,ii1+ii)*vecnm(2,ii2+ii)
5330 : : doti=doti+vecnm(1,ii1+ii)*vecnm(2,ii2+ii)-&
5331 : 6590292929 : & vecnm(2,ii1+ii)*vecnm(1,ii2+ii)
5332 : : end do
5333 : : ! Init mpi_comm
5334 : 15966257 : buffer2(1)=doti
5335 : 15966257 : buffer2(2)=dotr
5336 : 15966257 : call timab(48,1,tsec)
5337 : 15966257 : call xmpi_sum(buffer2,comm,ierr)
5338 : : ! call xmpi_sum(doti,spaceComm,ierr)
5339 : : ! call xmpi_sum(dotr,spaceComm,ierr)
5340 : 15966257 : call timab(48,2,tsec)
5341 : 15966257 : doti=buffer2(1)
5342 : 15966257 : dotr=buffer2(2)
5343 : :
5344 : : ! Then subtract the appropriate amount of the lower state
5345 : : #ifdef FC_INTEL
5346 : : ! DIR$ ivdep
5347 : : #endif
5348 : : !$OMP PARALLEL DO PRIVATE(ii) SHARED(doti,dotr,ii1,ii2,nelem,vecnm)
5349 [ + + ]: 6591983581 : do ii=1,nelem
5350 : : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)+&
5351 : 6574326672 : & doti*vecnm(2,ii1+ii)
5352 : : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-doti*vecnm(1,ii1+ii)-&
5353 : 6590292929 : & dotr*vecnm(2,ii1+ii)
5354 : : end do
5355 : : end do
5356 : :
5357 : : end if ! Test on useoverlap
5358 : :
5359 [ + + ]: 239260 : else if(istwf_k==2)then
5360 : : ! At gamma point use of time-reversal symmetry saves cpu time.
5361 : :
5362 [ + + ]: 104310 : if (useoverlap==1) then
5363 : : ! ----- Using overlap -----
5364 [ + + ]: 391204 : do ivec2=ivec+1,nvec
5365 : : ! First compute scalar product
5366 : 361741 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+igsc
5367 [ + - ]: 361741 : if (me_g0 ==1) then
5368 : 361741 : dotr=half*vecnm(1,ii1+1)*ovl_vecnm(1,ii2+1)
5369 : : ! Avoid double counting G=0 contribution
5370 : : ! Imaginary part of vecnm at G=0 should be zero,so only take real part
5371 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5372 [ + + ]: 344065987 : do ii=2,nelem
5373 : : dotr=dotr+vecnm(1,ii1+ii)*ovl_vecnm(1,ii2+ii)+&
5374 : 344065987 : & vecnm(2,ii1+ii)*ovl_vecnm(2,ii2+ii)
5375 : : end do
5376 : : else
5377 : 0 : dotr=0._dp
5378 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5379 [ # # ]: 0 : do ii=1,nelem
5380 : : dotr=dotr+vecnm(1,ii1+ii)*ovl_vecnm(1,ii2+ii)+&
5381 : 0 : & vecnm(2,ii1+ii)*ovl_vecnm(2,ii2+ii)
5382 : : end do
5383 : : end if
5384 : :
5385 : 361741 : dotr=two*dotr
5386 : :
5387 : 361741 : call timab(48,1,tsec)
5388 : 361741 : call xmpi_sum(dotr,comm,ierr)
5389 : 361741 : call timab(48,2,tsec)
5390 : :
5391 : : ! Then subtract the appropriate amount of the lower state
5392 : 361741 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5393 : : #ifdef FC_INTEL
5394 : : ! DIR$ ivdep
5395 : : #endif
5396 : : !$OMP PARALLEL DO PRIVATE(ii) SHARED(dotr,ii1,ii2,nelem,vecnm)
5397 [ + + ]: 344427728 : do ii=1,nelem
5398 : 344065987 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)
5399 : 344427728 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-dotr*vecnm(2,ii1+ii)
5400 : : end do
5401 : 361741 : ii1=nelem*(ivec-1)+igsc;ii2=nelem*(ivec2-1)+igsc
5402 [ + + ]: 344818932 : do ii=1,nelem
5403 : 344065987 : ovl_vecnm(1,ii2+ii)=ovl_vecnm(1,ii2+ii)-dotr*ovl_vecnm(1,ii1+ii)
5404 : 344427728 : ovl_vecnm(2,ii2+ii)=ovl_vecnm(2,ii2+ii)-dotr*ovl_vecnm(2,ii1+ii)
5405 : : end do
5406 : : end do
5407 : : else
5408 : : ! ----- No overlap -----
5409 [ + + ]: 774378 : do ivec2=ivec+1,nvec
5410 : : ! First compute scalar product
5411 : 699531 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5412 [ + - ]: 699531 : if (me_g0 ==1) then
5413 : : ! Avoid double counting G=0 contribution
5414 : : ! Imaginary part of vecnm at G=0 should be zero,so only take real part
5415 : 699531 : dotr=half*vecnm(1,ii1+1)*vecnm(1,ii2+1)
5416 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5417 [ + + ]: 436944509 : do ii=2,nelem
5418 : 436944509 : dotr=dotr+vecnm(1,ii1+ii)*vecnm(1,ii2+ii)+vecnm(2,ii1+ii)*vecnm(2,ii2+ii)
5419 : : end do
5420 : : else
5421 : 0 : dotr=0._dp
5422 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5423 [ # # ]: 0 : do ii=1,nelem
5424 : 0 : dotr=dotr+vecnm(1,ii1+ii)*vecnm(1,ii2+ii)+vecnm(2,ii1+ii)*vecnm(2,ii2+ii)
5425 : : end do
5426 : : end if
5427 : 699531 : dotr=two*dotr
5428 : :
5429 : 699531 : call timab(48,1,tsec)
5430 : 699531 : call xmpi_sum(dotr,comm,ierr)
5431 : 699531 : call timab(48,2,tsec)
5432 : :
5433 : : ! Then subtract the appropriate amount of the lower state
5434 : : #ifdef FC_INTEL
5435 : : ! DIR$ ivdep
5436 : : #endif
5437 : : !$OMP PARALLEL DO PRIVATE(ii) SHARED(dotr,ii1,ii2,nelem,vecnm)
5438 [ + + ]: 437718887 : do ii=1,nelem
5439 : 436944509 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)
5440 : 437644040 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-dotr*vecnm(2,ii1+ii)
5441 : : end do
5442 : : end do
5443 : : end if ! Test on useoverlap
5444 : :
5445 : : else
5446 : : ! At other special points,use of time-reversal symmetry saves cpu time.
5447 : :
5448 [ + + ]: 134950 : if (useoverlap==1) then
5449 : : ! ----- Using overlap -----
5450 [ + + ]: 812784 : do ivec2=ivec+1,nvec
5451 : : ! First compute scalar product
5452 : 762200 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+igsc
5453 : : ! Avoid double counting G=0 contribution
5454 : : ! Imaginary part of vecnm at G=0 should be zero,so only take real part
5455 : 762200 : dotr=zero
5456 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5457 [ + + ]: 625854139 : do ii=1,nelem
5458 : 625854139 : dotr=dotr+vecnm(1,ii1+ii)*ovl_vecnm(1,ii2+ii)+vecnm(2,ii1+ii)*ovl_vecnm(2,ii2+ii)
5459 : : end do
5460 : 762200 : dotr=two*dotr
5461 : :
5462 : 762200 : call timab(48,1,tsec)
5463 : 762200 : call xmpi_sum(dotr,comm,ierr)
5464 : 762200 : call timab(48,2,tsec)
5465 : :
5466 : : ! Then subtract the appropriate amount of the lower state
5467 : 762200 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5468 : : #ifdef FC_INTEL
5469 : : ! DIR$ ivdep
5470 : : #endif
5471 : : !$OMP PARALLEL DO PRIVATE(ii) SHARED(dotr,ii1,ii2,nelem,vecnm)
5472 [ + + ]: 625854139 : do ii=1,nelem
5473 : 625091939 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)
5474 : 625854139 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-dotr*vecnm(2,ii1+ii)
5475 : : end do
5476 : 762200 : ii1=nelem*(ivec-1)+igsc;ii2=nelem*(ivec2-1)+igsc
5477 [ + + ]: 626666923 : do ii=1,nelem
5478 : 625091939 : ovl_vecnm(1,ii2+ii)=ovl_vecnm(1,ii2+ii)-dotr*ovl_vecnm(1,ii1+ii)
5479 : 625854139 : ovl_vecnm(2,ii2+ii)=ovl_vecnm(2,ii2+ii)-dotr*ovl_vecnm(2,ii1+ii)
5480 : : end do
5481 : : end do
5482 : : else
5483 : : ! ----- No overlap -----
5484 [ + + ]: 1187051 : do ivec2=ivec+1,nvec
5485 : : ! First compute scalar product
5486 : 1102685 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5487 : : ! Avoid double counting G=0 contribution
5488 : : ! Imaginary part of vecnm at G=0 should be zero,so only take real part
5489 : 1102685 : dotr=zero
5490 : : !$OMP PARALLEL DO PRIVATE(ii) REDUCTION(+:dotr) SHARED(ii1,ii2,nelem,vecnm)
5491 [ + + ]: 576065341 : do ii=1,nelem
5492 : 576065341 : dotr=dotr+vecnm(1,ii1+ii)*vecnm(1,ii2+ii)+vecnm(2,ii1+ii)*vecnm(2,ii2+ii)
5493 : : end do
5494 : 1102685 : dotr=two*dotr
5495 : :
5496 : 1102685 : call timab(48,1,tsec)
5497 : 1102685 : call xmpi_sum(dotr,comm,ierr)
5498 : 1102685 : call timab(48,2,tsec)
5499 : :
5500 : : ! Then subtract the appropriate amount of the lower state
5501 : : !$OMP PARALLEL DO PRIVATE(ii) SHARED(dotr,ii1,ii2,nelem,vecnm)
5502 [ + + ]: 576149707 : do ii=1,nelem
5503 : 574962656 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)
5504 : 576065341 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-dotr*vecnm(2,ii1+ii)
5505 : : end do
5506 : : end do
5507 : : end if
5508 : :
5509 : : end if ! End use of time-reversal symmetry
5510 : : end if ! Test on "ivec"
5511 : : end do ! end loop over vectors (or bands) with index ivec :
5512 : :
5513 : : else
5514 : 0 : ABI_ERROR(sjoin("Wrong value for ortalgo:", itoa(ortalgo)))
5515 : : end if
5516 : :
5517 : : !call cwtime_report(sjoin(" pw_orthon with ortalgo: ", itoa(ortalgo)), cpu, wall, gflops)
5518 : :
5519 [ - + - + ]: 495384 : end subroutine pw_orthon
5520 : : !!***
5521 : :
5522 : : !!****f* m_cgtools/pw_orthon_paw
5523 : : !! NAME
5524 : : !! pw_orthon_paw
5525 : : !!
5526 : : !! FUNCTION
5527 : : !! Normalize nvec complex vectors each of length nelem and then orthogonalize by modified Gram-Schmidt.
5528 : : !! The overlap matrix <c_m|S|c_n> (S can be identity) has to be provided as input, and is overwritten.
5529 : : !!
5530 : : !! INPUTS
5531 : : !! icg=shift to be given to the location of the data in cg(=vecnm)
5532 : : !! mcg=maximum size of second dimension of cg(=vecnm)
5533 : : !! nelem=number of complex elements in each vector
5534 : : !! nspinor=number of spinorial components of the wavefunctions (on current proc)
5535 : : !! nvec=number of vectors to be orthonormalized
5536 : : !! ortalgo= option for the choice of the algorithm
5537 : : !! -1: no orthogonalization (direct return)
5538 : : !! 0: do orthogonalization
5539 : : !! comm=MPI communicator
5540 : : !!
5541 : : !! SIDE EFFECTS
5542 : : !! cprj(optional)=<p_i|c_n> coefficients, updated to keep them consistent with the WF at output
5543 : : !! ovl_mat=overlap matrix <c_m|S|c_n> for m<=n
5544 : : !! vecnm= input: vectors to be orthonormalized; array of nvec column
5545 : : !! vectors,each of length nelem,shifted by icg
5546 : : !! This array is complex or else real(dp) of twice length
5547 : : !! output: orthonormalized set of vectors
5548 : : !!
5549 : : !! NOTES
5550 : : !! Note that each vector has an arbitrary phase which is not fixed in this routine.
5551 : : !!
5552 : : !! SOURCE
5553 : :
5554 [ # # # # : 0 : subroutine pw_orthon_cprj(icg,mcg,nelem,nspinor,nvec,ortalgo,ovl_mat,vecnm,cprj)
# # ]
5555 : :
5556 : : !Arguments ------------------------------------
5557 : : !scalars
5558 : : integer,intent(in) :: icg,mcg,nelem,nspinor,nvec,ortalgo
5559 : : !arrays
5560 : : real(dp),intent(inout) :: ovl_mat(nvec*(nvec+1)),vecnm(2,mcg)
5561 : : type(pawcprj_type),intent(inout),optional,target :: cprj(:,:)
5562 : :
5563 : : !Local variables-------------------------------
5564 : : !scalars
5565 : : logical :: do_cprj
5566 : : integer :: ii,ii1,ii2,ivec,ivec2,ivec3,iv1l,iv2l,iv3l,iv1r,iv2r,iv3r,ncprj
5567 : : real(dp) :: doti,dotr,summ,xnorm
5568 : : !arrays
5569 : 0 : real(dp) :: ovl_row_tmp(2*nvec),ovl_col_tmp(2*nvec)
5570 : : real(dp) :: re,im
5571 : : ! *************************************************************************
5572 : :
5573 : : !Nothing to do if ortalgo=-1
5574 [ # # ]: 0 : if(ortalgo==-1) return
5575 : :
5576 : 0 : do_cprj=.false.
5577 [ # # ]: 0 : if (present(cprj)) then
5578 : 0 : do_cprj=.true.
5579 : 0 : ncprj = size(cprj,2)
5580 [ # # ]: 0 : if (ncprj/=nspinor*nvec) then
5581 : 0 : ABI_ERROR('bad size for cprj')
5582 : : end if
5583 : : end if
5584 : :
5585 : : ! The overlap matrix is : ovl(i,j) = <psi_i|S|psi_j> = (<psi_j|S|psi_i>)^*
5586 : : ! The row index stands for the "left" band index
5587 : : ! The column index stands for the "right" band index
5588 : : ! Only the upper triangular part of the (complex) overlap matrix is stored, so only elements with i<=j.
5589 : : ! They are stored in the following order: ovl(1,1),ovl(1,2),ovl(2,2),ovl(1,3),ovl(2,3),...
5590 : : ! so:
5591 : : ! -- shift for the ith row : 2.(i.(i-1)/2) = i.(i-1)
5592 : : ! -- shift for the ith column : 2.(i-1)+1 = 2.i-1
5593 : : ! => 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)
5594 : : ! => index of imaginary part = index of real part + 1
5595 : : ! After orthogonalizing the first n vectors, we have:
5596 : : ! for i<=n, i<=j : ovl(i,j) = delta_ij
5597 : :
5598 [ # # ]: 0 : do ivec=1,nvec
5599 : :
5600 : : ! First we normalize the current vector
5601 : 0 : iv1r = ivec*(ivec-1) ! ith row
5602 : 0 : iv1l = 2*ivec-1 ! ith column
5603 : : ! ovl(i1,i1) = <psi_i1|S|psi_i1>
5604 : 0 : summ = ovl_mat(iv1r+iv1l)
5605 : 0 : xnorm = sqrt(abs(summ)) ; summ=1.0_dp/xnorm
5606 : : !$OMP PARALLEL DO PRIVATE(ii) SHARED(icg,ivec,nelem,summ,vecnm)
5607 [ # # ]: 0 : do ii=1+nelem*(ivec-1)+icg,nelem*ivec+icg
5608 : 0 : vecnm(1,ii)=vecnm(1,ii)*summ
5609 : 0 : vecnm(2,ii)=vecnm(2,ii)*summ
5610 : : end do
5611 : : ! Apply the normalization to cprj coeffs
5612 [ # # # # ]: 0 : if (do_cprj) call pawcprj_axpby(zero,summ,cprj(:,nspinor*(ivec-1)+1:nspinor*ivec),cprj(:,nspinor*(ivec-1)+1:nspinor*ivec))
5613 : :
5614 : : ! As the norm of |psi_i1> changed, we update the overlap matrix accordingly.
5615 : : ! From previous iterations, we already have:
5616 : : ! ovl(i2,i1) = <psi_i2|S|psi_i1> = 0 for i2<i1
5617 : : ! so we need to change only:
5618 : : ! ovl(i1,i2) = <psi_i1|S|psi_i2> for i1<=i2
5619 [ # # ]: 0 : do ivec2=ivec,nvec
5620 : 0 : iv2r=ivec2*(ivec2-1)
5621 [ # # ]: 0 : if (ivec<ivec2) then
5622 : 0 : ovl_mat(iv2r+iv1l ) = ovl_mat(iv2r+iv1l )*summ
5623 : 0 : ovl_mat(iv2r+iv1l+1) = ovl_mat(iv2r+iv1l+1)*summ
5624 [ # # ]: 0 : else if (ivec==ivec2) then
5625 : 0 : ovl_mat(iv2r+iv1l ) = ovl_mat(iv2r+iv1l )*summ*summ
5626 : 0 : ovl_mat(iv2r+iv1l+1) = ovl_mat(iv2r+iv1l+1)*summ*summ
5627 : 0 : re = ovl_mat(iv2r+iv1l )
5628 : 0 : im = ovl_mat(iv2r+iv1l+1)
5629 [ # # # # ]: 0 : if (abs(re-1)>tol10.or.abs(im)>tol10) then
5630 : 0 : write(std_out,'(a,es21.10e3)') '(pw_ortho) ovl (re)',re
5631 : 0 : write(std_out,'(a,es21.10e3)') '(pw_ortho) ovl (im)',im
5632 : 0 : ABI_WARNING('In pw_orthon_cprj: the result should be equal to one!')
5633 : : end if
5634 : : end if
5635 : : end do
5636 : :
5637 : : ! Remove projection in all higher states.
5638 [ # # ]: 0 : if (ivec<nvec) then
5639 : :
5640 [ # # ]: 0 : do ivec2=ivec+1,nvec
5641 : :
5642 : 0 : iv2r = ivec2*(ivec2-1)
5643 : 0 : iv2l = 2*ivec2-1
5644 : : ! (dotr,doti) = <psi_i1|S|psi_i2>
5645 : 0 : dotr = ovl_mat(iv2r+iv1l )
5646 : 0 : doti = ovl_mat(iv2r+iv1l+1)
5647 : :
5648 : : ! Then subtract the appropriate amount of the lower state
5649 : 0 : ii1=nelem*(ivec-1)+icg;ii2=nelem*(ivec2-1)+icg
5650 : : ! |psi'_i2> = |psi_i2> - <psi_i1|S|psi_i2> |psi_i1>
5651 : : !$OMP PARALLEL DO PRIVATE(ii) SHARED(doti,dotr,ii1,ii2,nelem,vecnm)
5652 [ # # ]: 0 : do ii=1,nelem
5653 : 0 : vecnm(1,ii2+ii)=vecnm(1,ii2+ii)-dotr*vecnm(1,ii1+ii)+doti*vecnm(2,ii1+ii)
5654 : 0 : vecnm(2,ii2+ii)=vecnm(2,ii2+ii)-doti*vecnm(1,ii1+ii)-dotr*vecnm(2,ii1+ii)
5655 : : end do
5656 [ # # ]: 0 : if (do_cprj) call pawcprj_zaxpby((/-dotr,-doti/),(/one,zero/),cprj(:,nspinor*(ivec-1)+1:nspinor*ivec),&
5657 [ # # # # : 0 : cprj(:,nspinor*(ivec2-1)+1:nspinor*ivec2))
# # ]
5658 : : ! As |psi_i2> changed, we update the overlap matrix accordingly.
5659 : : ! We have: <psi'_i3|S|psi'_i2> = <psi'_i3|S|psi_i2> - <psi_i1|S|psi_i2> <psi'_i3|S|psi_i1>
5660 : : ! Remember that i2>i1.
5661 : : ! For i3<=i2, we compute the new column i2.
5662 : : ! For i3<i1:
5663 : : ! (1) <psi'_i3|S|psi'_i2> = <psi_i3|S|psi_i2> - <psi_i1|S|psi_i2> <psi_i3|S|psi_i1>
5664 : : ! = <psi_i3|S|psi_i2>
5665 : : ! as for i3<i1 we have <psi_i3|S|psi_i1> = 0
5666 : : ! For i1<=i3<i2:
5667 : : ! (2) <psi'_i3|S|psi'_i2> = <psi_i3|S|psi_i2> - <psi_i1|S|psi_i2> <psi_i3|S|psi_i1>
5668 : : ! = <psi_i3|S|psi_i2> - <psi_i1|S|psi_i2> (<psi_i1|S|psi_i3>)^*
5669 : : ! For i3=i2:
5670 : : ! (3) <psi'_i3|S|psi'_i2> = <psi'_i2|S|psi_i2> - <psi_i1|S|psi_i2> <psi'_i2|S|psi_i1>
5671 : : ! = <psi_i2|S|psi_i2> - <psi_i1|S|psi_i2> <psi_i2|S|psi_i1>
5672 : : ! - <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>
5673 : : ! = <psi_i2|S|psi_i2> - <psi_i1|S|psi_i2> <psi_i2|S|psi_i1>
5674 : : ! = <psi_i2|S|psi_i2> - <psi_i1|S|psi_i2> (<psi_i1|S|psi_i2>)^*
5675 : : ! so the case i3=i2 (3) is equivalent to the case i1<=i3<i2 (2) with i3=i2.
5676 : : ! Here we compute (2) and (3) in a temporary array:
5677 [ # # ]: 0 : do ivec3=ivec,ivec2
5678 : 0 : iv3r=ivec3*(ivec3-1)
5679 : 0 : iv3l=2*ivec3-1
5680 : 0 : ovl_col_tmp(iv3l ) = ovl_mat(iv2r+iv3l ) - dotr*ovl_mat(iv3r+iv1l) - doti*ovl_mat(iv3r+iv1l+1)
5681 : 0 : ovl_col_tmp(iv3l+1) = ovl_mat(iv2r+iv3l+1) - doti*ovl_mat(iv3r+iv1l) + dotr*ovl_mat(iv3r+iv1l+1)
5682 : : end do
5683 : : ! For i2<i3, we compute the new row i2.
5684 : : ! (4) <psi'_i2|S|psi_i3> = <psi_i2|S|psi_i3> - <psi_i2|S|psi_i1> <psi_i1|S|psi_i3>
5685 : : ! = <psi_i2|S|psi_i3> - (<psi_i1|S|psi_i2>)^* <psi_i1|S|psi_i3>
5686 : : ! Here we compute (4) in a temporary array:
5687 [ # # ]: 0 : do ivec3=ivec2+1,nvec
5688 : 0 : iv3r=ivec3*(ivec3-1)
5689 : 0 : iv3l=2*ivec3-1
5690 : 0 : ovl_row_tmp(iv3l ) = ovl_mat(iv3r+iv2l ) - dotr*ovl_mat(iv3r+iv1l) - doti*ovl_mat(iv3r+iv1l+1)
5691 : 0 : ovl_row_tmp(iv3l+1) = ovl_mat(iv3r+iv2l+1) + doti*ovl_mat(iv3r+iv1l) - dotr*ovl_mat(iv3r+iv1l+1)
5692 : : end do
5693 : : ! We update the column i2 (starting from ivec and not 1, thanks to (1))
5694 [ # # ]: 0 : do ivec3=ivec,ivec2
5695 : 0 : iv3l=2*ivec3-1
5696 : 0 : ovl_mat(iv2r+iv3l ) = ovl_col_tmp(iv3l )
5697 : 0 : ovl_mat(iv2r+iv3l+1) = ovl_col_tmp(iv3l+1)
5698 : : end do
5699 : : ! We update the row i2
5700 [ # # ]: 0 : do ivec3=ivec2+1,nvec
5701 : 0 : iv3r=ivec3*(ivec3-1)
5702 : 0 : iv3l=2*ivec3-1
5703 : 0 : ovl_mat(iv3r+iv2l ) = ovl_row_tmp(iv3l )
5704 : 0 : ovl_mat(iv3r+iv2l+1) = ovl_row_tmp(iv3l+1)
5705 : : end do
5706 : : end do
5707 : :
5708 : : end if ! Test on "ivec"
5709 : :
5710 : : !end loop over vectors (or bands) with index ivec :
5711 : : end do
5712 : :
5713 : : end subroutine pw_orthon_cprj
5714 : : !!***
5715 : :
5716 : : !!****f* m_cgtools/cg_hprotate_and_get_diag
5717 : : !! NAME
5718 : : !! cg_hprotate_and_get_diag
5719 : : !!
5720 : : !! FUNCTION
5721 : : !! Compute the diagonal elements of E^H VNLX E
5722 : : !! where VNLX is an Hermitean matrixin packed form and E is the matrix with eigenvectors as column vectors.
5723 : : !! Mainly used to rotate the matrix elements of an operator after the subspace diagonalization.
5724 : : !!
5725 : : !! INPUTS
5726 : : !!
5727 : : !! OUTPUT
5728 : : !!
5729 : : !! SOURCE
5730 : :
5731 : 224112 : subroutine cg_hprotate_and_get_diag(nband_k, subvnlx, evec, enlx_k)
5732 : :
5733 : : !Arguments ------------------------------------
5734 : : !scalars
5735 : : integer,intent(in) :: nband_k
5736 : : !arrays
5737 : : real(dp),intent(in) :: subvnlx(nband_k*(nband_k+1))
5738 : : real(dp),intent(in) :: evec(2*nband_k,nband_k)
5739 : : real(dp), intent(out) :: enlx_k(nband_k)
5740 : :
5741 : : !Local variables ------------------------------
5742 : : !scalars
5743 : : integer :: ii,jj,pidx,iband
5744 : 224112 : real(dp),allocatable :: mat1(:,:,:),matvnl(:,:,:)
5745 : : ! *************************************************************************
5746 : :
5747 [ - + + - : 896448 : ABI_MALLOC(matvnl,(2,nband_k,nband_k))
- + + - +
- + - - +
- + ]
5748 [ - + + - : 672336 : ABI_MALLOC(mat1,(2,nband_k,nband_k))
- + + - -
+ + - ]
5749 : :
5750 : : ! Construct upper triangle of matvnl from subvnlx using full storage mode.
5751 : 1350722 : pidx=0
5752 [ + + ]: 1350722 : do jj=1,nband_k
5753 [ + + ]: 10000593 : do ii=1,jj
5754 : 8649871 : pidx=pidx+1
5755 : 8649871 : matvnl(1,ii,jj)=subvnlx(2*pidx-1)
5756 : 9776481 : matvnl(2,ii,jj)=subvnlx(2*pidx )
5757 : : end do
5758 : : end do
5759 : :
5760 : 224112 : call zhemm('L','U',nband_k,nband_k,cone,matvnl,nband_k,evec,nband_k,czero,mat1,nband_k)
5761 : :
5762 : : !$OMP PARALLEL DO
5763 [ + + ]: 1350722 : do iband=1,nband_k
5764 : 1350722 : enlx_k(iband) = cg_real_zdotc(nband_k,evec(:,iband),mat1(:,:,iband))
5765 : : end do
5766 : :
5767 [ - + ]: 224112 : ABI_FREE(matvnl)
5768 [ - + ]: 224112 : ABI_FREE(mat1)
5769 : :
5770 : 224112 : end subroutine cg_hprotate_and_get_diag
5771 : : !!***
5772 : :
5773 : : !!****f* m_cgtools/cg_hrotate_and_get_diag
5774 : : !! NAME
5775 : : !! cg_hrotate_and_get_diag
5776 : : !!
5777 : : !! FUNCTION
5778 : : !! Compute the diagonal elements of E^H VNLX E
5779 : : !! where VNLX is an Hermitean matrix.
5780 : : !! Mainly used to rotate the matrix elements of an operator after the subspace diagonalization.
5781 : : !!
5782 : : !! INPUTS
5783 : : !!
5784 : : !! OUTPUT
5785 : : !!
5786 : : !! SOURCE
5787 : :
5788 : 612 : subroutine cg_hrotate_and_get_diag(istwf_k, nband_k, totvnlx, evec, enlx_k)
5789 : :
5790 : : !Arguments ------------------------------------
5791 : : !scalars
5792 : : integer,intent(in) :: istwf_k, nband_k
5793 : : !arrays
5794 : : real(dp),intent(in) :: totvnlx(2*nband_k,nband_k)
5795 : : real(dp),intent(in) :: evec(2*nband_k,nband_k)
5796 : : real(dp),intent(out) :: enlx_k(nband_k)
5797 : :
5798 : : !Local variables ------------------------------
5799 : : !scalars
5800 : : real(dp),external :: ddot
5801 : : integer :: jj,iband
5802 : 612 : real(dp),allocatable :: mat_loc(:,:),mat1(:,:,:),matvnl(:,:,:), evec_loc(:,:)
5803 : : ! *************************************************************************
5804 : :
5805 [ - + + - : 2448 : ABI_MALLOC(matvnl, (2,nband_k, nband_k))
- + + - +
- + - - +
- + ]
5806 [ - + + - : 1836 : ABI_MALLOC(mat1, (2, nband_k, nband_k))
- + + - -
+ + - ]
5807 [ + + + + : 118540 : mat1=zero
+ + ]
5808 : :
5809 [ + + ]: 5404 : enlx_k(1:nband_k)=zero
5810 : :
5811 [ + + ]: 612 : if (istwf_k==1) then
5812 : 536 : call zhemm('l','l',nband_k,nband_k,cone,totvnlx,nband_k,evec,nband_k,czero,mat1,nband_k)
5813 [ + + ]: 4732 : do iband=1,nband_k
5814 : 4732 : enlx_k(iband)= cg_real_zdotc(nband_k,evec(:,iband),mat1(:,:,iband))
5815 : : end do
5816 : :
5817 [ + - ]: 76 : else if (istwf_k==2) then
5818 [ - + + - : 304 : ABI_MALLOC(evec_loc,(nband_k,nband_k))
- + + - +
- + - - +
- + ]
5819 [ - + + - : 228 : ABI_MALLOC(mat_loc,(nband_k,nband_k))
- + + - -
+ + - ]
5820 [ + + ]: 672 : do iband=1,nband_k
5821 [ + + ]: 5368 : do jj=1,nband_k
5822 : 5292 : evec_loc(iband,jj)=evec(2*iband-1,jj)
5823 : : end do
5824 : : end do
5825 : 76 : call dsymm('l','l',nband_k,nband_k,one,totvnlx,nband_k,evec_loc,nband_k,zero,mat_loc,nband_k)
5826 [ + + ]: 672 : do iband=1,nband_k
5827 : 672 : enlx_k(iband)=ddot(nband_k,evec_loc(:,iband),1,mat_loc(:,iband),1)
5828 : : end do
5829 [ - + ]: 76 : ABI_FREE(evec_loc)
5830 [ - + ]: 76 : ABI_FREE(mat_loc)
5831 : : end if
5832 : :
5833 [ - + ]: 612 : ABI_FREE(matvnl)
5834 [ - + ]: 612 : ABI_FREE(mat1)
5835 : :
5836 : 612 : end subroutine cg_hrotate_and_get_diag
5837 : : !!***
5838 : :
5839 : : !!****f* m_cgtools/cg_get_eigens
5840 : : !! NAME
5841 : : !! cg_get_eigens
5842 : : !!
5843 : : !! FUNCTION
5844 : : !! Helper functions to compute <i|H|i> / <i|S|i> for ndat states.
5845 : : !! Assume normalized input wavefunctions.
5846 : : !!
5847 : : !! INPUTS
5848 : : !!
5849 : : !! OUTPUT
5850 : : !!
5851 : : !! SOURCE
5852 : :
5853 : 2758 : subroutine cg_get_eigens(usepaw, istwf_k, npwsp, ndat, cg, ghc, gsc, eig, me_g0, comm)
5854 : :
5855 : : integer,intent(in) :: usepaw, istwf_k, npwsp, ndat, me_g0, comm
5856 : : real(dp),intent(in) :: ghc(2*npwsp, ndat), cg(2*npwsp, ndat), gsc(2*npwsp, ndat*usepaw)
5857 : : real(dp),intent(out) :: eig(ndat)
5858 : :
5859 : : !Local variables-------------------------------
5860 : : integer,parameter :: option1 = 1
5861 : : integer :: idat, ierr
5862 : 5516 : real(dp) :: doti, dots_r(ndat)
5863 : : ! *************************************************************************
5864 : :
5865 : : ! <psi|H|psi> / <psi|S|psi>
5866 : : !$OMP PARALLEL DO IF (ndat > 1)
5867 [ + + ]: 40790 : do idat=1,ndat
5868 : 38032 : call dotprod_g(eig(idat), doti, istwf_k, npwsp, option1, ghc(:,idat), cg(:,idat), me_g0, xmpi_comm_self)
5869 [ + + ]: 40790 : if (usepaw == 1) then
5870 : 7640 : call dotprod_g(dots_r(idat), doti, istwf_k, npwsp, option1, gsc(:,idat), cg(:,idat), me_g0, xmpi_comm_self)
5871 : : end if
5872 : : end do
5873 : :
5874 [ + + ]: 2758 : if (xmpi_comm_size(comm) > 1) then
5875 : 1548 : call xmpi_sum(eig, comm, ierr)
5876 [ + + ]: 1548 : if (usepaw == 1) call xmpi_sum(dots_r, comm, ierr)
5877 : : end if
5878 : :
5879 [ + + + + ]: 11389 : if (usepaw == 1) eig(:) = eig(:) / dots_r(:)
5880 : :
5881 : 2758 : end subroutine cg_get_eigens
5882 : : !!***
5883 : :
5884 : : !!****f* m_cgtools/cg_get_residvecs
5885 : : !! NAME
5886 : : !! cg_get_residvecs
5887 : : !!
5888 : : !! FUNCTION
5889 : : !! Compute residual vectors (H - eS) |psi> for ndat states.
5890 : : !!
5891 : : !! INPUTS
5892 : : !!
5893 : : !! OUTPUT
5894 : : !!
5895 : : !! SOURCE
5896 : :
5897 : 4496 : subroutine cg_get_residvecs(usepaw, npwsp, ndat, eig, cg, ghc, gsc, residvecs)
5898 : :
5899 : : integer,intent(in) :: usepaw, npwsp, ndat
5900 : : real(dp),intent(in) :: eig(ndat)
5901 : : real(dp),intent(in) :: ghc(2*npwsp, ndat), cg(2*npwsp, ndat), gsc(2*npwsp, ndat*usepaw)
5902 : : real(dp),intent(out) :: residvecs(2*npwsp, ndat)
5903 : :
5904 : : !Local variables-------------------------------
5905 : : integer :: idat
5906 : : ! *************************************************************************
5907 : :
5908 [ + + ]: 4496 : if (usepaw == 1) then
5909 : : ! (H - e) |psi>
5910 : : !$OMP PARALLEL DO IF (ndat > 1)
5911 [ + + ]: 13047 : do idat=1,ndat
5912 [ + + ]: 7426151 : residvecs(:,idat) = ghc(:,idat) - eig(idat) * gsc(:,idat)
5913 : : end do
5914 : : else
5915 : : ! (H - eS) |psi>
5916 : : !$OMP PARALLEL DO IF (ndat > 1)
5917 [ + + ]: 54073 : do idat=1,ndat
5918 [ + + ]: 126221017 : residvecs(:,idat) = ghc(:,idat) - eig(idat) * cg(:,idat)
5919 : : end do
5920 : : end if
5921 : :
5922 : 4496 : end subroutine cg_get_residvecs
5923 : : !!***
5924 : :
5925 : : !!****f* m_cgtools/cg_norm2g
5926 : : !! NAME
5927 : : !! cg_norm2g
5928 : : !!
5929 : : !! FUNCTION
5930 : : !! Compute <psi|psi> for ndat states distributed inside communicator comm.
5931 : : !!
5932 : : !! INPUTS
5933 : : !!
5934 : : !! OUTPUT
5935 : : !!
5936 : : !! SOURCE
5937 : :
5938 : 4496 : subroutine cg_norm2g(istwf_k, npwsp, ndat, cg, norms, me_g0, comm)
5939 : :
5940 : : integer,intent(in) :: istwf_k, npwsp, ndat, me_g0, comm
5941 : : real(dp),intent(in) :: cg(2*npwsp, ndat)
5942 : : real(dp),intent(out) :: norms(ndat)
5943 : :
5944 : : !Local variables-------------------------------
5945 : : integer :: idat, ierr
5946 : : ! *************************************************************************
5947 : :
5948 : : !$OMP PARALLEL DO IF (ndat > 1)
5949 [ + + ]: 67120 : do idat=1,ndat
5950 : 67120 : call sqnorm_g(norms(idat), istwf_k, npwsp, cg(:,idat), me_g0, xmpi_comm_self)
5951 : : end do
5952 [ + + ]: 4496 : if (xmpi_comm_size(comm) > 1) call xmpi_sum(norms, comm, ierr)
5953 : :
5954 : 4496 : end subroutine cg_norm2g
5955 : : !!***
5956 : :
5957 : : !!****f* m_cgtools/cg_zdotg_zip
5958 : : !! NAME
5959 : : !! cg_zdotg_zip
5960 : : !!
5961 : : !! FUNCTION
5962 : : !! Compute <cg1|cg2> for ndat states
5963 : : !!
5964 : : !! INPUTS
5965 : : !!
5966 : : !! OUTPUT
5967 : : !!
5968 : : !! SOURCE
5969 : :
5970 : 2575 : subroutine cg_zdotg_zip(istwf_k, npwsp, ndat, option, cg1, cg2, dots, me_g0, comm)
5971 : :
5972 : : integer,intent(in) :: istwf_k, npwsp, ndat, option, me_g0, comm
5973 : : real(dp),intent(in) :: cg1(2*npwsp,ndat), cg2(2*npwsp,ndat)
5974 : : real(dp),intent(out) :: dots(2,ndat)
5975 : :
5976 : : !Local variables-------------------------------
5977 : : integer :: idat, ierr
5978 : 5150 : real(dp) :: dotr, doti, re_dots(ndat)
5979 : : ! *************************************************************************
5980 : :
5981 : : !$OMP PARALLEL DO IF (ndat > 1) PRIVATE(dotr, doti)
5982 [ + + ]: 51143 : do idat=1,ndat
5983 : 48568 : call dotprod_g(dotr, doti, istwf_k, npwsp, option, cg1(:,idat), cg2(:,idat), me_g0, xmpi_comm_self)
5984 [ + + ]: 51143 : if (istwf_k == 2) then
5985 : 14096 : re_dots(idat) = dotr
5986 : : else
5987 [ + + ]: 103416 : dots(:, idat) = [dotr, doti]
5988 : : end if
5989 : : end do
5990 : :
5991 [ + + ]: 2575 : if (xmpi_comm_size(comm) > 1) then
5992 [ + + ]: 1660 : if (istwf_k == 2) then
5993 : 476 : call xmpi_sum(re_dots, comm, ierr)
5994 : : else
5995 : 1184 : call xmpi_sum(dots, comm, ierr)
5996 : : end if
5997 : : end if
5998 : :
5999 [ + + ]: 2575 : if (istwf_k == 2) then
6000 [ + + ]: 14648 : do idat=1,ndat
6001 : 14096 : dots(1,idat) = re_dots(idat)
6002 : 14648 : dots(2,idat) = zero
6003 : : end do
6004 : : end if
6005 : :
6006 : 2575 : end subroutine cg_zdotg_zip
6007 : : !!***
6008 : :
6009 : : !!****f* m_cgtools/cg_precon_many
6010 : : !! NAME
6011 : : !! cg_precon_many
6012 : : !!
6013 : : !! FUNCTION
6014 : : !!
6015 : : !! INPUTS
6016 : : !!
6017 : : !! OUTPUT
6018 : : !!
6019 : : !! SOURCE
6020 : :
6021 : 2454 : subroutine cg_precon_many(istwf_k, npw, nspinor, ndat, cg, optekin, kinpw, vect, me_g0, comm)
6022 : :
6023 : : integer,intent(in) :: istwf_k, npw, nspinor, optekin, ndat, me_g0, comm
6024 : : real(dp),intent(in) :: cg(2*npw*nspinor,ndat), kinpw(npw)
6025 : : real(dp),intent(inout) :: vect(2*npw*nspinor,ndat)
6026 : :
6027 : : !Local variables-------------------------------
6028 : : integer :: idat
6029 : 2454 : real(dp),allocatable :: pcon(:)
6030 : : ! *************************************************************************
6031 : :
6032 : : ! TODO: Optimized version for MPI with ndat > 1
6033 [ - + + - : 7362 : ABI_MALLOC(pcon, (npw))
+ - + - -
+ + - ]
6034 : :
6035 : : !$OMP PARALLEL DO IF (ndat > 1)
6036 [ + + ]: 38150 : do idat=1,ndat
6037 : 38150 : call cg_precon(cg(:,idat), zero, istwf_k, kinpw, npw, nspinor, me_g0, optekin, pcon, vect(:,idat), comm)
6038 : : end do
6039 [ - + ]: 2454 : ABI_FREE(pcon)
6040 : :
6041 : : !call cg_kinene(istwf_k, npw, nspinor, ndat, cg, me_g0, comm)
6042 : : !call cg_zprecon_block(cg,eval,blocksize,iterationnumber,kinpw, npw,nspinor,optekin,optpcon,pcon,ghc,vect,vectsize,comm)
6043 : :
6044 : 2454 : end subroutine cg_precon_many
6045 : : !!***
6046 : :
6047 : : !----------------------------------------------------------------------
6048 : :
6049 : : !!****f* m_cgtools/cg_zaxpy_many_areal
6050 : : !! NAME
6051 : : !! cg_zaxpy_many_areal
6052 : : !!
6053 : : !! FUNCTION
6054 : : !! Computes y = alpha*x + y
6055 : : !!
6056 : : !! INPUTS
6057 : : !! n = Specifies the number of elements in vectors x and y.
6058 : : !! ndat
6059 : : !! alpha(ndat) = Specifies the scalar alpha.
6060 : : !! x = Array
6061 : : !!
6062 : : !! SIDE EFFECTS
6063 : : !! y = Array. In output, y contains the updated vector.
6064 : : !!
6065 : : !! SOURCE
6066 : :
6067 : 1561 : subroutine cg_zaxpy_many_areal(npwsp, ndat, alphas, x, y)
6068 : :
6069 : : !Arguments ------------------------------------
6070 : : !scalars
6071 : : integer,intent(in) :: npwsp, ndat
6072 : : real(dp),intent(in) :: alphas(ndat)
6073 : : !arrays
6074 : : real(dp),intent(in) :: x(2*npwsp, ndat)
6075 : : real(dp),intent(inout) :: y(2*npwsp, ndat)
6076 : :
6077 : : !Local variables-------------------------------
6078 : : integer :: idat
6079 : : ! *************************************************************************
6080 : :
6081 : : !$OMP PARALLEL DO IF (ndat > 1)
6082 [ + + ]: 24769 : do idat=1,ndat
6083 : 24769 : call daxpy(2*npwsp, alphas(idat), x(1,idat), 1, y(1,idat), 1)
6084 : : end do
6085 : :
6086 : 1561 : end subroutine cg_zaxpy_many_areal
6087 : : !!***
6088 : :
6089 : : !----------------------------------------------------------------------
6090 : :
6091 : : !!****f* m_cgtools/cg_set_imag0_to_zero
6092 : : !! NAME
6093 : : !! cg_set_imag0_to_zero
6094 : : !!
6095 : : !! FUNCTION
6096 : : !! Set the imaginary part at G=0 to zero if istwfk == 2 and this proc has the gamma point
6097 : : !!
6098 : : !! INPUTS
6099 : : !! npwsp=Size of each vector (usually npw*nspinor)
6100 : : !! istwfk=Storage mode for the wavefunctions. 1 for standard full mode
6101 : : !! me_g0=1 if this node has G=0.
6102 : : !!
6103 : : !! SIDE EFFECTS
6104 : : !! cg(2*npwsp*nband)
6105 : : !! input: Input set of vectors.
6106 : : !! output: Orthonormalized set.
6107 : : !!
6108 : : !! SOURCE
6109 : :
6110 : 0 : pure subroutine cg_set_imag0_to_zero(istwfk, me_g0, npwsp, nband, cg, max_absimag)
6111 : :
6112 : : !Arguments ------------------------------------
6113 : : !scalars
6114 : : integer,intent(in) :: istwfk, me_g0, npwsp, nband
6115 : : !arrays
6116 : : real(dp),intent(inout) :: cg(2,npwsp*nband)
6117 : : real(dp),intent(out) :: max_absimag
6118 : :
6119 : : !Local variables ------------------------------
6120 : : integer :: ib, ii
6121 : : ! *************************************************************************
6122 : :
6123 : 0 : max_absimag = zero
6124 [ # # # # ]: 0 : if (istwfk == 2 .and. me_g0 == 1) then
6125 [ # # ]: 0 : do ib=1,nband
6126 : 0 : ii = 1 + (ib - 1) * npwsp
6127 : 0 : max_absimag = max(max_absimag, abs(cg(2, ii)))
6128 : 0 : cg(2, ii) = zero
6129 : : end do
6130 : : end if
6131 : :
6132 : 0 : end subroutine cg_set_imag0_to_zero
6133 : : !!***
6134 : :
6135 : : !----------------------------------------------------------------------
6136 : :
6137 : : !!****f* m_cgtools/cg_randomize
6138 : : !! NAME
6139 : : !! cg_randomize
6140 : : !!
6141 : : !! FUNCTION
6142 : : !! Initialize block of wavefunctions with random numbers. See wfconv
6143 : : !!
6144 : : !! INPUTS
6145 : : !!
6146 : : !! SOURCE
6147 : :
6148 : 44 : subroutine cg_randomize(istwf_k, npw_k, nspinor, nband_k, me_g0, cg_k)
6149 : :
6150 : : !Arguments ------------------------------------
6151 : : !scalars
6152 : : integer,intent(in) :: istwf_k, npw_k, nspinor, nband_k, me_g0
6153 : : !arrays
6154 : : real(dp),intent(inout) :: cg_k(2,npw_k*nspinor,nband_k)
6155 : :
6156 : : !Local variables ------------------------------
6157 : : integer :: ipw, ispinor, index
6158 : : integer, parameter :: int64 = selected_int_kind(18)
6159 : : integer(KIND=int64) :: seed
6160 : : integer :: fold1,fold2,foldim,foldre,iband
6161 : : ! *************************************************************************
6162 : :
6163 [ + + ]: 836 : do iband=1,nband_k
6164 : : index = 0
6165 [ + + ]: 1628 : do ispinor=1,nspinor
6166 [ + + ]: 1017378 : do ipw=1,npw_k
6167 : 1015794 : index=index+1
6168 : 1015794 : seed=(iband-1)*npw_k*nspinor + (ispinor-1)*npw_k + ipw
6169 : :
6170 : : ! For portability, use only integer numbers
6171 : : ! The series of couples (fold1,fold2) is periodic with a period of
6172 : : ! 3x5x7x11x13x17x19x23x29x31, that is, larger than 2**32, the largest integer*4
6173 : : ! fold1 is between 0 and 34, fold2 is between 0 and 114. As sums of five
6174 : : ! uniform random variables, their distribution is close to a gaussian
6175 : 1015794 : fold1=modulo(seed,3)+modulo(seed,5)+modulo(seed,7)+modulo(seed,11)+modulo(seed,13)
6176 : 1015794 : fold2=modulo(seed,17)+modulo(seed,19)+modulo(seed,23)+modulo(seed,29)+modulo(seed,31)
6177 : :
6178 : : ! The gaussian distributions are folded, in order to be back to a uniform distribution
6179 : : ! foldre is between 0 and 20, foldim is between 0 and 18
6180 : 1015794 : foldre=mod(fold1+fold2,21)
6181 : 1015794 : foldim=mod(3*fold1+2*fold2,19)
6182 : :
6183 : 1015794 : cg_k(1,index,iband) = dble(foldre)
6184 : 1015794 : cg_k(2,index,iband) = dble(foldim)
6185 : :
6186 : : ! XG030513: Time-reversal symmetry for k=gamma imposes zero imaginary part at G=0
6187 : : ! XG: I do not know what happens for spin-orbit here.
6188 [ - + - - ]: 1016586 : if (istwf_k == 2 .and. me_g0 == 1) cg_k(2,1,iband)=zero
6189 : : end do ! ipw
6190 : : end do ! ispinor
6191 : : end do ! iband
6192 : :
6193 : 44 : end subroutine cg_randomize
6194 : : !!***
6195 : :
6196 : : !----------------------------------------------------------------------
6197 : :
6198 : : !!****f* m_cgtools/cg_copy_spin
6199 : : !! NAME
6200 : : !! cg_copy_spin
6201 : : !!
6202 : : !! FUNCTION
6203 : : !!
6204 : : !! INPUTS
6205 : : !!
6206 : : !! SOURCE
6207 : :
6208 : 414326 : subroutine cg_copy_spin(spin, npw_k, nspinor, ndat, in_cg, out_cg)
6209 : :
6210 : : !Arguments ------------------------------------
6211 : : !scalars
6212 : : integer,intent(in) :: spin, npw_k, nspinor, ndat
6213 : : !arrays
6214 : : real(dp),intent(inout) :: in_cg(2,npw_k,nspinor,ndat)
6215 : : real(dp),intent(out) :: out_cg(2,npw_k,ndat)
6216 : :
6217 : : !Local variables ------------------------------
6218 : : integer :: idat
6219 : : ! *************************************************************************
6220 : :
6221 : : !$OMP PARALLEL DO IF (ndat > 1)
6222 [ + + ]: 828652 : do idat=1,ndat
6223 [ + + + + ]: 445960666 : out_cg(:,:,idat) = in_cg(:,:,spin,idat)
6224 : : end do
6225 : :
6226 : 414326 : end subroutine cg_copy_spin
6227 : : !!***
6228 : :
6229 : : !----------------------------------------------------------------------
6230 : :
6231 : : !!****f* m_cgtools/cg_put_spin
6232 : : !! NAME
6233 : : !! cg_put_spin
6234 : : !!
6235 : : !! FUNCTION
6236 : : !!
6237 : : !! INPUTS
6238 : : !!
6239 : : !! SOURCE
6240 : :
6241 : 409292 : subroutine cg_put_spin(spin, npw_k, nspinor, ndat, in_cg, out_cg)
6242 : :
6243 : : !Arguments ------------------------------------
6244 : : !scalars
6245 : : integer,intent(in) :: spin, npw_k, nspinor, ndat
6246 : : !arrays
6247 : : real(dp),intent(inout) :: in_cg(2,npw_k,ndat)
6248 : : real(dp),intent(out) :: out_cg(2,npw_k,nspinor,ndat)
6249 : :
6250 : : !Local variables ------------------------------
6251 : : integer :: idat
6252 : : ! *************************************************************************
6253 : :
6254 : : !$OMP PARALLEL DO IF (ndat > 1)
6255 [ + + ]: 818584 : do idat=1,ndat
6256 [ + + + + ]: 440089102 : out_cg(:,:,spin, idat) = in_cg(:,:,idat)
6257 : : end do
6258 : :
6259 : 409292 : end subroutine cg_put_spin
6260 : : !!***
6261 : :
6262 : : !----------------------------------------------------------------------
6263 : :
6264 : : !!****f* m_cgtools/cg_p_psi
6265 : : !! NAME
6266 : : !! cg_g_psi
6267 : : !!
6268 : : !! FUNCTION
6269 : : !! Compute <g|-i\Nabla |psi_nk>.
6270 : : !!
6271 : : !! INPUTS
6272 : : !!
6273 : : !! SOURCE
6274 : :
6275 : 0 : subroutine cg_p_psi(npw_k, nspinor, ndat, kk, kg_k, cg_k, p_cg_k)
6276 : :
6277 : : !Arguments ------------------------------------
6278 : : !scalars
6279 : : integer,intent(in) :: npw_k, nspinor, ndat
6280 : : !arrays
6281 : : real(dp),intent(in) :: kk(3)
6282 : : integer,intent(in) :: kg_k(3,npw_k)
6283 : : real(dp),intent(in) :: cg_k(2,npw_k*nspinor,ndat)
6284 : : real(dp),intent(out) :: p_cg_k(2,npw_k*nspinor,ndat,3)
6285 : :
6286 : : !Local variables ------------------------------
6287 : : integer :: idir, ig, ispinor, idat, spad, ipwsp
6288 : : ! *************************************************************************
6289 : :
6290 : : !$OMP PARALLEL DO COLLAPSE(2) PRIVATE(spad, ipwsp)
6291 [ # # ]: 0 : do idir=1,3
6292 [ # # ]: 0 : do idat=1,ndat
6293 [ # # ]: 0 : do ispinor=1,nspinor
6294 : 0 : spad = (ispinor - 1) * npw_k
6295 [ # # ]: 0 : do ig=1,npw_k
6296 : 0 : ipwsp = ig + spad
6297 [ # # ]: 0 : p_cg_k(:, ipwsp, idat, idir) = cg_k(:, ipwsp, idat) * (kg_k(idir, ig) + kk(idir))
6298 : : end do ! ig
6299 : : end do ! ispinor
6300 : : end do ! idir
6301 : : end do ! idat
6302 : :
6303 : 0 : end subroutine cg_p_psi
6304 : : !!**
6305 : :
6306 : : end module m_cgtools
6307 : : !!***
|
