C
C
C
C     SUBROUTINE DCFFTI(N,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE DCFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C     BOTH DCFFTF AND DCFFTB. 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
C
C     OUTPUT PARAMETER
C
C     WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4*N+15
C             THE SAME WORK ARRAY CAN BE USED FOR BOTH DCFFTF AND DCFFTB
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 DCFFTF OR DCFFTB
C
      SUBROUTINE DCFFTI (N,WSAVE)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       WSAVE(1)
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL DURA1 (N,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
CDECK DURA1
      SUBROUTINE DURA1 (N,WA,IFAC)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       WA(1)      ,IFAC(1)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(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
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
c
      tpi=1
      tpi=atan(tpi)*8
c
      ARGH = TPI/N
      I = 2
      L1 = 1
      DO 110 K1=1,NF
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IDOT = IDO+IDO+2
         IPM = IP-1
         DO 109 J=1,IPM
            I1 = I
            WA(I-1) = 1.
            WA(I) = 0.
            LD = LD+L1
            FI = 0.
            ARGLD =       LD *ARGH
            DO 108 II=4,IDOT,2
               I = I+2
               FI = FI+1.0D0
               ARG = FI*ARGLD
               WA(I-1) =DCOS(ARG)
               WA(I) =DSIN(ARG)
  108       CONTINUE
            IF (IP .LE. 5) GO TO 109
            WA(I1-1) = WA(I-1)
            WA(I1) = WA(I)
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END
CDECK DCFFTB
C     ******************************************************************
C
C     SUBROUTINE DCFFTB(N,C,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE DCFFTB COMPUTES THE BACKWARD COMPLEX DISCRETE FOURIER
C     TRANSFORM (THE FOURIER SYNTHESIS). EQUIVALENTLY , DCFFTB COMPUTES
C     A COMPLEX PERIODIC SEQUENCE FROM ITS FOURIER COEFFICIENTS.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
C
C     A CALL OF DCFFTF FOLLOWED BY A CALL OF DCFFTB WILL MULTIPLY THE
C     SEQUENCE BY N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE DCFFTB MUST BE
C     INITIALIZED BY CALLING SUBROUTINE DCFFTI(N,WSAVE).
C
C     INPUT PARAMETERS
C
C
C     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
C            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES.
C
C     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C
C     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15
C             IN THE PROGRAM THAT CALLS DCFFTB. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE DCFFTI(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 THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY DCFFTF AND DCFFTB.
C
C     OUTPUT PARAMETERS
C
C     C      FOR J=1,...,N
C
C                C(J)=THE SUM FROM K=1,...,N OF
C
C                      C(K)*EXP(I*J*K*2*PI/N)
C
C                            WHERE I=SQRT(-1)
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C             DESTROYED BETWEEN CALLS OF SUBROUTINE DCFFTF OR DCFFTB
      SUBROUTINE DCFFTB (N,C,WSAVE)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       C(1)       ,WSAVE(1)
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL DURAB1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
CDECK DURAF1
      SUBROUTINE DURAB1 (N,C,CH,WA,IFAC)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CH(1)      ,C(1)       ,WA(1)      ,IFAC(1)
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IF (NA .NE. 0) GO TO 101
         CALL DURAB4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL DURAB4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL DURAB2 (IDOT,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL DURAB2 (IDOT,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDOT
         IF (NA .NE. 0) GO TO 107
         CALL DURAB3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL DURAB3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IX4 = IX3+IDOT
         IF (NA .NE. 0) GO TO 110
         CALL DURAB5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL DURAB5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL DURAB (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL DURAB (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (NAC .NE. 0) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDOT
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      N2 = N+N
      DO 117 I=1,N2
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END
CDECK DURAB2
      SUBROUTINE DURAB2 (IDO,L1,CC,CH,WA1)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,
     1                WA1(1)
      IF (IDO .GT. 2) GO TO 102
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
         CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
         CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  101 CONTINUE
      RETURN
  102 IF(IDO/2.LT.L1) GO TO 105
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=2,IDO,2
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            TI2 = CC(I,1,K)-CC(I,2,K)
            CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2
            CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2
  103    CONTINUE
  104 CONTINUE
      RETURN
  105 DO 107 I=2,IDO,2
CDIR$ IVDEP
         DO 106 K=1,L1
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            TI2 = CC(I,1,K)-CC(I,2,K)
            CH(I,K,2) = WA1(I-1)*TI2+WA1(I)*TR2
            CH(I-1,K,2) = WA1(I-1)*TR2-WA1(I)*TI2
  106    CONTINUE
  107 CONTINUE
      RETURN
      END
CDECK DURAB3
      SUBROUTINE DURAB3 (IDO,L1,CC,CH,WA1,WA2)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(1)     ,WA2(1)
c
cccc      DATA TAUR,TAUI /-.5D0,.866025403784439D0/
c
      taur=1
      taur=-taur/2
      taui=3
      taui=taui/4
      taui=sqrt(taui)
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TR2 = CC(1,2,K)+CC(1,3,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         TI2 = CC(2,2,K)+CC(2,3,K)
         CI2 = CC(2,1,K)+TAUR*TI2
         CH(2,K,1) = CC(2,1,K)+TI2
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
         CH(2,K,2) = CI2+CR3
         CH(2,K,3) = CI2-CR3
  101 CONTINUE
      RETURN
  102 IF(IDO/2.LT.L1) GO TO 105
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
  103    CONTINUE
  104 CONTINUE
      RETURN
  105 DO 107 I=2,IDO,2
CDIR$ IVDEP
         DO 106 K=1,L1
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
  106    CONTINUE
  107 CONTINUE
      RETURN
      END
CDECK DURAB4
      SUBROUTINE DURAB4 (IDO,L1,CC,CH,WA1,WA2,WA3)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI1 = CC(2,1,K)-CC(2,3,K)
         TI2 = CC(2,1,K)+CC(2,3,K)
         TR4 = CC(2,4,K)-CC(2,2,K)
         TI3 = CC(2,2,K)+CC(2,4,K)
         TR1 = CC(1,1,K)-CC(1,3,K)
         TR2 = CC(1,1,K)+CC(1,3,K)
         TI4 = CC(1,2,K)-CC(1,4,K)
         TR3 = CC(1,2,K)+CC(1,4,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,3) = TR2-TR3
         CH(2,K,1) = TI2+TI3
         CH(2,K,3) = TI2-TI3
         CH(1,K,2) = TR1+TR4
         CH(1,K,4) = TR1-TR4
         CH(2,K,2) = TI1+TI4
         CH(2,K,4) = TI1-TI4
  101 CONTINUE
      RETURN
  102 IF(IDO/2.LT.L1) GO TO 105
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=2,IDO,2
            TI1 = CC(I,1,K)-CC(I,3,K)
            TI2 = CC(I,1,K)+CC(I,3,K)
            TI3 = CC(I,2,K)+CC(I,4,K)
            TR4 = CC(I,4,K)-CC(I,2,K)
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)
            TI4 = CC(I-1,2,K)-CC(I-1,4,K)
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2
            CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2
            CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3
            CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3
            CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4
            CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4
  103    CONTINUE
  104 CONTINUE
      RETURN
  105 DO 107 I=2,IDO,2
CDIR$ IVDEP
         DO 106 K=1,L1
            TI1 = CC(I,1,K)-CC(I,3,K)
            TI2 = CC(I,1,K)+CC(I,3,K)
            TI3 = CC(I,2,K)+CC(I,4,K)
            TR4 = CC(I,4,K)-CC(I,2,K)
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)
            TI4 = CC(I-1,2,K)-CC(I-1,4,K)
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2-WA1(I)*CI2
            CH(I,K,2) = WA1(I-1)*CI2+WA1(I)*CR2
            CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3
            CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3
            CH(I-1,K,4) = WA3(I-1)*CR4-WA3(I)*CI4
            CH(I,K,4) = WA3(I-1)*CI4+WA3(I)*CR4
  106    CONTINUE
  107 CONTINUE
      RETURN
      END
CDECK DURAB5
      SUBROUTINE DURAB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)     ,WA4(1)
c
      DATA TR11,TI11,TR12,TI12 /.309016994374947D0,.951056516295154D0,
     1-.809016994374947D0,.587785252292473D0/
c
      done=1
      pi=atan(done)*4
      tr11=sin(pi/10)
      ti11=cos(pi/10)
      tr12=-(ti11+done/2)
      tr12=-cos(pi/5)
      ti12=sin(pi/5)
c
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI5 = CC(2,2,K)-CC(2,5,K)
         TI2 = CC(2,2,K)+CC(2,5,K)
         TI4 = CC(2,3,K)-CC(2,4,K)
         TI3 = CC(2,3,K)+CC(2,4,K)
         TR5 = CC(1,2,K)-CC(1,5,K)
         TR2 = CC(1,2,K)+CC(1,5,K)
         TR4 = CC(1,3,K)-CC(1,4,K)
         TR3 = CC(1,3,K)+CC(1,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CH(2,K,1) = CC(2,1,K)+TI2+TI3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
         CR5 = TI11*TR5+TI12*TR4
         CI5 = TI11*TI5+TI12*TI4
         CR4 = TI12*TR5-TI11*TR4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,5) = CR2+CI5
         CH(2,K,2) = CI2+CR5
         CH(2,K,3) = CI3+CR4
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(2,K,4) = CI3-CR4
         CH(2,K,5) = CI2-CR5
  101 CONTINUE
      RETURN
  102 IF(IDO/2.LT.L1) GO TO 105
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=2,IDO,2
            TI5 = CC(I,2,K)-CC(I,5,K)
            TI2 = CC(I,2,K)+CC(I,5,K)
            TI4 = CC(I,3,K)-CC(I,4,K)
            TI3 = CC(I,3,K)+CC(I,4,K)
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
            CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4
            CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4
            CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5
            CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5
  103    CONTINUE
  104 CONTINUE
      RETURN
  105 DO 107 I=2,IDO,2
CDIR$ IVDEP
         DO 106 K=1,L1
            TI5 = CC(I,2,K)-CC(I,5,K)
            TI2 = CC(I,2,K)+CC(I,5,K)
            TI4 = CC(I,3,K)-CC(I,4,K)
            TI3 = CC(I,3,K)+CC(I,4,K)
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2-WA1(I)*DI2
            CH(I,K,2) = WA1(I-1)*DI2+WA1(I)*DR2
            CH(I-1,K,3) = WA2(I-1)*DR3-WA2(I)*DI3
            CH(I,K,3) = WA2(I-1)*DI3+WA2(I)*DR3
            CH(I-1,K,4) = WA3(I-1)*DR4-WA3(I)*DI4
            CH(I,K,4) = WA3(I-1)*DI4+WA3(I)*DR4
            CH(I-1,K,5) = WA4(I-1)*DR5-WA4(I)*DI5
            CH(I,K,5) = WA4(I-1)*DI5+WA4(I)*DR5
  106    CONTINUE
  107 CONTINUE
      RETURN
      END
CDECK DURAB
      SUBROUTINE DURAB (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,WA(1)      ,C2(IDL1,IP),
     2                CH2(IDL1,IP)
      IDOT = IDO/2
      NT = IP*IDL1
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IDP = IP*IDO
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 J=2,IPPH
         JC = IPP2-J
         DO 102 K=1,L1
CDIR$ IVDEP
            DO 101 I=1,IDO
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  101       CONTINUE
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
CDIR$ IVDEP
         DO 104 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 112
  106 DO 109 J=2,IPPH
         JC = IPP2-J
         DO 108 I=1,IDO
CDIR$ IVDEP
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      DO 111 I=1,IDO
CDIR$ IVDEP
         DO 110 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  110    CONTINUE
  111 CONTINUE
  112 IDL = 2-IDO
      INC = 0
      DO 116 L=2,IPPH
         LC = IPP2-L
         IDL = IDL+IDO
CDIR$ IVDEP
         DO 113 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
            C2(IK,LC) = WA(IDL)*CH2(IK,IP)
  113    CONTINUE
         IDLJ = IDL
         INC = INC+IDO
         DO 115 J=3,IPPH
            JC = IPP2-J
            IDLJ = IDLJ+INC
            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
            WAR = WA(IDLJ-1)
            WAI = WA(IDLJ)
CDIR$ IVDEP
            DO 114 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)+WAI*CH2(IK,JC)
  114       CONTINUE
  115    CONTINUE
  116 CONTINUE
      DO 118 J=2,IPPH
CDIR$ IVDEP
         DO 117 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  117    CONTINUE
  118 CONTINUE
      DO 120 J=2,IPPH
         JC = IPP2-J
CDIR$ IVDEP
         DO 119 IK=2,IDL1,2
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  119    CONTINUE
  120 CONTINUE
      NAC = 1
      IF (IDO .EQ. 2) RETURN
      NAC = 0
      DO 121 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  121 CONTINUE
      DO 123 J=2,IP
CDIR$ IVDEP
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  122    CONTINUE
  123 CONTINUE
      IF (IDOT .GT. L1) GO TO 127
      IDIJ = 0
      DO 126 J=2,IP
         IDIJ = IDIJ+2
         DO 125 I=4,IDO,2
            IDIJ = IDIJ+2
CDIR$ IVDEP
            DO 124 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  124       CONTINUE
  125    CONTINUE
  126 CONTINUE
      RETURN
  127 IDJ = 2-IDO
      DO 130 J=2,IP
         IDJ = IDJ+IDO
         DO 129 K=1,L1
            IDIJ = IDJ
CDIR$ IVDEP
            DO 128 I=4,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  128       CONTINUE
  129    CONTINUE
  130 CONTINUE
      RETURN
      END
CDECK DCFFTF
C     ******************************************************************
C
C     SUBROUTINE DCFFTF(N,C,WSAVE)
C
C     ******************************************************************
C
C     SUBROUTINE DCFFTF COMPUTES THE FORWARD COMPLEX DISCRETE FOURIER
C     TRANSFORM (THE FOURIER ANALYSIS). EQUIVALENTLY , DCFFTF COMPUTES
C     THE FOURIER COEFFICIENTS OF A COMPLEX PERIODIC SEQUENCE.
C     THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER C.
C
C     THE TRANSFORM IS NOT NORMALIZED. TO OBTAIN A NORMALIZED TRANSFORM
C     THE OUTPUT MUST BE DIVIDED BY N. OTHERWISE A CALL OF DCFFTF
C     FOLLOWED BY A CALL OF DCFFTB WILL MULTIPLY THE SEQUENCE BY N.
C
C     THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE DCFFTF MUST BE
C     INITIALIZED BY CALLING SUBROUTINE DCFFTI(N,WSAVE).
C
C     INPUT PARAMETERS
C
C
C     N      THE LENGTH OF THE COMPLEX SEQUENCE C. THE METHOD IS
C            MORE EFFICIENT WHEN N IS THE PRODUCT OF SMALL PRIMES. N
C
C     C      A COMPLEX ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C
C     WSAVE   A REAL WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 4N+15
C             IN THE PROGRAM THAT CALLS DCFFTF. THE WSAVE ARRAY MUST BE
C             INITIALIZED BY CALLING SUBROUTINE DCFFTI(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 THUS SUBSEQUENT
C             TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C             THE SAME WSAVE ARRAY CAN BE USED BY DCFFTF AND DCFFTB.
C
C     OUTPUT PARAMETERS
C
C     C      FOR J=1,...,N
C
C                C(J)=THE SUM FROM K=1,...,N OF
C
C                      C(K)*EXP(-I*J*K*2*PI/N)
C
C                            WHERE I=SQRT(-1)
C
C     WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C             DESTROYED BETWEEN CALLS OF SUBROUTINE DCFFTF OR DCFFTB
C
      SUBROUTINE DCFFTF (N,C,WSAVE)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       C(1)       ,WSAVE(1)
      IF (N .EQ. 1) RETURN
      IW1 = N+N+1
      IW2 = IW1+N+N
      CALL DURAF1 (N,C,WSAVE,WSAVE(IW1),WSAVE(IW2))
      RETURN
      END
CDECK DURAF1
      SUBROUTINE DURAF1 (N,C,CH,WA,IFAC)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CH(1)      ,C(1)       ,WA(1)      ,IFAC(1)
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDOT = IDO+IDO
         IDL1 = IDOT*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IF (NA .NE. 0) GO TO 101
         CALL DURAF4 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL DURAF4 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL DURAF2 (IDOT,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL DURAF2 (IDOT,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDOT
         IF (NA .NE. 0) GO TO 107
         CALL DURAF3 (IDOT,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL DURAF3 (IDOT,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDOT
         IX3 = IX2+IDOT
         IX4 = IX3+IDOT
         IF (NA .NE. 0) GO TO 110
         CALL DURAF5 (IDOT,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL DURAF5 (IDOT,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL DURAF (NAC,IDOT,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL DURAF (NAC,IDOT,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (NAC .NE. 0) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDOT
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      N2 = N+N
      DO 117 I=1,N2
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END
CDECK DURAF2
      SUBROUTINE DURAF2 (IDO,L1,CC,CH,WA1)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,
     1                WA1(1)
      IF (IDO .GT. 2) GO TO 102
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(1,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(1,2,K)
         CH(2,K,1) = CC(2,1,K)+CC(2,2,K)
         CH(2,K,2) = CC(2,1,K)-CC(2,2,K)
  101 CONTINUE
      RETURN
  102 IF(IDO/2.LT.L1) GO TO 105
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=2,IDO,2
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            TI2 = CC(I,1,K)-CC(I,2,K)
            CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2
            CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2
  103    CONTINUE
  104 CONTINUE
      RETURN
  105 DO 107 I=2,IDO,2
CDIR$ IVDEP
      DO 106 K=1,L1
            CH(I-1,K,1) = CC(I-1,1,K)+CC(I-1,2,K)
            TR2 = CC(I-1,1,K)-CC(I-1,2,K)
            CH(I,K,1) = CC(I,1,K)+CC(I,2,K)
            TI2 = CC(I,1,K)-CC(I,2,K)
            CH(I,K,2) = WA1(I-1)*TI2-WA1(I)*TR2
            CH(I-1,K,2) = WA1(I-1)*TR2+WA1(I)*TI2
  106    CONTINUE
  107 CONTINUE
      RETURN
      END
CDECK DURAF3
      SUBROUTINE DURAF3 (IDO,L1,CC,CH,WA1,WA2)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(1)     ,WA2(1)
c
cccc      DATA TAUR,TAUI /-.5D0,-.866025403784439D0/
c
      taur=1
      taur=-taur/2
      taui=3
      taui=taui/4
      taui=-sqrt(taui)
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TR2 = CC(1,2,K)+CC(1,3,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         TI2 = CC(2,2,K)+CC(2,3,K)
         CI2 = CC(2,1,K)+TAUR*TI2
         CH(2,K,1) = CC(2,1,K)+TI2
         CR3 = TAUI*(CC(1,2,K)-CC(1,3,K))
         CI3 = TAUI*(CC(2,2,K)-CC(2,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
         CH(2,K,2) = CI2+CR3
         CH(2,K,3) = CI2-CR3
  101 CONTINUE
      RETURN
  102 IF(IDO/2.LT.L1) GO TO 105
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=2,IDO,2
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
  103    CONTINUE
  104 CONTINUE
      RETURN
  105 DO 107 I=2,IDO,2
CDIR$ IVDEP
         DO 106 K=1,L1
            TR2 = CC(I-1,2,K)+CC(I-1,3,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,2,K)+CC(I,3,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,2,K)-CC(I-1,3,K))
            CI3 = TAUI*(CC(I,2,K)-CC(I,3,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
  106    CONTINUE
  107 CONTINUE
      RETURN
      END
CDECK DURAF4
      SUBROUTINE DURAF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI1 = CC(2,1,K)-CC(2,3,K)
         TI2 = CC(2,1,K)+CC(2,3,K)
         TR4 = CC(2,2,K)-CC(2,4,K)
         TI3 = CC(2,2,K)+CC(2,4,K)
         TR1 = CC(1,1,K)-CC(1,3,K)
         TR2 = CC(1,1,K)+CC(1,3,K)
         TI4 = CC(1,4,K)-CC(1,2,K)
         TR3 = CC(1,2,K)+CC(1,4,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,3) = TR2-TR3
         CH(2,K,1) = TI2+TI3
         CH(2,K,3) = TI2-TI3
         CH(1,K,2) = TR1+TR4
         CH(1,K,4) = TR1-TR4
         CH(2,K,2) = TI1+TI4
         CH(2,K,4) = TI1-TI4
  101 CONTINUE
      RETURN
  102 IF(IDO/2.LT.L1) GO TO 105
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=2,IDO,2
            TI1 = CC(I,1,K)-CC(I,3,K)
            TI2 = CC(I,1,K)+CC(I,3,K)
            TI3 = CC(I,2,K)+CC(I,4,K)
            TR4 = CC(I,2,K)-CC(I,4,K)
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)
            TI4 = CC(I-1,4,K)-CC(I-1,2,K)
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2
            CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2
            CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3
            CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3
            CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4
            CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4
  103    CONTINUE
  104 CONTINUE
      RETURN
  105 DO 107 I=2,IDO,2
CDIR$ IVDEP
         DO 106 K=1,L1
            TI1 = CC(I,1,K)-CC(I,3,K)
            TI2 = CC(I,1,K)+CC(I,3,K)
            TI3 = CC(I,2,K)+CC(I,4,K)
            TR4 = CC(I,2,K)-CC(I,4,K)
            TR1 = CC(I-1,1,K)-CC(I-1,3,K)
            TR2 = CC(I-1,1,K)+CC(I-1,3,K)
            TI4 = CC(I-1,4,K)-CC(I-1,2,K)
            TR3 = CC(I-1,2,K)+CC(I-1,4,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1+TR4
            CR4 = TR1-TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-1)*CR2+WA1(I)*CI2
            CH(I,K,2) = WA1(I-1)*CI2-WA1(I)*CR2
            CH(I-1,K,3) = WA2(I-1)*CR3+WA2(I)*CI3
            CH(I,K,3) = WA2(I-1)*CI3-WA2(I)*CR3
            CH(I-1,K,4) = WA3(I-1)*CR4+WA3(I)*CI4
            CH(I,K,4) = WA3(I-1)*CI4-WA3(I)*CR4
  106    CONTINUE
  107 CONTINUE
      RETURN
      END
CDECK DURAF5
      SUBROUTINE DURAF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,
     1                WA1(1)     ,WA2(1)     ,WA3(1)     ,WA4(1)
c
      DATA TR11,TI11,TR12,TI12 /.309016994374947D0,-.951056516295154D0,
     1-.809016994374947D0,-.587785252292473D0/
c
      done=1
      pi=atan(done)*4
      tr11=sin(pi/10)
      ti11=-cos(pi/10)

cc      tr12=-(ti11+done/2)

      tr12=-cos(pi/5)
      ti12=-sin(pi/5)
c
      IF (IDO .NE. 2) GO TO 102
      DO 101 K=1,L1
         TI5 = CC(2,2,K)-CC(2,5,K)
         TI2 = CC(2,2,K)+CC(2,5,K)
         TI4 = CC(2,3,K)-CC(2,4,K)
         TI3 = CC(2,3,K)+CC(2,4,K)
         TR5 = CC(1,2,K)-CC(1,5,K)
         TR2 = CC(1,2,K)+CC(1,5,K)
         TR4 = CC(1,3,K)-CC(1,4,K)
         TR3 = CC(1,3,K)+CC(1,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CH(2,K,1) = CC(2,1,K)+TI2+TI3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CI2 = CC(2,1,K)+TR11*TI2+TR12*TI3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI3 = CC(2,1,K)+TR12*TI2+TR11*TI3
         CR5 = TI11*TR5+TI12*TR4
         CI5 = TI11*TI5+TI12*TI4
         CR4 = TI12*TR5-TI11*TR4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,5) = CR2+CI5
         CH(2,K,2) = CI2+CR5
         CH(2,K,3) = CI3+CR4
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(2,K,4) = CI3-CR4
         CH(2,K,5) = CI2-CR5
  101 CONTINUE
      RETURN
  102 IF(IDO/2.LT.L1) GO TO 105
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=2,IDO,2
            TI5 = CC(I,2,K)-CC(I,5,K)
            TI2 = CC(I,2,K)+CC(I,5,K)
            TI4 = CC(I,3,K)-CC(I,4,K)
            TI3 = CC(I,3,K)+CC(I,4,K)
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4
            CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4
            CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5
            CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5
  103    CONTINUE
  104 CONTINUE
      RETURN
  105 DO 107 I=2,IDO,2
CDIR$ IVDEP
         DO 106 K=1,L1
            TI5 = CC(I,2,K)-CC(I,5,K)
            TI2 = CC(I,2,K)+CC(I,5,K)
            TI4 = CC(I,3,K)-CC(I,4,K)
            TI3 = CC(I,3,K)+CC(I,4,K)
            TR5 = CC(I-1,2,K)-CC(I-1,5,K)
            TR2 = CC(I-1,2,K)+CC(I-1,5,K)
            TR4 = CC(I-1,3,K)-CC(I-1,4,K)
            TR3 = CC(I-1,3,K)+CC(I-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-1)*DR2+WA1(I)*DI2
            CH(I,K,2) = WA1(I-1)*DI2-WA1(I)*DR2
            CH(I-1,K,3) = WA2(I-1)*DR3+WA2(I)*DI3
            CH(I,K,3) = WA2(I-1)*DI3-WA2(I)*DR3
            CH(I-1,K,4) = WA3(I-1)*DR4+WA3(I)*DI4
            CH(I,K,4) = WA3(I-1)*DI4-WA3(I)*DR4
            CH(I-1,K,5) = WA4(I-1)*DR5+WA4(I)*DI5
            CH(I,K,5) = WA4(I-1)*DI5-WA4(I)*DR5
  106    CONTINUE
  107 CONTINUE
      RETURN
      END
CDECK DURAF
      SUBROUTINE DURAF (NAC,IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
        IMPLICIT REAL *8 (A-H,O-Z)
        save
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,WA(1)      ,C2(IDL1,IP),
     2                CH2(IDL1,IP)
      IDOT = IDO/2
      NT = IP*IDL1
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IDP = IP*IDO
C
      IF (IDO .LT. L1) GO TO 106
      DO 103 J=2,IPPH
         JC = IPP2-J
         DO 102 K=1,L1
CDIR$ IVDEP
            DO 101 I=1,IDO
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  101       CONTINUE
  102    CONTINUE
  103 CONTINUE
      DO 105 K=1,L1
CDIR$ IVDEP
         DO 104 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
      GO TO 112
  106 DO 109 J=2,IPPH
         JC = IPP2-J
         DO 108 I=1,IDO
CDIR$ IVDEP
            DO 107 K=1,L1
               CH(I,K,J) = CC(I,J,K)+CC(I,JC,K)
               CH(I,K,JC) = CC(I,J,K)-CC(I,JC,K)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      DO 111 I=1,IDO
CDIR$ IVDEP
         DO 110 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  110    CONTINUE
  111 CONTINUE
  112 IDL = 2-IDO
      INC = 0
      DO 116 L=2,IPPH
         LC = IPP2-L
         IDL = IDL+IDO
CDIR$ IVDEP
         DO 113 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+WA(IDL-1)*CH2(IK,2)
            C2(IK,LC) = -WA(IDL)*CH2(IK,IP)
  113    CONTINUE
         IDLJ = IDL
         INC = INC+IDO
         DO 115 J=3,IPPH
            JC = IPP2-J
            IDLJ = IDLJ+INC
            IF (IDLJ .GT. IDP) IDLJ = IDLJ-IDP
            WAR = WA(IDLJ-1)
            WAI = WA(IDLJ)
CDIR$ IVDEP
            DO 114 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+WAR*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)-WAI*CH2(IK,JC)
  114       CONTINUE
  115    CONTINUE
  116 CONTINUE
      DO 118 J=2,IPPH
CDIR$ IVDEP
         DO 117 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  117    CONTINUE
  118 CONTINUE
      DO 120 J=2,IPPH
         JC = IPP2-J
CDIR$ IVDEP
         DO 119 IK=2,IDL1,2
            CH2(IK-1,J) = C2(IK-1,J)-C2(IK,JC)
            CH2(IK-1,JC) = C2(IK-1,J)+C2(IK,JC)
            CH2(IK,J) = C2(IK,J)+C2(IK-1,JC)
            CH2(IK,JC) = C2(IK,J)-C2(IK-1,JC)
  119    CONTINUE
  120 CONTINUE
      NAC = 1
      IF (IDO .EQ. 2) RETURN
      NAC = 0
CDIR$ IVDEP
      DO 121 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  121 CONTINUE
      DO 123 J=2,IP
CDIR$ IVDEP
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)
            C1(2,K,J) = CH(2,K,J)
  122    CONTINUE
  123 CONTINUE
      IF (IDOT .GT. L1) GO TO 127
      IDIJ = 0
      DO 126 J=2,IP
         IDIJ = IDIJ+2
         DO 125 I=4,IDO,2
            IDIJ = IDIJ+2
CDIR$ IVDEP
            DO 124 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  124       CONTINUE
  125    CONTINUE
  126 CONTINUE
      RETURN
  127 IDJ = 2-IDO
      DO 130 J=2,IP
         IDJ = IDJ+IDO
         DO 129 K=1,L1
            IDIJ = IDJ
CDIR$ IVDEP
            DO 128 I=4,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)+WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)-WA(IDIJ)*CH(I-1,K,J)
  128       CONTINUE
  129    CONTINUE
  130 CONTINUE
      RETURN
      END
         SUBROUTINE DURDEC(F,C,COSCOE,SINCOE,W,WSAVE)
        save
         COMPLEX *16 F(1),C,COSCOE(1),SINCOE(1),W(1),WSAVE(1),IMA,
     1              IM05,ALK,BETK,AK,BK
        REAL *8 DHALF,D1
        DATA IMA/(0.0D0,1.0D0)/,DHALF/0.5D0/
C
C        COPY THE ARRAY INTO W
C
        DO 1200 I=1,N
        W(I)=F(I)
 1200 CONTINUE
C
C        FOURIER TRANSFORM W
C
        CALL DCFFTF(N,W,WSAVE)
C        CALL PRIN('INSIDE FURDEC W IS*',W,N*2)
C
C        SEPARATE INTO SINES AND COSINES
C
        C=W(1)/N
        DO 1400 I=1,NHALF
        I1=I+1
        IN1=N-I+1
        ALK=W(I1)
        BETK=W(IN1)
C       CALL PRIN('BEFORE DO LOOP INSIDE FURDEC IM05 IS*',IM05,2)
        COSCOE(I)=D1 *(ALK+BETK)
        SINCOE(I)=IM05*(ALK-BETK)
 1400 CONTINUE
C       CALL PRIN('INSIDE FURDEC SINCOE IS*',SINCOE,NHALF*2)
        RETURN
C
C
C
C
        ENTRY DURINI(WSAVE,N77)
        N=N77
        CALL DCFFTI(N,WSAVE)
        NHALF= N   /2
        IM05=IMA*0.5*2.0/N
        D1=1
        D1=D1/N
        RETURN
C
C
C
C
        ENTRY DURSYN(C,COSCOE,SINCOE,F,WSAVE)
C
C        MERGE SINES AND COSINES INTO EXPONENTIIALS
C
        F(1)=C
        DO 2200 I=1,NHALF
        I1=I+1
        IN1=N-I+1
        AK=COSCOE(I)*DHALF
        BK=SINCOE(I)*DHALF
        F(I1)=AK-IMA*BK
        F(IN1)=AK+IMA*BK
 2200 CONTINUE
C
C        PERFORM THE FOURIER TRANSFORMATION
C
        CALL DCFFTB(N,F,WSAVE)
        RETURN
        END


module quartiles

  implicit none
  private :: quicksort
  public :: quart

   contains

subroutine quart(x, ntr, nt)
use my_init

implicit none
integer, intent(in):: ntr , nt
integer ::  i, k
real(wp), intent(in) :: x(ntr,nt)
real(wp), parameter :: q1 = 0.25_wp, q3 = 0.75_wp
real(wp) :: qh , ql

!dumies
real(wp) :: c, tol, diff1, diff2
integer :: n, ib1,ib2
real(wp) :: y(ntr)

tol = 1.E-8
ib1 = int( ntr * q1 - mod (ntr * q1 , one) )
diff1 = mod(ntr * q1 , one) - rero

ib2 = int( ntr * q3 - mod (ntr * q3 , one) )
diff2 = mod(ntr * q3 , one) - rero

do i = 1 , nt

  do k = 1 , ntr
    y(k) = x(k,i)
  enddo

call quicksort(y, 1, ntr)

  if(diff1 <= tol) then
    ql = ( y(ib1 + 1) + y(ib1) ) / two
  else
    ql = y( ib1 + 1 )
  end if

  if(diff2 <= tol) then
    qh = ( y(ib2 + 1) + y(ib2) ) / two
  else
    qh = y( ib2 + 1 )
  end if

  write(105,'(i8,2ES24.13E3)') i , ql, qh
enddo

end subroutine

recursive subroutine quicksort(a, first, last)
  use my_init
  implicit none

  real(wp), intent(inout) ::  a(last)
  real(wp) :: x, t
  integer, intent(in) :: first, last
  integer i, j

  x = a( (first+last) / 2 )
  i = first
  j = last
  do
     do while (a(i) < x)
        i = i + 1
     end do
     do while (x < a(j))
        j = j - 1
     end do
     if (i >= j) exit
     t = a(i);  a(i) = a(j);  a(j) = t
     i=i+1
     j=j-1
  end do
  if (first < i-1) call quicksort(a, first, i-1)
  if (j+1 < last)  call quicksort(a, j+1, last)

end subroutine quicksort

end module


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine error(u, errnm, nx, nxmax, ny, nz)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c   compute the solution error
c
c---------------------------------------------------------------------

      implicit none

      include 'header.h'
      integer nx, nxmax, ny, nz
      double precision u(5,nxmax,ny,nz), errnm(5)

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k, m
      double precision  tmp
      double precision  u000ijk(5)

      do m = 1, 5
         errnm(m) = 0.0d0
      end do

      do k = 2, nz-1
         do j = 2, ny-1
            do i = 2, nx-1
               call exact( i, j, k, u000ijk, nx, ny, nz )
               do m = 1, 5
                  tmp = ( u000ijk(m) - u(m,i,j,k) )
                  errnm(m) = errnm(m) + tmp ** 2
               end do
            end do
         end do
      end do

      do m = 1, 5
         errnm(m) = dsqrt ( errnm(m) / ( dble(nx-2)*(ny-2)*(nz-2) ) )
      end do

      return
      end


module param
    parameter nu = 10
    real*8 U0, dUdx
    real*8 U(nu)
end module param

module mtr
    parameter (nx = 100)
    parameter nL = 102, nt = 8
    real*8 Nd(-nx - 1:nx + 1), x(-nx - 1:nx + 1)
    real*8 xL(nl), Yl(nl, nt), Y1(nl), ts(nt), xmax
    integer JF(nt), it, its
    real*8 Xx(50, nt), CSD(50, nt)
end module mtr

program main
end program main


! -*- Mode: Fortran90; -*-
!-----------------------------------------------------------------
! Daniel R. Reynolds
! SMU, Mathematics
! Math 4370/6370
! 7 February 2015
!=================================================================

program DotProd
  !-----------------------------------------------------------------
  ! Description:
  !    Computes the dot-product of two vectors.
  !-----------------------------------------------------------------
  !======= Inclusions ===========

  !======= Declarations =========
  implicit none

  integer, parameter :: MAX_INTEGER_DIGITS = 10
  integer :: n, i
  character(MAX_INTEGER_DIGITS) :: n_string
  double precision, allocatable :: a(:), b(:)
  double precision :: sum, stime, ftime, alloctime, inittime, runtime

  !======= Internals ============

  ! get n from the command line
  call getarg(1, n_string)

  ! ensure that an argument was passed in
  if ( n_string == '' ) then
     stop 'Error: function requires one argument (vector length)'
  endif

  ! convert n_string to integer, and ensure it's positive
  read (n_string, *) n
  if ( n < 1 ) then
     stop 'Error: vector length must be greater than 0'
  endif

  ! allocate the vectors
  call get_time(stime)
  allocate(a(n),b(n))
  call get_time(ftime)
  alloctime = ftime-stime

  ! initialize the vector values
  call get_time(stime)
  do i=1,n
     a(i) = 1.d-3*i/n
     b(i) = 1.d-3*(n-i)/n
  enddo
  call get_time(ftime)
  inittime = ftime-stime

  ! compute dot-product
  call get_time(stime)
  sum = 0.d0
  do i=1,n,1
     sum = sum + a(i)*b(i)
  enddo
  call get_time(ftime)
  runtime = ftime-stime

  ! output computed value and runtime
  print *, ' vector length =',n
  print *, '  dot-product =',sum
  print *, '    alloctime =',alloctime
  print *, '     inittime =',inittime
  print *, '      runtime =',runtime

  ! free vectors
  deallocate(a,b)

end program DotProd
!=================================================================


program test_free_energy3

! nuclear charge: 1 Gaussian
! electronic charge: 1 Gaussian
! calculation: single free energy evaluation

! This test uses FE and produces the same result as test_free_energy_fft

use types, only: dp
use ofdft_fe, only: free_energy2
use constants, only: Ha2eV, pi
use utils, only: loadtxt, assert
use splines, only: spline3pars, iixmin, poly3
use interp3d, only: trilinear
use feutils, only: quad_lobatto
use converged_energies, only: one_gaussian
implicit none
real(dp) :: Eee, Een, Ts, Exc, Etot, Etot_conv
integer :: p, DOF, Nq
real(dp) :: Z
real(dp) :: Rcut, L, T_eV, T_au

Z = 1
Rcut = 0.3_dp
p = 8
L = 2
T_eV = 0.0862_dp
T_au = T_ev / Ha2eV
Nq = 9
call free_energy2(1._dp, L, 9, 9, 9, p, T_au, nen, ne, &
        Nq, quad_lobatto, &
        Eee, Een, Ts, Exc, DOF)
Etot = Ts + Een + Eee + Exc
Etot_conv = sum(one_gaussian)
print *, "p =", p
print *, "DOF =", DOF
print *, "Rcut =", Rcut
print *, "T_au =", T_au
print *, "Summary of energies [a.u.]:"
print "('    Ts   = ', f14.8)", Ts
print "('    Een  = ', f14.8)", Een
print "('    Eee  = ', f14.8)", Eee
print "('    Exc  = ', f14.8)", Exc
print *, "   ---------------------"
print "('    Etot = ', f14.8, ' a.u. = ', f14.8, ' eV')", Etot, Etot*Ha2eV

print *, "Errors:"
print *, abs(Ts - one_gaussian(1))
print *, abs(Een - one_gaussian(2))
print *, abs(Eee - one_gaussian(3))
print *, abs(Exc - one_gaussian(4))
print *, abs(Etot - Etot_conv)
call assert(abs(Ts - one_gaussian(1)) < 1e-8_dp)
call assert(abs(Een - one_gaussian(2)) < 1e-8_dp)
call assert(abs(Eee - one_gaussian(3)) < 1e-8_dp)
call assert(abs(Exc - one_gaussian(4)) < 1e-8_dp)
call assert(abs(Etot - Etot_conv) < 1e-8_dp)

contains

real(dp) function nen(x, y, z_) result(n)
real(dp), intent(in) :: x, y, z_
real(dp), parameter :: alpha = 6
real(dp) :: r
r = sqrt((x-L/2-L/64)**2+(y-L/2)**2+(z_-L/2)**2)
! This density:
n = -Z*alpha**3/pi**(3._dp/2)*exp(-alpha**2*R**2)
! Corresponds to the potential:
!V = -Z*erf(alpha*R)/R
end function

real(dp) function ne(x, y, z) result(n)
real(dp), intent(in) :: x, y, z
real(dp), parameter :: alpha = 5, Z_ = 1
real(dp) :: r
r = sqrt((x-L/2)**2+(y-L/2)**2+(z-L/2)**2)
n = Z_*alpha**3/pi**(3._dp/2)*exp(-alpha**2*R**2)
end function

end program


C***BEGIN PROLOGUE  SWEBILU
C***REFER TO  SDASKR
C***DATE WRITTEN   020813   (YYMMDD)
C***REVISION DATE  021217   Added JROOT output value.
C
C***AUTHORS  A. C. Hindmarsh, P. N. Brown
C            Lawrence Livermore National Laboratory
C            Livermore, CA 94551, USA
C
C***DESCRIPTION
C
C-----------------------------------------------------------------------
C Example program for SDASKR.
C DAE system derived from ns-species interaction PDE in 2 dimensions.
C
C This is the single precision version.
C-----------------------------------------------------------------------
C
C This program solves a DAE system that arises from a system
C of partial differential equations.  The PDE system is a food web
C population model, with predator-prey interaction and diffusion on
C the unit square in two dimensions.  The dependent variable vector is
C
C         1   2        ns
C   c = (c , c , ..., c  )
C
C and the PDEs are as follows..
C
C     i               i      i
C   dc /dt  =  d(i)*(c    + c   )  +  R (x,y,c)  (i=1,...,ns/2)
C                     xx     yy        i
C
C                     i      i
C   0       =  d(i)*(c    + c   )  +  R (x,y,c)  (i=(ns/2)+1,...,ns)
C                     xx     yy        i
C
C where
C                  i          ns         j
C   R (x,y,c)  =  c *(b(i) + sum a(i,j)*c )
C    i                       j=1
C
C The number of species is ns = 2*np, with the first np being prey and
C the last np being predators.  The coefficients a(i,j), b(i), d(i) are
C
C   a(i,i) = -a  (all i)
C   a(i,j) = -g  (i .le. np, j .gt. np)
C   a(i,j) =  e  (i .gt. np, j .le. np)
C   b(i) =  b*(1 + alpha*x*y + beta*sin(4*pi*x)*sin(4*pi*y))  (i .le. np)
C   b(i) = -b*(1 + alpha*x*y + beta*sin(4*pi*x)*sin(4*pi*y))  (i .gt. np)
C   d(i) = dprey  (i .le. np)
C   d(i) = dpred  (i .gt. np)
C
C The various scalar parameters are set in subroutine SETPAR.
C
C The boundary conditions are.. normal derivative = 0.
C A polynomial in x and y is used to set the initial conditions.
C
C The PDEs are discretized by central differencing on a MX by MY mesh.
C
C The root function is R(Y) = average(c1) - 20.
C
C The DAE system is solved by SDASKR with a sparse approximate Jacobian
C matrix as the preconditioner for the preconditioned Krylov option of
C SDASKR.  The Jacobian is formed by using finite-differences of residual
C values, and is stored in sparse format (compressed sparse row).
C An incomplete factorization is then performed using the ILUT(P) routine
C of the SPARSKIT library of Yousef Saad at the University of Minnesota.
C
C The preconditioner is set up and solved in the three main
C subroutines --  SSPSETUP, SJACILU and SPSOLILU.
C These routines are provided separately for use on general DAE
C problems.
C
C Two output files are written.. one with the problem description and
C performance statistics on unit LOUT = 9, and one with solution
C profiles at selected output times on unit LCOUT = 10.
C-----------------------------------------------------------------------
C Note.. in addition to the main program and subroutines given below,
C this program requires the BLAS routine SAXPY.
C-----------------------------------------------------------------------
C References
C [1] Peter N. Brown and Alan C. Hindmarsh,
C     Reduced Storage Matrix Methods in Stiff ODE Systems,
C     J. Appl. Math. & Comp., 31 (1989), pp. 40-91.
C [2] Peter N. Brown, Alan C. Hindmarsh, and Linda R. Petzold,
C     Using Krylov Methods in the Solution of Large-Scale Differential-
C     Algebraic Systems, SIAM J. Sci. Comput., 15 (1994), pp. 1467-1488.
C [3] Peter N. Brown, Alan C. Hindmarsh, and Linda R. Petzold,
C     Consistent Initial Condition Calculation for Differential-
C     Algebraic Systems, LLNL Report UCRL-JC-122175, August 1995;
C     submitted to SIAM J. Sci. Comp.
C-----------------------------------------------------------------------
C***ROUTINES CALLED
C   SETPAR, CINIT, SDASKR, OUTWEB
C
C***END PROLOGUE  SWEBILU
C
      IMPLICIT REAL (A-H,O-Z)
      EXTERNAL RESWEB, RTWEB, SJACILU, SPSOLILU
C Load parameters for sparse preconditioner.
      PARAMETER (LENPFAC = 10)
      PARAMETER (LENPLUFAC = 2)
      PARAMETER (IPREMETH = 2)  ! =1 means ILUT preconditioner used
                                ! =2 means ILUTP preconditioner used
      PARAMETER (LFILILUT = 10)
      PARAMETER (IREORDER = 1)
      PARAMETER (ISRNORM = 1)
      PARAMETER (NORMTYPE = 2)
      PARAMETER (JACOUT = 0)
      PARAMETER (JSCALCOL = 1)
      PARAMETER (TOLILUT = 0.001)
      PARAMETER (PERMTOL = 0.01)
C
C Dimension solution arrays and work arrays.
C
C When INFO(12) = 1, with INFO(5) = 0, INFO(6) = 1:
C    The length required for RWORK is
C       101 + 3*NRT + 19*NEQ + LENWP,
C    where LENWP is given by
C       LENWP =  length of RWORK segment WP =
C              2*LENPFAC*NEQ + LENPLUFAC*NEQ + ISRNORM*NEQ + 2*(NEQ+1)
C    The length required for IWORK is
C       40 + NEQ + LENIWP,
C    where LENIWP is given by
C       LENIWP = length of IWORK segment IWP =
C              4*(NEQ+1) + 3*LENPFAC*NEQ + 2*LENPLUFAC*NEQ
C                 + 2*IREORDER*NEQ + 2*(IPREMETH-1)*NEQ
C
C The dimensions for the various arrays are set below using parameters
C   MAXN    which must be .ge. NEQ = NS*MX*MY,
C   MAXS    which must be .ge. NS.
C
      PARAMETER (MAXS = 2, MAXN = 800)
      PARAMETER (LENWP = 2*LENPFAC*MAXN + LENPLUFAC*MAXN
     1                   + ISRNORM*MAXN + 2*(MAXN+1) )
      PARAMETER (LENIWP = 4*(MAXN+1) + 3*LENPFAC*MAXN
     1                    + 2*LENPLUFAC*MAXN + IREORDER*2*MAXN
     2                    + (IPREMETH-1)*2*MAXN )
      PARAMETER (LENRW = 104 + 19*MAXN, LENIW  = 40,
     1           LRW = LENRW + LENWP, LIW = LENIW + 2*MAXN + LENIWP)
C
      DIMENSION CC(MAXN), CCPRIME(MAXN), RWORK(LRW), IWORK(LIW),
     1          INFO(20), RPAR(2+MAXN), IPAR(30)
C
C The COMMON blocks /PPAR1/ and /PPAR2/ contain problem parameters.
C
      COMMON /PPAR1/ AA, EE, GG, BB, DPREY, DPRED
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
C Set output unit numbers for main output and tabulated solution.
      DATA LOUT/9/, LCOUT/10/
C
C Set unit number for SDASKR error message output.
      CALL XSETUN(LOUT)
C
C Open output files.
      OPEN(UNIT=LOUT,FILE='wdout',STATUS='unknown')
      OPEN(UNIT=LCOUT,FILE='wccout',STATUS='unknown')
      IF (JACOUT .EQ. 1) THEN
         IPAR(29) = 1
         OPEN(UNIT=1, FILE='Web_Test_Matrix.dat', STATUS='unknown')
      ENDIF
C
C Call SETPAR to set basic problem parameters.
      CALL SETPAR
C
C Set remaining problem parameters.
      NEQ = NS*MX*MY
      MXNS = MX*NS
      DX = AX/REAL(MX-1)
      DY = AY/REAL(MY-1)
      DO 10 I = 1,NS
        COX(I) = DIFF(I)/DX**2
 10     COY(I) = DIFF(I)/DY**2
C
C Set NRT = number of root functions.
      NRT = 1
C
      WRITE(LOUT,20)NS
 20   FORMAT(' SWEBILU: Example program for SDASKR package'//
     1   ' Food web problem with NS species, NS =',I4/
     2   ' Predator-prey interaction and diffusion on a 2-D square'/)
      WRITE(LOUT,25) AA,EE,GG,BB,DPREY,DPRED, ALPH,BETA
 25   FORMAT(' Matrix parameters..  a =',E12.4,'   e =',E12.4,
     1   '   g =',E12.4/21x,' b parameter =',E12.4//
     2   ' Diffusion coefficients.. dprey =',E12.4,'   dpred =',E12.4//
     3   ' Rate parameters alpha =',E12.4,' and beta =',E12.4/)
      WRITE(LOUT,30) MX,MY,NEQ
 30   FORMAT(' Mesh dimensions (MX,MY) =',2I4,
     1   5x,' Total system size is NEQ =',I7/)
      WRITE(LOUT,35)
 35   FORMAT(' Root function is R(Y) = average(c1) - 20'/)
C
C Here set the flat initial guess for the predators.
      PREDIC = 1.0E5
C
C Load values into IPAR and RPAR for sparse preconditioner.
      ML = NS*MX + 1
      MU = ML
      IPAR(1) = ML
      IPAR(2) = MU
      IPAR(3) = LENPFAC
      IPAR(4) = LENPLUFAC
      IPAR(5) = IPREMETH
      IPAR(6) = LFILILUT
      IPAR(7) = IREORDER
      IPAR(8) = ISRNORM
      IPAR(9) = NORMTYPE
      IPAR(10) = JACOUT
      IPAR(11) = JSCALCOL
      IPAR(30) = 0
      RPAR(1) = TOLILUT
      RPAR(2) = PERMTOL
C Check IPAR, RPAR, LENWP and LENIWP for illegal entries and long
C enough work array lengths.
      CALL SSPSETUP (NEQ, LENWP, LENIWP, RPAR, IPAR, IERR,
     .               LWPMIN, LIWPMIN)
      IF (IERR .NE. 0) THEN
         WRITE(LOUT,45) IERR
 45      FORMAT(' Error return from SSPSETUP: IERR = ',i5)
         IF (LWPMIN .GT. LENWP) THEN
            WRITE(LOUT,*) ' More WP work array length needed'
         ENDIF
         IF (LIWPMIN .GT. LENIWP) THEN
            WRITE(LOUT,*) ' More IWP work array length needed'
         ENDIF
         STOP
      ENDIF
C
C Set remaining method parameters for SDASKR.
C These include the INFO array and tolerances.
C
      DO 50 I = 1,20
 50     INFO(I) = 0
C
C Here set INFO(11) = 1, indicating I.C. calculation requested.
      INFO(11) = 1
C
C Here set INFO(12) = 1, indicating the Krylov linear system method.
      INFO(12) = 1
C
C Here set INFO(14) = 1 to get the computed initial values.
      INFO(14) = 1
C
C Here set INFO(15) = 1 to signal that a preconditioner setup routine
C is to be called in the Krylov case.
      INFO(15) = 1
C
C Here set INFO(16) = 1 to get alternative error test (on the
C differential variables only).
      INFO(16) = 1
C
C Here set the tolerances.
      RTOL = 1.0E-5
      ATOL = RTOL
C
      WRITE(LOUT,70)RTOL,ATOL,INFO(11),PREDIC,INFO(16)
 70   FORMAT(' Tolerance parameters.. RTOL =',E10.2,'   ATOL =',E10.2//
     1   ' Internal I.C. calculation flag INFO(11) =',I2,
     2   '   (0 = off, 1 = on)'/
     3   ' Predator I.C. guess =',E10.2//
     4   ' Alternate error test flag INFO(16) =',I2,
     5        '  (0 = off, 1 = on)'/)
C
C Set NOUT = number of output times.
      NOUT = 18
C
C Set and print various preconditioner parameters.
      IWORK(27) = LENWP
      IWORK(28) = LENIWP
      WRITE(LOUT,100) IPREMETH
 100  FORMAT(' Linear solver is: Krylov with ILU preconditioner'/
     1       ' Preconditioner flag is IPREMETH =',I3,
     2       '  (1 = ILUT, 2 = ILUTP)')
C Here call SETID to set the IWORK segment ID  indicating the
C differential and algebraic components.
      CALL SETID (MX, MY, NS, NP, 40, IWORK)
C Set the initial T and TOUT, and call CINIT to set initial values.
      T = 0.0E0
      TOUT = 1.0E-8
      CALL CINIT (CC, CCPRIME, PREDIC, RPAR)
C
      NLI = 0
      NNI = 0
C
      WRITE(LOUT,140)
 140  FORMAT(//'   t',12X,'Ave.c1  NSTEP  NRE  NNI  NLI  NPE  NQ',4X,
     1       'H',10X,'AVLIN')
C
C Loop over output times and call SDASKR.  At each output time,
C print average c1 value and performance data.
C The first call, with IOUT = 0, is to calculate initial values only.
C After the first call, reset INFO(11) = 0 and the initial TOUT.
C If a root was found, we flag this, and return to the SDASKR call.
C
      DO 200 IOUT = 0,NOUT
C
 150    CALL SDASKR (RESWEB, NEQ, T, CC, CCPRIME, TOUT, INFO, RTOL,ATOL,
     1        IDID, RWORK,LRW, IWORK,LIW, RPAR, IPAR, SJACILU, SPSOLILU,
     2        RTWEB, NRT, JROOT)
C
        NST = IWORK(11)
        NRE = IWORK(12)
        NPE = IWORK(13)
        NNIDIF = IWORK(19) - NNI
        NNI = IWORK(19)
        NLIDIF = IWORK(20) - NLI
        NLI = IWORK(20)
        NQU = IWORK(8)
        HU = RWORK(7)
        AVLIN = 0.0E0
        IF (NNIDIF .GT. 0) AVLIN = REAL(NLIDIF)/REAL(NNIDIF)
C
        IMOD3 = IOUT - 3*(IOUT/3)
        IF (IMOD3 .EQ. 0) CALL OUTWEB (T, CC, NS, MX, MY, LCOUT)
C
        CALL AVC1 (CC, C1AVE)
        WRITE(LOUT,160)T,C1AVE,NST,NRE,NNI,NLI,NPE,NQU,HU,AVLIN
 160    FORMAT(E13.5,f10.5,I5,I6,3I5,I4,E11.2,F9.4)
        IF (IDID .EQ. 5) THEN
          WRITE(LOUT,165)JROOT
 165      FORMAT(15X,'*****   Root found, JROOT =',I3)
          GO TO 150
          ENDIF
C
        IF (IDID .LT. 0) THEN
          WRITE(LOUT,170)T
 170      FORMAT(//' Final time reached =',E12.4//)
          GO TO 210
          ENDIF
C
        IF (TOUT .GT. 0.9E0) TOUT = TOUT + 1.0E0
        IF (TOUT .LT. 0.9E0) TOUT = TOUT*10.0E0
        IF (IOUT .EQ. 0) THEN
          INFO(11) = 0
          TOUT = 1.0E-8
          NLI = 0
          NNI = 0
          ENDIF
 200    CONTINUE
C
 210  CONTINUE
      LNRW = IWORK(18)
      LNIW = IWORK(17)
      NST = IWORK(11)
      NRE = IWORK(12)
      NPE = IWORK(13)
      NNI = IWORK(19)
      NLI = IWORK(20)
      NPS = IWORK(21)
      IF (NNI .GT. 0) AVLIN = REAL(NLI)/REAL(NNI)
      NCFN = IWORK(15)
      NCFL = IWORK(16)
      NRTE = IWORK(36)
      WRITE(LOUT,220) LNRW,LNIW,NST,NRE,IPAR(30),NRTE,NPE,NPS,NNI,NLI,
     1                AVLIN,NCFN,NCFL
 220   FORMAT(//' Final statistics for this run..'/
     1   ' RWORK size =',I8,'   IWORK size =',I6/
     1   ' Number of time steps            =',I5/
     1   ' Number of residual evaluations  =',I5/
     1   ' Number of res. evals. for prec. =',I5/
     1   ' Number of root fn. evaluations  =',I5/
     1   ' Number of Jac. or prec. evals.  =',I5/
     1   ' Number of preconditioner solves =',I5/
     1   ' Number of nonlinear iterations  =',I5/
     1   ' Number of linear iterations     =',I5/
     1   ' Average Krylov subspace dimension =',F8.4/
     1   I3,' nonlinear conv. failures,',i5,' linear conv. failures')
      WRITE(LOUT,230) LWPMIN, LIWPMIN
 230  FORMAT(' Minimum lengths for work arrays WP and IWP: ',i7,1x,i7)
C
      STOP
C------  End of main program for SWEBILU example program ---------------
      END

      SUBROUTINE SETPAR
C-----------------------------------------------------------------------
C This routine sets the basic problem parameters, namely
C AX, AY, NS, MX, MY,  problem coefficients ACOEF, BCOEF, DIFF,
C ALPH, BETA, using parameters NP, AA, EE, GG, BB, DPREY, DPRED.
C-----------------------------------------------------------------------
      IMPLICIT REAL (A-H,O-Z)
      PARAMETER (MAXS = 2)
      COMMON /PPAR1/ AA, EE, GG, BB, DPREY, DPRED
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      AX = 1.0E0
      AY = 1.0E0
      NP = 1
      MX = 20
      MY = 20
      AA = 1.0E0
      EE = 1.0E4
      GG = 0.5E-6
      BB = 1.0E0
      DPREY = 1.0E0
      DPRED = 0.05E0
      ALPH = 50.0E0
      BETA = 100.0E0
      NS = 2*NP
      DO 20 J = 1,NP
        DO 10 I = 1,NP
          ACOEF(NP+I,J) = EE
          ACOEF(I,NP+J) = -GG
 10       CONTINUE
        ACOEF(J,J) = -AA
        ACOEF(NP+J,NP+J) = -AA
        BCOEF(J) = BB
        BCOEF(NP+J) = -BB
        DIFF(J) = DPREY
        DIFF(NP+J) = DPRED
 20     CONTINUE
      PI = 3.141592653589793E0
      FPI = 4.0E0*PI
C
      RETURN
C------------  End of Subroutine SETPAR  -------------------------------
      END

      SUBROUTINE SETID (MX, MY, NS, NSD, LID, IWORK)
C-----------------------------------------------------------------------
C This routine sets the ID array in IWORK, indicating which components
C are differential and which are algebraic.
C-----------------------------------------------------------------------
      DIMENSION IWORK(*)
C
      NSDP1 = NSD + 1
      DO 40 JY = 1,MY
        I00 = MX*NS*(JY-1) + LID
        DO 30 JX = 1,MX
          I0 = I00 + NS*(JX-1)
          DO 10 I = 1,NSD
 10         IWORK(I0+I) = 1
          DO 20 I = NSDP1,NS
 20         IWORK(I0+I) = -1
 30       CONTINUE
 40     CONTINUE
C
      RETURN
C------------  End of Subroutine SETID  --------------------------------
      END

      SUBROUTINE CINIT (CC, CCPRIME, PREDIC, RPAR)
C-----------------------------------------------------------------------
C This routine computes and loads the vectors of initial values.
C-----------------------------------------------------------------------
      IMPLICIT REAL (A-H,O-Z)
      DIMENSION CC(*), CCPRIME(*), RPAR(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
C Load CC.
      NPP1 = NP + 1
      DO 30 JY = 1,MY
        Y = REAL(JY-1)*DY
        ARGY = 16.0E0*Y*Y*(AY-Y)*(AY-Y)
        IYOFF = MXNS*(JY-1)
        DO 20 JX = 1,MX
          X = REAL(JX-1)*DX
          ARGX = 16.0E0*X*X*(AX-X)*(AX-X)
          IOFF = IYOFF + NS*(JX-1)
          FAC = 1.0E0 + ALPH*X*Y + BETA*SIN(FPI*X)*SIN(FPI*Y)
          DO 10 I = 1,NP
 10         CC(IOFF + I) = 10.0E0 + REAL(I)*ARGX*ARGY
          DO 15 I = NPP1,NS
 15         CC(IOFF + I) = PREDIC
 20       CONTINUE
 30     CONTINUE
C
C Load CCPRIME.
      T = 0.0E0
      CALL FWEB (T, CC, CCPRIME, RPAR)
      DO 60 JY = 1,MY
        IYOFF = MXNS*(JY-1)
        DO 50 JX = 1,MX
          IOFF = IYOFF + NS*(JX-1)
          DO 40 I = NPP1,NS
 40         CCPRIME(IOFF+I) = 0.0E0
 50     CONTINUE
 60   CONTINUE
C
      RETURN
C------------  End of Subroutine CINIT  --------------------------------
      END

      SUBROUTINE OUTWEB (T, C, NS, MX, MY, LUN)
C-----------------------------------------------------------------------
C This routine prints the values of the individual species densities
C at the current time T, to logical unit LUN.
C-----------------------------------------------------------------------
      IMPLICIT REAL (A-H,O-Z)
      DIMENSION C(NS,MX,MY)
C
      WRITE(LUN,10) T
 10   FORMAT(/1X,79('-')/30X,'At time t = ',E16.8/1X,79('-') )
C
      DO 40 I = 1,NS
        WRITE(LUN,20) I
 20     FORMAT(' the species c(',i2,') values are ')
        DO 30 JY = MY,1,-1
          WRITE(LUN,25) (C(I,JX,JY),JX=1,MX)
 25       FORMAT(6(1X,G12.6))
 30       CONTINUE
        WRITE(LUN,35)
 35     FORMAT(1X,79('-'),/)
 40     CONTINUE
C
      RETURN
C------------  End of Subroutine OUTWEB  -------------------------------
      END

      SUBROUTINE RESWEB (T, U, UPRIME, CJ, DELTA, IRES, RPAR, IPAR)
C-----------------------------------------------------------------------
C This routine computes the residual vector, using Subroutine FWEB
C for the right-hand sides.
C-----------------------------------------------------------------------
C
      IMPLICIT REAL (A-H,O-Z)
      DIMENSION U(*),UPRIME(*),DELTA(*),RPAR(*),IPAR(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      CALL FWEB (T, U, DELTA, RPAR)
C
      DO 30 JY = 1,MY
         IYOFF = MXNS*(JY-1)
         DO 20 JX = 1,MX
            IC0 = IYOFF + NS*(JX-1)
            DO 10 I = 1,NS
               ICI = IC0 + I
               IF (I .GT. NP) THEN
                  DELTA(ICI) = -DELTA(ICI)
               ELSE
                  DELTA(ICI) = UPRIME(ICI) - DELTA(ICI)
               ENDIF
 10         CONTINUE
 20      CONTINUE
 30   CONTINUE
C
      RETURN
C------------  End of Subroutine RESWEB  -------------------------------
      END

      SUBROUTINE FWEB (T, CC, CRATE, RPAR)
C-----------------------------------------------------------------------
C This routine computes the right-hand sides of all the equations
C and returns them in the array CRATE.
C The interaction rates are computed by calls to WEBR, and these are
C saved in RPAR(1),...,RPAR(NEQ) for use later in preconditioning.
C-----------------------------------------------------------------------
      IMPLICIT REAL (A-H,O-Z)
      DIMENSION CC(*), CRATE(*), RPAR(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      DO 60 JY = 1,MY
        IYOFF = MXNS*(JY-1)
        IDYU = MXNS
        IF (JY .EQ. MY) IDYU = -MXNS
        IDYL = MXNS
        IF (JY .EQ. 1) IDYL = -MXNS
        DO 40 JX = 1,MX
          IC = IYOFF + NS*(JX-1) + 1
C Get interaction rates at one point (X,Y).
          CALL WEBR (T, JX, JY, CC(IC), RPAR(2+IC))
          IDXU = NS
          IF (JX .EQ. MX) IDXU = -NS
          IDXL = NS
          IF (JX .EQ. 1) IDXL = -NS
          DO 20 I = 1,NS
            ICI = IC + I - 1
C Do differencing in Y.
            DCYLI = CC(ICI) - CC(ICI-IDYL)
            DCYUI = CC(ICI+IDYU) - CC(ICI)
C Do differencing in X.
            DCXLI = CC(ICI) - CC(ICI-IDXL)
            DCXUI = CC(ICI+IDXU) - CC(ICI)
C Collect terms and load CRATE elements.
            CRATE(ICI) = COY(I)*(DCYUI - DCYLI) + COX(I)*(DCXUI - DCXLI)
     1                  + RPAR(2+ICI)
 20         CONTINUE
 40       CONTINUE
 60    CONTINUE
      RETURN
C------------  End of Subroutine FWEB  ---------------------------------
      END

      SUBROUTINE WEBR (T, JX, JY, C, CRATE)
C-----------------------------------------------------------------------
C This routine computes one block of the interaction term R of the
C system, namely block (JX,JY), for use in preconditioning.
C-----------------------------------------------------------------------
      IMPLICIT REAL (A-H,O-Z)
      DIMENSION C(*), CRATE(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      Y = REAL(JY-1)*DY
      X = REAL(JX-1)*DX
      DO 10 I = 1,NS
 10     CRATE(I) = 0.0E0
      DO 15 J = 1,NS
        CALL SAXPY (NS, C(J), ACOEF(1,J), 1, CRATE, 1)
 15     CONTINUE
      FAC = 1.0E0 + ALPH*X*Y + BETA*SIN(FPI*X)*SIN(FPI*Y)
      DO 20 I = 1,NS
 20     CRATE(I) = C(I)*(BCOEF(I)*FAC + CRATE(I))
      RETURN
C------------  End of Subroutine WEBR  ---------------------------------
      END

      SUBROUTINE AVC1 (CC, C1AVE)
C-----------------------------------------------------------------------
C This routine computes the average value of c1.
C-----------------------------------------------------------------------
      IMPLICIT REAL (A-H,O-Z)
      DIMENSION CC(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, ALPH, BETA, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      SUM = 0.0E0
      NPP1 = NP + 1
      DO 30 JY = 1,MY
        IYOFF = MXNS*(JY-1)
        DO 20 JX = 1,MX
          IOFF = IYOFF + NS*(JX-1)
          SUM = SUM + CC(IOFF + 1)
 20       CONTINUE
 30     CONTINUE
C
      C1AVE = SUM/(MX*MY)
C
      RETURN
C------------  End of Subroutine AVC1  ---------------------------------
      END

      SUBROUTINE RTWEB(NEQ, T, CC, CP, NRT, RVAL, RPAR, IPAR)
C
C This routine sets RVAL = average(c1) - 20.0.
C
      IMPLICIT REAL (A-H,O-Z)
      DIMENSION CC(NEQ), CP(NEQ)
C
      CALL AVC1 (CC, C1AVE)
      RVAL = C1AVE - 20.0E0
C
      RETURN
C------------  End of Subroutine RTWEB  --------------------------------
      END


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_rot3_swapdiag
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine passes the generator for a Givens rotation represented
! by 3 real numbers: the real and imaginary parts of a complex cosine
! and a scrictly real sine through a 2x2 complex diagonal matrix
! represented by 4 real numbers.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  D               REAL(8) array of dimension (4)
!                    array of generators for complex diagonal matrix
!
!  G               REAL(8) array of dimension (3)
!                    generator for a Givens rotation
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_rot3_swapdiag(D,G)

  implicit none

  ! input variables
  real(8), intent(inout) :: D(4), G(3)

  ! compute variables
  real(8) :: c1r, c1i, s1
  real(8) :: d1r, d1i
  real(8) :: d2r, d2i
  real(8) :: nrm

  ! set inputs
  c1r = G(1)
  c1i = G(2)
  s1 = G(3)

  ! retrieve D
  d1r = D(1)
  d1i = D(2)
  d2r = D(3)
  d2i = D(4)

  ! from right to left and left to right
  ! pass through diagonal
  nrm = (d1r*d2r + d1i*d2i)*c1r - (-d1r*d2i + d1i*d2r)*c1i
  c1i = (d1r*d2r + d1i*d2i)*c1i + (-d1r*d2i + d1i*d2r)*c1r
  c1r = nrm

  ! renormalize
  call z_rot3_unitvec3gen(c1r,c1i,s1,G(1),G(2),G(3))

  ! set D
  D(1) = d2r
  D(2) = d2i
  D(3) = d1r
  D(4) = d1i

end subroutine z_rot3_swapdiag


program i
  integer::a
  a=(3 + 4) * 5 / 5 * 6 ** 7
end program i


!=======================================================================
!
!  Calculate the level populations of a given coolant by constructing
!  the matrix of transition rates and solving to find the populations
!  assuming statistical equilibrium. The resulting set of statistical
!  equilibrium equations take the form:
!
!     n_i.∑_j R_ij = ∑_j n_j.R_ji
!  or:
!     n_i.∑_j R_ij - ∑_j n_j.R_ji = 0
!
!  where n_i is the population density (cm^-3) of level i and R_ij is
!  the transition rate (s^-1) from level i to level j. By rearranging
!  these equations, they can then be put into the matrix form: A.n=0,
!  where A is a coefficient matrix and n is a vector containing the N
!  population densities of all the levels. The right-hand side of the
!  matrix equation is then a vector of length N, composed of zeroes.
!
!  The elements of the coefficient matrix A are specified as follows:
!
!     A_ij = -R_ji    (j≠i)
!     A_ii = ∑_j R_ij (j≠i)
!
!  Since this set of equilibrium equations is not independent, one of
!  the equations has to be replaced by the conservation equation:
!
!     ∑_j n_j = n_tot
!
!  where n_tot is the density of the coolant species in all levels.
!
!  Therefore, the last row of the coefficient matrix is replaced with
!  this summation over all levels, and the last right-hand-side value
!  is set to the total density of the coolant species (cm^-3).
!
!  This system of linear equations is then solved using Gauss-Jordan
!  elimination to determine the population densities of all N levels.
!
!-----------------------------------------------------------------------
SUBROUTINE CALCULATE_LEVEL_POPULATIONS(NRAYS,ID,COOLANT,PARTICLE)

   USE HEALPIX_TYPES
   USE COOLANT_MODULE
   USE PARTICLE_MODULE
   USE SUBROUTINES_MODULE
   USE TRANSITION_MATRIX_MODULE

   IMPLICIT NONE

   INTEGER(KIND=I4B),   INTENT(IN)    :: NRAYS
   INTEGER(KIND=I4B),   INTENT(IN)    :: ID
   TYPE(COOLANT_TYPE),  INTENT(IN)    :: COOLANT
   TYPE(PARTICLE_TYPE), INTENT(INOUT) :: PARTICLE

   INTEGER(KIND=I4B) :: I,J
   REAL(KIND=DP)     :: SUM
   REAL(KIND=DP), ALLOCATABLE :: R(:,:),A(:,:),B(:)

!  Allocate the arrays
   ALLOCATE(R(1:COOLANT%NLEVEL,1:COOLANT%NLEVEL))
   ALLOCATE(A(1:COOLANT%NLEVEL,1:COOLANT%NLEVEL))
   ALLOCATE(B(1:COOLANT%NLEVEL))

!  Construct the matrix of transition rates R_ij (s^-1)
   CALL CONSTRUCT_TRANSITION_MATRIX(NRAYS,ID,COOLANT,PARTICLE,R)

!  Fill the coefficient matrix A and the right-hand-side vector b
   DO I=1,COOLANT%NLEVEL
      SUM=0.0D0
      DO J=1,COOLANT%NLEVEL
         IF(J.EQ.I) CYCLE
         A(I,J) = -R(J,I)
         SUM=SUM+R(I,J)
      END DO
      A(I,I)=SUM
   END DO
   B=0.0D0

!  Replace the last equilibrium equation in the transition matrix with
!  the conservation equation (i.e. the sum of the population densities
!  over all levels), and replace the last entry in the right-hand-side
!  vector with the total density of the coolant species.
   A(COOLANT%NLEVEL,:)=1 ! Sum over all levels, ∑_j n_j
   B(COOLANT%NLEVEL)=PARTICLE%COOLANT(ID)%DENSITY

!  Call the Gauss-Jordan solver (the solution is returned in vector b)
   CALL GAUSS_JORDAN(COOLANT%NLEVEL,A,B)

!  Replace negative or NaN values caused by numerical noise around zero
   DO I=1,COOLANT%NLEVEL
      IF(.NOT.B(I).GE.0) B(I)=0.0D0
   END DO

!  Store the previously-calculated population densities for comparison
   PARTICLE%COOLANT(ID)%PREVIOUS_POPULATION=PARTICLE%COOLANT(ID)%POPULATION

!  Store the new population densities
   PARTICLE%COOLANT(ID)%POPULATION=B

   DEALLOCATE(R,A,B)

   RETURN
END SUBROUTINE CALCULATE_LEVEL_POPULATIONS
!=======================================================================

!=======================================================================
!
!  Standard linear equation solver using Gauss-Jordon elimination taken
!  directly from Numerical Recipes (Chapter B2).
!
!  A is an NxN input coefficient matrix, B is an input vector of size N
!  containing the right-hand-side values. On output, A is replaced by its
!  matrix inverse and B is replaced by the corresponding set of solution
!  values.
!
!-----------------------------------------------------------------------
SUBROUTINE GAUSS_JORDAN(N,A,B)

   USE HEALPIX_TYPES
   USE SWAP_FUNCTION

   IMPLICIT NONE

   INTEGER(KIND=I4B), INTENT(IN)    :: N
   REAL(KIND=DP),     INTENT(INOUT) :: A(:,:)
   REAL(KIND=DP),     INTENT(INOUT) :: B(:)

   INTEGER(KIND=I4B) :: I,J,K,L,IROW,ICOL
   INTEGER(KIND=I4B), ALLOCATABLE :: IPIV(:),INDEX_ROW(:),INDEX_COL(:)
   REAL(KIND=DP) :: MAX,DUMMY,PIVINV

   ALLOCATE(IPIV(1:N),INDEX_ROW(1:N),INDEX_COL(1:N))

   ICOL=0
   IROW=0
   IPIV=0

   DO I=1,N ! Main loop over columns to be reduced
      MAX=0.0D0
      DO J=1,N
         IF(IPIV(J).NE.1) THEN
            DO K=1,N
               IF(IPIV(K).EQ.0) THEN
                  IF(ISNAN(A(J,K))) THEN
                     WRITE(6,*)
                     WRITE(6,*) 'ERROR! NaN found in coefficient matrix A of Gauss-Jordan routine'
                     WRITE(6,"(' A(',I3,',',I3,') =',F4.1)") J,K,A(J,K)
                     WRITE(6,*) 'A ='
                     DO L=1,N
                        WRITE(6,"(100(0PD9.1))") A(L,:)
                     END DO
                     WRITE(6,*)
                     STOP
                  END IF
                  IF(ABS(A(J,K)).GE.MAX) THEN
                     MAX=ABS(A(J,K))
                     IROW=J
                     ICOL=K
                  END IF
               ELSE IF(IPIV(K).GT.1) THEN
                  WRITE(6,*)
                  WRITE(6,*) 'ERROR! Singular matrix found in Gauss-Jordan routine (#1)'
                  WRITE(6,*)
                  STOP
               END IF
            END DO
         END IF
      END DO
      IPIV(ICOL)=IPIV(ICOL)+1
      IF(IROW.NE.ICOL) THEN
         CALL SWAP(A(IROW,:),A(ICOL,:))
         CALL SWAP(B(IROW),B(ICOL))
      END IF
      INDEX_ROW(I)=IROW
      INDEX_COL(I)=ICOL
      IF(A(ICOL,ICOL).EQ.0.0D0) THEN
         WRITE(6,*)
         WRITE(6,*) 'ERROR! Singular matrix found in Gauss-Jordan routine (#2)'
         WRITE(6,*)
         STOP
      END IF
      PIVINV=1.0D0/A(ICOL,ICOL)
      A(ICOL,ICOL)=1.0D0
      A(ICOL,:)=A(ICOL,:)*PIVINV
      B(ICOL)=B(ICOL)*PIVINV
      DO L=1,N
         IF(L.NE.ICOL) THEN
            DUMMY=A(L,ICOL)
            A(L,ICOL)=0.0D0
            A(L,:)=A(L,:)-A(ICOL,:)*DUMMY
            B(L)=B(L)-B(ICOL)*DUMMY
         END IF
      END DO
   END DO ! End of main loop over columns

!  Unscramble the solution by interchanging pairs of columns
!  in the reverse order to which the permutation was built up
   DO L=N,1,-1
      CALL SWAP(A(:,INDEX_ROW(L)),A(:,INDEX_COL(L)))
   END DO

   DEALLOCATE(IPIV,INDEX_ROW,INDEX_COL)

   RETURN
END SUBROUTINE GAUSS_JORDAN
!=======================================================================


SUBROUTINE p101(input_file,output_file)
!-------------------------------------------------------------------------
! Program 10.1 Eigenvalue analysis of elastic beams using 2-node
!              beam elements. Lumped mass.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,idiag,iel,ifail,j,k,nband,ndof=4,nels,neq,nlen,nmodes,nn,     &
   nod=2,nodof=2,nprops=2,np_types,nr
 REAL(iwp)::d12=12.0_iwp,one=1.0_iwp,pt5=0.5_iwp,penalty=1.e20_iwp,       &
   etol=1.0e-30_iwp,zero=0.0_iwp
 CHARACTER(LEN=15)::argv
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),kdiag(:),nf(:,:),num(:)
 REAL(iwp),ALLOCATABLE::diag(:),ell(:),kh(:),km(:,:),ku(:,:),kv(:),       &
   mm(:,:),prop(:,:),rrmass(:),udiag(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,np_types
 nn=nels+1
 ALLOCATE(nf(nodof,nn),km(ndof,ndof),num(nod),g(ndof),mm(ndof,ndof),      &
   ell(nels),etype(nels),g_g(ndof,nels),prop(nprops,np_types))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)ell
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(diag(0:neq),udiag(0:neq),kdiag(neq),rrmass(0:neq))
!-----------------------loop the elements to find global array sizes------
 nband=0
 kdiag=0
 elements_1: DO iel=1,nels
   num=(/iel,iel+1/)
   CALL num_to_g(num,nf,g)
   g_g(:,iel)=g
   IF(nband<bandwidth(g))nband=bandwidth(g)
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 WRITE(11,'(A,I5,A,/,A,I5,/,A,I5)')" There are",neq," equations",         &
   " The half-bandwidth (including diagonal) is",nband+1,                 &
   " The skyline storage is",kdiag(neq)
!-----------------------global stiffness and mass matrix assembly---------
 ALLOCATE(ku(neq,nband+1),kv(kdiag(neq)),kh(kdiag(neq)))
 diag=zero
 ku=zero
 elements_2: DO iel=1,nels
   g=g_g(:,iel)
   mm=zero
   mm(1,1)=pt5*prop(2,etype(iel))*ell(iel)
   mm(3,3)=mm(1,1)
   mm(2,2)=mm(1,1)*ell(iel)**2/d12
   mm(4,4)=mm(2,2)
   CALL formlump(diag,mm,g)
   CALL beam_km(km,prop(1,etype(iel)),ell(iel))
   CALL formku(ku,km,g)
 END DO elements_2
!-----------------------reduce to standard eigenvalue problem-------------
 rrmass(1:)=one/SQRT(diag(1:))
 DO i=1,neq
 IF(i<=neq-nband)THEN
   k=nband+1
 ELSE
   k=neq-i+1
 END IF
   DO j=1,k
     ku(i,j)=ku(i,j)*rrmass(i)*rrmass(i+j-1)
   END DO
 END DO
!-----------------------convert to skyline form---------------------------
 kh(1)=ku(1,1)
 k=1
 DO i=2,neq
   idiag=kdiag(i)-kdiag(i-1)
   DO j=1,idiag
   k=k+1
   kh(k)=ku(i+j-idiag,1-j+idiag)
   END DO
 END DO
!-----------------------extract the eigenvalues---------------------------
 CALL bandred(ku,diag,udiag)
 ifail=1
 CALL bisect(diag,udiag,etol,ifail)
 WRITE(11,'(/A)')" The eigenvalues are:"
 WRITE(11,'(6E12.4)')diag(1:)
!-----------------------extract the eigenvectors--------------------------
 READ(10,*)nmodes
 DO i=1,nmodes
   kv=kh;kv(kdiag)=kv(kdiag)-diag(i)
   kv(1)=kv(1)+penalty
   udiag=zero
   udiag(1)=kv(1)
   CALL sparin_gauss(kv,kdiag)
   CALL spabac_gauss(kv,udiag,kdiag)
   udiag=rrmass*udiag
   WRITE(11,'(A,I3,A)')" Eigenvector number",i," is:"
   WRITE(11,'(6E12.4)')udiag(1:)/MAXVAL(ABS(udiag(1:)))
 END DO
END SUBROUTINE p101