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