program test_linalg_linspace
    use forlab_io, only: disp, file
    use forlab_linalg, only: linspace, logspace
    implicit none
    real :: x(4)
    call linspace(x, 1.0, 10.0)
    call disp(x, 'linspace(x, 1.0, 10.0) : ')
    call logspace(x, 1.0, 10.0)
    call disp(x, 'logspace(x, 1.0, 10.0) : ')
end program test_linalg_linspace


    Program dsgesv_example

!     DSGESV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dsgesv
      Use lapack_precision, Only: sp, dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, info, iter, lda, ldb, ldx, n, r
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), work(:), x(:, :)
      Real (Kind=sp), Allocatable :: swork(:)
      Integer, Allocatable :: ipiv(:)
!     .. Executable Statements ..
      Write (nout, *) 'DSGESV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, r
      lda = n
      ldb = n
      ldx = n
      Allocate (a(lda,n), b(n,r), work(n*r), x(ldx,r), swork(n*(n+ &
        r)), ipiv(n))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:r), i=1, n)

!     Solve the equations Ax = b for x

      Call dsgesv(n, r, a, lda, ipiv, b, ldb, x, ldx, work, swork, iter, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Solution'
        Write (nout, 100)(x(i,1:r), i=1, n)

!       Print pivot indices

        Write (nout, *)
        Write (nout, *) 'Pivot indices'
        Write (nout, 110) ipiv(1:n)

      Else
        Write (nout, 120) 'The (', info, ',', info, ')', &
          ' element of the factor U is zero'
      End If

100   Format ((3X,7F11.4))
110   Format ((3X,7I11))
120   Format (1X, A, I3, A, I3, A, A)
    End Program


PROGRAM LA_SSPGVX_ET_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
  USE LA_PRECISION, ONLY: WP => SP
  USE F95_LAPACK, ONLY: LA_SPGVX
!  .. IMPLICIT STATEMENT ..
  IMPLICIT NONE
!  .. PARAMETERS ..
  CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
  INTEGER, PARAMETER :: NIN=5, NOUT=6
  CHARACTER(LEN=1) :: UPLO
!  .. LOCAL SCALARS ..
  INTEGER :: I, J, INFO, N, NS
  REAL(WP) :: VL, VU
  INTEGER ::  M, ITYPE, IL, IU
!  .. LOCAL ARRAYS ..
  REAL(WP), ALLOCATABLE :: AA(:), BB(:), W(:)
  REAL(WP), ALLOCATABLE :: A(:), B(:), Z(:,:)
  INTEGER, ALLOCATABLE :: IFAIL(:)
!  .. EXECUTABLE STATEMENTS ..
  WRITE (NOUT,*) 'SSPGVX ET_Example Program Results.'
  READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
  READ ( NIN, * ) N
  PRINT *, 'N = ', N
  NS = N*(N+1)/2
  ALLOCATE ( A(NS), AA(NS), B(NS), BB(NS), W(N), Z(N,N), IFAIL(N) )
!
  READ (NIN, *) AA, BB
  A=AA; B=BB
  WRITE(NOUT,*) 'The matrix A:'
  DO I = 1, N
    WRITE (NOUT,*) 'J = ', I; WRITE (NOUT,FMT) (A(J+(I-1)*I/2),J=1,I)
  ENDDO
  WRITE(NOUT,*) 'The matrix B:'
  DO I = 1, N
    WRITE (NOUT,*) 'J = ', I; WRITE (NOUT,FMT) (B(J+(I-1)*I/2),J=1,I)
  ENDDO
  ITYPE = 1; UPLO = 'L'; IL=1 ; IU=N; VL=-10; VU=10
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_SSPGVX LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   UPLO = 'U'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, 1, ''U'', Z, INFO=INFO )'
   A=AA; B=BB
   CALL LA_SPGVX( A, B, W, 1, UPLO, Z, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
   WRITE(NOUT,*) 'INFO = ', INFO
   WRITE(NOUT,*) 'The orthonormal eigenvectors of the matrix A stored in Z'
   DO I = 1, N
     WRITE(NOUT,FMT) Z(I,:)
   END DO
!
   UPLO = 'U'
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, 2, ''U'', Z , INFO = INFO)'
   A=AA; B=BB
   CALL LA_SPGVX( A, B, W, 2, UPLO, Z, INFO = INFO )
   WRITE(NOUT,*) ' EIGENVALUES:'
   WRITE(NOUT,FMT) W
   WRITE(NOUT,*) 'EIGENVECTORS:'
   DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
     WRITE(NOUT,*) 'INFO = ', INFO
!
        WRITE(NOUT,*)
        WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, 3, Z=Z, INFO=INFO )'
        A=AA; B=BB
        CALL LA_SPGVX( A, B, W, 3, Z=Z, INFO=INFO )
        WRITE(NOUT,*) ' EIGENVALUES:'
        WRITE(NOUT,FMT) W
        WRITE(NOUT,*) 'EIGENVECTORS:'
        DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
        WRITE(NOUT,*) 'INFO = ', INFO
!
        UPLO= 'L'
        WRITE(NOUT,*)
        WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, 1, Z, VL, VU, INFO=INFO )'
        A=AA; B=BB; W = HUGE(1.0_WP); Z = HUGE(1.0_WP)
        CALL LA_SPGVX( A, B, W, 1, Z=Z, VL=VL, VU=VU, INFO=INFO )
        WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
        WRITE(NOUT,FMT) W
        WRITE(NOUT,*) 'EIGENVECTORS:'
        DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
        WRITE(NOUT, *) 'The lower bound of the interval to be searched for eigenvalues VL= ', VL
        WRITE(NOUT, *) 'The upper bound of the interval to be searched for eigenvalues VU= ', VU
!
        UPLO= 'L'
        WRITE(NOUT,*)
        WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, 1, Z, IL=IL, IU=IU, INFO=INFO )'
        A=AA; B=BB; W = HUGE(1.0_WP); Z = HUGE(1.0_WP)
        CALL LA_SPGVX( A, B, W, 1, Z=Z, IL=IL, IU=IU, INFO=INFO )
        WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
        WRITE(NOUT,FMT) W
        WRITE(NOUT,*) 'EIGENVECTORS:'
        DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
        WRITE(NOUT, *) 'The indices of the smallest eigenvalue to be returned: IL= ', IL
        WRITE(NOUT, *) 'The indices of the largest eigenvalue to be returned: IU= ', IU
!
        UPLO= 'U'
        WRITE(NOUT,*)
        WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, 1, UPLO=''U'', Z, IL=IL, IU=IU, M=M, &
     &    IFAIL=IFAIL, INFO=INFO )'
        A=AA; B=BB; W = HUGE(1.0_WP); Z = HUGE(1.0_WP)
        CALL LA_SPGVX( A, B, W, 1, UPLO, Z, IL=IL, IU=IU, M=M, IFAIL=IFAIL,INFO=INFO )
        WRITE(NOUT,*) 'INFO = ', INFO, ' EIGENVALUES:'
        WRITE(NOUT,FMT) W
        WRITE(NOUT,*) 'EIGENVECTORS:'
        DO I = 1, N; WRITE(NOUT,*) 'I = ', I; WRITE (NOUT,FMT) Z(:,I); END DO
        WRITE(NOUT, *) 'The indices of the smallest eigenvalue to be returned: IL= ', IL
        WRITE(NOUT, *) 'The indices of the largest eigenvalue to be returned: IU= ', IU
        WRITE(NOUT,*) ' IFAIL  computed by LA_SPGVX:'
        WRITE(NOUT, *) IFAIL(:)
        WRITE(NOUT, *) 'The total number of eigenvalues found ', M
! STARTING THE ERROR TESTS
!ERROR 1
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVX( A(1:5), B, W, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SPGVX( A(1:5), B, W, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 2
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVX( A, B(1:5), W, INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SPGVX( A, B(1:5), W, INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 3
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W(1:N-1), INFO=INFO )'
   A=AA; B=BB; Z = HUGE(1.0_WP)
   CALL LA_SPGVX( A, B, W(1:N-1), INFO=INFO )
   WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 4
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, 5, INFO=INFO )'
      A=AA; B=BB; Z = HUGE(1.0_WP)
      CALL LA_SPGVX( A, B, W, 5, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 5
      UPLO = '9'
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, UPLO=''9'', INFO=INFO )'
      A=AA; B=BB; Z = HUGE(1.0_WP)
      CALL LA_SPGVX( A, B, W, UPLO=UPLO, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
      UPLO = 'U'
!ERROR 6
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, Z=Z(1:N-1,:), INFO=INFO )'
      A=AA; B=BB; Z = HUGE(1.0_WP)
      CALL LA_SPGVX( A, B, W, Z=Z(1:N-1,:), INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 6
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, Z=Z(:,1:N-1), INFO=INFO )'
      A=AA; B=BB; Z = HUGE(1.0_WP)
      CALL LA_SPGVX( A, B, W, Z=Z(:,1:N-1), INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 7
      VL = 10; VU = -10
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, ITYPE, UPLO, Z, VL, VU, M=M, IFAIL=IFAIL, INFO=INFO )'
      A=AA; B=BB; Z = HUGE(1.0_WP)
      CALL LA_SPGVX( A, B, W, ITYPE, UPLO, Z, VL, VU, M=M, IFAIL=IFAIL, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 8
      VL = 10; VU=-10; IL = 1; IU = N
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, ITYPE, UPLO, Z, VL, VU, IL, IU, M, IFAIL, INFO=INFO )'
      A=AA; B=BB; Z = HUGE(1.0_WP)
      CALL LA_SPGVX( A, B, W, ITYPE, UPLO, Z, VL, VU, IL, IU, M, IFAIL, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 9
      IL=1; IU=N+1
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, ITYPE, UPLO, Z, IL=IL, IU=IU, M=M, IFAIL=IFAIL, INFO=INFO )'
      A=AA; B=BB; Z = HUGE(1.0_WP)
      CALL LA_SPGVX( A, B, W, ITYPE, UPLO, Z, IL=IL, IU=IU, M=M, IFAIL=IFAIL, INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
!ERROR 10
      IL=1; IU=N+1
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, ITYPE, UPLO, Z, IL=IL, IU=IU, M=M, IFAIL=IFAIL, INFO=INFO )'
      A=AA; B=BB; Z = HUGE(1.0_WP)
      CALL LA_SPGVX( A, B, W, ITYPE, UPLO, Z, IL=IL, IU=IU, M=M, IFAIL=IFAIL, INFO=INFO  )
      WRITE(NOUT,*) 'INFO = ', INFO
! ERROR 12
      VL=-10; VU=10
      WRITE(NOUT,*)
      WRITE(NOUT,*) 'CALL LA_SPGVX( A, B, W, ITYPE, UPLO, Z, VL, VU, M=M, IFAIL=IFAIL(1:N-1), INFO=INFO )'
      A=AA; B=BB;
      CALL LA_SPGVX( A, B, W, ITYPE, UPLO, Z, VL, VU, M=M, IFAIL=IFAIL(1:N-1), INFO=INFO )
      WRITE(NOUT,*) 'INFO = ', INFO
END PROGRAM LA_SSPGVX_ET_EXAMPLE


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C   SOLVER : BiCG                              11.02.97
C            (d'après Templates)
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE BICG(N, x, b, A, IA, JA, ALU, JLU, JU, epsilon,
     #                it_max,z,z2,r,r2,p,p2,q,q2,IFLAG,ierr)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION A(*), ALU(*), IA(*), JA(*), JLU(*), JU(*),
     #          b(N), x(N),
     #          z(N), z2(N), r(N), r2(N), p(N), p2(N),
     #          q(N), q2(N)
C
C------------------------------------------------------------
C
C     Compute r0 & tol
C     ----------------
      CALL SMMV(N, A, IA, JA, x, r)
      CALL VectSub(N, b, r, r)
C
      residu=VectNorm(N,r)
      tol=epsilon*residu
C
C     Choose r20 = r0
C     ---------------
      CALL VectAssign(N,r2,r)
C
      j=0
      open(UNIT = 1, FILE = 'ite.m', STATUS = 'unknown')
C
C------------------------------------------------------------
C     Boucle principale
C--------------------------------------------------------
C
 10   j=j+1
C
      WRITE(*,210)j, residu
      WRITE(1,*)'residu2(',j,')=',residu,';'
C
C     Préconditionnement
C     ------------------
      IF(IFLAG.NE.0) THEN
         CALL LUSOL (n, r , z , alu, jlu, ju)
         CALL LUTSOL(n, r2, z2, alu, jlu, ju)
      ELSE
         CALL VectAssign(N,z ,r )
         CALL VectAssign(N,z2,r2)
      ENDIF
C
C     Calcul du rho et test du breakdown
C     ----------------------------------
      rho=ProdScal(N,z,r2)
      IF (dabs(rho).LT.tol) THEN
         WRITE(*,*)'Breakdown! rho =',rho

         ierr=1
         GOTO 999
      ENDIF
C
C     Calcul des directions de recherche bi-conjuguées
C     ------------------------------------------------
      IF (j.EQ.1) THEN
         CALL VectAssign(N,p,z)
         CALL VectAssign(N,p2,z2)
      ELSE
         beta=rho/rho2
         DO i=1,N
            p(i)  = z(i)  + beta * p(i)
            p2(i) = z2(i) + beta * p2(i)
         ENDDO
      ENDIF
C
C     Calcul de alpha
C     ---------------
      CALL SMMV (N, A, IA, JA, p , q )
      CALL SMMVT(N, A, IA, JA, p2, q2)
C
      alpha=ProdScal(N,p2,q)
      IF (dabs(alpha).LT.tol) THEN
         WRITE(*,*)'Breakdown! alpha =',alpha
         ierr=1
         GOTO 999
      ENDIF
      alpha=rho/alpha
C
C     Mise à jour de la solution et des résidus
C     -----------------------------------------
      DO i=1,N
         x(i)  = x(i)  + alpha * p(i)
         r(i)  = r(i)  - alpha * q(i)
         r2(i) = r2(i) - alpha * q2(i)
      ENDDO
C
      rho2=rho
C
C     Teste la convergence
C     --------------------
      residu=VectNorm(N,r)
      IF(residu.LT.tol) THEN
         WRITE(*,*)'Convergence!'
         ierr=0
         GOTO 999
      ENDIF
      IF(j.EQ.it_max) THEN
         WRITE(*,*)'it_max atteint!'
         ierr=1
         GOTO 999
      ENDIF
C
      GOTO 10
C------------------------------------------------------------
 999  close(unit=1)
      RETURN
C
 210  FORMAT(' Iteration :',T14,I4,'   Residu :',T32,D22.15)
C
      END


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
! Sous-routines & fonctions matricielles élémentaires
! (Version SPARSE MATRIX)
! 17.11.96
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

! Calcule c = A * b    (sparse matrix - CSR format)

SUBROUTINE SMMV(N, A, IA, JA, b, c)
    implicit none
    INTEGER, intent(in) :: N, IA(*), JA(*)
    REAL*8, intent(in) :: A(*), b(*)
    REAL*8, intent(out) :: c(*)

    REAL*8 :: t
    INTEGER :: i, j

    DO i = 1, N
        t = 0.0d0
        DO j = IA(i), IA(i+1)-1
            t = t + A(j) * b(JA(j))
        END DO
        c(i)=t
    END DO
END SUBROUTINE SMMV

! Calcule c = A^T * b    (sparse matrix - CSR format)

SUBROUTINE SMMVT(N, A, IA, JA, b, c)
    implicit none
    INTEGER, intent(in) :: N, IA(*), JA(*)
    REAL*8, intent(in) :: A(*), b(*)
    REAL*8, intent(out) :: c(*)
    INTEGER :: i, j, k

    DO i = 1, N
        c(i) = 0.0D0
    ENDDO

    DO i = 1, N
        DO j = IA(i), IA(i+1)-1
            k = JA(j)
            c(k) = c(k) + A(j) * b(i)
        END DO
    END DO
END SUBROUTINE SMMVT

! Fournit H(i,j)   (où H est triu + diag)

REAL*8 FUNCTION HCALL(H, i, j)
    implicit none
    REAL*8, intent(in) :: H(*)
    INTEGER, intent(in) :: i,j

    HCALL = H( (j-1)*(j+2)/2 + i )
END FUNCTION HCALL

! Effectue H(i,j):=alpha  (où H est triu + diag)

SUBROUTINE HASSIGN(H, i, j, alpha)
    implicit none
    REAL*8, intent(out) :: H(*)
    REAL*8, intent(in)  :: alpha
    INTEGER, intent(in) :: i, j

    H( ((j-1)*(j+2))/2 + i ) = alpha
END SUBROUTINE HASSIGN


    PROGRAM example
    USE mod_example_readmtx
    USE mod_kep
    IMPLICIT NONE
!
!   Input matrices A and B in Matrix Market exchange (MTX) format
    CHARACTER(256)  :: ipath_a,ipath_b
    INTEGER         :: n,nz_a,nz_b
    INTEGER,ALLOCATABLE,DIMENSION(:) :: indx_a,jndx_a,indx_b,jndx_b
    DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:) :: rval_a,rval_b
!
!   For SUBROUTINE kep
    INCLUDE 'kep_struct.h'
    TYPE(kep_struct) :: kep_io
!
!   Temporary
    CHARACTER(10)  :: ctemp
!
!---Read matrices A and B (MTX format)----------------------------------
!
!   Read A from file
    CALL GETARG(1,ipath_a) ! Provide the path as a command line argument
    CALL example_readmtx(ipath_a,n,nz_a,indx_a,jndx_a,rval_a)
!
!   Read B from file
    CALL GETARG(2,ipath_b) ! Provide the path as a command line argument
    CALL example_readmtx(ipath_b,n,nz_b,indx_b,jndx_b,rval_b)
!
!---Read the target index k---------------------------------------------
!
    CALL GETARG(3,ctemp)
    READ(ctemp,*) kep_io%k ! Provide the value as a command line argument
!
!---Set parameters for kep----------------------------------------------
!
    kep_io%iprm(1) =20  ! stopping criterion for bisection
                        ! (=maximum number of eigenpairs computed together)
    kep_io%iprm(2) =10  ! 10**-iprm(2)=tolerance for relative residual 2-norm
    kep_io%iprm(3) =10  ! 10**-iprm(3)=tolerance for relative difference 2-norm
    kep_io%iprm(11)=30  ! maximum iteration count for Lanczos
    kep_io%iprm(12)=30  ! maximum iteration count for Bisection
    kep_io%iprm(13)=300 ! maximum iteration count for shift-and-invert Lanczos
!
    kep_io%iprm(21)=1   ! If iprm(21) > 0, print details of computation to terminal
    kep_io%iprm(22)=0   ! If iprm(22) =< 0, output only the k-th eigenpair.
                        ! Otherwise, output all computed eigenpairs
!
!---Assign values of A and B for kep------------------------------------
!
!   Assign values of A
    kep_io%n=n              ! matrix size
    kep_io%nz_a=nz_a        ! number of non-zero elements of A
    ALLOCATE(kep_io%indx_a(kep_io%nz_a),&
        &    kep_io%jndx_a(kep_io%nz_a),&
        &    kep_io%rval_a(kep_io%nz_a))
    kep_io%indx_a=indx_a    ! row index of A
    kep_io%jndx_a=jndx_a    ! column index of A
    kep_io%rval_a=rval_a    ! value of A
!
!   Assign values of B
    kep_io%nz_b=nz_b        ! number of non-zero elements of B
    ALLOCATE(kep_io%indx_b(kep_io%nz_b),&
        &    kep_io%jndx_b(kep_io%nz_b),&
        &    kep_io%rval_b(kep_io%nz_b))
    kep_io%indx_b=indx_b    ! row index of B
    kep_io%jndx_b=jndx_b    ! columns index of B
    kep_io%rval_b=rval_b    ! value of B
!
!---Compute the k-th eigenpair------------------------------------------
!
    CALL kep(kep_io)
!
!---Write k-th eigenvalue-----------------------------------------------
!
    IF(kep_io%info.EQ.0) THEN
        CALL example_writekval(SIZE(kep_io%kndx),kep_io%kndx,kep_io%kval)
    END IF
!
!---Write k-th eigenvector----------------------------------------------
!
    IF(kep_io%info.EQ.0) THEN
        CALL example_writekvec(&
            & kep_io%n,SIZE(kep_io%kndx),kep_io%kndx,kep_io%kvec)
    END IF
!
!-----------------------------------------------------------------------
!
    DEALLOCATE(indx_a,jndx_a,rval_a,indx_b,jndx_b,rval_b)
    DEALLOCATE(kep_io%indx_a,kep_io%jndx_a,kep_io%rval_a)
    DEALLOCATE(kep_io%indx_b,kep_io%jndx_b,kep_io%rval_b)
!
    STOP
    END PROGRAM example


module matmul_m
    implicit none
    private
    public :: matmul_t

    restriction matmulable(T, U, V, times, sum)
        type :: T; end type
        type :: U; end type
        type :: V; end type
        interface
            elemental function times(x, y) result(prod)
                type(T), intent(in) :: x
                type(U), intent(in) :: y
                type(V) :: prod
            end function

            function sum(arr)
                type(V) :: arr(:)
                type(V) :: sum
            end function
        end interface
    end restrction

    template matmul_t(T, U, V, times, sum)
        private
        public :: matmul
        requires matmulable(T, U, V, times, sum)
        interface matmul
            module procedure matmul_
        end interface
    contains
        function matmul_(A, B) result(C)
            type(T), intent(in) :: A(:,:)
            type(U), intent(in) :: B(:,:)
            type(V), allocatable :: C(:, :)

            integer :: i, j

            if (size(A, dim=2) /= size(B, dim=1)) error stop "Mismatched matrix sizes"
            allocate(C(size(A, dim=1), size(B, dim=2)))
            do concurrent(i = 1 : size(A, dim=1), j = 1 : size(B, dim=2))
                C(i,j) = sum(times(A(i,:),B(:,j)))
            end do
        end function
    end template
end module


module poisson3d_test_util

use types, only: dp
use feutils, only: phih, dphih
use fe_mesh, only: cartesian_mesh_3d, define_connect_tensor_3d, &
    c2fullc_3d, fe2quad_3d
use poisson3d_assembly, only: assemble_3d, integral, func2quad, func_xyz
use feutils, only: get_parent_nodes, get_parent_quad_pts_wts
use linalg, only: solve
use isolve, only: solve_cg
use utils, only: assert, zeros
use constants, only: pi
implicit none

contains

subroutine test_poisson(box_dim, Nex, Ney, Nez, p, ibc, fexact, frhs, &
        l2_error_eps, hartree_energy_exact, hartree_energy_eps)
integer, intent(in) :: p, ibc
procedure(func_xyz) :: fexact, frhs
real(dp), intent(in) :: l2_error_eps, hartree_energy_exact, hartree_energy_eps
real(dp), intent(in) :: box_dim(3)

integer :: Nn, Ne
! nodes(:, i) are the (x,y) coordinates of the i-th mesh node
real(dp), allocatable :: nodes(:, :)
integer, allocatable :: elems(:, :) ! elems(:, i) are nodes of the i-th element
integer :: Nq, Nb
real(dp), allocatable :: xin(:), xiq(:), wtq(:), Ax(:), &
        rhs(:), sol(:), &
        fullsol(:), solq(:, :, :, :), wtq3(:, :, :), phihq(:, :), dphihq(:, :),&
        rhsq(:, :, :, :), exactq(:, :, :, :)
integer, allocatable :: in(:, :, :, :), ib(:, :, :, :), Ap(:), Aj(:)
integer :: i, j, k
integer, intent(in) :: Nex, Ney, Nez
real(dp) :: hartree_energy, l2_error, hartree_energy_error, background

call cartesian_mesh_3d(Nex, Ney, Nez, &
    [0._dp, 0._dp, 0._dp], box_dim, nodes, elems)
Nn = size(nodes, 2)
Ne = size(elems, 2)
Nq = p+1

print *, "Number of nodes:", Nn
print *, "Number of elements:", Ne
print *, "Nq =", Nq
print *, "p =", p
allocate(xin(p+1))
call get_parent_nodes(2, p, xin)
allocate(xiq(Nq), wtq(Nq), wtq3(Nq, Nq, Nq))
call get_parent_quad_pts_wts(1, Nq, xiq, wtq)
forall(i=1:Nq, j=1:Nq, k=1:Nq) wtq3(i, j, k) = wtq(i)*wtq(j)*wtq(k)
allocate(phihq(size(xiq), size(xin)))
allocate(dphihq(size(xiq), size(xin)))
! Tabulate parent basis at quadrature points
forall(i=1:size(xiq), j=1:size(xin))  phihq(i, j) =  phih(xin, j, xiq(i))
forall(i=1:size(xiq), j=1:size(xin)) dphihq(i, j) = dphih(xin, j, xiq(i))

call define_connect_tensor_3d(Nex, Ney, Nez, p, 1, in)
call define_connect_tensor_3d(Nex, Ney, Nez, p, ibc, ib)
Nb = maxval(ib)
print *, "DOFs =", Nb
allocate(rhs(Nb), sol(Nb), fullsol(maxval(in)), solq(Nq, Nq, Nq, Ne))
allocate(rhsq(Nq, Nq, Nq, Ne))
allocate(exactq(Nq, Nq, Nq, Ne))

exactq = func2quad(nodes, elems, xiq, fexact)
rhsq = func2quad(nodes, elems, xiq, frhs)
! Make the rhsq net neutral (zero integral):
if (ibc == 3) then
    background = integral(nodes, elems, wtq3, rhsq) / &
        (box_dim(1)*box_dim(2)*box_dim(3))
    print *, "Subtracting constant background: ", background
    rhsq = rhsq - background
end if
call assemble_3d(xin, nodes, elems, ib, xiq, wtq3, phihq, dphihq, 4*pi*rhsq, &
    Ap, Aj, Ax, rhs)
print *, "sum(rhs):    ", sum(rhs)
print *, "integral rhs:", integral(nodes, elems, wtq3, rhsq)
print *, "Solving..."
!sol = solve(A, rhs)
sol = solve_cg(Ap, Aj, Ax, rhs, zeros(size(rhs)), 1e-12_dp, 200)
call c2fullc_3d(in, ib, sol, fullsol)
call fe2quad_3d(elems, xin, xiq, phihq, in, fullsol, solq)
if (ibc == 3) solq = solq + (exactq(1, 1, 1, 1) - solq(1, 1, 1, 1))
l2_error = sqrt(integral(nodes, elems, wtq3, (solq-exactq)**2))
hartree_energy = integral(nodes, elems, wtq3, solq*rhsq) / 2
hartree_energy_error = abs(hartree_energy-hartree_energy_exact)
print "(' L2 Error:',es10.2)", l2_error
print *, "Hartree Energy (calculated):", hartree_energy
print *, "Hartree Energy (exact):     ", hartree_energy_exact
print "(' Hartree Energy (error):',es10.2)", hartree_energy_error
call assert(l2_error < l2_error_eps)
call assert(hartree_energy_error < hartree_energy_eps)
end subroutine

end module

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

program test_poisson3d
use types, only: dp
use poisson3d_test_util, only: test_poisson
use constants, only: pi
implicit none

call test_poisson([1._dp, 1._dp, 1._dp], 1, 1, 1, 8, 2, sol, rhs, &
    1e-7_dp, 3*pi/64, 1e-11_dp)
call test_poisson([1._dp, 1._dp, 1._dp], 2, 3, 5, 5, 2, sol, rhs, &
    1e-5_dp, 3*pi/64, 1e-7_dp)

call test_poisson([2._dp, 3._dp, 5._dp], 2, 2, 2, 8, 2, sol, rhs, &
    1e-2_dp, 45*pi/32, 1e-3_dp)

call test_poisson([2._dp, 3._dp, 5._dp], 2, 3, 5, 6, 2, sol, rhs, &
    1e-4_dp, 45*pi/32, 1e-5_dp)

call test_poisson([2._dp, 2._dp, 2._dp], 2, 3, 5, 6, 3, sol, rhs, &
    2e-5_dp, 3*pi/8, 5e-7_dp)

call test_poisson([2._dp, 2._dp, 2._dp], 2, 3, 5, 6, 3, sol2, rhs2, &
    2e-4_dp, 3*pi/8, 5e-6_dp)

call test_poisson([2._dp, 2._dp, 2._dp], 2, 2, 2, 4, 3, sol3, rhs3, &
    5e-13_dp, 128/(35*pi), 1e-14_dp)

! The analytic solution of the Hartree integral: 1152/(35*pi)
!   http://nbviewer.ipython.org/5506706
! Which is also equal to the numerical integral using sol4*rhs4.
! However, if the actual numerical solution is used (which does not agree with
! sol4), the Hartree integral is 44/9 larger.
call test_poisson([2._dp, 4._dp, 2._dp], 1, 1, 1, 4, 3, sol4, rhs4, &
    40._dp, 1152/(35*pi) * 44/9, 5e-12_dp)

contains

real(dp) function rhs(x, y, z) result(r)
real(dp), intent(in) :: x, y, z
r = 3._dp/4 * pi * sin(pi*x) * sin(pi*y) * sin(pi*z)
end function

real(dp) function sol(x, y, z) result(r)
real(dp), intent(in) :: x, y, z
r = sin(pi*x) * sin(pi*y) * sin(pi*z)
end function

real(dp) function rhs2(x, y, z) result(r)
real(dp), intent(in) :: x, y, z
r = 3._dp/4 * pi * sin(pi*(x+0.5_dp)) * sin(pi*(y+0.5_dp)) * sin(pi*(z+0.5_dp))
end function

real(dp) function sol2(x, y, z) result(r)
real(dp), intent(in) :: x, y, z
r = sin(pi*(x+0.5_dp)) * sin(pi*(y+0.5_dp)) * sin(pi*(z+0.5_dp))
end function

real(dp) function rhs3(x, y, z) result(r)
real(dp), intent(in) :: x, y, z
r = 3 * ((x-1)**2 + (y-1)**2 + (z-1)**2 - 1) / pi
end function

real(dp) function sol3(x, y, z) result(r)
real(dp), intent(in) :: x, y, z
r = -((x-1)**4 + (y-1)**4 + (z-1)**4) + 2*((x-1)**2 + (y-1)**2 + (z-1)**2)
end function

real(dp) function rhs4(x, y, z) result(r)
real(dp), intent(in) :: x, y, z
r = 3*((x-1)**2 + (y-2)**2 + (z-1)**2 - 2) / pi
end function

real(dp) function sol4(x, y, z) result(r)
real(dp), intent(in) :: x, y, z
r = -((x-1)**4 + (y-2)**4 + (z-1)**4) + 4*((x-1)**2 + (y-2)**2 + (z-1)**2)
end function

end program


!	Estimate the information matrix with the Louis approach.
!	adjust is .true. if the average of grads is to be subtracted.
!	grads is the array of observation gradients.
!	obsweight contains observation weights.
function information(adjust,grads,obsweight)
implicit none
!
interface
	subroutine makesym(matrix)
!	Symmetrize n by n matrix based on lower triangle.
		real(kind=8),intent(inout)::matrix(:,:)
	end subroutine makesym
end interface

logical,intent(in)::adjust
real(kind=8),intent(in)::grads(:,:),obsweight(:)
real(kind=8)::information(size(grads,1),size(grads,1))
!	avegrad is the average  gradient and diff is the deviation between the gradient and
!	the average gradient.
real(kind=8)::avegrad(size(grads,1)),diff(size(grads,1))
!	col is a column number.
!	obs is an observation counter.
!	row is a row  number.
integer::col,obs,row
if(adjust)then
	avegrad=0.0_8
	do obs=1,size(obsweight)
		if(obsweight(obs)<=0.0_8)cycle
		do row=1,size(grads,1)
			if(grads(row,obs)/=0.0_8)avegrad(row)=avegrad(row)+obsweight(obs)*grads(row,obs)
		end do
	end do
	avegrad=avegrad/sum(obsweight)
end if
information=0.0_8
do obs=1,size(obsweight)
	if(obsweight(obs)<=0.0_8) cycle
	do row=1,size(grads,1)
		diff(row)=grads(row,obs)
		if(adjust)diff(row)=diff(row)-avegrad(row)
		if(diff(row)/=0.0_8)then
			do col=1,row
				if(diff(col)/=0.0_8)information(row,col)=information(row,col)+obsweight(obs)*diff(row)*diff(col)
			end do
		end if
	end do
end do
call makesym(information)
return
end


!
MODULE quadrature_mod
  !
  ! Quadrature rules.
  !
  USE IntrinsicTypesModule, RK=>REAL_KIND
  !
  IMPLICIT NONE
  !
  ! 10-node tetrahedraon 15 integration points
  ! 6-node triangle 7 integration points
  INTEGER :: iqpt_1, iqpt_2, iqpt_3
  INTEGER, PARAMETER :: nqpt = 15
  INTEGER, PARAMETER :: nqpt1 = nqpt - 1
  INTEGER, PARAMETER, PRIVATE :: MAX_Q=nqpt1
  INTEGER, PARAMETER :: MAXQP3D=nqpt, MAXQP2D=7, NDIM3=3, NDIM2=2
  INTEGER :: nqp3d=MAXQP3D, nqp2d=MAXQP2D
  REAL(RK) :: qploc(0:2, 0:MAX_Q)
  REAL(RK) :: wtqp (0:2, 0:MAX_Q)
!
  REAL(RK) :: qp3d(NDIM3, MAXQP3D), qp2d(NDIM2, MAXQP2D)
  REAL(RK) :: wt3d(MAXQP3D), wt2d(MAXQP2D)

CONTAINS
  !
  SUBROUTINE initialize()
    !
    !     Set up quadrature rule.
    !
    !----------------------------------------------------------------------
    !
    IMPLICIT NONE
    !
    !     Arguments:
    !
    !     *NONE*
    !
    !     Locals:
    !
    INTEGER i, j, k
    !
    !----------------------------------------------------------------------
    !

! ** 10-noded tetrahedral element **
    ! excerpt from Nathan's code
    ! ---
    ! quadrature point
    !
    ! Rule from P. Keast, "Moderate-Degree Tetrahedral
    ! Quadrature Formulas", Computer Meth. Appl. Mechanics Eng. 55
    ! (1986), pp 339-348.
    !
    ! original coding -- D.Mika
    !
    ! Integrates 5th order polynomial exactly on tetrahedron
    !
    !

    qploc(0,0) =  0.333333333333333333d0
    qploc(0,1) =  0.333333333333333333d0
    qploc(0,2) =  0.333333333333333333d0
    qploc(0,3) =  0.0d0
    qploc(0,4) =  0.25d0
    qploc(0,5) =  0.909090909090909091d-1
    qploc(0,6) =  0.909090909090909091d-1
    qploc(0,7) =  0.909090909090909091d-1
    qploc(0,8) =  0.727272727272727273d0
    qploc(0,9) =  0.665501535736642813d-1
    qploc(0,10) = 0.665501535736642813d-1
    qploc(0,11) = 0.665501535736642813d-1
    qploc(0,12) = 0.433449846426335728d0
    qploc(0,13) = 0.433449846426335728d0
    qploc(0,14) = 0.433449846426335728d0

    qploc(1,0) =  0.333333333333333333d0
    qploc(1,1) =  0.333333333333333333d0
    qploc(1,2) =  0.0d0
    qploc(1,3) =  0.333333333333333333d0
    qploc(1,4) =  0.25d0
    qploc(1,5) =  0.909090909090909091d-1
    qploc(1,6) =  0.909090909090909091d-1
    qploc(1,7) =  0.727272727272727273d0
    qploc(1,8) =  0.909090909090909091d-1
    qploc(1,9) =  0.665501535736642813d-1
    qploc(1,10) = 0.433449846426335728d0
    qploc(1,11) = 0.433449846426335728d0
    qploc(1,12) = 0.665501535736642813d-1
    qploc(1,13) = 0.665501535736642813d-1
    qploc(1,14) = 0.433449846426335728d0

    qploc(2,0) =  0.333333333333333333d0
    qploc(2,1) =  0.0d0
    qploc(2,2) =  0.333333333333333333d0
    qploc(2,3) =  0.333333333333333333d0
    qploc(2,4) =  0.25d0
    qploc(2,5) =  0.909090909090909091d-1
    qploc(2,6) =  0.727272727272727273d0
    qploc(2,7) =  0.909090909090909091d-1
    qploc(2,8) =  0.909090909090909091d-1
    qploc(2,9) =  0.433449846426335728d0
    qploc(2,10) = 0.665501535736642813d-1
    qploc(2,11) = 0.433449846426335728d0
    qploc(2,12) = 0.665501535736642813d-1
    qploc(2,13) = 0.433449846426335728d0
    qploc(2,14) = 0.665501535736642813d-1

    ! weights

    wtqp(0,0:3)   = 0.602678571428571597d-2
    wtqp(0,4)     = 0.302836780970891856d-1
    wtqp(0,5:8)   = 0.116452490860289742d-1
    wtqp(0,9:14)  = 0.109491415613864534d-1

! ** 6-noded triangular element **

    ! quadrature points

    qp2d(1,1)=0.33333333333333d0
    qp2d(1,2)=0.05971587178977d0
    qp2d(1,3)=0.47014206410512d0
    qp2d(1,4)=0.47014206410512d0
    qp2d(1,5)=0.79742698535309d0
    qp2d(1,6)=0.10128650732346d0
    qp2d(1,7)=0.10128650732346d0

    qp2d(2,1)=0.33333333333333d0
    qp2d(2,2)=0.47014206410512d0
    qp2d(2,3)=0.05971587178977d0
    qp2d(2,4)=0.47014206410512d0
    qp2d(2,5)=0.10128650732346d0
    qp2d(2,6)=0.79742698535309d0
    qp2d(2,7)=0.10128650732346d0

    ! weight

    wt2d(1) = 0.1125d0
    wt2d(2) = 0.06619707639425d0
    wt2d(3) = 0.06619707639425d0
    wt2d(4) = 0.06619707639425d0
    wt2d(5) = 0.06296959027241d0
    wt2d(6) = 0.06296959027241d0
    wt2d(7) = 0.06296959027241d0

  END SUBROUTINE initialize
  !
  !**********************************************************************
  !
END MODULE quadrature_mod
!


      SUBROUTINE MB01OD( UPLO, TRANS, N, ALPHA, BETA, R, LDR, H, LDH,
     $                   X, LDX, E, LDE, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix formula
C
C       R := alpha*R + beta*( op( H )*X*op( E )' + op( E )*X*op( H )' ),
C
C     where alpha and beta are scalars, R and X are symmetric matrices,
C     H is an upper Hessenberg matrix, E is an upper triangular matrix,
C     and op( M ) is one of
C
C       op( M ) = M   or   op( M ) = M'.
C
C     The result is overwritten on R.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which triangles of the symmetric matrices R
C             and X are given as follows:
C             = 'U':  the upper triangular part is given;
C             = 'L':  the lower triangular part is given.
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( M ) to be used in the matrix
C             multiplication as follows:
C             = 'N':  op( M ) = M;
C             = 'T':  op( M ) = M';
C             = 'C':  op( M ) = M'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices R, H, E, and X.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then R need not be
C             set before entry, except when R is identified with X in
C             the call.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then H and X are not
C             referenced.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
C             On entry with UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix R.
C             On entry with UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix R.
C             In both cases, the other strictly triangular part is not
C             referenced.
C             On exit, the leading N-by-N upper triangular part (if
C             UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
C             this array contains the corresponding triangular part of
C             the computed matrix R.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,N)
C             On entry, the leading N-by-N upper Hessenberg part of this
C             array must contain the upper Hessenberg matrix H.
C             If TRANS = 'N', the entries 3, 4,..., N of the first
C             column are modified internally, but are restored on exit.
C             The remaining part of this array is not referenced.
C
C     LDH     INTEGER
C             The leading dimension of array H.  LDH >= MAX(1,N).
C
C     X       (input) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix X and the strictly
C             lower triangular part of the array is not referenced.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix X and the strictly
C             upper triangular part of the array is not referenced.
C             The diagonal elements of this array are modified
C             internally, but are restored on exit.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= MAX(1,N).
C
C     E       (input) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N upper triangular part of this
C             array must contain the upper triangular matrix E.
C             The remaining part of this array is not referenced.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             This array is not referenced when beta = 0, or N = 0.
C
C     LDWORK  The length of the array DWORK.
C             LDWORK >= N*N, if  beta <> 0;
C             LDWORK >= 0,   if  beta =  0.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -k, the k-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expression is efficiently evaluated taking the symmetry
C     into account. Specifically, let X = U + L, with U and L upper and
C     lower triangular matrices, defined by
C
C        U = triu( X ) - (1/2)*diag( X ),
C        L = tril( X ) - (1/2)*diag( X ),
C
C     where triu, tril, and diag denote the upper triangular part, lower
C     triangular part, and diagonal part of X, respectively. Then,
C     if UPLO = 'U',
C
C       H*X*E' + E*X*H' = (H*U)*E' + E*(H*U)' + H*(E*U)' + (E*U)*H',
C                         for TRANS = 'N',
C       H'*X*E + E'*X*H = H'*(U*E) + (U*E)'*H + (U*H)'*E + E'*(U*H),
C                         for TRANS = 'T', or 'C',
C
C     and if UPLO = 'L',
C
C       H*X*E' + E*X*H' = (H*L')*E' + E*(H*L')' + H*(E*L')' + (E*L')*H',
C                         for TRANS = 'N',
C       H'*X*E + E'*X*H = H'*(L'*E) + (L'*E)'*H + (L'*H)'*E + E'*(L'*H),
C                         for TRANS = 'T', or 'C',
C
C     which involve operations like in BLAS 2 and 3 (DTRMV and DSYR2K).
C     This approach ensures that the matrices H*U, U*H, H*L', or L'*H
C     are upper Hessenberg, and E*U, U*E, E*L', or L'*E are upper
C     triangular.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately N**3/2 operations.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2019.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO, HALF
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                  HALF = 0.5D0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANS, UPLO
      INTEGER           INFO, LDE, LDH, LDR, LDWORK, LDX, N
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), E(LDE,*), H(LDH,*), R(LDR,*), X(LDX,*)
C     .. Local Scalars ..
      LOGICAL           LTRANS, LUPLO
      INTEGER           I, J, J1
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DLASCL, DLASET, DSCAL, DTRMV,
     $                  MB01OE, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      LUPLO  = LSAME( UPLO,  'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF(      ( .NOT.LUPLO  ).AND.( .NOT.LSAME( UPLO,  'L' ) ) )THEN
         INFO = -1
      ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDH.LT.1 .OR. ( LTRANS .AND. LDH.LT.N ) .OR.
     $                  ( .NOT.LTRANS .AND. LDH.LT.N ) ) THEN
         INFO = -9
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.N*N )
     $     .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.0 ) ) THEN
         INFO = -13
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01OD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
      IF ( BETA.EQ.ZERO ) THEN
         IF ( ALPHA.EQ.ZERO ) THEN
C
C           Special case alpha = 0.
C
            CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR )
         ELSE
C
C           Special case beta = 0.
C
            IF ( ALPHA.NE.ONE )
     $         CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, N, N, R, LDR, INFO )
         END IF
         RETURN
      END IF
C
C     General case: beta <> 0.
C     Compute W = H*U or W = U*H in DWORK, and apply the corresponding
C     updating formula (see METHOD section).
C     Workspace: need N*N.
C
      CALL DSCAL( N, HALF, X, LDX+1 )
C
      IF ( .NOT.LTRANS ) THEN
C
C        For convenience, swap the subdiagonal entries in H with
C        those in the first column, and finally restore them.
C
         IF ( N.GT.2 )
     $      CALL DSWAP( N-2, H(3,1), 1, H(3,2), LDH+1 )
C
         IF ( LUPLO ) THEN
C
            DO 20 J = 1, N - 1
               J1 = J + 1
               CALL DCOPY( J, X(1,J), 1, DWORK(1+(J-1)*N), 1 )
               CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, H, LDH,
     $                     DWORK(1+(J-1)*N), 1 )
               DO 10 I = 2, J
                  DWORK(I+(J-1)*N) = DWORK(I+(J-1)*N) + H(I,1)*X(I-1,J)
   10          CONTINUE
               DWORK(J1+(J-1)*N) = H(J1,1)*X(J,J)
   20       CONTINUE
C
            CALL DCOPY( N, X(1,N), 1, DWORK(1+(N-1)*N), 1 )
            CALL DTRMV( UPLO, 'NoTran', 'NoDiag', N, H, LDH,
     $                  DWORK(1+(N-1)*N), 1 )
C
            DO 30 I = 2, N
               DWORK(I+(N-1)*N) = DWORK(I+(N-1)*N) + H(I,1)*X(I-1,N)
   30       CONTINUE
C
         ELSE
C
            DO 50 J = 1, N - 1
               J1 = J + 1
               CALL DCOPY( J, X(J,1), LDX, DWORK(1+(J-1)*N), 1 )
               CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', J, H, LDH,
     $                     DWORK(1+(J-1)*N), 1 )
               DO 40 I = 2, J
                  DWORK(I+(J-1)*N) = DWORK(I+(J-1)*N) + H(I,1)*X(J,I-1)
   40          CONTINUE
               DWORK(J1+(J-1)*N) = H(J1,1)*X(J,J)
   50       CONTINUE
C
            CALL DCOPY( N, X(N,1), LDX, DWORK(1+(N-1)*N), 1 )
            CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', N, H, LDH,
     $                  DWORK(1+(N-1)*N), 1 )
C
            DO 60 I = 2, N
               DWORK(I+(N-1)*N) = DWORK(I+(N-1)*N) + H(I,1)*X(N,I-1)
   60       CONTINUE
C
         END IF
C
         IF ( N.GT.2 )
     $      CALL DSWAP( N-2, H(3,1), 1, H(3,2), LDH+1 )
C
      ELSE
C
         IF ( LUPLO ) THEN
C
            DO 70 J = 1, N - 1
               J1 = J + 1
               CALL DCOPY( J, H(1,J), 1, DWORK(1+(J-1)*N), 1 )
               CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, X, LDX,
     $                     DWORK(1+(J-1)*N), 1 )
               CALL DAXPY( J, H(J1,J), X(1,J1), 1, DWORK(1+(J-1)*N), 1 )
               DWORK(J1+(J-1)*N) = H(J1,J)*X(J1,J1)
   70       CONTINUE
C
            CALL DCOPY( N, H(1,N), 1, DWORK(1+(N-1)*N), 1 )
            CALL DTRMV( UPLO, 'NoTran', 'NoDiag', N, X, LDX,
     $                  DWORK(1+(N-1)*N), 1 )
C
         ELSE
C
            DO 80 J = 1, N - 1
               J1 = J + 1
               CALL DCOPY( J, H(1,J), 1, DWORK(1+(J-1)*N), 1 )
               CALL DTRMV( UPLO, 'Tran', 'NoDiag', J, X, LDX,
     $                     DWORK(1+(J-1)*N), 1 )
               CALL DAXPY( J, H(J1,J), X(J1,1), LDX, DWORK(1+(J-1)*N),
     $                     1 )
               DWORK(J1+(J-1)*N) = H(J1,J)*X(J1,J1)
   80       CONTINUE
C
            CALL DCOPY( N, H(1,N), 1, DWORK(1+(N-1)*N), 1 )
            CALL DTRMV( UPLO, 'Tran', 'NoDiag', N, X, LDX,
     $                  DWORK(1+(N-1)*N), 1 )
C
         END IF
C
      END IF
C
      CALL MB01OE( UPLO, TRANS, N, ALPHA, BETA, R, LDR, DWORK, N, E,
     $             LDE )
C
C     Compute W = E*U or W = U*E in DWORK, and apply the corresponding
C     updating formula (see METHOD section).
C     Workspace: need N*N.
C
      IF ( .NOT.LTRANS ) THEN
C
         IF ( LUPLO ) THEN
C
            DO 90 J = 1, N
               CALL DCOPY( J, X(1,J), 1, DWORK(1+(J-1)*N), 1 )
               CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, E, LDE,
     $                     DWORK(1+(J-1)*N), 1 )
   90       CONTINUE
C
         ELSE
C
            DO 100 J = 1, N
               CALL DCOPY( J, X(J,1), LDX, DWORK(1+(J-1)*N), 1 )
               CALL DTRMV( 'Upper', 'NoTran', 'NoDiag', J, E, LDE,
     $                     DWORK(1+(J-1)*N), 1 )
  100       CONTINUE
C
         END IF
C
      ELSE
C
         IF ( LUPLO ) THEN
C
            DO 110 J = 1, N
               CALL DCOPY( J, E(1,J), 1, DWORK(1+(J-1)*N), 1 )
               CALL DTRMV( UPLO, 'NoTran', 'NoDiag', J, X, LDX,
     $                     DWORK(1+(J-1)*N), 1 )
  110       CONTINUE
C
         ELSE
C
            DO 120 J = 1, N
               CALL DCOPY( J, E(1,J), 1, DWORK(1+(J-1)*N), 1 )
               CALL DTRMV( UPLO, 'Tran', 'NoDiag', J, X, LDX,
     $                     DWORK(1+(J-1)*N), 1 )
  120       CONTINUE
C
         END IF
C
      END IF
C
      CALL MB01OE( UPLO, TRANS, N, ONE, BETA, R, LDR, H, LDH, DWORK,
     $             N )
C
      CALL DSCAL( N, TWO, X, LDX+1 )
C
      RETURN
C *** Last line of MB01OD ***
      END


!  calculate mean of n numbers
PROGRAM calculate_mean
  IMPLICIT none

  REAL :: value, total, mean
  INTEGER :: i, n

  total=0

  WRITE(6,*)  ' This program evaluates the mean of the data set '
  WRITE(6,*)  ' of n real numbers '
  WRITE(6,*)  '  '
  WRITE(6,*)  ' Enter the value of n'
  READ(5,*)n

  DO i=1,n
    WRITE(6,*) ' Enter value number',i
    READ(5,*) value
    total = total+value
    mean= total/i
    WRITE(6,*) ' i= ',i,' The mean is',mean
   END DO

 END PROGRAM calculate_mean


!==========================================================================
elemental function gsw_pressure_coefficient_ice (t, p)
!==========================================================================
!
!  Calculates pressure coefficient of ice.
!
!  t  =  in-situ temperature (ITS-90)                             [ deg C ]
!  p  =  sea pressure                                              [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  pressure_coefficient_ice  =  pressure coefficient of ice          [Pa/K]
!   Note. The output units are Pa/K NOT dbar/K.
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_gibbs_ice

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: t, p

real (r8) :: gsw_pressure_coefficient_ice

gsw_pressure_coefficient_ice = -gsw_gibbs_ice(1,1,t,p)/gsw_gibbs_ice(0,2,t,p)

return
end function

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


program complex2
complex :: x
x = (3.0, 4.0)
x = x - 4.0
x = 4.0 - x
print *, x
x = 2 - x
print *, x
x = (x - (0.0, 3.0))
print *, x
end program


c     ============================================
      subroutine setaux(mbc,mx,xlower,dx,maux,aux)
c     ============================================
c
c     # set auxiliary arrays
c     # variable coefficient acoustics
c     #  aux(i,1) = impedance Z in i'th cell
c     #  aux(i,2) = sound speed c in i'th cell
c
c     # Piecewise constant medium with single interface at x=0
c     # Density and sound speed to left and right are set in setprob.f
c
      implicit none

      integer, intent(in) :: mbc, mx, maux
      double precision, intent(in) :: xlower, dx
      double precision, intent(out) :: aux
      dimension aux(maux, 1-mbc:mx+mbc)

      common /comaux/ Zl, cl, Zr, cr
      double precision Zl, cl, Zr, cr

      integer i
      double precision xcell

      do i=1-mbc,mx+mbc
         xcell = xlower + (i-0.5d0)*dx
         if (xcell .lt. 0.0d0) then
            aux(1,i) = Zl
            aux(2,i) = cl
         else
            aux(1,i) = Zr
            aux(2,i) = cr
         endif
      enddo

      return
      end


program cfd

  use boundary
  use jacobi
  use cfdio

  use omp_lib

  implicit none

! Output frequency

  integer, parameter :: printfreq = 1000

! Variables associated with convergence

  double precision :: error, bnorm

! Set tolerance for convergence; zero or negative means do not check

  double precision, parameter :: tolerance = 0.0d0

! Main arrays

  double precision, allocatable ::  psi(:,:), zet(:,:)
  double precision, allocatable ::  psitmp(:,:), zettmp(:,:)

! Command-line arguments

  integer :: scalefactor,  numiter

  double precision :: re  ! re = 3.7 seems to be stability limit with Jacobi

  integer, parameter :: maxline = 32
  character(len=maxline) :: tmparg

!  Basic sizes of simulation

  integer, parameter :: bbase = 10
  integer, parameter :: hbase = 15
  integer, parameter :: wbase =  5
  integer, parameter :: mbase = 32
  integer, parameter :: nbase = 32

  logical :: irrotational = .true., checkerr = .false.

!  Some auxiliary parameters and variables

  integer :: m, n, b, h, w
  integer :: iter

  integer :: nthread

  double precision :: tstart, tstop, ttot, titer, modvsq, hue

!  Are we stopping based on tolerance?

  if (tolerance .gt. 0.0) checkerr = .true.

!  Parallel initialisation

!  Read in parameters

  if (command_argument_count() /= 2 .and. command_argument_count() /= 3) then

     write(*,*) 'Usage: cfd <scale> <numiter> [reynolds]'
     stop

  end if

  call get_command_argument(1, tmparg)
  read(tmparg,*) scalefactor
  call get_command_argument(2, tmparg)
  read(tmparg,*) numiter

  if (command_argument_count() == 3) then

     irrotational = .false.
     call get_command_argument(3, tmparg)
     read(tmparg,*) re

  else

     re = -1.0

  end if

  if (.not. checkerr) then
     write(*,fmt='('' Scale factor = '',i3,'', iterations = '', i6)') &
           scalefactor, numiter
  else
     write(*,fmt='('' Scale factor = '',i3,'', iterations = '', i6, &
          &'', tolerance = '', g11.4)') scalefactor, numiter, tolerance
  end if

  if (irrotational) then

     write(*,*) 'Irrotational flow'

  else

     write(*,fmt='('' Reynolds number = '', f6.3)') re

  end if

!  Calculate b, h & w and m & n

  b = bbase*scalefactor
  h = hbase*scalefactor
  w = wbase*scalefactor
  m = mbase*scalefactor
  n = nbase*scalefactor

  re = re / dble(scalefactor)

  nthread = omp_get_max_threads()

  write(*,fmt='('' Running CFD on '', i4, '' x '', i4, '' grid using '', &
                  &i4, '' thread(s)'')') m, n, nthread

!  Allocate arrays, including halos on psi and tmp

  allocate(psi(0:m+1, 0:n+1))
  allocate(zet(0:m+1, 0:n+1))

  allocate(psitmp(0:m+1, 0:n+1))

  if (.not. irrotational) then

     allocate(zettmp(0:m+1, 0:n+1))

  end if

!  Zero the psi array

  psi(:,:) = 0.0
  zet(:,:) = 0.0

!  Set the psi boundary condtions which are constant

   call boundarypsi(psi, m, n, b, h, w)

!  Compute normalisation factor for error

   bnorm = sum(psi(:,:)**2)

   if (.not. irrotational) then

!    Update the zeta boundary condtions which depend on psi

     call boundaryzet(zet, psi, m, n)

!    Update the normalisation

     bnorm = bnorm + sum(zet(:,:)**2)

  end if

   bnorm = sqrt(bnorm)

!  Begin iterative Jacobi loop

   write(*,*)
   write(*,*) 'Starting main loop ...'
   write(*,*)

   tstart = gettime()

  do iter = 1, numiter

!  Compute the new psi based on the old one

     if (irrotational) then

!  Call function with no vorticity

        call jacobistep(psitmp, psi, m, n)

     else

!  Call function containing vorticity

        call jacobistepvort(zettmp, psitmp, zet, psi, m, n, re)

     end if

!  Compute current error value if required

     if (checkerr .or. iter == numiter) then

        error = deltasq(psitmp, psi, m, n)

        if (.not. irrotational) then

           error = error + deltasq(zettmp, zet, m, n)

        end if

        error = sqrt(error)

        error = error / bnorm

     end if

!  Copy back

!$omp parallel workshare
     psi(1:m, 1:n) = psitmp(1:m, 1:n)
!$omp end parallel workshare

     if (.not. irrotational) then

!$omp parallel workshare
        zet(1:m, 1:n) = zettmp(1:m, 1:n)
!$omp end parallel workshare

     end if

     if (.not. irrotational) then

!    Update the zeta boundary condtions which depend on psi

        call boundaryzet(zet, psi, m, n)

     end if

!  Quit early if we have reached required tolerance

     if (checkerr) then
        if (error .lt. tolerance) then
           write(*,*) 'CONVERGED iteration ', iter, ': terminating'
           exit
        end if
     end if

!  End iterative Jacobi loop

     if (mod(iter,printfreq) == 0) then

        if (.not. checkerr) then
           write(*,*) 'completed iteration ', iter
        else
           write(*,*) 'completed iteration ', iter, ', error = ', error
        end if

     end if

  end do

  if (iter .gt. numiter) iter = numiter

  tstop = gettime()

  ttot  = tstop-tstart
  titer = ttot/dble(iter)

  write(*,*)
  write(*,*) '... finished'
  write(*,*)
  write(*,fmt='('' After    '', i6, '' iterations, error is '', g11.4)') &
        iter, error
  write(*,fmt='('' Time for '', i6, '' iterations was '',&
        &g11.4, '' seconds'')') iter, ttot
  write(*,fmt='('' Each individual iteration took '', g11.4, '' seconds'')') &
        titer
  write(*,*)
  write(*,*) 'Writing output file ...'

!  Output results

  call writedatafiles(psi, m, n, scalefactor)

!  Output gnuplot file

  call writeplotfile(m, n, scalefactor)

! Finish

  write(*,*) ' ... finished'
  write(*,*)
  write(*,*) 'CFD completed'
  write(*,*)

end program cfd


!> tests the projections for a given grid structure
program test_proj

use filesystem, only : mkdir
use phys_consts, only: wp
use meshobj_dipole, only : dipolemesh
use neutral, only : store_geo2native_projections

implicit none (type, external)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer, parameter :: lq=384+4,lp=96+4,lphi=64+4
real(wp), dimension(lq) :: q
real(wp), dimension(lp) :: p
real(wp), dimension(lphi) :: phi
! from tohoku20113D_lowres_3Dneu
real(wp), dimension(2), parameter :: qlims=[-0.5340405,0.5340405]
real(wp), dimension(2), parameter :: plims=[1.2509838,1.4372374]
real(wp), dimension(2), parameter :: philims=[3.6126509,3.7240195]
integer :: iq,ip,iphi, i
real(wp) :: minchkvar,maxchkvar
real(wp), dimension(:,:,:), allocatable :: proj
character(:), allocatable :: path
character(1000) :: argv
type(dipolemesh) :: x
real(wp), dimension(lq,lp,lphi,3) :: ealt,eglat,eglon
real(wp), dimension(3,3,lq,lp,lphi) :: rotmats
real(wp), dimension(3,3) :: matnow,eyetest,eye
real(wp), parameter :: errthresh=1e-6
real(wp) :: eyeerr
logical :: debug=.false.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!! create a dipole grid
q=[(qlims(1) + (qlims(2)-qlims(1))/(lq-1)*(iq-1),iq=1,lq)]
p=[(plims(1) + (plims(2)-plims(1))/(lp-1)*(ip-1),ip=1,lp)]
phi=[(philims(1) + (philims(2)-philims(1))/(lphi-1)*(iphi-1),iphi=1,lphi)]
call x%set_coords(q,p,phi,p,phi)
call x%init()
call x%make()

!! compute the geographic projections
call x%calc_unitvec_geo(ealt,eglon,eglat)
call store_geo2native_projections(x,ealt,eglon,eglat,rotmat=rotmats)

!! verify that the transformation is approximately unitary at all non-ghost grid points
print*, 'Begin testing transformation...'
eye=reshape([1,0,0,0,1,0,0,0,1],[3, 3])
do iphi=1,lphi-4
  do ip=1,lp-4
    do iq=1,lq-4
      matnow=rotmats(1:3,1:3,iq,ip,iphi)
      eyetest=matmul(matnow,transpose(matnow))     ! rotations are unitary so R*R.transpose() should be identity...
      eyeerr=sum(abs(eyetest-eye))                 ! aggregate error evaluation
      if (debug) call printmats()
      if (eyeerr > errthresh) then
        print*, 'Excessive deviation from unitary:  ',eyeerr
        print*, '  at grid indices:  ',iq,ip,iphi
        print*, '-------------------------------------------------------'
        call printmats()
        error stop
      end if
    end do
  end do
end do
print*, 'Transformation tests complete successfully...'

contains
  subroutine printmats()
    print*, eye(1,1:3)
    print*, eye(2,1:3)
    print*, eye(3,1:3)
    print*, '-------------------------------------------------------'
    print*, eyetest(1,1:3)
    print*, eyetest(2,1:3)
    print*, eyetest(3,1:3)
    print*, '-------------------------------------------------------'
  end subroutine printmats
end program test_proj


module mod_mean

use mod_math, only: divide, add

implicit none

public :: mean
private

contains

subroutine mean(a,b)
  real(8),dimension(:),intent(inout) :: a
  real(8),intent(inout) :: b

  real(8) :: temp

  real(8) :: n
  integer(8) :: i

  n = real(size(a),8)

  b = 0.0
  do i = 1,int(n)
    call add(b,a(i),temp)
    b = temp
  enddo

  call divide(b,n,temp)
  b = temp

end subroutine mean
end module mod_mean