Line data Source code
1 : !!****m* ABINIT/m_wfutils
2 : !! NAME
3 : !! m_wfutils
4 : !!
5 : !! FUNCTION
6 : !! parameters and function for wave functions copy
7 : !!
8 : !! COPYRIGHT
9 : !! Copyright (C) 2001-2026 ABINIT group (CS,GZ,FB)
10 : !! This file is distributed under the terms of the
11 : !! GNU General Public License, see ~ABINIT/Infos/copyright
12 : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : !!
14 : !! SOURCE
15 :
16 : #if defined HAVE_CONFIG_H
17 : #include "config.h"
18 : #endif
19 :
20 : #include "abi_common.h"
21 :
22 : module m_wfutils
23 :
24 : use defs_basis
25 : use m_abicore
26 : use m_errors
27 :
28 : use m_time, only : timab
29 :
30 : implicit none
31 :
32 : private
33 :
34 : public :: setWFParameter ! Definition of wave functions parameters for copy functions.
35 : public :: wfcopy ! Copy of wave functions arrays.
36 :
37 : ! Global variables
38 : integer,save,public ABI_PROTECTED :: x_cplx ! fortran data type for wave functions arrays real or complex.
39 : integer,save,public ABI_PROTECTED :: x_me_g0 ! processor number
40 : integer,save,public ABI_PROTECTED :: x_npw_k ! number of plane waves at this k point
41 : integer,save,public ABI_PROTECTED :: x_nspinor! number of spinorial components of the wavefunctions on current proc
42 : integer,save,public ABI_PROTECTED :: x_icg ! shift to be applied on the location of data in the array cg
43 : integer,save,public ABI_PROTECTED :: x_igsc ! shift to be applied on the location of data in the array gsc
44 : integer,save,public ABI_PROTECTED :: x_blocksize
45 :
46 : contains
47 : !!***
48 :
49 : !!****f* m_wfutils/setWFParameter
50 : !! NAME
51 : !!
52 : !! setWFParameter
53 : !!
54 : !! FUNCTION
55 : !! Initialize wave functions parameters for copy functions
56 : !!
57 : !! INPUTS
58 : !! cplx=fortran data type for wave functions arrays real or complex
59 : !! me_g0=1 if this node treats G=0.
60 : !! npw_k=number of plane waves at this k point
61 : !! nspinor=number of spinorial components of the wavefunctions on current proc
62 : !! icg=shift to be applied on the location of data in the array cg
63 : !! igsc=shift to be applied on the location of data in the array gsc
64 : !! blocksize=size of blocks
65 : !!
66 : !! SOURCE
67 : !!
68 5636 : subroutine setWFParameter(cplx,me_g0,npw_k,nspinor,icg,igsc,blocksize)
69 :
70 : !Arguments ------------------------------------
71 : integer, intent(in) :: cplx,me_g0,npw_k,nspinor
72 : integer, intent(in) :: icg,igsc,blocksize
73 :
74 : ! *********************************************************************
75 :
76 : ! Copy values in global variables
77 5636 : x_cplx=cplx
78 5636 : x_me_g0=me_g0
79 5636 : x_npw_k=npw_k
80 5636 : x_nspinor=nspinor
81 5636 : x_icg=icg
82 5636 : x_igsc=igsc
83 5636 : x_blocksize=blocksize
84 :
85 5636 : end subroutine setWFParameter
86 : !!***
87 :
88 : ! correspondence with abinit. here for real wf
89 : ! this is the index of a given band in cg array
90 8343 : integer function x_cgindex(iblocksize)
91 :
92 : integer, intent(in) :: iblocksize
93 :
94 8343 : x_cgindex=x_npw_k*x_nspinor*(iblocksize-1)+x_icg+1
95 :
96 : end function x_cgindex
97 :
98 : ! correspondence with abinit. here for real wf
99 : ! this is the index of a given band in gsc array
100 2525 : integer function x_gscindex(iblocksize)
101 :
102 : integer, intent(in) :: iblocksize
103 :
104 2525 : x_gscindex=x_npw_k*x_nspinor*(iblocksize-1)+x_igsc+1
105 :
106 : end function x_gscindex
107 :
108 86506 : integer function x_windex(iblocksize)
109 :
110 : integer, intent(in) :: iblocksize
111 :
112 86506 : x_windex=x_npw_k*x_nspinor*(iblocksize-1)+1
113 :
114 : end function x_windex
115 :
116 97374 : integer function wfindex(iblocksize,indtype)
117 :
118 : integer, intent(in) :: iblocksize
119 : character(len=1), intent(in) :: indtype
120 :
121 8343 : select case(indtype)
122 : case ('C')
123 8343 : wfindex=x_cgindex(iblocksize)
124 : case ('S')
125 2525 : wfindex=x_gscindex(iblocksize)
126 : case ('W')
127 86506 : wfindex=x_windex(iblocksize)
128 : case default
129 97374 : ABI_ERROR("Wrong indtype: "//trim(indtype))
130 : end select
131 :
132 97374 : end function wfindex
133 :
134 : !!****f* m_wfutils/wfcopy
135 : !! NAME
136 : !!
137 : !! wfcopy
138 : !!
139 : !! FUNCTION
140 : !! copy of wave functions arrays.
141 : !! called from lobpcg in REAL or COMPLEX wave functions.
142 : !!
143 : !! INPUTS
144 : !! direction=copy direction
145 : !! 'D' direct (global array to local)
146 : !! 'I' indirect (local to global)
147 : !! size=number of elements
148 : !! tsrc=source array
149 : !! incsrc=size increment for tsrc array
150 : !! tdest=destination array
151 : !! incdest=increment for tdest array
152 : !! blockiter=number of block iteration in case REAL
153 : !! iblock=block index
154 : !! indtype=indexation type in array
155 : !! withbbloc=apply block on band for each block
156 : !!
157 : !! TODO
158 : !! Split the two cases so that we can avoid the array descriptors.
159 : !!
160 : !! SOURCE
161 : !!
162 126373 : subroutine wfcopy(direction,size,tsrc,incsrc,tdest,incdest,blockiter,iblock,indtype,&
163 : & withbbloc,timopt,tim_wfcopy) ! optional arguments
164 :
165 : !Arguments ------------------------------------
166 : character(len=1), intent(in) :: direction
167 : integer, intent(in) :: size,incsrc,incdest
168 : integer, intent(in) :: blockiter,iblock
169 : character(len=1), intent(in) :: indtype
170 : logical, optional, intent(in) :: withbbloc
171 : integer, intent(in), optional :: timopt,tim_wfcopy
172 : !arrays
173 : real(dp), DEV_CONTARRD intent(in) :: tsrc(:,:)
174 : real(dp), DEV_CONTARRD intent(inout) :: tdest(:,:)
175 :
176 : !Local variables ------------------------------------
177 : integer,parameter :: ndat1=1
178 : logical :: bblock=.false.
179 : integer :: lig,g1,g2,vectsize,rvectsize
180 : integer :: blocksize,bblocksize,iblocksize,iband
181 : real(dp) :: factor
182 : real(dp) :: tsec(2)
183 :
184 : ! *********************************************************************
185 :
186 126373 : if (present(tim_wfcopy).and.present(timopt)) then
187 126373 : if(abs(timopt)==3) then
188 0 : call timab(tim_wfcopy,1,tsec)
189 : end if
190 : end if
191 :
192 126373 : if (present(withbbloc)) bblock=withbbloc
193 :
194 126373 : if (indtype == 'C') then
195 14658 : lig=x_icg
196 111715 : else if (indtype == 'S') then
197 8062 : lig=x_igsc
198 : else
199 : lig=0
200 : endif
201 :
202 126373 : rvectsize=x_npw_k*x_nspinor
203 126373 : if (x_me_g0 == 1) then
204 47413 : vectsize=2*rvectsize-1
205 : else
206 78960 : vectsize=2*rvectsize
207 : endif
208 126373 : if (x_cplx == 2) vectsize=x_npw_k*x_nspinor
209 :
210 126373 : blocksize = x_blocksize
211 126373 : bblocksize=(iblock-1)*blocksize
212 :
213 126373 : if (direction == 'D') then
214 :
215 81382 : if (x_cplx == 1) then
216 : ! Pack real and imag part.
217 4555 : factor=sqrt(two)
218 28641 : do iblocksize=1,blockiter
219 24086 : iband=iblocksize
220 24086 : if (bblock) then
221 1422 : iband=iblocksize+bblocksize
222 : endif
223 28641 : if (x_me_g0 == 1) then
224 10862 : tdest(1 ,iblocksize)=tsrc(1,wfindex(iband,indtype))
225 10862 : g1 = wfindex(iband, indtype)+1
226 10862 : g2 = wfindex(iband+1,indtype)-1
227 815782 : call dcopy(rvectsize-1,tsrc(1,g1:g2),1,tdest(2:rvectsize,iblocksize),1)
228 413322 : tdest(2:rvectsize,iblocksize) = factor * tdest(2:rvectsize,iblocksize)
229 :
230 815782 : call dcopy(rvectsize-1,tsrc(2,g1:g2),1,tdest(rvectsize+1:vectsize,iblocksize),1)
231 413322 : tdest(rvectsize+1:vectsize,iblocksize) = factor * tdest(rvectsize+1:vectsize,iblocksize)
232 : ! MG FIXME: Here gfortran4.9 allocates temporary arrays due to factor.
233 : else
234 13224 : g1 = wfindex(iband, indtype)
235 13224 : g2 = wfindex(iband+1,indtype)-1
236 462840 : call dcopy(rvectsize,tsrc(1,g1:g2),1,tdest(1:rvectsize,iblocksize),1)
237 238032 : tdest(1:rvectsize,iblocksize) = factor * tdest(1:rvectsize,iblocksize)
238 :
239 462840 : call dcopy(rvectsize,tsrc(2,g1:g2),1,tdest(rvectsize+1:vectsize,iblocksize),1)
240 238032 : tdest(rvectsize+1:vectsize,iblocksize) = factor * tdest(rvectsize+1:vectsize,iblocksize)
241 : end if
242 : end do
243 : else
244 76827 : if (indtype == 'C') then
245 8670 : if (bblock) then
246 5369 : g1 = vectsize*((iblock-1)*blocksize)+lig+1
247 5369 : g2 = vectsize*(iblock*blocksize)+lig
248 5369 : call zcopy(size,tsrc(:,g1:g2),incsrc,tdest(:,1:blocksize),incdest)
249 : else
250 3301 : g1 = lig+1
251 3301 : g2 = vectsize*((iblock-1)*blocksize)+lig
252 3301 : call zcopy(size,tsrc(:,g1:g2),incsrc,tdest(:,1:bblocksize),incdest)
253 : end if
254 68157 : else if (indtype == 'S') then
255 3213 : g1 = lig+1
256 3213 : g2 = vectsize*((iblock-1)*blocksize)+lig
257 3213 : call zcopy(size,tsrc(:,g1:g2),incsrc,tdest(:,1:bblocksize),incdest)
258 : else
259 64944 : call zcopy(size,tsrc,incsrc,tdest,incdest)
260 : endif
261 : end if
262 :
263 44991 : else if (direction == 'I') then
264 44991 : if (x_cplx == 1) then
265 : ! Unpack real and imag blocks.
266 2485 : factor=one/sqrt(two)
267 15778 : do iblocksize=1,blockiter
268 13293 : iband=iblocksize
269 13293 : if ( bblock ) then
270 2156 : iband=iblocksize+(iblock-1)*blocksize
271 : end if
272 15778 : if (x_me_g0 == 1) then
273 5877 : tdest(1,wfindex(iband,indtype))=tsrc(1,iblocksize)
274 5877 : tdest(2,wfindex(iband,indtype))=zero
275 :
276 5877 : g1 = wfindex(iband,indtype)+1
277 5877 : g2 = wfindex(iband+1,indtype)-1
278 451377 : call dcopy(rvectsize-1,tsrc(2:rvectsize,iblocksize),1,tdest(1,g1:g2),1)
279 228627 : tdest(1,g1:g2) = factor * tdest(1,g1:g2)
280 :
281 451377 : call dcopy(rvectsize-1,tsrc(rvectsize+1:vectsize,iblocksize),1,tdest(2,g1:g2),1)
282 228627 : tdest(2,g1:g2) = factor * tdest(2,g1:g2)
283 : else
284 7416 : g1 = wfindex(iband,indtype)
285 7416 : g2 = wfindex(iband+1,indtype)-1
286 259560 : call dcopy(rvectsize,tsrc(1:rvectsize,iblocksize),1,tdest(1,g1:g2),1)
287 133488 : tdest(1,g1:g2) = factor * tdest(1,g1:g2)
288 259560 : call dcopy(rvectsize,tsrc(rvectsize+1:vectsize,iblocksize),1,tdest(2,g1:g2),1)
289 133488 : tdest(2,g1:g2) = factor * tdest(2,g1:g2)
290 : end if
291 : end do
292 : else
293 42506 : if (indtype == 'C') then
294 5369 : g1 = vectsize*((iblock-1)*blocksize)+lig+1
295 5369 : g2 = vectsize*(iblock*blocksize)+lig
296 5369 : call zcopy(size,tsrc,1,tdest(:,g1:g2),1)
297 37137 : else if ( indtype == 'S' ) then
298 4665 : g1 = vectsize*((iblock-1)*blocksize)+lig+1
299 4665 : g2 = vectsize*(iblock*blocksize)+lig
300 4665 : call zcopy(size,tsrc,1,tdest(:,g1:g2),1)
301 : else
302 32472 : call zcopy(size,tsrc,1,tdest,1)
303 : end if
304 : end if
305 : else
306 0 : ABI_ERROR("Wrong direction: "//trim(direction))
307 : endif
308 :
309 126373 : if (present(tim_wfcopy).and.present(timopt)) then
310 126373 : if(abs(timopt)==3) then
311 0 : call timab(tim_wfcopy,2,tsec)
312 : end if
313 : end if
314 :
315 126373 : end subroutine wfcopy
316 : !!***
317 :
318 : end module m_wfutils
319 : !!***
|
