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 : !!***
|
