Branch data Line data Source code
1 : : !!****m* ABINIT/m_gwls_LanczosBasis
2 : : !! NAME
3 : : !! m_gwls_LanczosBasis
4 : : !!
5 : : !! FUNCTION
6 : : !! .
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2009-2026 ABINIT group (JLJ, BR, MC)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !!
14 : : !! SOURCE
15 : :
16 : : #if defined HAVE_CONFIG_H
17 : : #include "config.h"
18 : : #endif
19 : :
20 : : #include "abi_common.h"
21 : :
22 : :
23 : : module m_gwls_LanczosBasis
24 : : !----------------------------------------------------------------------------------------------------
25 : : ! This module contains the static Lanczos basis, which should be computed once and for all,
26 : : ! and then be made available to other modules.
27 : : !----------------------------------------------------------------------------------------------------
28 : : ! local modules
29 : : use m_gwls_utility
30 : : use m_gwls_wf
31 : : use m_gwls_hamiltonian
32 : : use m_gwls_GenerateEpsilon
33 : : use m_dtset
34 : :
35 : : ! Abinit modules
36 : : use defs_basis
37 : : use m_abicore
38 : :
39 : : implicit none
40 : : save
41 : : private
42 : : !!***
43 : :
44 : : ! Global arrays
45 : :
46 : : ! basis which diagonalizes the static dielectric matrix
47 : : complex(dp), public, allocatable :: Lbasis_lanczos(:,:) ! complex array which contains the Lanczos basis
48 : :
49 : : ! basis which diagonalizes the model static dielectric matrix
50 : : complex(dp), public, allocatable :: Lbasis_model_lanczos(:,:) ! complex array which contains the Lanczos basis
51 : :
52 : :
53 : : !------------------------------------------------------------
54 : : !
55 : : ! OBSOLETE STRUCTURES, KEPT AROUND TO NOT BREAK THE CODE
56 : : ! Some cleaning will eventually have to be done!
57 : : !
58 : : !------------------------------------------------------------
59 : : ! Lanczos basis which puts the static dielectric matrix in bands (OBSOLETE)
60 : : real(dp), public, allocatable :: lanczos_basis_0(:,:,:,:)
61 : :
62 : : ! modified basis, of the form (V^{1/2}. l^*) psie (OBSOLETE)
63 : : real(dp), public, allocatable :: basis_0(:,:,:,:)
64 : :
65 : :
66 : : ! modified basis, of the form (V^{1/2}. l^*) psie
67 : : complex(dp), public, allocatable :: Lbasis_modified(:,:)
68 : :
69 : :
70 : : integer, public :: lanczos_basis_size
71 : : !!***
72 : :
73 : : public :: setup_Lanczos_basis
74 : : public :: cleanup_Lanczos_basis
75 : : public :: modify_Lbasis_Coulomb
76 : : !!***
77 : : contains
78 : :
79 : : !!****f* m_hamiltonian/setup_Lanczos_basis
80 : : !! NAME
81 : : !! setup_Lanczos_basis
82 : : !!
83 : : !! FUNCTION
84 : : !! .
85 : : !!
86 : : !! INPUTS
87 : : !!
88 : : !! OUTPUT
89 : : !!
90 : : !! SOURCE
91 : :
92 : 7 : subroutine setup_Lanczos_basis(lmax,lmax_model)
93 : : !----------------------------------------------------------------------------------------------------
94 : : ! Set up the lanczos basis
95 : : !----------------------------------------------------------------------------------------------------
96 : :
97 : : integer, intent(in) :: lmax, lmax_model
98 : :
99 : : ! *************************************************************************
100 : :
101 [ - + + - : 28 : ABI_MALLOC(Lbasis_lanczos,(npw_k,lmax))
- + + - +
- + - - +
- + - + ]
102 : :
103 [ + + ]: 7 : if (lmax_model > 0) then
104 [ - + + - : 24 : ABI_MALLOC(Lbasis_model_lanczos,(npw_k,lmax_model))
- + + - +
- + - - +
- + - + ]
105 : : end if
106 : :
107 : 7 : end subroutine setup_Lanczos_basis
108 : : !!***
109 : :
110 : : !!****f* m_hamiltonian/cleanup_Lanczos_basis
111 : : !! NAME
112 : : !! cleanup_Lanczos_basis
113 : : !!
114 : : !! FUNCTION
115 : : !! .
116 : : !!
117 : : !! INPUTS
118 : : !!
119 : : !! OUTPUT
120 : : !!
121 : : !! SOURCE
122 : :
123 : 7 : subroutine cleanup_Lanczos_basis()
124 : :
125 : :
126 : : ! *************************************************************************
127 : :
128 : : ! if(allocated()) ABI_FREE() can cause a segfault if used in this form, without the THEN.
129 : : ! This is because ABI_MALLOC is expanded at compilation time in many statements; and the if() can only prevent the execution of
130 : : ! the first.
131 : : ! So, the deallocation takes place even if allocated() returns .false. without the THEN.
132 [ + - ]: 7 : if (allocated(Lbasis_lanczos)) then
133 : 7 : ABI_FREE(Lbasis_lanczos)
134 : : end if
135 [ + + ]: 7 : if (allocated(Lbasis_model_lanczos)) then
136 : 6 : ABI_FREE(Lbasis_model_lanczos)
137 : : end if
138 : :
139 : 7 : end subroutine cleanup_Lanczos_basis
140 : : !!***
141 : :
142 : : !!****f* m_hamiltonian/modify_Lbasis_Coulomb
143 : : !! NAME
144 : : !! modify_Lbasis_Coulomb
145 : : !!
146 : : !! FUNCTION
147 : : !! .
148 : : !!
149 : : !! INPUTS
150 : : !!
151 : : !! OUTPUT
152 : : !!
153 : : !! SOURCE
154 : :
155 : 7 : subroutine modify_Lbasis_Coulomb(psie_k, lmax, lmax_model)
156 : : !----------------------------------------------------------------------------------------------------
157 : : ! This subroutine computes, once and for all, the vectors (V^1/2.L)^*.psie
158 : : !----------------------------------------------------------------------------------------------------
159 : : real(dp),intent(in) :: psie_k(2,npw_k)
160 : : integer ,intent(in) :: lmax, lmax_model
161 : :
162 : :
163 : 7 : real(dp), allocatable :: psik_wrk(:,:), psikb_wrk(:,:), psikg_wrk(:,:)
164 : 7 : real(dp), allocatable :: psikg_e(:,:)
165 : :
166 : : integer :: iblk_lanczos, nbdblock_lanczos
167 : :
168 : : integer :: l, mb
169 : :
170 : : ! *************************************************************************
171 : :
172 [ - + + - : 21 : ABI_MALLOC(psik_wrk ,(2,npw_k))
+ - + - -
+ - + ]
173 [ - + + - : 21 : ABI_MALLOC(psikb_wrk ,(2,npw_kb))
+ - + - -
+ - + ]
174 [ - + + - : 21 : ABI_MALLOC(psikg_wrk ,(2,npw_g))
+ - + - -
+ - + ]
175 [ - + + - : 14 : ABI_MALLOC(psikg_e ,(2,npw_g))
- + - + ]
176 : :
177 : : ! copy the valence state on every row of FFT processors
178 [ + + ]: 18 : do mb = 1, blocksize
179 [ + + + + ]: 3873 : psikb_wrk(:,(mb-1)*npw_k+1:mb*npw_k) = psie_k(:,:)
180 : : end do ! mb
181 : : ! Transform to FFT representation
182 : 7 : call wf_block_distribute(psikb_wrk, psikg_e,1) ! LA -> FFT
183 : :
184 : :
185 : : ! Number of blocks of lanczos vectors
186 : 7 : nbdblock_lanczos = lmax/blocksize
187 [ - + ]: 7 : if (modulo(lmax,blocksize) /= 0) nbdblock_lanczos = nbdblock_lanczos + 1
188 : :
189 : : ! loop on all blocks of lanczos vectors
190 [ + + ]: 47 : do iblk_lanczos = 1, nbdblock_lanczos
191 : :
192 : : ! loop on all states within this block
193 [ + + ]: 96 : do mb = 1, blocksize
194 : : ! Determine the index of the Lanczos vector
195 : 56 : l = (iblk_lanczos-1)*blocksize + mb
196 : :
197 [ - + ]: 56 : if ( l <= lmax) then
198 [ + + ]: 8280 : psik_wrk(1,:) = dble (Lbasis_lanczos(:,l))
199 [ + + ]: 8280 : psik_wrk(2,:) = dimag(Lbasis_lanczos(:,l))
200 : : else
201 [ # # # # ]: 0 : psik_wrk(:,:) = zero
202 : : end if
203 : : ! Apply coulomb potential
204 : 56 : call sqrt_vc_k(psik_wrk)
205 : :
206 : : ! Store in array of blocks of wavefunctions
207 [ + + + + ]: 24768 : psikb_wrk(:,(mb-1)*npw_k+1:mb*npw_k) = psik_wrk(:,:)
208 : :
209 : : end do ! mb
210 : :
211 : : ! Transform to FFT representation
212 : 40 : call wf_block_distribute(psikb_wrk, psikg_wrk,1) ! LA -> FFT
213 : :
214 : : ! fourier transform, conjugate
215 : 40 : call g_to_r(psir1,psikg_wrk)
216 [ + + + + : 274360 : psir1(2,:,:,:) = -psir1(2,:,:,:)
+ + ]
217 : :
218 : : ! compute the product with the state "e"
219 : 40 : call gr_to_g(psikg_wrk, psir1, psikg_e)
220 : :
221 : : ! return to LA configuration
222 : :
223 : : ! Transform to LA representation
224 : 40 : call wf_block_distribute(psikb_wrk, psikg_wrk, 2) ! FFT -> LA
225 : :
226 [ + + ]: 103 : do mb = 1, blocksize
227 : : ! Determine the index of the Lanczos vector
228 : 56 : l = (iblk_lanczos-1)*blocksize + mb
229 : :
230 [ + - ]: 96 : if ( l <= lmax) then
231 [ + + + + ]: 24728 : psik_wrk(:,:) = psikb_wrk(:,(mb-1)*npw_k+1:mb*npw_k)
232 [ + + ]: 8280 : Lbasis_lanczos(:,l) = cmplx_1*psik_wrk(1,:)+cmplx_i*psik_wrk(2,:)
233 : : end if
234 : :
235 : : end do ! mb
236 : :
237 : : end do ! iblk_lanczos
238 : :
239 : : ! repeat, for model basis!
240 : : ! Number of blocks of lanczos vectors
241 : 7 : nbdblock_lanczos = lmax_model/blocksize
242 [ - + ]: 7 : if (modulo(lmax_model,blocksize) /= 0) nbdblock_lanczos = nbdblock_lanczos + 1
243 : :
244 : : ! loop on all blocks of lanczos vectors
245 [ + + ]: 39 : do iblk_lanczos = 1, nbdblock_lanczos
246 : :
247 : : ! loop on all states within this block
248 [ + + ]: 80 : do mb = 1, blocksize
249 : : ! Determine the index of the Lanczos vector
250 : 48 : l = (iblk_lanczos-1)*blocksize + mb
251 : :
252 [ - + ]: 48 : if ( l <= lmax_model) then
253 [ + + ]: 6216 : psik_wrk(1,:) = dble (Lbasis_model_lanczos(:,l))
254 [ + + ]: 6216 : psik_wrk(2,:) = dimag(Lbasis_model_lanczos(:,l))
255 : : else
256 [ # # # # ]: 0 : psik_wrk(:,:) = zero
257 : : end if
258 : : ! Apply coulomb potential
259 : 48 : call sqrt_vc_k(psik_wrk)
260 : :
261 : : ! Store in array of blocks of wavefunctions
262 [ + + + + ]: 18584 : psikb_wrk(:,(mb-1)*npw_k+1:mb*npw_k) = psik_wrk(:,:)
263 : :
264 : : end do ! mb
265 : :
266 : : ! Transform to FFT representation
267 : 32 : call wf_block_distribute(psikb_wrk, psikg_wrk,1) ! LA -> FFT
268 : :
269 : : ! fourier transform, conjugate
270 : 32 : call g_to_r(psir1,psikg_wrk)
271 [ + + + + : 219488 : psir1(2,:,:,:) = -psir1(2,:,:,:)
+ + ]
272 : :
273 : : ! compute the product with the state "e"
274 : 32 : call gr_to_g(psikg_wrk, psir1, psikg_e)
275 : :
276 : : ! return to LA configuration
277 : : ! Transform to LA representation
278 : 32 : call wf_block_distribute(psikb_wrk, psikg_wrk, 2) ! FFT -> LA
279 : :
280 [ + + ]: 87 : do mb = 1, blocksize
281 : : ! Determine the index of the Lanczos vector
282 : 48 : l = (iblk_lanczos-1)*blocksize + mb
283 : :
284 [ + - ]: 80 : if ( l <= lmax_model) then
285 [ + + + + ]: 18552 : psik_wrk(:,:) = psikb_wrk(:,(mb-1)*npw_k+1:mb*npw_k)
286 [ + + ]: 6216 : Lbasis_model_lanczos(:,l) = cmplx_1*psik_wrk(1,:)+cmplx_i*psik_wrk(2,:)
287 : : end if
288 : :
289 : : end do ! mb
290 : :
291 : : end do
292 : :
293 [ - + ]: 7 : ABI_FREE(psik_wrk )
294 [ - + ]: 7 : ABI_FREE(psikb_wrk )
295 [ - + ]: 7 : ABI_FREE(psikg_wrk )
296 [ - + ]: 7 : ABI_FREE(psikg_e )
297 : :
298 : :
299 : 7 : end subroutine modify_Lbasis_Coulomb
300 : : !!***
301 : :
302 : : end module m_gwls_LanczosBasis
303 : : !!***
|
