      SUBROUTINE DOPT(X, DIM1, NCAND, KIN, N, NBLOCK, IN, BLKSIZ, K,
     *    RSTART, NRBAR, D, RBAR, PICKED, LNDET, XX, TOL, ZPZ, WK,
     *    IFAULT)
C
C     ALGORITHM AS295.1 APPL. STATIST. (1994) VOL.43, NO.4
C
C     Heuristic algorithm to pick N rows of X out of NCAND to
C     maximize the determinant of X'X, using the Fedorov exchange
C     algorithm.
C
      INTEGER DIM1, NCAND, KIN, N, NBLOCK, IN(*), BLKSIZ(*), K, NRBAR,
     *        PICKED(N), IFAULT
      DOUBLE PRECISION X(DIM1, KIN), D(K), RBAR(NRBAR), LNDET, XX(K),
     *     TOL(K), ZPZ(NCAND, *), WK(K)
      LOGICAL RSTART
C
      INTEGER I, J, NIN, POINT, CASE, NB, BLOCK, L, POS, BEST, FIRST,
     *    LAST, CAND, LASTIN, LSTOUT, DROP, REMPOS, BL, RPOS, LAST1,
     *    LAST2, FIRST1, FIRST2, POS1, POS2, BLOCK1, BLOCK2, CASE1,
     *    CASE2, POSI, POSJ, BESTB1, BESTB2, BESTP1, BESTP2, RANK,
     *    MXRANK, INC
      DOUBLE PRECISION ONE, ZERO, MINUS1, TEMP, EPS, DETMAX, ABOVE1,
     *    SUM, SMALL, HUNDRD
      LOGICAL CHANGE
C
      DOUBLE PRECISION DELTA, RAND
Cgv      EXTERNAL BKSUB1, BKSUB2, CLEAR, DELTA, GETX, MODTRI, MODTR2,
Cgv     *         RAND, REGCF, SINGM
C
      DATA ONE /1.0E + 00/,  ZERO /0.0E + 00/,  ABOVE1 /1.0001E + 00/,
     *     EPS /1.0E - 06/, MINUS1 /-1.0E + 00/,  SMALL /1.0E - 04/,
     *     HUNDRD /100.0E + 00/
C
      IFAULT = 0
      IF (DIM1 .LT. NCAND) IFAULT = 1
      IF (K .GT. N) IFAULT = IFAULT + 2
      IF (NRBAR .LT. K*(K-1)/2) IFAULT = IFAULT + 4
      IF (K .NE. KIN+NBLOCK) IFAULT = IFAULT + 8
      IF (NBLOCK .GT. 1) THEN
         L = 0
         DO 10 BLOCK = 1, NBLOCK
            L = L + BLKSIZ(BLOCK)
   10    CONTINUE
         IF (N .NE. L) IFAULT = IFAULT + 16
      ELSE
         IF (N .NE. BLKSIZ(1)) IFAULT = IFAULT + 16
      END IF
C
C     NB = max(1, NBLOCK) so that we can force it to go through
C     DO-loops once. NIN = no. of design points forced into the
C     design.
C
      NB = MAX(1, NBLOCK)
      NIN = 0
      DO 20 I = 1, NB
         IF (IN(I) .LT. 0) GO TO 30
         IF (IN(I) .GT. 0) THEN
            IF (IN(I) .GT. BLKSIZ(I)) GO TO 30
            NIN = NIN + IN(I)
         END IF
   20 CONTINUE
      IF (NIN .LE. N) GO TO 40
   30 IFAULT = IFAULT + 32
   40 CONTINUE
      IF (IFAULT .NE. 0) RETURN
      CALL CLEAR(K, NRBAR, D, RBAR, IFAULT)
C
C        Set up an array of tolerances
C
      DO 50 I = 1, K
         TOL(I) = ZERO
   50 CONTINUE
      BLOCK = 1
      DO 70 CASE = 1, NCAND
            CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, CASE)
         DO 60 I = 1, K
            TOL(I) = TOL(I) + ABS(XX(I))
   60    CONTINUE
   70 CONTINUE
      TEMP = FLOAT(N) * EPS / NCAND
      DO 80 I = 1, K
         IF (I .LE. NBLOCK) THEN
            TOL(I) = EPS
         ELSE
            TOL(I) = TOL(I) * TEMP
         END IF
   80 CONTINUE
C
C        Form initial Cholesky factorization
C
      POS = 1
      DO 120 BLOCK = 1, NB
         IF (RSTART) THEN
            LAST1 = (IN(BLOCK) + BLKSIZ(BLOCK))/2
            INC = SQRT(FLOAT(NCAND) + SMALL)
         END IF
         DO 110 I = 1, BLKSIZ(BLOCK)
            IF (RSTART .AND. I .GT. IN(BLOCK)) THEN
               POINT = 1 + NCAND * RAND()
C
C     If I <= LAST1, use a random point, otherwise find the
C     candidate which maximizes the rank, and then maximizes the
C     subspace determinant for that rank.
C
            IF (I .GT. LAST1) THEN
                  MXRANK = 0
                  LNDET = -HUNDRD
                  DO 100 CAND = 1, NCAND, INC
                  CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, POINT)
                  CALL MODTR2(K, NRBAR, XX, D, RBAR, TOL, RANK, SUM)
                  IF (RANK .LT. MXRANK) GO TO 90
                  IF (RANK .EQ. MXRANK .AND. SUM .LT. LNDET) GO TO 90
                  BEST = POINT
                  MXRANK = RANK
                  LNDET = SUM * ABOVE1
   90             POINT = POINT + INC
                  IF (POINT .GT. NCAND) POINT = POINT - NCAND
  100             CONTINUE
                  POINT = BEST
               END IF
               PICKED(POS) = POINT
            ELSE
C
C        Case in which a full design has been input, or points are
C        to be forced into the design.
C
               POINT = PICKED(POS)
            END IF
C
C        Augment the Cholesky factorization
C
            CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, POINT)
            CALL MODTRI(K, NRBAR, ONE, XX, D, RBAR, TOL)
            POS = POS + 1
  110    CONTINUE
  120 CONTINUE
C
C        Adjust factorization in case of singular matrix
C
      CALL SINGM(K, NRBAR, D, RBAR, TOL, WK, IFAULT)
C
C        If rank of input design < K, try replacing points.
C
      IF (IFAULT .EQ. 0) GO TO 280
C
C     Find first row of Cholesky factorization with a zero
C     multiplier
C
  180 DO 190 POS = 1, K
         IF (D(POS) .LT. TOL(POS)) GO TO 200
  190 CONTINUE
      GO TO 280
C
C     Find linear relationship between variable in position POS
C     and the previous variables
C
  200 L = POS - 1
      DO 210 I = 1, POS - 1
         WK(I) = RBAR(L)
         L = L + K - I - 1
  210 CONTINUE
      CALL REGCF(K, NRBAR, D, RBAR, WK, TOL, WK, POS-1, IFAULT)
C
C     Find a candidate point which does not satisfy this linear
C     relationship.   Use a random start.
C
      BL = 1
      CASE = 1 + NCAND * RAND()
      DO 230 CAND = 1, NCAND
         CALL GETX(X, DIM1, KIN, NBLOCK, K, BL, XX, CASE)
         SUM = XX(POS)
         DO 220 I = 1, POS - 1
            SUM = SUM - WK(I) * XX(I)
  220    CONTINUE
         IF (ABS(SUM) .GT. HUNDRD * TOL(POS)) GO TO 240
         CASE = CASE + 1
         IF (CASE .GT. NCAND) CASE = 1
  230 CONTINUE
C
C     Failed to find any candidate point which would make the design
C     of higher rank
C
      IFAULT = -1
      RETURN
C
C     Before adding the point, find one which it can replace without
C     lowering the rank.
C
  240 BL = 0
      TEMP = ONE - SMALL
      POS = IN(1) + 1
      DO 270 BLOCK = 1, NB
         DO 260 J = IN(BLOCK) + 1, BLKSIZ(BLOCK)
            L = PICKED(POS)
            CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, L)
            CALL BKSUB2(RBAR, NRBAR, K, XX, WK)
            SUM = ZERO
            DO 250 I = 1, K
               IF (D(I) .GT. TOL(I)) SUM = SUM + WK(I)**2 / D(I)
  250       CONTINUE
            IF (SUM .LT. TEMP) THEN
               TEMP = SUM
               REMPOS = POS
               BL = BLOCK
            END IF
            POS = POS + 1
  260    CONTINUE
         IF (BLOCK .LT. NBLOCK) POS = POS + IN(BLOCK+1)
  270 CONTINUE
C
C     If BL = 0 it means that any point removed from the existing
C     design would reduce the rank
C
      IF (BL .EQ. 0) THEN
         IFAULT = -1
         RETURN
      END IF
C
C     Add candidate CASE in block BL, then delete the design point
C     already in that position.
C
      CALL GETX(X, DIM1, KIN, NBLOCK, K, BL, XX, CASE)
      CALL MODTRI(K, NRBAR, ONE, XX, D, RBAR, TOL)
      L = PICKED(REMPOS)
      CALL GETX(X, DIM1, KIN, NBLOCK, K, BL, XX, L)
      CALL MODTRI(K, NRBAR, MINUS1, XX, D, RBAR, TOL)
      PICKED(REMPOS) = CASE
      GO TO 180
C
C     Design is now of full rank. Calculate z'z for all candidate
C     points. z is the solution of R'z = x, so that
C     z'z = x'.inv(X'X).x. WK holds sqrt(D) times vector z on
C     return from BKSUB2.
C
  280 DO 310 BLOCK = 1, NB
         DO 300 CASE = 1, NCAND
            CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, CASE)
            CALL BKSUB2(RBAR, NRBAR, K, XX, WK)
            TEMP = ZERO
            DO 290 I = 1, K
               TEMP = TEMP + WK(I)**2 / D(I)
  290       CONTINUE
            ZPZ(CASE, BLOCK) = TEMP
  300    CONTINUE
  310 CONTINUE
C
C     Start of Fedorov exchange algorithm
C
      LASTIN = 0
      LSTOUT = 0
  320 CHANGE = .FALSE.
      LAST = 0
      DO 420 BLOCK = 1, NB
         FIRST = LAST + 1 + IN(BLOCK)
         LAST = LAST + BLKSIZ(BLOCK)
         DETMAX = SMALL
         BEST = 0
C
C     Start at a random position within the block.
C     I = no. of point being considered for deletion.
C
         POS = FIRST + (BLKSIZ(BLOCK) - IN(BLOCK)) * RAND()
         DO 350 CASE = IN(BLOCK)+1, BLKSIZ(BLOCK)
            POS = POS + 1
            IF (POS .GT. LAST) POS = FIRST
            I = PICKED(POS)
            IF (I .EQ. LASTIN) GO TO 350
            CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, I)
            CALL BKSUB2(RBAR, NRBAR, K, XX, WK)
            CALL BKSUB1(RBAR, NRBAR, K, WK, WK, TOL, D)
C
C     Cycle through the candidates for exchange, using a random
C     start. J = no. of point being considered for addition.
C
            J = 1 + NCAND * RAND()
            DO 340 CAND = 1, NCAND
               J = J + 1
               IF (J .GT. NCAND) J = 1
               IF (J .EQ. I .OR. J .EQ. LSTOUT) GO TO 340
C
C     The Cauchy-Schwarz test
C
               TEMP = ZPZ(J,BLOCK) - ZPZ(I,BLOCK)
               IF (TEMP .LT. DETMAX) GO TO 340
C
               CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, J)
               SUM = ZERO
               DO 330 L = 1, K
                  SUM = SUM + XX(L) * WK(L)
  330          CONTINUE
               TEMP = TEMP + SUM**2 - ZPZ(I,BLOCK) * ZPZ(J,BLOCK)
               IF (TEMP .GT. DETMAX) THEN
                  DETMAX = TEMP * ABOVE1
                  BEST = J
                  REMPOS = POS
                  DROP = I
               END IF
  340       CONTINUE
  350    CONTINUE
C
C     Exchange points BEST and DROP in position REMPOS, if the
C     determinant is increased.
C
         IF (BEST .NE. 0) THEN
            CHANGE = .TRUE.
            IF (NB .EQ. 1) THEN
               LASTIN = BEST
               LSTOUT = DROP
            END IF
C
C     Add the new point, BEST, first to avoid ill-conditioning.
C     Update z'z.
C
            CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, BEST)
            CALL BKSUB2(RBAR, NRBAR, K, XX, WK)
            CALL BKSUB1(RBAR, NRBAR, K, WK, WK, TOL, D)
            CALL MODTRI(K, NRBAR, ONE, XX, D, RBAR, TOL)
            TEMP = ONE + ZPZ(BEST,BLOCK)
            DO 360 BL = 1, NB
               DO 380 CASE = 1, NCAND
                  CALL GETX(X, DIM1, KIN, NBLOCK, K, BL, XX, CASE)
                  SUM = ZERO
                  DO 370 L = 1, K
                     SUM = SUM + XX(L) * WK(L)
  370             CONTINUE
                  ZPZ(CASE,BL) = ZPZ(CASE,BL) - SUM**2 / TEMP
  380          CONTINUE
  360       CONTINUE
C
C     Remove the point DROP, and update z'z.
C
            CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, DROP)
            CALL BKSUB2(RBAR, NRBAR, K, XX, WK)
            CALL BKSUB1(RBAR, NRBAR, K, WK, WK, TOL, D)
            CALL MODTRI(K, NRBAR, MINUS1, XX, D, RBAR, TOL)
            TEMP = ONE - ZPZ(DROP,BLOCK)
            DO 390 BL = 1, NB
               DO 410 CASE = 1, NCAND
                  CALL GETX(X, DIM1, KIN, NBLOCK, K, BL, XX, CASE)
                  SUM = ZERO
                  DO 400 L = 1, K
                     SUM = SUM + XX(L)*WK(L)
  400             CONTINUE
                  ZPZ(CASE,BL) = ZPZ(CASE,BL) + SUM**2 / TEMP
  410          CONTINUE
  390       CONTINUE
C
            PICKED(REMPOS) = BEST
         END IF
  420 CONTINUE
C
C     Repeat until there is no further improvement
C
      IF (CHANGE) GO TO 320
C
C     If there is more than one block, try swapping treatments
C     between blocks. This is the Cook & Nachtsheim(1989) algorithm.
C
      IF (NBLOCK .LE. 1) GO TO 500
C
C     RPOS is the position of the first element in RBAR after the
C     rows for the block constants
C
      RPOS = NBLOCK * K - NBLOCK * (NBLOCK + 1)/2 + 1
C
  430 LAST1 = 0
C
C     POS1 and POS2 will hold the positions of the start of the means
C     of the X-variables in the two blocks being considered in RBAR
C
      POS1 = NBLOCK
      DETMAX = SMALL
      CHANGE = .FALSE.
      DO 490 BLOCK1 = 1, NBLOCK - 1
         FIRST1 = LAST1 + 1 + IN(BLOCK1)
         LAST1 = LAST1 + BLKSIZ(BLOCK1)
         LAST2 = LAST1
         POS2 = POS1 + K - 1 - BLOCK1
         DO 480 BLOCK2 = BLOCK1+1, NBLOCK
            FIRST2 = LAST2 + 1 + IN(BLOCK2)
            LAST2 = LAST2 + BLKSIZ(BLOCK2)
            DO 470 CASE1 = IN(BLOCK1)+1, BLKSIZ(BLOCK1)
               POSI = FIRST1 - 1 + CASE1
               I = PICKED(POSI)
               CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, I)
               DO 440 L = 1, KIN
                  ZPZ(L,1) = XX(L+NBLOCK)
 440           CONTINUE
               DO 460 CASE2 = IN(BLOCK2) + 1, BLKSIZ(BLOCK2)
                  POSJ = FIRST2 - 1 + CASE2
                  J = PICKED(POSJ)
                  IF (I .EQ. J) GO TO 460
                  CALL GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, J)
                  DO 450 L = 1, KIN
                     ZPZ(L,2) = XX(L+NBLOCK)
  450             CONTINUE
C
C     Pass the orthogonal factorization to DELTA with the top NBLOCK
C     rows removed, i.e. without that part relating to the blocks.
C
              TEMP = DELTA(KIN, ZPZ(1,1), ZPZ(1,2), RBAR(POS1),
     *        RBAR(POS2), BLKSIZ(BLOCK1), BLKSIZ(BLOCK2), NRBAR,
     *        D(NBLOCK+1), RBAR(RPOS), ZPZ(1,3), WK, XX, ZPZ(1,2))
                  IF (TEMP .GT. DETMAX) THEN
                     DETMAX = TEMP * ABOVE1
                     BESTB1 = BLOCK1
                     BESTB2 = BLOCK2
                     BESTP1 = POSI
                     BESTP2 = POSJ
                     CHANGE = .TRUE.
                  END IF
  460          CONTINUE
  470       CONTINUE
            POS2 = POS2 + K - 1 - BLOCK2
  480    CONTINUE
         POS1 = POS1 + K - 1 - BLOCK1
  490 CONTINUE
C
C  If CHANGE=.TRUE. then make the swap, otherwise the search ends.
C
      IF (CHANGE) THEN
         I = PICKED(BESTP1)
         J = PICKED(BESTP2)
         CALL GETX(X, DIM1, KIN, NBLOCK, K, BESTB2, XX, I)
         CALL MODTRI(K, NRBAR, ONE, XX, D, RBAR, TOL)
         CALL GETX(X, DIM1, KIN, NBLOCK, K, BESTB1, XX, J)
         CALL MODTRI(K, NRBAR, ONE, XX, D, RBAR, TOL)
         CALL GETX(X, DIM1, KIN, NBLOCK, K, BESTB1, XX, I)
         CALL MODTRI(K, NRBAR, MINUS1, XX, D, RBAR, TOL)
         CALL GETX(X, DIM1, KIN, NBLOCK, K, BESTB2, XX, J)
         CALL MODTRI(K, NRBAR, MINUS1, XX, D, RBAR, TOL)
         PICKED(BESTP1) = J
         PICKED(BESTP2) = I
         GO TO 430
      END IF
C
C     Calculate log of determinant
C
  500 LNDET = ZERO
      DO 510 I = 1, K
         LNDET = LNDET + LOG(D(I))
  510 CONTINUE
      RETURN
      END
C
      SUBROUTINE MODTRI(NP, NRBAR, WEIGHT, XROW, D, RBAR, TOL)
C
C     ALGORITHM AS295.2 APPL. STATIST. (1994) VOL.43, NO.4
C
C     Modify a triangular (Cholesky) decomposition. Calling this
C     routine updates D and RBAR by adding another design point with
C     weight = WEIGHT, which may be negative. Algorithm based on
C     AS75.1 with modifications.
C     *** WARNING: Array XROW is overwritten ***
C
      INTEGER NP, NRBAR
      DOUBLE PRECISION WEIGHT, XROW(NP), D(NP), RBAR(*), TOL(NP)
C
      INTEGER I, K, NEXTR
      DOUBLE PRECISION CBAR, DI, DPI, SBAR, W, WXI, XI, XK, ZERO
C
      DATA ZERO /0.0E + 00/
C
      W = WEIGHT
      NEXTR = 1
      DO 30 I = 1, NP
C
C     Skip unnecessary transformations.   Test on exact zeroes must
C     be used or stability can be destroyed.
C
         IF (W .EQ. ZERO) RETURN
C
         XI = XROW(I)
         IF (ABS(XI) .LT. TOL(I)) THEN
            NEXTR = NEXTR + NP - I
            GO TO 30
         END IF
C
         DI = D(I)
         WXI = W*XI
         DPI = DI + WXI * XI
C
C        Test for new singularity
C
         IF (DPI .LT. TOL(I)) THEN
            DPI = ZERO
            CBAR = ZERO
            SBAR = ZERO
            W = ZERO
         ELSE
            CBAR = DI/DPI
            SBAR = WXI/DPI
            W = CBAR*W
         END IF
C
         D(I) = DPI
         DO 20 K = I + 1, NP
            XK = XROW(K)
            XROW(K) = XK - XI*RBAR(NEXTR)
            RBAR(NEXTR) = CBAR*RBAR(NEXTR) + SBAR*XK
            NEXTR = NEXTR + 1
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
C
      SUBROUTINE MODTR2(NP, NRBAR, XROW, D, RBAR, TOL, RANK, LNDET)
C
C        ALGORITHM AS295.3 APPL. STATIST. (1994) VOL.43, NO.4
C
C        Calculate the effect of an update of a QR factorization
C        upon the rank and determinant, without changing D or
C        RBAR. Algorithm based on AS75.1 with modifications.
C        *** WARNING: Array XROW is overwritten ***
C
      INTEGER NP, NRBAR, RANK
      DOUBLE PRECISION XROW(NP), D(NP), RBAR(*), TOL(NP), LNDET
C
      INTEGER I, J, K, NEXTR
      DOUBLE PRECISION CBAR, DI, DPI, ONE, W, WXI, XI, XK, ZERO
C
      DATA ZERO /0.0E + 00/, ONE /1.0E + 00/
C
      W = ONE
      RANK = 0
      LNDET = ZERO
      NEXTR = 1
      DO 30 I = 1, NP
C
C     Skip unnecessary transformations. Test on exact zeroes must be
C     used or stability can be destroyed.
C
         IF (W .EQ. ZERO) THEN
            DO 10 J = I, NP
               IF (D(J) .GT. TOL(J)) THEN
                  RANK = RANK + 1
                  LNDET = LNDET + LOG(D(J))
               END IF
   10       CONTINUE
            RETURN
         END IF
C
         XI = XROW(I)
         IF (ABS(XI) .LT. TOL(I)) THEN
            IF (D(I) .GT. TOL(I)) THEN
               RANK = RANK + 1
               LNDET = LNDET + LOG(D(I))
            END IF
            NEXTR = NEXTR + NP - I
            GO TO 30
         END IF
C
         DI = D(I)
         WXI = W * XI
         DPI = DI + WXI * XI
C
C        Test for new singularity
C
         IF (DPI .LT. TOL(I)) THEN
            DPI = ZERO
            CBAR = ZERO
            W = ZERO
         ELSE
            CBAR = DI / DPI
            W = CBAR * W
            LNDET = LNDET + LOG(DPI)
            RANK = RANK + 1
         END IF
C
         DO 20 K = I + 1, NP
            XK = XROW(K)
            XROW(K) = XK - XI * RBAR(NEXTR)
            NEXTR = NEXTR + 1
   20    CONTINUE
   30 CONTINUE
      RETURN
      END
C
      SUBROUTINE GETX(X, DIM1, KIN, NBLOCK, K, BLOCK, XX, CASE)
C
C        ALGORITHM AS295.4 APPL. STATIST. (1994) VOL.43, NO.4
C
C        Copy one case from X to XX
C
      INTEGER DIM1, KIN, NBLOCK, K, BLOCK, CASE
      DOUBLE PRECISION X(DIM1, KIN), XX(K)
C
      INTEGER I, J
      DOUBLE PRECISION ONE, ZERO
C
      DATA ZERO /0.0E + 00/, ONE /1.0E + 00/
C
      DO 10 I = 1, NBLOCK
         IF (I .NE. BLOCK) THEN
            XX(I) = ZERO
         ELSE
            XX(I) = ONE
         END IF
   10 CONTINUE
      J = NBLOCK + 1
      DO 20 I = 1, KIN
         XX(J) = X(CASE, I)
         J = J + 1
   20 CONTINUE
      RETURN
      END
C
      SUBROUTINE BKSUB1(RBAR, NRBAR, K, RHS, SOLN, TOL, D)
C
C     ALGORITHM AS295.5 APPL. STATIST. (1994) VOL.43, NO.4
C
C     Solves  D R y = z for y (SOLN), where z = RHS.
C     RBAR is an upper-triangular matrix with implicit 1's on it's
C     diagonal, stored by rows.
C
      INTEGER NRBAR, K
      DOUBLE PRECISION RBAR(NRBAR), RHS(K), SOLN(K), TOL(K), D(K)
C
      INTEGER COL, POS, ROW
      DOUBLE PRECISION TEMP, ZERO
C
      DATA ZERO /0.0E + 00/
C
      POS = K * (K - 1) / 2
      DO 20 ROW = K, 1, -1
         IF (D(ROW) .GT. TOL(ROW)) THEN
            TEMP = RHS(ROW) / D(ROW)
            DO 10 COL = K, ROW + 1, -1
               TEMP = TEMP - RBAR(POS) * SOLN(COL)
               POS = POS - 1
   10       CONTINUE
            SOLN(ROW) = TEMP
         ELSE
            POS = POS - K + ROW
            SOLN(ROW) = ZERO
         END IF
   20 CONTINUE
      RETURN
      END
C
      SUBROUTINE BKSUB2(RBAR, NRBAR, K, RHS, SOLN)
C
C     ALGORITHM AS295.6 APPL. STATIST. (1994) VOL.43, NO.4
C
C     Solves  R'(sqrt(D).z) = x where (sqrt(D).z) = SOLN and x = RHS.
C     RBAR is an upper-triangular matrix with implicit 1's on it's
C     diagonal, stored by rows.
C
      INTEGER NRBAR, K
      DOUBLE PRECISION RBAR(NRBAR), RHS(K), SOLN(K)
C
      INTEGER COL, POS, ROW
      DOUBLE PRECISION TEMP
C
      SOLN(1) = RHS(1)
      DO 20 ROW = 2, K
         TEMP = RHS(ROW)
         POS = ROW - 1
         DO 10 COL = 1, ROW - 1
            TEMP = TEMP - RBAR(POS) * SOLN(COL)
            POS = POS + K - COL - 1
   10    CONTINUE
         SOLN(ROW) = TEMP
   20 CONTINUE
      RETURN
      END
C
      DOUBLE PRECISION FUNCTION DELTA(K, XJ, XL, XBARI, XBARK, NI, NK,
     *                    NRBAR, D, RBAR, Z, A, B, DIFF)
C
C     ALGORITHM AS295.7 APPL. STATIST. (1994) VOL.43, NO.4
C
C     Calculate the delta function for the swap of case J in block I
C     with case L in block K. Uses the method of Cook & Nachtsheim.
C
      INTEGER K, NI, NK, NRBAR
      DOUBLE PRECISION XJ(K), XL(K), XBARI(K), XBARK(K), D(K),
     *     RBAR(NRBAR), Z(K,3), A(K), B(K), DIFF(K)
C
      INTEGER I
      DOUBLE PRECISION CONST, E11, E12, E21, E22, ONE, TEMP, TWO
C
      DOUBLE PRECISION DOTPRD
cgvEXTERNAL BKSUB2, DOTPRD
C
      DATA ONE /1.0E + 00/, TWO /2.0E + 00/
C
C     Calculate vectors DIFF, A and B
C
      CONST = TWO - ONE/NI - ONE/NK
      DO 10 I = 1, K
         TEMP = XJ(I) - XL(I)
         DIFF(I) = -TEMP
         A(I) = TEMP - XBARI(I) + XBARK(I)
         B(I) = A(I) - CONST * TEMP
   10 CONTINUE
C
C     Calculate the z-vectors by back-substitution. Z1 for A, Z2
C     for B and Z3 for DIFF. The solutions returned from
C     BKSUB2 have the I-th element multiplied by sqrt(D(I)).
C
      CALL BKSUB2(RBAR, NRBAR, K, A, Z(1,1))
      CALL BKSUB2(RBAR, NRBAR, K, B, Z(1,2))
      CALL BKSUB2(RBAR, NRBAR, K, DIFF, Z(1,3))
C
C        Calculate the elements E11, E12, E21 and E22 as dot-products
C        of the appropriate z-vectors
C
      E11 = DOTPRD(K, Z(1,3), Z(1,1), D)
      E12 = DOTPRD(K, Z(1,3), Z(1,3), D)
      E21 = DOTPRD(K, Z(1,2), Z(1,1), D)
      E22 = DOTPRD(K, Z(1,2), Z(1,3), D)
C
C        Return the determinant of the matrix:   E11+1    E12
C                                                 E21    E22+1
C        minus 1
C
      DELTA = (E11+ONE) * (E22+ONE) - E12 * E21 - ONE
      RETURN
      END
C
      DOUBLE PRECISION FUNCTION DOTPRD(K, X, Y, D)
C
C     ALGORITHM AS295.8 APPL. STATIST. (1994) VOL.43, NO.4
C
C     Dot-product scaled by vector D
C
      INTEGER K
      DOUBLE PRECISION X(K), Y(K), D(K)
C
      INTEGER I
      DOUBLE PRECISION ZERO
C
      DATA ZERO /0.0E + 00/
C
      DOTPRD = ZERO
      DO 10 I = 1, K
         DOTPRD = DOTPRD + X(I) * Y(I) / D(I)
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE SINGM(NP, NRBAR, D, RBAR, TOL, WORK, IFAULT)
C
C        ALGORITHM AS295.9 APPL. STATIST. (1994) VOL.43, NO.4
C
C        Checks for singularities, and adjusts orthogonal
C        reductions produced by AS75.1. Modified from AS274.5
C
      INTEGER NP, NRBAR, IFAULT
      DOUBLE PRECISION D(NP), RBAR(NRBAR), TOL(NP), WORK(NP)
C
      INTEGER COL, J, NP2, POS, POS1, ROW
      DOUBLE PRECISION TEMP, ZERO
C
cgv      EXTERNAL MODTRI
C
      DATA ZERO /0.0E + 00/
C
C     Check input parameters
C
      IFAULT = 0
      IF (NP .LE. 0) IFAULT = 1
      IF (NRBAR .LT. NP * (NP - 1)/2) IFAULT = IFAULT + 2
      IF (IFAULT .NE. 0) RETURN
C
      DO 10 COL = 1, NP
         WORK(COL) = SQRT(D(COL))
   10 CONTINUE
C
      DO 40 COL = 1, NP
C
C     Set elements within RBAR to zero if they are less than TOL(COL)
C     in absolute value after being scaled by the square root of
C     their row multiplier
C
         TEMP = TOL(COL)
         POS = COL - 1
         DO 20 ROW = 1, COL - 1
            IF (ABS(RBAR(POS)) * WORK(ROW) .LT. TEMP) RBAR(POS) = ZERO
            POS = POS + NP - ROW - 1
   20    CONTINUE
C
C     If diagonal element is near zero, set it to zero, and use
C     MODTRI to augment the projections in the lower rows of the
C     factorization.
C
         IF (WORK(COL) .LE. TEMP) THEN
            IFAULT = IFAULT - 1
         IF (COL .LT. NP) THEN
            NP2 = NP - COL
            POS2 = POS + NP - COL + 1
            IF (NP2 .GT. 1) THEN
               CALL MODTRI(NP2, NP2*(NP2-1)/2, D(COL), RBAR(POS+1),
     *                     D(COL+1), RBAR(POS2), TOL)
            ELSE
               CALL MODTRI(1, 0, D(COL), RBAR(POS+1), D(COL+1),
     *                     RBAR(1), TOL)
            END IF
            DO 30 J = INT(POS + 1), INT(POS2 - 1)
               RBAR(J) = ZERO
   30       CONTINUE
         END IF
         D(COL) = ZERO
         END IF
   40 CONTINUE
      RETURN
      END
C
      SUBROUTINE XXTR(NP, NRBAR, D, RBAR, NREQ, TRACE, RINV)
C
C        ALGORITHM AS295.10 APPL. STATIST. (1994) VOL.43, NO.4
C
C        Calculate the trace of the inverse of X'X (= R'R)
C
      INTEGER NP, NRBAR, NREQ
      DOUBLE PRECISION D(NP), RBAR(NRBAR), TRACE, RINV(*)
C
      INTEGER COL, POS, ROW
      DOUBLE PRECISION ONE, ZERO
C
cgv      EXTERNAL INV
C        AS274.8, Appl.Statist.(1992), vol.41, no.2
C
      DATA ONE /1.0E + 00/, ZERO /0.0E + 00/
C
C     Get the inverse of R
C
      CALL INV(NP, NRBAR, RBAR, NREQ, RINV)
C
C     Trace = the sum of the diagonal elements
C     of RINV * (1/D) * (RINV)'
C
      TRACE = ZERO
      POS = 1
      DO 20 ROW = 1, NREQ
         TRACE = TRACE + ONE / D(ROW)
         DO 10 COL = ROW + 1, NREQ
            TRACE = TRACE + RINV(POS)**2 / D(COL)
            POS = POS + 1
   10    CONTINUE
   20 CONTINUE
      RETURN
      END

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

      SUBROUTINE INCLUD(NP, NRBAR, WEIGHT, XROW, YELEM, D, RBAR, THETAB,
     +      SSERR, IER)
C
C     ALGORITHM AS274.1  APPL. STATIST. (1992) VOL 41, NO. 2
C
C     DOUBLE PRECISION VERSION
C
C     Calling this routine updates d, rbar, thetab and sserr by the
C     inclusion of xrow, yelem with the specified weight.
C     This version has been modified to make it slightly faster when the
C     early elements of XROW are not zeroes.
C
C     *** WARNING ***   The elements of XROW are over-written.
C
      INTEGER NP, NRBAR, IER
      DOUBLE PRECISION WEIGHT, XROW(NP), YELEM, D(NP), RBAR(*),
     +       THETAB(NP), SSERR
C
C     Local variables
C
      INTEGER I, K, NEXTR
      DOUBLE PRECISION ZERO, W, Y, XI, DI, WXI, DPI, CBAR, SBAR, XK
C
      DATA ZERO/0.D0/
C
C     Some checks.
C
      IER = 0
      IF (NP .LT. 1) IER = 1
      IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2
      IF (IER .NE. 0) RETURN
C
      W = WEIGHT
      Y = YELEM
      NEXTR = 1
      DO 30 I = 1, NP
C
C     Skip unnecessary transformations.   Test on exact zeroes must be
C     used or stability can be destroyed.
C
      IF (W .EQ. ZERO) RETURN
      XI = XROW(I)
      IF (XI .EQ. ZERO) THEN
      NEXTR = NEXTR + NP - I
      GO TO 30
      END IF
      DI = D(I)
      WXI = W * XI
      DPI = DI + WXI*XI
      CBAR = DI / DPI
      SBAR = WXI / DPI
      W = CBAR * W
      D(I) = DPI
      IF (I .EQ. NP) GO TO 20
      DO 10 K = I+1, NP
        XK = XROW(K)
        XROW(K) = XK - XI * RBAR(NEXTR)
        RBAR(NEXTR) = CBAR * RBAR(NEXTR) + SBAR * XK
        NEXTR = NEXTR + 1
   10   CONTINUE
   20   XK = Y
      Y = XK - XI * THETAB(I)
      THETAB(I) = CBAR * THETAB(I) + SBAR * XK
   30 CONTINUE
C
C     Y * SQRT(W) is now equal to the Brown, Durbin & Evans recursive
C     residual.
C
      SSERR = SSERR + W * Y * Y
C
      RETURN
      END
C
cgv      SUBROUTINE CLEAR(NP, NRBAR, D, RBAR, THETAB, SSERR, IER)
      SUBROUTINE CLEAR(NP, NRBAR, D, RBAR, IER)
C
C     ALGORITHM AS274.2  APPL. STATIST. (1992) VOL.41, NO.2
C
C     Sets arrays to zero prior to calling AS75.1
C
      INTEGER NP, NRBAR, IER
cgv      DOUBLE PRECISION D(NP), RBAR(*), THETAB(NP), SSERR
      DOUBLE PRECISION D(NP), RBAR(*)
C
C     Local variables
C
      INTEGER I
      DOUBLE PRECISION ZERO
C
      DATA ZERO/0.D0/
C
C     Some checks.
C
      IER = 0
      IF (NP .LT. 1) IER = 1
      IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2
      IF (IER .NE. 0) RETURN
C
      DO 10 I = 1, NP
      D(I) = ZERO
cgv      THETAB(I) = ZERO
   10 CONTINUE
      DO 20 I = 1, NRBAR
   20 RBAR(I) = ZERO
cgv      SSERR = ZERO
      RETURN
      END
C
      SUBROUTINE REGCF(NP, NRBAR, D, RBAR, THETAB, TOL, BETA, NREQ,
     +     IER)
C
C     ALGORITHM AS274.3  APPL. STATIST. (1992) VOL 41, NO.2
C
C     Modified version of AS75.4 to calculate regression coefficients
C     for the first NREQ variables, given an orthogonal reduction from
C     AS75.1.
C
      INTEGER NP, NRBAR, NREQ, IER
      DOUBLE PRECISION D(NP), RBAR(*), THETAB(NP), TOL(NP), BETA(NP)
C
C     Local variables
C
      INTEGER I, J, NEXTR
      DOUBLE PRECISION ZERO
C
      DATA ZERO/0.D0/
C
C     Some checks.
C
      IER = 0
      IF (NP .LT. 1) IER = 1
      IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2
      IF (NREQ .LT. 1 .OR. NREQ .GT. NP) IER = IER + 4
      IF (IER .NE. 0) RETURN
C
      DO 20 I = NREQ, 1, -1
      IF (SQRT(D(I)) .LT. TOL(I)) THEN
        BETA(I) = ZERO
        D(I) = ZERO
        GO TO 20
      END IF
      BETA(I) = THETAB(I)
      NEXTR = (I-1) * (NP+NP-I)/2 + 1
      DO 10 J = I+1, NREQ
        BETA(I) = BETA(I) - RBAR(NEXTR) * BETA(J)
        NEXTR = NEXTR + 1
   10   CONTINUE
   20 CONTINUE
C
      RETURN
      END
C
      SUBROUTINE TOLSET(NP, NRBAR, D, RBAR, TOL, WORK, IER)
C
C     ALGORITHM AS274.4  APPL. STATIST. (1992) VOL 41, NO.2
C
C     Sets up array TOL for testing for zeroes in an orthogonal
C     reduction formed using AS75.1.
C
      INTEGER NP, NRBAR, IER
      DOUBLE PRECISION D(NP), RBAR(*), TOL(NP), WORK(NP)
C
C     Local variables.
C
      INTEGER COL, ROW, POS
      DOUBLE PRECISION EPS, SUM
C
C     EPS is a machine-dependent constant.   For compilers which use
C     the IEEE format for floating-point numbers, recommended values
C     are 1.E-06 for single precision and 1.E-15 for double precision.
C
      DATA EPS/1.D-15/
C
C     Some checks.
C
      IER = 0
      IF (NP .LT. 1) IER = 1
      IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2
      IF (IER .NE. 0) RETURN
C
C     Set TOL(I) = sum of absolute values in column I of RBAR after
C     scaling each element by the square root of its row multiplier.
C
      DO 10 COL = 1, NP
   10 WORK(COL) = SQRT(D(COL))
      DO 30 COL = 1, NP
      POS = COL - 1
      SUM = WORK(COL)
      DO 20 ROW = 1, COL-1
        SUM = SUM + ABS(RBAR(POS)) * WORK(ROW)
        POS = POS + NP - ROW - 1
  20    CONTINUE
      TOL(COL) = EPS * SUM
   30 CONTINUE
C
      RETURN
      END
C
      SUBROUTINE SING(NP, NRBAR, D, RBAR, THETAB, SSERR, TOL, LINDEP,
     +   WORK, IER)
C
C     ALGORITHM AS274.5  APPL. STATIST. (1992) VOL 41, NO.2
C
C     Checks for singularities, reports, and adjusts orthogonal
C     reductions produced by AS75.1.
C
      INTEGER NP, NRBAR, IER
      DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), SSERR, TOL(NP),
     +        WORK(NP)
      LOGICAL LINDEP(NP)
C
C     Local variables
C
      DOUBLE PRECISION ZERO, TEMP
      INTEGER COL, POS, ROW, NP2, POS2
C
      DATA ZERO/0.D0/
C
C     Check input parameters
C
      IER = 0
      IF (NP .LE. 0) IER = 1
      IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2
      IF (IER .NE. 0) RETURN
C
      DO 10 COL = 1, NP
   10 WORK(COL) = SQRT(D(COL))
C
      DO 40 COL = 1, NP
C
C     Set elements within RBAR to zero if they are less than TOL(COL) in
C     absolute value after being scaled by the square root of their row
C     multiplier.
C
      TEMP = TOL(COL)
      POS = COL - 1
      DO 30 ROW = 1, COL-1
      IF (ABS(RBAR(POS)) * WORK(ROW) .LT. TEMP) RBAR(POS) = ZERO
      POS = POS + NP - ROW - 1
   30   CONTINUE
C
C     If diagonal element is near zero, set it to zero, set appropriate
C     element of LINDEP, and use INCLUD to augment the projections in
C     the lower rows of the orthogonalization.
C
      LINDEP(COL) = .FALSE.
      IF (WORK(COL) .LT. TEMP) THEN
        LINDEP(COL) = .TRUE.
        IER = IER - 1
        IF (COL .LT. NP) THEN
          NP2 = NP - COL
          POS2 = POS + NP - COL + 1
          CALL INCLUD(NP2, NP2*(NP2-1)/2, D(COL), RBAR(POS+1),
     +            THETAB(COL), D(COL+1), RBAR(POS2), THETAB(COL+1),
     +            SSERR, IER)
        ELSE
          SSERR = SSERR + D(COL) * THETAB(COL)**2
        END IF
        D(COL) = ZERO
        WORK(COL) = ZERO
        THETAB(COL) = ZERO
      END IF
   40 CONTINUE
      RETURN
      END
C
      SUBROUTINE SS(NP, D, THETAB, SSERR, RSS, IER)
C
C     ALGORITHM AS274.6  APPL. STATIST. (1992) VOL 41, NO.2
C
C     Calculates partial residual sums of squares from an orthogonal
C     reduction from AS75.1.
C
      INTEGER NP, IER
      DOUBLE PRECISION D(NP), THETAB(NP), SSERR, RSS(NP)
C
C     Local variables
C
      INTEGER I
      DOUBLE PRECISION SUM
C
C     Some checks.
C
      IER = 0
      IF (NP .LT. 1) IER = 1
      IF (IER .NE. 0) RETURN
C
      SUM = SSERR
      RSS(NP) = SSERR
      DO 10 I = NP, 2, -1
      SUM = SUM + D(I) * THETAB(I)**2
      RSS(I-1) = SUM
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE COV(NP, NRBAR, D, RBAR, NREQ, RINV, VAR, COVMAT,
     +      DIMCOV, STERR, IER)
C
C     ALGORITHM AS274.7  APPL. STATIST. (1992) VOL 41, NO.2
C
C     Calculate covariance matrix for regression coefficients for the
C     first NREQ variables, from an orthogonal reduction produced from
C     AS75.1.
C
C     Auxiliary routine called: INV
C
      INTEGER NP, NRBAR, NREQ, DIMCOV, IER
      DOUBLE PRECISION D(NP), RBAR(*), RINV(*), VAR, COVMAT(DIMCOV),
     +       STERR(NP)
C
C     Local variables.
C
      INTEGER POS, ROW, START, POS2, COL, POS1, K
      DOUBLE PRECISION ZERO, ONE, SUM
C
      DATA ZERO/0.D0/, ONE/1.D0/
C
C     Some checks.
C
      IER = 0
      IF (NP .LT. 1) IER = 1
      IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2
      IF (DIMCOV .LT. NREQ*(NREQ+1)/2) IER = IER + 4
      DO 10 ROW = 1, NREQ
      IF (D(ROW) .EQ. ZERO) IER = -ROW
   10 CONTINUE
      IF (IER .NE. 0) RETURN
C
      CALL INV(NP, NRBAR, RBAR, NREQ, RINV)
      POS = 1
      START = 1
      DO 40 ROW = 1, NREQ
      POS2 = START
      DO 30 COL = ROW, NREQ
        POS1 = START + COL - ROW
        IF (ROW .EQ. COL) THEN
          SUM = ONE / D(COL)
        ELSE
          SUM = RINV(POS1-1) / D(COL)
        END IF
      DO 20 K = COL+1, NREQ
        SUM = SUM + RINV(POS1) * RINV(POS2) / D(K)
        POS1 = POS1 + 1
        POS2 = POS2 + 1
   20     CONTINUE
      COVMAT(POS) = SUM * VAR
      IF (ROW .EQ. COL) STERR(ROW) = SQRT(COVMAT(POS))
        POS = POS + 1
   30   CONTINUE
        START = START + NREQ - ROW
   40 CONTINUE
C
      RETURN
      END
C
      SUBROUTINE INV(NP, NRBAR, RBAR, NREQ, RINV)
C
C     ALGORITHM AS274.8  APPL. STATIST. (1992) VOL 41, NO.2
C
C     Invert first NREQ rows and columns of Cholesky factorization
C     produced by AS75.1.
C
      INTEGER NP, NRBAR, NREQ
      DOUBLE PRECISION RBAR(*), RINV(*)
C
C     Local variables.
C
      INTEGER POS, ROW, COL, START, K, POS1, POS2
      DOUBLE PRECISION SUM, ZERO
C
      DATA ZERO/0.D0/
C
C     Invert RBAR ignoring row multipliers, from the bottom up.
C
      POS = NREQ * (NREQ-1)/2
      DO 30 ROW = NREQ-1, 1, -1
      START = (ROW-1) * (NP+NP-ROW)/2 + 1
      DO 20 COL = NREQ, ROW+1, -1
        POS1 = START
        POS2 = POS
        SUM = ZERO
      DO 10 K = ROW+1, COL-1
        POS2 = POS2 + NREQ - K
        SUM = SUM - RBAR(POS1) * RINV(POS2)
        POS1 = POS1 + 1
   10     CONTINUE
      RINV(POS) = SUM - RBAR(POS1)
      POS = POS - 1
   20   CONTINUE
   30 CONTINUE
C
      RETURN
      END
C
      SUBROUTINE PCORR(NP, NRBAR, D, RBAR, THETAB, SSERR, IN, WORK,
     +      CORMAT, DIMC, YCORR, IER)
C
C     ALGORITHM AS274.9  APPL. STATIST. (1992) VOL 41, NO.2
C
C     Calculate partial correlations after the first IN variables
C     have been forced into the regression.
C
C     Auxiliary routine called: COR
C
      INTEGER NP, NRBAR, IN, DIMC, IER
      DOUBLE PRECISION D(NP), RBAR(*), THETAB(NP), SSERR, WORK(NP),
     +        CORMAT(*), YCORR
C
C     Local variables.
C
      INTEGER START, IN1, I
      DOUBLE PRECISION ZERO
C
      DATA ZERO/0.D0/
C
C     Some checks.
C
      IER = 0
      IF (NP .LT. 1) IER = 1
      IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2
      IF (IN .LT. 0 .OR. IN .GT. NP-1) IER = IER + 4
      IF (DIMC .LT. (NP-IN)*(NP-IN-1)/2) IER = IER + 8
      IF (IER .NE. 0) RETURN
C
      START = IN * (NP+NP-IN-1)/2 + 1
      IN1 = IN + 1
      CALL COR(NP-IN, D(IN1), RBAR(START), THETAB(IN1), SSERR, WORK,
     +      CORMAT, YCORR)
C
C     Check for zeroes.
C
      DO 10 I = 1, NP-IN
      IF (WORK(I) .LE. ZERO) IER = -I
   10 CONTINUE
C
      RETURN
      END
C
      SUBROUTINE COR(NP, D, RBAR, THETAB, SSERR, WORK, CORMAT, YCORR)
C
C     ALGORITHM AS274.10  APPL. STATIST. (1992) VOL 41, NO.2
C
C     Calculate correlations from an orthogonal reduction.   This
C     routine will usually be called from PCORR, which will have
C     removed the appropriate number of rows at the start.
C
      INTEGER NP
      DOUBLE PRECISION D(NP), RBAR(*), THETAB(NP), SSERR, WORK(NP),
     +      CORMAT(*), YCORR(NP)
C
C     Local variables.
C
      INTEGER ROW, POS, COL1, POS1, COL2, POS2, DIFF
      DOUBLE PRECISION SUMY, SUM, ZERO
C
      DATA ZERO/0.D0/
C
C     Process by columns, including the projections of the dependent
C     variable (THETAB).
C
      SUMY = SSERR
      DO 10 ROW = 1, NP
   10 SUMY = SUMY + D(ROW) * THETAB(ROW)**2
      SUMY = SQRT(SUMY)
      POS = NP*(NP-1)/2
      DO 70 COL1 = NP, 1, -1
C
C     Calculate the length of column COL1.
C
      SUM = D(COL1)
      POS1 = COL1 - 1
      DO 20 ROW = 1, COL1-1
        SUM = SUM + D(ROW) * RBAR(POS1)**2
        POS1 = POS1 + NP - ROW - 1
   20   CONTINUE
      WORK(COL1) = SQRT(SUM)
C
C     If SUM = 0, set all correlations with this variable to zero.
C
      IF (SUM .EQ. ZERO) THEN
        YCORR(COL1) = ZERO
        DO 30 COL2 = NP, COL1+1, -1
          CORMAT(POS) = ZERO
          POS = POS - 1
   30     CONTINUE
        GO TO 70
      END IF
C
C     Form cross-products, then divide by product of column lengths.
C
      SUM = D(COL1) * THETAB(COL1)
      POS1 = COL1 - 1
      DO 40 ROW = 1, COL1-1
        SUM = SUM + D(ROW) * RBAR(POS1) * THETAB(ROW)
        POS1 = POS1 + NP - ROW - 1
   40   CONTINUE
      YCORR(COL1) = SUM / (SUMY * WORK(COL1))
C
      DO 60 COL2 = NP, COL1+1, -1
      IF (WORK(COL2) .GT. ZERO) THEN
        POS1 = COL1 - 1
        POS2 = COL2 - 1
        DIFF = COL2 - COL1
          SUM = ZERO
          DO 50 ROW = 1, COL1-1
            SUM = SUM + D(ROW) * RBAR(POS1) * RBAR(POS2)
            POS1 = POS1 + NP - ROW - 1
            POS2 = POS1 + DIFF
   50       CONTINUE
          SUM = SUM + D(COL1) * RBAR(POS2)
          CORMAT(POS) = SUM / (WORK(COL1) * WORK(COL2))
        ELSE
          CORMAT(POS) = ZERO
        END IF
        POS = POS - 1
   60   CONTINUE
   70 CONTINUE
C
      RETURN
      END
C
      SUBROUTINE VMOVE(NP, NRBAR, VORDER, D, RBAR, THETAB, RSS, FROM,
     +    TO, TOL, IER)
C
C     ALGORITHM AS274.11 APPL. STATIST. (1992) VOL 41, NO.2
C
C     Move variable from position FROM to position TO in an
C     orthogonal reduction produced by AS75.1.
C
      INTEGER NP, NRBAR, VORDER(NP), FROM, TO, IER
      DOUBLE PRECISION D(NP), RBAR(*), THETAB(NP), RSS(NP), TOL(NP)
C
C     Local variables
C
      DOUBLE PRECISION ZERO, D1, D2, X, ONE, D1NEW, D2NEW, CBAR, SBAR, Y
      INTEGER M, FIRST, LAST, INC, M1, M2, MP1, COL, POS, ROW
C
      DATA ZERO/0.D0/, ONE/1.D0/
C
C     Check input parameters
C
      IER = 0
      IF (NP .LE. 0) IER = 1
      IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2
      IF (FROM .LT. 1 .OR. FROM .GT. NP) IER = IER + 4
      IF (TO .LT. 1 .OR. TO .GT. NP) IER = IER + 8
      IF (IER .NE. 0) RETURN
C
      IF (FROM .EQ. TO) RETURN
C
      IF (FROM .LT. TO) THEN
      FIRST = FROM
      LAST = TO - 1
      INC = 1
      ELSE
      FIRST = FROM - 1
      LAST = TO
      INC = -1
      END IF
      DO 70 M = FIRST, LAST, INC
C
C     Find addresses of first elements of RBAR in rows M and (M+1).
C
      M1 = (M-1)*(NP+NP-M)/2 + 1
      M2 = M1 + NP - M
      MP1 = M + 1
      D1 = D(M)
      D2 = D(MP1)
C
C     Special cases.
C
      IF (D1 .EQ. ZERO .AND. D2 .EQ. ZERO) GO TO 40
      X = RBAR(M1)
      IF (ABS(X) * SQRT(D1) .LT. TOL(MP1)) THEN
        X = ZERO
      END IF
      IF (D1 .EQ. ZERO .OR. X .EQ. ZERO) THEN
        D(M) = D2
        D(MP1) = D1
        RBAR(M1) = ZERO
        DO 10 COL = M+2, NP
          M1 = M1 + 1
          X = RBAR(M1)
          RBAR(M1) = RBAR(M2)
          RBAR(M2) = X
          M2 = M2 + 1
   10     CONTINUE
        X = THETAB(M)
        THETAB(M) = THETAB(MP1)
        THETAB(MP1) = X
        GO TO 40
      ELSE IF (D2 .EQ. ZERO) THEN
        D(M) = D1 * X**2
        RBAR(M1) = ONE / X
        DO 20 COL = M+2, NP
          M1 = M1 + 1
          RBAR(M1) = RBAR(M1) / X
   20     CONTINUE
        THETAB(M) = THETAB(M) / X
        GO TO 40
      END IF
C
C     Planar rotation in regular case.
C
      D1NEW = D2 + D1*X**2
      CBAR = D2 / D1NEW
      SBAR = X * D1 / D1NEW
      D2NEW = D1 * CBAR
      D(M) = D1NEW
      D(MP1) = D2NEW
      RBAR(M1) = SBAR
      DO 30 COL = M+2, NP
        M1 = M1 + 1
        Y = RBAR(M1)
        RBAR(M1) = CBAR*RBAR(M2) + SBAR*Y
        RBAR(M2) = Y - X*RBAR(M2)
        M2 = M2 + 1
   30   CONTINUE
      Y = THETAB(M)
      THETAB(M) = CBAR*THETAB(MP1) + SBAR*Y
      THETAB(MP1) = Y - X*THETAB(MP1)
C
C     Swap columns M and (M+1) down to row (M-1).
C
   40   IF (M .EQ. 1) GO TO 60
      POS = M
      DO 50 ROW = 1, M-1
        X = RBAR(POS)
        RBAR(POS) = RBAR(POS-1)
        RBAR(POS-1) = X
        POS = POS + NP - ROW - 1
   50   CONTINUE
C
C     Adjust variable order (VORDER), the tolerances (TOL) and
C     the vector of residual sums of squares (RSS).
C
   60   M1 = VORDER(M)
      VORDER(M) = VORDER(MP1)
      VORDER(MP1) = M1
      X = TOL(M)
      TOL(M) = TOL(MP1)
      TOL(MP1) = X
      RSS(M) = RSS(MP1) + D(MP1) * THETAB(MP1)**2
   70 CONTINUE
C
      RETURN
      END
C
      SUBROUTINE REORDR(NP, NRBAR, VORDER, D, RBAR, THETAB, RSS, TOL,
     +      LIST, N, POS1, IER)
C
C     ALGORITHM AS274.12  APPL. STATIST. (1992) VOL 41, NO.2
C
C     Re-order the variables in an orthogonal reduction produced by
C     AS75.1 so that the N variables in LIST start at position POS1,
C     though will not necessarily be in the same order as in LIST.
C     Any variables in VORDER before position POS1 are not moved.
C
C     Auxiliary routine called: VMOVE
C
      INTEGER NP, NRBAR, VORDER(NP), N, LIST(N), POS1, IER
      DOUBLE PRECISION D(NP), RBAR(NRBAR), THETAB(NP), RSS(NP), TOL(NP)
C
C     Local variables.
C
      INTEGER NEXT, I, L, J
C
C     Check N.
C
      IER = 0
      IF (NP .LT. 1) IER = 1
      IF (NRBAR .LT. NP*(NP-1)/2) IER = IER + 2
      IF (N .LT. 1 .OR. N .GE. NP+1-POS1) IER = IER + 4
      IF (IER .NE. 0) RETURN
C
C     Work through VORDER finding variables which are in LIST.
C
      NEXT = POS1
      I = POS1
   10 L = VORDER(I)
      DO 20 J = 1, N
      IF (L .EQ. LIST(J)) GO TO 40
   20 CONTINUE
   30 I = I + 1
      IF (I .LE. NP) GO TO 10
C
C     If this point is reached, one or more variables in LIST has not
C     been found.
C
      IER = 8
      RETURN
C
C     Variable L is in LIST; move it up to position NEXT if it is not
C     already there.
C
   40 IF (I .GT. NEXT) CALL VMOVE(NP, NRBAR, VORDER, D, RBAR, THETAB,
     +      RSS, I, NEXT, TOL, IER)
      NEXT = NEXT + 1
      IF (NEXT .LT. N+POS1) GO TO 30
C
      RETURN
      END
C
      SUBROUTINE HDIAG(XROW, NP, NRBAR, D, RBAR, TOL, NREQ, HII, WK,
     +     IFAULT)
C
C     ALGORITHM AS274.13  APPL. STATIST. (1992) VOL.41, NO.2
C
      INTEGER NP, NRBAR, NREQ, IFAULT
      DOUBLE PRECISION XROW(NP), D(NP), RBAR(*), TOL(NP), HII, WK(NP)
C
C     Local variables
C
      INTEGER COL, ROW, POS
      DOUBLE PRECISION ZERO, SUM
C
      DATA ZERO /0.0D0/
C
C     Some checks
C
      IFAULT = 0
      IF (NP .LT. 1) IFAULT = 1
      IF (NRBAR .LT. NP*(NP-1)/2) IFAULT = IFAULT + 2
      IF (NREQ .GT. NP) IFAULT = IFAULT + 4
      IF (IFAULT .NE. 0) RETURN
C
C     The elements of XROW.inv(RBAR).sqrt(D) are calculated and stored
C     in WK.
C
      HII = ZERO
      DO 20 COL = 1, NREQ
      IF (SQRT(D(COL)) .LE. TOL(COL)) THEN
        WK(COL) = ZERO
        GO TO 20
      END IF
      POS = COL - 1
      SUM = XROW(COL)
      DO 10 ROW = 1, COL-1
        SUM = SUM - WK(ROW)*RBAR(POS)
        POS = POS + NP - ROW - 1
   10   CONTINUE
      WK(COL) = SUM
      HII = HII + SUM**2 / D(COL)
   20 CONTINUE
C
      RETURN
      END


      subroutine fpader(t,n,c,k1,x,l,d)
c  subroutine fpader calculates the derivatives
c             (j-1)
c     d(j) = s     (x) , j=1,2,...,k1
c  of a spline of order k1 at the point t(l)<=x<t(l+1), using the
c  stable recurrence scheme of de boor
c  ..
c  ..scalar arguments..
      real x
      integer n,k1,l
c  ..array arguments..
      real t(n),c(n),d(k1)
c  ..local scalars..
      integer i,ik,j,jj,j1,j2,ki,kj,li,lj,lk
      real ak,fac,one
c  ..local array..
      real h(6)
c  ..
      one = 0.1e+01
      lk = l-k1
      do 100 i=1,k1
        ik = i+lk
        h(i) = c(ik)
 100  continue
      kj = k1
      fac = one
      do 700 j=1,k1
        ki = kj
        j1 = j+1
        if(j.eq.1) go to 300
        i = k1
        do 200 jj=j,k1
          li = i+lk
          lj = li+kj
          h(i) = (h(i)-h(i-1))/(t(lj)-t(li))
          i = i-1
 200    continue
 300    do 400 i=j,k1
          d(i) = h(i)
 400    continue
        if(j.eq.k1) go to 600
        do 500 jj=j1,k1
          ki = ki-1
          i = k1
          do 500 j2=jj,k1
            li = i+lk
            lj = li+ki
            d(i) = ((x-t(li))*d(i)+(t(lj)-x)*d(i-1))/(t(lj)-t(li))
            i = i-1
 500    continue
 600    d(j) = d(k1)*fac
        ak = k1-j
        fac = fac*ak
        kj = kj-1
 700  continue
      return
      end


!------------------------------------------------------------------------------
! MODULE: distributions
!
!> @author
!> Pavel Junker
!
! DESCRIPTION:
!> a small collection of benchmark pdfs, all are technically 1d
!
! REVISION HISTORY:
! 13.03.2021 - Initial Version
!------------------------------------------------------------------------------
module distributions
	implicit none

	integer, parameter, private :: DP = kind(0.D0)

	abstract interface
		real(kind=DP) pure function rn_to_r(x)
			import :: DP
			real(kind=DP), intent(in) :: x(:)
		end function rn_to_r
	end interface

contains
! ========================== normal distribution pdf ==========================

!                                       #
!                                     #####
!                                   #########
!                                  ###########
!                                  ###########
!                                 #############
!                                ###############
!                               #################
!                               #################
!                              ###################
!                             #####################
!                             #####################
!                            #######################
!                            #######################
!                           #########################
!                          ###########################
!                          ###########################
!                         #############################
!                        ###############################
!                        ###############################
!                       #################################
!                      ###################################
!                     #####################################
!                    #######################################
!                    #######################################
!                  ###########################################
!                 #############################################
!                ###############################################
!              ###################################################
!          ###########################################################

	pure function gauss(x) result(out)
		real(kind=DP), intent(in) :: x(:)
		real(kind=DP) :: out
        	out = exp(-0.5 * norm2(x)**2)
	end function

! ========================== flat-ish top bell curve ==========================

!                                       #
!                                   #########
!                                  ###########
!                                 #############
!                                 #############
!                                ###############
!                                ###############
!                               #################
!                               #################
!                              ###################
!                              ###################
!                              ###################
!                             #####################
!                             #####################
!                             #####################
!                            #######################
!                            #######################
!                            #######################
!                           #########################
!                           #########################
!                          ###########################
!                          ###########################
!                         #############################
!                        ###############################
!                        ###############################
!                       #################################
!                      ###################################
!                    #######################################
!                  ###########################################
!              ###################################################

	pure function plateau(x) result(out)
		real(kind=DP), intent(in) :: x(:)
		real(kind=DP) :: out
		out = 1/(1+norm2(x)**4)
	end function

! ================================== bimodal ==================================

!                      #                                 #
!                     ###                               ###
!                    #####                             #####
!                    ######                           ######
!                   #######                           #######
!                   ########                         ########
!                  #########                         #########
!                  #########                         #########
!                  ##########                       ##########
!                 ###########                       ###########
!                 ############                     ############
!                 ############                     ############
!                #############                     #############
!                ##############                   ##############
!                ##############                   ##############
!               ###############                   ###############
!               ################                 ################
!              #################                 #################
!              ##################               ##################
!              ##################               ##################
!             ###################               ###################
!             ####################             ####################
!            #####################             #####################
!            ######################           ######################
!           #######################           #######################
!           ########################         ########################
!          ##########################       ##########################
!         ############################     ############################
!        ###############################################################
!      ###################################################################

	pure function bimodal(x) result(out)
		real(kind=DP), intent(in) :: x(:)
		real(kind=DP) :: out
		out = exp(-1.5*(norm2(x)-1.5)**2) + exp(-1.5*(norm2(x)+1.5)**2)
	end function

! ========================== comb-like (more nodes) ===========================

!                                       #
!                                       #
!                                      ###
!                                      ###
!                                      ###
!                                      ###
!                                      ###
!                                     #####
!                                     #####
!                                     #####
!                                     #####
!                             #       #####       #
!                            ##       #####       ##
!                            ###     #######     ###
!                            ###     #######     ###
!                           ####     #######     ####
!                           #####    #######    #####
!                           #####    #######    #####
!                           #####    #######    #####
!                          ######   #########   ######
!                          #######  #########  #######
!                          #######  #########  #######
!                          ###########################
!                         #############################
!                         #############################
!                   #     #############################     #
!                 ####   ###############################   ####
!                ###############################################
!               #################################################
!              ###################################################

	pure function comb(x) result(out)
		real(kind=DP), intent(in) :: x(:)
		real(kind=DP) :: out
		out = (0.65d0+0.35d0*cos(6.5d0*norm2(x)))*exp(-0.5d0*norm2(x)**2)
	end function

! =========================== comb-like (less nodes) ==========================

!                                       #
!                                      ###
!                                      ###
!                                     #####
!                                     #####
!                                     #####
!                                    #######
!                                    #######
!                                    #######
!                                   #########
!                                   #########
!                                   #########
!                                  ###########
!                                  ###########
!                                 #############
!                           ###   #############   ###
!                          ###########################
!                         #############################
!                         #############################
!                        ###############################
!                        ###############################
!                       #################################
!                       #################################
!                      ###################################
!                     #####################################
!                     #####################################
!                    #######################################
!                  ###########################################
!              ###################################################
!           #########################################################

	pure function comb2(x) result(out)
		real(kind=DP), intent(in) :: x(:)
		real(kind=DP) :: out
		out = (0.8d0+0.2d0*cos(5.0d0*norm2(x)))*exp(-0.5d0*norm2(x)**2)
	end function

! ============================== skewed (1d only) =============================

!                                        #
!                                        #
!                                        ##
!                                        ##
!                                        ##
!                                        ##
!                                        ###
!                                        ###
!                                        ###
!                                        ###
!                                       #####
!                                       #####
!                                       #####
!                                       #####
!                                       ######
!                                       ######
!                                       ######
!                                       #######
!                                       #######
!                                       #######
!                                       ########
!                                       ########
!                                       #########
!                                       #########
!                                      ###########
!                                      ############
!                                      ############
!                                      ##############
!                                      ###############
!                                     ###################

	pure function skewed(x) result(out)
		real(kind=DP), intent(in) :: x(:)
		real(kind=DP) :: out
		out = 1 / (1 + exp(-20*x(1))) / (1 + exp(3*x(1)))
	end function

! ============================= a bit wider skewed ============================

!                    #
!                   ###
!                   ####
!                   ####
!                  ######
!                  #######
!                  #######
!                  ########
!                  #########
!                  ##########
!                 ###########
!                 ############
!                 #############
!                 ##############
!                 ###############
!                 ###############
!                 ################
!                ##################
!                ####################
!                #####################
!                ######################
!                #######################
!                #########################
!               ###########################
!               #############################
!               ###############################
!               ##################################
!              ######################################
!              ###########################################
!             ####################################################

	pure function skewed2(x) result(out)
		real(kind=DP), intent(in) :: x(:)
		real(kind=DP) :: out
		out = 1 / (1 + exp(-10*(x(1)+2))) / (1 + exp(x(1)+2))
	end function

end module distributions


external sG0
external dcuhre

! Double precision
! integer, parameter :: dp=kind(0.d0)

! sqlite interface
type(SQLITE_DATABASE)                      :: db
type(SQLITE_COLUMN), dimension(:), pointer :: column

! Parameters
!    omega = om + i * del
real(dp), intent(in) :: om, del

! Global variables
!     omega  complex.
!            Frequency (energy) used for G
common /gvars/ Pi, t, mu, x0, epsf, V, Uc, Uf, Gkinv, Gkqinv
common /freq/  omega, qx, qy
common /date/  date, time
real(dp)    :: Pi, t, mu, x0, epsf, V, Uc, Uf, qx, qy
complex(dp) :: omega, Gkinv(16), Gkqinv(16)
character(len=8) :: date
character(len=4) :: time
character(len=16):: filename
character(len=64):: title

! Local variables
!     steps  integer.
!            Number of iterations to do
!            steps*steps/2 total iterations
real(dp)         :: qstep
integer          :: steps, iqx, iqy, log=10
real             :: start, end

! Variables for dcuhre
!     ndim   integer.
!            number of variables. 1 < ndim <=  15.
!     nfun   integer.
!            number of components of the integral.
!     a      real array of dimension ndim.
!            lower limits of integration.
!     b      real array of dimension ndim.
!            upper limits of integration.
!     minpts integer.
!            minimum number of function evaluations.
!     maxpts integer.
!            maximum number of function evaluations.
!     abserr real.
!            requested absolute error.
!     relerr real.
!            requested relative error.
!     nwork  integer.
!            defines the length of the working array work.
!     result real array of dimension nfun.
!            approximations to all components of the integral.
!     absest real array of dimension nfun.
!            estimates of absolute errors.
!     neval  integer.
!            number of function evaluations used by dcuhre.
!     ifail  integer.
!            ifail = 0 for normal exit, when abserr(k) <=  epsabs or
!              abserr(k) <=  abs(result(k))*epsrel with maxpts or less
!              function evaluations for all values of k,
!              1 <= k <= nfun .
!            ifail = 1 if maxpts was too small for dcuhre
!              to obtain the required accuracy. in this case dcuhre
!              returns values of result with estimated absolute
!              errors abserr.
!            ifail = 2 if key is less than 0 or key greater than 4.
!            ifail = 3 if ndim is less than 2 or ndim greater than 15.
!            ifail = 4 if key = 1 and ndim not equal to 2.
!            ifail = 5 if key = 2 and ndim not equal to 3.
!            ifail = 6 if nfun is less than 1.
!            ifail = 7 if volume of region of integration is zero.
!            ifail = 8 if maxpts is less than 3*num.
!            ifail = 9 if maxpts is less than minpts.
!            ifail = 10 if epsabs < 0 and epsrel < 0.
!            ifail = 11 if nw is too small.
!            ifail = 12 if unlegal restar.
!     work   real array of dimension nwork.
!            used as working storage.
integer            :: minpts, maxpts, neval, ifail
integer, parameter :: ndim = 2, nfun = 1, nwork = 6000000
real(dp)           :: a(ndim), b(ndim), abserr, relerr, &
                      result(nfun), absest(nfun), work(nwork)

! Interface for called procedures
! TODO: fix segmentation fault caused by non-declared array sizes
!   interface
!     subroutine dcuhre(ndim, nfun, a, b, minpts, maxpts, sG0, &
!                     abserr, relerr, key, nwork, restar, result,&
!                     absest, neval, ifail, work)
!       implicit none
!       integer, parameter      :: dp=kind(0.d0)
!       integer, intent(in)     :: ndim, nfun, minpts, maxpts, key, nwork, restar
!       integer, intent(out)    :: neval, ifail
!       real (dp), intent(in)   :: a(:), b(:), abserr, relerr
!       real (dp), intent(out)  :: result(:), absest(:)
!       real (dp), intent(in out)  :: work(:)

!       interface
!         subroutine sG0(ndim, z, nfun, f)
!           implicit none
!           integer, parameter     :: dp=kind(0.d0)
!           integer, intent(in)    :: ndim, nfun
!           real (dp), intent(in)  :: z(:)
!           real (dp), intent(out) :: f(:)
!         end subroutine sG0
!       end interface
!     end subroutine dcuhre
!   end interface


program test_sch3d_eig

use types, only: dp
use constants, only: i_
use ofdft, only: read_pseudo
use ofdft_fft, only: free_energy, radial_potential_fourier, &
    reciprocal_space_vectors, free_energy_min, real2fourier, integral, &
    fourier2real, real_space_vectors, vtk_save, integralG
use utils, only: loadtxt, stop_error, assert, linspace, strfmt, init_random
use splines, only: spline3pars, iixmin, poly3, spline3ders
use interp3d, only: trilinear
use md, only: positions_fcc, positions_bcc
use linalg, only: eigvals, inv, solve
use arpack, only: eig
use sorting, only: argsort
implicit none
integer :: Ng
real(dp), allocatable :: G(:,:,:,:), G2(:,:,:)
real(dp), allocatable :: Xn(:,:,:,:), Vn(:,:,:), r(:,:,:), psi(:,:,:), H(:,:)
complex(dp), allocatable, dimension(:) :: lam
complex(dp), allocatable :: psiG(:,:,:)
integer, allocatable :: idx(:)
real(dp) :: L
real(dp) :: lambda !, omega
integer :: i, ai, aj, ak, bi, bj, bk, ci, cj, ck, a_idx, b_idx !, a, b
real(dp) :: lam0
integer :: n, nev, ncv
real(dp), allocatable :: d(:), v(:,:)
real(dp), parameter :: lam_ref(2) = [-0.25808952900095627_dp, &
    9.4209719071036897_dp]

Ng = 8

L = 10._dp

allocate(G(Ng,Ng,Ng,3), G2(Ng,Ng,Ng), psi(Ng,Ng,Ng), psiG(Ng,Ng,Ng))
allocate(Xn(Ng, Ng, Ng, 3), Vn(Ng, Ng, Ng), r(Ng, Ng, Ng))
allocate(H(Ng**3, Ng**3))
allocate(lam(Ng**3), idx(Ng**3))

call real_space_vectors([L, L, L], Xn)
call reciprocal_space_vectors([L, L, L], G, G2)
!omega = 1._dp
r = sqrt(sum((Xn-L/2)**2, dim=4))
!Vn = omega**2 * r**2 / 2
lambda = 0.2_dp
Vn = -exp(-lambda*r**2)

!a = 2
!b = 12
!Vn = -1/sqrt(a+(Xn-L/2)**b)

call fourier2real(G2/2+0*i_, psi)

!do j = 1, Ng
!do i = 1, Ng
!    k = i-j+1
!    if (k < 1) k = k + Ng
!    H(i,j) = psi(k) / Ng
!end do
!end do

print *, "Assembly"

a_idx = 0
do ak = 1, Ng
do aj = 1, Ng
do ai = 1, Ng
    a_idx = a_idx+1
    b_idx = 0
    do bk = 1, Ng
    do bj = 1, Ng
    do bi = 1, Ng
        b_idx = b_idx+1
        ci = ai-bi+1
        cj = aj-bj+1
        ck = ak-bk+1
        if (ci < 1) ci = ci + Ng
        if (cj < 1) cj = cj + Ng
        if (ck < 1) ck = ck + Ng
        H(a_idx,b_idx) = psi(ci,cj,ck) / Ng**3
    end do
    end do
    end do
end do
end do
end do

a_idx = 0
do ak = 1, Ng
do aj = 1, Ng
do ai = 1, Ng
    a_idx = a_idx+1
    H(a_idx,a_idx) = H(a_idx,a_idx) + Vn(ai,aj,ak)
end do
end do
end do

print *, "Eigensolver"
lam = eigvals(H)

print *, "Sorting"
idx = argsort(real(lam, dp))

print *, "Power iteration"
call init_random()
lam0 = power_iteration(H)
print *, lam0, abs(lam0 - lam_ref(2))
call assert(abs(lam0 - lam_ref(2)) < 1e-5_dp)
print *, "Eigenvalues:"
do i = Ng**3, 1, -1
    print *, i, lam(idx(i))
end do
print *, lam(idx(Ng**3)), abs(lam(idx(Ng**3)) - lam_ref(2))
call assert(abs(lam(idx(Ng**3)) - lam_ref(2)) < 1e-13_dp)
print *, lam(idx(1)), abs(lam(idx(1)) - lam_ref(1))
call assert(abs(lam(idx(1)) - lam_ref(1)) < 1e-13_dp)

print *, "Inverse iteration"
lam0 = inverse_iteration(H, -0.20_dp)
print *, lam0, abs(lam0 - lam_ref(1))
call assert(abs(lam0 - lam_ref(1)) < 1e-13_dp)

print *, "Arpack"

n = Ng**3
nev = 4
ncv = 100
allocate(v(n,ncv), d(ncv))
call eig(n, nev, ncv, "SA", av, d, v)
do i = 1, nev
    print *, d(i)
end do
print *, d(1), abs(d(1) - lam_ref(1))
call assert(abs(d(1) - lam_ref(1)) < 1e-13_dp)

!print *, "E_tot_exact =", 3*omega/2

contains

    real(dp) function power_iteration(A) result(lam)
    real(dp), intent(in) :: A(:, :)
    real(dp) :: y(size(A, 1)), v(size(A, 1))
    real(dp) :: y0(size(A, 1))
    integer :: i
    call random_number(y0)
    y = y0
    print *
    do i = 1, 70
        v = y / sqrt(sum(abs(y)**2))
        y = matmul(A, v)
        lam = dot_product(v, y)
        print *, i, lam
    end do
    end function

    real(dp) function inverse_iteration(A, mu) result(lam)
    real(dp), intent(in) :: A(:, :)
    real(dp), intent(in) :: mu
    real(dp) :: M(size(A, 1), size(A, 2))
    real(dp) :: y(size(A, 1)), v(size(A, 1)), theta
    real(dp) :: y0(size(A, 1))
    integer :: i, N
    logical, parameter :: invert = .false.
    N = size(A, 1)
    call assert(size(A, 2) == N)
    M = A
    do i = 1, N
        M(i,i) = M(i,i) - mu
    end do
    if (invert) then
        print *, "inverting:"
        M = inv(M)
        print *, "done"
    end if

    call random_number(y0)
    y = y0
    print *
    do i = 1, 13
        v = y / sqrt(sum(abs(y)**2))
        if (invert) then
            y = matmul(M, v)
        else
            y = solve(M, v)
        end if
        theta = dot_product(v, y)
        lam = mu + 1/theta
        print *, i, lam
    end do
    end function

    subroutine av(x, y)
    ! Compute y = A*x
    real(dp), intent(in) :: x(:)
    real(dp), intent(out) :: y(:)
    call real2fourier(reshape(x, [Ng,Ng,Ng]), psiG)
    call fourier2real(G2/2*psiG, psi)
    y = reshape(psi, [Ng**3]) + reshape(Vn, [Ng**3])*x
    !y = reshape(psi + Vn * reshape(x, [Ng,Ng,Ng]), [Ng**3])
    end

end program


!
!   at rho=1.0 => P(delta) = exp(-delta/0.052)
!
!   ~ 5 metro sweeps per sec
!

    program ecmc
    use iso_fortran_env, only: int64
    use universe, only: pp2d, stack, pr, pi
    use histogram, only: hist1d, hist2d
    implicit none
    type(pp2d)     :: pos
    type(stack)    :: env
    type(hist1d)   :: h_delta, h_xji, h_rji
    type(hist2d)   :: h_gxy
    real(pr)       :: rnd, cutoff, skin, cut2, wth, rho, &
                      powhi, delta, rji(2), max_del, sum_del, &
                      xji, dji, dji_ave, pressure, psi(2), &
                      theta, mat(2,2)
    integer        :: idx, dir, pow, powh, mloc(1), n, &
                       ch, sweep, num_sweeps, uscalars, &
                       uvecs, sample
    integer(int64) :: timestamp
!    character(len=*) , parameter :: address = "../../repulsive/p_64/c_1.8/r_0.882/n_256/mc_restart.txt"

    pow = 12; powh = pow/2; powhi = 1.0_pr/powh
    cutoff = 1.8_pr; cut2 = cutoff**2
    skin = 0.2_pr
    wth = cutoff + skin
    call h_delta%init(0.0_pr,0.6_pr,0.005_pr)
    call h_xji%init(0.0_pr,wth,0.01_pr)
    call h_rji%init(0.6_pr,wth,0.01_pr)
    call h_gxy%init(-wth,wth,0.05_pr,-wth,wth,0.05)
    call fopen("ecmc_scalars.txt",uscalars)
    !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

    open(newunit=uvecs,file="mc_vectors.txt",status="old",action="read")
    do sample = 1, 40

        pos = pp2d(uvecs,wth); rho = pos%nop/(pos%lx*pos%ly)
        call pos%stage()

        max_del = 0.05*sqrt(real(pos%nop))/2
        num_sweeps = 100
        timestamp = 0
        do sweep = 1, num_sweeps
           !~~~~~~~~~~~ a sweep
           dji_ave = 0.0_pr
           do ch = 1, pos%nop
                !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ an event chain
                ! select a random direction
                call random_number(rnd)
                if( rnd<0.5_pr ) then
                        dir = 1
                else
                        dir = 2
                end if
                ! select a random particle
                call random_number(rnd)
                idx = floor(rnd*pos%nop)
                ! event chain
                sum_del = 0.0_pr
                dji     = 0.0_pr
                do
                    timestamp = timestamp + 1
                    ! find the earliest collision of idx
                    if( dir==1 ) then
                            call pos%zoom_r(idx,env)
                            n = env%n
                            call random_number(env%g(1:n))
                            env%g(1:n) = -log(env%g(1:n))
                            env%f(1:n) = collide(env%x(1:n),env%y(1:n),env%g(1:n))
                    else
                            call pos%zoom_u(idx,env)
                            n = env%n
                            call random_number(env%g(1:n))
                            env%g(1:n) = -log(env%g(1:n))
                            env%f(1:n) = collide(env%y(1:n),env%x(1:n),env%g(1:n))
                    end if
                    mloc  = minloc(env%f(1:n))
                    delta = env%f(mloc(1))                    ; call h_delta%gather(delta)
                    rji   = [ env%x(mloc(1)), env%y(mloc(1)) ]; call h_rji%gather(sqrt(sum(rji**2)))
                    xji   = rji(dir) - delta                  ; call h_xji%gather(xji)
                    ! move
                    sum_del = sum_del + delta
                    if( sum_del>=max_del ) then
                            delta = delta - (sum_del - max_del)
                            call pos%move(idx,dir,delta)
                            exit
                    else
                            dji = dji + xji
                            call pos%move(idx,dir,delta)
                    end if
                    ! transfer idx
                    idx   = env%id(mloc(1))
                end do!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ end of an event chain
                dji_ave = dji_ave + dji
           end do !~~~~~~~~~~~~~~~~~  end of a sweep
           ! pressure
           dji_ave = dji_ave/(pos%nop)
           pressure = rho*(1.0_pr + dji_ave/max_del)
           ! orientational order
           psi = 0.0_pr
           do idx = 0, pos%nop-1
              call pos%zoom_on(idx,env)
              psi = psi + env%hexorder()
           end do
           psi = psi/pos%nop
           ! angle of orientation
           rnd = sum(psi**2)
           theta = acos( psi(1)/sqrt(rnd) )
           if( psi(2)<0.0_pr ) theta = 2*pi-theta
           theta = theta/6
           ! gxy
           mat = reshape( [cos(-theta), sin(-theta), &
                          -sin(-theta), cos(-theta)], [2,2] )
           do idx = 0, pos%nop-1
              call pos%zoom_on(idx,env)
              call env%rotate(matrix=mat)
              n = env%n
              call h_gxy%gather(env%x(1:n),env%y(1:n))
           end do
           !
           write(uscalars,*) sample, pressure, psi, theta
           write(0,*) sample, pressure, psi, theta
        end do

    end do

    !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
    close(uscalars)
    call h_delta%write("hist_delta.txt")
    call h_xji%write("hist_xji.txt")
    call h_rji%write("hist_rji.txt")
    call h_gxy%write("hist_gxy.txt")

    contains

            elemental &
            function collide(x,y,de) result(delta)
            implicit none
            real(pr), intent(in) :: x, y, de
            real(pr)             :: delta, e, u, v, &
                                    y2, xx, xxx
            if( x<=0.0_pr ) then ! no collision ?
                    delta = wth; return
            end if
            y2 = y*y
            if( y2>=cut2 ) then ! no collision ?
                    delta = wth; return
            end if
            u = x*x + y2
            if( u>cut2 ) then
                   xx = sqrt( cut2-y2 )
                   delta = x - xx
                   u = cut2
            else
                    xx = x
                    delta = 0.0_pr
            end if
            e = de + 1.0_pr/u**powh
            v = (1.0_pr/e)**powhi
            if( y2>v ) then ! no collision ?
                    delta = wth; return
            end if
            xxx = sqrt(v-y2)
            delta = delta + xx - xxx
            end function collide

            subroutine fopen(fname,u)
            implicit none
            character(len=*), intent(in) :: fname
            integer, intent(out)         :: u
            logical                      :: yes
            inquire(file=fname,exist=yes)
            if( yes ) then
               open(newunit=u,file=fname,status="old",action="write",access="append")
            else
               open(newunit=u,file=fname,status="new",action="write")
            end if
            end subroutine

    end program


program test_wdt
    implicit none
    integer (kind=4), parameter :: n_x=4
    integer (kind=4), parameter :: n_y=4
    real (kind=8), dimension(0:n_x-1,0:n_y-1) :: cost_field,wdt_field
    real (kind=8), parameter :: obstacle_value = 200

    ! Example:
    !- - - -
    !* * * -
    !- * - -
    !- - - -

    cost_field = 1
    cost_field(1,1) = 0
    cost_field(0:3,2) = 0
    cost_field(3,1:3)= obstacle_value
    wdt_field = obstacle_value
    wdt_field(2,2) = 0
    call weighted_distance_transform(cost_field,wdt_field,n_x,n_y,obstacle_value)
end program

subroutine weighted_distance_transform(cost_field,wdt_field,n_x,n_y,obstacle_value)
use wdt_module
implicit none
!   Compute the potential in a single cell with a first order upwind method
!f2py intent(in) cell_x,cell_y,pot_field,u_x,u_y,inf
!f2py depend(n_x,n_y) pot_field,u_x,u_y
!f2py intent(out) out_pot
!
integer ::  n_x,n_y
real (kind=8) :: obstacle_value ! value exceeding largest in potential computation. max(pot) + max(u_x,u_y) + 1 will do
real (kind=8) :: unknown_value ! Value exceeding inf, indicated that we do not know yet
integer (kind=4) :: nb_cell_x,nb_cell_y, exists! neighbour indices
real (kind=8):: hor_potential,ver_potential,hor_cost,ver_cost

integer (kind=4) :: direction
integer (kind=4), parameter :: LEFT = 0
integer (kind=4), parameter :: DOWN = 1
integer (kind=4), parameter :: RIGHT = 2
integer (kind=4), parameter :: UP = 3

integer (kind=4), dimension(:,:), allocatable :: nb_values

integer (kind=4) :: exists
integer (kind=4) :: i,j
real (kind=8), dimension(0:n_x-1,0:n_y-1) :: cost_field,wdt_field
real (kind=8), dimension(0:n_x,0:n_y-1) :: costs_x
real (kind=8), dimension(0:n_x-1,0:n_y) :: costs_y
integer (kind=4) :: cell_x,cell_y
real (kind=8) :: pot

!neighbour_pots=  (/ inf, inf, inf, inf /)
costs_x = obstacle_value
costs_x(1:n_x-1,:) = (cost_field(1:n_x-1,:) + cost_field(0:n_x-2,:))/2
costs_y = obstacle_value
costs_x(:,1:n_y-1) = (cost_field(:,1:n_y-1) + cost_field(:,0:n_y-2))/2

    allocate(nb_values(0:3,0:1))
        nb_values = new_candidate_cells(2,1)
    print*,nb_values
    deallocate(nb_values)

    do i=0,n_x-1
        write(*,*) ( cost_field(j,n_x-i-1), j=0,n_y-1 )
    enddo

end subroutine


      program P1105A
c>> 1997-10-02 Krogh Generate plots for first two figures in ch11-05.tex
      integer MAXPT
      real RMAXPT, XA, XB, XSIZE, YSIZE
      parameter (MAXPT=101, RMAXPT=101.E0)
      parameter (XA = 0.0E0, XB = 6.0E0)
      parameter (XSIZE=3.2E0, YSIZE=2.5E0)
      real DX, X(MAXPT), Y(MAXPT,2)
      external SSVAL
      real SSVAL
      integer I, J
      real OPTA1(10), OPTA2(5), OPTA3(6), OPTB1(21), OPTB2(7)
      character COPTA1*17, COPTB1*50
c
      integer NCOEF, KORDER
      parameter (NCOEF = 9, KORDER = 4)
      real BCOEF(NCOEF), BVPOSA(7), BVPOSB(7), PKNOTS(7), TKNOTS(13),
     1  XPT(24), YPT(24)
c
      real PLOUNI,PLOTXT,PLONY,PLOBOR,PLOSYM,PLOYMX
      parameter (PLOUNI=1.E0, PLOTXT=14.E0, PLONY=2.E0, PLOBOR=4.E0,
     1  PLOSYM=10.E0, PLOYMX=9.E0)
c
      data OPTA1 / 0.E0, PLOSYM, 80603.E0, PLOBOR, 34.0E0, 0.E0, 0.E0,
     1   PLOUNI, 54.E0, 0.E0 /
      data COPTA1 /'F{pl11-05a.tex}Q'/
c
      data OPTA2 /0.E0, PLOUNI, 4.E0, 0.E0, 0.E0/
c
      data OPTA3 / 0.E0, PLOSYM, 1040000.E0, PLOUNI, 50.E0, 0.E0 /
c
      data OPTB1 / 0.E0, PLOSYM, 80603.E0, PLOBOR, 34.0E0, 0.E0, 0.E0,
     1   PLOUNI, 53.E0, PLOTXT, 3.5E0, 2.0E0, 0.E0,
     2   PLOTXT, 4.E0, -2.E0, 0.E0, PLOYMX, -4.E0, 4.E0, 0.E0 /
c                           111111111122222222223333333333444444444455
c                  123456789012345678901234567890123456789012345678901
      data COPTB1/'F{pl11-05b.tex}{$f^\prime$}{$f^{\prime \prime}$}'/
c
      data OPTB2 / 0.E0, PLOUNI, 3.E0, PLONY, MAXPT, 2.E0,
     1   0.E0 /
c
      data XPT / 0.000E0, 0.300E0, 0.700E0, 1.000E0, 1.300E0, 1.700E0,
     1  2.000E0, 2.300E0, 2.500E0, 2.600E0, 2.800E0, 2.900E0, 3.000E0,
     2  3.100E0, 3.200E0, 3.500E0, 3.700E0, 4.000E0, 4.300E0, 4.700E0,
     3  5.000E0, 5.300E0, 5.700E0, 6.000E0 /
      data YPT / 1.000E0, 1.100E0, 0.900E0, 1.020E0, 1.200E0, 1.000E0,
     1  1.200E0, 1.400E0, 1.760E0, 2.000E0, 2.400E0, 2.600E0, 3.000E0,
     2  3.400E0, 3.700E0, 4.300E0, 4.450E0, 4.760E0, 4.800E0, 5.000E0,
     3  4.960E0, 4.900E0, 4.900E0, 5.000E0 /
      data TKNOTS / 0.00000E0, 0.00000E0, 0.00000E0, 0.00000E0,
     1   1.50000E0, 2.50000E0, 3.30000E0, 4.00000E0, 4.70000E0,
     2   6.00000E0, 6.00000E0, 6.00000E0, 6.00000E0 /
      data BCOEF /  1.00000E0, 1.01613E0, 1.04300E0, 1.07848E0,
     1   4.07150E0, 4.87706E0, 4.92040E0, 4.96864E0, 5.00000E0 /
      data PKNOTS / 0.00000E0, 1.50000E0, 2.50000E0, 3.30000E0,
     1   4.00000E0, 4.70000E0, 6.00000E0 /
      data BVPOSA / 7*.3E0 /
      data BVPOSB / 7*-3.5E0 /
c
c Take care of the first figure for Chapter 11-05.
c
c Take care of the breakpoint marks
      call SPLOT(XSIZE, YSIZE, PKNOTS, 7, BVPOSA, OPTA1, COPTA1)
c
      DX = (XB - XA) / (MAXPT - 1)
      do 100 I = 1, MAXPT
         X(I) = real(I - 1) * DX
         Y(I,1) = SSVAL(KORDER, NCOEF, TKNOTS, BCOEF, X(I), 0)
  100 continue
      call SPLOT(XSIZE, YSIZE, X, MAXPT, Y, OPTA2, 'Q')
c Plot the data points
      call SPLOT(XSIZE, YSIZE, XPT, 24, YPT, OPTA3, 'Q')
c
c Take care of second figure for Chapter 11-05
c
c Take care of the breakpoint marks
      call SPLOT(XSIZE, YSIZE, PKNOTS, 7, BVPOSB, OPTB1, COPTB1)
      do 200 J = 1, 6
c                Loop over the intervals between breakpoints.
         DX = (PKNOTS(J+1) - PKNOTS(J)) / 19.E0
         do 150 I = 1, 20
            X(I) = PKNOTS(J) + real(I - 1) * DX
            Y(I,1) = SSVAL(KORDER, NCOEF, TKNOTS, BCOEF, X(I), 1)
            Y(I,2) = SSVAL(KORDER, NCOEF, TKNOTS, BCOEF, X(I), 2)
  150    continue
         if (J .eq. 6) OPTB2(3) = 0.E0
         call SPLOT(XSIZE, YSIZE, X, 20, Y, OPTB2, 'Q')
  200 continue
      stop
      end


! { dg-do run }
! PR 21912
! We didn't adapt the exit condition to negative steps in array constructors,
! leaving the resulting arrays uninitialized.
integer :: i(5), n, m, l, k

n = 5
i = (/ (m, m = n, 1, -1) /)
if (any (i /= (/ 5, 4, 3, 2, 1 /))) STOP 1

k = 1

i(5:1:-1) = (/ (m, m = n, k, -1) /)
if (any (i /= (/ 1, 2, 3, 4, 5 /))) STOP 2

l = -1

i = (/ (m, m = n, 1, l) /)
if (any (i /= (/ 5, 4, 3, 2, 1 /))) STOP 3

i(5:1:-1) = (/ (m, m = n, k, l) /)
if (any (i /= (/ 1, 2, 3, 4, 5 /))) STOP 4
end


program test_assert_pass
use types, only: dp
use utils, only: assert
implicit none

integer :: i, a(5)
real(dp) :: b(5)

! All these must pass
call assert(.true.)
call assert(5 == 5)

i = 5
call assert(i == 5)
call assert(i /= 6)

a = [1, 2, 3, 4, 5]
call assert(all(a == [1, 2, 3, 4, 5]))
call assert(.not. all(a == [2, 2, 3, 4, 5]))
b = [1, 2, 3, 4, 5]
call assert(all(abs(b - [1, 2, 3, 4, 5]) < epsilon(1._dp)))
call assert(.not. all(abs(b - [2, 2, 3, 4, 5]) < epsilon(1._dp)))

end program


module m ! parameterized derived type analog of dt_stream.f90
implicit none
integer, parameter :: nlen = 10
type :: data_frame(n1,n2)
   integer, len         :: n1,n2
   character (len=nlen) :: col_names(n2)
   real                 :: x(n1,n2)
end type data_frame
contains
subroutine write_stream(df,iu)
type(data_frame(*,*)), intent(in) :: df
integer              , intent(in) :: iu
! write dimensions of df components followed by values
write (iu) df%n1,df%n2,df%col_names,df%x
end subroutine write_stream
!
subroutine read_stream(df,iu)
type(data_frame(:,:)), intent(out), allocatable :: df
integer              , intent(in)  :: iu
integer                            :: n1,n2
read (iu) n1,n2 ! read dimensions of df%x
allocate (data_frame(n1,n2) :: df)
read (iu) df%col_names,df%x ! read df
end subroutine read_stream
!
end module m
!
program main
use m, only: data_frame, write_stream, read_stream
implicit none
integer, parameter :: n1 = 10**7, n2 = 2
type(data_frame(:,:)), allocatable :: df_in,df_out
character (len=*), parameter :: fname = "temp.bin"
integer :: iu
allocate (data_frame(n1,n2) :: df_in)
df_in%col_names = ["x1","x2"]
call random_number(df_in%x)
open (unit=iu,file=fname,form="unformatted",access="stream")
call write_stream(df_in,iu) ! write dimensions and values of df_in
rewind (iu)
call read_stream(df_out,iu) ! read df_out and check it
print*,minval(df_in%x),maxval(df_in%x),all(df_in%x == df_out%x), &
       all(df_in%col_names==df_out%col_names)
end program main
! sample output:
!    1.78813934E-07  0.999999940     T T


program test_sorting_sort
    use forlab_sorting,only:argsort,sort
    use forlab_io, only:disp
    real(8)::x(4)
    integer::a(4)=[1,3,2,4]
    call random_number(x)
    call disp("argsort/sort tri U L test")
    call disp(x,"x")
    call disp(argsort(x),"argsort(x)")
    call disp(argsort(x,2),"argsort(x)")
    call disp(sort(x,2),"sort(x)")
    call disp(sort(x,1),"sort(x)")
    call disp(a,"x")
    call disp(argsort(a),"argsort(a)")
    call disp(argsort(a,2),"argsort(a)")
    call disp(sort(a,2),"sort(a)")
    call disp(sort(a,1),"sort(a)")
end program test_sorting_sort


      subroutine user46_setaux_manifold(mbc,mx,my,
     &      xlower,ylower,dx,dy,maux,aux,blockno,
     &      xd,yd,zd,area)
      implicit none

      integer mbc, mx,my, meqn, maux
      integer blockno
      double precision dx,dy, xlower, ylower
      double precision  aux(1-mbc:mx+mbc,1-mbc:my+mbc, maux)

      double precision xd(-mbc:mx+mbc+2,-mbc:my+mbc+2)
      double precision yd(-mbc:mx+mbc+2,-mbc:my+mbc+2)
      double precision zd(-mbc:mx+mbc+2,-mbc:my+mbc+2)

      double precision area(-mbc:mx+mbc+1,-mbc:my+mbc+1)

      integer i,j
      double precision dxdy, t, x

      dxdy = dx*dy

      do i = 1-mbc,mx+mbc
         do j = 1-mbc,my+mbc
            aux(i,j,1) = area(i,j)/dxdy
         enddo
      enddo

      t = 0
      call user46_set_velocity_manifold(mx,my,mbc,
     &      dx,dy,t,blockno,xd,yd,zd,aux,maux)

      return
      end

      subroutine user46_set_velocity_manifold(mx,my,mbc,
     &      dx,dy,t,blockno,xd,yd,zd,aux,maux)
      implicit none

      integer mx,my,mbc,maux, blockno
      double precision dx,dy, t

      double precision xd(-mbc:mx+mbc+2,-mbc:my+mbc+2)
      double precision yd(-mbc:mx+mbc+2,-mbc:my+mbc+2)
      double precision zd(-mbc:mx+mbc+2,-mbc:my+mbc+2)

      double precision xd1(3),xd2(3)
      double precision aux(1-mbc:mx+mbc,1-mbc:my+mbc,maux)

      integer i,j
      double precision vn
      logical ispillowsphere

      do i = 1-mbc,mx+mbc
         do j = 1-mbc,my+mbc
c           # x-faces
            xd1(1) = xd(i,j+1)
            xd1(2) = yd(i,j+1)
            xd1(3) = zd(i,j+1)

            xd2(1) = xd(i,j)
            xd2(2) = yd(i,j)
            xd2(3) = zd(i,j)

            call get_psi_vel(xd1,xd2,dy,vn,t)
            if (ispillowsphere()) then
               if (blockno == 1) then
                  vn = -vn
               endif
            endif
            aux(i,j,2) = vn
         enddo
      enddo

      do j = 1-mbc,my+mbc
         do i = 1-mbc,mx+mbc
c           # y-faces
            xd1(1) = xd(i+1,j)
            xd1(2) = yd(i+1,j)
            xd1(3) = zd(i+1,j)

            xd2(1) = xd(i,j)
            xd2(2) = yd(i,j)
            xd2(3) = zd(i,j)

            call get_psi_vel(xd1,xd2,dx,vn,t)
            if (ispillowsphere()) then
               if (blockno == 1) then
                  vn = -vn
               endif
            endif

            aux(i,j,3) = -vn
         enddo
      enddo
      end


      double complex function Fsc3(j1,j2,j3,j4,j5,j6,za,zb)
      implicit none
      include 'constants.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4,j5,j6
      double complex L1
      double precision t
      Fsc3=
     .-((za(j4,j5)**2*((L1(-s(j5,j6),-t(j2,j3,j4))*
     .(za(j1,j5)*za(j2,j4)*zb(j1,j2)+
     .za(j1,j5)*za(j3,j4)*zb(j1,j3))**2)/
     .(2d0*za(j4,j5)**2*t(j2,j3,j4)**2)-
     .(L1(-s(j3,j4),-t(j2,j3,j4))*za(j2,j5)**2*za(j3,j4)**2*zb(j2,j3)**2
     .)/
     .(2d0*za(j4,j5)**2*t(j2,j3,j4)**2)))/
     .(za(j1,j2)*za(j2,j3)*za(j3,j4)*za(j5,j6)))+
     .(-((za(j4,j5)*(za(j1,j3)*zb(j1,j3)*zb(j1,j6)+
     .za(j2,j3)*zb(j1,j3)*zb(j2,j6)))/t(j1,j2,j3))+
     .(zb(j1,j6)*(-(za(j2,j5)*za(j3,j4)*zb(j2,j3))+
     .za(j3,j4)*za(j4,j5)*zb(j3,j4)))/t(j2,j3,j4))/
     .(3d0*s(j5,j6)*za(j2,j3)**2)+(-((za(j2,j5)*za(j4,j5)*zb(j2,j3))/
     .(za(j1,j2)*za(j2,j3)*za(j5,j6)*t(j2,j3,j4)))+
     .(-(za(j2,j4)*zb(j2,j6))-za(j3,j4)*zb(j3,j6))**2/
     .(za(j1,j2)*za(j2,j3)*za(j3,j4)*zb(j5,j6)*t(j2,j3,j4))-
     .(za(j4,j5)*zb(j2,j3)*(-(za(j2,j5)*zb(j2,j3))+za(j4,j5)*zb(j3,j4)))
     ./
     .(za(j1,j2)*za(j5,j6)*t(j1,j2,j3)*t(j2,j3,j4))+
     .(za(j2,j4)*zb(j1,j6)*zb(j2,j3)*
     .(za(j1,j2)*zb(j2,j6)+za(j1,j3)*zb(j3,j6)))/
     .(za(j1,j2)*za(j2,j3)*zb(j5,j6)*t(j1,j2,j3)*t(j2,j3,j4)))/2
      return
      end


    subroutine getrusanovflux(Qfl,Qfr,Fnl,Fnr,Az,normf,sign_l,sign_r,eigv)
    use setup2d,only: gam,eigvmax
    implicit none

    integer,intent(in) :: sign_l,sign_r
    double precision :: Qfl(9),Qfr(9),Fnl(8),Fnr(8),eigv,normf(2)
    double precision :: ul,vl,wl,ur,vr,wr,Vn_l,Vn_r,pl,pr,&
    Bxl,Byl,Bzl,Bxr,Byr,Bzr,NORM_Bl,NORM_Br,Bx,By,Bz,Bn_l,Bn_r,Az
    double precision :: rhoi,c_a,c_d,c_n,c_tmp,c_f
    double precision :: unit_x,unit_y,magnorm

    ! get the magnitude of normal vector |J| div(\xi) or |J| div(\eta) from left cell
    magnorm = dsqrt(normf(1)**2+normf(2)**2)

    ! unit normal vector pointing from left cell to right cell
    unit_x = normf(1)/magnorm*sign_l
    unit_y = normf(2)/magnorm*sign_l

    ! compute the Rosanov flux on physical domain along vector (unit_x,unit_y)

    !for the left side
    rhoi  = 1.d0/Qfl(1)
    ul    = rhoi*Qfl(2)
    vl    = rhoi*Qfl(3)
    wl    = rhoi*Qfl(4)
    Bxl   = Qfl(6)
    Byl   = Qfl(7)
    Bzl   = Qfl(8)

    NORM_Bl = Bxl**2+Byl**2+Bzl**2

    pl    = (gam-1.d0)*(Qfl(5) - 0.5d0*Qfl(1)*(ul**2+vl**2+wl**2)-NORM_Bl*0.5d0)
    pl    = pl + 0.5d0*NORM_Bl  ! Total pressure = pressure + magnetic pressure
    Vn_l  = ul*unit_x+vl*unit_y
    Bn_l  = Bxl*unit_x + Byl*unit_y

    !for the right side
    rhoi  = 1.d0/Qfr(1)
    ur    = rhoi*Qfr(2)
    vr    = rhoi*Qfr(3)
    wr    = rhoi*Qfr(4)
    Bxr   = Qfr(6)
    Byr   = Qfr(7)
    Bzr   = Qfr(8)

    NORM_Br = Bxr**2 + Byr**2 + Bzr**2

    pr    = (gam-1.d0)*(Qfr(5) - 0.5d0*Qfr(1)*(ur**2+vr**2+wr**2)-NORM_Br*0.5d0)
    pr    = pr + NORM_Br*0.5d0  ! Total pressure = pressure + magnetic pressure
    Vn_r  = ur*unit_x+vr*unit_y
    Bn_r  = Bxr*unit_x + Byr*unit_y

    ! calculate the normal flux component at left side
    Fnl(1) = Qfl(1)*Vn_l
    Fnl(2) = Qfl(2)*Vn_l + pl*unit_x - Bxl*Bn_l
    Fnl(3) = Qfl(3)*Vn_l + pl*unit_y - Byl*Bn_l
    Fnl(4) = Qfl(4)*Vn_l -Bzl*Bn_l
    Fnl(5) = (Qfl(5)+pl)*Vn_l - Bn_l*(ul*Bxl+vl*Byl+wl*Bzl)
    Fnl(6) = (vl*Bxl-ul*Byl)*unit_y
    Fnl(7) = (ul*Byl-vl*Bxl)*unit_x
    Fnl(8) = Bzl*Vn_l - wl*Bn_l

    ! calculate the normal flux component at right side
    Fnr(1) = Qfr(1)*Vn_r
    Fnr(2) = Qfr(2)*Vn_r + pr*unit_x - Bxr*Bn_r
    Fnr(3) = Qfr(3)*Vn_r + pr*unit_y - Byr*Bn_r
    Fnr(4) = Qfr(4)*Vn_r - Bzr*Bn_r
    Fnr(5) = (Qfr(5)+pr)*Vn_r - Bn_r*(ur*Bxr+vr*Byr+wr*Bzr)
    Fnr(6) = (vr*Bxr-ur*Byr)*unit_y
    Fnr(7) = (ur*Byr-vr*Bxr)*unit_x
    Fnr(8) = Bzr*Vn_r - wr*Bn_r

    ! calculate the eignvalue (fast magneto-acoustic wave speed)
    pl = pl -  0.5d0*NORM_Bl
    pr = pr -  0.5d0*NORM_Br
    Bx = 0.5d0*(Bxl+Bxr)
    By = 0.5d0*(Byl+Byr)
    Bz = 0.5d0*(Bzl+Bzr)

    c_a  = gam*(pl+pr)/(Qfl(1)+Qfr(1))
    c_d  = (Bx**2+By**2+Bz**2)/(0.5d0*(Qfl(1)+Qfr(1)))
    c_n  = (Bx*unit_x+By*unit_y)**2/(0.5d0*(Qfl(1)+Qfr(1)))
    c_tmp= dsqrt((c_a+c_d)**2-4.0d0*c_a*c_n)

    c_f  = dsqrt(0.5d0*(c_a+c_d+c_tmp))

    eigv = 0.5d0*dabs(Vn_l+Vn_r) + c_f

    ! Rusanov flux for left cell on physical domain
    Fnl(1:8) = 0.5d0*(Fnl(1:8)+Fnr(1:8)-eigv*(Qfr(1:8)-Qfl(1:8)))

    ! Transfer to computational domain for left cell
    Fnl(1:8) = magnorm*sign_l*Fnl(1:8)

    ! Transfer to computational domain for right cell
    Fnr(1:8) = sign_l*sign_r*Fnl(1:8)

    ! upwind scheme for magnetic potential A
    if (Vn_l.gt.0.d0) then
        Az = Qfl(9)
    else
        Az = Qfr(9)
    end if

    if (eigv.gt.eigvmax) then
        eigvmax = eigv
    end if

    end subroutine getrusanovflux

    subroutine getIfluxvectors(Qi,Fi,Gi)
    use setup2d,only: gam
    implicit none

    double precision,intent(in) :: Qi(8)
    double precision,intent(out) :: Fi(8),Gi(8)
    double precision :: rho,rhou,rhov,rhow,rhoE,pr,Bx,By,Bz,NORM_B

    rho  = Qi(1)
    rhou = Qi(2)
    rhov = Qi(3)
    rhow = Qi(4)
    rhoE = Qi(5)
    Bx   = Qi(6)
    By   = Qi(7)
    Bz   = Qi(8)

    NORM_B = Bx**2+By**2+Bz**2

    !compute the pressure
    pr = (gam-1.d0)*(rhoE - 0.5d0*(rhou**2+rhov**2+rhow**2)/rho-0.5d0*NORM_B)

    !compute flux vector F
    Fi(1) = rhou
    Fi(2) = (rhou**2)/rho + pr + (0.5d0*NORM_B-Bx**2)
    Fi(3) = rhou*rhov/rho - Bx*By
    Fi(4) = rhou*rhow/rho - Bx*Bz
    Fi(5) = (rhou/rho)*(rhoE+pr+0.5d0*NORM_B) - (rhou/rho*Bx+rhov/rho*By+rhow/rho*Bz)*Bx
    Fi(6) = 0.d0
    Fi(7) = rhou/rho*By-rhov/rho*Bx
    Fi(8) = rhou/rho*Bz-rhow/rho*Bx

    !compute flux vector G
    Gi(1) = rhov
    Gi(2) = rhou*rhov / rho - Bx*By
    Gi(3) = (rhov**2)/rho + pr + (0.5d0*NORM_B-By**2)
    Gi(4) = rhow*rhov/rho - By*Bz
    Gi(5) = (rhov/rho)*(rhoE+pr+0.5d0*NORM_B) - (rhou/rho*Bx+rhov/rho*By+rhow/rho*Bz)*By
    Gi(6) = rhov/rho*Bx - rhou/rho*By
    Gi(7) = 0.d0
    Gi(8) = rhov/rho*Bz - rhow/rho*By

    end subroutine getIfluxvectors

    !subroutine to calculate viscous flux
    !Qv and nablaQ are all smoothed ones for the interface flux points
    SUBROUTINE getVfluxvectors(Qv,nablaQ,Fv,Gv)

    use setup2d
    IMPLICIT NONE

    double precision,intent(in) :: Qv(numv),nablaQ(numv,2)
    double precision,intent(out) :: Fv(numv),Gv(numv)
    double precision :: u, v, w, NORM_U, Bx, By, Bz, Jx, Jy, Jz, NORM_B, inte
    double precision :: rho, rhou, rhov, rhow, rhoE
    double precision :: ux, vx, uy, vy, wx, wy, ex, ey, rhox, rhoy, Bxy, Byx, Bzy, Bzx
    double precision :: du(2),dv(2),dw(2),drho(2),dBx(2),dBy(2),dBz(2),de(2),dKE(2),dpre_B(2)

    rho  = Qv(1)
    rhou = Qv(2)
    rhov = Qv(3)
    rhow = Qv(4)
    rhoE = Qv(5)
    Bx   = Qv(6)
    By   = Qv(7)
    Bz   = Qv(8)

    u = rhou/rho
    v = rhov/rho
    w = rhow/rho

    NORM_U = u**2  + v**2  + w**2
    NORM_B = Bx**2 + By**2 + Bz**2

    inte = (rhoE - 0.5d0*NORM_U*rho - 0.5d0*NORM_B)/rho

    drho(:) =  nablaQ(1,:)
    du(:)   = (nablaQ(2,:)-drho(:)*u)/rho
    dv(:)   = (nablaQ(3,:)-drho(:)*v)/rho
    dw(:)   = (nablaQ(4,:)-drho(:)*w)/rho
    dBx(:)  =  nablaQ(6,:)
    dBy(:)  =  nablaQ(7,:)
    dBz(:)  =  nablaQ(8,:)

    dKE(:)    = 0.5d0*NORM_U*drho(:) + rho*(u*du(:)+v*dv(:)+w*dw(:))
    dpre_B(:) = Bx*dBx(:) + By*dBy(:) + Bz*dBz(:)

    de(:)  = (nablaQ(5,:) - dKE(:) - dpre_B(:) - drho(:)*inte)/rho

    rhox = drho(1)
    rhoy = drho(2)

    ux = du(1)
    uy = du(2)
    vx = dv(1)
    vy = dv(2)
    wx = dw(1)
    wy = dw(2)
    ex = de(1)
    ey = de(2)

    Bxy = dBx(2)
    Byx = dBy(1)
    Bzx = dBz(1)
    Bzy = dBz(2)

    ! Viscous term from hydrodynamics
    Fv(1) = 0.d0
    Fv(2) = mu*(2.d0*ux+lambda*(ux+vy))
    Fv(3) = mu*(vx+uy)
    Fv(4) = mu*wx
    Fv(5) = u*Fv(2)+v*Fv(3)+w*Fv(4)+mu*gam*ex/prandt

    Gv(1) = 0.d0
    Gv(2) = mu*(vx+uy)
    Gv(3) = mu*(2.d0*vy+lambda*(ux+vy))
    Gv(4) = mu*wy
    Gv(5) = Gv(2)*u+Gv(3)*v+Gv(4)*w+mu*gam*ey/prandt

    ! Resistive term from magnetic

    Jx = Bzy   - 0.0d0
    Jy = 0.0d0 - Bzx
    Jz = Byx   - Bxy

    Fv(6) = 0.0d0
    Fv(7) = eta0*Jz
    Fv(8) = -eta0*Jy
    Fv(5) = Fv(5) + Fv(7)*By + Fv(8)*Bz

    Gv(6) = -eta0*Jz
    Gv(7) = 0.0d0
    Gv(8) = eta0*Jx
    Gv(5) = Gv(5) + Gv(6)*Bx + Gv(8)*Bz

    Fv(9) = 0.d0
    Gv(9) = 0.d0

    END SUBROUTINE getVfluxvectors

    SUBROUTINE getVfluxvectors_AV(Qv,nablaQ,Fv,Gv,fam,ifp,jfp,ic)
    use setup2d, only: numv,muAVfi,muAVfj,Xs,Xf,prandt,gam,lambda

    double precision :: Qv(numv),nablaQ(numv,2),Fv(numv),Gv(numv)
    integer,intent(in) :: ifp,jfp,ic,fam
    double precision :: epsilon_loc(numv),xsi,eta,mu_art,eta_art
    double precision :: u, v, w, NORM_U, Bx, By, Bz, NORM_B, inte
    double precision :: rho, rhou, rhov, rhow, rhoE
    double precision :: ux, vx, uy, vy, wx, wy, ex, ey, rhox, rhoy, Bxy, Byx, Bzy, Bzx
    double precision :: Jx, Jy, Jz
    double precision :: du(2),dv(2),dw(2),drho(2),dBx(2),dBy(2),dBz(2),de(2),dKE(2),dpre_B(2)

    if (fam==1) then
        xsi = Xf(ifp)
        eta = Xs(jfp)
    else
        xsi = Xs(ifp)
        eta = Xf(jfp)
    end if

    if (fam==1) then
        epsilon_loc(1:numv) = muAVfi(1:numv,1,ic) * (1.d0-xsi) + &
        muAVfi(1:numv,2,ic) * xsi
    else
        epsilon_loc(1:numv) = muAVfj(1:numv,1,ic) * (1.d0-eta) + &
        muAVfj(1:numv,2,ic) * eta
    end if

    mu_art = epsilon_loc(1)
    eta_art = 0.d0

    rho  = Qv(1)
    rhou = Qv(2)
    rhov = Qv(3)
    rhow = Qv(4)
    rhoE = Qv(5)
    Bx   = Qv(6)
    By   = Qv(7)
    Bz   = Qv(8)

    u = rhou/rho
    v = rhov/rho
    w = rhow/rho

    NORM_U = u**2  + v**2  + w**2
    NORM_B = Bx**2 + By**2 + Bz**2

    inte = (rhoE - 0.5d0*NORM_U*rho - 0.5d0*NORM_B)/rho

    drho(:) =  nablaQ(1,:)
    du(:)   = (nablaQ(2,:)-drho(:)*u)/rho
    dv(:)   = (nablaQ(3,:)-drho(:)*v)/rho
    dw(:)   = (nablaQ(4,:)-drho(:)*w)/rho
    dBx(:)  =  nablaQ(6,:)
    dBy(:)  =  nablaQ(7,:)
    dBz(:)  =  nablaQ(8,:)

    dKE(:)    = 0.5d0*NORM_U*drho(:) + rho*(u*du(:)+v*dv(:)+w*dw(:))
    dpre_B(:) = Bx*dBx(:) + By*dBy(:) + Bz*dBz(:)

    de(:)  = (nablaQ(5,:) - dKE(:) - dpre_B(:) - drho(:)*inte)/rho

    rhox = drho(1)
    rhoy = drho(2)

    ux = du(1)
    uy = du(2)
    vx = dv(1)
    vy = dv(2)
    wx = dw(1)
    wy = dw(2)
    ex = de(1)
    ey = de(2)

    Bxy = dBx(2)
    Byx = dBy(1)
    Bzx = dBz(1)
    Bzy = dBz(2)

    ! Viscous term from hydrodynamics
    Fv(1) = 0.d0
    Fv(2) = mu_art*(2.d0*ux+lambda*(ux+vy))
    Fv(3) = mu_art*(vx+uy)
    Fv(4) = mu_art*wx
    Fv(5) = u*Fv(2)+v*Fv(3)+w*Fv(4)+mu_art*gam*ex/prandt

    Gv(1) = 0.d0
    Gv(2) = mu_art*(vx+uy)
    Gv(3) = mu_art*(2.d0*vy+lambda*(ux+vy))
    Gv(4) = mu_art*wy
    Gv(5) = Gv(2)*u+Gv(3)*v+Gv(4)*w+mu_art*gam*ey/prandt

    ! Resistive term from magnetic
    Jx = Bzy   - 0.0d0
    Jy = 0.0d0 - Bzx
    Jz = Byx   - Bxy

    Fv(6) = 0.0d0
    Fv(7) = eta_art*Jz
    Fv(8) = -eta_art*Jy
    Fv(5) = Fv(5) + Fv(7)*By + Fv(8)*Bz

    Gv(6) = -eta_art*Jz
    Gv(7) = 0.0d0
    Gv(8) = eta_art*Jx
    Gv(5) = Gv(5) + Gv(6)*Bx + Gv(8)*Bz

    Fv(numv) = 0.d0
    Gv(numv) = 0.d0

    END SUBROUTINE getVfluxvectors_AV