!----------------------------------------------------------------------------------------------------------------------------------+
!                                                        M O D L I N A L G                                                         |
!                                                                                D. Everhart |
!                                                                                02 APR 2019 |
!----------------------------------------------------------------------------------------------------------------------------------+
! The MIT License (MIT)
!
! Copyright (c) 2019 Daniel Everhart
!
! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files
! (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify,
! merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
! OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR
! IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!----------------------------------------------------------------------------------------------------------------------------------+
! These subroutines have evolved significantly over the years.  They began as a undergraduate classroom assignment, and evolved to
! what they are now.  When writing code for numerical analysis, I inevitability have the need to do some matrix operations and most
! of the time, this includes matrix inversion.  While this began as FORTRAN77, it has been migrated to the F90 standard. This
! should allow for the more modern construction and operator overrides for matrix math.
!----------------------------------------------------------------------------------------------------------------------------------+
! AE 227 FALL 1994 - Wichita State University
!   MGAUSJ - Gauss-Jordan elimination
! AE 527 FALL 1996 - Wichita State University
!   MGAUSB - Gauss elimination with back substitution (more efficient)
! 2004 - PRESENT - Abstraction of procedures and cleanup.
! MAR 2016 - Cleanup and preparation of messages for use by others.
! APR 2019 - Conversion to F90 (F95 standard uses SIZE intrinsic).
!----------------------------------------------------------------------------------------------------------------------------------+
MODULE MODLINALG
IMPLICIT NONE
PRIVATE
!----------------------------------------------------------------------------------------------------------------------------------+
PUBLIC :: MATRIX_PRINT,TEST_MODLINALG,MATRIX_RANDOMIZE
!----------------------------------------------------------------------------------------------------------------------------------+
                                                            CONTAINS
!----------------------------------------------------------------------------------------------------------------------------------+
SUBROUTINE MATRIX_PRINT(MATRIX)
  IMPLICIT NONE
  REAL(KIND=8),INTENT(IN),DIMENSION(:,:) :: MATRIX
  INTEGER(KIND=4)                        :: I, J, COLS
  CHARACTER(LEN=9)                       :: F
  COLS = SIZE(MATRIX,2)
  WRITE(F,'(A1I2A6)') '(', COLS, 'F10.4)'
  DO I = 1, SIZE(MATRIX,1)
    WRITE(6,F) (MATRIX(I,J), J=1, COLS)
  END DO
END SUBROUTINE MATRIX_PRINT
!----------------------------------------------------------------------------------------------------------------------------------+
SUBROUTINE MATRIX_RANDOMIZE(MATRIX,SEED)
  IMPLICIT NONE
  REAL(KIND=8),INTENT(INOUT),DIMENSION(:,:) :: MATRIX ! Matrix to be initialized.
  INTEGER(KIND=4),INTENT(IN),OPTIONAL       :: SEED   ! Optional seed for random number generator.
  INTEGER(KIND=4)                           :: I,J    ! Indicies for random number.
  IF (PRESENT(SEED)) CALL SRAND(SEED)
  DO I = 1,SIZE(MATRIX,1)
    DO J = 1,SIZE(MATRIX,2)
      MATRIX(I,J) = DBLE(RAND())
    END DO
  END DO
END SUBROUTINE MATRIX_RANDOMIZE
!----------------------------------------------------------------------------------------------------------------------------------+
SUBROUTINE MATRIX_IDENTITY(MATRIX)
  IMPLICIT NONE
  REAL(KIND=8),INTENT(INOUT),DIMENSION(:,:) :: MATRIX ! Matrix to be initialized.
  INTEGER(KIND=4)                           :: I      ! Index for random number.
  MATRIX = 0D0
  DO I = 1,MIN(SIZE(MATRIX,1),SIZE(MATRIX,2))
    MATRIX(I,I) = 1D0
  END DO
END SUBROUTINE MATRIX_IDENTITY
!----------------------------------------------------------------------------------------------------------------------------------+
SUBROUTINE MATRIX_MULTIPLY(A,B,P)
!----------------------------------------------------------------------------------------------------------------------------------+
! Product of [A]*[B] is placed in P.
!----------------------------------------------------------------------------------------------------------------------------------+
  IMPLICIT NONE
  REAL(KIND=8),INTENT(IN),DIMENSION(:,:)    :: A      ! Matrix A
  REAL(KIND=8),INTENT(IN),DIMENSION(:,:)    :: B      ! Matrix B
  REAL(KIND=8),INTENT(INOUT),DIMENSION(:,:) :: P      ! Matrix P (product: [P] = [A] * [B])
  INTEGER(KIND=4)                           :: AROWS  ! Rows of A
  INTEGER(KIND=4)                           :: ACOLS  ! Cols of A (Must match BROWS)
  INTEGER(KIND=4)                           :: BROWS  ! Rows of B (Must match ACOLS)
  INTEGER(KIND=4)                           :: BCOLS  ! Cols of B
  INTEGER(KIND=4)                           :: PROWS  ! Rows of P (Must be .GE. AROWS)
  INTEGER(KIND=4)                           :: PCOLS  ! Cols of P (Must be .GE. BCOLS)
  INTEGER(KIND=4)                           :: I,J,K  ! Counter indicies
  REAL(KIND=8)                              :: SM     ! Accumulator for matrix multiplicaiton.
!----------------------------------------------------------------------------------------------------------------------------------+
!
!                                   [A]     *         [B]         =         [P]
!
!                               | A11 A12 |   | B11 B12 B13 B14 |   | P11 P12 P13 P14 |
!                               | A21 A22 | * | B21 B22 B23 B12 | = | P21 P22 P23 P24 |
!                               | A31 A32 |                         | P31 P32 P33 P34 |
!
!
!                                               <-------- K -------->
!
!                                         P11 = A11 * B11 + A12 * B21   ^   ^
!                                         P21 = A21 * B11 + A22 * B21   I   |
!                                         P31 = A31 * B11 + A32 * B21   v   |
!                                                                           |
!                                         P12 = A11 * B12 + A12 * B22   ^   |
!                                         P22 = A21 * B12 + A22 * B22   I   |
!                                         P32 = A31 * B12 + A32 * B22   v
!                                                                           J
!                                         P13 = A11 * B13 + A12 * B23   ^
!                                         P23 = A21 * B13 + A22 * B23   I   |
!                                         P33 = A31 * B13 + A32 * B23   v   |
!                                                                           |
!                                         P14 = A11 * B14 + A12 * B24   ^   |
!                                         P24 = A21 * B14 + A22 * B24   I   |
!                                         P34 = A31 * B14 + A32 * B24   v   v
!
!----------------------------------------------------------------------------------------------------------------------------------+
  AROWS = SIZE(A,1)
  ACOLS = SIZE(A,2)
  BROWS = SIZE(B,1)
  BCOLS = SIZE(B,2)
  PROWS = SIZE(B,1)
  PCOLS = SIZE(B,2)
!----------------------------------------------------------------------------------------------------------------------------------+
  IF (ACOLS.NE.BROWS) THEN
    WRITE(0,910) ACOLS, BROWS
    STOP
  END IF
  IF (PROWS.LT.AROWS) THEN
    WRITE(0,920) PROWS, AROWS
    STOP
  END IF
  IF (PCOLS.LT.BCOLS) THEN
    WRITE(0,930) PCOLS, BCOLS
    STOP
  END IF
!----------------------------------------------------------------------------------------------------------------------------------+
  DO I = 1, PROWS
    DO J = 1, PCOLS
      SM = 0D0
      DO K = 1, ACOLS
        SM = SM + A(I,K) * B(K,J)
      END DO
      P(I,J) = SM
    END DO
  END DO
!----------------------------------------------------------------------------------------------------------------------------------+
 910 FORMAT('*** FATAL ERRROR: MATRIX_MULTIPLY: MATRIX A COLUMNS MUST MATCH MATRIX B ROWS:',/,18X,I8, ' .NE. ', I8)
 920 FORMAT('*** FATAL ERRROR: MATRIX_MULTIPLY: MATRIX P ROWS MUST AT LEAST EQUAL MATRIX A ROWS:',/,18X,I8, ' .LT. ', I8)
 930 FORMAT('*** FATAL ERRROR: MATRIX_MULTIPLY: MATRIX P COLUMNS MUST AT LEAST EQUAL MATRIX B COLUMNS:',/,18X,I8, ' .LT. ', I8)
END SUBROUTINE MATRIX_MULTIPLY
!----------------------------------------------------------------------------------------------------------------------------------+
SUBROUTINE PARTIAL_PIVOT(MATRIX,ROW)
!----------------------------------------------------------------------------------------------------------------------------------+
  IMPLICIT NONE
  REAL(KIND=8),INTENT(INOUT),DIMENSION(:,:) :: MATRIX
  INTEGER(KIND=4),INTENT(IN)                :: ROW
  INTEGER(KIND=4)                           :: J, K
  REAL(KIND=8),PARAMETER                    :: TOL = 1D-12
  REAL(KIND=8)                              :: TMP
!----------------------------------------------------------------------------------------------------------------------------------+
  IF (ABS(MATRIX(ROW,ROW)).LE.TOL) THEN
     DO J = ROW+1, SIZE(MATRIX,1)
       IF (ABS(MATRIX(J,ROW)).GE.TOL) EXIT
     END DO
     DO K = ROW, SIZE(MATRIX,2)
       TMP = MATRIX(ROW,K)
       MATRIX(ROW,K) = MATRIX(J,K)
       MATRIX(J,K) = TMP
     END DO
  END IF
END SUBROUTINE PARTIAL_PIVOT
!----------------------------------------------------------------------------------------------------------------------------------+
SUBROUTINE MODLINALG_GAUSS_ELIMINATE_ROW(MATRIX,ROW,COL,SCOL)
!----------------------------------------------------------------------------------------------------------------------------------+
! Performs Gauss elimination on a particular row.
!----------------------------------------------------------------------------------------------------------------------------------+
  IMPLICIT NONE
  REAL(KIND=8),INTENT(INOUT),DIMENSION(:,:) :: MATRIX      ! Matrix on which this operation is performed.
  INTEGER(KIND=4),INTENT(IN)                :: ROW         ! Matrix row on which to perform elimination
  INTEGER(KIND=4),INTENT(IN)                :: COL         ! Associated column to be zeroed for elimination
  INTEGER(KIND=4),INTENT(IN)                :: SCOL        ! Column to begin elimination
  REAL(KIND=8),PARAMETER                    :: TOL = 1D-12 ! Values who's magnitude are less that TOL are set to 0D0
  REAL(KIND=8)                              :: RATIO       ! Ratio used to scale row to be subtracted from rows being eliminated.
  INTEGER(KIND=4)                           :: I,J         ! Counter indicies.
!----------------------------------------------------------------------------------------------------------------------------------+
! Performs Gauss elimination on a particular row.  This procedure is called multiple times to eliminate a particular column.
! Consider the following matrix:
!
!                                               | A11 A12 A13 A14 A15 A16 A17 |
!                                               | 0.0 A22 A23 A24 A25 A26 A27 |
!                                               | 0.0 A32 A33 A34 A35 A36 A37 |
!                                               | 0.0 A42 A43 A44 A45 A46 A47 |
!                                               | 0.0 A52 A53 A54 A55 A56 A57 |
!
! Row 3, column 2 is the next to be zeroed.  This is done by  subtracting a scaled row 2 from row 3.  Scale factor RATIO is
! calculated by:
!
!                                                      RATIO = A32 / A22
!
! This ratio is chosen so that the result at row 3, column 2 will calculate to zero.
!
!                                                A32 = A32 - A22 * A32 / A22  (Results in 0.0)
!                                                A33 = A33 - A23 * A32 / A22
!                                                A34 = A34 - A24 * A32 / A22
!                                                A35 = A35 - A25 * A32 / A22
!                                                A36 = A36 - A26 * A32 / A22
!                                                A37 = A37 - A27 * A32 / A22
!
! The resulting state of the matrix after this procedure is:
!
!                                               | A11 A12 A13 A14 A15 A16 A17 |
!                                               | 0.0 A22 A23 A24 A25 A26 A27 |
!                                               | 0.0 0.0 A33 A34 A35 A36 A37 |
!                                               | 0.0 A42 A43 A44 A45 A46 A47 |
!                                               | 0.0 A52 A53 A54 A55 A56 A57 |
!
! Note:  This procedure does not require that ROW .GT. COL.  The result is that in the above example, the same operation could be
! performed on row 1 to zero out A12.  This is useful if the elimination is Gauss-Jordan where all elements not on the diagonal
! are zeroed out.
!
! Additionally, this procedure is called with a starting column. To save operations, the start column may be set to COL+1 when
! calling and nothing will be done to the elements to the left of COL.  This is useful when reducing the matrix to a upper triangle
! matrix.
!
!----------------------------------------------------------------------------------------------------------------------------------+
  IF (ABS(MATRIX(ROW,COL)).GE.TOL) THEN
    RATIO = MATRIX(ROW,COL) / MATRIX(COL,COL)
    DO I = SCOL, SIZE(MATRIX,2)
      IF (I.EQ.COL) THEN
        MATRIX(ROW,I) = 0D0 ! By definition this location must be zero.  Set the value to zero instead of doing calculation.
      ELSE
        MATRIX(ROW,I) = MATRIX(ROW,I) - RATIO * MATRIX(COL,I)
      ENDIF
    END DO
  ELSE
    MATRIX(ROW,COL) = 0D0
  END IF
END SUBROUTINE MODLINALG_GAUSS_ELIMINATE_ROW
!----------------------------------------------------------------------------------------------------------------------------------+
SUBROUTINE BACK_SUBSTITUTION(MATRIX)
!----------------------------------------------------------------------------------------------------------------------------------+
! Performs on a matrix representing a system of equations.
!----------------------------------------------------------------------------------------------------------------------------------+
  IMPLICIT NONE
  REAL(KIND=8),INTENT(INOUT),DIMENSION(:,:) :: MATRIX              ! Matrix system on which backwards substitution is performed.
  INTEGER(KIND=4)                           :: I,J,K,ROWS,COLS     ! Counters and indicies
  REAL(KIND=8)                              :: SM                  ! Accumulator variable.
!----------------------------------------------------------------------------------------------------------------------------------+
! Consider the reduced system.
!
!                                              | A11 A12 A13 A14 A15 B16 B17 |
!                                              | JNK A22 A23 A24 A25 B26 B27 |
!                                              | JNK JNK A33 A34 A35 B36 B37 |
!                                              | JNK JNK JNK A44 A45 B46 B47 |
!                                              | JNK JNK JNK JNK A55 B56 B57 |
!
! JNK values are assumed to be 0.0.  Recall that this is a set of equations for each B column vector:
!
!                                    A11*X16 + A12*X26 + A13*X36 + A14*X46 + A15*X56 = B16
!                                              A22*X26 + A23*X36 + A24*X46 + A25*X56 = B26
!                                                        A33*X36 + A34*X46 + A35*X56 = B36
!                                                                  A44*X46 + A45*X56 = B46
!                                                                            A55*X56 = B56
!
!                                    A11*X17 + A12*X27 + A13*X37 + A14*X47 + A15*X57 = B17
!                                              A22*X27 + A23*X37 + A24*X47 + A25*X57 = B27
!                                                        A33*X37 + A34*X47 + A35*X57 = B37
!                                                                  A44*X47 + A45*X57 = B47
!                                                                            A55*X57 = B57
!
! These equations may be solved starting from the bottom:
!
!                                                        <------------- K --------------->
!
!                                |  |     X56 = (B56                                        ) / A55
!                                |  |     X46 = (B46 - A45*X56                              ) / A44
!                                |  J     X36 = (B36 - A34*X46 - A35*X56                    ) / A33
!                                |  |     X26 = (B26 - A23*X36 - A24*X46 - A25*X56          ) / A22
!                                |  v     X16 = (B16 - A12*X26 - A13*X36 - A14*X46 - A15*X56) / A11
!                                I
!                                |  |     X57 = (B57                                        ) / A55
!                                |  |     X47 = (B47 - A45*X57                              ) / A44
!                                |  J     X37 = (B37 - A34*X47 - A35*X57                    ) / A33
!                                |  |     X27 = (B27 - A23*X37 - A24*X47 - A25*X57          ) / A22
!                                v  v     X17 = (B17 - A12*X27 - A13*X37 - A14*X47 - A15*X57) / A11
!
! The resulting aray has the solution vectors in place of the B vectors.
!
!                                              | A11 A12 A13 A14 A15 X16 X17 |
!                                              | JNK A22 A23 A24 A25 X26 X27 |
!                                              | JNK JNK A33 A34 A35 X36 X37 |
!                                              | JNK JNK JNK A44 A45 X46 X47 |
!                                              | JNK JNK JNK JNK A55 X56 X57 |
!
!----------------------------------------------------------------------------------------------------------------------------------+
  ROWS = SIZE(MATRIX,1)
  COLS = SIZE(MATRIX,2)
!----------------------------------------------------------------------------------------------------------------------------------+
  DO I = ROWS+1, COLS
    DO J = ROWS, 1, -1
      SM = 0D0
      DO K = ROWS, J+1, -1
        SM = SM + MATRIX(J,K) * MATRIX(K,I)
      END DO
      MATRIX(J,I) = (MATRIX(J,I) - SM) / MATRIX(J,J)
    END DO
  END DO
!----------------------------------------------------------------------------------------------------------------------------------+
END SUBROUTINE BACK_SUBSTITUTION
!----------------------------------------------------------------------------------------------------------------------------------+
SUBROUTINE GAUSS_ELIMINATION(MATRIX,JORDAN)
!----------------------------------------------------------------------------------------------------------------------------------+
! Performs Gauss elimination on the matrix.
!----------------------------------------------------------------------------------------------------------------------------------+
  IMPLICIT NONE
  REAL(KIND=8),INTENT(INOUT),DIMENSION(:,:) :: MATRIX        ! Matrix on which Gauss elimination is performed
  LOGICAL,INTENT(IN)                        :: JORDAN        ! .TRUE. to request Gauss-Jordan elimination
  INTEGER(KIND=4)                           :: I,J,ROWS,COLS ! Index and counter variables.
  REAL(KIND=8)                              :: TMP           ! Temporary storage value
!----------------------------------------------------------------------------------------------------------------------------------+
! Consider the matrix below representing the system of equations:
!
!                                                          [A]*[X] = B
!
!                                                | A11 A12 A13 A14 A15 B16 B17 |
!                                                | A21 A22 A23 A24 A25 B26 B27 |
!                                                | A31 A32 A33 A34 A35 B36 B37 |
!                                                | A41 A42 A43 A44 A45 B46 B47 |
!                                                | A51 A52 A53 A54 A55 B56 B57 |
!
!
! With the JORDAN flag set to .TRUE., this procedure performs Gauss-Jordan elimination with repeated calls to
! MODLINALG_ELIMINATE_COLUMN to zero out non-diagonal elements, and normalize to 1.0 resulting in the following:
!
!
!                                                | 1.0 0.0 0.0 0.0 0.0 X16 X17 |
!                                                | 0.0 1.0 0.0 0.0 0.0 X26 X27 |
!                                                | 0.0 0.0 1.0 0.0 0.0 X36 X37 |
!                                                | 0.0 0.0 0.0 1.0 0.0 X46 X47 |
!                                                | 0.0 0.0 0.0 0.0 1.0 X56 X57 |
!
! X values show where the solution matrix is stored.
!
! Without the JORDAN flag set, this procedure performs Gauss elimination with repeated calls to GAUSS_ELIMINATE_COLUMN
! leaveing an upper triangle matrix.  Junk values are left in place below the diagonal to save operations.  This results in the
! following:
!
!                                               | A11 A12 A13 A14 A15 B16 B17 |
!                                               | JNK A22 A23 A24 A25 B26 B27 |
!                                               | JNK JNK A33 A34 A35 B36 B37 |
!                                               | JNK JNK JNK A44 A45 B46 B47 |
!                                               | JNK JNK JNK JNK A55 B56 B57 |
!
!----------------------------------------------------------------------------------------------------------------------------------+
  ROWS = SIZE(MATRIX,1)
  COLS = SIZE(MATRIX,2)
  IF (ROWS.GT.COLS) THEN
    WRITE(0,910), ROWS, COLS
    STOP
  END IF
!----------------------------------------------------------------------------------------------------------------------------------+
  DO I = 1, ROWS
    CALL PARTIAL_PIVOT(MATRIX,I)
    IF (JORDAN) THEN
      CALL GAUSS_ELIMINATE_COLUMN(MATRIX,I,1)
      TMP = MATRIX(I,I)
      DO J = I, COLS                          ! This loop results in a 1.0 on the diagonal.
         MATRIX(I,J) = MATRIX(I,J) / TMP
      END DO
    ELSE
      CALL GAUSS_ELIMINATE_COLUMN(MATRIX,I,I+1)
    END IF
  END DO
910 FORMAT('*** FATAL ERRROR: GAUSS_ELIMINATION: MATRIX ROWS LARGER THAN COLUMNS',/,18X,I8, '   .GT.   ',I8)
!----------------------------------------------------------------------------------------------------------------------------------+
END SUBROUTINE GAUSS_ELIMINATION
!----------------------------------------------------------------------------------------------------------------------------------+
SUBROUTINE GAUSS_ELIMINATE_COLUMN(MATRIX,COL,SCOL)
!----------------------------------------------------------------------------------------------------------------------------------+
! Performs gauss elimination on a particular column.
!----------------------------------------------------------------------------------------------------------------------------------+
  IMPLICIT NONE
  REAL(KIND=8),INTENT(INOUT),DIMENSION(:,:) :: MATRIX  ! Matrix on which the column is zeroed.
  INTEGER(KIND=4),INTENT(IN)                :: COL     ! Associated column to be zeroed for elimination.
  INTEGER(KIND=4),INTENT(IN)                :: SCOL    ! Column to begin elimination
  INTEGER(KIND=4)                           :: J
!----------------------------------------------------------------------------------------------------------------------------------+
! Performs Gauss elimination on a particular column.  This procedure is called multiple times to columns for Gauss-Jordan
! elimination.  Consider the following matrix:
!
!                                              | A11 A12 A13 A14 A15 A16 A17 |
!                                              | JNK A22 A23 A24 A25 A26 A27 |
!                                              | JNK A32 A33 A34 A35 A36 A37 |
!                                              | JNK A42 A43 A44 A45 A46 A47 |
!                                              | JNK A52 A53 A54 A55 A56 A57 |
!
!
! Column 2 is the next to be 'zeroed'.  This is done by repeated calls  to MODLINALG_GAUSS_ELIMINATE_ROW with SCOL=COL+1.  The
! result is the following:
!
!                                              | A11 A12 A13 A14 A15 A16 A17 |
!                                              | JNK A22 A23 A24 A25 A26 A27 |
!                                              | JNK JNK A33 A34 A35 A36 A37 |
!                                              | JNK JNK A43 A44 A45 A46 A47 |
!                                              | JNK JNK A53 A54 A55 A56 A57 |
!
!   Note:  This procedure calls MODLINALG_GAUSS_ELIMINATE_ROW for rows below the diagonal at the particular column in the matrix.
!
!   Repeated calls, result in a matrix with junk (JNK) values below the diagonal and actuals values on and above the diagonal.  The
!   junk values are left in place to save operations for large systems.
!
!----------------------------------------------------------------------------------------------------------------------------------+
  DO J = SCOL, SIZE(MATRIX,1)
    IF (J.NE.COL) CALL MODLINALG_GAUSS_ELIMINATE_ROW(MATRIX,J,COL,SCOL)
  END DO
END SUBROUTINE GAUSS_ELIMINATE_COLUMN
!----------------------------------------------------------------------------------------------------------------------------------+
SUBROUTINE TEST_MODLINALG
  INTEGER(KIND=4),PARAMETER :: ROWS = 3
  INTEGER(KIND=4),PARAMETER :: COLS = 6
  REAL(KIND=8),DIMENSION(ROWS,COLS) :: D  = 0D0
  REAL(KIND=8),DIMENSION(ROWS,ROWS) :: D1
  REAL(KIND=8),DIMENSION(ROWS,ROWS) :: D2
  REAL(KIND=8),DIMENSION(ROWS,ROWS) :: E  = 0D0
  EQUIVALENCE (D1(1,1), D(1,1)), (D2(1,1), D(1,ROWS+1))
!----------------------------------------------------------------------------------------------------------------------------------+
  WRITE(6,910)
  WRITE(6,920)
  WRITE(6,910)
  WRITE(6,900)
  WRITE(6,980)'MATRIX D IS COMPRISED OF D1 AND D2.'
  WRITE(6,980)'       [ D ] =  [ D1 | D2 ]'
  WRITE(6,980)'MATRIX E IS SQUARE DIMENSIONED THE SAME AS'
  WRITE(6,980)'            D1 AND D2'
  WRITE(6,900)
  WRITE(6,910)
!----------------------------------------------------------------------------------------------------------------------------------+
  WRITE(6,900)
  WRITE(6,980)'TESTING MATRIX_IDENTITY ON [D].'
  WRITE(6,900)
  CALL MATRIX_IDENTITY(D)
  CALL MATRIX_PRINT(D)
!----------------------------------------------------------------------------------------------------------------------------------+
  WRITE(6,900)
  WRITE(6,980)'TESTING MATRIX_IDENTITY ON [D2].'
  WRITE(6,900)
  CALL MATRIX_IDENTITY(D2)
  CALL MATRIX_PRINT(D)
!----------------------------------------------------------------------------------------------------------------------------------+
  WRITE(6,900)
  WRITE(6,980)'TESTING MATRIX_RANDOMIZE ON [D1].'
  WRITE(6,900)
  CALL MATRIX_RANDOMIZE(D1,0)
  CALL MATRIX_PRINT(D)
!----------------------------------------------------------------------------------------------------------------------------------+
  WRITE(6,900)
  WRITE(6,980)'ASSIGNING [D1] = [E] FOR LATER USE.'
  WRITE(6,900)
  E = D1
  CALL MATRIX_PRINT(E)
!----------------------------------------------------------------------------------------------------------------------------------+
  WRITE(6,900)
  WRITE(6,980)'RUNNING NEW GAUSS ELIMINATION ON [D]'
  WRITE(6,900)
  CALL MATRIX_IDENTITY(D2)
  CALL MATRIX_RANDOMIZE(D1,0)
  CALL GAUSS_ELIMINATION(D,.FALSE.)
  CALL BACK_SUBSTITUTION(D)
  CALL MATRIX_PRINT(D)
!----------------------------------------------------------------------------------------------------------------------------------+
  WRITE(6,900)
  WRITE(6,980)'RUNNING NEW GAUSS ELIMINATION WITH JORDAN=.TRUE. ON [D]'
  WRITE(6,900)
  CALL MATRIX_IDENTITY(D2)
  CALL MATRIX_RANDOMIZE(D1,0)
  CALL GAUSS_ELIMINATION(D,.TRUE.)
  CALL MATRIX_PRINT(D)
!----------------------------------------------------------------------------------------------------------------------------------+
  WRITE(6,900)
  WRITE(6,980)'RUNNING GAUSS ELIMINATION AND BACK SUBSTITUTION ON [D]'
  WRITE(6,900)
  CALL MATRIX_RANDOMIZE(D1,0)
  CALL MATRIX_IDENTITY(D2)
  CALL GAUSS_ELIMINATION(D,.FALSE.)
  CALL BACK_SUBSTITUTION(D)
  CALL MATRIX_PRINT(D)
!----------------------------------------------------------------------------------------------------------------------------------+
  WRITE(6,900)
  WRITE(6,980)'MULTIPLYING MATRIX BY INVERSE [D1] = [D2] * [E]'
  WRITE(6,900)
  CALL MATRIX_MULTIPLY(D2,E,D1)
  CALL MATRIX_PRINT(D1)
!----------------------------------------------------------------------------------------------------------------------------------+
900 FORMAT()
910 FORMAT('********************************************************************************')
920 FORMAT('******************************** LINALG UNIT TESTS *****************************')
980 FORMAT(15X,A)
END SUBROUTINE TEST_MODLINALG
!----------------------------------------------------------------------------------------------------------------------------------+
END MODULE MODLINALG
!----------------------------------------------------------------------------------------------------------------------------------+
PROGRAM LINAGLTEST
USE MODLINALG
  IMPLICIT NONE
  CALL TEST_MODLINALG
!  REAL(KIND=8),DIMENSION(3,3) :: A, B
!  REAL(KIND=8),DIMENSION(3,3) :: C
!
!  CALL MATRIX_RANDOMIZE(A)
!  CALL MATRIX_RANDOMIZE(B)
!
!  CALL MATRIX_PRINT(A)
!  WRITE(6,*)
!  CALL MATRIX_PRINT(B)
!  WRITE(6,*)
!  C = A + B
!  CALL MATRIX_PRINT(C)
!  WRITE(6,*)
!  C = A * B
!  CALL MATRIX_PRINT(C)
END PROGRAM LINAGLTEST


c===========================================================================
c
c   This file is part of TISEAN
c
c   Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber
c
c   TISEAN is free software; you can redistribute it and/or modify
c   it under the terms of the GNU General Public License as published by
c   the Free Software Foundation; either version 2 of the License, or
c   (at your option) any later version.
c
c   TISEAN is distributed in the hope that it will be useful,
c   but WITHOUT ANY WARRANTY; without even the implied warranty of
c   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c   GNU General Public License for more details.
c
c   You should have received a copy of the GNU General Public License
c   along with TISEAN; if not, write to the Free Software
c   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
c
c===========================================================================
c   henon.f
c   iterate Henon map
c   author Thomas Schreiber (1998)
c===========================================================================
      double precision xo, yo, xn, yn, a, b
      character*72 fout
      data a/1.4/,b/0.3/,ntrans/10000/,xo/.68587/,yo/.65876/
      data iverb/1/

      call whatido("Henon map",iverb)
      nmax=imust('l')
      ntrans=ican('x',ntrans)
      a=fcan('A',real(a))
      b=fcan('B',real(b))
      xo=fcan('X',real(xo))
      yo=fcan('Y',real(yo))
      isout=igetout(fout,iverb)

      if(isout.eq.1) fout="henon.dat"
      call outfile(fout,iunit,iverb)
      n=-ntrans
 1    n=n+1
      xn=1.-a*xo**2+b*yo
      yn=xo
      xo=xn
      yo=yn
      if(n.lt.1) goto 1
      write(iunit,*) real(xn), real(yn)
      if(nmax.eq.0.or.n.lt.nmax) goto 1
      end

      subroutine usage()
c usage message

      call whatineed(
     .   "-l# [-A# -B# -X# -Y# -o outfile -x# -V# -h]")
      call popt("l","number of points x,y (l=0: infinite)")
      call popt("A","parameter a (1.4)")
      call popt("B","parameter b (0.3)")
      call popt("X","initial x")
      call popt("Y","initial y")
      call popt("x","number of transients discarded (10000)")
      call pout("henon.dat")
      call pall()
      stop
      end


module markovst_gth
  implicit none
  private
  public markovst_gth_dense
  public markovst_gth_csr
  public markovst_gth_csc
  public markovst_gth_coo

contains

  ! Description: stationary vector via GTH algorithm
  !        x * Q = 0, x*1 = 1
  !
  ! Q: CTMC kernel

  subroutine markovst_gth_base(n, A, lda, x, incx)
    integer, intent(in) :: n, lda, incx
    double precision, intent(inout) :: A(1:lda,1:n)
    double precision, intent(out) :: x(1:incx,1:n)

    integer :: i, j, l
    double precision :: tmp

    do l = n, 2, -1
       tmp = sum(A(l,1:(l-1)))
       do j = 1, l-1
          do i = 1, l-1
             if (i /= j) then
                A(i,j) = A(i,j) + A(l,j) * A(i,l) / tmp
             end if
          end do
       end do
       do i = l-1, 1, -1
          A(i,l) = A(i,l) / tmp
       end do
       do i = 1, l-1
          A(l,i) = 0.0d0
       end do
       A(l,l) = -1.0d0
    end do

    x(1,1) = 1.0d0
    do l = 2, n
       x(1,l) = sum(x(1,1:(l-1)) * A(1:(l-1),l))
    end do
    x(1,1:n) = x(1,1:n) / sum(x(1,1:n))
  end subroutine markovst_gth_base

  subroutine markovst_gth_dense(n, Q, ldq, x, incx)
    integer, intent(in) :: n, ldq, incx
    double precision, intent(in) :: Q(1:ldq,1:n)
    double precision, intent(out) :: x(1:incx,1:n)
    double precision :: A(1:n,1:n)

    A(1:n,1:n) = Q(1:n,1:n)
    call markovst_gth_base(n, A, n, x, incx)
  end subroutine markovst_gth_dense

  subroutine markovst_gth_csr(n, spQ, rowptr, colind, nnz, x, incx)
    use sparse
    integer, intent(in) :: n, nnz, incx
    integer, intent(in) :: rowptr(1:n+1), colind(1:nnz)
    double precision, intent(in) :: spQ(1:nnz)
    double precision, intent(out) :: x(1:incx,1:n)

    double precision :: A(1:n,1:n)

    call csr_to_dense(n, n, spQ, rowptr, colind, nnz, A, n)
    call markovst_gth_base(n, A, n, x, incx)
  end subroutine markovst_gth_csr

  subroutine markovst_gth_csc(n, spQ, colptr, rowind, nnz, x, incx)
    use sparse
    integer, intent(in) :: n, nnz, incx
    integer, intent(in) :: colptr(1:n+1), rowind(1:nnz)
    double precision, intent(in) :: spQ(1:nnz)
    double precision, intent(out) :: x(1:incx,1:n)

    double precision :: A(1:n,1:n)

    call csc_to_dense(n, n, spQ, colptr, rowind, nnz, A, n)
    call markovst_gth_base(n, A, n, x, incx)
  end subroutine markovst_gth_csc

  subroutine markovst_gth_coo(n, spQ, rowind, colind, nnz, x, incx)
    use sparse
    integer, intent(in) :: n, nnz, incx
    integer, intent(in) :: rowind(1:nnz), colind(1:nnz)
    double precision, intent(in) :: spQ(1:nnz)
    double precision, intent(out) :: x(1:incx,1:n)

    double precision :: A(1:n,1:n)

    call coo_to_dense(n, n, spQ, rowind, colind, nnz, A, n)
    call markovst_gth_base(n, A, n, x, incx)
  end subroutine markovst_gth_coo

end module markovst_gth


recursive function binarySearch_R (a, value) result (bsresult)
    real, intent(in) :: a(:), value
    integer          :: bsresult, mid

    mid = size(a)/2 + 1
    if (size(a) == 0) then
        bsresult = 0        ! not found
    else if (a(mid) > value) then
        bsresult= binarySearch_R(a(:mid-1), value)
    else if (a(mid) < value) then
        bsresult = binarySearch_R(a(mid+1:), value)
        if (bsresult /= 0) then
            bsresult = mid + bsresult
        end if
    else
        bsresult = mid      ! SUCCESS!!
    end if
end function binarySearch_R


	!>@author
	!>Paul Connolly, The University of Manchester
	!>@brief
	!>module variables for integration using vode
    module ode_vars
        use numerics_type
        implicit none
        logical(lgt), save :: initialise_ode=.true.
        integer(i4b) :: neq,itol=2,itask=1,istate=1,iopt=1,lrw,liw,mf=22,iout
        real(wp), dimension(:), allocatable :: rpar
        integer(i4b), dimension(:), allocatable :: ipar

        contains

        subroutine jac (neq, t, y, ml, mu, pd, nrpd, rpar, ipar)
            use numerics_type
            implicit none
            real(wp) :: t
            real(wp), dimension(neq) :: y
            real(wp), dimension(nrpd, neq) :: pd
            integer(i4b) :: neq, ml, mu, nrpd
            real(wp) :: rpar
            integer(i4b) :: ipar

        end subroutine jac
    end module ode_vars

	!>@author
	!>Paul Connolly, The University of Manchester
	!>@brief
	!>code to perform integration using vode
	!>@ref dvode
	!>param[inout] ystart: solution vector
	!>param[in] x1,x2,eps,h1,hmin
	!>param[in] fdash: function to calculate derivatives
	subroutine vode_integrate(ystart,x1,x2,eps,h1,hmin,fdash)
	    use numerics_type
	    use ode_vars
	    use numerics, only : dvode,xsetf
	    implicit none
	    real(wp), intent(in) :: x1,x2,eps,h1,hmin
        real(wp), intent(inout), dimension(:) :: ystart
        interface
            subroutine fdash(p,z,dzdp)
                use numerics_type
                implicit none
                real(wp), intent(in) :: p
                real(wp), dimension(:), intent(in) :: z
                real(wp), dimension(:), intent(out) :: dzdp
            end subroutine fdash
        end interface

	    real(wp) :: x
	    real(wp), dimension(size(ystart)) :: rtol,atol,y
	    real(wp), dimension(22+9*size(ystart)+2*size(ystart)**2) :: rwork
	    integer(i4b), dimension(30+size(ystart)) :: iwork

	    if(initialise_ode) then
	        neq=size(ystart)
            lrw=22+9*neq+2*neq**2
            liw=30+neq
            atol=1.e-10_wp
            rtol=eps
            x=x1
            y=ystart
            iwork=0
            rwork=0._wp
            call xsetf(0) ! do not print messages
            iwork(6)=100 ! max steps
            iwork(5)=5 ! order
            rwork(5)=h1 ! initial step
            rwork(7)=hmin ! minimum step
            rwork(14)=2._wp ! tolerance scale-factor
	    endif

	    if(x1.lt.x2) then
            do while (x .lt. x2)
                istate=1
            	!>@callgraph
            	!>@code call dvode(fex,neq,y,x,x2,itol,rtol,atol,itask,istate,iopt, &
                !>            rwork,lrw,iwork,liw,jac,mf,rpar,ipar)
                !>@endcode
                call dvode(fex,neq,y,x,x2,itol,rtol,atol,itask,istate,iopt, &
                            rwork,lrw,iwork,liw,jac,mf,rpar,ipar)
            enddo
        else
            do while (x .lt. x1)
                istate=1
                call dvode(fex,neq,y,x,x1,itol,rtol,atol,itask,istate,iopt, &
                            rwork,lrw,iwork,liw,jac,mf,rpar,ipar)
            enddo
        endif
        ystart=y

        contains
            subroutine fex(neq,tt,y,ydot,rpar,ipar)
                integer(i4b), intent(in) :: neq
                real(wp), intent(inout) :: tt
                real(wp), intent(in) :: rpar
                integer(i4b), intent(in) :: ipar
                real(wp), dimension(neq), intent(inout) :: y,ydot

                call fdash(tt,y,ydot)
            end subroutine fex

	end subroutine vode_integrate


subroutine print_error(stat, fname)
    Use MKL_DFTI
    implicit none
    integer, intent(in):: stat
    character(len=*), intent(in) :: fname
    if (stat /= 0) then
        print *,'***ERROR*** stat = ', stat, ' after ', fname
        print *, DftiErrorMessage(stat)
    endif
end subroutine

program test

    ! gfortran -O3 fftr8.f90 -I"${MKLROOT}/include" $MKLROOT/include/mkl_cdft.f90 -o fftr8 -L${MKLROOT}/lib/lp64 -lmkl -lgomp

    Use MKL_DFTI
    use omp_lib

    implicit none
    integer :: n, stat, i, n1
    character(len=32) :: nstr
    real(8), allocatable :: fs(:)
    real(8), allocatable :: res(:)
    real(8) :: dt, tic, toc

    type(dfti_descriptor), pointer :: handle
    complex*16, allocatable :: fbar(:)

    if (command_argument_count() < 1) then
        stop 'ERROR must supply array size as command line argument'
    endif
    call get_command_argument(1, nstr)
    read(nstr, *, iostat=stat) n
    n1 = n + 1

    allocate(fs(n), fbar(2*n1), res(n))
    do i = 1, n
        fs(i) = i
    enddo
    fbar = 0

    stat = DftiCreateDescriptor(handle, DFTI_DOUBLE, DFTI_COMPLEX, 1, 2*n1)
    call print_error(stat, 'DftiCreateDescriptor')

    stat = DftiCommitDescriptor(handle)
    call print_error(stat, 'DftiCommitDescriptor')

    tic = omp_get_wtime()
    ! load the array
    fbar(2:n1) = fs

    stat = dftiComputeForward(handle, fbar)
    call print_error(stat, 'dftiComputeForward')

    res = -aimag(fbar(2:n1))
    toc = omp_get_wtime()

    dt = toc - tic
    print *, 'fftr8 n = ', n, ' time = ', dt, ' secs res = ', sum(res)

    stat = dftiFreeDescriptor(handle)
    call print_error(stat, 'dftiFreeDescriptor')
end program test


*=======================================================================
*
* WCSLIB 4.24 - an implementation of the FITS WCS standard.
* Copyright (C) 1995-2014, Mark Calabretta
*
* This file is part of WCSLIB.
*
* WCSLIB is free software: you can redistribute it and/or modify it
* under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation, either version 3 of the License, or
* (at your option) any later version.
*
* WCSLIB is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
* FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
* License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with WCSLIB.  If not, see http://www.gnu.org/licenses.
*
* Direct correspondence concerning WCSLIB to mark@calabretta.id.au
*
* Author: Mark Calabretta, Australia Telescope National Facility, CSIRO.
* http://www.atnf.csiro.au/people/Mark.Calabretta
* $Id: ttab3.f,v 4.24 2014/09/18 15:25:02 mcalabre Exp $
*=======================================================================

      PROGRAM TTAB3
*-----------------------------------------------------------------------
*
* TTAB3 tests the -TAB routines using PGPLOT for graphical display.  It
* constructs a table that approximates Bonne's projection and uses it to
* draw a graticule.
*
*-----------------------------------------------------------------------

*     Set up the lookup table.
      INTEGER   K1, K2, M
      PARAMETER (M = 2, K1 = 271, K2 = 235)

      INTEGER   K(M), MAP(M)
      DOUBLE PRECISION CRVAL(M)
      DATA K     /K1, K2/
      DATA MAP   /0, 1/
      DATA CRVAL /135D0, 95D0/

      INTEGER   CI, I, IK, ILAT, ILNG, IM, J, STAT(K1,K2), STATUS
      REAL      XR(361), YR(361)
      DOUBLE PRECISION COORD(M,K1,K2), WORLD(M,361), X(K1), XY(M,361),
     :          Y(K2)

*     On some systems, such as Sun Sparc, the structs MUST be aligned
*     on a double precision boundary, done here using equivalences.
*     Failure to do this may result in mysterious "bus errors".
      INCLUDE 'prj.inc'
      INCLUDE 'tab.inc'
      INTEGER   PRJ(PRJLEN), TAB(TABLEN)
      DOUBLE PRECISION DUMMY1, DUMMY2
      EQUIVALENCE (PRJ,DUMMY1), (TAB,DUMMY2)
*-----------------------------------------------------------------------

      WRITE (*, 10)
 10   FORMAT ('Testing WCSLIB inverse coordinate lookup table ',
     :        'routines (ttab3.f)',/,
     :        '-----------------------------------------------',
     :        '------------------',/)

*     PGPLOT initialization.
      CALL PGBEG (0, '/xwindow', 1, 1)
      CALL PGVSTD ()
      CALL PGSCH (0.7)
      CALL PGWNAD (-135.0, 135.0, -95.0, 140.0)
      CALL PGBOX ('BC', 0.0, 0, 'BC', 0.0, 0)

      CALL PGSCR (0, 0.00, 0.00, 0.00)
      CALL PGSCR (1, 1.00, 1.00, 0.00)
      CALL PGSCR (2, 1.00, 1.00, 1.00)
      CALL PGSCR (3, 0.50, 0.50, 0.80)
      CALL PGSCR (4, 0.80, 0.50, 0.50)
      CALL PGSCR (5, 0.80, 0.80, 0.80)
      CALL PGSCR (6, 0.50, 0.50, 0.80)
      CALL PGSCR (7, 0.80, 0.50, 0.50)
      CALL PGSCR (8, 0.30, 0.50, 0.30)

*     Set up the lookup table.
      STATUS = TABPUT (TAB, TAB_FLAG, -1, 0, 0)
      STATUS = TABINI(M, K, TAB)
      IF (STATUS.NE.0) THEN
        WRITE (*, 20) STATUS
 20     FORMAT ('TABINI ERROR',I2,'.')
        GO TO 999
      END IF

      STATUS = TABPUT (TAB, TAB_M, M, 0, 0)
      DO 40 IM = 1, M
        STATUS = TABPUT (TAB, TAB_K,     K(IM),     IM, 0)
        STATUS = TABPUT (TAB, TAB_MAP,   MAP(IM),   IM, 0)
        STATUS = TABPUT (TAB, TAB_CRVAL, CRVAL(IM), IM, 0)

        DO 30 IK = 1, K(IM)
          STATUS = TABPUT (TAB, TAB_INDEX, DBLE(IK-1), IM, IK)
 30     CONTINUE
 40   CONTINUE

*     Set up the lookup table to approximate Bonne's projection.
      DO 50 I = 1, K1
        X(I) = 136 - I
 50   CONTINUE
      DO 60 J = 1, K2
        Y(J) = J - 96
 60   CONTINUE

      STATUS = PRJINI (PRJ)
      STATUS = PRJPTD (PRJ, PRJ_PV, 35D0, 1)

*     Disable bounds checking (or alternatively, simply ignore
*     out-of-bounds errors).  This is necessary to provide continuity
*     beyond the -180 and +180 meridians, noting that bonx2s() computes
*     out-of-bounds values so as to provide continuity.
      STATUS = PRJPTI (PRJ, PRJ_BOUNDS, 0, 0)

      STATUS = BONX2S (PRJ, K1, K2, 1, 2, X, Y, COORD(1,1,1),
     :                 COORD(2,1,1), STAT)

      IK = 1
      DO 80 J = 1, K2
        DO 70 I = 1, K1
          STATUS = TABPUT (TAB, TAB_COORD, COORD(1,I,J), IK, 0)
          STATUS = TABPUT (TAB, TAB_COORD, COORD(2,I,J), IK+1, 0)
          IK = IK + 2
 70     CONTINUE
 80   CONTINUE

*     Draw meridians.
      CI = 1
      DO 110 ILNG = -180, 180, 15
        CI = CI + 1
        IF (CI.GT.7) CI = 2
        IF (ILNG.NE.0) THEN
          CALL PGSCI (CI)
        ELSE
          CALL PGSCI (1)
        END IF

        J = 0
        DO 90 ILAT = -90, 90
          J = J + 1
          WORLD(1,J) = DBLE(ILNG)
          WORLD(2,J) = DBLE(ILAT)
 90     CONTINUE

*       A fudge to account for the singularity at the poles.
        WORLD(1,1)   = 0D0
        WORLD(1,181) = 0D0

        STATUS = TABS2X (TAB, 181, 2, WORLD, XY, STAT)

        IK = 0
        DO 100 J = 1, 181
          IF (STAT(J,1).NE.0) THEN
            IF (IK.GT.1) CALL PGLINE (K, XR, YR)
            IK = 0
            GO TO 100
          END IF

          IK = IK + 1
          XR(IK) = REAL(XY(1,J))
          YR(IK) = REAL(XY(2,J))
 100    CONTINUE

        CALL PGLINE (IK, XR, YR)
 110  CONTINUE

*     Draw parallels.
      CI = 1
      DO 140 ILAT = -75, 75, 15
        CI = CI + 1
        IF (CI.GT.7) CI = 2
        IF (ILAT.NE.0) THEN
          CALL PGSCI (CI)
        ELSE
          CALL PGSCI (1)
        END IF

        J = 0
        DO 120 ILNG = -180, 180
          J = J + 1
          WORLD(1,J) = DBLE(ILNG)
          WORLD(2,J) = DBLE(ILAT)
 120    CONTINUE

        STATUS = TABS2X (TAB, 361, 2, WORLD, XY, STAT)

        IK = 0
        DO 130 J = 1, 361
          IF (STAT(J,1).NE.0) THEN
            IF (IK.GT.1) CALL PGLINE (IK, XR, YR)
            IK = 0
            GO TO 130
          END IF

          IK = IK + 1
          XR(IK) = REAL(XY(1,J))
          YR(IK) = REAL(XY(2,J))
 130    CONTINUE

        CALL PGLINE (IK, XR, YR)
 140  CONTINUE

      CALL PGEND ()

 999  STATUS = TABFREE (TAB)

      END


!move_nodes.f90

!Algoritmo para deteccao de comunidades em rede, baseado no artigo:
!------------------------------------------------------------------
!Paper: Fast unfolding of communities in large networks
!Authors: Vincent D Blondel, Jean-Loup Guillaume, Renaud Lambiotte and Etienne Lefebvre
!doi:10.1088/1742-5468/2008/10/P10008
!------------------------------------------------------------------
!Este programa eh composto de tres partes: louvain.f90; move_nodes.f90; aggregate.f90

!A variavel ki(i) nesta subrotina eh diferente da usada em louvain.f90
      !variaveis comuns somente a move_nodes.f90 e suas funcoes
      module variaveis_move
      integer*8, allocatable ::  ki(:)
      end module

      subroutine move_nodes()
      use variaveis
      use variaveis_move

      real*8 gain_q, q, best_q, best_c
      integer*8 kc, e_ic
      integer*8 i, j, move, n

!-------grau dos nos (ki) do grafo G1---
      allocate (ki(numb_comun))
      do i=1,numb_comun
            ki(i) = 0
         do j =1,numb_comun
            ki(i) = ki(i)+G1(i,j)
         end do
      end do
!---------------------------------------

      deallocate(C1, C2)
      allocate (C1(numb_comun),C2(numb_comun))
      do i=1,numb_comun !Aloca o no i na comunidade Ci
         C2(i)=i
         C1(i)=C2(i)
      end do

      move = numb_comun
      do while (move.ne.0)!mova enquanto houver ganho de modularidade
      move = numb_comun
        do i=1,numb_comun
!          i= int(rand(0)*(numb_comun+1-1))+1
           best_q = -1000
           best_c = C2(i)
           do j=1,numb_comun
             if(G1(i,j).gt.0) then
             gain_q = (1.d0/m)*(e_ic(C2(j),i)- &
                      (ki(i)*kc(C2(j),i)/(2.d0*m)))
               if(best_q.lt.gain_q) then
                  best_q = gain_q
                  best_c = C2(j)
               end if
              end if
           end do
           C2(i) = best_c
           if(C1(i).eq.C2(i)) then
             move = move - 1
           end if
           C1(i) = C2(i)
        end do
      end do

      deallocate (ki)
      end subroutine move_nodes

!-------grau da comunidade (kc)--------------
         function kc(cmt,node)
         use variaveis
         use variaveis_move
         integer*8 i, kc,node, cmt
         kc = 0
         do i = 1,numb_comun
              if (C2(i).eq.cmt) then
                kc = kc+ki(i)
              end if
         end do
        if (C2(node).eq.cmt) then
            kc = kc - ki(node)
         end if
         return
         end function kc

!-soma dos pesos dos links entre o no i e a comunidade C(cmt)-
         function e_ic(cmt,node)
         use variaveis
         use variaveis_move
         integer*8 j, e_ic, cmt, node
         e_ic = 0
         do j = 1,numb_comun
         if(node.ne.j) then
           if ( (C2(j).eq.cmt).and.(G1(node,j).gt.0) ) then
             e_ic = e_ic+G1(node,j)
           end if
         end if
         end do
         return
         end function e_ic


program PlanarInterpConvergence

use NumberKindsModule
use LoggerModule
use PolyMesh2dModule
use ParticlesModule
use EdgesModule
use FacesModule
use STDIntVectorModule
use FieldModule
use BIVARModule

implicit none

type(Logger) :: exeLog

type(PolyMesh2d) :: triMesh
integer(kint), parameter :: meshSeed = TRI_HEX_SEED
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: amrLimit
real(kreal) :: ampFactor

type(Field) :: scalar
type(Field) :: estGrad, exactGrad, gradError
type(Field) :: est2ndPartials, exact2ndPartials, partialsError
type(Field) :: estLap, exactLap, lapError

real(kreal), parameter :: b = 3.0_kreal
real(kreal), parameter :: xc = 0.0_kreal, yc = 0.0_kreal
real(kreal), parameter :: maxAbsLap = 36.0_kreal
real(kreal) :: estGradError(9), estLapError(9), interpError(9), meshSize(9)
real(kreal) :: testStart, testEnd, maxGradMag

integer(kint) :: i, j

integer(kint) :: nTri, nL
integer(kint), allocatable :: ipt(:), ipl(:), iwl(:), iwp(:)
real(kreal), allocatable :: wk(:), partials(:)

integer(kint), parameter :: nn = 501
real(kreal), parameter :: dx = 8.0_kreal / real( nn - 1, kreal)
real(kreal), parameter :: xmin = -4.0_kreal
real(kreal), parameter :: xmax = 4.0_kreal
real(kreal), parameter :: ymin = xmin
real(kreal), parameter :: ymax = xmax

real(kreal) :: x(nn), y(nn)
real(kreal) :: interpScalar(nn,nn), exactScalar(nn,nn)
real(kreal) :: xVecA(3), xVecB(3)
integer(kint) :: inTri(nn,nn)

character(len=MAX_STRING_LENGTH) :: logstring
character(len=MAX_STRING_LENGTH) :: filename
!
!----------------
! PROGRAM START
!----------------
!
call New(exeLog, DEBUG_LOGGING_LEVEL)

do initNest = 8, 8

	write(logstring,'(A,I3,A)') "test ", initNest+1, ", of 9..."
	call LogMessage(exeLog, TRACE_LOGGING_LEVEL,"Interpolation Convergence : ", logString)
	call cpu_time(testStart)
	!
	! build a mesh
	!
	maxNest = initNest
	amrLimit = 0
	ampFactor = 3.0_kreal
	call New(triMesh, meshSeed, initNest, maxNest, amrLimit, ampFactor)
	! define a scalar field on the mesh
	call New(scalar, 1, triMesh%particles%N, "gaussScalar", "n/a")
	call New(estGrad,2, triMesh%particles%N, "estGradient", "n/a")
	call New(exactGrad,2,triMesh%particles%N,"exactGradient","n/a")
	call New(gradError,1,triMesh%particles%N, "gradError", "n/a")
	call New(est2ndPartials,3,triMesh%particles%N, "estPartials","n/a")
	call New(exact2ndPartials,3,triMesh%particles%N,"exactPartials","n/a")
	call New(partialsError,3,triMesh%particles%N, "partialsError","n/a")
	call New(estLap, 1, triMesh%particles%N, "estLaplacian","n/a")
	call New(exactLap,1, triMesh%particles%N,"exactLaplacian", "n/a")
	call New(lapError,1, triMesh%particles%N,"lapError","n/a")

	do i = 1, triMesh%particles%N
		call InsertScalarToField( scalar, Gaussian( [triMesh%particles%x(i), triMesh%particles%y(i)], b) )
		call InsertVectorToField(exactGrad, GaussGrad( [triMesh%particles%x(i), triMesh%particles%y(i)], b))
		call InsertVectorToField(exact2ndPartials, Gauss2ndDerivs([triMesh%particles%x(i), triMesh%particles%y(i)], b))
		call InsertScalarToField(exactLap, GaussLap([triMesh%particles%x(i), triMesh%particles%y(i)],b) )
	enddo

	!
	! set up interpolation, estimate derivatives
	!

	!
	! interpolate to uniform mesh
	!
	do i = 1, nn
		x(i) = xmin + dx * (i-1)
		y(i) = ymin + dx * (i-1)
	enddo

	allocate(ipt(6*triMesh%particles%N - 15))  ! triangle vertices : triangle I has vertices at
											   !  	indices ipt(3*I-2), ipt(3*I-1), and ipt(3*I), for I = 1,...,nTri.
	allocate(ipl(6*triMesh%particles%N))	   ! border edges and triangles : border edge I has
											   ! 	endpoint 1, endpoint 2, and triangle index stored at
											   !	ipl(3*I-2), ipl(3*I-1), and ipl(3*I), for I = 1,...,nL.
	allocate(iwl(18*triMesh%particles%N))	! work space only
	allocate(iwp(triMesh%particles%N))		! work space only
	allocate(wk(8*triMesh%particles%N))		! work space only
	!
	!	triangulate particles
	!
	call idtang( triMesh%particles%N, triMesh%particles%x, triMesh%particles%y, &
				 nTri, ipt, nL, ipl, iwl, iwp, wk)
	!
	!	locate triangles that contain destination points
	!
	inTri = 0
	do j = 1, nn
		do i = 1, nn
			call idlctn( triMesh%particles%N, triMesh%particles%x, triMesh%particles%y, nTri, ipt, nL, ipl, &
						 x(j), y(i), inTri(i,j), iwl, wk )
		enddo
	enddo
	!
	!	estimate partial derivatives at particles
	!
	allocate(partials(5*triMesh%particles%N)) ! partial derivatives : partials of of particle I stored at
											  !		partials(5*I-4:5*I)
	call idpdrv( triMesh%particles%N, triMesh%particles%x, triMesh%particles%y, scalar%scalar, nTri, ipt, partials, wk)
	do i = 1, triMesh%particles%N
		call InsertVectorToField( estGrad, partials(5*i-4:5*i-3) )
		call InsertVectorToField( est2ndPartials, partials(5*i-2:5*i))
		call InsertScalarToField( estLap, partials(5*i-2) + partials(5*i))
	enddo

	do i = 1, triMesh%particles%N
		partials(5*i-4:5*i-3) = GaussGrad( [triMesh%particles%x(i), triMesh%particles%y(i)], b)
		partials(5*i-2:5*i) = Gauss2ndDerivs( [triMesh%particles%x(i), triMesh%particles%y(i)], b)
	enddo

	!
	! 	interpolate the scalar
	!
	do j = 1, nn
		do i = 1, nn
			exactScalar(i,j) = Gaussian( [x(j),y(i)], b)
			!if ( pointIsOutsideMesh(triMesh, [ x(j), y(i), 0.0_kreal ]) ) then
			!	interpScalar(i,j) = 0.0_kreal
			!else
				call idptip( triMesh%particles%N, triMesh%particles%x, triMesh%particles%y, scalar%scalar, &
						 nTri, ipt, nL, ipl, partials, inTri(i,j), x(j), y(i), interpScalar(i,j))
			!endif
		enddo
	enddo

	!
	! calculate derivative error at particles
	!
	do i = 1, triMesh%particles%N
		xVecA = 0.0_kreal
		xVecB = 0.0_kreal
		xVecA(1:2) = [estGrad%xComp(i), estGrad%yComp(i)]
		xVecB(1:2) = GaussGrad( [triMesh%particles%x(i), triMesh%particles%y(i)], b)
		call InsertScalarToField( gradError, sqrt(sum( xVecA - xVecB)))
		call InsertScalarToField( lapError, estLap%scalar(i) - exactLap%scalar(i))
		xVecA = [est2ndPartials%xComp(i), est2ndPartials%yComp(i), est2ndPartials%zComp(i)]
		xVecB = Gauss2ndDerivs( [triMesh%particles%x(i), triMesh%particles%y(i)], b)
		call InsertVectorToField( partialsError, xVecA - xVecB )
	enddo

	maxGradMag = MaxMagnitude(exactGrad)
	meshSize(initNest+1) = MaxEdgeLength(triMesh%edges, triMesh%particles)
	estGradError(initNest+1) = maxval(gradError%scalar)/maxGradMag
	estLapError(initNest+1) = maxval(abs(lapError%scalar))/maxAbsLap
	interpError(initNest+1) = maxval(abs(interpScalar-exactScalar))

	write(6,'(4A24)') "dx", "gradErr-particles", "lapErr-particles", "interp error"
	write(6,'(4F24.10)') meshSize(initNest+1), estGradError(initNest+1), estLapError(initNest+1), interpError(initNest+1)

	write(filename,'(A,I1,A)') 'BivarTestTriMesh', initNest, '.m'
	open(unit=WRITE_UNIT_1,file=filename,status='REPLACE',action='WRITE')
		call WriteParticlesToMatlab(triMesh%particles, WRITE_UNIT_1)
		call WriteFieldToMatlab(scalar, WRITE_UNIT_1)
		call WriteFieldToMatlab(estGrad, WRITE_UNIT_1)
		call WriteFieldToMatlab(exactGrad, WRITE_UNIT_1)
		call WriteFieldToMatlab(estLap, WRITE_UNIT_1)
		call WriteFieldToMatlab(exactLap, WRITE_UNIT_1)
		call WriteFieldToMatlab(gradError, WRITE_UNIT_1)
		call WriteFieldToMatlab(lapError, WRITE_UNIT_1)

		write(WRITE_UNIT_1,'(A)',advance='NO') "xi = ["
		do i = 1, nn - 1
			write(WRITE_UNIT_1,'(F18.12,A)', advance='NO') x(i), ", "
		enddo
		write(WRITE_UNIT_1,'(F18.12,A)') x(nn), "];"
		write(WRITE_UNIT_1, '(A)') "yi = xi; "

		write(WRITE_UNIT_1,'(A)',advance='NO') "interp = ["
		do i = 1, nn - 1
			do j = 1, nn - 1
				write(WRITE_UNIT_1,'(F18.12,A)',advance='NO') interpScalar(i,j), ", "
			enddo
			write(WRITE_UNIT_1,'(F18.12,A)') interpScalar(i,nn), "; ..."
		enddo
		do j = 1, nn - 1
			write(WRITE_UNIT_1,'(F18.12,A)',advance='NO') interpScalar(nn,j), ", "
		enddo
		write(WRITE_UNIT_1,'(F18.12,A)') interpScalar(nn,nn), "];"

	close(WRITE_UNIT_1)

	call cpu_time(testEnd)
	write(6,'(A,I8,A,F12.2,A)') "nParticles = ", triMesh%particles%N, ": elapsed time = ", testEnd-testStart, " seconds."

	!
	! reset for next iteration
	!
	deallocate(partials)
	deallocate(wk)
	deallocate(iwl)
	deallocate(iwp)
	deallocate(ipl)
	deallocate(ipt)
	call Delete(lapError)
	call Delete(exactLap)
	call Delete(estLap)
	call Delete(partialsError)
	call Delete(exact2ndPartials)
	call Delete(est2ndPartials)
	call Delete(gradError)
	call Delete(exactGrad)
	call Delete(estGrad)
	call Delete(scalar)
	call Delete(triMesh)

	call LogMessage(exeLog,TRACE_LOGGING_LEVEL, "test complete for initNest = ", initNest)
enddo

write(6,'(4A24)') "dx", "gradErr-particles", "lapErr-particles", "interp error"
do i = 1, 9
	write(6,'(4F24.10)') meshSize(i), estGradError(i), estLapError(i), interpError(i)
enddo

contains

function Gaussian( xy, b )
	real(kreal) :: Gaussian
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b

	Gaussian = exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc)))
end function

function GaussGrad(xy, b)
	real(kreal) :: GaussGrad(2)
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b
	GaussGrad(1) = xy(1)-xc
	GaussGrad(2) = xy(2)-yc
	GaussGrad = -2.0_kreal * GaussGrad * b * b * exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ))
end function

function GaussLap(xy, b)
	real(kreal) :: GaussLap
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b
	GaussLap = ( b*b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ) - 1.0_kreal ) * 4.0_kreal * b * b * &
			exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ))
end function

function Gauss2ndDerivs( xy, b)
	real(kreal) :: Gauss2ndDerivs(3)
	real(kreal), intent(in) :: xy(2)
	real(kreal), intent(in) :: b
	Gauss2ndDerivs(1) = 2.0_kreal * b * b *(2.0_kreal * b*b *(xy(1)-xc)*(xy(1)-xc) - 1.0_kreal)
	Gauss2ndDerivs(2) = 4.0_kreal * b**4 * (xy(1)-xc)*(xy(2)-yc)
	Gauss2ndDerivs(3) = 2.0_kreal * b * b *(2.0_kreal * b*b * (xy(2)-yc)*(xy(2)-yc) - 1.0_kreal)
	Gauss2ndDerivs = Gauss2ndDerivs * exp( - b * b * ( (xy(1)-xc)*(xy(1)-xc) + (xy(2)-yc)*(xy(2)-yc) ))
end function

end program


      SUBROUTINE slAFIN (STRING, IPTR, A, J)
*+
*     - - - - -
*      A F I N
*     - - - - -
*
*  Sexagesimal character string to angle (single precision)
*
*  Given:
*     STRING  c*(*)   string containing deg, arcmin, arcsec fields
*     IPTR      i     pointer to start of decode (1st = 1)
*
*  Returned:
*     IPTR      i     advanced past the decoded angle
*     A         r     angle in radians
*     J         i     status:  0 = OK
*                             +1 = default, A unchanged
*                             -1 = bad degrees      )
*                             -2 = bad arcminutes   )  (note 3)
*                             -3 = bad arcseconds   )
*
*  Example:
*
*    argument    before                           after
*
*    STRING      '-57 17 44.806  12 34 56.7'      unchanged
*    IPTR        1                                16 (points to 12...)
*    A           ?                                -1.00000
*    J           ?                                0
*
*    A further call to slAFIN, without adjustment of IPTR, will
*    decode the second angle, 12deg 34min 56.7sec.
*
*  Notes:
*
*     1)  The first three "fields" in STRING are degrees, arcminutes,
*         arcseconds, separated by spaces or commas.  The degrees field
*         may be signed, but not the others.  The decoding is carried
*         out by the DFLTIN routine and is free-format.
*
*     2)  Successive fields may be absent, defaulting to zero.  For
*         zero status, the only combinations allowed are degrees alone,
*         degrees and arcminutes, and all three fields present.  If all
*         three fields are omitted, a status of +1 is returned and A is
*         unchanged.  In all other cases A is changed.
*
*     3)  Range checking:
*
*           The degrees field is not range checked.  However, it is
*           expected to be integral unless the other two fields are
*           absent.
*
*           The arcminutes field is expected to be 0-59, and integral if
*           the arcseconds field is present.  If the arcseconds field
*           is absent, the arcminutes is expected to be 0-59.9999...
*
*           The arcseconds field is expected to be 0-59.9999...
*
*     4)  Decoding continues even when a check has failed.  Under these
*         circumstances the field takes the supplied value, defaulting
*         to zero, and the result A is computed and returned.
*
*     5)  Further fields after the three expected ones are not treated
*         as an error.  The pointer IPTR is left in the correct state
*         for further decoding with the present routine or with DFLTIN
*         etc.  See the example, above.
*
*     6)  If STRING contains hours, minutes, seconds instead of degrees
*         etc, or if the required units are turns (or days) instead of
*         radians, the result A should be multiplied as follows:
*
*           for        to obtain    multiply
*           STRING     A in         A by
*
*           d ' "      radians      1       =  1.0
*           d ' "      turns        1/2pi   =  0.1591549430918953358
*           h m s      radians      15      =  15.0
*           h m s      days         15/2pi  =  2.3873241463784300365
*
*  Called:  slDAFN
*
*  P.T.Wallace   Starlink   13 September 1990
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      CHARACTER*(*) STRING
      INTEGER IPTR
      REAL A
      INTEGER J

      DOUBLE PRECISION AD

*  Call the double precision version
      CALL slDAFN(STRING,IPTR,AD,J)
      IF (J.LE.0) A=REAL(AD)

      END


module c_supercells

  use supercell, only: find_optimal_cell
  use iso_c_binding, only: c_int, c_double, c_bool
  implicit none

  contains

  subroutine c_find_optimal_cell(cell, target_metric, target_size, smatrix) bind(c)

    real(c_double),  intent(in) :: cell(3,3)
    real(c_double),  intent(in) :: target_metric(3,3)
    real(c_double), intent(in), value           :: target_size
    integer(c_int), intent(out) :: smatrix(3,3)

    ! integer(c_int), optional, intent(in)        :: lower_limit, upper_limit
    ! logical(c_bool), optional, intent(in)       :: verbose
    ! integer(c_int)                              :: llim, ulim
    ! logical(c_bool)                             :: vrbs, found
    ! options and defaults
    ! llim = -2
    ! ulim =  2
    ! vrbs = .false.
    ! if(present(lower_limit)) llim = lower_limit
    ! if(present(upper_limit)) ylim = upper_limit
    ! if(present(verbose))     vrbs = verbose

    smatrix = find_optimal_cell(cell, target_metric, target_size)
    !, lower_limit, &
    !  !upper_limit, verbose)

  end subroutine

end module


        !COMPILER-GENERATED INTERFACE MODULE: Tue May  2 15:02:05 2017
        MODULE UPDATECVM__genmod
          INTERFACE
            SUBROUTINE UPDATECVM(OLDCVM,OLDMEAN,N,PAR,NEWMEAN,NEWCVM)
              USE INTERFACE_MOD, ONLY :                                 &
     &          NPAR,                                                   &
     &          PRIORCVM
              REAL(KIND=8), INTENT(IN) :: OLDCVM(NPAR*(NPAR+1)/2)
              REAL(KIND=8), INTENT(IN) :: OLDMEAN(NPAR)
              REAL(KIND=8), INTENT(IN) :: N
              REAL(KIND=8), INTENT(IN) :: PAR(NPAR)
              REAL(KIND=8), INTENT(OUT) :: NEWMEAN(NPAR)
              REAL(KIND=8), INTENT(OUT) :: NEWCVM(NPAR*(NPAR+1)/2)
            END SUBROUTINE UPDATECVM
          END INTERFACE
        END MODULE UPDATECVM__genmod


      subroutine d2ztay(delxi,dzvc0,d2zvc1,kcol,kmax,nord,nrd1mx)
c
c     This subroutine computes the Taylor's series expansion for the
c     second derivative of the kcol-th master variables. This second
c     derivative is used to test whether or not a critical point
c     corresponds to a maximum.
c
c     See also:
c
c       EQ6/d1ztay.f
c       EQ6/ztaylr.f
c
c     This subroutine is called by:
c
c       None
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       delxi  = the step size (in reaction progress)
c       dzvc0  = the dz/d(xi) vector at the base point
c       kcol   = the index of the master variable whose second
c                  derivative is to be calculated
c       kmax   = the maximum number of elements in the z vector
c       nord   = the order of the truncated Taylor's series
c       nrd1mx = the maximum order of the truncated Taylor's series + 1
c
c     Principal output:
c
c       d2zvc1 = the d2z/d(xi)2 element for the kcol-th master
c                  variable
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer kmax,nrd1mx
c
      integer kcol,nord
c
      real*8 dzvc0(nrd1mx,kmax)
c
      real*8 delxi,d2zvc1
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer j,jk
c
      real*8 dxp,d2z
c
      real*8 fctrl
c
c-----------------------------------------------------------------------
c
      d2zvc1 = 0.
      if (nord .gt. 1) then
        d2z = dzvc0(2,kcol)
        if (nord .gt. 2) then
          jk = nord - 2
          dxp = 1.
          do j = 1,jk
            dxp = dxp*delxi
            d2z = d2z + ( dzvc0(j + 2,kcol )/fctrl(j) )*dxp
          enddo
        endif
        d2zvc1 = d2z
      endif
c
      end


      program day12
        integer*8 x(3,4), xdot(3,4), f(3,4), step, i, k, l(3), m, n
        data xdot/12*0/, l/3*0/
        common /param/ x,xdot

        do i = 1,4
           read(*,*) (x(k,i),k=1,3)
        end do

        step = 1
 1      do i = 1,4
           call grav(x(1,i), f(1,i))
        end do
        do i = 1,4
           call euler(xdot(1,i), f(1,i))
           call euler(x(1,i), xdot(1,i))
        end do

        if (step.eq.1000) then
           call energy
        end if

        do k = 1,3
           do i = 1,4
              if (xdot(k,i).ne.0) go to 5
           end do
           l(k) = step
 5         continue
        end do

        step = step + 1
        if (l(1)*l(2)*l(3).eq.0 .or. step.le.1000) go to 1

        call lcm(l(1), l(2), m)
        call lcm(m, l(3), n)
        write(*,*) n

        stop
      end

      subroutine energy
        integer*8 e, kin, pot, x(3,4), xdot(3,4), i, k
        common /param/ x,xdot

        e = 0
        do i = 1,4
           kin = 0
           pot = 0
           do k = 1,3
              pot = pot + abs(x(k,i))
              kin = kin + abs(xdot(k,i))
           end do
           e = e + kin * pot
        end do

        write(*,*) e
      end

      subroutine euler(xi, xidot)
        integer*8 xi(3), xidot(3), k
        do k = 1,3
           xi(k) = xi(k) + xidot(k)
        end do
        return
      end

      subroutine grav(xi, f)
        integer*8 x(3,4), xdot(3,4), j, k, dx, f(3), xi(3)
        common /param/ x,xdot
        do k = 1,3
           f(k) = 0
        end do

        do j = 1,4
           do k = 1,3
              dx = x(k,j) - xi(k)
              if (dx.lt.0) then
                 f(k) = f(k) - 1
              else if (dx.gt.0) then
                 f(k) = f(k) + 1
              end if
           end do
        end do
        return
      end


        implicit real *8 (a-h,o-z)
        complex *16 z,j0,ima,ztest(1000 000),jtest(1000 000),
     1    jtest2(1000 000),jtest3(1000 000)
        real *8 rtest(1000 0000),thetatest(1000 0000),jtestr(1000 0000),
     1      jtesti(1000 0000),xtest(1000 0000),ytest(1000 0000),
     2      rerrors(5,4),times(4,2)
        data ima/(0.0d0,1.0d0)/

        call prini(6,13)

        do i=1,4
           do j=1,5
              rerrors(j,i)=0
           enddo
        enddo

        ntest=10000
        OPEN(UNIT=66,FILE="../mathematica/rm1test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) rtest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/thetam1test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) thetatest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/jm1testr.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtestr(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/jm1testi.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtesti(i)
        enddo
        close(66)

        do i=1,ntest
           ztest(i)=rtest(i)*exp(ima*thetatest(i))
c           ztest(i)=rtest(i)
c           ztest(i) = ztest(i)/10
           write(79,*) dble(ztest(i)), imag(ztest(i))
        enddo

        do i=1,ntest
           jtest(i)=jtestr(i)+ima*jtesti(i)
        enddo

        ifexpon=0
        t1=second()
        do k = 1,10
        do i=1,ntest
           call abramm1(ztest(i),jtest2(i),ifexpon)
        enddo
        enddo
        t2=second()
        call prin2('evaluation time of J_{-1}=*',t2-t1,1)
        times(1,1)=t2-t1

        t1=second()
        do k = 1,10
        do i=1,ntest
           jtest3(i)=exp(ztest(i))
        enddo
        enddo
        t2=second()
        write(11,*) jtest3(1)
        call prin2('evaluation time of complex exponentials=*',t2-t1,1)
        times(1,2)=t2-t1

        dmax=0
        imax=0
        do i=1,ntest
           dd=abs((jtest(i)-jtest2(i))/jtest(i))
           if (dd .gt. 1d-14) then
              print *, dd, ztest(i)
           endif
           az=abs(ztest(i))
           if (az .lt. 1) then
              if (rerrors(1,1) .lt. dd) then
                 rerrors(1,1) = dd
              endif
           elseif (az .ge. 1 .and. az .lt. 3) then
              if (rerrors(2,1) .lt. dd) then
                 rerrors(2,1) = dd
              endif
           elseif (az .ge. 3 .and. az .lt. 15) then
              if (rerrors(3,1) .lt. dd) then
                 rerrors(3,1) = dd
              endif
           elseif (az .ge. 15 .and. az .lt. 120) then
              if (rerrors(4,1) .lt. dd) then
                 rerrors(4,1) = dd
              endif
           elseif (az .gt. 120) then
              if (rerrors(5,1) .lt. dd) then
                 rerrors(5,1) = dd
              endif
           endif

           if (dmax .lt. dd) then
              dmax=dd
              imax=i
           endif
        enddo

        print *, 'maximum relative error = ', dmax
        print *, 'occured at ', ztest(imax), imax
        print *, 'true value = ', jtest(imax)
        print *, 'computed value = ', jtest2(imax)
        print *, 'done with testing J_{-1}'

ccc        ntest=100 000
        OPEN(UNIT=66,FILE="../mathematica/r0test.txt",FORM="FORMATTED",
     1      STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) rtest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/theta0test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) thetatest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j0testr.txt",FORM="FORMATTED",
     1      STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtestr(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j0testi.txt",FORM="FORMATTED",
     1      STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtesti(i)
        enddo
        close(66)

        do i=1,ntest
           ztest(i)=rtest(i)*exp(ima*thetatest(i))
c           ztest(i)=rtest(i)
c           ztest(i) = ztest(i)/10
           write(80,*) dble(ztest(i)), imag(ztest(i))
        enddo

        do i=1,ntest
           jtest(i)=jtestr(i)+ima*jtesti(i)
        enddo

        ifexpon=0
        t1=second()
        do k=1,10
        do i=1,ntest
           call abram0(ztest(i),jtest2(i),ifexpon)
        enddo
        enddo
        t2=second()
        call prin2('evaluation time of J_0=*',t2-t1,1)
        times(2,1)=t2-t1

        t1=second()
        do k=1,10
        do i=1,ntest
           jtest3(i)=exp(ztest(i))
        enddo
        enddo
        t2=second()
        write(11,*) jtest3(1)
        call prin2('evaluation time of complex exponentials=*',t2-t1,1)
        times(2,2)=t2-t1

        dmax=0
        imax=0
        do i=1,ntest
           dd=abs((jtest(i)-jtest2(i))/jtest(i))
           if (dd .gt. 1d-14) then
              print *, dd, ztest(i)
           endif
           az=abs(ztest(i))
           if (az .lt. 1) then
              if (rerrors(1,2) .lt. dd) then
                 rerrors(1,2) = dd
              endif
           elseif (az .ge. 1 .and. az .lt. 3) then
              if (rerrors(2,2) .lt. dd) then
                 rerrors(2,2) = dd
              endif
           elseif (az .ge. 3 .and. az .lt. 15) then
              if (rerrors(3,2) .lt. dd) then
                 rerrors(3,2) = dd
              endif
           elseif (az .ge. 15 .and. az .lt. 120) then
              if (rerrors(4,2) .lt. dd) then
                 rerrors(4,2) = dd
              endif
           elseif (az .gt. 120) then
              if (rerrors(5,2) .lt. dd) then
                 rerrors(5,2) = dd
              endif
           endif

           if (dmax .lt. dd) then
              dmax=dd
              imax=i
           endif
        enddo

        print *, 'maximum relative error = ', dmax
        print *, 'occured at ', ztest(imax), imax
        print *, 'true value = ', jtest(imax)
        print *, 'computed value = ', jtest2(imax)
        print *, 'done with testing J_0'

ccc        ntest=100 000
        OPEN(UNIT=66,FILE="../mathematica/r1test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) rtest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/theta1test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) thetatest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j1testr.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtestr(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j1testi.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtesti(i)
        enddo
        close(66)

        do i=1,ntest
           ztest(i)=rtest(i)*exp(ima*thetatest(i))
c           ztest(i)=rtest(i)
c           ztest(i) = ztest(i)/10
           write(81,*) dble(ztest(i)), imag(ztest(i))
        enddo

        do i=1,ntest
           jtest(i)=jtestr(i)+ima*jtesti(i)
        enddo

        ifexpon=0
        t1=second()
        do k=1,10
        do i=1,ntest
           call abram1(ztest(i),jtest2(i),ifexpon)
        enddo
        enddo
        t2=second()
        call prin2('evaluation time of J_1=*',t2-t1,1)
        times(3,1)=t2-t1

        t1=second()
        do k=1,10
        do i=1,ntest
           jtest3(i)=exp(ztest(i))
        enddo
        enddo
        t2=second()
        write(11,*) jtest3(1)
        call prin2('evaluation time of complex exponentials=*',t2-t1,1)
        times(3,2)=t2-t1

        dmax=0
        imax=0
        do i=1,ntest
           dd=abs((jtest(i)-jtest2(i))/jtest(i))
           if (dd .gt. 1d-14) then
              print *, dd, ztest(i)
           endif
           az=abs(ztest(i))
           if (az .lt. 1) then
              if (rerrors(1,3) .lt. dd) then
                 rerrors(1,3) = dd
              endif
           elseif (az .ge. 1 .and. az .lt. 3) then
              if (rerrors(2,3) .lt. dd) then
                 rerrors(2,3) = dd
              endif
           elseif (az .ge. 3 .and. az .lt. 15) then
              if (rerrors(3,3) .lt. dd) then
                 rerrors(3,3) = dd
              endif
           elseif (az .ge. 15 .and. az .lt. 120) then
              if (rerrors(4,3) .lt. dd) then
                 rerrors(4,3) = dd
              endif
           elseif (az .gt. 120) then
              if (rerrors(5,3) .lt. dd) then
                 rerrors(5,3) = dd
              endif
           endif

           if (dmax .lt. dd) then
              dmax=dd
              imax=i
           endif
        enddo

        print *, 'maximum relative error = ', dmax
        print *, 'occured at ', ztest(imax), imax
        print *, 'true value = ', jtest(imax)
        print *, 'computed value = ', jtest2(imax)
        print *, 'done with testing J_1'

ccc        ntest=100 000
        OPEN(UNIT=66,FILE="../mathematica/r2test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) rtest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/theta2test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) thetatest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j2testr.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtestr(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j2testi.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtesti(i)
        enddo
        close(66)

        do i=1,ntest
           ztest(i)=rtest(i)*exp(ima*thetatest(i))
c           ztest(i)=xtest(i)+ima*ytest(i)
c           ztest(i)=rtest(i)
c           ztest(i) = ztest(i)/10
           write(82,*) dble(ztest(i)), imag(ztest(i))
        enddo

        do i=1,ntest
           jtest(i)=jtestr(i)+ima*jtesti(i)
        enddo

        ifexpon=0
        t1=second()
        do k=1,10
        do i=1,ntest
           call abram2(ztest(i),jtest2(i),ifexpon)
        enddo
        enddo
        t2=second()
        call prin2('evaluation time of J_2=*',t2-t1,1)
        times(4,1)=t2-t1

        t1=second()
        do k=1,10
        do i=1,ntest
           jtest3(i)=exp(ztest(i))
        enddo
        enddo
        t2=second()
        write(11,*) jtest3(1)
        call prin2('evaluation time of complex exponentials=*',t2-t1,1)
        times(4,2)=t2-t1

        dmax=0
        imax=0
        do i=1,ntest
           dd=abs((jtest(i)-jtest2(i))/jtest(i))
           if (dd .gt. 1d-14) then
              print *, dd, ztest(i)
           endif
           az=abs(ztest(i))
           if (az .lt. 1) then
              if (rerrors(1,4) .lt. dd) then
                 rerrors(1,4) = dd
              endif
           elseif (az .ge. 1 .and. az .lt. 3) then
              if (rerrors(2,4) .lt. dd) then
                 rerrors(2,4) = dd
              endif
           elseif (az .ge. 3 .and. az .lt. 15) then
              if (rerrors(3,4) .lt. dd) then
                 rerrors(3,4) = dd
              endif
           elseif (az .ge. 15 .and. az .lt. 120) then
              if (rerrors(4,4) .lt. dd) then
                 rerrors(4,4) = dd
              endif
           elseif (az .gt. 120) then
              if (rerrors(5,4) .lt. dd) then
                 rerrors(5,4) = dd
              endif
           endif

           if (dmax .lt. dd) then
              dmax=dd
              imax=i
           endif
        enddo

        print *, 'maximum relative error = ', dmax
        print *, 'occured at ', ztest(imax), imax
        print *, 'true value = ', jtest(imax)
        print *, 'computed value = ', jtest2(imax)

        print *, 'done with testing J_2'

        write(29,*) '  &     S     &    Q_1 &     Q_2 &    Q_3 &    A\\'
 1600   format('J_{',I2,'}',2x,'&',4(2x,ES8.2,'&'), 2x, ES8.2, '\\')
        do i=1,4
           write(29,1600) i-2, (rerrors(j,i), j=1,5)
        enddo

        write(30,*) '  &     J_{-1} &     J_0 &     J_1 &     J_2\\'
 1800 format('T_E &', 3(2x,ES8.2,'&'),2x,ES8.2,'\\')
        do i=1,2
           write(30,1800) (times(j,i), j=1,4)
        enddo

        stop
        end


      program rvbr
c-----------------------------------------------------------------------
c     SPARSKIT test program for Variable Block Matrix Support
c-----------------------------------------------------------------------
c     This program tests all three conversion routines of csrvbr.
c     For each conversion to VBR, the format is converted back to CSR
c     with vbrcsr.  The subroutines csrkvstr, csrkvstc, and kvstmerge
c     become tested in the process.  The subroutines vbrinfo and vbrmv
c     are also tested.
c-----------------------------------------------------------------------
      integer nxmax, nmx, nnzmax
      parameter (nxmax = 10, nmx = nxmax*nxmax, nnzmax=10*nmx)
      integer ia(nmx+1),ja(nnzmax),ia1(nnzmax),ja1(nnzmax), iwk(nmx*2+1)
      real( kind = 8 ) stencil(7,100),a(nnzmax),a1(nnzmax)
      integer ib(nmx+1),kvstr(nmx+1),kvstc(nmx+1),jb(nmx*10),kb(nmx*10)
      real( kind = 8 ) b(nnzmax)
      real( kind = 8 ) x(nmx),rhs(nmx),ans(nmx)
      integer n, na, nx, ny, nz, nfree
      integer nr, nc, i, job, maxblock, ierr
      real( kind = 8 ) rnd
c-----dimension of grid
      nx = 4
      ny = 2
      nz = 1
      nfree = 2
c-----generate grid problem.
      na = nfree*nfree
      call gen57bl (nx,ny,nz,nfree,na,n,a1,ja1,ia1,iwk,stencil)
c-----convert matrix to CSR
      call bsrcsr (1,n,nfree,na,a1,ja1,ia1,a,ja,ia)
      n = n * nfree
c     call dump(1, n, .true., a, ja, ia, 6)
c-----generate random x vector for testing matrix-vector product
      do i = 1, n
         x(i) = rnd()
      enddo
c-----generate correct solution for matrix-vector product
      call amux(n, x, ans, a, ja, ia)
      do job = 0, 2
         write (*,*) 'Testing job = ', job
         if (job .eq. 0) then
c-----------maximum blocksize for random block partitioning
            maxblock = n/4
c-----------generate random block partitioning for rows
            nr = 1
            kvstr(1) = 1
 2000       continue
               nr = nr + 1
               kvstr(nr) = kvstr(nr-1) + int(rnd()*maxblock)+1
            if (kvstr(nr) .lt. n+1) goto 2000
            kvstr(nr) = n+1
            nr = nr - 1
c-----------generate random block partitioning for columns
            nc = 1
            kvstc(1) = 1
 2010       continue
               nc = nc + 1
               kvstc(nc) = kvstc(nc-1) + int(rnd()*maxblock)+1
            if (kvstc(nc) .lt. n+1) goto 2010
            kvstc(nc) = n+1
            nc = nc - 1
         endif
c--------convert to VBR format------------------------------------------
         call csrvbr(n, ia, ja, a, nr, nc, kvstr, kvstc, ib, jb, kb,
     &      b, job, iwk, nmx*10, nnzmax, ierr)
c--------convert back to CSR format-------------------------------------
         call vbrcsr(ia1, ja1, a1, nr, kvstr, kvstc, ib, jb, kb,
     &      b, nnzmax, ierr)
c--------compare original and converted CSR structures if job not 0
         write (*,*) 'Checking conversions....'
         if (job .ne. 0) then
            do i = 1, n
               if (ia(i) .ne. ia1(i)) then
                  write (*,*) 'csrvbr or vbrcsr conversion mismatch'
                  stop
               endif
            enddo
            do i = 1, ia(n+1)-1
               if ((ja(i) .ne. ja1(i)) .or. (a(i) .ne. a1(i))) then
                  write (*,*) 'csrvbr or vbrcsr conversion mismatch'
                  stop
               endif
            enddo
         endif
c--------test vbrinfo---------------------------------------------------
         call vbrinfo(nr, nc, kvstr, kvstc, ib, jb, kb, iwk, 6)
c--------test vbrmv-----------------------------------------------------
         call vbrmv(nr, nc, ib, jb, b, kvstr, kvstc, x, rhs)
c--------compare answer with answer computed with CSR format
         do i = 1, n
            if (abs(ans(i) - rhs(i)) .gt. abs(0.001d0*ans(i))) then
               write (*,*) 'VBR matrix-vector product is erroneous ',i
               stop
            endif
         enddo
c--------fill CSR structure with garbage
         do i = 1, ia1(n+1)-1
            ja1(i) = -1
            a1(i) = -1.d0
         enddo
         do i = 1, n+1
            ia1(i) = -1
         enddo
c--------fill VBR structure with garbage
         do i = 1, kb(ib(nr+1))-1
            b(i) = -1.d0
         enddo
         do i = 1, ib(nr+1)
            jb(i) = -1
            kb(i) = -1
         enddo
         do i = 1, nr+1
            ib(i) = -1
         enddo
c--------fill kvstr and kvstc with garbage
         do i = 1, nr+1
            kvstr(i) = -1
         enddo
         do i = 1, nc+1
            kvstc(i) = -1
         enddo
c--------fill rhs with garbage
         do i = 1, n
            rhs(i) = -1.d0
         enddo
c-----endloop on job
      enddo
      stop
      end
c-----------------------------------------------------------------------
      function rnd()
      real( kind = 8 ) rnd
      integer im, ia, ic, jran
      save jran
      data im /6075/, ia /106/, ic /1283/, jran/1/
      jran = mod(jran*ia+ic, im)
      rnd = dble(jran)/dble(im)
      return
      end
c-----------------------------------------------------------------------
c     Coded by Edmond Chow, chow@cs.umn.edu
c-----------------------------------------------------------------------