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