      SUBROUTINE VSINT(M,N,X,XT,MDIMX,WSAVE)
*
* $Id$
*
      implicit double precision (a-h, o-z)
C***BEGIN PROLOGUE  VSINT
C***DATE WRITTEN   860701   (YYMMDD)
C***REVISION DATE  900509   (YYMMDD)
C***CATEGORY NO.  J1A3
c***KEYWORDS  FAST FOURIER TRANSFORM, SINE TRANSFORM, MULTIPLE
C             SEQUENCES
C***AUTHOR  BOISVERT, R. F., (NIST)
C***PURPOSE  Sine transform of one or more real, odd sequences.
C***DESCRIPTION
C
C  Subroutine VSINT computes the discrete Fourier sine transform
C  of M odd sequences X(J,I), J=1,...,M.  The transform is defined
C  below at output parameter X.
C
C  The array WSAVE which is used by subroutine VSINT must be
C  initialized by calling subroutine VSINTI(N,WSAVE).
C
C  Input Parameters
C
C  M       the number of sequences to be transformed.
C
C  N       the length of the sequence to be transformed.  The method
C          is most efficient when N+1 is the product of small primes.
C
C  X       an array of size at least X(MDIMX,N+1) 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.  The extra column of X is used as work
C          storage.
C
C  XT      a work array of size at least XT(MDIMX,N+1).
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 with dimension at least INT(2.5*N+15)
C          in the program that calls VSINT.  The WSAVE array must be
C          initialized by calling subroutine VSINTI(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(J,I)= the sum from k=1 to k=N
C
C                    2*X(J,K)*SIN(K*I*PI/(N+1))/SQRT(2*(N+1))
C
C  WSAVE   contains initialization calculations which must not be
C          destroyed between calls of VSINT.
C
C  -----------------------------------------------------------------
C
C  NOTE  -  A call of VSINT followed immediately by another call
C           of VSINT will return the original sequences X.  Thus,
C           VSINT is the correctly normalized inverse of itself.
C
C  -----------------------------------------------------------------
C
C  VSINT is a straightforward extension of the subprogram SINT to
C  handle M simultaneous sequences.  The scaling of the sequences
C  computed by VSINT is different than that of SINT.  SINT was
C  originally developed 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  VRFFTF
C***END PROLOGUE  VSINT
      DIMENSION       X(MDIMX,*), XT(MDIMX,*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  SINT
      IF (M .LE. 0)  GO TO 900
      IF (N .LE. 1)  GO TO 900
      IF (N .GT. 2)  GO TO 300
C
C  CASE   N = 2
C
      SQRTH = SQRT(0.50d0)
      DO 201 J=1,M
         XH = SQRTH*(X(J,1)+X(J,2))
         X(J,2) = SQRTH*(X(J,1)-X(J,2))
         X(J,1) = XH
  201 CONTINUE
      GO TO 900
C
C  CASE   N .GT. 2
C
C     ... PREPROCESSING
C
  300 CONTINUE
      NP1 = N+1
      NS2 = N/2
      DO 301 J=1,M
         XT(J,1) = 0.0d0
  301 CONTINUE
      DO 310 K=1,NS2
         KC = NP1-K
         DO 310 J=1,M
            T1 = X(J,K)-X(J,KC)
            T2 = WSAVE(K)*(X(J,K)+X(J,KC))
            XT(J,K+1) = T1+T2
            XT(J,KC+1) = T2-T1
  310 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .NE. 0) THEN
         DO 320 J=1,M
            XT(J,NS2+2) = 4.0d0*X(J,NS2+1)
  320    CONTINUE
      ENDIF
C
C     ... REAL PERIODIC TRANSFORM
C
      NF = NS2+1
      CALL VRFFTF(M,NP1,XT,X,MDIMX,WSAVE(NF))
C
C     ... POSTPROCESSING
C
      DO 330 J=1,M
         X(J,1) = 0.5d0*XT(J,1)
  330 CONTINUE
      DO 350 I=3,N,2
         DO 340 J=1,M
            X(J,I-1) = -XT(J,I)
  340    CONTINUE
         DO 345 J=1,M
            X(J,I) = X(J,I-2)+XT(J,I-1)
  345    CONTINUE
  350 CONTINUE
      IF (MODN .EQ. 0) THEN
         DO 360 J=1,M
            X(J,N) = -XT(J,N+1)
  360    CONTINUE
      ENDIF
C
C     ... NORMALIZATION
C
      SCALE = SQRT(0.5d0)
      DO 370 I=1,N
         DO 370 J=1,M
            X(J,I) = SCALE*X(J,I)
  370 CONTINUE
C
C  EXIT
C
  900 CONTINUE
      RETURN
      END
      FUNCTION PIMACH(DUM)
      implicit double precision (a-h, o-z)
C***BEGIN PROLOGUE  PIMACH
C
C     This subprogram supplies the value of the constant PI correct to
C     machine precision where
C
C     PI=3.1415926535897932384626433832795028841971693993751058209749446
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  PIMACH
C
C***FIRST EXECUTABLE STATEMENT  PIMACH
      PIMACH=3.1415926535897932d0
      RETURN
      END
      SUBROUTINE VRADF2 (MP,IDO,L1,CC,CH,MDIMC,WA1)
      implicit double precision (a-h, o-z)
C
C     VRFFTPK, VERSION 1, AUGUST 1985
C
      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
               cc1 = (WA1(I-2)*CC(M,I,K,2)-WA1(I-1)*CC(M,I-1,K,2))
               CH(M,I,1,K) = CC(M,I,K,1) + cc1
               CH(M,IC,2,K) = cc1 - CC(M,I,K,1)
               cc2 = (WA1(I-2)*CC(M,I-1,K,2)+WA1(I-1)*CC(M,I,K,2))
               CH(M,I-1,1,K) = CC(M,I-1,K,1) + cc2
               CH(M,IC-1,2,K) = CC(M,I-1,K,1)- cc2
 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 VRADF3 (MP,IDO,L1,CC,CH,MDIMC,WA1,WA2)
      implicit double precision (a-h, o-z)
C
C     VRFFTPK, VERSION 1, AUGUST 1985
C
      DIMENSION   CH(MDIMC,IDO,3,L1)  ,CC(MDIMC,IDO,L1,3)     ,
     1     WA1(IDO)     ,WA2(IDO)
      ARG=2.d0*PIMACH(1.0d0)/3.d0
      TAUR=COS(ARG)
      TAUI=SIN(ARG)
      DO 101 K=1,L1
         DO 1001 M=1,MP
            cc23 = (CC(M,1,K,2)+CC(M,1,K,3))
            CH(M,1,1,K) = CC(M,1,K,1)+cc23
            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*cc23
 1001    CONTINUE
 101  CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      DO K=1,L1
         DO I=3,IDO,2
            IC = IDP2-I
            DO M=1,MP
               p1 = WA1(I-1)*CC(M,I,K,2) + WA1(I-2)*CC(M,I-1,K,2)
               p2 = WA2(I-1)*CC(M,I,K,3) + WA2(I-2)*CC(M,I-1,K,3)
               p3 = WA1(I-2)*CC(M,I,K,2) - WA1(I-1)*CC(M,I-1,K,2)
               p4 = WA2(I-2)*CC(M,I,K,3) - WA2(I-1)*CC(M,I-1,K,3)
               p1pp2 = p1 + p2
               p3pp4 = p3 + p4
               tp1pp2 = taur*p1pp2
               tp3pp4 = TAUR*p3pp4
               tp3mp4 = TAUI*(p3-p4)
               tp2mp1 = TAUI*(p2-p1)
               cc12 = CC(M,I-1,K,1)+tp1pp2
               cc34 = CC(M,I,K,1)+tp3pp4
               CH(M,I-1,1,K)  = CC(M,I-1,K,1)+p1pp2
               CH(M,I,1,K)    = CC(M,I,K,1)+p3pp4
               CH(M,I-1,3,K)  = cc12+tp3mp4
               CH(M,IC-1,2,K) = cc12-tp3mp4
               CH(M,I,3,K)    = cc34+tp2mp1
               CH(M,IC,2,K)   = tp2mp1-cc34
            enddo
         enddo
      enddo
      RETURN
      END
      SUBROUTINE VRADF4 (MP,IDO,L1,CC,CH,MDIMC,WA1,WA2,WA3)
      implicit double precision (a-h, o-z)
C
C     VRFFTPK, VERSION 1, AUGUST 1985
C
      DIMENSION    CC(MDIMC,IDO,L1,4)   ,CH(MDIMC,IDO,4,L1)     ,
     1                WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)
      HSQT2=SQRT(2.d0)/2.d0
      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
               p1 = WA1(I-1)*CC(M,I,K,2) + WA1(I-2)*CC(M,I-1,K,2)
               p2 = WA1(I-2)*CC(M,I,K,2) - WA1(I-1)*CC(M,I-1,K,2)
               p3 = WA3(I-2)*CC(M,I,K,4) - WA3(I-1)*CC(M,I-1,K,4)
               p4 = WA3(I-1)*CC(M,I,K,4) + WA3(I-2)*CC(M,I-1,K,4)
               p5 = WA2(I-1)*CC(M,I,K,3) + WA2(I-2)*CC(M,I-1,K,3)
               p6 = WA2(I-2)*CC(M,I,K,3) - WA2(I-1)*CC(M,I-1,K,3)
               p4pp1 = p4 + p1
               p4mp1 = p4 - p1
               p2pp3 = p2 + p3
               p2mp3 = p2 - p3
               cc5 = CC(M,I-1,K,1)+p5
               cc5m= CC(M,I-1,K,1)-p5
               cc6 = CC(M,I,K,1)+p6
               cc6m= CC(M,I,K,1)-p6
               CH(M,I-1,1,K) = p4pp1+cc5
            CH(M,IC-1,4,K) = cc5-p4pp1
            CH(M,I,1,K) = p2pp3+cc6
            CH(M,IC,4,K) = p2pp3-cc6
            CH(M,I-1,3,K) = p2mp3+cc5m
            CH(M,IC-1,2,K) = cc5m-p2mp3
            CH(M,I,3,K) = p4mp1+cc6m
            CH(M,IC,2,K) = p4mp1-cc6m
 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 VRADF5 (MP,IDO,L1,CC,CH,MDIMC,WA1,WA2,WA3,WA4)
      implicit double precision (a-h, o-z)
C
C     VRFFTPK, VERSION 1, AUGUST 1985
C
      DIMENSION  CC(MDIMC,IDO,L1,5)    ,CH(MDIMC,IDO,5,L1)     ,
     1     WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)
      ARG=2.d0*PIMACH(1.0d0)/5.d0
      TR11=COS(ARG)
      TI11=SIN(ARG)
      TR12=COS(2.d0*ARG)
      TI12=SIN(2.d0*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
               p1 = WA1(I-1)*CC(M,I,K,2) + WA1(I-2)*CC(M,I-1,K,2)
               p2 = WA4(I-2)*CC(M,I-1,K,5) + WA4(I-1)*CC(M,I,K,5)
               p3 = WA2(I-1)*CC(M,I,K,3) + WA2(I-2)*CC(M,I-1,K,3)
               p4 = WA3(I-2)*CC(M,I-1,K,4) + WA3(I-1)*CC(M,I,K,4)
               p5 = WA2(I-2)*CC(M,I,K,3) - WA2(I-1)*CC(M,I-1,K,3)
               p6 = WA3(I-2)*CC(M,I,K,4) - WA3(I-1)*CC(M,I-1,K,4)
               p7 = WA1(I-2)*CC(M,I,K,2) - WA1(I-1)*CC(M,I-1,K,2)
               p8 = WA4(I-2)*CC(M,I,K,5) - WA4(I-1)*CC(M,I-1,K,5)
c
               p1pp2 = p1 + p2
               p3pp4 = p3 + p4
               p7pp8 = p7 + p8
               p5pp6 = p5 + p6
               cc7 = TI12*(p5-p6) + TI11*(p7-p8)
               CH(M,I-1,1,K) = CC(M,I-1,K,1)+p1pp2+p3pp4
               CH(M,I,1,K)   = CC(M,I,K,1)+p7pp8+p5pp6
               CH(M,I-1,3,K) = CC(M,I-1,K,1)+TR11*p1pp2+TR12*p3pp4+
     $              cc7
               CH(M,IC-1,2,K) = CC(M,I-1,K,1)+TR11*p1pp2+
     $              TR12*p3pp4-cc7
               cc5 = CC(M,I,K,1)+TR11*p7pp8+TR12*p5pp6
               cc6 = TI11*(p2-p1)+TI12*(p4-p3)
               CH(M,I,3,K) = cc5 + cc6
               CH(M,IC,2,K) = cc6 - cc5
               cc3 = CC(M,I-1,K,1)+TR12*p1pp2+TR11*p3pp4
               cc4 = TI12*(p7-p8)-TI11*(p5-p6)
               CH(M,I-1,5,K)  = cc3 + cc4
               CH(M,IC-1,4,K) = cc3 - cc4
               cc1 = CC(M,I,K,1)+TR12*p7pp8+TR11*p5pp6
               cc2 = TI12*(p2-p1)-TI11*(p4-p3)
               CH(M,I,5,K)  = cc1 + cc2
               CH(M,IC,4,K) = cc2 - cc1
 1002       CONTINUE
 102     CONTINUE
 103  CONTINUE
      RETURN
      END
      SUBROUTINE VRADFG (MP,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,MDIMC,WA)
      implicit double precision (a-h, o-z)
C
C     VRFFTPK, VERSION 1, AUGUST 1985
C
      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.d0*PIMACH(1.0d0)
      ARG = TPI/DBLE(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
C
      AR1 = 1.d0
      AI1 = 0.d0
      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
C
      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 VRFFTF (M,N,R,RT,MDIMR,WSAVE)
      implicit double precision (a-h, o-z)
C***BEGIN PROLOGUE  VRFFTF
C***DATE WRITTEN   850801   (YYMMDD)
C***REVISION DATE  900509   (YYMMDD)
C***CATEGORY NO.  J1A1
C***KEYWORDS  FAST FOURIER TRANSFORM, REAL PERIODIC TRANSFORM,
C             FOURIER ANALYSIS, FORWARD TRANSFORM, MULTIPLE SEQUENCES
C***AUTHOR  SWEET, R.A. (NIST) AND LINDGREN, L.L. (NIST)
C***PURPOSE  Forward real periodic transform, M sequences.
C***DESCRIPTION
C
C  Subroutine VRFFTF computes the Fourier coefficients (forward
C  transform) of a number of real periodic sequences.  Specifically,
C  for each sequence the subroutine claculates the independent
C  Fourier coefficients described below at output parameter R.
C
C  The array WSAVE which is used by subroutine VRFFTF must be
C  initialized by calling subroutine VRFFTI(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          however n may be any positive integer.
C
C  R       areal two-dimensional array of size MDIMX x N containing the
C          the sequences to be transformed.  The sequences are stored
C          in the ROWS of R.  Thus, the I-th sequence to be transformed,
C          X(I,J), J=0,1,...,N-1, is stored as
C
C               R(I,J) = X(I,J-1) , J=1, 2, . . . , N.
C
C  RT      a real two-dimensional work array of size MDIMX x N.
C
C  MDIMR   the row (or first) dimension of the arrays R and RT exactly
C          as they appear in the calling program.  This parameter is
C          used to specify the variable dimension of these arrays.
C
C  WSAVE   a real one-dimensional work array which must be dimensioned
C          at least N+15.  The WSAVE array must be initialized by
C          calling subroutine VRFFTI.  A different WSAVE array must be
C          used for each different value of N.  This initialization does
C          not have to be repeated so long as N remains unchanged.  The
C          same WSAVE array may be used by VRFFTF and VRFFTB.
C
C  Output Parameters
C
C  R       contains the Fourier coefficients F(K) for each of the M
C          input sequences.  Specifically, row I of R, R(I,J),
C          J=1,2,..,N, contains the independent Fourier coefficients
C          F(I,K), for the I-th input sequence stored as
C
C             R(I,1) = DBLE( F(I,0) ),
C                    = SQRT(1/N)*SUM(J=0,N-1)[ X(I,J) ],
C
C             R(I,2*K) = DBLE( F(I,K) )
C                      = SQRT(1/N)*SUM(J=0,N-1)[X(I,J)*COS(2J*K*PI/N)]
C
C             R(I,2*K+1) = IMAG( F(I,K) )
C                        =-SQRT(1/N)*SUM(J=0,N-1)[X(I,J)*SIN(2J*K*PI/N)]
C
C                   for K = 1, 2, . . . , M-1,
C
C              and, when N is even,
C
C              R(I,N) = DBLE( F(I,N/2) ).
C                     = SQRT(1/N)*SUM(J=0,N-1)[ (-1)**J*X(I,J) ].
C
C  WSAVE   contains results which must not be destroyed between calls
C          to VRFFTF or VRFFTB.
C
C  -----------------------------------------------------------------
C
C  NOTE  -  A call of VRFFTF followed immediately by a call of
C           of VRFFTB will return the original sequences R.  Thus,
C           VRFFTB is the correctly normalized inverse of VRFFTF.
C
C  -----------------------------------------------------------------
C
C  VRFFTF is a straightforward extension of the subprogram RFFTF to
C  handle M simultaneous sequences.  RFFTF was originally developed
C  by P. N. Swarztrauber of NCAR.
C
C
C              * * * * * * * * * * * * * * * * * * * * *
C              *                                       *
C              *         PROGRAM SPECIFICATIONS        *
C              *                                       *
C              * * * * * * * * * * * * * * * * * * * * *
C
C
C     DIMENSION OF    R(MDIMR,N), RT(MDIMR,N), WSAVE(N+15)
C     ARGUMENTS
C
C     LATEST          AUGUST 1, 1985
C     REVISION
C
C     SUBPROGRAMS     VRFFTI, VRFTI1, VRFFTF, VRFTF1, VRADF2, VRADF3,
C     REQUIRED        VRADF4, VRADF5, VRADFG, VRFFTB, VRFTB1, VRADB2,
C                     VRADB3, VRADB4, VRADB5, VRADBG, PIMACH
C
C     SPECIAL         NONE
C     CONDITIONS
C
C     COMMON          NONE
C     BLOCKS
C
C     I/O             NONE
C
C     PRECISION       SINGLE
C
C     SPECIALIST      ROLAND SWEET
C
C     LANGUAGE        FORTRAN
C
C     HISTORY         WRITTEN BY LINDA LINDGREN AND ROLAND SWEET AT THE
C                     NATIONAL BUREAU OF STANDARDS (BOULDER).
C
C     ALGORITHM       A REAL VARIANT OF THE STOCKHAM AUTOSORT VERSION
C                     OF THE COOLEY-TUKEY FAST FOURIER TRANSFORM.
C
C     PORTABILITY     AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN 77.
C                     THE ONLY MACHINE DEPENDENT CONSTANT IS LOCATED IN
C                     THE FUNCTION PIMACH.
C
C     REQUIRED        COS,SIN
C     RESIDENT
C     ROUTINES
C
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  VRFTF1
C***END PROLOGUE  VRFFTF
C
C     VRFFTPK, VERSION 1, AUGUST 1985
C
      DIMENSION       R(MDIMR,N)  ,RT(MDIMR,N)    ,WSAVE(N+15)
C***FIRST EXECUTABLE STATEMENT  VRFFTF
      IF (N .EQ. 1) RETURN
      CALL VRFTF1 (M,N,R,RT,MDIMR,WSAVE(1),WSAVE(N+1))
      RETURN
      END
      SUBROUTINE VRFTF1 (M,N,C,CH,MDIMC,WA,FAC)
      implicit double precision (a-h, o-z)
C
C     VRFFTPK, VERSION 1, AUGUST 1985
C
      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.0d0/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 VSINTI(N,WSAVE)
      implicit double precision (a-h, o-z)
C***BEGIN PROLOGUE  VSINTI
C***DATE WRITTEN   860701   (YYMMDD)
C***REVISION DATE  900509   (YYMMDD)
C***CATEGORY NO.  J1A3
c***KEYWORDS  FAST FOURIER TRANSFORM, SINE TRANSFORM, MULTIPLE
C             SEQUENCES
C***AUTHOR  BOISVERT, R. F. (NIST)
C***PURPOSE  Initialize for VSINT.
C***DESCRIPTION
C
C  Subroutine VSINTI initializes the array WSAVE which is used in
C  subroutine SINT.  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 sequence to be transformed.  The method
C          is most efficient when N+1 is a product of small primes.
C
C  Output Parameter
C
C  WSAVE   a work array with at least INT(2.5*N+15) locations.
C          Different WSAVE arrays are required for different values
C          of N.  The contents of WSAVE must not be changed between
C          calls of VSINT.
C
C  -----------------------------------------------------------------
C
C  VSINTI is a straightforward extension of the subprogram SINTI to
C  handle M simultaneous sequences.  SINTI was originally developed
C  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  VRFFTI
C***END PROLOGUE  VSINTI
      DIMENSION       WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  SINTI
      PI = PIMACH(1.0d0)
      IF (N .LE. 1) RETURN
      NP1 = N+1
      NS2 = N/2
      DT = PI/DBLE(NP1)
      KS = 1
      KF = KS+NS2-1
      FK = 0.0d0
      DO 101 K=KS,KF
         FK = FK+1.d0
         WSAVE(K) = 2.d0*SIN(FK*DT)
  101 CONTINUE
      CALL VRFFTI (NP1,WSAVE(KF+1))
      RETURN
      END
      SUBROUTINE VRFFTI (N,WSAVE)
      implicit double precision (a-h, o-z)
C***BEGIN PROLOGUE  VRFFTI
C***DATE WRITTEN   860701   (YYMMDD)
C***REVISION DATE  900509   (YYMMDD)
C***CATEGORY NO.  J1A1
C***KEYWORDS  FAST FOURIER TRANSFORM, REAL PERIODIC TRANSFORM,
C             MULTIPLE SEQUENCES
C***AUTHOR  SWEET, R.A. (NIST) AND LINDGREN, L.L. (NIST)
C***PURPOSE  Initialization for VRFFTF and VRFFTB.
C***DESCRIPTION
C
C  Subroutine VRFFTI initializes the array WSAVE which is used in
C  both VRFFTF and VRFFTB.  The prime factorization of N together with
C  a tabulation of certain trigonometric functions are computed and
C  stored in the array WSAVE.
C
C  Input Parameter
C
C  N       the length of the sequence to be transformed.  There is no
C          restriction on N.
C
C  Output Parameter
C
C  WSAVE   a work array which must be dimensioned at least N+15.
C          The same work array can be used for both VRFFTF and VRFFTB
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 VRFFTF or VRFFTB.
C
C
C              * * * * * * * * * * * * * * * * * * * * *
C              *                                       *
C              *         PROGRAM SPECIFICATIONS        *
C              *                                       *
C              * * * * * * * * * * * * * * * * * * * * *
C
C
C     DIMENSION OF    R(MDIMR,N), RT(MDIMR,N), WSAVE(N+15)
C     ARGUMENTS
C
C     LATEST          AUGUST 1, 1985
C     REVISION
C
C     SUBPROGRAMS     VRFFTI, VRFTI1, VRFFTF, VRFTF1, VRADF2, VRADF3,
C     REQUIRED        VRADF4, VRADF5, VRADFG, VRFFTB, VRFTB1, VRADB2,
C                     VRADB3, VRADB4, VRADB5, VRADBG, PIMACH
C
C     SPECIAL         NONE
C     CONDITIONS
C
C     COMMON          NONE
C     BLOCKS
C
C     I/O             NONE
C
C     PRECISION       SINGLE
C
C     SPECIALIST      ROLAND SWEET
C
C     LANGUAGE        FORTRAN
C
C     HISTORY         WRITTEN BY LINDA LINDGREN AND ROLAND SWEET AT THE
C                     NATIONAL BUREAU OF STANDARDS (BOULDER).
C
C     ALGORITHM       A REAL VARIANT OF THE STOCKHAM AUTOSORT VERSION
C                     OF THE COOLEY-TUKEY FAST FOURIER TRANSFORM.
C
C     PORTABILITY     AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN 77.
C                     THE ONLY MACHINE DEPENDENT CONSTANT IS LOCATED IN
C                     THE FUNCTION PIMACH.
C
C     REQUIRED        COS,SIN
C     RESIDENT
C     ROUTINES
C
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  VRFTI1
C***END PROLOGUE  VRFFTI
C
C     VRFFTPK, VERSION 1, AUGUST 1985
C
      DIMENSION       WSAVE(N+15)
C***FIRST EXECUTABLE STATEMENT  VRFFTI
      IF (N .EQ. 1) RETURN
      CALL VRFTI1 (N,WSAVE(1),WSAVE(N+1))
      RETURN
      END
      SUBROUTINE VRFTI1 (N,WA,FAC)
      implicit double precision (a-h, o-z)
C
C     VRFFTPK, VERSION 1, AUGUST 1985
C
      DIMENSION       WA(N)      ,FAC(15)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
      NTRY = 0
      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.d0*PIMACH(1.0d0)
      ARGH = TPI/DBLE(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 = DBLE(LD)*ARGH
            FI = 0.d0
            DO 108 II=3,IDO,2
               I = I+2
               FI = FI+1.d0
               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 DMFGR (A,M,N,EPS,IRANK,IROW,ICOL)
C
C     DMFGR CALCULATES THE RANK AND LINEARLY INDEPENDENT ROWS AND
C     COLUMNS OF A M BY N MATRIX.  IT EXPRESSES A SUBMATRIX OF
C     MAXIMAL RANK AS A PRODUCT OF TRIANGULAR FACTORS, NONBASIC ROWS
C     IN TERMS OF BASIC ONES AND BASIC VARIABLES IN TERMS OF FREE ONES
C
C     DIMENSIONED DUMMY VARIABLES
C
      DIMENSION A(1),IROW(1),ICOL(1)
      DOUBLE PRECISION A,PIV,HOLD,SAVE
C
C     TEST OF SPECIFIED DIMENSIONS
C
      IF (M) 20,20,10
   10 IF (N) 20,20,40
   20 IRANK = -1
   30 RETURN
C
C     RETURN IN CASE OF FORMAL ERRORS
C
C     INITIALIZE COLUMN INDEX VECTOR
C     SEARCH FIRST PIVOT ELEMENT
C
   40 IRANK = 0
      PIV = 0.D0
      JJ  = 0
      DO 60 J = 1,N
      ICOL(J) = J
      DO 60 I = 1,M
      JJ  = JJ + 1
      HOLD = A(JJ)
      IF (DABS(PIV)-DABS(HOLD)) 50,60,60
   50 PIV = HOLD
      IR  = I
      IC  = J
   60 CONTINUE
C
C     INITIALIZE ROW INDEX VECTOR
C
      DO 70 I = 1,M
   70 IROW(I) = I
C
C     SET UP INTERNAL TOLERANCE
C
      TOL = ABS(EPS*SNGL(PIV))
C
C     INITIALIZE ELIMINATION LOOP
C
      NM = N*M
      DO 210 NCOL = M,NM,M
C
C     TEST FOR FEASIBILITY OF PIVOT ELEMENT
C
      IF (ABS(SNGL(PIV))-TOL) 220,220,90
C
C     UPDATE RANK
C
   90 IRANK = IRANK + 1
C
C     INTERCHANGE ROWS IF NECESSARY
C
      JJ = IR - IRANK
      IF (JJ) 120,120,100
  100 DO 110 J = IRANK,NM,M
      I  = J + JJ
      SAVE = A(J)
      A(J) = A(I)
  110 A(I) = SAVE
C
C     UPDATE ROW INDEX VECTOR
C
      JJ = IROW(IR)
      IROW(IR) = IROW(IRANK)
      IROW(IRANK) = JJ
C
C     INTERCHANGE COLUMNS IF NECESSARY
C
  120 JJ = (IC-IRANK)*M
      IF (JJ) 150,150,130
  130 KK = NCOL
      DO 140 J = 1,M
      I  = KK + JJ
      SAVE  = A(KK)
      A(KK) = A(I)
      KK = KK - 1
  140 A(I) = SAVE
C
C     UPDATE COLUMN INDEX VECTOR
C
      JJ = ICOL(IC)
      ICOL(IC) = ICOL(IRANK)
      ICOL(IRANK) = JJ
  150 KK = IRANK + 1
      MM = IRANK - M
      LL = NCOL  + MM
C
C     TEST FOR LAST ROW
C
      IF (MM) 160,270,270
C
C     TRANSFORM CURRENT SUBMATRIX AND SEARCH NEXT PIVOT
C
  160 JJ   = LL
      SAVE = PIV
      PIV  = 0.D0
      DO 200 J = KK,M
      JJ   = JJ + 1
      HOLD = A(JJ)/SAVE
      A(JJ)= HOLD
      L    = J - IRANK
C
C     TEST FOR LAST COLUMN
C
      IF (IRANK-N) 170,200,200
  170 II = JJ
      DO 190 I = KK,N
      II = II + M
      MM = II - L
      A(II) = A(II) - HOLD*A(MM)
      IF (DABS(A(II))-DABS(PIV)) 190,190,180
  180 PIV = A(II)
      IR  = J
      IC  = I
  190 CONTINUE
  200 CONTINUE
  210 CONTINUE
C
C     SET UP MATRIX EXPRESSING ROW DEPENDENCIES
C
  220 IF (IRANK-1) 30,270,230
  230 IR = LL
      DO 260 J = 2,IRANK
      II = J - 1
      IR = IR - M
      JJ = LL
      DO 250 I = KK,M
      HOLD = 0.D0
      JJ = JJ + 1
      MM = JJ
      IC = IR
      DO 240 L = 1,II
      HOLD = HOLD + A(MM)*A(IC)
      IC = IC - 1
  240 MM = MM - M
  250 A(MM) = A(MM) - HOLD
  260 CONTINUE
C
C     TEST FOR COLUMN REGULARITY
C
  270 IF (N-IRANK) 30,30,280
C
C     SET UP MATRIX EXPRESSING BASIC VARIABLES IN TERMS OF FREE
C     PARAMETERS (HOMOGENEOUS SOLUTION).
C
  280 IR = LL
      KK = LL + M
      DO 320 J = 1,IRANK
      DO 310 I = KK,NM,M
      JJ = IR
      LL = I
      HOLD = 0.D0
      II = J
  290 II = II - 1
      IF (II) 310,310,300
  300 HOLD = HOLD - A(JJ)*A(LL)
      JJ = JJ - M
      LL = LL - 1
      GO TO 290
  310 A(LL) = (HOLD-A(LL))/A(JJ)
  320 IR = IR - 1
      RETURN
      END


C$Procedure      PL2NVC ( Plane to normal vector and constant )

      SUBROUTINE PL2NVC ( PLANE, NORMAL, CONST )

C$ Abstract
C
C     Return a unit normal vector and constant that define a specified
C     plane.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     PLANES
C
C$ Keywords
C
C     GEOMETRY
C     MATH
C     PLANE
C
C$ Declarations

      INTEGER               UBPL
      PARAMETER           ( UBPL    =   4 )

      DOUBLE PRECISION      PLANE  ( UBPL )
      DOUBLE PRECISION      NORMAL (    3 )
      DOUBLE PRECISION      CONST

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     PLANE      I   A SPICELIB plane.
C     NORMAL,
C     CONST      O   A normal vector and constant defining the
C                    geometric plane represented by PLANE.
C
C$ Detailed_Input
C
C     PLANE          is a SPICELIB plane.
C
C$ Detailed_Output
C
C     NORMAL,
C     CONST          are, respectively, a unit normal vector and
C                    constant that define the geometric plane
C                    represented by PLANE.  Let the symbol < a, b >
C                    indicate the inner product of vectors a and b;
C                    then the geometric plane is the set of vectors X
C                    in three-dimensional space that satisfy
C
C                       < X,  NORMAL >  =  CONST.
C
C                    NORMAL is a unit vector.  CONST is the distance of
C                    the plane from the origin;
C
C                       CONST * NORMAL
C
C                    is the closest point in the plane to the origin.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     1)  The input plane MUST have been created by one of the SPICELIB
C         routines
C
C            NVC2PL ( Normal vector and constant to plane )
C            NVP2PL ( Normal vector and point to plane    )
C            PSV2PL ( Point and spanning vectors to plane )
C
C         Otherwise, the results of this routine are unpredictable.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     SPICELIB geometry routines that deal with planes use the `plane'
C     data type to represent input and output planes.  This data type
C     makes the subroutine interfaces simpler and more uniform.
C
C     The SPICELIB routines that produce SPICELIB planes from data that
C     define a plane are:
C
C        NVC2PL ( Normal vector and constant to plane )
C        NVP2PL ( Normal vector and point to plane    )
C        PSV2PL ( Point and spanning vectors to plane )
C
C     The SPICELIB routines that convert SPICELIB planes to data that
C     define a plane are:
C
C        PL2NVC ( Plane to normal vector and constant )
C        PL2NVP ( Plane to normal vector and point    )
C        PL2PSV ( Plane to point and spanning vectors )
C
C$ Examples
C
C     1)  Given a point in a plane and a normal vector, find the
C         distance of the plane from the origin.  We make a
C         `plane' from the point and normal, then convert the
C         plane to a unit normal and constant.  CONST is the distance
C         of the plane from the origin.
C
C            CALL NVP2PL ( NORMAL, POINT,  PLANE )
C            CALL PL2NVC ( PLANE,  NORMAL, CONST )
C
C
C     2)  Apply a linear transformation represented by the matrix M to
C         a plane represented by the normal vector N and the constant C.
C         Find a normal vector and constant for the transformed plane.
C
C            C
C            C     Make a SPICELIB plane from N and C, and then find a
C            C     point in the plane and spanning vectors for the
C            C     plane.  N need not be a unit vector.
C            C
C                  CALL NVC2PL ( N,      C,      PLANE         )
C                  CALL PL2PSV ( PLANE,  POINT,  SPAN1,  SPAN2 )
C
C            C
C            C     Apply the linear transformation to the point and
C            C     spanning vectors.  All we need to do is multiply
C            C     these vectors by M, since for any linear
C            C     transformation T,
C            C
C            C           T ( POINT  +  t1 * SPAN1     +  t2 * SPAN2 )
C            C
C            C        =  T (POINT)  +  t1 * T(SPAN1)  +  t2 * T(SPAN2),
C            C
C            C     which means that T(POINT), T(SPAN1), and T(SPAN2)
C            C     are a point and spanning vectors for the transformed
C            C     plane.
C            C
C                  CALL MXV ( M, POINT, TPOINT )
C                  CALL MXV ( M, SPAN1, TSPAN1 )
C                  CALL MXV ( M, SPAN2, TSPAN2 )
C
C            C
C            C     Make a new SPICELIB plane TPLANE from the
C            C     transformed point and spanning vectors, and find a
C            C     unit normal and constant for this new plane.
C            C
C                  CALL PSV2PL ( TPOINT,  TSPAN1,  TSPAN2,  TPLANE )
C                  CALL PL2NVC ( TPLANE,  TN,      TC              )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     [1] `Calculus and Analytic Geometry', Thomas and Finney.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 01-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     plane to normal vector and constant
C
C-&

C
C     The contents of SPICELIB planes are as follows:
C
C        Elements NMLPOS through NMLPOS + 2 contain a unit normal
C        vector for the plane.
C
C        Element CONPOS contains a constant for the plane;  every point
C        X in the plane satisifies
C
C           < X, PLANE(NMLPOS) >  =  PLANE(CONPOS).
C
C        The plane constant is the distance of the plane from the
C        origin; the normal vector, scaled by the constant, is the
C        closest point in the plane to the origin.
C
C
      INTEGER               NMLPOS
      PARAMETER           ( NMLPOS = 1 )

      INTEGER               CONPOS
      PARAMETER           ( CONPOS = 4 )

C
C     Unpack the plane.
C
      CALL VEQU ( PLANE(NMLPOS), NORMAL )
      CONST   =   PLANE(CONPOS)

      RETURN
      END


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.02.01/03                           *
C  *    TEST TITLE : Behavior of 2D mapping                *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

C  Declare program-specific variables
      REAL       VWWNLM(4), PJVPLM(4), ACT3X3(3,3), EXP3X3(3,3)
      LOGICAL    TRNSEQ
      CHARACTER  MSG*300

      CALL INITGL ('06.02.01/03')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)

      CALL SETMSG ('1 2 11 12 13', '<Evaluate view mapping matrix> '  //
     1             'should return a correct representation for the '  //
     2             'transformation from the view window to the 2D '   //
     3             'projection viewport.')

C  Set 2D mapping parameters:
      VWWNLM(1) = -23.32
      VWWNLM(2) = 3.56E4
      VWWNLM(3) = 2.29
      VWWNLM(4) = 2.295

      PJVPLM(1) = 0.298
      PJVPLM(2) = 0.736
      PJVPLM(3) = 0.22
      PJVPLM(4) = 0.89

C  <Evaluate view mapping matrix> returns act3x3 = actual array
      CALL PEVMM (VWWNLM, PJVPLM, ERRIND, ACT3X3)
      IF (ERRIND .NE. 0) THEN
         CALL FAIL
         WRITE (MSG, '(A,I5)')
     1         'Non-zero error code from PEVMM:', ERRIND
         CALL INMSG (MSG)
         GOTO 666
      ENDIF

C  Compute exp3x3 = expected array
      CALL EEVMM (VWWNLM, PJVPLM, EXP3X3)

C  pass/fail depending on (act3x3 represents same transformation as exp3x3)
      CALL IFPF (TRNSEQ (3, ACT3X3, EXP3X3))

666   CONTINUE
      CALL ENDIT
      END


      SUBROUTINE cumchn(x,df,pnonc,cum,ccum)
C***********************************************************************
C
C     SUBROUTINE CUMCHN(X,DF,PNONC,CUM,CCUM)
C             CUMulative of the Non-central CHi-square distribution
C
C                               Function
C
C     Calculates     the       cumulative      non-central    chi-square
C     distribution, i.e.,  the probability   that  a   random   variable
C     which    follows  the  non-central chi-square  distribution,  with
C     non-centrality  parameter    PNONC  and   continuous  degrees   of
C     freedom DF, is less than or equal to X.
C
C                              Arguments
C
C     X       --> Upper limit of integration of the non-central
C                 chi-square distribution.
C                                                 X is DOUBLE PRECISION
C
C     DF      --> Degrees of freedom of the non-central
C                 chi-square distribution.
C                                                 DF is DOUBLE PRECISION
C
C     PNONC   --> Non-centrality parameter of the non-central
C                 chi-square distribution.
C                                                 PNONC is DOUBLE PRECIS
C
C     CUM <-- Cumulative non-central chi-square distribution.
C                                                 CUM is DOUBLE PRECISIO
C
C     CCUM <-- Compliment of Cumulative non-central chi-square distribut
C                                                 CCUM is DOUBLE PRECISI
C
C
C                                Method
C
C     Uses  formula  26.4.25   of  Abramowitz  and  Stegun, Handbook  of
C     Mathematical    Functions,  US   NBS   (1966)    to calculate  the
C     non-central chi-square.
C
C                                Variables
C
C     EPS     --- Convergence criterion.  The sum stops when a
C                 term is less than EPS*SUM.
C                                                 EPS is DOUBLE PRECISIO
C
C     CCUM <-- Compliment of Cumulative non-central
C              chi-square distribution.
C                                                 CCUM is DOUBLE PRECISI
C
C***********************************************************************
C
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION ccum,cum,df,pnonc,x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION adj,centaj,centwt,chid2,dfd2,eps,lcntaj,lcntwt,
     +                 lfact,pcent,pterm,sum,sumadj,term,wt,xnonc,xx,
     +                 abstol
      INTEGER i,icent
C     ..
C     .. External Functions ..
      DOUBLE PRECISION alngam
      EXTERNAL alngam
C     ..
C     .. External Subroutines ..
      EXTERNAL cumchi
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC dble,exp,int,log
C     ..
C     .. Statement Functions ..
      DOUBLE PRECISION dg
      LOGICAL qsmall
C     ..
C     .. Data statements ..
      DATA eps/1.0D-5/
      DATA abstol/1.0D-300/
C     ..
C     .. Statement Function definitions ..
      qsmall(xx) = .NOT. (sum .GE. abstol .AND. xx .GE. eps*sum)
      dg(i) = df + 2.0D0*dble(i)
C     ..
C
      IF (.NOT. (x.LE.0.0D0)) GO TO 10
      cum = 0.0D0
      ccum = 1.0D0
      RETURN

   10 IF (.NOT. (pnonc.LE.1.0D-10)) GO TO 20
C
C
C     When non-centrality parameter is (essentially) zero,
C     use cumulative chi-square distribution
C
C
      CALL cumchi(x,df,cum,ccum)
      RETURN

   20 xnonc = pnonc/2.0D0
C***********************************************************************
C
C     The following code calcualtes the weight, chi-square, and
C     adjustment term for the central term in the infinite series.
C     The central term is the one in which the poisson weight is
C     greatest.  The adjustment term is the amount that must
C     be subtracted from the chi-square to move up two degrees
C     of freedom.
C
C***********************************************************************
      icent = int(xnonc)
      IF (icent.EQ.0) icent = 1
      chid2 = x/2.0D0
C
C
C     Calculate central weight term
C
C
      lfact = alngam(dble(icent+1))
      lcntwt = -xnonc + icent*log(xnonc) - lfact
      centwt = exp(lcntwt)
C
C
C     Calculate central chi-square
C
C
      CALL cumchi(x,dg(icent),pcent,ccum)
C
C
C     Calculate central adjustment term
C
C
      dfd2 = dg(icent)/2.0D0
      lfact = alngam(1.0D0+dfd2)
      lcntaj = dfd2*log(chid2) - chid2 - lfact
      centaj = exp(lcntaj)
      sum = centwt*pcent
C***********************************************************************
C
C     Sum backwards from the central term towards zero.
C     Quit whenever either
C     (1) the zero term is reached, or
C     (2) the term gets small relative to the sum, or
C
C***********************************************************************
      sumadj = 0.0D0
      adj = centaj
      wt = centwt
      i = icent
C
      GO TO 40

   30 IF (qsmall(term) .OR. i.EQ.0) GO TO 50
   40 dfd2 = dg(i)/2.0D0
C
C
C     Adjust chi-square for two fewer degrees of freedom.
C     The adjusted value ends up in PTERM.
C
C
      adj = adj*dfd2/chid2
      sumadj = sumadj + adj
      pterm = pcent + sumadj
C
C
C     Adjust poisson weight for J decreased by one
C
C
      wt = wt* (i/xnonc)
      term = wt*pterm
      sum = sum + term
      i = i - 1
      GO TO 30

   50 sumadj = centaj
C***********************************************************************
C
C     Now sum forward from the central term towards infinity.
C     Quit when either
C     (1) the term gets small relative to the sum, or
C
C***********************************************************************
      adj = centaj
      wt = centwt
      i = icent
C
      GO TO 70

   60 IF (qsmall(term)) GO TO 80
C
C
C     Update weights for next higher J
C
C
   70 wt = wt* (xnonc/ (i+1))
C
C
C     Calculate PTERM and add term to sum
C
C
      pterm = pcent - sumadj
      term = wt*pterm
      sum = sum + term
C
C
C     Update adjustment term for DF for next iteration
C
C
      i = i + 1
      dfd2 = dg(i)/2.0D0
      adj = adj*chid2/dfd2
      sumadj = sumadj + adj
      GO TO 60

   80 cum = sum
      ccum = 0.5D0 + (0.5D0-cum)
C
      RETURN

      END


module observables
    use types
    use box_pot_parameters
    implicit none
    save
    public gr, normalize, difusion
contains
    subroutine gr(r,g,dr,pbc)
        real(dp), intent(in) :: r(:,:)
        real(dp), intent(inout) :: g(:)
        real(dp), intent(in) :: dr
        logical, intent(in) :: pbc
        real(dp), external :: dnrm2

        ! Local variables
        integer :: i, j, nbin
        real(dp) :: rposij(3), rij

        do i = 1,np-1
            do j = i+1,np
                rposij = r(:,i) - r(:,j)
                if (pbc) then
                    rposij = rposij - boxl*dnint(rposij/boxl)
                end if
                rij = dnrm2( 3,rposij,1 )
                if (rij < rc) then
                    nbin = idnint(rij/dr) + 1
                    if (nbin <= mr) then
                        g(nbin) = g(nbin) + 2.0_dp
                    end if
                end if
            end do
        end do
    end subroutine gr

    subroutine normalize(g,h,r,dr,nprom,filename)
        ! Variables de entrada/salida
        real(dp), intent(inout) :: g(:), h(:), r(:)
        real(dp), intent(in) :: dr
        character(len=*), intent(in) :: filename
        integer, intent(in) :: nprom

        ! Variables locales
        integer :: u, i
        real(dp) :: dv, fnorm, graux, hraux

        open(newunit=u, file=filename, status='unknown')
        write(u,'(3f16.8)') r(1), g(1)

        do i=2,mr
            r(i)=(i-1)*dr
            dv=4.0_dp*pi*r(i)*r(i)*dr
            fnorm=boxl**3.0_dp/( np**2.0_dp * nprom*dv )
            graux=g(i)*fnorm
            hraux=graux-1.0_dp
            g(i)=graux
            h(i)=hraux
            write(u,'(3f16.8)')r(i),graux,hraux
        end do
        close(u)
    end subroutine normalize

    ! This sobroutine computes the mean-square displacement
    subroutine difusion(nprom, cfx, cfy, cfz, wt, ft)
        real(dp), intent(in) :: cfx(:,:), cfy(:,:), cfz(:,:)
        real(dp), intent(inout) :: wt(:), ft(:)
        integer, intent(in):: nprom
        ! Local variables
        integer :: i, j, k
        real(dp) :: dif2, dself, dx, dy, dz, dk, aux, aux2

        !Mean-square displacement and intermediate scattering function
        dk = 6.6_dp
        do i = 1, nprom-1
            dif2 = 0.0_dp
            dself = 0.0_dp
            do j = 1, nprom-i
                do k = 1, np
                    dx = cfx(j+i,k)-cfx(j,k)
                    dy = cfy(j+i,k)-cfy(j,k)
                    dz = cfz(j+i,k)-cfz(j,k)
                    aux = dx*dx + dy*dy + dz*dz
                    dif2 = dif2 + aux
                    aux2 = dk*dsqrt(aux)
                    aux = dsin(aux2)/aux2
                    dself = dself+aux
                end do
            end do
            aux2 = real(np*(nprom-i))
            dif2 = dif2/aux2
            dself = dself/aux2
            wt(i) = wt(i)+dif2
            ft(i) = ft(i)+dself
        end do
    end subroutine difusion
end module observables


c$Id: validityTest.f 1443 2006-10-24 11:21:23Z llh $
      BLOCK DATA validityTestBD
C Keeps the current bounds of the validity interval
C Initial value is ]-infinity, +infinity[
      REAL gmin, gmax
      LOGICAL infmin, infmax
      COMMON /validity_test_common/
     +     gmin, gmax, infmin, infmax
      DATA infmin/.TRUE./
      DATA infmax/.TRUE./
      DATA gmin/-999.99/
      DATA gmax/999.99/
      END

      SUBROUTINE validity_domain_real8(t, td)
C Updates the bounds of the validity interval
C with the new constraint that t keeps its sign.
      real*8 t, td
      real gmin, gmax, temp
      logical infmin, infmax
      COMMON /validity_test_common/
     +     gmin, gmax, infmin, infmax

      if(td .ne. 0.0) then
       temp = -(t/td)
       if ( temp .lt. 0.0 ) then
         if ( infmin ) then
            gmin = temp
            infmin = .FALSE.
         else
            gmin = max(gmin,temp)
         endif
       else
         if ( infmax ) then
            gmax = temp
            infmax = .FALSE.
         else
            gmax = min(gmax,temp)
         endif
       endif
      endif
      end

      SUBROUTINE validity_domain_real4(t, td)
C Updates the bounds of the validity interval
C with the new constraint that t keeps its sign.
      real*4 t, td
      real gmin, gmax, temp
      logical infmin, infmax
      COMMON /validity_test_common/
     +     gmin, gmax, infmin, infmax

      if(td .ne. 0.0) then
       temp = -(t/td)
       if ( temp .lt. 0.0 ) then
         if ( infmin ) then
            gmin = temp
            infmin = .FALSE.
         else
            gmin = max(gmin,temp)
         endif
       else
         if ( infmax ) then
            gmax = temp
            infmax = .FALSE.
         else
            gmax = min(gmax,temp)
         endif
       endif
      endif
      end


  module func
  implicit none
  contains
      subroutine decomplu(a,p,n)
      integer :: n,i,j,k,ik,im,ii,p(n)
      real(kind=8) :: a(n,n),b(n),x(n),s,amax
      do i=1,n
         p(i) = i
      enddo
      do k=1,n
         amax = 0.0
         im = p(k)
         do i=k,n
            ii = p(i)
            do j=1,k-1
               a(ii,k) = a(ii,k) - a(ii,j) * a(p(j),k)
            enddo
            if (abs(a(ii,k)).gt.amax) then
               amax = abs(a(ii,k))
               im = ii
               ik = i
            endif
         enddo
         p(ik) = p(k)
         p(k) = im
         do j=k+1,n
            ik = p(k)
            do i=1,k-1
               a(ik,j) = a(ik,j)-a(ik,i)*a(p(i),j)
            enddo
            a(p(j),k) = a(p(j),k) / a(p(k),k)
         enddo
      enddo
      return
      end
      subroutine solve_lu(a,b,x,p,n)
      integer :: n,i,j,k,p(n)
      real(kind=8) :: a(n,n),x(n),b(n),det
      x(1) = b(p(1))
      do i=2,n
         x(i) = b(p(i))
         do j=1,i-1
            x(i) = x(i) - a(p(i),j) * x(j)
         enddo
      enddo
      det = a(p(n),n)
      x(n) = x(n) / a(p(n),n)
      do i=n-1,1,-1
         do j=i+1,n
            x(i) = x(i) - a(p(i),j) * x(j)
         enddo
         det = det * a(p(i),i)
         x(i) = x(i) / a(p(i),i)
      enddo
      end

      subroutine exchange(x,n,sgn,xmax,sgnmax)
      integer :: n,i1,i2,k
      real(kind=8) :: x(n),sgn,xmax,sgnmax

      if (xmax.lt.x(1)) then
         if (sgn*sgnmax.lt.0) then
            x(1) = xmax
          else
            x(1:n-1) = x(2:n)
            x(n) = xmax
         endif
         return
      endif
      if (xmax.gt.x(n)) then
         if ((-1)**n * sgn*sgnmax.gt.0) then
            x(n) = xmax
          else
            x(2:n) = x(1:n-1)
            x(1) = xmax
         endif
         return
      endif
      i1 = 1
      i2 = n
      do
         if (i2-i1.eq.1) exit
         k = (i1+i2)/2
         if (xmax.lt.x(k)) then
           i2 = k
          else
           i1 = k
         endif
      enddo
      if ((-1)**i1 * sgn*sgnmax.gt.0) then
         x(i1) = xmax
       else
         x(i2) = xmax
      endif
      end subroutine exchange

      subroutine set_matrix(a,b,x,nd,l,n,gama,ini)
      integer :: nd,l,n,i,j,mi,k,ini
      real(kind=8) :: a(nd,nd),b(nd),x(n),gama,pi,h

      if (ini.eq.1) then
         pi = acos(-1.0d0)
         h = pi / n
         do i=1,n
            x(i) = i*h
         enddo
      endif
      a(1,:) = 1.0d0
      a(1,nd) = 0.0d0
      b(1) = 1.0d0
      do i=1,l
         a(i+1,1) = 0.0d0
         a(i+1,nd) = 0.0d0
         do j=1,nd-2
            a(i+1,j+1) = j**(2*i)
            b(i+1) =  gama ** (2*i)
         enddo
      enddo
      mi = -1
      do i=1,n
         k = i+l+1
         a(k,1) = 1.0d0
         a(k,nd) = mi
         do j=1,nd-2
            a(k,j+1) = cos(j*x(i))
            b(k) = cos(gama*x(i))
         enddo
         mi = - mi
      enddo
      end subroutine set_matrix

      subroutine best_app(a,b,p,x,nd,l,n,m,gama,c)
      integer ::n,m,l,nd,p(nd),k,i
      real(kind=8) :: gama,xmax,sgnmax,fmax,eps,sgn,y,h
      real(kind=8) :: a(nd,nd), b(nd), c(nd), x(n)

      eps = 1.0d-05
      k = 1
      h = acos(-1.d0)/200
      do
         fmax = abs(c(nd))
         call glob_max(gama,c,m,xmax,sgnmax)
         k= k + 1
         if ((abs(error(xmax,gama,c,m))-fmax).lt.eps) exit
         sgn = fmax / c(nd)
         call exchange(x,n,sgn,xmax,sgnmax)
         call set_matrix(a,b,x,nd,l,n,gama,0)
         call decomplu(a,p,nd)
         call solve_lu(a,b,c,p,nd)
      enddo

      end subroutine best_app

      subroutine glob_max(gama,c,m,xmax,sgnmax)
      integer :: m,i,k
      real(kind=8) :: gama,c(m+1),xmax,xm,sgnmax,h,f,f1,f2,f3,fm,pi,a,b
      k = 100
      pi = acos(-1.d0)
      h = pi / k
      f1 = error(0.0d0,gama,c,m)
      f2 = error(h,gama,c,m)
      fm = f1
      xmax = 0.0d0
      do i=2,k
         a = (i-2)*h
         b = i*h
         f3 = error(b,gama,c,m)
         if ((f2-f1)*(f3-f2).le.0.0d0) then
            if((f2-f1).gt.0.0d0) then
               xm = max_fib(a,b,gama,c,m)
              elseif ((f3-f2).lt.0.0d0) then
               xm = max_fib(a,b,gama,c,m)
              else
               xm = min_fib(a,b,gama,c,m)
            endif
            f = error(xm,gama,c,m)
            if (abs(f).gt.abs(fm)) then
               fm = f
               xmax = xm
            endif
         endif
         f1 = f2
         f2 = f3
      enddo
      if (abs(f3).gt.abs(fm)) then
          fm = f3
          xmax = pi
      endif
      sgnmax = fm / abs(fm)
      end subroutine glob_max

      function max_fib(a,b,gama,coef,m)
      integer :: m
      real(kind=8) :: a,b,c,d,r,max_fib,gama,coef(m+1),eps
      r = (sqrt(5.d0)+1.0d0)/2.0d0
      eps = 1.0d-05
      do
         c = b - (b-a)/r
         d = a + (b-a)/r
         if (abs(c-d).lt.eps) exit
         if (error(c,gama,coef,m).gt.error(d,gama,coef,m)) then
            b = d
          else
            a = c
         endif
      enddo
      max_fib = (a+b)/2.0d0
      end function max_fib

      function min_fib(a,b,gama,coef,m)
      integer :: m
      real(kind=8) :: a,b,c,d,r,min_fib,gama,coef(m+1),eps
      r = (sqrt(5.d0)+1.0d0)/2.0d0
      eps = 1.0d-05
      do
         c = b - (b-a)/r
         d = a + (b-a)/r
         if (abs(c-d).lt.eps) exit
         if (error(c,gama,coef,m).lt.error(d,gama,coef,m)) then
            b = d
          else
            a = c
         endif
      enddo
      min_fib = (a+b)/2.0d0
      end function min_fib

      function g(x,c,n)
      integer :: n,k
      real(kind=8) :: g,c(n),x
      g = c(1)
      do k=2,n
        g = g + c(k)*cos((k-1)*x)
      enddo
      end function g

      function error(x,gama,c,m)
      integer :: m
      real(kind=8) :: gama, c(m+1), x, error
      error = cos(gama*x)- g(x,c,m+1)
      end function error

      subroutine printa(a,b,n)
      integer :: n,i,j
      real(kind=8) :: a(n,n),b(n)
      write(*,*) 'matrix A'
      do i=1,n
         write(*,*) (a(i,j),j=1,n)
      enddo
      return
      end

      function f(x)
      real(kind=8) :: f,x
      f = 10.*exp(-400.d0*(x-0.5)**2)*sin(135*x)
      end

end module func

program sistema

use func
implicit none

      integer :: n,i,j,k,m,l,nd,np,nx,iold,iact,inew,im,ip,nout
      integer, allocatable :: p(:)
      real (kind=8), allocatable  :: x(:),b(:),a(:,:),c(:),u(:,:)
      real (kind=8) :: gama, pi, h, y
      write(*,*) 'entre  m,gama,l'
      read(*,*) m,gama,l
      n = m-l+1
      nd = m+2
      pi = acos(-1.d0)
      h = pi/200
      allocate (x(n))
      allocate (p(nd))
      allocate (b(nd))
      allocate (c(nd))
      allocate (a(nd,nd))
      call set_matrix(a,b,x,nd,l,n,gama,1)
      call decomplu(a,p,nd)
      call solve_lu(a,b,c,p,nd)
      call best_app(a,b,p,x,nd,l,n,m,gama,c)
      write(*,*) ' solução ', c
      write(*,*) ' primeiros',m+1,' valores correspondem a -c0 -c1 ... -cm '
      write(*,*) ' módulo do último valor é o erro uniforme entre cos(gama*k) e p(k) '
      write(*,*) ' arquivos fort.7 e fort.8 têm as duas funções e o fort.9 a diferença'
      do i=0,200
         y = i*h
         write(7,*) y, cos(gama*y)
         write(8,*) y,  g(y,c,m+1)
         write(9,*) y, cos(gama*y)- g(y,c,m+1)
      enddo
      write(*,*) ' entre nx e npassos'
      read(*,*) nx,np
      allocate(u(0:nx-1,3))
      iold = 1
      iact = 2
      inew = 3
      h = 1.d0/nx
      do i=0,nx-1
         u(i,iold) = f(i*h)
         u(i,iact) = u(i,iold)
      enddo
            do i=0,nx-1
               write(10,*) i*h,u(i,iold)
            enddo
            write(10,*) 1,u(0,iold)
            do i=0,nx-1
               write(11,*) i*h,u(i,iact)
            enddo
            write(11,*) 1,u(0,iact)
      nout = 12
      do k=1,np
         do i=0,nx-1
            u(i,inew) = 2.0d0*c(1)*u(i,iact) - u(i,iold)
            do l=1,m
               im = modulo(i-l,nx)
               ip = modulo(i+l,nx)
               u(i,inew) = u(i,inew) + c(l+1) * (u(im,iact)+u(ip,iact))
            enddo
         enddo
         if (mod(k,5).eq.0) then
            do i=0,nx-1
               write(nout,*) i*h,u(i,inew)
            enddo
            write(nout,*) 1,u(0,inew)
            nout = nout+1
         endif
         i = inew
         inew = iold
         iold = iact
         iact = i
      enddo
end  program sistema


* umftst.f
* FORTRAN-77 version of testumfpack.c to test UMFPACK FORTRAN
* interface.
* The C example program is from the UMFPACK (v5.2.0) User Guide
* by Timothy A. Davis, University of Florida
* http://www.cise.ufl.edu/research/sparse/umfpack/
*
* $Id: umftst.f 1690 2008-07-16 04:35:47Z astivala $
      program umftst
      implicit none

      external umf4def,umf4sym,umf4num,umf4solr,umf4fsym,umf4fnum
      integer n,nz
      parameter (n=5, nz=12)

      integer Ap(n+1), Ai(nz), numeric, symbolic, sys, i
      double precision Ax(nz), x(n), b(n), control(20), info(90)

      data Ap /0, 2, 5, 9, 10, 12/
      data Ai /0, 1, 0, 2, 4, 1, 2, 3, 4, 2, 1, 4/
      data Ax /2.0d0, 3.0d0, 3.0d0, -1.0d0, 4.0d0, 4.0d0, -3.0d0, 1.0d0,
     $  2.0d0, 2.0d0, 6.0d0, 1.0d0/
      data b /8.0d0, 45.0d0, -3.0d0, 3.0d0, 19.0d0/

*     set default parameters
      call umf4def(control)

*     pre-order and symbolic analysis
      call umf4sym(n, n, Ap, Ai, Ax, symbolic, control, info)
      if (info(1) .lt. 0) then
        write(*,*) 'UMF4SYM failed, info = ', info(1)
        stop
      endif

*     numeric factorization
      call umf4num(Ap, Ai, Ax, symbolic, numeric, control, info)
      if (info(1) .lt. 0) then
        write(*,*) 'UMF4NUM failed, info = ', info(1)
        stop
      endif

*     solve Ax=b, with iterative refinement
      sys = 0
      call umf4solr(sys, Ap, Ai, Ax, x, b, numeric, control, info)
      if (info(1) .lt. 0) then
        write(*,*) 'UMFSOLR failed, info = ', info(1)
        stop
      endif

*     free the numeric factorization
      call umf4fnum(numeric)

      write(*,100) (i, x(i), i = 1, n)
 100  format('x(',i1,') = ',f8.4)

*     free the symbolic analysis
      call umf4fsym(symbolic)

      end


      subroutine DHERQL(AR, AI, LDA, N, EVAL, VR, VI, WORK, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-10-20 DHERQL Krogh  Changes to use M77CON
C>> 1994-04-20 DHERQL CLL Edited comment to make DP & SP files similar.
c>> 1992-04-23 CLL  Declaring all variables.
c>> 1992-04-08 DHERQL  Removed unused label 220.
c>> 1991-10-23 DHERQL  Krogh Initial version, converted from EISPACK.
c
c     This subroutine reduces a complex hermitian matrix to a real
c     symmetric tridiagonal matrix using unitary similarity
c     transformations, computes the eigenvalues and eigenvectors of the
c     tridiagonal matrix, and then computes the eigenvectors of the
c     original matrix.
c
c     This subroutine is a concatenation of a slight modification of the
c     EISPACK subroutine HTRIDI, a call to DIMQL which is a slight
c     modification of the EISPACK subroutine IMTQL2, and a slight
c     modification of the EISPACK subroutine HTRIBK.  These subroutines
c     in turn are a translation of a complex analogue of the ALGOL
c     procedure TRED1, Num. Math. 11, 181-195(1968) by Martin, Reinsch,
c     and Wilkinson. Handbook for Auto. Comp., Vol.ii-Linear Algebra,
c     212-226(1971), and the complex analogue of the ALGOL procedure
c     TRBAK1, Num. Math. 11, 181-195(1968) by Martin, Reinsch, and
c     Wilkinson.  Handbook for Auto. Comp., vol.ii-Linear Algebra,
c     212-226(1971).
c     EISPACK routines are dated August 1983.
c
c     On input
c
c        AR and AI contain the real and imaginary parts,
c          respectively, of the complex hermitian input matrix.
c          only the lower triangle of the matrix need be supplied.
c
c        LDA must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        N is the order of the matrix.
c
c     On output
c
c     AR and AI contain information about the unitary transformations
c          used in the reduction in their full lower triangles.  Their
c          strict upper triangles and the diagonal of AR are unaltered.
c
c     EVAL contains the eigenvalues in ascending order.  If an
c          error exit is made, the eigenvalues are correct but
c          unordered for indices 1,2,...,IERR-1, and no eigenvectors are
c          computed.
c
c     VR and VI contain the the real and imaginary parts of the
c     eigenvectors with column k corresponding to the eigenvalue in
c     EVAL(k).  Note that the last component of each returned vector
c     is real and that vector euclidean norms are preserved.
c
c     WORK used for working storage.
c
c     IERR is set to:
c          zero  for normal return,
c          J     if the J-th eigenvalue has not been determined after 30
c                iterations.
c
c     ------------------------------------------------------------------
c--D replaces "?": ?HERQL, ?IMQL
c     Both versions use IERM1
c     ------------------------------------------------------------------
      integer I, IERR, J,K,L,N,LDA,N1,N2
      double precision AR(LDA,N),AI(LDA,N),EVAL(N),WORK(*)
      double precision VR(LDA,N),VI(LDA,N)
      double precision F,G,H,FI,GI,HH,SI,SCALE
      double precision S
c     ------------------------------------------------------------------
      N1 = N
      N2 = N1 + N1
      WORK(N2) = 1.0D0
      WORK(N2 + N1) = 0.0D0
c
      do 100 I = 1, N1
         EVAL(I) = AR(I,I)
  100 continue
      if (N1 .le. 1) then
         if (N1 .eq. 1) then
            AR(1,1) = 1.0d0
            AI(1,1) = 0.0d0
         else
            call IERM1('DHERQL',-1, 0, 'Require N > 0.', 'N', N1, '.')
            IERR = -1
         end if
         return
      end if
      do 300 I = N1, 1, -1
         L = I - 1
         H = 0.0D0
         SCALE = 0.0D0
         if (L .lt. 1) go to 130
c     .......... scale row (algol tol then not needed) ..........
         do 120 K = 1, L
            SCALE = SCALE + abs(AR(I,K)) + abs(AI(I,K))
  120    continue
c
         if (SCALE .ne. 0.0D0) go to 140
         WORK(N1 + L) = 1.0D0
         WORK(N2 + L) = 0.0D0
  130    WORK(I) = 0.0D0
         go to 290
c
  140    do 150 K = 1, L
            AR(I,K) = AR(I,K) / SCALE
            AI(I,K) = AI(I,K) / SCALE
            H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K)
  150    continue
c
         G = sqrt(H)
         WORK(I) = SCALE * G
         F = abs(AR(I,L))
         SI = abs(AI(I,L))
         if (F .gt. SI) then
            F = F * sqrt(1.0d0 + (SI / F) **2)
         else if (SI .ne. 0.0d0) then
            F = SI * sqrt(1.0d0 + (F / SI) **2)
         else
            WORK(N1 + L) = -WORK(N1 + I)
            SI = WORK(N2 + I)
            AR(I,L) = G
            go to 170
         end if
c     .......... Form next diagonal element of matrix t ..........
         WORK(N1+L) = (AI(I,L) * WORK(N2+I) - AR(I,L) * WORK(N1+I)) / F
         SI = (AR(I,L) * WORK(N2 + I) + AI(I,L) * WORK(N1 + I)) / F
         H = H + F * G
         G = 1.0D0 + G / F
         AR(I,L) = G * AR(I,L)
         AI(I,L) = G * AI(I,L)
         if (L .eq. 1) go to 270
         F = 0.0D0
c
  170    do 240 J = 1, L
            G = 0.0D0
            GI = 0.0D0
c     .......... form element of a*u ..........
            do 180 K = 1, J
               G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K)
               GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K)
  180       continue
c
            do 200 K = J+1, L
               G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K)
               GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K)
  200       continue
c     .......... form element of p ..........
            WORK(J) = G / H
            WORK(N2 + J) = GI / H
            F = F + WORK(J) * AR(I,J) - WORK(N2 + J) * AI(I,J)
  240    continue
c
         HH = F / (H + H)
c     .......... form reduced a ..........
         do 260 J = 1, L
            F = AR(I,J)
            G = WORK(J) - HH * F
            WORK(J) = G
            FI = -AI(I,J)
            GI = WORK(N2 + J) - HH * FI
            WORK(N2 + J) = -GI
c
            do 250 K = 1, J
               AR(J,K) = AR(J,K) - F * WORK(K) - G * AR(I,K)
     x                           + FI * WORK(N2 + K) + GI * AI(I,K)
               AI(J,K) = AI(J,K) - F * WORK(N2 + K) - G * AI(I,K)
     x                           - FI * WORK(K) - GI * AR(I,K)
  250       continue
  260    continue
c
  270    do 280 K = 1, L
            AR(I,K) = SCALE * AR(I,K)
            AI(I,K) = SCALE * AI(I,K)
  280    continue
c
         WORK(N2 + L) = -SI
  290    HH = EVAL(I)
         EVAL(I) = AR(I,I)
         AR(I,I) = HH
         AI(I,I) = SCALE * sqrt(H)
  300 continue
c
c     ------------------------------------------------------------------
c
      do 420 I = 1, N1
         do 410 J = 1, N1
            VR(I,J) = 0.0d0
  410    continue
         VR(I,I) = 1.0d0
  420 continue
      call DIMQL(VR, LDA, N1, EVAL, WORK, IERR)
      if (IERR .ne. 0) return
c
c     ------------------------------------------------------------------
c
c     .......... transform the eigenvectors of the real symmetric
c                tridiagonal matrix to those of the hermitian
c                tridiagonal matrix. ..........
      do 550 K = 1, N1
c
         do 540 J = 1, N1
            VI(K,J) = -VR(K,J) * WORK(N2 + K)
            VR(K,J) = VR(K,J) * WORK(N1 + K)
  540    continue
  550 continue
c
c     .......... Recover and apply the Householder matrices ..........
      do 640 I = 2, N1
         L = I - 1
         H = AI(I,I)
         if (H .ne. 0.0D0) then
            do 630 J = 1, N1
               S = 0.0D0
               SI = 0.0D0
               do 610 K = 1, L
                  S = S + AR(I,K) * VR(K,J) - AI(I,K) * VI(K,J)
                  SI = SI + AR(I,K) * VI(K,J) + AI(I,K) * VR(K,J)
  610          continue
c        .......... double divisions avoid possible underflow ..........
               S = (S / H) / H
               SI = (SI / H) / H
c
               do 620 K = 1, L
                  VR(K,J) = VR(K,J) - S * AR(I,K) - SI * AI(I,K)
                  VI(K,J) = VI(K,J) - SI * AR(I,K) + S * AI(I,K)
  620          continue
  630       continue
         end if
  640 continue
c
      return
      end


SUBROUTINE interp_orb2(interv, NPint, fname_orbint)

! ----------------------------------------------------------------------
! SUBROUTINE: interp_orb2.f90
! ----------------------------------------------------------------------
! Purpose:
!  GNSS sp3 orbit interpolation based on Lagrange polynomials
! ----------------------------------------------------------------------
! Input arguments:
! - interv: 		Interval of the interpolation epochs (in seconds)
! - NPint:			Number of data points to be used for interpolation (defines the order of the polynomial)
! - fname_orbint:	Output file name for writing interpolated orbit array
!
! Input arguments (via module):
! - orb1:			Orbit array including only the position vector (based on multiple sp3 files)
! - mdl_arr.f90: 	Module used for the declaration of these variables as allocatable arrays
!
! Output arguments (via module):
! - orb2:   		Interpolated orbit including position and velocity vetors per epoch (allocatable array)
! - mdl_arr.f90: 	Module used for the declaration of these variables as allocatable arrays
! ----------------------------------------------------------------------
! Note 1:
!  The input orbit file (sp3) is considered to include only position vector
!  of the GNSS satellites as this is the IGS standard products
!  During the orbit interpolation, based on Lagrange polynomials, position
!  and velocity vectors for the selected satellite (PRN) are computed and
!  provided in the output files.
! ----------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou, Geoscience Australia         5 August 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_arr
      USE mdl_write
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      CHARACTER (LEN=150), INTENT(IN) :: fname_orbint
      INTEGER (KIND = prec_int8), INTENT(IN) :: interv, NPint
!	  INTEGER (KIND = 4) :: PRN
! OUT

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

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: Nepochs, epoch_i, sz1, sz2
      INTEGER (KIND = prec_int8) :: data_rate, Nepoch_int, Norb_int, NPint_1, NPint_2
	  INTEGER (KIND = prec_int8) :: i, j, i1, i2, ti
	  REAL (KIND = prec_d) :: SecDay_i, MJD_i
	  REAL (KIND = prec_d) :: MJD_tint, tint, Xint, Xint_1, Yint, Yint_1, Zint, Zint_1
	  REAL (KIND = prec_d) :: X, Y, Z, Vx, Vy, Vz
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      CHARACTER (LEN=300) :: fname_write
! ----------------------------------------------------------------------

	  ! orb1 via module mdl_arr.f90: Orbit array based on all of the input sp3 files
	  sz1 = size(orb1, DIM = 1)

	  ! Data rate of sp3 (in sec)
      DO i = 1 , sz1-1
		if ( INT(orb1(i+1,1)) - INT(orb1(i,1)) == 0 ) then
			data_rate = INT( orb1(2,2) - orb1(1,2) )
			EXIT
		end if
	  End Do

      ! Number of points to be interpolated per epoch of the sp3 orbit file (15min, 5min)
	  Nepoch_int = data_rate / interv - 1

      ! Number of epochs of interpolated orbit
      Norb_int = (data_rate / interv) * (sz1-1) + 1

! Allocatable arrays for Lagrange Interpolation (declared in mdl_arr.f90)
      ALLOCATE (X_interp(NPint), STAT = AllocateStatus)
      ALLOCATE (Y_interp(NPint), STAT = AllocateStatus)

! Allocatable arrays  for the interpolated orbit array
      ALLOCATE (orb2(Norb_int, 8) , STAT = AllocateStatus)

! ----------------------------------------------------------------------
! Number of data points (used for the interpolation) before and after of each epoch of sp3 file
      NPint_1 = INT(NPint/2)
      NPint_2 = NPint - NPint_1

	  epoch_i = 0
      DO i = 1 , sz1
		epoch_i  = epoch_i + 1
		MJD_i    = orb1(i,1)
		SecDay_i = orb1(i,2)

! ----------------------------------------------------------------------
! Form arrays with data points to be used in the interpolation
		if ( i < NPint_1 ) then
			i1 = i
			i2 = i + (NPint - 1)
			!print *,"sz1, i, epoch_i, i1, i2", sz1, i, epoch_i, i1, i2
		else if ( sz1 - i < NPint_2 ) then
			i2 = sz1
			i1 = i2 - (NPint-1)
			!print *,"sz1, i, epoch_i, i1, i2", sz1, i, epoch_i, i1, i2
		else
			i1 = i - (NPint_1 - 1)
			i2 = i + NPint_2
			!print *,"i,epoch_i,i1,i2", i, epoch_i, i1, i2
		end if

! ----------------------------------------------------------------------
! Time array of the data points used for the interpolation: X_interp
!		ti = 1
!		X_interp(1) = orb1(i1, 2)
!		Do ti = 2 , NPint
!			X_interp(ti) = X_interp(1) + (ti - 1) * data_rate * 1.D0
!		End Do

		ti = 0
		Do j = i1 , i2
		ti = ti + 1
			X_interp(ti) = SecDay_i + (j-i) * data_rate * 1.D0  !(ti - 1) * data_rate * 1.D0
		End Do
	    j = 0
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Data Point: Velocity computation based on interpolation
! ----------------------------------------------------------------------
		! Position Vector: value from the IGS sp3 file
		orb2(epoch_i, 1:5) = orb1(i, 1:5)
        X = orb1(i,3)
		Y = orb1(i,4)
		Z = orb1(i,5)

		! Velocity Vector: computation via Lagrange interpolation
		tint = SecDay_i

		! Vx
		Y_interp = orb1(i1:i2, 3)
		Call interp_lag(tint-1, Xint_1)
        Vx = X - Xint_1
		! Vy
		Y_interp = orb1(i1:i2, 4)
		Call interp_lag(tint-1, Yint_1)
        Vy = Y - Yint_1
		! Vz
		Y_interp = orb1(i1:i2, 5)
		Call interp_lag(tint-1, Zint_1)
        Vz = Z - Zint_1

		! Write Velocity to array orb2
		orb2(epoch_i, 6) = Vx
		orb2(epoch_i, 7) = Vy
		orb2(epoch_i, 8) = Vz
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Lagrange Interpolation applied for the new points
! ----------------------------------------------------------------------
If (i < sz1) then
		DO j = 1 , Nepoch_int
			tint = j * interv * 1.D0 + SecDay_i

		!DO j = t(1) , t(NPint) , interv
			!tint = j * interv + orb1(i,2)

			! Position and Velocity Vectors

			! X
			Y_interp = orb1(i1:i2, 3)
			Call interp_lag(tint, Xint)
			! Vx
			Call interp_lag(tint-1, Xint_1)
            !Vx = Xint_1 - Xint
            Vx = Xint - Xint_1

			! Y
			Y_interp = orb1(i1:i2, 4)
			Call interp_lag(tint, Yint)
			! Vy
			Call interp_lag(tint-1, Yint_1)
            !Vy = Yint_1 - Yint
            Vy = Yint - Yint_1

			! Z
			Y_interp = orb1(i1:i2, 5)
			Call interp_lag(tint, Zint)
			! Vz
			Call interp_lag(tint-1, Zint_1)
            !Vz = Zint_1 - Zint
            Vz = Zint - Zint_1

! Next epoch
			epoch_i = epoch_i + 1

! MJD epoch
			MJD_tint = INT(MJD_i) * 1.D0 + tint / 86400.D0

! Write interpolated state vector in array
			! Time arguments at interpolation epoch
			orb2(epoch_i, 1) = MJD_tint

			If (tint > 86400.D0) then
			   tint = tint - 86400.D0
			End If

			orb2(epoch_i, 2) = tint

			! Position vector (interpolated)
			orb2(epoch_i, 3) = Xint
			orb2(epoch_i, 4) = Yint
			orb2(epoch_i, 5) = Zint

			! Velocity vector (interpolated)
			orb2(epoch_i, 6) = Vx
			orb2(epoch_i, 7) = Vy
			orb2(epoch_i, 8) = Vz
		End DO
End IF
! ----------------------------------------------------------------------

      End Do

	  Deallocate (X_interp)
	  Deallocate (Y_interp)

! Write Orbit after interpolation
	  sz1 = size(orb2, DIM = 1)
	  sz2 = size(orb2, DIM = 2)
      ALLOCATE (wrtArray(sz1,sz2), STAT = AllocateStatus)
      !fname_write = 'orb_interp.out'
      fname_write = fname_orbint
      wrtArray = orb2
      CALL write_array (fname_write)
      DEALLOCATE (wrtArray, STAT = DeAllocateStatus)

	  sz1 = size(orb1, DIM = 1)
	  sz2 = size(orb1, DIM = 2)
      ALLOCATE (wrtArray(sz1,sz2), STAT = AllocateStatus)
      fname_write = 'orb_sp3.out'
      wrtArray = orb1
      CALL write_array (fname_write)
      DEALLOCATE (wrtArray, STAT = DeAllocateStatus)

End subroutine


C  Copyright (C) 2007: Leslie Greengard
C  Contact: greengard@cims.nyu.edu
C
C  All rights reserved.
C  This copy is not for distribution without permission of the author.
C
c***********************************************************************
      subroutine phi_incoming(str,kvec,targ,phi,gradphi)
c***********************************************************************
c
c     This subroutine defines incoming field as
c
c     phi = str * exp( i kvec \cdot targ)
c
c     INPUT:
c
c     str        (complex *16) : strength parameter
c     kvec       (complex *16) : vector parameter
c     targ           (real *8) : coordinates of sample point
c
c     OUTPUT:
c
c     phi        (complex *16) : potential
c     gradphi    (complex *16) : gradient of potential
c
c***********************************************************************
c
c
      implicit real *8 (a-h,o-z)
      real *8 dot,kvec(3),targ(3)
      complex *16 phi,gradphi(3),eye, str
      data eye/(0.0d0,1.0d0)/
C
      dot = kvec(1)*targ(1)+kvec(2)*targ(2)+kvec(3)*targ(3)
      phi = str*cdexp( eye*dot)
      gradphi(1) = phi*eye*kvec(1)
      gradphi(2) = phi*eye*kvec(2)
      gradphi(3) = phi*eye*kvec(3)
      return
      end

c***********************************************************************
      subroutine getincoming(str,kvec,radius,center,nterms,
ccc     1           sh1,sh2,w,lw,ier)
     1           sh1,sh2)
c***********************************************************************
c
c     This subroutine expands an arbitrary incoming field
c     defined by subroutine
c
c        phi_incoming(str,kvec,targ,phi,gradphi)
c
c     on the sphere of radius RADIUS as a spherical harmonic expansion.
c
c     INPUT:
c
c     str        (complex *16) : strength parameter
c     kvec       (complex *16) : vector parameter
c     radius      (real *8 )   : radius of sphere about (0,0,zshift)
c                                where phival, phivaln are computed.
c     center      (real *8)    : coordinates of sphere center
c     nterms     (integer *4 ) : order of expansion
c     w          (complex *16) : workspace
c     lw          (integer *4) : length of workspace
c
c     OUTPUT:
c
c     sh1  (complex *16)  :    sph. harmonic expansion of potential
c     sh2  (complex *16)  :    sph. harmonic expansion of normal
c                              derivative of potential
c     ier                 :    error return code
c                              not yet implemented
c
c
c     WARNING:  xnodes, wts, bb are dimensioned as local variables
c               at length 2000  => nterms < 1000.
c
c***********************************************************************
      implicit real *8 (a-h,o-z)
      integer *4 nterms
ccc      real *8 w(lw),xnodes(2000),wts(2000),bb(2000)
      real *8 targ(3), center(3)
      real *8 kvec(3)
      complex *16 sh1(0:nterms,-nterms:nterms)
      complex *16 sh2(0:nterms,-nterms:nterms)
      real *8 :: w
      allocatable w(:)
C
      integer *4 l,m,jnew,knew
C
      pi = 4.0d0*datan(1.0d0)
      nquad = 2*nterms
      iphival = 1
      iphivaln = iphival + 2*nquad*nquad
      iynm = iphivaln + 2*nquad*nquad
      ixnodes = iynm + (nterms+1)**2
      iwts = ixnodes+ nquad
      ibb = iwts+ nquad
      iused = ibb+nquad
      lw = iused+ 100000
ccc      if (iused. lt. lw) then
ccc         ier = 1
ccc	 return
ccc      endif
      allocate (w(lw))
      call gaussq(0,nquad,0,0,0,0,w(ibb),w(ixnodes),w(iwts))
c
      call sampleincoming(str,kvec,radius,center,nquad,w(ixnodes),
     1                    w(iphival),w(iphivaln))
c
      call h3dprojloc(nterms,nterms,nquad,w(ixnodes),w(iwts),
ccc     1                w(iphival),sh1,w(iynm),w(iused),lw-iused,ier)
     1                w(iphival),sh1,w(iynm))
ccc      call prin2(' after projloc ier is *',ier,1)
      call h3dprojloc(nterms,nterms,nquad,w(ixnodes),w(iwts),
ccc     1                w(iphivaln),sh2,w(iynm),w(iused),lw-iused,ier)
     1                w(iphivaln),sh2,w(iynm))
ccc      call prin2(' after second projloc ier is *',ier,1)
      deallocate (w)
      return
      end
c
c***********************************************************************
      subroutine sampleincoming(str,kvec,radius,center,nquad,xnodes,
     1           phival,phivaln)
c***********************************************************************
c
c     This subroutine samples an incoming field
c     defined by subroutine phi_incoming(x,y,z)
c     on the sphere of radius RADIUS centered at CENTER.
c
c     INPUT:
c
c     str        (complex *16) : complex parameter to send to
c                                subroutine phi_incoming.
c     kvec        (complex *16) : complex 3-vector to send to
c                                subroutine phi_incoming.
c     radius      (real *8 ) : radius of sphere
c                              where phival, phivaln are computed.
c     center      (real *8 ) : sphere center
c     nquad    (integer *4 ) : number of quadrature nodes
c                              on target sphere is nquad*nquad.
c     xnodes      (real *8 ) : Legendre nodes x_j = cos theta_j.
c
c     OUTPUT:
c
c     phival  (complex *16)  : value of potential on tensor product
c                              mesh on target sphere.
c     phivaln  (complex *16) : value of normal derivative of potential
c                              on tensor product mesh on target sphere.
c
c***********************************************************************
      implicit real *8 (a-h,o-z)
      integer *4 nterms
      real *8 targ(3), center(3)
      real *8 xnodes(1),kvec(3)
      complex *16 phival(nquad,nquad)
      complex *16 phivaln(nquad,nquad)
      complex *16 pot,gradphi(3),str,eye
      data eye/(0.0d0,1.0d0)/
C
      integer *4 l,m,jnew,knew
C
      pi = 4.0d0*datan(1.0d0)
      iffld = 0
      do jj=1,nquad
      do kk=1,nquad
	 ctheta = xnodes(jj)
	 stheta = dsqrt(1.0d0 - ctheta**2)
	 phi = 2*pi*kk/nquad
	 cosphi = dcos(phi)
	 sinphi = dsin(phi)
	 rx = stheta*cosphi
	 ry = stheta*sinphi
	 rz = ctheta
	 targ(1) = center(1) + rx*radius
	 targ(2) = center(2) + ry*radius
	 targ(3) = center(3) + rz*radius
         call phi_incoming(str,kvec,targ,pot,gradphi)
c
c        scale by radius/eye = -eye*radius
c        has something to do with local expansion evaluation.
c        may ttrack this down more carefully (or not).
c
         phival(jj,kk) = -eye*pot*radius
         phivaln(jj,kk) = -eye*radius*
     1   	 (gradphi(1)*rx+gradphi(2)*ry+gradphi(3)*rz)
      enddo
      enddo
      return
      end
c


!********************************************************************************
!* This file is part of:
!* BAFFLE (https://github.com/ATHannington/BAFFLE)
!* BAFFLE: BAsic Fortran FLuids Engine
!*
!* BAFFLE:
!* Copyright (C) 2017 Andrew Hannington (ath4@st-andrews.ac.uk)
!*
!* This software is a derivative of work by Bert Vandenbroucke
!* (bert.vandenbroucke@gmail.com)
!* Find more work by Bert Vandenbroucke at: (https://github.com/bwvdnbro)
!*
!* BAFFLE is a free software: you can redistribute it and/or modify it under the
!* terms of the GNU Affero General Public License
!* as published by the Free Software Foundation, either version 3 of the License, or
!* (at your option) any later version.
!*
!* BAFFLE is distributed in the hope that it will
!* be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!* GNU Affero General Public License for more details.
!*
!* You should have received a copy of the GNU Affero General Public License
!* along with BAFFLE. If not, see
!* <http://www.gnu.org/licenses/>.
!********************************************************************************

!********************************************************************************
!* @file init_conds_1DSod.f90
!*
!* @Initial Conditions subroutine for 1D Sod Shock Test Tube Simulation: Fortran 90 version.
!*
!* @author Andrew Hannington (ath4@st-andrews.ac.uk)
!********************************************************************************

!===============================================================================
!
!*** 				INITIAL CONDITIONS			     ***
!
!-------------------------------------------------------------------------------
!Subroutine for initial conditions functions for density, velocity, and pressure
!& as a function of x.
!-------------------------------------------------------------------------------
subroutine init_conds(x,y,z,rho,ux,uy,uz,p)
	use constants								!Tells program to use global constants
	implicit none

		Real*8, intent(in) :: x,y,z
		Real*8, intent(out) :: rho,ux,uy,uz,p
		Real*8 :: r_xy							!Radius in x-y plane
		Real*8 :: delx,dely,delz					!Ranges in x, y and z for the maximum range limit
		Real*8 :: lowbound,midbound,upbound				!Bounds for ranges in initial conditions
		Real*8 :: x0,y0							!x and y coordinates of centre of high pressure region
		Real*8 :: rmax							!Maximum radius of high pressure region

		real*8,external::isotherm_p					!Isothermal Pressure

!#	Cells format: 	cells(i,j,k,1:29) = (/m,qx,qy,qz,E,rho,ux,uy,uz,p,V,Midx,Midy,Midz, &
!#						& grad_d_x,grad_d_y,grad_d_z, &
!#						& grad_ux_x,grad_uy_x,grad_uz_x, &
!#						& grad_ux_y,grad_uy_y,grad_uz_y, &
!#						& grad_ux_z,grad_uy_z,grad_uz_z, &
!#						& grad_p_x,grad_p_y,grad_p_z /)

!	uy=0.d0
	uz=0.d0

!	Set x0, y0 to be centre of system:
	x0=0.5d0
	y0=0.5d0

!	Set max radius of high pressure region:
	rmax=0.50d0/2.d0

!	Set radius:
	r_xy = Sqrt((x-x0)**2+(y-y0)**2)!+z**2)
!	r_xy = Sqrt(x**2+y**2)

!	Set axis lengths and calculate lower bound, mid-pont, and upper bound:
	delx=xrangeMax-xrangeMin
	dely=yrangeMax-yrangeMin
	delz=zrangeMax-zrangeMin

	lowbound=0.d0
	midbound=0.5d0
	upbound=1.d0!Sqrt(delx**2+dely**2+delz**2)

!Sets values of pressure, x-velocity, and density according to starting conditions for 2D Sod Shock
	If ((x>=lowbound).and.(x<midbound)) then
		rho=1.d0
		ux=0.d0
		uy=0.d0
		uz=0.d0
		p=1.d0
	else if ((x>=midbound).and.(x<=upbound)) then
		rho=0.125d0
		ux=0.d0
		uy=0.d0
		uz=0.d0
		p=0.1d0
	else
		Print*,"Invalid coordinate! Program will terminate!"		!Exits program if x lies outside of 1 to 0 range
		STOP
	endif

	If (IsoBool.eqv..TRUE.) then
		p = isotherm_p(rho)
	endif

end subroutine init_conds
!===============================================================================


*     MB04MD EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA
      PARAMETER        ( LDA = NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
      DOUBLE PRECISION MAXRED
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), SCALE(NMAX)
*     .. External Subroutines ..
      EXTERNAL         MB04MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, MAXRED
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Balance matrix A.
         CALL MB04MD( N, MAXRED, A, LDA, SCALE, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99994 ) ( SCALE(I), I = 1,N )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04MD = ',I2)
99997 FORMAT (' The balanced matrix is ')
99996 FORMAT (20(1X,F10.4))
99994 FORMAT (/' SCALE is ',/20(1X,F10.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
      END


C++*****************************************************************
C Program CALCUL
C
C JLP Version of 14-03-86
C--*****************************************************************
	CHARACTER REP*1,FICH*25
	REAL*4 VAL1(100),VAL2(100),VAL(100)
	REAL*4 X(30),Y(30),THETA(30)
	PRINT 21
21	FORMAT(' PROGRAMME DE CALCUL - VERSION DU 14-03-86 -',/,
     1	' OPTION 1 : ENTREE DES DONNEES DANS LE TABLEAU 1',/,
     1	' OPTION 2 : ENTREE DES DONNEES DANS LE TABLEAU 2',/,
     1	' OPERATIONS SUR CES TABLEAUX :',/,
     1	' OPTION 3: (2 - 1) ---> 1',/,
     1	' OPTION 4: CALCUL DE MOYENNE ET D"ECART-TYPE DU TABLEAU 1',/,
     1	' OPTION 5: (2 - 1)/ ((2+1)/2) ----> 1',/,
     1	' OPTION 6: CALCUL D"UNE ELLIPSE SYNTHETIQUE',/,
     1	' OPTION 7: CALCUL D"UN LOG OU EXP',/,
     1	' OPTION 8: CALCUL SQRT(TAB1**2 +TAB2**2) DANS TAB1',/,
     1	' OPTION 10: EXIT',/,
     1	' ENTREZ L"OPTION CHOISIE')
	READ(5,*) IOPT
	IF(IOPT.LE.2)THEN
	N=0
	PRINT *,' ENTREZ LES VALEURS (FORMAT: X.Y OU X.Y,S POUR SORTIR)'
10	PRINT 20
20	FORMAT(' ? ',$)
	N=N+1
	ACCEPT 11,VAL(N),REP
11	FORMAT(F9.3,A)
	IF(REP.NE.'S')GO TO 10
	IF(IOPT.EQ.2)THEN
	DO 12 I=1,N
	VAL2(I)=VAL(I)
12	CONTINUE
	N2=N
	ELSE
	N1=N
	DO 14 I=1,N
	VAL1(I)=VAL(I)
14	CONTINUE
	ENDIF
	GO TO 1
	ENDIF
C****************OPTION 3 DIFF 2-1 EN 1****************************
	IF(IOPT.EQ.3)THEN
	N1=MIN0(N1,N2)
	N=N1
	DO 21 I=1,N
	VAL1(I)=VAL2(I)-VAL1(I)
21	CONTINUE
	GOTO 1
	ENDIF
C*******************************************************************
C	CALCUL DE LA MOYENNE
C*******************************************************************
	IF(IOPT.EQ.4)THEN
	VV=0.
	N=N1
	DO 40 I=1,N
	VV=VV+VAL1(I)
40	CONTINUE
	VMOY=VV/FLOAT(N)
	PRINT *,' MOYENNE:',VMOY
C*******************************************************************
C	CALCUL DE L'ECART-TYPE
C*******************************************************************
	VV=0.
	DO 50 I=1,N
	VV=VV+(VAL1(I)-VMOY)**2
50	CONTINUE
	SIGMA=SQRT(VV/FLOAT(N))
	PRINT *,' ECART-TYPE :',SIGMA
	GO TO 1
	ENDIF
C****************OPTION 3  : (2-1)/((2+1)/2) EN 1****************************
	IF(IOPT.EQ.5)THEN
	N1=MIN0(N1,N2)
	N=N1
	DO I=1,N
	VAL1(I)=2.*(VAL2(I)-VAL1(I))/(VAL2(I)+VAL1(I))
	END DO
	GOTO 1
	ENDIF
C*******************************************************************
C	CALCUL D'UNE ELLIPSE SYNTHETIQUE
C*******************************************************************
	IF(IOPT.EQ.6) THEN
395	PRINT *,' NOM DU FICHIER DE SORTIE ?'
	ACCEPT 111,FICH
	OPEN(UNIT=1,FILE=FICH,STATUS='NEW',INITIALSIZE=-3,
     1	ERR=395)
	PRINT *,' COORDONNEES DU CENTRE X, Y ?'
	READ(5,*) XC,YC
	PRINT *,' ELLIPTICITE ? (10*(1-BB/AA)'
	READ(5,*) EE
	PRINT *,' VALEUR DU GRAND AXE ?'
	READ(5,*) AA
	PRINT *,' ORIENTATION DU GRAND-AXE (DEG)?'
	READ(5,*) THETA0
	WRITE(1,396)1,30
	DO 300 I=1,30
	THETA(I)=.2*FLOAT(I)
	XX=AA*COS(THETA(I))
	YY=AA*(1.-EE/10.)*SIN(THETA(I))
	X(I)=XC+COSD(THETA0)*XX-SIND(THETA0)*YY
	Y(I)=YC+SIND(THETA0)*XX+COSD(THETA0)*YY
	PRINT 1013,I,X(I),Y(I)
	WRITE(1,397) X(I),Y(I)
300	CONTINUE
111	FORMAT(A)
396	FORMAT(' SHELL NUMBER :',I3,'  POINTS :',I4,/,
     1	2X,'    X   ',2X,'    Y   ',/)
397	FORMAT(2X,F8.2,2X,F8.2)
1013	FORMAT(2X,' I=',I3,2X,'X ET Y :',2(2X,F8.3))
	CLOSE(1)
	ENDIF
C*****************************************************************
	IF(IOPT.EQ.7)THEN
	PRINT *,' 1.LOG NEP     2.EXP BASE E ?'
	READ(5,*) II
	PRINT *,' VALEUR D"ENTREE ?'
	READ(5,*) XX
	IF(II.EQ.1)S=ALOG(XX)
	IF(II.EQ.2)S=EXP(XX)
	PRINT *,'LE RESULTAT EST ',S
	ENDIF
C********************************************************************
	IF(IOPT.EQ.8)THEN
	N1=MIN0(N1,N2)
	DO I=1,N1
	VAL1(I)=SQRT(VAL1(I)*VAL1(I)+VAL2(I)*VAL2(I))
	END DO
	GOTO 1
	ENDIF

	STOP
	END