module gmath_fourt
  !---------------------------------------------------------------------
  ! Pre-Computed Sin/Cos for FFT, up to 32768 (MMAX=15)
  ! We limit FFT length to 20000 due to the prime number decomposition
  !---------------------------------------------------------------------
  integer(kind=4), parameter :: mmax=15
  ! Pre-computed Sin/Cos, Bloc Start and Bit-Reverse
  real(kind=4), allocatable :: w1c(:),w3c(:)
  integer(kind=4), allocatable :: jx0(:),bitrev(:)
  integer(kind=4) :: idfft=0
  !$OMP THREADPRIVATE (w1c,w3c,jx0,bitrev,idfft)
end module gmath_fourt
!
module gmath_fftw
  use gildas_def
  !$ use omp_lib
  !---------------------------------------------------------------------
  !    Support for Fastest Fourier Transform in the West (of Italy)
  !
  ! These codes are for FFTW Version 3.1.1
  !---------------------------------------------------------------------
  integer(kind=4), parameter :: fftw_r2hc    =  0
  integer(kind=4), parameter :: fftw_hc2r    =  1
  integer(kind=4), parameter :: fftw_dht     =  2
  integer(kind=4), parameter :: fftw_redft00 =  3
  integer(kind=4), parameter :: fftw_redft01 =  4
  integer(kind=4), parameter :: fftw_redft10 =  5
  integer(kind=4), parameter :: fftw_redft11 =  6
  integer(kind=4), parameter :: fftw_rodft00 =  7
  integer(kind=4), parameter :: fftw_rodft01 =  8
  integer(kind=4), parameter :: fftw_rodft10 =  9
  integer(kind=4), parameter :: fftw_rodft11 = 10
  !
  integer(kind=4), parameter :: fftw_forward  = -1
  integer(kind=4), parameter :: fftw_backward = +1
  !
  integer(kind=4), parameter :: fftw_measure                = 0
  integer(kind=4), parameter :: fftw_destroy_input          = 1
  integer(kind=4), parameter :: fftw_unaligned              = 2
  integer(kind=4), parameter :: fftw_conserve_memory        = 4
  integer(kind=4), parameter :: fftw_exhaustive             = 8
  integer(kind=4), parameter :: fftw_preserve_input         = 16
  integer(kind=4), parameter :: fftw_patient                = 32
  integer(kind=4), parameter :: fftw_estimate               = 64
  integer(kind=4), parameter :: fftw_estimate_patient       = 128
  integer(kind=4), parameter :: fftw_believe_pcost          = 256
  integer(kind=4), parameter :: fftw_no_dft_r2hc            = 512
  integer(kind=4), parameter :: fftw_no_nonthreaded         = 1024
  integer(kind=4), parameter :: fftw_no_buffering           = 2048
  integer(kind=4), parameter :: fftw_no_indirect_op         = 4096
  integer(kind=4), parameter :: fftw_allow_large_generic    = 8192
  integer(kind=4), parameter :: fftw_no_rank_splits         = 16384
  integer(kind=4), parameter :: fftw_no_vrank_splits        = 32768
  integer(kind=4), parameter :: fftw_no_vrecurse            = 65536
  integer(kind=4), parameter :: fftw_no_simd                = 131072
  integer(kind=4), parameter :: fftw_no_slow                = 262144
  integer(kind=4), parameter :: fftw_no_fixed_radix_large_n = 524288
  integer(kind=4), parameter :: fftw_allow_pruning          = 1048576
  !
  ! One plan for Direct and one for Reverse
  logical, save :: fftw_debug=.false.
#if defined(FFTW)
#if defined(GAG_USE_OPENMP)
  logical, save :: fftw_use=.false.
#else
  logical, save :: fftw_use=.true.
#endif
  integer(kind=address_length), save :: fftw_plan(2)=(/0,0/)
  integer(kind=4), save :: fftw_ndim(2)=(/0,0/)
  logical, save :: fftw_exist(2) = (/ .false.,.false. /)
  integer(kind=4), save :: fftw_dims(16,2)
#else 
  logical, save :: fftw_use=.false.
#endif
  !
end module gmath_fftw
!
subroutine fourt_set_usage(status)
  use gmath_interfaces, except_this=>fourt_set_usage
  use gmath_messaging
  use gmath_fftw
  !---------------------------------------------------------------------
  ! @ public
  !   Toggle the use of FFTW and its Debug mode, and
  !   return the previous status
  !---------------------------------------------------------------------
  logical, intent(inout) :: status(2)  !  Use and Debug FFTW code ?
  !
#if defined(FFTW)
  fftw_use = status(1)
  fftw_debug = status(2)
#else
  if (status(1)) call gmath_message(seve%w,'FFT','Not compiled with FFTW, FAST mode not available')
  status= .false. 
#endif
end subroutine fourt_set_usage
!
subroutine fourt_get_usage(status) 
  use gmath_fftw
  !---------------------------------------------------------------------
  ! @ public
  !   Toggle the use of FFTW and its Debug mode, and
  !   return the previous status 
  !---------------------------------------------------------------------
  logical, intent(out) :: status(2)    !  Use and Debug FFTW code ?
  !
  status = [fftw_use,fftw_debug]
end subroutine fourt_get_usage
!
subroutine fourt_plan(data,nn,ndim,isign,iform)
  !$ use omp_lib
  use gildas_def
  use gmath_dependencies_interfaces
  use gmath_interfaces, except_this=>fourt_plan
  use gmath_messaging
  use gmath_fftw
  use gmath_fourt
  !---------------------------------------------------------------------
  ! @ public-mandatory (because symbol is renamed elsewhere)
  ! Fast Fourier Transform Planner
  !
  ! If the data is of type Real (IFORM=0), the imaginary part should be
  ! set to 0. WORK should be dimensionned to twice the largest dimension.
  !
  ! NOTES:
  !     Calls FFTW when available, if FFTW_USE is set.
  !     Calls specialized procedures for 1-D and 2-D FFT with powers of 2,
  !         based on near-optimal Split-Radix method of P.Duhamel.
  !     Calls the Cooley-Tukey FOURTCT in other cases.
  !---------------------------------------------------------------------
  complex(kind=4) :: data(*)  ! Complex array of data             Input/Output
  integer(kind=4) :: nn(*)    ! Dimensions of data array          Input
  integer(kind=4) :: ndim     ! Number of dimensions              Input
  integer(kind=4) :: isign    ! Sign of FT (-1 Direct, 1 Inverse) Input
  integer(kind=4) :: iform    ! Type of data (0 Real, 1 Complex)  (Unused)
#if defined(FFTW)
  ! Local
  character(len=*), parameter :: rname='FOURT_PLAN'
  integer(kind=4) :: iplan
  logical :: destroy
  character(len=message_length) :: mess
  integer :: the_seve = seve%d
  !
  ! Real Transform not yet ready here (REAL array conventions differ between
  !    FFTW and the other routines...)
  ! So always use the Complex DFT case
  !
  if (.not.fftw_use) return
!$  if (omp_in_parallel()) then
!$    if (fftw_debug) call gmath_message(seve%e,rname,'FOURT_PLAN call invalid in Parallel')
!$    return
!$  endif
  !
  ! Check consistency with previous call
  iplan = (isign+3)/2          ! 1 Direct, 2 Reverse
  if (fftw_exist(iplan)) then
    if (fftw_debug) then
      write(mess,*) 'Testing Plan ',iplan
      call gmath_message(the_seve,rname,mess)
    endif
    destroy = .false.
    if (ndim.ne.fftw_ndim(iplan)) destroy = .true.
    if ( any(nn(1:ndim).ne.fftw_dims(1:ndim,iplan)) ) destroy = .true.
    if (destroy) then
      if (fftw_debug) then
        write(mess,*) 'Destroying Plan ',iplan, fftw_plan(iplan)
        call gmath_message(the_seve,rname,mess)
      endif
      call sfftw_destroy_plan(fftw_plan(iplan))
      fftw_exist(iplan) = .false.
    else
      if (fftw_debug) then
        write(mess,*) 'Reusing Plan ',iplan
        call gmath_message(the_seve,rname,mess)
      endif
      return
    endif
  else
    if (fftw_debug) then 
      write(mess,*) 'No such Plan ',iplan
      call gmath_message(the_seve,rname,mess)
    endif
  endif
  !
  ! Declare the plan
  call sfftw_plan_dft(fftw_plan(iplan),ndim,nn,data,data,isign,fftw_estimate)
  ! Log its characteristics
  fftw_ndim(iplan) = ndim
  fftw_dims(:,iplan) = 0
  fftw_dims(1:ndim,iplan) = nn(1:ndim)
  fftw_exist(iplan)=.true.
  if (fftw_debug) then
    write(mess,100) 'Creating FFTW Plan ',iplan,fftw_ndim(iplan),fftw_dims(1:ndim,iplan)
    call gmath_message(seve%w,rname,mess)
  endif
100 format(a,i3,i3,20(1X,I0))
#endif
end subroutine fourt_plan
!
subroutine fourt(data,nn,ndim,isign,iform,work)
  !$ use omp_lib
  use gildas_def
  use gmath_dependencies_interfaces
  use gmath_interfaces, except_this=>fourt,    &
                        no_interface1=>fft1d,  &
                        no_interface2=>fft2d,  &
                        no_interface3=>fourct
  use gmath_messaging
  use gmath_fftw
  use gmath_fourt
  !---------------------------------------------------------------------
  ! @ public-mandatory (because symbol is renamed elsewhere)
  ! Fast Fourier Transform
  !
  ! If the data is of type Real (IFORM=0), the imaginary part should be
  ! set to 0. WORK should be dimensioned to twice the largest dimension.
  !
  ! NOTES:
  !  For COMPLEX (IFORM=1) transforms
  !     Calls FFTW when available
  !     Calls specialized procedures for 1-D and 2-D FFT with powers of 2,
  !         based on near-optimal Split-Radix method of P.Duhamel.
  !     Calls the Cooley-Tukey FOURTCT in other cases.
  !  For REAL (IFORM=0) transforms
  !     Calls FFTW when available, but in COMPLEX mode only
  !     Calls specialized procedures for 1-D and 2-D FFT with powers of 2.
  !     Calls the Cooley-Tukey FOURTCT in other cases.
  !  data(*) is declared as "complex (*)" here for the interface,
  !     but passed to subroutines treating it as "real (2,*)"
  !---------------------------------------------------------------------
  complex(kind=4), intent(inout) :: data(*)  ! Complex array of data
  integer(kind=4), intent(in)    :: nn(*)    ! Dimensions of data array
  integer(kind=4), intent(in)    :: ndim     ! Number of dimensions
  integer(kind=4), intent(in)    :: isign    ! Sign of FT (-1 Direct, 1 Inverse)
  integer(kind=4), intent(in)    :: iform    ! Type of data (0 Real, 1 Complex)
  real(kind=4)                   :: work(*)  ! Work space
#if defined(FFTW)
  ! Local
  character(len=*), parameter :: rname='FOURT'
  integer(kind=4) :: iplan
  character(len=message_length) :: mess
  integer :: the_seve = seve%d
#endif
  integer(kind=4) :: n,m1,m2,seuil
  ! SEUIL has been determined experimentally on HP-700 series.
  data seuil/0/
  !
#if defined(FFTW)
  if (fftw_use) then
    !
    ! Use the plan if possible
    iplan = (3+isign)/2
    if (fftw_exist(iplan)) then
!
! Test if the Plan is valid, comparing sizes to fftw_sndim and fftw_dims
    if ( (fftw_ndim(iplan).eq.ndim) .and. all(fftw_dims(1:ndim,iplan).eq.nn(1:ndim)) ) then
        if (fftw_debug) then
          write(mess,*) 'Using plan ',iplan,isign
          call gmath_message(the_seve,rname,mess)
        endif
!
! Can work with different adresses than in Plan
        call sfftw_execute_dft(fftw_plan(iplan),data,data)
        return
      endif
    endif
  else if (fftw_debug) then
    call gmath_message(the_seve,rname,'No matching FFTW plan, Falling back on FOURT')
  endif
#endif
  !
  if (ndim.eq.1) then
    m1 = power_of_two(nn(1))
    if (m1.gt.0) then
      n = nn(1)
      call fft1d(data,n,isign,m1,work(1),work(n+1))
    else
      call fourct(data,nn,ndim,isign,iform,work)
    endif
  elseif (ndim.eq.2) then
    m1 = power_of_two(nn(1))
    m2 = power_of_two(nn(2))
    if (m1.gt.seuil .and. m2.gt.seuil) then
      n = max(nn(1),nn(2))
      call fft2d(data,nn(1),nn(2),isign,m1,m2,work(1),work(n+1),n)
    else
      call fourct(data,nn,ndim,isign,iform,work)
    endif
  else
    call fourct(data,nn,ndim,isign,iform,work)
  endif
end subroutine fourt
!
subroutine fft1d(data,n,isign,m,xr,xi)
  use gmath_interfaces, except_this=>fft1d
  use gmath_fourt
  !---------------------------------------------------------------------
  ! @ private-mandatory (because of explicit renaming elsewhere)
  ! Transformee de Fourier               Pierre Duhamel
  !
  ! Ce sous-programme calcule la transformee de Fourier directe
  ! (ISIGN=-1) ou inverse (ISIGN=1) du tableau complexe DATA de
  ! dimension N=2**M (n doit etre compris entre 8 et 2**mmax et etre
  ! une puissance de 2)
  !---------------------------------------------------------------------
  complex(kind=4), intent(inout) :: data(*)  !
  integer(kind=4), intent(in)    :: n        !
  integer(kind=4), intent(in)    :: isign    !
  integer(kind=4), intent(in)    :: m        !
  real(kind=4)                   :: xr(*)    !
  real(kind=4)                   :: xi(*)    !
  ! Local
  integer(kind=4) :: i,k
  !
  if (idfft.ne.m) call inifft(m,n)
  do i=1,n
    xr(i)=real(data(i))
    xi(i)=aimag(data(i))
  enddo
  if (isign.lt.0) then
    call fftcfr(xr,xi,m,n)
  else
    call fftcfr(xi,xr,m,n)
  endif
  do i=1,n
    k = bitrev(i)
    data(i)=cmplx(xr(k),xi(k))
  enddo
end subroutine fft1d
!
subroutine fft2d(data,dim1,dim2,isign,m1,m2,xr,xi,mm)
  use gmath_interfaces, except_this=>fft2d
  use gmath_fourt
  !---------------------------------------------------------------------
  ! @ private-mandatory (because of explicit renaming elsewhere)
  ! Joue le meme role que Fourt : Pas de Normalisation.
  !
  ! If Signe=-1 Then
  !       Direct Fourier Transform
  ! Else
  !       Inverse Fourier Transform
  !---------------------------------------------------------------------
  integer(kind=4), intent(in)    :: dim1             !
  integer(kind=4), intent(in)    :: dim2             !
  complex(kind=4), intent(inout) :: data(dim1,dim2)  !
  integer(kind=4), intent(in)    :: isign            !
  integer(kind=4), intent(in)    :: m1               !
  integer(kind=4), intent(in)    :: m2               !
  integer(kind=4), intent(in)    :: mm               !
  real(kind=4)                   :: xr(mm)           !
  real(kind=4)                   :: xi(mm)           !
  ! Local
  integer(kind=4) :: ifft,jfft,kfft
  integer(kind=4) :: m,n
  !
  ! Init DIM1
  m = m1
  n = dim1
  if (idfft.ne.m) call inifft(m,n)
  if (isign.lt.0) then
    do jfft=1,dim2
      do ifft=1,dim1
        xr(ifft)=real(data(ifft,jfft))
        xi(ifft)=aimag(data(ifft,jfft))
      enddo
      !
      call fftcfr(xr,xi,m,n)
      !
      do ifft=1,dim1
        kfft = bitrev(ifft)
        data(ifft,jfft)=cmplx(xr(kfft),xi(kfft))
      enddo
    enddo
  else
    do jfft=1,dim2
      do ifft=1,dim1
        xi(ifft)=real(data(ifft,jfft))
        xr(ifft)=aimag(data(ifft,jfft))
      enddo
      !
      call fftcfr(xr,xi,m,n)
      !
      do ifft=1,dim1
        kfft = bitrev(ifft)
        data(ifft,jfft)=cmplx(xi(kfft),xr(kfft))
      enddo
    enddo
  endif
  !
  ! Init DIM2
  m = m2
  n = dim2
  if (idfft.ne.m) call inifft(m,n)
  if (isign.lt.0) then
    do jfft=1,dim1
      ! Transpose
      do ifft=1,dim2
        xr(ifft)=real(data(jfft,ifft))
        xi(ifft)=aimag(data(jfft,ifft))
      enddo
      !
      call fftcfr(xr,xi,m,n)
      !
      ! Transpose and Bit-Reverse
      do ifft=1,dim2
        kfft = bitrev(ifft)
        data(jfft,ifft)=cmplx(xr(kfft),xi(kfft))
      enddo
    enddo
  else
    do jfft=1,dim1
      ! Transpose
      do ifft=1,dim2
        xi(ifft)=real(data(jfft,ifft))
        xr(ifft)=aimag(data(jfft,ifft))
      enddo
      !
      call fftcfr(xr,xi,m,n)
      !
      ! Transpose and Bit-Reverse
      do ifft=1,dim2
        kfft = bitrev(ifft)
        data(jfft,ifft)=cmplx(xi(kfft),xr(kfft))
      enddo
    enddo
  endif
end subroutine fft2d
! 
subroutine fftcfr(xr,xi,m,n)
  use gmath_interfaces, except_this=>fftcfr
  use gmath_fourt
  !---------------------------------------------------------------------
  ! @ private
  ! FFT de sequence complexe (xr + j*xi) de taille 2**m
  !
  ! Algorithme SRFFT, version rapide, qui necessite donc un appel
  ! de INIFFT , et decimation en frequences (les rearrangements sont a
  ! effectuer apres appel a la FFT)
  !
  !  Un algorithme de transformation de Fourier rapide a double base.
  !    Pierre DUHAMEL
  !  Annales des teleommunications, tome 40, n! 9-10, sept-oct 1985
  !---------------------------------------------------------------------
  real(kind=4)                 :: xr(*)  !
  real(kind=4)                 :: xi(*)  !
  integer(kind=4), intent(in)  :: m      !
  integer(kind=4), intent(in)  :: n      !
  ! Local
  real(kind=4), parameter :: c21=0.707106781186547
  real(kind=4), parameter :: cm=-1.414213562373095
  real(kind=4) :: sp,s,r,t,rp,y2,x2,t1,u
  integer(kind=4) :: nd4,n1,istep,ib,nb,lnb,jstep,ij,llnb
  integer(kind=4) :: j,i,i0,i1,i2,i3,i4,i5,i6,i7
  !
  !     n = 2**m
  nd4 = n/4
  n1 = n/2
  !
  istep = 1
  ib = 0
  nb = 1
  lnb = 0
  !
  ! Boucle sur les etages
  do j=1,m-3
    n1 = n1/2
    !
    ! Boucle sur les blocs
    do i=ib+1,ib+nb
      !
      !-------------0-mult butterfly------------
      i0 = jx0(i)
      i1 = i0+n1
      i2 = i1+n1
      i3 = i2+n1
      sp = xr(i1)-xr(i3)
      s = xi(i1)-xi(i3)
      xr(i1) = xr(i1)+xr(i3)
      r = xr(i0)-xr(i2)
      xr(i3) = r-s
      xr(i0) = xr(i0)+xr(i2)
      xr(i2) = r+s
      r = xi(i0)-xi(i2)
      xi(i0) = xi(i0)+xi(i2)
      xi(i1) = xi(i1)+xi(i3)
      xi(i3) = r+sp
      xi(i2) = r-sp
      !
      !-------------general 6-mult butterfly--------
      jstep = 0
      do ij=i0+1,i0+n1-1
        i1 = ij+n1
        i2 = i1+n1
        i3 = i2+n1
        r = xi(ij)-xi(i2)
        xi(ij) = xi(ij)+xi(i2)
        s = xi(i1)-xi(i3)
        xi(i1) = xi(i1)+xi(i3)
        sp = xr(i1)-xr(i3)
        t = r-sp
        r = r+sp
        xr(i1) = xr(i1)+xr(i3)
        rp = xr(ij)-xr(i2)
        sp = rp+s
        jstep = jstep+istep
        xi(i2) = t*w1c(jstep)-sp*w1c(nd4-jstep)
        xr(ij) = xr(ij)+xr(i2)
        xr(i2) = sp*w1c(jstep)+t*w1c(nd4-jstep)
        rp = rp-s
        xi(i3) = r*w3c(jstep)+rp*w3c(nd4-jstep)
        xr(i3) = rp*w3c(jstep)-r*w3c(nd4-jstep)
      enddo
    enddo
    !
    ib = ib+nb
    llnb = lnb
    lnb = nb
    nb = lnb+llnb+llnb
    istep = istep+istep
  enddo
  !
  do i=ib+1,ib+nb
    !
    !-------------8-point butterfly--------------
    i0 = jx0(i)
    i1 = i0+1
    i3 = i0+3
    i5 = i0+5
    i7 = i0+7
    r = xi(i1)-xi(i5)
    xi(i1) = xi(i1)+xi(i5)
    s = xi(i3)-xi(i7)
    xi(i3) = xi(i3)+xi(i7)
    sp = xr(i3)-xr(i7)
    xr(i3) = xr(i3)+xr(i7)
    rp = xr(i1)-xr(i5)
    t = s+rp
    y2 = (t-sp+r)*c21
    x2 = t*cm+y2
    xr(i1) = xr(i1)+xr(i5)
    t = r+sp
    sp = (t-rp+s)*c21
    rp = t*cm+sp
    !
    i2 = i0+2
    i4 = i0+4
    i6 = i0+6
    r = xi(i0)-xi(i4)
    xi(i0) = xi(i0)+xi(i4)
    s = xi(i2)-xi(i6)
    xi(i2) = xi(i2)+xi(i6)
    t = xr(i2)-xr(i6)
    t1 = r+t
    xi(i6) = t1+rp
    xi(i7) = t1-rp
    t = r-t
    xi(i4) = t+x2
    xi(i5) = t-x2
    xr(i2) = xr(i2)+xr(i6)
    r = xr(i0)-xr(i4)
    t = r-s
    xr(i6) = t+sp
    xr(i7) = t-sp
    xr(i0) = xr(i0)+xr(i4)
    s = r+s
    xr(i4) = s+y2
    xr(i5) = s-y2
  enddo
  !
  !--------------4-point dft----------------
  ib = ib+nb
  nb = nb+lnb+lnb
  do i=ib+1,ib+nb
    i0 = jx0(i)
    i1 = i0+1
    i2 = i1+1
    i3 = i2+1
    r = xi(i0)+xi(i2)
    s = xi(i0)-xi(i2)
    t = xi(i1)+xi(i3)
    xi(i0) = r+t
    u = xi(i1)-xi(i3)
    xi(i1) = r-t
    r = xr(i1)+xr(i3)
    t = xr(i1)-xr(i3)
    xi(i3) = s+t
    xi(i2) = s-t
    t = xr(i0)-xr(i2)
    xr(i3) = t-u
    s = xr(i0)+xr(i2)
    xr(i0) = s+r
    xr(i1) = s-r
    xr(i2) = t+u
  enddo
end subroutine fftcfr
!
subroutine inifft(m,n)
  use gmath_interfaces, except_this=>inifft
  use gmath_fourt
  !---------------------------------------------------------------------
  ! @ private
  !  Precalcul des cos, debuts de blocs et bit-reversal
  !
  !  Sous programme a appeler avant utilisation des versions rapides.
  ! Il est commun a toutes les versions, et un seul appel a INIFFT est
  ! necessaire.
  !---------------------------------------------------------------------
  integer(kind=4), intent(in) :: m
  integer(kind=4), intent(in) :: n
  ! Local
  real(kind=8) :: ang, c, s, dpi, xn
  integer(kind=4) :: m1,n1,ia1,ia2,ia3,nh,ibr,i,ipair,k,j,jbr,jbri,indt
  integer(kind=4) :: n2,n2p1,n4,n8,n16,n6,n12,ip,nb,lnb,ip1,llnb
  !
  !     n   = 2**m
  if (idfft.eq.m) return
  !
  call inifft_allocate()
  !
  idfft = m
  xn  = n
  dpi = 6.283185307179586d0
  ang = dpi/xn
  n2  = n/2
  n2p1= n2+1
  n4  = n/4
  n8  = n4/2
  n16 = n8/2
  n6  = n/6
  n12 = n6/2
  !
  ! Sin/Cos
  c = cos(ang)
  s = sin(ang)
  w1c(1) = c
  w1c(n4-1) = s
  w1c(n/8) = 0.707106781186547
  do i=2,n16
    w1c(i) = w1c(i-1)*c-w1c(n4-i+1)*s
    w1c(n4-i) = w1c(n4-i+1)*c+w1c(i-1)*s
    w1c(n8+i-1) = w1c(n8+i-2)*c-w1c(n8-i+2)*s
    w1c(n8-i+1) = w1c(n8-i+2)*c+w1c(n8+i-2)*s
  enddo
  do i=1,n12
    w3c(i) = w1c(3*i)
  enddo
  do i=n12+1,n6
    w3c(i) = -w1c(n2-3*i)
  enddo
  do i=n6+1,n4-1
    w3c(i) = -w1c(3*i-n2)
  enddo
  !
  ! Bloc Beginning
  jx0(1) = 1
  jx0(2) = 1
  jx0(3) = 1
  jx0(4) = n2p1
  jx0(5) = 3*n4+1
  ip = 5
  nb = 3
  lnb = 1
  do i=1,m-4
    do j=ip+1,ip+nb
      jx0(j) = jx0(j-nb)/2+1
    enddo
    ip = ip+nb
    ip1=-(nb+nb+lnb)
    do j=ip+1,ip+lnb
      jx0(j) = jx0(j+ip1)/4+n2p1
      jx0(j+lnb) = jx0(j)+n4
    enddo
    ip = ip+lnb+lnb
    llnb = lnb
    lnb = nb
    nb = lnb+llnb+llnb
  enddo
  !
  ! Bit-Reversal
  do i=1,n
    bitrev(i) = i
  enddo
  !
  m1 = m/2
  n1 = 2**m1
  ia1= n1/2
  ia2= n/n1
  ia3= ia1+ia2
  nh = n/2
  do ipair=0,(m-m1-m1)*n1,n1
    ibr = 0
    indt = bitrev(ipair+ia1+1)
    bitrev(ipair+ia1+1) = bitrev(ipair+ia2+1)
    bitrev(ipair+ia2+1) = indt
    do i=2+ipair,ia1+ipair
      k = nh
      !            if (k.gt.ibr) go to 23
      !24          ibr = ibr-k
      !            k = k/2
      !            if (k.le.ibr) go to 24
      !23          ibr = ibr+k
      do while (k.le.ibr)
        ibr = ibr-k
        k = k/2
      enddo
      ibr = ibr+k
      !
      indt = bitrev(ibr+i+ia1)
      bitrev(ibr+i+ia1) = bitrev(ibr+i+ia2)
      bitrev(ibr+i+ia2) = indt
      !
      jbr = 0
      !
      if (m.ge.4) then
        do j=ibr+ipair+1,ibr+i-1
          jbri=jbr+i
          indt = bitrev(jbri)
          bitrev(jbri) = bitrev(j)
          bitrev(j) = indt
          indt = bitrev(jbri+ia1)
          bitrev(jbri+ia1) = bitrev(j+ia2)
          bitrev(j+ia2) = indt
          indt = bitrev(jbri+ia2)
          bitrev(jbri+ia2) = bitrev(j+ia1)
          bitrev(j+ia1) = indt
          indt = bitrev(jbri+ia3)
          bitrev(jbri+ia3) = bitrev(j+ia3)
          bitrev(j+ia3) = indt
          k = nh
          !               if (k.gt.jbr) go to 33
          !34             jbr = jbr-k
          !               k = k/2
          !               if (k.le.jbr) go to 34
          !33             jbr = jbr+k
          do while (k.le.jbr)
            jbr = jbr-k
            k = k/2
          enddo
          jbr = jbr+k
        enddo
      endif
    enddo
  enddo
  !
contains
  !
  subroutine inifft_allocate()
    use gmath_dependencies_interfaces
    !-------------------------------------------------------------------
    ! Allocate (once for all) the buffers to the maximum possible size
    !
    ! Required memory:
    !         w1c     :       nmax/4
    !         w3c     :       nmax/4
    !         jx0     :       nmax/3
    !         BITREV  :       nmax
    !                      ---------
    !         total   :  11/6*nmax
    !-------------------------------------------------------------------
    ! Local
    logical :: error
    integer(kind=4) :: nmax,ns3,ns4,ier
    !
    if (allocated(bitrev))  return
    !
    error = .false.
    nmax=2**mmax
    ns3=nmax/3
    ns4=nmax/4
    allocate(w1c(ns4),w3c(ns4),jx0(ns3),bitrev(nmax),stat=ier)
    if (failed_allocate('INITFFT','FFT buffers',ier,error)) return
  end subroutine inifft_allocate
  !
end subroutine inifft
!
function power_of_two(dim)
  use gmath_fourt
  !---------------------------------------------------------------------
  ! @ public
  !---------------------------------------------------------------------
  integer(kind=4) :: power_of_two     ! Value on return
  integer(kind=4), intent(in) :: dim  !
  ! Local
  integer(kind=4) :: power(0:mmax),i
  data power /1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768/
  !
  ! MMAX is a parameter defined in gmath_fourt specifying the maximum
  ! power of two preallocated in BITREV and other pointers
  !
  do i = 1,mmax
    if (dim.eq.power(i)) then
      power_of_two = i
      return
    endif
  enddo
  power_of_two = -1
end function power_of_two
!
subroutine gi4_round_forfft(isize,osize,error,tolerance,exponent)
  use gildas_def
  use gmath_interfaces, except_this=>gi4_round_forfft
  use gmath_messaging
  !---------------------------------------------------------------------
  ! @ public
  !
  !  Find the nearest number in the form 2^n 3^p 5^q with p and q
  ! smaller than Exponent (can be 0, then only powers of two are
  ! returned.)
  !
  !  Round to near if within Tolerance. Use Ceiling if not.
  !---------------------------------------------------------------------
  integer(kind=4), intent(in)           :: isize      ! Input size
  integer(kind=4), intent(out)          :: osize      ! Output size
  real(kind=4),    intent(in), optional :: tolerance  ! Tolerance
  integer(kind=4), intent(in), optional :: exponent   ! Max exponent
  logical,         intent(inout)        :: error      !
  ! Saved globals
  character(len=*), parameter :: rname='ROUND_MAPSIZE'
  integer(kind=size_length), save :: nval(0:2)
  integer, parameter :: numbers=72
  ! There are 72 numbers between 64 and 20000 for exponent 2
  integer(kind=4), save :: values(numbers,0:2)
  integer(kind=4) :: it(numbers)
  integer(kind=4), save :: the_expo=-1
  real(kind=4), save :: the_tolerance=0.10
  !
  integer(kind=size_length) :: ival
  integer(kind=4) :: x2, x3, y3, x5, y5
  integer(kind=4) :: count, iexpo, i,j,k
  !
  if (present(tolerance)) then
    if (tolerance.lt.0 .or. tolerance.gt.0.3) then
      call gmath_message(seve%e,rname,'Tolerance out of range ]0,0.3]')
      error = .true.
      return
    endif
    the_tolerance = tolerance
  endif
  !
  ! Initialize the values
  if (the_expo.eq.-1) then
    ! Start from 5 to make sure X2 is > 32, and end at 2^(5+9) = 16384 
    ! to be less than  20000
    do i=1,9
      values(i,0) = 2**(i+5)
    enddo
    nval(0) = 9
    !
    do iexpo=1,2
      count = 0
      !
      ! Start from 1 to make sure X2 is even, and end at 2^14 = 16384 
      ! to be less than  20000
      do i=1,14  
        x2 = 2**i
        do j=0,iexpo
          x3 = 3**j
          y3 = x2*x3
          if (y3.gt.20000) exit
          do k=0,iexpo
            x5 = 5**k
            y5 = y3*x5
            if (y5.gt.20000) exit
            if (y5.ge.64) then
              count = count+1
              if (count.gt.ubound(values,1)) Stop 'Programming error'
              values(count,iexpo) = y5
            endif
          enddo
        enddo
      enddo
      call gi4_trie(values(1:count,iexpo),it,count,error)
      nval(iexpo) = count
    enddo
    the_expo = 0  ! Default value after initialization
  endif
  !
  if (present(exponent)) then
    if (exponent.lt.0 .or. exponent.gt.2) then
      call gmath_message(seve%e,rname,'Exponent not 0,1 or 2')
      error = .true.
      return
    endif
    the_expo = exponent
  endif
  !
  if (isize.gt.values(nval(the_expo),the_expo)) then
    call gmath_message(seve%w,rname,'Size exceeds capability, has been truncated')
    osize = values(nval(the_expo),the_expo)
    return
  else if (isize.lt.values(1,the_expo)/2) then
    call gmath_message(seve%e,rname,'Size below 32 pixels')
    error = .true.
    return
  else if (isize.lt.values(1,the_expo)) then
    call gmath_message(seve%d,rname,'Size rounded upwards to 64')
    osize = values(1,the_expo)
    return
  else
    ! Dichotomic search to find out the position in the values array
    call gi4_dicho(nval(the_expo),values(:,the_expo),isize,.false.,  &
      ival,error)
    if (error)  return
  endif
  !
  if (isize-values(ival,the_expo).lt.the_tolerance*isize) then
    osize = values(ival,the_expo)
  else
    osize = values(ival+1,the_expo)
  endif
end subroutine gi4_round_forfft
!
subroutine fourct(data,nn,ndim,isign,iform,work)
  use gildas_def
  use phys_const
  use gmath_interfaces, except_this=>fourct
  !---------------------------------------------------------------------
  ! @ private-mandatory (because symbol is used elsewhere)
  ! Cooley-Tukey Fast Fourier Transform
  !
  ! If the data is of type Real (IFORM=0), the imaginary part should be
  ! set to 0. WORK should be dimensioned to twice the largest dimension
  ! which is not a power of 2. It can be replaced by 0 if all dimensions
  ! are powers of 2.
  !
  ! The FT are not normalized in the standard way. If a Direct FT is
  ! performed, then an Inverse FT on the result, the original data is
  ! multiply by the size of the data (product of all dimensions).
  !----------------------------------------------------------------------
  real(kind=4),    intent(inout) :: data(*)  ! Complex array of data
  integer(kind=4), intent(in)    :: nn(*)    ! Dimensions of data array
  integer(kind=4), intent(in)    :: ndim     ! Number of dimensions
  integer(kind=4), intent(in)    :: isign    ! Sign of FT (-1 Direct, 1 Inverse)
  integer(kind=4), intent(in)    :: iform    ! Type of data (0 Real, 1 Complex)
  real(kind=4)                   :: work(*)  ! Work space
  ! Local
  integer(kind=4) :: ifact(32),np0,idim,nprev
  integer(kind=4) :: if,idiv,iquot,irem,inon2,non2p
  integer(kind=4) :: ifmin,i1rng,icase,np2hf,kmin
  integer(kind=4) :: ipar,ifp1,ifp2,nhalf,nwork
  !
  integer(kind=size_length) :: np1,np2,ntot
  integer(kind=size_length) :: ntwo
  integer(kind=size_length) :: mmax,lmax,kdif,kstep
  integer(kind=size_length) :: i,j,i1,i2,i3,j2,j1,j3,k1,k2,k3,k4,l,m,n
  integer(kind=size_length) :: i1max,i2max,j2max,j3max,imax,imin,jmax,jmin
  integer(kind=size_length) :: np1tw
  !
  ! Made these Double Precision to avoid round-off errors
  real(kind=8), parameter :: rthlf=.7071067811865475244d0
  real(kind=8) :: tempr,tempi,theta,wr,wi,w2r,w2i,w3r,w3i
  real(kind=8) :: u1r,u1i,u2r,u2i,u3r,u3i,u4r,u4i,t2r,t2i,t3r,t3i,t4r,t4i
  real(kind=8) :: wstpr,wstpi,thetm,wminr,wmini,twowr,sr,si,oldsr,oldsi
  real(kind=8) :: stmpr,stmpi,wtemp,sumr,sumi,difr,difi
  !
  np0=0
  nprev=0
  if (ndim-1) 920,1,1
1 ntot=2
  do 2 idim=1,ndim
    if (nn(idim)) 920,920,2
2 ntot=ntot*nn(idim)  ! Enddo idim
  !
  !     MAIN LOOP FOR EACH DIMENSION
  !
  np1=2
  do 910 idim=1,ndim
    n=nn(idim)
    np2=np1*n
    if(n-1)920,900,5
    !
    !     IS N A POWER OF TWO AND IF NOT, WHAT ARE ITS FACTORS
    !
5   m=n
    ntwo=np1
    if=1
    idiv=2
10  iquot=m/idiv
    irem=m-idiv*iquot
    if(iquot-idiv)50,11,11
11  if(irem)20,12,20
12  ntwo=ntwo+ntwo
    ifact(if)=idiv
    if=if+1
    m=iquot
    go to 10
20  idiv=3
    inon2=if
30  iquot=m/idiv
    irem=m-idiv*iquot
    if(iquot-idiv)60,31,31
31  if(irem)40,32,40
32  ifact(if)=idiv
    if=if+1
    m=iquot
    go to 30
40  idiv=idiv+2
    go to 30
50  inon2=if
    if(irem)60,51,60
51  ntwo=ntwo+ntwo
    go to 70
60  ifact(if)=m
70  non2p=np2/ntwo
    !
    !     SEPARATE FOUR CASES--
    !        1. COMPLEX TRANSFORM
    !        2. REAL TRANSFORM FOR THE 2ND, 3RD, ETC. DIMENSION.  METHOD--
    !           TRANSFORM HALF THE DATA, SUPPLYING THE OTHER HALF BY CON-
    !           JUGATE SYMMETRY.
    !        3. REAL TRANSFORM FOR THE 1ST DIMENSION, N ODD.  METHOD--
    !           SET THE IMAGINARY PARTS TO ZERO.
    !        4. REAL TRANSFORM FOR THE 1ST DIMENSION, N EVEN.  METHOD--
    !           TRANSFORM A COMPLEX ARRAY OF LENGTH N/2 WHOSE REAL PARTS
    !           ARE THE EVEN NUMBERED REAL VALUES AND WHOSE IMAGINARY PARTS
    !           ARE THE ODD NUMBERED REAL VALUES.  SEPARATE AND SUPPLY
    !           THE SECOND HALF BY CONJUGATE SYMMETRY.
    !
    ifmin = 1
    i1rng = np1
    if (iform .le. 0 .and. idim .lt. 4) go to 71
    icase = 1
    go to 100
    !
71  if (idim .le. 1) go to 72
    icase = 2
    i1rng = np0 * (1 + nprev / 2)
    go to 100
    !
72  if (ntwo .gt. np1) go to 73
    icase = 3
    go to 100
    !
73  icase = 4
    ifmin = 2
    ntwo = ntwo / 2
    n = n / 2
    np2 = np2 / 2
    ntot = ntot / 2
    !
    i = - 1
    do 80 j = 1, ntot
      i = i + 2
      data(j) = data(i)
80  continue  ! Enddo j
    !
    !     SHUFFLE DATA BY BIT REVERSAL, SINCE N=2**K.  AS THE SHUFFLING
    !     CAN BE DONE BY SIMPLE INTERCHANGE, NO WORKING ARRAY IS NEEDED
    !
100 if(non2p-1)101,101,200
101 np2hf=np2/2
    j=1
    do 150 i2=1,np2,np1
      if(j-i2)121,130,130
121   i1max=i2+np1-2
      do 125 i1=i2,i1max,2
        do 125 i3=i1,ntot,np2
          j3=j+i3-i2
          tempr=data(i3)
          tempi=data(i3+1)
          data(i3)=data(j3)
          data(i3+1)=data(j3+1)
          data(j3)=tempr
125   data(j3+1)=tempi  ! Enddo i1,i3
130   m=np2hf
140   if(j-m)150,150,141
141   j=j-m
      m=m/2
      if(m-np1)150,140,140
150 j=j+m  ! Enddo i2
    go to 300
    !
    !     SHUFFLE DATA BY DIGIT REVERSAL FOR GENERAL N
    !
200 nwork=2*n
    do 270 i1=1,np1,2
      do 270 i3=i1,ntot,np2
        j=i3
        do 260 i=1,nwork,2
          if(icase-3)210,220,210
210       work(i)=data(j)
          work(i+1)=data(j+1)
          go to 240
220       work(i)=data(j)
          work(i+1)=0.
240       ifp2=np2
          if=ifmin
250       ifp1=ifp2/ifact(if)
          j=j+ifp1
          if(j-i3-ifp2)260,255,255
255       j=j-ifp2
          ifp2=ifp1
          if=if+1
          if(ifp2-np1)260,260,250
260     continue  ! Enddo i
        i2max=i3+np2-np1
        i=1
        do 270 i2=i3,i2max,np1
          data(i2)=work(i)
          data(i2+1)=work(i+1)
270 i=i+2  ! Enddo i1,i3,i2
    !
    !     MAIN LOOP FOR FACTORS OF TWO.
    !     W=EXP(ISIGN*2*PI*SQRT(-1)*M/(4*MMAX)).  CHECK FOR W=ISIGN*SQRT(-1)
    !     AND REPEAT FOR W=W*(1+ISIGN*SQRT(-1))/SQRT(2).
    !
300 if(ntwo-np1)600,600,305
305 np1tw=np1+np1
    ipar=ntwo/np1
310 if(ipar-2)350,330,320
320 ipar=ipar/4
    go to 310
330 do 340 i1=1,i1rng,2
      do 340 k1=i1,ntot,np1tw
        k2=k1+np1
        tempr=data(k2)
        tempi=data(k2+1)
        data(k2)=data(k1)-tempr
        data(k2+1)=data(k1+1)-tempi
        data(k1)=data(k1)+tempr
340 data(k1+1)=data(k1+1)+tempi  ! Enddo i1,k1
350 mmax=np1
360 if(mmax-ntwo/2)370,600,600
370 lmax=max(np1tw,mmax/2)
    do 570 l=np1,lmax,np1tw
      m=l
      if (mmax-np1) 420,420,380
380   theta=-twopi*float(l)/float(4*mmax)
      if (isign) 400,390,390
390   theta=-theta
400   wr=cos(theta)
      wi=sin(theta)
410   w2r=wr*wr-wi*wi
      w2i=2.*wr*wi
      w3r=w2r*wr-w2i*wi
      w3i=w2r*wi+w2i*wr
420   do 530 i1=1,i1rng,2
        kmin=i1+ipar*m
        if(mmax-np1)430,430,440
430     kmin=i1
440     kdif=ipar*mmax
450     kstep=4*kdif
        if(kstep-ntwo)460,460,530
460     do 520 k1=kmin,ntot,kstep
          k2=k1+kdif
          k3=k2+kdif
          k4=k3+kdif
          if(mmax-np1)470,470,480
470       u1r=data(k1)+data(k2)
          u1i=data(k1+1)+data(k2+1)
          u2r=data(k3)+data(k4)
          u2i=data(k3+1)+data(k4+1)
          u3r=data(k1)-data(k2)
          u3i=data(k1+1)-data(k2+1)
          if (isign) 471,472,472
471       u4r=data(k3+1)-data(k4+1)
          u4i=data(k4)-data(k3)
          go to 510
472       u4r=data(k4+1)-data(k3+1)
          u4i=data(k3)-data(k4)
          go to 510
480       t2r=w2r*data(k2)-w2i*data(k2+1)
          t2i=w2r*data(k2+1)+w2i*data(k2)
          t3r=wr*data(k3)-wi*data(k3+1)
          t3i=wr*data(k3+1)+wi*data(k3)
          t4r=w3r*data(k4)-w3i*data(k4+1)
          t4i=w3r*data(k4+1)+w3i*data(k4)
          u1r=data(k1)+t2r
          u1i=data(k1+1)+t2i
          u2r=t3r+t4r
          u2i=t3i+t4i
          u3r=data(k1)-t2r
          u3i=data(k1+1)-t2i
          if (isign) 490,500,500
490       u4r=t3i-t4i
          u4i=t4r-t3r
          go to 510
500       u4r=t4i-t3i
          u4i=t3r-t4r
510       data(k1)=u1r+u2r
          data(k1+1)=u1i+u2i
          data(k2)=u3r+u4r
          data(k2+1)=u3i+u4i
          data(k3)=u1r-u2r
          data(k3+1)=u1i-u2i
          data(k4)=u3r-u4r
520     data(k4+1)=u3i-u4i  ! Enddo k1
        kdif=kstep
        kmin=4*(kmin-i1)+i1
        go to 450
530   continue  ! Enddo i1
      m=m+lmax
      if (m-mmax) 540,540,570
540   if (isign) 550,560,560
550   tempr=wr
      wr=(wr+wi)*rthlf
      wi=(wi-tempr)*rthlf
      go to 410
560   tempr=wr
      wr=(wr-wi)*rthlf
      wi=(tempr+wi)*rthlf
      go to 410
570 continue  ! Enddo l
    ipar=3-ipar
    mmax=mmax+mmax
    go to 360
    !
    !     MAIN LOOP FOR FACTORS NOT EQUAL TO TWO.
    !     W=EXP(ISIGN*2*PI*SQRT(-1)*(J1+J2-I3-1)/IFP2)
    !
600 if(non2p-1)700,700,601
601 ifp1=ntwo
    if=inon2
610 ifp2=ifact(if)*ifp1
    theta=-twopi/float(ifact(if))
    if (isign) 612,611,611
611 theta=-theta
612 wstpr=cos(theta)
    wstpi=sin(theta)
    do 650 j1=1,ifp1,np1
      thetm=-twopi*float(j1-1)/float(ifp2)
      if (isign) 614,613,613
613   thetm=-thetm
614   wminr=cos(thetm)
      wmini=sin(thetm)
      i1max=j1+i1rng-2
      do 650 i1=j1,i1max,2
        do 650 i3=i1,ntot,np2
          i=1
          wr=wminr
          wi=wmini
          j2max=i3+ifp2-ifp1
          do 640 j2=i3,j2max,ifp1
            twowr=wr+wr
            j3max=j2+np2-ifp2
            do 630 j3=j2,j3max,ifp2
              jmin=j3-j2+i3
              j=jmin+ifp2-ifp1
              sr=data(j)
              si=data(j+1)
              oldsr=0.
              oldsi=0.
              j=j-ifp1
620           stmpr=sr
              stmpi=si
              sr=twowr*sr-oldsr+data(j)
              si=twowr*si-oldsi+data(j+1)
              oldsr=stmpr
              oldsi=stmpi
              j=j-ifp1
              if(j-jmin)621,621,620
621           work(i)=wr*sr-wi*si-oldsr+data(j)
              work(i+1)=wi*sr+wr*si-oldsi+data(j+1)
630         i=i+2  ! Enddo j3
            wtemp=wr*wstpi
            wr=wr*wstpr-wi*wstpi
640       wi=wi*wstpr+wtemp  ! Enddo j2
          i=1
          do 650 j2=i3,j2max,ifp1
            j3max=j2+np2-ifp2
            do 650 j3=j2,j3max,ifp2
              data(j3)=work(i)
              data(j3+1)=work(i+1)
650 i=i+2  ! Enddo j1,i1,i3,j2,j3
    if=if+1
    ifp1=ifp2
    if(ifp1-np2)610,700,700
    !
    !     COMPLETE A REAL TRANSFORM IN THE 1ST DIMENSION, N EVEN, BY CON-
    !     JUGATE SYMMETRIES.
    !
700 go to (900,800,900,701),icase
701 nhalf=n
    n=n+n
    theta=-twopi/float(n)
    if (isign) 703,702,702
702 theta=-theta
703 wstpr=cos(theta)
    wstpi=sin(theta)
    wr=wstpr
    wi=wstpi
    imin=3
    jmin=2*nhalf-1
    go to 725
710 j=jmin
    do 720 i=imin,ntot,np2
      sumr=(data(i)+data(j))/2.
      sumi=(data(i+1)+data(j+1))/2.
      difr=(data(i)-data(j))/2.
      difi=(data(i+1)-data(j+1))/2.
      tempr=wr*sumi+wi*difr
      tempi=wi*sumi-wr*difr
      data(i)=sumr+tempr
      data(i+1)=difi+tempi
      data(j)=sumr-tempr
      data(j+1)=-difi+tempi
720 j=j+np2  ! Enddo i
    imin=imin+2
    jmin=jmin-2
    wtemp=wr*wstpi
    wr=wr*wstpr-wi*wstpi
    wi=wi*wstpr+wtemp
725 if (imin-jmin) 710,730,740
730 if (isign) 731,740,740
731 do 735 i=imin,ntot,np2
735 data(i+1)=-data(i+1)  ! Enddo i
740 np2=np2+np2
    ntot=ntot+ntot
    j=ntot+1
    imax=ntot/2+1
745 imin=imax-2*nhalf
    i=imin
    go to 755
750 data(j)=data(i)
    data(j+1)=-data(i+1)
755 i=i+2
    j=j-2
    if(i-imax)750,760,760
760 data(j)=data(imin)-data(imin+1)
    data(j+1)=0.
    if(i-j)770,780,780
765 data(j)=data(i)
    data(j+1)=data(i+1)
770 i=i-2
    j=j-2
    if(i-imin)775,775,765
775 data(j)=data(imin)+data(imin+1)
    data(j+1)=0.
    imax=imin
    go to 745
780 data(1)=data(1)+data(2)
    data(2)=0.
    go to 900
    !
    !     COMPLETE A REAL TRANSFORM FOR THE 2ND, 3RD, ETC. DIMENSION BY
    !     CONJUGATE SYMMETRIES.
    !
800 if(i1rng-np1)805,900,900
805 do 860 i3=1,ntot,np2
      i2max=i3+np2-np1
      do 860 i2=i3,i2max,np1
        imax=i2+np1-2
        imin=i2+i1rng
        jmax=2*i3+np1-imin
        if(i2-i3)820,820,810
810     jmax=jmax+np2
820     if(idim-2)850,850,830
830     j=jmax+np0
        do 840 i=imin,imax,2
          data(i)=data(j)
          data(i+1)=-data(j+1)
840     j=j-2  ! Enddo i
850     j=jmax
        do 860 i=imin,imax,np0
          data(i)=data(j)
          data(i+1)=-data(j+1)
860 j=j-np0  ! Enddo i3,i2,i
    !
    !     END OF LOOP ON EACH DIMENSION
    !
900 np0=np1
    np1=np2
910 nprev=n  ! Enddo idim
920 return
end subroutine fourct
