    Program zgbcon_example

!     ZGBCON 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: zgbcon, zgbtrf, zlangb
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: norm = '1'
!     .. Local Scalars ..
      Real (Kind=dp) :: anorm, rcond
      Integer :: i, info, j, k, kl, ku, ldab, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ab(:, :), work(:)
      Real (Kind=dp), Allocatable :: rwork(:)
      Integer, Allocatable :: ipiv(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon, max, min
!     .. Executable Statements ..
      Write (nout, *) 'ZGBCON Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, kl, ku
      ldab = 2*kl + ku + 1
      Allocate (ab(ldab,n), work(2*n), rwork(n), ipiv(n))

!     Read A from data file

      k = kl + ku + 1
      Read (nin, *)((ab(k+i-j,j),j=max(i-kl,1),min(i+ku,n)), i=1, n)

      anorm = zlangb(norm, n, kl, ku, ab(kl+1,1), ldab, rwork)

!     Factorize A
      Call zgbtrf(n, n, kl, ku, ab, ldab, ipiv, info)

      Write (nout, *)
      If (info==0) Then

!       Estimate condition number
        Call zgbcon(norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond, work, &
          rwork, info)

        If (rcond>=epsilon(1.0E0_dp)) Then
          Write (nout, 100) 'Estimate of condition number =', 1.0E0_dp/rcond
        Else
          Write (nout, *) 'A is singular to working precision'
        End If
      Else
        Write (nout, *) 'The factor U is singular'
      End If

100   Format (1X, A, 1P, E10.2)
    End Program


submodule(forlab_linalg) forlab_linalg_eig

    implicit none

contains

    module procedure eig_sp
    integer :: opt_itermax, iter, i, j, k, n
    integer, dimension(:), allocatable :: idx
    real(sp) :: threshold, gapj, termi, termj, h, term, t, &
                theta, c, s, tau, g
    real(sp), dimension(:), allocatable :: bw, zw
    real(sp), dimension(:, :), allocatable :: B
    real(sp), parameter::zero = 0.0_sp, one = 1.0_sp, half = 0.5_sp
    opt_itermax = 1000
    if (present(itermax)) opt_itermax = itermax

    if (.not. is_symmetric(A)) then
        stop "Error: in eig(A), A is not symmetric."
    else
        if (allocated(V)) deallocate (V)
        if (allocated(d)) deallocate (d)

        B = A
        n = size(B, 1)
        allocate (V(n, n))
        call eye(V)
        d = diag(B)
        bw = d
        zw = zeros(n)

        iter = 0
        do while (iter .lt. opt_itermax)
            iter = iter + 1

            threshold = sqrt(sum(triu(B, 1)**2))/(4*n)
            if (threshold .eq. zero) exit

            do i = 1, n
            do j = i + 1, n
                gapj = 10.0_sp*abs(B(i, j))
                termi = gapj + abs(d(i))
                termj = gapj + abs(d(j))

                if ((iter .gt. 4) .and. (termi .eq. abs(d(i))) &
                    .and. (termj .eq. abs(d(j)))) then
                    B(i, j) = zero
                elseif (threshold .le. abs(B(i, j))) then
                    h = d(j) - d(i)
                    term = abs(h) + gapj

                    if (term .eq. abs(h)) then
                        t = B(i, j)/h
                    else
                        theta = half*h/B(i, j)
                        t = one/(abs(theta) + sqrt(one + theta*theta))
                        if (theta .lt. zero) t = -t
                    end if

                    c = one/sqrt(one + t*t)
                    s = t*c
                    tau = s/(one + c)
                    h = t*B(i, j)

                    zw(i) = zw(i) - h
                    zw(j) = zw(j) + h
                    d(i) = d(i) - h
                    d(j) = d(j) + h
                    B(i, j) = zero

                    do k = 1, i - 1
                        g = B(k, i)
                        h = B(k, j)
                        B(k, i) = g - s*(h + g*tau)
                        B(k, j) = h + s*(g - h*tau)
                    end do

                    do k = i + 1, j - 1
                        g = B(i, k)
                        h = B(k, j)
                        B(i, k) = g - s*(h + g*tau)
                        B(k, j) = h + s*(g - h*tau)
                    end do

                    do k = j + 1, n
                        g = B(i, k)
                        h = B(j, k)
                        B(i, k) = g - s*(h + g*tau)
                        B(j, k) = h + s*(g - h*tau)
                    end do

                    do k = 1, n
                        g = V(k, i)
                        h = V(k, j)
                        v(k, i) = g - s*(h + g*tau)
                        v(k, j) = h + s*(g - h*tau)
                    end do

                end if
            end do
            end do

            bw = bw + zw
            d = bw
            zw = zero
        end do
        idx = argsort(d, 1)
        d = d(idx)
        V = V(:, idx)
    end if

    end procedure eig_sp
    module procedure eig_dp
    integer :: opt_itermax, iter, i, j, k, n
    integer, dimension(:), allocatable :: idx
    real(dp) :: threshold, gapj, termi, termj, h, term, t, &
                theta, c, s, tau, g
    real(dp), dimension(:), allocatable :: bw, zw
    real(dp), dimension(:, :), allocatable :: B
    real(dp), parameter::zero = 0.0_dp, one = 1.0_dp, half = 0.5_dp
    opt_itermax = 1000
    if (present(itermax)) opt_itermax = itermax

    if (.not. is_symmetric(A)) then
        stop "Error: in eig(A), A is not symmetric."
    else
        if (allocated(V)) deallocate (V)
        if (allocated(d)) deallocate (d)

        B = A
        n = size(B, 1)
        allocate (V(n, n))
        call eye(V)
        d = diag(B)
        bw = d
        zw = zeros(n)

        iter = 0
        do while (iter .lt. opt_itermax)
            iter = iter + 1

            threshold = sqrt(sum(triu(B, 1)**2))/(4*n)
            if (threshold .eq. zero) exit

            do i = 1, n
            do j = i + 1, n
                gapj = 10.0_dp*abs(B(i, j))
                termi = gapj + abs(d(i))
                termj = gapj + abs(d(j))

                if ((iter .gt. 4) .and. (termi .eq. abs(d(i))) &
                    .and. (termj .eq. abs(d(j)))) then
                    B(i, j) = zero
                elseif (threshold .le. abs(B(i, j))) then
                    h = d(j) - d(i)
                    term = abs(h) + gapj

                    if (term .eq. abs(h)) then
                        t = B(i, j)/h
                    else
                        theta = half*h/B(i, j)
                        t = one/(abs(theta) + sqrt(one + theta*theta))
                        if (theta .lt. zero) t = -t
                    end if

                    c = one/sqrt(one + t*t)
                    s = t*c
                    tau = s/(one + c)
                    h = t*B(i, j)

                    zw(i) = zw(i) - h
                    zw(j) = zw(j) + h
                    d(i) = d(i) - h
                    d(j) = d(j) + h
                    B(i, j) = zero

                    do k = 1, i - 1
                        g = B(k, i)
                        h = B(k, j)
                        B(k, i) = g - s*(h + g*tau)
                        B(k, j) = h + s*(g - h*tau)
                    end do

                    do k = i + 1, j - 1
                        g = B(i, k)
                        h = B(k, j)
                        B(i, k) = g - s*(h + g*tau)
                        B(k, j) = h + s*(g - h*tau)
                    end do

                    do k = j + 1, n
                        g = B(i, k)
                        h = B(j, k)
                        B(i, k) = g - s*(h + g*tau)
                        B(j, k) = h + s*(g - h*tau)
                    end do

                    do k = 1, n
                        g = V(k, i)
                        h = V(k, j)
                        v(k, i) = g - s*(h + g*tau)
                        v(k, j) = h + s*(g - h*tau)
                    end do

                end if
            end do
            end do

            bw = bw + zw
            d = bw
            zw = zero
        end do
        idx = argsort(d, 1)
        d = d(idx)
        V = V(:, idx)
    end if

    end procedure eig_dp

end submodule forlab_linalg_eig


      INTEGER FUNCTION MA01CD( A, IA, B, IB )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute, without over- or underflow, the sign of the sum of two
C     real numbers represented using integer powers of a base (usually,
C     the machine base). Any base can be used, but it should the same
C     for both numbers. The result is an integer with value 1, 0, or -1,
C     depending on the sum being found as positive, zero, or negative,
C     respectively.
C
C     FUNCTION VALUE
C
C     MA01CD  INTEGER
C             The sign of the sum of the two numbers, which is usually
C             either 1, or -1. If both numbers are 0, or if they have
C             the same exponent and their sum is 0, the returned value
C             is 0.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     A       (input)  DOUBLE PRECISION
C             The first real scalar.
C
C     IA      (input)  INTEGER
C             Exponent of the base for the first real scalar. The scalar
C             is represented as A * BASE**(IA).
C
C     B       (input)  DOUBLE PRECISION
C             The first real scalar.
C
C     IB      (input)  INTEGER
C             Exponent of the base for the first real scalar. The scalar
C             is represented as B * BASE**(IB).
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Feb. 2010.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Computer arithmetic, overflow, underflow.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           IA, IB
      DOUBLE PRECISION  A, B
C     .. Local Scalars ..
      DOUBLE PRECISION  S, SA, SB
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, LOG, SIGN
C
C     .. Executable Statements ..
C
      IF( A.EQ.ZERO .AND. B.EQ.ZERO ) THEN
         MA01CD = 0
      ELSE IF( A.EQ.ZERO ) THEN
         MA01CD = SIGN( ONE, B )
      ELSE IF( B.EQ.ZERO ) THEN
         MA01CD = SIGN( ONE, A )
      ELSE IF( IA.EQ.IB ) THEN
         S = A + B
         IF( S.EQ.ZERO ) THEN
            MA01CD = 0
         ELSE
            MA01CD = SIGN( ONE, S )
         END IF
      ELSE
         SA = SIGN( ONE, A )
         SB = SIGN( ONE, B )
         IF( SA.EQ.SB ) THEN
            MA01CD = SA
         ELSE IF( IA.GT.IB ) THEN
            IF( ( LOG( ABS( A ) ) + IA - IB ).GE.LOG( ABS( B ) ) ) THEN
               MA01CD = SA
            ELSE
               MA01CD = SB
            END IF
         ELSE
            IF( ( LOG( ABS( B ) ) + IB - IA ).GE.LOG( ABS( A ) ) ) THEN
               MA01CD = SB
            ELSE
               MA01CD = SA
            END IF
         END IF
      END IF
C
      RETURN
C *** Last line of MA01CD ***
      END


module clusan
  implicit none
  private
  public kmeans

  integer, parameter :: ITMAX = 10000

contains
  pure subroutine kmeans(x, m)
    real, intent(in) :: x(:, :)
    real, intent(inout) :: m(:, :)
    real :: c(size(m, 1), size(m, 2)), tol, v, vmin
    logical :: mask(size(x, 2))
    integer :: s(size(x, 2))
    integer :: i, j, k, num, n, z

    tol = sqrt(epsilon(1.))
    k = size(m, 2)
    n = size(x, 2)
    do z = 1, ITMAX
      do j = 1, n
        vmin = -1.
        do i = 1, k
          v = norm2(x(:, j) - m(:, i))
          if(vmin > v .or. vmin < 0) then
            vmin = v
            s(j) = i
          end if
        end do
      end do
      do i = 1, k
        mask = s == i
        num = count(mask)
        do concurrent(j = 1:size(m, 1))
          c(j, i) = sum(x(j, :), mask) / num
        end do
      end do
      if(norm2(c - m) < tol) exit
      m = c
    end do
  end subroutine
end module


      program linReg2
      implicit none
      integer, parameter :: rp = SELECTED_REAL_KIND(15)
      integer, parameter :: n = 1000
      real (kind = rp) , dimension(n, 4):: x       ! it's a 1000 row, 4 column matrix
      real (kind = rp) , dimension(n, 1):: y       ! the dv, column vector
      real (kind = rp) , dimension(4, n):: x_T     ! transpose of the 1000 row, 4 column matrix
      real (kind = rp) , dimension(1, n):: y_T     ! the dv, row vector
      real (kind = rp) , dimension(4, 4):: x_Tx    !the product of transpose(x) and x
      real (kind = rp) , dimension(4, 4):: x_Txinv !copy of x_Tx to prevent lapack from mutating it
      real (kind = rp) , dimension(n)   :: work    ! work array for LAPACK
      integer, dimension(n)             :: ipiv    ! pivot indices
      integer :: info

      ! External procedures defined in LAPACK
      external DGETRF
      external DGETRI

      open(file = "R:/DataSets/Matrix-10-18-18.txt", unit = 50)
      read (50,*) x_T
      x = transpose(x_T)

C       print *, y
      open(file = "R:/DataSets/vector-10-18-18.txt", unit = 52)
      read(52,*) y_T
      y = transpose(y_T)
      x_Tx = matmul(x_T, x)

      write (*,*) "program works"
      end program linReg2


!*******************************************************************************
!*******************************************************************************
MODULE IMSL_REPLACEMENTS

	!/* setup   */

	IMPLICIT NONE

  	REAL, PARAMETER :: SMALL_FLOAT = 1.0e-5

	! External procedures defined in LAPACK
	EXTERNAL DGETRF
	EXTERNAL DGETRI
	EXTERNAL DPOTRF

	PUBLIC

CONTAINS
!*******************************************************************************
!*******************************************************************************
SUBROUTINE LFCDS(N, A, LDA, FACT, LDFACT, RCOND)

	!/* external objects    */

	REAL, INTENT(OUT)		:: FACT(N, N)

	INTEGER, INTENT(IN)		:: LDFACT
	INTEGER, INTENT(IN)		:: LDA
	INTEGER, INTENT(IN)		:: N

	REAL, INTENT(IN)		:: A(N, N)
	REAL, INTENT(IN)		:: RCOND

	!/* internal objects    */

	INTEGER           		:: INFO

!-------------------------------------------------------------------------------
! Algorithm
!-------------------------------------------------------------------------------

    ! Initialize matrix for replacement.
    FACT = A

    ! Compute the Cholesky factorization of a real symmetric positive
    ! definite matrix A (single precision).
    CALL SPOTRF('L', N, FACT, N, INFO)

END SUBROUTINE
!*******************************************************************************
!*******************************************************************************
SUBROUTINE RNNOR(dim, draw)

	!
	! This subroutine generates deviates from a standard normal distribution
	! using the Box-Muller algorithm.
	!

	!/* external objects    */

	INTEGER, INTENT(IN)   	:: dim

	REAL, INTENT(OUT)   	:: draw(dim)

	!/* internal objects    */

	INTEGER             	:: g

	REAL, ALLOCATABLE   	:: u(:), r(:)
    REAL     				:: pi = 3.141592653589793238462643383279502884197

!-------------------------------------------------------------------------------
! Algorithm
!-------------------------------------------------------------------------------

	! Allocate containers
	ALLOCATE(u(2*dim)); ALLOCATE(r(2*dim))

	! Call uniform deviates
	CALL random_number(u)

	! Apply Box-Muller transform
	DO g = 1, 2*dim, 2

			r(g)   = SQRT(-2*LOG(u(g)))*COS(2*pi*u(g+1))
			r(g+1) = SQRT(-2*LOG(u(g)))*SIN(2*pi*u(g+1))

	END DO

	! Extract relevant floats
	DO g = 1, dim

			draw(g) = r(g)

	END DO

END SUBROUTINE
!*******************************************************************************
!*******************************************************************************
SUBROUTINE LINDS(N, A, LDA, AINV, LDAINV)

	!/* external objects    */

	INTEGER, INTENT(IN)     :: N, LDA, LDAINV
	REAL, INTENT(IN)      	:: A(LDA, LDA)

	REAL, INTENT(INOUT)     :: AINV(LDAINV, LDAINV)

!-------------------------------------------------------------------------------
! Algorithm
!-------------------------------------------------------------------------------

	AINV(:N, :N) = inverse(A(:N, :N), N)

END SUBROUTINE
!*******************************************************************************
!*******************************************************************************
FUNCTION inverse(A, n)

	!/* external objects        */

	INTEGER , INTENT(IN)    :: n

	REAL, INTENT(IN)      	:: A(:, :)

	!/* internal objects        */

	INTEGER                	:: ipiv(n)
	INTEGER                 :: info

	REAL                  	:: inverse(n, n)
	REAL                  	:: work(n)

!-------------------------------------------------------------------------------
! Algorithm
!-------------------------------------------------------------------------------

	! Initialize matrix for replacement
	inverse = A

	! SGETRF computes an LU factorization of a general M-by-N matrix A
	! using partial pivoting with row interchanges.
	CALL SGETRF(n, n, inverse, n, ipiv, info)

	! SGETRI computes the inverse of a matrix using the LU factorization
	! computed by DGETRF.
	CALL SGETRI(n, inverse, n, ipiv, work, n, info)

END FUNCTION
!*******************************************************************************
!*******************************************************************************
SUBROUTINE RNOPT(seed)

	!/* external objects    */

	INTEGER, INTENT(IN)		:: seed

	!/* internal objects    */

!-------------------------------------------------------------------------------
! Algorithm
!-------------------------------------------------------------------------------

END SUBROUTINE
!*******************************************************************************
!*******************************************************************************
SUBROUTINE RNGET(seed)

	!/* external objects    */

	INTEGER, INTENT(IN)  	:: seed

	!/* internal objects    */

	INTEGER                  :: size
	INTEGER                  :: auxiliary(55)

!-------------------------------------------------------------------------------
! Algorithm
!-------------------------------------------------------------------------------

	CALL RANDOM_SEED(size=size)

	auxiliary = seed

	CALL RANDOM_SEED(get=auxiliary)

END SUBROUTINE
!*******************************************************************************
!*******************************************************************************
SUBROUTINE RNSET(seed)

	!/* external objects    */

	INTEGER, INTENT(IN)    	:: seed

	!/* internal objects    */

	INTEGER                 :: size
	INTEGER                 :: auxiliary(55)

!-------------------------------------------------------------------------------
! Algorithm
!-------------------------------------------------------------------------------

	CALL RANDOM_SEED(size=size)

	auxiliary = seed

	CALL RANDOM_SEED(put=auxiliary)

END SUBROUTINE
!*******************************************************************************
!*******************************************************************************
SUBROUTINE RNSRI(NSAMP, NPOP, INDEX)

	!/* external objects    */

	INTEGER, INTENT(OUT)	:: INDEX(:)

	INTEGER, INTENT(IN)		:: NSAMP
	INTEGER, INTENT(IN)		:: NPOP

	!/* internal objects    */

	INTEGER 				:: shuffled(NPOP)
	INTEGER 				:: initial(NPOP)
	INTEGER 				:: i

!-------------------------------------------------------------------------------
! Algorithm
!-------------------------------------------------------------------------------

	DO i = 1, NPOP
		initial(i) = i
	END DO

	shuffled = initial
	CALL shuffle(shuffled)

	INDEX(:NSAMP) = shuffled(:NSAMP)

END SUBROUTINE
!*******************************************************************************
!*******************************************************************************
SUBROUTINE shuffle(a)

	!/* external objects    */

	INTEGER, INTENT(INOUT)	:: a(:)

	!/* internal objects    */

	INTEGER 				:: randpos
	INTEGER 				:: temp
	INTEGER 				:: i

	REAL 					:: r

!-------------------------------------------------------------------------------
! Algorithm
!-------------------------------------------------------------------------------

	DO i = SIZE(a), 2, -1

		CALL RANDOM_NUMBER(r)

		randpos = int(r * i) + 1

		temp = a(randpos)

		a(randpos) = a(i)

		a(i) = temp

	END DO

END SUBROUTINE
!*******************************************************************************
!*******************************************************************************
FUNCTION PEI_SQRT(ARG)

	!
	! This function is used as a replacement for the plain application of the
	! SQRT intrinsic function. Otherwise negative values are passed in as
	! arguments due to numerical error.
	!

	!/* external objects        */

	REAL, INTENT(IN)    :: ARG
	REAL 				:: PEI_SQRT

!-------------------------------------------------------------------------------
! Algorithm
!-------------------------------------------------------------------------------

	IF(ARG < SMALL_FLOAT) THEN
		PEI_SQRT = SQRT(SMALL_FLOAT)
	ELSE
		PEI_SQRT = SQRT(ARG)
	END IF

END FUNCTION
!*******************************************************************************
!*******************************************************************************
END MODULE


module mod_mkkn

	implicit none

contains

subroutine MKKN(ds,gf,cnorm,kfel,nbi,nbdeg,ks00,kt00)

	implicit none

	integer, intent(in) :: kfel, nbdeg, ks00, kt00
	real(8), intent(in) :: gf(kfel,16), cnorm

	integer, intent(out) :: nbi
	real(8), intent(inout) :: ds(kfel)

	integer :: is, it, lc, ix, iy, lls, llt, ld
	real(8) :: da

	nbi = 0

	do it = 1, kt00+nbdeg
		do is = 1, ks00+nbdeg

			da = 0.d0
			nbi = nbi + 1
			lc = 0

			do iy = 0, nbdeg

				llt = it - nbdeg +iy

				do ix = 0, nbdeg

					lls = is - nbdeg + ix
					lc = lc + 1

					if(llt < 1 .or. llt > kt00) cycle
					if(lls < 1 .or. lls > ks00) cycle

					ld = lls + (llt-1) * ks00
					da = da + gf(ld,lc)

				end do
			end do

			ds(nbi) = da * cnorm

		end do
	end do

return
end subroutine MKKN

end module mod_mkkn


subroutine distcheck(randgen, n, delta)

  interface
    function randgen
      integer :: randgen
    end function randgen
  end interface

  real, intent(in) :: delta
  integer, intent(in) :: n
  integer :: i, mval, lolim, hilim
  integer, allocatable :: buckets(:)
  integer, allocatable :: rnums(:)
  logical :: skewed = .false.

  allocate(rnums(n))

  do i = 1, n
    rnums(i) = randgen()
  end do

  mval = maxval(rnums)
  allocate(buckets(mval))
  buckets = 0

  do i = 1, n
    buckets(rnums(i)) = buckets(rnums(i)) + 1
  end do

  lolim = n/mval - n/mval*delta
  hilim = n/mval + n/mval*delta

  do i = 1, mval
    if(buckets(i) < lolim .or. buckets(i) > hilim) then
      write(*,"(a,i0,a,i0,a,i0)") "Distribution potentially skewed for bucket ", i, "   Expected: ", &
                                   n/mval, "   Actual: ", buckets(i)
      skewed = .true.
    end if
  end do

  if (.not. skewed) write(*,"(a)") "Distribution uniform"

  deallocate(rnums)
  deallocate(buckets)

end subroutine


program main
    implicit none

    ! Size of vectors
    integer,parameter :: n = 20480

    real(8) :: a, m, tmp
    integer :: i

    real(8),dimension(:),allocatable :: x
    real(8),dimension(:),allocatable :: y
    real(8),dimension(:),allocatable :: yomp
    real(8),dimension(:),allocatable :: yacc

    call random_number(a)

    ! Allocate memory for each vector on host
    allocate(x(n))
    allocate(y(n))
    allocate(yomp(n))
    allocate(yacc(n))

    ! Initialize x and y
    call random_number(x)
    call random_number(y)

    ! Compute axpy on the host CPU cores
    !$omp parallel do
    do i=1,n
        yomp(i) = a*x(i) + y(i)
    enddo
    !$omp end parallel do

    ! Compute axpy on the accelerator
    !$acc kernels copyin(x(1:n),y(1:n)), copyout(yacc(1:n))
    do i=1,n
        yacc(i) = a*x(i) + y(i)
    enddo
    !$acc end kernels

    ! Verify the results
    m = -1.
    !$omp parallel do private(tmp) reduction(max:m)
    do i=1,n
        tmp = abs( (yacc(i)-yomp(i))/yomp(i) )
        if ( tmp > m ) m = tmp
    enddo

    if ( m < 1E-12) then
        print *, "Success!"
    else
       print *, "Failure!"
    endif

    ! Release memory
    deallocate(x)
    deallocate(y)
    deallocate(yomp)
    deallocate(yacc)

end program main


! { dg-do run }
! { dg-require-effective-target fortran_large_real }
! Tests the fix for PR35944/6/7, in which the variable array constructors below
! were incorrectly translated and wrong code was produced.
!
! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
!
      program try_fa6013
      call fa6013 (10, 1, -1)
      call fa6077 (10, 1, -1, (/1,2,3,4,5,6,7,8,9,10/))
      call fa2083
      end program

      subroutine  FA6013 (nf10, nf1, mf1)
      integer, parameter :: kv = 4
      REAL(KV) DDA1(10)
      REAL(KV) DDA2(10)
      REAL(KV) DDA(10), dval
      dda = (/1,2,3,4,5,6,7,8,9,10/)
      DDA1 = ATAN2 ((/(REAL(J1,KV),J1=1,10)/),
     $                 REAL((/(J1,J1=nf10,nf1,mf1)/), KV))   !fails
      DDA2 = ATAN2 (DDA, DDA(10:1:-1))
      if (any (DDA1 - DDA2 .gt. epsilon(dval))) call abort ()
      END

      subroutine FA6077 (nf10,nf1,mf1, ida)
      INTEGER IDA1(10)
      INTEGER IDA2(10), ida(10)
      IDA1 = IEOR((/1,2,3,4,5,6,7,8,9,10/),
     $            (/(IDA(J1),J1=10,1,-1)/) )
      IDA2 = IEOR ((/1,2,3,4,5,6,7,8,9,10/), (/10,9,8,7,6,5,4,3,2,1/) )
      if (any (ida1 .ne. ida2)) call abort ()
      END SUBROUTINE

      subroutine fa2083
      implicit none
      integer j1,k
      parameter (k=selected_real_kind (precision (0.0_8) + 1)) ! failed
      REAL(k) QDA1(10)
      REAL(k) QDA(10), qval
      qda = (/ 1,2,3,4,5,6,7,8,9,10 /)
      QDA1 = MOD ( 1.1_k*( QDA(1) -5.0_k), P=( QDA -2.5_k))
      DO J1 = 1,10
        QVAL = MOD(1.1_k*(QDA(1)-5.0_k),P=(QDA(J1)-2.5_k))
        if (qval - qda1(j1) .gt. epsilon(qval)) call abort ()
      ENDDO
      END


!----------------------------------------
subroutine vorticity(ui, uj, wk, l, m, n)
  !
  ! omega_k = delta_i[u_j] - delta_j[u_i]
  !
  ! direction i should be the first one,
  ! imposing to view arrays in the j direction
  !
  implicit none

  integer, intent(in):: l, m, n
  real*8, dimension(l, m, n), intent(in) :: ui, uj
  real*8, dimension(l, m, n), intent(inout) :: wk

  !f2py intent(inplace):: ui, uj, wk

  integer:: i, j, k

  do k = 1, l
     do j = 1, m-1
        do i = 1, n-1
           wk(k,j,i) = uj(k,j,i+1) - uj(k,j,i) - ui(k,j+1,i) + ui(k,j,i)
        enddo
        wk(k,j,n) = 0.
     enddo
  enddo

end subroutine vorticity

!----------------------------------------
subroutine vorticity_all_comp(ui, uj, uk, wi, wj, wk, l, m, n)
  !
  ! compute the three components with all arrays in the
  ! same convention (k, j, i)
  !
  implicit none

  integer, intent(in):: l, m, n
  real*8, dimension(l, m, n), intent(in) :: ui, uj, uk
  real*8, dimension(l, m, n), intent(inout) :: wi, wj, wk

  !f2py intent(inplace):: ui, uj, uk, wi, wj, wk

  integer:: i, j, k

  do k = 1, l-1
     do j = 1, m-1
        do i = 1, n
           wi(k,j,i) = uk(k,j+1,i) - uk(k,j,i) - uj(k+1,j,i) + uj(k,j,i)
        enddo
     enddo
  enddo
  do k = 1, l-1
     do j = 1, m
        do i = 1, n-1
           wj(k,j,i) = ui(k+1,j,i) - ui(k,j,i) - uk(k,j,i+1) + uk(k,j,i)
        enddo
     enddo
  enddo
  do k = 1, l
     do j = 1, m-1
        do i = 1, n-1
           wk(k,j,i) = uj(k,j,i+1) - uj(k,j,i) - ui(k,j+1,i) + ui(k,j,i)
        enddo
     enddo
  enddo

end subroutine vorticity_all_comp


!------------------------------------------------------------!
! TOYPROB.F90                                                !
!                                                            !
! This file is a simple problem for testing, taken from the  !
! Hock and Schittkowski set:                                 !
!                                                            !
! (HS6) min (1 - x_1) ** 2 s.t. 10 * (x_2 - x_1 ** 2) = 0    !
!                                                            !
!------------------------------------------------------------!

!------------------------------------------------------------!
! SUBROUTINE INITIALIZES                                     !
!                                                            !
! This subroutine initializes the SCALAR information of the  !
! problem.                                                   !
!                                                            !
!------------------------------------------------------------!

subroutine initializes(n,m,flag)

  implicit none

  ! SCALAR ARGUMENTS
  integer,intent(out) :: flag,m,n

  flag = 0

  n = 2
  m = 1

end subroutine initializes

!------------------------------------------------------------!
! SUBROUTINE INITIALIZEA                                     !
!                                                            !
! This subroutine initializes the ARRAY information of the   !
! problem.                                                   !
!                                                            !
!------------------------------------------------------------!

subroutine initializea(n,x,l,u,m,flag)

  implicit none

  ! SCALAR ARGUMENTS
  integer :: flag,m,n

  ! ARRAY ARGUMENTS
  real(8) :: l(n),u(n),x(n)

  intent(in ) :: m,n
  intent(out) :: flag,l,u,x

  ! LOCAL SCALARS
  integer :: i

  flag = 0

  x(1) = - 1.2D0
  x(2) =   1.0D0

  do i = 1,n
     l(i) = - 1.0D+20
     u(i) =   1.0D+20
  end do

end subroutine initializea

!------------------------------------------------------------!
! SUBROUTINE FINALIZE                                        !
!                                                            !
! Finalizes the problem, sometimes printing additional       !
! information related to the specific problem.               !
!                                                            !
!------------------------------------------------------------!

subroutine finalize(ne,x,m,maxinfeas)

  implicit none

  ! SCALAR ARGUMENTS
  integer,intent(in) :: m,ne
  real(8),intent(in) :: maxinfeas

  ! ARRAY ARGUMENTS
  real(8),intent(in) :: x(ne)

end subroutine finalize

!------------------------------------------------------------!
! SUBROUTINE EVAOBJFUN                                       !
!                                                            !
! Defines the objective function.                            !
!                                                            !
!------------------------------------------------------------!

subroutine evalobjfun(n,x,f,flag)

  implicit none

  ! SCALAR ARGUMENTS
  integer :: flag,n
  real(8) :: f

  ! ARRAY ARGUMENTS
  real(8) :: x(n)

  intent(in ) :: n,x
  intent(out) :: f,flag

  flag = 0

  f = (1.0D0 - x(1)) ** 2

end subroutine evalobjfun

!------------------------------------------------------------!
! SUBROUTINE EVALCONSTR                                      !
!                                                            !
! Defines the constraints.                                   !
!                                                            !
!------------------------------------------------------------!

subroutine evalconstr(n,x,ind,c,flag)

  implicit none

  ! SCALAR ARGUMENTS
  integer :: flag,ind,n
  real(8) :: c

  ! ARRAY ARGUMENTS
  real(8) :: x(n)

  intent(in ) :: ind,n,x
  intent(out) :: c,flag

  flag = 0

  if ( ind .eq. 1 ) then
     c = 10.0D0 * (x(2) - x(1) ** 2.0D0)
  else
     flag = - 1
  end if

end subroutine evalconstr

!------------------------------------------------------------!
! SUBROUTINE EVALJACOB                                       !
!                                                            !
! Defines the Jacobian of the constraints.                   !
!                                                            !
!------------------------------------------------------------!

subroutine evaljacob(n,x,ind,jcvar,jcval,jcnnz,flag)

  implicit none

  ! SCALAR ARGUMENTS
  integer :: flag,ind,jcnnz,n

  ! ARRAY ARGUMENTS
  integer :: jcvar(n)
  real(8) :: jcval(n),x(n)

  intent(in ) :: ind,n,x
  intent(out) :: flag,jcnnz,jcval,jcvar

  flag = 0

  if ( ind .eq. 1 ) then
     jcnnz = 2

     jcvar(1) = 1
     jcval(1) = - 20.0D0 * x(1)

     jcvar(2) = 2
     jcval(2) = 10.0D0
  else
     flag = - 1
  end if

end subroutine evaljacob

!------------------------------------------------------------!
! SUBROUTINE DRAWSBI                                         !
!                                                            !
! This subroutine draws the state of the problem (if/when    !
! possible) at the beginning of iteration 'iter'.            !
!                                                            !
!------------------------------------------------------------!

subroutine drawsBI(n,x,m,gamma,infeas,iter)

  implicit none

  ! SCALAR ARGUMENTS
  integer :: iter,m,n
  real(8) :: gamma,infeas

  ! ARRAY ARGUMENTS
  real(8) :: x(n)

  intent(in) :: gamma,infeas,iter,m,n,x

end subroutine drawsBI

!------------------------------------------------------------!
! SUBROUTINE DRAWSAR                                         !
!                                                            !
! This subroutine draws the state of the problem (if/when    !
! possible) immediately after the restoration phase at       !
! iteration 'iter'.                                          !
!                                                            !
!------------------------------------------------------------!

subroutine drawsAR(n,x,m,gamma,infeas,iter)

  implicit none

  ! SCALAR ARGUMENTS
  integer :: iter,m,n
  real(8) :: gamma,infeas

  ! ARRAY ARGUMENTS
  real(8) :: x(n)

  intent(in) :: gamma,infeas,iter,m,n,x

end subroutine drawsAR

!------------------------------------------------------------!
! SUBROUTINE DRAWSAO                                         !
!                                                            !
! This subroutine draws the state of the problem (if/when    !
! possible) immediately after the optimization phase at      !
! iteration 'iter'.                                          !
!                                                            !
!------------------------------------------------------------!

subroutine drawsAO(n,x,m,gamma,infeas,iter)

  implicit none

  ! SCALAR ARGUMENTS
  integer :: iter,m,n
  real(8) :: gamma,infeas

  ! ARRAY ARGUMENTS
  real(8) :: x(n)

  intent(in) :: gamma,infeas,iter,m,n,x

end subroutine drawsAO


module stats_mod
    use, intrinsic :: iso_fortran_env, only : f8 => REAL64, i8 => INT64, &
                                              error_unit
    implicit none

    private
    type, public :: stats_type
        private
        real(kind=f8) :: sum = 0.0_f8
        integer(kind=i8) :: n = 0_i8
    contains
        procedure :: add
        procedure :: avg
    end type stats_type

    public :: new_stats

contains

    type(stats_type) function new_stats()
        implicit none
        new_stats%sum = 0.0_f8
        new_stats%n = 0_i8
    end function new_stats

    subroutine add(stats, value)
        implicit none
        class(stats_type), intent(inout) :: stats
        real(kind=f8), intent(in) :: value
        stats%sum = stats%sum + value
        stats%n = stats%n + 1
    end subroutine add

    real(kind=f8) function avg(stats)
        implicit none
        class(stats_type), intent(in) :: stats
        if (stats%n == 0) then
            write(unit=error_unit, fmt='(A)') '### error: no data for avg'
            stop
        end if
        avg = stats%sum/stats%n
    end function avg

end module stats_mod


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/57142
!
integer :: B(huge(1)+3_8,2_8)
integer(8) :: var1(2), var2, var3

var1 = shape(B,kind=8)
var2 = size(B,kind=8)
var3 = size(B,dim=1,kind=8)
end

! { dg-final { scan-tree-dump "static integer.kind=8. A..\\\[2\\\] = \\\{2147483650, 2\\\};" "original" } }
! { dg-final { scan-tree-dump "var2 = 4294967300;" "original" } }
! { dg-final { scan-tree-dump "var3 = 2147483650;" "original" } }


program call_geofractal
use types;
implicit none
!--------------------------------------------------------------------------------
!       some cluster constants
!--------------------------------------------------------------------------------
real(kind=dp),parameter :: k0_chain = sqrt(3.0_dp)
real(kind=dp),parameter :: df_chain = 1.0_dp
real(kind=dp),parameter :: df_bpca  = 3.0_dp
real(kind=dp),parameter :: k0_bpca  = 0.3_dp
real(kind=dp),parameter :: k0_bcca  = 1.04_dp
real(kind=dp),parameter :: df_bcca  = 1.90_dp

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

integer,parameter       :: n        = 250
integer                 :: i,iqapp,iqcon,iqcor
real(kind=dp)           :: PN(1:n),G(1:n),G0,k0,df

!--------------------------------------------------------------------------------
!       calculation mode
!--------------------------------------------------------------------------------
iqapp   = 3                     ! switch 1: 1 or 3
iqcon   = 2                     ! switch 2: 1 or 2
iqcor   = 3                     ! correlation func.
!--------------------------------------------------------------------------------
!       straight chain
!--------------------------------------------------------------------------------
!k0      = k0_chain              ! fractal prefactor
!df      = df_chain              ! fractal dimension
!--------------------------------------------------------------------------------
!       BPCA
!--------------------------------------------------------------------------------
!df      = df_bpca               ! fractal dimension
!k0      = k0_bpca               ! fractal prefactor
!--------------------------------------------------------------------------------
!       BCCA
!--------------------------------------------------------------------------------
!df      = df_bcca               ! fractal dimension
!k0      = k0_bcca               ! fractal prefactor
!--------------------------------------------------------------------------------
!       other fractal dimensions
!--------------------------------------------------------------------------------
df      = 3.0_dp                ! fractal dimension
k0      = (k0_chain-k0_bpca)/(df_chain-df_bpca)*(df-df_bpca)+k0_bpca
!--------------------------------------------------------------------------------

!--------------------------------------------------------------------------------
!       call geofractal
!--------------------------------------------------------------------------------
do i=1,n
        PN(i) = 1.0_dp * (1.e10_dp/1.0_dp) ** &
                (real(i-1,kind=dp)/real(n-1,kind=dp))
        call geofrac(iqapp,iqcon,iqcor,PN(i),k0,df,G0)
        G(i) = G0
enddo

!--------------------------------------------------------------------------------
!       Output
!--------------------------------------------------------------------------------
open(10,file="gratio.out",status="unknown")
write(10,'("# iqapp = ",I3)')iqapp
write(10,'("# iqcon = ",I3)')iqcon
write(10,'("# iqcor = ",I3)')iqcor
write(10,'("# df    = ",1PE14.6)')df
write(10,'("# k0    = ",1PE14.6)')k0
write(10,'("#",A14,A15)') "PN","G/NpiR0^2"
do i=1,n
        write(10,'(1P2E15.6)') PN(i),G(i)
enddo

print *, 'finished.'

stop
end program call_geofractal


c-----------------------------------------------------------------------
c\BeginDoc
c
c\Name: ssapps
c
c\Description:
c  Given the Arnoldi factorization
c
c     A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T,
c
c  apply NP shifts implicitly resulting in
c
c     A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q
c
c  where Q is an orthogonal matrix of order KEV+NP. Q is the product of
c  rotations resulting from the NP bulge chasing sweeps.  The updated Arnoldi
c  factorization becomes:
c
c     A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T.
c
c\Usage:
c  call ssapps
c     ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD )
c
c\Arguments
c  N       Integer.  (INPUT)
c          Problem size, i.e. dimension of matrix A.
c
c  KEV     Integer.  (INPUT)
c          INPUT: KEV+NP is the size of the input matrix H.
c          OUTPUT: KEV is the size of the updated matrix HNEW.
c
c  NP      Integer.  (INPUT)
c          Number of implicit shifts to be applied.
c
c  SHIFT   Real array of length NP.  (INPUT)
c          The shifts to be applied.
c
c  V       Real N by (KEV+NP) array.  (INPUT/OUTPUT)
c          INPUT: V contains the current KEV+NP Arnoldi vectors.
c          OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors
c          are in the first KEV columns of V.
c
c  LDV     Integer.  (INPUT)
c          Leading dimension of V exactly as declared in the calling
c          program.
c
c  H       Real (KEV+NP) by 2 array.  (INPUT/OUTPUT)
c          INPUT: H contains the symmetric tridiagonal matrix of the
c          Arnoldi factorization with the subdiagonal in the 1st column
c          starting at H(2,1) and the main diagonal in the 2nd column.
c          OUTPUT: H contains the updated tridiagonal matrix in the
c          KEV leading submatrix.
c
c  LDH     Integer.  (INPUT)
c          Leading dimension of H exactly as declared in the calling
c          program.
c
c  RESID   Real array of length (N).  (INPUT/OUTPUT)
c          INPUT: RESID contains the the residual vector r_{k+p}.
c          OUTPUT: RESID is the updated residual vector rnew_{k}.
c
c  Q       Real KEV+NP by KEV+NP work array.  (WORKSPACE)
c          Work array used to accumulate the rotations during the bulge
c          chase sweep.
c
c  LDQ     Integer.  (INPUT)
c          Leading dimension of Q exactly as declared in the calling
c          program.
c
c  WORKD   Real work array of length 2*N.  (WORKSPACE)
c          Distributed array used in the application of the accumulated
c          orthogonal matrix Q.
c
c\EndDoc
c
c-----------------------------------------------------------------------
c
c\BeginLib
c
c\Local variables:
c     xxxxxx  real
c
c\References:
c  1. D.C. Sorensen, "Implicit Application of Polynomial Filters in
c     a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992),
c     pp 357-385.
c  2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly
c     Restarted Arnoldi Iteration", Rice University Technical Report
c     TR95-13, Department of Computational and Applied Mathematics.
c
c\Routines called:
c     ivout   ARPACK utility routine that prints integers.
c     arscnd  ARPACK utility routine for timing.
c     svout   ARPACK utility routine that prints vectors.
c     slamch  LAPACK routine that determines machine constants.
c     slartg  LAPACK Givens rotation construction routine.
c     slacpy  LAPACK matrix copy routine.
c     slaset  LAPACK matrix initialization routine.
c     sgemv   Level 2 BLAS routine for matrix vector multiplication.
c     saxpy   Level 1 BLAS that computes a vector triad.
c     scopy   Level 1 BLAS that copies one vector to another.
c     sscal   Level 1 BLAS that scales a vector.
c
c\Author
c     Danny Sorensen               Phuong Vu
c     Richard Lehoucq              CRPC / Rice University
c     Dept. of Computational &     Houston, Texas
c     Applied Mathematics
c     Rice University
c     Houston, Texas
c
c\Revision history:
c     12/16/93: Version ' 2.4'
c
c\SCCS Information: @(#)
c FILE: sapps.F   SID: 2.6   DATE OF SID: 3/28/97   RELEASE: 2
c
c\Remarks
c  1. In this version, each shift is applied to all the subblocks of
c     the tridiagonal matrix H and not just to the submatrix that it
c     comes from. This routine assumes that the subdiagonal elements
c     of H that are stored in h(1:kev+np,1) are nonegative upon input
c     and enforce this condition upon output. This version incorporates
c     deflation. See code for documentation.
c
c\EndLib
c
c-----------------------------------------------------------------------
c
      subroutine ssapps
     &   ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd )
c
c     %----------------------------------------------------%
c     | Include files for debugging and timing information |
c     %----------------------------------------------------%
c
      include   'debug.h'
      include   'stat.h'
c
c     %------------------%
c     | Scalar Arguments |
c     %------------------%
c
      integer    kev, ldh, ldq, ldv, n, np
c
c     %-----------------%
c     | Array Arguments |
c     %-----------------%
c
      Real
     &           h(ldh,2), q(ldq,kev+np), resid(n), shift(np),
     &           v(ldv,kev+np), workd(2*n)
c
c     %------------%
c     | Parameters |
c     %------------%
c
      Real
     &           one, zero
      parameter (one = 1.0E+0, zero = 0.0E+0)
c
c     %---------------%
c     | Local Scalars |
c     %---------------%
c
      integer    i, iend, istart, itop, j, jj, kplusp, msglvl
      logical    first
      Real
     &           a1, a2, a3, a4, big, c, epsmch, f, g, r, s
      save       epsmch, first
c
c
c     %----------------------%
c     | External Subroutines |
c     %----------------------%
c
      external   saxpy, scopy, sscal, slacpy, slartg, slaset, svout,
     &           ivout, arscnd, sgemv
c
c     %--------------------%
c     | External Functions |
c     %--------------------%
c
      Real
     &           slamch
      external   slamch
c
c     %----------------------%
c     | Intrinsics Functions |
c     %----------------------%
c
      intrinsic  abs
c
c     %----------------%
c     | Data statments |
c     %----------------%
c
      data       first / .true. /
c
c     %-----------------------%
c     | Executable Statements |
c     %-----------------------%
c
      if (first) then
         epsmch = slamch('Epsilon-Machine')
         first = .false.
      end if
      itop = 1
c
c     %-------------------------------%
c     | Initialize timing statistics  |
c     | & message level for debugging |
c     %-------------------------------%
c
      call arscnd (t0)
      msglvl = msapps
c
      kplusp = kev + np
c
c     %----------------------------------------------%
c     | Initialize Q to the identity matrix of order |
c     | kplusp used to accumulate the rotations.     |
c     %----------------------------------------------%
c
      call slaset ('All', kplusp, kplusp, zero, one, q, ldq)
c
c     %----------------------------------------------%
c     | Quick return if there are no shifts to apply |
c     %----------------------------------------------%
c
      if (np .eq. 0) go to 9000
c
c     %----------------------------------------------------------%
c     | Apply the np shifts implicitly. Apply each shift to the  |
c     | whole matrix and not just to the submatrix from which it |
c     | comes.                                                   |
c     %----------------------------------------------------------%
c
      do 90 jj = 1, np
c
         istart = itop
c
c        %----------------------------------------------------------%
c        | Check for splitting and deflation. Currently we consider |
c        | an off-diagonal element h(i+1,1) negligible if           |
c        |         h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| )   |
c        | for i=1:KEV+NP-1.                                        |
c        | If above condition tests true then we set h(i+1,1) = 0.  |
c        | Note that h(1:KEV+NP,1) are assumed to be non negative.  |
c        %----------------------------------------------------------%
c
   20    continue
c
c        %------------------------------------------------%
c        | The following loop exits early if we encounter |
c        | a negligible off diagonal element.             |
c        %------------------------------------------------%
c
         do 30 i = istart, kplusp-1
            big   = abs(h(i,2)) + abs(h(i+1,2))
            if (h(i+1,1) .le. epsmch*big) then
               if (msglvl .gt. 0) then
                  call ivout (logfil, 1, i, ndigit,
     &                 '_sapps: deflation at row/column no.')
                  call ivout (logfil, 1, jj, ndigit,
     &                 '_sapps: occured before shift number.')
                  call svout (logfil, 1, h(i+1,1), ndigit,
     &                 '_sapps: the corresponding off diagonal element')
               end if
               h(i+1,1) = zero
               iend = i
               go to 40
            end if
   30    continue
         iend = kplusp
   40    continue
c
         if (istart .lt. iend) then
c
c           %--------------------------------------------------------%
c           | Construct the plane rotation G'(istart,istart+1,theta) |
c           | that attempts to drive h(istart+1,1) to zero.          |
c           %--------------------------------------------------------%
c
             f = h(istart,2) - shift(jj)
             g = h(istart+1,1)
             call slartg (f, g, c, s, r)
c
c            %-------------------------------------------------------%
c            | Apply rotation to the left and right of H;            |
c            | H <- G' * H * G,  where G = G(istart,istart+1,theta). |
c            | This will create a "bulge".                           |
c            %-------------------------------------------------------%
c
             a1 = c*h(istart,2)   + s*h(istart+1,1)
             a2 = c*h(istart+1,1) + s*h(istart+1,2)
             a4 = c*h(istart+1,2) - s*h(istart+1,1)
             a3 = c*h(istart+1,1) - s*h(istart,2)
             h(istart,2)   = c*a1 + s*a2
             h(istart+1,2) = c*a4 - s*a3
             h(istart+1,1) = c*a3 + s*a4
c
c            %----------------------------------------------------%
c            | Accumulate the rotation in the matrix Q;  Q <- Q*G |
c            %----------------------------------------------------%
c
             do 60 j = 1, min(istart+jj,kplusp)
                a1            =   c*q(j,istart) + s*q(j,istart+1)
                q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1)
                q(j,istart)   = a1
   60        continue
c
c
c            %----------------------------------------------%
c            | The following loop chases the bulge created. |
c            | Note that the previous rotation may also be  |
c            | done within the following loop. But it is    |
c            | kept separate to make the distinction among  |
c            | the bulge chasing sweeps and the first plane |
c            | rotation designed to drive h(istart+1,1) to  |
c            | zero.                                        |
c            %----------------------------------------------%
c
             do 70 i = istart+1, iend-1
c
c               %----------------------------------------------%
c               | Construct the plane rotation G'(i,i+1,theta) |
c               | that zeros the i-th bulge that was created   |
c               | by G(i-1,i,theta). g represents the bulge.   |
c               %----------------------------------------------%
c
                f = h(i,1)
                g = s*h(i+1,1)
c
c               %----------------------------------%
c               | Final update with G(i-1,i,theta) |
c               %----------------------------------%
c
                h(i+1,1) = c*h(i+1,1)
                call slartg (f, g, c, s, r)
c
c               %-------------------------------------------%
c               | The following ensures that h(1:iend-1,1), |
c               | the first iend-2 off diagonal of elements |
c               | H, remain non negative.                   |
c               %-------------------------------------------%
c
                if (r .lt. zero) then
                   r = -r
                   c = -c
                   s = -s
                end if
c
c               %--------------------------------------------%
c               | Apply rotation to the left and right of H; |
c               | H <- G * H * G',  where G = G(i,i+1,theta) |
c               %--------------------------------------------%
c
                h(i,1) = r
c
                a1 = c*h(i,2)   + s*h(i+1,1)
                a2 = c*h(i+1,1) + s*h(i+1,2)
                a3 = c*h(i+1,1) - s*h(i,2)
                a4 = c*h(i+1,2) - s*h(i+1,1)
c
                h(i,2)   = c*a1 + s*a2
                h(i+1,2) = c*a4 - s*a3
                h(i+1,1) = c*a3 + s*a4
c
c               %----------------------------------------------------%
c               | Accumulate the rotation in the matrix Q;  Q <- Q*G |
c               %----------------------------------------------------%
c
                do 50 j = 1, min( i+jj, kplusp )
                   a1       =   c*q(j,i) + s*q(j,i+1)
                   q(j,i+1) = - s*q(j,i) + c*q(j,i+1)
                   q(j,i)   = a1
   50           continue
c
   70        continue
c
         end if
c
c        %--------------------------%
c        | Update the block pointer |
c        %--------------------------%
c
         istart = iend + 1
c
c        %------------------------------------------%
c        | Make sure that h(iend,1) is non-negative |
c        | If not then set h(iend,1) <-- -h(iend,1) |
c        | and negate the last column of Q.         |
c        | We have effectively carried out a        |
c        | similarity on transformation H           |
c        %------------------------------------------%
c
         if (h(iend,1) .lt. zero) then
             h(iend,1) = -h(iend,1)
             call sscal(kplusp, -one, q(1,iend), 1)
         end if
c
c        %--------------------------------------------------------%
c        | Apply the same shift to the next block if there is any |
c        %--------------------------------------------------------%
c
         if (iend .lt. kplusp) go to 20
c
c        %-----------------------------------------------------%
c        | Check if we can increase the the start of the block |
c        %-----------------------------------------------------%
c
         do 80 i = itop, kplusp-1
            if (h(i+1,1) .gt. zero) go to 90
            itop  = itop + 1
   80    continue
c
c        %-----------------------------------%
c        | Finished applying the jj-th shift |
c        %-----------------------------------%
c
   90 continue
c
c     %------------------------------------------%
c     | All shifts have been applied. Check for  |
c     | more possible deflation that might occur |
c     | after the last shift is applied.         |
c     %------------------------------------------%
c
      do 100 i = itop, kplusp-1
         big   = abs(h(i,2)) + abs(h(i+1,2))
         if (h(i+1,1) .le. epsmch*big) then
            if (msglvl .gt. 0) then
               call ivout (logfil, 1, i, ndigit,
     &              '_sapps: deflation at row/column no.')
               call svout (logfil, 1, h(i+1,1), ndigit,
     &              '_sapps: the corresponding off diagonal element')
            end if
            h(i+1,1) = zero
         end if
 100  continue
c
c     %-------------------------------------------------%
c     | Compute the (kev+1)-st column of (V*Q) and      |
c     | temporarily store the result in WORKD(N+1:2*N). |
c     | This is not necessary if h(kev+1,1) = 0.         |
c     %-------------------------------------------------%
c
      if ( h(kev+1,1) .gt. zero )
     &   call sgemv ('N', n, kplusp, one, v, ldv,
     &                q(1,kev+1), 1, zero, workd(n+1), 1)
c
c     %-------------------------------------------------------%
c     | Compute column 1 to kev of (V*Q) in backward order    |
c     | taking advantage that Q is an upper triangular matrix |
c     | with lower bandwidth np.                              |
c     | Place results in v(:,kplusp-kev:kplusp) temporarily.  |
c     %-------------------------------------------------------%
c
      do 130 i = 1, kev
         call sgemv ('N', n, kplusp-i+1, one, v, ldv,
     &               q(1,kev-i+1), 1, zero, workd, 1)
         call scopy (n, workd, 1, v(1,kplusp-i+1), 1)
  130 continue
c
c     %-------------------------------------------------%
c     |  Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). |
c     %-------------------------------------------------%
c
      call slacpy ('All', n, kev, v(1,np+1), ldv, v, ldv)
c
c     %--------------------------------------------%
c     | Copy the (kev+1)-st column of (V*Q) in the |
c     | appropriate place if h(kev+1,1) .ne. zero. |
c     %--------------------------------------------%
c
      if ( h(kev+1,1) .gt. zero )
     &     call scopy (n, workd(n+1), 1, v(1,kev+1), 1)
c
c     %-------------------------------------%
c     | Update the residual vector:         |
c     |    r <- sigmak*r + betak*v(:,kev+1) |
c     | where                               |
c     |    sigmak = (e_{kev+p}'*Q)*e_{kev}  |
c     |    betak = e_{kev+1}'*H*e_{kev}     |
c     %-------------------------------------%
c
      call sscal (n, q(kplusp,kev), resid, 1)
      if (h(kev+1,1) .gt. zero)
     &   call saxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1)
c
      if (msglvl .gt. 1) then
         call svout (logfil, 1, q(kplusp,kev), ndigit,
     &      '_sapps: sigmak of the updated residual vector')
         call svout (logfil, 1, h(kev+1,1), ndigit,
     &      '_sapps: betak of the updated residual vector')
         call svout (logfil, kev, h(1,2), ndigit,
     &      '_sapps: updated main diagonal of H for next iteration')
         if (kev .gt. 1) then
         call svout (logfil, kev-1, h(2,1), ndigit,
     &      '_sapps: updated sub diagonal of H for next iteration')
         end if
      end if
c
      call arscnd (t1)
      tsapps = tsapps + (t1 - t0)
c
 9000 continue
      return
c
c     %---------------%
c     | End of ssapps |
c     %---------------%
c
      end


      subroutine torus_basis_complete(x,y, t, tinv,tderivs, flag)
      implicit none

      double precision x,y
      integer flag
      double precision t(3,2), tinv(3,2), tderivs(3,2,2)

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta, theta_range(2), phi_range(2)
      common /torus_comm/ alpha, beta, theta_range, phi_range

      double precision r1, r1x, r1xx, r1y, r1yy, r1xy
      double precision R,  Rx,  Rxx,  Ry,  Ryy,  Rxy
      double precision f(3), fx(3), fy(3), fxx(3), fyy(3), fxy(3)
      double precision g(3), gx(3), gy(3), gxx(3), gyy(3), gxy(3)
c      double precision t1(3), t2(3), a11, a12, a22, a21
c      double precision det, a11inv, a22inv, a12inv, a21inv
      double precision pi4
      double precision map_dot

      double precision theta, phi
      double precision thetax, thetay, phix, phiy

      integer k, kk, i
      logical compute_covariant, compute_contravariant
      logical compute_derivatives, b(32)

      if (flag > 7) then
          write(6,*) 'torus_basis_complete : flag > 7'
          stop
      endif

c     # flag = 0      NA
c     # flag = 1      Covariant basis only
c     # flag = 2      NA
c     # flag = 3      Covariant + contravariant basis
c     # flag = 4      Derivatives only
c     # flag = 5      Derivatives + covariant basis
c     # flag = 6      NA
c     # flag = 7      Covariant + contravariant + derivatives

      do i = 1,bit_size(flag)
          b(i) = btest(flag,i-1)
      enddo

      compute_covariant     = b(1) .or. b(2)
      compute_contravariant = b(2)
      compute_derivatives   = b(3)

      pi4 = pi2*pi2

c     # Torus mapping
c     #
c     #    r1 = alpha*(1 + beta*sin(pi2*x))
c     #    R = 1 + r1*cos(pi2*y)
c     #
c     #    xp =  R*cos(pi2*x)
c     #    yp =  R*sin(pi2*x)
c     #    zp = r1*sin(pi2*y)
c     #
c     #  Express X,Y,Z as
c     #
c     #     X(x,y) = g(x,y)*f(x,y) == g(1)*f(1)
c     #     Y(x,y) = g(x,y)*f(x,y) == g(2)*f(2)
c     #     Z(x,y) = g(x,y)*f(x,y) == g(3)*f(3)
c     #
c     # Compute derivatives and use product rule to get higher order
c     # derivatives, i.e.
c     #
c     #     dX/dx = g(1)*fx(1) + gx(1)*f(1)
c     #     dY/dx = g(2)*fx(2) + gx(2)*f(2)
c     #     dZ/dx = g(3)*fx(3) + gx(3)*f(3)
c     #

      call map_comp2toroidal_derivs(x,y,theta,phi,
     &           thetax, thetay, phix, phiy)

      r1    = alpha*(1 + beta*sin(theta))
      r1x   = alpha*beta*cos(theta)*thetax
      r1y   = 0
      r1xx  = -alpha*beta*sin(theta)*thetax*thetax
      r1yy  = 0
      r1xy  = 0

      R     = 1 +   r1*cos(phi)
      Rx    =      r1x*cos(phi)
      Rxx   =     r1xx*cos(phi)
      Ry    =  -r1*sin(phi)*phiy
      Ryy   =  -r1*cos(phi)*phiy*phiy
      Rxy   = -r1x*sin(phi)*phiy

      f(1)  = cos(theta);
      fx(1) = -sin(theta)*thetax
      fy(1) = 0;

      f(2)  = sin(theta);
      fx(2) = cos(theta)*thetax
      fy(2) = 0;

      f(3)  = sin(phi);
      fx(3) = 0;
      fy(3) = cos(phi)*phiy

      g(1)  = R
      g(2)  = R
      g(3)  = r1

      gx(1) = Rx
      gx(2) = Rx
      gx(3) = r1x

      gy(1) = Ry
      gy(2) = Ry
      gy(3) = r1y

      if (compute_covariant) then
          do k = 1,3
              t(k,1) = gx(k)*f(k) + g(k)*fx(k);
              t(k,2) = gy(k)*f(k) + g(k)*fy(k);
          enddo
      endif

      if (compute_contravariant) then
          call map_contravariant(t,tinv)
      endif

      if (compute_derivatives) then
          fxx(1) = -cos(theta)*thetax**2
          fyy(1) = 0;
          fxy(1) = 0;

          fxx(2) = -sin(theta)*thetax**2
          fyy(2) = 0;
          fxy(2) = 0;

          fxx(3) = 0;
          fxy(3) = 0;
          fyy(3) = -sin(phi)*phiy**2

          gxx(1) = Rxx
          gxx(2) = Rxx
          gxx(3) = r1xx

          gyy(1) = Ryy
          gyy(2) = Ryy
          gyy(3) = r1yy

          gxy(1) = Rxy
          gxy(2) = Rxy
          gxy(3) = r1xy

          do k = 1,3
c             # d(t1)/dx = d(g*fx + gx*f)/dx
              tderivs(k,1,1) = g(k)*fxx(k) + 2*fx(k)*gx(k) + gxx(k)*f(k)

c             # d(t1)/dy = d(g*fx + gx*f)/dy
              tderivs(k,1,2) = g(k)*fxy(k) + gy(k)*fx(k) +
     &                    gx(k)*fy(k) + gxy(k)*f(k)

c             # d(t2)/dx = d(g*fy + gy*f)/dx
              tderivs(k,2,1) = g(k)*fxy(k) + gx(k)*fy(k) +
     &                    gy(k)*fx(k) + gxy(k)*f(k)

c             # d(t2)/dy = d(g*fy + gy*f)/dy
              tderivs(k,2,2) = g(k)*fyy(k) + 2*fy(k)*gy(k) + gyy(k)*f(k)
          enddo
      endif

      end

      subroutine map_comp2torus(xc,yc,theta,phi)
      implicit none

      double precision xc,yc,theta, phi

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta, theta_range(2), phi_range(2)
      common /torus_comm/ alpha, beta, theta_range, phi_range

      double precision thetax, thetay, phix, phiy

c     # Map xc in [0,1] to theta in [-pi,pi]
c     # Map yc in [0,1] to phi in [-pi/2,pi/2]

      call map_comp2toroidal_derivs(xc,yc,theta,phi,
     &               thetax, thetay, phix, phiy)

      end

      subroutine map_comp2toroidal_derivs(xc,yc,theta,phi,
     &      thetax, thetay, phix, phiy)
      implicit none

      double precision xc,yc,theta, phi
      double precision  thetax, thetay, phix, phiy

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta, theta_range(2), phi_range(2)
      common /torus_comm/ alpha, beta, theta_range, phi_range

      double precision tr1, tr2, pr1, pr2

c     # Map xc in [0,1] to theta in [0,2*pi]
c     # Map yc in [0,1] to phi in [-pi/2,pi/2]

      tr1 = pi2*theta_range(1)
      tr2 = pi2*theta_range(2)

      theta = tr1 + (tr2-tr1)*xc
      thetax = tr2-tr1
      thetay = 0

      pr1 = pi2*phi_range(1)
      pr2 = pi2*phi_range(2)

      phi = pr1 + (pr2-pr1)*yc
      phix = 0
      phiy = pr2-pr1

      end

      subroutine map_toroidal2comp(theta,phi,xc,yc)
      implicit none

      double precision xc,yc,phi,theta

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta, theta_range(2), phi_range(2)
      common /torus_comm/ alpha, beta, theta_range, phi_range

      double precision tr1, tr2, pr1, pr2

c     # Map xc in [0,1] to theta in [0,2*pi]
c     # Map yc in [0,1] to phi in [-pi/2,pi/2]

      tr1 = pi2*theta_range(1)
      tr2 = pi2*theta_range(2)

      pr1 = pi2*phi_range(1)
      pr2 = pi2*phi_range(2)

      xc = (theta-tr1)/(tr2-tr1)
      yc = (phi-pr1)/(pr2-pr1)

      end

      subroutine map2toroidal(xp,yp,zp,theta,phi)
      implicit none

      double precision xp,yp,zp,phi,theta

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision alpha, beta, theta_range(2), phi_range(2)
      common /torus_comm/ alpha, beta, theta_range, phi_range

      double precision r1, r

c      r1 = alpha*(1 + beta*sin(pi2*xc))
c      R = 1 + r1*cos(pi2*yc)
c
c      xp = R*cos(pi2*xc)
c      yp = R*sin(pi2*xc)
c      zp = r1*sin(pi2*yc)

      theta = atan2(yp,xp)    !! returns value in [-pi, pi]
      if (theta < 0) then
          theta = theta + pi2
      endif

      r1 = alpha*(1 + beta*sin(theta))
      if (r1 .eq. 0) then
          write(6,*) 'torus_basis.f : r1 .eq. 0'
          stop
      endif

c     # Phi in [-pi/2, pi/2];  We need to transform it to
c     # [0,2*pi]
      phi = asin(zp/r1)
      r = sqrt(xp**2 + yp**2)
      if (r .le. 1) then
          if (phi .gt. 0) then
              phi = pi - phi
          else
              phi = -pi - phi
          endif
      endif
      if (phi < 0) then
          phi = phi + pi2
      endif

      end

      subroutine map2comp(xp,yp,zp,xc,yc)
      implicit none

      double precision xp,yp,zp, xc,yc

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision phi, theta

      call map2toroidal(xp,yp,zp,theta,phi)

      call map_toroidal2comp(theta,phi,xc,yc)

      end

cc     # Map to computational coordinates in [0,1]x[0,1]
c      subroutine map2comp(blockno,xc,yc,xp,yp,zp,xc1,yc1)
c      implicit none
c
c      double precision xc,yc,xp,yp,zp,xc1,yc1, zc1
c      integer blockno
c
c      integer*8 cont, get_context
c
c      cont = get_context()
c
cc     # We shouldn't be returning zc1 here - should always be zero in 2d
c      call fclaw2d_map_brick2c(cont,blockno,xc,yc,xc1,yc1,zc1)
c
c
c      end


       include 'ttb/ttb_library.f'

       program script_tensortoolbox

       ! Example program for ttb-usage
       ! ttb is only active inside user subroutine

       implicit none

       real(kind=8), dimension(3,3) :: F, E, Eye

       real(kind=8), dimension(3,3) :: Siso
       real(kind=8), dimension(3,3,3,3) :: C4iso

       ! Deformation Gradient
       F = 0.0
       F(1,1) = 1.1
       F(2,2) = 1.0
       F(3,3) = 1.0
       F(1,2) = 0.1
       F(1,3) = 0.0

       Eye = 0.0
       Eye(1,1) = 1.0
       Eye(2,2) = 1.0
       Eye(3,3) = 1.0

       ! Green-Lagrange Strain
       E = 0.5*(matmul(transpose(F),F) - Eye)

       ! User Material Subroutine
       call umat(Siso,C4iso,F,E)

       ! Outputs
       print *, ''
       print *, '2nd Piola Kirchhoff Stress Tensor'
       write (*,993) Siso
       print *, ''
       print *, 'Material Elasticity Tensor'
       write (*,999) C4iso
       print *, ''

993    format('| ',f8.2,' ',f8.2,' ',f8.2,' |')
996    format('| ',f8.2,' ',f8.2,' ',f8.2,' ',
     *             f8.2,' ',f8.2,' ',f8.2,' |')
999    format('| ',f8.2,' ',f8.2,' ',f8.2,' ',
     *             f8.2,' ',f8.2,' ',f8.2,' ',
     *             f8.2,' ',f8.2,' ',f8.2,' |')

       end program script_tensortoolbox

       subroutine umat(Siso_arr,C4iso_arr,F_arr,E_arr)
       ! A very basic Example of a User Material Subroutine
       ! Isochoric part of nearly-incompressible Neo-Hookean material

       use Tensor

       implicit none

       real(kind=8) :: J

       real(kind=8), dimension(3,3), intent(in) :: F_arr, E_arr
       real(kind=8), dimension(3,3), intent(inout) :: Siso_arr
       real(kind=8), dimension(3,3,3,3), intent(inout) :: C4iso_arr

       type(Tensor2) :: F, E
       type(Tensor2) :: Siso
       type(Tensor4) :: C4iso

       type(Tensor2) :: Shat, Eye, C, invC
       type(Tensor4) :: C4hat, P4

       F = F_arr
       E = E_arr

       J = det(F)
       Eye = identity2(Eye)

       C = transpose(F)*F
       invC = inv(C)

       Shat = J**(-2./3.)*Eye

       ! Isochoric part of 2nd Piola Kirchhoff stress tensor
       Siso = dev(Shat*C)*invC

       ! Deviatoric projection tensor
       P4 = identity4(Eye)-1./3.*(invC.dya.C)
       C4hat = J**(-4./3.)*0.d0

       ! Isochoric part of Material Elasticity tensor
       C4iso = P4**C4hat**transpose(P4)
     *      + 2./3.*tr(Shat*C)*identity4(invC)
     *      - 2./3.*((Shat.dya.invC)+(invC.dya.Shat))
     *      + 2./9.*tr(Shat*C)*(invC.dya.invC)

       ! Ouput Tensor as Array with given dimensions
       Siso_arr(1:3,1:3) = Siso%ab(1:3,1:3)
       C4iso_arr(1:3,1:3,1:3,1:3) = C4iso%abcd(1:3,1:3,1:3,1:3)

       end