(git:08825b9)
Loading...
Searching...
No Matches
pw_methods.F
Go to the documentation of this file.
1!--------------------------------------------------------------------------------------------------!
2! CP2K: A general program to perform molecular dynamics simulations !
3! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
8! **************************************************************************************************
9!> \note
10!> If parallel mode is distributed certain combination of
11!> "in_use" and "in_space" can not be used.
12!> For performance reasons it would be better to have the loops
13!> over g-vectors in the gather/scatter routines in new subprograms
14!> with the actual arrays (also the addressing) in the parameter list
15!> \par History
16!> JGH (29-Dec-2000) : Changes for parallel use
17!> JGH (13-Mar-2001) : added timing calls
18!> JGH (26-Feb-2003) : OpenMP enabled
19!> JGH (17-Nov-2007) : Removed mass arrays
20!> JGH (01-Dec-2007) : Removed and renamed routines
21!> JGH (04-Jul-2019) : added pw_multiply routine
22!> 03.2008 [tlaino] : Splitting pw_types into pw_types and pw_methods
23!> \author apsi
24! **************************************************************************************************
25MODULE pw_methods
26
27
28 USE cp_log_handling, ONLY: cp_logger_get_default_io_unit, &
29 cp_to_string
30 USE fft_tools, ONLY: bwfft, &
31 fwfft, &
32 fft3d
33 USE kahan_sum, ONLY: accurate_dot_product, &
34 accurate_sum
35 USE kinds, ONLY: dp
36 USE machine, ONLY: m_memory
37 USE mathconstants, ONLY: gaussi, &
38 z_zero
39 USE pw_copy_all, ONLY: pw_copy_match
40 USE pw_fpga, ONLY: pw_fpga_c1dr3d_3d_dp, &
41 pw_fpga_c1dr3d_3d_sp, &
42 pw_fpga_init_bitstream, &
43 pw_fpga_r3dc1d_3d_dp, &
44 pw_fpga_r3dc1d_3d_sp
45 USE pw_gpu, ONLY: pw_gpu_c1dr3d_3d, &
46 pw_gpu_c1dr3d_3d_ps, &
47 pw_gpu_r3dc1d_3d, &
48 pw_gpu_r3dc1d_3d_ps
49 USE pw_grid_types, ONLY: halfspace, &
50 pw_mode_distributed, &
51 pw_mode_local, &
52 pw_grid_type
53 USE pw_types, ONLY: pw_r1d_rs_type
54 USE pw_types, ONLY: pw_r3d_rs_type
55 USE pw_types, ONLY: pw_c1d_rs_type
56 USE pw_types, ONLY: pw_c3d_rs_type
57 USE pw_types, ONLY: pw_r1d_gs_type
58 USE pw_types, ONLY: pw_r3d_gs_type
59 USE pw_types, ONLY: pw_c1d_gs_type
60 USE pw_types, ONLY: pw_c3d_gs_type
61#include "../base/base_uses.f90"
62
63 IMPLICIT NONE
64
65 PRIVATE
66
67 PUBLIC :: pw_zero, pw_structure_factor, pw_smoothing
68 PUBLIC :: pw_copy, pw_axpy, pw_transfer, pw_scale
69 PUBLIC :: pw_gauss_damp, pw_compl_gauss_damp, pw_derive, pw_laplace, pw_dr2, pw_write, pw_multiply
70 PUBLIC :: pw_log_deriv_gauss, pw_log_deriv_compl_gauss, pw_log_deriv_mix_cl, pw_log_deriv_trunc
71 PUBLIC :: pw_gauss_damp_mix, pw_multiply_with
72 PUBLIC :: pw_integral_ab, pw_integral_a2b
73 PUBLIC :: pw_dr2_gg, pw_integrate_function
74 PUBLIC :: pw_set, pw_truncated
75 PUBLIC :: pw_scatter, pw_gather
76 PUBLIC :: pw_copy_to_array, pw_copy_from_array
77
78 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'pw_methods'
79 LOGICAL, PARAMETER, PRIVATE :: debug_this_module = .false.
80 INTEGER, PARAMETER, PUBLIC :: do_accurate_sum = 0, &
81 do_standard_sum = 1
82
83 INTERFACE pw_zero
84 MODULE PROCEDURE pw_zero_r1d_rs
85 MODULE PROCEDURE pw_zero_r3d_rs
86 MODULE PROCEDURE pw_zero_c1d_rs
87 MODULE PROCEDURE pw_zero_c3d_rs
88 MODULE PROCEDURE pw_zero_r1d_gs
89 MODULE PROCEDURE pw_zero_r3d_gs
90 MODULE PROCEDURE pw_zero_c1d_gs
91 MODULE PROCEDURE pw_zero_c3d_gs
92 END INTERFACE
93
94 INTERFACE pw_scale
95 MODULE PROCEDURE pw_scale_r1d_rs
96 MODULE PROCEDURE pw_scale_r3d_rs
97 MODULE PROCEDURE pw_scale_c1d_rs
98 MODULE PROCEDURE pw_scale_c3d_rs
99 MODULE PROCEDURE pw_scale_r1d_gs
100 MODULE PROCEDURE pw_scale_r3d_gs
101 MODULE PROCEDURE pw_scale_c1d_gs
102 MODULE PROCEDURE pw_scale_c3d_gs
103 END INTERFACE
104
105 INTERFACE pw_write
106 MODULE PROCEDURE pw_write_r1d_rs
107 MODULE PROCEDURE pw_write_r3d_rs
108 MODULE PROCEDURE pw_write_c1d_rs
109 MODULE PROCEDURE pw_write_c3d_rs
110 MODULE PROCEDURE pw_write_r1d_gs
111 MODULE PROCEDURE pw_write_r3d_gs
112 MODULE PROCEDURE pw_write_c1d_gs
113 MODULE PROCEDURE pw_write_c3d_gs
114 END INTERFACE
115
116 INTERFACE pw_integrate_function
117 MODULE PROCEDURE pw_integrate_function_r1d_rs
118 MODULE PROCEDURE pw_integrate_function_r3d_rs
119 MODULE PROCEDURE pw_integrate_function_c1d_rs
120 MODULE PROCEDURE pw_integrate_function_c3d_rs
121 MODULE PROCEDURE pw_integrate_function_r1d_gs
122 MODULE PROCEDURE pw_integrate_function_r3d_gs
123 MODULE PROCEDURE pw_integrate_function_c1d_gs
124 MODULE PROCEDURE pw_integrate_function_c3d_gs
125 END INTERFACE
126
127 INTERFACE pw_set
128 MODULE PROCEDURE pw_set_value_r1d_rs
129 MODULE PROCEDURE pw_zero_r1d_rs
130 MODULE PROCEDURE pw_set_value_r3d_rs
131 MODULE PROCEDURE pw_zero_r3d_rs
132 MODULE PROCEDURE pw_set_value_c1d_rs
133 MODULE PROCEDURE pw_zero_c1d_rs
134 MODULE PROCEDURE pw_set_value_c3d_rs
135 MODULE PROCEDURE pw_zero_c3d_rs
136 MODULE PROCEDURE pw_set_value_r1d_gs
137 MODULE PROCEDURE pw_zero_r1d_gs
138 MODULE PROCEDURE pw_set_value_r3d_gs
139 MODULE PROCEDURE pw_zero_r3d_gs
140 MODULE PROCEDURE pw_set_value_c1d_gs
141 MODULE PROCEDURE pw_zero_c1d_gs
142 MODULE PROCEDURE pw_set_value_c3d_gs
143 MODULE PROCEDURE pw_zero_c3d_gs
144 END INTERFACE
145
146 INTERFACE pw_copy
147 MODULE PROCEDURE pw_copy_r1d_r1d_rs
148 MODULE PROCEDURE pw_copy_r1d_c1d_rs
149 MODULE PROCEDURE pw_copy_r3d_r3d_rs
150 MODULE PROCEDURE pw_copy_r3d_c3d_rs
151 MODULE PROCEDURE pw_copy_c1d_r1d_rs
152 MODULE PROCEDURE pw_copy_c1d_c1d_rs
153 MODULE PROCEDURE pw_copy_c3d_r3d_rs
154 MODULE PROCEDURE pw_copy_c3d_c3d_rs
155 MODULE PROCEDURE pw_copy_r1d_r1d_gs
156 MODULE PROCEDURE pw_copy_r1d_c1d_gs
157 MODULE PROCEDURE pw_copy_r3d_r3d_gs
158 MODULE PROCEDURE pw_copy_r3d_c3d_gs
159 MODULE PROCEDURE pw_copy_c1d_r1d_gs
160 MODULE PROCEDURE pw_copy_c1d_c1d_gs
161 MODULE PROCEDURE pw_copy_c3d_r3d_gs
162 MODULE PROCEDURE pw_copy_c3d_c3d_gs
163 END INTERFACE
164
165 INTERFACE pw_axpy
166 MODULE PROCEDURE pw_axpy_r1d_r1d_rs
167 MODULE PROCEDURE pw_axpy_r1d_c1d_rs
168 MODULE PROCEDURE pw_axpy_r3d_r3d_rs
169 MODULE PROCEDURE pw_axpy_r3d_c3d_rs
170 MODULE PROCEDURE pw_axpy_c1d_r1d_rs
171 MODULE PROCEDURE pw_axpy_c1d_c1d_rs
172 MODULE PROCEDURE pw_axpy_c3d_r3d_rs
173 MODULE PROCEDURE pw_axpy_c3d_c3d_rs
174 MODULE PROCEDURE pw_axpy_r1d_r1d_gs
175 MODULE PROCEDURE pw_axpy_r1d_c1d_gs
176 MODULE PROCEDURE pw_axpy_r3d_r3d_gs
177 MODULE PROCEDURE pw_axpy_r3d_c3d_gs
178 MODULE PROCEDURE pw_axpy_c1d_r1d_gs
179 MODULE PROCEDURE pw_axpy_c1d_c1d_gs
180 MODULE PROCEDURE pw_axpy_c3d_r3d_gs
181 MODULE PROCEDURE pw_axpy_c3d_c3d_gs
182 END INTERFACE
183
184 INTERFACE pw_multiply
185 MODULE PROCEDURE pw_multiply_r1d_r1d_rs
186 MODULE PROCEDURE pw_multiply_r1d_c1d_rs
187 MODULE PROCEDURE pw_multiply_r3d_r3d_rs
188 MODULE PROCEDURE pw_multiply_r3d_c3d_rs
189 MODULE PROCEDURE pw_multiply_c1d_r1d_rs
190 MODULE PROCEDURE pw_multiply_c1d_c1d_rs
191 MODULE PROCEDURE pw_multiply_c3d_r3d_rs
192 MODULE PROCEDURE pw_multiply_c3d_c3d_rs
193 MODULE PROCEDURE pw_multiply_r1d_r1d_gs
194 MODULE PROCEDURE pw_multiply_r1d_c1d_gs
195 MODULE PROCEDURE pw_multiply_r3d_r3d_gs
196 MODULE PROCEDURE pw_multiply_r3d_c3d_gs
197 MODULE PROCEDURE pw_multiply_c1d_r1d_gs
198 MODULE PROCEDURE pw_multiply_c1d_c1d_gs
199 MODULE PROCEDURE pw_multiply_c3d_r3d_gs
200 MODULE PROCEDURE pw_multiply_c3d_c3d_gs
201 END INTERFACE
202
203 INTERFACE pw_multiply_with
204 MODULE PROCEDURE pw_multiply_with_r1d_r1d_rs
205 MODULE PROCEDURE pw_multiply_with_r1d_c1d_rs
206 MODULE PROCEDURE pw_multiply_with_r3d_r3d_rs
207 MODULE PROCEDURE pw_multiply_with_r3d_c3d_rs
208 MODULE PROCEDURE pw_multiply_with_c1d_r1d_rs
209 MODULE PROCEDURE pw_multiply_with_c1d_c1d_rs
210 MODULE PROCEDURE pw_multiply_with_c3d_r3d_rs
211 MODULE PROCEDURE pw_multiply_with_c3d_c3d_rs
212 MODULE PROCEDURE pw_multiply_with_r1d_r1d_gs
213 MODULE PROCEDURE pw_multiply_with_r1d_c1d_gs
214 MODULE PROCEDURE pw_multiply_with_r3d_r3d_gs
215 MODULE PROCEDURE pw_multiply_with_r3d_c3d_gs
216 MODULE PROCEDURE pw_multiply_with_c1d_r1d_gs
217 MODULE PROCEDURE pw_multiply_with_c1d_c1d_gs
218 MODULE PROCEDURE pw_multiply_with_c3d_r3d_gs
219 MODULE PROCEDURE pw_multiply_with_c3d_c3d_gs
220 END INTERFACE
221
222 INTERFACE pw_integral_ab
223 MODULE PROCEDURE pw_integral_ab_r1d_r1d_rs
224 MODULE PROCEDURE pw_integral_ab_r1d_c1d_rs
225 MODULE PROCEDURE pw_integral_ab_r3d_r3d_rs
226 MODULE PROCEDURE pw_integral_ab_r3d_c3d_rs
227 MODULE PROCEDURE pw_integral_ab_c1d_r1d_rs
228 MODULE PROCEDURE pw_integral_ab_c1d_c1d_rs
229 MODULE PROCEDURE pw_integral_ab_c3d_r3d_rs
230 MODULE PROCEDURE pw_integral_ab_c3d_c3d_rs
231 MODULE PROCEDURE pw_integral_ab_r1d_r1d_gs
232 MODULE PROCEDURE pw_integral_ab_r1d_c1d_gs
233 MODULE PROCEDURE pw_integral_ab_r3d_r3d_gs
234 MODULE PROCEDURE pw_integral_ab_r3d_c3d_gs
235 MODULE PROCEDURE pw_integral_ab_c1d_r1d_gs
236 MODULE PROCEDURE pw_integral_ab_c1d_c1d_gs
237 MODULE PROCEDURE pw_integral_ab_c3d_r3d_gs
238 MODULE PROCEDURE pw_integral_ab_c3d_c3d_gs
239 END INTERFACE
240
241 INTERFACE pw_integral_a2b
242 MODULE PROCEDURE pw_integral_a2b_r1d_r1d
243 MODULE PROCEDURE pw_integral_a2b_r1d_c1d
244 MODULE PROCEDURE pw_integral_a2b_c1d_r1d
245 MODULE PROCEDURE pw_integral_a2b_c1d_c1d
246 END INTERFACE
247
248 INTERFACE pw_gather
249 MODULE PROCEDURE pw_gather_p_r1d
250 MODULE PROCEDURE pw_gather_p_c1d
251 MODULE PROCEDURE pw_gather_s_r1d_r3d
252 MODULE PROCEDURE pw_gather_s_r1d_c3d
253 MODULE PROCEDURE pw_gather_s_c1d_r3d
254 MODULE PROCEDURE pw_gather_s_c1d_c3d
255 END INTERFACE
256
257 INTERFACE pw_scatter
258 MODULE PROCEDURE pw_scatter_p_r1d
259 MODULE PROCEDURE pw_scatter_p_c1d
260 MODULE PROCEDURE pw_scatter_s_r1d_r3d
261 MODULE PROCEDURE pw_scatter_s_r1d_c3d
262 MODULE PROCEDURE pw_scatter_s_c1d_r3d
263 MODULE PROCEDURE pw_scatter_s_c1d_c3d
264 END INTERFACE
265
266 INTERFACE pw_copy_to_array
267 MODULE PROCEDURE pw_copy_to_array_r1d_r1d_rs
268 MODULE PROCEDURE pw_copy_to_array_r1d_c1d_rs
269 MODULE PROCEDURE pw_copy_to_array_r3d_r3d_rs
270 MODULE PROCEDURE pw_copy_to_array_r3d_c3d_rs
271 MODULE PROCEDURE pw_copy_to_array_c1d_r1d_rs
272 MODULE PROCEDURE pw_copy_to_array_c1d_c1d_rs
273 MODULE PROCEDURE pw_copy_to_array_c3d_r3d_rs
274 MODULE PROCEDURE pw_copy_to_array_c3d_c3d_rs
275 MODULE PROCEDURE pw_copy_to_array_r1d_r1d_gs
276 MODULE PROCEDURE pw_copy_to_array_r1d_c1d_gs
277 MODULE PROCEDURE pw_copy_to_array_r3d_r3d_gs
278 MODULE PROCEDURE pw_copy_to_array_r3d_c3d_gs
279 MODULE PROCEDURE pw_copy_to_array_c1d_r1d_gs
280 MODULE PROCEDURE pw_copy_to_array_c1d_c1d_gs
281 MODULE PROCEDURE pw_copy_to_array_c3d_r3d_gs
282 MODULE PROCEDURE pw_copy_to_array_c3d_c3d_gs
283 END INTERFACE
284
285 INTERFACE pw_copy_from_array
286 MODULE PROCEDURE pw_copy_from_array_r1d_r1d_rs
287 MODULE PROCEDURE pw_copy_from_array_r1d_c1d_rs
288 MODULE PROCEDURE pw_copy_from_array_r3d_r3d_rs
289 MODULE PROCEDURE pw_copy_from_array_r3d_c3d_rs
290 MODULE PROCEDURE pw_copy_from_array_c1d_r1d_rs
291 MODULE PROCEDURE pw_copy_from_array_c1d_c1d_rs
292 MODULE PROCEDURE pw_copy_from_array_c3d_r3d_rs
293 MODULE PROCEDURE pw_copy_from_array_c3d_c3d_rs
294 MODULE PROCEDURE pw_copy_from_array_r1d_r1d_gs
295 MODULE PROCEDURE pw_copy_from_array_r1d_c1d_gs
296 MODULE PROCEDURE pw_copy_from_array_r3d_r3d_gs
297 MODULE PROCEDURE pw_copy_from_array_r3d_c3d_gs
298 MODULE PROCEDURE pw_copy_from_array_c1d_r1d_gs
299 MODULE PROCEDURE pw_copy_from_array_c1d_c1d_gs
300 MODULE PROCEDURE pw_copy_from_array_c3d_r3d_gs
301 MODULE PROCEDURE pw_copy_from_array_c3d_c3d_gs
302 END INTERFACE
303
304 INTERFACE pw_transfer
305 MODULE PROCEDURE pw_copy_r1d_r1d_rs
306 MODULE PROCEDURE pw_copy_r1d_r1d_gs
307 MODULE PROCEDURE pw_gather_s_r1d_r3d_2
308 MODULE PROCEDURE pw_scatter_s_r1d_r3d_2
309 MODULE PROCEDURE pw_copy_r1d_c1d_rs
310 MODULE PROCEDURE pw_copy_r1d_c1d_gs
311 MODULE PROCEDURE pw_gather_s_r1d_c3d_2
312 MODULE PROCEDURE pw_scatter_s_r1d_c3d_2
313 MODULE PROCEDURE pw_copy_r3d_r3d_rs
314 MODULE PROCEDURE pw_copy_r3d_r3d_gs
315 MODULE PROCEDURE fft_wrap_pw1pw2_r3d_c1d_rs_gs
316 MODULE PROCEDURE pw_copy_r3d_c3d_rs
317 MODULE PROCEDURE pw_copy_r3d_c3d_gs
318 MODULE PROCEDURE fft_wrap_pw1pw2_r3d_c3d_rs_gs
319 MODULE PROCEDURE pw_copy_c1d_r1d_rs
320 MODULE PROCEDURE pw_copy_c1d_r1d_gs
321 MODULE PROCEDURE pw_gather_s_c1d_r3d_2
322 MODULE PROCEDURE pw_scatter_s_c1d_r3d_2
323 MODULE PROCEDURE fft_wrap_pw1pw2_c1d_r3d_gs_rs
324 MODULE PROCEDURE pw_copy_c1d_c1d_rs
325 MODULE PROCEDURE pw_copy_c1d_c1d_gs
326 MODULE PROCEDURE pw_gather_s_c1d_c3d_2
327 MODULE PROCEDURE pw_scatter_s_c1d_c3d_2
328 MODULE PROCEDURE fft_wrap_pw1pw2_c1d_c3d_gs_rs
329 MODULE PROCEDURE pw_copy_c3d_r3d_rs
330 MODULE PROCEDURE pw_copy_c3d_r3d_gs
331 MODULE PROCEDURE fft_wrap_pw1pw2_c3d_r3d_gs_rs
332 MODULE PROCEDURE fft_wrap_pw1pw2_c3d_c1d_rs_gs
333 MODULE PROCEDURE pw_copy_c3d_c3d_rs
334 MODULE PROCEDURE pw_copy_c3d_c3d_gs
335 MODULE PROCEDURE fft_wrap_pw1pw2_c3d_c3d_rs_gs
336 MODULE PROCEDURE fft_wrap_pw1pw2_c3d_c3d_gs_rs
337 END INTERFACE
338
339CONTAINS
340! **************************************************************************************************
341!> \brief Set values of a pw type to zero
342!> \param pw ...
343!> \par History
344!> none
345!> \author apsi
346! **************************************************************************************************
347 SUBROUTINE pw_zero_r1d_rs (pw)
348
349 TYPE(pw_r1d_rs_type), INTENT(INOUT) :: pw
350
351 CHARACTER(len=*), PARAMETER :: routineN = 'pw_zero'
352
353 INTEGER :: handle
354
355 CALL timeset(routinen, handle)
356
357#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
358!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw)
359 pw%array = 0.0_dp
360!$OMP END PARALLEL WORKSHARE
361#else
362 pw%array = 0.0_dp
363#endif
364
365 CALL timestop(handle)
366
367 END SUBROUTINE pw_zero_r1d_rs
368
369! **************************************************************************************************
370!> \brief multiplies pw coeffs with a number
371!> \param pw ...
372!> \param a ...
373!> \par History
374!> 11.2004 created [Joost VandeVondele]
375! **************************************************************************************************
376 SUBROUTINE pw_scale_r1d_rs (pw, a)
377
378 TYPE(pw_r1d_rs_type), INTENT(INOUT) :: pw
379 REAL(KIND=dp), INTENT(IN) :: a
380
381 CHARACTER(len=*), PARAMETER :: routineN = 'pw_scale'
382
383 INTEGER :: handle
384
385 CALL timeset(routinen, handle)
386
387!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(A, pw)
388 pw%array = a*pw%array
389!$OMP END PARALLEL WORKSHARE
390
391 CALL timestop(handle)
392
393 END SUBROUTINE pw_scale_r1d_rs
394
395! **************************************************************************************************
396!> \brief writes a small description of the actual grid
397!> (change to output the data as cube file, maybe with an
398!> optional long_description arg?)
399!> \param pw the pw data to output
400!> \param unit_nr the unit to output to
401!> \par History
402!> 08.2002 created [fawzi]
403!> \author Fawzi Mohamed
404! **************************************************************************************************
405 SUBROUTINE pw_write_r1d_rs (pw, unit_nr)
406
407 TYPE(pw_r1d_rs_type), INTENT(in) :: pw
408 INTEGER, INTENT(in) :: unit_nr
409
410 INTEGER :: iostatus
411
412 WRITE (unit=unit_nr, fmt="('<pw>:{ ')", iostat=iostatus)
413
414 WRITE (unit=unit_nr, fmt="(a)", iostat=iostatus) " in_use=r1d"
415 IF (ASSOCIATED(pw%array)) THEN
416 WRITE (unit=unit_nr, fmt="(' array=<r(',i8,':',i8,')>')") &
417 lbound(pw%array, 1), ubound(pw%array, 1)
418 ELSE
419 WRITE (unit=unit_nr, fmt="(' array=*null*')")
420 END IF
421
422 END SUBROUTINE pw_write_r1d_rs
423
424! **************************************************************************************************
425!> \brief ...
426!> \param fun ...
427!> \param isign ...
428!> \param oprt ...
429!> \return ...
430! **************************************************************************************************
431 FUNCTION pw_integrate_function_r1d_rs (fun, isign, oprt) RESULT(total_fun)
432
433 TYPE(pw_r1d_rs_type), INTENT(IN) :: fun
434 INTEGER, INTENT(IN), OPTIONAL :: isign
435 CHARACTER(len=*), INTENT(IN), OPTIONAL :: oprt
436 REAL(kind=dp) :: total_fun
437
438 INTEGER :: iop
439
440 iop = 0
441
442 IF (PRESENT(oprt)) THEN
443 SELECT CASE (oprt)
444 CASE ("ABS", "abs")
445 iop = 1
446 CASE DEFAULT
447 cpabort("Unknown operator")
448 END SELECT
449 END IF
450
451 total_fun = 0.0_dp
452
453 ! do reduction using maximum accuracy
454 IF (iop == 1) THEN
455 total_fun = fun%pw_grid%dvol*accurate_sum(abs(fun%array))
456 ELSE
457 total_fun = fun%pw_grid%dvol*accurate_sum( fun%array)
458 END IF
459
460 IF (fun%pw_grid%para%mode /= pw_mode_local) THEN
461 CALL fun%pw_grid%para%group%sum(total_fun)
462 END IF
463
464 IF (PRESENT(isign)) THEN
465 total_fun = total_fun*sign(1._dp, real(isign, dp))
466 END IF
467
468 END FUNCTION pw_integrate_function_r1d_rs
469
470! **************************************************************************************************
471!> \brief ...
472!> \param pw ...
473!> \param value ...
474! **************************************************************************************************
475 SUBROUTINE pw_set_value_r1d_rs (pw, value)
476 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw
477 REAL(KIND=dp), INTENT(IN) :: value
478
479 CHARACTER(len=*), PARAMETER :: routineN = 'pw_set_value'
480
481 INTEGER :: handle
482
483 CALL timeset(routinen, handle)
484
485!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw,value)
486 pw%array = value
487!$OMP END PARALLEL WORKSHARE
488
489 CALL timestop(handle)
490
491 END SUBROUTINE pw_set_value_r1d_rs
492! **************************************************************************************************
493!> \brief Set values of a pw type to zero
494!> \param pw ...
495!> \par History
496!> none
497!> \author apsi
498! **************************************************************************************************
499 SUBROUTINE pw_zero_r1d_gs (pw)
500
501 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw
502
503 CHARACTER(len=*), PARAMETER :: routineN = 'pw_zero'
504
505 INTEGER :: handle
506
507 CALL timeset(routinen, handle)
508
509#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
510!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw)
511 pw%array = 0.0_dp
512!$OMP END PARALLEL WORKSHARE
513#else
514 pw%array = 0.0_dp
515#endif
516
517 CALL timestop(handle)
518
519 END SUBROUTINE pw_zero_r1d_gs
520
521! **************************************************************************************************
522!> \brief multiplies pw coeffs with a number
523!> \param pw ...
524!> \param a ...
525!> \par History
526!> 11.2004 created [Joost VandeVondele]
527! **************************************************************************************************
528 SUBROUTINE pw_scale_r1d_gs (pw, a)
529
530 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw
531 REAL(KIND=dp), INTENT(IN) :: a
532
533 CHARACTER(len=*), PARAMETER :: routineN = 'pw_scale'
534
535 INTEGER :: handle
536
537 CALL timeset(routinen, handle)
538
539!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(A, pw)
540 pw%array = a*pw%array
541!$OMP END PARALLEL WORKSHARE
542
543 CALL timestop(handle)
544
545 END SUBROUTINE pw_scale_r1d_gs
546
547! **************************************************************************************************
548!> \brief writes a small description of the actual grid
549!> (change to output the data as cube file, maybe with an
550!> optional long_description arg?)
551!> \param pw the pw data to output
552!> \param unit_nr the unit to output to
553!> \par History
554!> 08.2002 created [fawzi]
555!> \author Fawzi Mohamed
556! **************************************************************************************************
557 SUBROUTINE pw_write_r1d_gs (pw, unit_nr)
558
559 TYPE(pw_r1d_gs_type), INTENT(in) :: pw
560 INTEGER, INTENT(in) :: unit_nr
561
562 INTEGER :: iostatus
563
564 WRITE (unit=unit_nr, fmt="('<pw>:{ ')", iostat=iostatus)
565
566 WRITE (unit=unit_nr, fmt="(a)", iostat=iostatus) " in_use=r1d"
567 IF (ASSOCIATED(pw%array)) THEN
568 WRITE (unit=unit_nr, fmt="(' array=<r(',i8,':',i8,')>')") &
569 lbound(pw%array, 1), ubound(pw%array, 1)
570 ELSE
571 WRITE (unit=unit_nr, fmt="(' array=*null*')")
572 END IF
573
574 END SUBROUTINE pw_write_r1d_gs
575
576! **************************************************************************************************
577!> \brief ...
578!> \param fun ...
579!> \param isign ...
580!> \param oprt ...
581!> \return ...
582! **************************************************************************************************
583 FUNCTION pw_integrate_function_r1d_gs (fun, isign, oprt) RESULT(total_fun)
584
585 TYPE(pw_r1d_gs_type), INTENT(IN) :: fun
586 INTEGER, INTENT(IN), OPTIONAL :: isign
587 CHARACTER(len=*), INTENT(IN), OPTIONAL :: oprt
588 REAL(kind=dp) :: total_fun
589
590 INTEGER :: iop
591
592 iop = 0
593
594 IF (PRESENT(oprt)) THEN
595 SELECT CASE (oprt)
596 CASE ("ABS", "abs")
597 iop = 1
598 CASE DEFAULT
599 cpabort("Unknown operator")
600 END SELECT
601 END IF
602
603 total_fun = 0.0_dp
604
605 IF (iop == 1) &
606 cpabort("Operator ABS not implemented")
607 IF (fun%pw_grid%have_g0) total_fun = fun%pw_grid%vol* fun%array(1)
608
609 IF (fun%pw_grid%para%mode /= pw_mode_local) THEN
610 CALL fun%pw_grid%para%group%sum(total_fun)
611 END IF
612
613 IF (PRESENT(isign)) THEN
614 total_fun = total_fun*sign(1._dp, real(isign, dp))
615 END IF
616
617 END FUNCTION pw_integrate_function_r1d_gs
618
619! **************************************************************************************************
620!> \brief ...
621!> \param pw ...
622!> \param value ...
623! **************************************************************************************************
624 SUBROUTINE pw_set_value_r1d_gs (pw, value)
625 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw
626 REAL(KIND=dp), INTENT(IN) :: value
627
628 CHARACTER(len=*), PARAMETER :: routineN = 'pw_set_value'
629
630 INTEGER :: handle
631
632 CALL timeset(routinen, handle)
633
634!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw,value)
635 pw%array = value
636!$OMP END PARALLEL WORKSHARE
637
638 CALL timestop(handle)
639
640 END SUBROUTINE pw_set_value_r1d_gs
641
642! **************************************************************************************************
643!> \brief ...
644!> \param pw ...
645!> \param c ...
646!> \param scale ...
647! **************************************************************************************************
648 SUBROUTINE pw_gather_p_r1d (pw, c, scale)
649
650 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw
651 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, INTENT(IN), TARGET :: c
652 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
653
654 CHARACTER(len=*), PARAMETER :: routineN = 'pw_gather_p'
655
656 INTEGER :: gpt, handle
657 COMPLEX(KIND=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
658
659 CALL timeset(routinen, handle)
660
661 IF (pw%pw_grid%para%mode /= pw_mode_distributed) THEN
662 cpabort("This grid type is not distributed")
663 END IF
664
665 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
666 c_1d(1:SIZE(c)) => c
667 associate(ngpts => SIZE(pw%pw_grid%gsq), g_hatmap => pw%pw_grid%g_hatmap)
668
669 IF (PRESENT(scale)) THEN
670!$OMP PARALLEL DO DEFAULT(NONE) &
671!$OMP PRIVATE(gpt) &
672!$OMP SHARED(c_1d, pw, scale)
673 DO gpt = 1, ngpts
674 pw%array(gpt) = scale* real(c_1d(g_hatmap(gpt, 1) + 1), kind=dp)
675 END DO
676!$OMP END PARALLEL DO
677 ELSE
678!$OMP PARALLEL DO DEFAULT(NONE) &
679!$OMP PRIVATE(gpt) &
680!$OMP SHARED(c_1d, pw)
681 DO gpt = 1, ngpts
682 pw%array(gpt) = real(c_1d(g_hatmap(gpt, 1) + 1), kind=dp)
683 END DO
684!$OMP END PARALLEL DO
685 END IF
686
687 END associate
688
689 CALL timestop(handle)
690
691 END SUBROUTINE pw_gather_p_r1d
692
693! **************************************************************************************************
694!> \brief ...
695!> \param pw ...
696!> \param c ...
697!> \param scale ...
698! **************************************************************************************************
699 SUBROUTINE pw_scatter_p_r1d (pw, c, scale)
700 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw
701 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, INTENT(INOUT), TARGET :: c
702 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
703
704 CHARACTER(len=*), PARAMETER :: routineN = 'pw_scatter_p'
705
706 INTEGER :: gpt, handle
707 COMPLEX(KIND=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
708
709 CALL timeset(routinen, handle)
710
711 IF (pw%pw_grid%para%mode /= pw_mode_distributed) THEN
712 cpabort("This grid type is not distributed")
713 END IF
714
715 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
716 c_1d(1:SIZE(c)) => c
717 associate(g_hatmap => pw%pw_grid%g_hatmap, ngpts => SIZE(pw%pw_grid%gsq))
718
719 IF (.NOT. PRESENT(scale)) c = z_zero
720
721 IF (PRESENT(scale)) THEN
722!$OMP PARALLEL DO DEFAULT(NONE) &
723!$OMP PRIVATE(gpt) &
724!$OMP SHARED(c_1d, pw, scale)
725 DO gpt = 1, ngpts
726 c_1d(g_hatmap(gpt, 1) + 1) = cmplx(scale*pw%array(gpt), 0.0_dp, kind=dp)
727 END DO
728!$OMP END PARALLEL DO
729 ELSE
730!$OMP PARALLEL DO DEFAULT(NONE) &
731!$OMP PRIVATE(gpt) &
732!$OMP SHARED(c_1d, pw)
733 DO gpt = 1, ngpts
734 c_1d(g_hatmap(gpt, 1) + 1) = cmplx(pw%array(gpt), 0.0_dp, kind=dp)
735 END DO
736!$OMP END PARALLEL DO
737 END IF
738
739 IF (pw%pw_grid%grid_span == halfspace) THEN
740
741 IF (PRESENT(scale)) THEN
742!$OMP PARALLEL DO DEFAULT(NONE) &
743!$OMP PRIVATE(gpt) &
744!$OMP SHARED(c_1d, pw, scale)
745 DO gpt = 1, ngpts
746 c_1d(g_hatmap(gpt, 2) + 1) = scale*( cmplx(pw%array(gpt), 0.0_dp, kind=dp))
747 END DO
748!$OMP END PARALLEL DO
749 ELSE
750!$OMP PARALLEL DO DEFAULT(NONE) &
751!$OMP PRIVATE(gpt) &
752!$OMP SHARED(c_1d, pw)
753 DO gpt = 1, ngpts
754 c_1d(g_hatmap(gpt, 2) + 1) = ( cmplx(pw%array(gpt), 0.0_dp, kind=dp))
755 END DO
756!$OMP END PARALLEL DO
757 END IF
758 END IF
759
760 END associate
761
762 CALL timestop(handle)
763
764 END SUBROUTINE pw_scatter_p_r1d
765! **************************************************************************************************
766!> \brief Set values of a pw type to zero
767!> \param pw ...
768!> \par History
769!> none
770!> \author apsi
771! **************************************************************************************************
772 SUBROUTINE pw_zero_r3d_rs (pw)
773
774 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw
775
776 CHARACTER(len=*), PARAMETER :: routineN = 'pw_zero'
777
778 INTEGER :: handle
779
780 CALL timeset(routinen, handle)
781
782#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
783!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw)
784 pw%array = 0.0_dp
785!$OMP END PARALLEL WORKSHARE
786#else
787 pw%array = 0.0_dp
788#endif
789
790 CALL timestop(handle)
791
792 END SUBROUTINE pw_zero_r3d_rs
793
794! **************************************************************************************************
795!> \brief multiplies pw coeffs with a number
796!> \param pw ...
797!> \param a ...
798!> \par History
799!> 11.2004 created [Joost VandeVondele]
800! **************************************************************************************************
801 SUBROUTINE pw_scale_r3d_rs (pw, a)
802
803 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw
804 REAL(KIND=dp), INTENT(IN) :: a
805
806 CHARACTER(len=*), PARAMETER :: routineN = 'pw_scale'
807
808 INTEGER :: handle
809
810 CALL timeset(routinen, handle)
811
812!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(A, pw)
813 pw%array = a*pw%array
814!$OMP END PARALLEL WORKSHARE
815
816 CALL timestop(handle)
817
818 END SUBROUTINE pw_scale_r3d_rs
819
820! **************************************************************************************************
821!> \brief writes a small description of the actual grid
822!> (change to output the data as cube file, maybe with an
823!> optional long_description arg?)
824!> \param pw the pw data to output
825!> \param unit_nr the unit to output to
826!> \par History
827!> 08.2002 created [fawzi]
828!> \author Fawzi Mohamed
829! **************************************************************************************************
830 SUBROUTINE pw_write_r3d_rs (pw, unit_nr)
831
832 TYPE(pw_r3d_rs_type), INTENT(in) :: pw
833 INTEGER, INTENT(in) :: unit_nr
834
835 INTEGER :: iostatus
836
837 WRITE (unit=unit_nr, fmt="('<pw>:{ ')", iostat=iostatus)
838
839 WRITE (unit=unit_nr, fmt="(a)", iostat=iostatus) " in_use=r3d"
840 IF (ASSOCIATED(pw%array)) THEN
841 WRITE (unit=unit_nr, fmt="(' array=<r(',i8,':',i8,',',i8,':',i8,',',i8,':',i8,')>')") &
842 lbound(pw%array, 1), ubound(pw%array, 1), lbound(pw%array, 2), ubound(pw%array, 2), &
843 lbound(pw%array, 3), ubound(pw%array, 3)
844 ELSE
845 WRITE (unit=unit_nr, fmt="(' array=*null*')")
846 END IF
847
848 END SUBROUTINE pw_write_r3d_rs
849
850! **************************************************************************************************
851!> \brief ...
852!> \param fun ...
853!> \param isign ...
854!> \param oprt ...
855!> \return ...
856! **************************************************************************************************
857 FUNCTION pw_integrate_function_r3d_rs (fun, isign, oprt) RESULT(total_fun)
858
859 TYPE(pw_r3d_rs_type), INTENT(IN) :: fun
860 INTEGER, INTENT(IN), OPTIONAL :: isign
861 CHARACTER(len=*), INTENT(IN), OPTIONAL :: oprt
862 REAL(kind=dp) :: total_fun
863
864 INTEGER :: iop
865
866 iop = 0
867
868 IF (PRESENT(oprt)) THEN
869 SELECT CASE (oprt)
870 CASE ("ABS", "abs")
871 iop = 1
872 CASE DEFAULT
873 cpabort("Unknown operator")
874 END SELECT
875 END IF
876
877 total_fun = 0.0_dp
878
879 ! do reduction using maximum accuracy
880 IF (iop == 1) THEN
881 total_fun = fun%pw_grid%dvol*accurate_sum(abs(fun%array))
882 ELSE
883 total_fun = fun%pw_grid%dvol*accurate_sum( fun%array)
884 END IF
885
886 IF (fun%pw_grid%para%mode /= pw_mode_local) THEN
887 CALL fun%pw_grid%para%group%sum(total_fun)
888 END IF
889
890 IF (PRESENT(isign)) THEN
891 total_fun = total_fun*sign(1._dp, real(isign, dp))
892 END IF
893
894 END FUNCTION pw_integrate_function_r3d_rs
895
896! **************************************************************************************************
897!> \brief ...
898!> \param pw ...
899!> \param value ...
900! **************************************************************************************************
901 SUBROUTINE pw_set_value_r3d_rs (pw, value)
902 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw
903 REAL(KIND=dp), INTENT(IN) :: value
904
905 CHARACTER(len=*), PARAMETER :: routineN = 'pw_set_value'
906
907 INTEGER :: handle
908
909 CALL timeset(routinen, handle)
910
911!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw,value)
912 pw%array = value
913!$OMP END PARALLEL WORKSHARE
914
915 CALL timestop(handle)
916
917 END SUBROUTINE pw_set_value_r3d_rs
918! **************************************************************************************************
919!> \brief Set values of a pw type to zero
920!> \param pw ...
921!> \par History
922!> none
923!> \author apsi
924! **************************************************************************************************
925 SUBROUTINE pw_zero_r3d_gs (pw)
926
927 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw
928
929 CHARACTER(len=*), PARAMETER :: routineN = 'pw_zero'
930
931 INTEGER :: handle
932
933 CALL timeset(routinen, handle)
934
935#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
936!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw)
937 pw%array = 0.0_dp
938!$OMP END PARALLEL WORKSHARE
939#else
940 pw%array = 0.0_dp
941#endif
942
943 CALL timestop(handle)
944
945 END SUBROUTINE pw_zero_r3d_gs
946
947! **************************************************************************************************
948!> \brief multiplies pw coeffs with a number
949!> \param pw ...
950!> \param a ...
951!> \par History
952!> 11.2004 created [Joost VandeVondele]
953! **************************************************************************************************
954 SUBROUTINE pw_scale_r3d_gs (pw, a)
955
956 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw
957 REAL(KIND=dp), INTENT(IN) :: a
958
959 CHARACTER(len=*), PARAMETER :: routineN = 'pw_scale'
960
961 INTEGER :: handle
962
963 CALL timeset(routinen, handle)
964
965!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(A, pw)
966 pw%array = a*pw%array
967!$OMP END PARALLEL WORKSHARE
968
969 CALL timestop(handle)
970
971 END SUBROUTINE pw_scale_r3d_gs
972
973! **************************************************************************************************
974!> \brief writes a small description of the actual grid
975!> (change to output the data as cube file, maybe with an
976!> optional long_description arg?)
977!> \param pw the pw data to output
978!> \param unit_nr the unit to output to
979!> \par History
980!> 08.2002 created [fawzi]
981!> \author Fawzi Mohamed
982! **************************************************************************************************
983 SUBROUTINE pw_write_r3d_gs (pw, unit_nr)
984
985 TYPE(pw_r3d_gs_type), INTENT(in) :: pw
986 INTEGER, INTENT(in) :: unit_nr
987
988 INTEGER :: iostatus
989
990 WRITE (unit=unit_nr, fmt="('<pw>:{ ')", iostat=iostatus)
991
992 WRITE (unit=unit_nr, fmt="(a)", iostat=iostatus) " in_use=r3d"
993 IF (ASSOCIATED(pw%array)) THEN
994 WRITE (unit=unit_nr, fmt="(' array=<r(',i8,':',i8,',',i8,':',i8,',',i8,':',i8,')>')") &
995 lbound(pw%array, 1), ubound(pw%array, 1), lbound(pw%array, 2), ubound(pw%array, 2), &
996 lbound(pw%array, 3), ubound(pw%array, 3)
997 ELSE
998 WRITE (unit=unit_nr, fmt="(' array=*null*')")
999 END IF
1000
1001 END SUBROUTINE pw_write_r3d_gs
1002
1003! **************************************************************************************************
1004!> \brief ...
1005!> \param fun ...
1006!> \param isign ...
1007!> \param oprt ...
1008!> \return ...
1009! **************************************************************************************************
1010 FUNCTION pw_integrate_function_r3d_gs (fun, isign, oprt) RESULT(total_fun)
1011
1012 TYPE(pw_r3d_gs_type), INTENT(IN) :: fun
1013 INTEGER, INTENT(IN), OPTIONAL :: isign
1014 CHARACTER(len=*), INTENT(IN), OPTIONAL :: oprt
1015 REAL(kind=dp) :: total_fun
1016
1017 INTEGER :: iop
1018
1019 iop = 0
1020
1021 IF (PRESENT(oprt)) THEN
1022 SELECT CASE (oprt)
1023 CASE ("ABS", "abs")
1024 iop = 1
1025 CASE DEFAULT
1026 cpabort("Unknown operator")
1027 END SELECT
1028 END IF
1029
1030 total_fun = 0.0_dp
1031
1032 IF (iop == 1) &
1033 cpabort("Operator ABS not implemented")
1034 cpabort("Reciprocal space integration for 3D grids not implemented!")
1035
1036 IF (fun%pw_grid%para%mode /= pw_mode_local) THEN
1037 CALL fun%pw_grid%para%group%sum(total_fun)
1038 END IF
1039
1040 IF (PRESENT(isign)) THEN
1041 total_fun = total_fun*sign(1._dp, real(isign, dp))
1042 END IF
1043
1044 END FUNCTION pw_integrate_function_r3d_gs
1045
1046! **************************************************************************************************
1047!> \brief ...
1048!> \param pw ...
1049!> \param value ...
1050! **************************************************************************************************
1051 SUBROUTINE pw_set_value_r3d_gs (pw, value)
1052 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw
1053 REAL(KIND=dp), INTENT(IN) :: value
1054
1055 CHARACTER(len=*), PARAMETER :: routineN = 'pw_set_value'
1056
1057 INTEGER :: handle
1058
1059 CALL timeset(routinen, handle)
1060
1061!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw,value)
1062 pw%array = value
1063!$OMP END PARALLEL WORKSHARE
1064
1065 CALL timestop(handle)
1066
1067 END SUBROUTINE pw_set_value_r3d_gs
1068
1069! **************************************************************************************************
1070!> \brief Set values of a pw type to zero
1071!> \param pw ...
1072!> \par History
1073!> none
1074!> \author apsi
1075! **************************************************************************************************
1076 SUBROUTINE pw_zero_c1d_rs (pw)
1077
1078 TYPE(pw_c1d_rs_type), INTENT(INOUT) :: pw
1079
1080 CHARACTER(len=*), PARAMETER :: routineN = 'pw_zero'
1081
1082 INTEGER :: handle
1083
1084 CALL timeset(routinen, handle)
1085
1086#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
1087!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw)
1088 pw%array = cmplx(0.0_dp, 0.0_dp, kind=dp)
1089!$OMP END PARALLEL WORKSHARE
1090#else
1091 pw%array = cmplx(0.0_dp, 0.0_dp, kind=dp)
1092#endif
1093
1094 CALL timestop(handle)
1095
1096 END SUBROUTINE pw_zero_c1d_rs
1097
1098! **************************************************************************************************
1099!> \brief multiplies pw coeffs with a number
1100!> \param pw ...
1101!> \param a ...
1102!> \par History
1103!> 11.2004 created [Joost VandeVondele]
1104! **************************************************************************************************
1105 SUBROUTINE pw_scale_c1d_rs (pw, a)
1106
1107 TYPE(pw_c1d_rs_type), INTENT(INOUT) :: pw
1108 REAL(KIND=dp), INTENT(IN) :: a
1109
1110 CHARACTER(len=*), PARAMETER :: routineN = 'pw_scale'
1111
1112 INTEGER :: handle
1113
1114 CALL timeset(routinen, handle)
1115
1116!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(A, pw)
1117 pw%array = a*pw%array
1118!$OMP END PARALLEL WORKSHARE
1119
1120 CALL timestop(handle)
1121
1122 END SUBROUTINE pw_scale_c1d_rs
1123
1124! **************************************************************************************************
1125!> \brief writes a small description of the actual grid
1126!> (change to output the data as cube file, maybe with an
1127!> optional long_description arg?)
1128!> \param pw the pw data to output
1129!> \param unit_nr the unit to output to
1130!> \par History
1131!> 08.2002 created [fawzi]
1132!> \author Fawzi Mohamed
1133! **************************************************************************************************
1134 SUBROUTINE pw_write_c1d_rs (pw, unit_nr)
1135
1136 TYPE(pw_c1d_rs_type), INTENT(in) :: pw
1137 INTEGER, INTENT(in) :: unit_nr
1138
1139 INTEGER :: iostatus
1140
1141 WRITE (unit=unit_nr, fmt="('<pw>:{ ')", iostat=iostatus)
1142
1143 WRITE (unit=unit_nr, fmt="(a)", iostat=iostatus) " in_use=c1d"
1144 IF (ASSOCIATED(pw%array)) THEN
1145 WRITE (unit=unit_nr, fmt="(' array=<c(',i8,':',i8,')>')") &
1146 lbound(pw%array, 1), ubound(pw%array, 1)
1147 ELSE
1148 WRITE (unit=unit_nr, fmt="(' array=*null*')")
1149 END IF
1150
1151 END SUBROUTINE pw_write_c1d_rs
1152
1153! **************************************************************************************************
1154!> \brief ...
1155!> \param fun ...
1156!> \param isign ...
1157!> \param oprt ...
1158!> \return ...
1159! **************************************************************************************************
1160 FUNCTION pw_integrate_function_c1d_rs (fun, isign, oprt) RESULT(total_fun)
1161
1162 TYPE(pw_c1d_rs_type), INTENT(IN) :: fun
1163 INTEGER, INTENT(IN), OPTIONAL :: isign
1164 CHARACTER(len=*), INTENT(IN), OPTIONAL :: oprt
1165 REAL(kind=dp) :: total_fun
1166
1167 INTEGER :: iop
1168
1169 iop = 0
1170
1171 IF (PRESENT(oprt)) THEN
1172 SELECT CASE (oprt)
1173 CASE ("ABS", "abs")
1174 iop = 1
1175 CASE DEFAULT
1176 cpabort("Unknown operator")
1177 END SELECT
1178 END IF
1179
1180 total_fun = 0.0_dp
1181
1182 ! do reduction using maximum accuracy
1183 IF (iop == 1) THEN
1184 total_fun = fun%pw_grid%dvol*accurate_sum(abs(fun%array))
1185 ELSE
1186 total_fun = fun%pw_grid%dvol*accurate_sum( real(fun%array, kind=dp))
1187 END IF
1188
1189 IF (fun%pw_grid%para%mode /= pw_mode_local) THEN
1190 CALL fun%pw_grid%para%group%sum(total_fun)
1191 END IF
1192
1193 IF (PRESENT(isign)) THEN
1194 total_fun = total_fun*sign(1._dp, real(isign, dp))
1195 END IF
1196
1197 END FUNCTION pw_integrate_function_c1d_rs
1198
1199! **************************************************************************************************
1200!> \brief ...
1201!> \param pw ...
1202!> \param value ...
1203! **************************************************************************************************
1204 SUBROUTINE pw_set_value_c1d_rs (pw, value)
1205 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw
1206 REAL(KIND=dp), INTENT(IN) :: value
1207
1208 CHARACTER(len=*), PARAMETER :: routineN = 'pw_set_value'
1209
1210 INTEGER :: handle
1211
1212 CALL timeset(routinen, handle)
1213
1214!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw,value)
1215 pw%array = cmplx(value, 0.0_dp, kind=dp)
1216!$OMP END PARALLEL WORKSHARE
1217
1218 CALL timestop(handle)
1219
1220 END SUBROUTINE pw_set_value_c1d_rs
1221! **************************************************************************************************
1222!> \brief Set values of a pw type to zero
1223!> \param pw ...
1224!> \par History
1225!> none
1226!> \author apsi
1227! **************************************************************************************************
1228 SUBROUTINE pw_zero_c1d_gs (pw)
1229
1230 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
1231
1232 CHARACTER(len=*), PARAMETER :: routineN = 'pw_zero'
1233
1234 INTEGER :: handle
1235
1236 CALL timeset(routinen, handle)
1237
1238#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
1239!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw)
1240 pw%array = cmplx(0.0_dp, 0.0_dp, kind=dp)
1241!$OMP END PARALLEL WORKSHARE
1242#else
1243 pw%array = cmplx(0.0_dp, 0.0_dp, kind=dp)
1244#endif
1245
1246 CALL timestop(handle)
1247
1248 END SUBROUTINE pw_zero_c1d_gs
1249
1250! **************************************************************************************************
1251!> \brief multiplies pw coeffs with a number
1252!> \param pw ...
1253!> \param a ...
1254!> \par History
1255!> 11.2004 created [Joost VandeVondele]
1256! **************************************************************************************************
1257 SUBROUTINE pw_scale_c1d_gs (pw, a)
1258
1259 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
1260 REAL(KIND=dp), INTENT(IN) :: a
1261
1262 CHARACTER(len=*), PARAMETER :: routineN = 'pw_scale'
1263
1264 INTEGER :: handle
1265
1266 CALL timeset(routinen, handle)
1267
1268!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(A, pw)
1269 pw%array = a*pw%array
1270!$OMP END PARALLEL WORKSHARE
1271
1272 CALL timestop(handle)
1273
1274 END SUBROUTINE pw_scale_c1d_gs
1275
1276! **************************************************************************************************
1277!> \brief writes a small description of the actual grid
1278!> (change to output the data as cube file, maybe with an
1279!> optional long_description arg?)
1280!> \param pw the pw data to output
1281!> \param unit_nr the unit to output to
1282!> \par History
1283!> 08.2002 created [fawzi]
1284!> \author Fawzi Mohamed
1285! **************************************************************************************************
1286 SUBROUTINE pw_write_c1d_gs (pw, unit_nr)
1287
1288 TYPE(pw_c1d_gs_type), INTENT(in) :: pw
1289 INTEGER, INTENT(in) :: unit_nr
1290
1291 INTEGER :: iostatus
1292
1293 WRITE (unit=unit_nr, fmt="('<pw>:{ ')", iostat=iostatus)
1294
1295 WRITE (unit=unit_nr, fmt="(a)", iostat=iostatus) " in_use=c1d"
1296 IF (ASSOCIATED(pw%array)) THEN
1297 WRITE (unit=unit_nr, fmt="(' array=<c(',i8,':',i8,')>')") &
1298 lbound(pw%array, 1), ubound(pw%array, 1)
1299 ELSE
1300 WRITE (unit=unit_nr, fmt="(' array=*null*')")
1301 END IF
1302
1303 END SUBROUTINE pw_write_c1d_gs
1304
1305! **************************************************************************************************
1306!> \brief ...
1307!> \param fun ...
1308!> \param isign ...
1309!> \param oprt ...
1310!> \return ...
1311! **************************************************************************************************
1312 FUNCTION pw_integrate_function_c1d_gs (fun, isign, oprt) RESULT(total_fun)
1313
1314 TYPE(pw_c1d_gs_type), INTENT(IN) :: fun
1315 INTEGER, INTENT(IN), OPTIONAL :: isign
1316 CHARACTER(len=*), INTENT(IN), OPTIONAL :: oprt
1317 REAL(kind=dp) :: total_fun
1318
1319 INTEGER :: iop
1320
1321 iop = 0
1322
1323 IF (PRESENT(oprt)) THEN
1324 SELECT CASE (oprt)
1325 CASE ("ABS", "abs")
1326 iop = 1
1327 CASE DEFAULT
1328 cpabort("Unknown operator")
1329 END SELECT
1330 END IF
1331
1332 total_fun = 0.0_dp
1333
1334 IF (iop == 1) &
1335 cpabort("Operator ABS not implemented")
1336 IF (fun%pw_grid%have_g0) total_fun = fun%pw_grid%vol* real(fun%array(1), kind=dp)
1337
1338 IF (fun%pw_grid%para%mode /= pw_mode_local) THEN
1339 CALL fun%pw_grid%para%group%sum(total_fun)
1340 END IF
1341
1342 IF (PRESENT(isign)) THEN
1343 total_fun = total_fun*sign(1._dp, real(isign, dp))
1344 END IF
1345
1346 END FUNCTION pw_integrate_function_c1d_gs
1347
1348! **************************************************************************************************
1349!> \brief ...
1350!> \param pw ...
1351!> \param value ...
1352! **************************************************************************************************
1353 SUBROUTINE pw_set_value_c1d_gs (pw, value)
1354 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
1355 REAL(KIND=dp), INTENT(IN) :: value
1356
1357 CHARACTER(len=*), PARAMETER :: routineN = 'pw_set_value'
1358
1359 INTEGER :: handle
1360
1361 CALL timeset(routinen, handle)
1362
1363!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw,value)
1364 pw%array = cmplx(value, 0.0_dp, kind=dp)
1365!$OMP END PARALLEL WORKSHARE
1366
1367 CALL timestop(handle)
1368
1369 END SUBROUTINE pw_set_value_c1d_gs
1370
1371! **************************************************************************************************
1372!> \brief ...
1373!> \param pw ...
1374!> \param c ...
1375!> \param scale ...
1376! **************************************************************************************************
1377 SUBROUTINE pw_gather_p_c1d (pw, c, scale)
1378
1379 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
1380 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, INTENT(IN), TARGET :: c
1381 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
1382
1383 CHARACTER(len=*), PARAMETER :: routineN = 'pw_gather_p'
1384
1385 INTEGER :: gpt, handle
1386 COMPLEX(KIND=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
1387
1388 CALL timeset(routinen, handle)
1389
1390 IF (pw%pw_grid%para%mode /= pw_mode_distributed) THEN
1391 cpabort("This grid type is not distributed")
1392 END IF
1393
1394 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
1395 c_1d(1:SIZE(c)) => c
1396 associate(ngpts => SIZE(pw%pw_grid%gsq), g_hatmap => pw%pw_grid%g_hatmap)
1397
1398 IF (PRESENT(scale)) THEN
1399!$OMP PARALLEL DO DEFAULT(NONE) &
1400!$OMP PRIVATE(gpt) &
1401!$OMP SHARED(c_1d, pw, scale)
1402 DO gpt = 1, ngpts
1403 pw%array(gpt) = scale* c_1d(g_hatmap(gpt, 1) + 1)
1404 END DO
1405!$OMP END PARALLEL DO
1406 ELSE
1407!$OMP PARALLEL DO DEFAULT(NONE) &
1408!$OMP PRIVATE(gpt) &
1409!$OMP SHARED(c_1d, pw)
1410 DO gpt = 1, ngpts
1411 pw%array(gpt) = c_1d(g_hatmap(gpt, 1) + 1)
1412 END DO
1413!$OMP END PARALLEL DO
1414 END IF
1415
1416 END associate
1417
1418 CALL timestop(handle)
1419
1420 END SUBROUTINE pw_gather_p_c1d
1421
1422! **************************************************************************************************
1423!> \brief ...
1424!> \param pw ...
1425!> \param c ...
1426!> \param scale ...
1427! **************************************************************************************************
1428 SUBROUTINE pw_scatter_p_c1d (pw, c, scale)
1429 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
1430 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, INTENT(INOUT), TARGET :: c
1431 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
1432
1433 CHARACTER(len=*), PARAMETER :: routineN = 'pw_scatter_p'
1434
1435 INTEGER :: gpt, handle
1436 COMPLEX(KIND=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
1437
1438 CALL timeset(routinen, handle)
1439
1440 IF (pw%pw_grid%para%mode /= pw_mode_distributed) THEN
1441 cpabort("This grid type is not distributed")
1442 END IF
1443
1444 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
1445 c_1d(1:SIZE(c)) => c
1446 associate(g_hatmap => pw%pw_grid%g_hatmap, ngpts => SIZE(pw%pw_grid%gsq))
1447
1448 IF (.NOT. PRESENT(scale)) c = z_zero
1449
1450 IF (PRESENT(scale)) THEN
1451!$OMP PARALLEL DO DEFAULT(NONE) &
1452!$OMP PRIVATE(gpt) &
1453!$OMP SHARED(c_1d, pw, scale)
1454 DO gpt = 1, ngpts
1455 c_1d(g_hatmap(gpt, 1) + 1) = scale*pw%array(gpt)
1456 END DO
1457!$OMP END PARALLEL DO
1458 ELSE
1459!$OMP PARALLEL DO DEFAULT(NONE) &
1460!$OMP PRIVATE(gpt) &
1461!$OMP SHARED(c_1d, pw)
1462 DO gpt = 1, ngpts
1463 c_1d(g_hatmap(gpt, 1) + 1) = pw%array(gpt)
1464 END DO
1465!$OMP END PARALLEL DO
1466 END IF
1467
1468 IF (pw%pw_grid%grid_span == halfspace) THEN
1469
1470 IF (PRESENT(scale)) THEN
1471!$OMP PARALLEL DO DEFAULT(NONE) &
1472!$OMP PRIVATE(gpt) &
1473!$OMP SHARED(c_1d, pw, scale)
1474 DO gpt = 1, ngpts
1475 c_1d(g_hatmap(gpt, 2) + 1) = scale*conjg( pw%array(gpt))
1476 END DO
1477!$OMP END PARALLEL DO
1478 ELSE
1479!$OMP PARALLEL DO DEFAULT(NONE) &
1480!$OMP PRIVATE(gpt) &
1481!$OMP SHARED(c_1d, pw)
1482 DO gpt = 1, ngpts
1483 c_1d(g_hatmap(gpt, 2) + 1) = conjg( pw%array(gpt))
1484 END DO
1485!$OMP END PARALLEL DO
1486 END IF
1487 END IF
1488
1489 END associate
1490
1491 CALL timestop(handle)
1492
1493 END SUBROUTINE pw_scatter_p_c1d
1494! **************************************************************************************************
1495!> \brief Set values of a pw type to zero
1496!> \param pw ...
1497!> \par History
1498!> none
1499!> \author apsi
1500! **************************************************************************************************
1501 SUBROUTINE pw_zero_c3d_rs (pw)
1502
1503 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw
1504
1505 CHARACTER(len=*), PARAMETER :: routineN = 'pw_zero'
1506
1507 INTEGER :: handle
1508
1509 CALL timeset(routinen, handle)
1510
1511#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
1512!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw)
1513 pw%array = cmplx(0.0_dp, 0.0_dp, kind=dp)
1514!$OMP END PARALLEL WORKSHARE
1515#else
1516 pw%array = cmplx(0.0_dp, 0.0_dp, kind=dp)
1517#endif
1518
1519 CALL timestop(handle)
1520
1521 END SUBROUTINE pw_zero_c3d_rs
1522
1523! **************************************************************************************************
1524!> \brief multiplies pw coeffs with a number
1525!> \param pw ...
1526!> \param a ...
1527!> \par History
1528!> 11.2004 created [Joost VandeVondele]
1529! **************************************************************************************************
1530 SUBROUTINE pw_scale_c3d_rs (pw, a)
1531
1532 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw
1533 REAL(KIND=dp), INTENT(IN) :: a
1534
1535 CHARACTER(len=*), PARAMETER :: routineN = 'pw_scale'
1536
1537 INTEGER :: handle
1538
1539 CALL timeset(routinen, handle)
1540
1541!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(A, pw)
1542 pw%array = a*pw%array
1543!$OMP END PARALLEL WORKSHARE
1544
1545 CALL timestop(handle)
1546
1547 END SUBROUTINE pw_scale_c3d_rs
1548
1549! **************************************************************************************************
1550!> \brief writes a small description of the actual grid
1551!> (change to output the data as cube file, maybe with an
1552!> optional long_description arg?)
1553!> \param pw the pw data to output
1554!> \param unit_nr the unit to output to
1555!> \par History
1556!> 08.2002 created [fawzi]
1557!> \author Fawzi Mohamed
1558! **************************************************************************************************
1559 SUBROUTINE pw_write_c3d_rs (pw, unit_nr)
1560
1561 TYPE(pw_c3d_rs_type), INTENT(in) :: pw
1562 INTEGER, INTENT(in) :: unit_nr
1563
1564 INTEGER :: iostatus
1565
1566 WRITE (unit=unit_nr, fmt="('<pw>:{ ')", iostat=iostatus)
1567
1568 WRITE (unit=unit_nr, fmt="(a)", iostat=iostatus) " in_use=c3d"
1569 IF (ASSOCIATED(pw%array)) THEN
1570 WRITE (unit=unit_nr, fmt="(' array=<c(',i8,':',i8,',',i8,':',i8,',',i8,':',i8,')>')") &
1571 lbound(pw%array, 1), ubound(pw%array, 1), lbound(pw%array, 2), ubound(pw%array, 2), &
1572 lbound(pw%array, 3), ubound(pw%array, 3)
1573 ELSE
1574 WRITE (unit=unit_nr, fmt="(' array=*null*')")
1575 END IF
1576
1577 END SUBROUTINE pw_write_c3d_rs
1578
1579! **************************************************************************************************
1580!> \brief ...
1581!> \param fun ...
1582!> \param isign ...
1583!> \param oprt ...
1584!> \return ...
1585! **************************************************************************************************
1586 FUNCTION pw_integrate_function_c3d_rs (fun, isign, oprt) RESULT(total_fun)
1587
1588 TYPE(pw_c3d_rs_type), INTENT(IN) :: fun
1589 INTEGER, INTENT(IN), OPTIONAL :: isign
1590 CHARACTER(len=*), INTENT(IN), OPTIONAL :: oprt
1591 REAL(kind=dp) :: total_fun
1592
1593 INTEGER :: iop
1594
1595 iop = 0
1596
1597 IF (PRESENT(oprt)) THEN
1598 SELECT CASE (oprt)
1599 CASE ("ABS", "abs")
1600 iop = 1
1601 CASE DEFAULT
1602 cpabort("Unknown operator")
1603 END SELECT
1604 END IF
1605
1606 total_fun = 0.0_dp
1607
1608 ! do reduction using maximum accuracy
1609 IF (iop == 1) THEN
1610 total_fun = fun%pw_grid%dvol*accurate_sum(abs(fun%array))
1611 ELSE
1612 total_fun = fun%pw_grid%dvol*accurate_sum( real(fun%array, kind=dp))
1613 END IF
1614
1615 IF (fun%pw_grid%para%mode /= pw_mode_local) THEN
1616 CALL fun%pw_grid%para%group%sum(total_fun)
1617 END IF
1618
1619 IF (PRESENT(isign)) THEN
1620 total_fun = total_fun*sign(1._dp, real(isign, dp))
1621 END IF
1622
1623 END FUNCTION pw_integrate_function_c3d_rs
1624
1625! **************************************************************************************************
1626!> \brief ...
1627!> \param pw ...
1628!> \param value ...
1629! **************************************************************************************************
1630 SUBROUTINE pw_set_value_c3d_rs (pw, value)
1631 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw
1632 REAL(KIND=dp), INTENT(IN) :: value
1633
1634 CHARACTER(len=*), PARAMETER :: routineN = 'pw_set_value'
1635
1636 INTEGER :: handle
1637
1638 CALL timeset(routinen, handle)
1639
1640!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw,value)
1641 pw%array = cmplx(value, 0.0_dp, kind=dp)
1642!$OMP END PARALLEL WORKSHARE
1643
1644 CALL timestop(handle)
1645
1646 END SUBROUTINE pw_set_value_c3d_rs
1647! **************************************************************************************************
1648!> \brief Set values of a pw type to zero
1649!> \param pw ...
1650!> \par History
1651!> none
1652!> \author apsi
1653! **************************************************************************************************
1654 SUBROUTINE pw_zero_c3d_gs (pw)
1655
1656 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw
1657
1658 CHARACTER(len=*), PARAMETER :: routineN = 'pw_zero'
1659
1660 INTEGER :: handle
1661
1662 CALL timeset(routinen, handle)
1663
1664#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
1665!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw)
1666 pw%array = cmplx(0.0_dp, 0.0_dp, kind=dp)
1667!$OMP END PARALLEL WORKSHARE
1668#else
1669 pw%array = cmplx(0.0_dp, 0.0_dp, kind=dp)
1670#endif
1671
1672 CALL timestop(handle)
1673
1674 END SUBROUTINE pw_zero_c3d_gs
1675
1676! **************************************************************************************************
1677!> \brief multiplies pw coeffs with a number
1678!> \param pw ...
1679!> \param a ...
1680!> \par History
1681!> 11.2004 created [Joost VandeVondele]
1682! **************************************************************************************************
1683 SUBROUTINE pw_scale_c3d_gs (pw, a)
1684
1685 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw
1686 REAL(KIND=dp), INTENT(IN) :: a
1687
1688 CHARACTER(len=*), PARAMETER :: routineN = 'pw_scale'
1689
1690 INTEGER :: handle
1691
1692 CALL timeset(routinen, handle)
1693
1694!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(A, pw)
1695 pw%array = a*pw%array
1696!$OMP END PARALLEL WORKSHARE
1697
1698 CALL timestop(handle)
1699
1700 END SUBROUTINE pw_scale_c3d_gs
1701
1702! **************************************************************************************************
1703!> \brief writes a small description of the actual grid
1704!> (change to output the data as cube file, maybe with an
1705!> optional long_description arg?)
1706!> \param pw the pw data to output
1707!> \param unit_nr the unit to output to
1708!> \par History
1709!> 08.2002 created [fawzi]
1710!> \author Fawzi Mohamed
1711! **************************************************************************************************
1712 SUBROUTINE pw_write_c3d_gs (pw, unit_nr)
1713
1714 TYPE(pw_c3d_gs_type), INTENT(in) :: pw
1715 INTEGER, INTENT(in) :: unit_nr
1716
1717 INTEGER :: iostatus
1718
1719 WRITE (unit=unit_nr, fmt="('<pw>:{ ')", iostat=iostatus)
1720
1721 WRITE (unit=unit_nr, fmt="(a)", iostat=iostatus) " in_use=c3d"
1722 IF (ASSOCIATED(pw%array)) THEN
1723 WRITE (unit=unit_nr, fmt="(' array=<c(',i8,':',i8,',',i8,':',i8,',',i8,':',i8,')>')") &
1724 lbound(pw%array, 1), ubound(pw%array, 1), lbound(pw%array, 2), ubound(pw%array, 2), &
1725 lbound(pw%array, 3), ubound(pw%array, 3)
1726 ELSE
1727 WRITE (unit=unit_nr, fmt="(' array=*null*')")
1728 END IF
1729
1730 END SUBROUTINE pw_write_c3d_gs
1731
1732! **************************************************************************************************
1733!> \brief ...
1734!> \param fun ...
1735!> \param isign ...
1736!> \param oprt ...
1737!> \return ...
1738! **************************************************************************************************
1739 FUNCTION pw_integrate_function_c3d_gs (fun, isign, oprt) RESULT(total_fun)
1740
1741 TYPE(pw_c3d_gs_type), INTENT(IN) :: fun
1742 INTEGER, INTENT(IN), OPTIONAL :: isign
1743 CHARACTER(len=*), INTENT(IN), OPTIONAL :: oprt
1744 REAL(kind=dp) :: total_fun
1745
1746 INTEGER :: iop
1747
1748 iop = 0
1749
1750 IF (PRESENT(oprt)) THEN
1751 SELECT CASE (oprt)
1752 CASE ("ABS", "abs")
1753 iop = 1
1754 CASE DEFAULT
1755 cpabort("Unknown operator")
1756 END SELECT
1757 END IF
1758
1759 total_fun = 0.0_dp
1760
1761 IF (iop == 1) &
1762 cpabort("Operator ABS not implemented")
1763 cpabort("Reciprocal space integration for 3D grids not implemented!")
1764
1765 IF (fun%pw_grid%para%mode /= pw_mode_local) THEN
1766 CALL fun%pw_grid%para%group%sum(total_fun)
1767 END IF
1768
1769 IF (PRESENT(isign)) THEN
1770 total_fun = total_fun*sign(1._dp, real(isign, dp))
1771 END IF
1772
1773 END FUNCTION pw_integrate_function_c3d_gs
1774
1775! **************************************************************************************************
1776!> \brief ...
1777!> \param pw ...
1778!> \param value ...
1779! **************************************************************************************************
1780 SUBROUTINE pw_set_value_c3d_gs (pw, value)
1781 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw
1782 REAL(KIND=dp), INTENT(IN) :: value
1783
1784 CHARACTER(len=*), PARAMETER :: routineN = 'pw_set_value'
1785
1786 INTEGER :: handle
1787
1788 CALL timeset(routinen, handle)
1789
1790!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw,value)
1791 pw%array = cmplx(value, 0.0_dp, kind=dp)
1792!$OMP END PARALLEL WORKSHARE
1793
1794 CALL timestop(handle)
1795
1796 END SUBROUTINE pw_set_value_c3d_gs
1797
1798
1799! **************************************************************************************************
1800!> \brief copy a pw type variable
1801!> \param pw1 ...
1802!> \param pw2 ...
1803!> \par History
1804!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
1805!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
1806!> JGH (21-Feb-2003) : Code for generalized reference grids
1807!> \author apsi
1808!> \note
1809!> Currently only copying of respective types allowed,
1810!> in order to avoid errors
1811! **************************************************************************************************
1812 SUBROUTINE pw_copy_r1d_r1d_rs (pw1, pw2)
1813
1814 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw1
1815 TYPE(pw_r1d_rs_type), INTENT(INOUT) :: pw2
1816
1817 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
1818
1819 INTEGER :: handle
1820 INTEGER :: i, j, ng, ng1, ng2, ns
1821
1822 CALL timeset(routinen, handle)
1823
1824 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
1825 cpabort("Both grids must be either spherical or non-spherical!")
1826 IF (pw1%pw_grid%spherical) &
1827 cpabort("Spherical grids only exist in reciprocal space!")
1828
1829 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
1830 IF (pw1%pw_grid%spherical .AND. pw2%pw_grid%spherical) THEN
1831 IF (pw_compatible(pw1%pw_grid, pw2%pw_grid)) THEN
1832 ng1 = SIZE(pw1%array)
1833 ng2 = SIZE(pw2%array)
1834 ng = min(ng1, ng2)
1835!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, pw1, pw2)
1836 pw2%array(1:ng) = pw1%array(1:ng)
1837!$OMP END PARALLEL WORKSHARE
1838 IF (ng2 > ng) THEN
1839!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, ng2, pw2)
1840 pw2%array(ng + 1:ng2) = 0.0_dp
1841!$OMP END PARALLEL WORKSHARE
1842 END IF
1843 ELSE
1844 cpabort("Copies between spherical grids require compatible grids!")
1845 END IF
1846 ELSE
1847 ng1 = SIZE(pw1%array)
1848 ng2 = SIZE(pw2%array)
1849 ns = 2*max(ng1, ng2)
1850
1851 IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
1852 IF (ng1 >= ng2) THEN
1853!$OMP PARALLEL DO DEFAULT(NONE) &
1854!$OMP PRIVATE(i,j) &
1855!$OMP SHARED(ng2, pw1, pw2)
1856 DO i = 1, ng2
1857 j = pw2%pw_grid%gidx(i)
1858 pw2%array(i) = pw1%array(j)
1859 END DO
1860!$OMP END PARALLEL DO
1861 ELSE
1862 CALL pw_zero(pw2)
1863!$OMP PARALLEL DO DEFAULT(NONE) &
1864!$OMP PRIVATE(i,j) &
1865!$OMP SHARED(ng1, pw1, pw2)
1866 DO i = 1, ng1
1867 j = pw2%pw_grid%gidx(i)
1868 pw2%array(j) = pw1%array(i)
1869 END DO
1870!$OMP END PARALLEL DO
1871 END IF
1872 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
1873 IF (ng1 >= ng2) THEN
1874!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng2, pw1, pw2)
1875 DO i = 1, ng2
1876 j = pw1%pw_grid%gidx(i)
1877 pw2%array(i) = pw1%array(j)
1878 END DO
1879!$OMP END PARALLEL DO
1880 ELSE
1881 CALL pw_zero(pw2)
1882!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng1, pw1, pw2)
1883 DO i = 1, ng1
1884 j = pw1%pw_grid%gidx(i)
1885 pw2%array(j) = pw1%array(i)
1886 END DO
1887!$OMP END PARALLEL DO
1888 END IF
1889 ELSE
1890 cpabort("Copy not implemented!")
1891 END IF
1892
1893 END IF
1894
1895 ELSE
1896!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
1897 pw2%array = pw1%array
1898!$OMP END PARALLEL WORKSHARE
1899 END IF
1900
1901 CALL timestop(handle)
1902
1903 END SUBROUTINE pw_copy_r1d_r1d_rs
1904
1905! **************************************************************************************************
1906!> \brief ...
1907!> \param pw ...
1908!> \param array ...
1909! **************************************************************************************************
1910 SUBROUTINE pw_copy_to_array_r1d_r1d_rs (pw, array)
1911 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw
1912 REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: array
1913
1914 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
1915
1916 INTEGER :: handle
1917
1918 CALL timeset(routinen, handle)
1919
1920!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
1921 array(:) = pw%array(:)
1922!$OMP END PARALLEL WORKSHARE
1923
1924 CALL timestop(handle)
1925 END SUBROUTINE pw_copy_to_array_r1d_r1d_rs
1926
1927! **************************************************************************************************
1928!> \brief ...
1929!> \param pw ...
1930!> \param array ...
1931! **************************************************************************************************
1932 SUBROUTINE pw_copy_from_array_r1d_r1d_rs (pw, array)
1933 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw
1934 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: array
1935
1936 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
1937
1938 INTEGER :: handle
1939
1940 CALL timeset(routinen, handle)
1941
1942!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
1943 pw%array = array
1944!$OMP END PARALLEL WORKSHARE
1945
1946 CALL timestop(handle)
1947 END SUBROUTINE pw_copy_from_array_r1d_r1d_rs
1948
1949! **************************************************************************************************
1950!> \brief pw2 = alpha*pw1 + beta*pw2
1951!> alpha defaults to 1, beta defaults to 1
1952!> \param pw1 ...
1953!> \param pw2 ...
1954!> \param alpha ...
1955!> \param beta ...
1956!> \param allow_noncompatible_grids ...
1957!> \par History
1958!> JGH (21-Feb-2003) : added reference grid functionality
1959!> JGH (01-Dec-2007) : rename and remove complex alpha
1960!> \author apsi
1961!> \note
1962!> Currently only summing up of respective types allowed,
1963!> in order to avoid errors
1964! **************************************************************************************************
1965 SUBROUTINE pw_axpy_r1d_r1d_rs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
1966
1967 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw1
1968 TYPE(pw_r1d_rs_type), INTENT(INOUT) :: pw2
1969 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
1970 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
1971
1972 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
1973
1974 INTEGER :: handle
1975 LOGICAL :: my_allow_noncompatible_grids
1976 REAL(KIND=dp) :: my_alpha, my_beta
1977 INTEGER :: i, j, ng, ng1, ng2
1978
1979 CALL timeset(routinen, handle)
1980
1981 my_alpha = 1.0_dp
1982 IF (PRESENT(alpha)) my_alpha = alpha
1983
1984 my_beta = 1.0_dp
1985 IF (PRESENT(beta)) my_beta = beta
1986
1987 my_allow_noncompatible_grids = .false.
1988 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
1989
1990 IF (my_beta /= 1.0_dp) THEN
1991 IF (my_beta == 0.0_dp) THEN
1992 CALL pw_zero(pw2)
1993 ELSE
1994!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
1995 pw2%array = pw2%array*my_beta
1996!$OMP END PARALLEL WORKSHARE
1997 END IF
1998 END IF
1999
2000 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
2001
2002 IF (my_alpha == 1.0_dp) THEN
2003!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
2004 pw2%array = pw2%array + pw1%array
2005!$OMP END PARALLEL WORKSHARE
2006 ELSE IF (my_alpha /= 0.0_dp) THEN
2007!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha)
2008 pw2%array = pw2%array + my_alpha* pw1%array
2009!$OMP END PARALLEL WORKSHARE
2010 END IF
2011
2012 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
2013
2014 ng1 = SIZE(pw1%array)
2015 ng2 = SIZE(pw2%array)
2016 ng = min(ng1, ng2)
2017
2018 IF (pw1%pw_grid%spherical) THEN
2019 IF (my_alpha == 1.0_dp) THEN
2020!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2021 DO i = 1, ng
2022 pw2%array(i) = pw2%array(i) + pw1%array(i)
2023 END DO
2024!$OMP END PARALLEL DO
2025 ELSE IF (my_alpha /= 0.0_dp) THEN
2026!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha,ng)
2027 DO i = 1, ng
2028 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(i)
2029 END DO
2030!$OMP END PARALLEL DO
2031 END IF
2032 ELSE IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
2033 IF (ng1 >= ng2) THEN
2034 IF (my_alpha == 1.0_dp) THEN
2035!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2036 DO i = 1, ng
2037 j = pw2%pw_grid%gidx(i)
2038 pw2%array(i) = pw2%array(i) + pw1%array(j)
2039 END DO
2040!$OMP END PARALLEL DO
2041 ELSE IF (my_alpha /= 0.0_dp) THEN
2042!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
2043 DO i = 1, ng
2044 j = pw2%pw_grid%gidx(i)
2045 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(j)
2046 END DO
2047!$OMP END PARALLEL DO
2048 END IF
2049 ELSE
2050 IF (my_alpha == 1.0_dp) THEN
2051!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2052 DO i = 1, ng
2053 j = pw2%pw_grid%gidx(i)
2054 pw2%array(j) = pw2%array(j) + pw1%array(i)
2055 END DO
2056!$OMP END PARALLEL DO
2057 ELSE IF (my_alpha /= 0.0_dp) THEN
2058!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
2059 DO i = 1, ng
2060 j = pw2%pw_grid%gidx(i)
2061 pw2%array(j) = pw2%array(j) + my_alpha* pw1%array(i)
2062 END DO
2063!$OMP END PARALLEL DO
2064 END IF
2065 END IF
2066 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
2067 IF (ng1 >= ng2) THEN
2068 IF (my_alpha == 1.0_dp) THEN
2069!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2070 DO i = 1, ng
2071 j = pw1%pw_grid%gidx(i)
2072 pw2%array(i) = pw2%array(i) + pw1%array(j)
2073 END DO
2074!$OMP END PARALLEL DO
2075 ELSE IF (my_alpha /= 0.0_dp) THEN
2076!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
2077 DO i = 1, ng
2078 j = pw1%pw_grid%gidx(i)
2079 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(j)
2080 END DO
2081!$OMP END PARALLEL DO
2082 END IF
2083 ELSE
2084 IF (my_alpha == 1.0_dp) THEN
2085!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2086 DO i = 1, ng
2087 j = pw1%pw_grid%gidx(i)
2088 pw2%array(j) = pw2%array(j) + pw1%array(i)
2089 END DO
2090!$OMP END PARALLEL DO
2091 ELSE IF (my_alpha /= 0.0_dp) THEN
2092!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
2093 DO i = 1, ng
2094 j = pw1%pw_grid%gidx(i)
2095 pw2%array(j) = pw2%array(j) + my_alpha* pw1%array(i)
2096 END DO
2097!$OMP END PARALLEL DO
2098 END IF
2099 END IF
2100 ELSE
2101 cpabort("Grids not compatible")
2102 END IF
2103
2104 ELSE
2105
2106 cpabort("Grids not compatible")
2107
2108 END IF
2109
2110 CALL timestop(handle)
2111
2112 END SUBROUTINE pw_axpy_r1d_r1d_rs
2113
2114! **************************************************************************************************
2115!> \brief pw_out = pw_out + alpha * pw1 * pw2
2116!> alpha defaults to 1
2117!> \param pw_out ...
2118!> \param pw1 ...
2119!> \param pw2 ...
2120!> \param alpha ...
2121!> \author JGH
2122! **************************************************************************************************
2123 SUBROUTINE pw_multiply_r1d_r1d_rs (pw_out, pw1, pw2, alpha)
2124
2125 TYPE(pw_r1d_rs_type), INTENT(INOUT) :: pw_out
2126 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw1
2127 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw2
2128 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
2129
2130 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
2131
2132 INTEGER :: handle
2133 REAL(KIND=dp) :: my_alpha
2134
2135 CALL timeset(routinen, handle)
2136
2137 my_alpha = 1.0_dp
2138 IF (PRESENT(alpha)) my_alpha = alpha
2139
2140 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
2141 cpabort("pw_multiply not implemented for non-identical grids!")
2142
2143#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
2144 IF (my_alpha == 1.0_dp) THEN
2145!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
2146 pw_out%array = pw_out%array + pw1%array* pw2%array
2147!$OMP END PARALLEL WORKSHARE
2148 ELSE
2149!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
2150 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
2151!$OMP END PARALLEL WORKSHARE
2152 END IF
2153#else
2154 IF (my_alpha == 1.0_dp) THEN
2155 pw_out%array = pw_out%array + pw1%array* pw2%array
2156 ELSE
2157 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
2158 END IF
2159#endif
2160
2161 CALL timestop(handle)
2162
2163 END SUBROUTINE pw_multiply_r1d_r1d_rs
2164
2165! **************************************************************************************************
2166!> \brief ...
2167!> \param pw1 ...
2168!> \param pw2 ...
2169! **************************************************************************************************
2170 SUBROUTINE pw_multiply_with_r1d_r1d_rs (pw1, pw2)
2171 TYPE(pw_r1d_rs_type), INTENT(INOUT) :: pw1
2172 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw2
2173
2174 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
2175
2176 INTEGER :: handle
2177
2178 CALL timeset(routinen, handle)
2179
2180 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
2181 cpabort("Incompatible grids!")
2182
2183!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
2184 pw1%array = pw1%array* pw2%array
2185!$OMP END PARALLEL WORKSHARE
2186
2187 CALL timestop(handle)
2188
2189 END SUBROUTINE pw_multiply_with_r1d_r1d_rs
2190
2191! **************************************************************************************************
2192!> \brief Calculate integral over unit cell for functions in plane wave basis
2193!> only returns the real part of it ......
2194!> \param pw1 ...
2195!> \param pw2 ...
2196!> \param sumtype ...
2197!> \param just_sum ...
2198!> \param local_only ...
2199!> \return ...
2200!> \par History
2201!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
2202!> \author apsi
2203! **************************************************************************************************
2204 FUNCTION pw_integral_ab_r1d_r1d_rs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
2205
2206 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw1
2207 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw2
2208 INTEGER, INTENT(IN), OPTIONAL :: sumtype
2209 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
2210 REAL(kind=dp) :: integral_value
2211
2212 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_r1d_r1d_rs'
2213
2214 INTEGER :: handle, loc_sumtype
2215 LOGICAL :: my_just_sum, my_local_only
2216
2217 CALL timeset(routinen, handle)
2218
2219 loc_sumtype = do_accurate_sum
2220 IF (PRESENT(sumtype)) loc_sumtype = sumtype
2221
2222 my_local_only = .false.
2223 IF (PRESENT(local_only)) my_local_only = local_only
2224
2225 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
2226 cpabort("Grids incompatible")
2227 END IF
2228
2229 my_just_sum = .false.
2230 IF (PRESENT(just_sum)) my_just_sum = just_sum
2231
2232 ! do standard sum
2233 IF (loc_sumtype == do_standard_sum) THEN
2234
2235 ! Do standard sum
2236
2237 integral_value = dot_product(pw1%array, pw2%array)
2238
2239 ELSE
2240
2241 ! Do accurate sum
2242 integral_value = accurate_dot_product(pw1%array, pw2%array)
2243
2244 END IF
2245
2246 ! Apply reciprocal multiplicity before scaling the integral;
2247 ! the unpaired G=0 term must receive the same volume factor.
2248 IF (pw1%pw_grid%grid_span == halfspace) THEN
2249 integral_value = 2.0_dp*integral_value
2250 IF (pw1%pw_grid%have_g0) integral_value = integral_value - &
2251 pw1%array(1)*pw2%array(1)
2252 END IF
2253
2254 IF (.NOT. my_just_sum) THEN
2255 integral_value = integral_value*pw1%pw_grid%dvol
2256 END IF
2257
2258 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
2259 CALL pw1%pw_grid%para%group%sum(integral_value)
2260
2261 CALL timestop(handle)
2262
2263 END FUNCTION pw_integral_ab_r1d_r1d_rs
2264! **************************************************************************************************
2265!> \brief copy a pw type variable
2266!> \param pw1 ...
2267!> \param pw2 ...
2268!> \par History
2269!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
2270!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
2271!> JGH (21-Feb-2003) : Code for generalized reference grids
2272!> \author apsi
2273!> \note
2274!> Currently only copying of respective types allowed,
2275!> in order to avoid errors
2276! **************************************************************************************************
2277 SUBROUTINE pw_copy_r1d_r1d_gs (pw1, pw2)
2278
2279 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
2280 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw2
2281
2282 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
2283
2284 INTEGER :: handle
2285 INTEGER :: i, j, ng, ng1, ng2, ns
2286
2287 CALL timeset(routinen, handle)
2288
2289 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
2290 cpabort("Both grids must be either spherical or non-spherical!")
2291
2292 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
2293 IF (pw1%pw_grid%spherical .AND. pw2%pw_grid%spherical) THEN
2294 IF (pw_compatible(pw1%pw_grid, pw2%pw_grid)) THEN
2295 ng1 = SIZE(pw1%array)
2296 ng2 = SIZE(pw2%array)
2297 ng = min(ng1, ng2)
2298!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, pw1, pw2)
2299 pw2%array(1:ng) = pw1%array(1:ng)
2300!$OMP END PARALLEL WORKSHARE
2301 IF (ng2 > ng) THEN
2302!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, ng2, pw2)
2303 pw2%array(ng + 1:ng2) = 0.0_dp
2304!$OMP END PARALLEL WORKSHARE
2305 END IF
2306 ELSE
2307 cpabort("Copies between spherical grids require compatible grids!")
2308 END IF
2309 ELSE
2310 ng1 = SIZE(pw1%array)
2311 ng2 = SIZE(pw2%array)
2312 ns = 2*max(ng1, ng2)
2313
2314 IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
2315 IF (ng1 >= ng2) THEN
2316!$OMP PARALLEL DO DEFAULT(NONE) &
2317!$OMP PRIVATE(i,j) &
2318!$OMP SHARED(ng2, pw1, pw2)
2319 DO i = 1, ng2
2320 j = pw2%pw_grid%gidx(i)
2321 pw2%array(i) = pw1%array(j)
2322 END DO
2323!$OMP END PARALLEL DO
2324 ELSE
2325 CALL pw_zero(pw2)
2326!$OMP PARALLEL DO DEFAULT(NONE) &
2327!$OMP PRIVATE(i,j) &
2328!$OMP SHARED(ng1, pw1, pw2)
2329 DO i = 1, ng1
2330 j = pw2%pw_grid%gidx(i)
2331 pw2%array(j) = pw1%array(i)
2332 END DO
2333!$OMP END PARALLEL DO
2334 END IF
2335 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
2336 IF (ng1 >= ng2) THEN
2337!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng2, pw1, pw2)
2338 DO i = 1, ng2
2339 j = pw1%pw_grid%gidx(i)
2340 pw2%array(i) = pw1%array(j)
2341 END DO
2342!$OMP END PARALLEL DO
2343 ELSE
2344 CALL pw_zero(pw2)
2345!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng1, pw1, pw2)
2346 DO i = 1, ng1
2347 j = pw1%pw_grid%gidx(i)
2348 pw2%array(j) = pw1%array(i)
2349 END DO
2350!$OMP END PARALLEL DO
2351 END IF
2352 ELSE
2353 cpabort("Copy not implemented!")
2354 END IF
2355
2356 END IF
2357
2358 ELSE
2359!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
2360 pw2%array = pw1%array
2361!$OMP END PARALLEL WORKSHARE
2362 END IF
2363
2364 CALL timestop(handle)
2365
2366 END SUBROUTINE pw_copy_r1d_r1d_gs
2367
2368! **************************************************************************************************
2369!> \brief ...
2370!> \param pw ...
2371!> \param array ...
2372! **************************************************************************************************
2373 SUBROUTINE pw_copy_to_array_r1d_r1d_gs (pw, array)
2374 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw
2375 REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: array
2376
2377 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
2378
2379 INTEGER :: handle
2380
2381 CALL timeset(routinen, handle)
2382
2383!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
2384 array(:) = pw%array(:)
2385!$OMP END PARALLEL WORKSHARE
2386
2387 CALL timestop(handle)
2388 END SUBROUTINE pw_copy_to_array_r1d_r1d_gs
2389
2390! **************************************************************************************************
2391!> \brief ...
2392!> \param pw ...
2393!> \param array ...
2394! **************************************************************************************************
2395 SUBROUTINE pw_copy_from_array_r1d_r1d_gs (pw, array)
2396 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw
2397 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: array
2398
2399 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
2400
2401 INTEGER :: handle
2402
2403 CALL timeset(routinen, handle)
2404
2405!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
2406 pw%array = array
2407!$OMP END PARALLEL WORKSHARE
2408
2409 CALL timestop(handle)
2410 END SUBROUTINE pw_copy_from_array_r1d_r1d_gs
2411
2412! **************************************************************************************************
2413!> \brief pw2 = alpha*pw1 + beta*pw2
2414!> alpha defaults to 1, beta defaults to 1
2415!> \param pw1 ...
2416!> \param pw2 ...
2417!> \param alpha ...
2418!> \param beta ...
2419!> \param allow_noncompatible_grids ...
2420!> \par History
2421!> JGH (21-Feb-2003) : added reference grid functionality
2422!> JGH (01-Dec-2007) : rename and remove complex alpha
2423!> \author apsi
2424!> \note
2425!> Currently only summing up of respective types allowed,
2426!> in order to avoid errors
2427! **************************************************************************************************
2428 SUBROUTINE pw_axpy_r1d_r1d_gs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
2429
2430 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
2431 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw2
2432 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
2433 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
2434
2435 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
2436
2437 INTEGER :: handle
2438 LOGICAL :: my_allow_noncompatible_grids
2439 REAL(KIND=dp) :: my_alpha, my_beta
2440 INTEGER :: i, j, ng, ng1, ng2
2441
2442 CALL timeset(routinen, handle)
2443
2444 my_alpha = 1.0_dp
2445 IF (PRESENT(alpha)) my_alpha = alpha
2446
2447 my_beta = 1.0_dp
2448 IF (PRESENT(beta)) my_beta = beta
2449
2450 my_allow_noncompatible_grids = .false.
2451 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
2452
2453 IF (my_beta /= 1.0_dp) THEN
2454 IF (my_beta == 0.0_dp) THEN
2455 CALL pw_zero(pw2)
2456 ELSE
2457!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
2458 pw2%array = pw2%array*my_beta
2459!$OMP END PARALLEL WORKSHARE
2460 END IF
2461 END IF
2462
2463 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
2464
2465 IF (my_alpha == 1.0_dp) THEN
2466!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
2467 pw2%array = pw2%array + pw1%array
2468!$OMP END PARALLEL WORKSHARE
2469 ELSE IF (my_alpha /= 0.0_dp) THEN
2470!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha)
2471 pw2%array = pw2%array + my_alpha* pw1%array
2472!$OMP END PARALLEL WORKSHARE
2473 END IF
2474
2475 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
2476
2477 ng1 = SIZE(pw1%array)
2478 ng2 = SIZE(pw2%array)
2479 ng = min(ng1, ng2)
2480
2481 IF (pw1%pw_grid%spherical) THEN
2482 IF (my_alpha == 1.0_dp) THEN
2483!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2484 DO i = 1, ng
2485 pw2%array(i) = pw2%array(i) + pw1%array(i)
2486 END DO
2487!$OMP END PARALLEL DO
2488 ELSE IF (my_alpha /= 0.0_dp) THEN
2489!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha,ng)
2490 DO i = 1, ng
2491 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(i)
2492 END DO
2493!$OMP END PARALLEL DO
2494 END IF
2495 ELSE IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
2496 IF (ng1 >= ng2) THEN
2497 IF (my_alpha == 1.0_dp) THEN
2498!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2499 DO i = 1, ng
2500 j = pw2%pw_grid%gidx(i)
2501 pw2%array(i) = pw2%array(i) + pw1%array(j)
2502 END DO
2503!$OMP END PARALLEL DO
2504 ELSE IF (my_alpha /= 0.0_dp) THEN
2505!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
2506 DO i = 1, ng
2507 j = pw2%pw_grid%gidx(i)
2508 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(j)
2509 END DO
2510!$OMP END PARALLEL DO
2511 END IF
2512 ELSE
2513 IF (my_alpha == 1.0_dp) THEN
2514!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2515 DO i = 1, ng
2516 j = pw2%pw_grid%gidx(i)
2517 pw2%array(j) = pw2%array(j) + pw1%array(i)
2518 END DO
2519!$OMP END PARALLEL DO
2520 ELSE IF (my_alpha /= 0.0_dp) THEN
2521!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
2522 DO i = 1, ng
2523 j = pw2%pw_grid%gidx(i)
2524 pw2%array(j) = pw2%array(j) + my_alpha* pw1%array(i)
2525 END DO
2526!$OMP END PARALLEL DO
2527 END IF
2528 END IF
2529 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
2530 IF (ng1 >= ng2) THEN
2531 IF (my_alpha == 1.0_dp) THEN
2532!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2533 DO i = 1, ng
2534 j = pw1%pw_grid%gidx(i)
2535 pw2%array(i) = pw2%array(i) + pw1%array(j)
2536 END DO
2537!$OMP END PARALLEL DO
2538 ELSE IF (my_alpha /= 0.0_dp) THEN
2539!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
2540 DO i = 1, ng
2541 j = pw1%pw_grid%gidx(i)
2542 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(j)
2543 END DO
2544!$OMP END PARALLEL DO
2545 END IF
2546 ELSE
2547 IF (my_alpha == 1.0_dp) THEN
2548!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2549 DO i = 1, ng
2550 j = pw1%pw_grid%gidx(i)
2551 pw2%array(j) = pw2%array(j) + pw1%array(i)
2552 END DO
2553!$OMP END PARALLEL DO
2554 ELSE IF (my_alpha /= 0.0_dp) THEN
2555!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
2556 DO i = 1, ng
2557 j = pw1%pw_grid%gidx(i)
2558 pw2%array(j) = pw2%array(j) + my_alpha* pw1%array(i)
2559 END DO
2560!$OMP END PARALLEL DO
2561 END IF
2562 END IF
2563 ELSE
2564 cpabort("Grids not compatible")
2565 END IF
2566
2567 ELSE
2568
2569 cpabort("Grids not compatible")
2570
2571 END IF
2572
2573 CALL timestop(handle)
2574
2575 END SUBROUTINE pw_axpy_r1d_r1d_gs
2576
2577! **************************************************************************************************
2578!> \brief pw_out = pw_out + alpha * pw1 * pw2
2579!> alpha defaults to 1
2580!> \param pw_out ...
2581!> \param pw1 ...
2582!> \param pw2 ...
2583!> \param alpha ...
2584!> \author JGH
2585! **************************************************************************************************
2586 SUBROUTINE pw_multiply_r1d_r1d_gs (pw_out, pw1, pw2, alpha)
2587
2588 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw_out
2589 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
2590 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw2
2591 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
2592
2593 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
2594
2595 INTEGER :: handle
2596 REAL(KIND=dp) :: my_alpha
2597
2598 CALL timeset(routinen, handle)
2599
2600 my_alpha = 1.0_dp
2601 IF (PRESENT(alpha)) my_alpha = alpha
2602
2603 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
2604 cpabort("pw_multiply not implemented for non-identical grids!")
2605
2606#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
2607 IF (my_alpha == 1.0_dp) THEN
2608!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
2609 pw_out%array = pw_out%array + pw1%array* pw2%array
2610!$OMP END PARALLEL WORKSHARE
2611 ELSE
2612!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
2613 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
2614!$OMP END PARALLEL WORKSHARE
2615 END IF
2616#else
2617 IF (my_alpha == 1.0_dp) THEN
2618 pw_out%array = pw_out%array + pw1%array* pw2%array
2619 ELSE
2620 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
2621 END IF
2622#endif
2623
2624 CALL timestop(handle)
2625
2626 END SUBROUTINE pw_multiply_r1d_r1d_gs
2627
2628! **************************************************************************************************
2629!> \brief ...
2630!> \param pw1 ...
2631!> \param pw2 ...
2632! **************************************************************************************************
2633 SUBROUTINE pw_multiply_with_r1d_r1d_gs (pw1, pw2)
2634 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw1
2635 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw2
2636
2637 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
2638
2639 INTEGER :: handle
2640
2641 CALL timeset(routinen, handle)
2642
2643 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
2644 cpabort("Incompatible grids!")
2645
2646!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
2647 pw1%array = pw1%array* pw2%array
2648!$OMP END PARALLEL WORKSHARE
2649
2650 CALL timestop(handle)
2651
2652 END SUBROUTINE pw_multiply_with_r1d_r1d_gs
2653
2654! **************************************************************************************************
2655!> \brief Calculate integral over unit cell for functions in plane wave basis
2656!> only returns the real part of it ......
2657!> \param pw1 ...
2658!> \param pw2 ...
2659!> \param sumtype ...
2660!> \param just_sum ...
2661!> \param local_only ...
2662!> \return ...
2663!> \par History
2664!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
2665!> \author apsi
2666! **************************************************************************************************
2667 FUNCTION pw_integral_ab_r1d_r1d_gs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
2668
2669 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
2670 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw2
2671 INTEGER, INTENT(IN), OPTIONAL :: sumtype
2672 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
2673 REAL(kind=dp) :: integral_value
2674
2675 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_r1d_r1d_gs'
2676
2677 INTEGER :: handle, loc_sumtype
2678 LOGICAL :: my_just_sum, my_local_only
2679
2680 CALL timeset(routinen, handle)
2681
2682 loc_sumtype = do_accurate_sum
2683 IF (PRESENT(sumtype)) loc_sumtype = sumtype
2684
2685 my_local_only = .false.
2686 IF (PRESENT(local_only)) my_local_only = local_only
2687
2688 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
2689 cpabort("Grids incompatible")
2690 END IF
2691
2692 my_just_sum = .false.
2693 IF (PRESENT(just_sum)) my_just_sum = just_sum
2694
2695 ! do standard sum
2696 IF (loc_sumtype == do_standard_sum) THEN
2697
2698 ! Do standard sum
2699
2700 integral_value = dot_product(pw1%array, pw2%array)
2701
2702 ELSE
2703
2704 ! Do accurate sum
2705 integral_value = accurate_dot_product(pw1%array, pw2%array)
2706
2707 END IF
2708
2709 ! Apply reciprocal multiplicity before scaling the integral;
2710 ! the unpaired G=0 term must receive the same volume factor.
2711 IF (pw1%pw_grid%grid_span == halfspace) THEN
2712 integral_value = 2.0_dp*integral_value
2713 IF (pw1%pw_grid%have_g0) integral_value = integral_value - &
2714 pw1%array(1)*pw2%array(1)
2715 END IF
2716
2717 IF (.NOT. my_just_sum) THEN
2718 integral_value = integral_value*pw1%pw_grid%vol
2719 END IF
2720
2721 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
2722 CALL pw1%pw_grid%para%group%sum(integral_value)
2723
2724 CALL timestop(handle)
2725
2726 END FUNCTION pw_integral_ab_r1d_r1d_gs
2727
2728! **************************************************************************************************
2729!> \brief ...
2730!> \param pw1 ...
2731!> \param pw2 ...
2732!> \return ...
2733! **************************************************************************************************
2734 FUNCTION pw_integral_a2b_r1d_r1d (pw1, pw2) RESULT(integral_value)
2735
2736 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
2737 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw2
2738 REAL(kind=dp) :: integral_value
2739
2740 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_a2b'
2741
2742 INTEGER :: handle
2743
2744 CALL timeset(routinen, handle)
2745
2746 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
2747 cpabort("Grids incompatible")
2748 END IF
2749
2750 integral_value = accurate_sum(pw1%array*pw2%array*pw1%pw_grid%gsq)
2751 IF (pw1%pw_grid%grid_span == halfspace) THEN
2752 integral_value = 2.0_dp*integral_value
2753 END IF
2754
2755 integral_value = integral_value*pw1%pw_grid%vol
2756
2757 IF (pw1%pw_grid%para%mode == pw_mode_distributed) &
2758 CALL pw1%pw_grid%para%group%sum(integral_value)
2759 CALL timestop(handle)
2760
2761 END FUNCTION pw_integral_a2b_r1d_r1d
2762! **************************************************************************************************
2763!> \brief copy a pw type variable
2764!> \param pw1 ...
2765!> \param pw2 ...
2766!> \par History
2767!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
2768!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
2769!> JGH (21-Feb-2003) : Code for generalized reference grids
2770!> \author apsi
2771!> \note
2772!> Currently only copying of respective types allowed,
2773!> in order to avoid errors
2774! **************************************************************************************************
2775 SUBROUTINE pw_copy_r1d_c1d_rs (pw1, pw2)
2776
2777 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw1
2778 TYPE(pw_c1d_rs_type), INTENT(INOUT) :: pw2
2779
2780 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
2781
2782 INTEGER :: handle
2783 INTEGER :: i, j, ng, ng1, ng2, ns
2784
2785 CALL timeset(routinen, handle)
2786
2787 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
2788 cpabort("Both grids must be either spherical or non-spherical!")
2789 IF (pw1%pw_grid%spherical) &
2790 cpabort("Spherical grids only exist in reciprocal space!")
2791
2792 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
2793 IF (pw1%pw_grid%spherical .AND. pw2%pw_grid%spherical) THEN
2794 IF (pw_compatible(pw1%pw_grid, pw2%pw_grid)) THEN
2795 ng1 = SIZE(pw1%array)
2796 ng2 = SIZE(pw2%array)
2797 ng = min(ng1, ng2)
2798!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, pw1, pw2)
2799 pw2%array(1:ng) = cmplx(pw1%array(1:ng), 0.0_dp, kind=dp)
2800!$OMP END PARALLEL WORKSHARE
2801 IF (ng2 > ng) THEN
2802!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, ng2, pw2)
2803 pw2%array(ng + 1:ng2) = cmplx(0.0_dp, 0.0_dp, kind=dp)
2804!$OMP END PARALLEL WORKSHARE
2805 END IF
2806 ELSE
2807 cpabort("Copies between spherical grids require compatible grids!")
2808 END IF
2809 ELSE
2810 ng1 = SIZE(pw1%array)
2811 ng2 = SIZE(pw2%array)
2812 ns = 2*max(ng1, ng2)
2813
2814 IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
2815 IF (ng1 >= ng2) THEN
2816!$OMP PARALLEL DO DEFAULT(NONE) &
2817!$OMP PRIVATE(i,j) &
2818!$OMP SHARED(ng2, pw1, pw2)
2819 DO i = 1, ng2
2820 j = pw2%pw_grid%gidx(i)
2821 pw2%array(i) = cmplx(pw1%array(j), 0.0_dp, kind=dp)
2822 END DO
2823!$OMP END PARALLEL DO
2824 ELSE
2825 CALL pw_zero(pw2)
2826!$OMP PARALLEL DO DEFAULT(NONE) &
2827!$OMP PRIVATE(i,j) &
2828!$OMP SHARED(ng1, pw1, pw2)
2829 DO i = 1, ng1
2830 j = pw2%pw_grid%gidx(i)
2831 pw2%array(j) = cmplx(pw1%array(i), 0.0_dp, kind=dp)
2832 END DO
2833!$OMP END PARALLEL DO
2834 END IF
2835 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
2836 IF (ng1 >= ng2) THEN
2837!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng2, pw1, pw2)
2838 DO i = 1, ng2
2839 j = pw1%pw_grid%gidx(i)
2840 pw2%array(i) = cmplx(pw1%array(j), 0.0_dp, kind=dp)
2841 END DO
2842!$OMP END PARALLEL DO
2843 ELSE
2844 CALL pw_zero(pw2)
2845!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng1, pw1, pw2)
2846 DO i = 1, ng1
2847 j = pw1%pw_grid%gidx(i)
2848 pw2%array(j) = cmplx(pw1%array(i), 0.0_dp, kind=dp)
2849 END DO
2850!$OMP END PARALLEL DO
2851 END IF
2852 ELSE
2853 cpabort("Copy not implemented!")
2854 END IF
2855
2856 END IF
2857
2858 ELSE
2859!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
2860 pw2%array = cmplx(pw1%array, 0.0_dp, kind=dp)
2861!$OMP END PARALLEL WORKSHARE
2862 END IF
2863
2864 CALL timestop(handle)
2865
2866 END SUBROUTINE pw_copy_r1d_c1d_rs
2867
2868! **************************************************************************************************
2869!> \brief ...
2870!> \param pw ...
2871!> \param array ...
2872! **************************************************************************************************
2873 SUBROUTINE pw_copy_to_array_r1d_c1d_rs (pw, array)
2874 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw
2875 COMPLEX(KIND=dp), DIMENSION(:), INTENT(INOUT) :: array
2876
2877 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
2878
2879 INTEGER :: handle
2880
2881 CALL timeset(routinen, handle)
2882
2883!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
2884 array(:) = cmplx(pw%array(:), 0.0_dp, kind=dp)
2885!$OMP END PARALLEL WORKSHARE
2886
2887 CALL timestop(handle)
2888 END SUBROUTINE pw_copy_to_array_r1d_c1d_rs
2889
2890! **************************************************************************************************
2891!> \brief ...
2892!> \param pw ...
2893!> \param array ...
2894! **************************************************************************************************
2895 SUBROUTINE pw_copy_from_array_r1d_c1d_rs (pw, array)
2896 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw
2897 COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: array
2898
2899 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
2900
2901 INTEGER :: handle
2902
2903 CALL timeset(routinen, handle)
2904
2905!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
2906 pw%array = real(array, kind=dp)
2907!$OMP END PARALLEL WORKSHARE
2908
2909 CALL timestop(handle)
2910 END SUBROUTINE pw_copy_from_array_r1d_c1d_rs
2911
2912! **************************************************************************************************
2913!> \brief pw2 = alpha*pw1 + beta*pw2
2914!> alpha defaults to 1, beta defaults to 1
2915!> \param pw1 ...
2916!> \param pw2 ...
2917!> \param alpha ...
2918!> \param beta ...
2919!> \param allow_noncompatible_grids ...
2920!> \par History
2921!> JGH (21-Feb-2003) : added reference grid functionality
2922!> JGH (01-Dec-2007) : rename and remove complex alpha
2923!> \author apsi
2924!> \note
2925!> Currently only summing up of respective types allowed,
2926!> in order to avoid errors
2927! **************************************************************************************************
2928 SUBROUTINE pw_axpy_r1d_c1d_rs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
2929
2930 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw1
2931 TYPE(pw_c1d_rs_type), INTENT(INOUT) :: pw2
2932 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
2933 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
2934
2935 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
2936
2937 INTEGER :: handle
2938 LOGICAL :: my_allow_noncompatible_grids
2939 REAL(KIND=dp) :: my_alpha, my_beta
2940 INTEGER :: i, j, ng, ng1, ng2
2941
2942 CALL timeset(routinen, handle)
2943
2944 my_alpha = 1.0_dp
2945 IF (PRESENT(alpha)) my_alpha = alpha
2946
2947 my_beta = 1.0_dp
2948 IF (PRESENT(beta)) my_beta = beta
2949
2950 my_allow_noncompatible_grids = .false.
2951 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
2952
2953 IF (my_beta /= 1.0_dp) THEN
2954 IF (my_beta == 0.0_dp) THEN
2955 CALL pw_zero(pw2)
2956 ELSE
2957!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
2958 pw2%array = pw2%array*my_beta
2959!$OMP END PARALLEL WORKSHARE
2960 END IF
2961 END IF
2962
2963 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
2964
2965 IF (my_alpha == 1.0_dp) THEN
2966!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
2967 pw2%array = pw2%array + cmplx(pw1%array, 0.0_dp, kind=dp)
2968!$OMP END PARALLEL WORKSHARE
2969 ELSE IF (my_alpha /= 0.0_dp) THEN
2970!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha)
2971 pw2%array = pw2%array + my_alpha* cmplx(pw1%array, 0.0_dp, kind=dp)
2972!$OMP END PARALLEL WORKSHARE
2973 END IF
2974
2975 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
2976
2977 ng1 = SIZE(pw1%array)
2978 ng2 = SIZE(pw2%array)
2979 ng = min(ng1, ng2)
2980
2981 IF (pw1%pw_grid%spherical) THEN
2982 IF (my_alpha == 1.0_dp) THEN
2983!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2984 DO i = 1, ng
2985 pw2%array(i) = pw2%array(i) + cmplx(pw1%array(i), 0.0_dp, kind=dp)
2986 END DO
2987!$OMP END PARALLEL DO
2988 ELSE IF (my_alpha /= 0.0_dp) THEN
2989!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha,ng)
2990 DO i = 1, ng
2991 pw2%array(i) = pw2%array(i) + my_alpha* cmplx(pw1%array(i), 0.0_dp, kind=dp)
2992 END DO
2993!$OMP END PARALLEL DO
2994 END IF
2995 ELSE IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
2996 IF (ng1 >= ng2) THEN
2997 IF (my_alpha == 1.0_dp) THEN
2998!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
2999 DO i = 1, ng
3000 j = pw2%pw_grid%gidx(i)
3001 pw2%array(i) = pw2%array(i) + cmplx(pw1%array(j), 0.0_dp, kind=dp)
3002 END DO
3003!$OMP END PARALLEL DO
3004 ELSE IF (my_alpha /= 0.0_dp) THEN
3005!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
3006 DO i = 1, ng
3007 j = pw2%pw_grid%gidx(i)
3008 pw2%array(i) = pw2%array(i) + my_alpha* cmplx(pw1%array(j), 0.0_dp, kind=dp)
3009 END DO
3010!$OMP END PARALLEL DO
3011 END IF
3012 ELSE
3013 IF (my_alpha == 1.0_dp) THEN
3014!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
3015 DO i = 1, ng
3016 j = pw2%pw_grid%gidx(i)
3017 pw2%array(j) = pw2%array(j) + cmplx(pw1%array(i), 0.0_dp, kind=dp)
3018 END DO
3019!$OMP END PARALLEL DO
3020 ELSE IF (my_alpha /= 0.0_dp) THEN
3021!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
3022 DO i = 1, ng
3023 j = pw2%pw_grid%gidx(i)
3024 pw2%array(j) = pw2%array(j) + my_alpha* cmplx(pw1%array(i), 0.0_dp, kind=dp)
3025 END DO
3026!$OMP END PARALLEL DO
3027 END IF
3028 END IF
3029 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
3030 IF (ng1 >= ng2) THEN
3031 IF (my_alpha == 1.0_dp) THEN
3032!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
3033 DO i = 1, ng
3034 j = pw1%pw_grid%gidx(i)
3035 pw2%array(i) = pw2%array(i) + cmplx(pw1%array(j), 0.0_dp, kind=dp)
3036 END DO
3037!$OMP END PARALLEL DO
3038 ELSE IF (my_alpha /= 0.0_dp) THEN
3039!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
3040 DO i = 1, ng
3041 j = pw1%pw_grid%gidx(i)
3042 pw2%array(i) = pw2%array(i) + my_alpha* cmplx(pw1%array(j), 0.0_dp, kind=dp)
3043 END DO
3044!$OMP END PARALLEL DO
3045 END IF
3046 ELSE
3047 IF (my_alpha == 1.0_dp) THEN
3048!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
3049 DO i = 1, ng
3050 j = pw1%pw_grid%gidx(i)
3051 pw2%array(j) = pw2%array(j) + cmplx(pw1%array(i), 0.0_dp, kind=dp)
3052 END DO
3053!$OMP END PARALLEL DO
3054 ELSE IF (my_alpha /= 0.0_dp) THEN
3055!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
3056 DO i = 1, ng
3057 j = pw1%pw_grid%gidx(i)
3058 pw2%array(j) = pw2%array(j) + my_alpha* cmplx(pw1%array(i), 0.0_dp, kind=dp)
3059 END DO
3060!$OMP END PARALLEL DO
3061 END IF
3062 END IF
3063 ELSE
3064 cpabort("Grids not compatible")
3065 END IF
3066
3067 ELSE
3068
3069 cpabort("Grids not compatible")
3070
3071 END IF
3072
3073 CALL timestop(handle)
3074
3075 END SUBROUTINE pw_axpy_r1d_c1d_rs
3076
3077! **************************************************************************************************
3078!> \brief pw_out = pw_out + alpha * pw1 * pw2
3079!> alpha defaults to 1
3080!> \param pw_out ...
3081!> \param pw1 ...
3082!> \param pw2 ...
3083!> \param alpha ...
3084!> \author JGH
3085! **************************************************************************************************
3086 SUBROUTINE pw_multiply_r1d_c1d_rs (pw_out, pw1, pw2, alpha)
3087
3088 TYPE(pw_r1d_rs_type), INTENT(INOUT) :: pw_out
3089 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw1
3090 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw2
3091 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
3092
3093 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
3094
3095 INTEGER :: handle
3096 REAL(KIND=dp) :: my_alpha
3097
3098 CALL timeset(routinen, handle)
3099
3100 my_alpha = 1.0_dp
3101 IF (PRESENT(alpha)) my_alpha = alpha
3102
3103 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
3104 cpabort("pw_multiply not implemented for non-identical grids!")
3105
3106#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
3107 IF (my_alpha == 1.0_dp) THEN
3108!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
3109 pw_out%array = pw_out%array + pw1%array* real(pw2%array, kind=dp)
3110!$OMP END PARALLEL WORKSHARE
3111 ELSE
3112!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
3113 pw_out%array = pw_out%array + my_alpha*pw1%array* real(pw2%array, kind=dp)
3114!$OMP END PARALLEL WORKSHARE
3115 END IF
3116#else
3117 IF (my_alpha == 1.0_dp) THEN
3118 pw_out%array = pw_out%array + pw1%array* real(pw2%array, kind=dp)
3119 ELSE
3120 pw_out%array = pw_out%array + my_alpha*pw1%array* real(pw2%array, kind=dp)
3121 END IF
3122#endif
3123
3124 CALL timestop(handle)
3125
3126 END SUBROUTINE pw_multiply_r1d_c1d_rs
3127
3128! **************************************************************************************************
3129!> \brief ...
3130!> \param pw1 ...
3131!> \param pw2 ...
3132! **************************************************************************************************
3133 SUBROUTINE pw_multiply_with_r1d_c1d_rs (pw1, pw2)
3134 TYPE(pw_r1d_rs_type), INTENT(INOUT) :: pw1
3135 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw2
3136
3137 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
3138
3139 INTEGER :: handle
3140
3141 CALL timeset(routinen, handle)
3142
3143 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
3144 cpabort("Incompatible grids!")
3145
3146!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
3147 pw1%array = pw1%array* real(pw2%array, kind=dp)
3148!$OMP END PARALLEL WORKSHARE
3149
3150 CALL timestop(handle)
3151
3152 END SUBROUTINE pw_multiply_with_r1d_c1d_rs
3153
3154! **************************************************************************************************
3155!> \brief Calculate integral over unit cell for functions in plane wave basis
3156!> only returns the real part of it ......
3157!> \param pw1 ...
3158!> \param pw2 ...
3159!> \param sumtype ...
3160!> \param just_sum ...
3161!> \param local_only ...
3162!> \return ...
3163!> \par History
3164!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
3165!> \author apsi
3166! **************************************************************************************************
3167 FUNCTION pw_integral_ab_r1d_c1d_rs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
3168
3169 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw1
3170 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw2
3171 INTEGER, INTENT(IN), OPTIONAL :: sumtype
3172 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
3173 REAL(kind=dp) :: integral_value
3174
3175 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_r1d_c1d_rs'
3176
3177 INTEGER :: handle, loc_sumtype
3178 LOGICAL :: my_just_sum, my_local_only
3179
3180 CALL timeset(routinen, handle)
3181
3182 loc_sumtype = do_accurate_sum
3183 IF (PRESENT(sumtype)) loc_sumtype = sumtype
3184
3185 my_local_only = .false.
3186 IF (PRESENT(local_only)) my_local_only = local_only
3187
3188 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
3189 cpabort("Grids incompatible")
3190 END IF
3191
3192 my_just_sum = .false.
3193 IF (PRESENT(just_sum)) my_just_sum = just_sum
3194
3195 ! do standard sum
3196 IF (loc_sumtype == do_standard_sum) THEN
3197
3198 ! Do standard sum
3199
3200 integral_value = sum(pw1%array*real(pw2%array, kind=dp)) !? complex bit
3201
3202 ELSE
3203
3204 ! Do accurate sum
3205 integral_value = accurate_sum(pw1%array*real(pw2%array, kind=dp)) !? complex bit
3206
3207 END IF
3208
3209 ! Apply reciprocal multiplicity before scaling the integral;
3210 ! the unpaired G=0 term must receive the same volume factor.
3211 IF (pw1%pw_grid%grid_span == halfspace) THEN
3212 integral_value = 2.0_dp*integral_value
3213 IF (pw1%pw_grid%have_g0) integral_value = integral_value - &
3214 pw1%array(1)*real(pw2%array(1), kind=dp)
3215 END IF
3216
3217 IF (.NOT. my_just_sum) THEN
3218 integral_value = integral_value*pw1%pw_grid%dvol
3219 END IF
3220
3221 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
3222 CALL pw1%pw_grid%para%group%sum(integral_value)
3223
3224 CALL timestop(handle)
3225
3226 END FUNCTION pw_integral_ab_r1d_c1d_rs
3227! **************************************************************************************************
3228!> \brief copy a pw type variable
3229!> \param pw1 ...
3230!> \param pw2 ...
3231!> \par History
3232!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
3233!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
3234!> JGH (21-Feb-2003) : Code for generalized reference grids
3235!> \author apsi
3236!> \note
3237!> Currently only copying of respective types allowed,
3238!> in order to avoid errors
3239! **************************************************************************************************
3240 SUBROUTINE pw_copy_r1d_c1d_gs (pw1, pw2)
3241
3242 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
3243 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw2
3244
3245 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
3246
3247 INTEGER :: handle
3248 INTEGER :: i, j, ng, ng1, ng2, ns
3249
3250 CALL timeset(routinen, handle)
3251
3252 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
3253 cpabort("Both grids must be either spherical or non-spherical!")
3254
3255 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
3256 IF (pw1%pw_grid%spherical .AND. pw2%pw_grid%spherical) THEN
3257 IF (pw_compatible(pw1%pw_grid, pw2%pw_grid)) THEN
3258 ng1 = SIZE(pw1%array)
3259 ng2 = SIZE(pw2%array)
3260 ng = min(ng1, ng2)
3261!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, pw1, pw2)
3262 pw2%array(1:ng) = cmplx(pw1%array(1:ng), 0.0_dp, kind=dp)
3263!$OMP END PARALLEL WORKSHARE
3264 IF (ng2 > ng) THEN
3265!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, ng2, pw2)
3266 pw2%array(ng + 1:ng2) = cmplx(0.0_dp, 0.0_dp, kind=dp)
3267!$OMP END PARALLEL WORKSHARE
3268 END IF
3269 ELSE
3270 cpabort("Copies between spherical grids require compatible grids!")
3271 END IF
3272 ELSE
3273 ng1 = SIZE(pw1%array)
3274 ng2 = SIZE(pw2%array)
3275 ns = 2*max(ng1, ng2)
3276
3277 IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
3278 IF (ng1 >= ng2) THEN
3279!$OMP PARALLEL DO DEFAULT(NONE) &
3280!$OMP PRIVATE(i,j) &
3281!$OMP SHARED(ng2, pw1, pw2)
3282 DO i = 1, ng2
3283 j = pw2%pw_grid%gidx(i)
3284 pw2%array(i) = cmplx(pw1%array(j), 0.0_dp, kind=dp)
3285 END DO
3286!$OMP END PARALLEL DO
3287 ELSE
3288 CALL pw_zero(pw2)
3289!$OMP PARALLEL DO DEFAULT(NONE) &
3290!$OMP PRIVATE(i,j) &
3291!$OMP SHARED(ng1, pw1, pw2)
3292 DO i = 1, ng1
3293 j = pw2%pw_grid%gidx(i)
3294 pw2%array(j) = cmplx(pw1%array(i), 0.0_dp, kind=dp)
3295 END DO
3296!$OMP END PARALLEL DO
3297 END IF
3298 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
3299 IF (ng1 >= ng2) THEN
3300!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng2, pw1, pw2)
3301 DO i = 1, ng2
3302 j = pw1%pw_grid%gidx(i)
3303 pw2%array(i) = cmplx(pw1%array(j), 0.0_dp, kind=dp)
3304 END DO
3305!$OMP END PARALLEL DO
3306 ELSE
3307 CALL pw_zero(pw2)
3308!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng1, pw1, pw2)
3309 DO i = 1, ng1
3310 j = pw1%pw_grid%gidx(i)
3311 pw2%array(j) = cmplx(pw1%array(i), 0.0_dp, kind=dp)
3312 END DO
3313!$OMP END PARALLEL DO
3314 END IF
3315 ELSE
3316 cpabort("Copy not implemented!")
3317 END IF
3318
3319 END IF
3320
3321 ELSE
3322!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
3323 pw2%array = cmplx(pw1%array, 0.0_dp, kind=dp)
3324!$OMP END PARALLEL WORKSHARE
3325 END IF
3326
3327 CALL timestop(handle)
3328
3329 END SUBROUTINE pw_copy_r1d_c1d_gs
3330
3331! **************************************************************************************************
3332!> \brief ...
3333!> \param pw ...
3334!> \param array ...
3335! **************************************************************************************************
3336 SUBROUTINE pw_copy_to_array_r1d_c1d_gs (pw, array)
3337 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw
3338 COMPLEX(KIND=dp), DIMENSION(:), INTENT(INOUT) :: array
3339
3340 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
3341
3342 INTEGER :: handle
3343
3344 CALL timeset(routinen, handle)
3345
3346!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
3347 array(:) = cmplx(pw%array(:), 0.0_dp, kind=dp)
3348!$OMP END PARALLEL WORKSHARE
3349
3350 CALL timestop(handle)
3351 END SUBROUTINE pw_copy_to_array_r1d_c1d_gs
3352
3353! **************************************************************************************************
3354!> \brief ...
3355!> \param pw ...
3356!> \param array ...
3357! **************************************************************************************************
3358 SUBROUTINE pw_copy_from_array_r1d_c1d_gs (pw, array)
3359 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw
3360 COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: array
3361
3362 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
3363
3364 INTEGER :: handle
3365
3366 CALL timeset(routinen, handle)
3367
3368!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
3369 pw%array = real(array, kind=dp)
3370!$OMP END PARALLEL WORKSHARE
3371
3372 CALL timestop(handle)
3373 END SUBROUTINE pw_copy_from_array_r1d_c1d_gs
3374
3375! **************************************************************************************************
3376!> \brief pw2 = alpha*pw1 + beta*pw2
3377!> alpha defaults to 1, beta defaults to 1
3378!> \param pw1 ...
3379!> \param pw2 ...
3380!> \param alpha ...
3381!> \param beta ...
3382!> \param allow_noncompatible_grids ...
3383!> \par History
3384!> JGH (21-Feb-2003) : added reference grid functionality
3385!> JGH (01-Dec-2007) : rename and remove complex alpha
3386!> \author apsi
3387!> \note
3388!> Currently only summing up of respective types allowed,
3389!> in order to avoid errors
3390! **************************************************************************************************
3391 SUBROUTINE pw_axpy_r1d_c1d_gs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
3392
3393 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
3394 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw2
3395 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
3396 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
3397
3398 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
3399
3400 INTEGER :: handle
3401 LOGICAL :: my_allow_noncompatible_grids
3402 REAL(KIND=dp) :: my_alpha, my_beta
3403 INTEGER :: i, j, ng, ng1, ng2
3404
3405 CALL timeset(routinen, handle)
3406
3407 my_alpha = 1.0_dp
3408 IF (PRESENT(alpha)) my_alpha = alpha
3409
3410 my_beta = 1.0_dp
3411 IF (PRESENT(beta)) my_beta = beta
3412
3413 my_allow_noncompatible_grids = .false.
3414 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
3415
3416 IF (my_beta /= 1.0_dp) THEN
3417 IF (my_beta == 0.0_dp) THEN
3418 CALL pw_zero(pw2)
3419 ELSE
3420!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
3421 pw2%array = pw2%array*my_beta
3422!$OMP END PARALLEL WORKSHARE
3423 END IF
3424 END IF
3425
3426 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
3427
3428 IF (my_alpha == 1.0_dp) THEN
3429!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
3430 pw2%array = pw2%array + cmplx(pw1%array, 0.0_dp, kind=dp)
3431!$OMP END PARALLEL WORKSHARE
3432 ELSE IF (my_alpha /= 0.0_dp) THEN
3433!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha)
3434 pw2%array = pw2%array + my_alpha* cmplx(pw1%array, 0.0_dp, kind=dp)
3435!$OMP END PARALLEL WORKSHARE
3436 END IF
3437
3438 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
3439
3440 ng1 = SIZE(pw1%array)
3441 ng2 = SIZE(pw2%array)
3442 ng = min(ng1, ng2)
3443
3444 IF (pw1%pw_grid%spherical) THEN
3445 IF (my_alpha == 1.0_dp) THEN
3446!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(ng, pw1, pw2)
3447 DO i = 1, ng
3448 pw2%array(i) = pw2%array(i) + cmplx(pw1%array(i), 0.0_dp, kind=dp)
3449 END DO
3450!$OMP END PARALLEL DO
3451 ELSE IF (my_alpha /= 0.0_dp) THEN
3452!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha,ng)
3453 DO i = 1, ng
3454 pw2%array(i) = pw2%array(i) + my_alpha* cmplx(pw1%array(i), 0.0_dp, kind=dp)
3455 END DO
3456!$OMP END PARALLEL DO
3457 END IF
3458 ELSE IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
3459 IF (ng1 >= ng2) THEN
3460 IF (my_alpha == 1.0_dp) THEN
3461!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
3462 DO i = 1, ng
3463 j = pw2%pw_grid%gidx(i)
3464 pw2%array(i) = pw2%array(i) + cmplx(pw1%array(j), 0.0_dp, kind=dp)
3465 END DO
3466!$OMP END PARALLEL DO
3467 ELSE IF (my_alpha /= 0.0_dp) THEN
3468!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
3469 DO i = 1, ng
3470 j = pw2%pw_grid%gidx(i)
3471 pw2%array(i) = pw2%array(i) + my_alpha* cmplx(pw1%array(j), 0.0_dp, kind=dp)
3472 END DO
3473!$OMP END PARALLEL DO
3474 END IF
3475 ELSE
3476 IF (my_alpha == 1.0_dp) THEN
3477!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
3478 DO i = 1, ng
3479 j = pw2%pw_grid%gidx(i)
3480 pw2%array(j) = pw2%array(j) + cmplx(pw1%array(i), 0.0_dp, kind=dp)
3481 END DO
3482!$OMP END PARALLEL DO
3483 ELSE IF (my_alpha /= 0.0_dp) THEN
3484!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
3485 DO i = 1, ng
3486 j = pw2%pw_grid%gidx(i)
3487 pw2%array(j) = pw2%array(j) + my_alpha* cmplx(pw1%array(i), 0.0_dp, kind=dp)
3488 END DO
3489!$OMP END PARALLEL DO
3490 END IF
3491 END IF
3492 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
3493 IF (ng1 >= ng2) THEN
3494 IF (my_alpha == 1.0_dp) THEN
3495!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
3496 DO i = 1, ng
3497 j = pw1%pw_grid%gidx(i)
3498 pw2%array(i) = pw2%array(i) + cmplx(pw1%array(j), 0.0_dp, kind=dp)
3499 END DO
3500!$OMP END PARALLEL DO
3501 ELSE IF (my_alpha /= 0.0_dp) THEN
3502!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
3503 DO i = 1, ng
3504 j = pw1%pw_grid%gidx(i)
3505 pw2%array(i) = pw2%array(i) + my_alpha* cmplx(pw1%array(j), 0.0_dp, kind=dp)
3506 END DO
3507!$OMP END PARALLEL DO
3508 END IF
3509 ELSE
3510 IF (my_alpha == 1.0_dp) THEN
3511!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
3512 DO i = 1, ng
3513 j = pw1%pw_grid%gidx(i)
3514 pw2%array(j) = pw2%array(j) + cmplx(pw1%array(i), 0.0_dp, kind=dp)
3515 END DO
3516!$OMP END PARALLEL DO
3517 ELSE IF (my_alpha /= 0.0_dp) THEN
3518!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
3519 DO i = 1, ng
3520 j = pw1%pw_grid%gidx(i)
3521 pw2%array(j) = pw2%array(j) + my_alpha* cmplx(pw1%array(i), 0.0_dp, kind=dp)
3522 END DO
3523!$OMP END PARALLEL DO
3524 END IF
3525 END IF
3526 ELSE
3527 cpabort("Grids not compatible")
3528 END IF
3529
3530 ELSE
3531
3532 cpabort("Grids not compatible")
3533
3534 END IF
3535
3536 CALL timestop(handle)
3537
3538 END SUBROUTINE pw_axpy_r1d_c1d_gs
3539
3540! **************************************************************************************************
3541!> \brief pw_out = pw_out + alpha * pw1 * pw2
3542!> alpha defaults to 1
3543!> \param pw_out ...
3544!> \param pw1 ...
3545!> \param pw2 ...
3546!> \param alpha ...
3547!> \author JGH
3548! **************************************************************************************************
3549 SUBROUTINE pw_multiply_r1d_c1d_gs (pw_out, pw1, pw2, alpha)
3550
3551 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw_out
3552 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
3553 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw2
3554 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
3555
3556 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
3557
3558 INTEGER :: handle
3559 REAL(KIND=dp) :: my_alpha
3560
3561 CALL timeset(routinen, handle)
3562
3563 my_alpha = 1.0_dp
3564 IF (PRESENT(alpha)) my_alpha = alpha
3565
3566 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
3567 cpabort("pw_multiply not implemented for non-identical grids!")
3568
3569#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
3570 IF (my_alpha == 1.0_dp) THEN
3571!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
3572 pw_out%array = pw_out%array + pw1%array* real(pw2%array, kind=dp)
3573!$OMP END PARALLEL WORKSHARE
3574 ELSE
3575!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
3576 pw_out%array = pw_out%array + my_alpha*pw1%array* real(pw2%array, kind=dp)
3577!$OMP END PARALLEL WORKSHARE
3578 END IF
3579#else
3580 IF (my_alpha == 1.0_dp) THEN
3581 pw_out%array = pw_out%array + pw1%array* real(pw2%array, kind=dp)
3582 ELSE
3583 pw_out%array = pw_out%array + my_alpha*pw1%array* real(pw2%array, kind=dp)
3584 END IF
3585#endif
3586
3587 CALL timestop(handle)
3588
3589 END SUBROUTINE pw_multiply_r1d_c1d_gs
3590
3591! **************************************************************************************************
3592!> \brief ...
3593!> \param pw1 ...
3594!> \param pw2 ...
3595! **************************************************************************************************
3596 SUBROUTINE pw_multiply_with_r1d_c1d_gs (pw1, pw2)
3597 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw1
3598 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw2
3599
3600 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
3601
3602 INTEGER :: handle
3603
3604 CALL timeset(routinen, handle)
3605
3606 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
3607 cpabort("Incompatible grids!")
3608
3609!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
3610 pw1%array = pw1%array* real(pw2%array, kind=dp)
3611!$OMP END PARALLEL WORKSHARE
3612
3613 CALL timestop(handle)
3614
3615 END SUBROUTINE pw_multiply_with_r1d_c1d_gs
3616
3617! **************************************************************************************************
3618!> \brief Calculate integral over unit cell for functions in plane wave basis
3619!> only returns the real part of it ......
3620!> \param pw1 ...
3621!> \param pw2 ...
3622!> \param sumtype ...
3623!> \param just_sum ...
3624!> \param local_only ...
3625!> \return ...
3626!> \par History
3627!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
3628!> \author apsi
3629! **************************************************************************************************
3630 FUNCTION pw_integral_ab_r1d_c1d_gs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
3631
3632 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
3633 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw2
3634 INTEGER, INTENT(IN), OPTIONAL :: sumtype
3635 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
3636 REAL(kind=dp) :: integral_value
3637
3638 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_r1d_c1d_gs'
3639
3640 INTEGER :: handle, loc_sumtype
3641 LOGICAL :: my_just_sum, my_local_only
3642
3643 CALL timeset(routinen, handle)
3644
3645 loc_sumtype = do_accurate_sum
3646 IF (PRESENT(sumtype)) loc_sumtype = sumtype
3647
3648 my_local_only = .false.
3649 IF (PRESENT(local_only)) my_local_only = local_only
3650
3651 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
3652 cpabort("Grids incompatible")
3653 END IF
3654
3655 my_just_sum = .false.
3656 IF (PRESENT(just_sum)) my_just_sum = just_sum
3657
3658 ! do standard sum
3659 IF (loc_sumtype == do_standard_sum) THEN
3660
3661 ! Do standard sum
3662
3663 integral_value = sum(pw1%array*real(pw2%array, kind=dp)) !? complex bit
3664
3665 ELSE
3666
3667 ! Do accurate sum
3668 integral_value = accurate_sum(pw1%array*real(pw2%array, kind=dp)) !? complex bit
3669
3670 END IF
3671
3672 ! Apply reciprocal multiplicity before scaling the integral;
3673 ! the unpaired G=0 term must receive the same volume factor.
3674 IF (pw1%pw_grid%grid_span == halfspace) THEN
3675 integral_value = 2.0_dp*integral_value
3676 IF (pw1%pw_grid%have_g0) integral_value = integral_value - &
3677 pw1%array(1)*real(pw2%array(1), kind=dp)
3678 END IF
3679
3680 IF (.NOT. my_just_sum) THEN
3681 integral_value = integral_value*pw1%pw_grid%vol
3682 END IF
3683
3684 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
3685 CALL pw1%pw_grid%para%group%sum(integral_value)
3686
3687 CALL timestop(handle)
3688
3689 END FUNCTION pw_integral_ab_r1d_c1d_gs
3690
3691! **************************************************************************************************
3692!> \brief ...
3693!> \param pw1 ...
3694!> \param pw2 ...
3695!> \return ...
3696! **************************************************************************************************
3697 FUNCTION pw_integral_a2b_r1d_c1d (pw1, pw2) RESULT(integral_value)
3698
3699 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
3700 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw2
3701 REAL(kind=dp) :: integral_value
3702
3703 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_a2b'
3704
3705 INTEGER :: handle
3706
3707 CALL timeset(routinen, handle)
3708
3709 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
3710 cpabort("Grids incompatible")
3711 END IF
3712
3713 integral_value = accurate_sum(pw1%array*real(pw2%array, kind=dp)*pw1%pw_grid%gsq)
3714 IF (pw1%pw_grid%grid_span == halfspace) THEN
3715 integral_value = 2.0_dp*integral_value
3716 END IF
3717
3718 integral_value = integral_value*pw1%pw_grid%vol
3719
3720 IF (pw1%pw_grid%para%mode == pw_mode_distributed) &
3721 CALL pw1%pw_grid%para%group%sum(integral_value)
3722 CALL timestop(handle)
3723
3724 END FUNCTION pw_integral_a2b_r1d_c1d
3725! **************************************************************************************************
3726!> \brief copy a pw type variable
3727!> \param pw1 ...
3728!> \param pw2 ...
3729!> \par History
3730!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
3731!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
3732!> JGH (21-Feb-2003) : Code for generalized reference grids
3733!> \author apsi
3734!> \note
3735!> Currently only copying of respective types allowed,
3736!> in order to avoid errors
3737! **************************************************************************************************
3738 SUBROUTINE pw_copy_r3d_r3d_rs (pw1, pw2)
3739
3740 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw1
3741 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw2
3742
3743 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
3744
3745 INTEGER :: handle
3746
3747 CALL timeset(routinen, handle)
3748
3749 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
3750 cpabort("Both grids must be either spherical or non-spherical!")
3751 IF (pw1%pw_grid%spherical) &
3752 cpabort("Spherical grids only exist in reciprocal space!")
3753
3754 IF (any(shape(pw2%array) /= shape(pw1%array))) &
3755 cpabort("3D grids must be compatible!")
3756 IF (pw1%pw_grid%spherical) &
3757 cpabort("3D grids must not be spherical!")
3758!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
3759 pw2%array(:, :, :) = pw1%array(:, :, :)
3760!$OMP END PARALLEL WORKSHARE
3761
3762 CALL timestop(handle)
3763
3764 END SUBROUTINE pw_copy_r3d_r3d_rs
3765
3766! **************************************************************************************************
3767!> \brief ...
3768!> \param pw ...
3769!> \param array ...
3770! **************************************************************************************************
3771 SUBROUTINE pw_copy_to_array_r3d_r3d_rs (pw, array)
3772 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw
3773 REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: array
3774
3775 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
3776
3777 INTEGER :: handle
3778
3779 CALL timeset(routinen, handle)
3780
3781!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
3782 array(:, :, :) = pw%array(:, :, :)
3783!$OMP END PARALLEL WORKSHARE
3784
3785 CALL timestop(handle)
3786 END SUBROUTINE pw_copy_to_array_r3d_r3d_rs
3787
3788! **************************************************************************************************
3789!> \brief ...
3790!> \param pw ...
3791!> \param array ...
3792! **************************************************************************************************
3793 SUBROUTINE pw_copy_from_array_r3d_r3d_rs (pw, array)
3794 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw
3795 REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: array
3796
3797 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
3798
3799 INTEGER :: handle
3800
3801 CALL timeset(routinen, handle)
3802
3803!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
3804 pw%array = array
3805!$OMP END PARALLEL WORKSHARE
3806
3807 CALL timestop(handle)
3808 END SUBROUTINE pw_copy_from_array_r3d_r3d_rs
3809
3810! **************************************************************************************************
3811!> \brief pw2 = alpha*pw1 + beta*pw2
3812!> alpha defaults to 1, beta defaults to 1
3813!> \param pw1 ...
3814!> \param pw2 ...
3815!> \param alpha ...
3816!> \param beta ...
3817!> \param allow_noncompatible_grids ...
3818!> \par History
3819!> JGH (21-Feb-2003) : added reference grid functionality
3820!> JGH (01-Dec-2007) : rename and remove complex alpha
3821!> \author apsi
3822!> \note
3823!> Currently only summing up of respective types allowed,
3824!> in order to avoid errors
3825! **************************************************************************************************
3826 SUBROUTINE pw_axpy_r3d_r3d_rs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
3827
3828 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw1
3829 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw2
3830 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
3831 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
3832
3833 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
3834
3835 INTEGER :: handle
3836 LOGICAL :: my_allow_noncompatible_grids
3837 REAL(KIND=dp) :: my_alpha, my_beta
3838
3839 CALL timeset(routinen, handle)
3840
3841 my_alpha = 1.0_dp
3842 IF (PRESENT(alpha)) my_alpha = alpha
3843
3844 my_beta = 1.0_dp
3845 IF (PRESENT(beta)) my_beta = beta
3846
3847 my_allow_noncompatible_grids = .false.
3848 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
3849
3850 IF (my_beta /= 1.0_dp) THEN
3851 IF (my_beta == 0.0_dp) THEN
3852 CALL pw_zero(pw2)
3853 ELSE
3854!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
3855 pw2%array = pw2%array*my_beta
3856!$OMP END PARALLEL WORKSHARE
3857 END IF
3858 END IF
3859
3860 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
3861 IF (my_alpha == 1.0_dp) THEN
3862!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2)
3863 pw2%array = pw2%array + pw1%array
3864!$OMP END PARALLEL WORKSHARE
3865 ELSE IF (my_alpha /= 0.0_dp) THEN
3866!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2, my_alpha)
3867 pw2%array = pw2%array + my_alpha* pw1%array
3868!$OMP END PARALLEL WORKSHARE
3869 END IF
3870
3871 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
3872
3873 IF (any(shape(pw1%array) /= shape(pw2%array))) &
3874 cpabort("Noncommensurate grids not implemented for 3D grids!")
3875
3876 IF (my_alpha == 1.0_dp) THEN
3877!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
3878 pw2%array = pw2%array + pw1%array
3879!$OMP END PARALLEL WORKSHARE
3880 ELSE
3881!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2,my_alpha)
3882 pw2%array = pw2%array + my_alpha* pw1%array
3883!$OMP END PARALLEL WORKSHARE
3884 END IF
3885
3886 ELSE
3887
3888 cpabort("Grids not compatible")
3889
3890 END IF
3891
3892 CALL timestop(handle)
3893
3894 END SUBROUTINE pw_axpy_r3d_r3d_rs
3895
3896! **************************************************************************************************
3897!> \brief pw_out = pw_out + alpha * pw1 * pw2
3898!> alpha defaults to 1
3899!> \param pw_out ...
3900!> \param pw1 ...
3901!> \param pw2 ...
3902!> \param alpha ...
3903!> \author JGH
3904! **************************************************************************************************
3905 SUBROUTINE pw_multiply_r3d_r3d_rs (pw_out, pw1, pw2, alpha)
3906
3907 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw_out
3908 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw1
3909 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw2
3910 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
3911
3912 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
3913
3914 INTEGER :: handle
3915 REAL(KIND=dp) :: my_alpha
3916
3917 CALL timeset(routinen, handle)
3918
3919 my_alpha = 1.0_dp
3920 IF (PRESENT(alpha)) my_alpha = alpha
3921
3922 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
3923 cpabort("pw_multiply not implemented for non-identical grids!")
3924
3925#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
3926 IF (my_alpha == 1.0_dp) THEN
3927!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
3928 pw_out%array = pw_out%array + pw1%array* pw2%array
3929!$OMP END PARALLEL WORKSHARE
3930 ELSE
3931!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
3932 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
3933!$OMP END PARALLEL WORKSHARE
3934 END IF
3935#else
3936 IF (my_alpha == 1.0_dp) THEN
3937 pw_out%array = pw_out%array + pw1%array* pw2%array
3938 ELSE
3939 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
3940 END IF
3941#endif
3942
3943 CALL timestop(handle)
3944
3945 END SUBROUTINE pw_multiply_r3d_r3d_rs
3946
3947! **************************************************************************************************
3948!> \brief ...
3949!> \param pw1 ...
3950!> \param pw2 ...
3951! **************************************************************************************************
3952 SUBROUTINE pw_multiply_with_r3d_r3d_rs (pw1, pw2)
3953 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw1
3954 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw2
3955
3956 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
3957
3958 INTEGER :: handle
3959
3960 CALL timeset(routinen, handle)
3961
3962 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
3963 cpabort("Incompatible grids!")
3964
3965!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
3966 pw1%array = pw1%array* pw2%array
3967!$OMP END PARALLEL WORKSHARE
3968
3969 CALL timestop(handle)
3970
3971 END SUBROUTINE pw_multiply_with_r3d_r3d_rs
3972
3973! **************************************************************************************************
3974!> \brief Calculate integral over unit cell for functions in plane wave basis
3975!> only returns the real part of it ......
3976!> \param pw1 ...
3977!> \param pw2 ...
3978!> \param sumtype ...
3979!> \param just_sum ...
3980!> \param local_only ...
3981!> \return ...
3982!> \par History
3983!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
3984!> \author apsi
3985! **************************************************************************************************
3986 FUNCTION pw_integral_ab_r3d_r3d_rs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
3987
3988 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw1
3989 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw2
3990 INTEGER, INTENT(IN), OPTIONAL :: sumtype
3991 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
3992 REAL(kind=dp) :: integral_value
3993
3994 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_r3d_r3d_rs'
3995
3996 INTEGER :: handle, loc_sumtype
3997 LOGICAL :: my_just_sum, my_local_only
3998
3999 CALL timeset(routinen, handle)
4000
4001 loc_sumtype = do_accurate_sum
4002 IF (PRESENT(sumtype)) loc_sumtype = sumtype
4003
4004 my_local_only = .false.
4005 IF (PRESENT(local_only)) my_local_only = local_only
4006
4007 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
4008 cpabort("Grids incompatible")
4009 END IF
4010
4011 my_just_sum = .false.
4012 IF (PRESENT(just_sum)) my_just_sum = just_sum
4013
4014 ! do standard sum
4015 IF (loc_sumtype == do_standard_sum) THEN
4016
4017 ! Do standard sum
4018
4019 integral_value = sum(pw1%array*pw2%array)
4020
4021 ELSE
4022
4023 ! Do accurate sum
4024 integral_value = accurate_dot_product(pw1%array, pw2%array)
4025
4026 END IF
4027
4028
4029 IF (.NOT. my_just_sum) THEN
4030 integral_value = integral_value*pw1%pw_grid%dvol
4031 END IF
4032
4033 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
4034 CALL pw1%pw_grid%para%group%sum(integral_value)
4035
4036 CALL timestop(handle)
4037
4038 END FUNCTION pw_integral_ab_r3d_r3d_rs
4039! **************************************************************************************************
4040!> \brief copy a pw type variable
4041!> \param pw1 ...
4042!> \param pw2 ...
4043!> \par History
4044!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
4045!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
4046!> JGH (21-Feb-2003) : Code for generalized reference grids
4047!> \author apsi
4048!> \note
4049!> Currently only copying of respective types allowed,
4050!> in order to avoid errors
4051! **************************************************************************************************
4052 SUBROUTINE pw_copy_r3d_r3d_gs (pw1, pw2)
4053
4054 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw1
4055 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw2
4056
4057 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
4058
4059 INTEGER :: handle
4060
4061 CALL timeset(routinen, handle)
4062
4063 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
4064 cpabort("Both grids must be either spherical or non-spherical!")
4065
4066 IF (any(shape(pw2%array) /= shape(pw1%array))) &
4067 cpabort("3D grids must be compatible!")
4068 IF (pw1%pw_grid%spherical) &
4069 cpabort("3D grids must not be spherical!")
4070!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
4071 pw2%array(:, :, :) = pw1%array(:, :, :)
4072!$OMP END PARALLEL WORKSHARE
4073
4074 CALL timestop(handle)
4075
4076 END SUBROUTINE pw_copy_r3d_r3d_gs
4077
4078! **************************************************************************************************
4079!> \brief ...
4080!> \param pw ...
4081!> \param array ...
4082! **************************************************************************************************
4083 SUBROUTINE pw_copy_to_array_r3d_r3d_gs (pw, array)
4084 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw
4085 REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: array
4086
4087 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
4088
4089 INTEGER :: handle
4090
4091 CALL timeset(routinen, handle)
4092
4093!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
4094 array(:, :, :) = pw%array(:, :, :)
4095!$OMP END PARALLEL WORKSHARE
4096
4097 CALL timestop(handle)
4098 END SUBROUTINE pw_copy_to_array_r3d_r3d_gs
4099
4100! **************************************************************************************************
4101!> \brief ...
4102!> \param pw ...
4103!> \param array ...
4104! **************************************************************************************************
4105 SUBROUTINE pw_copy_from_array_r3d_r3d_gs (pw, array)
4106 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw
4107 REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: array
4108
4109 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
4110
4111 INTEGER :: handle
4112
4113 CALL timeset(routinen, handle)
4114
4115!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
4116 pw%array = array
4117!$OMP END PARALLEL WORKSHARE
4118
4119 CALL timestop(handle)
4120 END SUBROUTINE pw_copy_from_array_r3d_r3d_gs
4121
4122! **************************************************************************************************
4123!> \brief pw2 = alpha*pw1 + beta*pw2
4124!> alpha defaults to 1, beta defaults to 1
4125!> \param pw1 ...
4126!> \param pw2 ...
4127!> \param alpha ...
4128!> \param beta ...
4129!> \param allow_noncompatible_grids ...
4130!> \par History
4131!> JGH (21-Feb-2003) : added reference grid functionality
4132!> JGH (01-Dec-2007) : rename and remove complex alpha
4133!> \author apsi
4134!> \note
4135!> Currently only summing up of respective types allowed,
4136!> in order to avoid errors
4137! **************************************************************************************************
4138 SUBROUTINE pw_axpy_r3d_r3d_gs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
4139
4140 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw1
4141 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw2
4142 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
4143 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
4144
4145 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
4146
4147 INTEGER :: handle
4148 LOGICAL :: my_allow_noncompatible_grids
4149 REAL(KIND=dp) :: my_alpha, my_beta
4150
4151 CALL timeset(routinen, handle)
4152
4153 my_alpha = 1.0_dp
4154 IF (PRESENT(alpha)) my_alpha = alpha
4155
4156 my_beta = 1.0_dp
4157 IF (PRESENT(beta)) my_beta = beta
4158
4159 my_allow_noncompatible_grids = .false.
4160 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
4161
4162 IF (my_beta /= 1.0_dp) THEN
4163 IF (my_beta == 0.0_dp) THEN
4164 CALL pw_zero(pw2)
4165 ELSE
4166!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
4167 pw2%array = pw2%array*my_beta
4168!$OMP END PARALLEL WORKSHARE
4169 END IF
4170 END IF
4171
4172 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
4173 IF (my_alpha == 1.0_dp) THEN
4174!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2)
4175 pw2%array = pw2%array + pw1%array
4176!$OMP END PARALLEL WORKSHARE
4177 ELSE IF (my_alpha /= 0.0_dp) THEN
4178!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2, my_alpha)
4179 pw2%array = pw2%array + my_alpha* pw1%array
4180!$OMP END PARALLEL WORKSHARE
4181 END IF
4182
4183 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
4184
4185 IF (any(shape(pw1%array) /= shape(pw2%array))) &
4186 cpabort("Noncommensurate grids not implemented for 3D grids!")
4187
4188 IF (my_alpha == 1.0_dp) THEN
4189!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
4190 pw2%array = pw2%array + pw1%array
4191!$OMP END PARALLEL WORKSHARE
4192 ELSE
4193!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2,my_alpha)
4194 pw2%array = pw2%array + my_alpha* pw1%array
4195!$OMP END PARALLEL WORKSHARE
4196 END IF
4197
4198 ELSE
4199
4200 cpabort("Grids not compatible")
4201
4202 END IF
4203
4204 CALL timestop(handle)
4205
4206 END SUBROUTINE pw_axpy_r3d_r3d_gs
4207
4208! **************************************************************************************************
4209!> \brief pw_out = pw_out + alpha * pw1 * pw2
4210!> alpha defaults to 1
4211!> \param pw_out ...
4212!> \param pw1 ...
4213!> \param pw2 ...
4214!> \param alpha ...
4215!> \author JGH
4216! **************************************************************************************************
4217 SUBROUTINE pw_multiply_r3d_r3d_gs (pw_out, pw1, pw2, alpha)
4218
4219 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw_out
4220 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw1
4221 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw2
4222 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
4223
4224 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
4225
4226 INTEGER :: handle
4227 REAL(KIND=dp) :: my_alpha
4228
4229 CALL timeset(routinen, handle)
4230
4231 my_alpha = 1.0_dp
4232 IF (PRESENT(alpha)) my_alpha = alpha
4233
4234 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
4235 cpabort("pw_multiply not implemented for non-identical grids!")
4236
4237#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
4238 IF (my_alpha == 1.0_dp) THEN
4239!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
4240 pw_out%array = pw_out%array + pw1%array* pw2%array
4241!$OMP END PARALLEL WORKSHARE
4242 ELSE
4243!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
4244 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
4245!$OMP END PARALLEL WORKSHARE
4246 END IF
4247#else
4248 IF (my_alpha == 1.0_dp) THEN
4249 pw_out%array = pw_out%array + pw1%array* pw2%array
4250 ELSE
4251 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
4252 END IF
4253#endif
4254
4255 CALL timestop(handle)
4256
4257 END SUBROUTINE pw_multiply_r3d_r3d_gs
4258
4259! **************************************************************************************************
4260!> \brief ...
4261!> \param pw1 ...
4262!> \param pw2 ...
4263! **************************************************************************************************
4264 SUBROUTINE pw_multiply_with_r3d_r3d_gs (pw1, pw2)
4265 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw1
4266 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw2
4267
4268 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
4269
4270 INTEGER :: handle
4271
4272 CALL timeset(routinen, handle)
4273
4274 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
4275 cpabort("Incompatible grids!")
4276
4277!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
4278 pw1%array = pw1%array* pw2%array
4279!$OMP END PARALLEL WORKSHARE
4280
4281 CALL timestop(handle)
4282
4283 END SUBROUTINE pw_multiply_with_r3d_r3d_gs
4284
4285! **************************************************************************************************
4286!> \brief Calculate integral over unit cell for functions in plane wave basis
4287!> only returns the real part of it ......
4288!> \param pw1 ...
4289!> \param pw2 ...
4290!> \param sumtype ...
4291!> \param just_sum ...
4292!> \param local_only ...
4293!> \return ...
4294!> \par History
4295!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
4296!> \author apsi
4297! **************************************************************************************************
4298 FUNCTION pw_integral_ab_r3d_r3d_gs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
4299
4300 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw1
4301 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw2
4302 INTEGER, INTENT(IN), OPTIONAL :: sumtype
4303 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
4304 REAL(kind=dp) :: integral_value
4305
4306 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_r3d_r3d_gs'
4307
4308 INTEGER :: handle, loc_sumtype
4309 LOGICAL :: my_just_sum, my_local_only
4310
4311 CALL timeset(routinen, handle)
4312
4313 loc_sumtype = do_accurate_sum
4314 IF (PRESENT(sumtype)) loc_sumtype = sumtype
4315
4316 my_local_only = .false.
4317 IF (PRESENT(local_only)) my_local_only = local_only
4318
4319 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
4320 cpabort("Grids incompatible")
4321 END IF
4322
4323 my_just_sum = .false.
4324 IF (PRESENT(just_sum)) my_just_sum = just_sum
4325
4326 ! do standard sum
4327 IF (loc_sumtype == do_standard_sum) THEN
4328
4329 ! Do standard sum
4330
4331 integral_value = sum(pw1%array*pw2%array)
4332
4333 ELSE
4334
4335 ! Do accurate sum
4336 integral_value = accurate_dot_product(pw1%array, pw2%array)
4337
4338 END IF
4339
4340
4341 IF (.NOT. my_just_sum) THEN
4342 integral_value = integral_value*pw1%pw_grid%vol
4343 END IF
4344
4345 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
4346 CALL pw1%pw_grid%para%group%sum(integral_value)
4347
4348 CALL timestop(handle)
4349
4350 END FUNCTION pw_integral_ab_r3d_r3d_gs
4351
4352! **************************************************************************************************
4353!> \brief copy a pw type variable
4354!> \param pw1 ...
4355!> \param pw2 ...
4356!> \par History
4357!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
4358!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
4359!> JGH (21-Feb-2003) : Code for generalized reference grids
4360!> \author apsi
4361!> \note
4362!> Currently only copying of respective types allowed,
4363!> in order to avoid errors
4364! **************************************************************************************************
4365 SUBROUTINE pw_copy_r3d_c3d_rs (pw1, pw2)
4366
4367 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw1
4368 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw2
4369
4370 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
4371
4372 INTEGER :: handle
4373
4374 CALL timeset(routinen, handle)
4375
4376 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
4377 cpabort("Both grids must be either spherical or non-spherical!")
4378 IF (pw1%pw_grid%spherical) &
4379 cpabort("Spherical grids only exist in reciprocal space!")
4380
4381 IF (any(shape(pw2%array) /= shape(pw1%array))) &
4382 cpabort("3D grids must be compatible!")
4383 IF (pw1%pw_grid%spherical) &
4384 cpabort("3D grids must not be spherical!")
4385!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
4386 pw2%array(:, :, :) = cmplx(pw1%array(:, :, :), 0.0_dp, kind=dp)
4387!$OMP END PARALLEL WORKSHARE
4388
4389 CALL timestop(handle)
4390
4391 END SUBROUTINE pw_copy_r3d_c3d_rs
4392
4393! **************************************************************************************************
4394!> \brief ...
4395!> \param pw ...
4396!> \param array ...
4397! **************************************************************************************************
4398 SUBROUTINE pw_copy_to_array_r3d_c3d_rs (pw, array)
4399 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw
4400 COMPLEX(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: array
4401
4402 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
4403
4404 INTEGER :: handle
4405
4406 CALL timeset(routinen, handle)
4407
4408!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
4409 array(:, :, :) = cmplx(pw%array(:, :, :), 0.0_dp, kind=dp)
4410!$OMP END PARALLEL WORKSHARE
4411
4412 CALL timestop(handle)
4413 END SUBROUTINE pw_copy_to_array_r3d_c3d_rs
4414
4415! **************************************************************************************************
4416!> \brief ...
4417!> \param pw ...
4418!> \param array ...
4419! **************************************************************************************************
4420 SUBROUTINE pw_copy_from_array_r3d_c3d_rs (pw, array)
4421 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw
4422 COMPLEX(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: array
4423
4424 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
4425
4426 INTEGER :: handle
4427
4428 CALL timeset(routinen, handle)
4429
4430!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
4431 pw%array = real(array, kind=dp)
4432!$OMP END PARALLEL WORKSHARE
4433
4434 CALL timestop(handle)
4435 END SUBROUTINE pw_copy_from_array_r3d_c3d_rs
4436
4437! **************************************************************************************************
4438!> \brief pw2 = alpha*pw1 + beta*pw2
4439!> alpha defaults to 1, beta defaults to 1
4440!> \param pw1 ...
4441!> \param pw2 ...
4442!> \param alpha ...
4443!> \param beta ...
4444!> \param allow_noncompatible_grids ...
4445!> \par History
4446!> JGH (21-Feb-2003) : added reference grid functionality
4447!> JGH (01-Dec-2007) : rename and remove complex alpha
4448!> \author apsi
4449!> \note
4450!> Currently only summing up of respective types allowed,
4451!> in order to avoid errors
4452! **************************************************************************************************
4453 SUBROUTINE pw_axpy_r3d_c3d_rs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
4454
4455 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw1
4456 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw2
4457 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
4458 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
4459
4460 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
4461
4462 INTEGER :: handle
4463 LOGICAL :: my_allow_noncompatible_grids
4464 REAL(KIND=dp) :: my_alpha, my_beta
4465
4466 CALL timeset(routinen, handle)
4467
4468 my_alpha = 1.0_dp
4469 IF (PRESENT(alpha)) my_alpha = alpha
4470
4471 my_beta = 1.0_dp
4472 IF (PRESENT(beta)) my_beta = beta
4473
4474 my_allow_noncompatible_grids = .false.
4475 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
4476
4477 IF (my_beta /= 1.0_dp) THEN
4478 IF (my_beta == 0.0_dp) THEN
4479 CALL pw_zero(pw2)
4480 ELSE
4481!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
4482 pw2%array = pw2%array*my_beta
4483!$OMP END PARALLEL WORKSHARE
4484 END IF
4485 END IF
4486
4487 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
4488 IF (my_alpha == 1.0_dp) THEN
4489!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2)
4490 pw2%array = pw2%array + cmplx(pw1%array, 0.0_dp, kind=dp)
4491!$OMP END PARALLEL WORKSHARE
4492 ELSE IF (my_alpha /= 0.0_dp) THEN
4493!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2, my_alpha)
4494 pw2%array = pw2%array + my_alpha* cmplx(pw1%array, 0.0_dp, kind=dp)
4495!$OMP END PARALLEL WORKSHARE
4496 END IF
4497
4498 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
4499
4500 IF (any(shape(pw1%array) /= shape(pw2%array))) &
4501 cpabort("Noncommensurate grids not implemented for 3D grids!")
4502
4503 IF (my_alpha == 1.0_dp) THEN
4504!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
4505 pw2%array = pw2%array + cmplx(pw1%array, 0.0_dp, kind=dp)
4506!$OMP END PARALLEL WORKSHARE
4507 ELSE
4508!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2,my_alpha)
4509 pw2%array = pw2%array + my_alpha* cmplx(pw1%array, 0.0_dp, kind=dp)
4510!$OMP END PARALLEL WORKSHARE
4511 END IF
4512
4513 ELSE
4514
4515 cpabort("Grids not compatible")
4516
4517 END IF
4518
4519 CALL timestop(handle)
4520
4521 END SUBROUTINE pw_axpy_r3d_c3d_rs
4522
4523! **************************************************************************************************
4524!> \brief pw_out = pw_out + alpha * pw1 * pw2
4525!> alpha defaults to 1
4526!> \param pw_out ...
4527!> \param pw1 ...
4528!> \param pw2 ...
4529!> \param alpha ...
4530!> \author JGH
4531! **************************************************************************************************
4532 SUBROUTINE pw_multiply_r3d_c3d_rs (pw_out, pw1, pw2, alpha)
4533
4534 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw_out
4535 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw1
4536 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw2
4537 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
4538
4539 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
4540
4541 INTEGER :: handle
4542 REAL(KIND=dp) :: my_alpha
4543
4544 CALL timeset(routinen, handle)
4545
4546 my_alpha = 1.0_dp
4547 IF (PRESENT(alpha)) my_alpha = alpha
4548
4549 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
4550 cpabort("pw_multiply not implemented for non-identical grids!")
4551
4552#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
4553 IF (my_alpha == 1.0_dp) THEN
4554!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
4555 pw_out%array = pw_out%array + pw1%array* real(pw2%array, kind=dp)
4556!$OMP END PARALLEL WORKSHARE
4557 ELSE
4558!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
4559 pw_out%array = pw_out%array + my_alpha*pw1%array* real(pw2%array, kind=dp)
4560!$OMP END PARALLEL WORKSHARE
4561 END IF
4562#else
4563 IF (my_alpha == 1.0_dp) THEN
4564 pw_out%array = pw_out%array + pw1%array* real(pw2%array, kind=dp)
4565 ELSE
4566 pw_out%array = pw_out%array + my_alpha*pw1%array* real(pw2%array, kind=dp)
4567 END IF
4568#endif
4569
4570 CALL timestop(handle)
4571
4572 END SUBROUTINE pw_multiply_r3d_c3d_rs
4573
4574! **************************************************************************************************
4575!> \brief ...
4576!> \param pw1 ...
4577!> \param pw2 ...
4578! **************************************************************************************************
4579 SUBROUTINE pw_multiply_with_r3d_c3d_rs (pw1, pw2)
4580 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw1
4581 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw2
4582
4583 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
4584
4585 INTEGER :: handle
4586
4587 CALL timeset(routinen, handle)
4588
4589 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
4590 cpabort("Incompatible grids!")
4591
4592!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
4593 pw1%array = pw1%array* real(pw2%array, kind=dp)
4594!$OMP END PARALLEL WORKSHARE
4595
4596 CALL timestop(handle)
4597
4598 END SUBROUTINE pw_multiply_with_r3d_c3d_rs
4599
4600! **************************************************************************************************
4601!> \brief Calculate integral over unit cell for functions in plane wave basis
4602!> only returns the real part of it ......
4603!> \param pw1 ...
4604!> \param pw2 ...
4605!> \param sumtype ...
4606!> \param just_sum ...
4607!> \param local_only ...
4608!> \return ...
4609!> \par History
4610!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
4611!> \author apsi
4612! **************************************************************************************************
4613 FUNCTION pw_integral_ab_r3d_c3d_rs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
4614
4615 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw1
4616 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw2
4617 INTEGER, INTENT(IN), OPTIONAL :: sumtype
4618 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
4619 REAL(kind=dp) :: integral_value
4620
4621 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_r3d_c3d_rs'
4622
4623 INTEGER :: handle, loc_sumtype
4624 LOGICAL :: my_just_sum, my_local_only
4625
4626 CALL timeset(routinen, handle)
4627
4628 loc_sumtype = do_accurate_sum
4629 IF (PRESENT(sumtype)) loc_sumtype = sumtype
4630
4631 my_local_only = .false.
4632 IF (PRESENT(local_only)) my_local_only = local_only
4633
4634 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
4635 cpabort("Grids incompatible")
4636 END IF
4637
4638 my_just_sum = .false.
4639 IF (PRESENT(just_sum)) my_just_sum = just_sum
4640
4641 ! do standard sum
4642 IF (loc_sumtype == do_standard_sum) THEN
4643
4644 ! Do standard sum
4645
4646 integral_value = sum(pw1%array*real(pw2%array, kind=dp)) !? complex bit
4647
4648 ELSE
4649
4650 ! Do accurate sum
4651 integral_value = accurate_sum(pw1%array*real(pw2%array, kind=dp)) !? complex bit
4652
4653 END IF
4654
4655
4656 IF (.NOT. my_just_sum) THEN
4657 integral_value = integral_value*pw1%pw_grid%dvol
4658 END IF
4659
4660 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
4661 CALL pw1%pw_grid%para%group%sum(integral_value)
4662
4663 CALL timestop(handle)
4664
4665 END FUNCTION pw_integral_ab_r3d_c3d_rs
4666! **************************************************************************************************
4667!> \brief copy a pw type variable
4668!> \param pw1 ...
4669!> \param pw2 ...
4670!> \par History
4671!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
4672!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
4673!> JGH (21-Feb-2003) : Code for generalized reference grids
4674!> \author apsi
4675!> \note
4676!> Currently only copying of respective types allowed,
4677!> in order to avoid errors
4678! **************************************************************************************************
4679 SUBROUTINE pw_copy_r3d_c3d_gs (pw1, pw2)
4680
4681 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw1
4682 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw2
4683
4684 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
4685
4686 INTEGER :: handle
4687
4688 CALL timeset(routinen, handle)
4689
4690 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
4691 cpabort("Both grids must be either spherical or non-spherical!")
4692
4693 IF (any(shape(pw2%array) /= shape(pw1%array))) &
4694 cpabort("3D grids must be compatible!")
4695 IF (pw1%pw_grid%spherical) &
4696 cpabort("3D grids must not be spherical!")
4697!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
4698 pw2%array(:, :, :) = cmplx(pw1%array(:, :, :), 0.0_dp, kind=dp)
4699!$OMP END PARALLEL WORKSHARE
4700
4701 CALL timestop(handle)
4702
4703 END SUBROUTINE pw_copy_r3d_c3d_gs
4704
4705! **************************************************************************************************
4706!> \brief ...
4707!> \param pw ...
4708!> \param array ...
4709! **************************************************************************************************
4710 SUBROUTINE pw_copy_to_array_r3d_c3d_gs (pw, array)
4711 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw
4712 COMPLEX(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: array
4713
4714 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
4715
4716 INTEGER :: handle
4717
4718 CALL timeset(routinen, handle)
4719
4720!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
4721 array(:, :, :) = cmplx(pw%array(:, :, :), 0.0_dp, kind=dp)
4722!$OMP END PARALLEL WORKSHARE
4723
4724 CALL timestop(handle)
4725 END SUBROUTINE pw_copy_to_array_r3d_c3d_gs
4726
4727! **************************************************************************************************
4728!> \brief ...
4729!> \param pw ...
4730!> \param array ...
4731! **************************************************************************************************
4732 SUBROUTINE pw_copy_from_array_r3d_c3d_gs (pw, array)
4733 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw
4734 COMPLEX(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: array
4735
4736 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
4737
4738 INTEGER :: handle
4739
4740 CALL timeset(routinen, handle)
4741
4742!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
4743 pw%array = real(array, kind=dp)
4744!$OMP END PARALLEL WORKSHARE
4745
4746 CALL timestop(handle)
4747 END SUBROUTINE pw_copy_from_array_r3d_c3d_gs
4748
4749! **************************************************************************************************
4750!> \brief pw2 = alpha*pw1 + beta*pw2
4751!> alpha defaults to 1, beta defaults to 1
4752!> \param pw1 ...
4753!> \param pw2 ...
4754!> \param alpha ...
4755!> \param beta ...
4756!> \param allow_noncompatible_grids ...
4757!> \par History
4758!> JGH (21-Feb-2003) : added reference grid functionality
4759!> JGH (01-Dec-2007) : rename and remove complex alpha
4760!> \author apsi
4761!> \note
4762!> Currently only summing up of respective types allowed,
4763!> in order to avoid errors
4764! **************************************************************************************************
4765 SUBROUTINE pw_axpy_r3d_c3d_gs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
4766
4767 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw1
4768 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw2
4769 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
4770 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
4771
4772 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
4773
4774 INTEGER :: handle
4775 LOGICAL :: my_allow_noncompatible_grids
4776 REAL(KIND=dp) :: my_alpha, my_beta
4777
4778 CALL timeset(routinen, handle)
4779
4780 my_alpha = 1.0_dp
4781 IF (PRESENT(alpha)) my_alpha = alpha
4782
4783 my_beta = 1.0_dp
4784 IF (PRESENT(beta)) my_beta = beta
4785
4786 my_allow_noncompatible_grids = .false.
4787 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
4788
4789 IF (my_beta /= 1.0_dp) THEN
4790 IF (my_beta == 0.0_dp) THEN
4791 CALL pw_zero(pw2)
4792 ELSE
4793!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
4794 pw2%array = pw2%array*my_beta
4795!$OMP END PARALLEL WORKSHARE
4796 END IF
4797 END IF
4798
4799 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
4800 IF (my_alpha == 1.0_dp) THEN
4801!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2)
4802 pw2%array = pw2%array + cmplx(pw1%array, 0.0_dp, kind=dp)
4803!$OMP END PARALLEL WORKSHARE
4804 ELSE IF (my_alpha /= 0.0_dp) THEN
4805!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2, my_alpha)
4806 pw2%array = pw2%array + my_alpha* cmplx(pw1%array, 0.0_dp, kind=dp)
4807!$OMP END PARALLEL WORKSHARE
4808 END IF
4809
4810 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
4811
4812 IF (any(shape(pw1%array) /= shape(pw2%array))) &
4813 cpabort("Noncommensurate grids not implemented for 3D grids!")
4814
4815 IF (my_alpha == 1.0_dp) THEN
4816!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
4817 pw2%array = pw2%array + cmplx(pw1%array, 0.0_dp, kind=dp)
4818!$OMP END PARALLEL WORKSHARE
4819 ELSE
4820!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2,my_alpha)
4821 pw2%array = pw2%array + my_alpha* cmplx(pw1%array, 0.0_dp, kind=dp)
4822!$OMP END PARALLEL WORKSHARE
4823 END IF
4824
4825 ELSE
4826
4827 cpabort("Grids not compatible")
4828
4829 END IF
4830
4831 CALL timestop(handle)
4832
4833 END SUBROUTINE pw_axpy_r3d_c3d_gs
4834
4835! **************************************************************************************************
4836!> \brief pw_out = pw_out + alpha * pw1 * pw2
4837!> alpha defaults to 1
4838!> \param pw_out ...
4839!> \param pw1 ...
4840!> \param pw2 ...
4841!> \param alpha ...
4842!> \author JGH
4843! **************************************************************************************************
4844 SUBROUTINE pw_multiply_r3d_c3d_gs (pw_out, pw1, pw2, alpha)
4845
4846 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw_out
4847 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw1
4848 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw2
4849 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
4850
4851 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
4852
4853 INTEGER :: handle
4854 REAL(KIND=dp) :: my_alpha
4855
4856 CALL timeset(routinen, handle)
4857
4858 my_alpha = 1.0_dp
4859 IF (PRESENT(alpha)) my_alpha = alpha
4860
4861 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
4862 cpabort("pw_multiply not implemented for non-identical grids!")
4863
4864#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
4865 IF (my_alpha == 1.0_dp) THEN
4866!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
4867 pw_out%array = pw_out%array + pw1%array* real(pw2%array, kind=dp)
4868!$OMP END PARALLEL WORKSHARE
4869 ELSE
4870!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
4871 pw_out%array = pw_out%array + my_alpha*pw1%array* real(pw2%array, kind=dp)
4872!$OMP END PARALLEL WORKSHARE
4873 END IF
4874#else
4875 IF (my_alpha == 1.0_dp) THEN
4876 pw_out%array = pw_out%array + pw1%array* real(pw2%array, kind=dp)
4877 ELSE
4878 pw_out%array = pw_out%array + my_alpha*pw1%array* real(pw2%array, kind=dp)
4879 END IF
4880#endif
4881
4882 CALL timestop(handle)
4883
4884 END SUBROUTINE pw_multiply_r3d_c3d_gs
4885
4886! **************************************************************************************************
4887!> \brief ...
4888!> \param pw1 ...
4889!> \param pw2 ...
4890! **************************************************************************************************
4891 SUBROUTINE pw_multiply_with_r3d_c3d_gs (pw1, pw2)
4892 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw1
4893 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw2
4894
4895 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
4896
4897 INTEGER :: handle
4898
4899 CALL timeset(routinen, handle)
4900
4901 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
4902 cpabort("Incompatible grids!")
4903
4904!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
4905 pw1%array = pw1%array* real(pw2%array, kind=dp)
4906!$OMP END PARALLEL WORKSHARE
4907
4908 CALL timestop(handle)
4909
4910 END SUBROUTINE pw_multiply_with_r3d_c3d_gs
4911
4912! **************************************************************************************************
4913!> \brief Calculate integral over unit cell for functions in plane wave basis
4914!> only returns the real part of it ......
4915!> \param pw1 ...
4916!> \param pw2 ...
4917!> \param sumtype ...
4918!> \param just_sum ...
4919!> \param local_only ...
4920!> \return ...
4921!> \par History
4922!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
4923!> \author apsi
4924! **************************************************************************************************
4925 FUNCTION pw_integral_ab_r3d_c3d_gs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
4926
4927 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw1
4928 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw2
4929 INTEGER, INTENT(IN), OPTIONAL :: sumtype
4930 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
4931 REAL(kind=dp) :: integral_value
4932
4933 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_r3d_c3d_gs'
4934
4935 INTEGER :: handle, loc_sumtype
4936 LOGICAL :: my_just_sum, my_local_only
4937
4938 CALL timeset(routinen, handle)
4939
4940 loc_sumtype = do_accurate_sum
4941 IF (PRESENT(sumtype)) loc_sumtype = sumtype
4942
4943 my_local_only = .false.
4944 IF (PRESENT(local_only)) my_local_only = local_only
4945
4946 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
4947 cpabort("Grids incompatible")
4948 END IF
4949
4950 my_just_sum = .false.
4951 IF (PRESENT(just_sum)) my_just_sum = just_sum
4952
4953 ! do standard sum
4954 IF (loc_sumtype == do_standard_sum) THEN
4955
4956 ! Do standard sum
4957
4958 integral_value = sum(pw1%array*real(pw2%array, kind=dp)) !? complex bit
4959
4960 ELSE
4961
4962 ! Do accurate sum
4963 integral_value = accurate_sum(pw1%array*real(pw2%array, kind=dp)) !? complex bit
4964
4965 END IF
4966
4967
4968 IF (.NOT. my_just_sum) THEN
4969 integral_value = integral_value*pw1%pw_grid%vol
4970 END IF
4971
4972 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
4973 CALL pw1%pw_grid%para%group%sum(integral_value)
4974
4975 CALL timestop(handle)
4976
4977 END FUNCTION pw_integral_ab_r3d_c3d_gs
4978
4979! **************************************************************************************************
4980!> \brief copy a pw type variable
4981!> \param pw1 ...
4982!> \param pw2 ...
4983!> \par History
4984!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
4985!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
4986!> JGH (21-Feb-2003) : Code for generalized reference grids
4987!> \author apsi
4988!> \note
4989!> Currently only copying of respective types allowed,
4990!> in order to avoid errors
4991! **************************************************************************************************
4992 SUBROUTINE pw_copy_c1d_r1d_rs (pw1, pw2)
4993
4994 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw1
4995 TYPE(pw_r1d_rs_type), INTENT(INOUT) :: pw2
4996
4997 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
4998
4999 INTEGER :: handle
5000 INTEGER :: i, j, ng, ng1, ng2, ns
5001
5002 CALL timeset(routinen, handle)
5003
5004 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
5005 cpabort("Both grids must be either spherical or non-spherical!")
5006 IF (pw1%pw_grid%spherical) &
5007 cpabort("Spherical grids only exist in reciprocal space!")
5008
5009 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
5010 IF (pw1%pw_grid%spherical .AND. pw2%pw_grid%spherical) THEN
5011 IF (pw_compatible(pw1%pw_grid, pw2%pw_grid)) THEN
5012 ng1 = SIZE(pw1%array)
5013 ng2 = SIZE(pw2%array)
5014 ng = min(ng1, ng2)
5015!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, pw1, pw2)
5016 pw2%array(1:ng) = real(pw1%array(1:ng), kind=dp)
5017!$OMP END PARALLEL WORKSHARE
5018 IF (ng2 > ng) THEN
5019!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, ng2, pw2)
5020 pw2%array(ng + 1:ng2) = 0.0_dp
5021!$OMP END PARALLEL WORKSHARE
5022 END IF
5023 ELSE
5024 cpabort("Copies between spherical grids require compatible grids!")
5025 END IF
5026 ELSE
5027 ng1 = SIZE(pw1%array)
5028 ng2 = SIZE(pw2%array)
5029 ns = 2*max(ng1, ng2)
5030
5031 IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
5032 IF (ng1 >= ng2) THEN
5033!$OMP PARALLEL DO DEFAULT(NONE) &
5034!$OMP PRIVATE(i,j) &
5035!$OMP SHARED(ng2, pw1, pw2)
5036 DO i = 1, ng2
5037 j = pw2%pw_grid%gidx(i)
5038 pw2%array(i) = real(pw1%array(j), kind=dp)
5039 END DO
5040!$OMP END PARALLEL DO
5041 ELSE
5042 CALL pw_zero(pw2)
5043!$OMP PARALLEL DO DEFAULT(NONE) &
5044!$OMP PRIVATE(i,j) &
5045!$OMP SHARED(ng1, pw1, pw2)
5046 DO i = 1, ng1
5047 j = pw2%pw_grid%gidx(i)
5048 pw2%array(j) = real(pw1%array(i), kind=dp)
5049 END DO
5050!$OMP END PARALLEL DO
5051 END IF
5052 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
5053 IF (ng1 >= ng2) THEN
5054!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng2, pw1, pw2)
5055 DO i = 1, ng2
5056 j = pw1%pw_grid%gidx(i)
5057 pw2%array(i) = real(pw1%array(j), kind=dp)
5058 END DO
5059!$OMP END PARALLEL DO
5060 ELSE
5061 CALL pw_zero(pw2)
5062!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng1, pw1, pw2)
5063 DO i = 1, ng1
5064 j = pw1%pw_grid%gidx(i)
5065 pw2%array(j) = real(pw1%array(i), kind=dp)
5066 END DO
5067!$OMP END PARALLEL DO
5068 END IF
5069 ELSE
5070 cpabort("Copy not implemented!")
5071 END IF
5072
5073 END IF
5074
5075 ELSE
5076!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
5077 pw2%array = real(pw1%array, kind=dp)
5078!$OMP END PARALLEL WORKSHARE
5079 END IF
5080
5081 CALL timestop(handle)
5082
5083 END SUBROUTINE pw_copy_c1d_r1d_rs
5084
5085! **************************************************************************************************
5086!> \brief ...
5087!> \param pw ...
5088!> \param array ...
5089! **************************************************************************************************
5090 SUBROUTINE pw_copy_to_array_c1d_r1d_rs (pw, array)
5091 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw
5092 REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: array
5093
5094 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
5095
5096 INTEGER :: handle
5097
5098 CALL timeset(routinen, handle)
5099
5100!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
5101 array(:) = real(pw%array(:), kind=dp)
5102!$OMP END PARALLEL WORKSHARE
5103
5104 CALL timestop(handle)
5105 END SUBROUTINE pw_copy_to_array_c1d_r1d_rs
5106
5107! **************************************************************************************************
5108!> \brief ...
5109!> \param pw ...
5110!> \param array ...
5111! **************************************************************************************************
5112 SUBROUTINE pw_copy_from_array_c1d_r1d_rs (pw, array)
5113 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw
5114 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: array
5115
5116 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
5117
5118 INTEGER :: handle
5119
5120 CALL timeset(routinen, handle)
5121
5122!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
5123 pw%array = cmplx(array, 0.0_dp, kind=dp)
5124!$OMP END PARALLEL WORKSHARE
5125
5126 CALL timestop(handle)
5127 END SUBROUTINE pw_copy_from_array_c1d_r1d_rs
5128
5129! **************************************************************************************************
5130!> \brief pw2 = alpha*pw1 + beta*pw2
5131!> alpha defaults to 1, beta defaults to 1
5132!> \param pw1 ...
5133!> \param pw2 ...
5134!> \param alpha ...
5135!> \param beta ...
5136!> \param allow_noncompatible_grids ...
5137!> \par History
5138!> JGH (21-Feb-2003) : added reference grid functionality
5139!> JGH (01-Dec-2007) : rename and remove complex alpha
5140!> \author apsi
5141!> \note
5142!> Currently only summing up of respective types allowed,
5143!> in order to avoid errors
5144! **************************************************************************************************
5145 SUBROUTINE pw_axpy_c1d_r1d_rs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
5146
5147 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw1
5148 TYPE(pw_r1d_rs_type), INTENT(INOUT) :: pw2
5149 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
5150 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
5151
5152 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
5153
5154 INTEGER :: handle
5155 LOGICAL :: my_allow_noncompatible_grids
5156 REAL(KIND=dp) :: my_alpha, my_beta
5157 INTEGER :: i, j, ng, ng1, ng2
5158
5159 CALL timeset(routinen, handle)
5160
5161 my_alpha = 1.0_dp
5162 IF (PRESENT(alpha)) my_alpha = alpha
5163
5164 my_beta = 1.0_dp
5165 IF (PRESENT(beta)) my_beta = beta
5166
5167 my_allow_noncompatible_grids = .false.
5168 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
5169
5170 IF (my_beta /= 1.0_dp) THEN
5171 IF (my_beta == 0.0_dp) THEN
5172 CALL pw_zero(pw2)
5173 ELSE
5174!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
5175 pw2%array = pw2%array*my_beta
5176!$OMP END PARALLEL WORKSHARE
5177 END IF
5178 END IF
5179
5180 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
5181
5182 IF (my_alpha == 1.0_dp) THEN
5183!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
5184 pw2%array = pw2%array + real(pw1%array, kind=dp)
5185!$OMP END PARALLEL WORKSHARE
5186 ELSE IF (my_alpha /= 0.0_dp) THEN
5187!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha)
5188 pw2%array = pw2%array + my_alpha* real(pw1%array, kind=dp)
5189!$OMP END PARALLEL WORKSHARE
5190 END IF
5191
5192 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
5193
5194 ng1 = SIZE(pw1%array)
5195 ng2 = SIZE(pw2%array)
5196 ng = min(ng1, ng2)
5197
5198 IF (pw1%pw_grid%spherical) THEN
5199 IF (my_alpha == 1.0_dp) THEN
5200!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(ng, pw1, pw2)
5201 DO i = 1, ng
5202 pw2%array(i) = pw2%array(i) + real(pw1%array(i), kind=dp)
5203 END DO
5204!$OMP END PARALLEL DO
5205 ELSE IF (my_alpha /= 0.0_dp) THEN
5206!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha,ng)
5207 DO i = 1, ng
5208 pw2%array(i) = pw2%array(i) + my_alpha* real(pw1%array(i), kind=dp)
5209 END DO
5210!$OMP END PARALLEL DO
5211 END IF
5212 ELSE IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
5213 IF (ng1 >= ng2) THEN
5214 IF (my_alpha == 1.0_dp) THEN
5215!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
5216 DO i = 1, ng
5217 j = pw2%pw_grid%gidx(i)
5218 pw2%array(i) = pw2%array(i) + real(pw1%array(j), kind=dp)
5219 END DO
5220!$OMP END PARALLEL DO
5221 ELSE IF (my_alpha /= 0.0_dp) THEN
5222!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
5223 DO i = 1, ng
5224 j = pw2%pw_grid%gidx(i)
5225 pw2%array(i) = pw2%array(i) + my_alpha* real(pw1%array(j), kind=dp)
5226 END DO
5227!$OMP END PARALLEL DO
5228 END IF
5229 ELSE
5230 IF (my_alpha == 1.0_dp) THEN
5231!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
5232 DO i = 1, ng
5233 j = pw2%pw_grid%gidx(i)
5234 pw2%array(j) = pw2%array(j) + real(pw1%array(i), kind=dp)
5235 END DO
5236!$OMP END PARALLEL DO
5237 ELSE IF (my_alpha /= 0.0_dp) THEN
5238!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
5239 DO i = 1, ng
5240 j = pw2%pw_grid%gidx(i)
5241 pw2%array(j) = pw2%array(j) + my_alpha* real(pw1%array(i), kind=dp)
5242 END DO
5243!$OMP END PARALLEL DO
5244 END IF
5245 END IF
5246 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
5247 IF (ng1 >= ng2) THEN
5248 IF (my_alpha == 1.0_dp) THEN
5249!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
5250 DO i = 1, ng
5251 j = pw1%pw_grid%gidx(i)
5252 pw2%array(i) = pw2%array(i) + real(pw1%array(j), kind=dp)
5253 END DO
5254!$OMP END PARALLEL DO
5255 ELSE IF (my_alpha /= 0.0_dp) THEN
5256!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
5257 DO i = 1, ng
5258 j = pw1%pw_grid%gidx(i)
5259 pw2%array(i) = pw2%array(i) + my_alpha* real(pw1%array(j), kind=dp)
5260 END DO
5261!$OMP END PARALLEL DO
5262 END IF
5263 ELSE
5264 IF (my_alpha == 1.0_dp) THEN
5265!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
5266 DO i = 1, ng
5267 j = pw1%pw_grid%gidx(i)
5268 pw2%array(j) = pw2%array(j) + real(pw1%array(i), kind=dp)
5269 END DO
5270!$OMP END PARALLEL DO
5271 ELSE IF (my_alpha /= 0.0_dp) THEN
5272!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
5273 DO i = 1, ng
5274 j = pw1%pw_grid%gidx(i)
5275 pw2%array(j) = pw2%array(j) + my_alpha* real(pw1%array(i), kind=dp)
5276 END DO
5277!$OMP END PARALLEL DO
5278 END IF
5279 END IF
5280 ELSE
5281 cpabort("Grids not compatible")
5282 END IF
5283
5284 ELSE
5285
5286 cpabort("Grids not compatible")
5287
5288 END IF
5289
5290 CALL timestop(handle)
5291
5292 END SUBROUTINE pw_axpy_c1d_r1d_rs
5293
5294! **************************************************************************************************
5295!> \brief pw_out = pw_out + alpha * pw1 * pw2
5296!> alpha defaults to 1
5297!> \param pw_out ...
5298!> \param pw1 ...
5299!> \param pw2 ...
5300!> \param alpha ...
5301!> \author JGH
5302! **************************************************************************************************
5303 SUBROUTINE pw_multiply_c1d_r1d_rs (pw_out, pw1, pw2, alpha)
5304
5305 TYPE(pw_c1d_rs_type), INTENT(INOUT) :: pw_out
5306 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw1
5307 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw2
5308 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
5309
5310 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
5311
5312 INTEGER :: handle
5313 REAL(KIND=dp) :: my_alpha
5314
5315 CALL timeset(routinen, handle)
5316
5317 my_alpha = 1.0_dp
5318 IF (PRESENT(alpha)) my_alpha = alpha
5319
5320 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
5321 cpabort("pw_multiply not implemented for non-identical grids!")
5322
5323#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
5324 IF (my_alpha == 1.0_dp) THEN
5325!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
5326 pw_out%array = pw_out%array + pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
5327!$OMP END PARALLEL WORKSHARE
5328 ELSE
5329!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
5330 pw_out%array = pw_out%array + my_alpha*pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
5331!$OMP END PARALLEL WORKSHARE
5332 END IF
5333#else
5334 IF (my_alpha == 1.0_dp) THEN
5335 pw_out%array = pw_out%array + pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
5336 ELSE
5337 pw_out%array = pw_out%array + my_alpha*pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
5338 END IF
5339#endif
5340
5341 CALL timestop(handle)
5342
5343 END SUBROUTINE pw_multiply_c1d_r1d_rs
5344
5345! **************************************************************************************************
5346!> \brief ...
5347!> \param pw1 ...
5348!> \param pw2 ...
5349! **************************************************************************************************
5350 SUBROUTINE pw_multiply_with_c1d_r1d_rs (pw1, pw2)
5351 TYPE(pw_c1d_rs_type), INTENT(INOUT) :: pw1
5352 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw2
5353
5354 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
5355
5356 INTEGER :: handle
5357
5358 CALL timeset(routinen, handle)
5359
5360 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
5361 cpabort("Incompatible grids!")
5362
5363!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
5364 pw1%array = pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
5365!$OMP END PARALLEL WORKSHARE
5366
5367 CALL timestop(handle)
5368
5369 END SUBROUTINE pw_multiply_with_c1d_r1d_rs
5370
5371! **************************************************************************************************
5372!> \brief Calculate integral over unit cell for functions in plane wave basis
5373!> only returns the real part of it ......
5374!> \param pw1 ...
5375!> \param pw2 ...
5376!> \param sumtype ...
5377!> \param just_sum ...
5378!> \param local_only ...
5379!> \return ...
5380!> \par History
5381!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
5382!> \author apsi
5383! **************************************************************************************************
5384 FUNCTION pw_integral_ab_c1d_r1d_rs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
5385
5386 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw1
5387 TYPE(pw_r1d_rs_type), INTENT(IN) :: pw2
5388 INTEGER, INTENT(IN), OPTIONAL :: sumtype
5389 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
5390 REAL(kind=dp) :: integral_value
5391
5392 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_c1d_r1d_rs'
5393
5394 INTEGER :: handle, loc_sumtype
5395 LOGICAL :: my_just_sum, my_local_only
5396
5397 CALL timeset(routinen, handle)
5398
5399 loc_sumtype = do_accurate_sum
5400 IF (PRESENT(sumtype)) loc_sumtype = sumtype
5401
5402 my_local_only = .false.
5403 IF (PRESENT(local_only)) my_local_only = local_only
5404
5405 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
5406 cpabort("Grids incompatible")
5407 END IF
5408
5409 my_just_sum = .false.
5410 IF (PRESENT(just_sum)) my_just_sum = just_sum
5411
5412 ! do standard sum
5413 IF (loc_sumtype == do_standard_sum) THEN
5414
5415 ! Do standard sum
5416
5417 integral_value = sum(real(pw1%array, kind=dp)*pw2%array) !? complex bit
5418
5419 ELSE
5420
5421 ! Do accurate sum
5422 integral_value = accurate_sum(real(pw1%array, kind=dp)*pw2%array) !? complex bit
5423
5424 END IF
5425
5426 ! Apply reciprocal multiplicity before scaling the integral;
5427 ! the unpaired G=0 term must receive the same volume factor.
5428 IF (pw1%pw_grid%grid_span == halfspace) THEN
5429 integral_value = 2.0_dp*integral_value
5430 IF (pw1%pw_grid%have_g0) integral_value = integral_value - &
5431 REAL(conjg(pw1%array(1))*pw2%array(1), kind=dp)
5432 END IF
5433
5434 IF (.NOT. my_just_sum) THEN
5435 integral_value = integral_value*pw1%pw_grid%dvol
5436 END IF
5437
5438 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
5439 CALL pw1%pw_grid%para%group%sum(integral_value)
5440
5441 CALL timestop(handle)
5442
5443 END FUNCTION pw_integral_ab_c1d_r1d_rs
5444! **************************************************************************************************
5445!> \brief copy a pw type variable
5446!> \param pw1 ...
5447!> \param pw2 ...
5448!> \par History
5449!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
5450!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
5451!> JGH (21-Feb-2003) : Code for generalized reference grids
5452!> \author apsi
5453!> \note
5454!> Currently only copying of respective types allowed,
5455!> in order to avoid errors
5456! **************************************************************************************************
5457 SUBROUTINE pw_copy_c1d_r1d_gs (pw1, pw2)
5458
5459 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
5460 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw2
5461
5462 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
5463
5464 INTEGER :: handle
5465 INTEGER :: i, j, ng, ng1, ng2, ns
5466
5467 CALL timeset(routinen, handle)
5468
5469 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
5470 cpabort("Both grids must be either spherical or non-spherical!")
5471
5472 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
5473 IF (pw1%pw_grid%spherical .AND. pw2%pw_grid%spherical) THEN
5474 IF (pw_compatible(pw1%pw_grid, pw2%pw_grid)) THEN
5475 ng1 = SIZE(pw1%array)
5476 ng2 = SIZE(pw2%array)
5477 ng = min(ng1, ng2)
5478!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, pw1, pw2)
5479 pw2%array(1:ng) = real(pw1%array(1:ng), kind=dp)
5480!$OMP END PARALLEL WORKSHARE
5481 IF (ng2 > ng) THEN
5482!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, ng2, pw2)
5483 pw2%array(ng + 1:ng2) = 0.0_dp
5484!$OMP END PARALLEL WORKSHARE
5485 END IF
5486 ELSE
5487 cpabort("Copies between spherical grids require compatible grids!")
5488 END IF
5489 ELSE
5490 ng1 = SIZE(pw1%array)
5491 ng2 = SIZE(pw2%array)
5492 ns = 2*max(ng1, ng2)
5493
5494 IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
5495 IF (ng1 >= ng2) THEN
5496!$OMP PARALLEL DO DEFAULT(NONE) &
5497!$OMP PRIVATE(i,j) &
5498!$OMP SHARED(ng2, pw1, pw2)
5499 DO i = 1, ng2
5500 j = pw2%pw_grid%gidx(i)
5501 pw2%array(i) = real(pw1%array(j), kind=dp)
5502 END DO
5503!$OMP END PARALLEL DO
5504 ELSE
5505 CALL pw_zero(pw2)
5506!$OMP PARALLEL DO DEFAULT(NONE) &
5507!$OMP PRIVATE(i,j) &
5508!$OMP SHARED(ng1, pw1, pw2)
5509 DO i = 1, ng1
5510 j = pw2%pw_grid%gidx(i)
5511 pw2%array(j) = real(pw1%array(i), kind=dp)
5512 END DO
5513!$OMP END PARALLEL DO
5514 END IF
5515 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
5516 IF (ng1 >= ng2) THEN
5517!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng2, pw1, pw2)
5518 DO i = 1, ng2
5519 j = pw1%pw_grid%gidx(i)
5520 pw2%array(i) = real(pw1%array(j), kind=dp)
5521 END DO
5522!$OMP END PARALLEL DO
5523 ELSE
5524 CALL pw_zero(pw2)
5525!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng1, pw1, pw2)
5526 DO i = 1, ng1
5527 j = pw1%pw_grid%gidx(i)
5528 pw2%array(j) = real(pw1%array(i), kind=dp)
5529 END DO
5530!$OMP END PARALLEL DO
5531 END IF
5532 ELSE
5533 cpabort("Copy not implemented!")
5534 END IF
5535
5536 END IF
5537
5538 ELSE
5539!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
5540 pw2%array = real(pw1%array, kind=dp)
5541!$OMP END PARALLEL WORKSHARE
5542 END IF
5543
5544 CALL timestop(handle)
5545
5546 END SUBROUTINE pw_copy_c1d_r1d_gs
5547
5548! **************************************************************************************************
5549!> \brief ...
5550!> \param pw ...
5551!> \param array ...
5552! **************************************************************************************************
5553 SUBROUTINE pw_copy_to_array_c1d_r1d_gs (pw, array)
5554 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
5555 REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: array
5556
5557 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
5558
5559 INTEGER :: handle
5560
5561 CALL timeset(routinen, handle)
5562
5563!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
5564 array(:) = real(pw%array(:), kind=dp)
5565!$OMP END PARALLEL WORKSHARE
5566
5567 CALL timestop(handle)
5568 END SUBROUTINE pw_copy_to_array_c1d_r1d_gs
5569
5570! **************************************************************************************************
5571!> \brief ...
5572!> \param pw ...
5573!> \param array ...
5574! **************************************************************************************************
5575 SUBROUTINE pw_copy_from_array_c1d_r1d_gs (pw, array)
5576 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
5577 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: array
5578
5579 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
5580
5581 INTEGER :: handle
5582
5583 CALL timeset(routinen, handle)
5584
5585!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
5586 pw%array = cmplx(array, 0.0_dp, kind=dp)
5587!$OMP END PARALLEL WORKSHARE
5588
5589 CALL timestop(handle)
5590 END SUBROUTINE pw_copy_from_array_c1d_r1d_gs
5591
5592! **************************************************************************************************
5593!> \brief pw2 = alpha*pw1 + beta*pw2
5594!> alpha defaults to 1, beta defaults to 1
5595!> \param pw1 ...
5596!> \param pw2 ...
5597!> \param alpha ...
5598!> \param beta ...
5599!> \param allow_noncompatible_grids ...
5600!> \par History
5601!> JGH (21-Feb-2003) : added reference grid functionality
5602!> JGH (01-Dec-2007) : rename and remove complex alpha
5603!> \author apsi
5604!> \note
5605!> Currently only summing up of respective types allowed,
5606!> in order to avoid errors
5607! **************************************************************************************************
5608 SUBROUTINE pw_axpy_c1d_r1d_gs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
5609
5610 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
5611 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw2
5612 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
5613 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
5614
5615 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
5616
5617 INTEGER :: handle
5618 LOGICAL :: my_allow_noncompatible_grids
5619 REAL(KIND=dp) :: my_alpha, my_beta
5620 INTEGER :: i, j, ng, ng1, ng2
5621
5622 CALL timeset(routinen, handle)
5623
5624 my_alpha = 1.0_dp
5625 IF (PRESENT(alpha)) my_alpha = alpha
5626
5627 my_beta = 1.0_dp
5628 IF (PRESENT(beta)) my_beta = beta
5629
5630 my_allow_noncompatible_grids = .false.
5631 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
5632
5633 IF (my_beta /= 1.0_dp) THEN
5634 IF (my_beta == 0.0_dp) THEN
5635 CALL pw_zero(pw2)
5636 ELSE
5637!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
5638 pw2%array = pw2%array*my_beta
5639!$OMP END PARALLEL WORKSHARE
5640 END IF
5641 END IF
5642
5643 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
5644
5645 IF (my_alpha == 1.0_dp) THEN
5646!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
5647 pw2%array = pw2%array + real(pw1%array, kind=dp)
5648!$OMP END PARALLEL WORKSHARE
5649 ELSE IF (my_alpha /= 0.0_dp) THEN
5650!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha)
5651 pw2%array = pw2%array + my_alpha* real(pw1%array, kind=dp)
5652!$OMP END PARALLEL WORKSHARE
5653 END IF
5654
5655 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
5656
5657 ng1 = SIZE(pw1%array)
5658 ng2 = SIZE(pw2%array)
5659 ng = min(ng1, ng2)
5660
5661 IF (pw1%pw_grid%spherical) THEN
5662 IF (my_alpha == 1.0_dp) THEN
5663!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(ng, pw1, pw2)
5664 DO i = 1, ng
5665 pw2%array(i) = pw2%array(i) + real(pw1%array(i), kind=dp)
5666 END DO
5667!$OMP END PARALLEL DO
5668 ELSE IF (my_alpha /= 0.0_dp) THEN
5669!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha,ng)
5670 DO i = 1, ng
5671 pw2%array(i) = pw2%array(i) + my_alpha* real(pw1%array(i), kind=dp)
5672 END DO
5673!$OMP END PARALLEL DO
5674 END IF
5675 ELSE IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
5676 IF (ng1 >= ng2) THEN
5677 IF (my_alpha == 1.0_dp) THEN
5678!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
5679 DO i = 1, ng
5680 j = pw2%pw_grid%gidx(i)
5681 pw2%array(i) = pw2%array(i) + real(pw1%array(j), kind=dp)
5682 END DO
5683!$OMP END PARALLEL DO
5684 ELSE IF (my_alpha /= 0.0_dp) THEN
5685!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
5686 DO i = 1, ng
5687 j = pw2%pw_grid%gidx(i)
5688 pw2%array(i) = pw2%array(i) + my_alpha* real(pw1%array(j), kind=dp)
5689 END DO
5690!$OMP END PARALLEL DO
5691 END IF
5692 ELSE
5693 IF (my_alpha == 1.0_dp) THEN
5694!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
5695 DO i = 1, ng
5696 j = pw2%pw_grid%gidx(i)
5697 pw2%array(j) = pw2%array(j) + real(pw1%array(i), kind=dp)
5698 END DO
5699!$OMP END PARALLEL DO
5700 ELSE IF (my_alpha /= 0.0_dp) THEN
5701!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
5702 DO i = 1, ng
5703 j = pw2%pw_grid%gidx(i)
5704 pw2%array(j) = pw2%array(j) + my_alpha* real(pw1%array(i), kind=dp)
5705 END DO
5706!$OMP END PARALLEL DO
5707 END IF
5708 END IF
5709 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
5710 IF (ng1 >= ng2) THEN
5711 IF (my_alpha == 1.0_dp) THEN
5712!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
5713 DO i = 1, ng
5714 j = pw1%pw_grid%gidx(i)
5715 pw2%array(i) = pw2%array(i) + real(pw1%array(j), kind=dp)
5716 END DO
5717!$OMP END PARALLEL DO
5718 ELSE IF (my_alpha /= 0.0_dp) THEN
5719!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
5720 DO i = 1, ng
5721 j = pw1%pw_grid%gidx(i)
5722 pw2%array(i) = pw2%array(i) + my_alpha* real(pw1%array(j), kind=dp)
5723 END DO
5724!$OMP END PARALLEL DO
5725 END IF
5726 ELSE
5727 IF (my_alpha == 1.0_dp) THEN
5728!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
5729 DO i = 1, ng
5730 j = pw1%pw_grid%gidx(i)
5731 pw2%array(j) = pw2%array(j) + real(pw1%array(i), kind=dp)
5732 END DO
5733!$OMP END PARALLEL DO
5734 ELSE IF (my_alpha /= 0.0_dp) THEN
5735!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
5736 DO i = 1, ng
5737 j = pw1%pw_grid%gidx(i)
5738 pw2%array(j) = pw2%array(j) + my_alpha* real(pw1%array(i), kind=dp)
5739 END DO
5740!$OMP END PARALLEL DO
5741 END IF
5742 END IF
5743 ELSE
5744 cpabort("Grids not compatible")
5745 END IF
5746
5747 ELSE
5748
5749 cpabort("Grids not compatible")
5750
5751 END IF
5752
5753 CALL timestop(handle)
5754
5755 END SUBROUTINE pw_axpy_c1d_r1d_gs
5756
5757! **************************************************************************************************
5758!> \brief pw_out = pw_out + alpha * pw1 * pw2
5759!> alpha defaults to 1
5760!> \param pw_out ...
5761!> \param pw1 ...
5762!> \param pw2 ...
5763!> \param alpha ...
5764!> \author JGH
5765! **************************************************************************************************
5766 SUBROUTINE pw_multiply_c1d_r1d_gs (pw_out, pw1, pw2, alpha)
5767
5768 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw_out
5769 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
5770 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw2
5771 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
5772
5773 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
5774
5775 INTEGER :: handle
5776 REAL(KIND=dp) :: my_alpha
5777
5778 CALL timeset(routinen, handle)
5779
5780 my_alpha = 1.0_dp
5781 IF (PRESENT(alpha)) my_alpha = alpha
5782
5783 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
5784 cpabort("pw_multiply not implemented for non-identical grids!")
5785
5786#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
5787 IF (my_alpha == 1.0_dp) THEN
5788!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
5789 pw_out%array = pw_out%array + pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
5790!$OMP END PARALLEL WORKSHARE
5791 ELSE
5792!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
5793 pw_out%array = pw_out%array + my_alpha*pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
5794!$OMP END PARALLEL WORKSHARE
5795 END IF
5796#else
5797 IF (my_alpha == 1.0_dp) THEN
5798 pw_out%array = pw_out%array + pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
5799 ELSE
5800 pw_out%array = pw_out%array + my_alpha*pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
5801 END IF
5802#endif
5803
5804 CALL timestop(handle)
5805
5806 END SUBROUTINE pw_multiply_c1d_r1d_gs
5807
5808! **************************************************************************************************
5809!> \brief ...
5810!> \param pw1 ...
5811!> \param pw2 ...
5812! **************************************************************************************************
5813 SUBROUTINE pw_multiply_with_c1d_r1d_gs (pw1, pw2)
5814 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw1
5815 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw2
5816
5817 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
5818
5819 INTEGER :: handle
5820
5821 CALL timeset(routinen, handle)
5822
5823 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
5824 cpabort("Incompatible grids!")
5825
5826!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
5827 pw1%array = pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
5828!$OMP END PARALLEL WORKSHARE
5829
5830 CALL timestop(handle)
5831
5832 END SUBROUTINE pw_multiply_with_c1d_r1d_gs
5833
5834! **************************************************************************************************
5835!> \brief Calculate integral over unit cell for functions in plane wave basis
5836!> only returns the real part of it ......
5837!> \param pw1 ...
5838!> \param pw2 ...
5839!> \param sumtype ...
5840!> \param just_sum ...
5841!> \param local_only ...
5842!> \return ...
5843!> \par History
5844!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
5845!> \author apsi
5846! **************************************************************************************************
5847 FUNCTION pw_integral_ab_c1d_r1d_gs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
5848
5849 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
5850 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw2
5851 INTEGER, INTENT(IN), OPTIONAL :: sumtype
5852 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
5853 REAL(kind=dp) :: integral_value
5854
5855 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_c1d_r1d_gs'
5856
5857 INTEGER :: handle, loc_sumtype
5858 LOGICAL :: my_just_sum, my_local_only
5859
5860 CALL timeset(routinen, handle)
5861
5862 loc_sumtype = do_accurate_sum
5863 IF (PRESENT(sumtype)) loc_sumtype = sumtype
5864
5865 my_local_only = .false.
5866 IF (PRESENT(local_only)) my_local_only = local_only
5867
5868 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
5869 cpabort("Grids incompatible")
5870 END IF
5871
5872 my_just_sum = .false.
5873 IF (PRESENT(just_sum)) my_just_sum = just_sum
5874
5875 ! do standard sum
5876 IF (loc_sumtype == do_standard_sum) THEN
5877
5878 ! Do standard sum
5879
5880 integral_value = sum(real(pw1%array, kind=dp)*pw2%array) !? complex bit
5881
5882 ELSE
5883
5884 ! Do accurate sum
5885 integral_value = accurate_sum(real(pw1%array, kind=dp)*pw2%array) !? complex bit
5886
5887 END IF
5888
5889 ! Apply reciprocal multiplicity before scaling the integral;
5890 ! the unpaired G=0 term must receive the same volume factor.
5891 IF (pw1%pw_grid%grid_span == halfspace) THEN
5892 integral_value = 2.0_dp*integral_value
5893 IF (pw1%pw_grid%have_g0) integral_value = integral_value - &
5894 REAL(conjg(pw1%array(1))*pw2%array(1), kind=dp)
5895 END IF
5896
5897 IF (.NOT. my_just_sum) THEN
5898 integral_value = integral_value*pw1%pw_grid%vol
5899 END IF
5900
5901 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
5902 CALL pw1%pw_grid%para%group%sum(integral_value)
5903
5904 CALL timestop(handle)
5905
5906 END FUNCTION pw_integral_ab_c1d_r1d_gs
5907
5908! **************************************************************************************************
5909!> \brief ...
5910!> \param pw1 ...
5911!> \param pw2 ...
5912!> \return ...
5913! **************************************************************************************************
5914 FUNCTION pw_integral_a2b_c1d_r1d (pw1, pw2) RESULT(integral_value)
5915
5916 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
5917 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw2
5918 REAL(kind=dp) :: integral_value
5919
5920 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_a2b'
5921
5922 INTEGER :: handle
5923
5924 CALL timeset(routinen, handle)
5925
5926 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
5927 cpabort("Grids incompatible")
5928 END IF
5929
5930 integral_value = accurate_sum(real(conjg(pw1%array), kind=dp)*pw2%array*pw1%pw_grid%gsq)
5931 IF (pw1%pw_grid%grid_span == halfspace) THEN
5932 integral_value = 2.0_dp*integral_value
5933 END IF
5934
5935 integral_value = integral_value*pw1%pw_grid%vol
5936
5937 IF (pw1%pw_grid%para%mode == pw_mode_distributed) &
5938 CALL pw1%pw_grid%para%group%sum(integral_value)
5939 CALL timestop(handle)
5940
5941 END FUNCTION pw_integral_a2b_c1d_r1d
5942! **************************************************************************************************
5943!> \brief copy a pw type variable
5944!> \param pw1 ...
5945!> \param pw2 ...
5946!> \par History
5947!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
5948!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
5949!> JGH (21-Feb-2003) : Code for generalized reference grids
5950!> \author apsi
5951!> \note
5952!> Currently only copying of respective types allowed,
5953!> in order to avoid errors
5954! **************************************************************************************************
5955 SUBROUTINE pw_copy_c1d_c1d_rs (pw1, pw2)
5956
5957 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw1
5958 TYPE(pw_c1d_rs_type), INTENT(INOUT) :: pw2
5959
5960 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
5961
5962 INTEGER :: handle
5963 INTEGER :: i, j, ng, ng1, ng2, ns
5964
5965 CALL timeset(routinen, handle)
5966
5967 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
5968 cpabort("Both grids must be either spherical or non-spherical!")
5969 IF (pw1%pw_grid%spherical) &
5970 cpabort("Spherical grids only exist in reciprocal space!")
5971
5972 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
5973 IF (pw1%pw_grid%spherical .AND. pw2%pw_grid%spherical) THEN
5974 IF (pw_compatible(pw1%pw_grid, pw2%pw_grid)) THEN
5975 ng1 = SIZE(pw1%array)
5976 ng2 = SIZE(pw2%array)
5977 ng = min(ng1, ng2)
5978!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, pw1, pw2)
5979 pw2%array(1:ng) = pw1%array(1:ng)
5980!$OMP END PARALLEL WORKSHARE
5981 IF (ng2 > ng) THEN
5982!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, ng2, pw2)
5983 pw2%array(ng + 1:ng2) = cmplx(0.0_dp, 0.0_dp, kind=dp)
5984!$OMP END PARALLEL WORKSHARE
5985 END IF
5986 ELSE
5987 cpabort("Copies between spherical grids require compatible grids!")
5988 END IF
5989 ELSE
5990 ng1 = SIZE(pw1%array)
5991 ng2 = SIZE(pw2%array)
5992 ns = 2*max(ng1, ng2)
5993
5994 IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
5995 IF (ng1 >= ng2) THEN
5996!$OMP PARALLEL DO DEFAULT(NONE) &
5997!$OMP PRIVATE(i,j) &
5998!$OMP SHARED(ng2, pw1, pw2)
5999 DO i = 1, ng2
6000 j = pw2%pw_grid%gidx(i)
6001 pw2%array(i) = pw1%array(j)
6002 END DO
6003!$OMP END PARALLEL DO
6004 ELSE
6005 CALL pw_zero(pw2)
6006!$OMP PARALLEL DO DEFAULT(NONE) &
6007!$OMP PRIVATE(i,j) &
6008!$OMP SHARED(ng1, pw1, pw2)
6009 DO i = 1, ng1
6010 j = pw2%pw_grid%gidx(i)
6011 pw2%array(j) = pw1%array(i)
6012 END DO
6013!$OMP END PARALLEL DO
6014 END IF
6015 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
6016 IF (ng1 >= ng2) THEN
6017!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng2, pw1, pw2)
6018 DO i = 1, ng2
6019 j = pw1%pw_grid%gidx(i)
6020 pw2%array(i) = pw1%array(j)
6021 END DO
6022!$OMP END PARALLEL DO
6023 ELSE
6024 CALL pw_zero(pw2)
6025!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng1, pw1, pw2)
6026 DO i = 1, ng1
6027 j = pw1%pw_grid%gidx(i)
6028 pw2%array(j) = pw1%array(i)
6029 END DO
6030!$OMP END PARALLEL DO
6031 END IF
6032 ELSE
6033 cpabort("Copy not implemented!")
6034 END IF
6035
6036 END IF
6037
6038 ELSE
6039!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
6040 pw2%array = pw1%array
6041!$OMP END PARALLEL WORKSHARE
6042 END IF
6043
6044 CALL timestop(handle)
6045
6046 END SUBROUTINE pw_copy_c1d_c1d_rs
6047
6048! **************************************************************************************************
6049!> \brief ...
6050!> \param pw ...
6051!> \param array ...
6052! **************************************************************************************************
6053 SUBROUTINE pw_copy_to_array_c1d_c1d_rs (pw, array)
6054 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw
6055 COMPLEX(KIND=dp), DIMENSION(:), INTENT(INOUT) :: array
6056
6057 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
6058
6059 INTEGER :: handle
6060
6061 CALL timeset(routinen, handle)
6062
6063!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
6064 array(:) = pw%array(:)
6065!$OMP END PARALLEL WORKSHARE
6066
6067 CALL timestop(handle)
6068 END SUBROUTINE pw_copy_to_array_c1d_c1d_rs
6069
6070! **************************************************************************************************
6071!> \brief ...
6072!> \param pw ...
6073!> \param array ...
6074! **************************************************************************************************
6075 SUBROUTINE pw_copy_from_array_c1d_c1d_rs (pw, array)
6076 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw
6077 COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: array
6078
6079 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
6080
6081 INTEGER :: handle
6082
6083 CALL timeset(routinen, handle)
6084
6085!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
6086 pw%array = array
6087!$OMP END PARALLEL WORKSHARE
6088
6089 CALL timestop(handle)
6090 END SUBROUTINE pw_copy_from_array_c1d_c1d_rs
6091
6092! **************************************************************************************************
6093!> \brief pw2 = alpha*pw1 + beta*pw2
6094!> alpha defaults to 1, beta defaults to 1
6095!> \param pw1 ...
6096!> \param pw2 ...
6097!> \param alpha ...
6098!> \param beta ...
6099!> \param allow_noncompatible_grids ...
6100!> \par History
6101!> JGH (21-Feb-2003) : added reference grid functionality
6102!> JGH (01-Dec-2007) : rename and remove complex alpha
6103!> \author apsi
6104!> \note
6105!> Currently only summing up of respective types allowed,
6106!> in order to avoid errors
6107! **************************************************************************************************
6108 SUBROUTINE pw_axpy_c1d_c1d_rs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
6109
6110 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw1
6111 TYPE(pw_c1d_rs_type), INTENT(INOUT) :: pw2
6112 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
6113 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
6114
6115 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
6116
6117 INTEGER :: handle
6118 LOGICAL :: my_allow_noncompatible_grids
6119 REAL(KIND=dp) :: my_alpha, my_beta
6120 INTEGER :: i, j, ng, ng1, ng2
6121
6122 CALL timeset(routinen, handle)
6123
6124 my_alpha = 1.0_dp
6125 IF (PRESENT(alpha)) my_alpha = alpha
6126
6127 my_beta = 1.0_dp
6128 IF (PRESENT(beta)) my_beta = beta
6129
6130 my_allow_noncompatible_grids = .false.
6131 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
6132
6133 IF (my_beta /= 1.0_dp) THEN
6134 IF (my_beta == 0.0_dp) THEN
6135 CALL pw_zero(pw2)
6136 ELSE
6137!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
6138 pw2%array = pw2%array*my_beta
6139!$OMP END PARALLEL WORKSHARE
6140 END IF
6141 END IF
6142
6143 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
6144
6145 IF (my_alpha == 1.0_dp) THEN
6146!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
6147 pw2%array = pw2%array + pw1%array
6148!$OMP END PARALLEL WORKSHARE
6149 ELSE IF (my_alpha /= 0.0_dp) THEN
6150!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha)
6151 pw2%array = pw2%array + my_alpha* pw1%array
6152!$OMP END PARALLEL WORKSHARE
6153 END IF
6154
6155 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
6156
6157 ng1 = SIZE(pw1%array)
6158 ng2 = SIZE(pw2%array)
6159 ng = min(ng1, ng2)
6160
6161 IF (pw1%pw_grid%spherical) THEN
6162 IF (my_alpha == 1.0_dp) THEN
6163!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(ng, pw1, pw2)
6164 DO i = 1, ng
6165 pw2%array(i) = pw2%array(i) + pw1%array(i)
6166 END DO
6167!$OMP END PARALLEL DO
6168 ELSE IF (my_alpha /= 0.0_dp) THEN
6169!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha,ng)
6170 DO i = 1, ng
6171 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(i)
6172 END DO
6173!$OMP END PARALLEL DO
6174 END IF
6175 ELSE IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
6176 IF (ng1 >= ng2) THEN
6177 IF (my_alpha == 1.0_dp) THEN
6178!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
6179 DO i = 1, ng
6180 j = pw2%pw_grid%gidx(i)
6181 pw2%array(i) = pw2%array(i) + pw1%array(j)
6182 END DO
6183!$OMP END PARALLEL DO
6184 ELSE IF (my_alpha /= 0.0_dp) THEN
6185!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
6186 DO i = 1, ng
6187 j = pw2%pw_grid%gidx(i)
6188 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(j)
6189 END DO
6190!$OMP END PARALLEL DO
6191 END IF
6192 ELSE
6193 IF (my_alpha == 1.0_dp) THEN
6194!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
6195 DO i = 1, ng
6196 j = pw2%pw_grid%gidx(i)
6197 pw2%array(j) = pw2%array(j) + pw1%array(i)
6198 END DO
6199!$OMP END PARALLEL DO
6200 ELSE IF (my_alpha /= 0.0_dp) THEN
6201!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
6202 DO i = 1, ng
6203 j = pw2%pw_grid%gidx(i)
6204 pw2%array(j) = pw2%array(j) + my_alpha* pw1%array(i)
6205 END DO
6206!$OMP END PARALLEL DO
6207 END IF
6208 END IF
6209 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
6210 IF (ng1 >= ng2) THEN
6211 IF (my_alpha == 1.0_dp) THEN
6212!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
6213 DO i = 1, ng
6214 j = pw1%pw_grid%gidx(i)
6215 pw2%array(i) = pw2%array(i) + pw1%array(j)
6216 END DO
6217!$OMP END PARALLEL DO
6218 ELSE IF (my_alpha /= 0.0_dp) THEN
6219!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
6220 DO i = 1, ng
6221 j = pw1%pw_grid%gidx(i)
6222 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(j)
6223 END DO
6224!$OMP END PARALLEL DO
6225 END IF
6226 ELSE
6227 IF (my_alpha == 1.0_dp) THEN
6228!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
6229 DO i = 1, ng
6230 j = pw1%pw_grid%gidx(i)
6231 pw2%array(j) = pw2%array(j) + pw1%array(i)
6232 END DO
6233!$OMP END PARALLEL DO
6234 ELSE IF (my_alpha /= 0.0_dp) THEN
6235!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
6236 DO i = 1, ng
6237 j = pw1%pw_grid%gidx(i)
6238 pw2%array(j) = pw2%array(j) + my_alpha* pw1%array(i)
6239 END DO
6240!$OMP END PARALLEL DO
6241 END IF
6242 END IF
6243 ELSE
6244 cpabort("Grids not compatible")
6245 END IF
6246
6247 ELSE
6248
6249 cpabort("Grids not compatible")
6250
6251 END IF
6252
6253 CALL timestop(handle)
6254
6255 END SUBROUTINE pw_axpy_c1d_c1d_rs
6256
6257! **************************************************************************************************
6258!> \brief pw_out = pw_out + alpha * pw1 * pw2
6259!> alpha defaults to 1
6260!> \param pw_out ...
6261!> \param pw1 ...
6262!> \param pw2 ...
6263!> \param alpha ...
6264!> \author JGH
6265! **************************************************************************************************
6266 SUBROUTINE pw_multiply_c1d_c1d_rs (pw_out, pw1, pw2, alpha)
6267
6268 TYPE(pw_c1d_rs_type), INTENT(INOUT) :: pw_out
6269 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw1
6270 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw2
6271 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
6272
6273 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
6274
6275 INTEGER :: handle
6276 REAL(KIND=dp) :: my_alpha
6277
6278 CALL timeset(routinen, handle)
6279
6280 my_alpha = 1.0_dp
6281 IF (PRESENT(alpha)) my_alpha = alpha
6282
6283 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
6284 cpabort("pw_multiply not implemented for non-identical grids!")
6285
6286#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
6287 IF (my_alpha == 1.0_dp) THEN
6288!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
6289 pw_out%array = pw_out%array + pw1%array* pw2%array
6290!$OMP END PARALLEL WORKSHARE
6291 ELSE
6292!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
6293 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
6294!$OMP END PARALLEL WORKSHARE
6295 END IF
6296#else
6297 IF (my_alpha == 1.0_dp) THEN
6298 pw_out%array = pw_out%array + pw1%array* pw2%array
6299 ELSE
6300 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
6301 END IF
6302#endif
6303
6304 CALL timestop(handle)
6305
6306 END SUBROUTINE pw_multiply_c1d_c1d_rs
6307
6308! **************************************************************************************************
6309!> \brief ...
6310!> \param pw1 ...
6311!> \param pw2 ...
6312! **************************************************************************************************
6313 SUBROUTINE pw_multiply_with_c1d_c1d_rs (pw1, pw2)
6314 TYPE(pw_c1d_rs_type), INTENT(INOUT) :: pw1
6315 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw2
6316
6317 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
6318
6319 INTEGER :: handle
6320
6321 CALL timeset(routinen, handle)
6322
6323 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
6324 cpabort("Incompatible grids!")
6325
6326!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
6327 pw1%array = pw1%array* pw2%array
6328!$OMP END PARALLEL WORKSHARE
6329
6330 CALL timestop(handle)
6331
6332 END SUBROUTINE pw_multiply_with_c1d_c1d_rs
6333
6334! **************************************************************************************************
6335!> \brief Calculate integral over unit cell for functions in plane wave basis
6336!> only returns the real part of it ......
6337!> \param pw1 ...
6338!> \param pw2 ...
6339!> \param sumtype ...
6340!> \param just_sum ...
6341!> \param local_only ...
6342!> \return ...
6343!> \par History
6344!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
6345!> \author apsi
6346! **************************************************************************************************
6347 FUNCTION pw_integral_ab_c1d_c1d_rs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
6348
6349 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw1
6350 TYPE(pw_c1d_rs_type), INTENT(IN) :: pw2
6351 INTEGER, INTENT(IN), OPTIONAL :: sumtype
6352 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
6353 REAL(kind=dp) :: integral_value
6354
6355 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_c1d_c1d_rs'
6356
6357 INTEGER :: handle, loc_sumtype
6358 LOGICAL :: my_just_sum, my_local_only
6359
6360 CALL timeset(routinen, handle)
6361
6362 loc_sumtype = do_accurate_sum
6363 IF (PRESENT(sumtype)) loc_sumtype = sumtype
6364
6365 my_local_only = .false.
6366 IF (PRESENT(local_only)) my_local_only = local_only
6367
6368 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
6369 cpabort("Grids incompatible")
6370 END IF
6371
6372 my_just_sum = .false.
6373 IF (PRESENT(just_sum)) my_just_sum = just_sum
6374
6375 ! do standard sum
6376 IF (loc_sumtype == do_standard_sum) THEN
6377
6378 ! Do standard sum
6379
6380 integral_value = sum(real(conjg(pw1%array) &
6381 *pw2%array, kind=dp)) !? complex bit
6382
6383 ELSE
6384
6385 ! Do accurate sum
6386 integral_value = accurate_sum(real(conjg(pw1%array)*pw2%array, kind=dp))
6387
6388 END IF
6389
6390 ! Apply reciprocal multiplicity before scaling the integral;
6391 ! the unpaired G=0 term must receive the same volume factor.
6392 IF (pw1%pw_grid%grid_span == halfspace) THEN
6393 integral_value = 2.0_dp*integral_value
6394 IF (pw1%pw_grid%have_g0) integral_value = integral_value - &
6395 REAL(conjg(pw1%array(1))*pw2%array(1), kind=dp)
6396 END IF
6397
6398 IF (.NOT. my_just_sum) THEN
6399 integral_value = integral_value*pw1%pw_grid%dvol
6400 END IF
6401
6402 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
6403 CALL pw1%pw_grid%para%group%sum(integral_value)
6404
6405 CALL timestop(handle)
6406
6407 END FUNCTION pw_integral_ab_c1d_c1d_rs
6408! **************************************************************************************************
6409!> \brief copy a pw type variable
6410!> \param pw1 ...
6411!> \param pw2 ...
6412!> \par History
6413!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
6414!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
6415!> JGH (21-Feb-2003) : Code for generalized reference grids
6416!> \author apsi
6417!> \note
6418!> Currently only copying of respective types allowed,
6419!> in order to avoid errors
6420! **************************************************************************************************
6421 SUBROUTINE pw_copy_c1d_c1d_gs (pw1, pw2)
6422
6423 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
6424 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw2
6425
6426 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
6427
6428 INTEGER :: handle
6429 INTEGER :: i, j, ng, ng1, ng2, ns
6430
6431 CALL timeset(routinen, handle)
6432
6433 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
6434 cpabort("Both grids must be either spherical or non-spherical!")
6435
6436 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
6437 IF (pw1%pw_grid%spherical .AND. pw2%pw_grid%spherical) THEN
6438 IF (pw_compatible(pw1%pw_grid, pw2%pw_grid)) THEN
6439 ng1 = SIZE(pw1%array)
6440 ng2 = SIZE(pw2%array)
6441 ng = min(ng1, ng2)
6442!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, pw1, pw2)
6443 pw2%array(1:ng) = pw1%array(1:ng)
6444!$OMP END PARALLEL WORKSHARE
6445 IF (ng2 > ng) THEN
6446!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(ng, ng2, pw2)
6447 pw2%array(ng + 1:ng2) = cmplx(0.0_dp, 0.0_dp, kind=dp)
6448!$OMP END PARALLEL WORKSHARE
6449 END IF
6450 ELSE
6451 cpabort("Copies between spherical grids require compatible grids!")
6452 END IF
6453 ELSE
6454 ng1 = SIZE(pw1%array)
6455 ng2 = SIZE(pw2%array)
6456 ns = 2*max(ng1, ng2)
6457
6458 IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
6459 IF (ng1 >= ng2) THEN
6460!$OMP PARALLEL DO DEFAULT(NONE) &
6461!$OMP PRIVATE(i,j) &
6462!$OMP SHARED(ng2, pw1, pw2)
6463 DO i = 1, ng2
6464 j = pw2%pw_grid%gidx(i)
6465 pw2%array(i) = pw1%array(j)
6466 END DO
6467!$OMP END PARALLEL DO
6468 ELSE
6469 CALL pw_zero(pw2)
6470!$OMP PARALLEL DO DEFAULT(NONE) &
6471!$OMP PRIVATE(i,j) &
6472!$OMP SHARED(ng1, pw1, pw2)
6473 DO i = 1, ng1
6474 j = pw2%pw_grid%gidx(i)
6475 pw2%array(j) = pw1%array(i)
6476 END DO
6477!$OMP END PARALLEL DO
6478 END IF
6479 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
6480 IF (ng1 >= ng2) THEN
6481!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng2, pw1, pw2)
6482 DO i = 1, ng2
6483 j = pw1%pw_grid%gidx(i)
6484 pw2%array(i) = pw1%array(j)
6485 END DO
6486!$OMP END PARALLEL DO
6487 ELSE
6488 CALL pw_zero(pw2)
6489!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng1, pw1, pw2)
6490 DO i = 1, ng1
6491 j = pw1%pw_grid%gidx(i)
6492 pw2%array(j) = pw1%array(i)
6493 END DO
6494!$OMP END PARALLEL DO
6495 END IF
6496 ELSE
6497 CALL pw_copy_match(pw1, pw2)
6498 END IF
6499
6500 END IF
6501
6502 ELSE
6503!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
6504 pw2%array = pw1%array
6505!$OMP END PARALLEL WORKSHARE
6506 END IF
6507
6508 CALL timestop(handle)
6509
6510 END SUBROUTINE pw_copy_c1d_c1d_gs
6511
6512! **************************************************************************************************
6513!> \brief ...
6514!> \param pw ...
6515!> \param array ...
6516! **************************************************************************************************
6517 SUBROUTINE pw_copy_to_array_c1d_c1d_gs (pw, array)
6518 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
6519 COMPLEX(KIND=dp), DIMENSION(:), INTENT(INOUT) :: array
6520
6521 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
6522
6523 INTEGER :: handle
6524
6525 CALL timeset(routinen, handle)
6526
6527!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
6528 array(:) = pw%array(:)
6529!$OMP END PARALLEL WORKSHARE
6530
6531 CALL timestop(handle)
6532 END SUBROUTINE pw_copy_to_array_c1d_c1d_gs
6533
6534! **************************************************************************************************
6535!> \brief ...
6536!> \param pw ...
6537!> \param array ...
6538! **************************************************************************************************
6539 SUBROUTINE pw_copy_from_array_c1d_c1d_gs (pw, array)
6540 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
6541 COMPLEX(KIND=dp), DIMENSION(:), INTENT(IN) :: array
6542
6543 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
6544
6545 INTEGER :: handle
6546
6547 CALL timeset(routinen, handle)
6548
6549!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
6550 pw%array = array
6551!$OMP END PARALLEL WORKSHARE
6552
6553 CALL timestop(handle)
6554 END SUBROUTINE pw_copy_from_array_c1d_c1d_gs
6555
6556! **************************************************************************************************
6557!> \brief pw2 = alpha*pw1 + beta*pw2
6558!> alpha defaults to 1, beta defaults to 1
6559!> \param pw1 ...
6560!> \param pw2 ...
6561!> \param alpha ...
6562!> \param beta ...
6563!> \param allow_noncompatible_grids ...
6564!> \par History
6565!> JGH (21-Feb-2003) : added reference grid functionality
6566!> JGH (01-Dec-2007) : rename and remove complex alpha
6567!> \author apsi
6568!> \note
6569!> Currently only summing up of respective types allowed,
6570!> in order to avoid errors
6571! **************************************************************************************************
6572 SUBROUTINE pw_axpy_c1d_c1d_gs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
6573
6574 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
6575 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw2
6576 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
6577 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
6578
6579 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
6580
6581 INTEGER :: handle
6582 LOGICAL :: my_allow_noncompatible_grids
6583 REAL(KIND=dp) :: my_alpha, my_beta
6584 INTEGER :: i, j, ng, ng1, ng2
6585
6586 CALL timeset(routinen, handle)
6587
6588 my_alpha = 1.0_dp
6589 IF (PRESENT(alpha)) my_alpha = alpha
6590
6591 my_beta = 1.0_dp
6592 IF (PRESENT(beta)) my_beta = beta
6593
6594 my_allow_noncompatible_grids = .false.
6595 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
6596
6597 IF (my_beta /= 1.0_dp) THEN
6598 IF (my_beta == 0.0_dp) THEN
6599 CALL pw_zero(pw2)
6600 ELSE
6601!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
6602 pw2%array = pw2%array*my_beta
6603!$OMP END PARALLEL WORKSHARE
6604 END IF
6605 END IF
6606
6607 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
6608
6609 IF (my_alpha == 1.0_dp) THEN
6610!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw1, pw2)
6611 pw2%array = pw2%array + pw1%array
6612!$OMP END PARALLEL WORKSHARE
6613 ELSE IF (my_alpha /= 0.0_dp) THEN
6614!$OMP PARALLEL WORKSHARE PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha)
6615 pw2%array = pw2%array + my_alpha* pw1%array
6616!$OMP END PARALLEL WORKSHARE
6617 END IF
6618
6619 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
6620
6621 ng1 = SIZE(pw1%array)
6622 ng2 = SIZE(pw2%array)
6623 ng = min(ng1, ng2)
6624
6625 IF (pw1%pw_grid%spherical) THEN
6626 IF (my_alpha == 1.0_dp) THEN
6627!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(ng, pw1, pw2)
6628 DO i = 1, ng
6629 pw2%array(i) = pw2%array(i) + pw1%array(i)
6630 END DO
6631!$OMP END PARALLEL DO
6632 ELSE IF (my_alpha /= 0.0_dp) THEN
6633!$OMP PARALLEL DO PRIVATE(i) DEFAULT(NONE) SHARED(pw2,pw1,my_alpha,ng)
6634 DO i = 1, ng
6635 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(i)
6636 END DO
6637!$OMP END PARALLEL DO
6638 END IF
6639 ELSE IF ((pw1%pw_grid%id_nr == pw2%pw_grid%reference)) THEN
6640 IF (ng1 >= ng2) THEN
6641 IF (my_alpha == 1.0_dp) THEN
6642!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
6643 DO i = 1, ng
6644 j = pw2%pw_grid%gidx(i)
6645 pw2%array(i) = pw2%array(i) + pw1%array(j)
6646 END DO
6647!$OMP END PARALLEL DO
6648 ELSE IF (my_alpha /= 0.0_dp) THEN
6649!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
6650 DO i = 1, ng
6651 j = pw2%pw_grid%gidx(i)
6652 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(j)
6653 END DO
6654!$OMP END PARALLEL DO
6655 END IF
6656 ELSE
6657 IF (my_alpha == 1.0_dp) THEN
6658!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
6659 DO i = 1, ng
6660 j = pw2%pw_grid%gidx(i)
6661 pw2%array(j) = pw2%array(j) + pw1%array(i)
6662 END DO
6663!$OMP END PARALLEL DO
6664 ELSE IF (my_alpha /= 0.0_dp) THEN
6665!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
6666 DO i = 1, ng
6667 j = pw2%pw_grid%gidx(i)
6668 pw2%array(j) = pw2%array(j) + my_alpha* pw1%array(i)
6669 END DO
6670!$OMP END PARALLEL DO
6671 END IF
6672 END IF
6673 ELSE IF ((pw2%pw_grid%id_nr == pw1%pw_grid%reference)) THEN
6674 IF (ng1 >= ng2) THEN
6675 IF (my_alpha == 1.0_dp) THEN
6676!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
6677 DO i = 1, ng
6678 j = pw1%pw_grid%gidx(i)
6679 pw2%array(i) = pw2%array(i) + pw1%array(j)
6680 END DO
6681!$OMP END PARALLEL DO
6682 ELSE IF (my_alpha /= 0.0_dp) THEN
6683!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
6684 DO i = 1, ng
6685 j = pw1%pw_grid%gidx(i)
6686 pw2%array(i) = pw2%array(i) + my_alpha* pw1%array(j)
6687 END DO
6688!$OMP END PARALLEL DO
6689 END IF
6690 ELSE
6691 IF (my_alpha == 1.0_dp) THEN
6692!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(ng, pw1, pw2)
6693 DO i = 1, ng
6694 j = pw1%pw_grid%gidx(i)
6695 pw2%array(j) = pw2%array(j) + pw1%array(i)
6696 END DO
6697!$OMP END PARALLEL DO
6698 ELSE IF (my_alpha /= 0.0_dp) THEN
6699!$OMP PARALLEL DO PRIVATE(i,j) DEFAULT(NONE) SHARED(my_alpha, ng, pw1, pw2)
6700 DO i = 1, ng
6701 j = pw1%pw_grid%gidx(i)
6702 pw2%array(j) = pw2%array(j) + my_alpha* pw1%array(i)
6703 END DO
6704!$OMP END PARALLEL DO
6705 END IF
6706 END IF
6707 ELSE
6708 cpabort("Grids not compatible")
6709 END IF
6710
6711 ELSE
6712
6713 cpabort("Grids not compatible")
6714
6715 END IF
6716
6717 CALL timestop(handle)
6718
6719 END SUBROUTINE pw_axpy_c1d_c1d_gs
6720
6721! **************************************************************************************************
6722!> \brief pw_out = pw_out + alpha * pw1 * pw2
6723!> alpha defaults to 1
6724!> \param pw_out ...
6725!> \param pw1 ...
6726!> \param pw2 ...
6727!> \param alpha ...
6728!> \author JGH
6729! **************************************************************************************************
6730 SUBROUTINE pw_multiply_c1d_c1d_gs (pw_out, pw1, pw2, alpha)
6731
6732 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw_out
6733 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
6734 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw2
6735 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
6736
6737 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
6738
6739 INTEGER :: handle
6740 REAL(KIND=dp) :: my_alpha
6741
6742 CALL timeset(routinen, handle)
6743
6744 my_alpha = 1.0_dp
6745 IF (PRESENT(alpha)) my_alpha = alpha
6746
6747 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
6748 cpabort("pw_multiply not implemented for non-identical grids!")
6749
6750#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
6751 IF (my_alpha == 1.0_dp) THEN
6752!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
6753 pw_out%array = pw_out%array + pw1%array* pw2%array
6754!$OMP END PARALLEL WORKSHARE
6755 ELSE
6756!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
6757 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
6758!$OMP END PARALLEL WORKSHARE
6759 END IF
6760#else
6761 IF (my_alpha == 1.0_dp) THEN
6762 pw_out%array = pw_out%array + pw1%array* pw2%array
6763 ELSE
6764 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
6765 END IF
6766#endif
6767
6768 CALL timestop(handle)
6769
6770 END SUBROUTINE pw_multiply_c1d_c1d_gs
6771
6772! **************************************************************************************************
6773!> \brief ...
6774!> \param pw1 ...
6775!> \param pw2 ...
6776! **************************************************************************************************
6777 SUBROUTINE pw_multiply_with_c1d_c1d_gs (pw1, pw2)
6778 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw1
6779 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw2
6780
6781 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
6782
6783 INTEGER :: handle
6784
6785 CALL timeset(routinen, handle)
6786
6787 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
6788 cpabort("Incompatible grids!")
6789
6790!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
6791 pw1%array = pw1%array* pw2%array
6792!$OMP END PARALLEL WORKSHARE
6793
6794 CALL timestop(handle)
6795
6796 END SUBROUTINE pw_multiply_with_c1d_c1d_gs
6797
6798! **************************************************************************************************
6799!> \brief Calculate integral over unit cell for functions in plane wave basis
6800!> only returns the real part of it ......
6801!> \param pw1 ...
6802!> \param pw2 ...
6803!> \param sumtype ...
6804!> \param just_sum ...
6805!> \param local_only ...
6806!> \return ...
6807!> \par History
6808!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
6809!> \author apsi
6810! **************************************************************************************************
6811 FUNCTION pw_integral_ab_c1d_c1d_gs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
6812
6813 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
6814 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw2
6815 INTEGER, INTENT(IN), OPTIONAL :: sumtype
6816 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
6817 REAL(kind=dp) :: integral_value
6818
6819 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_c1d_c1d_gs'
6820
6821 INTEGER :: handle, loc_sumtype
6822 LOGICAL :: my_just_sum, my_local_only
6823
6824 CALL timeset(routinen, handle)
6825
6826 loc_sumtype = do_accurate_sum
6827 IF (PRESENT(sumtype)) loc_sumtype = sumtype
6828
6829 my_local_only = .false.
6830 IF (PRESENT(local_only)) my_local_only = local_only
6831
6832 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
6833 cpabort("Grids incompatible")
6834 END IF
6835
6836 my_just_sum = .false.
6837 IF (PRESENT(just_sum)) my_just_sum = just_sum
6838
6839 ! do standard sum
6840 IF (loc_sumtype == do_standard_sum) THEN
6841
6842 ! Do standard sum
6843
6844 integral_value = sum(real(conjg(pw1%array) &
6845 *pw2%array, kind=dp)) !? complex bit
6846
6847 ELSE
6848
6849 ! Do accurate sum
6850 integral_value = accurate_sum(real(conjg(pw1%array)*pw2%array, kind=dp))
6851
6852 END IF
6853
6854 ! Apply reciprocal multiplicity before scaling the integral;
6855 ! the unpaired G=0 term must receive the same volume factor.
6856 IF (pw1%pw_grid%grid_span == halfspace) THEN
6857 integral_value = 2.0_dp*integral_value
6858 IF (pw1%pw_grid%have_g0) integral_value = integral_value - &
6859 REAL(conjg(pw1%array(1))*pw2%array(1), kind=dp)
6860 END IF
6861
6862 IF (.NOT. my_just_sum) THEN
6863 integral_value = integral_value*pw1%pw_grid%vol
6864 END IF
6865
6866 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
6867 CALL pw1%pw_grid%para%group%sum(integral_value)
6868
6869 CALL timestop(handle)
6870
6871 END FUNCTION pw_integral_ab_c1d_c1d_gs
6872
6873! **************************************************************************************************
6874!> \brief ...
6875!> \param pw1 ...
6876!> \param pw2 ...
6877!> \return ...
6878! **************************************************************************************************
6879 FUNCTION pw_integral_a2b_c1d_c1d (pw1, pw2) RESULT(integral_value)
6880
6881 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
6882 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw2
6883 REAL(kind=dp) :: integral_value
6884
6885 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_a2b'
6886
6887 INTEGER :: handle
6888
6889 CALL timeset(routinen, handle)
6890
6891 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
6892 cpabort("Grids incompatible")
6893 END IF
6894
6895 integral_value = accurate_sum(real(conjg(pw1%array)*pw2%array, kind=dp)*pw1%pw_grid%gsq)
6896 IF (pw1%pw_grid%grid_span == halfspace) THEN
6897 integral_value = 2.0_dp*integral_value
6898 END IF
6899
6900 integral_value = integral_value*pw1%pw_grid%vol
6901
6902 IF (pw1%pw_grid%para%mode == pw_mode_distributed) &
6903 CALL pw1%pw_grid%para%group%sum(integral_value)
6904 CALL timestop(handle)
6905
6906 END FUNCTION pw_integral_a2b_c1d_c1d
6907! **************************************************************************************************
6908!> \brief copy a pw type variable
6909!> \param pw1 ...
6910!> \param pw2 ...
6911!> \par History
6912!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
6913!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
6914!> JGH (21-Feb-2003) : Code for generalized reference grids
6915!> \author apsi
6916!> \note
6917!> Currently only copying of respective types allowed,
6918!> in order to avoid errors
6919! **************************************************************************************************
6920 SUBROUTINE pw_copy_c3d_r3d_rs (pw1, pw2)
6921
6922 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw1
6923 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw2
6924
6925 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
6926
6927 INTEGER :: handle
6928
6929 CALL timeset(routinen, handle)
6930
6931 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
6932 cpabort("Both grids must be either spherical or non-spherical!")
6933 IF (pw1%pw_grid%spherical) &
6934 cpabort("Spherical grids only exist in reciprocal space!")
6935
6936 IF (any(shape(pw2%array) /= shape(pw1%array))) &
6937 cpabort("3D grids must be compatible!")
6938 IF (pw1%pw_grid%spherical) &
6939 cpabort("3D grids must not be spherical!")
6940!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
6941 pw2%array(:, :, :) = real(pw1%array(:, :, :), kind=dp)
6942!$OMP END PARALLEL WORKSHARE
6943
6944 CALL timestop(handle)
6945
6946 END SUBROUTINE pw_copy_c3d_r3d_rs
6947
6948! **************************************************************************************************
6949!> \brief ...
6950!> \param pw ...
6951!> \param array ...
6952! **************************************************************************************************
6953 SUBROUTINE pw_copy_to_array_c3d_r3d_rs (pw, array)
6954 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw
6955 REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: array
6956
6957 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
6958
6959 INTEGER :: handle
6960
6961 CALL timeset(routinen, handle)
6962
6963!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
6964 array(:, :, :) = real(pw%array(:, :, :), kind=dp)
6965!$OMP END PARALLEL WORKSHARE
6966
6967 CALL timestop(handle)
6968 END SUBROUTINE pw_copy_to_array_c3d_r3d_rs
6969
6970! **************************************************************************************************
6971!> \brief ...
6972!> \param pw ...
6973!> \param array ...
6974! **************************************************************************************************
6975 SUBROUTINE pw_copy_from_array_c3d_r3d_rs (pw, array)
6976 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw
6977 REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: array
6978
6979 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
6980
6981 INTEGER :: handle
6982
6983 CALL timeset(routinen, handle)
6984
6985!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
6986 pw%array = cmplx(array, 0.0_dp, kind=dp)
6987!$OMP END PARALLEL WORKSHARE
6988
6989 CALL timestop(handle)
6990 END SUBROUTINE pw_copy_from_array_c3d_r3d_rs
6991
6992! **************************************************************************************************
6993!> \brief pw2 = alpha*pw1 + beta*pw2
6994!> alpha defaults to 1, beta defaults to 1
6995!> \param pw1 ...
6996!> \param pw2 ...
6997!> \param alpha ...
6998!> \param beta ...
6999!> \param allow_noncompatible_grids ...
7000!> \par History
7001!> JGH (21-Feb-2003) : added reference grid functionality
7002!> JGH (01-Dec-2007) : rename and remove complex alpha
7003!> \author apsi
7004!> \note
7005!> Currently only summing up of respective types allowed,
7006!> in order to avoid errors
7007! **************************************************************************************************
7008 SUBROUTINE pw_axpy_c3d_r3d_rs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
7009
7010 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw1
7011 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw2
7012 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
7013 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
7014
7015 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
7016
7017 INTEGER :: handle
7018 LOGICAL :: my_allow_noncompatible_grids
7019 REAL(KIND=dp) :: my_alpha, my_beta
7020
7021 CALL timeset(routinen, handle)
7022
7023 my_alpha = 1.0_dp
7024 IF (PRESENT(alpha)) my_alpha = alpha
7025
7026 my_beta = 1.0_dp
7027 IF (PRESENT(beta)) my_beta = beta
7028
7029 my_allow_noncompatible_grids = .false.
7030 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
7031
7032 IF (my_beta /= 1.0_dp) THEN
7033 IF (my_beta == 0.0_dp) THEN
7034 CALL pw_zero(pw2)
7035 ELSE
7036!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
7037 pw2%array = pw2%array*my_beta
7038!$OMP END PARALLEL WORKSHARE
7039 END IF
7040 END IF
7041
7042 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
7043 IF (my_alpha == 1.0_dp) THEN
7044!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2)
7045 pw2%array = pw2%array + real(pw1%array, kind=dp)
7046!$OMP END PARALLEL WORKSHARE
7047 ELSE IF (my_alpha /= 0.0_dp) THEN
7048!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2, my_alpha)
7049 pw2%array = pw2%array + my_alpha* real(pw1%array, kind=dp)
7050!$OMP END PARALLEL WORKSHARE
7051 END IF
7052
7053 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
7054
7055 IF (any(shape(pw1%array) /= shape(pw2%array))) &
7056 cpabort("Noncommensurate grids not implemented for 3D grids!")
7057
7058 IF (my_alpha == 1.0_dp) THEN
7059!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
7060 pw2%array = pw2%array + real(pw1%array, kind=dp)
7061!$OMP END PARALLEL WORKSHARE
7062 ELSE
7063!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2,my_alpha)
7064 pw2%array = pw2%array + my_alpha* real(pw1%array, kind=dp)
7065!$OMP END PARALLEL WORKSHARE
7066 END IF
7067
7068 ELSE
7069
7070 cpabort("Grids not compatible")
7071
7072 END IF
7073
7074 CALL timestop(handle)
7075
7076 END SUBROUTINE pw_axpy_c3d_r3d_rs
7077
7078! **************************************************************************************************
7079!> \brief pw_out = pw_out + alpha * pw1 * pw2
7080!> alpha defaults to 1
7081!> \param pw_out ...
7082!> \param pw1 ...
7083!> \param pw2 ...
7084!> \param alpha ...
7085!> \author JGH
7086! **************************************************************************************************
7087 SUBROUTINE pw_multiply_c3d_r3d_rs (pw_out, pw1, pw2, alpha)
7088
7089 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw_out
7090 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw1
7091 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw2
7092 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
7093
7094 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
7095
7096 INTEGER :: handle
7097 REAL(KIND=dp) :: my_alpha
7098
7099 CALL timeset(routinen, handle)
7100
7101 my_alpha = 1.0_dp
7102 IF (PRESENT(alpha)) my_alpha = alpha
7103
7104 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
7105 cpabort("pw_multiply not implemented for non-identical grids!")
7106
7107#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
7108 IF (my_alpha == 1.0_dp) THEN
7109!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
7110 pw_out%array = pw_out%array + pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
7111!$OMP END PARALLEL WORKSHARE
7112 ELSE
7113!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
7114 pw_out%array = pw_out%array + my_alpha*pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
7115!$OMP END PARALLEL WORKSHARE
7116 END IF
7117#else
7118 IF (my_alpha == 1.0_dp) THEN
7119 pw_out%array = pw_out%array + pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
7120 ELSE
7121 pw_out%array = pw_out%array + my_alpha*pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
7122 END IF
7123#endif
7124
7125 CALL timestop(handle)
7126
7127 END SUBROUTINE pw_multiply_c3d_r3d_rs
7128
7129! **************************************************************************************************
7130!> \brief ...
7131!> \param pw1 ...
7132!> \param pw2 ...
7133! **************************************************************************************************
7134 SUBROUTINE pw_multiply_with_c3d_r3d_rs (pw1, pw2)
7135 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw1
7136 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw2
7137
7138 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
7139
7140 INTEGER :: handle
7141
7142 CALL timeset(routinen, handle)
7143
7144 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
7145 cpabort("Incompatible grids!")
7146
7147!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
7148 pw1%array = pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
7149!$OMP END PARALLEL WORKSHARE
7150
7151 CALL timestop(handle)
7152
7153 END SUBROUTINE pw_multiply_with_c3d_r3d_rs
7154
7155! **************************************************************************************************
7156!> \brief Calculate integral over unit cell for functions in plane wave basis
7157!> only returns the real part of it ......
7158!> \param pw1 ...
7159!> \param pw2 ...
7160!> \param sumtype ...
7161!> \param just_sum ...
7162!> \param local_only ...
7163!> \return ...
7164!> \par History
7165!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
7166!> \author apsi
7167! **************************************************************************************************
7168 FUNCTION pw_integral_ab_c3d_r3d_rs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
7169
7170 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw1
7171 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw2
7172 INTEGER, INTENT(IN), OPTIONAL :: sumtype
7173 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
7174 REAL(kind=dp) :: integral_value
7175
7176 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_c3d_r3d_rs'
7177
7178 INTEGER :: handle, loc_sumtype
7179 LOGICAL :: my_just_sum, my_local_only
7180
7181 CALL timeset(routinen, handle)
7182
7183 loc_sumtype = do_accurate_sum
7184 IF (PRESENT(sumtype)) loc_sumtype = sumtype
7185
7186 my_local_only = .false.
7187 IF (PRESENT(local_only)) my_local_only = local_only
7188
7189 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
7190 cpabort("Grids incompatible")
7191 END IF
7192
7193 my_just_sum = .false.
7194 IF (PRESENT(just_sum)) my_just_sum = just_sum
7195
7196 ! do standard sum
7197 IF (loc_sumtype == do_standard_sum) THEN
7198
7199 ! Do standard sum
7200
7201 integral_value = sum(real(pw1%array, kind=dp)*pw2%array) !? complex bit
7202
7203 ELSE
7204
7205 ! Do accurate sum
7206 integral_value = accurate_sum(real(pw1%array, kind=dp)*pw2%array) !? complex bit
7207
7208 END IF
7209
7210
7211 IF (.NOT. my_just_sum) THEN
7212 integral_value = integral_value*pw1%pw_grid%dvol
7213 END IF
7214
7215 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
7216 CALL pw1%pw_grid%para%group%sum(integral_value)
7217
7218 CALL timestop(handle)
7219
7220 END FUNCTION pw_integral_ab_c3d_r3d_rs
7221! **************************************************************************************************
7222!> \brief copy a pw type variable
7223!> \param pw1 ...
7224!> \param pw2 ...
7225!> \par History
7226!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
7227!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
7228!> JGH (21-Feb-2003) : Code for generalized reference grids
7229!> \author apsi
7230!> \note
7231!> Currently only copying of respective types allowed,
7232!> in order to avoid errors
7233! **************************************************************************************************
7234 SUBROUTINE pw_copy_c3d_r3d_gs (pw1, pw2)
7235
7236 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
7237 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw2
7238
7239 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
7240
7241 INTEGER :: handle
7242
7243 CALL timeset(routinen, handle)
7244
7245 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
7246 cpabort("Both grids must be either spherical or non-spherical!")
7247
7248 IF (any(shape(pw2%array) /= shape(pw1%array))) &
7249 cpabort("3D grids must be compatible!")
7250 IF (pw1%pw_grid%spherical) &
7251 cpabort("3D grids must not be spherical!")
7252!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
7253 pw2%array(:, :, :) = real(pw1%array(:, :, :), kind=dp)
7254!$OMP END PARALLEL WORKSHARE
7255
7256 CALL timestop(handle)
7257
7258 END SUBROUTINE pw_copy_c3d_r3d_gs
7259
7260! **************************************************************************************************
7261!> \brief ...
7262!> \param pw ...
7263!> \param array ...
7264! **************************************************************************************************
7265 SUBROUTINE pw_copy_to_array_c3d_r3d_gs (pw, array)
7266 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw
7267 REAL(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: array
7268
7269 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
7270
7271 INTEGER :: handle
7272
7273 CALL timeset(routinen, handle)
7274
7275!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
7276 array(:, :, :) = real(pw%array(:, :, :), kind=dp)
7277!$OMP END PARALLEL WORKSHARE
7278
7279 CALL timestop(handle)
7280 END SUBROUTINE pw_copy_to_array_c3d_r3d_gs
7281
7282! **************************************************************************************************
7283!> \brief ...
7284!> \param pw ...
7285!> \param array ...
7286! **************************************************************************************************
7287 SUBROUTINE pw_copy_from_array_c3d_r3d_gs (pw, array)
7288 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw
7289 REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: array
7290
7291 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
7292
7293 INTEGER :: handle
7294
7295 CALL timeset(routinen, handle)
7296
7297!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
7298 pw%array = cmplx(array, 0.0_dp, kind=dp)
7299!$OMP END PARALLEL WORKSHARE
7300
7301 CALL timestop(handle)
7302 END SUBROUTINE pw_copy_from_array_c3d_r3d_gs
7303
7304! **************************************************************************************************
7305!> \brief pw2 = alpha*pw1 + beta*pw2
7306!> alpha defaults to 1, beta defaults to 1
7307!> \param pw1 ...
7308!> \param pw2 ...
7309!> \param alpha ...
7310!> \param beta ...
7311!> \param allow_noncompatible_grids ...
7312!> \par History
7313!> JGH (21-Feb-2003) : added reference grid functionality
7314!> JGH (01-Dec-2007) : rename and remove complex alpha
7315!> \author apsi
7316!> \note
7317!> Currently only summing up of respective types allowed,
7318!> in order to avoid errors
7319! **************************************************************************************************
7320 SUBROUTINE pw_axpy_c3d_r3d_gs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
7321
7322 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
7323 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw2
7324 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
7325 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
7326
7327 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
7328
7329 INTEGER :: handle
7330 LOGICAL :: my_allow_noncompatible_grids
7331 REAL(KIND=dp) :: my_alpha, my_beta
7332
7333 CALL timeset(routinen, handle)
7334
7335 my_alpha = 1.0_dp
7336 IF (PRESENT(alpha)) my_alpha = alpha
7337
7338 my_beta = 1.0_dp
7339 IF (PRESENT(beta)) my_beta = beta
7340
7341 my_allow_noncompatible_grids = .false.
7342 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
7343
7344 IF (my_beta /= 1.0_dp) THEN
7345 IF (my_beta == 0.0_dp) THEN
7346 CALL pw_zero(pw2)
7347 ELSE
7348!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
7349 pw2%array = pw2%array*my_beta
7350!$OMP END PARALLEL WORKSHARE
7351 END IF
7352 END IF
7353
7354 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
7355 IF (my_alpha == 1.0_dp) THEN
7356!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2)
7357 pw2%array = pw2%array + real(pw1%array, kind=dp)
7358!$OMP END PARALLEL WORKSHARE
7359 ELSE IF (my_alpha /= 0.0_dp) THEN
7360!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2, my_alpha)
7361 pw2%array = pw2%array + my_alpha* real(pw1%array, kind=dp)
7362!$OMP END PARALLEL WORKSHARE
7363 END IF
7364
7365 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
7366
7367 IF (any(shape(pw1%array) /= shape(pw2%array))) &
7368 cpabort("Noncommensurate grids not implemented for 3D grids!")
7369
7370 IF (my_alpha == 1.0_dp) THEN
7371!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
7372 pw2%array = pw2%array + real(pw1%array, kind=dp)
7373!$OMP END PARALLEL WORKSHARE
7374 ELSE
7375!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2,my_alpha)
7376 pw2%array = pw2%array + my_alpha* real(pw1%array, kind=dp)
7377!$OMP END PARALLEL WORKSHARE
7378 END IF
7379
7380 ELSE
7381
7382 cpabort("Grids not compatible")
7383
7384 END IF
7385
7386 CALL timestop(handle)
7387
7388 END SUBROUTINE pw_axpy_c3d_r3d_gs
7389
7390! **************************************************************************************************
7391!> \brief pw_out = pw_out + alpha * pw1 * pw2
7392!> alpha defaults to 1
7393!> \param pw_out ...
7394!> \param pw1 ...
7395!> \param pw2 ...
7396!> \param alpha ...
7397!> \author JGH
7398! **************************************************************************************************
7399 SUBROUTINE pw_multiply_c3d_r3d_gs (pw_out, pw1, pw2, alpha)
7400
7401 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw_out
7402 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
7403 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw2
7404 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
7405
7406 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
7407
7408 INTEGER :: handle
7409 REAL(KIND=dp) :: my_alpha
7410
7411 CALL timeset(routinen, handle)
7412
7413 my_alpha = 1.0_dp
7414 IF (PRESENT(alpha)) my_alpha = alpha
7415
7416 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
7417 cpabort("pw_multiply not implemented for non-identical grids!")
7418
7419#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
7420 IF (my_alpha == 1.0_dp) THEN
7421!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
7422 pw_out%array = pw_out%array + pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
7423!$OMP END PARALLEL WORKSHARE
7424 ELSE
7425!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
7426 pw_out%array = pw_out%array + my_alpha*pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
7427!$OMP END PARALLEL WORKSHARE
7428 END IF
7429#else
7430 IF (my_alpha == 1.0_dp) THEN
7431 pw_out%array = pw_out%array + pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
7432 ELSE
7433 pw_out%array = pw_out%array + my_alpha*pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
7434 END IF
7435#endif
7436
7437 CALL timestop(handle)
7438
7439 END SUBROUTINE pw_multiply_c3d_r3d_gs
7440
7441! **************************************************************************************************
7442!> \brief ...
7443!> \param pw1 ...
7444!> \param pw2 ...
7445! **************************************************************************************************
7446 SUBROUTINE pw_multiply_with_c3d_r3d_gs (pw1, pw2)
7447 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw1
7448 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw2
7449
7450 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
7451
7452 INTEGER :: handle
7453
7454 CALL timeset(routinen, handle)
7455
7456 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
7457 cpabort("Incompatible grids!")
7458
7459!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
7460 pw1%array = pw1%array* cmplx(pw2%array, 0.0_dp, kind=dp)
7461!$OMP END PARALLEL WORKSHARE
7462
7463 CALL timestop(handle)
7464
7465 END SUBROUTINE pw_multiply_with_c3d_r3d_gs
7466
7467! **************************************************************************************************
7468!> \brief Calculate integral over unit cell for functions in plane wave basis
7469!> only returns the real part of it ......
7470!> \param pw1 ...
7471!> \param pw2 ...
7472!> \param sumtype ...
7473!> \param just_sum ...
7474!> \param local_only ...
7475!> \return ...
7476!> \par History
7477!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
7478!> \author apsi
7479! **************************************************************************************************
7480 FUNCTION pw_integral_ab_c3d_r3d_gs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
7481
7482 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
7483 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw2
7484 INTEGER, INTENT(IN), OPTIONAL :: sumtype
7485 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
7486 REAL(kind=dp) :: integral_value
7487
7488 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_c3d_r3d_gs'
7489
7490 INTEGER :: handle, loc_sumtype
7491 LOGICAL :: my_just_sum, my_local_only
7492
7493 CALL timeset(routinen, handle)
7494
7495 loc_sumtype = do_accurate_sum
7496 IF (PRESENT(sumtype)) loc_sumtype = sumtype
7497
7498 my_local_only = .false.
7499 IF (PRESENT(local_only)) my_local_only = local_only
7500
7501 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
7502 cpabort("Grids incompatible")
7503 END IF
7504
7505 my_just_sum = .false.
7506 IF (PRESENT(just_sum)) my_just_sum = just_sum
7507
7508 ! do standard sum
7509 IF (loc_sumtype == do_standard_sum) THEN
7510
7511 ! Do standard sum
7512
7513 integral_value = sum(real(pw1%array, kind=dp)*pw2%array) !? complex bit
7514
7515 ELSE
7516
7517 ! Do accurate sum
7518 integral_value = accurate_sum(real(pw1%array, kind=dp)*pw2%array) !? complex bit
7519
7520 END IF
7521
7522
7523 IF (.NOT. my_just_sum) THEN
7524 integral_value = integral_value*pw1%pw_grid%vol
7525 END IF
7526
7527 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
7528 CALL pw1%pw_grid%para%group%sum(integral_value)
7529
7530 CALL timestop(handle)
7531
7532 END FUNCTION pw_integral_ab_c3d_r3d_gs
7533
7534! **************************************************************************************************
7535!> \brief copy a pw type variable
7536!> \param pw1 ...
7537!> \param pw2 ...
7538!> \par History
7539!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
7540!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
7541!> JGH (21-Feb-2003) : Code for generalized reference grids
7542!> \author apsi
7543!> \note
7544!> Currently only copying of respective types allowed,
7545!> in order to avoid errors
7546! **************************************************************************************************
7547 SUBROUTINE pw_copy_c3d_c3d_rs (pw1, pw2)
7548
7549 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw1
7550 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw2
7551
7552 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
7553
7554 INTEGER :: handle
7555
7556 CALL timeset(routinen, handle)
7557
7558 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
7559 cpabort("Both grids must be either spherical or non-spherical!")
7560 IF (pw1%pw_grid%spherical) &
7561 cpabort("Spherical grids only exist in reciprocal space!")
7562
7563 IF (any(shape(pw2%array) /= shape(pw1%array))) &
7564 cpabort("3D grids must be compatible!")
7565 IF (pw1%pw_grid%spherical) &
7566 cpabort("3D grids must not be spherical!")
7567!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
7568 pw2%array(:, :, :) = pw1%array(:, :, :)
7569!$OMP END PARALLEL WORKSHARE
7570
7571 CALL timestop(handle)
7572
7573 END SUBROUTINE pw_copy_c3d_c3d_rs
7574
7575! **************************************************************************************************
7576!> \brief ...
7577!> \param pw ...
7578!> \param array ...
7579! **************************************************************************************************
7580 SUBROUTINE pw_copy_to_array_c3d_c3d_rs (pw, array)
7581 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw
7582 COMPLEX(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: array
7583
7584 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
7585
7586 INTEGER :: handle
7587
7588 CALL timeset(routinen, handle)
7589
7590!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
7591 array(:, :, :) = pw%array(:, :, :)
7592!$OMP END PARALLEL WORKSHARE
7593
7594 CALL timestop(handle)
7595 END SUBROUTINE pw_copy_to_array_c3d_c3d_rs
7596
7597! **************************************************************************************************
7598!> \brief ...
7599!> \param pw ...
7600!> \param array ...
7601! **************************************************************************************************
7602 SUBROUTINE pw_copy_from_array_c3d_c3d_rs (pw, array)
7603 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw
7604 COMPLEX(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: array
7605
7606 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
7607
7608 INTEGER :: handle
7609
7610 CALL timeset(routinen, handle)
7611
7612!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
7613 pw%array = array
7614!$OMP END PARALLEL WORKSHARE
7615
7616 CALL timestop(handle)
7617 END SUBROUTINE pw_copy_from_array_c3d_c3d_rs
7618
7619! **************************************************************************************************
7620!> \brief pw2 = alpha*pw1 + beta*pw2
7621!> alpha defaults to 1, beta defaults to 1
7622!> \param pw1 ...
7623!> \param pw2 ...
7624!> \param alpha ...
7625!> \param beta ...
7626!> \param allow_noncompatible_grids ...
7627!> \par History
7628!> JGH (21-Feb-2003) : added reference grid functionality
7629!> JGH (01-Dec-2007) : rename and remove complex alpha
7630!> \author apsi
7631!> \note
7632!> Currently only summing up of respective types allowed,
7633!> in order to avoid errors
7634! **************************************************************************************************
7635 SUBROUTINE pw_axpy_c3d_c3d_rs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
7636
7637 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw1
7638 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw2
7639 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
7640 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
7641
7642 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
7643
7644 INTEGER :: handle
7645 LOGICAL :: my_allow_noncompatible_grids
7646 REAL(KIND=dp) :: my_alpha, my_beta
7647
7648 CALL timeset(routinen, handle)
7649
7650 my_alpha = 1.0_dp
7651 IF (PRESENT(alpha)) my_alpha = alpha
7652
7653 my_beta = 1.0_dp
7654 IF (PRESENT(beta)) my_beta = beta
7655
7656 my_allow_noncompatible_grids = .false.
7657 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
7658
7659 IF (my_beta /= 1.0_dp) THEN
7660 IF (my_beta == 0.0_dp) THEN
7661 CALL pw_zero(pw2)
7662 ELSE
7663!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
7664 pw2%array = pw2%array*my_beta
7665!$OMP END PARALLEL WORKSHARE
7666 END IF
7667 END IF
7668
7669 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
7670 IF (my_alpha == 1.0_dp) THEN
7671!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2)
7672 pw2%array = pw2%array + pw1%array
7673!$OMP END PARALLEL WORKSHARE
7674 ELSE IF (my_alpha /= 0.0_dp) THEN
7675!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2, my_alpha)
7676 pw2%array = pw2%array + my_alpha* pw1%array
7677!$OMP END PARALLEL WORKSHARE
7678 END IF
7679
7680 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
7681
7682 IF (any(shape(pw1%array) /= shape(pw2%array))) &
7683 cpabort("Noncommensurate grids not implemented for 3D grids!")
7684
7685 IF (my_alpha == 1.0_dp) THEN
7686!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
7687 pw2%array = pw2%array + pw1%array
7688!$OMP END PARALLEL WORKSHARE
7689 ELSE
7690!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2,my_alpha)
7691 pw2%array = pw2%array + my_alpha* pw1%array
7692!$OMP END PARALLEL WORKSHARE
7693 END IF
7694
7695 ELSE
7696
7697 cpabort("Grids not compatible")
7698
7699 END IF
7700
7701 CALL timestop(handle)
7702
7703 END SUBROUTINE pw_axpy_c3d_c3d_rs
7704
7705! **************************************************************************************************
7706!> \brief pw_out = pw_out + alpha * pw1 * pw2
7707!> alpha defaults to 1
7708!> \param pw_out ...
7709!> \param pw1 ...
7710!> \param pw2 ...
7711!> \param alpha ...
7712!> \author JGH
7713! **************************************************************************************************
7714 SUBROUTINE pw_multiply_c3d_c3d_rs (pw_out, pw1, pw2, alpha)
7715
7716 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw_out
7717 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw1
7718 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw2
7719 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
7720
7721 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
7722
7723 INTEGER :: handle
7724 REAL(KIND=dp) :: my_alpha
7725
7726 CALL timeset(routinen, handle)
7727
7728 my_alpha = 1.0_dp
7729 IF (PRESENT(alpha)) my_alpha = alpha
7730
7731 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
7732 cpabort("pw_multiply not implemented for non-identical grids!")
7733
7734#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
7735 IF (my_alpha == 1.0_dp) THEN
7736!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
7737 pw_out%array = pw_out%array + pw1%array* pw2%array
7738!$OMP END PARALLEL WORKSHARE
7739 ELSE
7740!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
7741 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
7742!$OMP END PARALLEL WORKSHARE
7743 END IF
7744#else
7745 IF (my_alpha == 1.0_dp) THEN
7746 pw_out%array = pw_out%array + pw1%array* pw2%array
7747 ELSE
7748 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
7749 END IF
7750#endif
7751
7752 CALL timestop(handle)
7753
7754 END SUBROUTINE pw_multiply_c3d_c3d_rs
7755
7756! **************************************************************************************************
7757!> \brief ...
7758!> \param pw1 ...
7759!> \param pw2 ...
7760! **************************************************************************************************
7761 SUBROUTINE pw_multiply_with_c3d_c3d_rs (pw1, pw2)
7762 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw1
7763 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw2
7764
7765 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
7766
7767 INTEGER :: handle
7768
7769 CALL timeset(routinen, handle)
7770
7771 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
7772 cpabort("Incompatible grids!")
7773
7774!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
7775 pw1%array = pw1%array* pw2%array
7776!$OMP END PARALLEL WORKSHARE
7777
7778 CALL timestop(handle)
7779
7780 END SUBROUTINE pw_multiply_with_c3d_c3d_rs
7781
7782! **************************************************************************************************
7783!> \brief Calculate integral over unit cell for functions in plane wave basis
7784!> only returns the real part of it ......
7785!> \param pw1 ...
7786!> \param pw2 ...
7787!> \param sumtype ...
7788!> \param just_sum ...
7789!> \param local_only ...
7790!> \return ...
7791!> \par History
7792!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
7793!> \author apsi
7794! **************************************************************************************************
7795 FUNCTION pw_integral_ab_c3d_c3d_rs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
7796
7797 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw1
7798 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw2
7799 INTEGER, INTENT(IN), OPTIONAL :: sumtype
7800 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
7801 REAL(kind=dp) :: integral_value
7802
7803 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_c3d_c3d_rs'
7804
7805 INTEGER :: handle, loc_sumtype
7806 LOGICAL :: my_just_sum, my_local_only
7807
7808 CALL timeset(routinen, handle)
7809
7810 loc_sumtype = do_accurate_sum
7811 IF (PRESENT(sumtype)) loc_sumtype = sumtype
7812
7813 my_local_only = .false.
7814 IF (PRESENT(local_only)) my_local_only = local_only
7815
7816 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
7817 cpabort("Grids incompatible")
7818 END IF
7819
7820 my_just_sum = .false.
7821 IF (PRESENT(just_sum)) my_just_sum = just_sum
7822
7823 ! do standard sum
7824 IF (loc_sumtype == do_standard_sum) THEN
7825
7826 ! Do standard sum
7827
7828 integral_value = sum(real(conjg(pw1%array) &
7829 *pw2%array, kind=dp)) !? complex bit
7830
7831 ELSE
7832
7833 ! Do accurate sum
7834 integral_value = accurate_sum(real(conjg(pw1%array)*pw2%array, kind=dp))
7835
7836 END IF
7837
7838
7839 IF (.NOT. my_just_sum) THEN
7840 integral_value = integral_value*pw1%pw_grid%dvol
7841 END IF
7842
7843 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
7844 CALL pw1%pw_grid%para%group%sum(integral_value)
7845
7846 CALL timestop(handle)
7847
7848 END FUNCTION pw_integral_ab_c3d_c3d_rs
7849! **************************************************************************************************
7850!> \brief copy a pw type variable
7851!> \param pw1 ...
7852!> \param pw2 ...
7853!> \par History
7854!> JGH (7-Mar-2001) : check for pw_grid %id_nr, allow copy if
7855!> in_use == COMPLEXDATA1D and in_space == RECIPROCALSPACE
7856!> JGH (21-Feb-2003) : Code for generalized reference grids
7857!> \author apsi
7858!> \note
7859!> Currently only copying of respective types allowed,
7860!> in order to avoid errors
7861! **************************************************************************************************
7862 SUBROUTINE pw_copy_c3d_c3d_gs (pw1, pw2)
7863
7864 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
7865 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw2
7866
7867 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy'
7868
7869 INTEGER :: handle
7870
7871 CALL timeset(routinen, handle)
7872
7873 IF (pw1%pw_grid%spherical .neqv. pw2%pw_grid%spherical) &
7874 cpabort("Both grids must be either spherical or non-spherical!")
7875
7876 IF (any(shape(pw2%array) /= shape(pw1%array))) &
7877 cpabort("3D grids must be compatible!")
7878 IF (pw1%pw_grid%spherical) &
7879 cpabort("3D grids must not be spherical!")
7880!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
7881 pw2%array(:, :, :) = pw1%array(:, :, :)
7882!$OMP END PARALLEL WORKSHARE
7883
7884 CALL timestop(handle)
7885
7886 END SUBROUTINE pw_copy_c3d_c3d_gs
7887
7888! **************************************************************************************************
7889!> \brief ...
7890!> \param pw ...
7891!> \param array ...
7892! **************************************************************************************************
7893 SUBROUTINE pw_copy_to_array_c3d_c3d_gs (pw, array)
7894 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw
7895 COMPLEX(KIND=dp), DIMENSION(:, :, :), INTENT(INOUT) :: array
7896
7897 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_to_array'
7898
7899 INTEGER :: handle
7900
7901 CALL timeset(routinen, handle)
7902
7903!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
7904 array(:, :, :) = pw%array(:, :, :)
7905!$OMP END PARALLEL WORKSHARE
7906
7907 CALL timestop(handle)
7908 END SUBROUTINE pw_copy_to_array_c3d_c3d_gs
7909
7910! **************************************************************************************************
7911!> \brief ...
7912!> \param pw ...
7913!> \param array ...
7914! **************************************************************************************************
7915 SUBROUTINE pw_copy_from_array_c3d_c3d_gs (pw, array)
7916 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw
7917 COMPLEX(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: array
7918
7919 CHARACTER(len=*), PARAMETER :: routineN = 'pw_copy_from_array'
7920
7921 INTEGER :: handle
7922
7923 CALL timeset(routinen, handle)
7924
7925!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw, array)
7926 pw%array = array
7927!$OMP END PARALLEL WORKSHARE
7928
7929 CALL timestop(handle)
7930 END SUBROUTINE pw_copy_from_array_c3d_c3d_gs
7931
7932! **************************************************************************************************
7933!> \brief pw2 = alpha*pw1 + beta*pw2
7934!> alpha defaults to 1, beta defaults to 1
7935!> \param pw1 ...
7936!> \param pw2 ...
7937!> \param alpha ...
7938!> \param beta ...
7939!> \param allow_noncompatible_grids ...
7940!> \par History
7941!> JGH (21-Feb-2003) : added reference grid functionality
7942!> JGH (01-Dec-2007) : rename and remove complex alpha
7943!> \author apsi
7944!> \note
7945!> Currently only summing up of respective types allowed,
7946!> in order to avoid errors
7947! **************************************************************************************************
7948 SUBROUTINE pw_axpy_c3d_c3d_gs (pw1, pw2, alpha, beta, allow_noncompatible_grids)
7949
7950 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
7951 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw2
7952 REAL(KIND=dp), INTENT(in), OPTIONAL :: alpha, beta
7953 LOGICAL, INTENT(IN), OPTIONAL :: allow_noncompatible_grids
7954
7955 CHARACTER(len=*), PARAMETER :: routineN = 'pw_axpy'
7956
7957 INTEGER :: handle
7958 LOGICAL :: my_allow_noncompatible_grids
7959 REAL(KIND=dp) :: my_alpha, my_beta
7960
7961 CALL timeset(routinen, handle)
7962
7963 my_alpha = 1.0_dp
7964 IF (PRESENT(alpha)) my_alpha = alpha
7965
7966 my_beta = 1.0_dp
7967 IF (PRESENT(beta)) my_beta = beta
7968
7969 my_allow_noncompatible_grids = .false.
7970 IF (PRESENT(allow_noncompatible_grids)) my_allow_noncompatible_grids = allow_noncompatible_grids
7971
7972 IF (my_beta /= 1.0_dp) THEN
7973 IF (my_beta == 0.0_dp) THEN
7974 CALL pw_zero(pw2)
7975 ELSE
7976!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw2,my_beta)
7977 pw2%array = pw2%array*my_beta
7978!$OMP END PARALLEL WORKSHARE
7979 END IF
7980 END IF
7981
7982 IF (ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
7983 IF (my_alpha == 1.0_dp) THEN
7984!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2)
7985 pw2%array = pw2%array + pw1%array
7986!$OMP END PARALLEL WORKSHARE
7987 ELSE IF (my_alpha /= 0.0_dp) THEN
7988!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1, pw2, my_alpha)
7989 pw2%array = pw2%array + my_alpha* pw1%array
7990!$OMP END PARALLEL WORKSHARE
7991 END IF
7992
7993 ELSE IF (pw_compatible(pw1%pw_grid, pw2%pw_grid) .OR. my_allow_noncompatible_grids) THEN
7994
7995 IF (any(shape(pw1%array) /= shape(pw2%array))) &
7996 cpabort("Noncommensurate grids not implemented for 3D grids!")
7997
7998 IF (my_alpha == 1.0_dp) THEN
7999!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
8000 pw2%array = pw2%array + pw1%array
8001!$OMP END PARALLEL WORKSHARE
8002 ELSE
8003!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2,my_alpha)
8004 pw2%array = pw2%array + my_alpha* pw1%array
8005!$OMP END PARALLEL WORKSHARE
8006 END IF
8007
8008 ELSE
8009
8010 cpabort("Grids not compatible")
8011
8012 END IF
8013
8014 CALL timestop(handle)
8015
8016 END SUBROUTINE pw_axpy_c3d_c3d_gs
8017
8018! **************************************************************************************************
8019!> \brief pw_out = pw_out + alpha * pw1 * pw2
8020!> alpha defaults to 1
8021!> \param pw_out ...
8022!> \param pw1 ...
8023!> \param pw2 ...
8024!> \param alpha ...
8025!> \author JGH
8026! **************************************************************************************************
8027 SUBROUTINE pw_multiply_c3d_c3d_gs (pw_out, pw1, pw2, alpha)
8028
8029 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw_out
8030 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
8031 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw2
8032 REAL(KIND=dp), INTENT(IN), OPTIONAL :: alpha
8033
8034 CHARACTER(len=*), PARAMETER :: routineN = 'pw_multiply'
8035
8036 INTEGER :: handle
8037 REAL(KIND=dp) :: my_alpha
8038
8039 CALL timeset(routinen, handle)
8040
8041 my_alpha = 1.0_dp
8042 IF (PRESENT(alpha)) my_alpha = alpha
8043
8044 IF (.NOT. ASSOCIATED(pw_out%pw_grid, pw1%pw_grid) .OR. .NOT. ASSOCIATED(pw_out%pw_grid, pw2%pw_grid)) &
8045 cpabort("pw_multiply not implemented for non-identical grids!")
8046
8047#if !defined(__INTEL_LLVM_COMPILER) || (20250000 <= __INTEL_LLVM_COMPILER)
8048 IF (my_alpha == 1.0_dp) THEN
8049!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw_out, pw1, pw2)
8050 pw_out%array = pw_out%array + pw1%array* pw2%array
8051!$OMP END PARALLEL WORKSHARE
8052 ELSE
8053!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(my_alpha, pw_out, pw1, pw2)
8054 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
8055!$OMP END PARALLEL WORKSHARE
8056 END IF
8057#else
8058 IF (my_alpha == 1.0_dp) THEN
8059 pw_out%array = pw_out%array + pw1%array* pw2%array
8060 ELSE
8061 pw_out%array = pw_out%array + my_alpha*pw1%array* pw2%array
8062 END IF
8063#endif
8064
8065 CALL timestop(handle)
8066
8067 END SUBROUTINE pw_multiply_c3d_c3d_gs
8068
8069! **************************************************************************************************
8070!> \brief ...
8071!> \param pw1 ...
8072!> \param pw2 ...
8073! **************************************************************************************************
8074 SUBROUTINE pw_multiply_with_c3d_c3d_gs (pw1, pw2)
8075 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw1
8076 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw2
8077
8078 CHARACTER(LEN=*), PARAMETER :: routineN = 'pw_multiply_with'
8079
8080 INTEGER :: handle
8081
8082 CALL timeset(routinen, handle)
8083
8084 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) &
8085 cpabort("Incompatible grids!")
8086
8087!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw1,pw2)
8088 pw1%array = pw1%array* pw2%array
8089!$OMP END PARALLEL WORKSHARE
8090
8091 CALL timestop(handle)
8092
8093 END SUBROUTINE pw_multiply_with_c3d_c3d_gs
8094
8095! **************************************************************************************************
8096!> \brief Calculate integral over unit cell for functions in plane wave basis
8097!> only returns the real part of it ......
8098!> \param pw1 ...
8099!> \param pw2 ...
8100!> \param sumtype ...
8101!> \param just_sum ...
8102!> \param local_only ...
8103!> \return ...
8104!> \par History
8105!> JGH (14-Mar-2001) : Parallel sum and some tests, HALFSPACE case
8106!> \author apsi
8107! **************************************************************************************************
8108 FUNCTION pw_integral_ab_c3d_c3d_gs (pw1, pw2, sumtype, just_sum, local_only) RESULT(integral_value)
8109
8110 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
8111 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw2
8112 INTEGER, INTENT(IN), OPTIONAL :: sumtype
8113 LOGICAL, INTENT(IN), OPTIONAL :: just_sum, local_only
8114 REAL(kind=dp) :: integral_value
8115
8116 CHARACTER(len=*), PARAMETER :: routinen = 'pw_integral_ab_c3d_c3d_gs'
8117
8118 INTEGER :: handle, loc_sumtype
8119 LOGICAL :: my_just_sum, my_local_only
8120
8121 CALL timeset(routinen, handle)
8122
8123 loc_sumtype = do_accurate_sum
8124 IF (PRESENT(sumtype)) loc_sumtype = sumtype
8125
8126 my_local_only = .false.
8127 IF (PRESENT(local_only)) my_local_only = local_only
8128
8129 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
8130 cpabort("Grids incompatible")
8131 END IF
8132
8133 my_just_sum = .false.
8134 IF (PRESENT(just_sum)) my_just_sum = just_sum
8135
8136 ! do standard sum
8137 IF (loc_sumtype == do_standard_sum) THEN
8138
8139 ! Do standard sum
8140
8141 integral_value = sum(real(conjg(pw1%array) &
8142 *pw2%array, kind=dp)) !? complex bit
8143
8144 ELSE
8145
8146 ! Do accurate sum
8147 integral_value = accurate_sum(real(conjg(pw1%array)*pw2%array, kind=dp))
8148
8149 END IF
8150
8151
8152 IF (.NOT. my_just_sum) THEN
8153 integral_value = integral_value*pw1%pw_grid%vol
8154 END IF
8155
8156 IF (.NOT. my_local_only .AND. pw1%pw_grid%para%mode == pw_mode_distributed) &
8157 CALL pw1%pw_grid%para%group%sum(integral_value)
8158
8159 CALL timestop(handle)
8160
8161 END FUNCTION pw_integral_ab_c3d_c3d_gs
8162
8163
8164
8165
8166
8167
8168
8169
8170
8171
8172
8173
8174
8175! **************************************************************************************************
8176!> \brief Gathers the pw vector from a 3d data field
8177!> \param pw ...
8178!> \param c ...
8179!> \param scale ...
8180!> \par History
8181!> none
8182!> \author JGH
8183! **************************************************************************************************
8184 SUBROUTINE pw_gather_s_r1d_r3d_2(pw1, pw2, scale)
8185
8186 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw1
8187 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw2
8188 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
8189
8190 CALL pw_gather_s_r1d_r3d (pw2, pw1%array, scale)
8191
8192 END SUBROUTINE pw_gather_s_r1d_r3d_2
8193
8194! **************************************************************************************************
8195!> \brief Gathers the pw vector from a 3d data field
8196!> \param pw ...
8197!> \param c ...
8198!> \param scale ...
8199!> \par History
8200!> none
8201!> \author JGH
8202! **************************************************************************************************
8203 SUBROUTINE pw_gather_s_r1d_r3d (pw, c, scale)
8204
8205 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw
8206 REAL(kind=dp), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN), TARGET :: c
8207 REAL(kind=dp), INTENT(IN), OPTIONAL :: scale
8208
8209 CHARACTER(len=*), PARAMETER :: routinen = 'pw_gather_s'
8210
8211 INTEGER :: gpt, handle
8212 REAL(kind=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
8213
8214 CALL timeset(routinen, handle)
8215
8216 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
8217 c_1d(1:SIZE(c)) => c
8218 associate(ngpts => SIZE(pw%pw_grid%gsq), g_hatmap => pw%pw_grid%g_hatmap)
8219
8220 IF (PRESENT(scale)) THEN
8221!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
8222 DO gpt = 1, ngpts
8223 pw%array(gpt) = scale* c_1d(g_hatmap(gpt, 1) + 1)
8224 END DO
8225!$OMP END PARALLEL DO
8226 ELSE
8227!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
8228 DO gpt = 1, ngpts
8229 pw%array(gpt) = c_1d(g_hatmap(gpt, 1) + 1)
8230 END DO
8231!$OMP END PARALLEL DO
8232 END IF
8233
8234 END associate
8235
8236 CALL timestop(handle)
8237
8238 END SUBROUTINE pw_gather_s_r1d_r3d
8239
8240! **************************************************************************************************
8241!> \brief Scatters a pw vector to a 3d data field
8242!> \param pw ...
8243!> \param c ...
8244!> \param scale ...
8245!> \par History
8246!> none
8247!> \author JGH
8248! **************************************************************************************************
8249 SUBROUTINE pw_scatter_s_r1d_r3d_2(pw1, pw2, scale)
8250
8251 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
8252 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw2
8253 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
8254
8255 CALL pw_scatter_s_r1d_r3d (pw1, pw2%array, scale)
8256
8257 END SUBROUTINE pw_scatter_s_r1d_r3d_2
8258
8259! **************************************************************************************************
8260!> \brief Scatters a pw vector to a 3d data field
8261!> \param pw ...
8262!> \param c ...
8263!> \param scale ...
8264!> \par History
8265!> none
8266!> \author JGH
8267! **************************************************************************************************
8268 SUBROUTINE pw_scatter_s_r1d_r3d (pw, c, scale)
8269
8270 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw
8271 REAL(kind=dp), DIMENSION(:, :, :), CONTIGUOUS, INTENT(INOUT), TARGET :: c
8272 REAL(kind=dp), INTENT(IN), OPTIONAL :: scale
8273
8274 CHARACTER(len=*), PARAMETER :: routinen = 'pw_scatter_s'
8275
8276 INTEGER :: gpt, handle
8277 REAL(kind=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
8278
8279 CALL timeset(routinen, handle)
8280
8281 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
8282 c_1d(1:SIZE(c)) => c
8283 associate(g_hatmap => pw%pw_grid%g_hatmap, ngpts => SIZE(pw%pw_grid%gsq))
8284
8285 ! should only zero the unused bits (but the zero is needed)
8286 IF (.NOT. PRESENT(scale)) c = 0.0_dp
8287
8288 IF (PRESENT(scale)) THEN
8289!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
8290 DO gpt = 1, ngpts
8291 c_1d(g_hatmap(gpt, 1) + 1) = scale* pw%array(gpt)
8292 END DO
8293!$OMP END PARALLEL DO
8294 ELSE
8295!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
8296 DO gpt = 1, ngpts
8297 c_1d(g_hatmap(gpt, 1) + 1) = pw%array(gpt)
8298 END DO
8299!$OMP END PARALLEL DO
8300 END IF
8301
8302 IF (pw%pw_grid%grid_span == halfspace) THEN
8303
8304 IF (PRESENT(scale)) THEN
8305!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
8306 DO gpt = 1, ngpts
8307 c_1d(g_hatmap(gpt, 2) + 1) = scale*( pw%array(gpt))
8308 END DO
8309!$OMP END PARALLEL DO
8310 ELSE
8311!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
8312 DO gpt = 1, ngpts
8313 c_1d(g_hatmap(gpt, 2) + 1) = ( pw%array(gpt))
8314 END DO
8315!$OMP END PARALLEL DO
8316 END IF
8317
8318 END IF
8319
8320 END associate
8321
8322 CALL timestop(handle)
8323
8324 END SUBROUTINE pw_scatter_s_r1d_r3d
8325
8326
8327
8328
8329
8330
8331
8332
8333
8334
8335
8336! **************************************************************************************************
8337!> \brief Gathers the pw vector from a 3d data field
8338!> \param pw ...
8339!> \param c ...
8340!> \param scale ...
8341!> \par History
8342!> none
8343!> \author JGH
8344! **************************************************************************************************
8345 SUBROUTINE pw_gather_s_r1d_c3d_2(pw1, pw2, scale)
8346
8347 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
8348 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw2
8349 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
8350
8351 CALL pw_gather_s_r1d_c3d (pw2, pw1%array, scale)
8352
8353 END SUBROUTINE pw_gather_s_r1d_c3d_2
8354
8355! **************************************************************************************************
8356!> \brief Gathers the pw vector from a 3d data field
8357!> \param pw ...
8358!> \param c ...
8359!> \param scale ...
8360!> \par History
8361!> none
8362!> \author JGH
8363! **************************************************************************************************
8364 SUBROUTINE pw_gather_s_r1d_c3d (pw, c, scale)
8365
8366 TYPE(pw_r1d_gs_type), INTENT(INOUT) :: pw
8367 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN), TARGET :: c
8368 REAL(kind=dp), INTENT(IN), OPTIONAL :: scale
8369
8370 CHARACTER(len=*), PARAMETER :: routinen = 'pw_gather_s'
8371
8372 INTEGER :: gpt, handle
8373 COMPLEX(KIND=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
8374
8375 CALL timeset(routinen, handle)
8376
8377 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
8378 c_1d(1:SIZE(c)) => c
8379 associate(ngpts => SIZE(pw%pw_grid%gsq), g_hatmap => pw%pw_grid%g_hatmap)
8380
8381 IF (PRESENT(scale)) THEN
8382!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
8383 DO gpt = 1, ngpts
8384 pw%array(gpt) = scale* real(c_1d(g_hatmap(gpt, 1) + 1), kind=dp)
8385 END DO
8386!$OMP END PARALLEL DO
8387 ELSE
8388!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
8389 DO gpt = 1, ngpts
8390 pw%array(gpt) = real(c_1d(g_hatmap(gpt, 1) + 1), kind=dp)
8391 END DO
8392!$OMP END PARALLEL DO
8393 END IF
8394
8395 END associate
8396
8397 CALL timestop(handle)
8398
8399 END SUBROUTINE pw_gather_s_r1d_c3d
8400
8401! **************************************************************************************************
8402!> \brief Scatters a pw vector to a 3d data field
8403!> \param pw ...
8404!> \param c ...
8405!> \param scale ...
8406!> \par History
8407!> none
8408!> \author JGH
8409! **************************************************************************************************
8410 SUBROUTINE pw_scatter_s_r1d_c3d_2(pw1, pw2, scale)
8411
8412 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw1
8413 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw2
8414 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
8415
8416 CALL pw_scatter_s_r1d_c3d (pw1, pw2%array, scale)
8417
8418 END SUBROUTINE pw_scatter_s_r1d_c3d_2
8419
8420! **************************************************************************************************
8421!> \brief Scatters a pw vector to a 3d data field
8422!> \param pw ...
8423!> \param c ...
8424!> \param scale ...
8425!> \par History
8426!> none
8427!> \author JGH
8428! **************************************************************************************************
8429 SUBROUTINE pw_scatter_s_r1d_c3d (pw, c, scale)
8430
8431 TYPE(pw_r1d_gs_type), INTENT(IN) :: pw
8432 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, INTENT(INOUT), TARGET :: c
8433 REAL(kind=dp), INTENT(IN), OPTIONAL :: scale
8434
8435 CHARACTER(len=*), PARAMETER :: routinen = 'pw_scatter_s'
8436
8437 INTEGER :: gpt, handle
8438 COMPLEX(KIND=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
8439
8440 CALL timeset(routinen, handle)
8441
8442 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
8443 c_1d(1:SIZE(c)) => c
8444 associate(g_hatmap => pw%pw_grid%g_hatmap, ngpts => SIZE(pw%pw_grid%gsq))
8445
8446 ! should only zero the unused bits (but the zero is needed)
8447 IF (.NOT. PRESENT(scale)) c = 0.0_dp
8448
8449 IF (PRESENT(scale)) THEN
8450!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
8451 DO gpt = 1, ngpts
8452 c_1d(g_hatmap(gpt, 1) + 1) = scale* cmplx(pw%array(gpt), 0.0_dp, kind=dp)
8453 END DO
8454!$OMP END PARALLEL DO
8455 ELSE
8456!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
8457 DO gpt = 1, ngpts
8458 c_1d(g_hatmap(gpt, 1) + 1) = cmplx(pw%array(gpt), 0.0_dp, kind=dp)
8459 END DO
8460!$OMP END PARALLEL DO
8461 END IF
8462
8463 IF (pw%pw_grid%grid_span == halfspace) THEN
8464
8465 IF (PRESENT(scale)) THEN
8466!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
8467 DO gpt = 1, ngpts
8468 c_1d(g_hatmap(gpt, 2) + 1) = scale*( cmplx(pw%array(gpt), 0.0_dp, kind=dp))
8469 END DO
8470!$OMP END PARALLEL DO
8471 ELSE
8472!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
8473 DO gpt = 1, ngpts
8474 c_1d(g_hatmap(gpt, 2) + 1) = ( cmplx(pw%array(gpt), 0.0_dp, kind=dp))
8475 END DO
8476!$OMP END PARALLEL DO
8477 END IF
8478
8479 END IF
8480
8481 END associate
8482
8483 CALL timestop(handle)
8484
8485 END SUBROUTINE pw_scatter_s_r1d_c3d
8486
8487
8488
8489
8490
8491
8492
8493
8494
8495
8496
8497
8498! **************************************************************************************************
8499!> \brief Generic function for 3d FFT of a coefficient_type or pw_r3d_rs_type
8500!> \param pw1 ...
8501!> \param pw2 ...
8502!> \param debug ...
8503!> \par History
8504!> JGH (30-12-2000): New setup of functions and adaptation to parallelism
8505!> JGH (04-01-2001): Moved routine from pws to this module, only covers
8506!> pw_types, no more coefficient types
8507!> \author apsi
8508!> \note
8509!> fft_wrap_pw1pw2
8510! **************************************************************************************************
8511 SUBROUTINE fft_wrap_pw1pw2_r3d_c1d_rs_gs (pw1, pw2, debug)
8512
8513 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw1
8514 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw2
8515 LOGICAL, INTENT(IN), OPTIONAL :: debug
8516
8517 CHARACTER(len=*), PARAMETER :: routineN = 'fft_wrap_pw1pw2'
8518
8519 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, POINTER :: grays
8520 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, POINTER :: c_in, c_out
8521 INTEGER :: handle, handle2, my_pos, nrays, &
8522 out_unit
8523 INTEGER, DIMENSION(3) :: nloc
8524#if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_PW)
8525 LOGICAL :: use_pw_gpu
8526#endif
8527 INTEGER, DIMENSION(:), POINTER :: n
8528 LOGICAL :: test
8529
8530 CALL timeset(routinen, handle2)
8531 out_unit = cp_logger_get_default_io_unit()
8532 CALL timeset(routinen//"_"//trim(adjustl(cp_to_string( &
8533 ceiling(pw1%pw_grid%cutoff/10)*10))), handle)
8534
8535 NULLIFY (c_in)
8536 NULLIFY (c_out)
8537
8538 IF (PRESENT(debug)) THEN
8539 test = debug
8540 ELSE
8541 test = .false.
8542 END IF
8543
8544 !..check if grids are compatible
8545 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
8546 IF (pw1%pw_grid%dvol /= pw2%pw_grid%dvol) THEN
8547 cpabort("PW grids not compatible")
8548 END IF
8549 IF (pw1%pw_grid%para%group /= pw2%pw_grid%para%group) THEN
8550 cpabort("PW grids have not compatible MPI groups")
8551 END IF
8552 END IF
8553
8554 n => pw1%pw_grid%npts
8555
8556 IF (pw1%pw_grid%para%mode == pw_mode_local) THEN
8557
8558 !
8559 !..replicated data, use local FFT
8560 !
8561
8562 IF (test .AND. out_unit > 0) THEN
8563 WRITE (out_unit, '(A)') " FFT Protocol "
8564 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "FWFFT"
8565 WRITE (out_unit, '(A,T72,A)') " in space ", "REALSPACE"
8566 WRITE (out_unit, '(A,T72,A)') " out space ", "REALSPACE"
8567 END IF
8568
8569#if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_PW)
8570 CALL pw_gpu_r3dc1d_3d(pw1, pw2)
8571#elif defined (__PW_FPGA)
8572 ALLOCATE (c_out(n(1), n(2), n(3)))
8573 ! check if bitstream for the fft size is present
8574 ! if not, perform fft3d in CPU
8575 IF (pw_fpga_init_bitstream(n) == 1) THEN
8576 CALL pw_copy_to_array(pw1, c_out)
8577#if (__PW_FPGA_SP && __PW_FPGA)
8578 CALL pw_fpga_r3dc1d_3d_sp(n, c_out)
8579#else
8580 CALL pw_fpga_r3dc1d_3d_dp(n, c_out)
8581#endif
8582 CALL zdscal(n(1)*n(2)*n(3), 1.0_dp/pw1%pw_grid%ngpts, c_out, 1)
8583 CALL pw_gather_s_c1d_c3d(pw2, c_out)
8584 ELSE
8585 CALL pw_copy_to_array(pw1, c_out)
8586 CALL fft3d(fwfft, n, c_out, debug=test)
8587 CALL pw_gather_s_c1d_c3d(pw2, c_out)
8588 END IF
8589 DEALLOCATE (c_out)
8590#else
8591 ALLOCATE (c_out(n(1), n(2), n(3)))
8592 c_out = 0.0_dp
8593 CALL pw_copy_to_array(pw1, c_out)
8594 CALL fft3d(fwfft, n, c_out, debug=test)
8595 CALL pw_gather_s_c1d_c3d(pw2, c_out)
8596 DEALLOCATE (c_out)
8597#endif
8598
8599 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " End of FFT Protocol "
8600
8601 ELSE
8602
8603 !
8604 !..parallel FFT
8605 !
8606
8607 IF (test .AND. out_unit > 0) THEN
8608 WRITE (out_unit, '(A)') " FFT Protocol "
8609 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "FWFFT"
8610 WRITE (out_unit, '(A,T72,A)') " in space ", "REALSPACE"
8611 WRITE (out_unit, '(A,T72,A)') " out space ", "REALSPACE"
8612 END IF
8613
8614 my_pos = pw1%pw_grid%para%group%mepos
8615 nrays = pw1%pw_grid%para%nyzray(my_pos)
8616 grays => pw1%pw_grid%grays
8617
8618#if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_PW)
8619 ! (no ray dist. is not efficient in CUDA)
8620 use_pw_gpu = pw1%pw_grid%para%ray_distribution
8621 IF (use_pw_gpu) THEN
8622 CALL pw_gpu_r3dc1d_3d_ps(pw1, pw2)
8623 ELSE
8624#endif
8625!.. prepare input
8626 nloc = pw1%pw_grid%npts_local
8627 ALLOCATE (c_in(nloc(1), nloc(2), nloc(3)))
8628 CALL pw_copy_to_array(pw1, c_in)
8629 grays = z_zero
8630 !..transform
8631 IF (pw1%pw_grid%para%ray_distribution) THEN
8632 CALL fft3d(fwfft, n, c_in, grays, pw1%pw_grid%para%group, &
8633 pw1%pw_grid%para%yzp, pw1%pw_grid%para%nyzray, &
8634 pw1%pw_grid%para%bo, debug=test)
8635 ELSE
8636 CALL fft3d(fwfft, n, c_in, grays, pw1%pw_grid%para%group, &
8637 pw1%pw_grid%para%bo, debug=test)
8638 END IF
8639 !..prepare output
8640 IF (test .AND. out_unit > 0) &
8641 WRITE (out_unit, '(A)') " PW_GATHER : 2d -> 1d "
8642 CALL pw_gather_p_c1d (pw2, grays)
8643 DEALLOCATE (c_in)
8644
8645#if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_PW)
8646 END IF
8647#endif
8648 END IF
8649
8650 IF (test .AND. out_unit > 0) THEN
8651 WRITE (out_unit, '(A)') " End of FFT Protocol "
8652 END IF
8653
8654 CALL timestop(handle)
8655 CALL timestop(handle2)
8656
8657 END SUBROUTINE fft_wrap_pw1pw2_r3d_c1d_rs_gs
8658
8659
8660
8661
8662
8663! **************************************************************************************************
8664!> \brief Generic function for 3d FFT of a coefficient_type or pw_r3d_rs_type
8665!> \param pw1 ...
8666!> \param pw2 ...
8667!> \param debug ...
8668!> \par History
8669!> JGH (30-12-2000): New setup of functions and adaptation to parallelism
8670!> JGH (04-01-2001): Moved routine from pws to this module, only covers
8671!> pw_types, no more coefficient types
8672!> \author apsi
8673!> \note
8674!> fft_wrap_pw1pw2
8675! **************************************************************************************************
8676 SUBROUTINE fft_wrap_pw1pw2_r3d_c3d_rs_gs (pw1, pw2, debug)
8677
8678 TYPE(pw_r3d_rs_type), INTENT(IN) :: pw1
8679 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw2
8680 LOGICAL, INTENT(IN), OPTIONAL :: debug
8681
8682 CHARACTER(len=*), PARAMETER :: routineN = 'fft_wrap_pw1pw2'
8683
8684 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, POINTER :: grays
8685 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, POINTER :: c_in, c_out
8686 INTEGER :: handle, handle2, my_pos, nrays, &
8687 out_unit
8688 INTEGER, DIMENSION(:), POINTER :: n
8689 LOGICAL :: test
8690
8691 CALL timeset(routinen, handle2)
8692 out_unit = cp_logger_get_default_io_unit()
8693 CALL timeset(routinen//"_"//trim(adjustl(cp_to_string( &
8694 ceiling(pw1%pw_grid%cutoff/10)*10))), handle)
8695
8696 NULLIFY (c_in)
8697 NULLIFY (c_out)
8698
8699 IF (PRESENT(debug)) THEN
8700 test = debug
8701 ELSE
8702 test = .false.
8703 END IF
8704
8705 !..check if grids are compatible
8706 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
8707 IF (pw1%pw_grid%dvol /= pw2%pw_grid%dvol) THEN
8708 cpabort("PW grids not compatible")
8709 END IF
8710 IF (pw1%pw_grid%para%group /= pw2%pw_grid%para%group) THEN
8711 cpabort("PW grids have not compatible MPI groups")
8712 END IF
8713 END IF
8714
8715 n => pw1%pw_grid%npts
8716
8717 IF (pw1%pw_grid%para%mode == pw_mode_local) THEN
8718
8719 !
8720 !..replicated data, use local FFT
8721 !
8722
8723 IF (test .AND. out_unit > 0) THEN
8724 WRITE (out_unit, '(A)') " FFT Protocol "
8725 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "FWFFT"
8726 WRITE (out_unit, '(A,T72,A)') " in space ", "REALSPACE"
8727 WRITE (out_unit, '(A,T72,A)') " out space ", "REALSPACE"
8728 END IF
8729
8730 pw2%array = cmplx(pw1%array, 0.0_dp, kind=dp)
8731 c_out => pw2%array
8732 CALL fft3d(fwfft, n, c_out, debug=test)
8733
8734 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " End of FFT Protocol "
8735
8736 ELSE
8737
8738 !
8739 !..parallel FFT
8740 !
8741
8742 IF (test .AND. out_unit > 0) THEN
8743 WRITE (out_unit, '(A)') " FFT Protocol "
8744 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "FWFFT"
8745 WRITE (out_unit, '(A,T72,A)') " in space ", "REALSPACE"
8746 WRITE (out_unit, '(A,T72,A)') " out space ", "REALSPACE"
8747 END IF
8748
8749 my_pos = pw1%pw_grid%para%group%mepos
8750 nrays = pw1%pw_grid%para%nyzray(my_pos)
8751 grays => pw1%pw_grid%grays
8752
8753 END IF
8754
8755 IF (test .AND. out_unit > 0) THEN
8756 WRITE (out_unit, '(A)') " End of FFT Protocol "
8757 END IF
8758
8759 CALL timestop(handle)
8760 CALL timestop(handle2)
8761
8762 END SUBROUTINE fft_wrap_pw1pw2_r3d_c3d_rs_gs
8763
8764
8765
8766
8767
8768
8769
8770
8771
8772
8773
8774! **************************************************************************************************
8775!> \brief Generic function for 3d FFT of a coefficient_type or pw_r3d_rs_type
8776!> \param pw1 ...
8777!> \param pw2 ...
8778!> \param debug ...
8779!> \par History
8780!> JGH (30-12-2000): New setup of functions and adaptation to parallelism
8781!> JGH (04-01-2001): Moved routine from pws to this module, only covers
8782!> pw_types, no more coefficient types
8783!> \author apsi
8784!> \note
8785!> fft_wrap_pw1pw2
8786! **************************************************************************************************
8787 SUBROUTINE fft_wrap_pw1pw2_c1d_r3d_gs_rs (pw1, pw2, debug)
8788
8789 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
8790 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw2
8791 LOGICAL, INTENT(IN), OPTIONAL :: debug
8792
8793 CHARACTER(len=*), PARAMETER :: routineN = 'fft_wrap_pw1pw2'
8794
8795 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, POINTER :: grays
8796 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, POINTER :: c_in, c_out
8797 INTEGER :: handle, handle2, my_pos, nrays, &
8798 out_unit
8799 INTEGER, DIMENSION(3) :: nloc
8800#if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_PW)
8801 LOGICAL :: use_pw_gpu
8802#endif
8803 INTEGER, DIMENSION(:), POINTER :: n
8804 LOGICAL :: test
8805
8806 CALL timeset(routinen, handle2)
8807 out_unit = cp_logger_get_default_io_unit()
8808 CALL timeset(routinen//"_"//trim(adjustl(cp_to_string( &
8809 ceiling(pw1%pw_grid%cutoff/10)*10))), handle)
8810
8811 NULLIFY (c_in)
8812 NULLIFY (c_out)
8813
8814 IF (PRESENT(debug)) THEN
8815 test = debug
8816 ELSE
8817 test = .false.
8818 END IF
8819
8820 !..check if grids are compatible
8821 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
8822 IF (pw1%pw_grid%dvol /= pw2%pw_grid%dvol) THEN
8823 cpabort("PW grids not compatible")
8824 END IF
8825 IF (pw1%pw_grid%para%group /= pw2%pw_grid%para%group) THEN
8826 cpabort("PW grids have not compatible MPI groups")
8827 END IF
8828 END IF
8829
8830 n => pw1%pw_grid%npts
8831
8832 IF (pw1%pw_grid%para%mode == pw_mode_local) THEN
8833
8834 !
8835 !..replicated data, use local FFT
8836 !
8837
8838 IF (test .AND. out_unit > 0) THEN
8839 WRITE (out_unit, '(A)') " FFT Protocol "
8840 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "BWFFT"
8841 WRITE (out_unit, '(A,T66,A)') " in space ", "RECIPROCALSPACE"
8842 WRITE (out_unit, '(A,T66,A)') " out space ", "RECIPROCALSPACE"
8843 END IF
8844
8845#if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_PW)
8846 CALL pw_gpu_c1dr3d_3d(pw1, pw2)
8847#elif defined (__PW_FPGA)
8848 ALLOCATE (c_out(n(1), n(2), n(3)))
8849 ! check if bitstream for the fft size is present
8850 ! if not, perform fft3d in CPU
8851 IF (pw_fpga_init_bitstream(n) == 1) THEN
8852 CALL pw_scatter_s_c1d_c3d(pw1, c_out)
8853 ! transform using FPGA
8854#if (__PW_FPGA_SP && __PW_FPGA)
8855 CALL pw_fpga_c1dr3d_3d_sp(n, c_out)
8856#else
8857 CALL pw_fpga_c1dr3d_3d_dp(n, c_out)
8858#endif
8859 CALL zdscal(n(1)*n(2)*n(3), 1.0_dp, c_out, 1)
8860 ! use real part only
8861 CALL pw_copy_from_array(pw2, c_out)
8862 ELSE
8863 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " PW_SCATTER : 3d -> 1d "
8864 CALL pw_scatter_s_c1d_c3d(pw1, c_out)
8865 ! transform
8866 CALL fft3d(bwfft, n, c_out, debug=test)
8867 ! use real part only
8868 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " REAL part "
8869 CALL pw_copy_from_array(pw2, c_out)
8870 END IF
8871 DEALLOCATE (c_out)
8872#else
8873 ALLOCATE (c_out(n(1), n(2), n(3)))
8874 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " PW_SCATTER : 3d -> 1d "
8875 CALL pw_scatter_s_c1d_c3d(pw1, c_out)
8876 ! transform
8877 CALL fft3d(bwfft, n, c_out, debug=test)
8878 ! use real part only
8879 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " REAL part "
8880 CALL pw_copy_from_array(pw2, c_out)
8881 DEALLOCATE (c_out)
8882#endif
8883
8884 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " End of FFT Protocol "
8885
8886 ELSE
8887
8888 !
8889 !..parallel FFT
8890 !
8891
8892 IF (test .AND. out_unit > 0) THEN
8893 WRITE (out_unit, '(A)') " FFT Protocol "
8894 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "BWFFT"
8895 WRITE (out_unit, '(A,T66,A)') " in space ", "RECIPROCALSPACE"
8896 WRITE (out_unit, '(A,T66,A)') " out space ", "RECIPROCALSPACE"
8897 END IF
8898
8899 my_pos = pw1%pw_grid%para%group%mepos
8900 nrays = pw1%pw_grid%para%nyzray(my_pos)
8901 grays => pw1%pw_grid%grays
8902
8903#if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_PW)
8904 ! (no ray dist. is not efficient in CUDA)
8905 use_pw_gpu = pw1%pw_grid%para%ray_distribution
8906 IF (use_pw_gpu) THEN
8907 CALL pw_gpu_c1dr3d_3d_ps(pw1, pw2)
8908 ELSE
8909#endif
8910!.. prepare input
8911 IF (test .AND. out_unit > 0) &
8912 WRITE (out_unit, '(A)') " PW_SCATTER : 2d -> 1d "
8913 grays = z_zero
8914 CALL pw_scatter_p_c1d (pw1, grays)
8915 nloc = pw2%pw_grid%npts_local
8916 ALLOCATE (c_in(nloc(1), nloc(2), nloc(3)))
8917 !..transform
8918 IF (pw1%pw_grid%para%ray_distribution) THEN
8919 CALL fft3d(bwfft, n, c_in, grays, pw1%pw_grid%para%group, &
8920 pw1%pw_grid%para%yzp, pw1%pw_grid%para%nyzray, &
8921 pw1%pw_grid%para%bo, debug=test)
8922 ELSE
8923 CALL fft3d(bwfft, n, c_in, grays, pw1%pw_grid%para%group, &
8924 pw1%pw_grid%para%bo, debug=test)
8925 END IF
8926 !..prepare output
8927 IF (test .AND. out_unit > 0) &
8928 WRITE (out_unit, '(A)') " Real part "
8929 CALL pw_copy_from_array(pw2, c_in)
8930 DEALLOCATE (c_in)
8931#if defined(__OFFLOAD) && !defined(__NO_OFFLOAD_PW)
8932 END IF
8933#endif
8934 END IF
8935
8936 IF (test .AND. out_unit > 0) THEN
8937 WRITE (out_unit, '(A)') " End of FFT Protocol "
8938 END IF
8939
8940 CALL timestop(handle)
8941 CALL timestop(handle2)
8942
8943 END SUBROUTINE fft_wrap_pw1pw2_c1d_r3d_gs_rs
8944
8945
8946
8947! **************************************************************************************************
8948!> \brief Gathers the pw vector from a 3d data field
8949!> \param pw ...
8950!> \param c ...
8951!> \param scale ...
8952!> \par History
8953!> none
8954!> \author JGH
8955! **************************************************************************************************
8956 SUBROUTINE pw_gather_s_c1d_r3d_2(pw1, pw2, scale)
8957
8958 TYPE(pw_r3d_gs_type), INTENT(IN) :: pw1
8959 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw2
8960 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
8961
8962 CALL pw_gather_s_c1d_r3d (pw2, pw1%array, scale)
8963
8964 END SUBROUTINE pw_gather_s_c1d_r3d_2
8965
8966! **************************************************************************************************
8967!> \brief Gathers the pw vector from a 3d data field
8968!> \param pw ...
8969!> \param c ...
8970!> \param scale ...
8971!> \par History
8972!> none
8973!> \author JGH
8974! **************************************************************************************************
8975 SUBROUTINE pw_gather_s_c1d_r3d (pw, c, scale)
8976
8977 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
8978 REAL(kind=dp), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN), TARGET :: c
8979 REAL(kind=dp), INTENT(IN), OPTIONAL :: scale
8980
8981 CHARACTER(len=*), PARAMETER :: routinen = 'pw_gather_s'
8982
8983 INTEGER :: gpt, handle
8984 REAL(kind=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
8985
8986 CALL timeset(routinen, handle)
8987
8988 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
8989 c_1d(1:SIZE(c)) => c
8990 associate(ngpts => SIZE(pw%pw_grid%gsq), g_hatmap => pw%pw_grid%g_hatmap)
8991
8992 IF (PRESENT(scale)) THEN
8993!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
8994 DO gpt = 1, ngpts
8995 pw%array(gpt) = scale* cmplx(c_1d(g_hatmap(gpt, 1) + 1), 0.0_dp, kind=dp)
8996 END DO
8997!$OMP END PARALLEL DO
8998 ELSE
8999!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
9000 DO gpt = 1, ngpts
9001 pw%array(gpt) = cmplx(c_1d(g_hatmap(gpt, 1) + 1), 0.0_dp, kind=dp)
9002 END DO
9003!$OMP END PARALLEL DO
9004 END IF
9005
9006 END associate
9007
9008 CALL timestop(handle)
9009
9010 END SUBROUTINE pw_gather_s_c1d_r3d
9011
9012! **************************************************************************************************
9013!> \brief Scatters a pw vector to a 3d data field
9014!> \param pw ...
9015!> \param c ...
9016!> \param scale ...
9017!> \par History
9018!> none
9019!> \author JGH
9020! **************************************************************************************************
9021 SUBROUTINE pw_scatter_s_c1d_r3d_2(pw1, pw2, scale)
9022
9023 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
9024 TYPE(pw_r3d_gs_type), INTENT(INOUT) :: pw2
9025 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
9026
9027 CALL pw_scatter_s_c1d_r3d (pw1, pw2%array, scale)
9028
9029 END SUBROUTINE pw_scatter_s_c1d_r3d_2
9030
9031! **************************************************************************************************
9032!> \brief Scatters a pw vector to a 3d data field
9033!> \param pw ...
9034!> \param c ...
9035!> \param scale ...
9036!> \par History
9037!> none
9038!> \author JGH
9039! **************************************************************************************************
9040 SUBROUTINE pw_scatter_s_c1d_r3d (pw, c, scale)
9041
9042 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
9043 REAL(kind=dp), DIMENSION(:, :, :), CONTIGUOUS, INTENT(INOUT), TARGET :: c
9044 REAL(kind=dp), INTENT(IN), OPTIONAL :: scale
9045
9046 CHARACTER(len=*), PARAMETER :: routinen = 'pw_scatter_s'
9047
9048 INTEGER :: gpt, handle
9049 REAL(kind=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
9050
9051 CALL timeset(routinen, handle)
9052
9053 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
9054 c_1d(1:SIZE(c)) => c
9055 associate(g_hatmap => pw%pw_grid%g_hatmap, ngpts => SIZE(pw%pw_grid%gsq))
9056
9057 ! should only zero the unused bits (but the zero is needed)
9058 IF (.NOT. PRESENT(scale)) c = 0.0_dp
9059
9060 IF (PRESENT(scale)) THEN
9061!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
9062 DO gpt = 1, ngpts
9063 c_1d(g_hatmap(gpt, 1) + 1) = scale* real(pw%array(gpt), kind=dp)
9064 END DO
9065!$OMP END PARALLEL DO
9066 ELSE
9067!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
9068 DO gpt = 1, ngpts
9069 c_1d(g_hatmap(gpt, 1) + 1) = real(pw%array(gpt), kind=dp)
9070 END DO
9071!$OMP END PARALLEL DO
9072 END IF
9073
9074 IF (pw%pw_grid%grid_span == halfspace) THEN
9075
9076 IF (PRESENT(scale)) THEN
9077!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
9078 DO gpt = 1, ngpts
9079 c_1d(g_hatmap(gpt, 2) + 1) = scale*( real(pw%array(gpt), kind=dp))
9080 END DO
9081!$OMP END PARALLEL DO
9082 ELSE
9083!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
9084 DO gpt = 1, ngpts
9085 c_1d(g_hatmap(gpt, 2) + 1) = ( real(pw%array(gpt), kind=dp))
9086 END DO
9087!$OMP END PARALLEL DO
9088 END IF
9089
9090 END IF
9091
9092 END associate
9093
9094 CALL timestop(handle)
9095
9096 END SUBROUTINE pw_scatter_s_c1d_r3d
9097
9098
9099
9100
9101
9102
9103
9104
9105! **************************************************************************************************
9106!> \brief Generic function for 3d FFT of a coefficient_type or pw_r3d_rs_type
9107!> \param pw1 ...
9108!> \param pw2 ...
9109!> \param debug ...
9110!> \par History
9111!> JGH (30-12-2000): New setup of functions and adaptation to parallelism
9112!> JGH (04-01-2001): Moved routine from pws to this module, only covers
9113!> pw_types, no more coefficient types
9114!> \author apsi
9115!> \note
9116!> fft_wrap_pw1pw2
9117! **************************************************************************************************
9118 SUBROUTINE fft_wrap_pw1pw2_c1d_c3d_gs_rs (pw1, pw2, debug)
9119
9120 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
9121 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw2
9122 LOGICAL, INTENT(IN), OPTIONAL :: debug
9123
9124 CHARACTER(len=*), PARAMETER :: routineN = 'fft_wrap_pw1pw2'
9125
9126 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, POINTER :: grays
9127 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, POINTER :: c_in, c_out
9128 INTEGER :: handle, handle2, my_pos, nrays, &
9129 out_unit
9130 INTEGER, DIMENSION(:), POINTER :: n
9131 LOGICAL :: test
9132
9133 CALL timeset(routinen, handle2)
9134 out_unit = cp_logger_get_default_io_unit()
9135 CALL timeset(routinen//"_"//trim(adjustl(cp_to_string( &
9136 ceiling(pw1%pw_grid%cutoff/10)*10))), handle)
9137
9138 NULLIFY (c_in)
9139 NULLIFY (c_out)
9140
9141 IF (PRESENT(debug)) THEN
9142 test = debug
9143 ELSE
9144 test = .false.
9145 END IF
9146
9147 !..check if grids are compatible
9148 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
9149 IF (pw1%pw_grid%dvol /= pw2%pw_grid%dvol) THEN
9150 cpabort("PW grids not compatible")
9151 END IF
9152 IF (pw1%pw_grid%para%group /= pw2%pw_grid%para%group) THEN
9153 cpabort("PW grids have not compatible MPI groups")
9154 END IF
9155 END IF
9156
9157 n => pw1%pw_grid%npts
9158
9159 IF (pw1%pw_grid%para%mode == pw_mode_local) THEN
9160
9161 !
9162 !..replicated data, use local FFT
9163 !
9164
9165 IF (test .AND. out_unit > 0) THEN
9166 WRITE (out_unit, '(A)') " FFT Protocol "
9167 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "BWFFT"
9168 WRITE (out_unit, '(A,T66,A)') " in space ", "RECIPROCALSPACE"
9169 WRITE (out_unit, '(A,T66,A)') " out space ", "RECIPROCALSPACE"
9170 END IF
9171
9172 c_out => pw2%array
9173 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " PW_SCATTER : 3d -> 1d "
9174 CALL pw_scatter_s_c1d_c3d(pw1, c_out)
9175 CALL fft3d(bwfft, n, c_out, debug=test)
9176
9177 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " End of FFT Protocol "
9178
9179 ELSE
9180
9181 !
9182 !..parallel FFT
9183 !
9184
9185 IF (test .AND. out_unit > 0) THEN
9186 WRITE (out_unit, '(A)') " FFT Protocol "
9187 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "BWFFT"
9188 WRITE (out_unit, '(A,T66,A)') " in space ", "RECIPROCALSPACE"
9189 WRITE (out_unit, '(A,T66,A)') " out space ", "RECIPROCALSPACE"
9190 END IF
9191
9192 my_pos = pw1%pw_grid%para%group%mepos
9193 nrays = pw1%pw_grid%para%nyzray(my_pos)
9194 grays => pw1%pw_grid%grays
9195
9196 !..prepare input
9197 IF (test .AND. out_unit > 0) &
9198 WRITE (out_unit, '(A)') " PW_SCATTER : 2d -> 1d "
9199 grays = z_zero
9200 CALL pw_scatter_p_c1d (pw1, grays)
9201 c_in => pw2%array
9202 !..transform
9203 IF (pw1%pw_grid%para%ray_distribution) THEN
9204 CALL fft3d(bwfft, n, c_in, grays, pw1%pw_grid%para%group, &
9205 pw1%pw_grid%para%yzp, pw1%pw_grid%para%nyzray, &
9206 pw1%pw_grid%para%bo, debug=test)
9207 ELSE
9208 CALL fft3d(bwfft, n, c_in, grays, pw1%pw_grid%para%group, &
9209 pw1%pw_grid%para%bo, debug=test)
9210 END IF
9211 !..prepare output (nothing to do)
9212 END IF
9213
9214 IF (test .AND. out_unit > 0) THEN
9215 WRITE (out_unit, '(A)') " End of FFT Protocol "
9216 END IF
9217
9218 CALL timestop(handle)
9219 CALL timestop(handle2)
9220
9221 END SUBROUTINE fft_wrap_pw1pw2_c1d_c3d_gs_rs
9222
9223
9224
9225! **************************************************************************************************
9226!> \brief Gathers the pw vector from a 3d data field
9227!> \param pw ...
9228!> \param c ...
9229!> \param scale ...
9230!> \par History
9231!> none
9232!> \author JGH
9233! **************************************************************************************************
9234 SUBROUTINE pw_gather_s_c1d_c3d_2(pw1, pw2, scale)
9235
9236 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
9237 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw2
9238 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
9239
9240 CALL pw_gather_s_c1d_c3d (pw2, pw1%array, scale)
9241
9242 END SUBROUTINE pw_gather_s_c1d_c3d_2
9243
9244! **************************************************************************************************
9245!> \brief Gathers the pw vector from a 3d data field
9246!> \param pw ...
9247!> \param c ...
9248!> \param scale ...
9249!> \par History
9250!> none
9251!> \author JGH
9252! **************************************************************************************************
9253 SUBROUTINE pw_gather_s_c1d_c3d (pw, c, scale)
9254
9255 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
9256 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, INTENT(IN), TARGET :: c
9257 REAL(kind=dp), INTENT(IN), OPTIONAL :: scale
9258
9259 CHARACTER(len=*), PARAMETER :: routinen = 'pw_gather_s'
9260
9261 INTEGER :: gpt, handle
9262 COMPLEX(KIND=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
9263
9264 CALL timeset(routinen, handle)
9265
9266 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
9267 c_1d(1:SIZE(c)) => c
9268 associate(ngpts => SIZE(pw%pw_grid%gsq), g_hatmap => pw%pw_grid%g_hatmap)
9269
9270 IF (PRESENT(scale)) THEN
9271!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
9272 DO gpt = 1, ngpts
9273 pw%array(gpt) = scale* c_1d(g_hatmap(gpt, 1) + 1)
9274 END DO
9275!$OMP END PARALLEL DO
9276 ELSE
9277!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
9278 DO gpt = 1, ngpts
9279 pw%array(gpt) = c_1d(g_hatmap(gpt, 1) + 1)
9280 END DO
9281!$OMP END PARALLEL DO
9282 END IF
9283
9284 END associate
9285
9286 CALL timestop(handle)
9287
9288 END SUBROUTINE pw_gather_s_c1d_c3d
9289
9290! **************************************************************************************************
9291!> \brief Scatters a pw vector to a 3d data field
9292!> \param pw ...
9293!> \param c ...
9294!> \param scale ...
9295!> \par History
9296!> none
9297!> \author JGH
9298! **************************************************************************************************
9299 SUBROUTINE pw_scatter_s_c1d_c3d_2(pw1, pw2, scale)
9300
9301 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw1
9302 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw2
9303 REAL(KIND=dp), INTENT(IN), OPTIONAL :: scale
9304
9305 CALL pw_scatter_s_c1d_c3d (pw1, pw2%array, scale)
9306
9307 END SUBROUTINE pw_scatter_s_c1d_c3d_2
9308
9309! **************************************************************************************************
9310!> \brief Scatters a pw vector to a 3d data field
9311!> \param pw ...
9312!> \param c ...
9313!> \param scale ...
9314!> \par History
9315!> none
9316!> \author JGH
9317! **************************************************************************************************
9318 SUBROUTINE pw_scatter_s_c1d_c3d (pw, c, scale)
9319
9320 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
9321 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, INTENT(INOUT), TARGET :: c
9322 REAL(kind=dp), INTENT(IN), OPTIONAL :: scale
9323
9324 CHARACTER(len=*), PARAMETER :: routinen = 'pw_scatter_s'
9325
9326 INTEGER :: gpt, handle
9327 COMPLEX(KIND=dp), CONTIGUOUS, DIMENSION(:), POINTER :: c_1d
9328
9329 CALL timeset(routinen, handle)
9330
9331 ! Rank-1 pointer remap of contiguous c for flat g_hatmap indexing
9332 c_1d(1:SIZE(c)) => c
9333 associate(g_hatmap => pw%pw_grid%g_hatmap, ngpts => SIZE(pw%pw_grid%gsq))
9334
9335 ! should only zero the unused bits (but the zero is needed)
9336 IF (.NOT. PRESENT(scale)) c = 0.0_dp
9337
9338 IF (PRESENT(scale)) THEN
9339!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
9340 DO gpt = 1, ngpts
9341 c_1d(g_hatmap(gpt, 1) + 1) = scale* pw%array(gpt)
9342 END DO
9343!$OMP END PARALLEL DO
9344 ELSE
9345!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
9346 DO gpt = 1, ngpts
9347 c_1d(g_hatmap(gpt, 1) + 1) = pw%array(gpt)
9348 END DO
9349!$OMP END PARALLEL DO
9350 END IF
9351
9352 IF (pw%pw_grid%grid_span == halfspace) THEN
9353
9354 IF (PRESENT(scale)) THEN
9355!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw, scale)
9356 DO gpt = 1, ngpts
9357 c_1d(g_hatmap(gpt, 2) + 1) = scale*conjg( pw%array(gpt))
9358 END DO
9359!$OMP END PARALLEL DO
9360 ELSE
9361!$OMP PARALLEL DO PRIVATE(gpt) DEFAULT(NONE) SHARED(c_1d, pw)
9362 DO gpt = 1, ngpts
9363 c_1d(g_hatmap(gpt, 2) + 1) = conjg( pw%array(gpt))
9364 END DO
9365!$OMP END PARALLEL DO
9366 END IF
9367
9368 END IF
9369
9370 END associate
9371
9372 CALL timestop(handle)
9373
9374 END SUBROUTINE pw_scatter_s_c1d_c3d
9375
9376
9377
9378
9379
9380
9381
9382
9383! **************************************************************************************************
9384!> \brief Generic function for 3d FFT of a coefficient_type or pw_r3d_rs_type
9385!> \param pw1 ...
9386!> \param pw2 ...
9387!> \param debug ...
9388!> \par History
9389!> JGH (30-12-2000): New setup of functions and adaptation to parallelism
9390!> JGH (04-01-2001): Moved routine from pws to this module, only covers
9391!> pw_types, no more coefficient types
9392!> \author apsi
9393!> \note
9394!> fft_wrap_pw1pw2
9395! **************************************************************************************************
9396 SUBROUTINE fft_wrap_pw1pw2_c3d_r3d_gs_rs (pw1, pw2, debug)
9397
9398 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
9399 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw2
9400 LOGICAL, INTENT(IN), OPTIONAL :: debug
9401
9402 CHARACTER(len=*), PARAMETER :: routineN = 'fft_wrap_pw1pw2'
9403
9404 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, POINTER :: grays
9405 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, POINTER :: c_in, c_out
9406 INTEGER :: handle, handle2, my_pos, nrays, &
9407 out_unit
9408 INTEGER, DIMENSION(:), POINTER :: n
9409 LOGICAL :: test
9410
9411 CALL timeset(routinen, handle2)
9412 out_unit = cp_logger_get_default_io_unit()
9413 CALL timeset(routinen//"_"//trim(adjustl(cp_to_string( &
9414 ceiling(pw1%pw_grid%cutoff/10)*10))), handle)
9415
9416 NULLIFY (c_in)
9417 NULLIFY (c_out)
9418
9419 IF (PRESENT(debug)) THEN
9420 test = debug
9421 ELSE
9422 test = .false.
9423 END IF
9424
9425 !..check if grids are compatible
9426 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
9427 IF (pw1%pw_grid%dvol /= pw2%pw_grid%dvol) THEN
9428 cpabort("PW grids not compatible")
9429 END IF
9430 IF (pw1%pw_grid%para%group /= pw2%pw_grid%para%group) THEN
9431 cpabort("PW grids have not compatible MPI groups")
9432 END IF
9433 END IF
9434
9435 n => pw1%pw_grid%npts
9436
9437 IF (pw1%pw_grid%para%mode == pw_mode_local) THEN
9438
9439 !
9440 !..replicated data, use local FFT
9441 !
9442
9443 IF (test .AND. out_unit > 0) THEN
9444 WRITE (out_unit, '(A)') " FFT Protocol "
9445 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "BWFFT"
9446 WRITE (out_unit, '(A,T66,A)') " in space ", "RECIPROCALSPACE"
9447 WRITE (out_unit, '(A,T66,A)') " out space ", "RECIPROCALSPACE"
9448 END IF
9449
9450 c_in => pw1%array
9451 ALLOCATE (c_out(n(1), n(2), n(3)))
9452 CALL fft3d(bwfft, n, c_in, c_out, debug=test)
9453 ! use real part only
9454 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " REAL part "
9455 pw2%array = real(c_out, kind=dp)
9456 DEALLOCATE (c_out)
9457
9458 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " End of FFT Protocol "
9459
9460 ELSE
9461
9462 !
9463 !..parallel FFT
9464 !
9465
9466 IF (test .AND. out_unit > 0) THEN
9467 WRITE (out_unit, '(A)') " FFT Protocol "
9468 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "BWFFT"
9469 WRITE (out_unit, '(A,T66,A)') " in space ", "RECIPROCALSPACE"
9470 WRITE (out_unit, '(A,T66,A)') " out space ", "RECIPROCALSPACE"
9471 END IF
9472
9473 my_pos = pw1%pw_grid%para%group%mepos
9474 nrays = pw1%pw_grid%para%nyzray(my_pos)
9475 grays => pw1%pw_grid%grays
9476
9477 END IF
9478
9479 IF (test .AND. out_unit > 0) THEN
9480 WRITE (out_unit, '(A)') " End of FFT Protocol "
9481 END IF
9482
9483 CALL timestop(handle)
9484 CALL timestop(handle2)
9485
9486 END SUBROUTINE fft_wrap_pw1pw2_c3d_r3d_gs_rs
9487
9488
9489
9490
9491! **************************************************************************************************
9492!> \brief Generic function for 3d FFT of a coefficient_type or pw_r3d_rs_type
9493!> \param pw1 ...
9494!> \param pw2 ...
9495!> \param debug ...
9496!> \par History
9497!> JGH (30-12-2000): New setup of functions and adaptation to parallelism
9498!> JGH (04-01-2001): Moved routine from pws to this module, only covers
9499!> pw_types, no more coefficient types
9500!> \author apsi
9501!> \note
9502!> fft_wrap_pw1pw2
9503! **************************************************************************************************
9504 SUBROUTINE fft_wrap_pw1pw2_c3d_c1d_rs_gs (pw1, pw2, debug)
9505
9506 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw1
9507 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw2
9508 LOGICAL, INTENT(IN), OPTIONAL :: debug
9509
9510 CHARACTER(len=*), PARAMETER :: routineN = 'fft_wrap_pw1pw2'
9511
9512 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, POINTER :: grays
9513 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, POINTER :: c_in, c_out
9514 INTEGER :: handle, handle2, my_pos, nrays, &
9515 out_unit
9516 INTEGER, DIMENSION(:), POINTER :: n
9517 LOGICAL :: test
9518
9519 CALL timeset(routinen, handle2)
9520 out_unit = cp_logger_get_default_io_unit()
9521 CALL timeset(routinen//"_"//trim(adjustl(cp_to_string( &
9522 ceiling(pw1%pw_grid%cutoff/10)*10))), handle)
9523
9524 NULLIFY (c_in)
9525 NULLIFY (c_out)
9526
9527 IF (PRESENT(debug)) THEN
9528 test = debug
9529 ELSE
9530 test = .false.
9531 END IF
9532
9533 !..check if grids are compatible
9534 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
9535 IF (pw1%pw_grid%dvol /= pw2%pw_grid%dvol) THEN
9536 cpabort("PW grids not compatible")
9537 END IF
9538 IF (pw1%pw_grid%para%group /= pw2%pw_grid%para%group) THEN
9539 cpabort("PW grids have not compatible MPI groups")
9540 END IF
9541 END IF
9542
9543 n => pw1%pw_grid%npts
9544
9545 IF (pw1%pw_grid%para%mode == pw_mode_local) THEN
9546
9547 !
9548 !..replicated data, use local FFT
9549 !
9550
9551 IF (test .AND. out_unit > 0) THEN
9552 WRITE (out_unit, '(A)') " FFT Protocol "
9553 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "FWFFT"
9554 WRITE (out_unit, '(A,T72,A)') " in space ", "REALSPACE"
9555 WRITE (out_unit, '(A,T72,A)') " out space ", "REALSPACE"
9556 END IF
9557
9558 c_in => pw1%array
9559 ALLOCATE (c_out(n(1), n(2), n(3)))
9560 ! transform
9561 CALL fft3d(fwfft, n, c_in, c_out, debug=test)
9562 ! gather results
9563 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " PW_GATHER : 3d -> 1d "
9564 CALL pw_gather_s_c1d_c3d(pw2, c_out)
9565 DEALLOCATE (c_out)
9566
9567 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " End of FFT Protocol "
9568
9569 ELSE
9570
9571 !
9572 !..parallel FFT
9573 !
9574
9575 IF (test .AND. out_unit > 0) THEN
9576 WRITE (out_unit, '(A)') " FFT Protocol "
9577 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "FWFFT"
9578 WRITE (out_unit, '(A,T72,A)') " in space ", "REALSPACE"
9579 WRITE (out_unit, '(A,T72,A)') " out space ", "REALSPACE"
9580 END IF
9581
9582 my_pos = pw1%pw_grid%para%group%mepos
9583 nrays = pw1%pw_grid%para%nyzray(my_pos)
9584 grays => pw1%pw_grid%grays
9585
9586 !..prepare input
9587 c_in => pw1%array
9588 grays = z_zero
9589 !..transform
9590 IF (pw1%pw_grid%para%ray_distribution) THEN
9591 CALL fft3d(fwfft, n, c_in, grays, pw1%pw_grid%para%group, &
9592 pw1%pw_grid%para%yzp, pw1%pw_grid%para%nyzray, &
9593 pw1%pw_grid%para%bo, debug=test)
9594 ELSE
9595 CALL fft3d(fwfft, n, c_in, grays, pw1%pw_grid%para%group, &
9596 pw1%pw_grid%para%bo, debug=test)
9597 END IF
9598 !..prepare output
9599 IF (test .AND. out_unit > 0) &
9600 WRITE (out_unit, '(A)') " PW_GATHER : 2d -> 1d "
9601 CALL pw_gather_p_c1d (pw2, grays)
9602 END IF
9603
9604 IF (test .AND. out_unit > 0) THEN
9605 WRITE (out_unit, '(A)') " End of FFT Protocol "
9606 END IF
9607
9608 CALL timestop(handle)
9609 CALL timestop(handle2)
9610
9611 END SUBROUTINE fft_wrap_pw1pw2_c3d_c1d_rs_gs
9612
9613
9614
9615
9616
9617! **************************************************************************************************
9618!> \brief Generic function for 3d FFT of a coefficient_type or pw_r3d_rs_type
9619!> \param pw1 ...
9620!> \param pw2 ...
9621!> \param debug ...
9622!> \par History
9623!> JGH (30-12-2000): New setup of functions and adaptation to parallelism
9624!> JGH (04-01-2001): Moved routine from pws to this module, only covers
9625!> pw_types, no more coefficient types
9626!> \author apsi
9627!> \note
9628!> fft_wrap_pw1pw2
9629! **************************************************************************************************
9630 SUBROUTINE fft_wrap_pw1pw2_c3d_c3d_rs_gs (pw1, pw2, debug)
9631
9632 TYPE(pw_c3d_rs_type), INTENT(IN) :: pw1
9633 TYPE(pw_c3d_gs_type), INTENT(INOUT) :: pw2
9634 LOGICAL, INTENT(IN), OPTIONAL :: debug
9635
9636 CHARACTER(len=*), PARAMETER :: routineN = 'fft_wrap_pw1pw2'
9637
9638 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, POINTER :: grays
9639 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, POINTER :: c_in, c_out
9640 INTEGER :: handle, handle2, my_pos, nrays, &
9641 out_unit
9642 INTEGER, DIMENSION(:), POINTER :: n
9643 LOGICAL :: test
9644
9645 CALL timeset(routinen, handle2)
9646 out_unit = cp_logger_get_default_io_unit()
9647 CALL timeset(routinen//"_"//trim(adjustl(cp_to_string( &
9648 ceiling(pw1%pw_grid%cutoff/10)*10))), handle)
9649
9650 NULLIFY (c_in)
9651 NULLIFY (c_out)
9652
9653 IF (PRESENT(debug)) THEN
9654 test = debug
9655 ELSE
9656 test = .false.
9657 END IF
9658
9659 !..check if grids are compatible
9660 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
9661 IF (pw1%pw_grid%dvol /= pw2%pw_grid%dvol) THEN
9662 cpabort("PW grids not compatible")
9663 END IF
9664 IF (pw1%pw_grid%para%group /= pw2%pw_grid%para%group) THEN
9665 cpabort("PW grids have not compatible MPI groups")
9666 END IF
9667 END IF
9668
9669 n => pw1%pw_grid%npts
9670
9671 IF (pw1%pw_grid%para%mode == pw_mode_local) THEN
9672
9673 !
9674 !..replicated data, use local FFT
9675 !
9676
9677 IF (test .AND. out_unit > 0) THEN
9678 WRITE (out_unit, '(A)') " FFT Protocol "
9679 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "FWFFT"
9680 WRITE (out_unit, '(A,T72,A)') " in space ", "REALSPACE"
9681 WRITE (out_unit, '(A,T72,A)') " out space ", "REALSPACE"
9682 END IF
9683
9684 c_in => pw1%array
9685 c_out => pw2%array
9686 CALL fft3d(fwfft, n, c_in, c_out, debug=test)
9687
9688 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " End of FFT Protocol "
9689
9690 ELSE
9691
9692 !
9693 !..parallel FFT
9694 !
9695
9696 IF (test .AND. out_unit > 0) THEN
9697 WRITE (out_unit, '(A)') " FFT Protocol "
9698 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "FWFFT"
9699 WRITE (out_unit, '(A,T72,A)') " in space ", "REALSPACE"
9700 WRITE (out_unit, '(A,T72,A)') " out space ", "REALSPACE"
9701 END IF
9702
9703 my_pos = pw1%pw_grid%para%group%mepos
9704 nrays = pw1%pw_grid%para%nyzray(my_pos)
9705 grays => pw1%pw_grid%grays
9706
9707 END IF
9708
9709 IF (test .AND. out_unit > 0) THEN
9710 WRITE (out_unit, '(A)') " End of FFT Protocol "
9711 END IF
9712
9713 CALL timestop(handle)
9714 CALL timestop(handle2)
9715
9716 END SUBROUTINE fft_wrap_pw1pw2_c3d_c3d_rs_gs
9717
9718! **************************************************************************************************
9719!> \brief Generic function for 3d FFT of a coefficient_type or pw_r3d_rs_type
9720!> \param pw1 ...
9721!> \param pw2 ...
9722!> \param debug ...
9723!> \par History
9724!> JGH (30-12-2000): New setup of functions and adaptation to parallelism
9725!> JGH (04-01-2001): Moved routine from pws to this module, only covers
9726!> pw_types, no more coefficient types
9727!> \author apsi
9728!> \note
9729!> fft_wrap_pw1pw2
9730! **************************************************************************************************
9731 SUBROUTINE fft_wrap_pw1pw2_c3d_c3d_gs_rs (pw1, pw2, debug)
9732
9733 TYPE(pw_c3d_gs_type), INTENT(IN) :: pw1
9734 TYPE(pw_c3d_rs_type), INTENT(INOUT) :: pw2
9735 LOGICAL, INTENT(IN), OPTIONAL :: debug
9736
9737 CHARACTER(len=*), PARAMETER :: routineN = 'fft_wrap_pw1pw2'
9738
9739 COMPLEX(KIND=dp), DIMENSION(:, :), CONTIGUOUS, POINTER :: grays
9740 COMPLEX(KIND=dp), DIMENSION(:, :, :), CONTIGUOUS, POINTER :: c_in, c_out
9741 INTEGER :: handle, handle2, my_pos, nrays, &
9742 out_unit
9743 INTEGER, DIMENSION(:), POINTER :: n
9744 LOGICAL :: test
9745
9746 CALL timeset(routinen, handle2)
9747 out_unit = cp_logger_get_default_io_unit()
9748 CALL timeset(routinen//"_"//trim(adjustl(cp_to_string( &
9749 ceiling(pw1%pw_grid%cutoff/10)*10))), handle)
9750
9751 NULLIFY (c_in)
9752 NULLIFY (c_out)
9753
9754 IF (PRESENT(debug)) THEN
9755 test = debug
9756 ELSE
9757 test = .false.
9758 END IF
9759
9760 !..check if grids are compatible
9761 IF (.NOT. ASSOCIATED(pw1%pw_grid, pw2%pw_grid)) THEN
9762 IF (pw1%pw_grid%dvol /= pw2%pw_grid%dvol) THEN
9763 cpabort("PW grids not compatible")
9764 END IF
9765 IF (pw1%pw_grid%para%group /= pw2%pw_grid%para%group) THEN
9766 cpabort("PW grids have not compatible MPI groups")
9767 END IF
9768 END IF
9769
9770 n => pw1%pw_grid%npts
9771
9772 IF (pw1%pw_grid%para%mode == pw_mode_local) THEN
9773
9774 !
9775 !..replicated data, use local FFT
9776 !
9777
9778 IF (test .AND. out_unit > 0) THEN
9779 WRITE (out_unit, '(A)') " FFT Protocol "
9780 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "BWFFT"
9781 WRITE (out_unit, '(A,T66,A)') " in space ", "RECIPROCALSPACE"
9782 WRITE (out_unit, '(A,T66,A)') " out space ", "RECIPROCALSPACE"
9783 END IF
9784
9785 c_in => pw1%array
9786 c_out => pw2%array
9787 CALL fft3d(bwfft, n, c_in, c_out, debug=test)
9788
9789 IF (test .AND. out_unit > 0) WRITE (out_unit, '(A)') " End of FFT Protocol "
9790
9791 ELSE
9792
9793 !
9794 !..parallel FFT
9795 !
9796
9797 IF (test .AND. out_unit > 0) THEN
9798 WRITE (out_unit, '(A)') " FFT Protocol "
9799 WRITE (out_unit, '(A,T76,A)') " Transform direction ", "BWFFT"
9800 WRITE (out_unit, '(A,T66,A)') " in space ", "RECIPROCALSPACE"
9801 WRITE (out_unit, '(A,T66,A)') " out space ", "RECIPROCALSPACE"
9802 END IF
9803
9804 my_pos = pw1%pw_grid%para%group%mepos
9805 nrays = pw1%pw_grid%para%nyzray(my_pos)
9806 grays => pw1%pw_grid%grays
9807
9808 END IF
9809
9810 IF (test .AND. out_unit > 0) THEN
9811 WRITE (out_unit, '(A)') " End of FFT Protocol "
9812 END IF
9813
9814 CALL timestop(handle)
9815 CALL timestop(handle2)
9816
9817 END SUBROUTINE fft_wrap_pw1pw2_c3d_c3d_gs_rs
9818
9819
9820
9821! **************************************************************************************************
9822!> \brief Multiply all data points with a Gaussian damping factor
9823!> Needed for longrange Coulomb potential
9824!> V(\vec r)=erf(omega*r)/r
9825!> V(\vec g)=\frac{4*\pi}{g**2}*exp(-g**2/omega**2)
9826!> \param pw ...
9827!> \param omega ...
9828!> \par History
9829!> Frederick Stein (12-04-2019) created
9830!> \author Frederick Stein (12-Apr-2019)
9831!> \note
9832!> Performs a Gaussian damping
9833! **************************************************************************************************
9834 SUBROUTINE pw_gauss_damp(pw, omega)
9835
9836 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
9837 REAL(kind=dp), INTENT(IN) :: omega
9838
9839 CHARACTER(len=*), PARAMETER :: routinen = 'pw_gauss_damp'
9840
9841 INTEGER :: handle, i
9842 REAL(kind=dp) :: omega_2, tmp
9843
9844 CALL timeset(routinen, handle)
9845 cpassert(omega >= 0)
9846
9847 omega_2 = omega*omega
9848 omega_2 = 0.25_dp/omega_2
9849
9850!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,tmp) SHARED(pw,omega_2)
9851 DO i = 1, SIZE(pw%array)
9852 tmp = exp(-pw%pw_grid%gsq(i)*omega_2)
9853 pw%array(i) = pw%array(i)*tmp
9854 END DO
9855!$OMP END PARALLEL DO
9856
9857 CALL timestop(handle)
9858
9859 END SUBROUTINE pw_gauss_damp
9860
9861! **************************************************************************************************
9862!> \brief Multiply all data points with the logarithmic derivative of a Gaussian
9863!> \param pw ...
9864!> \param omega ...
9865!> \note
9866!> Performs a Gaussian damping
9867! **************************************************************************************************
9868 SUBROUTINE pw_log_deriv_gauss(pw, omega)
9869
9870 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
9871 REAL(kind=dp), INTENT(IN) :: omega
9872
9873 CHARACTER(len=*), PARAMETER :: routinen = 'pw_log_deriv_gauss'
9874
9875 INTEGER :: handle, i
9876 REAL(kind=dp) :: omega_2, tmp
9877
9878 CALL timeset(routinen, handle)
9879 cpassert(omega >= 0)
9880
9881 omega_2 = omega*omega
9882 omega_2 = 0.25_dp/omega_2
9883
9884!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,tmp) SHARED(pw,omega_2)
9885 DO i = 1, SIZE(pw%array)
9886 tmp = 1.0_dp + omega_2*pw%pw_grid%gsq(i)
9887 pw%array(i) = pw%array(i)*tmp
9888 END DO
9889!$OMP END PARALLEL DO
9890
9891 CALL timestop(handle)
9892 END SUBROUTINE pw_log_deriv_gauss
9893
9894! **************************************************************************************************
9895!> \brief Multiply all data points with a Gaussian damping factor
9896!> Needed for longrange Coulomb potential
9897!> V(\vec r)=erf(omega*r)/r
9898!> V(\vec g)=\frac{4*\pi}{g**2}*exp(-g**2/omega**2)
9899!> \param pw ...
9900!> \param omega ...
9901!> \par History
9902!> Frederick Stein (12-04-2019) created
9903!> \author Frederick Stein (12-Apr-2019)
9904!> \note
9905!> Performs a Gaussian damping
9906! **************************************************************************************************
9907 SUBROUTINE pw_compl_gauss_damp(pw, omega)
9908
9909 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
9910 REAL(kind=dp), INTENT(IN) :: omega
9911
9912 CHARACTER(len=*), PARAMETER :: routinen = 'pw_compl_gauss_damp'
9913
9914 INTEGER :: cnt, handle, i
9915 REAL(kind=dp) :: omega_2, tmp, tmp2
9916
9917 CALL timeset(routinen, handle)
9918
9919 omega_2 = omega*omega
9920 omega_2 = 0.25_dp/omega_2
9921
9922 cnt = SIZE(pw%array)
9923
9924!$OMP PARALLEL DO PRIVATE(i, tmp, tmp2) DEFAULT(NONE) SHARED(cnt, pw,omega_2)
9925 DO i = 1, cnt
9926 tmp = -omega_2*pw%pw_grid%gsq(i)
9927 IF (abs(tmp) > 1.0e-5_dp) THEN
9928 tmp2 = 1.0_dp - exp(tmp)
9929 ELSE
9930 tmp2 = tmp + 0.5_dp*tmp*(tmp + (1.0_dp/3.0_dp)*tmp**2)
9931 END IF
9932 pw%array(i) = pw%array(i)*tmp2
9933 END DO
9934!$OMP END PARALLEL DO
9935
9936 CALL timestop(handle)
9937
9938 END SUBROUTINE pw_compl_gauss_damp
9939
9940! **************************************************************************************************
9941!> \brief Multiply all data points with the logarithmic derivative of the complementary Gaussian damping factor
9942!> \param pw ...
9943!> \param omega ...
9944!> \note
9945! **************************************************************************************************
9946 SUBROUTINE pw_log_deriv_compl_gauss(pw, omega)
9947
9948 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
9949 REAL(kind=dp), INTENT(IN) :: omega
9950
9951 CHARACTER(len=*), PARAMETER :: routinen = 'pw_log_deriv_compl_gauss'
9952
9953 INTEGER :: handle, i
9954 REAL(kind=dp) :: omega_2, tmp, tmp2
9955
9956 CALL timeset(routinen, handle)
9957
9958 omega_2 = omega*omega
9959 omega_2 = 0.25_dp/omega_2
9960
9961!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,tmp,tmp2) &
9962!$OMP SHARED(pw,omega_2)
9963 DO i = 1, SIZE(pw%array)
9964 tmp = omega_2*pw%pw_grid%gsq(i)
9965 ! For too small arguments, use the Taylor polynomial to prevent division by zero
9966 IF (abs(tmp) >= 0.003_dp) THEN
9967 tmp2 = 1.0_dp - tmp*exp(-tmp)/(1.0_dp - exp(-tmp))
9968 ELSE
9969 tmp2 = 0.5_dp*tmp - tmp**2/12.0_dp
9970 END IF
9971 pw%array(i) = pw%array(i)*tmp2
9972 END DO
9973!$OMP END PARALLEL DO
9974
9975 CALL timestop(handle)
9976
9977 END SUBROUTINE pw_log_deriv_compl_gauss
9978
9979! **************************************************************************************************
9980!> \brief Multiply all data points with a Gaussian damping factor and mixes it with the original function
9981!> Needed for mixed longrange/Coulomb potential
9982!> V(\vec r)=(a+b*erf(omega*r))/r
9983!> V(\vec g)=\frac{4*\pi}{g**2}*(a+b*exp(-g**2/omega**2))
9984!> \param pw ...
9985!> \param omega ...
9986!> \param scale_coul ...
9987!> \param scale_long ...
9988!> \par History
9989!> Frederick Stein (16-Dec-2021) created
9990!> \author Frederick Stein (16-Dec-2021)
9991!> \note
9992!> Performs a Gaussian damping
9993! **************************************************************************************************
9994 SUBROUTINE pw_gauss_damp_mix(pw, omega, scale_coul, scale_long)
9995
9996 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
9997 REAL(kind=dp), INTENT(IN) :: omega, scale_coul, scale_long
9998
9999 CHARACTER(len=*), PARAMETER :: routinen = 'pw_gauss_damp_mix'
10000
10001 INTEGER :: handle, i
10002 REAL(kind=dp) :: omega_2, tmp
10003
10004 CALL timeset(routinen, handle)
10005
10006 omega_2 = omega*omega
10007 omega_2 = 0.25_dp/omega_2
10008
10009!$OMP PARALLEL DO DEFAULT(NONE) SHARED(pw, omega_2, scale_coul, scale_long) PRIVATE(i,tmp)
10010 DO i = 1, SIZE(pw%array)
10011 tmp = scale_coul + scale_long*exp(-pw%pw_grid%gsq(i)*omega_2)
10012 pw%array(i) = pw%array(i)*tmp
10013 END DO
10014!$OMP END PARALLEL DO
10015
10016 CALL timestop(handle)
10017
10018 END SUBROUTINE pw_gauss_damp_mix
10019
10020! **************************************************************************************************
10021!> \brief Multiply all data points with the logarithmic derivative of the mixed longrange/Coulomb potential
10022!> Needed for mixed longrange/Coulomb potential
10023!> \param pw ...
10024!> \param omega ...
10025!> \param scale_coul ...
10026!> \param scale_long ...
10027!> \note
10028! **************************************************************************************************
10029 SUBROUTINE pw_log_deriv_mix_cl(pw, omega, scale_coul, scale_long)
10030
10031 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
10032 REAL(kind=dp), INTENT(IN) :: omega, scale_coul, scale_long
10033
10034 CHARACTER(len=*), PARAMETER :: routinen = 'pw_log_deriv_mix_cl'
10035
10036 INTEGER :: handle, i
10037 REAL(kind=dp) :: omega_2, tmp, tmp2
10038
10039 CALL timeset(routinen, handle)
10040
10041 omega_2 = omega*omega
10042 omega_2 = 0.25_dp/omega_2
10043
10044!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,tmp,tmp2) &
10045!$OMP SHARED(pw,omega_2,scale_long,scale_coul)
10046 DO i = 1, SIZE(pw%array)
10047 tmp = omega_2*pw%pw_grid%gsq(i)
10048 tmp2 = 1.0_dp + scale_long*tmp*exp(-tmp)/(scale_coul + scale_long*exp(-tmp))
10049 pw%array(i) = pw%array(i)*tmp2
10050 END DO
10051!$OMP END PARALLEL DO
10052
10053 CALL timestop(handle)
10054
10055 END SUBROUTINE pw_log_deriv_mix_cl
10056
10057! **************************************************************************************************
10058!> \brief Multiply all data points with a complementary cosine
10059!> Needed for truncated Coulomb potential
10060!> V(\vec r)=1/r if r<rc, 0 else
10061!> V(\vec g)=\frac{4*\pi}{g**2}*(1-cos(g*rc))
10062!> \param pw ...
10063!> \param rcutoff ...
10064!> \par History
10065!> Frederick Stein (07-06-2021) created
10066!> \author Frederick Stein (07-Jun-2021)
10067!> \note
10068!> Multiplies by complementary cosine
10069! **************************************************************************************************
10070 SUBROUTINE pw_truncated(pw, rcutoff)
10071
10072 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
10073 REAL(kind=dp), INTENT(IN) :: rcutoff
10074
10075 CHARACTER(len=*), PARAMETER :: routinen = 'pw_truncated'
10076
10077 INTEGER :: handle, i
10078 REAL(kind=dp) :: tmp, tmp2
10079
10080 CALL timeset(routinen, handle)
10081 cpassert(rcutoff >= 0)
10082
10083!$OMP PARALLEL DO PRIVATE(i,tmp,tmp2) DEFAULT(NONE) SHARED(pw, rcutoff)
10084 DO i = 1, SIZE(pw%array)
10085 tmp = sqrt(pw%pw_grid%gsq(i))*rcutoff
10086 IF (tmp >= 0.005_dp) THEN
10087 tmp2 = 1.0_dp - cos(tmp)
10088 ELSE
10089 tmp2 = tmp**2/2.0_dp*(1.0_dp - tmp**2/12.0_dp)
10090 END IF
10091 pw%array(i) = pw%array(i)*tmp2
10092 END DO
10093!$OMP END PARALLEL DO
10094
10095 CALL timestop(handle)
10096
10097 END SUBROUTINE pw_truncated
10098
10099! **************************************************************************************************
10100!> \brief Multiply all data points with the logarithmic derivative of the complementary cosine
10101!> This function is needed for virials using truncated Coulomb potentials
10102!> \param pw ...
10103!> \param rcutoff ...
10104!> \note
10105! **************************************************************************************************
10106 SUBROUTINE pw_log_deriv_trunc(pw, rcutoff)
10107
10108 TYPE(pw_c1d_gs_type), INTENT(IN) :: pw
10109 REAL(kind=dp), INTENT(IN) :: rcutoff
10110
10111 CHARACTER(len=*), PARAMETER :: routinen = 'pw_log_deriv_trunc'
10112
10113 INTEGER :: handle, i
10114 REAL(kind=dp) :: rchalf, tmp, tmp2
10115
10116 CALL timeset(routinen, handle)
10117 cpassert(rcutoff >= 0)
10118
10119 rchalf = 0.5_dp*rcutoff
10120!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(i,tmp,tmp2) &
10121!$OMP SHARED(pw,rchalf)
10122 DO i = 1, SIZE(pw%array)
10123 tmp = rchalf*sqrt(pw%pw_grid%gsq(i))
10124 ! For too small arguments, use the Taylor polynomial to prevent division by zero
10125 IF (abs(tmp) >= 0.0001_dp) THEN
10126 tmp2 = 1.0_dp - tmp/tan(tmp)
10127 ELSE
10128 tmp2 = tmp**2*(1.0_dp + tmp**2/15.0_dp)/3.0_dp
10129 END IF
10130 pw%array(i) = pw%array(i)*tmp2
10131 END DO
10132!$OMP END PARALLEL DO
10133
10134 CALL timestop(handle)
10135
10136 END SUBROUTINE pw_log_deriv_trunc
10137
10138! **************************************************************************************************
10139!> \brief Calculate the derivative of a plane wave vector
10140!> \param pw ...
10141!> \param n ...
10142!> \par History
10143!> JGH (06-10-2002) allow only for inplace derivatives
10144!> \author JGH (25-Feb-2001)
10145!> \note
10146!> Calculate the derivative dx^n(1) dy^n(2) dz^n(3) PW
10147! **************************************************************************************************
10148 SUBROUTINE pw_derive(pw, n)
10149
10150 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
10151 INTEGER, DIMENSION(3), INTENT(IN) :: n
10152
10153 CHARACTER(len=*), PARAMETER :: routinen = 'pw_derive'
10154
10155 COMPLEX(KIND=dp) :: im
10156 INTEGER :: handle, m, idx, idir
10157
10158 CALL timeset(routinen, handle)
10159
10160 IF (any(n < 0)) &
10161 cpabort("Nonnegative exponents are not supported!")
10162
10163 m = sum(n)
10164 im = gaussi**m
10165
10166 DO idir = 1, 3
10167 IF (n(idir) == 1) THEN
10168!$OMP PARALLEL DO DEFAULT(NONE) SHARED(pw,idir) PRIVATE(idx)
10169 DO idx = 1, SIZE(pw%array)
10170 pw%array(idx) = pw%array(idx)*pw%pw_grid%g(idir, idx)
10171 END DO
10172!$OMP END PARALLEL DO
10173 ELSE IF (n(idir) > 1) THEN
10174!$OMP PARALLEL DO DEFAULT(NONE) SHARED(n, pw,idir) PRIVATE(idx)
10175 DO idx = 1, SIZE(pw%array)
10176 pw%array(idx) = pw%array(idx)*pw%pw_grid%g(idir, idx)**n(idir)
10177 END DO
10178!$OMP END PARALLEL DO
10179 END IF
10180 END DO
10181
10182 ! im can take the values 1, -1, i, -i
10183 ! skip this if im == 1
10184 IF (abs(real(im, kind=dp) - 1.0_dp) > 1.0e-10_dp) THEN
10185!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(im, pw)
10186 pw%array(:) = im*pw%array(:)
10187!$OMP END PARALLEL WORKSHARE
10188 END IF
10189
10190 CALL timestop(handle)
10191
10192 END SUBROUTINE pw_derive
10193
10194! **************************************************************************************************
10195!> \brief Calculate the Laplacian of a plane wave vector
10196!> \param pw ...
10197!> \par History
10198!> Frederick Stein (01-02-2022) created
10199!> \author JGH (25-Feb-2001)
10200!> \note
10201!> Calculate the derivative DELTA PW
10202! **************************************************************************************************
10203 SUBROUTINE pw_laplace(pw)
10204
10205 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
10206
10207 CHARACTER(len=*), PARAMETER :: routinen = 'pw_laplace'
10208
10209 INTEGER :: handle
10210
10211 CALL timeset(routinen, handle)
10212
10213!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(pw)
10214 pw%array(:) = -pw%array(:)*pw%pw_grid%gsq(:)
10215!$OMP END PARALLEL WORKSHARE
10216
10217 CALL timestop(handle)
10218
10219 END SUBROUTINE pw_laplace
10220
10221! **************************************************************************************************
10222!> \brief Calculate the tensorial 2nd derivative of a plane wave vector
10223!> \param pw ...
10224!> \param pwdr2 ...
10225!> \param i ...
10226!> \param j ...
10227!> \par History
10228!> none
10229!> \author JGH (05-May-2006)
10230!> \note
10231! **************************************************************************************************
10232 SUBROUTINE pw_dr2(pw, pwdr2, i, j)
10233
10234 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw, pwdr2
10235 INTEGER, INTENT(IN) :: i, j
10236
10237 CHARACTER(len=*), PARAMETER :: routinen = 'pw_dr2'
10238
10239 INTEGER :: cnt, handle, ig
10240 REAL(kind=dp) :: gg, o3
10241
10242 CALL timeset(routinen, handle)
10243
10244 o3 = 1.0_dp/3.0_dp
10245
10246 cnt = SIZE(pw%array)
10247
10248 IF (i == j) THEN
10249!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ig,gg) SHARED(cnt, i, o3, pw, pwdr2)
10250 DO ig = 1, cnt
10251 gg = pw%pw_grid%g(i, ig)**2 - o3*pw%pw_grid%gsq(ig)
10252 pwdr2%array(ig) = gg*pw%array(ig)
10253 END DO
10254!$OMP END PARALLEL DO
10255 ELSE
10256!$OMP PARALLEL DO PRIVATE (ig) DEFAULT(NONE) SHARED(cnt, i, j, pw, pwdr2)
10257 DO ig = 1, cnt
10258 pwdr2%array(ig) = pw%array(ig)*(pw%pw_grid%g(i, ig)*pw%pw_grid%g(j, ig))
10259 END DO
10260!$OMP END PARALLEL DO
10261 END IF
10262
10263 CALL timestop(handle)
10264
10265 END SUBROUTINE pw_dr2
10266
10267! **************************************************************************************************
10268!> \brief Calculate the tensorial 2nd derivative of a plane wave vector
10269!> and divides by |G|^2. pwdr2_gg(G=0) is put to zero.
10270!> \param pw ...
10271!> \param pwdr2_gg ...
10272!> \param i ...
10273!> \param j ...
10274!> \par History
10275!> none
10276!> \author RD (20-Nov-2006)
10277!> \note
10278!> Adapted from pw_dr2
10279! **************************************************************************************************
10280 SUBROUTINE pw_dr2_gg(pw, pwdr2_gg, i, j)
10281
10282 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw, pwdr2_gg
10283 INTEGER, INTENT(IN) :: i, j
10284
10285 INTEGER :: cnt, handle, ig
10286 REAL(kind=dp) :: gg, o3
10287 CHARACTER(len=*), PARAMETER :: routinen = 'pw_dr2_gg'
10288
10289 CALL timeset(routinen, handle)
10290
10291 o3 = 1.0_dp/3.0_dp
10292
10293 cnt = SIZE(pw%array)
10294
10295 IF (i == j) THEN
10296!$OMP PARALLEL DO PRIVATE (ig) DEFAULT(NONE) PRIVATE(gg) SHARED(cnt, i, o3, pw, pwdr2_gg)
10297 DO ig = pw%pw_grid%first_gne0, cnt
10298 gg = pw%pw_grid%g(i, ig)**2 - o3*pw%pw_grid%gsq(ig)
10299 pwdr2_gg%array(ig) = gg/pw%pw_grid%gsq(ig)*pw%array(ig)
10300 END DO
10301!$OMP END PARALLEL DO
10302 ELSE
10303!$OMP PARALLEL DO PRIVATE (ig) DEFAULT(NONE) SHARED(cnt, i, j, pw, pwdr2_gg)
10304 DO ig = pw%pw_grid%first_gne0, cnt
10305 pwdr2_gg%array(ig) = pw%array(ig)*((pw%pw_grid%g(i, ig)*pw%pw_grid%g(j, ig)) &
10306 /pw%pw_grid%gsq(ig))
10307 END DO
10308!$OMP END PARALLEL DO
10309 END IF
10310
10311 IF (pw%pw_grid%have_g0) pwdr2_gg%array(1) = 0.0_dp
10312
10313 CALL timestop(handle)
10314
10315 END SUBROUTINE pw_dr2_gg
10316
10317! **************************************************************************************************
10318!> \brief Multiplies a G-space function with a smoothing factor of the form
10319!> f(|G|) = exp((ecut - G^2)/sigma)/(1+exp((ecut - G^2)/sigma))
10320!> \param pw ...
10321!> \param ecut ...
10322!> \param sigma ...
10323!> \par History
10324!> none
10325!> \author JGH (09-June-2006)
10326!> \note
10327! **************************************************************************************************
10328 SUBROUTINE pw_smoothing(pw, ecut, sigma)
10329
10330 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: pw
10331 REAL(kind=dp), INTENT(IN) :: ecut, sigma
10332
10333 CHARACTER(len=*), PARAMETER :: routinen = 'pw_smoothing'
10334
10335 INTEGER :: cnt, handle, ig
10336 REAL(kind=dp) :: arg, f
10337
10338 CALL timeset(routinen, handle)
10339
10340 cnt = SIZE(pw%array)
10341
10342!$OMP PARALLEL DO DEFAULT(NONE) PRIVATE(ig, arg, f) SHARED(cnt, ecut, pw, sigma)
10343 DO ig = 1, cnt
10344 arg = (ecut - pw%pw_grid%gsq(ig))/sigma
10345 f = exp(arg)/(1 + exp(arg))
10346 pw%array(ig) = f*pw%array(ig)
10347 END DO
10348!$OMP END PARALLEL DO
10349
10350 CALL timestop(handle)
10351
10352 END SUBROUTINE pw_smoothing
10353
10354! **************************************************************************************************
10355!> \brief ...
10356!> \param grida ...
10357!> \param gridb ...
10358!> \return ...
10359! **************************************************************************************************
10360 ELEMENTAL FUNCTION pw_compatible(grida, gridb) RESULT(compat)
10361
10362 TYPE(pw_grid_type), INTENT(IN) :: grida, gridb
10363 LOGICAL :: compat
10364
10365 compat = .false.
10366
10367 IF (grida%id_nr == gridb%id_nr) THEN
10368 compat = .true.
10369 ELSE IF (grida%reference == gridb%id_nr) THEN
10370 compat = .true.
10371 ELSE IF (gridb%reference == grida%id_nr) THEN
10372 compat = .true.
10373 END IF
10374
10375 END FUNCTION pw_compatible
10376
10377! **************************************************************************************************
10378!> \brief Calculate the structure factor for point r
10379!> \param sf ...
10380!> \param r ...
10381!> \par History
10382!> none
10383!> \author JGH (05-May-2006)
10384!> \note
10385! **************************************************************************************************
10386 SUBROUTINE pw_structure_factor(sf, r)
10387
10388 TYPE(pw_c1d_gs_type), INTENT(INOUT) :: sf
10389 REAL(kind=dp), DIMENSION(:), INTENT(IN) :: r
10390
10391 CHARACTER(len=*), PARAMETER :: routinen = 'pw_structure_factor'
10392
10393 INTEGER :: cnt, handle, ig
10394 REAL(kind=dp) :: arg
10395
10396 CALL timeset(routinen, handle)
10397
10398 cnt = SIZE(sf%array)
10399
10400!$OMP PARALLEL DO PRIVATE (ig, arg) DEFAULT(NONE) SHARED(cnt, r, sf)
10401 DO ig = 1, cnt
10402 arg = dot_product(sf%pw_grid%g(:, ig), r)
10403 sf%array(ig) = cmplx(cos(arg), -sin(arg), kind=dp)
10404 END DO
10405!$OMP END PARALLEL DO
10406
10407 CALL timestop(handle)
10408
10409 END SUBROUTINE pw_structure_factor
10410
10411 END MODULE pw_methods
idx
static GRID_HOST_DEVICE int idx(const orbital a)
Return coset index of given orbital angular momentum.
Definition grid_common.h:162
cp_log_handling::cp_to_string
Definition cp_log_handling.F:90
fft_tools::fft3d
Definition fft_tools.F:162
kahan_sum::accurate_dot_product
Definition kahan_sum.F:52
kahan_sum::accurate_sum
Definition kahan_sum.F:41
pw_methods::pw_axpy
Definition pw_methods.F:165
pw_methods::pw_copy_from_array
Definition pw_methods.F:285
pw_methods::pw_copy_to_array
Definition pw_methods.F:266
pw_methods::pw_copy
Definition pw_methods.F:146
pw_methods::pw_gather
Definition pw_methods.F:248
pw_methods::pw_integral_a2b
Definition pw_methods.F:241
pw_methods::pw_integral_ab
Definition pw_methods.F:222
pw_methods::pw_integrate_function
Definition pw_methods.F:116
pw_methods::pw_multiply_with
Definition pw_methods.F:203
pw_methods::pw_multiply
Definition pw_methods.F:184
pw_methods::pw_scale
Definition pw_methods.F:94
pw_methods::pw_scatter
Definition pw_methods.F:257
pw_methods::pw_set
Definition pw_methods.F:127
pw_methods::pw_transfer
Definition pw_methods.F:304
pw_methods::pw_write
Definition pw_methods.F:105
pw_methods::pw_zero
Definition pw_methods.F:83
cp_log_handling
various routines to log and control the output. The idea is that decisions about where to log should ...
Definition cp_log_handling.F:41
cp_log_handling::cp_logger_get_default_io_unit
integer function, public cp_logger_get_default_io_unit(logger)
returns the unit nr for the ionode (-1 on all other processors) skips as well checks if the procs cal...
Definition cp_log_handling.F:523
fft_tools
Definition fft_tools.F:29
fft_tools::bwfft
integer, parameter, public bwfft
Definition fft_tools.F:146
fft_tools::fwfft
integer, parameter, public fwfft
Definition fft_tools.F:146
kahan_sum
sums arrays of real/complex numbers with much reduced round-off as compared to a naive implementation...
Definition kahan_sum.F:29
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
machine
Machine interface based on Fortran 2003 and POSIX.
Definition machine.F:17
machine::m_memory
subroutine, public m_memory(mem)
Returns the total amount of memory [bytes] in use, if known, zero otherwise.
Definition machine.F:442
mathconstants
Definition of mathematical constants and functions.
Definition mathconstants.F:16
mathconstants::gaussi
complex(kind=dp), parameter, public gaussi
Definition mathconstants.F:143
mathconstants::z_zero
complex(kind=dp), parameter, public z_zero
Definition mathconstants.F:144
pw_copy_all
Definition pw_copy_all.F:15
pw_copy_all::pw_copy_match
subroutine, public pw_copy_match(pw1, pw2)
copy a pw type variable
Definition pw_copy_all.F:43
pw_fpga
Definition pw_fpga.F:17
pw_fpga::pw_fpga_init_bitstream
integer function, public pw_fpga_init_bitstream(n)
Invoke the pw_fpga_check_bitstream C function passing the path to the data dir.
Definition pw_fpga.F:264
pw_fpga::pw_fpga_r3dc1d_3d_dp
subroutine, public pw_fpga_r3dc1d_3d_dp(n, c_out)
perform an in-place double precision fft3d on the FPGA
Definition pw_fpga.F:147
pw_fpga::pw_fpga_r3dc1d_3d_sp
subroutine, public pw_fpga_r3dc1d_3d_sp(n, c_out)
perform an in-place single precision fft3d on the FPGA
Definition pw_fpga.F:195
pw_fpga::pw_fpga_c1dr3d_3d_dp
subroutine, public pw_fpga_c1dr3d_3d_dp(n, c_out)
perform an in-place double precision inverse fft3d on the FPGA
Definition pw_fpga.F:171
pw_fpga::pw_fpga_c1dr3d_3d_sp
subroutine, public pw_fpga_c1dr3d_3d_sp(n, c_out)
perform an in-place single precision inverse fft3d on the FPGA
Definition pw_fpga.F:229
pw_gpu
Definition pw_gpu.F:26
pw_gpu::pw_gpu_c1dr3d_3d_ps
subroutine, public pw_gpu_c1dr3d_3d_ps(pw1, pw2)
perform an parallel scatter followed by a fft on the gpu
Definition pw_gpu.F:381
pw_gpu::pw_gpu_c1dr3d_3d
subroutine, public pw_gpu_c1dr3d_3d(pw1, pw2)
perform an scatter followed by a fft on the gpu
Definition pw_gpu.F:160
pw_gpu::pw_gpu_r3dc1d_3d
subroutine, public pw_gpu_r3dc1d_3d(pw1, pw2)
perform an fft followed by a gather on the gpu
Definition pw_gpu.F:102
pw_gpu::pw_gpu_r3dc1d_3d_ps
subroutine, public pw_gpu_r3dc1d_3d_ps(pw1, pw2)
perform an parallel fft followed by a gather on the gpu
Definition pw_gpu.F:218
pw_grid_types
Definition pw_grid_types.F:13
pw_grid_types::halfspace
integer, parameter, public halfspace
Definition pw_grid_types.F:26
pw_grid_types::pw_mode_local
integer, parameter, public pw_mode_local
Definition pw_grid_types.F:27
pw_grid_types::pw_mode_distributed
integer, parameter, public pw_mode_distributed
Definition pw_grid_types.F:27
pw_methods
Definition pw_methods.F:25
pw_methods::pw_smoothing
subroutine, public pw_smoothing(pw, ecut, sigma)
Multiplies a G-space function with a smoothing factor of the form f(|G|) = exp((ecut - G^2)/sigma)/(1...
Definition pw_methods.F:10329
pw_methods::pw_log_deriv_trunc
subroutine, public pw_log_deriv_trunc(pw, rcutoff)
Multiply all data points with the logarithmic derivative of the complementary cosine This function is...
Definition pw_methods.F:10107
pw_methods::pw_gauss_damp
subroutine, public pw_gauss_damp(pw, omega)
Multiply all data points with a Gaussian damping factor Needed for longrange Coulomb potential V(\vec...
Definition pw_methods.F:9835
pw_methods::pw_log_deriv_compl_gauss
subroutine, public pw_log_deriv_compl_gauss(pw, omega)
Multiply all data points with the logarithmic derivative of the complementary Gaussian damping factor...
Definition pw_methods.F:9947
pw_methods::pw_dr2_gg
subroutine, public pw_dr2_gg(pw, pwdr2_gg, i, j)
Calculate the tensorial 2nd derivative of a plane wave vector and divides by |G|^2....
Definition pw_methods.F:10281
pw_methods::pw_laplace
subroutine, public pw_laplace(pw)
Calculate the Laplacian of a plane wave vector.
Definition pw_methods.F:10204
pw_methods::pw_log_deriv_gauss
subroutine, public pw_log_deriv_gauss(pw, omega)
Multiply all data points with the logarithmic derivative of a Gaussian.
Definition pw_methods.F:9869
pw_methods::pw_gauss_damp_mix
subroutine, public pw_gauss_damp_mix(pw, omega, scale_coul, scale_long)
Multiply all data points with a Gaussian damping factor and mixes it with the original function Neede...
Definition pw_methods.F:9995
pw_methods::pw_truncated
subroutine, public pw_truncated(pw, rcutoff)
Multiply all data points with a complementary cosine Needed for truncated Coulomb potential V(\vec r)...
Definition pw_methods.F:10071
pw_methods::do_accurate_sum
integer, parameter, public do_accurate_sum
Definition pw_methods.F:80
pw_methods::do_standard_sum
integer, parameter, public do_standard_sum
Definition pw_methods.F:80
pw_methods::pw_derive
subroutine, public pw_derive(pw, n)
Calculate the derivative of a plane wave vector.
Definition pw_methods.F:10149
pw_methods::pw_structure_factor
subroutine, public pw_structure_factor(sf, r)
Calculate the structure factor for point r.
Definition pw_methods.F:10387
pw_methods::pw_compl_gauss_damp
subroutine, public pw_compl_gauss_damp(pw, omega)
Multiply all data points with a Gaussian damping factor Needed for longrange Coulomb potential V(\vec...
Definition pw_methods.F:9908
pw_methods::pw_log_deriv_mix_cl
subroutine, public pw_log_deriv_mix_cl(pw, omega, scale_coul, scale_long)
Multiply all data points with the logarithmic derivative of the mixed longrange/Coulomb potential Nee...
Definition pw_methods.F:10030
pw_methods::pw_dr2
subroutine, public pw_dr2(pw, pwdr2, i, j)
Calculate the tensorial 2nd derivative of a plane wave vector.
Definition pw_methods.F:10233
pw_types
Definition pw_types.F:24
pw_grid_types::pw_grid_type
Definition pw_grid_types.F:53
pw_types::pw_c1d_gs_type
Definition pw_types.F:127
pw_types::pw_c1d_rs_type
Definition pw_types.F:75
pw_types::pw_c3d_gs_type
Definition pw_types.F:140
pw_types::pw_c3d_rs_type
Definition pw_types.F:88
pw_types::pw_r1d_gs_type
Definition pw_types.F:101
pw_types::pw_r1d_rs_type
Definition pw_types.F:49
pw_types::pw_r3d_gs_type
Definition pw_types.F:114
pw_types::pw_r3d_rs_type
Definition pw_types.F:62