    MODULE blas_dense_mat_vec_op

      ! Fortran 95 Bindings Generic Interface Blocks
      ! .  for section 2.8.6 -- Matrix-Vector Operations
      ! .  using external procedures.
      ! Written on 14 December 2000
      ! .  Zohair Maany and Sven Hammarling, NAG Central Office.

      PRIVATE
      PUBLIC :: gbmv, sbmv, spmv, hbmv, hpmv, tbmv, tpmv, ge_sum_mv, gemvt, &
       trmvt, gemver, tbsv, tpsv, spr, hpr, spr2, hpr2

      INTERFACE gbmv
        ! m is not needed as an argument
        ! if trans = blas_no_trans then
        ! . x has shape (n)
        ! . y has shape (m)
        ! . a has shape (kl+ku+1,n), SIZE(a,1) > kl
        ! if trans =/ blas_no_trans then
        ! . x has shape (m)
        ! . y has shape (n)
        ! . a has shape (kl+ku+1,m), SIZE(a,1) > kl
        SUBROUTINE gbmv_d(a,m,kl,x,y,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), x(:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp), INTENT (INOUT) :: y(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE gbmv_d
        SUBROUTINE gbmv_z(a,m,kl,x,y,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), x(:)
          INTEGER, INTENT (IN) :: m, kl
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE gbmv_z
        SUBROUTINE gbmv_s(a,m,kl,x,y,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), x(:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp), INTENT (INOUT) :: y(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE gbmv_s
        SUBROUTINE gbmv_c(a,m,kl,x,y,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), x(:)
          INTEGER, INTENT (IN) :: m, kl
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE gbmv_c
      END INTERFACE

      INTERFACE sbmv
        ! x and y have shape (n)
        ! a has shape (k+1,n), (k=band width = SIZE(a,1)-1)
        SUBROUTINE sbmv_d(a,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), x(:)
          REAL (wp), INTENT (INOUT) :: y(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sbmv_d
        SUBROUTINE sbmv_z(a,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), x(:)
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sbmv_z
        SUBROUTINE sbmv_s(a,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), x(:)
          REAL (wp), INTENT (INOUT) :: y(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sbmv_s
        SUBROUTINE sbmv_c(a,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), x(:)
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sbmv_c
      END INTERFACE

      INTERFACE spmv
        ! x and y have shape (n)
        ! ap has shape ((n+1)*n/2)
        SUBROUTINE spmv_d(ap,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: ap(:), x(:)
          REAL (wp), INTENT (INOUT) :: y(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE spmv_d
        SUBROUTINE spmv_z(ap,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:), x(:)
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE spmv_z
        SUBROUTINE spmv_s(ap,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: ap(:), x(:)
          REAL (wp), INTENT (INOUT) :: y(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE spmv_s
        SUBROUTINE spmv_c(ap,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:), x(:)
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE spmv_c
      END INTERFACE

      INTERFACE hbmv
        ! x and y have shape (n)
        ! a has shape (k+1,n), (k=band width = SIZE(a,1)-1)
        SUBROUTINE hbmv_z(a,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), x(:)
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hbmv_z
        SUBROUTINE hbmv_c(a,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), x(:)
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hbmv_c
      END INTERFACE

      INTERFACE hpmv
        ! x and y have shape (n)
        ! ap has shape ((n+1)*n/2)
        SUBROUTINE hpmv_z(ap,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:), x(:)
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hpmv_z
        SUBROUTINE hpmv_c(ap,x,y,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:), x(:)
          COMPLEX (wp), INTENT (INOUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hpmv_c
      END INTERFACE

      INTERFACE tbmv
        ! x has shape (n)
        ! t has shape (k+1,n), (k=band width = SIZE(t,1)-1)
        SUBROUTINE tbmv_d(t,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: x(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tbmv_d
        SUBROUTINE tbmv_z(t,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: x(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tbmv_z
        SUBROUTINE tbmv_s(t,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: x(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tbmv_s
        SUBROUTINE tbmv_c(t,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: x(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tbmv_c
      END INTERFACE

      INTERFACE tpmv
        ! x has shape (n)
        ! tp has shape ((n+1)*n/2)
        SUBROUTINE tpmv_d(tp,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: tp(:)
          REAL (wp), INTENT (INOUT) :: x(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tpmv_d
        SUBROUTINE tpmv_z(tp,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: tp(:)
          COMPLEX (wp), INTENT (INOUT) :: x(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tpmv_z
        SUBROUTINE tpmv_s(tp,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: tp(:)
          REAL (wp), INTENT (INOUT) :: x(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tpmv_s
        SUBROUTINE tpmv_c(tp,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: tp(:)
          COMPLEX (wp), INTENT (INOUT) :: x(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tpmv_c
      END INTERFACE

      INTERFACE ge_sum_mv
        ! x has shape (n)
        ! y has shape (m)
        ! a and b have shape (m,n)
        SUBROUTINE ge_sum_mv_d(a,x,b,y,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:), x(:)
          REAL (wp), INTENT (OUT) :: y(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ge_sum_mv_d
        SUBROUTINE ge_sum_mv_z(a,x,b,y,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:), x(:)
          COMPLEX (wp), INTENT (OUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ge_sum_mv_z
        SUBROUTINE ge_sum_mv_s(a,x,b,y,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:), x(:)
          REAL (wp), INTENT (OUT) :: y(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ge_sum_mv_s
        SUBROUTINE ge_sum_mv_c(a,x,b,y,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:), x(:)
          COMPLEX (wp), INTENT (OUT) :: y(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ge_sum_mv_c
      END INTERFACE

      INTERFACE gemvt
        ! x and z have shape (n)
        ! y and w have shape (m)
        ! a has shape (m,n)
        SUBROUTINE gemvt_d(a,x,y,w,z,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), y(:), z(:)
          REAL (wp), INTENT (OUT) :: x(:), w(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gemvt_d
        SUBROUTINE gemvt_z(a,x,y,w,z,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), y(:), z(:)
          COMPLEX (wp), INTENT (OUT) :: x(:), w(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gemvt_z
        SUBROUTINE gemvt_s(a,x,y,w,z,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), y(:), z(:)
          REAL (wp), INTENT (OUT) :: x(:), w(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gemvt_s
        SUBROUTINE gemvt_c(a,x,y,w,z,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), y(:), z(:)
          COMPLEX (wp), INTENT (OUT) :: x(:), w(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gemvt_c
      END INTERFACE

      INTERFACE trmvt
        ! w, x, y and z have shape (n)
        ! t has shape (n,n)
        SUBROUTINE trmvt_d(t,x,y,w,z,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: t(:,:), y(:), z(:)
          REAL (wp), INTENT (OUT) :: x(:), w(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE trmvt_d
        SUBROUTINE trmvt_z(t,x,y,w,z,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: t(:,:), y(:), z(:)
          COMPLEX (wp), INTENT (OUT) :: x(:), w(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE trmvt_z
        SUBROUTINE trmvt_s(t,x,y,w,z,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: t(:,:), y(:), z(:)
          REAL (wp), INTENT (OUT) :: x(:), w(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE trmvt_s
        SUBROUTINE trmvt_c(t,x,y,w,z,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: t(:,:), y(:), z(:)
          COMPLEX (wp), INTENT (OUT) :: x(:), w(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE trmvt_c
      END INTERFACE

      INTERFACE gemver
        ! u1, u2, w and y have shape (m)
        ! v1, v2, x and z have shape (n)
        ! a has shape (m,n)
        SUBROUTINE gemver_d(a,u1,v1,u2,v2,x,y,z,w,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: u1(:), u2(:), v1(:), v2(:), y(:), z(:)
          REAL (wp), INTENT (INOUT) :: a(:,:), x(:)
          REAL (wp), INTENT (OUT) :: w(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gemver_d
        SUBROUTINE gemver_z(a,u1,v1,u2,v2,x,y,z,w,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: u1(:), u2(:), v1(:), v2(:), y(:), z(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:), x(:)
          COMPLEX (wp), INTENT (OUT) :: w(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gemver_z
        SUBROUTINE gemver_s(a,u1,v1,u2,v2,x,y,z,w,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: u1(:), u2(:), v1(:), v2(:), y(:), z(:)
          REAL (wp), INTENT (INOUT) :: a(:,:), x(:)
          REAL (wp), INTENT (OUT) :: w(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gemver_s
        SUBROUTINE gemver_c(a,u1,v1,u2,v2,x,y,z,w,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: u1(:), u2(:), v1(:), v2(:), y(:), z(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:), x(:)
          COMPLEX (wp), INTENT (OUT) :: w(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gemver_c
      END INTERFACE

      INTERFACE tbsv
        ! x has shape (n)
        ! t has shape (k+1,n), (k=band width = SIZE(t,1)-1)
        SUBROUTINE tbsv_d(t,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: x(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tbsv_d
        SUBROUTINE tbsv_z(t,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: x(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tbsv_z
        SUBROUTINE tbsv_s(t,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: x(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tbsv_s
        SUBROUTINE tbsv_c(t,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: x(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tbsv_c
      END INTERFACE

      INTERFACE tpsv
        ! x has shape (n)
        ! tp has shape ((n+1)*n/2)
        SUBROUTINE tpsv_d(tp,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: tp(:)
          REAL (wp), INTENT (INOUT) :: x(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tpsv_d
        SUBROUTINE tpsv_z(tp,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: tp(:)
          COMPLEX (wp), INTENT (INOUT) :: x(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tpsv_z
        SUBROUTINE tpsv_s(tp,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: tp(:)
          REAL (wp), INTENT (INOUT) :: x(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tpsv_s
        SUBROUTINE tpsv_c(tp,x,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: tp(:)
          COMPLEX (wp), INTENT (INOUT) :: x(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tpsv_c
      END INTERFACE

      INTERFACE spr
        ! x has shape (n)
        ! ap has shape ((n+1)*n/2)
        SUBROUTINE spr_d(x,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (INOUT) :: ap(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE spr_d
        SUBROUTINE spr_z(x,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE spr_z
        SUBROUTINE spr_s(x,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:)
          REAL (wp), INTENT (INOUT) :: ap(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE spr_s
        SUBROUTINE spr_c(x,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE spr_c
      END INTERFACE

      INTERFACE hpr
        ! x has shape (n)
        ! ap has shape ((n+1)*n/2)
        SUBROUTINE hpr_z(x,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE hpr_z
        SUBROUTINE hpr_c(x,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE hpr_c
      END INTERFACE

      INTERFACE spr2
        ! x and y have shape (n)
        ! ap has shape ((n+1)*n/2)
        SUBROUTINE spr2_d(x,y,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: x(:), y(:)
          REAL (wp), INTENT (INOUT) :: ap(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE spr2_d
        SUBROUTINE spr2_z(x,y,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:), y(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE spr2_z
        SUBROUTINE spr2_s(x,y,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: x(:), y(:)
          REAL (wp), INTENT (INOUT) :: ap(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE spr2_s
        SUBROUTINE spr2_c(x,y,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:), y(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE spr2_c
      END INTERFACE

      INTERFACE hpr2
        ! x and y have shape (n)
        ! ap has shape ((n+1)*n/2)
        SUBROUTINE hpr2_z(x,y,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: x(:), y(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE hpr2_z
        SUBROUTINE hpr2_c(x,y,ap,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: x(:), y(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE hpr2_c
      END INTERFACE
    END MODULE blas_dense_mat_vec_op


SUBROUTINE ComputeNormalVectors(CompGrid,GhostGridX,GhostGridY,GhostGridZ)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def), INTENT(INOUT) :: CompGrid
INTEGER :: i,j,k,GhostGridX,GhostGridY,GhostGridZ, Nxg, Nyg, Nzg
REAL(KIND=long) :: s, ex, ey, nx, ny, hx, hy

Nxg = CompGrid%Nx + 2*GhostGridX
Nyg = CompGrid%Ny + 2*GhostGridY
Nzg = CompGrid%Nz + GhostGridZ

ALLOCATE( CompGrid%CurvilinearStuff%NormalX(Nzg,Nxg,Nyg) )
ALLOCATE( CompGrid%CurvilinearStuff%NormalY(Nzg,Nxg,Nyg) )
ALLOCATE( CompGrid%CurvilinearStuff%NormalZ(Nzg,Nxg,Nyg) )
CompGrid%CurvilinearStuff%NormalX = zero
CompGrid%CurvilinearStuff%NormalY = zero
CompGrid%CurvilinearStuff%NormalZ = zero

IF (CompGrid%Nx>1) THEN
! West boundary
i = 1
DO j = 1+GhostGridY, CompGrid%Ny+GhostGridY ! omit ghost boundary corners
	DO k = 1+GhostGridZ, CompGrid%Nz+GhostGridZ ! omit bottom layer
		ex = CompGrid%CurvilinearStuff%ex(i+1,j)
		ey = CompGrid%CurvilinearStuff%ey(i+1,j)
		s = SQRT(ex**2+ey**2)
		CompGrid%CurvilinearStuff%NormalX(k,i,j) = -ex/s !west
		CompGrid%CurvilinearStuff%NormalY(k,i,j) = -ey/s !west
!		CompGrid%CurvilinearStuff%NormalZ(k,i,j) = zero
	END DO
END DO

! East boundary
i = CompGrid%Nx+2*GhostGridX
DO j = 1+GhostGridY, CompGrid%Ny+GhostGridY ! omit ghost boundary corners
	DO k = 1+GhostGridZ, CompGrid%Nz+GhostGridZ ! omit bottom layer
		ex = CompGrid%CurvilinearStuff%ex(i-1,j)
		ey = CompGrid%CurvilinearStuff%ey(i-1,j)
		s = SQRT(ex**2+ey**2)
		CompGrid%CurvilinearStuff%NormalX(k,i,j) = ex/s !east
		CompGrid%CurvilinearStuff%NormalY(k,i,j) = ey/s !east
!		CompGrid%CurvilinearStuff%NormalZ(k,i,j) = zero
	END DO
END DO
END IF

IF (CompGrid%Ny>1) THEN
! South boundary
j = 1
DO i = 1+GhostGridX, CompGrid%Nx+GhostGridX ! omit ghost boundary corners
	DO k = 1+GhostGridZ, CompGrid%Nz+GhostGridZ ! omit bottom layer
		nx = CompGrid%CurvilinearStuff%nx(i,j+1)
		ny = CompGrid%CurvilinearStuff%ny(i,j+1)
		s = SQRT(nx**2+ny**2)
		CompGrid%CurvilinearStuff%NormalX(k,i,j) = -nx/s !south
		CompGrid%CurvilinearStuff%NormalY(k,i,j) = -ny/s !south
!		CompGrid%CurvilinearStuff%NormalZ(k,i,j) = zero
	END DO
END DO

! North boundary
j = CompGrid%Ny+2*GhostGridY
DO i = 1+GhostGridX, CompGrid%Nx+GhostGridX ! omit ghost boundary corners
	DO k = 1+GhostGridZ, CompGrid%Nz+GhostGridZ ! omit bottom layer
		nx = CompGrid%CurvilinearStuff%nx(i,j-1)
		ny = CompGrid%CurvilinearStuff%ny(i,j-1)
		s = SQRT(nx**2+ny**2)
		CompGrid%CurvilinearStuff%NormalX(k,i,j) = nx/s !north
		CompGrid%CurvilinearStuff%NormalY(k,i,j) = ny/s !north
!		CompGrid%CurvilinearStuff%NormalZ(k,i,j) = zero
	END DO
END DO
END IF

! Down boundary
k = 1
DO i = 1+GhostGridX, CompGrid%Nx+GhostGridX ! omit ghost boundary corners
	DO j = 1+GhostGridY, CompGrid%Ny+GhostGridY ! omit ghost boundary corners
		IF (CompGrid%Nx>1 .AND. CompGrid%Ny>1) THEN
			hx = CompGrid%hx(i,j)
			hy = CompGrid%hy(i,j)
			s = SQRT(hx**2+hy**2+one)
			CompGrid%CurvilinearStuff%NormalX(k,i,j) = -hx/s  !down
			CompGrid%CurvilinearStuff%NormalY(k,i,j) = -hy/s  !down
			CompGrid%CurvilinearStuff%NormalZ(k,i,j) = -one/s !down
		ELSE IF (CompGrid%Nx>1) THEN
			hx = CompGrid%hx(i,j)
			s = SQRT(hx**2+one)
			CompGrid%CurvilinearStuff%NormalX(k,i,j) = -hx/s  !down
			CompGrid%CurvilinearStuff%NormalZ(k,i,j) = -one/s !down
		ELSE IF (CompGrid%Ny>1) THEN
			hy = CompGrid%hy(i,j)
			s = SQRT(hy**2+one)
			CompGrid%CurvilinearStuff%NormalY(k,i,j) = -hy/s  !down
			CompGrid%CurvilinearStuff%NormalZ(k,i,j) = -one/s !down
		ENDIF
	END DO
END DO

! APEK: NOT NEEDED
! Up boundary
!k = CompGrid%Nz + GhostGridZ
!DO i = 1+GhostGridX, CompGrid%Nx+GhostGridX ! omit ghost boundary corners
!	DO j = 1+GhostGridY, CompGrid%Ny+GhostGridY ! omit ghost boundary corners
!		etax = CompGrid%Wavefield_FS%Ex(i,j)
!		etay = CompGrid%Wavefield_FS%Ey(i,j)
!		s = SQRT(etax**2+etay**2)
!		CompGrid%CurvilinearStuff%NormalX(k,i,j) = etax/s  !up
!		CompGrid%CurvilinearStuff%NormalY(k,i,j) = etay/s  !up
!		CompGrid%CurvilinearStuff%NormalZ(k,i,j) = one/s   !up
!	END DO
!END DO

END SUBROUTINE ComputeNormalVectors


      SUBROUTINE JACOBI (A,B,X,EIGV,D,N,NWA,RTOL,NSMAX,IFPR,IOUT)
! ....................................................................
! .
! .   P R O G R A M
! .        TO SOLVE THE GENERALIZED EIGENPROBLEM USING THE
! .        GENERALIZED JACOBI ITERATION
! ....................................................................
!
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: N,NWA,NSMAX,IOUT
      LOGICAL, INTENT(IN) :: IFPR
      REAL(8), INTENT(INOUT) :: A(NWA),B(NWA),X(N,N),EIGV(N),D(N)
      REAL(8), INTENT(IN) :: RTOL
!
      INTEGER :: N1,I,J,K,II,IK,NSWEEP,NR,JP1,JM1,KP1,KM1,JK,KK,LJK,JJ
      INTEGER :: IM1,IJ,JI,KI,LKI,LJI
      REAL(8) :: AK,AKK,AJ,BJ,AJJ,AB,BB,BK,EPS,EPSA,EPSB,EPTOLA,EPTOLB
      REAL(8) :: ABCH,AKKCH,AJJCH,CHECK,SQCH,D1,D2,DEN,CA,CG,DIF,TOL
      REAL(8) :: SCALE,XK,XJ

!
!     INITIALIZE EIGENVALUE AND EIGENVECTOR MATRICES
!
      N1=N + 1
      II=1
!
      DO I=1,N
         IF (A(II).LE.0. .OR. B(II).LE.0.) THEN
            WRITE (IOUT,2020) II,A(II),B(II)
            STOP
         END IF
         D(I)=A(II)/B(II)
         EIGV(I)=D(I)
         II=II + N1 - I
      END DO
!
      DO I=1,N
         DO J=1,N
            X(I,J)=0.
         END DO
         X(I,I)=1.
      END DO
!
      IF (N.EQ.1) RETURN
!
!     INITIALIZE SWEEP COUNTER AND BEGIN ITERATION
!
      NSWEEP=0
      NR=N - 1
!
      DO WHILE (NSWEEP.LT.NSMAX)
         NSWEEP=NSWEEP + 1
         IF (IFPR) WRITE (IOUT,2000) NSWEEP
!
!     CHECK IF PRESENT OFF-DIAGONAL ELEMENT IS LARGE ENOUGH TO REQUIRE
!     ZEROING
!
         EPS=(.01)**(NSWEEP*2)
         DO J=1,NR
            JP1=J + 1
            JM1=J - 1
            LJK=JM1*N - JM1*J/2
            JJ=LJK + J
            DO K=JP1,N
               KP1=K + 1
               KM1=K - 1
               JK=LJK + K
               KK=KM1*N - KM1*K/2 + K
               EPTOLA=(A(JK)/A(JJ))*(A(JK)/A(KK))
               EPTOLB=(B(JK)/B(JJ))*(B(JK)/B(KK))
               IF (EPTOLA.LT.EPS .AND. EPTOLB.LT.EPS) CYCLE
!
!     IF ZEROING IS REQUIRED, CALCULATE THE ROTATION MATRIX ELEMENTS CA
!     AND CG
!
               AKK=A(KK)*B(JK) - B(KK)*A(JK)
               AJJ=A(JJ)*B(JK) - B(JJ)*A(JK)
               AB=A(JJ)*B(KK) - A(KK)*B(JJ)
               SCALE=A(KK)*B(KK)
               ABCH=AB/SCALE
               AKKCH=AKK/SCALE
               AJJCH=AJJ/SCALE
               CHECK=(ABCH*ABCH+4.0*AKKCH*AJJCH)/4.0
               IF (CHECK.LT.0) THEN
                  WRITE (IOUT,2020) JJ,A(JJ),B(JJ)
                  STOP
               END IF
               SQCH=SCALE*SQRT(CHECK)
               D1=AB/2. + SQCH
               D2=AB/2. - SQCH
               DEN=D1
               IF (ABS(D2).GT.ABS(D1)) DEN=D2
               IF (DEN.EQ.0) THEN
                  CA=0.
                  CG=-A(JK)/A(KK)
               ELSE
                  CA=AKK/DEN
                  CG=-AJJ/DEN
               END IF
!
!     PERFORM THE GENERALIZED ROTATION TO ZERO THE PRESENT OFF-DIAGONAL
!     ELEMENT
!
               IF (N-2.NE.0) THEN
                  IF (JM1-1.GE.0) THEN
                     DO I=1,JM1
                        IM1=I - 1
                        IJ=IM1*N - IM1*I/2 + J
                        IK=IM1*N - IM1*I/2 + K
                        AJ=A(IJ)
                        BJ=B(IJ)
                        AK=A(IK)
                        BK=B(IK)
                        A(IJ)=AJ + CG*AK
                        B(IJ)=BJ + CG*BK
                        A(IK)=AK + CA*AJ
                        B(IK)=BK + CA*BJ
                     END DO
                  END IF
                  IF (KP1-N.LE.0) THEN
                     LJI=JM1*N - JM1*J/2
                     LKI=KM1*N - KM1*K/2
                     DO I=KP1,N
                        JI=LJI + I
                        KI=LKI + I
                        AJ=A(JI)
                        BJ=B(JI)
                        AK=A(KI)
                        BK=B(KI)
                        A(JI)=AJ + CG*AK
                        B(JI)=BJ + CG*BK
                        A(KI)=AK + CA*AJ
                        B(KI)=BK + CA*BJ
                     END DO
                  END IF
                  IF (JP1-KM1.LE.0) THEN
                     LJI=JM1*N - JM1*J/2
                     DO I=JP1,KM1
                        JI=LJI + I
                        IM1=I - 1
                        IK=IM1*N - IM1*I/2 + K
                        AJ=A(JI)
                        BJ=B(JI)
                        AK=A(IK)
                        BK=B(IK)
                        A(JI)=AJ + CG*AK
                        B(JI)=BJ + CG*BK
                        A(IK)=AK + CA*AJ
                        B(IK)=BK + CA*BJ
                     END DO
                  END IF
               END IF
               AK=A(KK)
               BK=B(KK)
               A(KK)=AK + 2.*CA*A(JK) + CA*CA*A(JJ)
               B(KK)=BK + 2.*CA*B(JK) + CA*CA*B(JJ)
               A(JJ)=A(JJ) + 2.*CG*A(JK) + CG*CG*AK
               B(JJ)=B(JJ) + 2.*CG*B(JK) + CG*CG*BK
               A(JK)=0.
               B(JK)=0.
!
!     UPDATE THE EIGENVECTOR MATRIX AFTER EACH ROTATION
!
               DO I=1,N
                  XJ=X(I,J)
                  XK=X(I,K)
                  X(I,J)=XJ + CG*XK
                  X(I,K)=XK + CA*XJ
               END DO
            END DO
         END DO
!
!     UPDATE THE EIGENVALUES AFTER EACH SWEEP
!
         II=1
         DO I=1,N
            IF (A(II).LE.0. .OR. B(II).LE.0.) THEN
               WRITE (IOUT,2020) II,A(II),B(II)
               STOP
            END IF
            EIGV(I)=A(II)/B(II)
            II=II + N1 - I
         END DO
         IF (IFPR) THEN
            WRITE (IOUT,2030)
            WRITE (IOUT,2010) (EIGV(I),I=1,N)
         END IF
!
!     CHECK FOR CONVERGENCE
!
         DO I=1,N
            TOL=RTOL*D(I)
            DIF=ABS(EIGV(I)-D(I))
            IF (DIF.GT.TOL) GO TO 280
         END DO
!
!     CHECK ALL OFF-DIAGONAL ELEMENTS TO SEE IF ANOTHER SWEEP IS
!     REQUIRED
!
         EPS=RTOL**2
         DO J=1,NR
            JM1=J - 1
            JP1=J + 1
            LJK=JM1*N - JM1*J/2
            JJ=LJK + J
            DO K=JP1,N
               KM1=K - 1
               JK=LJK + K
               KK=KM1*N - KM1*K/2 + K
               EPSA=(A(JK)/A(JJ))*(A(JK)/A(KK))
               EPSB=(B(JK)/B(JJ))*(B(JK)/B(KK))
               IF (EPSA.GE.EPS .OR. EPSB.GE.EPS) GO TO 280
            END DO
         END DO
!
!     CONVERGENCE REACHED
!
         EXIT
!
!     UPDATE  D  MATRIX AND START NEW SWEEP, IF ALLOWED
!
 280     DO I=1,N
            D(I)=EIGV(I)
         END DO
      END DO
!
!     SCALE EIGENVECTORS
!
      II=1
      DO I=1,N
         BB=SQRT(B(II))
         DO K=1,N
            X(K,I)=X(K,I)/BB
         END DO
         II=II + N1 - I
      END DO
!
      RETURN
!
 2000 FORMAT (//,' SWEEP NUMBER IN *JACOBI* = ',I8)
 2010 FORMAT (' ',6E20.12)
 2020 FORMAT (' *** ERROR *** SOLUTION STOP',/, &
              ' MATRICES NOT POSITIVE DEFINITE',/, &
              ' II = ',I8,' A(II) = ',E20.12,' B(II) = ',E20.12)
 2030 FORMAT (/,' CURRENT EIGENVALUES IN *JACOBI* ARE',/)
      END


Module nescgle
Use math_constants
Use omp_lib
Use scgle
Implicit None

contains

!Subroutine that calculates the alpha vector used for the calculation of
!the S(k,u(t)) structure
Subroutine Calc_alphaSku(k_v,SkF_v,D0_val,alpha_v)
	implicit none
	real * 8, dimension(:), intent(in) :: k_v, SkF_v
	real * 8, dimension(:), intent(out) :: alpha_v
	real * 8, intent (in) :: D0_val
	alpha_v = 2.d0 * (k_v ** 2) * D0_val / SkF_v
End Subroutine

!Subroutine that calculates the structure factor of the system at a given
!u material time through an instantaneous isochoric quench
Function sku_quench(Sk0_v,SkF_v,alpha_v,u_val) result(sku)
	implicit none
	real * 8, dimension(:), intent(in) :: Sk0_v, SkF_v, alpha_v
	real * 8, intent(in) :: u_val
	real * 8, dimension(size(Sk0_v)) :: Sku
	integer :: i1
	If (u_val > 0.d0) Then
		sku = SkF_v + ( Sk0_v - SkF_v ) * exp( - alpha_v * u_val )
	Else
		sku= Sk0_v
	End If
	return
End Function

!Subroutine that calculates the value of the material time u in which a system arrest
!calculated up to a max value of u and gamma when an instantaneous isochoric quench
!is applied to the system
Function calc_ua_isoch_inst_quench(Sk0,SkF,alpha,lam,k,kw,rho,d) result(ua_val)
	implicit none
	real * 8, dimension(:), intent(in) :: Sk0, SkF, alpha, lam, k, kw
	real * 8, dimension(size(Sk0)) :: sku
	real * 8, intent(in) :: rho
	real * 8 :: gam_val
	integer, intent(in) :: d
	real * 8 :: ua_val
	logical :: convergence
	real * 8 :: u_low, u_up, gam_test_u, gam_test_l, error, u_test, gam_test
	integer :: i1
	Real * 8, parameter :: gam_max_val = 1.d20, tol = 1.d-8
	Real * 8, parameter :: ua_max_val = 1.d20, ua_min_val = 1.d-20
	u_low = 0.d0
	u_up = 1.d-4
	sku = sku_quench( Sk0,SkF,alpha,u_up)
	gam_test_u = gamma(d,rho,k,kw,sku,lam)
	sku = sku_quench(Sk0,SkF,alpha,u_low)
	gam_test_l = gamma(d,rho,k,kw,sku,lam)
	If ( gam_test_u > gam_max_val .OR. gam_test_u /= gam_test_u ) Then
		convergence = .false.
		do while (convergence .eqv. .false.)
			u_low = u_up
			u_up  = u_up * 2.d0
			sku = sku_quench( Sk0,SkF,alpha,u_up)
			gam_test = gamma(d,rho,k,kw,sku,lam)
			If ( gam_test < gam_max_val .or. u_up > ua_max_val )	convergence = .true.
		end do
	else if (gam_test_l < gam_max_val ) then
		u_up = u_low
		return
	end if
	ua_val  = u_up
	gam_val = gam_test
	error =  abs(u_up - u_low) / u_up
	if ( error > tol ) convergence = .false.
	if ( u_up > ua_max_val ) convergence = .true.
	do while (convergence .eqv. .false.)
		u_test = (u_up + u_low) / 2.d0
		sku = sku_quench( Sk0,SkF,alpha,u_test)
		gam_test = gamma(d,rho,k,kw,sku,lam)
		if ( gam_test < gam_max_val ) then
			u_up = u_test
			gam_val = gam_test
		else
			u_low = u_test
		end if
		error =  abs(u_up - u_low) / u_up
		if ( error < tol ) convergence = .true.
	end do
	ua_val = u_up
	print*, ua_val, gam_val, error
	return
End Function

!Subroutine that search in an isochore the arrest temperature and then

Real * 8 Function gamma_u(Sk0_v,SkF_v,alpha_v,u_val,lam_v,k_v,kw_v,phi_val,d)
	implicit none
	real * 8, dimension(:), intent(in) :: Sk0_v, SkF_v, alpha_v, lam_v, k_v, kw_v
	real * 8, intent(in) :: u_val, phi_val
	integer, intent(in) :: d
	real * 8, dimension(size(Sk0_v)) :: Sku_v
	Real * 8 :: rho
	rho = phi_val * 6.d0 / pi
	!Call Calc_Sk_u(Sk0_v,SkF_v,alpha_v,Sku_v,u_val)
	gamma_u = gamma(d,rho,k_v,kw_v,Sku_v,lam_v)
	return
End Function

!This subroutine is for the writting of the structure factor as well as the
!weights of the quadrature and the information file
Subroutine su_si_sf_writting(k,sku,ski,skf,kw,i_unit)
	Implicit None
	Real * 8, dimension(:), intent(in) :: k, sku, ski, skf, kw
	Integer :: i1
	Integer, intent(in) :: i_unit
	!k S(k) kw WRITTING
	Write (i_unit,*) "# //	k //	S(k;u)	//	Si(k)	//	Sf(k)	//	Weights		//"
	Do i1=1, size(k)
		Write(i_unit,*) k(i1),sku(i1),ski(i1),skf(i1),kw(i1)
	End Do
End Subroutine

!Subroutine diagram_phi_T(phi,Ti,Tfl,system,k,kw,lamk,)
!	Implicit None
	!!! Volume/Area fraction and # density !!!
!	Real * 8 :: phi, rho
	!!! Quench Initial Temperature // Quench Final Temperature !!!
!	Real * 8 :: Ti, Tf
	!!! Structure factors !!!
!	Real * 8, dimension(:) :: sku, ski, skf
	!!! Wave vectors !!!
!	Real * 8, dimension(:) :: k, kw
	!!! Radial distribution functions !!!
!	Real * 8, dimension(:) :: gru, gri, grf
	!!! Radial vectors !!!
!	Real * 8, dimension(:) :: r, rw
	!!! Differential Radial vectors !!!
!	Real * 8, dimension(:) :: dr, drw
	!!! Integer for the wave-vector parameter !!!
!	Integer :: ikp
	!!! System and system approximation !!!
!	Character ( len = 4 ) :: sys, sys_approx
	!!! System parameters !!!
!	Real * 8, dimension(:) :: s_params
	!!! Writting Folder !!!
!	Character ( len = 100 ) :: folder
	!!! Writting Wave vectors !!!
!	Real * 8, dimension(:) :: k_wr, kw_wr
	!!! Writting Structure factors !!!
!	Real * 8, dimension(:) :: sku_wr, ski_wr, skf_wr
	!!! Writting File Names !!!
!	Character(len=100) :: gam_file_name, S_file_name, g_file_name, S_inf_file_name
!	Character(len=100) :: gam_inf_file_name
	!!! Dummy Variables !!!
!	Real * 8 :: ua
!	Integer :: i1,i2,i3
!	Do i1 = 1, 4000
!		phi = i1 * 1.d-4
!		rho = phi * 6.d0 / pi !3D
!		Ti = 4.d0
!		swlambda = 1.5d0
!		s_params(1) = phi
!		s_params(2) = Ti
!		Do i2 = 1, knp
!			s_params(ikp) = kv(i2)
!			SkI(i2) = structure("s0",sys,sys_approx,s_params)
!		End Do
!		Do i2 = 1, knpgr
!			s_params(ikp) = kvgr(i2)
!			skigr(i2) = structure("s0",sys,sys_approx,s_params)
!		End Do
!		i3 = 800
!		ua_val = 0.d0
!		call file_name_constructor(sys,s_params,folder,"gamma",id,".dat",S_file_name)
!		call file_name_constructor(sys,s_params,folder,"info_ua",id,".inf",inf_file_name)
!		open (unit=104, file=trim(S_file_name), status="Replace")
!		open (unit=105, file=trim(inf_file_name), status="Replace")
!		call k_info_writting(kv,k_quadp,k_approx,105)
!		call lambda_info_writting(kc,105)
!		write(104,*) "#phi,   Tf,   gamma,    ua"
!		close(105)
!		Do while (ua_val < 1.d20)
!			T_low = i3 * 1.d-4
!			s_params(2) = T_low
!			Print*, phi, T_low
!			call file_name_constructor(sys,s_params,folder,"s_ua",id,".dat",S_file_name)
!			call file_name_constructor(sys,s_params,folder,"g_ua",id,".dat",g_file_name)
!			call file_name_constructor(sys,s_params,folder,"info_ua",id,".inf",inf_file_name)
!			Print*, S_file_name
!			open (unit=101, file=trim(S_file_name), status="Replace")
!			open (unit=102, file=trim(g_file_name), status="Replace")
!			open (unit=103, file=trim(inf_file_name), status="Replace")
!			Do i2 = 1, knp
!				s_params(ikp) = kv(i2)
!				SkF(i2) = structure("s0",sys,sys_approx,s_params)
!			End Do
!			Print*, "Skf Done"
!			call Calc_alphaSku(kv,SkF,D0,alphaku)
!			Print*, "alphaku Done"
!			ua_val = calc_ua_isoch_inst_quench(SkI,SkF,alphaku,lamkv,kv,kwv,rho,d)
!			skv = sku_quench(SkI,SkF,alphaku,ua_val)
!			if (ua_val < 1.d20) Then
!			 gam_val = gamma(d,rho,kv,kwv,skv,lamkv)
!			 ua_writting = ua_val
!			 Ta = T_low
!			 Print*, "gamma=",gam_val, "ua=",ua_val
!			 Write(104,*) phi, T_low, gam_val, ua_val
!			End If
!			Do i2 = 1, knpgr
!				s_params(ikp) = kvgr(i2)
!				skfgr(i2) = structure("s0",sys,sys_approx,s_params)
!			End Do
!			call Calc_alphaSku(kvgr,skfgr,D0,alphakgr)
!			skvgru = sku_quench(skigr,skfgr,alphakgr,ua_val)
!			call calc_gr_dependent_functions(rho,kvgr,kwvgr,skvgru,rv,drv,drw,grv,coor_n_rv,d)
!			call s_writting(kvgr,skvgru,kwvgr,101)
!			call g_writting(rv,grv,coor_n_rv,102)
!			call k_info_writting(kvgr,kgr_quadp,k_approx,103)
!			call r_info_writting(rv,r_quadp,r_approx,103)
!			call dr_info_writting(drv,drw,dr_quadp,dr_approx,103)
!			flush(101)
!			flush(102)
!			flush(103)
!			Close(101)
!			Close(102)
!			Close(103)
!			i3=i3+1
!		End Do
!		Write(201,*) phi, Ta, gam_val, ua_writting
!		flush(201)
!	End Do
!	Close(201)
!End Subroutine

End Module


      SUBROUTINE CQLT02( M, N, K, A, AF, Q, L, LDA, TAU, WORK, LWORK,
     $                   RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            K, LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      REAL               RESULT( * ), RWORK( * )
      COMPLEX            A( LDA, * ), AF( LDA, * ), L( LDA, * ),
     $                   Q( LDA, * ), TAU( * ), WORK( LWORK )
*     ..
*
*  Purpose
*  =======
*
*  CQLT02 tests CUNGQL, which generates an m-by-n matrix Q with
*  orthonornmal columns that is defined as the product of k elementary
*  reflectors.
*
*  Given the QL factorization of an m-by-n matrix A, CQLT02 generates
*  the orthogonal matrix Q defined by the factorization of the last k
*  columns of A; it compares L(m-n+1:m,n-k+1:n) with
*  Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are
*  orthonormal.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix Q to be generated.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix Q to be generated.
*          M >= N >= 0.
*
*  K       (input) INTEGER
*          The number of elementary reflectors whose product defines the
*          matrix Q. N >= K >= 0.
*
*  A       (input) COMPLEX array, dimension (LDA,N)
*          The m-by-n matrix A which was factorized by CQLT01.
*
*  AF      (input) COMPLEX array, dimension (LDA,N)
*          Details of the QL factorization of A, as returned by CGEQLF.
*          See CGEQLF for further details.
*
*  Q       (workspace) COMPLEX array, dimension (LDA,N)
*
*  L       (workspace) COMPLEX array, dimension (LDA,N)
*
*  LDA     (input) INTEGER
*          The leading dimension of the arrays A, AF, Q and L. LDA >= M.
*
*  TAU     (input) COMPLEX array, dimension (N)
*          The scalar factors of the elementary reflectors corresponding
*          to the QL factorization in AF.
*
*  WORK    (workspace) COMPLEX array, dimension (LWORK)
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK.
*
*  RWORK   (workspace) REAL array, dimension (M)
*
*  RESULT  (output) REAL array, dimension (2)
*          The test ratios:
*          RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
*          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      COMPLEX            ROGUE
      PARAMETER          ( ROGUE = ( -1.0E+10, -1.0E+10 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            INFO
      REAL               ANORM, EPS, RESID
*     ..
*     .. External Functions ..
      REAL               CLANGE, CLANSY, SLAMCH
      EXTERNAL           CLANGE, CLANSY, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEMM, CHERK, CLACPY, CLASET, CUNGQL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CMPLX, MAX, REAL
*     ..
*     .. Scalars in Common ..
      CHARACTER*6        SRNAMT
*     ..
*     .. Common blocks ..
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
         RESULT( 1 ) = ZERO
         RESULT( 2 ) = ZERO
         RETURN
      END IF
*
      EPS = SLAMCH( 'Epsilon' )
*
*     Copy the last k columns of the factorization to the array Q
*
      CALL CLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA )
      IF( K.LT.M )
     $   CALL CLACPY( 'Full', M-K, K, AF( 1, N-K+1 ), LDA,
     $                Q( 1, N-K+1 ), LDA )
      IF( K.GT.1 )
     $   CALL CLACPY( 'Upper', K-1, K-1, AF( M-K+1, N-K+2 ), LDA,
     $                Q( M-K+1, N-K+2 ), LDA )
*
*     Generate the last n columns of the matrix Q
*
      SRNAMT = 'CUNGQL'
      CALL CUNGQL( M, N, K, Q, LDA, TAU( N-K+1 ), WORK, LWORK, INFO )
*
*     Copy L(m-n+1:m,n-k+1:n)
*
      CALL CLASET( 'Full', N, K, CMPLX( ZERO ), CMPLX( ZERO ),
     $             L( M-N+1, N-K+1 ), LDA )
      CALL CLACPY( 'Lower', K, K, AF( M-K+1, N-K+1 ), LDA,
     $             L( M-K+1, N-K+1 ), LDA )
*
*     Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n)
*
      CALL CGEMM( 'Conjugate transpose', 'No transpose', N, K, M,
     $            CMPLX( -ONE ), Q, LDA, A( 1, N-K+1 ), LDA,
     $            CMPLX( ONE ), L( M-N+1, N-K+1 ), LDA )
*
*     Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
*
      ANORM = CLANGE( '1', M, K, A( 1, N-K+1 ), LDA, RWORK )
      RESID = CLANGE( '1', N, K, L( M-N+1, N-K+1 ), LDA, RWORK )
      IF( ANORM.GT.ZERO ) THEN
         RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, M ) ) ) / ANORM ) / EPS
      ELSE
         RESULT( 1 ) = ZERO
      END IF
*
*     Compute I - Q'*Q
*
      CALL CLASET( 'Full', N, N, CMPLX( ZERO ), CMPLX( ONE ), L, LDA )
      CALL CHERK( 'Upper', 'Conjugate transpose', N, M, -ONE, Q, LDA,
     $            ONE, L, LDA )
*
*     Compute norm( I - Q'*Q ) / ( M * EPS ) .
*
      RESID = CLANSY( '1', 'Upper', N, L, LDA, RWORK )
*
      RESULT( 2 ) = ( RESID / REAL( MAX( 1, M ) ) ) / EPS
*
      RETURN
*
*     End of CQLT02
*
      END