#pragma -xO
      program tstfft
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c                       version 4  april 1985
c
c                         a test driver for
c          a package of fortran subprograms for the fast fourier
c           transform of periodic and other symmetric sequences
c
c                              by
c
c                       paul n swarztrauber
c
c       national center for atmospheric research  boulder,colorado 80307
c
c        which is sponsored by the national science foundation
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c             this program tests the package of fast fourier
c     transforms for both complex and real periodic sequences and
c     certian other symmetric sequences that are listed below.
c
c     1.   rffti     initialize  rfftf and rfftb
c     2.   rfftf     forward transform of a real periodic sequence
c     3.   rfftb     backward transform of a real coefficient array
c
c     4.   ezffti    initialize ezfftf and ezfftb
c     5.   ezfftf    a simplified real periodic forward transform
c     6.   ezfftb    a simplified real periodic backward transform
c
c     7.   sinti     initialize sint
c     8.   sint      sine transform of a real odd sequence
c
c     9.   costi     initialize cost
c     10.  cost      cosine transform of a real even sequence
c
c     11.  sinqi     initialize sinqf and sinqb
c     12.  sinqf     forward sine transform with odd wave numbers
c     13.  sinqb     unnormalized inverse of sinqf
c
c     14.  cosqi     initialize cosqf and cosqb
c     15.  cosqf     forward cosine transform with odd wave numbers
c     16.  cosqb     unnormalized inverse of cosqf
c
c     17.  cffti     initialize cfftf and cfftb
c     18.  cfftf     forward transform of a complex periodic sequence
c     19.  cfftb     unnormalized inverse of cfftf

c     *** hacked by hcp for the double prec. version novemember 1999


c
      implicit double precision (a-h,o-z)
      dimension       nd(10)     ,x(200)     ,y(200)     ,w(2000)    ,
     1                a(100)     ,b(100)     ,ah(100)    ,bh(100)    ,
     2                xh(200)    ,cx(200)    ,cy(200)
      double complex         cx         ,cy
      data nd(1),nd(2),nd(3),nd(4),nd(5),nd(6),nd(7)/120,54,49,32,4,3,2/
      sqrt2 = sqrt(2.0d0)
      nns = 7
      do 157 nz=1,nns
         n = nd(nz)
         modn = mod(n,2)
         fn = float(n)
         tfn = fn+fn
         np1 = n+1
         nm1 = n-1
         do 101 j=1,np1
            x(j) = sin(float(j)*sqrt2)
            y(j) = x(j)
            xh(j) = x(j)
  101    continue
c
c     test subroutines rffti,rfftf and rfftb
c
         call dffti (n,w)
         pi = 3.14159265358979323846d0
         dt = (pi+pi)/fn
         ns2 = (n+1)/2
         if (ns2 .lt. 2) go to 104
         do 103 k=2,ns2
            sum1 = 0.0d0
            sum2 = 0.0d0
            arg = float(k-1)*dt
            do 102 i=1,n
               arg1 = float(i-1)*arg
               sum1 = sum1+x(i)*cos(arg1)
               sum2 = sum2+x(i)*sin(arg1)
  102       continue
            y(2*k-2) = sum1
            y(2*k-1) = -sum2
  103    continue
  104    sum1 = 0.0d0
         sum2 = 0.0d0
         do 105 i=1,nm1,2
            sum1 = sum1+x(i)
            sum2 = sum2+x(i+1)
  105    continue
         if (modn .eq. 1) sum1 = sum1+x(n)
         y(1) = sum1+sum2
         if (modn .eq. 0) y(n) = sum1-sum2
         call dfftf (n,x,w)
         rftf = 0.0d0
         do 106 i=1,n
            rftf = dmax1(rftf,abs(x(i)-y(i)))
            x(i) = xh(i)
  106    continue
         rftf = rftf/fn
         do 109 i=1,n
            sum = 0.5d0*x(1)
            arg = float(i-1)*dt
            if (ns2 .lt. 2) go to 108
            do 107 k=2,ns2
               arg1 = float(k-1)*arg
               sum = sum+x(2*k-2)*cos(arg1)-x(2*k-1)*sin(arg1)
  107       continue
  108       if (modn .eq. 0) sum = sum+.5*float((-1)**(i-1))*x(n)
            y(i) = sum+sum
  109    continue
         call dfftb (n,x,w)
         rftb = 0.0d0
         do 110 i=1,n
            rftb = dmax1(rftb,abs(x(i)-y(i)))
            x(i) = xh(i)
            y(i) = xh(i)
  110    continue
         call dfftb (n,y,w)
         call dfftf (n,y,w)
         cf = 1.0d0/fn
         rftfb = 0.
         do 111 i=1,n
            rftfb = dmax1(rftfb,abs(cf*y(i)-x(i)))
  111    continue
c
c     test subroutines dsinti and dsint
c
         dt = pi/fn
         do 112 i=1,nm1
            x(i) = xh(i)
  112    continue
         do 114 i=1,nm1
            y(i) = 0.0d0
            arg1 = float(i)*dt
            do 113 k=1,nm1
               y(i) = y(i)+x(k)*sin(float(k)*arg1)
  113       continue
            y(i) = y(i)+y(i)
  114    continue
         call dsinti (nm1,w)
         call dsint (nm1,x,w)
         cf = 0.5d0/fn
         sintt = 0.0d0
         do 115 i=1,nm1
            sintt = dmax1(sintt,abs(x(i)-y(i)))
            x(i) = xh(i)
            y(i) = x(i)
  115    continue
         sintt = cf*sintt
         call dsint (nm1,x,w)
         call dsint (nm1,x,w)
         sintfb = 0.0d0
         do 116 i=1,nm1
            sintfb = dmax1(sintfb,abs(cf*x(i)-y(i)))
  116    continue
c
c     test subroutines costi and cost
c
         do 117 i=1,np1
            x(i) = xh(i)
  117    continue
         do 119 i=1,np1
            y(i) = 0.5d0*(x(1)+float((-1)**(i+1))*x(n+1))
            arg = float(i-1)*dt
            do 118 k=2,n
               y(i) = y(i)+x(k)*cos(float(k-1)*arg)
  118       continue
            y(i) = y(i)+y(i)
  119    continue
         call dcosti (np1,w)
         call dcost (np1,x,w)
         costt = 0.0d0
         do 120 i=1,np1
            costt = dmax1(costt,abs(x(i)-y(i)))
            x(i) = xh(i)
            y(i) = xh(i)
  120    continue
         costt = cf*costt
         call dcost (np1,x,w)
         call dcost (np1,x,w)
         costfb = 0.0d0
         do 121 i=1,np1
            costfb = dmax1(costfb,abs(cf*x(i)-y(i)))
  121    continue
c
c     test subroutines sinqi,sinqf and sinqb
c
         cf = 0.25d0/fn
         do 122 i=1,n
            y(i) = xh(i)
  122    continue
         dt = pi/(fn+fn)
         do 124 i=1,n
            x(i) = 0.0d0
            arg = dt*float(i)
            do 123 k=1,n
               x(i) = x(i)+y(k)*sin(float(k+k-1)*arg)
  123       continue
            x(i) = 4.0d0*x(i)
  124    continue
         call dsinqi (n,w)
         call dsinqb (n,y,w)
         sinqbt = 0.0d0
         do 125 i=1,n
            sinqbt = dmax1(sinqbt,abs(y(i)-x(i)))
            x(i) = xh(i)
  125    continue
         sinqbt = cf*sinqbt
         do 127 i=1,n
            arg = float(i+i-1)*dt
            y(i) = 0.5d0*float((-1)**(i+1))*x(n)
            do 126 k=1,nm1
               y(i) = y(i)+x(k)*sin(float(k)*arg)
  126       continue
            y(i) = y(i)+y(i)
  127    continue
         call dsinqf (n,x,w)
         sinqft = 0.0d0
         do 128 i=1,n
            sinqft = dmax1(sinqft,abs(x(i)-y(i)))
            y(i) = xh(i)
            x(i) = xh(i)
  128    continue
         call dsinqf (n,y,w)
         call dsinqb (n,y,w)
         sinqfb = 0.0d0
         do 129 i=1,n
            sinqfb = dmax1(sinqfb,abs(cf*y(i)-x(i)))
  129    continue
c
c     test subroutines cosqi,cosqf and cosqb
c
         do 130 i=1,n
            y(i) = xh(i)
  130    continue
         do 132 i=1,n
            x(i) = 0.0d0
            arg = float(i-1)*dt
            do 131 k=1,n
               x(i) = x(i)+y(k)*cos(float(k+k-1)*arg)
  131       continue
            x(i) = 4.0d0*x(i)
  132    continue
         call dcosqi (n,w)
         call dcosqb (n,y,w)
         cosqbt = 0.0d0
         do 133 i=1,n
            cosqbt = dmax1(cosqbt,abs(x(i)-y(i)))
            x(i) = xh(i)
  133    continue
         cosqbt = cf*cosqbt
         do 135 i=1,n
            y(i) = 0.5d0*x(1)
            arg = float(i+i-1)*dt
            do 134 k=2,n
               y(i) = y(i)+x(k)*cos(float(k-1)*arg)
  134       continue
            y(i) = y(i)+y(i)
  135    continue
         call dcosqf (n,x,w)
         cosqft = 0.0d0
         do 136 i=1,n
            cosqft = dmax1(cosqft,abs(y(i)-x(i)))
            x(i) = xh(i)
            y(i) = xh(i)
  136    continue
         cosqft = cf*cosqft
         call dcosqb (n,x,w)
         call dcosqf (n,x,w)
         cosqfb = 0.0d0
         do 137 i=1,n
            cosqfb = dmax1(cosqfb,abs(cf*x(i)-y(i)))
  137    continue
c
c     test programs ezffti,ezfftf,ezfftb
c
         call dzffti(n,w)
         do 138 i=1,n
            x(i) = xh(i)
  138    continue
         tpi = 8.0d0*atan(1.0d0)
         dt = tpi/float(n)
         ns2 = (n+1)/2
         cf = 2.0d0/float(n)
         ns2m = ns2-1
         if (ns2m .le. 0) go to 141
         do 140 k=1,ns2m
            sum1 = 0.0d0
            sum2 = 0.0d0
            arg = float(k)*dt
            do 139 i=1,n
               arg1 = float(i-1)*arg
               sum1 = sum1+x(i)*cos(arg1)
               sum2 = sum2+x(i)*sin(arg1)
  139       continue
            a(k) = cf*sum1
            b(k) = cf*sum2
  140    continue
  141    nm1 = n-1
         sum1 = 0.0d0
         sum2 = 0.0d0
         do 142 i=1,nm1,2
            sum1 = sum1+x(i)
            sum2 = sum2+x(i+1)
  142    continue
         if (modn .eq. 1) sum1 = sum1+x(n)
         azero = 0.5d0*cf*(sum1+sum2)
         if (modn .eq. 0) a(ns2) = 0.5d0*cf*(sum1-sum2)
         call dzfftf (n,x,azeroh,ah,bh,w)
         dezf1 = abs(azeroh-azero)
         if (modn .eq. 0) dezf1 = dmax1(dezf1,abs(a(ns2)-ah(ns2)))
         if (ns2m .le. 0) go to 144
         do 143 i=1,ns2m
            dezf1 = dmax1(dezf1,abs(ah(i)-a(i)),abs(bh(i)-b(i)))
  143    continue
  144    ns2 = n/2
         if (modn .eq. 0) b(ns2) = 0.0d0
         do 146 i=1,n
            sum = azero
            arg1 = float(i-1)*dt
            do 145 k=1,ns2
               arg2 = float(k)*arg1
               sum = sum+a(k)*cos(arg2)+b(k)*sin(arg2)
  145       continue
            x(i) = sum
  146    continue
         call dzfftb (n,y,azero,a,b,w)
         dezb1 = 0.0d0
         do 147 i=1,n
            dezb1 = dmax1(dezb1,abs(x(i)-y(i)))
            x(i) = xh(i)
  147    continue
         call dzfftf (n,x,azero,a,b,w)
         call dzfftb (n,y,azero,a,b,w)
         dezfb = 0.0d0
         do 148 i=1,n
            dezfb = dmax1(dezfb,abs(x(i)-y(i)))
  148    continue
c
c     test  cffti,cfftf,cfftb
c
         do 149 i=1,n
            cx(i) = dcmplx(cos(sqrt2*float(i)),sin(sqrt2*float(i*i)))
  149    continue
         dt = (pi+pi)/fn
         do 151 i=1,n
            arg1 = -float(i-1)*dt
            cy(i) = (0.0d0,0.0d0)
            do 150 k=1,n
               arg2 = float(k-1)*arg1
               cy(i) = cy(i)+dcmplx(cos(arg2),sin(arg2))*cx(k)
  150       continue
  151    continue
         call zffti (n,w)
         call zfftf (n,cx,w)
         dcfftf = 0.0d0
         do 152 i=1,n
            dcfftf = dmax1(dcfftf,abs(cx(i)-cy(i)))
            cx(i) = cx(i)/fn
  152    continue
         dcfftf = dcfftf/fn
         do 154 i=1,n
            arg1 = float(i-1)*dt
            cy(i) = (0.0d0,0.0d0)
            do 153 k=1,n
               arg2 = float(k-1)*arg1
               cy(i) = cy(i)+dcmplx(cos(arg2),sin(arg2))*cx(k)
  153       continue
  154    continue
         call zfftb (n,cx,w)
         dcfftb = 0.0d0
         do 155 i=1,n
            dcfftb = dmax1(dcfftb,abs(cx(i)-cy(i)))
            cx(i) = cy(i)
  155    continue
         cf = 1.0d0/fn
         call zfftf (n,cx,w)
         call zfftb (n,cx,w)
         dcfb = 0.0d0
         do 156 i=1,n
            dcfb = dmax1(dcfb,abs(cf*cx(i)-cy(i)))
  156    continue
         write (6,1001) n,rftf,rftb,rftfb,sintt,sintfb,costt,costfb,
     1                  sinqft,sinqbt,sinqfb,cosqft,cosqbt,cosqfb,dezf1,
     2                  dezb1,dezfb,dcfftf,dcfftb,dcfb
  157 continue
c
c
c
 1001 format (2h0n,i5,8h rfftf  ,e10.3,8h rfftb  ,e10.3,8h rfftfb ,
     1        e10.3,8h sint   ,e10.3,8h sintfb ,e10.3,8h cost   ,e10.3/
     2        7x,8h costfb ,e10.3,8h sinqf  ,e10.3,8h sinqb  ,e10.3,
     3        8h sinqfb ,e10.3,8h cosqf  ,e10.3,8h cosqb  ,e10.3/7x,
     4        8h cosqfb ,e10.3,8h dezf   ,e10.3,8h dezb   ,e10.3,
     5        8h dezfb  ,e10.3,8h cfftf  ,e10.3,8h cfftb  ,e10.3/
     6        7x,8h cfftfb ,e10.3)
c
      end
