Branch data Line data Source code
1 : : block
2 : : !Local variables-------------------------------
3 : : !scalars
4 : : integer,parameter :: ndat1 = 1, option3 = 3, cplex0 = 0, npwin0 = 0
5 : : integer :: ldxyz,gsp_pt,box_pt,nthreads,dat,ug_ptr,ur_ptr
6 : : real(dp),parameter :: weight_i=one,weight_r=one
7 : : logical :: use_fftrisc
8 : : !arrays
9 : : integer :: ngfft(18),kg_kin0(3,0)
10 : : real(dp) :: denpot(0,0,0)
11 : : ! *************************************************************************
12 : :
13 : 780004 : ldxyz = ldx*ldy*ldz
14 : :
15 : : ! TODO ndat > 1 with threads and istwf_k == 2.
16 : : !use_fftrisc = (mod(fftalg,10)==2 .and. istwf_k==1 .and. ndat==1)
17 [ - - - - : 780004 : use_fftrisc = (mod(fftalg, 10) == 2 .and. istwf_k == 1)
+ - + + +
- + + ]
18 : :
19 : : if (use_fftrisc) then
20 : : !call wrtout(std_out, "fft_ug: using_fftrisc")
21 : :
22 : : ! Initialize ngfft
23 [ - - + + : 7019748 : ngfft(1:8) = [nx, ny, nz, ldx, ldy, ldz, fftalg, fftcache]
+ + ]
24 : :
25 [ - - + + : 2339916 : call C_F_pointer(c_loc(ug), real_ug, shape=[2, npw_k*ndat])
+ + ]
26 [ - - + + : 2339916 : call C_F_pointer(c_loc(ur), real_ur, shape=[2, ldx*ldy*ldz*ndat])
+ + ]
27 : :
28 [ - - - + : 779972 : if (fftcore_mixprec == 0) then
- + ]
29 : : !$OMP PARALLEL DO PRIVATE(ug_ptr, ur_ptr) IF (ndat > 1)
30 [ - - + + : 1559950 : do dat=1,ndat
+ + ]
31 : 779978 : ug_ptr = 1 + (dat-1)*npw_k
32 : 779978 : ur_ptr = 1 + (dat-1)*ldx*ldy*ldz
33 : : call FFT_PREF_fftrisc (cplex0,denpot,dum_ugin,real_ug(:,ug_ptr:),real_ur(:,ur_ptr:),&
34 : 1559950 : gbound,gbound,istwf_k,kg_kin0,kg_k,mgfft,ngfft,npwin0,npw_k,ldx,ldy,ldz,option3,weight_r,weight_i)
35 : : end do
36 : : else
37 : : ! Mixed precision FFT but only if we have double precision API
38 : : !$OMP PARALLEL DO PRIVATE(ug_ptr, ur_ptr) IF (ndat > 1)
39 [ # # # # : 0 : do dat=1,ndat
# # ]
40 : 0 : ug_ptr = 1 + (dat-1)*npw_k
41 : 0 : ur_ptr = 1 + (dat-1)*ldx*ldy*ldz
42 : : #if FFT_PRECISION == FFT_DOUBLE
43 : : call FFT_PREF_fftrisc_mixprec (cplex0,denpot,dum_ugin,real_ug(:,ug_ptr:),real_ur(:,ur_ptr:),&
44 : 0 : gbound,gbound,istwf_k,kg_kin0,kg_k,mgfft,ngfft,npwin0,npw_k,ldx,ldy,ldz,option3,weight_r,weight_i)
45 : : #elif FFT_PRECISION == FFT_SINGLE
46 : : call FFT_PREF_fftrisc (cplex0,denpot,dum_ugin,real_ug(:,ug_ptr:),real_ur(:,ur_ptr:),&
47 : 0 : gbound,gbound,istwf_k,kg_kin0,kg_k,mgfft,ngfft,npwin0,npw_k,ldx,ldy,ldz,option3,weight_r,weight_i)
48 : : #else
49 : : #error "Wrong FFT precision"
50 : : #endif
51 : :
52 : : end do
53 : : end if
54 : :
55 : : else
56 : :
57 : 32 : nthreads = xomp_get_num_threads(open_parallel=.TRUE.)
58 : :
59 : : if (.not. SPAWN_THREADS_HERE(ndat,nthreads)) then
60 : : ! Inplace ur --> ug
61 : 32 : call FFT_PREF_fftpad (ur,nx,ny,nz,ldx,ldy,ldz,ndat,mgfft,-1,gbound)
62 : :
63 : : ! Copy data in ug
64 : 32 : call TK_PREF_box2gsph (nx,ny,nz,ldx,ldy,ldz,ndat,npw_k,kg_k,ur,ug)
65 : :
66 : : else ! Spawn OMP threads here.
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 : :
73 : : call FFT_PREF_fftpad (ur(box_pt:),nx,ny,nz,ldx,ldy,ldz,ndat1,mgfft,-1,gbound)
74 : :
75 : : call TK_PREF_box2gsph (nx,ny,nz,ldx,ldy,ldz,ndat1,npw_k,kg_k,ur(box_pt:),ug(gsp_pt:))
76 : : end do
77 : : end if
78 : : end if
79 : :
80 : : end block
|
