Branch data 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,protected :: x_cplx ! fortran data type for wave functions arrays real or complex.
39 : : integer,save,public,protected :: x_me_g0 ! processor number
40 : : integer,save,public,protected :: x_npw_k ! number of plane waves at this k point
41 : : integer,save,public,protected :: x_nspinor! number of spinorial components of the wavefunctions on current proc
42 : : integer,save,public,protected :: x_icg ! shift to be applied on the location of data in the array cg
43 : : integer,save,public,protected :: x_igsc ! shift to be applied on the location of data in the array gsc
44 : : integer,save,public,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 : : !!***
|
