      include 'ttb/ttb_library.f'

      subroutine hypela2(d,g,e,de,s,t,dt,ngens,m,nn,kcus,matus,ndi,
     2             nshear,disp,dispt,coord,ffn,frotn,strechn,eigvn,ffn1,
     3                   frotn1,strechn1,eigvn1,ncrd,itel,ndeg,ndm,
     4                   nnode,jtype,lclass,ifr,ifu)

      ! HYPELA2 Nonlinear Viscoelasticity with
      !         Neo-Hookean Hyperelasticity
      ! ----------------------------------------------------------------
      ! Source: Shutov et.al. (2013): An explicit solution for
      !         implicit time stepping in multiplicative
      !         finite strain viscoelasticity.
      !         DOI: http://dx.doi.org/10.1016/j.cma.2013.07.004
      !         --> Lagrangian formulation, EBMSC-method (eq.41f)
      !
      ! Formulation: Total Lagrange, Large Strain
      !             (with option for Updated Lagrange with Push Forward
      !              and Jaumann-like Tangent Correction included)
      !
      ! ----------------------------------------------------------------
      ! Andreas Dutzler, Graz University of Technology
      ! 2018-04-05

      use Tensor
      implicit none

      integer :: ifr,ifu,itel,jtype,ncrd,ndeg,ndi,ndm,ngens,
     *           nn,nnode,nshear
      integer,      dimension(2)       :: m,matus,kcus,lclass
      real(kind=8), dimension(*)       :: e,de,t,dt,g,s
      real(kind=8), dimension(itel)    :: strechn,strechn1
      real(kind=8), dimension(ngens,*) :: d
      real(kind=8), dimension(ncrd,*)  :: coord
      real(kind=8), dimension(ndeg,*)  :: disp, dispt
      real(kind=8), dimension(itel,3)  :: ffn,ffn1,frotn,frotn1
      real(kind=8), dimension(itel,*)  :: eigvn,eigvn1

      include 'concom'
      include 'creeps'

      ! begin user code
      type(Tensor2)  :: F1
      type(Tensor2s) :: C1,invC1,C0_i,invC1_i,S1,S1_hat,S1_bar,Eye,
     *                  Phi,Phi_hat,invPhi
      type(Tensor4s) :: C4,C4_hat,C4_bar,I4,P4,Eye4
      real(kind=8)   :: J,J_th,C10,mu,eta,kappa,tr_SC,
     *                  p,dpdJ,detPhi,dtime

      ! material parameters
      C10 = 0.5
      mu = 2.0
      eta = 10.0
      kappa = 50.0

      ! time increment
      dtime = timinc

      ! deformation gradient
      Eye = identity2(Eye)
      F1 = Eye
      F1%ab(1:itel,1:3) = ffn1(1:itel,1:3)

      ! volumetric ratio
      J = det(F1)

      ! hydrostatic stress and derivative
      p = kappa*(J-1)
      dpdJ = kappa

      ! right cauchy-green deformation tensor and inverse
      C1 = transpose(F1)*F1
      invC1 = inv(C1,J**2)

      ! PK2-stress elastic ground network
      S1_hat = 2.*C10*Eye
      C4_hat = 0.0

      ! inelastic deformation at beginning of the inc.
      C0_i = t(2:7)
      if (t(2) == 0.0) then
       ! if start of analysis is detected
       ! --> no inelastic deformation
       C0_i = Eye
      end if

      ! inelastic part of rCG (= Phi_hat)
      Phi = C0_i + mu*dtime/eta * J**(-2./3.)*C1
      Phi_hat = unimodular(Phi)
      invC1_i = inv(Phi_hat,1.d0)

      ! PK2-stress viscous overstress
      S1_hat = S1_hat + mu*(invC1_i)
      Eye4 = Eye.cdya.Eye
      detPhi = det(Phi)
      invPhi = inv(Phi,detPhi)
      C4_hat = C4_hat + (mu*(invC1_i.cdya.invC1_i))**
     *         (detPhi**(-1./3.) * 2.*mu*dtime/eta*
     *         (Eye4 - 1./3.*(Phi.dya.invPhi)))

      S1_bar = J**(-2./3.) * S1_hat
      C4_bar = J**(-4./3.) * C4_hat

      ! distortional + hydrostatic component of PK2-stress
      tr_SC = S1_bar**C1
      S1 = (S1_bar - 1./3.*tr_SC*invC1) + p*J*invC1

      ! material elasticity tensor
      I4 = invC1.cdya.invC1
      P4 = (Eye.cdya.Eye) - 1./3.*(invC1.dya.C1)
      C4 = P4**C4_bar**transpose(P4)
     *    + 2./3. * (tr_SC*I4
     *    -(S1_bar.dya.invC1)-(invC1.dya.S1_bar)
     *    +tr_SC/3.*(invC1.dya.invC1))
     *    +(p*J+dpdJ*J**2)*(invC1.dya.invC1)
     *    -2.*p*J*I4

      ! (lovl==6) --> solution converged, save state variables
      if (lovl.eq.6) then
       t(2:7) = asarray( asvoigt(Phi_hat), 6)
      end if

      ! updated lagrange
      if (iupdat.eq.1) then
       ! cauchy stress
       S1 = piola(F1,S1)/J
       ! tangent matrix (jaumann-like co-rotated)
       C4 = piola(F1,C4)/J
     *      + (S1.cdya.Eye) + (Eye.cdya.S1)
      endif

      ! output as array
      s(1:ngens)         = asarray( asvoigt(S1), ngens )
      d(1:ngens,1:ngens) = asarray( asvoigt(C4), ngens,ngens )

      return
      end


! =====================================================
subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,fwave,s,amdq,apdq)
! =====================================================

! Approximate Riemann solver for the nonlinear p-system in 2d
! with variable coefficients.

! waves: 2
! equations: 3

! Conserved quantities:
!       1 strain
!       2 x_momentum
!       3 y_momentum

! The variable names are based on an elasticity interpretation

! The jacobian matrix of the flux vector (in each direction)
! is approximated by the linear localized problem.

! There are 3 eigenvectors; however, the second eigenvalue
! is always zero and just two waves are computed.

! Solve Riemann problems along one slice of data:
!  in the x-direction if ixy=1
!  in the y-direction if ixy=2.

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell

! f-wave approach is considered. This consists in decomposing the flux
! difference (assuming it's continuous) using the eigenvectors of the
! jacobian matrices of the flux vectors (in each spatial direction).
! This is convinient for variable coefficient PDEs.

! On output, fwave contains the f-waves,
!            s the speeds,
!            amdq the  left-going fluctuation
!            apdq the right-going fluctuation

! Note that the i'th Riemann problem has left state qr(i-1,:)
!                                    and right state ql(i,:)
! From the basic clawpack routines, this routine is called with ql = qr

    implicit double precision (a-h,o-z)
    dimension fwave(meqn,mwaves,1-mbc:maxm+mbc)
    dimension    s(mwaves,1-mbc:maxm+mbc)
    dimension   ql(meqn,1-mbc:maxm+mbc)
    dimension   qr(meqn,1-mbc:maxm+mbc)
    dimension apdq(meqn,1-mbc:maxm+mbc)
    dimension amdq(meqn,1-mbc:maxm+mbc)
    dimension auxl(maux,1-mbc:maxm+mbc)
    dimension auxr(maux,1-mbc:maxm+mbc)

    do 10 i=2-mbc,mx+mbc
    ! material properties
        pim=auxr(1,i-1)
        pi=auxl(1,i)
        Eim=auxr(2,i-1)
        Ei=auxl(2,i)
    ! solution eps, urho and vrho
        epsi=ql(1,i)
        urhoi=ql(2,i)
        vrhoi=ql(3,i)
        epsim=qr(1,i-1)
        urhoim=qr(2,i-1)
        vrhoim=qr(3,i-1)
    ! linearity of material (for cell i and for cell im)
        linearity_mati=auxl(3,i)
        linearity_matim=auxr(3,i-1)
    ! sigma
        sigmai=sigma(epsi,Ei,linearity_mati)
        sigmaim=sigma(epsim,Eim,linearity_matim)
    ! sigmap
        sigmapi=sigmap(epsi,Ei,linearity_mati)
        sigmapim=sigmap(epsim,Eim,linearity_matim)
    ! computation of components of eigenvectors
        r11=1/dsqrt(sigmapim*pim)
        r13=-1/dsqrt(sigmapi*pi)
    ! shock speeds
        s(1,i)=-dsqrt(sigmapim/pim)  !lambda_1
        s(2,i)=dsqrt(sigmapi/pi)     !lambda_2

        if(ixy == 1) then      !x direction
        ! compute jump in flux
            dF1=-(urhoi/pi-urhoim/pim)
            dF2=-(sigmai-sigmaim)
        ! compute betas
            beta1=(dF1-r13*dF2)/(r11-r13)
            beta3=(-dF1+r11*dF2)/(r11-r13)
        ! compute f-waves
            fwave(1,1,i)=beta1*r11
            fwave(2,1,i)=beta1*1
            fwave(3,1,i)=beta1*0
            fwave(1,2,i)=beta3*r13
            fwave(2,2,i)=beta3*1
            fwave(3,2,i)=beta3*0
        else                   !y direction
        ! compute jump in flux
            dF1=-(vrhoi/pi-vrhoim/pim)
            dF3=-(sigmai-sigmaim)
        ! compute betas
            beta1=(dF1-r13*dF3)/(r11-r13)
            beta3=(-dF1+r11*dF3)/(r11-r13)
        ! compute f-waves
            fwave(1,1,i)=beta1*r11
            fwave(2,1,i)=beta1*0
            fwave(3,1,i)=beta1*1
            fwave(1,2,i)=beta3*r13
            fwave(2,2,i)=beta3*0
            fwave(3,2,i)=beta3*1
        endif
    ! computation of the fluctuations
        amdq(1,i)=fwave(1,1,i)
        amdq(2,i)=fwave(2,1,i)
        amdq(3,i)=fwave(3,1,i)
        apdq(1,i)=fwave(1,2,i)
        apdq(2,i)=fwave(2,2,i)
        apdq(3,i)=fwave(3,2,i)

    10 END DO

    return
    end subroutine rpn2

    double precision function sigma(eps,E,linearity_mat)
!     Returns the flux sigma for a given
!     eps, E and depending the linearity of the material
    implicit double precision (a-h,o-z)
    beta=5
    select case (linearity_mat)
    case (1)
    sigma=E*eps
    case (2)
    sigma=dexp(E*eps)-1
    case (3)
    sigma=0.1*E*eps+beta*eps**3*E**3
    end select
    return
    END function

    double precision function sigmap(eps,E,linearity_mat)
    implicit double precision (a-h,o-z)
! Returns the derivative of sigma wrt eps for a given
!     eps, E and depending the linearity of the material
    beta=5
    select case (linearity_mat)
    case (1)
    sigmap=E
    case (2)
    sigmap=E*dexp(E*eps)
    case (3)
    sigmap=0.1*E+3*beta*eps**2*E**3
    end select
    return
    END function


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none
    real*8, parameter :: mu = 1d0, sig2 = 0.1d0, minp = 1d0
    integer, parameter :: n = 10
    real*8 :: y(0:n), w(0:n)

contains

    function market(A)

        implicit none
        real*8, intent(in) :: A
        real*8 :: market
        real*8 :: Ep

        ! calculate expected price
        Ep = sum(w*max(3d0-2d0*A*y, minp))

        ! get equilibrium equation
        market = A - (0.5d0+0.5d0*Ep)

    end function

end module globals


program intel_dgesvd

use,intrinsic:: iso_fortran_env, only: sp=>real32, dp=>real64, compiler_version, stderr=>error_unit

implicit none (type, external)

external :: dgesvd

! Intel(R) Fortran Intel(R) 64 Compiler for applications running on Intel(R) 64,
! Version 19.0.1.144 Build 20181018
! 64 bits: error mag:   0.000000000000E+00  0.000000000000E+00  0.000000000000E+00

! GCC version 7.3.0  (system Lapack)
! 64 bits: error mag:   0.000000000000E+00  2.220446049250E-16  4.996003610813E-16

! GCC version 7.3.0  (MKL 19)
! 64 bits: error mag:   6.952923663893-310  6.941716482845-310  4.940656458412-324

! pgf90 18.10-0 (system Lapack
! 64 bits: error mag:   0.000000000000E+00  2.220446049250E-16  4.996003610813E-16

! pgf90 18.10-0 (MKL 19)
! 64 bits: error mag:   0.000000000000E+00  0.000000000000E+00  0.000000000000E+00

real(dp):: A(3,3) = reshape( &
        [ 1, 0, 1, &
         -1,-2, 0, &
          0, 1,-1 ], &
           shape(A))

integer :: svdinfo
integer, parameter :: M = size(a,1), N = size(a,2), Lratio = 5
integer, parameter :: LWORK = LRATIO*M
real(dp) :: U(M,M),VT(M,M), SWORK(LRATIO*M)

real(dp) :: ss64(M, N), s64(M), e64(M), maxerr
real(dp), parameter :: s64ref(3) = [2.460504870018764_dp, 1.699628148275318_dp, 0.239123278256554_dp]

call dgesvd('A','N',M,M,A,M,SS64,U,M,VT,M, SWORK, LWORK,svdinfo)
if (svdinfo /=0) then
  write(stderr,*) 'svd error: ',svdinfo
  error stop
endif

s64 = ss64(:,1)  ! NOT DIAG!!!!

!e64 = s64 - S64ref

print *,compiler_version()
print '(I3,A,3ES20.12)',storage_size(s64),' bits: error mag: ',e64

maxerr=maxval(abs(e64))

if (maxerr > 1e-7_dp) error stop 'excessive singular value error'

end program


!
!  ludcmp.f90
!
!
!  Created by Xingshi on 1/30/08.
!  Copyright 2008 __MyCompanyName__. All rights reserved.
!  a the matrix put in , n=np give the dimension, d returns the determinant
	   subroutine determinant(a,n,np,d)! LU decomposition to calculate dertiminant
	   integer n, np
	   real(8) d, a(np,np)
	   integer indx(n)
	   integer j
	   call ludcmp(a,n,np,indx,d)
	   do j=1,n
	      d=d*a(j,j)
	   end do
	   return
	   end

	   subroutine ludcmp(a,n,np,inx,d)
	   integer n,np,indx(n), NMAX
	   real(8) d, a(np,np), TINY
	   parameter (NMAX=500, TINY=1.0e-20)
	   integer i, imax,j,k
	   real(8) aamax, dum, summ, vv(NMAX)
	   d=1
	   do i=1,n
	      aamax=0.0d0
		  do j=1,n
		     if (abs(a(i,j)) .gt. aamax) aamax=abs(a(i,j))
		  end do
		  if (aamax .eq. 0) pause 'sigular matrix in ludcmp'
		  vv(i)=1.d0/aamax
	   end do
	   do j=1,n
	      do i=1,j-1
		     summ=a(i,j)
			 do k=1, i-1
			 summ=summ-a(i,k)*a(k,j)
			 end do
			 a(i,j)=summ
              end do
              aamax=0
              do i=j,n
                 summ=a(i,j)
                 do k=1,j-1
                    summ=summ-a(i,k)*a(k,j)
                 end do
                 a(i,j)=summ
			 dum=vv(i)*abs(summ)
			 if (dum .ge. aamax) then
			    imax=i
				aamax=dum
			 end if
	       end do

		   if (j .ne. imax) then
		      do k=1,n
			     dum=a(imax,k)
				 a(imax,k)=a(j,k)
				 a(j,k)=dum
			  end do
			  d=-d
			  vv(imax)=vv(j)
		    end if
			indx(j)=imax
			if(a(j,j) .eq. 0) a(j,j)=TINY
			if (j .ne. n) then
			   dum=1./a(j,j)
			   do i= j+1, n
			      a(i,j)=a(i,j)*dum
			   end do
			end if
		end do
          return
       end


#
# Example program: FizzBuzz!
#
use foreach

fbz(x | x % 15 = 0): say(x, ' FizzBuzz') .
fbz(x | x % 3 = 0):  say(x, ' Fizz') .
fbz(x | x % 5 = 0):  say(x, ' Buzz') .
fbz(x) : say(x).

main():
    foreach( [x | 1 <= x <= 100] ,  fbz ).


program modulo_test
  implicit none
  integer, parameter :: n=1024
  real :: array(n,n)
  integer :: i
  !$omp declare target map(alloc:array)

  !$omp target teams distribute parallel do simd
  do i=1,size(array)
    array(modulo(i,n),i/n)=i
  enddo
end program modulo_test


PROGRAM symmetric_eigen

! Demonstration program 2 using the 'LONG' package.   Calculation of the
! eigenvalues & vectors of 2 large symmetric matrices using Kaiser's method.
! In this version, quadruple precision is used to orthogonalize the columns
! of the input matrix, but the final calculation of the eigenvalues and
! normalization of the eigenvectors is in double precision.

! Programmer: Alan Miller

! Latest revision - 28 September 1986
! Fortran 90 version - 6 December 1996
! Revised - 19 June 1997

USE quadruple_precision
IMPLICIT NONE

TYPE (quad)       :: a(44,44)
REAL (dp)         :: eigenv(44), trace, sume
INTEGER           :: i, j, nrows, ier
REAL              :: tstart, tend
CHARACTER (LEN=1) :: ch

INTERFACE
  SUBROUTINE qkaiser(a, dim_a, n, eigenv, trace, sume, ier)
    USE quadruple_precision
    IMPLICIT NONE
    INTEGER, INTENT(IN)                         :: dim_a, n
    INTEGER, INTENT(OUT)                        :: ier
    TYPE (quad), DIMENSION(:,:), INTENT(IN OUT) :: a
    REAL (dp), DIMENSION(:), INTENT(OUT)        :: eigenv
    REAL (dp), INTENT(OUT)                      :: trace, sume
  END SUBROUTINE qkaiser
END INTERFACE

! First example 30 x 30

!      ( 10  1  1  1                                  )
!      (  1 10  0  0  1                               )
!      (  1  0 10  0  0  1                            )
!      (  1  0  0  9  0  0  1                         )
!      (     1  0  0  9  0  0  1                      )
! A  = (                 . . . . . . . .              )
!      (                         1  0  0  2  0  0  1  )
!      (                            1  0  0  1  0  0  )
!      (                               1  0  0  1  0  )
!      (                                  1  0  0  1  )

! The published eigenvalues of this matrix are:-
! 11.80931 0238 10.74619 4183 10.17489 2583  9.47341 06874
!  9.21067 86475  8.68784 18564  8.11381 05886  8.03894 11158
!  7.76156 65166  7.01635 02620  7.00395 17985  6.96372 64186
!  6.00126 33582  6.00021 75223  5.99783 78494  4.99983 25857
!  4.99978 24777  4.99968 95662  3.99604 97565  3.99604 82014
!  3.99604 56418  2.96105 89161  2.96105 88842  2.96105 88358
!  1.78932 13529  1.78932 13527  1.78932 13522  0.25380 58171
!  0.25380 58171  0.25380 58170

DO i = 1, 30
  DO j = 1, 30
    a(i,j)%lo = 0._dp
    IF (i == j) THEN
      a(i,i)%hi = (33-i)/3
    ELSE IF (ABS(i-j) == 3) THEN
      a(i,j)%hi = 1._dp
    ELSE
      a(i,j)%hi = 0._dp
    END IF
  END DO
END DO
a(1,2)%hi = 1._dp
a(1,3)%hi = 1._dp
a(2,1)%hi = 1._dp
a(3,1)%hi = 1._dp

nrows = 30
CALL time_now(tstart)
CALL qkaiser(a, 44, nrows, eigenv, trace, sume, ier)
IF (ier == 0) THEN
  WRITE(*, 900) eigenv(1:nrows)
  900 FORMAT(' Eigenvalues:-', 11(/ 4F19.14))
  WRITE(*, *)
  WRITE(*, '(a, 2F19.14)') ' Trace & sum of eigenvalues = ', trace, sume
  WRITE(*, *) 'Trace = sum if all eigenvalues +ve'
ELSE
  WRITE(*, '(a, i4)') ' *** qkaiser error no. ', ier
END IF

CALL time_now(tend)
WRITE(*, '(a, f8.2, a)') ' Time taken = ', tend-tstart, 'secs.'

WRITE(*, *)
WRITE(*, *) 'Press RETURN to continue'
READ(*, '(a)') ch
WRITE(*, '(a)') ' ' // ch

! Second example 44 x 44
!
!      ( 5  2  1  1                               )
!      ( 2  6  3  1  1                            )
!      ( 1  3  6  3  1  1                         )
!      ( 1  1  3  6  3  1  1                      )
!      (    1  1  3  6  3  1  1                   )
! A  = (               . . . . . . . .            )
!      (                         1  1  3  6  3  1 )
!      (                            1  1  3  6  2 )
!      (                               1  1  2  5 )

! This is a particularly difficult matrix as it has 11 eigenvalues
! (nos. 15-25) very close together.   Their published values are:-
! 4.16250 38244 29765   4.14589 80337 50315
! 4.14077 17541 12427   4.12083 46534 01856
! 4.09474 53700 81830   4.07872 56924 26601
! 4.05284 15893 88415   4.03456 80076 76363
! 4.00521 19531 60050   4.00453 18458 00653
! 4.0 (exactly)

DO i = 1, 44
  DO j = 1, 44
    a(i,j)%lo = 0._dp
    IF (i == j) THEN
      a(i,i)%hi = 6._dp
    ELSE IF (ABS(i-j) == 1) THEN
      a(i,j)%hi = 3._dp
    ELSE IF (ABS(i-j) <= 3) THEN
      a(i,j)%hi = 1._dp
    ELSE
      a(i,j)%hi = 0._dp
    END IF
  END DO
END DO
a(1,1)%hi   = 5._dp
a(1,2)%hi   = 2._dp
a(2,1)%hi   = 2._dp
a(44,44)%hi = 5._dp
a(44,43)%hi = 2._dp
a(43,44)%hi = 2._dp

nrows = 44
CALL time_now(tstart)
CALL qkaiser(a, 44, nrows, eigenv, trace, sume, ier)
IF (ier == 0) THEN
  WRITE(*, 900) eigenv(1:nrows)
  WRITE(*, *)
  WRITE(*, '(a, 2F19.14)') ' Trace & sum of eigenvalues = ', trace, sume
  WRITE(*, *) 'Trace = sum if all eigenvalues +ve'
ELSE
  WRITE(*, '(a, i4)') ' *** qkaiser error no. ', ier
END IF

CALL time_now(tend)
WRITE(*, '(a, f8.2, a)') ' Time taken = ', tend-tstart, 'secs.'

STOP

CONTAINS

SUBROUTINE time_now(seconds)
REAL, INTENT(OUT) :: seconds

! Local variables
INTEGER :: t(8)

CALL DATE_AND_TIME(values=t)
seconds = 3600.*t(5) + 60.*t(6) + t(7) + 0.001*t(8)

RETURN
END SUBROUTINE time_now

END PROGRAM symmetric_eigen

SUBROUTINE qkaiser(a, dim_a, n, eigenv, trace, sume, ier)

! Calculate the eigenvalues & vectors of a +ve definite symmetric
! matrix in quadruple precision, using a method due to Kaiser.
! Reference:
! Kaiser, H.F. 'The JK method: a procedure for finding the eigenvalues of
!               a real symmetric matrix', Computer J., 15, 271-273, 1972.
! N.B. Strictly the method finds the squared eigenvalues.   It can be used
! with any symmetric matrix - it does not need to be +ve definite, but it
! does not know what signs to give to the eigenvalues.

! Arguments:
! A(DIM_A,*) INPUT.   Contains the matrix in quadruple-precision.
!            OUTPUT.  The columns contain the eigenvectors.
!                     N.B. The input matrix is overwritten.
! DIM_A      INPUT.   Second dimension of A in the calling program
! N          INPUT.   The order or no. of columns in A.
! EIGENV(N)  OUTPUT.  The eigenvalues (ordered).
! TRACE      OUTPUT.  The trace of A.
! SUME       OUTPUT.  Sum of the eigenvalues.   This should equal the trace
!                     if all the eigenvalues are >= 0.
!                     If not, the difference is equal to twice the sum
!                     of the negative eigenvalues.
! IER        OUTPUT.  Error indicator
!                     = 0 if no errors detected
!                     = 1 if N > DIM_A
!                     = 2 failed to converge in 12 iterations

! Programmer: Alan Miller

! Latest revision - 28 September 1986
! Fortran 90 version - 3 December 1996
! Revised - 5 August 1997

USE quadruple_precision
IMPLICIT NONE

INTEGER, INTENT(IN)                         :: dim_a, n
INTEGER, INTENT(OUT)                        :: ier
TYPE (quad), DIMENSION(:,:), INTENT(IN OUT) :: a
REAL (dp), DIMENSION(:), INTENT(OUT)        :: eigenv
REAL (dp), INTENT(OUT)                      :: trace, sume

! Local variables

TYPE (quad) :: halfp, q, temp, sine, cosine, qone
REAL (dp)   :: small = 1.E-08_dp, very_small = 1.E-25_dp, ss, eps1, eps2,  &
               xj, xk, p, absp, absq, tangent, cotan, zero = 0._dp, one = 1._dp
INTEGER     :: iter, nn, ncount, i, j, k

! Initial checks

IF (n < 1 .OR. n > dim_a) THEN
  ier = 1
  RETURN
END IF
ier = 0
qone%hi = one
qone%lo = zero

! Calculate trace & tolerances.

sume = zero
trace = zero
ss = zero
DO i = 1, n
  trace = trace + a(i,i)%hi
  DO j = 1, n
    ss = ss + a(i,j)%hi**2
  END DO
END DO
eps1 = small * ss/n
eps2 = very_small * ss/n

! Some initialization.

iter = 1
nn = n*(n-1)/2
ncount = nn

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

! Main loop to orthogonalize all pairs of columns starts here.

30 DO j = 1, n-1
  DO k = j+1, n

! Calculate planar rotation in double precision.
! This is fairly fast so it does not matter if we have to repeat
! it in quadruple precision.

    halfp%hi = zero
    q%hi = zero
    DO i = 1, n
      xj = a(i,j)%hi
      xk = a(i,k)%hi
      halfp%hi = halfp%hi + xj*xk
      q%hi = q%hi + (xj + xk) * (xj - xk)
    END DO
    p = SCALE(halfp%hi, 1)
    absp = ABS(p)
    absq = ABS(q%hi)

! If the cross-product in p or the difference of 2-norms in q%hi is
! small, repeat the calculation in quadruple precision.

    IF (absp < eps1 .OR. absq < eps1) THEN
      halfp%hi = zero
      halfp%lo = zero
      q%hi = zero
      q%lo = zero
      DO i = 1, n
        halfp = halfp + a(i,j) * a(i,k)
        q = q + (a(i,j) + a(i,k)) * (a(i,j) - a(i,k))
      END DO
      p = SCALE(halfp%hi, 1)
      absp = ABS(p)
      absq = ABS(q%hi)
    END IF

! Test if columns are almost orthogonal and in the correct order.

    IF (absp < eps2) THEN
      IF (q%hi >= zero) GO TO 80
    END IF

! The trigonometric bit.

    IF (absp <= absq) THEN
      tangent = absp / absq
      temp = exactmul2(tangent, tangent)
      cosine = qone / SQRT(temp + qone)
      temp%hi = tangent
      temp%lo = zero
      sine = temp * cosine
    ELSE
      cotan = absq / absp
      temp = exactmul2(cotan, cotan)
      sine = qone / SQRT(temp + qone)
      temp%hi = cotan
      temp%lo = zero
      cosine = temp * sine
    END IF
    temp = qone + cosine
    temp = SCALE(temp, -1)
    cosine = SQRT(temp)
    temp = SCALE(cosine, 1)
    sine = sine / temp
    IF (q%hi < zero) THEN
      temp = cosine
      cosine = sine
      sine = temp
    END IF
    IF (p < zero) THEN
      sine = -sine
    END IF

! Carry out the rotation in quadruple precision.

    WRITE(*, 900) iter, j, k, sine%hi
    900 FORMAT('+', 'iter:', i3, '   columns:', 2I4, '   sine:', g13.5)
    DO i = 1, n
      q = a(i,j) * cosine + a(i,k) * sine
      a(i,k) = a(i,k) * cosine - a(i,j) * sine
      a(i,j) = q
    END DO
    CYCLE

! No rotation was needed if this point is reached.
! Test for convergence.

    80 ncount = ncount - 1
    IF (ncount <= 0) GO TO 110

! End of loop over pairs of columns.

  END DO
END DO

! Increase count of iterations, then go back for more.

ncount = nn
iter = iter + 1
IF (iter <= 12) GO TO 30
ier = 2
WRITE(*, *)' *** Failed to converge ***'

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

! Converged, or gave up after 12 iterations.
! Eigenvalues squared are the squared lengths of columns.
! The columns of A contain the eigenvectors; scale to length 1.

110 DO j = 1, n
  ss = SUM( a(1:n,j)%hi**2 )
  eigenv(j) = SQRT(ss)
  sume = sume + eigenv(j)
  a(1:n,j)%hi = a(1:n,j)%hi / eigenv(j)
  a(1:n,j)%lo = zero
END DO

RETURN
END SUBROUTINE qkaiser


SUBROUTINE svbksb_sp(u,w,v,b,x)
  USE nrtype
  USE nrutil, ONLY : assert_eq
  REAL(SP), DIMENSION(:,:), INTENT(IN) :: u,v
  REAL(SP), DIMENSION(:), INTENT(IN) :: w,b
  REAL(SP), DIMENSION(:), INTENT(OUT) :: x
  INTEGER(I4B) :: mdum,ndum
  REAL(SP), DIMENSION(size(x)) :: tmp
  mdum=assert_eq(size(u,1),size(b),'svbksb_sp: mdum')
  ndum=assert_eq((/size(u,2),size(v,1),size(v,2),size(w),size(x)/),&
  'svbksb_sp: ndum')
  where (w /= 0.0)
  tmp=matmul(b,u)/w
elsewhere
   tmp=0.0
end where
x=matmul(v,tmp)
END SUBROUTINE svbksb_sp

SUBROUTINE svbksb_dp(u,w,v,b,x)
  USE nrtype
  USE nrutil, ONLY : assert_eq
  REAL(DP), DIMENSION(:,:), INTENT(IN) :: u,v
  REAL(DP), DIMENSION(:), INTENT(IN) :: w,b
  REAL(DP), DIMENSION(:), INTENT(OUT) :: x
  INTEGER(I4B) :: mdum,ndum
  REAL(DP), DIMENSION(size(x)) :: tmp
  mdum=assert_eq(size(u,1),size(b),'svbksb_dp: mdum')
  ndum=assert_eq((/size(u,2),size(v,1),size(v,2),size(w),size(x)/),&
  'svbksb_dp: ndum')
  where (w /= 0.0)
  tmp=matmul(b,u)/w
elsewhere
   tmp=0.0
end where
x=matmul(v,tmp)
END SUBROUTINE svbksb_dp


!> @brief This function returns the overall index for any step within 6 nested do loops
!>
!> @param[in] i1 the index of the first do loop
!>
!> @param[in] i2 the index of the second do loop
!>
!> @param[in] i3 the index of the third do loop
!>
!> @param[in] i4 the index of the fourth do loop
!>
!> @param[in] i5 the index of the fifth do loop
!>
!> @param[in] i6 the index of the sixth do loop
!>
!> @param[in] n2 the end of the second do loop
!>
!> @param[in] n3 the end of the third do loop
!>
!> @param[in] n4 the end of the fourth do loop
!>
!> @param[in] n5 the end of the fifth do loop
!>
!> @param[in] n6 the end of the sixth do loop
!>
!> @warning This function assumes that all indexes go from 1 to n (inclusive)
!>

ELEMENTAL FUNCTION func_overall_index_6loops(i1, i2, i3, i4, i5, i6, n2, n3, n4, n5, n6) RESULT(ans)
    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    INTEGER(kind = INT64), INTENT(in)                                           :: i1
    INTEGER(kind = INT64), INTENT(in)                                           :: i2
    INTEGER(kind = INT64), INTENT(in)                                           :: i3
    INTEGER(kind = INT64), INTENT(in)                                           :: i4
    INTEGER(kind = INT64), INTENT(in)                                           :: i5
    INTEGER(kind = INT64), INTENT(in)                                           :: i6
    INTEGER(kind = INT64), INTENT(in)                                           :: n2
    INTEGER(kind = INT64), INTENT(in)                                           :: n3
    INTEGER(kind = INT64), INTENT(in)                                           :: n4
    INTEGER(kind = INT64), INTENT(in)                                           :: n5
    INTEGER(kind = INT64), INTENT(in)                                           :: n6
    INTEGER(kind = INT64)                                                       :: ans

    ans = i6 + n6 * ((i5 - 1_INT64) + n5 * ((i4 - 1_INT64) + n4 * ((i3 - 1_INT64) + n3 * ((i2 - 1_INT64) + n2 * (i1 - 1_INT64)))))
END FUNCTION