Branch data Line data Source code
1 : : block
2 : : !Local variables-------------------------------
3 : : !scalars
4 : : integer,parameter :: ndat1 = 1, option0 = 0, cplex0 = 0, npwout0 = 0
5 : : integer :: ldxyz,gsp_pt,box_pt,nthreads,dat,ug_ptr,ur_ptr
6 : : real(dp),parameter :: weight1_i=one, weight1_r=one
7 : : logical :: use_fftrisc
8 : : !arrays
9 : : integer :: ngfft(18)
10 : : real(dp) :: denpot(0,0,0)
11 : : ! *************************************************************************
12 : :
13 : : ! FFT: ug -> ur
14 [ - - - - : 215006 : use_fftrisc = mod(fftalg, 10) == 2 .and. any(istwf_k== [1, 2])
+ - + + +
- + + ]
15 : :
16 : : if (use_fftrisc) then
17 : : !call wrtout(std_out, "fft_ug: using_fftrisc")
18 : : !
19 : : ! Initialize ngfft
20 [ - - + + : 1916784 : ngfft(1:8) = [nx, ny, nz, ldx, ldy, ldz, fftalg, fftcache]
+ + ]
21 : :
22 [ - - + + : 638928 : call C_F_pointer(c_loc(ug), real_ug, shape=[2, npw_k*ndat])
+ + ]
23 [ - - + + : 638928 : call C_F_pointer(c_loc(ur), real_ur, shape=[2, ldx*ldy*ldz*ndat])
+ + ]
24 : :
25 [ - - - + : 212976 : if (fftcore_mixprec == 0) then
- + ]
26 : : !$OMP PARALLEL DO PRIVATE(ug_ptr, ur_ptr) IF (ndat > 1)
27 [ - - + + : 426754 : do dat=1,ndat
+ + ]
28 : 213778 : ug_ptr = 1 + (dat-1)*npw_k
29 : 213778 : ur_ptr = 1 + (dat-1)*ldx*ldy*ldz
30 : : call FFT_PREF_fftrisc (cplex0,denpot,real_ug(:,ug_ptr:),fofgout,real_ur(:,ur_ptr:), &
31 : : gbound,gbound,istwf_k,kg_k,kg_k,mgfft,ngfft,npw_k,npwout0,ldx,ldy,ldz,option0,weight1_r,weight1_i, &
32 : 426754 : abi_convention=(isign__==+1), iscale=iscale__)
33 : : end do
34 : :
35 : : else
36 : : ! Mixed precision FFT but only if we have the double precision API.
37 : : !$OMP PARALLEL DO PRIVATE(ug_ptr, ur_ptr) IF (ndat > 1)
38 [ # # # # : 0 : do dat=1,ndat
# # ]
39 : 0 : ug_ptr = 1 + (dat-1)*npw_k
40 : 0 : ur_ptr = 1 + (dat-1)*ldx*ldy*ldz
41 : : #if FFT_PRECISION == FFT_DOUBLE
42 : : call FFT_PREF_fftrisc_mixprec (cplex0,denpot,real_ug(:,ug_ptr:),fofgout,real_ur(:,ur_ptr:),&
43 : : gbound,gbound,istwf_k,kg_k,kg_k,mgfft,ngfft,npw_k,npwout0,ldx,ldy,ldz,option0,weight1_r,weight1_i, &
44 : 0 : abi_convention=(isign__==+1), iscale=iscale__)
45 : : #elif FFT_PRECISION == FFT_SINGLE
46 : : call FFT_PREF_fftrisc (cplex0,denpot,real_ug(:,ug_ptr:),fofgout,real_ur(:,ur_ptr:),&
47 : : gbound,gbound,istwf_k,kg_k,kg_k,mgfft,ngfft,npw_k,npwout0,ldx,ldy,ldz,option0,weight1_r,weight1_i, &
48 : 0 : abi_convention=(isign__==+1), iscale=iscale__)
49 : : #else
50 : : #error "Wrong FFT precision"
51 : : #endif
52 : : end do
53 : : end if
54 : :
55 : : else
56 : 2030 : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
57 : :
58 : : if (.not. SPAWN_THREADS_HERE(ndat, nthreads)) then
59 : : ! Insert ug in ur defined on the (augmented) FFT mesh
60 : 2030 : call TK_PREF_gsph2box (nx, ny, nz, ldx, ldy, ldz, ndat, npw_k, istwf_k, kg_k, ug, ur)
61 : : ! zero-padded FFT.
62 : 2030 : call FFT_PREF_fftpad (ur, nx, ny, nz, ldx, ldy, ldz, ndat, mgfft, isign__, gbound, iscale=iscale__)
63 : :
64 : : else
65 : : ! Spawn OMP threads here.
66 : : ldxyz = ldx*ldy*ldz
67 : :
68 : : !$OMP PARALLEL DO PRIVATE(gsp_pt, box_pt)
69 : : do dat=1,ndat
70 : : gsp_pt = 1 + dist * npw_k * (dat-1)
71 : : box_pt = 1 + dist * ldxyz * (dat-1)
72 : : ! Insert ug in ur defined on the (augmented) FFT mesh
73 : : call TK_PREF_gsph2box (nx, ny, nz, ldx, ldy, ldz, ndat1, npw_k, istwf_k, kg_k, ug(gsp_pt:), ur(box_pt:))
74 : : ! zero-padded FFT.
75 : : call FFT_PREF_fftpad (ur(box_pt:), nx, ny, nz, ldx, ldy, ldz, ndat1, mgfft, isign__, gbound, iscale=iscale__)
76 : : end do
77 : : end if
78 : : end if
79 : : end block
|
