Line data Source code
1 : !!****m* ABINIT/m_FFT_prof
2 : !! NAME
3 : !! m_FFT_prof
4 : !!
5 : !! COPYRIGHT
6 : !! Copyright (C) 2008-2026 ABINIT group (MG)
7 : !! This file is distributed under the terms of the
8 : !! GNU General Public License, see ~abinit/COPYING
9 : !! or http://www.gnu.org/copyleft/gpl.txt .
10 : !!
11 : !! SOURCE
12 :
13 : #if defined HAVE_CONFIG_H
14 : #include "config.h"
15 : #endif
16 :
17 : #include "abi_common.h"
18 :
19 : module m_FFT_prof
20 :
21 : use defs_basis
22 : use m_xomp
23 : use m_errors
24 : use m_abicore
25 : use m_fftw3
26 : use m_fft
27 : use m_distribfft
28 :
29 : use defs_abitypes, only : MPI_type
30 : use m_fstrings, only : sjoin, itoa
31 : use m_numeric_tools, only : arth
32 : use m_time, only : cwtime
33 : use m_io_tools, only : open_file
34 : use m_geometry, only : metric
35 : use m_hide_blas, only : xcopy
36 : use m_cgtools, only : set_istwfk
37 : use m_fftcore, only : get_kg, print_ngfft, fftalg_info, kgindex, getng, sphereboundary
38 : use m_fft_mesh, only : calc_eigr, calc_ceigr
39 : use m_mpinfo, only : nullify_mpi_enreg, destroy_mpi_enreg, copy_mpi_enreg, initmpi_seq
40 : use m_oscillators, only : rho_tw_g
41 :
42 : implicit none
43 :
44 : private
45 :
46 : integer,private,parameter :: TNAME_LEN=100
47 : !!***
48 :
49 : !----------------------------------------------------------------------
50 :
51 : public :: fftprof_ncalls_per_test
52 :
53 : ! Routines for benchmarking
54 : public :: prof_fourdp
55 : public :: prof_fourwf
56 : public :: prof_rhotwg
57 :
58 : !----------------------------------------------------------------------
59 :
60 : !!****t* m_fft_mesh/FFT_test_t
61 : !! NAME
62 : !! FFT_test_t
63 : !!
64 : !! FUNCTION
65 : !! Parameters passed to the FFT routines used in abinit (fourdp|fourwf).
66 : !!
67 : !! SOURCE
68 :
69 : type, public :: FFT_test_t
70 :
71 : integer :: available = 0
72 : integer :: istwf_k = -1
73 : integer :: mgfft = -1
74 : integer :: ndat = -1
75 : integer :: nfft = -1
76 : integer :: nthreads = 1
77 : integer :: npw_k = -1
78 : integer :: npw_kout = -1
79 : integer :: paral_kgb = -1
80 : integer :: gpu_option = 0
81 :
82 : real(dp) :: ecut=zero
83 : integer :: ngfft(18)=-1
84 :
85 : real(dp) :: kpoint(3) = [zero,zero,zero]
86 : real(dp) :: rprimd(3,3),rmet(3,3)
87 : real(dp) :: gprimd(3,3),gmet(3,3)
88 :
89 : integer,allocatable :: kg_k(:,:)
90 : integer,allocatable :: kg_kout(:,:)
91 : integer,allocatable :: indpw_k(:)
92 :
93 : type(MPI_type) :: MPI_enreg
94 :
95 : contains
96 : procedure :: init => fft_test_init
97 : procedure :: free => fft_test_free_0D
98 : procedure :: print => fft_test_print
99 : procedure :: get_name
100 :
101 : ! Timing routines.
102 : procedure :: time_fourdp
103 : procedure :: time_fftbox
104 : procedure :: time_fourwf
105 : procedure :: time_rhotwg
106 : procedure :: time_fftu
107 : end type FFT_test_t
108 :
109 : public :: fft_tests_free
110 :
111 : interface fft_tests_free
112 : module procedure fft_test_free_0D
113 : module procedure fft_test_free_1D
114 : end interface fft_tests_free
115 : !!***
116 :
117 : !----------------------------------------------------------------------
118 :
119 : !!****t* m_fft_mesh/FFT_prof_t
120 : !! NAME
121 : !! FFT_prof_t
122 : !!
123 : !! FUNCTION
124 : !! The results of the tests
125 : !!
126 : !! SOURCE
127 :
128 : type,public :: FFT_prof_t
129 : integer :: ncalls
130 : integer :: ndat
131 : integer :: gpu_option
132 : integer :: nthreads
133 : real(dp) :: cpu_time
134 : real(dp) :: wall_time
135 : real(dp) :: gflops
136 : character(len=TNAME_LEN) :: test_name
137 : complex(dp),allocatable :: results(:)
138 :
139 : contains
140 : procedure :: init => fftprof_init
141 : procedure :: free => fftprof_free_0D
142 : end type FFT_prof_t
143 :
144 : public :: fftprofs_free
145 : public :: fftprofs_print
146 :
147 : interface fftprofs_free
148 : module procedure fftprof_free_0D
149 : module procedure fftprof_free_1D
150 : end interface fftprofs_free
151 : !!***
152 :
153 : !----------------------------------------------------------------------
154 : ! Number of calls of each FFT algo, used to have a betters statistics for timing.
155 : integer,save,private :: NCALLS_FOR_TEST=10
156 :
157 : integer,private,parameter :: CACHE_KBSIZE=0
158 : ! Argument of empty_cache. Set it to zero if the cache should not be emptied.
159 :
160 : CONTAINS !====================================================================
161 : !!***
162 :
163 : !----------------------------------------------------------------------
164 :
165 : !!****f* m_FFT_prof/fft_test_init
166 : !! NAME
167 : !! fft_test_init
168 : !!
169 : !! FUNCTION
170 : !! Creation method for the FFT_test_t structured datatype.
171 : !!
172 : !! INPUTS
173 : !!
174 : !! OUTPUT
175 : !!
176 : !! SOURCE
177 :
178 98 : subroutine fft_test_init(Ftest, fft_setup, kpoint, ecut, boxcutmin, rprimd, nsym, symrel, MPI_enreg_in)
179 :
180 : !Arguments -----------------------------------
181 : !scalars
182 : class(FFT_test_t),intent(inout) :: Ftest
183 : integer,intent(in) :: nsym
184 : real(dp),intent(in) :: ecut,boxcutmin
185 : class(MPI_type),intent(in) :: MPI_enreg_in
186 : !arrays
187 : integer,intent(in) :: fft_setup(6),symrel(3,3,nsym)
188 : real(dp),intent(in) :: kpoint(3),rprimd(3,3)
189 :
190 : !Local variables-------------------------------
191 : !scalars
192 : integer :: fftalg,fftcache,ndat
193 : real(dp) :: ucvol
194 : !arrays
195 98 : logical,allocatable :: mask(:)
196 : real(dp),parameter :: k0(3)=zero
197 : real(dp) :: gmet(3,3),gprimd(3,3),rmet(3,3)
198 98 : real(dp),allocatable :: tnons(:,:)
199 : ! *************************************************************************
200 :
201 98 : call nullify_mpi_enreg(Ftest%MPI_enreg)
202 :
203 98 : call metric(gmet,gprimd,-1,rmet,rprimd,ucvol)
204 :
205 1274 : Ftest%rprimd = rprimd
206 1274 : Ftest%rmet = rmet
207 1274 : Ftest%gprimd = gprimd
208 1274 : Ftest%gmet = gmet
209 98 : Ftest%ecut = ecut
210 :
211 98 : fftalg = fft_setup(1)
212 98 : fftcache = fft_setup(2)
213 98 : ndat = fft_setup(3)
214 98 : Ftest%nthreads = fft_setup(4)
215 98 : Ftest%available = fft_setup(5)
216 98 : Ftest%gpu_option = fft_setup(6)
217 :
218 98 : Ftest%paral_kgb = 0
219 392 : Ftest%kpoint = kpoint
220 98 : Ftest%ndat = ndat
221 :
222 98 : Ftest%istwf_k = set_istwfk(kpoint)
223 :
224 98 : call get_kg(Ftest%kpoint,Ftest%istwf_k,ecut,gmet,Ftest%npw_k,Ftest%kg_k)
225 98 : call get_kg(Ftest%kpoint,Ftest%istwf_k,ecut,gmet,Ftest%npw_kout,Ftest%kg_kout)
226 :
227 98 : call copy_mpi_enreg(MPI_enreg_in,Ftest%MPI_enreg)
228 :
229 98 : Ftest%ngfft(7) = fftalg
230 98 : Ftest%ngfft(8) = fftcache
231 :
232 : ! Fill part of ngfft
233 686 : ABI_CALLOC(tnons,(3,nsym))
234 :
235 : call getng(boxcutmin,0,ecut,gmet,k0,Ftest%MPI_enreg%me_fft,Ftest%mgfft,Ftest%nfft,Ftest%ngfft,Ftest%MPI_enreg%nproc_fft,nsym,&
236 98 : Ftest%MPI_enreg%paral_kgb,symrel,tnons, unit=dev_null, gpu_option=ftest%gpu_option)
237 :
238 98 : ABI_FREE(tnons)
239 :
240 98 : call Ftest%MPI_enreg%distribfft%init('c',Ftest%MPI_enreg%nproc_fft,Ftest%ngfft(2),Ftest%ngfft(3))
241 :
242 : ! Compute the index of each plane wave in the FFT grid.
243 294 : ABI_MALLOC(Ftest%indpw_k,(Ftest%npw_k))
244 :
245 196 : ABI_MALLOC(mask,(Ftest%npw_k))
246 98 : call kgindex(Ftest%indpw_k,Ftest%kg_k,mask,Ftest%MPI_enreg,Ftest%ngfft,Ftest%npw_k)
247 2474319 : ABI_CHECK(ALL(mask),"FFT parallelism not supported in fftprof")
248 98 : ABI_FREE(mask)
249 :
250 98 : end subroutine fft_test_init
251 : !!***
252 :
253 : !----------------------------------------------------------------------
254 :
255 : !!****f* m_FFT_prof/fft_test_free_0D
256 : !! NAME
257 : !! fft_test_free_0D
258 : !!
259 : !! FUNCTION
260 : !! Destruction method for the FFT_test_t structured datatype.
261 : !!
262 : !! INPUTS
263 : !!
264 : !! OUTPUT
265 : !!
266 : !! SOURCE
267 :
268 98 : subroutine fft_test_free_0D(Ftest)
269 :
270 : !Arguments -----------------------------------
271 : class(FFT_test_t),intent(inout) :: Ftest
272 : ! *********************************************************************
273 :
274 98 : ABI_SFREE(Ftest%indpw_k)
275 98 : ABI_SFREE(Ftest%kg_k)
276 98 : ABI_SFREE(Ftest%kg_kout)
277 :
278 98 : call destroy_mpi_enreg(Ftest%MPI_enreg)
279 :
280 98 : end subroutine fft_test_free_0D
281 : !!***
282 :
283 : !----------------------------------------------------------------------
284 :
285 : !!****f* m_FFT_prof/fft_test_free_1D
286 : !! NAME
287 : !! fft_test_free_1D
288 : !!
289 : !! FUNCTION
290 : !! Destruction method for the FFT_test_t structured datatype.
291 : !!
292 : !! INPUTS
293 : !!
294 : !! OUTPUT
295 : !!
296 : !! SOURCE
297 :
298 17 : subroutine fft_test_free_1D(Ftest)
299 :
300 : !Arguments -----------------------------------
301 : class(FFT_test_t),intent(inout) :: Ftest(:)
302 :
303 : !Local variables-------------------------------
304 : integer :: ii
305 : ! *********************************************************************
306 :
307 132 : do ii=LBOUND(Ftest,DIM=1),UBOUND(Ftest,DIM=1)
308 115 : call Ftest(ii)%free()
309 : end do
310 :
311 17 : end subroutine fft_test_free_1D
312 : !!***
313 :
314 : !----------------------------------------------------------------------
315 :
316 : !!****f* m_FFT_prof/fft_test_print
317 : !! NAME
318 : !! fft_test_print
319 : !!
320 : !! FUNCTION
321 : !! Printout of the FFT_test_t structured datatype.
322 : !!
323 : !! INPUTS
324 : !!
325 : !! OUTPUT
326 : !!
327 : !! SOURCE
328 :
329 98 : subroutine fft_test_print(Ftest, header, unit, mode_paral, prtvol)
330 :
331 : !Arguments -----------------------------------
332 : class(FFT_test_t),intent(in) :: Ftest
333 : integer,optional,intent(in) :: unit,prtvol
334 : character(len=4),optional,intent(in) :: mode_paral
335 : character(len=*),optional,intent(in) :: header
336 :
337 : !Local variables-------------------------------
338 : !scalars
339 : integer :: my_unt,my_prtvol
340 : character(len=4) :: my_mode
341 : character(len=500) :: msg
342 : ! *********************************************************************
343 :
344 0 : my_unt =std_out; if (PRESENT(unit )) my_unt =unit
345 98 : my_prtvol=0 ; if (PRESENT(prtvol )) my_prtvol=prtvol
346 98 : my_mode ='COLL' ; if (PRESENT(mode_paral)) my_mode =mode_paral
347 :
348 : !msg=' ==== Info on the FFT test object ==== '
349 98 : if (PRESENT(header)) then
350 0 : msg=' ==== '//TRIM(ADJUSTL(header))//' ==== '
351 0 : call wrtout(my_unt,msg,my_mode)
352 : end if
353 :
354 98 : write(msg,'(a,i3)')"FFT setup for fftalg ",Ftest%ngfft(7)
355 196 : call print_ngfft([my_unt], Ftest%ngfft, header=msg)
356 :
357 98 : end subroutine fft_test_print
358 : !!***
359 :
360 : !----------------------------------------------------------------------
361 :
362 : !!****f* m_FFT_prof/get_name
363 : !! NAME
364 : !! get_name
365 : !!
366 : !! FUNCTION
367 : !! Returns a string with info on the test.
368 : !!
369 : !! INPUTS
370 : !!
371 : !! OUTPUT
372 : !!
373 : !! SOURCE
374 :
375 403 : character(len=TNAME_LEN) function get_name(Ftest)
376 :
377 : !Arguments -----------------------------------
378 : class(FFT_test_t),intent(in) :: Ftest
379 :
380 : !Local variables-------------------------------
381 : character(len=TNAME_LEN) :: library_name,cplex_mode,padding_mode
382 : ! *********************************************************************
383 :
384 403 : if (ftest%gpu_option == 0) then
385 403 : call fftalg_info(Ftest%ngfft(7), library_name, cplex_mode, padding_mode)
386 : !get_name = TRIM(library_name)//"; "//TRIM(cplex_mode)//"; "//TRIM(padding_mode)
387 403 : write(get_name,'(i3)')Ftest%ngfft(7)
388 403 : get_name = TRIM(library_name)//" ("//TRIM(get_name)//")"
389 : else
390 0 : get_name = "GPU_FLAVOR"
391 : end if
392 :
393 403 : end function get_name
394 : !!***
395 :
396 : !----------------------------------------------------------------------
397 :
398 : !!****f* m_FFT_prof/fftprof_init
399 : !! NAME
400 : !! fftprof_init
401 : !!
402 : !! FUNCTION
403 : !! Creation method for the FFT_prof_t structured datatype.
404 : !!
405 : !! INPUTS
406 : !! gflops = Gigaflops
407 : !!
408 : !! OUTPUT
409 : !!
410 : !! SOURCE
411 :
412 403 : subroutine fftprof_init(Ftprof, test_name, nthreads, ncalls, ndat, gpu_option, cpu_time, wall_time, gflops, results)
413 :
414 : !Arguments -----------------------------------
415 : class(FFT_prof_t),intent(out) :: Ftprof
416 : integer,intent(in) :: ncalls,nthreads,ndat, gpu_option
417 : real(dp),intent(in) :: cpu_time,wall_time,gflops
418 : character(len=*),intent(in) :: test_name
419 : !arrays
420 : complex(dp),optional,intent(in) :: results(:)
421 : ! *************************************************************************
422 :
423 403 : Ftprof%ncalls = ncalls
424 403 : Ftprof%nthreads = nthreads
425 403 : Ftprof%ndat = ndat
426 403 : Ftprof%gpu_option = gpu_option
427 403 : Ftprof%cpu_time = cpu_time
428 403 : Ftprof%wall_time = wall_time
429 403 : Ftprof%gflops = gflops
430 403 : Ftprof%test_name = test_name
431 :
432 403 : if (present(results)) then
433 921 : ABI_REMALLOC(Ftprof%results, (size(results)))
434 280722773 : Ftprof%results = results
435 : end if
436 :
437 403 : end subroutine fftprof_init
438 : !!***
439 :
440 : !----------------------------------------------------------------------
441 :
442 : !!****f* m_FFT_prof/fftprof_free_0D
443 : !! NAME
444 : !! fftprof_free_0D
445 : !!
446 : !! FUNCTION
447 : !! Destruction method for the FFT_prof_t structured datatype.
448 : !!
449 : !! SOURCE
450 :
451 501 : subroutine fftprof_free_0D(Ftprof)
452 :
453 : !Arguments -----------------------------------
454 : class(FFT_prof_t),intent(inout) :: Ftprof
455 : ! *********************************************************************
456 :
457 501 : ABI_SFREE(Ftprof%results)
458 :
459 501 : end subroutine fftprof_free_0D
460 : !!***
461 :
462 : !----------------------------------------------------------------------
463 :
464 : !!****f* m_FFT_prof/fftprof_free_1D
465 : !! NAME
466 : !! fftprof_free_1D
467 : !!
468 : !! FUNCTION
469 : !! Destruction method for the FFT_prof_t structured datatype.
470 : !!
471 : !! INPUTS
472 : !!
473 : !! OUTPUT
474 : !!
475 : !! SOURCE
476 :
477 75 : subroutine fftprof_free_1D(Ftprof)
478 :
479 : !Arguments -----------------------------------
480 : class(FFT_prof_t),intent(inout) :: Ftprof(:)
481 :
482 : !Local variables-------------------------------
483 : integer :: ii
484 : ! *********************************************************************
485 :
486 651 : do ii=LBOUND(Ftprof,DIM=1),UBOUND(Ftprof,DIM=1)
487 576 : call fftprof_free_0D(Ftprof(ii))
488 : end do
489 :
490 75 : end subroutine fftprof_free_1D
491 : !!***
492 :
493 : !----------------------------------------------------------------------
494 :
495 : !!****f* m_FFT_prof/fftprofs_print
496 : !! NAME
497 : !! fftprofs_print
498 : !!
499 : !! FUNCTION
500 : !! Printout of the FFT_prof_t structured datatype.
501 : !!
502 : !! INPUTS
503 : !!
504 : !! OUTPUT
505 : !!
506 : !! SOURCE
507 :
508 116 : subroutine fftprofs_print(Fprof, header, unit, mode_paral, prtvol)
509 :
510 : !Arguments -----------------------------------
511 : class(FFT_prof_t),intent(in) :: Fprof(:)
512 : integer,optional,intent(in) :: unit,prtvol
513 : character(len=4),optional,intent(in) :: mode_paral
514 : character(len=*),optional,intent(in) :: header
515 :
516 : !Local variables-------------------------------
517 : !scalars
518 : integer :: my_unt,my_prtvol,ncalls, field1_w,ii,ref_lib !ifft
519 : real(dp) :: mabs_err,mean_err,check_mabs_err,check_mean_err, ref_wtime,para_eff
520 : character(len=4) :: my_mode
521 : character(len=500) :: ofmt,hfmt,nafmt,msg
522 : ! *********************************************************************
523 :
524 58 : my_unt =std_out; if (PRESENT(unit )) my_unt =unit
525 58 : my_prtvol=0 ; if (PRESENT(prtvol )) my_prtvol=prtvol
526 58 : my_mode ='COLL' ; if (PRESENT(mode_paral)) my_mode =mode_paral
527 :
528 58 : msg='==== Info on the FFT_prof_t object ===='
529 58 : if (PRESENT(header)) msg='==== '//TRIM(ADJUSTL(header))//' ===='
530 :
531 3506 : call wrtout(my_unt,ch10//REPEAT("=",LEN_TRIM(msg)))
532 58 : call wrtout(my_unt,msg,my_mode)
533 3506 : call wrtout(my_unt,REPEAT("=",LEN_TRIM(msg)))
534 :
535 58 : field1_w=0 ! Width of the field used to print key names.
536 461 : do ii=1,SIZE(Fprof)
537 461 : field1_w = MAX(field1_w, LEN_TRIM(Fprof(ii)%test_name))
538 : end do
539 :
540 58 : if (field1_w==0) RETURN
541 58 : field1_w = field1_w + 2 ! To account for ". "
542 58 : write(ofmt,*)"(a",field1_w,",2x,2(f7.4,4x),1x,i2,1x,a,i3,a,1x,i0,4x,2(es9.2,3x))"
543 :
544 58 : write(hfmt,*)"(a",field1_w,",2x,a)"
545 58 : write(std_out,hfmt)" Library ","CPU-time WALL-time nthreads ncalls Max_|Err| <|Err|>"
546 : !
547 : ! Find reference library.
548 58 : ref_lib=0
549 58 : do ii=1,SIZE(Fprof)
550 58 : if (Fprof(ii)%ncalls>0) then
551 : ref_lib = ii
552 : EXIT
553 : end if
554 : end do
555 : !ref_lib=3
556 : !
557 : ! Write timing analysis and error wrt reference library if available.
558 58 : check_mabs_err=zero; check_mean_err=zero
559 461 : do ii=1,SIZE(Fprof)
560 403 : ncalls = Fprof(ii)%ncalls
561 461 : if (ncalls > 0) then
562 307 : mabs_err = zero; mean_err=zero
563 307 : if (ref_lib>0) then
564 280722773 : mabs_err = MAXVAL( ABS(Fprof(ii)%results - Fprof(ref_lib)%results) )
565 280722466 : mean_err = SUM( ABS(Fprof(ii)%results - Fprof(ref_lib)%results) ) / SIZE(Fprof(ref_lib)%results)
566 : ! Relative error is not a good estimator because some components are close to zero within machine accuracy.
567 : !mean_err = 100 * MAXVAL( ABS(Fprof(ii)%results - Fprof(1)%results)/ ABS(Fprof(1)%results ))
568 : !ifft = imax_loc( ABS(Fprof(ii)%results - Fprof(1)%results)/ ABS(Fprof(1)%results) )
569 : !write(std_out,*) Fprof(ii)%results(ifft),Fprof(1)%results(ifft)
570 : end if
571 307 : if (Fprof(ii)%nthreads==1) ref_wtime = Fprof(ii)%wall_time
572 307 : para_eff = 100 * ref_wtime / ( Fprof(ii)%wall_time * Fprof(ii)%nthreads)
573 : write(std_out,ofmt)&
574 307 : "- "//Fprof(ii)%test_name,Fprof(ii)%cpu_time/ncalls,Fprof(ii)%wall_time/ncalls,&
575 614 : Fprof(ii)%nthreads,"(",NINT(para_eff),"%)",ncalls,mabs_err,mean_err
576 307 : check_mabs_err = MAX(check_mabs_err, mabs_err)
577 307 : check_mean_err = MAX(check_mean_err, mean_err)
578 : else
579 96 : write(nafmt,*)"(a",field1_w,",2x,a)"
580 96 : write(std_out,nafmt)"- "//Fprof(ii)%test_name," N/A N/A N/A N/A N/A N/A"
581 : end if
582 : end do
583 :
584 58 : if (ref_lib > 0) then
585 : write(std_out,'(/,2(a,es9.2),2a)')&
586 58 : " Consistency check: MAX(Max_|Err|) = ",check_mabs_err,&
587 116 : ", Max(<|Err|>) = ",check_mean_err,", reference_lib: ",TRIM(Fprof(ref_lib)%test_name)
588 : end if
589 58 : write(std_out,*)
590 :
591 58 : end subroutine fftprofs_print
592 : !!***
593 :
594 : !----------------------------------------------------------------------
595 :
596 : !!****f* m_FFT_prof/time_fourdp
597 : !! NAME
598 : !! time_fourdp
599 : !!
600 : !! FUNCTION
601 : !! Profiling of the fourdp routine.
602 : !!
603 : !! INPUTS
604 : !!
605 : !! OUTPUT
606 : !!
607 : !! SOURCE
608 :
609 16 : subroutine time_fourdp(Ftest, isign, cplex, header, Ftprof)
610 :
611 : !Arguments -----------------------------------
612 : class(FFT_test_t),intent(inout) :: Ftest
613 : integer,intent(in) :: cplex,isign
614 : character(len=500),intent(out) :: header
615 : class(FFT_prof_t),intent(out) :: Ftprof
616 :
617 : !Local variables-------------------------------
618 : !scalars
619 : integer,parameter :: nspinor1=1
620 : integer :: icall,i1,i2,i3,n1,n2,n3,ifft
621 : real(dp) :: cpu_time,wall_time,gflops,gsq
622 : !character(len=500) :: msg
623 : character(len=TNAME_LEN) :: test_name
624 : !arrays
625 : integer,parameter :: g0(3)=(/1,2,-1/)
626 : integer :: gg(3)
627 16 : real(dp),allocatable :: fofg(:,:),fofr(:)
628 16 : complex(dp),allocatable :: results(:),ctmp(:)
629 : ! *********************************************************************
630 :
631 16 : test_name = Ftest%get_name()
632 16 : n1=Ftest%ngfft(1); n2=Ftest%ngfft(2); n3=Ftest%ngfft(3)
633 :
634 16 : write(header,'(2(a,i2),a)')" fourdp with cplex ",cplex,", isign ",isign,", ndat 1"
635 :
636 16 : if (Ftest%available == 0) then
637 4 : call Ftprof%init(test_name,0,0,0,0,zero,zero,zero)
638 : RETURN
639 : end if
640 :
641 12 : call xomp_set_num_threads(Ftest%nthreads)
642 :
643 12 : if (Ftest%ngfft(7)/100 == FFT_FFTW3) call fftw3_set_nthreads(Ftest%nthreads)
644 :
645 36 : ABI_MALLOC(fofg,(2,Ftest%nfft))
646 36 : ABI_MALLOC(fofr,(cplex*Ftest%nfft))
647 :
648 : ! Initialize input data.
649 12 : if (isign==1) then
650 : ! initialize fofg
651 13122006 : fofg = zero
652 : ifft=0
653 546 : do i3=1,n3
654 540 : gg(3)=i3-1; if (i3>1+n3/2) gg(3)=i3-n3-1 ! TODO recheck this
655 49146 : do i2=1,n2
656 48600 : gg(2)=i2-1; if (i2>1+n2/2) gg(2)=i2-n2-1
657 4423140 : do i1=1,n1
658 4374000 : gg(1)=i1-1; if (i1>1+n1/2) gg(1)=i1-n1-1
659 83106000 : gsq = two_pi**2 * DOT_PRODUCT(gg,MATMUL(Ftest%gmet,gg))
660 4374000 : ifft=ifft+1
661 4374000 : fofg(1,ifft) = EXP(-gsq)
662 4422600 : fofg(2,ifft) = zero
663 : end do
664 : end do
665 : end do
666 :
667 : else
668 : ! init fofr
669 6 : if (cplex==2) then
670 3 : call calc_eigr(g0,Ftest%nfft,Ftest%ngfft,fofr)
671 3 : else if (cplex==1) then
672 9 : ABI_MALLOC(ctmp,(Ftest%nfft))
673 3 : call calc_ceigr(g0,Ftest%nfft,nspinor1,Ftest%ngfft,ctmp)
674 2187006 : fofr = REAL(ctmp)
675 3 : ABI_FREE(ctmp)
676 : else
677 0 : ABI_ERROR(sjoin("Wrong cplex:", itoa(cplex)))
678 : end if
679 : end if
680 :
681 8748036 : ABI_CALLOC(results, (Ftest%nfft))
682 12 : call cwtime(cpu_time, wall_time, gflops, "start")
683 :
684 72 : do icall=1,NCALLS_FOR_TEST
685 60 : ifft = empty_cache(CACHE_KBSIZE)
686 60 : call fourdp(cplex,fofg,fofr,isign,Ftest%MPI_enreg,Ftest%nfft,1,Ftest%ngfft,0)
687 :
688 : ! Store results at the first call.
689 72 : if (icall==1) then
690 12 : if (isign==1) then
691 6 : if (cplex==1) then
692 2187006 : results = DCMPLX(fofr, zero)
693 3 : else if (cplex==2) then
694 2187006 : results = DCMPLX( fofr(1:2*Ftest%nfft:2), fofr(2:2*Ftest%nfft:2) )
695 : end if
696 6 : else if (isign==-1) then
697 4374012 : results = DCMPLX(fofg(1,:),fofg(2,:))
698 : end if
699 : end if
700 : end do
701 :
702 12 : call cwtime(cpu_time, wall_time, gflops, "stop")
703 : call Ftprof%init(test_name,Ftest%nthreads,NCALLS_FOR_TEST,Ftest%ndat,ftest%gpu_option, &
704 12 : cpu_time,wall_time,gflops,results=results)
705 :
706 12 : ABI_FREE(fofg)
707 12 : ABI_FREE(fofr)
708 12 : ABI_FREE(results)
709 :
710 24 : end subroutine time_fourdp
711 : !!***
712 :
713 : !----------------------------------------------------------------------
714 :
715 : !!****f* m_FFT_prof/time_fftbox
716 : !! NAME
717 : !! time_fftbox
718 : !!
719 : !! FUNCTION
720 : !! Profiling of the fftbox_[io]p routines.
721 : !!
722 : !! INPUTS
723 : !!
724 : !! OUTPUT
725 : !!
726 : !! SOURCE
727 :
728 12 : subroutine time_fftbox(Ftest, isign, inplace, header, Ftprof)
729 :
730 : !Arguments -----------------------------------
731 : class(FFT_test_t),intent(inout) :: Ftest
732 : integer,intent(in) :: isign,inplace
733 : character(len=500),intent(inout) :: header
734 : class(FFT_prof_t),intent(out) :: Ftprof
735 :
736 : !Local variables-------------------------------
737 : !scalars
738 : integer,parameter :: nspinor1 = 1, fftcache0 = 0
739 : integer :: icall,i1,i2,i3,n1,n2,n3,ifft,ndat,nfft,dat,padat
740 : real(dp) :: cpu_time,wall_time,gflops,gsq
741 : !character(len=500) :: msg
742 : character(len=TNAME_LEN) :: test_name
743 : type(fftbox_plan3_t) :: plan
744 : !arrays
745 : integer,parameter :: g0(3) = [1,-2,1]
746 : integer :: gg(3)
747 12 : complex(dp),allocatable :: ffc(:),ggc(:),results(:)
748 : ! *********************************************************************
749 :
750 12 : test_name = Ftest%get_name()
751 :
752 12 : if (Ftest%available == 0) then
753 4 : call Ftprof%init(test_name, 0, 0, 0, 0, zero, zero, zero)
754 : return
755 : end if
756 :
757 8 : call xomp_set_num_threads(Ftest%nthreads)
758 :
759 8 : if (Ftest%ngfft(7)/100 == FFT_FFTW3) call fftw3_set_nthreads(Ftest%nthreads)
760 :
761 8 : n1 = Ftest%ngfft(1); n2 = Ftest%ngfft(2); n3 = Ftest%ngfft(3)
762 8 : nfft = Ftest%nfft; ndat = Ftest%ndat
763 8 : write(header,'(3(a,i2))')" fftbox with isign ",isign,", in-place ",inplace,", ndat ",ndat
764 :
765 5832024 : ABI_CALLOC(ffc, (nfft*ndat))
766 5832016 : ABI_CALLOC(ggc, (nfft*ndat))
767 5832016 : ABI_CALLOC(results, (nfft*ndat))
768 :
769 8 : if (isign==-1) then
770 4 : call calc_ceigr(g0,nfft,nspinor1,Ftest%ngfft,ffc)
771 4 : else if (isign==1) then
772 : ifft=0
773 364 : do i3=1,n3
774 360 : gg(3)=i3-1; if (i3>1+n3/2) gg(3)=i3-n3-1 ! TODO recheck this
775 32764 : do i2=1,n2
776 32400 : gg(2)=i2-1; if (i2>1+n2/2) gg(2)=i2-n2-1
777 2948760 : do i1=1,n1
778 2916000 : gg(1)=i1-1; if (i1>1+n1/2) gg(1)=i1-n1-1
779 55404000 : gsq = two_pi**2 * DOT_PRODUCT(gg,MATMUL(Ftest%gmet,gg))
780 2916000 : ifft=ifft+1
781 2948400 : ffc(ifft) = EXP(-gsq)
782 : end do
783 : end do
784 : end do
785 : else
786 0 : ABI_ERROR("Wrong isign")
787 : end if
788 :
789 : ! Replicate and scale input data
790 8 : do dat=2,ndat
791 0 : padat = (dat-1) * nfft
792 8 : do ifft=1,nfft
793 0 : ffc(ifft+padat) = DBLE(dat) * ffc(ifft)
794 : end do
795 : end do
796 :
797 8 : call cwtime(cpu_time, wall_time, gflops, "start")
798 :
799 : ! No augmentation here.
800 8 : call plan%init(ndat, Ftest%ngfft(1:3), Ftest%ngfft(1:3), Ftest%ngfft(7), fftcache0, ftest%gpu_option)
801 :
802 : if (plan%gpu_option == ABI_GPU_OPENMP) then
803 : #ifdef HAVE_OPENMP_OFFLOAD
804 : !$OMP TARGET ENTER DATA MAP(to:ffc, ggc)
805 : #endif
806 : end if
807 :
808 12 : select case (inplace)
809 : case (0)
810 24 : do icall=1,NCALLS_FOR_TEST
811 20 : ifft = empty_cache(CACHE_KBSIZE)
812 20 : call plan%execute(ffc, ggc, isign, ndat, iscale=0)
813 : ! Store results at the first call.
814 24 : if (icall == 1) then
815 : #ifdef HAVE_OPENMP_OFFLOAD
816 : !$omp target update from(ggc)
817 : #endif
818 2916008 : results = ggc
819 : end if
820 : end do
821 : case (1)
822 24 : do icall=1,NCALLS_FOR_TEST
823 20 : ifft = empty_cache(CACHE_KBSIZE)
824 20 : call plan%execute(ffc, isign, ndat, iscale=0)
825 : ! Store results at the first call.
826 24 : if (icall == 1) then
827 : #ifdef HAVE_OPENMP_OFFLOAD
828 : !$omp target update from(ffc)
829 : #endif
830 2916008 : results = ffc
831 : end if
832 : end do
833 : case default
834 8 : ABI_ERROR(sjoin("Wrong value for inplace:", itoa(inplace)))
835 : end select
836 :
837 8 : call cwtime(cpu_time, wall_time, gflops, "stop")
838 : call Ftprof%init(test_name,Ftest%nthreads,NCALLS_FOR_TEST,Ftest%ndat,ftest%gpu_option, &
839 8 : cpu_time,wall_time,gflops,results=results)
840 :
841 8 : call plan%free()
842 :
843 : if (plan%gpu_option == ABI_GPU_OPENMP) then
844 : #ifdef HAVE_OPENMP_OFFLOAD
845 : !$OMP TARGET EXIT DATA MAP(delete:ffc, ggc)
846 : #endif
847 : end if
848 8 : ABI_FREE(ffc)
849 8 : ABI_FREE(ggc)
850 8 : ABI_FREE(results)
851 :
852 100 : end subroutine time_fftbox
853 : !!***
854 :
855 : !----------------------------------------------------------------------
856 :
857 : !!****f* m_FFT_prof/time_fourwf
858 : !! NAME
859 : !! time_fourwf
860 : !!
861 : !! FUNCTION
862 : !! Profiling of the fourwf routine.
863 : !!
864 : !! INPUTS
865 : !!
866 : !! OUTPUT
867 : !!
868 : !! SOURCE
869 :
870 363 : subroutine time_fourwf(Ftest, cplex, option_fourwf, header, Ftprof)
871 :
872 : !Arguments -----------------------------------
873 : class(FFT_test_t),intent(inout) :: Ftest
874 : integer,intent(in) :: cplex,option_fourwf
875 : character(len=500),intent(out) :: header
876 : class(FFT_prof_t),intent(out) :: Ftprof
877 :
878 : !Local variables-------------------------------
879 : !scalars
880 : integer,parameter :: tim0=0
881 : integer :: n1,n2,n3,n4,n5,n6,npw_out,icall,i1,i2,i3,idx,ipw,ndat,cnt,dat,padat
882 : integer :: fftalg,fftalga,fftalgc
883 : real(dp),parameter :: weight_i=one,weight_r=one
884 : real(dp) :: cpu_time,wall_time,gflops,gsq,g0dotr
885 : logical :: isbuggy,not_supported
886 : !character(len=500) :: msg
887 : character(len=TNAME_LEN) :: test_name
888 : !arrays
889 : integer,parameter :: g0(3)=[1,-1,2] !g0(3)=[1,0,0]
890 : integer :: gg(3)
891 363 : integer,allocatable :: gbound_in(:,:),gbound_out(:,:)
892 363 : real(dp),allocatable :: denpot(:,:,:),fofg_in(:,:), fofr_4(:,:,:,:),fofg_out(:,:)
893 363 : complex(dp),allocatable :: results(:)
894 : ! *********************************************************************
895 :
896 363 : test_name = Ftest%get_name()
897 :
898 363 : fftalg = Ftest%ngfft(7); fftalga = fftalg/100; fftalgc = MOD(fftalg,10)
899 :
900 : isbuggy = &
901 : (option_fourwf==3 .and. fftalga==FFT_SG2002 .and. fftalgc /= 0 .and. &
902 2008 : any(Ftest%istwf_k == [3,4,5,6,7,8,9])) ! see sg_fourwf
903 : !isbuggy = .False.
904 :
905 : !FIXME problems with the unitary tests reference files!
906 : not_supported = ( &
907 363 : (fftalgc == 2 .and. option_fourwf==0 .and. Ftest%istwf_k > 2))
908 : !not_supported = .FALSE.
909 :
910 363 : npw_out= Ftest%npw_kout
911 363 : ndat = Ftest%ndat
912 363 : n1=Ftest%ngfft(1); n2=Ftest%ngfft(2); n3=Ftest%ngfft(3)
913 363 : n4=Ftest%ngfft(4); n5=Ftest%ngfft(5); n6=Ftest%ngfft(6)
914 :
915 363 : write(header,'(4(a,i2))')" fourwf with option ",option_fourwf,", cplex ",cplex,", ndat ",ndat,", istwf_k ",Ftest%istwf_k
916 :
917 363 : if (isbuggy .or. not_supported .or. Ftest%available==0) then
918 81 : call Ftprof%init(test_name,0,0,0,0,zero,zero,zero)
919 81 : RETURN
920 : end if
921 :
922 282 : call xomp_set_num_threads(Ftest%nthreads)
923 :
924 282 : if (Ftest%ngfft(7)/100 == FFT_FFTW3) call fftw3_set_nthreads(Ftest%nthreads)
925 :
926 : ! FFTW3 does not need gbound_in but oh well
927 1128 : ABI_MALLOC(gbound_in, (2*Ftest%mgfft+8,2))
928 282 : call sphereboundary(gbound_in,Ftest%istwf_k,Ftest%kg_k,Ftest%mgfft,Ftest%npw_k)
929 :
930 1128 : ABI_MALLOC(gbound_out, (2*Ftest%mgfft+8,2))
931 282 : call sphereboundary(gbound_out,Ftest%istwf_k,Ftest%kg_kout,Ftest%mgfft,Ftest%npw_kout)
932 :
933 118451490 : ABI_CALLOC(denpot, (cplex*n4,n5,n6))
934 38832138 : ABI_CALLOC(fofg_in, (2,Ftest%npw_k*ndat))
935 38832138 : ABI_CALLOC(fofg_out, (2,npw_out*ndat))
936 811367790 : ABI_CALLOC(fofr_4, (2,n4,n5,n6*ndat))
937 264648846 : ABI_CALLOC(results, (Ftest%nfft*ndat))
938 :
939 : select case (option_fourwf)
940 : case (0, 1, 2)
941 : !! for option==0, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
942 : !! fofr(2,n4,n5,n6) contains the output Fourier Transform of fofgin;
943 : !! no use of denpot, fofgout and npwout.
944 : !! for option==1, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
945 : !! denpot(cplex*n4,n5,n6) contains the input density at input,
946 : !! and the updated density at output (accumulated);
947 : !! no use of fofgout and npwout.
948 : !! for option==2, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
949 : !! denpot(cplex*n4,n5,n6) contains the input local potential;
950 : !! fofgout(2,npwout*ndat) contains the output function;
951 : !!
952 10259385 : do cnt=0, (Ftest%npw_k * ndat) - 1
953 10259165 : ipw = 1 + MOD(cnt, Ftest%npw_k)
954 41036660 : gg = Ftest%kg_k(:,ipw)
955 194924135 : gsq = two_pi**2 * DOT_PRODUCT(gg,MATMUL(Ftest%gmet,gg))
956 10259165 : fofg_in(1,cnt+1) = EXP(-gsq)
957 10259385 : fofg_in(2,cnt+1) = zero
958 : end do
959 :
960 45465740 : if (option_fourwf==1) denpot = one
961 :
962 220 : if (option_fourwf==2) then
963 : ! Init denpot
964 89 : if (cplex==1) then
965 6556 : do i3=0,n3-1
966 529116 : do i2=0,n2-1
967 44721040 : do i1=0,n1-1
968 : g0dotr= two_pi*( g0(1)*(i1/DBLE(n1)) &
969 : +g0(2)*(i2/DBLE(n2)) &
970 44192000 : +g0(3)*(i3/DBLE(n3)) )
971 44714560 : denpot(i1+1,i2+1,i3+1)=COS(g0dotr)
972 : end do
973 : end do
974 : end do
975 13 : else if (cplex==2) then
976 1313 : do i3=0,n3-1
977 131313 : do i2=0,n2-1
978 : idx=1
979 13131300 : do i1=0,n1-1
980 : g0dotr= two_pi*( g0(1)*(i1/DBLE(n1)) &
981 : +g0(2)*(i2/DBLE(n2)) &
982 13000000 : +g0(3)*(i3/DBLE(n3)) )
983 :
984 13000000 : denpot(idx, i2+1,i3+1)= COS(g0dotr)
985 13000000 : denpot(idx+1,i2+1,i3+1)= SIN(g0dotr)
986 13130000 : idx=idx+2
987 : end do
988 : end do
989 : end do
990 : end if
991 : end if
992 :
993 : case (3)
994 : !! for option==3, fofr(2,n4,n5,n6*ndat) contains the input real space wavefunction;
995 : !! fofgout(2,npwout*ndat) contains its output Fourier transform;
996 : !! no use of fofgin and npwin.
997 : idx=0
998 142 : do dat=1,ndat
999 80 : padat = (dat-1)*n6
1000 7302 : do i3=0,n3-1
1001 629160 : do i2=0,n2-1
1002 56773080 : do i1=0,n1-1
1003 : g0dotr= two_pi*( g0(1)*(i1/DBLE(n1)) &
1004 : +g0(2)*(i2/DBLE(n2)) &
1005 56144000 : +g0(3)*(i3/DBLE(n3)) )
1006 : !fofr_4(1,i1+1,i2+1,i3+1+padat)=COS(g0dotr)
1007 : !fofr_4(2,i1+1,i2+1,i3+1+padat)=SIN(g0dotr)
1008 56144000 : fofr_4(1,i1+1,i2+1,i3+1+padat)=10 * EXP(-g0dotr**2)
1009 56144000 : fofr_4(2,i1+1,i2+1,i3+1+padat)=zero
1010 56144000 : idx=idx+1
1011 56765920 : results(idx) = DCMPLX(fofr_4(1,i1+1,i2+1,i3+1+padat), fofr_4(2,i1+1,i2+1,i3+1+padat))
1012 : end do
1013 : end do
1014 : end do
1015 : end do
1016 :
1017 : case default
1018 282 : ABI_ERROR(sjoin("Wrong value for option_fourwf:", itoa(option_fourwf)))
1019 : end select
1020 :
1021 282 : call cwtime(cpu_time, wall_time, gflops, "start")
1022 :
1023 1602 : do icall=1,NCALLS_FOR_TEST
1024 :
1025 1320 : i1 = empty_cache(CACHE_KBSIZE)
1026 :
1027 : call fourwf(cplex,denpot,fofg_in,fofg_out,fofr_4,gbound_in,gbound_out,Ftest%istwf_k,&
1028 : Ftest%kg_k,Ftest%kg_kout,Ftest%mgfft,Ftest%MPI_enreg,ndat,Ftest%ngfft,Ftest%npw_k,npw_out,n4,n5,n6,option_fourwf,&
1029 1320 : tim0,weight_r,weight_i, gpu_option=ftest%gpu_option)
1030 :
1031 : ! Store results at the first call.
1032 1602 : if (icall == 1) then
1033 : select case (option_fourwf)
1034 : case (0)
1035 : !! for option==0, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
1036 : !! fofr(2,n4,n5,n6) contains the output Fourier Transform of fofgin;
1037 : !! no use of denpot, fofgout and npwout.
1038 : idx=0
1039 128 : do dat=1,ndat
1040 73 : padat = (dat-1)*n6
1041 6728 : do i3=1,n3
1042 588273 : do i2=1,n2
1043 53708200 : do i1=1,n1
1044 53120000 : idx=idx+1
1045 53701600 : results(idx) = DCMPLX(fofr_4(1,i1,i2,i3+padat),fofr_4(2,i1,i2,i3+padat))
1046 : end do
1047 : end do
1048 : end do
1049 : end do
1050 : case (1)
1051 : !! for option==1, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
1052 : !! denpot(cplex*n4,n5,n6) contains the input density at input,
1053 : !! and the updated density at output (accumulated);
1054 : !! no use of fofgout and npwout.
1055 76 : if (cplex==1) then
1056 : idx=0
1057 6556 : do i3=1,n3
1058 529116 : do i2=1,n2
1059 44721040 : do i1=1,n1
1060 44192000 : idx=idx+1
1061 44714560 : results(idx) = DCMPLX(denpot(i1,i2,i3),zero)
1062 : end do
1063 : end do
1064 : end do
1065 :
1066 0 : else if (cplex==2) then
1067 : idx=0
1068 0 : do i3=1,n3
1069 0 : do i2=1,n2
1070 0 : do i1=1,2*n1,2
1071 0 : idx=idx+1
1072 0 : results(idx) = DCMPLX(denpot(i1,i2,i3),denpot(i1+1,i2,i3))
1073 : end do
1074 : end do
1075 : end do
1076 : else
1077 0 : ABI_ERROR("Wrong cplex")
1078 : end if
1079 :
1080 : case (2)
1081 : !! for option==2, fofgin(2,npwin*ndat)=holds input wavefunction in G sphere;
1082 : !! denpot(cplex*n4,n5,n6) contains the input local potential;
1083 : !! fofgout(2,npwout*ndat) contains the output function;
1084 4803443 : do ipw=1,npw_out*ndat
1085 4803443 : results(ipw) = DCMPLX(fofg_out(1,ipw),fofg_out(2,ipw))
1086 : end do
1087 :
1088 : case (3)
1089 : !! for option==3, fofr(2,n4,n5,n6*ndat) contains the input real space wavefunction;
1090 : !! fofgout(2,npwout*ndat) contains its output Fourier transform;
1091 : !! no use of fofgin and npwin.
1092 2684881 : do ipw=1,npw_out*ndat
1093 2684661 : results(ipw) = DCMPLX(fofg_out(1,ipw),fofg_out(2,ipw))
1094 : end do
1095 : !write(Ftest%ngfft(7),*)"results opt 3 Ftest%ngfft(7)",Ftest%ngfft(7)
1096 : !do dat=1,ndat
1097 : ! do ipw=1,npw_out
1098 : ! idx = ipw + (dat-1)*npw_out
1099 : ! write(Ftest%ngfft(7),*)ipw,dat,results(idx)
1100 : ! end do
1101 : !end do
1102 : end select
1103 : end if
1104 : end do
1105 :
1106 282 : call cwtime(cpu_time, wall_time, gflops, "stop")
1107 : call Ftprof%init(test_name,Ftest%nthreads,NCALLS_FOR_TEST,Ftest%ndat,ftest%gpu_option,&
1108 282 : cpu_time,wall_time,gflops,results=results)
1109 :
1110 282 : ABI_FREE(denpot)
1111 282 : ABI_FREE(fofg_in)
1112 282 : ABI_FREE(fofg_out)
1113 282 : ABI_FREE(fofr_4)
1114 282 : ABI_FREE(gbound_in)
1115 282 : ABI_FREE(gbound_out)
1116 282 : ABI_FREE(results)
1117 :
1118 927 : end subroutine time_fourwf
1119 : !!***
1120 :
1121 : !----------------------------------------------------------------------
1122 :
1123 : !!****f* m_FFT_prof/fftprof_ncalls_per_test
1124 : !! NAME
1125 : !! fftprof_ncalls_per_test
1126 : !!
1127 : !! FUNCTION
1128 : !! Helper function used to set the number of calls to be used in each time_* routine.
1129 : !!
1130 : !! INPUTS
1131 : !! ncalls=Number of calls to be used.
1132 : !!
1133 : !! SIDE EFFECTS
1134 : !! NCALLS_FOR_TEST = ncalls
1135 : !!
1136 : !! SOURCE
1137 :
1138 17 : subroutine fftprof_ncalls_per_test(ncalls)
1139 :
1140 : !Arguments -----------------------------------
1141 : integer,intent(in) :: ncalls
1142 : ! *********************************************************************
1143 :
1144 17 : NCALLS_FOR_TEST = ncalls
1145 :
1146 17 : end subroutine fftprof_ncalls_per_test
1147 : !!***
1148 :
1149 : !----------------------------------------------------------------------
1150 :
1151 : !!****f* m_FFT_prof/time_rhotwg
1152 : !! NAME
1153 : !! time_rhotwg
1154 : !!
1155 : !! FUNCTION
1156 : !! Profiling of the rho_tw_g routine.
1157 : !!
1158 : !! INPUTS
1159 : !!
1160 : !! OUTPUT
1161 : !!
1162 : !! SOURCE
1163 :
1164 6 : subroutine time_rhotwg(Ftest, map2sphere, use_padfft, osc_npw, osc_gvec, header, Ftprof)
1165 :
1166 : !Arguments -----------------------------------
1167 : !scalars
1168 : class(FFT_test_t),intent(inout) :: Ftest
1169 : integer,intent(in) :: map2sphere,use_padfft,osc_npw
1170 : character(len=500),intent(out) :: header
1171 : class(FFT_prof_t),intent(out) :: Ftprof
1172 : !arrays
1173 : integer,intent(in) :: osc_gvec(3,osc_npw)
1174 :
1175 : !Local variables-------------------------------
1176 : !scalars
1177 : integer,parameter :: nspinor1=1,dim_rtwg1=1,istwfk1=1
1178 : integer :: icall,ifft,itim1,itim2,nfft,dat,sprc,ptr,ndat, n1,n2,n3,n4,n5,n6
1179 : real(dp) :: cpu_time,wall_time,gflops
1180 : complex(dp) :: ktabp1 = cone, ktabp2 = cone
1181 : character(len=TNAME_LEN) :: test_name
1182 : logical :: not_implemented
1183 6 : type(MPI_type) :: MPI_enreg_seq
1184 : !arrays
1185 : !integer,parameter :: g1(3)=[1,1,2],g2(3)=[-1,-2,-1]
1186 : integer,parameter :: g1(3)=[-1,0,0], g2(3)=[1,0,0]
1187 6 : integer,allocatable :: gbound(:,:), ktabr1(:), ktabr2(:), igfftg0(:)
1188 : real(dp),parameter :: spinrot1(4)=(/one,zero,zero,one/),spinrot2(4)=(/one,zero,zero,one/)
1189 6 : logical,allocatable :: mask(:)
1190 6 : complex(dp),allocatable :: results(:)
1191 6 : complex(gwp),allocatable :: rhotwg(:), wfn1(:), wfn2(:)
1192 : ! *********************************************************************
1193 :
1194 6 : test_name = Ftest%get_name()
1195 :
1196 6 : nfft = Ftest%nfft; ndat = Ftest%ndat
1197 6 : n1=Ftest%ngfft(1); n2=Ftest%ngfft(2); n3=Ftest%ngfft(3)
1198 6 : n4=Ftest%ngfft(4); n5=Ftest%ngfft(5); n6=Ftest%ngfft(6)
1199 :
1200 6 : write(header,'(3(a,i2))')"rho_tw_g with use_padfft ",use_padfft,", map2sphere ",map2sphere,", ndat ",ndat
1201 :
1202 : ! TODO: zero-pad not available with SG2001 routines.
1203 6 : not_implemented = (use_padfft==1.and.Ftest%ngfft(7) == 412)
1204 :
1205 6 : if (Ftest%available==0.or.not_implemented) then
1206 3 : call Ftprof%init(test_name,0,0,0,0,zero,zero,zero)
1207 3 : return
1208 : end if
1209 :
1210 3 : call xomp_set_num_threads(Ftest%nthreads)
1211 :
1212 3 : if (Ftest%ngfft(7)/100 == FFT_FFTW3) call fftw3_set_nthreads(Ftest%nthreads)
1213 :
1214 3 : call initmpi_seq(MPI_enreg_seq)
1215 3 : call MPI_enreg_seq%distribfft%init_seq('c',n2,n3,'all')
1216 :
1217 3 : itim1=1; itim2=1
1218 9 : ABI_MALLOC(ktabr1,(nfft))
1219 6 : ABI_MALLOC(ktabr2,(nfft))
1220 :
1221 2187003 : do ifft=1,nfft
1222 2187000 : ktabr1(ifft)= ifft
1223 2187003 : ktabr2(ifft)= ifft
1224 : end do
1225 :
1226 9 : ABI_MALLOC(igfftg0,(osc_npw*map2sphere))
1227 :
1228 3 : if (map2sphere > 0) then
1229 9 : ABI_MALLOC(mask,(osc_npw))
1230 3 : call kgindex(igfftg0,osc_gvec,mask,MPI_enreg_seq,Ftest%ngfft,osc_npw)
1231 36162 : ABI_CHECK(ALL(mask)," FFT parallelism not supported")
1232 3 : ABI_FREE(mask)
1233 : end if
1234 :
1235 12 : ABI_MALLOC(gbound,(2*Ftest%mgfft+8,2*use_padfft))
1236 3 : if (use_padfft == 1) call sphereboundary(gbound,istwfk1,osc_gvec,Ftest%mgfft,osc_npw)
1237 :
1238 9 : ABI_MALLOC(wfn1, (nfft*nspinor1*ndat))
1239 6 : ABI_MALLOC(wfn2, (nfft*nspinor1*ndat))
1240 :
1241 6 : do dat=1,ndat
1242 9 : do sprc=1,nspinor1
1243 3 : ptr = 1 + (sprc-1)*nfft + (dat-1)*nfft*nspinor1
1244 3 : call calc_ceigr(g1,nfft,nspinor1,Ftest%ngfft,wfn1(ptr:))
1245 6 : call calc_ceigr(g2,nfft,nspinor1,Ftest%ngfft,wfn2(ptr:))
1246 : end do
1247 : end do
1248 :
1249 9 : ABI_MALLOC(rhotwg,(osc_npw*dim_rtwg1*ndat))
1250 6 : ABI_MALLOC(results,(osc_npw*dim_rtwg1*ndat))
1251 :
1252 3 : call cwtime(cpu_time, wall_time, gflops, "start")
1253 :
1254 18 : do icall=1,NCALLS_FOR_TEST
1255 15 : ifft = empty_cache(CACHE_KBSIZE)
1256 : call rho_tw_g(nspinor1,osc_npw,nfft,ndat,Ftest%ngfft,map2sphere,use_padfft,igfftg0,gbound,&
1257 : wfn1,itim1,ktabr1,ktabp1,spinrot1,&
1258 : wfn2,itim2,ktabr2,ktabp2,spinrot2,&
1259 15 : dim_rtwg1,rhotwg)
1260 : ! Store results at the first call.
1261 36180 : if (icall==1) results = rhotwg
1262 : end do
1263 :
1264 3 : call cwtime(cpu_time, wall_time, gflops, "stop")
1265 : call Ftprof%init(test_name,Ftest%nthreads,NCALLS_FOR_TEST,Ftest%ndat,ftest%gpu_option, &
1266 3 : cpu_time,wall_time,gflops,results=results)
1267 :
1268 3 : ABI_FREE(ktabr1)
1269 3 : ABI_FREE(ktabr2)
1270 3 : ABI_FREE(igfftg0)
1271 3 : ABI_FREE(gbound)
1272 3 : ABI_FREE(rhotwg)
1273 3 : ABI_FREE(wfn1)
1274 3 : ABI_FREE(wfn2)
1275 3 : ABI_FREE(results)
1276 3 : call destroy_mpi_enreg(MPI_enreg_seq)
1277 :
1278 12 : end subroutine time_rhotwg
1279 : !!***
1280 :
1281 : !----------------------------------------------------------------------
1282 :
1283 : !!****f* m_FFT_prof/time_fftu
1284 : !! NAME
1285 : !! time_fftu
1286 : !!
1287 : !! FUNCTION
1288 : !! Profiling of the fftu routines.
1289 : !!
1290 : !! INPUTS
1291 : !!
1292 : !! OUTPUT
1293 : !!
1294 : !! SOURCE
1295 :
1296 6 : subroutine time_fftu(Ftest, isign, header, Ftprof)
1297 :
1298 : !Arguments -----------------------------------
1299 : class(FFT_test_t),intent(inout) :: Ftest
1300 : integer,intent(in) :: isign
1301 : character(len=500),intent(out) :: header
1302 : class(FFT_prof_t),intent(out) :: Ftprof
1303 :
1304 : !Local variables-------------------------------
1305 : !scalars
1306 : integer,parameter :: nspinor1=1
1307 : integer :: icall,i1,i2,i3,n1,n2,n3,ifft,npw_k,ndat,dat,nfft,cnt,ipw,padat,istwf_k
1308 : !integer :: n4,n5,n6,n456,idx
1309 : real(dp) :: cpu_time,wall_time,gflops,gsq,g0dotr
1310 : logical :: not_implemented
1311 : !character(len=500) :: msg
1312 : character(len=TNAME_LEN) :: test_name
1313 : !arrays
1314 : integer,parameter :: g0(3) = [1,-2,1]
1315 : integer :: gg(3)
1316 6 : integer,allocatable :: kg_k(:,:),gbound(:,:)
1317 6 : complex(dp),allocatable :: ug(:),results(:),ur(:)
1318 : ! *********************************************************************
1319 :
1320 6 : test_name = Ftest%get_name()
1321 :
1322 6 : n1=Ftest%ngfft(1); n2=Ftest%ngfft(2); n3=Ftest%ngfft(3)
1323 : !n4=Ftest%ngfft(4); n5=Ftest%ngfft(5); n6=Ftest%ngfft(6)
1324 :
1325 6 : nfft = n1*n2*n3
1326 : !n456 = n4*n5*n6
1327 6 : ndat = Ftest%ndat
1328 :
1329 6 : write(header,'(2(a,i2))')" fftu with isign ",isign,", ndat ",ndat
1330 :
1331 : ! TODO: zero-pad not available with SG2001 routines.
1332 6 : not_implemented = (Ftest%ngfft(7) == 412)
1333 :
1334 6 : if (Ftest%available==0.or.not_implemented) then
1335 4 : call Ftprof%init(test_name,0,0,0,0,zero,zero,zero)
1336 : return
1337 : end if
1338 :
1339 2 : call xomp_set_num_threads(Ftest%nthreads)
1340 :
1341 2 : if (Ftest%ngfft(7)/100 == FFT_FFTW3) call fftw3_set_nthreads(Ftest%nthreads)
1342 : !
1343 2 : istwf_k = Ftest%istwf_k
1344 : !istwf_k = 1 ! Do not use istwf_k trick here
1345 2 : call get_kg(Ftest%kpoint,istwf_k,Ftest%ecut,Ftest%gmet,npw_k,kg_k)
1346 :
1347 8 : ABI_MALLOC(gbound,(2*Ftest%mgfft+8,2))
1348 2 : call sphereboundary(gbound,istwf_k,kg_k,Ftest%mgfft,npw_k)
1349 :
1350 6 : ABI_MALLOC(ug,(npw_k*ndat))
1351 6 : ABI_MALLOC(ur, (nfft*ndat))
1352 4 : ABI_MALLOC(results,(nfft*ndat))
1353 1458002 : results=czero ! needed for R --> G since npw_k < nfft
1354 :
1355 2 : if (isign==1) then
1356 34169 : do cnt=0,(npw_k * ndat) - 1
1357 34168 : ipw = 1 + MOD(cnt, npw_k)
1358 136672 : gg = kg_k(:,ipw)
1359 649192 : gsq = two_pi**2 * DOT_PRODUCT(gg,MATMUL(Ftest%gmet,gg))
1360 34169 : ug(cnt+1) = DCMPLX(EXP(-gsq), zero)
1361 : end do
1362 : !
1363 : ! Replicate input data
1364 1 : do dat=2,ndat
1365 0 : padat = (dat-1) * npw_k
1366 1 : do ipw=1,npw_k
1367 0 : ug(ipw+padat) = DBLE(dat) * ug(ipw)
1368 : end do
1369 : end do
1370 :
1371 1 : else if (isign==-1) then
1372 :
1373 91 : do i3=0,n3-1
1374 8191 : do i2=0,n2-1
1375 737190 : do i1=0,n1-1
1376 : g0dotr= two_pi*( g0(1)*(i1/DBLE(n1)) &
1377 : +g0(2)*(i2/DBLE(n2)) &
1378 729000 : +g0(3)*(i3/DBLE(n3)) )
1379 729000 : ifft = 1 + i1 + i2*n1 + i3*n2*n3
1380 737100 : ur(ifft)=DCMPLX(DCOS(g0dotr),DSIN(g0dotr))
1381 : end do
1382 : end do
1383 : end do
1384 : !
1385 : ! Replicate input data
1386 1 : do dat=2,ndat
1387 0 : padat = (dat-1)*nfft
1388 1 : do ifft=1,nfft
1389 0 : ur(ifft+padat) = DBLE(dat) * ur(ifft)
1390 : end do
1391 : end do
1392 :
1393 : else
1394 0 : ABI_ERROR(sjoin("Wrong isign:", itoa(isign)))
1395 : end if
1396 :
1397 2 : call cwtime(cpu_time, wall_time, gflops, "start")
1398 :
1399 12 : do icall=1,NCALLS_FOR_TEST
1400 10 : ifft = empty_cache(CACHE_KBSIZE)
1401 :
1402 : !call fftpad(ug,Ftest%ngfft,n1,n2,n3,n4,n5,n6,ndat,Ftest%mgfft,isign,gbound)
1403 12 : if (isign == +1) then
1404 5 : call fft_ug(npw_k,nfft,nspinor1,ndat,Ftest%mgfft,Ftest%ngfft,istwf_k,kg_k,gbound,ug,ur)
1405 : ! Store results at the first call.
1406 5 : if (icall == 1) call xcopy(nfft*ndat,ur,1,results,1)
1407 :
1408 : else
1409 5 : call fft_ur(npw_k,nfft,nspinor1,ndat,Ftest%mgfft,Ftest%ngfft,istwf_k,kg_k,gbound,ur,ug)
1410 : ! Store results at the first call.
1411 5 : if (icall==1) call xcopy(npw_k*ndat,ug,1,results,1)
1412 : end if
1413 : !if (isign==-1) then
1414 : ! write(Ftest%ngfft(7),*)"ngfft, isign ",Ftest%ngfft(7),isign
1415 : ! do idx =1,n4*n5*n6*ndat; write(Ftest%ngfft(7),*)idx,results(idx); end do
1416 : !end if
1417 : end do
1418 :
1419 2 : call cwtime(cpu_time, wall_time, gflops, "stop")
1420 : call Ftprof%init(test_name,Ftest%nthreads,NCALLS_FOR_TEST,ndat,ftest%gpu_option, &
1421 2 : cpu_time,wall_time,gflops,results=results)
1422 :
1423 2 : ABI_FREE(kg_k)
1424 2 : ABI_FREE(gbound)
1425 2 : ABI_FREE(ug)
1426 2 : ABI_FREE(ur)
1427 2 : ABI_FREE(results)
1428 :
1429 4 : end subroutine time_fftu
1430 : !!***
1431 :
1432 : !----------------------------------------------------------------------
1433 :
1434 : !!****f* m_FFT_prof/prof_fourdp
1435 : !! NAME
1436 : !! prof_fourdp
1437 : !!
1438 : !! FUNCTION
1439 : !! Profile fourdp
1440 : !!
1441 : !! INPUTS
1442 : !!
1443 : !! OUTPUT
1444 : !!
1445 : !! SOURCE
1446 :
1447 0 : subroutine prof_fourdp(fft_setups, isign, cplex, necut, ecut_arth, boxcutmin, rprimd, nsym, symrel, MPI_enreg_in)
1448 :
1449 : !Arguments -----------------------------------
1450 : !scalars
1451 : integer,intent(in) :: nsym,isign,cplex,necut
1452 : real(dp),intent(in) :: boxcutmin
1453 : type(MPI_type),intent(in) :: MPI_enreg_in
1454 : !arrays
1455 : integer,intent(in) :: fft_setups(:,:),symrel(3,3,nsym)
1456 : real(dp),intent(in) :: ecut_arth(2)
1457 : real(dp),intent(in) :: rprimd(3,3)
1458 :
1459 : !Local variables-------------------------------
1460 : !scalars
1461 : integer :: iec,nsetups,set,funt
1462 0 : type(FFT_test_t) :: Ftest
1463 0 : type(FFT_prof_t) :: Ftprof
1464 : character(len=500) :: msg,frm,header
1465 : character(len=fnlen) :: fname
1466 : !arrays
1467 0 : integer :: ngfft_ecut(18,necut)
1468 : real(dp),parameter :: k_gamma(3)=zero
1469 0 : real(dp) :: ecut_list(necut)
1470 0 : real(dp),allocatable :: prof_res(:,:,:)
1471 : ! *********************************************************************
1472 :
1473 0 : nsetups = size(fft_setups, dim=2)
1474 0 : ecut_list = arth(ecut_arth(1), ecut_arth(2), necut)
1475 :
1476 : ! Open file and write header with info.
1477 0 : write(fname,'(2(a,i1))')"PROF_fourdp_cplex",cplex,"_isign",isign
1478 0 : if (open_file(fname, msg, newunit=funt) /= 0) then
1479 0 : ABI_ERROR(msg)
1480 : end if
1481 :
1482 0 : write(msg,'(2(a,i0))')"Benchmark: routine = fourdp, cplex =",cplex,", isign=",isign
1483 0 : write(std_out,'(a)')" Running "//TRIM(msg)
1484 :
1485 0 : write(funt,'(a)')"# "//TRIM(msg)
1486 0 : do set=1,nsetups
1487 0 : write(funt,'(a, 6(a,i0))') "#",&
1488 0 : " fftalg = " ,fft_setups(1,set), &
1489 0 : ", fftcache = " ,fft_setups(2,set), &
1490 0 : ", ndat = " ,fft_setups(3,set), &
1491 0 : ", nthreads = " ,fft_setups(4,set), &
1492 0 : ", available = ",fft_setups(5,set), &
1493 0 : ", gpu_option = ",fft_setups(6,set)
1494 : end do
1495 :
1496 0 : ABI_MALLOC(prof_res,(2,necut,nsetups))
1497 :
1498 0 : do set=1,nsetups
1499 0 : do iec=1,necut
1500 0 : call Ftest%init(fft_setups(:,set),k_gamma,ecut_list(iec),boxcutmin,rprimd,nsym,symrel,MPI_enreg_in)
1501 0 : call Ftest%time_fourdp(isign, cplex, header, Ftprof)
1502 :
1503 0 : prof_res(1,iec,set) = Ftprof%cpu_time /Ftprof%ncalls
1504 0 : prof_res(2,iec,set) = Ftprof%wall_time/Ftprof%ncalls
1505 :
1506 : ! Save FFT divisions.
1507 0 : if (set == 1) ngfft_ecut(:,iec) = Ftest%ngfft
1508 :
1509 0 : call Ftprof%free()
1510 0 : call Ftest%free()
1511 : end do
1512 : end do
1513 :
1514 : ! Write the wall-time as a function of ecut.
1515 0 : write(frm,*)"(f7.1,3i4,",nsetups,"(f7.4))"
1516 0 : do iec=1,necut
1517 0 : write(funt,frm) ecut_list(iec),ngfft_ecut(4:6,iec),prof_res(2,iec,:)
1518 : end do
1519 :
1520 0 : close(funt)
1521 0 : ABI_FREE(prof_res)
1522 :
1523 0 : end subroutine prof_fourdp
1524 : !!***
1525 :
1526 : !----------------------------------------------------------------------
1527 :
1528 : !!****f* m_FFT_prof/prof_fourwf
1529 : !! NAME
1530 : !! prof_fourwf
1531 : !!
1532 : !! FUNCTION
1533 : !! profile fourwf
1534 : !!
1535 : !! INPUTS
1536 : !!
1537 : !! OUTPUT
1538 : !!
1539 : !! SOURCE
1540 :
1541 0 : subroutine prof_fourwf(fft_setups, cplex, option, kpoint, necut, ecut_arth, &
1542 0 : boxcutmin, rprimd, nsym, symrel, MPI_enreg_in)
1543 :
1544 : !Arguments -----------------------------------
1545 : !scalars
1546 : integer,intent(in) :: nsym,cplex,necut,option
1547 : real(dp),intent(in) :: boxcutmin
1548 : type(MPI_type),intent(in) :: MPI_enreg_in
1549 : !arrays
1550 : integer,intent(in) :: fft_setups(:,:),symrel(3,3,nsym)
1551 : real(dp),intent(in) :: ecut_arth(2)
1552 : real(dp),intent(in) :: kpoint(3),rprimd(3,3)
1553 :
1554 : !Local variables-------------------------------
1555 : !scalars
1556 : integer :: iec,nsetups,set,funt,istwf_k
1557 0 : type(FFT_test_t) :: Ftest
1558 0 : type(FFT_prof_t) :: Ftprof
1559 : character(len=500) :: msg,frm,header
1560 : character(len=fnlen) :: fname
1561 : !arrays
1562 0 : integer :: ngfft_ecut(18,necut)
1563 0 : real(dp) :: ecut_list(necut)
1564 0 : real(dp),allocatable :: prof_res(:,:,:)
1565 : ! *********************************************************************
1566 :
1567 0 : nsetups = size(fft_setups, dim=2)
1568 0 : ecut_list = arth(ecut_arth(1), ecut_arth(2), necut)
1569 0 : istwf_k = set_istwfk(kpoint)
1570 :
1571 : ! Open file and write header with info.
1572 0 : write(fname,'(3(a,i1))')"PROF_fourwf_cplex",cplex,"_option",option,"_istwfk",istwf_k
1573 0 : if (open_file(fname, msg, newunit=funt) /= 0) then
1574 0 : ABI_ERROR(msg)
1575 : end if
1576 :
1577 0 : write(msg,'(3(a,i1))')"Benchmark: routine = fourwf, cplex = ",cplex,", option= ",option,", istwfk= ",istwf_k
1578 0 : write(std_out,'(a)')" Running "//TRIM(msg)
1579 :
1580 0 : write(funt,'(a)')"# "//TRIM(msg)
1581 0 : do set=1,nsetups
1582 0 : write(funt,'(a,6(a,i0))') "#",&
1583 0 : " fftalg = " ,fft_setups(1,set), &
1584 0 : ", fftcache = " ,fft_setups(2,set), &
1585 0 : ", ndat = " ,fft_setups(3,set), &
1586 0 : ", nthreads = " ,fft_setups(4,set), &
1587 0 : ", available = ",fft_setups(5,set), &
1588 0 : ", gpu_option = ",fft_setups(6,set)
1589 : end do
1590 :
1591 0 : ABI_MALLOC(prof_res,(2,necut,nsetups))
1592 :
1593 0 : do set=1,nsetups
1594 0 : do iec=1,necut
1595 0 : call Ftest%init(fft_setups(:,set),kpoint,ecut_list(iec),boxcutmin,rprimd,nsym,symrel,MPI_enreg_in)
1596 0 : call Ftest%time_fourwf(cplex, option, header, Ftprof)
1597 :
1598 0 : prof_res(1,iec,set) = Ftprof%cpu_time /Ftprof%ncalls
1599 0 : prof_res(2,iec,set) = Ftprof%wall_time/Ftprof%ncalls
1600 :
1601 : ! Save FFT divisions.
1602 0 : if (set == 1) ngfft_ecut(:,iec) = Ftest%ngfft
1603 0 : call Ftprof%free()
1604 0 : call Ftest%free()
1605 : end do
1606 : end do
1607 :
1608 : ! Write the wall-time as a function of ecut.
1609 0 : write(frm,*)"(f7.1,3i4,",nsetups,"(f7.4))"
1610 0 : do iec=1,necut
1611 0 : write(funt,frm) ecut_list(iec),ngfft_ecut(4:6,iec),prof_res(2,iec,:)
1612 : end do
1613 :
1614 0 : close(funt)
1615 0 : ABI_FREE(prof_res)
1616 :
1617 0 : end subroutine prof_fourwf
1618 : !!***
1619 :
1620 : !----------------------------------------------------------------------
1621 :
1622 : !!****f* m_FFT_prof/prof_rhotwg
1623 : !! NAME
1624 : !! prof_rhotwg
1625 : !!
1626 : !! FUNCTION
1627 : !! profile rhotwg
1628 : !!
1629 : !! INPUTS
1630 : !!
1631 : !! OUTPUT
1632 : !!
1633 : !! SOURCE
1634 :
1635 0 : subroutine prof_rhotwg(fft_setups,map2sphere,use_padfft,necut,ecut_arth,osc_ecut,boxcutmin,&
1636 0 : rprimd,nsym,symrel,gmet,MPI_enreg_in)
1637 :
1638 : !Arguments -----------------------------------
1639 : !scalars
1640 : integer,intent(in) :: nsym,necut,map2sphere,use_padfft
1641 : real(dp),intent(in) :: boxcutmin,osc_ecut
1642 : type(MPI_type),intent(in) :: MPI_enreg_in
1643 : !arrays
1644 : integer,intent(in) :: fft_setups(:,:),symrel(3,3,nsym)
1645 : real(dp),intent(in) :: ecut_arth(2)
1646 : real(dp),intent(in) :: rprimd(3,3),gmet(3,3)
1647 :
1648 : !Local variables-------------------------------
1649 : !scalars
1650 : integer :: iec,nsetups,set,funt,osc_npw
1651 0 : type(FFT_test_t) :: Ftest
1652 0 : type(FFT_prof_t) :: Ftprof
1653 : character(len=500) :: msg,frm,header
1654 : character(len=fnlen) :: fname
1655 : !arrays
1656 0 : integer,allocatable :: osc_gvec(:,:)
1657 0 : integer :: ngfft_ecut(18,necut)
1658 : real(dp),parameter :: k_gamma(3)=zero
1659 0 : real(dp) :: ecut_list(necut)
1660 0 : real(dp),allocatable :: prof_res(:,:,:)
1661 : ! *********************************************************************
1662 :
1663 0 : nsetups = size(fft_setups, dim=2)
1664 0 : ecut_list = arth(ecut_arth(1), ecut_arth(2), necut)
1665 :
1666 : ! Open file and write header with info.
1667 0 : write(fname,'(2(a,i1))')"PROF_rhotwg_map2sphere",map2sphere,"_use_padfft",use_padfft
1668 0 : if (open_file(fname, msg, newunit=funt) /= 0) then
1669 0 : ABI_ERROR(msg)
1670 : end if
1671 :
1672 : write(msg,'(2(a,i0),a,f5.1)') &
1673 0 : "Benchmark: routine = rho_tw_g, map2sphere = ",map2sphere,", use_padfft = ",use_padfft,", osc_ecut = ",osc_ecut
1674 0 : write(std_out,'(a)')" Running "//TRIM(msg)
1675 :
1676 0 : write(funt,'(a)')"# "//TRIM(msg)
1677 0 : do set=1,nsetups
1678 0 : write(funt,'(a,6(a,i0))') "#",&
1679 0 : " fftalg = " ,fft_setups(1,set),&
1680 0 : ", fftcache = " ,fft_setups(2,set),&
1681 0 : ", ndat = " ,fft_setups(3,set),&
1682 0 : ", nthreads = " ,fft_setups(4,set),&
1683 0 : ", available = ",fft_setups(5,set),&
1684 0 : ", gpu_option = ",fft_setups(6,set)
1685 : end do
1686 :
1687 0 : call get_kg([zero,zero,zero],1,osc_ecut,gmet,osc_npw,osc_gvec)
1688 : ! TODO should reorder by shells to be consistent with the GW part!
1689 : ! Moreover I guess this ordering is more efficient when we have
1690 : ! to map the box to the G-sphere!
1691 :
1692 0 : ABI_MALLOC(prof_res,(2,necut,nsetups))
1693 :
1694 0 : do set=1,nsetups
1695 0 : do iec=1,necut
1696 0 : call Ftest%init(fft_setups(:,set),k_gamma,ecut_list(iec),boxcutmin,rprimd,nsym,symrel,MPI_enreg_in)
1697 :
1698 0 : call Ftest%time_rhotwg(map2sphere,use_padfft,osc_npw,osc_gvec,header,Ftprof)
1699 :
1700 0 : prof_res(1,iec,set) = Ftprof%cpu_time /Ftprof%ncalls
1701 0 : prof_res(2,iec,set) = Ftprof%wall_time/Ftprof%ncalls
1702 : ! Save FFT divisions.
1703 0 : if (set==1) ngfft_ecut(:,iec) = Ftest%ngfft
1704 :
1705 0 : call Ftprof%free()
1706 0 : call Ftest%free()
1707 : end do
1708 : end do
1709 :
1710 : ! Write the wall-time as a function of ecut.
1711 0 : write(frm,*)"(f7.1,3i4,",nsetups,"(f7.4))"
1712 0 : do iec=1,necut
1713 0 : write(funt,frm) ecut_list(iec),ngfft_ecut(4:6,iec),prof_res(2,iec,:)
1714 : end do
1715 :
1716 0 : close(funt)
1717 0 : ABI_FREE(prof_res)
1718 0 : ABI_FREE(osc_gvec)
1719 :
1720 0 : end subroutine prof_rhotwg
1721 : !!***
1722 :
1723 : !----------------------------------------------------------------------
1724 :
1725 : !!****f* m_FFT_prof/empty_cache
1726 : !! NAME
1727 : !! empty_cache
1728 : !!
1729 : !! FUNCTION
1730 : !! Empty the memory cache
1731 : !!
1732 : !! INPUTS
1733 : !!
1734 : !! OUTPUT
1735 : !!
1736 : !! SOURCE
1737 :
1738 1445 : integer function empty_cache(kbsize) result(fake)
1739 :
1740 : !Arguments -----------------------------------
1741 : integer,intent(in) :: kbsize
1742 :
1743 : !Local variables-------------------------------
1744 : integer :: sz
1745 1445 : real(dp),allocatable :: chunk(:)
1746 : ! *********************************************************************
1747 :
1748 1445 : fake = 0
1749 1445 : if (kbsize <= 0) RETURN
1750 :
1751 0 : sz = int((100._dp * kbsize) / dp)
1752 :
1753 0 : ABI_MALLOC(chunk,(sz))
1754 0 : call random_number(chunk)
1755 0 : fake = int(SUM(chunk)) ! Need a result, otherwise smart compilers may skip the call.
1756 0 : ABI_FREE(chunk)
1757 :
1758 1445 : end function empty_cache
1759 : !!***
1760 :
1761 : !----------------------------------------------------------------------
1762 :
1763 1612 : end module m_FFT_prof
1764 : !!***
|
