C  This Fortran script contains the Fast Fourier Transform of real,
C  periodic sequences and the cosine transform (using FFT) of zero
C  Neumann boundary conditions.
C
C  It can be compiled and archived in libs, then called from outside
C  in the source codes. See readme.txt.
C
C  The main subroutines are: VRFFTI: initialization of FFT
C                            VRFFTF: forward transform
C                            VRFFTB: backward or inverse transform
C
C                            VCOSQI: initialization of cos transform
C                            VCOSQF: forward transform
C                            VCOSQB: backward or inverse transform
C
C  Note added by Anthony Ge (KTH) on 24 Januray 2017.
C--------------------------------------------------------------------

      SUBROUTINE VCOSQI(N,WSAVE)
C***BEGIN PROLOGUE  VCOSQI
C***DATE WRITTEN   860701   (YYMMDD)
C***REVISION DATE  900509   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FAST FOURIER TRANSFORM, COSINE TRANSFORM, ODD WAVE
C             NUMBERS, MULTIPLE SEQUENCES
C***AUTHOR  BOISVERT, R. F. (NIST)
C***PURPOSE  Initialize for VCOSQF and VCOSQB.
C***DESCRIPTION
C
C  Subroutine VCOSQI initializes the array WSAVE which is used in
C  both VCOSQF and VCOSQB.  The prime factorization of N together with
C  a tabulation of the trigonometric functions are computed and
C  stored in WSAVE.
C
C  Input Parameter
C
C  N       the length of the array to be transformed.  The method
C          is most efficient when N is a product of small primes.
C
C  Output Parameter
C
C  WSAVE   a work array which must be dimensioned at least 2*N+15.
C          The same work array can be used for both VCOSQF and VCOSQB
C          as long as N remains unchanged.  Different WSAVE arrays
C          are required for different values of N.  The contents of
C          WSAVE must not be changed between calls of VCOSQF or VCOSQB.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C               Computations, (G. Rodrigue, ed.), Academic Press, 1982,
C               pp. 51-83.
C***ROUTINES CALLED  VRFFTI
C***END PROLOGUE  VCOSQI
      DIMENSION       WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  VCOSQI
      PIH = 0.5*PIMACHNEW(1.0)
      DT = PIH/REAL(N)
      FK = 0.
      DO 101 K=1,N
         FK = FK+1.
         WSAVE(K) = COS(FK*DT)
  101 CONTINUE
      CALL VRFFTI (N,WSAVE(N+1))
      RETURN
      END SUBROUTINE VCOSQI

C--------------------------------------------------------------------

      SUBROUTINE VCOSQF(M,N,X,XT,MDIMX,WSAVE)
C***BEGIN PROLOGUE  VCOSQF
C***DATE WRITTEN   860701   (YYMMDD)
C***REVISION DATE  900509   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FAST FOURIER TRANSFORM, COSINE TRANSFORM, ODD WAVE
C             NUMBERS, MULTIPLE SEQUENCES
C***AUTHOR  BOISVERT, R. F. (NIST)
C***PURPOSE  Forward cosine transform, odd wave numbers, M sequences.
C***DESCRIPTION
C
C  Subroutine VCOSQF computes the forward fast Fourier cosine transform
C  of M quarter wave sequences.  That is, cosine series representations
C  with only odd wave numbers.  The transform is defined below at output
C  parameter X.
C
C  The array WSAVE which is used by subroutine VCOSQF must be
C  initialized by calling subroutine VCOSQI(N,WSAVE).
C
C
C  Input Parameters
C
C  M       the number of sequences to be transformed.
C
C  N       the length of the sequences to be transformed.  The method
C          is most efficient when N is a product of small primes.
C
C  X       an array of size at least X(MDIMX,N) which contains the
C          the sequences to be transformed.  The sequences are stored
C          in the ROWS of X.  Thus, the Jth sequence is stored in
C          X(J,I), I=1,..,N.
C
C  XT      a work array of size at least XT(MDIMX,N).
C
C  MDIMX   the first dimension of the array X exactly as it appears in
C          the calling program.
C
C  WSAVE   a work array which must be dimensioned at least 2*N+15
C          in the program that calls VCOSQF.  The WSAVE array must be
C          initialized by calling subroutine VCOSQI(N,WSAVE), and a
C          different WSAVE array must be used for each different
C          value of N.  This initialization does not have to be
C          repeated so long as N remains unchanged.
C
C  Output Parameters
C
C  X       For I=1,...,N and J=1,...,M
C
C               X(I) = ( X(1) + the sum from K=2 to K=N of
C
C                  2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N)) )/SQRT(4*N)
C
C  WSAVE   contains initialization calculations which must not
C          be destroyed between calls of VCOSQF or VCOSQB.
C
C  -----------------------------------------------------------------
C
C  NOTE  -  A call of VCOSQF followed immediately by a call of
C           of VCOSQB will return the original sequences X.  Thus,
C           VCOSQB is the correctly normalized inverse VCOSQF.
C
C  -----------------------------------------------------------------
C
C  VCOSQF is a straightforward extension of the subprogram COSQF to
C  handle M simultaneous sequences.  COSQF was originally developed
C  by P. N. Swarztrauber of NCAR.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C               Computations, (G. Rodrigue, ed.), Academic Press, 1982,
C               pp. 51-83.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  VCOSQF
      DIMENSION       X(MDIMX,*), XT(MDIMX,*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  VCOSQF
      IF (M .LE. 0)  GO TO 900
      IF (N .GT. 2)  GO TO 300
      IF (N .LT. 2)  GO TO 900
C
C  CASE  N = 2
C
      SQRT2 = SQRT(2.0)
      SCALE = 0.50E0/SQRT2
      DO 210 J=1,M
         TSQX = SQRT2*X(J,2)
         X(J,2) = SCALE*(X(J,1)-TSQX)
         X(J,1) = SCALE*(X(J,1)+TSQX)
  210 CONTINUE
      GO TO 900
C
C  CASE N .GT. 2
C
  300 CONTINUE
C
C     ... PREPROCESSING
C
      NS2 = (N+1)/2
      NP2 = N+2
      DO 310 K=2,NS2
         KC = NP2-K
         DO 310 J=1,M
            XT(J,K) = X(J,K)+X(J,KC)
            XT(J,KC) = X(J,K)-X(J,KC)
  310 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) THEN
         DO 320 J=1,M
            XT(J,NS2+1) = X(J,NS2+1)+X(J,NS2+1)
  320    CONTINUE
      ENDIF
      DO 330 K=2,NS2
         KC = NP2-K
         DO 330 J=1,M
            X(J,K) = WSAVE(K-1)*XT(J,KC)+WSAVE(KC-1)*XT(J,K)
            X(J,KC) = WSAVE(K-1)*XT(J,K)-WSAVE(KC-1)*XT(J,KC)
  330 CONTINUE
      IF (MODN .EQ. 0) THEN
         DO 340 J=1,M
            X(J,NS2+1) = WSAVE(NS2)*XT(J,NS2+1)
  340    CONTINUE
      ENDIF
C
C     ... REAL, PERIODIC TRANSFORM
C
      CALL VRFFTF (M,N,X,XT,MDIMX,WSAVE(N+1))
C
C     ... POSTPROCESSING
C
      DO 350 I=3,N,2
         DO 350 J=1,M
            XIM1 = X(J,I-1)-X(J,I)
            X(J,I) = X(J,I-1)+X(J,I)
            X(J,I-1) = XIM1
  350 CONTINUE
C
C     ... NORMALIZATION
C
      SCALE = 0.5
      DO 360 I=1,N
         DO 360 J=1,M
            X(J,I) = SCALE*X(J,I)
  360 CONTINUE
C
C  EXIT
C
  900 CONTINUE
      RETURN
      END SUBROUTINE VCOSQF

C--------------------------------------------------------------------

      SUBROUTINE VCOSQB(M,N,X,XT,MDIMX,WSAVE)
C***BEGIN PROLOGUE  VCOSQB
C***DATE WRITTEN   860701   (YYMMDD)
C***REVISION DATE  900509   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FAST FOURIER TRANSFORM, COSINE TRANSFORM, ODD WAVE
C             NUMBERS, MULTIPLE SEQUENCES
C***AUTHOR  BOISVERT, R. F. (NIST)
C***PURPOSE  Normalized inverse of VCOSQF.
C***DESCRIPTION
C
C  Subroutine VCOSQB computes the backward fast Fourier cosine transform
C  of M quarter wave sequences.  That is, cosine series representations
C  with only odd wave numbers.  The transform is defined below at output
C  parameter X.
C
C  The array WSAVE which is used by subroutine VCOSQB must be
C  initialized by calling subroutine VCOSQI(N,WSAVE).
C
C
C  Input Parameters
C
C  M       the number of sequences to be transformed.
C
C  N       the length of the sequences to be transformed.  The method
C          is most efficient when N is a product of small primes.
C
C  X       an array of size at least X(MDIMX,N) which contains the
C          the sequences to be transformed.  The sequences are stored
C          in the ROWS of X.  Thus, the Jth sequence is stored in
C          X(J,I), I=1,..,N.
C
C  XT      a work array of size at least XT(MDIMX,N).
C
C  MDIMX   the first dimension of the array X exactly as it appears in
C          the calling program.
C
C  WSAVE   a work array which must be dimensioned at least 2*N+15
C          in the program that calls VCOSQB.  The WSAVE array must be
C          initialized by calling subroutine VCOSQI(N,WSAVE), and a
C          different WSAVE array must be used for each different
C          value of N.  This initialization does not have to be
C          repeated so long as N remains unchanged.
C
C  Output Parameters
C
C  X       For I=1,...,N and J=1,...,M
C
C               X(I)= the sum from K=1 to K=N of
C
C                 4*X(K)*COS((2*K-1)*(I-1)*PI/(2*N)) /SQRT(4*N)
C
C  WSAVE   contains initialization calculations which must not
C          be destroyed between calls of VCOSQF or VCOSQB.
C
C  -----------------------------------------------------------------
C
C  NOTE  -  A call of VCOSQF followed immediately by a call of
C           of VCOSQB will return the original sequences X.  Thus,
C           VCOSQB is the correctly normalized inverse VCOSQF.
C
C  -----------------------------------------------------------------
C
C  VCOSQB is a straightforward extension of the subprogram COSQB to
C  handle M simultaneous sequences.  COSQB was originally developed
C  by P. N. Swarztrauber of NCAR.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C               Computations, (G. Rodrigue, ed.), Academic Press, 1982,
C               pp. 51-83.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  VCOSQB
      DIMENSION       X(MDIMX,*), XT(MDIMX,*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  VCOSQB
      IF (M .LE. 0)  GO TO 900
      IF (N .GT. 2)  GO TO 300
      IF (N .EQ. 2)  GO TO 200
      GO TO 900
C
C  CASE  N = 2
C
  200 CONTINUE
      SCALE = 2.0E0*SQRT(0.50E0)
      DO 210 J=1,M
         X1 = SCALE*(X(J,1)+X(J,2))
         X(J,2) = X(J,1)-X(J,2)
         X(J,1) = X1
  210 CONTINUE
      GO TO 900
C
C  CASE N .GT. 2
C
C     ... PREPROCESSING
C
  300 CONTINUE
      NS2 = (N+1)/2
      NP2 = N+2
      DO 310 I=3,N,2
         DO 310 J=1,M
            XIM1 = X(J,I-1)+X(J,I)
            X(J,I) = X(J,I)-X(J,I-1)
            X(J,I-1) = XIM1
  310 CONTINUE
      DO 320 J=1,M
         X(J,1) = X(J,1)+X(J,1)
  320 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) THEN
         DO 330 J=1,M
            X(J,N) = X(J,N)+X(J,N)
  330    CONTINUE
      ENDIF
C
C     ... REAL, PERIODIC TRANSFORM
C
      CALL VRFFTB (M,N,X,XT,MDIMX,WSAVE(N+1))
C
C     ... POSTPROCESSING
C
      DO 340 K=2,NS2
         KC = NP2-K
         DO 340 J=1,M
            XT(J,K) = WSAVE(K-1)*X(J,KC)+WSAVE(KC-1)*X(J,K)
            XT(J,KC) = WSAVE(K-1)*X(J,K)-WSAVE(KC-1)*X(J,KC)
  340 CONTINUE
      IF (MODN .EQ. 0) THEN
         DO 350 J=1,M
            X(J,NS2+1) = WSAVE(NS2)*(X(J,NS2+1)+X(J,NS2+1))
  350    CONTINUE
      ENDIF
      DO 360 K=2,NS2
         KC = NP2-K
         DO 360 J=1,M
            X(J,K) = XT(J,K)+XT(J,KC)
            X(J,KC) = XT(J,K)-XT(J,KC)
  360 CONTINUE
      DO 370 J=1,M
         X(J,1) = X(J,1)+X(J,1)
  370 CONTINUE
C
C     ... NORMALIZATION
C
      SCALE = 0.5
      DO 380 I=1,N
         DO 380 J=1,M
            X(J,I) = SCALE*X(J,I)
  380 CONTINUE
C
C  EXIT
C
  900 CONTINUE
      RETURN
      END SUBROUTINE VCOSQB

C--------------------------------------------------------------------

      SUBROUTINE VRFFTB(M,N,R,RT,MDIMR,WSAVE)
!***BEGIN PROLOGUE  VRFFTB
!***DATE WRITTEN   850801   (YYMMDD)
!***REVISION DATE  900509   (YYMMDD)
!***CATEGORY NO.  J1A1
!***KEYWORDS  FAST FOURIER TRANSFORM, REAL PERIODIC TRANSFORM,
!             FOURIER SYNTHESIS, BACKWARD TRANSFORM, MULTIPLE SEQUENCES
!***AUTHOR  SWEET, R.A. (NIST) AND LINDGREN, L.L. (NIST)
!***PURPOSE  Backward real periodic transform, M sequences.
!***DESCRIPTION
!
!  Subroutine VRFFTB computes the synthesis (backward transform) of a
!  number of real periodic sequences from their Fourier coefficients.
!  Specifically, for each set of independent Fourier coefficients
!  F(K), the corresponding real periodic sequence is computed.
!
!  The array WSAVE which is used by subroutine VRFFTB must be
!  initialized by calling subroutine VRFFTI(N,WSAVE).
!
!
!  Input Parameters
!
!  M       the number of sets of coefficients.
!
!  N       the length of the sequences of coefficients to be
!          transformed.  The method is most efficient when N is a
!          product of small primes, however n may be any positive
!          integer.
!
!  R       a real two-dimensional array of size MDIMX x N containing the
!          coefficients to be transformed.  Each set of coefficients
!          F(K), K\0,1,..,N-1, is stored as a ROW of R.  Specifically,
!          the I-th set of independent Fourier coefficients is stored
!
!                R(I,1) = REAL( F(I,0) ),
!
!                R(I,2*K) = REAL( F(I,K) )
!
!                R(I,2*K+1) = IMAG( F(I,K) )
!
!                   for K = 1, 2, . . . , M-1,
!
!                and, when N is even,
!
!                R(I,N) = REAL( F(I,N/2) ).
!
!  RT      a real two-dimensional work array of size MDIMX x N.
!
!  MDIMR   the row (or first) dimension of the arrays R and RT exactly
!          as they appear in the calling program.  This parameter is
!          used to specify the variable dimension of these arrays.
!
!  WSAVE   a real one-dimensional work array which must be dimensioned
!          at least N+15.  The WSAVE array must be initialized by
!          calling subroutine VRFFTI.  A different WSAVE array must be
!          used for each different value of N.  This initialization does
!          not have to be repeated so long as N remains unchanged.  The
!          same WSAVE array may be used by VRFFTB and VRFFTB.
!
!  Output Parameters
!
!  R       contains M real periodic sequences corresponding to the given
!          coefficients.  Specifically, the I-th row of R contains the
!          real periodic sequence corresponding to the I-th set of
!          independent Fourier coefficients F(I,K) stored as
!
!               R(I,J) = X(I,J-1) ,   J = 1, 2, . . . , N, where
!
!               X(I,J) = SQRT(1/N)* F(I,0) + (-1)**J*F(I,N/2)
!                        + 2*SUM(K=1,M)[ REAL(F(I,2K))*COS(2K*J*PI/N)
!                        - IMAG(F(I,2K+1))*SIN(2K*J*PI/N) ]  ,
!
!                 when N is even, and
!
!               X(I,J) = SQRT(1/N)* F(I,0) +
!                        2*SUM(K=1,M)[ REAL(F(I,2K))*COS(2K*J*PI/N)
!                        - IMAG(F(I,2K+1))*SIN(2K*J*PI/N) ]  ,
!
!                 when N is odd.
!
!  WSAVE   contains results which must not be destroyed between calls
!          to VRFFTF or VRFFTB.
!
!  -----------------------------------------------------------------
!
!  NOTE  -  A call of VRFFTF followed immediately by a call of
!           of VRFFTB will return the original sequences R.  Thus,
!           VRFFTB is the correctly normalized inverse of VRFFTF.
!
!  -----------------------------------------------------------------
!
!  VRFFTB is a straightforward extension of the subprogram RFFTB to
!  handle M simultaneous sequences.  RFFTB was originally developed
!  by P. N. Swarztrauber of NCAR.
!
!
!              * * * * * * * * * * * * * * * * * * * * *
!              *                                       *
!              *         PROGRAM SPECIFICATIONS        *
!              *                                       *
!              * * * * * * * * * * * * * * * * * * * * *
!
!
!     DIMENSION OF    R(MDIMR,N), RT(MDIMR,N), WSAVE(N+15)
!     ARGUMENTS
!
!     LATEST          AUGUST 1, 1985
!     REVISION
!
!     SUBPROGRAMS     VRFFTI, VRFTI1, VRFFTF, VRFTF1, VRADF2, VRADF3,
!     REQUIRED        VRADF4, VRADF5, VRADFG, VRFFTB, VRFTB1, VRADB2,
!                     VRADB3, VRADB4, VRADB5, VRADBG, PIMACHNEW
!
!     SPECIAL         NONE
!     CONDITIONS
!
!     COMMON          NONE
!     BLOCKS
!
!     I/O             NONE
!
!     PRECISION       SINGLE
!
!     SPECIALIST      ROLAND SWEET
!
!     LANGUAGE        FORTRAN
!
!     HISTORY         WRITTEN BY LINDA LINDGREN AND ROLAND SWEET AT THE
!                     NATIONAL BUREAU OF STANDARDS (BOULDER).
!
!     ALGORITHM       A REAL VARIANT OF THE STOCKHAM AUTOSORT VERSION
!                     OF THE COOLEY-TUKEY FAST FOURIER TRANSFORM.
!
!     PORTABILITY     AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN 77.
!                     THE ONLY MACHINE DEPENDENT CONSTANT IS LOCATED IN
!                     THE FUNCTION PIMACHNEW.
!
!     REQUIRED        COS,SIN
!     RESIDENT
!     ROUTINES
!
!
!***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
!               Computations, (G. Rodrigue, ed.), Academic Press, 1982,
!               pp. 51-83.
!***ROUTINES CALLED  VRFTB1
!***END PROLOGUE  VRFFTB
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION     R(MDIMR,N),RT(MDIMR,N),WSAVE(N+15)
      IF (N .EQ. 1) RETURN
      CALL VRFTB1 (M,N,R,RT,MDIMR,WSAVE(1),WSAVE(N+1))
      RETURN
      END SUBROUTINE VRFFTB

      SUBROUTINE VRADB2 (MP,IDO,L1,CC,CH,MDIMC,WA1)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION  CC(MDIMC,IDO,2,L1)    ,CH(MDIMC,IDO,L1,2),
     1                WA1(IDO)
      DO 101 K=1,L1
          DO 1001 M=1,MP
         CH(M,1,K,1) = CC(M,1,1,K)+CC(M,IDO,2,K)
         CH(M,1,K,2) = CC(M,1,1,K)-CC(M,IDO,2,K)
 1001     CONTINUE
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
               DO 1002 M=1,MP
            CH(M,I-1,K,1) = CC(M,I-1,1,K)+CC(M,IC-1,2,K)
            CH(M,I,K,1) = CC(M,I,1,K)-CC(M,IC,2,K)
            CH(M,I-1,K,2) = WA1(I-2)*(CC(M,I-1,1,K)-CC(M,IC-1,2,K))
     1      -WA1(I-1)*(CC(M,I,1,K)+CC(M,IC,2,K))
            CH(M,I,K,2) = WA1(I-2)*(CC(M,I,1,K)+CC(M,IC,2,K))+WA1(I-1)
     1      *(CC(M,I-1,1,K)-CC(M,IC-1,2,K))
 1002          CONTINUE
  103    CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
          DO 1003 M=1,MP
         CH(M,IDO,K,1) = CC(M,IDO,1,K)+CC(M,IDO,1,K)
         CH(M,IDO,K,2) = -(CC(M,1,2,K)+CC(M,1,2,K))
 1003     CONTINUE
  106 CONTINUE
  107 RETURN
      END SUBROUTINE VRADB2

      SUBROUTINE VRADB3 (MP,IDO,L1,CC,CH,MDIMC,WA1,WA2)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION  CC(MDIMC,IDO,3,L1)    ,CH(MDIMC,IDO,L1,3),
     1                WA1(IDO)   ,WA2(IDO)
      ARG=2.*PIMACHNEW(1.0)/3.
      TAUR=COS(ARG)
      TAUI=SIN(ARG)
      DO 101 K=1,L1
          DO 1001 M=1,MP
         CH(M,1,K,1) = CC(M,1,1,K)+2.*CC(M,IDO,2,K)
         CH(M,1,K,2) = CC(M,1,1,K)+(2.*TAUR)*CC(M,IDO,2,K)
     1   -(2.*TAUI)*CC(M,1,3,K)
         CH(M,1,K,3) = CC(M,1,1,K)+(2.*TAUR)*CC(M,IDO,2,K)
     1   +2.*TAUI*CC(M,1,3,K)
 1001     CONTINUE
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
               DO 1002 M=1,MP
            CH(M,I-1,K,1) = CC(M,I-1,1,K)+(CC(M,I-1,3,K)+CC(M,IC-1,2,K))
            CH(M,I,K,1) = CC(M,I,1,K)+(CC(M,I,3,K)-CC(M,IC,2,K))
            CH(M,I-1,K,2) = WA1(I-2)*
     1 ((CC(M,I-1,1,K)+TAUR*(CC(M,I-1,3,K)+CC(M,IC-1,2,K)))-
     * (TAUI*(CC(M,I,3,K)+CC(M,IC,2,K))))
     2                   -WA1(I-1)*
     3 ((CC(M,I,1,K)+TAUR*(CC(M,I,3,K)-CC(M,IC,2,K)))+
     * (TAUI*(CC(M,I-1,3,K)-CC(M,IC-1,2,K))))
            CH(M,I,K,2) = WA1(I-2)*
     4 ((CC(M,I,1,K)+TAUR*(CC(M,I,3,K)-CC(M,IC,2,K)))+
     8 (TAUI*(CC(M,I-1,3,K)-CC(M,IC-1,2,K))))
     5                  +WA1(I-1)*
     6 ((CC(M,I-1,1,K)+TAUR*(CC(M,I-1,3,K)+CC(M,IC-1,2,K)))-
     8 (TAUI*(CC(M,I,3,K)+CC(M,IC,2,K))))
              CH(M,I-1,K,3) = WA2(I-2)*
     7 ((CC(M,I-1,1,K)+TAUR*(CC(M,I-1,3,K)+CC(M,IC-1,2,K)))+
     8 (TAUI*(CC(M,I,3,K)+CC(M,IC,2,K))))
     8                      -WA2(I-1)*
     9 ((CC(M,I,1,K)+TAUR*(CC(M,I,3,K)-CC(M,IC,2,K)))-
     8 (TAUI*(CC(M,I-1,3,K)-CC(M,IC-1,2,K))))
            CH(M,I,K,3) = WA2(I-2)*
     1 ((CC(M,I,1,K)+TAUR*(CC(M,I,3,K)-CC(M,IC,2,K)))-
     8 (TAUI*(CC(M,I-1,3,K)-CC(M,IC-1,2,K))))
     2                 +WA2(I-1)*
     3 ((CC(M,I-1,1,K)+TAUR*(CC(M,I-1,3,K)+CC(M,IC-1,2,K)))+
     8 (TAUI*(CC(M,I,3,K)+CC(M,IC,2,K))))
 1002          CONTINUE
  102    CONTINUE
  103 CONTINUE
      RETURN
      END SUBROUTINE VRADB3

      SUBROUTINE VRADB4 (MP,IDO,L1,CC,CH,MDIMC,WA1,WA2,WA3)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION  CC(MDIMC,IDO,4,L1)  ,CH(MDIMC,IDO,L1,4)    ,
     1                WA1(IDO)  ,WA2(IDO)  ,WA3(IDO)
      SQRT2=SQRT(2.)
      DO 101 K=1,L1
          DO 1001 M=1,MP
         CH(M,1,K,3) = (CC(M,1,1,K)+CC(M,IDO,4,K))
     1   -(CC(M,IDO,2,K)+CC(M,IDO,2,K))
         CH(M,1,K,1) = (CC(M,1,1,K)+CC(M,IDO,4,K))
     1   +(CC(M,IDO,2,K)+CC(M,IDO,2,K))
         CH(M,1,K,4) = (CC(M,1,1,K)-CC(M,IDO,4,K))
     1   +(CC(M,1,3,K)+CC(M,1,3,K))
         CH(M,1,K,2) = (CC(M,1,1,K)-CC(M,IDO,4,K))
     1   -(CC(M,1,3,K)+CC(M,1,3,K))
 1001     CONTINUE
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
               DO 1002 M=1,MP
            CH(M,I-1,K,1) = (CC(M,I-1,1,K)+CC(M,IC-1,4,K))
     1      +(CC(M,I-1,3,K)+CC(M,IC-1,2,K))
            CH(M,I,K,1) = (CC(M,I,1,K)-CC(M,IC,4,K))
     1      +(CC(M,I,3,K)-CC(M,IC,2,K))
            CH(M,I-1,K,2)=WA1(I-2)*((CC(M,I-1,1,K)-CC(M,IC-1,4,K))
     1      -(CC(M,I,3,K)+CC(M,IC,2,K)))-WA1(I-1)
     1      *((CC(M,I,1,K)+CC(M,IC,4,K))+(CC(M,I-1,3,K)-CC(M,IC-1,2,K)))
            CH(M,I,K,2)=WA1(I-2)*((CC(M,I,1,K)+CC(M,IC,4,K))
     1      +(CC(M,I-1,3,K)-CC(M,IC-1,2,K)))+WA1(I-1)
     1      *((CC(M,I-1,1,K)-CC(M,IC-1,4,K))-(CC(M,I,3,K)+CC(M,IC,2,K)))
            CH(M,I-1,K,3)=WA2(I-2)*((CC(M,I-1,1,K)+CC(M,IC-1,4,K))
     1      -(CC(M,I-1,3,K)+CC(M,IC-1,2,K)))-WA2(I-1)
     1      *((CC(M,I,1,K)-CC(M,IC,4,K))-(CC(M,I,3,K)-CC(M,IC,2,K)))
            CH(M,I,K,3)=WA2(I-2)*((CC(M,I,1,K)-CC(M,IC,4,K))
     1      -(CC(M,I,3,K)-CC(M,IC,2,K)))+WA2(I-1)
     1      *((CC(M,I-1,1,K)+CC(M,IC-1,4,K))-(CC(M,I-1,3,K)
     1      +CC(M,IC-1,2,K)))
            CH(M,I-1,K,4)=WA3(I-2)*((CC(M,I-1,1,K)-CC(M,IC-1,4,K))
     1      +(CC(M,I,3,K)+CC(M,IC,2,K)))-WA3(I-1)
     1     *((CC(M,I,1,K)+CC(M,IC,4,K))-(CC(M,I-1,3,K)-CC(M,IC-1,2,K)))
            CH(M,I,K,4)=WA3(I-2)*((CC(M,I,1,K)+CC(M,IC,4,K))
     1      -(CC(M,I-1,3,K)-CC(M,IC-1,2,K)))+WA3(I-1)
     1      *((CC(M,I-1,1,K)-CC(M,IC-1,4,K))+(CC(M,I,3,K)+CC(M,IC,2,K)))
 1002          CONTINUE
  103    CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2) .EQ. 1) RETURN
  105 CONTINUE
      DO 106 K=1,L1
               DO 1003 M=1,MP
         CH(M,IDO,K,1) = (CC(M,IDO,1,K)+CC(M,IDO,3,K))
     1   +(CC(M,IDO,1,K)+CC(M,IDO,3,K))
         CH(M,IDO,K,2) = SQRT2*((CC(M,IDO,1,K)-CC(M,IDO,3,K))
     1   -(CC(M,1,2,K)+CC(M,1,4,K)))
         CH(M,IDO,K,3) = (CC(M,1,4,K)-CC(M,1,2,K))
     1   +(CC(M,1,4,K)-CC(M,1,2,K))
         CH(M,IDO,K,4) = -SQRT2*((CC(M,IDO,1,K)-CC(M,IDO,3,K))
     1   +(CC(M,1,2,K)+CC(M,1,4,K)))
 1003          CONTINUE
  106 CONTINUE
  107 RETURN
      END SUBROUTINE VRADB4

      SUBROUTINE VRADB5 (MP,IDO,L1,CC,CH,MDIMC,WA1,WA2,WA3,WA4)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION  CC(MDIMC,IDO,5,L1)    ,CH(MDIMC,IDO,L1,5),
     1             WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)
      ARG=2.*PIMACHNEW(1.0)/5.
      TR11=COS(ARG)
      TI11=SIN(ARG)
      TR12=COS(2.*ARG)
      TI12=SIN(2.*ARG)
      DO 101 K=1,L1
      DO 1001 M=1,MP
         CH(M,1,K,1) = CC(M,1,1,K)+2.*CC(M,IDO,2,K)+2.*CC(M,IDO,4,K)
         CH(M,1,K,2) = (CC(M,1,1,K)+TR11*2.*CC(M,IDO,2,K)
     1   +TR12*2.*CC(M,IDO,4,K))-(TI11*2.*CC(M,1,3,K)
     1   +TI12*2.*CC(M,1,5,K))
         CH(M,1,K,3) = (CC(M,1,1,K)+TR12*2.*CC(M,IDO,2,K)
     1   +TR11*2.*CC(M,IDO,4,K))-(TI12*2.*CC(M,1,3,K)
     1   -TI11*2.*CC(M,1,5,K))
         CH(M,1,K,4) = (CC(M,1,1,K)+TR12*2.*CC(M,IDO,2,K)
     1   +TR11*2.*CC(M,IDO,4,K))+(TI12*2.*CC(M,1,3,K)
     1   -TI11*2.*CC(M,1,5,K))
         CH(M,1,K,5) = (CC(M,1,1,K)+TR11*2.*CC(M,IDO,2,K)
     1   +TR12*2.*CC(M,IDO,4,K))+(TI11*2.*CC(M,1,3,K)
     1   +TI12*2.*CC(M,1,5,K))
 1001          CONTINUE
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
      DO 1002 M=1,MP
            CH(M,I-1,K,1) = CC(M,I-1,1,K)+(CC(M,I-1,3,K)+CC(M,IC-1,2,K))
     1      +(CC(M,I-1,5,K)+CC(M,IC-1,4,K))
            CH(M,I,K,1) = CC(M,I,1,K)+(CC(M,I,3,K)-CC(M,IC,2,K))
     1      +(CC(M,I,5,K)-CC(M,IC,4,K))
            CH(M,I-1,K,2) = WA1(I-2)*((CC(M,I-1,1,K)+TR11*
     1      (CC(M,I-1,3,K)+CC(M,IC-1,2,K))+TR12
     1      *(CC(M,I-1,5,K)+CC(M,IC-1,4,K)))-(TI11*(CC(M,I,3,K)
     1      +CC(M,IC,2,K))+TI12*(CC(M,I,5,K)+CC(M,IC,4,K))))
     1      -WA1(I-1)*((CC(M,I,1,K)+TR11*(CC(M,I,3,K)-CC(M,IC,2,K))
     1      +TR12*(CC(M,I,5,K)-CC(M,IC,4,K)))+(TI11*(CC(M,I-1,3,K)
     1      -CC(M,IC-1,2,K))+TI12*(CC(M,I-1,5,K)-CC(M,IC-1,4,K))))
            CH(M,I,K,2) = WA1(I-2)*((CC(M,I,1,K)+TR11*(CC(M,I,3,K)
     1      -CC(M,IC,2,K))+TR12*(CC(M,I,5,K)-CC(M,IC,4,K)))
     1      +(TI11*(CC(M,I-1,3,K)-CC(M,IC-1,2,K))+TI12
     1      *(CC(M,I-1,5,K)-CC(M,IC-1,4,K))))+WA1(I-1)
     1      *((CC(M,I-1,1,K)+TR11*(CC(M,I-1,3,K)
     1      +CC(M,IC-1,2,K))+TR12*(CC(M,I-1,5,K)+CC(M,IC-1,4,K)))
     1      -(TI11*(CC(M,I,3,K)+CC(M,IC,2,K))+TI12
     1      *(CC(M,I,5,K)+CC(M,IC,4,K))))
            CH(M,I-1,K,3) = WA2(I-2)
     1      *((CC(M,I-1,1,K)+TR12*(CC(M,I-1,3,K)+CC(M,IC-1,2,K))
     1      +TR11*(CC(M,I-1,5,K)+CC(M,IC-1,4,K)))-(TI12*(CC(M,I,3,K)
     1      +CC(M,IC,2,K))-TI11*(CC(M,I,5,K)+CC(M,IC,4,K))))
     1     -WA2(I-1)
     1     *((CC(M,I,1,K)+TR12*(CC(M,I,3,K)-
     1      CC(M,IC,2,K))+TR11*(CC(M,I,5,K)-CC(M,IC,4,K)))
     1      +(TI12*(CC(M,I-1,3,K)-CC(M,IC-1,2,K))-TI11
     1      *(CC(M,I-1,5,K)-CC(M,IC-1,4,K))))
            CH(M,I,K,3) = WA2(I-2)
     1     *((CC(M,I,1,K)+TR12*(CC(M,I,3,K)-
     1      CC(M,IC,2,K))+TR11*(CC(M,I,5,K)-CC(M,IC,4,K)))
     1      +(TI12*(CC(M,I-1,3,K)-CC(M,IC-1,2,K))-TI11
     1      *(CC(M,I-1,5,K)-CC(M,IC-1,4,K))))
     1      +WA2(I-1)
     1      *((CC(M,I-1,1,K)+TR12*(CC(M,I-1,3,K)+CC(M,IC-1,2,K))
     1      +TR11*(CC(M,I-1,5,K)+CC(M,IC-1,4,K)))-(TI12*(CC(M,I,3,K)
     1      +CC(M,IC,2,K))-TI11*(CC(M,I,5,K)+CC(M,IC,4,K))))
            CH(M,I-1,K,4) = WA3(I-2)
     1      *((CC(M,I-1,1,K)+TR12*(CC(M,I-1,3,K)+CC(M,IC-1,2,K))
     1      +TR11*(CC(M,I-1,5,K)+CC(M,IC-1,4,K)))+(TI12*(CC(M,I,3,K)
     1      +CC(M,IC,2,K))-TI11*(CC(M,I,5,K)+CC(M,IC,4,K))))
     1      -WA3(I-1)
     1     *((CC(M,I,1,K)+TR12*(CC(M,I,3,K)-
     1      CC(M,IC,2,K))+TR11*(CC(M,I,5,K)-CC(M,IC,4,K)))
     1      -(TI12*(CC(M,I-1,3,K)-CC(M,IC-1,2,K))-TI11
     1      *(CC(M,I-1,5,K)-CC(M,IC-1,4,K))))
            CH(M,I,K,4) = WA3(I-2)
     1     *((CC(M,I,1,K)+TR12*(CC(M,I,3,K)-
     1      CC(M,IC,2,K))+TR11*(CC(M,I,5,K)-CC(M,IC,4,K)))
     1      -(TI12*(CC(M,I-1,3,K)-CC(M,IC-1,2,K))-TI11
     1      *(CC(M,I-1,5,K)-CC(M,IC-1,4,K))))
     1      +WA3(I-1)
     1      *((CC(M,I-1,1,K)+TR12*(CC(M,I-1,3,K)+CC(M,IC-1,2,K))
     1      +TR11*(CC(M,I-1,5,K)+CC(M,IC-1,4,K)))+(TI12*(CC(M,I,3,K)
     1      +CC(M,IC,2,K))-TI11*(CC(M,I,5,K)+CC(M,IC,4,K))))
            CH(M,I-1,K,5) = WA4(I-2)
     1      *((CC(M,I-1,1,K)+TR11*(CC(M,I-1,3,K)+CC(M,IC-1,2,K))
     1      +TR12*(CC(M,I-1,5,K)+CC(M,IC-1,4,K)))+(TI11*(CC(M,I,3,K)
     1      +CC(M,IC,2,K))+TI12*(CC(M,I,5,K)+CC(M,IC,4,K))))
     1      -WA4(I-1)
     1      *((CC(M,I,1,K)+TR11*(CC(M,I,3,K)-CC(M,IC,2,K))
     1      +TR12*(CC(M,I,5,K)-CC(M,IC,4,K)))-(TI11*(CC(M,I-1,3,K)
     1      -CC(M,IC-1,2,K))+TI12*(CC(M,I-1,5,K)-CC(M,IC-1,4,K))))
            CH(M,I,K,5) = WA4(I-2)
     1      *((CC(M,I,1,K)+TR11*(CC(M,I,3,K)-CC(M,IC,2,K))
     1      +TR12*(CC(M,I,5,K)-CC(M,IC,4,K)))-(TI11*(CC(M,I-1,3,K)
     1      -CC(M,IC-1,2,K))+TI12*(CC(M,I-1,5,K)-CC(M,IC-1,4,K))))
     1      +WA4(I-1)
     1      *((CC(M,I-1,1,K)+TR11*(CC(M,I-1,3,K)+CC(M,IC-1,2,K))
     1      +TR12*(CC(M,I-1,5,K)+CC(M,IC-1,4,K)))+(TI11*(CC(M,I,3,K)
     1      +CC(M,IC,2,K))+TI12*(CC(M,I,5,K)+CC(M,IC,4,K))))
 1002          CONTINUE
  102    CONTINUE
  103 CONTINUE
      RETURN
      END SUBROUTINE VRADB5

      SUBROUTINE VRADBG (MP,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
     *                 MDIMC,WA)
      DIMENSION    CH(MDIMC,IDO,L1,IP)    ,CC(MDIMC,IDO,IP,L1) ,
     1           C1(MDIMC,IDO,L1,IP)     ,C2(MDIMC,IDL1,IP),
     2                CH2(MDIMC,IDL1,IP)       ,WA(IDO)
      TPI=2.*PIMACHNEW(1.0)
      ARG = TPI/FLOAT(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IF (IDO .LT. L1) GO TO 103
      DO 102 K=1,L1
         DO 101 I=1,IDO
            DO 1001 M=1,MP
            CH(M,I,K,1) = CC(M,I,1,K)
 1001       CONTINUE
  101    CONTINUE
  102 CONTINUE
      GO TO 106
  103 DO 105 I=1,IDO
         DO 104 K=1,L1
            DO 1004 M=1,MP
            CH(M,I,K,1) = CC(M,I,1,K)
 1004       CONTINUE
  104    CONTINUE
  105 CONTINUE
  106 DO 108 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 107 K=1,L1
            DO 1007 M=1,MP
            CH(M,1,K,J) = CC(M,IDO,J2-2,K)+CC(M,IDO,J2-2,K)
            CH(M,1,K,JC) = CC(M,1,J2-1,K)+CC(M,1,J2-1,K)
 1007       CONTINUE
  107    CONTINUE
  108 CONTINUE
      IF (IDO .EQ. 1) GO TO 116
      IF (NBD .LT. L1) GO TO 112
      DO 111 J=2,IPPH
         JC = IPP2-J
         DO 110 K=1,L1
            DO 109 I=3,IDO,2
               IC = IDP2-I
               DO 1009 M=1,MP
               CH(M,I-1,K,J) = CC(M,I-1,2*J-1,K)+CC(M,IC-1,2*J-2,K)
               CH(M,I-1,K,JC) = CC(M,I-1,2*J-1,K)-CC(M,IC-1,2*J-2,K)
               CH(M,I,K,J) = CC(M,I,2*J-1,K)-CC(M,IC,2*J-2,K)
               CH(M,I,K,JC) = CC(M,I,2*J-1,K)+CC(M,IC,2*J-2,K)
 1009          CONTINUE
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
      GO TO 116
  112 DO 115 J=2,IPPH
         JC = IPP2-J
         DO 114 I=3,IDO,2
            IC = IDP2-I
            DO 113 K=1,L1
               DO 1013 M=1,MP
               CH(M,I-1,K,J) = CC(M,I-1,2*J-1,K)+CC(M,IC-1,2*J-2,K)
               CH(M,I-1,K,JC) = CC(M,I-1,2*J-1,K)-CC(M,IC-1,2*J-2,K)
               CH(M,I,K,J) = CC(M,I,2*J-1,K)-CC(M,IC,2*J-2,K)
               CH(M,I,K,JC) = CC(M,I,2*J-1,K)+CC(M,IC,2*J-2,K)
 1013          CONTINUE
  113       CONTINUE
  114    CONTINUE
  115 CONTINUE
  116 AR1 = 1.
      AI1 = 0.
      DO 120 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 117 IK=1,IDL1
            DO 1017 M=1,MP
            C2(M,IK,L) = CH2(M,IK,1)+AR1*CH2(M,IK,2)
            C2(M,IK,LC) = AI1*CH2(M,IK,IP)
 1017       CONTINUE
  117    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 119 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 118 IK=1,IDL1
               DO 1018 M=1,MP
               C2(M,IK,L) = C2(M,IK,L)+AR2*CH2(M,IK,J)
               C2(M,IK,LC) = C2(M,IK,LC)+AI2*CH2(M,IK,JC)
 1018          CONTINUE
  118       CONTINUE
  119    CONTINUE
  120 CONTINUE
      DO 122 J=2,IPPH
         DO 121 IK=1,IDL1
            DO 1021 M=1,MP
            CH2(M,IK,1) = CH2(M,IK,1)+CH2(M,IK,J)
 1021       CONTINUE
  121    CONTINUE
  122 CONTINUE
      DO 124 J=2,IPPH
         JC = IPP2-J
         DO 123 K=1,L1
            DO 1023 M=1,MP
            CH(M,1,K,J) = C1(M,1,K,J)-C1(M,1,K,JC)
            CH(M,1,K,JC) = C1(M,1,K,J)+C1(M,1,K,JC)
 1023       CONTINUE
  123    CONTINUE
  124 CONTINUE
      IF (IDO .EQ. 1) GO TO 132
      IF (NBD .LT. L1) GO TO 128
      DO 127 J=2,IPPH
         JC = IPP2-J
         DO 126 K=1,L1
            DO 125 I=3,IDO,2
               DO 1025 M=1,MP
               CH(M,I-1,K,J) = C1(M,I-1,K,J)-C1(M,I,K,JC)
               CH(M,I-1,K,JC) = C1(M,I-1,K,J)+C1(M,I,K,JC)
               CH(M,I,K,J) = C1(M,I,K,J)+C1(M,I-1,K,JC)
               CH(M,I,K,JC) = C1(M,I,K,J)-C1(M,I-1,K,JC)
 1025          CONTINUE
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      GO TO 132
  128 DO 131 J=2,IPPH
         JC = IPP2-J
         DO 130 I=3,IDO,2
            DO 129 K=1,L1
               DO 1029 M=1,MP
               CH(M,I-1,K,J) = C1(M,I-1,K,J)-C1(M,I,K,JC)
               CH(M,I-1,K,JC) = C1(M,I-1,K,J)+C1(M,I,K,JC)
               CH(M,I,K,J) = C1(M,I,K,J)+C1(M,I-1,K,JC)
               CH(M,I,K,JC) = C1(M,I,K,J)-C1(M,I-1,K,JC)
 1029          CONTINUE
  129       CONTINUE
  130    CONTINUE
  131 CONTINUE
  132 CONTINUE
      IF (IDO .EQ. 1) RETURN
      DO 133 IK=1,IDL1
         DO 1033 M=1,MP
         C2(M,IK,1) = CH2(M,IK,1)
 1033    CONTINUE
  133 CONTINUE
      DO 135 J=2,IP
         DO 134 K=1,L1
            DO 1034 M=1,MP
            C1(M,1,K,J) = CH(M,1,K,J)
 1034       CONTINUE
  134    CONTINUE
  135 CONTINUE
      IF (NBD .GT. L1) GO TO 139
      IS = -IDO
      DO 138 J=2,IP
         IS = IS+IDO
         IDIJ = IS
         DO 137 I=3,IDO,2
            IDIJ = IDIJ+2
            DO 136 K=1,L1
               DO 1036 M=1,MP
               C1(M,I-1,K,J) = WA(IDIJ-1)*CH(M,I-1,K,J)-WA(IDIJ)*
     1          CH(M,I,K,J)
               C1(M,I,K,J) = WA(IDIJ-1)*CH(M,I,K,J)+WA(IDIJ)*
     1          CH(M,I-1,K,J)
 1036          CONTINUE
  136       CONTINUE
  137    CONTINUE
  138 CONTINUE
      GO TO 143
  139 IS = -IDO
      DO 142 J=2,IP
         IS = IS+IDO
         DO 141 K=1,L1
            IDIJ = IS
            DO 140 I=3,IDO,2
               IDIJ = IDIJ+2
               DO 1040 M=1,MP
               C1(M,I-1,K,J) = WA(IDIJ-1)*CH(M,I-1,K,J)-WA(IDIJ)*
     1          CH(M,I,K,J)
               C1(M,I,K,J) = WA(IDIJ-1)*CH(M,I,K,J)+WA(IDIJ)*
     1          CH(M,I-1,K,J)
 1040          CONTINUE
  140       CONTINUE
  141    CONTINUE
  142 CONTINUE
  143 RETURN
      END SUBROUTINE VRADBG

      SUBROUTINE VRFTB1 (M,N,C,CH,MDIMC,WA,FAC)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION       CH(MDIMC,N), C(MDIMC,N), WA(N) ,FAC(15)
      NF = FAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = FAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDL1 = IDO*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL VRADB4 (M,IDO,L1,C,CH,MDIMC,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL VRADB4 (M,IDO,L1,CH,C,MDIMC,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL VRADB2 (M,IDO,L1,C,CH,MDIMC,WA(IW))
         GO TO 105
  104    CALL VRADB2 (M,IDO,L1,CH,C,MDIMC,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 107
         CALL VRADB3 (M,IDO,L1,C,CH,MDIMC,WA(IW),WA(IX2))
         GO TO 108
  107    CALL VRADB3 (M,IDO,L1,CH,C,MDIMC,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 110
      CALL VRADB5 (M,IDO,L1,C,CH,MDIMC,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110 CALL VRADB5 (M,IDO,L1,CH,C,MDIMC,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL VRADBG (M,IDO,IP,L1,IDL1,C,C,C,CH,CH,MDIMC,WA(IW))
         GO TO 114
  113    CALL VRADBG (M,IDO,IP,L1,IDL1,CH,CH,CH,C,C,MDIMC,WA(IW))
  114    IF (IDO .EQ. 1) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDO
  116 CONTINUE
      SCALE=SQRT(1./N)
      IF (NA .EQ. 0) GO TO 118
      DO 117 J=1,N
      DO 117 I=1,M
         C(I,J) = SCALE*CH(I,J)
  117 CONTINUE
      RETURN
  118 DO 119 J=1,N
      DO 119 I=1,M
         C(I,J)=SCALE*C(I,J)
  119 CONTINUE
      RETURN
      END SUBROUTINE VRFTB1

C--------------------------------------------------------------------

      SUBROUTINE VRFFTF (M,N,R,RT,MDIMR,WSAVE)
!***BEGIN PROLOGUE  VRFFTF
!***DATE WRITTEN   850801   (YYMMDD)
!***REVISION DATE  900509   (YYMMDD)
!***CATEGORY NO.  J1A1
!***KEYWORDS  FAST FOURIER TRANSFORM, REAL PERIODIC TRANSFORM,
!             FOURIER ANALYSIS, FORWARD TRANSFORM, MULTIPLE SEQUENCES
!***AUTHOR  SWEET, R.A. (NIST) AND LINDGREN, L.L. (NIST)
!***PURPOSE  Forward real periodic transform, M sequences.
!***DESCRIPTION
!
!  Subroutine VRFFTF computes the Fourier coefficients (forward
!  transform) of a number of real periodic sequences.  Specifically,
!  for each sequence the subroutine claculates the independent
!  Fourier coefficients described below at output parameter R.
!
!  The array WSAVE which is used by subroutine VRFFTF must be
!  initialized by calling subroutine VRFFTI(N,WSAVE).
!
!
!  Input Parameters
!
!  M       the number of sequences to be transformed.
!
!  N       the length of the sequences to be transformed.  The method
!          is most efficient when N is a product of small primes,
!          however n may be any positive integer.
!
!  R       areal two-dimensional array of size MDIMX x N containing the
!          the sequences to be transformed.  The sequences are stored
!          in the ROWS of R.  Thus, the I-th sequence to be transformed,
!          X(I,J), J=0,1,...,N-1, is stored as
!
!               R(I,J) = X(I,J-1) , J=1, 2, . . . , N.
!
!  RT      a real two-dimensional work array of size MDIMX x N.
!
!  MDIMR   the row (or first) dimension of the arrays R and RT exactly
!          as they appear in the calling program.  This parameter is
!          used to specify the variable dimension of these arrays.
!
!  WSAVE   a real one-dimensional work array which must be dimensioned
!          at least N+15.  The WSAVE array must be initialized by
!          calling subroutine VRFFTI.  A different WSAVE array must be
!          used for each different value of N.  This initialization does
!          not have to be repeated so long as N remains unchanged.  The
!          same WSAVE array may be used by VRFFTF and VRFFTB.
!
!  Output Parameters
!
!  R       contains the Fourier coefficients F(K) for each of the M
!          input sequences.  Specifically, row I of R, R(I,J),
!          J=1,2,..,N, contains the independent Fourier coefficients
!          F(I,K), for the I-th input sequence stored as
!
!             R(I,1) = REAL( F(I,0) ),
!                    = SQRT(1/N)*SUM(J=0,N-1)[ X(I,J) ],
!
!             R(I,2*K) = REAL( F(I,K) )
!                      = SQRT(1/N)*SUM(J=0,N-1)[X(I,J)*COS(2J*K*PI/N)]
!
!             R(I,2*K+1) = IMAG( F(I,K) )
!                        =-SQRT(1/N)*SUM(J=0,N-1)[X(I,J)*SIN(2J*K*PI/N)]
!
!                   for K = 1, 2, . . . , M-1,
!
!              and, when N is even,
!
!              R(I,N) = REAL( F(I,N/2) ).
!                     = SQRT(1/N)*SUM(J=0,N-1)[ (-1)**J*X(I,J) ].
!
!  WSAVE   contains results which must not be destroyed between calls
!          to VRFFTF or VRFFTB.
!
!  -----------------------------------------------------------------
!
!  NOTE  -  A call of VRFFTF followed immediately by a call of
!           of VRFFTB will return the original sequences R.  Thus,
!           VRFFTB is the correctly normalized inverse of VRFFTF.
!
!  -----------------------------------------------------------------
!
!  VRFFTF is a straightforward extension of the subprogram RFFTF to
!  handle M simultaneous sequences.  RFFTF was originally developed
!  by P. N. Swarztrauber of NCAR.
!
!
!              * * * * * * * * * * * * * * * * * * * * *
!              *                                       *
!              *         PROGRAM SPECIFICATIONS        *
!              *                                       *
!              * * * * * * * * * * * * * * * * * * * * *
!
!
!     DIMENSION OF    R(MDIMR,N), RT(MDIMR,N), WSAVE(N+15)
!     ARGUMENTS
!
!     LATEST          AUGUST 1, 1985
!     REVISION
!
!     SUBPROGRAMS     VRFFTI, VRFTI1, VRFFTF, VRFTF1, VRADF2, VRADF3,
!     REQUIRED        VRADF4, VRADF5, VRADFG, VRFFTB, VRFTB1, VRADB2,
!                     VRADB3, VRADB4, VRADB5, VRADBG, PIMACHNEW
!
!     SPECIAL         NONE
!     CONDITIONS
!
!     COMMON          NONE
!     BLOCKS
!
!     I/O             NONE
!
!     PRECISION       SINGLE
!
!     SPECIALIST      ROLAND SWEET
!
!     LANGUAGE        FORTRAN
!
!     HISTORY         WRITTEN BY LINDA LINDGREN AND ROLAND SWEET AT THE
!                     NATIONAL BUREAU OF STANDARDS (BOULDER).
!
!     ALGORITHM       A REAL VARIANT OF THE STOCKHAM AUTOSORT VERSION
!                     OF THE COOLEY-TUKEY FAST FOURIER TRANSFORM.
!
!     PORTABILITY     AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN 77.
!                     THE ONLY MACHINE DEPENDENT CONSTANT IS LOCATED IN
!                     THE FUNCTION PIMACHNEW.
!
!     REQUIRED        COS,SIN
!     RESIDENT
!     ROUTINES
!
!
!***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
!               Computations, (G. Rodrigue, ed.), Academic Press, 1982,
!               pp. 51-83.
!***ROUTINES CALLED  VRFTF1
!***END PROLOGUE  VRFFTF
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION       R(MDIMR,N)  ,RT(MDIMR,N)    ,WSAVE(N+15)
!***FIRST EXECUTABLE STATEMENT  VRFFTF
      IF (N .EQ. 1) RETURN
      CALL VRFTF1 (M,N,R,RT,MDIMR,WSAVE(1),WSAVE(N+1))
      RETURN
      END SUBROUTINE VRFFTF

      SUBROUTINE VRADF2 (MP,IDO,L1,CC,CH,MDIMC,WA1)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION   CH(MDIMC,IDO,2,L1)  ,CC(MDIMC,IDO,L1,2)     ,
     1                WA1(IDO)
      DO 101 K=1,L1
         DO 1001 M=1,MP
         CH(M,1,1,K) = CC(M,1,K,1)+CC(M,1,K,2)
         CH(M,IDO,2,K) = CC(M,1,K,1)-CC(M,1,K,2)
 1001    CONTINUE
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            DO 1003 M=1,MP
            CH(M,I,1,K) = CC(M,I,K,1)+(WA1(I-2)*CC(M,I,K,2)-
     1       WA1(I-1)*CC(M,I-1,K,2))
            CH(M,IC,2,K) = (WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*
     1       CC(M,I-1,K,2))-CC(M,I,K,1)
            CH(M,I-1,1,K) = CC(M,I-1,K,1)+(WA1(I-2)*CC(M,I-1,K,2)+
     1       WA1(I-1)*CC(M,I,K,2))
            CH(M,IC-1,2,K) = CC(M,I-1,K,1)-(WA1(I-2)*CC(M,I-1,K,2)+
     1       WA1(I-1)*CC(M,I,K,2))
 1003       CONTINUE
  103    CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         DO 1006 M=1,MP
         CH(M,1,2,K) = -CC(M,IDO,K,2)
         CH(M,IDO,1,K) = CC(M,IDO,K,1)
 1006    CONTINUE
  106 CONTINUE
  107 RETURN
      END SUBROUTINE VRADF2

      SUBROUTINE VRADF3 (MP,IDO,L1,CC,CH,MDIMC,WA1,WA2)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION   CH(MDIMC,IDO,3,L1)  ,CC(MDIMC,IDO,L1,3)     ,
     1                WA1(IDO)     ,WA2(IDO)
      ARG=2.*PIMACHNEW(1.0)/3.
      TAUR=COS(ARG)
      TAUI=SIN(ARG)
      DO 101 K=1,L1
         DO 1001 M=1,MP
         CH(M,1,1,K) = CC(M,1,K,1)+(CC(M,1,K,2)+CC(M,1,K,3))
         CH(M,1,3,K) = TAUI*(CC(M,1,K,3)-CC(M,1,K,2))
         CH(M,IDO,2,K) = CC(M,1,K,1)+TAUR*
     1      (CC(M,1,K,2)+CC(M,1,K,3))
 1001    CONTINUE
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DO 1002 M=1,MP
            CH(M,I-1,1,K) = CC(M,I-1,K,1)+((WA1(I-2)*CC(M,I-1,K,2)+
     1       WA1(I-1)*CC(M,I,K,2))+(WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*
     1       CC(M,I,K,3)))
            CH(M,I,1,K) = CC(M,I,K,1)+((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*
     1       CC(M,I-1,K,2))+(WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*
     1       CC(M,I-1,K,3)))
            CH(M,I-1,3,K) = (CC(M,I-1,K,1)+TAUR*((WA1(I-2)*
     1       CC(M,I-1,K,2)+WA1(I-1)*CC(M,I,K,2))+(WA2(I-2)*
     1       CC(M,I-1,K,3)+WA2(I-1)*CC(M,I,K,3))))+(TAUI*((WA1(I-2)*
     1       CC(M,I,K,2)-WA1(I-1)*CC(M,I-1,K,2))-(WA2(I-2)*
     1       CC(M,I,K,3)-WA2(I-1)*CC(M,I-1,K,3))))
            CH(M,IC-1,2,K) = (CC(M,I-1,K,1)+TAUR*((WA1(I-2)*
     1       CC(M,I-1,K,2)+WA1(I-1)*CC(M,I,K,2))+(WA2(I-2)*
     1       CC(M,I-1,K,3)+WA2(I-1)*CC(M,I,K,3))))-(TAUI*((WA1(I-2)*
     1       CC(M,I,K,2)-WA1(I-1)*CC(M,I-1,K,2))-(WA2(I-2)*
     1       CC(M,I,K,3)-WA2(I-1)*CC(M,I-1,K,3))))
            CH(M,I,3,K) = (CC(M,I,K,1)+TAUR*((WA1(I-2)*CC(M,I,K,2)-
     1       WA1(I-1)*CC(M,I-1,K,2))+(WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*
     1       CC(M,I-1,K,3))))+(TAUI*((WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*
     1       CC(M,I,K,3))-(WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*
     1       CC(M,I,K,2))))
            CH(M,IC,2,K) = (TAUI*((WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*
     1       CC(M,I,K,3))-(WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*
     1       CC(M,I,K,2))))-(CC(M,I,K,1)+TAUR*((WA1(I-2)*CC(M,I,K,2)-
     1       WA1(I-1)*CC(M,I-1,K,2))+(WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*
     1       CC(M,I-1,K,3))))
 1002       CONTINUE
  102    CONTINUE
  103 CONTINUE
      RETURN
      END SUBROUTINE VRADF3

      SUBROUTINE VRADF4 (MP,IDO,L1,CC,CH,MDIMC,WA1,WA2,WA3)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION    CC(MDIMC,IDO,L1,4)   ,CH(MDIMC,IDO,4,L1)     ,
     1                WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)
      HSQT2=SQRT(2.)/2.
      DO 101 K=1,L1
         DO 1001 M=1,MP
         CH(M,1,1,K) = (CC(M,1,K,2)+CC(M,1,K,4))
     1      +(CC(M,1,K,1)+CC(M,1,K,3))
         CH(M,IDO,4,K) = (CC(M,1,K,1)+CC(M,1,K,3))
     1      -(CC(M,1,K,2)+CC(M,1,K,4))
         CH(M,IDO,2,K) = CC(M,1,K,1)-CC(M,1,K,3)
         CH(M,1,3,K) = CC(M,1,K,4)-CC(M,1,K,2)
 1001    CONTINUE
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      DO 104 K=1,L1
         DO 103 I=3,IDO,2
            IC = IDP2-I
            DO 1003 M=1,MP
            CH(M,I-1,1,K) = ((WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*
     1       CC(M,I,K,2))+(WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*
     1       CC(M,I,K,4)))+(CC(M,I-1,K,1)+(WA2(I-2)*CC(M,I-1,K,3)+
     1       WA2(I-1)*CC(M,I,K,3)))
            CH(M,IC-1,4,K) = (CC(M,I-1,K,1)+(WA2(I-2)*CC(M,I-1,K,3)+
     1       WA2(I-1)*CC(M,I,K,3)))-((WA1(I-2)*CC(M,I-1,K,2)+
     1       WA1(I-1)*CC(M,I,K,2))+(WA3(I-2)*CC(M,I-1,K,4)+
     1       WA3(I-1)*CC(M,I,K,4)))
            CH(M,I,1,K) = ((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*
     1       CC(M,I-1,K,2))+(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4)))+(CC(M,I,K,1)+(WA2(I-2)*CC(M,I,K,3)-
     1       WA2(I-1)*CC(M,I-1,K,3)))
            CH(M,IC,4,K) = ((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*
     1       CC(M,I-1,K,2))+(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4)))-(CC(M,I,K,1)+(WA2(I-2)*CC(M,I,K,3)-
     1       WA2(I-1)*CC(M,I-1,K,3)))
            CH(M,I-1,3,K) = ((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*
     1       CC(M,I-1,K,2))-(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4)))+(CC(M,I-1,K,1)-(WA2(I-2)*CC(M,I-1,K,3)+
     1       WA2(I-1)*CC(M,I,K,3)))
            CH(M,IC-1,2,K) = (CC(M,I-1,K,1)-(WA2(I-2)*CC(M,I-1,K,3)+
     1       WA2(I-1)*CC(M,I,K,3)))-((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*
     1       CC(M,I-1,K,2))-(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4)))
            CH(M,I,3,K) = ((WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*
     1       CC(M,I,K,4))-(WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*
     1       CC(M,I,K,2)))+(CC(M,I,K,1)-(WA2(I-2)*CC(M,I,K,3)-
     1       WA2(I-1)*CC(M,I-1,K,3)))
            CH(M,IC,2,K) = ((WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*
     1       CC(M,I,K,4))-(WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*
     1       CC(M,I,K,2)))-(CC(M,I,K,1)-(WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*
     1       CC(M,I-1,K,3)))
 1003       CONTINUE
  103    CONTINUE
  104 CONTINUE
      IF (MOD(IDO,2) .EQ. 1) RETURN
  105 CONTINUE
      DO 106 K=1,L1
         DO 1006 M=1,MP
            CH(M,IDO,1,K) = (HSQT2*(CC(M,IDO,K,2)-CC(M,IDO,K,4)))+
     1       CC(M,IDO,K,1)
            CH(M,IDO,3,K) = CC(M,IDO,K,1)-(HSQT2*(CC(M,IDO,K,2)-
     1       CC(M,IDO,K,4)))
            CH(M,1,2,K) = (-HSQT2*(CC(M,IDO,K,2)+CC(M,IDO,K,4)))-
     1       CC(M,IDO,K,3)
            CH(M,1,4,K) = (-HSQT2*(CC(M,IDO,K,2)+CC(M,IDO,K,4)))+
     1       CC(M,IDO,K,3)
 1006    CONTINUE
  106 CONTINUE
  107 RETURN
      END SUBROUTINE VRADF4

      SUBROUTINE VRADF5 (MP,IDO,L1,CC,CH,MDIMC,WA1,WA2,WA3,WA4)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION  CC(MDIMC,IDO,L1,5)    ,CH(MDIMC,IDO,5,L1)     ,
     1           WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)
      ARG=2.*PIMACHNEW(1.0)/5.
      TR11=COS(ARG)
      TI11=SIN(ARG)
      TR12=COS(2.*ARG)
      TI12=SIN(2.*ARG)
      DO 101 K=1,L1
         DO 1001 M=1,MP
         CH(M,1,1,K) = CC(M,1,K,1)+(CC(M,1,K,5)+CC(M,1,K,2))+
     1    (CC(M,1,K,4)+CC(M,1,K,3))
         CH(M,IDO,2,K) = CC(M,1,K,1)+TR11*(CC(M,1,K,5)+CC(M,1,K,2))+
     1    TR12*(CC(M,1,K,4)+CC(M,1,K,3))
         CH(M,1,3,K) = TI11*(CC(M,1,K,5)-CC(M,1,K,2))+TI12*
     1    (CC(M,1,K,4)-CC(M,1,K,3))
         CH(M,IDO,4,K) = CC(M,1,K,1)+TR12*(CC(M,1,K,5)+CC(M,1,K,2))+
     1    TR11*(CC(M,1,K,4)+CC(M,1,K,3))
         CH(M,1,5,K) = TI12*(CC(M,1,K,5)-CC(M,1,K,2))-TI11*
     1    (CC(M,1,K,4)-CC(M,1,K,3))
 1001    CONTINUE
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO 103 K=1,L1
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DO 1002 M=1,MP
            CH(M,I-1,1,K) = CC(M,I-1,K,1)+((WA1(I-2)*CC(M,I-1,K,2)+
     1       WA1(I-1)*CC(M,I,K,2))+(WA4(I-2)*CC(M,I-1,K,5)+WA4(I-1)*
     1       CC(M,I,K,5)))+((WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*
     1       CC(M,I,K,3))+(WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*CC(M,I,K,4)))
            CH(M,I,1,K) = CC(M,I,K,1)+((WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*
     1       CC(M,I-1,K,2))+(WA4(I-2)*CC(M,I,K,5)-WA4(I-1)*
     1       CC(M,I-1,K,5)))+((WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*
     1       CC(M,I-1,K,3))+(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4)))
            CH(M,I-1,3,K) = CC(M,I-1,K,1)+TR11*
     1      ( WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*CC(M,I,K,2)
     1       +WA4(I-2)*CC(M,I-1,K,5)+WA4(I-1)*CC(M,I,K,5))+TR12*
     1      ( WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*CC(M,I,K,3)
     1       +WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*CC(M,I,K,4))+TI11*
     1      ( WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*CC(M,I-1,K,2)
     1       -(WA4(I-2)*CC(M,I,K,5)-WA4(I-1)*CC(M,I-1,K,5)))+TI12*
     1      ( WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*CC(M,I-1,K,3)
     1       -(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*CC(M,I-1,K,4)))
            CH(M,IC-1,2,K) = CC(M,I-1,K,1)+TR11*
     1      ( WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*CC(M,I,K,2)
     1       +WA4(I-2)*CC(M,I-1,K,5)+WA4(I-1)*CC(M,I,K,5))+TR12*
     1     ( WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*CC(M,I,K,3)
     1      +WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*CC(M,I,K,4))-(TI11*
     1      ( WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*CC(M,I-1,K,2)
     1       -(WA4(I-2)*CC(M,I,K,5)-WA4(I-1)*CC(M,I-1,K,5)))+TI12*
     1      ( WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*CC(M,I-1,K,3)
     1       -(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*CC(M,I-1,K,4))))
            CH(M,I,3,K) = (CC(M,I,K,1)+TR11*((WA1(I-2)*CC(M,I,K,2)-
     1       WA1(I-1)*CC(M,I-1,K,2))+(WA4(I-2)*CC(M,I,K,5)-WA4(I-1)*
     1       CC(M,I-1,K,5)))+TR12*((WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*
     1       CC(M,I-1,K,3))+(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4))))+(TI11*((WA4(I-2)*CC(M,I-1,K,5)+
     1       WA4(I-1)*CC(M,I,K,5))-(WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*
     1       CC(M,I,K,2)))+TI12*((WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*
     1       CC(M,I,K,4))-(WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*
     1       CC(M,I,K,3))))
            CH(M,IC,2,K) = (TI11*((WA4(I-2)*CC(M,I-1,K,5)+WA4(I-1)*
     1       CC(M,I,K,5))-(WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*
     1       CC(M,I,K,2)))+TI12*((WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*
     1       CC(M,I,K,4))-(WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*
     1       CC(M,I,K,3))))-(CC(M,I,K,1)+TR11*((WA1(I-2)*CC(M,I,K,2)-
     1       WA1(I-1)*CC(M,I-1,K,2))+(WA4(I-2)*CC(M,I,K,5)-WA4(I-1)*
     1       CC(M,I-1,K,5)))+TR12*((WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*
     1       CC(M,I-1,K,3))+(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4))))
            CH(M,I-1,5,K) = (CC(M,I-1,K,1)+TR12*((WA1(I-2)*
     1       CC(M,I-1,K,2)+WA1(I-1)*CC(M,I,K,2))+(WA4(I-2)*
     1       CC(M,I-1,K,5)+WA4(I-1)*CC(M,I,K,5)))+TR11*((WA2(I-2)*
     1       CC(M,I-1,K,3)+WA2(I-1)*CC(M,I,K,3))+(WA3(I-2)*
     1       CC(M,I-1,K,4)+WA3(I-1)*CC(M,I,K,4))))+(TI12*((WA1(I-2)*
     1       CC(M,I,K,2)-WA1(I-1)*CC(M,I-1,K,2))-(WA4(I-2)*CC(M,I,K,5)-
     1       WA4(I-1)*CC(M,I-1,K,5)))-TI11*((WA2(I-2)*CC(M,I,K,3)-
     1       WA2(I-1)*CC(M,I-1,K,3))-(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4))))
            CH(M,IC-1,4,K) = (CC(M,I-1,K,1)+TR12*((WA1(I-2)*
     1       CC(M,I-1,K,2)+WA1(I-1)*CC(M,I,K,2))+(WA4(I-2)*
     1       CC(M,I-1,K,5)+WA4(I-1)*CC(M,I,K,5)))+TR11*((WA2(I-2)*
     1       CC(M,I-1,K,3)+WA2(I-1)*CC(M,I,K,3))+(WA3(I-2)*
     1       CC(M,I-1,K,4)+WA3(I-1)*CC(M,I,K,4))))-(TI12*((WA1(I-2)*
     1       CC(M,I,K,2)-WA1(I-1)*CC(M,I-1,K,2))-(WA4(I-2)*CC(M,I,K,5)-
     1       WA4(I-1)*CC(M,I-1,K,5)))-TI11*((WA2(I-2)*CC(M,I,K,3)-
     1       WA2(I-1)*CC(M,I-1,K,3))-(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4))))
            CH(M,I,5,K) = (CC(M,I,K,1)+TR12*((WA1(I-2)*CC(M,I,K,2)-
     1       WA1(I-1)*CC(M,I-1,K,2))+(WA4(I-2)*CC(M,I,K,5)-WA4(I-1)*
     1       CC(M,I-1,K,5)))+TR11*((WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*
     1       CC(M,I-1,K,3))+(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4))))+(TI12*((WA4(I-2)*CC(M,I-1,K,5)+
     1       WA4(I-1)*CC(M,I,K,5))-(WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*
     1       CC(M,I,K,2)))-TI11*((WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*
     1       CC(M,I,K,4))-(WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*
     1       CC(M,I,K,3))))
            CH(M,IC,4,K) = (TI12*((WA4(I-2)*CC(M,I-1,K,5)+WA4(I-1)*
     1       CC(M,I,K,5))-(WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*
     1       CC(M,I,K,2)))-TI11*((WA3(I-2)*CC(M,I-1,K,4)+WA3(I-1)*
     1       CC(M,I,K,4))-(WA2(I-2)*CC(M,I-1,K,3)+WA2(I-1)*
     1       CC(M,I,K,3))))-(CC(M,I,K,1)+TR12*((WA1(I-2)*CC(M,I,K,2)-
     1       WA1(I-1)*CC(M,I-1,K,2))+(WA4(I-2)*CC(M,I,K,5)-WA4(I-1)*
     1       CC(M,I-1,K,5)))+TR11*((WA2(I-2)*CC(M,I,K,3)-WA2(I-1)*
     1       CC(M,I-1,K,3))+(WA3(I-2)*CC(M,I,K,4)-WA3(I-1)*
     1       CC(M,I-1,K,4))))
 1002       CONTINUE
  102    CONTINUE
  103 CONTINUE
      RETURN
      END SUBROUTINE VRADF5

      SUBROUTINE VRADFG (MP,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,MDIMC,WA)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION     CH(MDIMC,IDO,L1,IP)   ,CC(MDIMC,IDO,IP,L1)  ,
     1            C1(MDIMC,IDO,L1,IP)    ,C2(MDIMC,IDL1,IP),
     2                CH2(MDIMC,IDL1,IP)           ,WA(IDO)
      TPI=2.*PIMACHNEW(1.0)
      ARG = TPI/FLOAT(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IPPH = (IP+1)/2
      IPP2 = IP+2
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IF (IDO .EQ. 1) GO TO 119
      DO 101 IK=1,IDL1
         DO 1001 M=1,MP
         CH2(M,IK,1) = C2(M,IK,1)
 1001    CONTINUE
  101 CONTINUE
      DO 103 J=2,IP
         DO 102 K=1,L1
            DO 1002 M=1,MP
            CH(M,1,K,J) = C1(M,1,K,J)
 1002       CONTINUE
  102    CONTINUE
  103 CONTINUE
      IF (NBD .GT. L1) GO TO 107
      IS = -IDO
      DO 106 J=2,IP
         IS = IS+IDO
         IDIJ = IS
         DO 105 I=3,IDO,2
            IDIJ = IDIJ+2
            DO 104 K=1,L1
               DO 1004 M=1,MP
               CH(M,I-1,K,J) = WA(IDIJ-1)*C1(M,I-1,K,J)+WA(IDIJ)
     1           *C1(M,I,K,J)
               CH(M,I,K,J) = WA(IDIJ-1)*C1(M,I,K,J)-WA(IDIJ)
     1           *C1(M,I-1,K,J)
 1004          CONTINUE
  104       CONTINUE
  105    CONTINUE
  106 CONTINUE
      GO TO 111
  107 IS = -IDO
      DO 110 J=2,IP
         IS = IS+IDO
         DO 109 K=1,L1
            IDIJ = IS
            DO 108 I=3,IDO,2
               IDIJ = IDIJ+2
               DO 1008 M=1,MP
               CH(M,I-1,K,J) = WA(IDIJ-1)*C1(M,I-1,K,J)+WA(IDIJ)
     1           *C1(M,I,K,J)
               CH(M,I,K,J) = WA(IDIJ-1)*C1(M,I,K,J)-WA(IDIJ)
     1           *C1(M,I-1,K,J)
 1008          CONTINUE
  108       CONTINUE
  109    CONTINUE
  110 CONTINUE
  111 IF (NBD .LT. L1) GO TO 115
      DO 114 J=2,IPPH
         JC = IPP2-J
         DO 113 K=1,L1
            DO 112 I=3,IDO,2
               DO 1012 M=1,MP
               C1(M,I-1,K,J) = CH(M,I-1,K,J)+CH(M,I-1,K,JC)
               C1(M,I-1,K,JC) = CH(M,I,K,J)-CH(M,I,K,JC)
               C1(M,I,K,J) = CH(M,I,K,J)+CH(M,I,K,JC)
               C1(M,I,K,JC) = CH(M,I-1,K,JC)-CH(M,I-1,K,J)
 1012          CONTINUE
  112       CONTINUE
  113    CONTINUE
  114 CONTINUE
      GO TO 121
  115 DO 118 J=2,IPPH
         JC = IPP2-J
         DO 117 I=3,IDO,2
            DO 116 K=1,L1
               DO 1016 M=1,MP
               C1(M,I-1,K,J) = CH(M,I-1,K,J)+CH(M,I-1,K,JC)
               C1(M,I-1,K,JC) = CH(M,I,K,J)-CH(M,I,K,JC)
               C1(M,I,K,J) = CH(M,I,K,J)+CH(M,I,K,JC)
               C1(M,I,K,JC) = CH(M,I-1,K,JC)-CH(M,I-1,K,J)
 1016          CONTINUE
  116       CONTINUE
  117    CONTINUE
  118 CONTINUE
      GO TO 121
  119 DO 120 IK=1,IDL1
         DO 1020 M=1,MP
         C2(M,IK,1) = CH2(M,IK,1)
 1020    CONTINUE
  120 CONTINUE
  121 DO 123 J=2,IPPH
         JC = IPP2-J
         DO 122 K=1,L1
            DO 1022 M=1,MP
            C1(M,1,K,J) = CH(M,1,K,J)+CH(M,1,K,JC)
            C1(M,1,K,JC) = CH(M,1,K,JC)-CH(M,1,K,J)
 1022       CONTINUE
  122    CONTINUE
  123 CONTINUE
!
      AR1 = 1.
      AI1 = 0.
      DO 127 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 124 IK=1,IDL1
            DO 1024 M=1,MP
            CH2(M,IK,L) = C2(M,IK,1)+AR1*C2(M,IK,2)
            CH2(M,IK,LC) = AI1*C2(M,IK,IP)
 1024       CONTINUE
  124    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 126 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 125 IK=1,IDL1
               DO 1025 M=1,MP
               CH2(M,IK,L) = CH2(M,IK,L)+AR2*C2(M,IK,J)
               CH2(M,IK,LC) = CH2(M,IK,LC)+AI2*C2(M,IK,JC)
 1025          CONTINUE
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      DO 129 J=2,IPPH
         DO 128 IK=1,IDL1
            DO 1028 M=1,MP
            CH2(M,IK,1) = CH2(M,IK,1)+C2(M,IK,J)
 1028       CONTINUE
  128    CONTINUE
  129 CONTINUE
!
      IF (IDO .LT. L1) GO TO 132
      DO 131 K=1,L1
         DO 130 I=1,IDO
            DO 1030 M=1,MP
            CC(M,I,1,K) = CH(M,I,K,1)
 1030       CONTINUE
  130    CONTINUE
  131 CONTINUE
      GO TO 135
  132 DO 134 I=1,IDO
         DO 133 K=1,L1
            DO 1033 M=1,MP
            CC(M,I,1,K) = CH(M,I,K,1)
 1033       CONTINUE
  133    CONTINUE
  134 CONTINUE
  135 DO 137 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 136 K=1,L1
            DO 1036 M=1,MP
            CC(M,IDO,J2-2,K) = CH(M,1,K,J)
            CC(M,1,J2-1,K) = CH(M,1,K,JC)
 1036       CONTINUE
  136    CONTINUE
  137 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IF (NBD .LT. L1) GO TO 141
      DO 140 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 139 K=1,L1
            DO 138 I=3,IDO,2
               IC = IDP2-I
               DO 1038 M=1,MP
               CC(M,I-1,J2-1,K) = CH(M,I-1,K,J)+CH(M,I-1,K,JC)
               CC(M,IC-1,J2-2,K) = CH(M,I-1,K,J)-CH(M,I-1,K,JC)
               CC(M,I,J2-1,K) = CH(M,I,K,J)+CH(M,I,K,JC)
               CC(M,IC,J2-2,K) = CH(M,I,K,JC)-CH(M,I,K,J)
 1038          CONTINUE
  138       CONTINUE
  139    CONTINUE
  140 CONTINUE
      RETURN
  141 DO 144 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 143 I=3,IDO,2
            IC = IDP2-I
            DO 142 K=1,L1
               DO 1042 M=1,MP
               CC(M,I-1,J2-1,K) = CH(M,I-1,K,J)+CH(M,I-1,K,JC)
               CC(M,IC-1,J2-2,K) = CH(M,I-1,K,J)-CH(M,I-1,K,JC)
               CC(M,I,J2-1,K) = CH(M,I,K,J)+CH(M,I,K,JC)
               CC(M,IC,J2-2,K) = CH(M,I,K,JC)-CH(M,I,K,J)
 1042          CONTINUE
  142       CONTINUE
  143    CONTINUE
  144 CONTINUE
      RETURN
      END SUBROUTINE VRADFG

      SUBROUTINE VRFTF1 (M,N,C,CH,MDIMC,WA,FAC)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION       CH(MDIMC,N) ,C(MDIMC,N)  ,WA(N)   ,FAC(15)
      NF = FAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1=1,NF
         KH = NF-K1
         IP = FAC(KH+3)
         L1 = L2/IP
         IDO = N/L2
         IDL1 = IDO*L1
         IW = IW-(IP-1)*IDO
         NA = 1-NA
         IF (IP .NE. 4) GO TO 102
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL VRADF4 (M,IDO,L1,C,CH,MDIMC,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  101    CALL VRADF4 (M,IDO,L1,CH,C,MDIMC,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  102    IF (IP .NE. 2) GO TO 104
         IF (NA .NE. 0) GO TO 103
         CALL VRADF2 (M,IDO,L1,C,CH,MDIMC,WA(IW))
         GO TO 110
  103    CALL VRADF2 (M,IDO,L1,CH,C,MDIMC,WA(IW))
         GO TO 110
  104    IF (IP .NE. 3) GO TO 106
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 105
         CALL VRADF3 (M,IDO,L1,C,CH,MDIMC,WA(IW),WA(IX2))
         GO TO 110
  105    CALL VRADF3 (M,IDO,L1,CH,C,MDIMC,WA(IW),WA(IX2))
         GO TO 110
  106    IF (IP .NE. 5) GO TO 108
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 107
      CALL VRADF5(M,IDO,L1,C,CH,MDIMC,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  107 CALL VRADF5 (M,IDO,L1,CH,C,MDIMC,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  108    IF (IDO .EQ. 1) NA = 1-NA
         IF (NA .NE. 0) GO TO 109
         CALL VRADFG (M,IDO,IP,L1,IDL1,C,C,C,CH,CH,MDIMC,WA(IW))
         NA = 1
         GO TO 110
  109    CALL VRADFG (M,IDO,IP,L1,IDL1,CH,CH,CH,C,C,MDIMC,WA(IW))
         NA = 0
  110    L2 = L1
  111 CONTINUE
      SCALE=SQRT(1./N)
      IF (NA .EQ. 1) GO TO 113
      DO 112 J=1,N
      DO 112 I=1,M
         C(I,J) = SCALE*CH(I,J)
  112 CONTINUE
      RETURN
  113 DO 114 J=1,N
      DO 114 I=1,M
         C(I,J)=SCALE*C(I,J)
  114 CONTINUE
      RETURN
      END SUBROUTINE VRFTF1

C--------------------------------------------------------------------

      SUBROUTINE VRFFTI (N,WSAVE)
!***BEGIN PROLOGUE  VRFFTI
!***DATE WRITTEN   860701   (YYMMDD)
!***REVISION DATE  900509   (YYMMDD)
!***CATEGORY NO.  J1A1
!***KEYWORDS  FAST FOURIER TRANSFORM, REAL PERIODIC TRANSFORM,
!             MULTIPLE SEQUENCES
!***AUTHOR  SWEET, R.A. (NIST) AND LINDGREN, L.L. (NIST)
!***PURPOSE  Initialization for VRFFTF and VRFFTB.
!***DESCRIPTION
!
!  Subroutine VRFFTI initializes the array WSAVE which is used in
!  both VRFFTF and VRFFTB.  The prime factorization of N together with
!  a tabulation of certain trigonometric functions are computed and
!  stored in the array WSAVE.
!
!  Input Parameter
!
!  N       the length of the sequence to be transformed.  There is no
!          restriction on N.
!
!  Output Parameter
!
!  WSAVE   a work array which must be dimensioned at least N+15.
!          The same work array can be used for both VRFFTF and VRFFTB
!          as long as N remains unchanged.  Different WSAVE arrays
!          are required for different values of N.  The contents of
!          WSAVE must not be changed between calls of VRFFTF or VRFFTB.
!
!
!              * * * * * * * * * * * * * * * * * * * * *
!              *                                       *
!              *         PROGRAM SPECIFICATIONS        *
!              *                                       *
!              * * * * * * * * * * * * * * * * * * * * *
!
!
!     DIMENSION OF    R(MDIMR,N), RT(MDIMR,N), WSAVE(N+15)
!     ARGUMENTS
!
!     LATEST          AUGUST 1, 1985
!     REVISION
!
!     SUBPROGRAMS     VRFFTI, VRFTI1, VRFFTF, VRFTF1, VRADF2, VRADF3,
!     REQUIRED        VRADF4, VRADF5, VRADFG, VRFFTB, VRFTB1, VRADB2,
!                     VRADB3, VRADB4, VRADB5, VRADBG, PIMACHNEW
!
!     SPECIAL         NONE
!     CONDITIONS
!
!     COMMON          NONE
!     BLOCKS
!
!     I/O             NONE
!
!     PRECISION       SINGLE
!
!     SPECIALIST      ROLAND SWEET
!
!     LANGUAGE        FORTRAN
!
!     HISTORY         WRITTEN BY LINDA LINDGREN AND ROLAND SWEET AT THE
!                     NATIONAL BUREAU OF STANDARDS (BOULDER).
!
!     ALGORITHM       A REAL VARIANT OF THE STOCKHAM AUTOSORT VERSION
!                     OF THE COOLEY-TUKEY FAST FOURIER TRANSFORM.
!
!     PORTABILITY     AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN 77.
!                     THE ONLY MACHINE DEPENDENT CONSTANT IS LOCATED IN
!                     THE FUNCTION PIMACHNEW.
!
!     REQUIRED        COS,SIN
!     RESIDENT
!     ROUTINES
!
!
!***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
!               Computations, (G. Rodrigue, ed.), Academic Press, 1982,
!               pp. 51-83.
!***ROUTINES CALLED  VRFTI1
!***END PROLOGUE  VRFFTI
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION       WSAVE(N+15)
!***FIRST EXECUTABLE STATEMENT  VRFFTI
      IF (N .EQ. 1) RETURN
      CALL VRFTI1 (N,WSAVE(1),WSAVE(N+1))
      RETURN
      END SUBROUTINE VRFFTI

      FUNCTION PIMACHNEW(DUM)
!***BEGIN PROLOGUE  PIMACHNEW
!
!     This subprogram supplies the value of the constant PI correct to
!     machine precision where
!
!     PI=3.1415926535897932384626433832795028841971693993751058209749446
!***ROUTINES CALLED  (NONE)
!***END PROLOGUE  PIMACHNEW
!
!***FIRST EXECUTABLE STATEMENT  PIMACHNEW
      PIMACHNEW = 3.1415926535897932
      RETURN
      END FUNCTION PIMACHNEW

      SUBROUTINE VRFTI1 (N,WA,FAC)
!
!     VRFFTPK, VERSION 1, AUGUST 1985
!
      DIMENSION       WA(N)      ,FAC(15)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      FAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         FAC(IB+2) = FAC(IB+1)
  106 CONTINUE
      FAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      FAC(1) = N
      FAC(2) = NF
      TPI = 2.*PIMACHNEW(1.0)
      ARGH = TPI/FLOAT(N)
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 110 K1=1,NFM1
         IP = FAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         DO 109 J=1,IPM
            LD = LD+L1
            I = IS
            ARGLD = FLOAT(LD)*ARGH
            FI = 0.
            DO 108 II=3,IDO,2
               I = I+2
               FI = FI+1.
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IS = IS+IDO
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END SUBROUTINE VRFTI1

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

      SUBROUTINE TRID (MR,A,B,C,Y,D)
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,Y(1)       ,
     1                D(1)
      M = MR
      MM1 = M-1
      Z = 1./B(1)
      D(1) = C(1)*Z
      Y(1) = Y(1)*Z
      DO 101 I=2,MM1
         Z = 1./(B(I)-A(I)*D(I-1))
         D(I) = C(I)*Z
         Y(I) = (Y(I)-A(I)*Y(I-1))*Z
  101 CONTINUE
      Z = B(M)-A(M)*D(MM1)
      IF (Z .NE. 0.) GO TO 102
      Y(M) = 0.
      GO TO 103
  102 Y(M) = (Y(M)-A(M)*Y(MM1))/Z
  103 CONTINUE
      DO 104 IP=1,MM1
         I = M-IP
         Y(I) = Y(I)-D(I)*Y(I+1)
  104 CONTINUE
      RETURN
      END SUBROUTINE TRID


subroutine compute_flux (lo, hi, domlo, domhi, phi, philo, phihi, &
                         fluxx, fxlo, fxhi, fluxy, fylo, fyhi, fluxz, fzlo, fzhi, &
                         dx) bind(C, name="compute_flux")

  use amrex_fort_module, only : amrex_real
  implicit none

  integer lo(3), hi(3), domlo(3), domhi(3)
  integer philo(3), phihi(3), fxlo(3), fxhi(3), fylo(3), fyhi(3), fzlo(3), fzhi(3)
  real(amrex_real), intent(in)    :: phi  (philo(1):phihi(1),philo(2):phihi(2),philo(3):phihi(3))
  real(amrex_real), intent(inout) :: fluxx( fxlo(1): fxhi(1), fxlo(2): fxhi(2), fxlo(3): fxhi(3))
  real(amrex_real), intent(inout) :: fluxy( fylo(1): fyhi(1), fylo(2): fyhi(2), fylo(3): fyhi(3))
  real(amrex_real), intent(inout) :: fluxz( fzlo(1): fzhi(1), fzlo(2): fzhi(2), fzlo(3): fzhi(3))
  real(amrex_real), intent(in)    :: dx(3)

  ! local variables
  integer i,j,k

  ! x-fluxes
  do k = lo(3), hi(3)
  do j = lo(2), hi(2)
  do i = lo(1), hi(1)+1
     fluxx(i,j,k) = ( phi(i,j,k) - phi(i-1,j,k) ) / dx(1)
  end do
  end do
  end do

  ! y-fluxes
  do k = lo(3), hi(3)
  do j = lo(2), hi(2)+1
  do i = lo(1), hi(1)
     fluxy(i,j,k) = ( phi(i,j,k) - phi(i,j-1,k) ) / dx(2)
  end do
  end do
  end do

  ! z-fluxes
  do k = lo(3), hi(3)+1
  do j = lo(2), hi(2)
  do i = lo(1), hi(1)
     fluxz(i,j,k) = ( phi(i,j,k) - phi(i,j,k-1) ) / dx(3)
  end do
  end do
  end do

end subroutine compute_flux

subroutine update_phi (lo, hi, phiold, polo, pohi, phinew, pnlo, pnhi, &
                       fluxx, fxlo, fxhi, fluxy, fylo, fyhi, fluxz, fzlo, fzhi, &
                       dx, dt) bind(C, name="update_phi")

  use amrex_fort_module, only : amrex_real
  implicit none

  integer lo(3), hi(3), polo(3), pohi(3), pnlo(3), pnhi(3), &
       fxlo(3), fxhi(3), fylo(3), fyhi(3), fzlo(3), fzhi(3)
  real(amrex_real), intent(in)    :: phiold(polo(1):pohi(1),polo(2):pohi(2),polo(3):pohi(3))
  real(amrex_real), intent(inout) :: phinew(pnlo(1):pnhi(1),pnlo(2):pnhi(2),pnlo(3):pnhi(3))
  real(amrex_real), intent(in   ) :: fluxx (fxlo(1):fxhi(1),fxlo(2):fxhi(2),fxlo(3):fxhi(3))
  real(amrex_real), intent(in   ) :: fluxy (fylo(1):fyhi(1),fylo(2):fyhi(2),fylo(3):fyhi(3))
  real(amrex_real), intent(in   ) :: fluxz (fzlo(1):fzhi(1),fzlo(2):fzhi(2),fzlo(3):fzhi(3))
  real(amrex_real), intent(in)    :: dx(3)
  real(amrex_real), intent(in)    :: dt

  ! local variables
  integer i,j,k
  real(amrex_real) :: dtdx(3)

  dtdx = dt/dx

  do k = lo(3), hi(3)
  do j = lo(2), hi(2)
  do i = lo(1), hi(1)

     phinew(i,j,k) = phiold(i,j,k) &
          + dtdx(1) * (fluxx(i+1,j  ,k  ) - fluxx(i,j,k)) &
          + dtdx(2) * (fluxy(i  ,j+1,k  ) - fluxy(i,j,k)) &
          + dtdx(3) * (fluxz(i  ,j  ,k+1) - fluxz(i,j,k))

  end do
  end do
  end do

end subroutine update_phi


!======================================================================
      MODULE factorial
!======================================================================
!
!     Compute and store log factorial i, namely
!     GAM(I) = LOG( GAMMA(I-1) ), WHERE GAMMA(I) = FACTORIAL I-1
!
!----------------------------------------------------------------------
         REAL(KIND=8), DIMENSION(100) :: GAM

      CONTAINS
         !================================================================
         SUBROUTINE FACTRL(NFACT)
            !================================================================
            IMPLICIT NONE
            INTEGER, INTENT(IN) :: NFACT
            INTEGER :: I
            REAL(KIND=8) :: X, GAMMA

            GAMMA = 1.d0
            GAM(1) = 0.d0
            DO I = 1, NFACT - 1
               GAMMA = I*GAMMA
               GAM(I + 1) = DLOG(GAMMA)
            END DO
            DO I = NFACT + 1, 100
               X = I - 1
               GAM(I) = GAM(I - 1) + DLOG(X)
            END DO
            RETURN
         END SUBROUTINE FACTRL

      END MODULE factorial


program newton
	use input_parameters
	use calculations
	implicit none
	integer :: i, j ,k
	real(4) :: x(n), y(n),alpha(n),delta_x,p,x_f(m),delta_x_f,y_f(m)
	open(unit=25,file="xy.dat") !contains the x y values calculated from the given function for n pts
	open(unit=43,file="xy_poly.dat") !contains x y values calculated from the interpolated polynomial Pn(x)
	open(unit=16,file="xy_exact.dat") !contains x_f(m) and corrospondin f(x) from exact solution for m points
	x(1)=lb
	x(n)=rb
	x_f(1)=lb
 	x_f(m)=rb
	delta_x=(x(n)-x(1))/(n-1) !calculating delta_x for n points for finding the required degree of polynomial
	delta_x_f=(x_f(m)-x_f(1))/(m-1) !calculatin delta_x for m points for ploting m points

	call calc_xy(x,y,delta_x,n) !calculating x & y coordinates for n number of points

	call calc_xf_yf(x_f,y_f,delta_x_f,m) !calculating x and y for m number of points

  call calc_alpha(x,y,alpha,n) ! calculating the coeficients for newton interpolation

	call calc_poly(x,x_f,alpha,p,n,m) !this subroutine will calculate y=f(x) from nth value polynomial for x_f(m) number of points

	close(25)
	close(43)
	close(16)

	print*, "Interpolation Completed"

end program newton


program main
    integer :: i, n, clock
    integer, allocatable :: seed(:)
    integer :: n_in = 0, n_tot = 100000000
    real(8), parameter :: l = 0.d0, r = 1.d0, b = -1.d0, t = 2.d0
    real(8) :: x, y, y_real
    real(8) :: integral

    call SYSTEM_CLOCK(clock)
    call RANDOM_SEED(size = n)
    allocate(seed(n))
    do i = 1, n
        seed(i) = clock + 37 * i
    end do
    call RANDOM_SEED(PUT = seed)
    deallocate(seed)

    do i = 1, n_tot
        call RANDOM_NUMBER(x)
        x = x * (r - l) + l
        call RANDOM_NUMBER(y)
        y = y * (t - b) + b
        call func(x, y_real)
        if (y < y_real) then
            n_in = n_in + 1
        end if
    end do

    integral = (t - b) * (r - l) * dble(n_in) / dble(n_tot) + b * (r - l)
    write(*,'(f10.5)') integral
end program main

subroutine func(x, y)
    ! the function to be integrated
    implicit none
    real(8), intent(in) :: x
    real(8), intent(out) :: y

    y = x**2
end subroutine func


module diag_from_stencil_module
    contains
        function stdiag(n, s, err)
            implicit none
            ! dimension of returned stdiag
            integer(4), intent(in) :: n
            ! stencil vector
            real(8), dimension(:), intent(in) :: s
            ! errornumber
            integer(4), intent(out) :: err

            ! result
            real(8), dimension(n, n) :: stdiag
            real(8), dimension(n*n) :: tmp
            ! size of s, middle index, size of tmp
            integer(4) :: l, m, nn
            ! loop indices
            integer(4) :: i, k

            stdiag = 0
            l = size(s)
            ! checking conditions
            if (mod(l, 2) == 0) then
                err = -1
                return
            else if (n <= l/2) then
                err = -2
                return
            end if
            err = 0
            ! if s contains one element, return diag(s(1))
            if (l == 1) then
                do i=1, n
                    stdiag(i, i) = s(1)
                end do
                return
            end if

            tmp = 0
            nn = size(tmp)
            m = (l-1) / 2
            k = 0
            ! fill upper and lower elements of stdiag with slices of s
            do i = 1, n*m, n
                tmp(i : i+m+k) = s(m+1-k : l)           ! upper
                tmp(nn-i-(m+k) : nn-i) = s(0 : m+1+k)   ! lower
                k = k + 1       ! extend slice of s by 1 for next iter
            end do
            ! fill rest of stdiag with copies of s along the diagonal
            do i = n*m+1, n*(n-m), n+1
                tmp(i:i+l) = s
            end do

            stdiag = reshape(tmp, [n, n])
        end function stdiag

end module diag_from_stencil_module

program test
    use diag_from_stencil_module, only: stdiag

    implicit none

    character(len=16) :: fmtstr
    integer(4) :: n
    integer(4) :: err
    real(8), dimension(5) :: s
    real(8), dimension(10, 10) :: a
    real(8), dimension(1) :: e
    real(8), dimension(10, 10) :: b
    n = 10

    write(fmtstr, '(A, I4, A, F3.1, A)') '(', n, '(2X,F', 4.0, '))'
    fmtstr = '(10(2X, F4.0))'
    s = [-1, -8, 0, 8, 1]
    a = stdiag(n, s, err)
    e = [6]
    b = stdiag(n, e, err)
    write(*, *) 'a = '
    write(*, fmtstr) a
    write(*, *) ''
    write(*, *) 'b = '
    write(*, fmtstr) b
end program


! testfunction for spline tf(x, m)
!           1. derivative tfp(x, m)
!           2. derivative tfpp(x, m)
!           3. derivative tfppp(x, m)

FUNCTION tf(x,m)
!
! calculate testfunction for spline tf(x, m)
!
!-----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------

  USE inter_precision

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

  IMPLICIT NONE

  REAL(DP), INTENT(IN) :: x
  REAL(DP), INTENT(IN) :: m
  REAL(DP)             :: tf

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

  IF (m .NE. 0.0D0) THEN
     IF (x == 0.0D0) THEN
        tf = 0.0D0
     ELSE
        tf = x**m
     END IF
  ELSE
     tf = 1.0D0
  END IF

END FUNCTION tf

FUNCTION tfp(x,m)
!
! calculate 1. derivative of testfunction for spline tfp(x, m)
!
!-----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------

  USE inter_precision

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

  IMPLICIT NONE

  REAL(DP), INTENT(IN) :: x
  REAL(DP), INTENT(IN) :: m
  REAL(DP)             :: tfp

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

  IF ((m - 1.0D0) .NE. 0.0D0) THEN
     IF (x == 0.0D0) THEN
        tfp = 0.0D0
     ELSE
        tfp = m * x**(m-1.0D0)
     END IF
  ELSE
     tfp = 1.0D0
  END IF

END FUNCTION tfp

FUNCTION tfpp(x,m)
!
! calculate 2. derivative of testfunction for spline tfpp(x, m)
!
!-----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------

  USE inter_precision

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

  IMPLICIT NONE

  REAL(DP), INTENT(IN) :: x
  REAL(DP), INTENT(IN) :: m
  REAL(DP)             :: tfpp

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

  IF ((m - 2.0D0) .NE. 0.0D0) THEN
     IF (x == 0.0D0) THEN
        tfpp = 0.0D0
     ELSE
        tfpp = m * (m - 1.0D0) * x**(m-2.0D0)
     END IF
  ELSE
     tfpp = 1.0D0
  END IF

END FUNCTION tfpp

FUNCTION tfppp(x,m)
!
! calculate 3. derivative of testfunction for spline tfppp(x, m)
!
!-----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------

  USE inter_precision

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

  IMPLICIT NONE

  REAL(DP), INTENT(IN) :: x
  REAL(DP), INTENT(IN) :: m
  REAL(DP)             :: tfppp

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

  IF ((m - 3.0D0) .NE. 0.0D0) THEN
     IF (x == 0.0D0) THEN
        tfppp = 0.0D0
     ELSE
        tfppp = m * (m - 1.0D0) * (m - 2.0D0) * x**(m-3.0D0)
     END IF
  ELSE
     tfppp = 1.0D0
  END IF

END FUNCTION tfppp

FUNCTION tfone(x,m)
! calculate testfunction for spline tf(x, m); here just 1
!-----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------
  USE inter_precision
!-----------------------------------------------------------------------
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: x
  REAL(DP), INTENT(IN) :: m
  REAL(DP)             :: tfone
!-----------------------------------------------------------------------
  tfone = 1.0D0
END FUNCTION tfone
FUNCTION tfzero(x,m)
! calculate testfunction for spline tf(x, m); here just 1
!-----------------------------------------------------------------------
! Modules
!-----------------------------------------------------------------------
  USE inter_precision
!-----------------------------------------------------------------------
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: x
  REAL(DP), INTENT(IN) :: m
  REAL(DP)             :: tfzero
!-----------------------------------------------------------------------
  tfzero = 0.0D0
END FUNCTION tfzero


program float_prec
use,intrinsic:: iso_fortran_env, stderr=>error_unit
implicit none (type, external)

real(real32) :: pi32 = 4*atan(1.0_real32)
real(real64) :: pi64 = 4*atan(1.0_real64)
real(real128) :: pi128 = 4*atan(1.0_real128)

print *,compiler_version()

if (storage_size(pi64) /= 64) then
  write(stderr,*) 'expected real64 but you have real bits: ', storage_size(pi64)
  error stop
endif
print *,'64-bit PI',pi64

if (storage_size(pi32) /= 32) then
  write(stderr,*) 'expected real32 but you have real bits: ', storage_size(pi32)
  error stop
endif
print *,'32-bit PI',pi32

if (storage_size(pi128) /= 128) then
  write(stderr,*) 'expected real128 but you have real bits: ', storage_size(pi128)
  error stop
endif
print *,'128-bit PI',pi128

! output should be:
! 32-bit PI   3.14159274
! 64-bit PI   3.1415926535897931
! 128-bit PI   3.14159265358979323846264338327950280

! both ifort and gfortran allows "q" to specify real128 literal, "d" to specify real64 literal, and "e" for real32 literal.

! One should use "e" as the separator and a trailing _wp to avoid silent type conflicts

! this line is only true for default real32
print *,'default real32  ',3.14159265358979323846264338327950280 == 3.14159274

end program


real*8 function polynom(m,np,xa,ya,c,x)
  implicit none
  integer, intent(in) :: m     ! which derivative 1,2,.... Here 0 means integral
  integer, intent(in) :: np    ! how many points to use for the polynomial fit
  real(8), intent(in) :: xa(np)!
  real(8), intent(in) :: ya(np)!
  real(8), intent(out):: c(np) ! temporary array
  real(8), intent(in) :: x     ! the value of x at the point we need derivative
  ! local variables
  integer i,j
  real(8) x1,t1,sum
  if (np <= 0) then
     write(6,*)
     write(6,'("Error(polynom): np <= 0 : ",I8)') np
     write(6,*)
     call exit(1)
  end if
  if (m > np) then
     polynom=0.d0
     return
  end if
  x1=xa(1)
  ! find the polynomial coefficients in divided differences form
  c(:)=ya(:)
  do i=2,np
     do j=np,i,-1
        c(j)=(c(j)-c(j-1))/(xa(j)-xa(j+1-i))
     end do
  end do
  ! special case m=0
  if (m.eq.0) then
     sum=c(1)
     t1=1.d0
     do i=2,np
        t1=t1*(x-xa(i-1))
        sum=sum+c(i)*t1
     end do
     polynom=sum
     return
  end if
  ! convert to standard form
  do j=1,np-1
     do i=1,np-j
        c(np-i)=c(np-i)-(xa(np-i-j+1)-x1)*c(np-i+1)
     end do
  end do
  if (m.gt.0) then
     ! take the m'th derivative
     do j=1,m
        do i=m+1,np
           c(i)=c(i)*dble(i-j)
        end do
     end do
     t1=c(np)
     do i=np-1,m+1,-1
        t1=t1*(x-x1)+c(i)
     end do
     polynom=t1
  else
     ! find the integral
     t1=c(np)/dble(np)
     do i=np-1,1,-1
        t1=t1*(x-x1)+c(i)/dble(i)
     end do
     polynom=t1*(x-x1)
  end if
  return
end function polynom

subroutine derv(ucpl,ucl,rr,npt,np)
  REAL*8, intent(out):: ucpl(npt)
  REAL*8, intent(in) :: ucl(npt), rr(npt)
  INTEGER, intent(in):: npt
  INTEGER, intent(in):: np  ! default np=4
  !f2py integer optional, intent(in) :: np=4
  real(8), external :: polynom
  ! locals
  INTEGER :: ir, ir0
  INTEGER :: np_2
  REAL*8  :: c(np)
  np_2 = np/2
  ucpl(1)=0.0d0
  do ir=2,npt
     if(ir <= np_2) then
        ir0 = 1
     elseif(ir > npt-np_2)then
        ir0 = npt-np+1
     else
        ir0 = ir-np_2
     endif
     ucpl(ir) = polynom(1,np,rr(ir0),ucl(ir0),c,rr(ir))
  enddo
end subroutine derv


program test_choose

  implicit none

  write (*, '(i0)') choose (5, 3)

contains

  function factorial (n) result (res)

    implicit none
    integer, intent (in) :: n
    integer :: res
    integer :: i

    res = product ((/(i, i = 1, n)/))

  end function factorial

  function choose (n, k) result (res)

    implicit none
    integer, intent (in) :: n
    integer, intent (in) :: k
    integer :: res

    res = factorial (n) / (factorial (k) * factorial (n - k))

  end function choose

end program test_choose


use FEMSolverClass
implicit none

real(real64),allocatable :: K(:,:), M(:,:),eigen_vector(:),eigen_value(:),&
x(:,:),eigen_vectors(:,:),lambda_mins(:),sample_mat(:,:),lambda(:),K_sp_val(:),&
bvec(:),new_vector(:),new_matrix(:,:)
real(real64)::lambda_min
integer(int32),allocatable :: K_sp_col(:),K_sp_rowptr(:)
integer(int32) :: i
type(FEMSolver_) :: FEMSolver
type(Random_) :: random

K = zeros(5,5)
M = eye(5,5)

K(1,:) = [2.0d0, 2.0d0, 0.0d0,0.0d0,0.0d0]
K(2,:) = [2.0d0, 4.0d0, 2.0d0,0.0d0,0.0d0]
K(3,:) = [0.0d0, 2.0d0, 4.0d0,2.0d0,0.0d0]
K(4,:) = [0.0d0, 0.0d0, 2.0d0,4.0d0,2.0d0]
K(5,:) = [0.0d0, 0.0d0, 0.0d0,2.0d0,1.0d0]

call to_CRS(K,K_sp_val,K_sp_col,K_sp_rowptr)

lambda_mins = zeros(1)
eigen_vectors =  LOBPCG_sparse(K_sp_val,K_sp_col,K_sp_rowptr,lambda_mins)

!eigen_vector =  LOBPCG_dense_single(K,M,lambda_min)

print *, "eigen_value",lambda_mins

print *, "eigen_vector"
call print(eigen_vectors)

!> Ans.
! eigen_value -0.35521847100475296
!eigen_vector
!-0.22020298528984170
! 0.25931306916251190
!-0.34447954900490979
! 0.49082877819227444
!-0.72435373143693627

!> Ans@ Scipy
! [-0.35521838  0.47871512  2.549596    5.122324    7.2045794 ]

! [[ 0.22020283  0.6878815  -0.537812   -0.38525033  0.20166838]
!  [-0.25931296 -0.5232321  -0.1477898  -0.6014385   0.52479976]
!  [ 0.3444794   0.23334298  0.64498943  0.0477451   0.6392136 ]
!  [-0.49082875  0.11239842 -0.3199573   0.6282312   0.49940613]
!  [ 0.72435385 -0.43123636 -0.4129556   0.3047946   0.16097984]]

!Theoretical solution:\lambda_1 = −0.35521847100475...
! plantFEM solution: \lambda_1  = -0.35521847100475296
! scipy solution:    \lambda_1  = -0.35521838

end


program main

  use iso_fortran_env     , only : dp => REAL64
  use matrix_utils        , only : toepliz, print
  use direct_linear_solve , only : mgs_qrfactor, cgs_qrfactor, &
       & householder, banded_householder, householder_factorization
  use direct_linear_solve , only : givens_factorization, givens, qriteration
  use linear_algebra      , only : eigvals, svdvals

  implicit none

  real(dp), parameter :: lambda = 2.0d0
  integer , parameter :: npts = 5
  real(8) , allocatable, dimension(:,:) :: A, Q, R, D, U

  integer  :: i
  real(dp) :: h

  allocate(A(npts,npts))
  allocate(Q(npts,npts))
  allocate(R(npts,npts))
  allocate(D(npts,npts))
  allocate(U(npts,npts))

  call assemble_matrix(0.0d0, 1.0d0, npts, lambda, A)
  call qriteration(A, R, Q, 100, 1.0d-3)

  stop

  print *, 'Performing Givens Transformation'
  Q = 0
  R = 0
  call givens_factorization(A, Q, R)
  print *, 'matrix'
  call print(A)

  print *, 'Q'
  call print(Q)

  print *, 'R'
  call print(R)

  ! Check similarity with A
  print *, 'consistency A'
  D = matmul(Q, R)
  print *, norm2(A - D)

  ! Check Orthogonality
  D = matmul(Q,transpose(Q))
  print *, 'orthogonality Q'
  do i = 1, npts
     D(i,i) = 1.0d0 - D(i,i)
  end do
  print *, norm2(D)

  deallocate(A,Q,R,D)

contains

  ! Model problem to solve
  subroutine assemble_matrix(a, b, npts, lambda, V)

    real(8), intent(in)  :: a, b ! bound of domain
    integer              :: npts ! number of points
    real(8), intent(out) :: V(npts,npts)
    real(8), intent(in)  :: lambda
    real(8), parameter   :: PI = 3.141592653589793d0
    integer              :: m, n, i, j

    h = (b-a)/dble(npts+1)
    V = 0.0d0

    m = npts
    n = npts
    do i = 1, m
       do j = 1, n
          if (i .eq. j-1) then
             V(i,j) = -1.0d0
          else if (i .eq. j+1) then
             V(i,j) = -1.0d0
          else if (i .eq. j) then
             V(i,i) = 2.0d0 + lambda*h*h
          else
             ! skip zeros
          end if
       end do
    end do

  end subroutine assemble_matrix

end program main