! Fast Fourier/Cosine/Sine Transform
!     dimension   :one
!     data length :power of 2
!     decimation  :frequency
!     radix       :8, 4, 2
!     data        :inplace
!     table       :use
! subroutines
!     cdft: Complex Discrete Fourier Transform
!     rdft: Real Discrete Fourier Transform
!     ddct: Discrete Cosine Transform
!     ddst: Discrete Sine Transform
!     dfct: Cosine Transform of RDFT (Real Symmetric DFT)
!     dfst: Sine Transform of RDFT (Real Anti-symmetric DFT)
!
!
! -------- Complex DFT (Discrete Fourier Transform) --------
!     [definition]
!         <case1>
!             X(k) = sum_j=0^n-1 x(j)*exp(2*pi*i*j*k/n), 0<=k<n
!         <case2>
!             X(k) = sum_j=0^n-1 x(j)*exp(-2*pi*i*j*k/n), 0<=k<n
!         (notes: sum_j=0^n-1 is a summation from j=0 to n-1)
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call cdft(2*n, 1, a, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call cdft(2*n, -1, a, ip, w)
!     [parameters]
!         2*n          :data length (integer)
!                       n >= 1, n = power of 2
!         a(0:2*n-1)   :input/output data (real*8)
!                       input data
!                           a(2*j) = Re(x(j)),
!                           a(2*j+1) = Im(x(j)), 0<=j<n
!                       output data
!                           a(2*k) = Re(X(k)),
!                           a(2*k+1) = Im(X(k)), 0<=k<n
!         ip(0:*)      :work area for bit reversal (integer)
!                       length of ip >= 2+sqrt(n)
!                       strictly,
!                       length of ip >=
!                           2+2**(int(log(n+0.5)/log(2.0))/2).
!                       ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:n/2-1)   :cos/sin table (real*8)
!                       w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call cdft(2*n, -1, a, ip, w)
!         is
!             call cdft(2*n, 1, a, ip, w)
!             do j = 0, 2 * n - 1
!                 a(j) = a(j) / n
!             end do
!         .
!
!
! -------- Real DFT / Inverse of Real DFT --------
!     [definition]
!         <case1> RDFT
!             R(k) = sum_j=0^n-1 a(j)*cos(2*pi*j*k/n), 0<=k<=n/2
!             I(k) = sum_j=0^n-1 a(j)*sin(2*pi*j*k/n), 0<k<n/2
!         <case2> IRDFT (excluding scale)
!             a(k) = (R(0) + R(n/2)*cos(pi*k))/2 +
!                    sum_j=1^n/2-1 R(j)*cos(2*pi*j*k/n) +
!                    sum_j=1^n/2-1 I(j)*sin(2*pi*j*k/n), 0<=k<n
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call rdft(n, 1, a, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call rdft(n, -1, a, ip, w)
!     [parameters]
!         n            :data length (integer)
!                       n >= 2, n = power of 2
!         a(0:n-1)     :input/output data (real*8)
!                       <case1>
!                           output data
!                               a(2*k) = R(k), 0<=k<n/2
!                               a(2*k+1) = I(k), 0<k<n/2
!                               a(1) = R(n/2)
!                       <case2>
!                           input data
!                               a(2*j) = R(j), 0<=j<n/2
!                               a(2*j+1) = I(j), 0<j<n/2
!                               a(1) = R(n/2)
!         ip(0:*)      :work area for bit reversal (integer)
!                       length of ip >= 2+sqrt(n/2)
!                       strictly,
!                       length of ip >=
!                           2+2**(int(log(n/2+0.5)/log(2.0))/2).
!                       ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:n/2-1)   :cos/sin table (real*8)
!                       w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call rdft(n, 1, a, ip, w)
!         is
!             call rdft(n, -1, a, ip, w)
!             do j = 0, n - 1
!                 a(j) = a(j) * 2 / n
!             end do
!         .
!
!
! -------- DCT (Discrete Cosine Transform) / Inverse of DCT --------
!     [definition]
!         <case1> IDCT (excluding scale)
!             C(k) = sum_j=0^n-1 a(j)*cos(pi*j*(k+1/2)/n), 0<=k<n
!         <case2> DCT
!             C(k) = sum_j=0^n-1 a(j)*cos(pi*(j+1/2)*k/n), 0<=k<n
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call ddct(n, 1, a, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call ddct(n, -1, a, ip, w)
!     [parameters]
!         n            :data length (integer)
!                       n >= 2, n = power of 2
!         a(0:n-1)     :input/output data (real*8)
!                       output data
!                           a(k) = C(k), 0<=k<n
!         ip(0:*)      :work area for bit reversal (integer)
!                       length of ip >= 2+sqrt(n/2)
!                       strictly,
!                       length of ip >=
!                           2+2**(int(log(n/2+0.5)/log(2.0))/2).
!                       ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:n*5/4-1) :cos/sin table (real*8)
!                       w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call ddct(n, -1, a, ip, w)
!         is
!             a(0) = a(0) / 2
!             call ddct(n, 1, a, ip, w)
!             do j = 0, n - 1
!                 a(j) = a(j) * 2 / n
!             end do
!         .
!
!
! -------- DST (Discrete Sine Transform) / Inverse of DST --------
!     [definition]
!         <case1> IDST (excluding scale)
!             S(k) = sum_j=1^n A(j)*sin(pi*j*(k+1/2)/n), 0<=k<n
!         <case2> DST
!             S(k) = sum_j=0^n-1 a(j)*sin(pi*(j+1/2)*k/n), 0<k<=n
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call ddst(n, 1, a, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call ddst(n, -1, a, ip, w)
!     [parameters]
!         n            :data length (integer)
!                       n >= 2, n = power of 2
!         a(0:n-1)     :input/output data (real*8)
!                       <case1>
!                           input data
!                               a(j) = A(j), 0<j<n
!                               a(0) = A(n)
!                           output data
!                               a(k) = S(k), 0<=k<n
!                       <case2>
!                           output data
!                               a(k) = S(k), 0<k<n
!                               a(0) = S(n)
!         ip(0:*)      :work area for bit reversal (integer)
!                       length of ip >= 2+sqrt(n/2)
!                       strictly,
!                       length of ip >=
!                           2+2**(int(log(n/2+0.5)/log(2.0))/2).
!                       ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:n*5/4-1) :cos/sin table (real*8)
!                       w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call ddst(n, -1, a, ip, w)
!         is
!             a(0) = a(0) / 2
!             call ddst(n, 1, a, ip, w)
!             do j = 0, n - 1
!                 a(j) = a(j) * 2 / n
!             end do
!         .
!
!
! -------- Cosine Transform of RDFT (Real Symmetric DFT) --------
!     [definition]
!         C(k) = sum_j=0^n a(j)*cos(pi*j*k/n), 0<=k<=n
!     [usage]
!         ip(0) = 0  ! first time only
!         call dfct(n, a, t, ip, w)
!     [parameters]
!         n            :data length - 1 (integer)
!                       n >= 2, n = power of 2
!         a(0:n)       :input/output data (real*8)
!                       output data
!                           a(k) = C(k), 0<=k<=n
!         t(0:n/2)     :work area (real*8)
!         ip(0:*)      :work area for bit reversal (integer)
!                       length of ip >= 2+sqrt(n/4)
!                       strictly,
!                       length of ip >=
!                           2+2**(int(log(n/4+0.5)/log(2.0))/2).
!                       ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:n*5/8-1) :cos/sin table (real*8)
!                       w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             a(0) = a(0) / 2
!             a(n) = a(n) / 2
!             call dfct(n, a, t, ip, w)
!         is
!             a(0) = a(0) / 2
!             a(n) = a(n) / 2
!             call dfct(n, a, t, ip, w)
!             do j = 0, n
!                 a(j) = a(j) * 2 / n
!             end do
!         .
!
!
! -------- Sine Transform of RDFT (Real Anti-symmetric DFT) --------
!     [definition]
!         S(k) = sum_j=1^n-1 a(j)*sin(pi*j*k/n), 0<k<n
!     [usage]
!         ip(0) = 0  ! first time only
!         call dfst(n, a, t, ip, w)
!     [parameters]
!         n            :data length + 1 (integer)
!                       n >= 2, n = power of 2
!         a(0:n-1)     :input/output data (real*8)
!                       output data
!                           a(k) = S(k), 0<k<n
!                       (a(0) is used for work area)
!         t(0:n/2-1)   :work area (real*8)
!         ip(0:*)      :work area for bit reversal (integer)
!                       length of ip >= 2+sqrt(n/4)
!                       strictly,
!                       length of ip >=
!                           2+2**(int(log(n/4+0.5)/log(2.0))/2).
!                       ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:n*5/8-1) :cos/sin table (real*8)
!                       w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call dfst(n, a, t, ip, w)
!         is
!             call dfst(n, a, t, ip, w)
!             do j = 1, n - 1
!                 a(j) = a(j) * 2 / n
!             end do
!         .
!
!
! Appendix :
!     The cos/sin table is recalculated when the larger table required.
!     w() and ip() are compatible with all routines.
!
!
      subroutine cdft(n, isgn, a, ip, w)
      integer n, isgn, ip(0 : *)
      real*8 a(0 : n - 1), w(0 : *)
      if (n .gt. 4 * ip(0)) then
          call makewt(n / 4, ip, w)
      end if
      if (n .gt. 4) then
          if (isgn .ge. 0) then
              call bitrv2(n, ip(2), a)
              call cftfsub(n, a, w)
          else
              call bitrv2conj(n, ip(2), a)
              call cftbsub(n, a, w)
          end if
      else if (n .eq. 4) then
          call cftfsub(n, a, w)
      end if
      end
!
      subroutine rdft(n, isgn, a, ip, w)
      integer n, isgn, ip(0 : *), nw, nc
      real*8 a(0 : n - 1), w(0 : *), xi
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n .gt. 4 * nc) then
          nc = n / 4
          call makect(nc, ip, w(nw))
      end if
      if (isgn .ge. 0) then
          if (n .gt. 4) then
              call bitrv2(n, ip(2), a)
              call cftfsub(n, a, w)
              call rftfsub(n, a, nc, w(nw))
          else if (n .eq. 4) then
              call cftfsub(n, a, w)
          end if
          xi = a(0) - a(1)
          a(0) = a(0) + a(1)
          a(1) = xi
      else
          a(1) = 0.5d0 * (a(0) - a(1))
          a(0) = a(0) - a(1)
          if (n .gt. 4) then
              call rftbsub(n, a, nc, w(nw))
              call bitrv2(n, ip(2), a)
              call cftbsub(n, a, w)
          else if (n .eq. 4) then
              call cftfsub(n, a, w)
          end if
      end if
      end
!
      subroutine ddct(n, isgn, a, ip, w)
      integer n, isgn, ip(0 : *), j, nw, nc
      real*8 a(0 : n - 1), w(0 : *), xr
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n .gt. nc) then
          nc = n
          call makect(nc, ip, w(nw))
      end if
      if (isgn .lt. 0) then
          xr = a(n - 1)
          do j = n - 2, 2, -2
              a(j + 1) = a(j) - a(j - 1)
              a(j) = a(j) + a(j - 1)
          end do
          a(1) = a(0) - xr
          a(0) = a(0) + xr
          if (n .gt. 4) then
              call rftbsub(n, a, nc, w(nw))
              call bitrv2(n, ip(2), a)
              call cftbsub(n, a, w)
          else if (n .eq. 4) then
              call cftfsub(n, a, w)
          end if
      end if
      call dctsub(n, a, nc, w(nw))
      if (isgn .ge. 0) then
          if (n .gt. 4) then
              call bitrv2(n, ip(2), a)
              call cftfsub(n, a, w)
              call rftfsub(n, a, nc, w(nw))
          else if (n .eq. 4) then
              call cftfsub(n, a, w)
          end if
          xr = a(0) - a(1)
          a(0) = a(0) + a(1)
          do j = 2, n - 2, 2
              a(j - 1) = a(j) - a(j + 1)
              a(j) = a(j) + a(j + 1)
          end do
          a(n - 1) = xr
      end if
      end
!
      subroutine ddst(n, isgn, a, ip, w)
      integer n, isgn, ip(0 : *), j, nw, nc
      real*8 a(0 : n - 1), w(0 : *), xr
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n .gt. nc) then
          nc = n
          call makect(nc, ip, w(nw))
      end if
      if (isgn .lt. 0) then
          xr = a(n - 1)
          do j = n - 2, 2, -2
              a(j + 1) = -a(j) - a(j - 1)
              a(j) = a(j) - a(j - 1)
          end do
          a(1) = a(0) + xr
          a(0) = a(0) - xr
          if (n .gt. 4) then
              call rftbsub(n, a, nc, w(nw))
              call bitrv2(n, ip(2), a)
              call cftbsub(n, a, w)
          else if (n .eq. 4) then
              call cftfsub(n, a, w)
          end if
      end if
      call dstsub(n, a, nc, w(nw))
      if (isgn .ge. 0) then
          if (n .gt. 4) then
              call bitrv2(n, ip(2), a)
              call cftfsub(n, a, w)
              call rftfsub(n, a, nc, w(nw))
          else if (n .eq. 4) then
              call cftfsub(n, a, w)
          end if
          xr = a(0) - a(1)
          a(0) = a(0) + a(1)
          do j = 2, n - 2, 2
              a(j - 1) = -a(j) - a(j + 1)
              a(j) = a(j) - a(j + 1)
          end do
          a(n - 1) = -xr
      end if
      end
!
      subroutine dfct(n, a, t, ip, w)
      integer n, ip(0 : *), j, k, l, m, mh, nw, nc
      real*8 a(0 : n), t(0 : n / 2), w(0 : *), xr, xi, yr, yi
      nw = ip(0)
      if (n .gt. 8 * nw) then
          nw = n / 8
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n .gt. 2 * nc) then
          nc = n / 2
          call makect(nc, ip, w(nw))
      end if
      m = n / 2
      yi = a(m)
      xi = a(0) + a(n)
      a(0) = a(0) - a(n)
      t(0) = xi - yi
      t(m) = xi + yi
      if (n .gt. 2) then
          mh = m / 2
          do j = 1, mh - 1
              k = m - j
              xr = a(j) - a(n - j)
              xi = a(j) + a(n - j)
              yr = a(k) - a(n - k)
              yi = a(k) + a(n - k)
              a(j) = xr
              a(k) = yr
              t(j) = xi - yi
              t(k) = xi + yi
          end do
          t(mh) = a(mh) + a(n - mh)
          a(mh) = a(mh) - a(n - mh)
          call dctsub(m, a, nc, w(nw))
          if (m .gt. 4) then
              call bitrv2(m, ip(2), a)
              call cftfsub(m, a, w)
              call rftfsub(m, a, nc, w(nw))
          else if (m .eq. 4) then
              call cftfsub(m, a, w)
          end if
          a(n - 1) = a(0) - a(1)
          a(1) = a(0) + a(1)
          do j = m - 2, 2, -2
              a(2 * j + 1) = a(j) + a(j + 1)
              a(2 * j - 1) = a(j) - a(j + 1)
          end do
          l = 2
          m = mh
          do while (m .ge. 2)
              call dctsub(m, t, nc, w(nw))
              if (m .gt. 4) then
                  call bitrv2(m, ip(2), t)
                  call cftfsub(m, t, w)
                  call rftfsub(m, t, nc, w(nw))
              else if (m .eq. 4) then
                  call cftfsub(m, t, w)
              end if
              a(n - l) = t(0) - t(1)
              a(l) = t(0) + t(1)
              k = 0
              do j = 2, m - 2, 2
                  k = k + 4 * l
                  a(k - l) = t(j) - t(j + 1)
                  a(k + l) = t(j) + t(j + 1)
              end do
              l = 2 * l
              mh = m / 2
              do j = 0, mh - 1
                  k = m - j
                  t(j) = t(m + k) - t(m + j)
                  t(k) = t(m + k) + t(m + j)
              end do
              t(mh) = t(m + mh)
              m = mh
          end do
          a(l) = t(0)
          a(n) = t(2) - t(1)
          a(0) = t(2) + t(1)
      else
          a(1) = a(0)
          a(2) = t(0)
          a(0) = t(1)
      end if
      end
!
      subroutine dfst(n, a, t, ip, w)
      integer n, ip(0 : *), j, k, l, m, mh, nw, nc
      real*8 a(0 : n - 1), t(0 : n / 2 - 1), w(0 : *), xr, xi, yr, yi
      nw = ip(0)
      if (n .gt. 8 * nw) then
          nw = n / 8
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n .gt. 2 * nc) then
          nc = n / 2
          call makect(nc, ip, w(nw))
      end if
      if (n .gt. 2) then
          m = n / 2
          mh = m / 2
          do j = 1, mh - 1
              k = m - j
              xr = a(j) + a(n - j)
              xi = a(j) - a(n - j)
              yr = a(k) + a(n - k)
              yi = a(k) - a(n - k)
              a(j) = xr
              a(k) = yr
              t(j) = xi + yi
              t(k) = xi - yi
          end do
          t(0) = a(mh) - a(n - mh)
          a(mh) = a(mh) + a(n - mh)
          a(0) = a(m)
          call dstsub(m, a, nc, w(nw))
          if (m .gt. 4) then
              call bitrv2(m, ip(2), a)
              call cftfsub(m, a, w)
              call rftfsub(m, a, nc, w(nw))
          else if (m .eq. 4) then
              call cftfsub(m, a, w)
          end if
          a(n - 1) = a(1) - a(0)
          a(1) = a(0) + a(1)
          do j = m - 2, 2, -2
              a(2 * j + 1) = a(j) - a(j + 1)
              a(2 * j - 1) = -a(j) - a(j + 1)
          end do
          l = 2
          m = mh
          do while (m .ge. 2)
              call dstsub(m, t, nc, w(nw))
              if (m .gt. 4) then
                  call bitrv2(m, ip(2), t)
                  call cftfsub(m, t, w)
                  call rftfsub(m, t, nc, w(nw))
              else if (m .eq. 4) then
                  call cftfsub(m, t, w)
              end if
              a(n - l) = t(1) - t(0)
              a(l) = t(0) + t(1)
              k = 0
              do j = 2, m - 2, 2
                  k = k + 4 * l
                  a(k - l) = -t(j) - t(j + 1)
                  a(k + l) = t(j) - t(j + 1)
              end do
              l = 2 * l
              mh = m / 2
              do j = 1, mh - 1
                  k = m - j
                  t(j) = t(m + k) + t(m + j)
                  t(k) = t(m + k) - t(m + j)
              end do
              t(0) = t(m + mh)
              m = mh
          end do
          a(l) = t(0)
      end if
      a(0) = 0
      end
!
! -------- initializing routines --------
!
      subroutine makewt(nw, ip, w)
      integer nw, ip(0 : *), j, nwh
      real*8 w(0 : nw - 1), delta, x, y
      ip(0) = nw
      ip(1) = 1
      if (nw .gt. 2) then
          nwh = nw / 2
          delta = atan(1.0d0) / nwh
          w(0) = 1
          w(1) = 0
          w(nwh) = cos(delta * nwh)
          w(nwh + 1) = w(nwh)
          if (nwh .gt. 2) then
              do j = 2, nwh - 2, 2
                  x = cos(delta * j)
                  y = sin(delta * j)
                  w(j) = x
                  w(j + 1) = y
                  w(nw - j) = y
                  w(nw - j + 1) = x
              end do
              do j = nwh - 2, 2, -2
                  x = w(2 * j)
                  y = w(2 * j + 1)
                  w(nwh + j) = x
                  w(nwh + j + 1) = y
              end do
              call bitrv2(nw, ip(2), w)
          end if
      end if
      end
!
      subroutine makect(nc, ip, c)
      integer nc, ip(0 : *), j, nch
      real*8 c(0 : nc - 1), delta
      ip(1) = nc
      if (nc .gt. 1) then
          nch = nc / 2
          delta = atan(1.0d0) / nch
          c(0) = cos(delta * nch)
          c(nch) = 0.5d0 * c(0)
          do j = 1, nch - 1
              c(j) = 0.5d0 * cos(delta * j)
              c(nc - j) = 0.5d0 * sin(delta * j)
          end do
      end if
      end
!
! -------- child routines --------
!
      subroutine bitrv2(n, ip, a)
      integer n, ip(0 : *), j, j1, k, k1, l, m, m2
      real*8 a(0 : n - 1), xr, xi, yr, yi
      ip(0) = 0
      l = n
      m = 1
      do while (8 * m .lt. l)
          l = l / 2
          do j = 0, m - 1
              ip(m + j) = ip(j) + l
          end do
          m = m * 2
      end do
      m2 = 2 * m
      if (8 * m .eq. l) then
          do k = 0, m - 1
              do j = 0, k - 1
                  j1 = 2 * j + ip(k)
                  k1 = 2 * k + ip(j)
                  xr = a(j1)
                  xi = a(j1 + 1)
                  yr = a(k1)
                  yi = a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
                  j1 = j1 + m2
                  k1 = k1 + 2 * m2
                  xr = a(j1)
                  xi = a(j1 + 1)
                  yr = a(k1)
                  yi = a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
                  j1 = j1 + m2
                  k1 = k1 - m2
                  xr = a(j1)
                  xi = a(j1 + 1)
                  yr = a(k1)
                  yi = a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
                  j1 = j1 + m2
                  k1 = k1 + 2 * m2
                  xr = a(j1)
                  xi = a(j1 + 1)
                  yr = a(k1)
                  yi = a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
              end do
              j1 = 2 * k + m2 + ip(k)
              k1 = j1 + m2
              xr = a(j1)
              xi = a(j1 + 1)
              yr = a(k1)
              yi = a(k1 + 1)
              a(j1) = yr
              a(j1 + 1) = yi
              a(k1) = xr
              a(k1 + 1) = xi
          end do
      else
          do k = 1, m - 1
              do j = 0, k - 1
                  j1 = 2 * j + ip(k)
                  k1 = 2 * k + ip(j)
                  xr = a(j1)
                  xi = a(j1 + 1)
                  yr = a(k1)
                  yi = a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
                  j1 = j1 + m2
                  k1 = k1 + m2
                  xr = a(j1)
                  xi = a(j1 + 1)
                  yr = a(k1)
                  yi = a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
              end do
          end do
      end if
      end
!
      subroutine bitrv2conj(n, ip, a)
      integer n, ip(0 : *), j, j1, k, k1, l, m, m2
      real*8 a(0 : n - 1), xr, xi, yr, yi
      ip(0) = 0
      l = n
      m = 1
      do while (8 * m .lt. l)
          l = l / 2
          do j = 0, m - 1
              ip(m + j) = ip(j) + l
          end do
          m = m * 2
      end do
      m2 = 2 * m
      if (8 * m .eq. l) then
          do k = 0, m - 1
              do j = 0, k - 1
                  j1 = 2 * j + ip(k)
                  k1 = 2 * k + ip(j)
                  xr = a(j1)
                  xi = -a(j1 + 1)
                  yr = a(k1)
                  yi = -a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
                  j1 = j1 + m2
                  k1 = k1 + 2 * m2
                  xr = a(j1)
                  xi = -a(j1 + 1)
                  yr = a(k1)
                  yi = -a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
                  j1 = j1 + m2
                  k1 = k1 - m2
                  xr = a(j1)
                  xi = -a(j1 + 1)
                  yr = a(k1)
                  yi = -a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
                  j1 = j1 + m2
                  k1 = k1 + 2 * m2
                  xr = a(j1)
                  xi = -a(j1 + 1)
                  yr = a(k1)
                  yi = -a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
              end do
              k1 = 2 * k + ip(k)
              a(k1 + 1) = -a(k1 + 1)
              j1 = k1 + m2
              k1 = j1 + m2
              xr = a(j1)
              xi = -a(j1 + 1)
              yr = a(k1)
              yi = -a(k1 + 1)
              a(j1) = yr
              a(j1 + 1) = yi
              a(k1) = xr
              a(k1 + 1) = xi
              k1 = k1 + m2
              a(k1 + 1) = -a(k1 + 1)
          end do
      else
          a(1) = -a(1)
          a(m2 + 1) = -a(m2 + 1)
          do k = 1, m - 1
              do j = 0, k - 1
                  j1 = 2 * j + ip(k)
                  k1 = 2 * k + ip(j)
                  xr = a(j1)
                  xi = -a(j1 + 1)
                  yr = a(k1)
                  yi = -a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
                  j1 = j1 + m2
                  k1 = k1 + m2
                  xr = a(j1)
                  xi = -a(j1 + 1)
                  yr = a(k1)
                  yi = -a(k1 + 1)
                  a(j1) = yr
                  a(j1 + 1) = yi
                  a(k1) = xr
                  a(k1 + 1) = xi
              end do
              k1 = 2 * k + ip(k)
              a(k1 + 1) = -a(k1 + 1)
              a(k1 + m2 + 1) = -a(k1 + m2 + 1)
          end do
      end if
      end
!
      subroutine cftfsub(n, a, w)
      integer n, j, j1, j2, j3, l
      real*8 a(0 : n - 1), w(0 : *)
      real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i
      l = 2
      if (n .ge. 16) then
          call cft1st(n, a, w)
          l = 16
          do while (8 * l .le. n)
              call cftmdl(n, l, a, w)
              l = 8 * l
          end do
      end if
      if (2 * l .lt. n) then
          do j = 0, l - 2, 2
              j1 = j + l
              j2 = j1 + l
              j3 = j2 + l
              x0r = a(j) + a(j1)
              x0i = a(j + 1) + a(j1 + 1)
              x1r = a(j) - a(j1)
              x1i = a(j + 1) - a(j1 + 1)
              x2r = a(j2) + a(j3)
              x2i = a(j2 + 1) + a(j3 + 1)
              x3r = a(j2) - a(j3)
              x3i = a(j2 + 1) - a(j3 + 1)
              a(j) = x0r + x2r
              a(j + 1) = x0i + x2i
              a(j2) = x0r - x2r
              a(j2 + 1) = x0i - x2i
              a(j1) = x1r - x3i
              a(j1 + 1) = x1i + x3r
              a(j3) = x1r + x3i
              a(j3 + 1) = x1i - x3r
          end do
      else if (2 * l .eq. n) then
          do j = 0, l - 2, 2
              j1 = j + l
              x0r = a(j) - a(j1)
              x0i = a(j + 1) - a(j1 + 1)
              a(j) = a(j) + a(j1)
              a(j + 1) = a(j + 1) + a(j1 + 1)
              a(j1) = x0r
              a(j1 + 1) = x0i
          end do
      end if
      end
!
      subroutine cftbsub(n, a, w)
      integer n, j, j1, j2, j3, j4, j5, j6, j7, l
      real*8 a(0 : n - 1), w(0 : *)
      real*8 wn4r, x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i
      real*8 y0r, y0i, y1r, y1i, y2r, y2i, y3r, y3i
      real*8 y4r, y4i, y5r, y5i, y6r, y6i, y7r, y7i
      l = 2
      if (n .gt. 16) then
          call cft1st(n, a, w)
          l = 16
          do while (8 * l .lt. n)
              call cftmdl(n, l, a, w)
              l = 8 * l
          end do
      end if
      if (4 * l .lt. n) then
          wn4r = w(2)
          do j = 0, l - 2, 2
              j1 = j + l
              j2 = j1 + l
              j3 = j2 + l
              j4 = j3 + l
              j5 = j4 + l
              j6 = j5 + l
              j7 = j6 + l
              x0r = a(j) + a(j1)
              x0i = -a(j + 1) - a(j1 + 1)
              x1r = a(j) - a(j1)
              x1i = -a(j + 1) + a(j1 + 1)
              x2r = a(j2) + a(j3)
              x2i = a(j2 + 1) + a(j3 + 1)
              x3r = a(j2) - a(j3)
              x3i = a(j2 + 1) - a(j3 + 1)
              y0r = x0r + x2r
              y0i = x0i - x2i
              y2r = x0r - x2r
              y2i = x0i + x2i
              y1r = x1r - x3i
              y1i = x1i - x3r
              y3r = x1r + x3i
              y3i = x1i + x3r
              x0r = a(j4) + a(j5)
              x0i = a(j4 + 1) + a(j5 + 1)
              x1r = a(j4) - a(j5)
              x1i = a(j4 + 1) - a(j5 + 1)
              x2r = a(j6) + a(j7)
              x2i = a(j6 + 1) + a(j7 + 1)
              x3r = a(j6) - a(j7)
              x3i = a(j6 + 1) - a(j7 + 1)
              y4r = x0r + x2r
              y4i = x0i + x2i
              y6r = x0r - x2r
              y6i = x0i - x2i
              x0r = x1r - x3i
              x0i = x1i + x3r
              x2r = x1r + x3i
              x2i = x1i - x3r
              y5r = wn4r * (x0r - x0i)
              y5i = wn4r * (x0r + x0i)
              y7r = wn4r * (x2r - x2i)
              y7i = wn4r * (x2r + x2i)
              a(j1) = y1r + y5r
              a(j1 + 1) = y1i - y5i
              a(j5) = y1r - y5r
              a(j5 + 1) = y1i + y5i
              a(j3) = y3r - y7i
              a(j3 + 1) = y3i - y7r
              a(j7) = y3r + y7i
              a(j7 + 1) = y3i + y7r
              a(j) = y0r + y4r
              a(j + 1) = y0i - y4i
              a(j4) = y0r - y4r
              a(j4 + 1) = y0i + y4i
              a(j2) = y2r - y6i
              a(j2 + 1) = y2i - y6r
              a(j6) = y2r + y6i
              a(j6 + 1) = y2i + y6r
          end do
      else if (4 * l .eq. n) then
          do j = 0, l - 2, 2
              j1 = j + l
              j2 = j1 + l
              j3 = j2 + l
              x0r = a(j) + a(j1)
              x0i = -a(j + 1) - a(j1 + 1)
              x1r = a(j) - a(j1)
              x1i = -a(j + 1) + a(j1 + 1)
              x2r = a(j2) + a(j3)
              x2i = a(j2 + 1) + a(j3 + 1)
              x3r = a(j2) - a(j3)
              x3i = a(j2 + 1) - a(j3 + 1)
              a(j) = x0r + x2r
              a(j + 1) = x0i - x2i
              a(j2) = x0r - x2r
              a(j2 + 1) = x0i + x2i
              a(j1) = x1r - x3i
              a(j1 + 1) = x1i - x3r
              a(j3) = x1r + x3i
              a(j3 + 1) = x1i + x3r
          end do
      else
          do j = 0, l - 2, 2
              j1 = j + l
              x0r = a(j) - a(j1)
              x0i = -a(j + 1) + a(j1 + 1)
              a(j) = a(j) + a(j1)
              a(j + 1) = -a(j + 1) - a(j1 + 1)
              a(j1) = x0r
              a(j1 + 1) = x0i
          end do
      end if
      end
!
      subroutine cft1st(n, a, w)
      integer n, j, k1
      real*8 a(0 : n - 1), w(0 : *)
      real*8 wn4r, wtmp, wk1r, wk1i, wk2r, wk2i, wk3r, wk3i
      real*8 wk4r, wk4i, wk5r, wk5i, wk6r, wk6i, wk7r, wk7i
      real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i
      real*8 y0r, y0i, y1r, y1i, y2r, y2i, y3r, y3i
      real*8 y4r, y4i, y5r, y5i, y6r, y6i, y7r, y7i
      wn4r = w(2)
      x0r = a(0) + a(2)
      x0i = a(1) + a(3)
      x1r = a(0) - a(2)
      x1i = a(1) - a(3)
      x2r = a(4) + a(6)
      x2i = a(5) + a(7)
      x3r = a(4) - a(6)
      x3i = a(5) - a(7)
      y0r = x0r + x2r
      y0i = x0i + x2i
      y2r = x0r - x2r
      y2i = x0i - x2i
      y1r = x1r - x3i
      y1i = x1i + x3r
      y3r = x1r + x3i
      y3i = x1i - x3r
      x0r = a(8) + a(10)
      x0i = a(9) + a(11)
      x1r = a(8) - a(10)
      x1i = a(9) - a(11)
      x2r = a(12) + a(14)
      x2i = a(13) + a(15)
      x3r = a(12) - a(14)
      x3i = a(13) - a(15)
      y4r = x0r + x2r
      y4i = x0i + x2i
      y6r = x0r - x2r
      y6i = x0i - x2i
      x0r = x1r - x3i
      x0i = x1i + x3r
      x2r = x1r + x3i
      x2i = x1i - x3r
      y5r = wn4r * (x0r - x0i)
      y5i = wn4r * (x0r + x0i)
      y7r = wn4r * (x2r - x2i)
      y7i = wn4r * (x2r + x2i)
      a(2) = y1r + y5r
      a(3) = y1i + y5i
      a(10) = y1r - y5r
      a(11) = y1i - y5i
      a(6) = y3r - y7i
      a(7) = y3i + y7r
      a(14) = y3r + y7i
      a(15) = y3i - y7r
      a(0) = y0r + y4r
      a(1) = y0i + y4i
      a(8) = y0r - y4r
      a(9) = y0i - y4i
      a(4) = y2r - y6i
      a(5) = y2i + y6r
      a(12) = y2r + y6i
      a(13) = y2i - y6r
      if (n .gt. 16) then
          wk1r = w(4)
          wk1i = w(5)
          x0r = a(16) + a(18)
          x0i = a(17) + a(19)
          x1r = a(16) - a(18)
          x1i = a(17) - a(19)
          x2r = a(20) + a(22)
          x2i = a(21) + a(23)
          x3r = a(20) - a(22)
          x3i = a(21) - a(23)
          y0r = x0r + x2r
          y0i = x0i + x2i
          y2r = x0r - x2r
          y2i = x0i - x2i
          y1r = x1r - x3i
          y1i = x1i + x3r
          y3r = x1r + x3i
          y3i = x1i - x3r
          x0r = a(24) + a(26)
          x0i = a(25) + a(27)
          x1r = a(24) - a(26)
          x1i = a(25) - a(27)
          x2r = a(28) + a(30)
          x2i = a(29) + a(31)
          x3r = a(28) - a(30)
          x3i = a(29) - a(31)
          y4r = x0r + x2r
          y4i = x0i + x2i
          y6r = x0r - x2r
          y6i = x0i - x2i
          x0r = x1r - x3i
          x0i = x1i + x3r
          x2r = x1r + x3i
          x2i = x3r - x1i
          y5r = wk1i * x0r - wk1r * x0i
          y5i = wk1i * x0i + wk1r * x0r
          y7r = wk1r * x2r + wk1i * x2i
          y7i = wk1r * x2i - wk1i * x2r
          x0r = wk1r * y1r - wk1i * y1i
          x0i = wk1r * y1i + wk1i * y1r
          a(18) = x0r + y5r
          a(19) = x0i + y5i
          a(26) = y5i - x0i
          a(27) = x0r - y5r
          x0r = wk1i * y3r - wk1r * y3i
          x0i = wk1i * y3i + wk1r * y3r
          a(22) = x0r - y7r
          a(23) = x0i + y7i
          a(30) = y7i - x0i
          a(31) = x0r + y7r
          a(16) = y0r + y4r
          a(17) = y0i + y4i
          a(24) = y4i - y0i
          a(25) = y0r - y4r
          x0r = y2r - y6i
          x0i = y2i + y6r
          a(20) = wn4r * (x0r - x0i)
          a(21) = wn4r * (x0i + x0r)
          x0r = y6r - y2i
          x0i = y2r + y6i
          a(28) = wn4r * (x0r - x0i)
          a(29) = wn4r * (x0i + x0r)
          k1 = 4
          do j = 32, n - 16, 16
              k1 = k1 + 4
              wk1r = w(k1)
              wk1i = w(k1 + 1)
              wk2r = w(k1 + 2)
              wk2i = w(k1 + 3)
              wtmp = 2 * wk2i
              wk3r = wk1r - wtmp * wk1i
              wk3i = wtmp * wk1r - wk1i
              wk4r = 1 - wtmp * wk2i
              wk4i = wtmp * wk2r
              wtmp = 2 * wk4i
              wk5r = wk3r - wtmp * wk1i
              wk5i = wtmp * wk1r - wk3i
              wk6r = wk2r - wtmp * wk2i
              wk6i = wtmp * wk2r - wk2i
              wk7r = wk1r - wtmp * wk3i
              wk7i = wtmp * wk3r - wk1i
              x0r = a(j) + a(j + 2)
              x0i = a(j + 1) + a(j + 3)
              x1r = a(j) - a(j + 2)
              x1i = a(j + 1) - a(j + 3)
              x2r = a(j + 4) + a(j + 6)
              x2i = a(j + 5) + a(j + 7)
              x3r = a(j + 4) - a(j + 6)
              x3i = a(j + 5) - a(j + 7)
              y0r = x0r + x2r
              y0i = x0i + x2i
              y2r = x0r - x2r
              y2i = x0i - x2i
              y1r = x1r - x3i
              y1i = x1i + x3r
              y3r = x1r + x3i
              y3i = x1i - x3r
              x0r = a(j + 8) + a(j + 10)
              x0i = a(j + 9) + a(j + 11)
              x1r = a(j + 8) - a(j + 10)
              x1i = a(j + 9) - a(j + 11)
              x2r = a(j + 12) + a(j + 14)
              x2i = a(j + 13) + a(j + 15)
              x3r = a(j + 12) - a(j + 14)
              x3i = a(j + 13) - a(j + 15)
              y4r = x0r + x2r
              y4i = x0i + x2i
              y6r = x0r - x2r
              y6i = x0i - x2i
              x0r = x1r - x3i
              x0i = x1i + x3r
              x2r = x1r + x3i
              x2i = x1i - x3r
              y5r = wn4r * (x0r - x0i)
              y5i = wn4r * (x0r + x0i)
              y7r = wn4r * (x2r - x2i)
              y7i = wn4r * (x2r + x2i)
              x0r = y1r + y5r
              x0i = y1i + y5i
              a(j + 2) = wk1r * x0r - wk1i * x0i
              a(j + 3) = wk1r * x0i + wk1i * x0r
              x0r = y1r - y5r
              x0i = y1i - y5i
              a(j + 10) = wk5r * x0r - wk5i * x0i
              a(j + 11) = wk5r * x0i + wk5i * x0r
              x0r = y3r - y7i
              x0i = y3i + y7r
              a(j + 6) = wk3r * x0r - wk3i * x0i
              a(j + 7) = wk3r * x0i + wk3i * x0r
              x0r = y3r + y7i
              x0i = y3i - y7r
              a(j + 14) = wk7r * x0r - wk7i * x0i
              a(j + 15) = wk7r * x0i + wk7i * x0r
              a(j) = y0r + y4r
              a(j + 1) = y0i + y4i
              x0r = y0r - y4r
              x0i = y0i - y4i
              a(j + 8) = wk4r * x0r - wk4i * x0i
              a(j + 9) = wk4r * x0i + wk4i * x0r
              x0r = y2r - y6i
              x0i = y2i + y6r
              a(j + 4) = wk2r * x0r - wk2i * x0i
              a(j + 5) = wk2r * x0i + wk2i * x0r
              x0r = y2r + y6i
              x0i = y2i - y6r
              a(j + 12) = wk6r * x0r - wk6i * x0i
              a(j + 13) = wk6r * x0i + wk6i * x0r
          end do
      end if
      end
!
      subroutine cftmdl(n, l, a, w)
      integer n, l, j, j1, j2, j3, j4, j5, j6, j7, k, k1, m
      real*8 a(0 : n - 1), w(0 : *)
      real*8 wn4r, wtmp, wk1r, wk1i, wk2r, wk2i, wk3r, wk3i
      real*8 wk4r, wk4i, wk5r, wk5i, wk6r, wk6i, wk7r, wk7i
      real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i
      real*8 y0r, y0i, y1r, y1i, y2r, y2i, y3r, y3i
      real*8 y4r, y4i, y5r, y5i, y6r, y6i, y7r, y7i
      m = 8 * l
      wn4r = w(2)
      do j = 0, l - 2, 2
          j1 = j + l
          j2 = j1 + l
          j3 = j2 + l
          j4 = j3 + l
          j5 = j4 + l
          j6 = j5 + l
          j7 = j6 + l
          x0r = a(j) + a(j1)
          x0i = a(j + 1) + a(j1 + 1)
          x1r = a(j) - a(j1)
          x1i = a(j + 1) - a(j1 + 1)
          x2r = a(j2) + a(j3)
          x2i = a(j2 + 1) + a(j3 + 1)
          x3r = a(j2) - a(j3)
          x3i = a(j2 + 1) - a(j3 + 1)
          y0r = x0r + x2r
          y0i = x0i + x2i
          y2r = x0r - x2r
          y2i = x0i - x2i
          y1r = x1r - x3i
          y1i = x1i + x3r
          y3r = x1r + x3i
          y3i = x1i - x3r
          x0r = a(j4) + a(j5)
          x0i = a(j4 + 1) + a(j5 + 1)
          x1r = a(j4) - a(j5)
          x1i = a(j4 + 1) - a(j5 + 1)
          x2r = a(j6) + a(j7)
          x2i = a(j6 + 1) + a(j7 + 1)
          x3r = a(j6) - a(j7)
          x3i = a(j6 + 1) - a(j7 + 1)
          y4r = x0r + x2r
          y4i = x0i + x2i
          y6r = x0r - x2r
          y6i = x0i - x2i
          x0r = x1r - x3i
          x0i = x1i + x3r
          x2r = x1r + x3i
          x2i = x1i - x3r
          y5r = wn4r * (x0r - x0i)
          y5i = wn4r * (x0r + x0i)
          y7r = wn4r * (x2r - x2i)
          y7i = wn4r * (x2r + x2i)
          a(j1) = y1r + y5r
          a(j1 + 1) = y1i + y5i
          a(j5) = y1r - y5r
          a(j5 + 1) = y1i - y5i
          a(j3) = y3r - y7i
          a(j3 + 1) = y3i + y7r
          a(j7) = y3r + y7i
          a(j7 + 1) = y3i - y7r
          a(j) = y0r + y4r
          a(j + 1) = y0i + y4i
          a(j4) = y0r - y4r
          a(j4 + 1) = y0i - y4i
          a(j2) = y2r - y6i
          a(j2 + 1) = y2i + y6r
          a(j6) = y2r + y6i
          a(j6 + 1) = y2i - y6r
      end do
      if (m .lt. n) then
          wk1r = w(4)
          wk1i = w(5)
          do j = m, l + m - 2, 2
              j1 = j + l
              j2 = j1 + l
              j3 = j2 + l
              j4 = j3 + l
              j5 = j4 + l
              j6 = j5 + l
              j7 = j6 + l
              x0r = a(j) + a(j1)
              x0i = a(j + 1) + a(j1 + 1)
              x1r = a(j) - a(j1)
              x1i = a(j + 1) - a(j1 + 1)
              x2r = a(j2) + a(j3)
              x2i = a(j2 + 1) + a(j3 + 1)
              x3r = a(j2) - a(j3)
              x3i = a(j2 + 1) - a(j3 + 1)
              y0r = x0r + x2r
              y0i = x0i + x2i
              y2r = x0r - x2r
              y2i = x0i - x2i
              y1r = x1r - x3i
              y1i = x1i + x3r
              y3r = x1r + x3i
              y3i = x1i - x3r
              x0r = a(j4) + a(j5)
              x0i = a(j4 + 1) + a(j5 + 1)
              x1r = a(j4) - a(j5)
              x1i = a(j4 + 1) - a(j5 + 1)
              x2r = a(j6) + a(j7)
              x2i = a(j6 + 1) + a(j7 + 1)
              x3r = a(j6) - a(j7)
              x3i = a(j6 + 1) - a(j7 + 1)
              y4r = x0r + x2r
              y4i = x0i + x2i
              y6r = x0r - x2r
              y6i = x0i - x2i
              x0r = x1r - x3i
              x0i = x1i + x3r
              x2r = x1r + x3i
              x2i = x3r - x1i
              y5r = wk1i * x0r - wk1r * x0i
              y5i = wk1i * x0i + wk1r * x0r
              y7r = wk1r * x2r + wk1i * x2i
              y7i = wk1r * x2i - wk1i * x2r
              x0r = wk1r * y1r - wk1i * y1i
              x0i = wk1r * y1i + wk1i * y1r
              a(j1) = x0r + y5r
              a(j1 + 1) = x0i + y5i
              a(j5) = y5i - x0i
              a(j5 + 1) = x0r - y5r
              x0r = wk1i * y3r - wk1r * y3i
              x0i = wk1i * y3i + wk1r * y3r
              a(j3) = x0r - y7r
              a(j3 + 1) = x0i + y7i
              a(j7) = y7i - x0i
              a(j7 + 1) = x0r + y7r
              a(j) = y0r + y4r
              a(j + 1) = y0i + y4i
              a(j4) = y4i - y0i
              a(j4 + 1) = y0r - y4r
              x0r = y2r - y6i
              x0i = y2i + y6r
              a(j2) = wn4r * (x0r - x0i)
              a(j2 + 1) = wn4r * (x0i + x0r)
              x0r = y6r - y2i
              x0i = y2r + y6i
              a(j6) = wn4r * (x0r - x0i)
              a(j6 + 1) = wn4r * (x0i + x0r)
          end do
          k1 = 4
          do k = 2 * m, n - m, m
              k1 = k1 + 4
              wk1r = w(k1)
              wk1i = w(k1 + 1)
              wk2r = w(k1 + 2)
              wk2i = w(k1 + 3)
              wtmp = 2 * wk2i
              wk3r = wk1r - wtmp * wk1i
              wk3i = wtmp * wk1r - wk1i
              wk4r = 1 - wtmp * wk2i
              wk4i = wtmp * wk2r
              wtmp = 2 * wk4i
              wk5r = wk3r - wtmp * wk1i
              wk5i = wtmp * wk1r - wk3i
              wk6r = wk2r - wtmp * wk2i
              wk6i = wtmp * wk2r - wk2i
              wk7r = wk1r - wtmp * wk3i
              wk7i = wtmp * wk3r - wk1i
              do j = k, l + k - 2, 2
                  j1 = j + l
                  j2 = j1 + l
                  j3 = j2 + l
                  j4 = j3 + l
                  j5 = j4 + l
                  j6 = j5 + l
                  j7 = j6 + l
                  x0r = a(j) + a(j1)
                  x0i = a(j + 1) + a(j1 + 1)
                  x1r = a(j) - a(j1)
                  x1i = a(j + 1) - a(j1 + 1)
                  x2r = a(j2) + a(j3)
                  x2i = a(j2 + 1) + a(j3 + 1)
                  x3r = a(j2) - a(j3)
                  x3i = a(j2 + 1) - a(j3 + 1)
                  y0r = x0r + x2r
                  y0i = x0i + x2i
                  y2r = x0r - x2r
                  y2i = x0i - x2i
                  y1r = x1r - x3i
                  y1i = x1i + x3r
                  y3r = x1r + x3i
                  y3i = x1i - x3r
                  x0r = a(j4) + a(j5)
                  x0i = a(j4 + 1) + a(j5 + 1)
                  x1r = a(j4) - a(j5)
                  x1i = a(j4 + 1) - a(j5 + 1)
                  x2r = a(j6) + a(j7)
                  x2i = a(j6 + 1) + a(j7 + 1)
                  x3r = a(j6) - a(j7)
                  x3i = a(j6 + 1) - a(j7 + 1)
                  y4r = x0r + x2r
                  y4i = x0i + x2i
                  y6r = x0r - x2r
                  y6i = x0i - x2i
                  x0r = x1r - x3i
                  x0i = x1i + x3r
                  x2r = x1r + x3i
                  x2i = x1i - x3r
                  y5r = wn4r * (x0r - x0i)
                  y5i = wn4r * (x0r + x0i)
                  y7r = wn4r * (x2r - x2i)
                  y7i = wn4r * (x2r + x2i)
                  x0r = y1r + y5r
                  x0i = y1i + y5i
                  a(j1) = wk1r * x0r - wk1i * x0i
                  a(j1 + 1) = wk1r * x0i + wk1i * x0r
                  x0r = y1r - y5r
                  x0i = y1i - y5i
                  a(j5) = wk5r * x0r - wk5i * x0i
                  a(j5 + 1) = wk5r * x0i + wk5i * x0r
                  x0r = y3r - y7i
                  x0i = y3i + y7r
                  a(j3) = wk3r * x0r - wk3i * x0i
                  a(j3 + 1) = wk3r * x0i + wk3i * x0r
                  x0r = y3r + y7i
                  x0i = y3i - y7r
                  a(j7) = wk7r * x0r - wk7i * x0i
                  a(j7 + 1) = wk7r * x0i + wk7i * x0r
                  a(j) = y0r + y4r
                  a(j + 1) = y0i + y4i
                  x0r = y0r - y4r
                  x0i = y0i - y4i
                  a(j4) = wk4r * x0r - wk4i * x0i
                  a(j4 + 1) = wk4r * x0i + wk4i * x0r
                  x0r = y2r - y6i
                  x0i = y2i + y6r
                  a(j2) = wk2r * x0r - wk2i * x0i
                  a(j2 + 1) = wk2r * x0i + wk2i * x0r
                  x0r = y2r + y6i
                  x0i = y2i - y6r
                  a(j6) = wk6r * x0r - wk6i * x0i
                  a(j6 + 1) = wk6r * x0i + wk6i * x0r
              end do
          end do
      end if
      end
!
      subroutine rftfsub(n, a, nc, c)
      integer n, nc, j, k, kk, ks, m
      real*8 a(0 : n - 1), c(0 : nc - 1), wkr, wki, xr, xi, yr, yi
      m = n / 2
      ks = 2 * nc / m
      kk = 0
      do j = 2, m - 2, 2
          k = n - j
          kk = kk + ks
          wkr = 0.5d0 - c(nc - kk)
          wki = c(kk)
          xr = a(j) - a(k)
          xi = a(j + 1) + a(k + 1)
          yr = wkr * xr - wki * xi
          yi = wkr * xi + wki * xr
          a(j) = a(j) - yr
          a(j + 1) = a(j + 1) - yi
          a(k) = a(k) + yr
          a(k + 1) = a(k + 1) - yi
      end do
      end
!
      subroutine rftbsub(n, a, nc, c)
      integer n, nc, j, k, kk, ks, m
      real*8 a(0 : n - 1), c(0 : nc - 1), wkr, wki, xr, xi, yr, yi
      a(1) = -a(1)
      m = n / 2
      ks = 2 * nc / m
      kk = 0
      do j = 2, m - 2, 2
          k = n - j
          kk = kk + ks
          wkr = 0.5d0 - c(nc - kk)
          wki = c(kk)
          xr = a(j) - a(k)
          xi = a(j + 1) + a(k + 1)
          yr = wkr * xr + wki * xi
          yi = wkr * xi - wki * xr
          a(j) = a(j) - yr
          a(j + 1) = yi - a(j + 1)
          a(k) = a(k) + yr
          a(k + 1) = yi - a(k + 1)
      end do
      a(m + 1) = -a(m + 1)
      end
!
      subroutine dctsub(n, a, nc, c)
      integer n, nc, j, k, kk, ks, m
      real*8 a(0 : n - 1), c(0 : nc - 1), wkr, wki, xr
      m = n / 2
      ks = nc / n
      kk = 0
      do j = 1, m - 1
          k = n - j
          kk = kk + ks
          wkr = c(kk) - c(nc - kk)
          wki = c(kk) + c(nc - kk)
          xr = wki * a(j) - wkr * a(k)
          a(j) = wkr * a(j) + wki * a(k)
          a(k) = xr
      end do
      a(m) = c(0) * a(m)
      end
!
      subroutine dstsub(n, a, nc, c)
      integer n, nc, j, k, kk, ks, m
      real*8 a(0 : n - 1), c(0 : nc - 1), wkr, wki, xr
      m = n / 2
      ks = nc / n
      kk = 0
      do j = 1, m - 1
          k = n - j
          kk = kk + ks
          wkr = c(kk) - c(nc - kk)
          wki = c(kk) + c(nc - kk)
          xr = wki * a(k) - wkr * a(j)
          a(k) = wkr * a(k) + wki * a(j)
          a(j) = xr
      end do
      a(m) = c(0) * a(m)
      end
!


fl
hex

1 wconstant build_float
\
\
\ In this implementation -0 is not returned from or considerd by routines, 0 is,
\ -inf (FF80 0000)and +inf (7F80 0000) and nan (7FC0 0000) are specific values
\ caution if importing hex data from somewhere else
\
\ converting floats to integers, -7FFFFF80 - 7FFFFF80 is the range of integer values returned,
\ if values are greater or less they are returned as -80000000 or 7FFFFFFF, nan is returned as 0
\
\ unnormalized values are not dealt with, if the exponent is < 1 (x*2^-126) the value is considered to be 0
\
\ the dynamic range of the mantissa is 24 bits, so addition or subtraction of two numbers which differ
\ by more than 24 (0x18) in the exponent is a nop
\
\ Original ref for IEEE754 float notation
\
\ http://www.psc.edu/general/software/packages/ieee/ieee.php
\
\ The IEEE single precision floating point standard representation requires a 32 bit word, which may
\ be represented as numbered from 31 to 0, left to right. The first bit is the sign bit, S,
\ the next eight bits are the exponent bits, 'E', and the final  23 bits are the fraction 'F':
\
\  S  EEEEEEEE  FFFFFFFFFFFFFFFFFFFFFFF
\  31 30     23 22                    0
\
\ The value V represented by the word may be determined as follows:
\
\    * If E=255 and F is nonzero, then V=NaN ("Not a number")
\    * If E=255 and F is zero and S is 1, then V=-Infinity
\    * If E=255 and F is zero and S is 0, then V=Infinity
\    * If 0<E<255 then V=(-1)**S * 2 ** (E-127) * (1.F) where "1.F" is intended to represent the binary
\                          number created by prefixing F with an implicit leading 1 and a binary point.
\    * If E=0 and F is nonzero, then V=(-1)**S * 2 ** (-126) * (0.F) These are "unnormalized" values.
\    * If E=0 and F is zero and S is 1, then V=-0
\    * If E=0 and F is zero and S is 0, then V=0
\
\ In particular,
\
\  0 00000000 00000000000000000000000 = 0
\  1 00000000 00000000000000000000000 = -0
\
\  0 11111111 00000000000000000000000 = Infinity
\  1 11111111 00000000000000000000000 = -Infinity
\
\  0 11111111 00000100000000000000000 = NaN
\  1 11111111 00100010001001010101010 = NaN

\  0 10000000 00000000000000000000000 = +1 * 2**(128-127) * 1.0 = 2
\  0 10000001 10100000000000000000000 = +1 * 2**(129-127) * 1.101 = 6.5
\  1 10000001 10100000000000000000000 = -1 * 2**(129-127) * 1.101 = -6.5
\
\  0 00000001 00000000000000000000000 = +1 * 2**(1-127) * 1.0 = 2**(-126)
\  0 00000000 10000000000000000000000 = +1 * 2**(-126) * 0.1 = 2**(-127)
\  0 00000000 00000000000000000000001 = +1 * 2**(-126) *
\                                       0.00000000000000000000001 =
\                                       2**(-149)  (Smallest positive value)
\
h80000000 dup constant _Fsmask constant _Fmsb
h7F800000 dup constant _Femask constant +inf
h00800000 constant _Ffhibit
h007FFFFF constant _Ffmask
hFF800000 constant -inf
h7FC00000 constant nan
h7FFFFFFF constant maxInt
h80000000 constant minInt
h7F07FFFF constant max+Float
h00800000 constant min+Float
h3F800000 constant _fd1
h41200000 constant _fde1
h3DCCCCCD constant _fde-1
h447A0000 constant _fde3
h4B189680 constant _fde7
\
\ rashift ( n1 n2 -- n3) \ n3 = n1 shifted right arithmetically n2 bits
[ifndef rashift
: rashift _xasm2>1 h077 _cnip ;
]
\ rev ( n1 n2 -- n3 ) n3 is n1 with the lower 32-n2 bits reversed and the upper bite cleared
[ifndef rev
: rev
	_xasm2>1 h079 _cnip
;
]
\ cappendc ( c1 cstr -- ) append c1 the cstr
[ifndef cappendc
: cappendc
	dup C@ 1+ over C! dup C@ + C!
;
]
\
\
\ fabs ( f1 -- f2 ) f2 is the absolute value of f1
: fabs
	_Fsmask invert and
;
\
\ _Fhb ( u1 -- u1 u2 ) u2 is the most significant bit set in n1 - 20 is the most significant bit 1 is the lsb (0 - no bit set)
: _Fhb
	_Fmsb h20 0
	do
		2dup and
		if
			drop h20 i - leave
		else
			1 rshift
		then
	loop
;
\
\ _Fu>me ( u1 -- u2 u3 ) unsigned u1 is converted to mantissa and exponent,
\        u2 is the fraction with the leading 1 in bit 24 (mantissa) u3 is the exponent
: _Fu>me
	dup 0=
	if
		0
	else
		_Fhb h18 - swap over dup 0>
		if
			rshift
		else
			negate lshift
		then
		swap h96 +
	then
;
\
\ u>f ( u1 -- f1 ) convert unsigned u1 to float f1
: u>f
	_Fu>me h17 lshift swap _Ffmask and or
;
\
\ i>f ( n1 -- f1 ) convert interger n1 to float f1
: i>f
	dup 0<>
	if
		dup 0>
		if
			0
		else
			negate _Fsmask
		then
		swap u>f or
	then
;
\
maxInt i>f constant fmaxInt
minInt i>f constant fminInt
\
\ _Ff>m ( f1 -- f1 u1 ) u1 is the mantissa - the fraction with the hi bit set
: _Ff>m
	dup 0=
	if
		0
	else
		dup _Ffmask and _Ffhibit or
	then
;
\
\ _Ff>e ( f1 -- f1 u1 ) u1 exponent
: _Ff>e
	dup h17 rshift hFF and
;
\
\ _Ff>me ( f1 -- n2 n3 ) f1 is a float n2 is the mantissa, n3 is the exponent
: _Ff>me
	_Ff>m swap _Ff>e nip
;
\
\ _Ff>sm ( f1 -- f1 n2 ) f1 is a float n2 is the signed mantissa
: _Ff>sm
	_Ff>m over _Fsmask and
	if
		negate
	then
;
\
\ f> ( f1 f2 -- t/f )  true if f1 > f2
: f>
\ process the edge stuff
	dup -inf = if  -1 else
	dup +inf = if 0 else
	dup nan = if 0 else
	over -inf = if 0 else
	over +inf = if -1 else
	over nan = if 0 else
\ otherwise normal process
		dup _Fsmask and rot dup
		_Fsmask and rot 2dup xor
		if
			>
		else
			and 0=
			if
				swap
			then
			_Ff>me rot _Ff>me rot 2dup >
			if
				2drop -1
			else
				=
				if
					2dup swap >
				else
					0
	 thens
	 nip nip
;
\
\ f>i ( f1 -- n1 ) convert float f1 to int n1, +inf > 7FFFFFFF -inf > 80000000 nan > 0,
\ 7FFFFF80 is the largest int normally returned and -7FFFFF80 is the minimum int normally returned (rounding)
: f>i
\ process the standard edge stuff
	dup -inf = if drop minInt else
	dup +inf = if drop maxInt else
	dup nan = if drop 0 else
	_fd1 over fabs f> if drop 0 else
\ otherwise normal process
		dup _Fsmask and
			if
				fminInt over f>
				if
					drop 0
				then
			else
				dup fmaxInt >
				if
					drop fmaxInt
				then
			then
			dup _Ff>me h96 - dup 0>
			if
				lshift
			else
				negate rshift
			then
			swap _Fsmask and
			if
				negate
	thens
;
\
\ f+ ( f1 f2 -- f3) f3 is f1 + f2
: f+
\ process edge cases
	dup nan = if 2drop nan else
	over nan = if 2drop nan else
	dup -inf = if 2drop -inf else
	dup +inf = if 2drop +inf else
	over -inf = if 2drop -inf else
	over +inf = if 2drop +inf else
\ process cases where one number is a lot larger thus the addition is a nop
		_Ff>e rot _Ff>e rot 2dup -
		dup h17 >
		if
			3drop nip
		else
			dup h-17 <
			if
				3drop drop
			else
\ f2 f1 e1 e2 e1-e2
				dup 0<
				if
					negate swap >r nip
				else
					rot >r nip rot2 swap rot
				then
\
\  fx fy n1 - fx is the larger float, fy the smaller float, n1 the exponent  difference, top of rs is the larger exponent
\
				swap _Ff>sm nip swap rashift swap _Ff>sm nip +
\
\ n1 - the signed sum, e1 is on rs - the larger of the exponents
\
				dup 0=
				if
					r> drop
				else
\ 97 - r> 7F - + 80 +
					i>f _Ff>e h96 - r> +
					dup hFE >
					if
						drop _Fsmask and +inf or
					else
						dup 1 <
						if
							2drop 0
						else
							h17 lshift swap _Femask invert and or
	thens
;
\
\ f- ( f1 f2 -- f3 ) f3 is f1 - f2
: f-
	_Fmsb xor f+
;
\
\ _f1 ( f1 f2 -- (80000000 | 0) m2 e2 m1 e1 ) whether the result will be positive or negative, and unpack the floats
: _f1
	2dup xor _Fmsb and rot2 _Ff>me rot _Ff>me
;
\
\ f* ( f1 f2 -- f3 ) f3 is f1 *f2
: f*
\ process edge cases
	dup nan = if 2drop nan else
	over nan = if 2drop nan else
	dup -inf = if drop dup 0= if drop nan else _Fsmask and -inf xor then else
	dup +inf = if drop dup 0= if drop nan else _Fsmask and +inf xor then else
	over -inf = if nip dup 0= if drop nan else _Fsmask and -inf xor then else
	over +inf = if nip dup 0= if drop nan else _Fsmask and +inf xor then else
	dup 0= if 2drop 0 else
	over 0= if 2drop 0 else
\ process normal
		_f1 rot + h7F -
			dup hFE >
			if
				3drop _Fsmask and +inf or
			else
				dup 0<
				if
					2drop 2drop 0
				else
					>r um* h8 lshift swap h800000 + h18 rshift or
					dup 0=
					if
						r> 3drop 0
					else
						i>f _Ff>e h95 - r> + h17 lshift swap _Femask invert and or or
	thens
;
\
\ f/ ( f1 f2 -- f3 ) f3 is f1 / f2
: f/
\ process edge cases
	dup nan = if 2drop nan else
	over nan = if 2drop nan else
	2dup or 0= if 2drop nan else
	over 0= if drop else
	dup 0= if drop _Fsmask and +inf xor else
\ process normal
		_f1 rot - h7F +
		dup 1 < if 2drop 2drop 0 else
		>r h8 lshift over u/mod h10 lshift rot2
		h8 lshift over u/mod h8 lshift rot2
		h8 lshift over u/mod swap _Ffmask >
		if
			1
		else
			0
		then
		+ nip + + i>f
		_Ff>e h97 swap - r> swap  - h17 lshift swap _Femask invert and or or
	thens
;
\
\ loMask ( n1 -- n2 ) n2 is the mask of the lo bits up to the right of bit n2
: loMask
	-1 h20 rot dup 1 <
	if
		3drop 0
	else
		dup h20 >
		if
			3drop -1
		else
			- rev
	thens
;
\
: hiMask
	loMask invert
;
\
\ _Ff>int ( f1 -- f1 f2 ) f2 is the integer portion of f1
: _Ff>int
	_Ff>e h96 swap - dup h17 >
	if
		drop 0
	else
		hiMask over and
	then
;
\
\ _Ff>frac ( f1 -- f1 f2 ) f2 is the fractional portion of f1
: _Ff>frac
	_Ff>e h96 swap - dup h17 >
	if
		drop dup
	else
		2dup loMask 2dup and
		if
			and i>f _Ff>e rot -
			h17 lshift swap _Femask invert and or
		else
			3drop 0
		then
	then
;
\
\ _f>cstr ( f1 -- ) converts f1 to a counted string in t
: _f>cstr
\ process the standard edge stuff
	tbuf h12 h30 fill hB tbuf C!
	dup -inf = if drop c" -inf" tbuf ccopy else
	dup +inf = if drop c" +inf" tbuf ccopy  else
	dup nan = if drop c" nan" tbuf ccopy else
		base W@ decimal
		tbuf hB h30 fill
		1 tbuf C! swap dup _Fsmask and
		if
			h2D
		else
			h20
		then
		tbuf 1+ C!
		fabs _Ff>int f>i <# #s #> tbuf cappend h2E tbuf cappendc
		_Ff>frac nip fabs _fde7 f* f>i <# #s #>
		h7 over C@ - tbuf C@ + tbuf C!
		tbuf cappend
		base W!
	thens
;
\
\ f>cstr ( f1 -- caddr ) converts f1 to a counted string, caddr is the pointer to the counted string (16 digits + 1 space)
: f>cstr
	_f>cstr h10 tbuf C! h20 tbuf cappendc tbuf
;
\
\ f. ( f1 -- ) emits f1 followed by a space
: f.
	f>cstr .cstr
;
\
\ : f2/  dup nan <> if dup 0<> if dup +inf <> if dup -inf <> if
\ _Ff>e 1- dup 1 < if 2drop 0 else 17 lshift swap _Femask invert and or thens ;
\
\ : f2*  dup nan <> if dup 0<> if dup +inf <> if dup -inf <> if
\ _Ff>e 1+ dup FE > if drop _Fsmask and +inf or else 17 lshift swap _Femask invert and or thens ;
\
\ g>cstr ( f1 -- caddr ) converts f1 to a counted string in engineering notation,
\	caddr is the pointer to the counted string (16 digits + 1 space)
: g>cstr
	dup 0= over -inf = or over +inf = or over nan = or
	if
		f>cstr
	else
		0 swap dup fabs _fde3 f>
		if
			begin
				swap 3 + swap _fde3 f/ _fde3 over fabs f>
			until
		else
			_fd1 over fabs f>
			if
				begin
					swap 3 - swap _fde3 f* dup fabs _fd1 f>
				until
		then
	then
		_f>cstr hB tbuf C! h65 tbuf cappendc
		dup 0<
		if
			negate h2D
		else
			h2B
		then
			tbuf cappendc
			base W@ decimal swap <# # # # #> tbuf cappend base W!
			h20 tbuf cappendc tbuf
		then
;
\
\ g. ( f1 -- ) emits f1 in engineering notation followed by a space
: g.
	g>cstr .cstr
;
\
\ parseCstr ( cstr1 c1 -- cstr2 cstr3 ) parse the word delimited by c1, or the end of cstr1 is reached,
\ cstr2 is the remaining string or 0 cstr3 is the parsed word, the original cstr1 is modified if cstr2 is not 0
: parseCstr
	over 0 rot2 dup C@++ bounds
	do
		over i C@ =
		if
			rot drop dup rot2 i ibound over - 1-
			over C! over - 1- over C! C@++ +
			rot2
		then
	loop
	2drop swap
;
\
\ parseFloat ( cstr --  cstr1 cstr2 cstr3 ) cstr1 is the exponent, cstr2 in the fratcional part, cstr1 is the integer part
: parseFloat
	tbuf ccopy tbuf h2E parseCstr swap dup 0=
	if
		drop c" NO" dup
	else
		dup C@ 0=
		if
			drop c" 0" dup
		else
			h65 parseCstr swap dup 0=
			if
				drop c" 0"
			then
			dup C@ 0=
			if
				drop c" 0"
			then
			swap
		then

	then
	rot
;
\
\ isFloat ( cstr -- t/f )
: isFloat
	parseFloat C@++ isnumber rot C@++ isnumber rot C@++ isnumber and and
;
\
\ int>frac ( n1 -- f2 ) divide f1 by decimal 10 until it is a fraction
: int>frac
	dup 0< swap abs i>f
	begin
		_fd1 over f>
		if
			-1
		else
			_fde1  f/ 0
		then
	until
	swap
	if
		_Fsmask or
	then
;
\
\ cstr>float ( cstr -- f1 )
: cstr>float
	dup isFloat
	if
		parseFloat
		over >r
		C@++ number rot C@++ number rot C@++ number rot
		dup 0<
		if
			swap negate swap
		then
		i>f swap
		int>frac
		r>
		C@++ bounds
		do
			i C@ h30 <>
			if
				leave
			else
				_fde1 f/
			then
		loop
		f+
		swap dup 0=
		if
			drop
		else
			dup 0>
			if
				_fde1
			else
				_fde-1
			then
			swap abs _fd1 swap 0
			do
				over f*
			loop
			nip f*
		 then
	else
		drop nan
	then
;
\
h3FC90FD9 constant pi/2
h40490FDA constant pi
h4096CBE3 constant 3pi/2
h40C90FDA constant 2pi
\
\ scpi ( f1 -- f2 ) f1 radians, f2 is a radian value from -pi to pi
: scpi
	2pi f/ _Ff>frac 2pi f* swap _Fsmask and
	if
		_Fsmask or 2pi swap f+
	then
	dup pi f>
	if
		2pi swap f- _Fsmask or
	then
;
\
\ _flu ( n1 f1 f2 -- f3) n1 is the base address of a 2k word table, f1 is a value between 0.0 and 1.0
\ f2 is the interpolated float value from the table between 0.0 and 1.0
: _flu
	f* _Ff>int f>i swap _Ff>frac nip swap
\ sin table which is longer is ok with this no bug
	dup h7FE >
	if
		2drop hFFE + W@ i>f
	else
		2* rot + dup W@ swap 2+ W@ over - i>f rot f* swap i>f f+
	then
\ 65535.0 f/
	h477FFF00 f/
;
\
\ sin ( f1 -- f2 ) f1 in radians, f2 is the sin from -1.0 to +1.0
: sin
\ process the edge stuff
	dup +inf = -inf over = or over nan = or
	if
		drop nan
	else
\ normal processing
		scpi dup _Fsmask and swap fabs dup pi/2 f>
		if
			pi/2 f- pi/2 swap f-
		then
\ e000 swap pi/2 f/ 2049.0 _flu or then ;
		hE000 swap pi/2 f/ h45001000 _flu or
	then
;
\
\ cos ( f1 -- f2 ) f1 in radians, f2 is the cos from -1.0 to +1.0
: cos
	pi/2 f+ sin
;
\
\ tan ( f1 -- f2 ) f1 in radians, f2 is the tan from -1.0 to +1.0
: tan
	dup sin swap cos f/
;
\
\ : d>r 17.4532909e-003 f* ;
: d>r
	h3C8EFA34 f*
;
\ : r>d 57.2957878 f* ;
: r>d
	h42652EE3 f*
;
\
\ log2 ( f1 -- f2) f2 is the base2 log of f1
: log2
\ process the edge stuff
	dup _Fsmask and over 0= or
	if
		drop nan
	else
		dup +inf =
		if
			drop +inf
		else
\ normal processing
\ _Ff>me 7F - i>f C000 rot _Ffmask and i>f 0x00800000 f/ 2048.0_flu f+ thens ;
			_Ff>me
			h7F -
			i>f
			hC000 rot
			_Ffmask and
			i>f
			h4B000000 f/ h45000000
			_flu
			f+
	thens
;
\
\ exp2 ( f1 -- f2) f2 is 2 to the power of f1
: exp2
\ process the edge stuff
	dup -inf = over 0= or if drop _fd1 else
	dup nan = if drop nan else
	dup +inf = if drop +inf else
\ normal processing
		dup _Fsmask and swap fabs
\ _Ff>int f>i 1 swap lshift i>f D000 rot _Ff>frac nip 2048.0 _flu _fd1 f+ f* thens ;
		_Ff>int
		f>i
		1 swap lshift
		i>f
		hD000 rot
		_Ff>frac nip
		h45000000
		_flu
		_fd1 f+
		f*
		swap
		if
			_fd1 swap f/

	thens
;
\
\ log10 ( f1 -- f2) f2 is the base10 log of f1
\ : log10 log2 0.301029996 f* ;
: log10
	log2 h3E9A2098 f*
;
\
\ ln ( f1 -- f2) f2 is the base10 log of f1
\ : ln log2 0.693147181 f* ;
: ln
	log2 h3F317214 f*
;
\
\ exp10 ( f1 -- f2) f2 is 10 to the power of f1
\ : exp10 3.321928095 f* exp2 ;
: exp10
	h40549A77 f* exp2
;
\
\ exp ( f1 -- f2) f2 is e to the power of f1
\ : exp 1.442695041 f* exp2 ;
: exp
	h3FB8AA3A f* exp2
;
\
\ 123.8 123.8e9 123.8e-9 are valid floats
\
\ patch the adresses in interpretpad to call isfnumber and fnumber instead of isnumber and number
' fisnumber
: fisnumber over swap xisnumber if drop -1 else 1- isFloat then ;
' fisnumber swap W!
\
' fnumber
: fnumber over swap xisnumber if 1- C@++ xnumber else 1- cstr>float then ;
' fnumber swap W!
decimal
\

{

: t
	i>f
dup g.
	101325.0 f/
dup g.
	log2
dup g.
	5.255 f/
dup g.
	exp2
dup g.
	1.0 swap -
dup g.
	443300.0 f*
dup g. cr
;
}

{

fl
hex
forget build_floatTest
1 wconstant build_floatTest

: _T00 i>f swap i>f f+ f>i = ;
: _T0 >r 2dup 0 RS@ _T00 rot2 r> _T00 and and ;
: _T10 i>f f+ = ;
: _T1 >r 2dup 0 RS@ _T10 rot2 r> _T10 and and ;

: TEST_f+
-1
7FFFFF8 7FFFFFF 1 _T0
7FFFFF8 7FFFFFF 2 _T0
7FFFFF8 7FFFFFF 4 _T0
8000000 7FFFFFF 8 _T0
7FFFFF8 7FFFFFF -1 _T0
7FFFFF8 7FFFFFF -2 _T0
7FFFFF8 7FFFFFF -4 _T0
7FFFFF0 7FFFFFF -8 _T0
0 AAAAA -AAAAA _T0
1 1001 -1000 _T0
-1 1000 -1001 _T0
A 1234A -12340 _T0
nan nan 0 _T1
nan nan 10 _T1
nan nan -10 _T1
-inf -inf 0 _T1
-inf -inf 10 _T1
-inf -inf -10 _T1
+inf +inf 0 _T1
+inf +inf 10 _T1
+inf +inf -10 _T1
+inf 7F07FFFF 7F07FFFF f+ = and
+inf 7F07FFFF 7F040000 f+ = and
-inf FF07FFFF FF07FFFF f+ = and
-inf FF07FFFF FF400000 f+ = and
;

: TEST_Fu>me
0        _Fu>me 0= swap 0= and
1        _Fu>me 7F = swap 800000 = and and
2        _Fu>me 80 = swap 800000 = and and
4        _Fu>me 81 = swap 800000 = and and
8        _Fu>me 82 = swap 800000 = and and
A        _Fu>me 82 = swap A00000 = and and
00000064 _Fu>me 85 = swap C80000 = and and
000003E8 _Fu>me 88 = swap FA0000 = and and
00002710 _Fu>me 8C = swap 9C4000 = and and
000186A0 _Fu>me 8F = swap C35000 = and and
000F4240 _Fu>me 92 = swap F42400 = and and
00989680 _Fu>me 96 = swap 989680 = and and
05F5E100 _Fu>me 99 = swap BEBC20 = and and
3B9ACA00 _Fu>me 9C = swap EE6B28 = and and
FFFFFFFF _Fu>me 9E = swap FFFFFF = and and
80000000 _Fu>me 9E = swap 800000 = and and
40000000 _Fu>me 9D = swap 800000 = and and
01000000 _Fu>me 97 = swap 800000 = and and
00800000 _Fu>me 96 = swap 800000 = and and
00400000 _Fu>me 95 = swap 800000 = and and
00200000 _Fu>me 94 = swap 800000 = and and ;

: TEST_Fhb 0 _Fhb 0= nip
1 _Fhb 1 = nip and
2 _Fhb 2 = nip and
4 _Fhb 3 = nip and
7 _Fhb 3 = nip and
60000000 _Fhb 1f = nip and
80000000 _Fhb 20 = nip and ;

: TEST_FAILED 0 ;

: TEST_i>f
00000000 i>f  00000000 =
00000001 i>f  3F800000 = and
0000000A i>f  41200000 = and
00000064 i>f  42C80000 = and
000003E8 i>f  447A0000 = and
00002710 i>f  461C4000 = and
000186A0 i>f  47C35000 = and
000F4240 i>f  49742400 = and
00989680 i>f  4B189680 = and
05F5E100 i>f  4CBEBC20 = and
3B9ACA00 i>f  4E6E6B28 = and
FFFFFFFF i>f  BF800000 = and
FFFFFFF6 i>f  C1200000 = and
FFFFFF9C i>f  C2C80000 = and
FFFFFC18 i>f  C47A0000 = and
FFFFD8F0 i>f  C61C4000 = and
FFFE7960 i>f  C7C35000 = and
FFF0BDC0 i>f  C9742400 = and
FF676980 i>f  CB189680 = and
FA0A1F00 i>f  CCBEBC20 = and
C4653600 i>f  CE6E6B28 = and
;

: _T2 dup i>f _Ff>me rot _Fu>me rot = rot2 = and ;
: TEST_Ff>me
00000000 _T2
00000001 _T2 and
0000000A _T2 and
00000064 _T2 and
000003E8 _T2 and
00002710 _T2 and
000186A0 _T2 and
000F4240 _T2 and
00989680 _T2 and
00F5E100 _T2 and
00FFFFFF _T2 and
;

: TEST_f>
nan	0	f> 0=
0	nan	f> 0= and
+inf	0	f> and
-inf	0	f> 0= and
+inf	10 i>f	f> and
-inf	10 i>f	f> 0= and
10 i>f	-inf	f> and
10 i>f	+inf	f> 0= and
1 i>f	0	f> and
0 i>f	1 i>f	f> 0= and
-1 i>f	0 	f> 0= and
-1 i>f	-inf	f> and
-1 i>f	-2 i>f	f> and
10 i>f	-2 i>f	f> and
FFFFFF i>f FFFFFE i>f f> and
FFFFFE i>f FFFFFF i>f f> 0= and
FFFFFF i>f 0FFFFE i>f f> and
0FFFFE i>f FFFFFF i>f f> 0= and

-FFFFFF i>f -FFFFFE i>f f> 0= and
-FFFFFE i>f -FFFFFF i>f f> and
-FFFFFF i>f -0FFFFE i>f f> 0= and
-0FFFFE i>f -FFFFFF i>f f> and
;

: TEST_f>i
-inf		f>i	80000000	=
+inf		f>i	7fffffff	= and
nan		f>i	0		= and

1	 i>f	f>i	1		= and
-1	 i>f	f>i	-1		= and
A	 i>f	f>i	A		= and
-A	 i>f	f>i	-A		= and
DC56	 i>f	f>i	DC56		= and
-DC56	 i>f	f>i	-DC56		= and
007FFFFF i>f	f>i	007FFFFF	= and
-007FFFFF i>f	f>i	-007FFFFF	= and

7FFFFFFF i>f	f>i	7FFFFF80	= and
-7FFFFFFF i>f	f>i	-7FFFFF80	= and

;

: _T30 i>f swap i>f f* f>i = ;
: _T3 >r 2dup 0 RS@ _T30 rot2 r> _T30 and and ;
: _T40 i>f f* = ;
: _T4 >r 2dup 0 RS@ _T40 rot2 r> _T40 and and ;
: _T5 >r 2dup 0 RS@ f* = rot2 r> f* = and and ;

: TEST_f*
-1
0 0 0 _T4
nan +inf 0 _T5
nan -inf 0 _T5
+inf +inf +inf _T5
-inf -inf +inf _T5
+inf -inf -inf _T5

nan nan 10 _T4
nan nan 1 _T4
nan nan -10 _T4
nan nan -1 _T4
nan nan 0 _T5

+inf +inf 10 _T4
-inf -inf 10 _T4
+inf -inf -10 _T4
+inf -inf -10 _T4
6 2 3 _T3
-6 -2 3 _T3
4edc2 123 456 _T3
-4edc2 123 -456 _T3
64 A A _T3
3E8 64 A _T3
2710 64 64 _T3
F4240 3E8 3E8 _T3
5F5E100 2710 2710 _T3
;

: _T6 i>f swap i>f swap f/ f>i = and ;
: _T7 swap i>f swap f/ = and ;
: _T8 f/ = and ;

: TEST_f/
-1
nan 0 0 _T8
nan 0 nan _T8
nan nan 0 _T8

0 0 +inf _T8
0 0 -inf _T8
+inf 1 0 _T7
+inf 10 0 _T7
-inf -1 0 _T7
-inf -10 0 _T7

FF 7FFFFFFF 00800000 _T6
40 40000000 00FFFFFF _T6
1 i>f dup a i>f f/ a i>f f* = and
FF i>f 800000 i>f f/ 800000 i>f f* f>i FF = and
;

: RUNTEST dup find if execute swap .cstr if ."  PASSED" else ."  ********************FAILED" then
else .cstr ."  ********************NOT FOUND" drop then cr ;

: TEST c" TEST_Fhb" RUNTEST c" TEST_Fu>me" RUNTEST c" TEST_i>f" RUNTEST
c" TEST_Ff>me" RUNTEST c" TEST_f>" RUNTEST c" TEST_f>i" RUNTEST c" TEST_f+" RUNTEST
c" TEST_f*" RUNTEST c" TEST_f/" RUNTEST
c" TEST_FAILED" RUNTEST
c" TEST_NAN" RUNTEST ;

}


program main
    implicit none

    integer, allocatable :: seed(:)
    integer :: n
    integer :: i

    interface
        function Free_path(lambda)
            ! 变换抽样法产生粒子随机运动的自由程分布
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp), intent(in) :: lambda
            real(dp) :: Free_path
        end function Free_path

        function Scattering_azimuth_angle()
            ! 变换抽样法产生粒子输运问题中散射方位角余弦分布
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp) :: Scattering_azimuth_angle
        end function Scattering_azimuth_angle

        function Random_pt_on_sphere(rho_)
            ! 变换抽样法产生球面上均匀分布的随机坐标点的 (rho,theta,phi) 坐标
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp), intent(in), optional :: rho_
            real(dp) :: Random_pt_on_sphere(3) ! rho, theta, phi
        end function Random_pt_on_sphere
    end interface

    call random_seed(size=n)
    allocate(seed(n))
    seed = 1
    call random_seed(put=seed)
    do i = 1, 100
        write(*,*) Free_path(1.d0)
    end do

    do i = 1, 100
        write(*,*) Scattering_azimuth_angle()
    end do

    open(unit=11, file='1.2.1.2-Random-Points-on-Sphere.txt', status='replace')
    do i = 1, 1000
        write(11,'(3f16.8)') Random_pt_on_sphere()
    end do
    close(11)
end program main

function Free_path(lambda)
    ! 变换抽样法产生粒子随机运动的自由程分布
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    real(dp), intent(in) :: lambda
    real(dp) :: Free_path

    real :: xi

    call random_number(xi)
    Free_path = -lambda * log(xi)
end function Free_path

function Scattering_azimuth_angle()
    ! 变换抽样法产生粒子输运问题中散射方位角余弦分布
    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: pi = acos(-1.d0)

    real(dp) :: Scattering_azimuth_angle

    real(dp) :: xi

    call random_number(xi)
    Scattering_azimuth_angle = sin(2 * pi * xi)
end function Scattering_azimuth_angle

function Random_pt_on_sphere(rho_)
    ! 变换抽样法产生球面上均匀分布的随机坐标点的 (rho,theta,phi) 坐标
    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter ::pi = acos(-1.d0)

    real(dp), intent(in), optional :: rho_
    real(dp) :: Random_pt_on_sphere(3) ! (rho, theta, phi)

    real(dp) :: xi

    if (present(rho_)) then
        Random_pt_on_sphere(1) = rho_
    else
        Random_pt_on_sphere(1) = 1.d0
    end if

    call random_number(xi)
    Random_pt_on_sphere(2) = acos(2.d0 * xi - 1.d0)
    call random_number(xi)
    Random_pt_on_sphere(3) = 2 * pi * xi
end function Random_pt_on_sphere


! MIT License
!
! Copyright (c) 2017 Anders Steen Christensen, Bing Huang
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

module utils

    implicit none

contains

function linspace(x0, x1, nx) result(xs)

    implicit none

    double precision, intent(in) :: x0
    double precision, intent(in) :: x1
    integer, intent(in) :: nx

    double precision, dimension(nx) :: xs

    integer :: i
    double precision :: step

    step = (x1 - x0) / (nx - 1)

    !$OMP PARALLEL DO
    do i = 1, nx
        xs(i) = x0 + (i - 1) * step
    enddo
    !$OMP END PARALLEL DO

end function linspace

function calc_angle(a, b, c) result(angle)

    implicit none

    double precision, intent(in), dimension(3) :: a
    double precision, intent(in), dimension(3) :: b
    double precision, intent(in), dimension(3) :: c

    double precision, dimension(3) :: v1
    double precision, dimension(3) :: v2

    double precision :: cos_angle
    double precision :: angle

    v1 = a - b
    v2 = c - b

    v1 = v1 / norm2(v1)
    v2 = v2 / norm2(v2)

    cos_angle = dot_product(v1,v2)

    ! Clipping
    if (cos_angle > 1.0d0) cos_angle = 1.0d0
    if (cos_angle < -1.0d0) cos_angle = -1.0d0

    angle = acos(cos_angle)

end function calc_angle

function calc_cos_angle(a, b, c) result(cos_angle)

    implicit none

    double precision, intent(in), dimension(3) :: a
    double precision, intent(in), dimension(3) :: b
    double precision, intent(in), dimension(3) :: c

    double precision, dimension(3) :: v1
    double precision, dimension(3) :: v2

    double precision :: cos_angle

    v1 = a - b
    v2 = c - b

    v1 = v1 / norm2(v1)
    v2 = v2 / norm2(v2)

    cos_angle = dot_product(v1,v2)

end function calc_cos_angle

end module utils


!>  Partitioning a graph with non-equal number of edges per node.
!
program test_PartGraphRecursive2

    use metis_interface, only: idx_t, METIS_PartGraphRecursive, METIS_SetDefaultOptions, &
        METIS_NOPTIONS, METIS_OPTION_NUMBERING, METIS_OK

    integer(idx_t) :: n, m
    integer(idx_t), allocatable :: xadj(:), adjncy(:), part(:)
    integer(idx_t) :: options(0:METIS_NOPTIONS-1), ios, ncon, objval, nparts

    write(*,'(A)') "TEST METIS_PartGraphRecursive 2"

    !   1---5
    !   |\ / \
    !   | 3   6
    !   |/ \ / \
    !   2---4---7

    xadj = [1,4,7,11,15,18,21,23]
    adjncy = [5,3,2,1,3,4,5,4,2,1,2,3,6,7,1,3,6,5,4,7,6,4]

    n = size(xadj) - 1
    m = size(adjncy)/2
    write(*,'(A,I0)') "n = ", n
    write(*,'(A,I0)') "m = ", m

    ios = METIS_SetDefaultOptions(options)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_SetDefaultOptions failed with error: ", ios
        error stop 1
    end if
    options(METIS_OPTION_NUMBERING) = 1     ! Fortran-style numbering

    ncon = 1
    nparts = 2
    allocate(part(n))
    ios = METIS_PartGraphRecursive(n,ncon,xadj,adjncy,&
                nparts=nparts,objval=objval,part=part,options=options)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_PartGraphKway failed with error: ", ios
        error stop 1
    end if

    write(*,'(A,I0)') "objval = ", objval
    write(*,'(A,*(I1,:,1X))') "part = ", part

end program


c     program DRSBLAS3
c>> 2001-05-22 DRSBLAS3 Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRSBLAS3 Krogh Added external statement.
c>> 1994-10-19 DRSBLAS3 Krogh  Changes to use M77CON
c>> 1992-03-16 DRSBLAS3 CLL
c>> 1991-07-25 DRSBLAS3 CLL
c
c     Demonstrate usage of
c     SASUM, SNRM2, SSCAL, SSWAP, and ISAMAX
c     from the BLAS.
c     Also uses SAXPY.
c     ------------------------------------------------------------------
c--S replaces "?": DR?BLAS3, ?AXPY, ?ASUM, ?NRM2
c--&                 ?SCAL, ?SWAP, I?AMAX
c     ------------------------------------------------------------------
      external SASUM, SNRM2, ISAMAX
      real             SASUM, SNRM2
      integer ISAMAX
      integer M3, M4, N3, N4
      parameter ( M3=10, M4=12 )
      parameter ( N3=3, N4=4 )
      integer IT1, J
      real             E(M3,M4)
      real             B(M3), C(5), C2(5), C3(5), D(5), D2(5), D3(5)
      real             T1
c
      data (B(J),J=1,N3)   /  7.0e0, -3.0e0, 5.0e0 /
      data (C(J),J=1,5)   /  7.0e0, -3.0e0,  5.0e0, -4.0e0, 1.0e0 /
      data (C2(J),J=1,5)   /  7.0e0, -3.0e0,  5.0e0, -4.0e0, 1.0e0 /
      data (C3(J),J=1,5)   /  7.0e0, -3.0e0,  5.0e0, -4.0e0, 1.0e0 /
      data (D(J),J=1,5)   / 14.0e0, -6.0e0, 10.0e0, -8.0e0, 2.0e0 /
      data (D2(J),J=1,5)   / 14.0e0, -6.0e0, 10.0e0, -8.0e0, 2.0e0 /
      data (D3(J),J=1,5)   / 14.0e0, -6.0e0, 10.0e0, -8.0e0, 2.0e0 /

      data (E(1,J),J=1,N4) / -4.0e0, 2.0e0,  3.0e0, -6.0e0 /
      data (E(2,J),J=1,N4) /  7.0e0, 5.0e0, -6.0e0, -3.0e0 /
      data (E(3,J),J=1,N4) /  3.0e0, 4.0e0, -2.0e0,  5.0e0 /

c     ---------------------------------------------------------------
c
      T1 = SASUM(N3, B, 1) - 15.0e0
      print*,'Test of SASUM(): ',T1
c
      T1 = SNRM2(5, C, 1) - 10.0e0
      print*,'Test of SNRM2(): ',T1
c
      call SSCAL(5, 2.0e0, C2, 1)
      call SAXPY(5, -1.0e0, C2, 1, D2, 1)
      T1 = SASUM(5, D2, 1)
      print*,'Test of SSCAL(): ',T1
c
      call SSWAP(5, C3, 1, D3, 1)
      call SAXPY(5, -1.0e0, C, 1, D3, 1)
      call SAXPY(5, -1.0e0, D, 1, C3, 1)
      T1 = SASUM(5, C3, 1) + SASUM(5, D3, 1)
      print*,'Test of SSWAP(): ',T1
c
      IT1 = ISAMAX(N4, E(1,1), M3) - 4
      print*,'Test of ISAMAX(): ',IT1
      stop
      end


program problem_9

    use aoc_utilities
    use iso_fortran_env, only: ip => int64

    implicit none

    integer :: iunit, i, j, k, n, n_lines
    character(len=:),allocatable :: line
    logical :: status_ok
    integer :: risk
    integer,dimension(:,:),allocatable :: ivec
    logical,dimension(:,:),allocatable :: mask
    integer,dimension(:),allocatable :: low_i
    integer,dimension(:),allocatable :: low_j
    integer(ip),dimension(:),allocatable :: basin_size
    integer,dimension(3) :: largest
    integer,dimension(1) :: iloc

    open(newunit=iunit,file='inputs/day9.txt')
    n_lines = number_of_lines_in_file(iunit)

    ! create the array of integers:
    do i = 1, n_lines
        call read_line_from_file(iunit,line,status_ok)
        if (.not. allocated(ivec)) then
            allocate(ivec(0:n_lines+1,0:len(line)+1))
            allocate(mask(0:n_lines+1,0:len(line)+1))
            ivec = huge(1) ! trick for the edges
        end if
        do j = 1, len(line)
            read(line(j:j),'(I1)') ivec(i,j)
        end do
    end do

    risk = 0
    allocate(low_i(0)); allocate(low_j(0))
    do i = 1 , ubound(ivec,1)-1
        do j = 1, ubound(ivec,2)-1
            if (all(ivec(i,j)<[ ivec(i-1,j),&
                                ivec(i+1,j),&
                                ivec(i,j-1),&
                                ivec(i,j+1) ])) then
                risk = risk + ivec(i,j) + 1
                low_i = [low_i, i]; low_j = [low_j, j]
                !write(*,*) 'low point: ', i, j, ivec(i,j)
            end if
        end do
    end do

    write(*,*) '9a : risk level = ', risk

    !***********************************************************************
    allocate(basin_size(size(low_i)))
    basin_size = 0
    do i = 1, size(low_i)
        mask = .false. ! initialize to false, will be true if part of the basin
        call count_basin_size(low_i(i), low_j(i), mask)
        basin_size(i) = count(mask)
    end do
    !write(*,*) 'basin sizes: ', basin_size

    ! find the 3 largest:
    do j = 1, 3
        iloc = maxloc(basin_size)
        largest(j) = basin_size(iloc(1))
        basin_size(iloc(1)) = 0
    end do
    !write(*,*) 'largest: ', largest

    write(*,*) '9b : product of 3 largest basin sizes = ', product(largest)

    contains

    recursive subroutine count_basin_size(i,j,mask)
    implicit none
    integer,intent(in) :: i,j
    logical,dimension(0:,0:),intent(inout) :: mask

    if (ivec(i,j)<9) then
        mask(i,j) = .true.
        if (.not. mask(i+1,j)) call count_basin_size(i+1,j,mask)
        if (.not. mask(i-1,j)) call count_basin_size(i-1,j,mask)
        if (.not. mask(i,j+1)) call count_basin_size(i,j+1,mask)
        if (.not. mask(i,j-1)) call count_basin_size(i,j-1,mask)
    end if

    end subroutine count_basin_size

    end program problem_9


!*==icamax.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b ICAMAX
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       INTEGER FUNCTION ICAMAX(N,CX,INCX)
!
!       .. Scalar Arguments ..
!       INTEGER INCX,N
!       ..
!       .. Array Arguments ..
!       COMPLEX CX(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>    ICAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)|
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] CX
!> \verbatim
!>          CX is COMPLEX array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>         storage spacing between elements of CX
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup aux_blas
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>     jack dongarra, linpack, 3/11/78.
!>     modified 3/93 to return if incx .le. 0.
!>     modified 12/3/93, array(1) declarations changed to array(*)
!> \endverbatim
!>
!  =====================================================================
      INTEGER FUNCTION ICAMAX(N,Cx,Incx)
      IMPLICIT NONE
!*--ICAMAX75
!
!  -- Reference BLAS level1 routine (version 3.8.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      INTEGER Incx , N
!     ..
!     .. Array Arguments ..
      COMPLEX Cx(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      REAL smax
      INTEGER i , ix
!     ..
!     .. External Functions ..
      REAL SCABS1
      EXTERNAL SCABS1
!     ..
      ICAMAX = 0
      IF ( N<1 .OR. Incx<=0 ) RETURN
      ICAMAX = 1
      IF ( N==1 ) RETURN
      IF ( Incx==1 ) THEN
!
!        code for increment equal to 1
!
         smax = SCABS1(Cx(1))
         DO i = 2 , N
            IF ( SCABS1(Cx(i))>smax ) THEN
               ICAMAX = i
               smax = SCABS1(Cx(i))
            ENDIF
         ENDDO
      ELSE
!
!        code for increment not equal to 1
!
         ix = 1
         smax = SCABS1(Cx(1))
         ix = ix + Incx
         DO i = 2 , N
            IF ( SCABS1(Cx(ix))>smax ) THEN
               ICAMAX = i
               smax = SCABS1(Cx(ix))
            ENDIF
            ix = ix + Incx
         ENDDO
      ENDIF
      END FUNCTION ICAMAX


c============================================== test.f
                real x, y
		real*8 x1, y1
		x=0.
		y = erfc(x)
		if (y .ne. 1.) call abort

		x=1.1
		y = erfc(x)
		if (abs(y - .1197949) .ge. 1.e-6) call abort

* modified from x=10, y .gt. 1.5e-44 to avoid lack of -mieee on Alphas.
		x=8
		y = erfc(x)
		if (y .gt. 1.2e-28) call abort

		x1=0.
		y1 = erfc(x1)
		if (y1 .ne. 1.) call abort

		x1=1.1d0
		y1 = erfc(x1)
		if (abs(y1 - .1197949d0) .ge. 1.d-6) call abort

		x1=10
		y1 = erfc(x1)
		if (y1 .gt. 1.5d-44) call abort
		end
c=================================================
!output:
!  0.  1.875
!  1.10000002  1.48958981
!  10.  5.00220949E-06
!
!The values should be:
!erfc(0)=1
!erfc(1.1)= 0.1197949
!erfc(10)<1.543115467311259E-044


module save_mod
implicit none
contains
function circle_area(radius) result(area)
real, intent(in) :: radius
real             :: area
real             :: pi = 3.14159
! real, parameter :: pi = 3.14159 ! better to write this
area = pi*radius**2
end function circle_area
!
function bad_factorial(n) result(nfac)
integer, intent(in) :: n
integer             :: nfac
integer             :: j
integer             :: i = 1 ! has same effect as line below
! integer, save       :: i = 1
do j=2,n
   i = i*j
end do
nfac = i
end function bad_factorial
!
function factorial(n) result(nfac)
integer, intent(in) :: n
integer             :: nfac
integer             :: i,j
i = 1
do j=2,n
   i = i*j
end do
nfac = i
end function factorial
end module save_mod
!
program test_save
use save_mod, only: factorial, bad_factorial
implicit none
print*,bad_factorial(3),bad_factorial(3) ! 6 36
print*,factorial(3),factorial(3) ! 6 6
end program test_save


! An illustration of simple Fortran functions

program main

    implicit none
    write (*,*) collatz(9)
    write (*,*) collatz(10)

contains

    integer function collatz (n)
        implicit none
        integer, intent(in) :: n
        if (mod(n, 2) == 0) then
            collatz = 3 * n + 1
        else
            collatz = 4 * n - 3
        end if
    end function collatz

end program main


MODULE linalg_mod
use mpi
! use EFIE_functions

CONTAINS

!======================================================================================!
subroutine cond(RCOND,A,N,NORM)
!! Here we assume that M>=N
	implicit none
	real(8) :: RCOND,ANORM
	integer,intent(in)  :: N
	character(1),intent(in)::NORM
	complex(8) :: A(N,N)
	complex(8) :: W(N)
	complex(8) :: VL(1,N),VR(1,N),WORK(2*N)
	real(8)    :: RWORK(2*N)
	integer :: LWORK,LDA,LDVL,LDVR,INFO
	!----------------------------------------------------------!
	LWORK = 2*N
	LDA = N
	LDVL = 1
	LDVR = 1
	if (NORM=='I') then
		ANORM = maxval(sum(abs(A),1))
	elseif (NORM=='O') then
		ANORM = maxval(sum(abs(A),2))
	endif
	call ZGECON(NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK,INFO )
	RCOND = 1.0d0/RCOND
return
end subroutine cond
!======================================================================================!
subroutine eig(W,A,N)
!! Here we assume that M>=N
	implicit none
	integer,intent(in)  :: N
	complex(8),intent(in) :: A(N,N)
	complex(8) :: B(N,N)
	complex(8) :: W(N)
	complex(8) :: VL(1,N),VR(1,N),WORK(2*N)
	real(8)    :: RWORK(2*N)
	integer :: LWORK,LDA,LDVL,LDVR,INFO
	!----------------------------------------------------------!
	LWORK = 2*N
	LDA = N
	LDVL = 1
	LDVR = 1
	B = A
	call ZGEEV('N', 'N', N, B, LDA, W, VL, LDVL, VR, LDVR, WORK,LWORK,RWORK,INFO)

	! call zgeev('N','N', N, A, LDA, W, VL, LDVL, VR, LDVR,
	!      $                  WORK, LWORK, RWORK, INFO )
	return
end subroutine eig

!======================================================================================!
subroutine qr(A,Q,M,N)
!! Here we assume that M>=N
! This subroutine computes the matrix Q of the QR factorization
	implicit none
   integer, intent(in)     :: N,M
   complex(8),intent(in)  :: A(M,N)
   complex(8),intent(out) :: Q(M,M)

	real(8)   :: rwork(2*N)
   integer :: lwork
   integer  :: info,jpvt(N),i,j,k,l
	complex(8) :: tau(N), work(2*N),v(M),u
	!----------------------------------------------------------!

	jpvt = 0
	lwork = 2*N
	call ZGEQP3( M, N, A, M, JPVT, TAU, WORK, LWORK,RWORK, INFO )

	Q = (0.0d0,0.0d0)

	do i=1,M
		Q(i,i) = (1.0d0,0.0d0)
	enddo
	do l=1,N
		if (l==1) then
			v(l)     = (1.0d0,0.0d0)
		else
			v(1:l-1) = (0.0d0,0.0d0)
			v(l)     = (1.0d0,0.0d0)
		endif
		v(l+1:m) = A(l+1:m,l)
		do i=1,M
			u = (0.0d0,0.0d0)
			do j=l,M
				u=u+Q(i,j)*v(j)
			enddo

			do j=l,M
				Q(i,j) = Q(i,j) - tau(l)*u*conjg(v(j))
			enddo
		enddo
	enddo

	return
end subroutine qr
!===================================================================================!

subroutine svd(A,U,S,VT,N)

	implicit none
   integer, intent(in)     :: N
   complex(8),intent(in)  :: A(N,N)
   complex(8),intent(out) :: VT(N,N),U(N,N)
   real(8),intent(out)    :: S(N)

   complex(8),allocatable :: work(:)
	real(8),allocatable    :: rwork(:)
   integer :: lwork
   integer  :: info

!----------------------------------------------------------------------------------!
	lwork = 3*N

	allocate(work(1:lwork))
	allocate(rwork(1:5*N))

	call ZGESVD('A','A',N,N,A,N,S,U,N,VT,N,WORK,lwork,RWORK,INFO)

   deallocate(work,rwork)

	return

end subroutine svd

!==============================================================================!

function matvec(Mat,x,N,M) result(y)
	implicit none
   integer :: N,M
   complex(8) :: Mat(N,M)
   complex(8) :: x(M)
   complex(8) :: y(N)
	integer :: i,j

   do i=1,N
		y(i) = (0.0d0,0.0d0)
   	do j=1,M
   		y(i) = y(i)+Mat(i,j)*x(j)
   	enddo
   enddo
   return
end function matvec
!==============================================================================!

subroutine  linsolve(mu,M,F,dm)
	implicit none
   integer,intent(in) :: dm
   complex(8),intent(in) :: M(dm,dm),F(dm)
   complex(8),allocatable,intent(out) :: mu(:)
   complex(8) :: M0(dm,dm)
   integer :: ipiv(dm),info
!-------------------------------------------------------------------------------------!
   allocate(mu(1:dm))
 	M0=M
 	mu = F
   call ZGESV(dm, 1, M0, dm, IPIV, mu, dm, INFO )

   return
end subroutine linsolve
!=====================================================================================!

subroutine  inv(Minv,M,dm)

   ! Computes the inverse of the matrix M of dimensions dm x dm

   implicit none

   integer,intent(in) :: dm

   complex(8),intent(in) :: M(dm,dm)

   complex(8) :: Minv(dm,dm),M0(dm,dm)

   integer :: ipiv(dm),info,j

   !--------------------------------------------------------

   M0 = M

   Minv = 0.0d0

	 do j=1,dm

		 Minv(j,j) = 1.0d0

	 end do

 call zgesv(dm, dm, M0, dm, IPIV, Minv, dm, INFO )

 return

end subroutine inv
!=====================================================================================!
subroutine diagPrecond(A,b)
	implicit none
	complex(8), intent(inout):: A(:,:),b(:)
	complex(8):: d
	integer :: N,i,j(1)

	N = size(b)
	do i=1,N
		d = A(i,i)
		! j = maxloc(abs(A(i,:)))
		! d = A(i,j(1))
		A(i,:) = A(i,:)/d
		b(i) = b(i)/d
	enddo

	return

end subroutine diagPrecond

!=====================================================================================!
subroutine gmres_solver(x,A,b,GMRES_tol,MAX_ITER)

    ! B: is the optional preconditioner

    implicit none

    complex(8),intent(in) :: A(:,:),b(:)

    complex(8),intent(out) :: x(:)

    integer,optional :: MAX_ITER

    real(8),optional :: GMRES_tol

		real(8) :: tol
		integer :: m_iter

    !gmres variables
    integer                 :: lda,ldstrt,lwork

    integer                 :: revcom, colx, coly, colz, nbscal

    integer                 :: irc(5), icntl(8), info(3)

    integer,parameter       :: matvec=1, precondleft=2, precondright=3, dotprod=4

    integer                 :: nout,n,counter

    complex(8),allocatable  :: work(:)

    complex(8),parameter    :: one  = (1.0d0,0.0d0)

    complex(8),parameter    :: zero = (0.0d0,0.0d0)

    real(8)                 :: cntl(5), rinfo(2)

    real(4)::time_gmres_begin,time_gmres_end

    integer :: vecSize

    !------------------------------------------------------------------------------!

    !  solving linear system

    !------------------------------------------------------------------------------!

		if (present(GMRES_tol)) then
			tol = GMRES_tol
    else
      tol = 1.0d-6
    endif

    if (present(MAX_ITER)) then
      m_iter = MAX_ITER
		else
			m_iter =100
    endif

    vecSize = size(b)

    lda     = vecSize
    ldstrt  = vecSize/10
    lwork   = ldstrt**2 + ldstrt*(lda+5) + 5*lda + 1

    allocate(work(1:lwork))

    call cpu_time(time_gmres_begin)

    call init_zgmres(icntl,cntl)
    ! Save the convergence history on standard output
    icntl(3) = 1!40

    ! preconditioner location
    icntl(4) = 0

    ! orthogonalization scheme
    icntl(5) = 0

    ! initial guess

    icntl(6) = 0

    ! Maximum number of iterations
    icntl(7) = m_iter

    ! residual calculation strategy at restart
    icntl(8) = 0

    ! initial guess
    work(1:vecSize) = zero!one!densIn%vec!one

    ! right hand side

    cntl(1) = tol !1.0e-10

    work((vecSize+1):(2*vecSize))= b

    !------------------------------------------------------------------------------!

    !  reverse communication implementation

    !------------------------------------------------------------------------------!
10  continue

    call drive_zgmres(vecSize,vecSize,ldstrt,lwork,work, &
        irc,icntl,cntl,info,rinfo)

    revcom = irc(1)
    colx   = irc(2)
    coly   = irc(3)
    colz   = irc(4)
    nbscal = irc(5)

    if (revcom.eq.matvec) then

      x = work(colx:(colx-1+vecSize))

    endif

    if (revcom.eq.matvec) then

      ! x = matmul(A,x)

      work(colz:(colz-1+vecSize)) = matmul(A,x)

      goto 10

    elseif (revcom.eq.dotprod) then

      call zgemv('c',vecSize,nbscal,one,work(colx),vecSize, &
           work(coly),1,zero,work(colz),1)

      goto 10

    endif

    call cpu_time(time_gmres_end)

    time_gmres_end = time_gmres_end-time_gmres_begin

    write(*,*)'   GMRES convergence time: ',time_gmres_end,'seconds.'

    x = work(1:vecSize)

    return

  end subroutine gmres_solver

!*****************************************************************************

!   subroutine gmres_solver_MPI(x,A,b,GMRES_tol,MAX_ITER)
! !
!     implicit none
!
!     complex(8),intent(in) :: A(:,:),b(:)
!
!     complex(8),intent(out) :: x(:)
!
!     real(8),optional :: GMRES_tol
!
!     integer,optional :: MAX_ITER
!
! 		real(8) :: tol
! 		integer :: m_iter
!
!     !gmres variables
!     integer                 :: lda,ldstrt,lwork
!
!     integer                 :: revcom, colx, coly, colz, nbscal
!
!     integer                 :: irc(5), icntl(8), info(3)
!
!     integer,parameter       :: matvec=1, precondleft=2, precondright=3, dotprod=4
!
!     integer                 :: nout,n,counter
!
!     complex(8),allocatable  :: work(:)
!
!     complex(8),parameter    :: one  = (1.0d0,0.0d0)
!
!     complex(8),parameter    :: zero = (0.0d0,0.0d0)
!
!     real(8)                 :: cntl(5), rinfo(2)
!
!     real(4)::time_gmres_begin,time_gmres_end
!
!     integer :: vecSize
!
!     integer :: id, ierr , N_procs ,j ,status(MPI_STATUS_SIZE)
!
!     !------------------------------------------------------------------------------!
!
!     !  solving linear system
!
!     !------------------------------------------------------------------------------!
!     call mpi_comm_size(MPI_COMM_WORLD,N_procs,ierr)
!
!     call mpi_comm_rank(MPI_COMM_WORLD,id,ierr)
!
!
! 		if (present(GMRES_tol)) then
! 			tol = GMRES_tol
!     else
!       tol = 1.0d-6
!     endif
!
!     if (present(MAX_ITER)) then
!       m_iter = MAX_ITER
! 		else
! 			m_iter =100
!     endif
!
!     vecSize = size(b)
!
!     lda     = vecSize
!     ldstrt  = vecSize/10
!     lwork   = ldstrt**2 + ldstrt*(lda+5) + 5*lda + 1
! !
!     allocate(work(1:lwork))
!
!     if (id==0) then
!
!        call cpu_time(time_gmres_begin)
!
!        call init_zgmres(icntl,cntl)
!        ! Save the convergence history on standard output
!        icntl(3) = 1!40
!
!        ! preconditioner location
!        icntl(4) = 0
!
!        ! orthogonalization scheme
!        icntl(5) = 0
!
!        ! initial guess
!
!        icntl(6) = 0
!
!        ! Maximum number of iterations
!        icntl(7) = m_iter
!
!        ! residual calculation strategy at restart
!        icntl(8) = 0
!
!
!        ! initial guess
!        work(1:vecSize) = zero!one!densIn%vec!one
!
!        ! right hand side
!
!        cntl(1) = tol !1.0e-10
!
!        work((vecSize+1):(2*vecSize))= b
!
!     endif
!
!     !------------------------------------------------------------------------------!
!
!     !  reverse communication implementation
!
!     !------------------------------------------------------------------------------!
!   10  continue
!
!     if (id==0) then
!
!        call drive_zgmres(vecSize,vecSize,ldstrt,lwork,work, &
!             irc,icntl,cntl,info,rinfo)
!
!        revcom = irc(1)
!        colx   = irc(2)
!        coly   = irc(3)
!        colz   = irc(4)
!        nbscal = irc(5)
!
!        if (revcom.eq.matvec) then
!
!           x = work(colx:(colx-1+vecSize))
!
!        endif
!
!        do j=1,n_procs-1
!
!           call mpi_send(revcom,1,MPI_INTEGER,j,j,MPI_COMM_WORLD,ierr)
!
!           if (revcom.eq.matvec) then
!
!              call mpi_send(x,vecSize,&
!                   MPI_double_complex,j,j,MPI_COMM_WORLD,ierr)
!
!           endif
!
!        enddo
!
!     else
!
!        call mpi_recv(revcom,1,MPI_INTEGER,0,MPI_ANY_TAG,MPI_COMM_WORLD,status,ierr)
!
!        if (revcom.eq.matvec) then
!
!           call mpi_recv(x,vecSize,&
!                MPI_double_complex,0,MPI_ANY_TAG,MPI_COMM_WORLD,status,ierr)
!
!        endif
!
!     endif
!
!
!     if (revcom.eq.matvec) then
!
!        x =  matmul_MPI(A,x)
!
!        if (id==0) then
!
!           work(colz:(colz-1+vecSize)) = x
!
!        endif
!
!        goto 10
!
!     elseif (revcom.eq.dotprod) then
!
!        if (id==0) then
!
!           call zgemv('c',vecSize,nbscal,one,work(colx),vecSize, &
!                work(coly),1,zero,work(colz),1)
!
!        end if
!
!        goto 10
!
!     endif
!
!     if (id==0) then
!
!        call cpu_time(time_gmres_end)
!
!        time_gmres_end = time_gmres_end-time_gmres_begin
!
!        write(*,*)'   GMRES convergence time: ',time_gmres_end,'seconds.'
!
!        x = work(1:vecSize)
!
!     end if
!
!    call mpi_Bcast(x,vecSize,MPI_double_complex,0,MPI_COMM_WORLD,ierr)
!
!     return
!
!   end subroutine gmres_solver_MPI
!
! !-------------------------------------------------------------------------------
! function matmul_MPI(A,b) result(x)
!   implicit none
!   complex(8) :: A(:,:),b(:)
!   complex(8) :: x(size(b))
!   complex(8),allocatable :: xbff(:)
!   integer :: N,start,finish,ierr,l
!   !---------------------------------
!   N = size(b)
!   allocate(xbff(N))
!
!   call divide_work(start,finish,N)
!
!   do l=start,finish
!
!     xbff(l) = sum(A(l,:)*b)
!
!   enddo
!
!   call mpi_Allreduce(xbff,x,N, &
!   MPI_double_complex,MPI_sum,MPI_comm_world,ierr)
!
!
! end function matmul_MPI

end module linalg_mod