mirror of https://gitlab.com/QEF/q-e.git
651 lines
19 KiB
Fortran
651 lines
19 KiB
Fortran
!
|
|
! Copyright (C) Quantum ESPRESSO group
|
|
!
|
|
! This file is distributed under the terms of the
|
|
! GNU General Public License. See the file `License'
|
|
! in the root directory of the present distribution,
|
|
! or http://www.gnu.org/copyleft/gpl.txt .
|
|
!
|
|
|
|
#if defined(__LINUX_ESSL)
|
|
|
|
#if defined(_OPENMP) && defined(__FFT_SCALAR_THREAD_SAFE)
|
|
! thread safety guard
|
|
#error ESSL is not compatiable with __FFT_SCALAR_THREAD_SAFE
|
|
#endif
|
|
|
|
!=----------------------------------------------------------------------=!
|
|
MODULE fft_scalar_essl
|
|
!=----------------------------------------------------------------------=!
|
|
|
|
USE fft_param
|
|
|
|
IMPLICIT NONE
|
|
SAVE
|
|
PRIVATE
|
|
PUBLIC :: cft_1z, cft_2xy, cfft3d, cfft3ds
|
|
|
|
! ... Local Parameter
|
|
|
|
|
|
! Workspace that is statically allocated is defined here
|
|
! in order to avoid multiple copies of the same workspace
|
|
! lwork: Dimension of the work space array (if any)
|
|
|
|
! ESSL IBM library: see the ESSL manual for DCFT
|
|
|
|
INTEGER, PARAMETER :: lwork = 20000 + ( 2*nfftx + 256 ) * 64 + 3*nfftx
|
|
REAL (DP) :: work( lwork )
|
|
|
|
|
|
!=----------------------------------------------------------------------=!
|
|
CONTAINS
|
|
!=----------------------------------------------------------------------=!
|
|
|
|
!
|
|
!=----------------------------------------------------------------------=!
|
|
!
|
|
!
|
|
!
|
|
! FFT along "z"
|
|
!
|
|
!
|
|
!
|
|
!=----------------------------------------------------------------------=!
|
|
!
|
|
|
|
SUBROUTINE cft_1z(c, nsl, nz, ldz, isign, cout)
|
|
|
|
! driver routine for nsl 1d complex fft's of length nz
|
|
! ldz >= nz is the distance between sequences to be transformed
|
|
! (ldz>nz is used on some architectures to reduce memory conflicts)
|
|
! input : c(ldz*nsl) (complex)
|
|
! output : cout(ldz*nsl) (complex - NOTA BENE: transform is not in-place!)
|
|
! isign > 0 : backward (f(G)=>f(R)), isign < 0 : forward (f(R) => f(G))
|
|
! Up to "ndims" initializations (for different combinations of input
|
|
! parameters nz, nsl, ldz) are stored and re-used if available
|
|
|
|
INTEGER, INTENT(IN) :: isign
|
|
INTEGER, INTENT(IN) :: nsl, nz, ldz
|
|
|
|
COMPLEX (DP) :: c(:), cout(:)
|
|
|
|
REAL (DP) :: tscale
|
|
INTEGER :: i, err, idir, ip, void
|
|
INTEGER, SAVE :: zdims( 3, ndims ) = -1
|
|
INTEGER, SAVE :: icurrent = 1
|
|
LOGICAL :: done
|
|
|
|
INTEGER :: tid
|
|
|
|
! ... Machine-Dependent parameters, work arrays and tables of factors
|
|
|
|
! ltabl Dimension of the tables of factors calculated at the
|
|
! initialization stage
|
|
|
|
#if defined(_OPENMP)
|
|
INTEGER :: offset, ldz_t
|
|
INTEGER :: omp_get_max_threads
|
|
EXTERNAL :: omp_get_max_threads
|
|
#endif
|
|
|
|
|
|
! ESSL IBM library: see the ESSL manual for DCFT
|
|
|
|
INTEGER, PARAMETER :: ltabl = 20000 + 3 * nfftx
|
|
REAL (DP), SAVE :: fw_tablez( ltabl, ndims )
|
|
REAL (DP), SAVE :: bw_tablez( ltabl, ndims )
|
|
|
|
|
|
IF( nsl < 0 ) THEN
|
|
CALL fftx_error__(" fft_scalar: cft_1z ", " nsl out of range ", nsl)
|
|
END IF
|
|
|
|
!
|
|
! Here initialize table only if necessary
|
|
!
|
|
|
|
DO ip = 1, ndims
|
|
|
|
! first check if there is already a table initialized
|
|
! for this combination of parameters
|
|
|
|
done = ( nz == zdims(1,ip) )
|
|
|
|
! The initialization in ESSL and FFTW v.3 depends on all three parameters
|
|
|
|
done = done .AND. ( nsl == zdims(2,ip) ) .AND. ( ldz == zdims(3,ip) )
|
|
IF (done) EXIT
|
|
END DO
|
|
|
|
IF( .NOT. done ) THEN
|
|
|
|
! no table exist for these parameters
|
|
! initialize a new one
|
|
|
|
! WRITE( stdout, fmt="('DEBUG cft_1z, reinitializing tables ', I3)" ) icurrent
|
|
|
|
tscale = 1.0_DP / nz
|
|
|
|
CALL DCFT ( 1, c(1), 1, ldz, cout(1), 1, ldz, nz, nsl, 1, &
|
|
tscale, fw_tablez(1, icurrent), ltabl, work(1), lwork)
|
|
CALL DCFT ( 1, c(1), 1, ldz, cout(1), 1, ldz, nz, nsl, -1, &
|
|
1.0_DP, bw_tablez(1, icurrent), ltabl, work(1), lwork)
|
|
|
|
zdims(1,icurrent) = nz; zdims(2,icurrent) = nsl; zdims(3,icurrent) = ldz;
|
|
ip = icurrent
|
|
icurrent = MOD( icurrent, ndims ) + 1
|
|
|
|
END IF
|
|
|
|
!
|
|
! Now perform the FFTs using machine specific drivers
|
|
!
|
|
|
|
#if defined(__FFT_CLOCKS)
|
|
CALL start_clock( 'cft_1z' )
|
|
#endif
|
|
|
|
|
|
! essl uses a different convention for forward/backward transforms
|
|
! wrt most other implementations: notice the sign of "idir"
|
|
|
|
IF( isign < 0 ) THEN
|
|
idir =+1
|
|
tscale = 1.0_DP / nz
|
|
CALL DCFT (0, c(1), 1, ldz, cout(1), 1, ldz, nz, nsl, idir, &
|
|
tscale, fw_tablez(1, ip), ltabl, work, lwork)
|
|
ELSE IF( isign > 0 ) THEN
|
|
idir =-1
|
|
tscale = 1.0_DP
|
|
CALL DCFT (0, c(1), 1, ldz, cout(1), 1, ldz, nz, nsl, idir, &
|
|
tscale, bw_tablez(1, ip), ltabl, work, lwork)
|
|
END IF
|
|
|
|
#if defined(__FFT_CLOCKS)
|
|
CALL stop_clock( 'cft_1z' )
|
|
#endif
|
|
|
|
RETURN
|
|
|
|
END SUBROUTINE cft_1z
|
|
|
|
!
|
|
!
|
|
!=----------------------------------------------------------------------=!
|
|
!
|
|
!
|
|
!
|
|
! FFT along "x" and "y" direction
|
|
!
|
|
!
|
|
!
|
|
!=----------------------------------------------------------------------=!
|
|
!
|
|
!
|
|
|
|
SUBROUTINE cft_2xy(r, nzl, nx, ny, ldx, ldy, isign, pl2ix)
|
|
|
|
! driver routine for nzl 2d complex fft's of lengths nx and ny
|
|
! input : r(ldx*ldy) complex, transform is in-place
|
|
! ldx >= nx, ldy >= ny are the physical dimensions of the equivalent
|
|
! 2d array: r2d(ldx, ldy) (x first dimension, y second dimension)
|
|
! (ldx>nx, ldy>ny used on some architectures to reduce memory conflicts)
|
|
! pl2ix(nx) (optional) is 1 for columns along y to be transformed
|
|
! isign > 0 : backward (f(G)=>f(R)), isign < 0 : forward (f(R) => f(G))
|
|
! Up to "ndims" initializations (for different combinations of input
|
|
! parameters nx,ny,nzl,ldx) are stored and re-used if available
|
|
|
|
IMPLICIT NONE
|
|
|
|
INTEGER, INTENT(IN) :: isign, ldx, ldy, nx, ny, nzl
|
|
INTEGER, OPTIONAL, INTENT(IN) :: pl2ix(:)
|
|
COMPLEX (DP) :: r( : )
|
|
INTEGER :: i, k, j, err, idir, ip, kk, void
|
|
REAL(DP) :: tscale
|
|
INTEGER, SAVE :: icurrent = 1
|
|
INTEGER, SAVE :: dims( 4, ndims) = -1
|
|
LOGICAL :: dofft( nfftx ), done
|
|
INTEGER, PARAMETER :: stdout = 6
|
|
|
|
#if defined(_OPENMP)
|
|
INTEGER :: offset
|
|
INTEGER :: nx_t, ny_t, nzl_t, ldx_t, ldy_t
|
|
INTEGER :: itid, mytid, ntids
|
|
INTEGER :: omp_get_thread_num, omp_get_num_threads,omp_get_max_threads
|
|
EXTERNAL :: omp_get_thread_num, omp_get_num_threads, omp_get_max_threads
|
|
#endif
|
|
|
|
INTEGER, PARAMETER :: ltabl = 20000 + 3 * nfftx
|
|
REAL (DP), SAVE :: fw_tablex( ltabl, ndims ), fw_tabley( ltabl, ndims )
|
|
REAL (DP), SAVE :: bw_tablex( ltabl, ndims ), bw_tabley( ltabl, ndims )
|
|
|
|
|
|
dofft( 1 : nx ) = .TRUE.
|
|
IF( PRESENT( pl2ix ) ) THEN
|
|
IF( SIZE( pl2ix ) < nx ) &
|
|
CALL fftx_error__( ' cft_2xy ', ' wrong dimension for arg no. 8 ', 1 )
|
|
DO i = 1, nx
|
|
IF( pl2ix(i) < 1 ) dofft( i ) = .FALSE.
|
|
END DO
|
|
END IF
|
|
|
|
! WRITE( stdout,*) 'DEBUG: ', COUNT( dofft )
|
|
|
|
!
|
|
! Here initialize table only if necessary
|
|
!
|
|
|
|
DO ip = 1, ndims
|
|
|
|
! first check if there is already a table initialized
|
|
! for this combination of parameters
|
|
|
|
done = ( ny == dims(1,ip) ) .AND. ( nx == dims(3,ip) )
|
|
done = done .AND. ( ldx == dims(2,ip) ) .AND. ( nzl == dims(4,ip) )
|
|
IF (done) EXIT
|
|
|
|
END DO
|
|
|
|
IF( .NOT. done ) THEN
|
|
|
|
! no table exist for these parameters
|
|
! initialize a new one
|
|
|
|
! WRITE( stdout, fmt="('DEBUG cft_2xy, reinitializing tables ', I3)" ) icurrent
|
|
|
|
#if defined(_OPENMP)
|
|
|
|
tscale = 1.0_DP / ( nx * ny )
|
|
CALL DCFT ( 1, r(1), ldx, 1, r(1), ldx, 1, ny, nx, 1, 1.0_DP, &
|
|
fw_tabley( 1, icurrent), ltabl, work(1), lwork )
|
|
CALL DCFT ( 1, r(1), ldx, 1, r(1), ldx, 1, ny, nx, -1, 1.0_DP, &
|
|
bw_tabley(1, icurrent), ltabl, work(1), lwork )
|
|
CALL DCFT ( 1, r(1), 1, ldx, r(1), 1, ldx, nx, ny, 1, &
|
|
tscale, fw_tablex( 1, icurrent), ltabl, work(1), lwork)
|
|
CALL DCFT ( 1, r(1), 1, ldx, r(1), 1, ldx, nx, ny, -1, &
|
|
1.0_DP, bw_tablex(1, icurrent), ltabl, work(1), lwork)
|
|
|
|
#else
|
|
|
|
tscale = 1.0_DP / ( nx * ny )
|
|
CALL DCFT ( 1, r(1), ldx, 1, r(1), ldx, 1, ny, 1, 1, 1.0_DP, &
|
|
fw_tabley( 1, icurrent), ltabl, work(1), lwork )
|
|
CALL DCFT ( 1, r(1), ldx, 1, r(1), ldx, 1, ny, 1, -1, 1.0_DP, &
|
|
bw_tabley(1, icurrent), ltabl, work(1), lwork )
|
|
CALL DCFT ( 1, r(1), 1, ldx, r(1), 1, ldx, nx, ny, 1, &
|
|
tscale, fw_tablex( 1, icurrent), ltabl, work(1), lwork)
|
|
CALL DCFT ( 1, r(1), 1, ldx, r(1), 1, ldx, nx, ny, -1, &
|
|
1.0_DP, bw_tablex(1, icurrent), ltabl, work(1), lwork)
|
|
|
|
#endif
|
|
|
|
dims(1,icurrent) = ny; dims(2,icurrent) = ldx;
|
|
dims(3,icurrent) = nx; dims(4,icurrent) = nzl;
|
|
ip = icurrent
|
|
icurrent = MOD( icurrent, ndims ) + 1
|
|
|
|
END IF
|
|
|
|
!
|
|
! Now perform the FFTs using machine specific drivers
|
|
!
|
|
|
|
#if defined(__FFT_CLOCKS)
|
|
CALL start_clock( 'cft_2xy' )
|
|
#endif
|
|
|
|
|
|
#if defined(_OPENMP)
|
|
|
|
IF( isign < 0 ) THEN
|
|
tscale = 1.0_DP / ( nx * ny )
|
|
do k = 1, nzl
|
|
kk = 1 + ( k - 1 ) * ldx * ldy
|
|
CALL DCFT ( 0, r( kk ), 1, ldx, r( kk ), 1, ldx, nx, ny, &
|
|
1, tscale, fw_tablex( 1, ip ), ltabl, work( 1 ), lwork)
|
|
CALL DCFT ( 0, r( kk ), ldx, 1, r( kk ), ldx, 1, ny, nx, &
|
|
1, 1.0_DP, fw_tabley(1, ip), ltabl, work( 1 ), lwork)
|
|
end do
|
|
ELSE IF( isign > 0 ) THEN
|
|
DO k = 1, nzl
|
|
kk = 1 + ( k - 1 ) * ldx * ldy
|
|
CALL DCFT ( 0, r( kk ), ldx, 1, r( kk ), ldx, 1, ny, nx, &
|
|
-1, 1.0_DP, bw_tabley(1, ip), ltabl, work( 1 ), lwork)
|
|
CALL DCFT ( 0, r( kk ), 1, ldx, r( kk ), 1, ldx, nx, ny, &
|
|
-1, 1.0_DP, bw_tablex(1, ip), ltabl, work( 1 ), lwork)
|
|
END DO
|
|
END IF
|
|
|
|
#else
|
|
|
|
IF( isign < 0 ) THEN
|
|
idir = 1
|
|
tscale = 1.0_DP / ( nx * ny )
|
|
do k = 1, nzl
|
|
kk = 1 + ( k - 1 ) * ldx * ldy
|
|
CALL DCFT ( 0, r(kk), 1, ldx, r(kk), 1, ldx, nx, ny, idir, &
|
|
tscale, fw_tablex( 1, ip ), ltabl, work( 1 ), lwork)
|
|
do i = 1, nx
|
|
IF( dofft( i ) ) THEN
|
|
kk = i + ( k - 1 ) * ldx * ldy
|
|
call DCFT ( 0, r( kk ), ldx, 1, r( kk ), ldx, 1, ny, 1, &
|
|
idir, 1.0_DP, fw_tabley(1, ip), ltabl, work( 1 ), lwork)
|
|
END IF
|
|
end do
|
|
end do
|
|
ELSE IF( isign > 0 ) THEN
|
|
idir = -1
|
|
DO k = 1, nzl
|
|
do i = 1, nx
|
|
IF( dofft( i ) ) THEN
|
|
kk = i + ( k - 1 ) * ldx * ldy
|
|
call DCFT ( 0, r( kk ), ldx, 1, r( kk ), ldx, 1, ny, 1, &
|
|
idir, 1.0_DP, bw_tabley(1, ip), ltabl, work( 1 ), lwork)
|
|
END IF
|
|
end do
|
|
kk = 1 + ( k - 1 ) * ldx * ldy
|
|
CALL DCFT ( 0, r( kk ), 1, ldx, r( kk ), 1, ldx, nx, ny, idir, &
|
|
1.0_DP, bw_tablex(1, ip), ltabl, work( 1 ), lwork)
|
|
END DO
|
|
END IF
|
|
#endif
|
|
|
|
#if defined(__FFT_CLOCKS)
|
|
CALL stop_clock( 'cft_2xy' )
|
|
#endif
|
|
|
|
RETURN
|
|
|
|
END SUBROUTINE cft_2xy
|
|
|
|
|
|
!
|
|
!=----------------------------------------------------------------------=!
|
|
!
|
|
!
|
|
!
|
|
! 3D scalar FFTs
|
|
!
|
|
!
|
|
!
|
|
!=----------------------------------------------------------------------=!
|
|
!
|
|
|
|
SUBROUTINE cfft3d( f, nx, ny, nz, ldx, ldy, ldz, howmany, isign )
|
|
|
|
! driver routine for 3d complex fft of lengths nx, ny, nz
|
|
! input : f(ldx*ldy*ldz) complex, transform is in-place
|
|
! ldx >= nx, ldy >= ny, ldz >= nz are the physical dimensions
|
|
! of the equivalent 3d array: f3d(ldx,ldy,ldz)
|
|
! (ldx>nx, ldy>ny, ldz>nz may be used on some architectures
|
|
! to reduce memory conflicts - not implemented for FFTW)
|
|
! isign > 0 : f(G) => f(R) ; isign < 0 : f(R) => f(G)
|
|
!
|
|
! Up to "ndims" initializations (for different combinations of input
|
|
! parameters nx,ny,nz) are stored and re-used if available
|
|
|
|
IMPLICIT NONE
|
|
|
|
INTEGER, INTENT(IN) :: nx, ny, nz, ldx, ldy, ldz, howmany, isign
|
|
COMPLEX (DP) :: f(:)
|
|
INTEGER :: i, k, j, err, idir, ip
|
|
REAL(DP) :: tscale
|
|
INTEGER, SAVE :: icurrent = 1
|
|
INTEGER, SAVE :: dims(3,ndims) = -1
|
|
|
|
IF ( nx < 1 ) &
|
|
call fftx_error__('cfft3d',' nx is less than 1 ', 1)
|
|
IF ( ny < 1 ) &
|
|
call fftx_error__('cfft3d',' ny is less than 1 ', 1)
|
|
IF ( nz < 1 ) &
|
|
call fftx_error__('cfft3d',' nz is less than 1 ', 1)
|
|
IF ( howmany /= 1 ) &
|
|
call fftx_error__('cfft3d',' howmany different from 1, not yetimplemented for ESSL ', 1)
|
|
!
|
|
! Here initialize table only if necessary
|
|
!
|
|
ip = -1
|
|
DO i = 1, ndims
|
|
|
|
! first check if there is already a table initialized
|
|
! for this combination of parameters
|
|
|
|
IF ( ( nx == dims(1,i) ) .and. &
|
|
( ny == dims(2,i) ) .and. &
|
|
( nz == dims(3,i) ) ) THEN
|
|
ip = i
|
|
EXIT
|
|
END IF
|
|
END DO
|
|
|
|
IF( ip == -1 ) THEN
|
|
|
|
! no table exist for these parameters
|
|
! initialize a new one
|
|
|
|
! no initialization for 3d FFT's from ESSL
|
|
|
|
dims(1,icurrent) = nx; dims(2,icurrent) = ny; dims(3,icurrent) = nz
|
|
ip = icurrent
|
|
icurrent = MOD( icurrent, ndims ) + 1
|
|
|
|
END IF
|
|
|
|
!
|
|
! Now perform the 3D FFT using the machine specific driver
|
|
!
|
|
|
|
IF ( isign < 0 ) THEN
|
|
tscale = 1.0_DP / ( nx * ny * nz )
|
|
idir = +1
|
|
ELSE IF( isign > 0 ) THEN
|
|
tscale = 1.0_DP
|
|
idir = -1
|
|
END IF
|
|
|
|
IF( isign /= 0 ) CALL dcft3( f(1), ldx,ldx*ldy, f(1), ldx,ldx*ldy, &
|
|
nx,ny,nz, idir, tscale, work(1), lwork)
|
|
|
|
RETURN
|
|
END SUBROUTINE cfft3d
|
|
|
|
!
|
|
!=----------------------------------------------------------------------=!
|
|
!
|
|
!
|
|
!
|
|
! 3D scalar FFTs, but using sticks!
|
|
!
|
|
!
|
|
!
|
|
!=----------------------------------------------------------------------=!
|
|
!
|
|
|
|
SUBROUTINE cfft3ds (f, nx, ny, nz, ldx, ldy, ldz, howmany, isign, &
|
|
do_fft_z, do_fft_y)
|
|
!
|
|
! driver routine for 3d complex "reduced" fft - see cfft3d
|
|
! The 3D fft are computed only on lines and planes which have
|
|
! non zero elements. These lines and planes are defined by
|
|
! the two integer vectors do_fft_y(nx) and do_fft_z(ldx*ldy)
|
|
! (1 = perform fft, 0 = do not perform fft)
|
|
! This routine is implemented only for fftw, essl, acml
|
|
! If not implemented, cfft3d is called instead
|
|
!
|
|
!----------------------------------------------------------------------
|
|
!
|
|
implicit none
|
|
|
|
integer :: nx, ny, nz, ldx, ldy, ldz, howmany, isign
|
|
!
|
|
! logical dimensions of the fft
|
|
! physical dimensions of the f array
|
|
! sign of the transformation
|
|
|
|
complex(DP) :: f ( ldx * ldy * ldz )
|
|
integer :: do_fft_y(:), do_fft_z(:)
|
|
!
|
|
integer :: m, incx1, incx2
|
|
INTEGER :: i, k, j, err, idir, ip, ii, jj
|
|
REAL(DP) :: tscale
|
|
INTEGER, SAVE :: icurrent = 1
|
|
INTEGER, SAVE :: dims(3,ndims) = -1
|
|
|
|
INTEGER, PARAMETER :: ltabl = 20000 + 3 * nfftx
|
|
REAL (DP), SAVE :: fw_table( ltabl, 3, ndims )
|
|
REAL (DP), SAVE :: bw_table( ltabl, 3, ndims )
|
|
|
|
tscale = 1.0_DP
|
|
|
|
! WRITE( stdout, fmt="('DEBUG cfft3ds :',6I6)") nx, ny, nz, ldx, ldy, ldz
|
|
! WRITE( stdout, fmt="('DEBUG cfft3ds :',24I2)") do_fft_y
|
|
! WRITE( stdout, fmt="('DEBUG cfft3ds :',24I2)") do_fft_z
|
|
|
|
|
|
IF( ny /= ldy ) &
|
|
CALL fftx_error__(' cfft3ds ', ' wrong dimensions: ny /= ldy ', 1 )
|
|
|
|
IF ( howmany /= 1 ) &
|
|
call fftx_error__('cfft3ds',' howmany different from 1, not yetimplemented for ESSL ', 1)
|
|
|
|
ip = -1
|
|
DO i = 1, ndims
|
|
|
|
! first check if there is already a table initialized
|
|
! for this combination of parameters
|
|
|
|
IF( ( nx == dims(1,i) ) .and. ( ny == dims(2,i) ) .and. &
|
|
( nz == dims(3,i) ) ) THEN
|
|
ip = i
|
|
EXIT
|
|
END IF
|
|
|
|
END DO
|
|
|
|
IF( ip == -1 ) THEN
|
|
|
|
! no table exist for these parameters
|
|
! initialize a new one
|
|
|
|
!
|
|
! ESSL sign convention for fft's is the opposite of the "usual" one
|
|
!
|
|
tscale = 1.0_DP
|
|
! x - direction
|
|
incx1 = 1; incx2 = ldx; m = ldy*nz
|
|
CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, nx, m, 1, 1.0_DP, &
|
|
fw_table( 1, 1, icurrent), ltabl, work(1), lwork )
|
|
CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, nx, m, -1, 1.0_DP, &
|
|
bw_table(1, 1, icurrent), ltabl, work(1), lwork )
|
|
! y - direction
|
|
incx1 = ldx; incx2 = ldx*ldy; m = nz;
|
|
CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, ny, m, 1, 1.0_DP, &
|
|
fw_table( 1, 2, icurrent), ltabl, work(1), lwork )
|
|
CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, ny, m, -1, 1.0_DP, &
|
|
bw_table(1, 2, icurrent), ltabl, work(1), lwork )
|
|
! z - direction
|
|
incx1 = ldx * ldy; incx2 = 1; m = 1
|
|
CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, nz, m, 1, 1.0_DP, &
|
|
fw_table(1, 3, icurrent), ltabl, work(1), lwork )
|
|
CALL DCFT ( 1, f(1), incx1, incx2, f(1), incx1, incx2, nz, m, -1, 1.0_DP, &
|
|
bw_table(1, 3, icurrent), ltabl, work(1), lwork )
|
|
|
|
|
|
dims(1,icurrent) = nx; dims(2,icurrent) = ny; dims(3,icurrent) = nz
|
|
ip = icurrent
|
|
icurrent = MOD( icurrent, ndims ) + 1
|
|
|
|
END IF
|
|
|
|
|
|
IF ( isign > 0 ) THEN
|
|
|
|
!
|
|
! k-direction ...
|
|
!
|
|
|
|
incx1 = ldx * ldy; incx2 = 1; m = 1
|
|
do i =1,nx
|
|
do j =1,ny
|
|
ii = i + ldx *(j -1)
|
|
if ( do_fft_z(ii) == 1 ) then
|
|
call dcft (0, f( ii ), incx1, incx2, f( ii ), incx1, incx2, nz, m, &
|
|
-isign, 1.0_DP, bw_table ( 1, 3, ip ), ltabl, work( 1 ), lwork)
|
|
end if
|
|
end do
|
|
end do
|
|
|
|
!
|
|
! ... j-direction ...
|
|
!
|
|
|
|
incx1 = ldx; incx2 = ldx*ldy; m = nz
|
|
|
|
do i = 1, nx
|
|
if ( do_fft_y( i ) == 1 ) then
|
|
call dcft (0, f (i), incx1, incx2, f (i), incx1, incx2, nx, m, &
|
|
-isign, 1.0_DP, bw_table ( 1, 2, ip ), ltabl, work( 1 ), lwork)
|
|
endif
|
|
enddo
|
|
|
|
!
|
|
! ... i - direction
|
|
!
|
|
|
|
incx1 = 1; incx2 = ldx; m = ldy * nz
|
|
|
|
call dcft (0, f (1), incx1,incx2, f (1), incx1,incx2, nx, m, &
|
|
-isign, 1.0_DP, bw_table ( 1, 1, ip ), ltabl, work( 1 ), lwork)
|
|
|
|
|
|
ELSE
|
|
|
|
!
|
|
! i - direction ...
|
|
!
|
|
|
|
incx1 = 1; incx2 = ldx; m = ldy*nz
|
|
|
|
call dcft (0, f (1), incx1,incx2, f (1), incx1,incx2, nx, m, &
|
|
-isign, 1.0_DP, fw_table ( 1, 1, ip ), ltabl, work( 1 ), lwork)
|
|
|
|
!
|
|
! ... j-direction ...
|
|
!
|
|
|
|
incx1 = ldx; incx2 = ldx*ldy; m = nz
|
|
|
|
do i = 1, nx
|
|
if ( do_fft_y ( i ) == 1 ) then
|
|
call dcft (0, f (i), incx1, incx2, f (i), incx1, incx2, ny, m, &
|
|
-isign, 1.0_DP, fw_table ( 1, 2, ip ), ltabl, work( 1 ), lwork)
|
|
endif
|
|
enddo
|
|
|
|
!
|
|
! ... k-direction
|
|
!
|
|
|
|
incx1 = ldx * ny; incx2 = 1; m = 1
|
|
|
|
do i = 1, nx
|
|
do j = 1, ny
|
|
ii = i + ldx * (j-1)
|
|
if (do_fft_z(ii) == 1 ) then
|
|
call dcft (0, f( ii ), incx1, incx2, f( ii ), incx1, incx2, nz, m, &
|
|
-isign, 1.0_DP, fw_table ( 1, 3, ip ), ltabl, work( 1 ), lwork)
|
|
end if
|
|
end do
|
|
end do
|
|
|
|
f(1:ldx * ldy * nz) = f(1:ldx * ldy * nz) * (1.0_DP/(nx * ny * nz))
|
|
|
|
END IF
|
|
RETURN
|
|
END SUBROUTINE cfft3ds
|
|
!=----------------------------------------------------------------------=!
|
|
END MODULE fft_scalar_essl
|
|
!=----------------------------------------------------------------------=!
|
|
#endif
|