module gramschmidt
!Modified based on
!     Numerical Analysis:
!     Mathematics of Scientific Computing
!     Third Edition
!     D.R. Kincaid & E.W. Cheney
!     Brooks/Cole Publ., 2002
!     Copyright (c) 1996
!     Section 5.3
!     Example of modified Gram-Schmidt algorithm
!     file: qrshif.f
!Original program only accepts square matrices

      use prep, only : i16b
      use, intrinsic :: iso_fortran_env, only: rk => real64
      use projection, only : REAL_MIN

      implicit none
      contains

      subroutine orth(a, q, r, m, n)
          real(rk) :: a(:, :), q(:, :), r(:, :), z
          integer, intent(in) :: m, n
          integer :: i, k
          do k = 1, m
              print *,' Matrix A'
              call prtmtx(n,a)
              z = a(n,n)
              do i=1,n
                a(i,i)= a(i,i) - z
              end do
              call mgs(a, q, r, n, n)
              print *,' Matrix Q'
              call prtmtx(n,q)
              print *,' Matrix R'
              call prtmtx(n,r)
              call mult(r,q, n, n, n, a)
              do i=1,n
                 a(i,i)=a(i,i) + z
              end do
          enddo
      end subroutine orth

      subroutine prtmtx(n,a)
          real(rk), intent(in):: a(:,:)
          integer, intent(in) :: n

          integer :: i, j
          do i=1,n
              write(*, '(4f10.6)') (a(i,j),j=1,n)
          enddo
      end subroutine

      subroutine mgs(a, q, t, m, n)
          !a(m, n), q(m, n), t(n, n)
          real(rk) :: a(:, :), q(:, :), t(:, :), z
          integer, intent(in) :: m, n
          integer :: i, j, k

          !if(size(a, 1).ne.m.OR.size(a, 2).ne.n.OR.size(q, 1).ne.m.OR.&
          !    &size(q, 2).ne.n.OR.size(t, 1).ne.n.OR.size(t, 2).ne.n) then
          !  write(*, *) 'matrix size not right in subroutine mgs'
          !  return
          !endif

          do j = 1, n
              do i = 1, n
                  t(i, j) = 0.
              enddo
              do i = 1, m
                  q(i, j) = a(i, j)
              enddo
          enddo

          do k = 1, n
              z = 0.
              do i = 1, m
                  z = z + q(i, k)**2
              end do
              t(k, k) = sqrt(z)
              do i = 1, m
                  q(i, k) = q(i, k) / t(k, k)
              end do
              do j = k+1, n
                  z = 0.
                  do i = 1, m
                      z = z + q(i, j) * q(i, k)
                  end do
                  t(k, j) = z
                  do i = 1, m
                      q(i, j) = q(i, j) - t(k, j) * q(i, k)
                  enddo
              enddo
          enddo
      end subroutine mgs

      subroutine mult(A, B, n1, m, n2, C)
      ! Matrix product C(n1, n2) = A(n1, m)*B(m, n2)
      integer, intent(in) :: n1, m, n2
      real(rk), intent(in) :: A(:, :), B(:, :)
      real(rk) :: C(:, :), tp
      integer :: i, j, k

        do i = 1, n1
            do j = 1, n2
                tp = 0.0
                do k = 1, m
                    tp = tp + A(i, k) * B(k, j)
                enddo
                C(i, j) = tp
            end do
        end do
      end subroutine mult

end module gramschmidt


!
!
!*******************************************************************************
!
real(kind=8) function tco_interpolate(e,nume,e_grid,tco)
!
!*******************************************************************************
!
!  Discussion:
!
!    This subroutine finds the transmission coeeficient at a
!    specific energy e by interpolating from a list of nume values
!    in the array tco on a energy grid defined by e_grid
!    Interpolate using a log-log linear approximation
!
!    Improved 6 Jan 2021 making use of the constant grid in log(e) to
!    find mid points. Sped up by 6x.
!
!   Dependencies:
!
!     Modules:
!
!        nodeinfo
!        variable_kinds
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   use nodeinfo
   use variable_kinds
   implicit none
   real(kind=8), intent(in) :: e
   integer(kind=4), intent(in) :: nume
   real(kind=8), intent(in) :: e_grid(nume),tco(nume)
!-----------------------------------------------------------------------------
   integer(kind=4) :: i1, i2
   real(kind=8) :: x1, x2, y1, y2, x, y, a, b

   real(kind=8) :: delta
!-----------------------------------------------------------------------------
   tco_interpolate = 1.0d-9
   if(e <= 0.0d0)return
   tco_interpolate = tco(1)
   if(e <= e_grid(1))return

   x = log(e)
   x1 = log(e_grid(1))

   delta = log(e_grid(2)) - x1
   i1 = int((x - x1)/delta) + 1
   i2 = i1 + 1

   x1 = log(e_grid(i1))
   x2 = log(e_grid(i2))
!------   Put in lower threshold
   y1 = log(max(tco(i1),1.0d-9))
   y2 = log(max(tco(i2),1.0d-9))
   a = (y2-y1)/(x2-x1)
   b = y1 - a*x1
   y = a*x + b
   tco_interpolate = exp(y)

  return
end function tco_interpolate


      SUBROUTINE CGELSY_F95( A, B, RANK, JPVT, RCOND, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP => SP
      USE LA_AUXMOD, ONLY: ERINFO
      USE F77_LAPACK, ONLY: GELSY_F77 => LA_GELSY
!   .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
      INTEGER, INTENT(OUT), OPTIONAL :: RANK
      INTEGER, INTENT(OUT), OPTIONAL :: INFO
      REAL(WP), INTENT(IN), OPTIONAL :: RCOND
!   .. ARRAY ARGUMENTS ..
      INTEGER, INTENT(INOUT), OPTIONAL, TARGET :: JPVT(:)
      COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!     LA_GELSY computes the minimum-norm least squares solution to one
! or more real or complex linear systems A*x = b using a complete
! orthogonal factorization of A. Matrix A is rectangular and may be
! rankdeficient. The vectors b and corresponding solution vectors x are
! the columns of matrices denoted B and X, respectively.
!     The routine computes a QR factorization of A with column pivoting:
!           A * P = Q * [ R11 R12 ]
!                       [  0  R22 ]
! where R11 is the largest leading submatrix whose estimated condition
! number is less than 1/RCOND. The order of R11, RANK, is the effective
! rank of A. R22 is considered to be negligible, and R12 is annihilated
! by orthogonal (unitary) transformations from the right, yielding the
! complete orthogonal (unitary) factorization
!           A * P = Q * [ T11  0  ] * Z
! 	              [  0   0  ]
! The minimum-norm least squares solution is then
!           x = P * Z^H [ T11^-1 * Q1^H * b ]
! 	              [        0          ]
! where Q1 consists of the first RANK columns of Q.
!
! =========
!
!          SUBROUTINE LA_GELSY( A, B, RANK=rank, &
!                     JPVT= jpvt, RCOND= rcond, INFO= info )
!              <type>(<wp>), INTENT(INOUT) :: A(:,:), <rhs>
!              INTEGER, INTENT(OUT), OPTIONAL :: RANK
!              INTEGER, INTENT(INOUT), OPTIONAL :: JPVT(:)
!              REAL(<wp>), INTENT(IN), OPTIONAL :: RCOND
!              INTEGER, INTENT(OUT), OPTIONAL :: INFO
!          where
!              <type> ::= REAL | COMPLEX
!              <wp>   ::= KIND(1.0) | KIND(1.0D0)
!              <rhs>  ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! A       (input/output) REAL or COMPLEX array, shape (:,:).
!         On entry, the matrix A.
!   	  On exit, A has been overwritten by details of its complete
!         orthogonal factorization.
! B       (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(B,1) = max(size(A,1),size(A,2)) or shape (:) with
! 	  size(B) = max(size(A,1), size(A,2)).
! 	  On entry, the matrix B.
! 	  On exit, rows 1 to size(A,2) contain the solution matrix X .
! 	  If size(A,1) >= size(A,2) and RANK = size(A,2), the residual
! 	  sum-of-squares for the solution vector in a column of B is
!   	  given by the sum of squares of elements in rows size(A,2)+1 :
!         size(A,1) of that column.
! RANK    Optional (output) INTEGER.
!         The effective rank of A, i.e., the order of the submatrix R11.
! 	  This is the same as the order of the submatrix T11 in the
! 	  complete orthogonal factorization of A.
! JPVT    Optional (input/output) INTEGER array, shape (:) with
!         size(JPVT) = size(A,2).
! 	  On entry, if JPVT(i) /= 0, the i-th column of A is an initial
! 	  column, otherwise it is a free column.
! 	  Before the QR factorization of A, all initial columns are
! 	  permuted to the leading positions; only the remaining free
! 	  columns are moved as a result of column pivoting during the
! 	  factorization.
! 	  On exit, if JPVT(i) = k, then the i-th column of the matrix
! 	  product A*P was the k-th column of A.
! RCOND   Optional (input) REAL.
!         RCOND is used to determine the effective rank of A. This is
! 	  defined as the order of the largest leading triangular
! 	  submatrix R11 in the QR factorization of A, with pivoting,
! 	  whose estimated condition number < 1/RCOND.
!         Default value: 10*max(size(A,1),size(A,2))*BEPSILON(1.0_<wp>),
! 	  where <wp> is the working precision.
! INFO    Optional (output) INTEGER.
!         = 0: successful exit
! 	  < 0: if INFO = -i, the i-th argument had an illegal value
! 	  If INFO is not present and an error occurs, then the program
! 	  is terminated with an error message.
!----------------------------------------------------------------------
!   .. PARAMETERS ..
      CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GELSY'
!   .. LOCAL SCALARS ..
      INTEGER :: LINFO, ISTAT, ISTAT1, LWORK, N, M, MN, NRHS, LRANK, SJPVT
      REAL(WP) :: LRCOND
!   .. LOCAL POINTERS ..
      INTEGER, POINTER :: LJPVT(:)
      COMPLEX(WP), POINTER :: WORK(:)
      COMPLEX(WP) :: WORKMIN(1)
      REAL(WP), POINTER :: RWORK(:)
!   .. INTRINSIC FUNCTIONS ..
      INTRINSIC SIZE, PRESENT, MAX, MIN, EPSILON
!   .. EXECUTABLE STATEMENTS ..
      LINFO = 0; ISTAT = 0; M = SIZE(A,1); N = SIZE(A,2); NRHS = SIZE(B,2)
      MN = MIN(M,N)
      IF( PRESENT(RCOND) )THEN; LRCOND = RCOND; ELSE
          LRCOND = 100*EPSILON(1.0_WP) ; ENDIF
      IF( PRESENT(JPVT) )THEN; SJPVT = SIZE(JPVT); ELSE; SJPVT = N; ENDIF
!   .. TEST THE ARGUMENTS
      IF( M < 0 .OR. N < 0 ) THEN; LINFO = -1
      ELSE IF( SIZE( B, 1 ) /= MAX(1,M,N) .OR. NRHS < 0 ) THEN; LINFO = -2
      ELSE IF( SJPVT /= N ) THEN; LINFO = -4
      ELSE IF( LRCOND <= 0.0_WP ) THEN; LINFO = -5
      ELSE
        IF( PRESENT(JPVT) )THEN; LJPVT => JPVT
        ELSE; ALLOCATE( LJPVT(N), STAT = ISTAT ); LJPVT = 0; END IF

        ALLOCATE(RWORK(2*N), STAT=ISTAT)
	IF( ISTAT /= 0 ) CALL ERINFO( -200, SRNAME, LINFO )

! .. DETERMINE THE WORKSPACE ..
! .. QUERING THE SIZE OF WORKSPACE ..
          LWORK = -1
	  CALL GELSY_F77( M, N, NRHS, A, MAX(1,M), B, MAX(1,M,N), &
     &      LJPVT, LRCOND, LRANK, WORKMIN, LWORK, RWORK, LINFO )
          LWORK = WORKMIN(1)
          IF( ISTAT == 0 ) THEN
            ALLOCATE( WORK(LWORK), STAT = ISTAT )
            IF( ISTAT /= 0 ) CALL ERINFO( -200, SRNAME, LINFO )
          END IF

          IF ( ISTAT == 0 ) THEN
            CALL GELSY_F77( M, N, NRHS, A, MAX(1,M), B, MAX(1,M,N), &
     &      LJPVT, LRCOND, LRANK, WORK, LWORK, RWORK, LINFO )
          ELSE; LINFO = -100; END IF
            IF( PRESENT(RANK) ) RANK = LRANK
            IF( PRESENT(JPVT) ) JPVT = LJPVT
            DEALLOCATE(WORK, RWORK, STAT = ISTAT1 )
          END IF
          CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
        END SUBROUTINE CGELSY_F95


MODULE OPT_MOD

  ! Interface for the gradient.
  INTERFACE
     SUBROUTINE GRAD(DIMS, X, G)
       USE REAL_PRECISION
       INTEGER :: DIMS
       REAL(KIND=R8) :: X(DIMS), G(DIMS)
     END SUBROUTINE GRAD
  END INTERFACE

CONTAINS

  SUBROUTINE SGD(D, GRAD, X, IBUDGET, ALPHA, TAU)
    ! Standard SGD optimization algorithm.
    ! INTEGER (IN) D : Dimension of space.
    ! REAL(KIND=R8), FUNCTION (IN) GRAD : Gradient of objective function
    ! 	g : R^D --> R.
    ! REAL(KIND=R8) (INOUT) X(D) : On input, starting position in R^D; On
    !	output, computed minima.
    ! INTEGER, OPTIONAL (IN) IBUDGET : Gradient evaluation budget.
    ! REAL(KIND=R8), OPTIONAL (IN) ALPHA : Step size/learning rate.
    ! REAL(KIND=R8), OPTIONAL (IN) TAU : Rate at which to decay step size
    USE REAL_PRECISION
    IMPLICIT NONE
    ! Parameter list.
    INTEGER, INTENT(IN) :: D
    EXTERNAL :: GRAD
    REAL(KIND=R8), INTENT(INOUT) :: X(D)
    ! Optional parameters.
    INTEGER, OPTIONAL, INTENT(IN) :: IBUDGET
    REAL(KIND=R8), OPTIONAL, INTENT(IN) :: ALPHA
    REAL(KIND=R8), OPTIONAL, INTENT(IN) :: TAU
    ! Local variables.
    REAL(KIND=R8) :: ALPHAL, TAUL
    INTEGER :: IBUDGETL, T
    REAL(KIND=R8) :: G(D)
    ! Set default values for the optional inputs.
    IBUDGETL = 1000
    ALPHAL = 0.01_R8
    TAUL = 0.99_R8
    ! Get the optional inputs.
    IF(PRESENT(IBUDGET)) THEN
       IBUDGETL = IBUDGET
    END IF
    IF(PRESENT(ALPHA)) THEN
       ALPHAL = ALPHA
    END IF
    IF(PRESENT(TAU)) THEN
       TAUL = TAU
    END IF
    ! Main loop over budget.
    DO T=1, IBUDGETL
       ! Set the current gradient.
       CALL GRAD(D,X,G)
       IF (ALL(G .EQ. 0.0_R8)) RETURN
       ! Take the update step.
       X = X - ALPHAL * G
       ! Decay the step size.
       ALPHAL = ALPHAL * TAUL
    END DO
    RETURN
  END SUBROUTINE SGD

  SUBROUTINE ADAM(D, GRAD, X, IBUDGET, ALPHA, BETA1, BETA2, EPS)
    ! ADaM optimization algorithm as proposed by D. P. Kingma and J. L. Ba.
    ! INTEGER (IN) D : Dimension of space.
    ! REAL(KIND=R8), FUNCTION (IN) GRAD : Gradient of objective function
    ! 	g : R^D --> R.
    ! REAL(KIND=R8) (INOUT) X(D) : On input, starting position in R^D; On
    !	output, computed minima.
    ! INTEGER, OPTIONAL (IN) IBUDGET : Gradient evaluation budget.
    ! REAL(KIND=R8), OPTIONAL (IN) ALPHA : Step size.
    ! REAL(KIND=R8), OPTIONAL (IN) BETA1 : Decay rate for first moment.
    ! REAL(KIND=R8), OPTIONAL (IN) BETA2 : Decay rate for second moment.
    ! REAL(KIND=R8), OPTIONAL (IN) EPS : Decay rate for second moment.
    USE REAL_PRECISION
    IMPLICIT NONE
    ! Parameter list.
    INTEGER, INTENT(IN) :: D
    EXTERNAL :: GRAD
    REAL(KIND=R8), INTENT(INOUT) :: X(D)
    ! Optional parameters.
    INTEGER, OPTIONAL, INTENT(IN) :: IBUDGET
    REAL(KIND=R8), OPTIONAL, INTENT(IN) :: ALPHA
    REAL(KIND=R8), OPTIONAL, INTENT(IN) :: BETA1
    REAL(KIND=R8), OPTIONAL, INTENT(IN) :: BETA2
    REAL(KIND=R8), OPTIONAL, INTENT(IN) :: EPS
    ! Local variables.
    REAL(KIND=R8) :: ALPHAL, BETA1L, BETA2L, EPSL
    INTEGER :: IBUDGETL, T
    REAL(KIND=R8) :: M(D), V(D), M_HAT(D), V_HAT(D), G(D)
    ! Set default values for the optional parameters.
    IBUDGETL = 1000
    ALPHAL = 0.01_R8
    BETA1L = 0.9_R8
    BETA2L = 0.999_R8
    EPSL = SQRT(EPSILON(0.0_R8))
    ! Get optional inputs.
    IF(PRESENT(IBUDGET)) THEN
       IBUDGETL = IBUDGET
    END IF
    IF(PRESENT(ALPHA)) THEN
       ALPHAL = ALPHA
    END IF
    IF(PRESENT(BETA1)) THEN
       BETA1L = BETA1
    END IF
    IF(PRESENT(BETA2)) THEN
       BETA2L = BETA2
    END IF
    IF(PRESENT(EPS)) THEN
       EPSL = EPS
    END IF
    ! Initialize the first and second moments.
    M = 0.0_R8
    V = 0.0_R8
    ! Main loop over budget.
    DO T=1, IBUDGETL
       ! Get the current gradient.
       CALL GRAD(D,X,G)
       IF (ALL(G .EQ. 0.0_R8)) RETURN
       ! Compute the biased first and second moments.
       M = BETA1L * M + (1.0_R8 - BETA1L) * G
       V = BETA2L * V + (1.0_R8 - BETA2L) * G * G
       ! Correct m and v for bias.
       M_HAT = M / (1.0_R8 - BETA1L ** REAL(T,KIND=R8))
       V_HAT = V / (1.0_R8 - BETA2L ** REAL(T,KIND=R8))
       ! Take a step according to nonbiased adaptive gradient.
       X = X - ALPHAL * M_HAT / (SQRT(V_HAT) + EPSL)
    END DO
    RETURN
  END SUBROUTINE ADAM

  SUBROUTINE ADAGRAD(D, GRAD, X, IBUDGET, ALPHA, EPS)
    ! ADAGRAD optimization algorithm as described by Duchi, Hazan, and Singer.
    ! INTEGER (IN) D : Dimension of space.
    ! REAL(KIND=R8), FUNCTION (IN) GRAD : Gradient of objective function
    ! 	g : R^D --> R.
    ! REAL(KIND=R8) (INOUT) X(D) : On input, starting position in R^D; On
    !	output, computed minima.
    ! INTEGER, OPTIONAL (IN) IBUDGET : Gradient evaluation budget.
    ! REAL(KIND=R8), OPTIONAL (IN) ALPHA : Step size in the adjusted space
    !	parameterized by the matrix norm induced by G.
    ! REAL(KIND=R8), OPTIONAL (IN) EPS : "Fudge factor" for adjusting the
    !	matrix norm G, avoiding pathological cases where the gradient
    !	disappears in one dimension. Should be a VERY small number
    !	(default: SQRT(EPSILON)).
    USE REAL_PRECISION
    IMPLICIT NONE
    ! Parameter list.
    INTEGER, INTENT(IN) :: D
    EXTERNAL :: GRAD
    REAL(KIND=R8), INTENT(INOUT) :: X(D)
    ! Optional parameters.
    INTEGER, OPTIONAL, INTENT(IN) :: IBUDGET
    REAL(KIND=R8), OPTIONAL, INTENT(IN) :: ALPHA
    REAL(KIND=R8), OPTIONAL, INTENT(IN) :: EPS
    ! Local variables.
    REAL(KIND=R8) :: EPSL, ALPHAL
    INTEGER :: IBUDGETL, T
    REAL(KIND=R8) :: G(D), STEP(D)
    ! Set default values for the optional parameters.
    IBUDGETL = 1000
    ALPHAL = 0.01_R8
    EPSL = SQRT(EPSILON(0.0_R8))
    ! Get optional inputs.
    IF(PRESENT(IBUDGET)) THEN
       IBUDGETL = IBUDGET
    END IF
    IF(PRESENT(EPS)) THEN
       EPSL = EPS
    END IF
    IF(PRESENT(ALPHA)) THEN
       ALPHAL = ALPHA
    END IF
    ! Initialize the matrix norm.
    G = 0.0_R8
    ! Main loop over budget.
    DO T=1, IBUDGETL
       ! Get the current gradient.
       CALL GRAD(D, X, STEP)
       IF (ALL(G .EQ. 0.0_R8)) RETURN
       ! Update the adaptive norm.
       G = G + STEP ** 2.0_R8
       ! Take the adjusted trust region step according to the current norm.
       STEP = STEP / (EPSL + SQRT(G))
       X = X - (ALPHAL * STEP)
    END DO
    RETURN
  END SUBROUTINE ADAGRAD

END MODULE OPT_MOD


c     prog3
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12
c     to appear in 'solving least squares problems', prentice-hall, 1974
c	   demonstrate the use of subroutine   svdrs  to compute the
c     singular value decomposition of a matrix, a, and solve a least
c     squares problem,	a*x=b.
c
c     the s.v.d.  a= u*(s,0)**t*v**t is
c     computed so that..
c     (1)  u**t*b replaces the m+1 st. col. of	b.
c
c     (2)  u**t   replaces the m by m identity in
c     the first m cols. of  b.
c
c     (3) v replaces the first n rows and cols.
c     of a.
c
c     (4) the diagonal entries of the s matrix
c     replace the first n entries of the array s.
c
c     the array s( ) must be dimensioned at least 3*n .
c
      dimension a(8,8),b(8,9),s(24),x(8),aa(8,8)
      real gen,anoise
      double precision sm
      data mda,mdb/8,8/
c
      do 150 noise=1,2
      anoise = 0.
      rho = 1.e-3
      if(noise .eq. 1) go to 5
      anoise = 1.e-4
      rho = 10. * anoise
    5 continue
      write(6,230)
      write(6,240) anoise,rho
c     initialize data generation function
c    ..
      dummy= gen(-1.)
c
	   do 150 mn1=1,6,5
	   mn2=mn1+2
		do 150 m=mn1,mn2
		do 150 n=mn1,mn2
		write (6,160) m,n
		     do 20 i=1,m
			  do 10 j=1,m
   10			  b(i,j)=0.
		     b(i,i)=1.
			  do 20 j=1,n
			  a(i,j)= gen(anoise)
   20			  aa(i,j)=a(i,j)
		     do 30 i=1,m
   30		     b(i,m+1)= gen(anoise)
c
c     the arrays are now filled in..
c     compute the s.v.d.
c     ******************************************************
		call svdrs (a,mda,m,n,b,mdb,m+1,s)
c     ******************************************************
c
		write (6,170)
		write (6,220) (i,s(i),i=1,n)
		write (6,180)
		write (6,220) (i,b(i,m+1),i=1,m)
c
c     test for disparity of ratio of singular values.
c    ..
		krank=n
		tau=rho*s(1)
		     do 40 i=1,n
		     if (s(i).le.tau) go to 50
   40		     continue
		go to 55
   50		krank=i-1
   55 write(6,250) tau, krank
c     compute solution vector assuming pseudorank is krank
c     ..
   60		     do 70 i=1,krank
   70		     b(i,m+1)=b(i,m+1)/s(i)
		     do 90 i=1,n
		     sm=0.d0
			  do 80 j=1,krank
   80			  sm=sm+a(i,j)*dble(b(j,m+1))
   90		     x(i)=sm
c     compute predicted norm of residual vector.
c     ..
		srsmsq=0.
		if (krank.eq.m) go to 110
		kp1=krank+1
		     do 100 i=kp1,m
  100		     srsmsq=srsmsq+b(i,m+1)**2
		srsmsq=sqrt(srsmsq)
c
  110		continue
		write (6,190)
		write (6,220) (i,x(i),i=1,n)
		write (6,200) srsmsq
c     compute the frobenius norm of  a**t- v*(s,0)*u**t.
c
c     compute  v*s  first.
c
		minmn=min0(m,n)
		     do 120 j=1,minmn
			  do 120 i=1,n
  120			  a(i,j)=a(i,j)*s(j)
		dn=0.
		     do 140 j=1,m
			  do 140 i=1,n
			  sm=0.d0
			       do 130 l=1,minmn
  130			       sm=sm+a(i,l)*dble(b(l,j))
c     computed difference of (i,j) th entry
c     of  a**t-v*(s,0)*u**t.
c     ..
			  t=aa(j,i)-sm
  140			  dn=dn+t**2
		dn=sqrt(dn)/(sqrt(float(n))*s(1))
		write (6,210) dn
  150		continue
      stop
  160 format (1h0////9h0   m   n/1x,2i4)
  170 format (1h0,8x,25hsingular values of matrix)
  180 format (1h0,8x,30htransformed right side, u**t*b)
  190 format (1h0,8x,33hestimated parameters,  x=a**(+)*b,21h computed b
     1y 'svdrs' )
  200 format (1h0,8x,24hresidual vector length =,e12.4)
  210 format (1h0,8x,43hfrobenius norm (a-u*(s,0)**t*v**t)/(sqrt(n),
     *22h*spectral norm of a) =,e12.4)
  220 format (9x,i5,e16.8,i5,e16.8,i5,e16.8,i5,e16.8,i5,e16.8)
  230 format(51h1prog3.     this program demonstrates the algorithm,
     * 9h, svdrs. )
  240 format(55h0the relative noise level of the generated data will be,
     *e16.4/44h0the relative tolerance, rho, for pseudorank,
     *17h determination is,e16.4)
  250 format(1h0,8x,36habsolute pseudorank tolerance, tau =,
     *e12.4,10x,12hpseudorank =,i5)
      end


! Program to test array constructors
program constructors
   integer, dimension (4) :: a
   integer, dimension (3, 2) :: b
   integer i, j, k, l, m, n

   a = (/1, (i,i=2,4)/)
   do i = 1, 4
      if (a(i) .ne. i) call abort
   end do

   b = reshape ((/0, 1, 2, 3, 4, 5/), (/3, 2/)) + 1
   do i=1,3
      if (b(i, 1) .ne. i) call abort
      if (b(i, 2) .ne. i + 3) call abort
   end do

   k = 1
   l = 2
   m = 3
   n = 4
   ! The remainder assumes constant constructors work ok.
   a = (/n, m, l, k/)
   if (any (a .ne. (/4, 3, 2, 1/))) call abort
   a = (/((/i+10, 42/), i = k, l)/)
   if (any (a .ne. (/11, 42, 12, 42/))) call abort
   a = (/(I, I=k,l) , (J, J=m,n)/)
   if (any (a .ne. (/1, 2, 3, 4/))) call abort
end program


program main_bvp

    use bvp_solvers, only: solve_bvp_direct
    use problem, only: u_true
    implicit none
    integer :: n, i
    real(kind=8) :: u_left, u_right, error_max, dx
    real(kind=8), dimension(:), allocatable :: x, u, ustar

    open(unit=21, file='input_data.txt', status='old')
    read(21,*) n
    print *, "n = ",n
    allocate(x(0:n+1), u(0:n+1), ustar(0:n+1))

    dx = 1.d0 / (n+1)
    do i=0,n+1
        x(i) = i*dx
        ustar(i) = u_true(x(i))
        enddo

    u_left = 20.d0
    u_right = 60.d0

    ! check for consistency with "true solution":
    if (abs(ustar(0) - u_left) .gt. 1.d-14) then
        print *, "u_left doesn't match true solution", ustar(0)
        stop
        endif
    if (abs(ustar(n+1) - u_right) .gt. 1.d-14) then
        print *, "u_right doesn't match true solution", ustar(n+1)
        stop
        endif

    call solve_bvp_direct(x, u_left, u_right, u)

    error_max = 0.d0
    do i=1,n
        error_max = max(error_max, abs(u(i) - ustar(i)))
        enddo

    print *, "error_max = ",error_max

end program main_bvp


module mergesort_module
   ! overloading interfaces
   ! main bottom up merge sort subroutines
   interface sort
      module procedure sort_integers
      module procedure sort_reals
      module procedure sort_strings
   end interface sort
   ! merge sort auxliary merge subroutine
   interface merge_arrays
      module procedure merge_integers
      module procedure merge_reals
      module procedure merge_strings
   end interface merge_arrays
   ! unit test functions
   interface sorted
      module procedure sorted_integers
      module procedure sorted_reals
      module procedure sorted_strings
   end interface sorted
contains
   subroutine sort_integers(n, x, y, order)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      integer, intent(inout), dimension(n) :: x, y
      character (len = *), intent(in) :: order
      ! local data
      integer i, j, rnsz, m, l, r

      rnsz = 1
      do
         if (2*rnsz > n) exit
         l = 1
         r = l+rnsz
         do
            if (r+rnsz > n+1) exit
            call merge_arrays(rnsz, rnsz, x(l:), x(r:), y(l:), order)
            l = l+2*rnsz
            r = l+rnsz
         end do
         m = mod(n, 2*rnsz)
         if (m > rnsz) then
            l = (n-m)+1
            r = l+rnsz
            call merge_arrays(rnsz, m-rnsz, x(l:), x(r:), y(l:), order)
         else if (m > 0) then
            l = (n-m)+1
            y(l:) = x(l:)
         end if
         x = y
         rnsz = 2*rnsz
      end do
      call merge_arrays(rnsz, n-rnsz, x(1:rnsz), x(rnsz+1:n), y, order)
   end subroutine sort_integers

   subroutine sort_reals(n, x, y, order)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      double precision, intent(inout), dimension(n) :: x, y
      character (len = *), intent(in) :: order
      ! local data
      integer i, j, rnsz, m, l, r

      rnsz = 1
      do
         if (2*rnsz > n) exit
         l = 1
         r = l+rnsz
         do
            if (r+rnsz > n+1) exit
            call merge_arrays(rnsz, rnsz, x(l:), x(r:), y(l:), order)
            l = l+2*rnsz
            r = l+rnsz
         end do
         m = mod(n, 2*rnsz)
         if (m > rnsz) then
            l = (n-m)+1
            r = l+rnsz
            call merge_arrays(rnsz, m-rnsz, x(l:), x(r:), y(l:), order)
         else if (m > 0) then
            l = (n-m)+1
            y(l:) = x(l:)
         end if
         x = y
         rnsz = 2*rnsz
      end do
      call merge_arrays(rnsz, n-rnsz, x(1:rnsz), x(rnsz+1:n), y, order)
   end subroutine sort_reals

   subroutine sort_strings(n, x, y, order)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      character (len = *), intent(inout), dimension(n) :: x, y
      character (len = *), intent(in) :: order
      ! local data
      integer i, j, rnsz, m, l, r

      rnsz = 1
      do
         if (2*rnsz > n) exit
         l = 1
         r = l+rnsz
         do
            if (r+rnsz > n+1) exit
            call merge_arrays(rnsz, rnsz, x(l:), x(r:), y(l:), order)
            l = l+2*rnsz
            r = l+rnsz
         end do
         m = mod(n, 2*rnsz)
         if (m > rnsz) then
            l = (n-m)+1
            r = l+rnsz
            call merge_arrays(rnsz, m-rnsz, x(l:), x(r:), y(l:), order)
         else if (m > 0) then
            l = (n-m)+1
            y(l:) = x(l:)
         end if
         x = y
         rnsz = 2*rnsz
      end do
      call merge_arrays(rnsz, n-rnsz, x(1:rnsz), x(rnsz+1:n), y, order)
   end subroutine sort_strings

   subroutine merge_integers(m, n, x, y, z, order)
      implicit none
      ! dummy arguments
      integer, intent(in) :: m, n
      integer, dimension(m), intent(in) :: x
      integer, dimension(n), intent(in) :: y
      integer, dimension(m+n), intent(out) :: z
      character (len = *), intent(in) :: order
      ! local data
      integer :: i, j, k
      ! processing
      i = 1
      j = 1
      k = 1
      do
         if (k > m+n) exit
         if (i > m) then
            z(k:m+n) = y(j:n)
            return
         else if (j > n) then
            z(k:m+n) = x(i:m)
            return
         else if (order == 'ASC' .and. x(i) <= y(j)) then
            z(k) = x(i)
            i = i+1
         else if (order == 'DESC' .and. x(i) >= y(j)) then
            z(k) = x(i)
            i = i + 1
         else
            z(k) = y(j)
            j = j+1
         end if
         k = k+1
      end do
   end subroutine merge_integers

   subroutine merge_reals(m, n, x, y, z, order)
      implicit none
      ! dummy arguments
      integer, intent(in) :: m, n
      double precision, dimension(m), intent(in) :: x
      double precision, dimension(n), intent(in) :: y
      double precision, dimension(m+n), intent(out) :: z
      character (len = *), intent(in) :: order
      ! local data
      integer :: i, j, k
      ! processing
      i = 1
      j = 1
      k = 1
      do
         if (k > m+n) exit
         if (i > m) then
            z(k:m+n) = y(j:n)
            return
         else if (j > n) then
            z(k:m+n) = x(i:m)
            return
         else if (order == 'ASC' .and. x(i) <= y(j)) then
            z(k) = x(i)
            i = i+1
         else if (order == 'DESC' .and. x(i) >= y(j)) then
            z(k) = x(i)
            i = i+1
         else
            z(k) = y(j)
            j = j+1
         end if
         k = k+1
      end do
   end subroutine merge_reals

   subroutine merge_strings(m, n, x, y, z, order)
      implicit none
      ! dummy arguments
      integer, intent(in) :: m, n
      character (len = *), dimension(m), intent(in) :: x
      character (len = *), dimension(n), intent(in) :: y
      character (len = *), dimension(m+n), intent(out) :: z
      character (len = *), intent(in) :: order
      ! local data
      integer :: i, j, k
      ! processing
      i = 1
      j = 1
      k = 1
      do
         if (k > m+n) exit
         if (i > m) then
            z(k:m+n) = y(j:n)
            return
         else if (j > n) then
            z(k:m+n) = x(i:m)
            return
         else if (order == 'ASC' .and. x(i) <= y(j)) then
            z(k) = x(i)
            i = i+1
         else if (order == 'DESC' .and. x(i) >= y(j)) then
            z(k) = x(i)
            i = i+1
         else
            z(k) = y(j)
            j = j+1
         end if
         k = k+1
      end do
   end subroutine merge_strings

   function sorted_integers(n, a, order) result(b)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      integer, dimension(n), intent(in) :: a
      character (len = *), intent(in) :: order
      ! function return location
      logical :: b
      ! local data
      integer :: i
      ! processing
      i = 1
      do
         if (i == n-1) exit
         if (order == 'ASC' .and. a(i+1) < a(i)) exit
         if (order == 'DESC' .and. a(i+1) > a(i)) exit
         i = i + 1
      end do
      if (i == n-1) then
         b = .true.
      else
         b = .false.
      end if
   end function sorted_integers

   function sorted_reals(n, a, order) result(b)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      double precision, dimension(n), intent(in) :: a
      character (len = *), intent(in) :: order
      ! function return location
      logical :: b
      ! local data
      integer :: i
      ! processing
      i = 1
      do
         if (i == n-1) then
            exit
         else if (order == 'ASC' .and. a(i+1) < a(i)) then
            exit
         else if (order == 'DESC' .and. a(i+1) > a(i)) then
            exit
         else
            i = i + 1
         end if
      end do
      if (i == n-1) then
         b = .true.
      else
         b = .false.
      end if
   end function sorted_reals

   function sorted_strings(n, a, order) result(b)
      implicit none
      ! dummy arguments
      integer, intent(in) :: n
      character (len = *), dimension(n), intent(in) :: a
      character (len = *), intent(in) :: order
      ! function return location
      logical :: b
      ! local data
      integer :: i
      ! processing
      i = 1
      do
         if (i == n-1) then
            exit
         else if (order == 'ASC' .and. a(i+1) < a(i)) then
            exit
         else if (order == 'DESC' .and. a(i+1) > a(i)) then
            exit
         else
            i = i + 1
         end if
      end do
      if (i == n-1) then
         b = .true.
      else
         b = .false.
      end if
   end function sorted_strings
end module


       subroutine pldp(l,pp,d)
        common/gfgmp/p1(2),p2(2)
        real l(3),p(2) ,pp(2),l1(3)
       l1(1)=-l(2)
       l1(2)=l(1)
       l1(3)=l(2)*pp(1)-l(1)*pp(2)
       s=l1(2)*l(1)-l(2)*l1(1)
       p(1)=(l1(3)*l(2)-l(3)*l1(2))/s
       p(2)=(l(3)*l1(1)-l1(3)*l(1))/s
        if(l(2).eq.0.) goto 20
        alp=l(1)**2+l(2)**2
        bet=l(1)*l(3)+l(1)*l(2)*p(2)-l(2)**2*p(1)
        gam=l(2)**2*p(1)**2+(l(3)+l(2)*p(2))**2-l(2)**2*d**2
        e=bet**2-alp*gam
        p1(1)=(-bet+sqrt(e))/alp
        p1(2)=-(l(1)*p1(1)+l(3))/l(2)
        p2(1)=(-bet-sqrt(e))/alp
        p2(2)=-(l(1)*p2(1)+l(3))/l(2)
        return
  20    f=d**2-(l(3)/l(1)+p(1))**2
        p1(1)=-l(3)/l(1)
        p1(2)=p(2)-sqrt(f)
        p2(1)=-l(3)/l(1)
        p2(2)=p(2)+sqrt(f)
        return
         end


subroutine compute_Cv(heat_cap) ! compute the heat capacity of the lattice using density of state
    use parameters
    integer :: tot_E
    double precision :: Z, E_avg, M_avg, E2_avg, weight
    double precision, intent(out) :: heat_cap

    Z = 0, E_avg = 0, M_avg = 0, E2_avg = 0, weight = 0
    do tot_E = -2*(latt_leng**2), 2*(latt_leng**2), 4
    weight = exp(-tot_E / T) * dens_of_tot_E
    Z = Z + weight
    E_avg = E_avg + weight * tot_E
    E2_avg = E2_avg + weight * tot_E ** 2
    end do
    E_avg = E_avg / Z
    E2_avg = E2_avg/ Z
    heat_cap = (E2_avg - E_avg ** 2) / (real (latt_leng**2, 8) * T**2)
end subroutine

subroutine compute_density_of_state_E(dens_of_tot_E)
   use parameters
   integer :: tot_E
   integer, dimension(-2*(latt_leng**2) : 2*(latt_leng**2) : 4), intent(out) :: dens_of_tot_E

   do tot_E = -2*(latt_leng**2), 2*(latt_leng**2), 4 ! compute density of state for each possible E
       dens_of_tot_E(tot_E) =
end subroutine


! This module contains all mathematical and physical constants
! This does not include constants which are configurable through input files,
module constants
  use real_kind

  implicit none

  ! Mathematical constants: pi, 4pi, log(10) and 1/3
  real(double), parameter :: CPI = 3.1415926535897932384626433832795029D0
  real(double), parameter :: CPI4 = 4.0D0 * CPI
  real(double), parameter :: CLN = 2.3025850929940456840179914546843642D0
  real(double), parameter :: C3RD = 1.0D0/3.0D0

  ! Physical constants
  real(double), parameter :: CL = 2.99792458D10     ! Speed of light
  real(double), parameter :: PLANCK = 6.6260693D-27 ! Planck constant
  real(double), parameter :: CG = 6.6742D-8         ! Newton constant
  real(double), parameter :: BOLTZM = 1.3806505D-16 ! Boltzmann constant
  real(double), parameter :: ECHAR = 4.80320441D-10 ! Electrostatic charge

  real(double), parameter :: AMU = 1.660538862D-24  ! Atomic mass unit
  real(double), parameter :: AME = 9.1093826D-28    ! Electron mass

  ! Astrophysical parameters
  real(double), parameter :: CMSN = 1.98844D0       ! Solar mass
  real(double), parameter :: CLSN = 3.844D0         ! Solar luminosity
  real(double), parameter :: CRSN = 0.69598D0       ! Solar radius
  real(double), parameter :: CASN = 4.57D9          ! Solar age
  real(double), parameter :: CZSN = 0.02            ! solar metallicity

  ! Units
  real(double), parameter :: CSY = 3.155692597D7    ! Seconds per year
  real(double), parameter :: CSDAY = 86400D0        ! Seconds per day
  real(double), parameter :: EVOLT = ECHAR/CL*1.0D8 ! erg/electron volt

  ! Derived constants
  real(double), parameter :: CA = 8.0D0*CPI**5*BOLTZM**4 / (15.0D0 * (CL*PLANCK)**3)
  real(double), parameter :: CME = 1.0D6*EVOLT/AMU  ! (erg/MeV) / (gram/amu)
  real(double), parameter :: CEVB = EVOLT/BOLTZM
  real(double), parameter :: CR = BOLTZM/AMU        ! gas constant

  real(double), parameter :: LAMC = PLANCK/(AME*CL) ! Compton length of electron
  real(double), parameter :: CRHO = 8.0D0*CPI/LAMC**3

  real(double), parameter :: CB = CRHO*AME*CL**2
  real(double), parameter :: CD = CRHO*AMU

  real(double), parameter :: CTE = BOLTZM/(AME*CL**2)
  real(double), parameter :: CGRT = 6.4D0*(CPI/4.32D4)**6*(1.0D11/CL)**5

  ! Constants that cannot be computed at compile time
  real(double) :: CEN
  real(double) :: CPL
  real(double) :: CG1
  real(double) :: CG2

  !Debug:
  integer, parameter :: debug_level = 0                    ! Debugging info:  0 - no debugging, 2 - print routine names when called

contains

   subroutine initialise_constants
      use real_kind
      use paquette_coefficients

      implicit none
      call initialise_collision_integrals
      CEN = (PLANCK/(2.0D0*CPI*AMU*BOLTZM)**0.5D0)**3 / AMU
      CPL = (CPI4/(AMU*BOLTZM**3))**0.5D0 * ECHAR**3
      CG1 = 1.0D5*CG**0.5D0
      CG2 = CG1*(CSDAY*1.0D-5) / (2.0D0 * CPI)
   end subroutine initialise_constants

end module constants

! Initialise constants, read in tables of physical data that are unchanged
! during the course of one run
subroutine setsup
  use real_kind
  use constants
  use neutrinos
  use ltm2ubv

  implicit none

  ! Initialise some constants that cannot be computed at compile time on some
  ! compilers
  call initialise_constants

  ! Read nuclear reaction rates and neutrino loss parameters
  ! Used to be read from the same file as the opacity data, which is stupid
  !  since this is independent of metalicity
  call load_reaction_neutrino_rates(42)

  ! Read Bol. Corr, U-B, B-V table.
  call load_colour_conversion_table(21)

  ! Read nuclear reaction (QRT) and neutrino (QNT) Q values, in MeV; constants
  ! for electron screening (CZA, CZB, CZC, CZD, VZ); atomic parameters (CBN, KZN),
  ! with masses (CAN) consistent with Q-values; ionization potentials (CHI) and
  ! statistical weights (COM); molecular hydrogen parameters (CH2)
  call load_atomic_data(26)

end subroutine setsup


!  *********************************************************************
!  *                                                                   *
!  *                        subroutine intr2d                          *
!  *                                                                   *
!  *********************************************************************
!  Mixed Precision Version 2.31
!  Written by Gordon A. Fenton, TUNS, Aug. 26, 1992
!  Latest Update: Jun 9, 1999
!
!  PURPOSE  creates the parameter matrices required for the interior cell
!           subdivision of LAS2G.
!
!  Requires:
!   1) from libGAFsim:	DSIFA, DSISL, DCHOL2, DAXPY, DSWAP, DDOT, IDAMAX
!
!    n    is the rank of [CC][CC^T]. It can be either n = 3 for the 2-D case or
!         n = 7 for the 3-D case.
!    mi   is the mapping from the global covariance matrix `R' into the local
!         `interior' covariance matrix (in the 2-D case, this is 1-to-1).
!
!  REVISION HISTORY:
!  2.31	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!-----------------------------------------------------------------------------
      subroutine intr2d( R, ir, B, ib, S, is, CI, n, AI, mi, iout, tol )
      real*8 R(ir,*), B(ib,*), S(is,*)
      real*8 RI(9,9), DA(9), BB(7,7)
      real CI(*), AI(9,*)
      integer mi(*), indx(9)

   1  format(a,a,a)
   2  format(a,e13.4)
!							extract R
      do 10 j = 1, 9
         do 10 i = 1, j
            RI(i,j) = R(mi(i),mi(j))
  10  continue
!							factorize R
      call dsifa( RI, 9, 9, indx, ierr )
      if( ierr .ne. 0 ) then
         write(iout,1)'Error: unable to factorize interior covariance matrix in INTR2D.'
         stop
      endif
!							make a copy of S
      do 50 j = 1, n
         do 20 i = 1, 9
            DA(i) = S(mi(i),j)
  20     continue
!							and solve for A
         call dsisl( RI, 9, 9, indx, DA )
!							store in real*4
         do 30 i = 1, 9
            AI(i,j) = DA(i)
  30     continue
!							update B
         do 40 i = 1, j
            BB(i,j) = B(i,j)                                               &
                    - S(mi(1),i)*DA(1)-S(mi(2),i)*DA(2)-S(mi(3),i)*DA(3)   &
                    - S(mi(4),i)*DA(4)-S(mi(5),i)*DA(5)-S(mi(6),i)*DA(6)   &
                    - S(mi(7),i)*DA(7)-S(mi(8),i)*DA(8)-S(mi(9),i)*DA(9)
  40     continue
  50  continue
!							Cholesky Decomposition
      call dchol2( BB, 7, n, rerr )
      if( rerr .gt. tol ) then
         write(iout,1)'Intr2d: Cholesky decomposition of interior covariance matrix BB'
         write(iout,2)'        has maximum relative error of ',rerr
      endif
!							store in real*4
      ii = 0
      do 60 j = 1, n
      do 60 i = 1, j
         ii = ii + 1
         CI(ii) = BB(i,j)
  60  continue

      return
      end


C$Procedure  VREL ( Vector relative difference, 3 dimensions )

      DOUBLE PRECISION FUNCTION VREL ( V1, V2  )

C$ Abstract
C
C   Return the relative difference between two 3-dimensional vectors.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C   None.
C
C$ Keywords
C
C     MATH
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION      V1 ( 3 )
      DOUBLE PRECISION      V2 ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C      V1,V2     I   Input vectors.
C
C$ Detailed_Input
C
C      V1, V2        are two 3-dimensional vectors for which the
C                    relative difference is to be computed.
C
C$ Detailed_Output
C
C      VREL          is the relative difference between V1 and V2.
C                    It is defined as:
C                                             || V1 - V2 ||
C                              VREL   =   ----------------------
C                                         MAX ( ||V1||, ||V2|| )
C
C                    where || X || indicates the Euclidean norm of
C                    the vector X.
C
C                    VREL assumes values in the range [0,2]. If both
C                    V1 and V2 are zero vectors then VREL is defined
C                    to be zero.
C
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C     If both V1 and V2 are zero vectors then VREL is defined
C     to be zero.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This function computes the relative difference between two
C     3-dimensional vectors as defined above.
C
C     The function VRELG may be used to find the relative difference
C     for two vectors of general dimension.
C
C$ Examples
C
C     This example code fragment computes the relative difference
C     between the geometric and light time corrected state of Io
C     with respect to Voyager 2 at a given UTC time.
C
C     C
C     C     The NAIF integer code for Io is 501 and the code for
C     C     Voyager 2 is -32.
C     C
C
C           INTEGER               IO
C           PARAMETER           ( IO  = 501 )
C
C           INTEGER               VG2
C           PARAMETER           ( VG2 = -32 )
C
C     C
C     C     Spicelib function
C     C
C           DOUBLE PRECISION      VREL
C     C
C     C     Local variables
C     C
C           DOUBLE PRECISION      STATE ( 6 )
C           DOUBLE PRECISION      POS1  ( 3 )
C           DOUBLE PRECISION      POS2  ( 3 )
C           DOUBLE PRECISION      DIFF
C           DOUBLE PRECISION      LT
C           DOUBLE PRECISION      ET
C
C           INTEGER               HANDLE
C
C           CHARACTER*(20)        UTC
C
C           DATA                  UTC / '1979 JUN 25 12:00:00' /
C
C     C
C     C     Load the sample SPK ephemeris file.
C     C
C           CALL SPKLEF ( 'VG2_JUP.BSP', HANDLE )
C     C
C     C     Convert the UTC time string to ephemeris time.
C     C
C           CALL UTC2ET ( UTC, ET )
C     C
C     C     First calculate the geometric state and then the light
C     C     time corrected state.
C     C
C           CALL SPKEZ ( IO, ET, 'J2000', 'NONE', VG2, STATE, LT )
C
C           CALL VEQU  ( STATE, POS1 )
C
C           CALL SPKEZ ( IO, ET, 'J2000', 'LT', VG2, STATE, LT )
C
C           CALL VEQU  ( STATE, POS2 )
C     C
C     C     Call VREL to find the relative difference between the
C     C     two states.
C     C
C           DIFF = VREL ( POS1, POS2 )
C
C           .
C           .
C           .
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     J.M. Lynch     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 15-JUN-1992 (JML)
C
C-&

C$ Index_Entries
C
C     relative difference of 3-dimensional vectors
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      VNORM
      DOUBLE PRECISION      VDIST

C
C     Local variables
C
      DOUBLE PRECISION      NUNORM
      DOUBLE PRECISION      DENORM

C
C     If the numerator is zero then set VREL equal to zero. Otherwise,
C     perform the rest of the calculation.
C
C     This handles the case where both vectors are zero vectors since
C     the distance between them will be zero.
C
      NUNORM = VDIST ( V1, V2 )

      IF ( NUNORM .EQ. 0.D0 ) THEN

         VREL = 0.D0

      ELSE

         DENORM = MAX (  VNORM(V1), VNORM(V2)  )

         VREL = NUNORM / DENORM

       END IF

      RETURN
      END


function ifft(yh) result(y)
! FFT function
complex(kind=8), intent(in)  :: yh(:)
integer(kind=8) :: plan_backward
complex(kind=8), allocatable :: y(:)
allocate(y(size(yh)))
call dfftw_plan_dft_1d_ (plan_backward, size(yh), yh, y, FFTW_BACKWARD, FFTW_ESTIMATE)
call dfftw_execute(plan_backward)
y = y/real(size(y),8)
end function ifft


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION WIGNER_3j(JA,JB,JC,MA,MB,MC)
!                                                                      *
!     Calculates the Wigner 3-j symbol by its algebraic formulae as    *
!     displayed in many texts on the theory of angular momentum        *
!     ((5.1) see R. D. Cowan, The Theory of Atomic Structure and       *
!     Spectra; University of California Press, 1981, p. 142).          *
!     The integer arguments ja,... of this function must be the double *
!     of the corresponding quantum numbers in the 3-j symbol, i.e.     *
!     jk = jk' + jk', mk = mk' + mk' in                                *
!                                                                      *
!                          (  ja'   jb'   jc'  )                       *
!                          (                   )                       *
!                          (  ma'   mb'   mc'  )                       *
!                                                                      *
!                                                                      *
!     Written by G. Gaigalas and D. Kato                               *
!                                        NIFS, Japan, September 2013   *
!     The last modification made by G. Gaigalas       June      2018   *
!                                                                      *
!***********************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: ZERO, ONE
      USE FACTS_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: JA, JB, JC, MA, MB, MC
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!----------------------------------------------
      INTEGER, DIMENSION(14) :: IK
      INTEGER :: K, KMIN, KMAX, I
      REAL(DOUBLE) :: DELTA, SUMK, SUM
!----------------------------------------------
!
!       Test the triangular condition and that for magnetic quantum numbers
!
      IF(MA+MB+MC /= 0 ) THEN
         WIGNER_3j = ZERO
         RETURN
      ELSE IF(ITTK(JA,JB,JC) == 0) THEN
         WIGNER_3j = ZERO
         RETURN
      ELSE IF(IABS(MA) > JA .OR. IABS(MB) > JB                         &
         .OR. IABS(MC) > JC) THEN
         WIGNER_3j = ZERO
         RETURN
      END IF
      IK( 1) =  JA+JB-JC
      IK( 2) =  JA-JB+JC
      IK( 3) = -JA+JB+JC
      IK( 4) =  JA+JB+JC+2
      IK( 5) =  JA-MA
      IK( 6) =  JA+MA
      IK( 7) =  JB-MB
      IK( 8) =  JB+MB
      IK( 9) =  JC-MC
      IK(10) =  JC+MC
      IK(11) =  JB-JC-MA
      IK(12) =  JA-JC+MB
      IK(13) =  JC-JB+MA
      IK(14) =  JA-JB-MC
      DO I = 1,14
         IF(MOD(IK(I),2) /= 0) THEN
         WRITE(0,*) 'Antras',I,IK(I)
            WIGNER_3j = ZERO
            RETURN
         END IF
         IK(I) = IK(I)/2
      END DO
!
!      Calculate the 3-j delta factor
      DELTA = DEXP(GAM(IK(1)+1))*DEXP(GAM(IK(2)+1))*DEXP(GAM(IK(3)+1)) &
            * DEXP(GAM(IK(5)+1))*DEXP(GAM(IK(6)+1))*DEXP(GAM(IK(7)+1)) &
            * DEXP(GAM(IK(8)+1))*DEXP(GAM(IK(9)+1))*DEXP(GAM(IK(10)+1))&
            /DEXP(GAM(IK(4)+1))
!
!     Find out the intervall of summation  k  and sum up
      KMIN = MAX(0,IK(11),IK(12))
      KMAX = MIN(IK(1),IK(5),IK(8))
      !
      SUM = 0.0
      DO K = KMIN,KMAX
         SUMK = DEXP(GAM(K+1))       * DEXP(GAM(IK(1)-K+1))            &
              * DEXP(GAM(IK( 5)-K+1))* DEXP(GAM(IK(8)-K+1))            &
              * DEXP(GAM(IK(13)+K+1))* DEXP(GAM(K-IK(12)+1))
         SUMK = 1.0/SUMK
         IF(MOD(K,2) == 0) THEN
            SUM = SUM + SUMK
         ELSE
            SUM = SUM - SUMK
         END IF
      END DO
      IF(MOD(IK(14),2) /= 0) THEN
         WIGNER_3j = -SQRT(DELTA) * SUM
      ELSE
         WIGNER_3j =  SQRT(DELTA) * SUM
      END IF
      RETURN
      END FUNCTION WIGNER_3j


      SUBROUTINE MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR,
     $                   RANK, X, RX, TOL, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To determine a value for the parameter PAR such that if x solves
C     the system
C
C           A*x = b ,     sqrt(PAR)*D*x = 0 ,
C
C     in the least squares sense, where A is an m-by-n matrix, D is an
C     n-by-n nonsingular diagonal matrix, and b is an m-vector, and if
C     DELTA is a positive number, DXNORM is the Euclidean norm of D*x,
C     then either PAR is zero and
C
C           ( DXNORM - DELTA ) .LE. 0.1*DELTA ,
C
C     or PAR is positive and
C
C           ABS( DXNORM - DELTA ) .LE. 0.1*DELTA .
C
C     It is assumed that a QR factorization, with column pivoting, of A
C     is available, that is, A*P = Q*R, where P is a permutation matrix,
C     Q has orthogonal columns, and R is an upper triangular matrix
C     with diagonal elements of nonincreasing magnitude.
C     The routine needs the full upper triangle of R, the permutation
C     matrix P, and the first n components of Q'*b (' denotes the
C     transpose). On output, MD03BY also provides an upper triangular
C     matrix S such that
C
C           P'*(A'*A + PAR*D*D)*P = S'*S .
C
C     Matrix S is used in the solution process.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COND    CHARACTER*1
C             Specifies whether the condition of the matrices R and S
C             should be estimated, as follows:
C             = 'E' :  use incremental condition estimation for R and S;
C             = 'N' :  do not use condition estimation, but check the
C                      diagonal entries of R and S for zero values;
C             = 'U' :  use the rank already stored in RANK (for R).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix R.  N >= 0.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR, N)
C             On entry, the leading N-by-N upper triangular part of this
C             array must contain the upper triangular matrix R.
C             On exit, the full upper triangle is unaltered, and the
C             strict lower triangle contains the strict upper triangle
C             (transposed) of the upper triangular matrix S.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     IPVT    (input) INTEGER array, dimension (N)
C             This array must define the permutation matrix P such that
C             A*P = Q*R. Column j of P is column IPVT(j) of the identity
C             matrix.
C
C     DIAG    (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the diagonal elements of the
C             matrix D.  DIAG(I) <> 0, I = 1,...,N.
C
C     QTB     (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the first n elements of the
C             vector Q'*b.
C
C     DELTA   (input) DOUBLE PRECISION
C             An upper bound on the Euclidean norm of D*x.  DELTA > 0.
C
C     PAR     (input/output) DOUBLE PRECISION
C             On entry, PAR must contain an initial estimate of the
C             Levenberg-Marquardt parameter.  PAR >= 0.
C             On exit, it contains the final estimate of this parameter.
C
C     RANK    (input or output) INTEGER
C             On entry, if COND = 'U', this parameter must contain the
C             (numerical) rank of the matrix R.
C             On exit, this parameter contains the numerical rank of
C             the matrix S.
C
C     X       (output) DOUBLE PRECISION array, dimension (N)
C             This array contains the least squares solution of the
C             system A*x = b, sqrt(PAR)*D*x = 0.
C
C     RX      (output) DOUBLE PRECISION array, dimension (N)
C             This array contains the matrix-vector product -R*P'*x.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If COND = 'E', the tolerance to be used for finding the
C             rank of the matrices R and S. If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             the reciprocal condition number;  a (sub)matrix whose
C             estimated condition number is less than 1/TOL is
C             considered to be of full rank.  If the user sets TOL <= 0,
C             then an implicitly computed, default tolerance, defined by
C             TOLDEF = N*EPS,  is used instead, where EPS is the machine
C             precision (see LAPACK Library routine DLAMCH).
C             This parameter is not relevant if COND = 'U' or 'N'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, the first N elements of this array contain the
C             diagonal elements of the upper triangular matrix S.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 4*N, if COND =  'E';
C             LDWORK >= 2*N, if COND <> 'E'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The algorithm computes the Gauss-Newton direction. A least squares
C     solution is found if the Jacobian is rank deficient. If the Gauss-
C     Newton direction is not acceptable, then an iterative algorithm
C     obtains improved lower and upper bounds for the parameter PAR.
C     Only a few iterations are generally needed for convergence of the
C     algorithm. If, however, the limit of ITMAX = 10 iterations is
C     reached, then the output PAR will contain the best value obtained
C     so far. If the Gauss-Newton step is acceptable, it is stored in x,
C     and PAR is set to zero, hence S = R.
C
C     REFERENCES
C
C     [1] More, J.J., Garbow, B.S, and Hillstrom, K.E.
C         User's Guide for MINPACK-1.
C         Applied Math. Division, Argonne National Laboratory, Argonne,
C         Illinois, Report ANL-80-74, 1980.
C
C     NUMERICAL ASPECTS
C                               2
C     The algorithm requires 0(N ) operations and is backward stable.
C
C     FURTHER COMMENTS
C
C     This routine is a LAPACK-based modification of LMPAR from the
C     MINPACK package [1], and with optional condition estimation.
C     The option COND = 'U' is useful when dealing with several
C     right-hand side vectors, but RANK should be reset.
C     If COND = 'E', but the matrix S is guaranteed to be nonsingular
C     and well conditioned relative to TOL, i.e., rank(R) = N, and
C     min(DIAG) > 0, then its condition is not estimated.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005.
C
C     KEYWORDS
C
C     Linear system of equations, matrix operations, plane rotations.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER           ITMAX
      PARAMETER         ( ITMAX = 10 )
      DOUBLE PRECISION  P1, P001, ZERO, SVLMAX
      PARAMETER         ( P1  = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0,
     $                    SVLMAX = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         COND
      INTEGER           INFO, LDR, LDWORK, N, RANK
      DOUBLE PRECISION  DELTA, PAR, TOL
C     .. Array Arguments ..
      INTEGER           IPVT(*)
      DOUBLE PRECISION  DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*)
C     .. Local Scalars ..
      INTEGER           ITER, J, L, N2
      DOUBLE PRECISION  DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL,
     $                  PARU, TEMP, TOLDEF
      LOGICAL           ECOND, NCOND, SING, UCOND
      CHARACTER         CONDL
C     .. Local Arrays ..
      DOUBLE PRECISION  DUM(3)
C     .. External Functions ..
      DOUBLE PRECISION  DDOT, DLAMCH, DNRM2
      LOGICAL           LSAME
      EXTERNAL          DDOT, DLAMCH, DNRM2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DSWAP, DTRMV, DTRSV, MB02YD,
     $                  MB03OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MAX, MIN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      ECOND = LSAME( COND, 'E' )
      NCOND = LSAME( COND, 'N' )
      UCOND = LSAME( COND, 'U' )
      INFO  = 0
      IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN
         INFO = -1
      ELSEIF( N.LT.0 ) THEN
         INFO = -2
      ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSEIF ( DELTA.LE.ZERO ) THEN
         INFO = -8
      ELSEIF( PAR.LT.ZERO ) THEN
         INFO = -9
      ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN
         INFO = -10
      ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN
         INFO = -15
      ELSEIF ( N.GT.0 ) THEN
         DMINO = DIAG(1)
         SING  = .FALSE.
C
         DO 10 J = 1, N
            IF ( DIAG(J).LT.DMINO )
     $         DMINO = DIAG(J)
            SING = SING .OR. DIAG(J).EQ.ZERO
   10    CONTINUE
C
         IF ( SING )
     $      INFO = -6
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MD03BY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         PAR  = ZERO
         RANK = 0
         RETURN
      END IF
C
C     DWARF is the smallest positive magnitude.
C
      DWARF = DLAMCH( 'Underflow' )
      N2    = N
C
C     Estimate the rank of R, if required.
C
      IF ( ECOND ) THEN
         N2   = 2*N
         TEMP = TOL
         IF ( TEMP.LE.ZERO ) THEN
C
C           Use the default tolerance in rank determination.
C
            TEMP = DBLE( N )*DLAMCH( 'Epsilon' )
         END IF
C
C        Estimate the reciprocal condition number of R and set the rank.
C        Workspace: 2*N.
C
         CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TEMP, SVLMAX, DWORK,
     $                RANK, DUM, DWORK, LDWORK, INFO )
C
      ELSEIF ( NCOND ) THEN
         J = 1
C
   20    CONTINUE
            IF ( R(J,J).NE.ZERO ) THEN
               J = J + 1
               IF ( J.LE.N )
     $            GO TO 20
            END IF
C
         RANK = J - 1
      END IF
C
C     Compute and store in x the Gauss-Newton direction. If the
C     Jacobian is rank-deficient, obtain a least squares solution.
C     The array RX is used as workspace.
C
      CALL DCOPY( RANK, QTB, 1, RX, 1 )
      DUM(1) = ZERO
      IF ( RANK.LT.N )
     $   CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 )
      CALL DTRSV( 'Upper', 'No transpose', 'Non unit', RANK, R, LDR,
     $            RX, 1 )
C
      DO 30 J = 1, N
         L    = IPVT(J)
         X(L) = RX(J)
   30 CONTINUE
C
C     Initialize the iteration counter.
C     Evaluate the function at the origin, and test
C     for acceptance of the Gauss-Newton direction.
C
      ITER = 0
C
      DO 40 J = 1, N
         DWORK(J) = DIAG(J)*X(J)
   40 CONTINUE
C
      DXNORM = DNRM2( N, DWORK, 1 )
      FP     = DXNORM - DELTA
      IF ( FP.GT.P1*DELTA ) THEN
C
C        Set an appropriate option for estimating the condition of
C        the matrix S.
C
         IF ( UCOND ) THEN
            IF ( LDWORK.GE.4*N ) THEN
               CONDL  = 'E'
               TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' )
            ELSE
               CONDL  = 'N'
               TOLDEF = TOL
            END IF
         ELSE
            CONDL  = COND
            TOLDEF = TOL
         END IF
C
C        If the Jacobian is not rank deficient, the Newton
C        step provides a lower bound, PARL, for the zero of
C        the function. Otherwise set this bound to zero.
C
         IF ( RANK.EQ.N ) THEN
C
            DO 50 J = 1, N
               L = IPVT(J)
               RX(J) = DIAG(L)*( DWORK(L)/DXNORM )
   50       CONTINUE
C
            CALL DTRSV( 'Upper', 'Transpose', 'Non unit', N, R, LDR,
     $                  RX, 1 )
            TEMP = DNRM2( N, RX, 1 )
            PARL = ( ( FP/DELTA )/TEMP )/TEMP
C
C           For efficiency, use CONDL = 'U', if possible.
C
            IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO )
     $         CONDL = 'U'
         ELSE
            PARL = ZERO
         END IF
C
C        Calculate an upper bound, PARU, for the zero of the function.
C
         DO 60 J = 1, N
            L = IPVT(J)
            RX(J) = DDOT( J, R(1,J), 1, QTB, 1 )/DIAG(L)
   60    CONTINUE
C
         GNORM = DNRM2( N, RX, 1 )
         PARU  = GNORM/DELTA
         IF ( PARU.EQ.ZERO )
     $      PARU = DWARF/MIN( DELTA, P1 )/P001
C
C        If the input PAR lies outside of the interval (PARL,PARU),
C        set PAR to the closer endpoint.
C
         PAR = MAX( PAR, PARL )
         PAR = MIN( PAR, PARU )
         IF ( PAR.EQ.ZERO )
     $      PAR = GNORM/DXNORM
C
C        Beginning of an iteration.
C
   70    CONTINUE
            ITER = ITER + 1
C
C           Evaluate the function at the current value of PAR.
C
            IF ( PAR.EQ.ZERO )
     $         PAR = MAX( DWARF, P001*PARU )
            TEMP = SQRT( PAR )
C
            DO 80 J = 1, N
               RX(J) = TEMP*DIAG(J)
   80       CONTINUE
C
C           Solve the system A*x = b , sqrt(PAR)*D*x = 0 , in a least
C           square sense. The first N elements of DWORK contain the
C           diagonal elements of the upper triangular matrix S, and
C           the next N elements contain the vector z, so that x = P*z.
C           The vector z is preserved if COND = 'E'.
C           Workspace:   4*N, if CONDL =  'E';
C                        2*N, if CONDL <> 'E'.
C
            CALL MB02YD( CONDL, N, R, LDR, IPVT, RX, QTB, RANK, X,
     $                   TOLDEF, DWORK, LDWORK, INFO )
C
            DO 90 J = 1, N
               DWORK(N2+J) = DIAG(J)*X(J)
   90       CONTINUE
C
            DXNORM = DNRM2( N, DWORK(N2+1), 1 )
            TEMP   = FP
            FP     = DXNORM - DELTA
C
C           If the function is small enough, accept the current value
C           of PAR. Also test for the exceptional cases where PARL
C           is zero or the number of iterations has reached ITMAX.
C
            IF ( ABS( FP ).GT.P1*DELTA .AND.
     $         ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND.
     $           ITER.LT.ITMAX ) THEN
C
C              Compute the Newton correction.
C
               DO 100 J = 1, RANK
                  L = IPVT(J)
                  RX(J) = DIAG(L)*( DWORK(N2+L)/DXNORM )
  100          CONTINUE
C
               IF ( RANK.LT.N )
     $            CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 )
               CALL DSWAP( N, R, LDR+1, DWORK, 1 )
               CALL DTRSV( 'Lower', 'No transpose', 'Non Unit', RANK,
     $                     R, LDR, RX, 1 )
               CALL DSWAP( N, R, LDR+1, DWORK, 1 )
               TEMP = DNRM2( RANK, RX, 1 )
               PARC = ( ( FP/DELTA )/TEMP )/TEMP
C
C              Depending on the sign of the function, update PARL
C              or PARU.
C
               IF ( FP.GT.ZERO ) THEN
                  PARL = MAX( PARL, PAR )
               ELSE IF ( FP.LT.ZERO ) THEN
                  PARU = MIN( PARU, PAR )
               END IF
C
C              Compute an improved estimate for PAR.
C
               PAR = MAX( PARL, PAR + PARC )
C
C              End of an iteration.
C
               GO TO 70
            END IF
      END IF
C
C     Compute -R*P'*x = -R*z.
C
      IF ( ECOND .AND. ITER.GT.0 ) THEN
C
         DO 110 J = 1, N
            RX(J) = -DWORK(N+J)
  110    CONTINUE
C
         CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, R, LDR,
     $               RX, 1 )
      ELSE
C
         DO 120 J = 1, N
            RX(J) = ZERO
            L     = IPVT(J)
            CALL DAXPY( J, -X(L), R(1,J), 1, RX, 1 )
  120    CONTINUE
C
      END IF
C
C     Termination. If PAR = 0, set S.
C
      IF ( ITER.EQ.0 ) THEN
         PAR = ZERO
C
         DO 130 J = 1, N - 1
            DWORK(J) = R(J,J)
            CALL DCOPY( N-J, R(J,J+1), LDR, R(J+1,J), 1 )
  130    CONTINUE
C
         DWORK(N) = R(N,N)
      END IF
C
      RETURN
C
C *** Last line of MD03BY ***
      END


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_rad_lower( n, gg, r )

!  Determine the radius r of the ball inscribed in the ellipsoid E given
!  by { x | norm(G^T * x) <=1 ), where G is an n x n lower triangular
!  matrix.  The array gg contains the matrix G in packed format.

!  Method:  r = 1 / sqrt(lam_max)  where lam_max is the largest
!           eigenvalue of G * G^T

!  S.B. Pope 6/12/04

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: gg((n*(n+1))/2)
real(k_dp), intent(out) :: r

integer    :: info, i, j, k, nev, lwork, iwork(5*n), ifail(n)
real(k_dp) :: g(n,n), a(n,n), dum(1), ev(n), dumz(n,1), work(n*(n+8))

lwork = n*(n+8)

!  unpack gg into g
k = 0
g = 0.d0
do j = 1, n
   do i = j, n
      k = k + 1
	  g(i,j) = gg(k)
   end do
end do

!  form a = A = G * G^T
a = g
call dtrmm ( 'R', 'L', 'T', 'N', n, n, 1.d0, g, n, a, n )

!  find first (smallest) eigenvalues of A

call dsyevx( 'N', 'I', 'L', n, a, n, dum, dum, n, n, 0.d0, nev, ev, dumz, n, &
             work, lwork, iwork, ifail, info )

if( info /= 0 ) then  !  use SVD instead
   call ell_chol2eig( n, gg, a, work )
   r = 1.d0 / work(1)
   return
endif

if( ev(1) <= 0.d0 ) then
   write(0,*)'ell_rad_lower: lam_min <=0 ', ev(1)
   stop
endif

r = 1.d0 / sqrt( ev(1) )

return
end subroutine ell_rad_lower


!*********************************************
!To compile program:
!
! gfortran spin_hyperfine_module.F90 -lblas -fopenmp -llapack -o spin_hyperfine.exe
!
! Program can also be compiled without -lblas, -llapack and/or -fopenmp for debugging
!
!Tested with LAPACK-3.4.2
!*********************************************

module decoherence_stuff
  implicit none

  !Simulation parameters
  integer,          parameter :: N = 1 				!Number of Nuclei in simulation
  integer,          parameter :: t_max = 10000 			!Maximum number of timesteps
  integer,          parameter :: dp=selected_real_kind(15,300)		!precision of numerical values
  real(kind=dp),    parameter :: interaction_constant = -0.04_dp 	!Interaction constant for hyperfine interaction
  complex(kind=dp), parameter :: TDSE_constant = (0.0_dp, 1.0E-5_dp)	!TDSE wavefunction constant
  integer         , parameter :: QN = 2**(N+1)				!'Quantum' N, defined as 2^(N+1) which is the number of possible states

  !Simulation Variables
  complex(kind=dp), save, dimension(1:QN)      :: C            !Complex numbers corresponding to basis states
  real(kind=dp),    save, dimension(1:QN,1:QN) :: H            !Hamiltonian matrix for system
  real(kind=dp),    save, dimension(1:QN,1:QN) :: basis        !matrix of basis vectors (diagonalised)
  real(kind=dp),    save, dimension(1:QN)      :: e_spin_up_wf !Wavefunction corresponding to superpositon of electron spin up states

  !Error reporting
  integer,          save :: ierr !Error integer

contains

  !*********************************************
  !
  !Performs Kronecker product of two matrices A and B producing matrix P
  !n and m correspond to the dimensions of A and x and y correspond to the dimensions of B
  !dimensions of P are assumed to be n*x and m*y
  !
  !*********************************************
  subroutine kronecker_product(A, B, P, n, m, x, y)
    implicit none
    integer :: i, j, k, l
    integer :: n, m, x, y
    complex(kind=dp), dimension(n, m) :: A
    complex(kind=dp), dimension(x, y) :: B
    complex(kind=dp), dimension(x*n, y*m) :: P

    do i = 1, n
      do j = 1, m

	do k = 1, x
	  do l = 1, y

	    P((i-1)*x + k, (j-1)*y + l) = A(i, j) * B(k, l)

	  end do
	end do

      end do
    end do

    return

  end subroutine kronecker_product

  !*********************************************
  !Generates a hamiltonian for the hyperfine interaction from pauli matrices
  !*********************************************
  subroutine hyperfine_hamiltonian
    implicit none
    integer :: i, j, k
    complex(kind=dp), dimension(3,2,2) :: pauli
    real(kind=dp), dimension(2,2) :: identity
    integer, dimension(1:N,1:N) :: diag_matrix
    complex(kind=dp), dimension(:,:), Allocatable :: A
    complex(kind=dp), dimension(2,2) :: B
    complex(kind=dp), dimension(:,:), Allocatable :: P

    pauli(1, 1, 2) = 1.0_dp		!Pauli x
    pauli(1, 1, 1) = 0.0_dp		!Pauli x
    pauli(1, 2, 2) = 0.0_dp		!Pauli x
    pauli(1, 2, 1) = 1.0_dp		!Pauli x

    pauli(2, 1, 1) = 1.0_dp		!Pauli z
    pauli(2, 1, 2) = 0.0_dp		!Pauli z
    pauli(2, 2, 1) = 0.0_dp		!Pauli z
    pauli(2, 2, 2) = -1.0_dp		!Pauli z

    pauli(3, 1, 2) = (0.0_dp, -1.0_dp) !Pauli y
    pauli(3, 1, 1) = 0.0_dp		!Pauli y
    pauli(3, 2, 2) = 0.0_dp		!Pauli y
    pauli(3, 2, 1) = (0.0_dp, 1.0_dp)  !Pauli y

    identity(1, 1) = 1.0_dp		!Identity matrix
    identity(2, 2) = 1.0_dp		!Identity matrix
    identity(1, 2) = 0.0_dp		!Identity matrix
    identity(2, 1) = 0.0_dp		!Identity matrix

    !Creates a diagonal matrix for permuations of spin matrices
    do i = 1, N
      diag_matrix(i, i) = 1
    end do

    !k signifies each of the cartesian dimensions
    !x = 1
    !z = 2
    !y = 3
    do k = 1, 3

      !Loops over number of possible combinations of identity and pauli matrices
      do i = 1, N

	!Allocates A input matrix for kronecker_product first iteration
	Allocate(A(1:2, 1:2))
	if (ierr/=0) stop 'Error in allocating matrix initial A'

	!Allocate matrix result for kronecker product so it set as first pauli matrix
	!and then can be deallocated in loop
	Allocate(P(1:2, 1:2))
	if (ierr/=0) stop 'Error in allocating matrix initial P'

	!Sets up the first A input matrix as the k dimension pauli matrix
	P = pauli(k, 1:2, 1:2)

	!Loops over each matrix to be multiplied for this iteration
	!Each j is a possible interaction pair
	do j = 1, N

	  !Sets previous product as next input
	  A = P

	  !Deallocates product matrix so it can be reshaped
	  Deallocate(P)
	  if (ierr/=0) stop 'Error in deallocating matrix P in loop'

	  !Finds the next matrix product based on diagonlised matrix
	  if(diag_matrix(i, j) == 1) then
	    !Sets the B input matrix as the kth dimensional pauli matrix
	    B(1:2, 1:2) = pauli(k, 1:2, 1:2)
	  else
	    !Sets the B input matrix as the identity matrix (non-interaction)
	    B(1:2, 1:2) = identity(1:2, 1:2)
	  end if

	  !Allocates P matrix to the size of size of the next k_product matrix
	  Allocate(P(1:2**(j+1), 1:2**(j+1)))

	  !Calls the tensor product for A and B producing P
	  !Dimensions of A are determined by place in j loop
	  call kronecker_product(A, B, P, 2**j, 2**j, 2, 2)

	  !Deallocates input matrix A to prepare for next loop
	  Deallocate(A)
	  if (ierr/=0) stop 'Error in deallocating matrix A in loop'

	  !Allocates input matrix A in next size to prepare for next loop
	  Allocate(A(1:2**(j+1), 1:2**(j+1)))
	  if (ierr/=0) stop 'Error in allocating matrix A in loop'

	end do

	!Deallocates A for this interaction
	Deallocate(A)
	if (ierr/=0) stop 'Error in deallocating matrix A at end of loop'

	!Adds P to hamiltonian in matrix at each loop
	!Allows for additional hamiltonian elements to be added later
	H(1:QN,1:QN) = H(1:QN,1:QN) + P(1:QN, 1:QN)

	Deallocate(P)
	if (ierr/=0) stop 'Error in deallocating matrix P at end'

      end do
    end do

    !Writes Hamiltonian to file for debugging
    open(400, file="hamiltonian.dat")
    do i = 1, QN
      write(400, *) (INT(H(i, j)), j = 1, QN)
    end do
    close(400)

    !Multiplies all hamiltonian elements by hyperfine interaction constant
    !H = interaction_constant * H

    return

  end subroutine hyperfine_hamiltonian

  !*********************************************
  !
  !*********************************************
  subroutine magnetic_hamiltonian
  !placeholder
  end subroutine magnetic_hamiltonian

  !*********************************************
  ! Uses LAPACK to find eigenstates of hamiltonian H using DGEEV functions
  ! DSYEVD finds the eigenvectors and eigenvalues of symmetric matrices
  !
  ! LAPACK reference:
  !@BOOK{laug,
  !    AUTHOR = {Anderson, E. and Bai, Z. and Bischof, C. and
  !              Blackford, S. and Demmel, J. and Dongarra, J. and
  !              Du Croz, J. and Greenbaum, A. and Hammarling, S. and
  !              McKenney, A. and Sorensen, D.},
  !    TITLE = {{LAPACK} Users' Guide},
  !    EDITION = {Third},
  !    PUBLISHER = {Society for Industrial and Applied Mathematics},
  !    YEAR = {1999},
  !    ADDRESS = {Philadelphia, PA},
  !    ISBN = {0-89871-447-8 (paperback)} }
  !*********************************************
  subroutine find_eigenstates
    implicit none

    integer :: i, j							!Loop integers
    integer, parameter :: LIWORK = 64

    real(kind=dp), dimension(1:QN) :: WR			!Work (real)
    real(kind=dp), dimension(1:QN) :: WI			!Work (imaginary)
    real(kind=dp), dimension(1:QN, 1:QN) :: A
    real(kind=dp), dimension(1:QN,1:QN) :: VL
    real(kind=dp), dimension(1:QN,1:QN) :: VR
    integer, dimension(1:LIWORK) :: WORK

    !Because A is overwritten by function
    A = H

    call DGEEV( 'N', 'V', QN, A, QN, WR, WI, VL, 1, VR, QN, WORK, LIWORK, ierr)

    if (ierr/=0) then
      print *, 'Error in solving eigenstates of hamiltonian'
      if (ierr<0) then
	print *, 'value', ierr, 'had illegal value'
      else
	print *, 'dgeev failed to converge'
      end if
      stop
    end if

    open(600, file='eigenstates.dat', iostat=ierr)
    if (ierr==0) then
      do j=1, QN
	if(WI(j)==0.0_dp) then
	  write(600,*) 'Eigenvalue', j, '=', WR(j)
	else
	  write(600,*) 'Eigenvalue', j, '=', WR(j), '+', WI(i), 'i'
	end if

	write(600,*)
	write(600,*) 'Eigenvector', j,  '='
	write(600,*)

	if(WI(j)==0.0_dp) then
	  do i=1, QN
	    write(600, *) VR(i, j)
	  end do
	elseif(WI(j)>=0.0_dp) then
	  do i=1, QN
	    write(600,*) VR(i, j), '+', VR(i, j+1), 'i'
	  end do
	else
	  do i=1, QN
	    write(600,*) VR(i, j-1), '+', VR(i, j), 'i'
	  end do
	 end if

	write(600,*)

      end do
    else
      stop 'Error in opening file eigenstates.dat'
    end if

    close(600, iostat=ierr)
    if (ierr/=0) stop 'Error in closing file eigenstates.dat'

  end subroutine find_eigenstates

  !*********************************************
  !Generates basis functions
  !
  !
  !
  !
  !*********************************************
  subroutine init_basis
    implicit none
    integer :: i, j          !loop variables

    !Sets all values in basis matrix to 0 with double precision
    basis(:, :) = 0.0_dp

    !Sets up basis functions
    do i = 1, QN
      basis(i,i) = 1.0_dp
    end do

    !sets up complex values and
    e_spin_up_wf(:) = 0.0_dp
    C(:) = 0.0_dp

    do i = 1, (2**N)
      e_spin_up_wf(i) = 1.0_dp / (SQRT(REAL(2**N, kind=dp)))
      C(i) = 1.0_dp / (SQRT(REAL(2**N, kind=dp)))
    end do

  end subroutine init_basis

  !*********************************************
  !Finds "fidelity" of system in current state
  !
  !
  !
  !
  !
  !*********************************************
  subroutine fidelity(Fid)
    implicit none

    !Subroutine variables
    real(kind=dp) :: Fid           !Fidelity variable for subroutine
    real(kind=dp) :: DDOT          !DDOT for blas library

!If BLAS is enabled when compiling (-lblas), this code segment
!will be compiled into final program using BLAS functions
#ifdef lblas

      Fid = (abs(DDOT(QN, e_spin_up_wf,1, C, 1)))**2

!If BLAS is not enabled when compiling, this section of intrinsic functions
!will be used instead.
#else

      Fid = (abs(DOT_PRODUCT(e_spin_up_wf, C)))**2

!ends the preprocessor if statement
#endif

    !returns value of Fid from subroutine to main program
    return

  end subroutine fidelity

  !*********************************************
  !Integrates time dependant schroedinger equation with simple numeric differnetiation
  !
  !
  !
  !
  !
  !*********************************************
  subroutine intergrate_TDSE
    implicit none

    !Library header for OpenMP
    !Required for single memory multiple processor operations
    !Requires compiler flag -fopenmp in gnu compilers to enable
    include 'omp_lib.h'

    !subroutine variables
    integer :: i, j                                     !Loop integers
    real(kind=dp) :: DDOT                               !BLAS library double precision dot product (required)

    real(kind=dp) :: Hij                                !Dot product of Hi and transpose of basis(j)
    complex(kind=dp) :: sum_C_H                         !Sum of Complex values multipled by Hij
    real(kind=dp), dimension(1:QN):: Hi           !Vector resulting from matrix vector multiply of H and basis(i)

    !iterate j from 1 to QN
    do j=1,QN

      !Set summation to zero to initial addition in next loop
      sum_C_H = 0.0_dp

      !$OMP parallel do private(i, Hij, Hi) shared(C, H, j) reduction(+:sum_C_H)
      !iterate i from 1 to QN
      !With OpenMP enabled this loop is performed on each thread seperately
      !Values of sum_C_H are added together from each thread at end of loop
      do i=1,QN

!If BLAS is enabled when compiling (-lblas), this code segment
!will be compiled into final program using BLAS functions
#ifdef lblas

	  !call for double precision matrix vector multiply from BLAS
	  !Multiplies Hamiltonian matrix with basis(i) to form vector Hi
	  call DGEMV( 'N', QN, QN, 1.0_dp, H(1:QN, 1:QN), QN, &
	  basis(i,1:QN), 1, 0.0_dp, Hi(1:QN), 1)

	  !call for double precision dot product from BLAS
	  !Performs dot product of transpose of basis(j) with Hi to form value Hij
	  Hij = DDOT(QN,basis(j, 1:QN),1,Hi(1:QN),1)

!If BLAS is not enabled when compiling, this section of intrinsic functions
!will be used instead.
#else

	  !call for intrinsic matrix vector multiply
	  !Multiplies Hamiltonian matrix with basis(i) to form vector Hi
	  Hi = MATMUL(H, basis(i, 1:QN))

	  !call for intrinsic dot product
	  !Performs dot product of transpose of basis(j) with Hi to form value Hij
	  Hij = DOT_PRODUCT(basis(j, 1:QN), Hi)

!Ends preprocessor if block
#endif

	!Adds product of C(i) and Hij to summation
	!This is processed individually on each thread then summed at end
	!if openMP is enabled (-fopenmp)
	sum_C_H = sum_C_H + C(i) * Hij

      end do
      !$OMP end parallel do
      !ends the parallel do loop for openMP

      !Find C(j) by multiplying TDSE_constant with sum_C_H
      C(j) = C(j) - TDSE_constant * sum_C_H

    end do

  end subroutine intergrate_TDSE

end module decoherence_stuff

!*********************************************
!
!Main program
!
!
!
!
!*********************************************
program hyperfine_spin_interaction
  use decoherence_stuff
  implicit none
  integer :: t
  integer :: i, j
  real(kind=dp) :: Fid
  real(kind=dp) :: sum_C_H
  real(kind=dp), dimension(1:QN):: Hi
  real(kind=dp) :: Hij

  !calls the hyperfine interaction hamiltonian subroutine
  !adds a hyperfine interaction hamiltonian for N nuclei and 1 electron
  !to H
  call hyperfine_hamiltonian

!If LAPACK is enabled when compiling (-llapack), this code segment
!will be compiled into final program using LAPACK functions
!#ifdef llapack

  !calls the eigenstate solution subroutine which finds the
  !eigenvectors and eigenvalues of the hamiltonian
  !and writes them to file eigenstates.dat
  call find_eigenstates

!#endif

  !calls the subroutine to initiate basis states
  call init_basis

    !Open output files for use in time loop
    !Opens file for c_vs_time.dat and assigns it value 100 and reports error if failure
    open(100, file="c_vs_time.dat",iostat=ierr)
    if (ierr/=0) stop 'Error in opening file c_vs_time.dat'

    !Opens file for sum_c_vs_time.dat and assigns it value 200 and reports error if failure
    open(200, file="sum_c_vs_time.dat",iostat=ierr)
    if (ierr/=0) stop 'Error in opening file sum_c_vs_time.dat'

    !Opens file for fidelity_vs_time.dat and assigns it value 300 and reports error if failure
    open(300, file="fidelity_vs_time.dat",iostat=ierr)
    if (ierr/=0) stop 'Error in opening file fidelity_vs_time.dat'

  !Loops over time from t= 1 to tmax which is set in module header
  do t = 1, t_max

    !Calls the subroutine to integrate the TDSE
    call intergrate_TDSE

    !Calls the fidelity function which finds the fidelity
    !of the system compared to e_spin_up_wf which
    !is a superpostion of the states which contain a spin up electron
    call fidelity(Fid)

    !write to output file
    !writes probability of each state to file in sequence as well as timesteps
    !writes to c_vs_time.dat
    write(100, *) t, (abs(C(i))**2.0_dp, i = 1, QN)

    !writes sum of probabilities and time step to file
    !writes to sum_c_vs_time.dat
    write(200, *) t, sum(abs(C)**2.0_dp)

    !writes fidelity of system compared to stated value with timestep
    !writes to fidelity_vs_time.dat
    write(300, *) t, Fid

  end do

  !Closes files
  !Closes file c_vs_time.dat and reports error if failure
  close(100,iostat=ierr)
  if (ierr/=0) stop 'Error in closing file c_vs_time.dat'

  !Closes file sum_c_vs_time.dat and reports error if failure
  close(200,iostat=ierr)
  if (ierr/=0) stop 'Error in closing file sum_c_vs_time.dat'

  !Closes file fidelity_vs_time.dat and reports error if failure
  close(300,iostat=ierr)
  if (ierr/=0) stop 'Error in opening file fidelity_vs_time.dat'

end program hyperfine_spin_interaction


      SUBROUTINE MC03MD( RP1, CP1, CP2, DP1, DP2, DP3, ALPHA, P1,
     $                   LDP11, LDP12, P2, LDP21, LDP22, P3, LDP31,
     $                   LDP32, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the coefficients of the real polynomial matrix
C
C        P(x) = P1(x) * P2(x) + alpha * P3(x),
C
C     where P1(x), P2(x) and P3(x) are given real polynomial matrices
C     and alpha is a real scalar.
C
C     Each of the polynomial matrices P1(x), P2(x) and P3(x) may be the
C     zero matrix.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     RP1     (input) INTEGER
C             The number of rows of the matrices P1(x) and P3(x).
C             RP1 >= 0.
C
C     CP1     (input) INTEGER
C             The number of columns of matrix P1(x) and the number of
C             rows of matrix P2(x).  CP1 >= 0.
C
C     CP2     (input) INTEGER
C             The number of columns of the matrices P2(x) and P3(x).
C             CP2 >= 0.
C
C     DP1     (input) INTEGER
C             The degree of the polynomial matrix P1(x).  DP1 >= -1.
C
C     DP2     (input) INTEGER
C             The degree of the polynomial matrix P2(x).  DP2 >= -1.
C
C     DP3     (input/output) INTEGER
C             On entry, the degree of the polynomial matrix P3(x).
C             DP3 >= -1.
C             On exit, the degree of the polynomial matrix P(x).
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar value alpha of the problem.
C
C     P1      (input) DOUBLE PRECISION array, dimension (LDP11,LDP12,*)
C             If DP1 >= 0, then the leading RP1-by-CP1-by-(DP1+1) part
C             of this array must contain the coefficients of the
C             polynomial matrix P1(x). Specifically, P1(i,j,k) must
C             contain the coefficient of x**(k-1) of the polynomial
C             which is the (i,j)-th element of P1(x), where i = 1,2,...,
C             RP1, j = 1,2,...,CP1 and k = 1,2,...,DP1+1.
C             If DP1 = -1, then P1(x) is taken to be the zero polynomial
C             matrix, P1 is not referenced and can be supplied as a
C             dummy array (i.e. set the parameters LDP11 = LDP12 = 1 and
C             declare this array to be P1(1,1,1) in the calling
C             program).
C
C     LDP11   INTEGER
C             The leading dimension of array P1.
C             LDP11 >= MAX(1,RP1) if DP1 >= 0,
C             LDP11 >= 1          if DP1 = -1.
C
C     LDP12   INTEGER
C             The second dimension of array P1.
C             LDP12 >= MAX(1,CP1) if DP1 >= 0,
C             LDP12 >= 1          if DP1 = -1.
C
C     P2      (input) DOUBLE PRECISION array, dimension (LDP21,LDP22,*)
C             If DP2 >= 0, then the leading CP1-by-CP2-by-(DP2+1) part
C             of this array must contain the coefficients of the
C             polynomial matrix P2(x). Specifically, P2(i,j,k) must
C             contain the coefficient of x**(k-1) of the polynomial
C             which is the (i,j)-th element of P2(x), where i = 1,2,...,
C             CP1, j = 1,2,...,CP2 and k = 1,2,...,DP2+1.
C             If DP2 = -1, then P2(x) is taken to be the zero polynomial
C             matrix, P2 is not referenced and can be supplied as a
C             dummy array (i.e. set the parameters LDP21 = LDP22 = 1 and
C             declare this array to be P2(1,1,1) in the calling
C             program).
C
C     LDP21   INTEGER
C             The leading dimension of array P2.
C             LDP21 >= MAX(1,CP1) if DP2 >= 0,
C             LDP21 >= 1          if DP2 = -1.
C
C     LDP22   INTEGER
C             The second dimension of array P2.
C             LDP22 >= MAX(1,CP2) if DP2 >= 0,
C             LDP22 >= 1          if DP2 = -1.
C
C     P3      (input/output) DOUBLE PRECISION array, dimension
C             (LDP31,LDP32,n), where n = MAX(DP1+DP2,DP3,0)+1.
C             On entry, if DP3 >= 0, then the leading
C             RP1-by-CP2-by-(DP3+1) part of this array must contain the
C             coefficients of the polynomial matrix P3(x). Specifically,
C             P3(i,j,k) must contain the coefficient of x**(k-1) of the
C             polynomial which is the (i,j)-th element of P3(x), where
C             i = 1,2,...,RP1, j = 1,2,...,CP2 and k = 1,2,...,DP3+1.
C             If DP3 = -1, then P3(x) is taken to be the zero polynomial
C             matrix.
C             On exit, if DP3 >= 0 on exit (ALPHA <> 0.0 and DP3 <> -1,
C             on entry, or DP1 <> -1 and DP2 <> -1), then the leading
C             RP1-by-CP2-by-(DP3+1) part of this array contains the
C             coefficients of P(x). Specifically, P3(i,j,k) contains the
C             coefficient of x**(k-1) of the polynomial which is the
C             (i,j)-th element of P(x), where i = 1,2,...,RP1, j = 1,2,
C             ...,CP2 and k = 1,2,...,DP3+1.
C             If DP3 = -1 on exit, then the coefficients of P(x) (the
C             zero polynomial matrix) are not stored in the array.
C
C     LDP31   INTEGER
C             The leading dimension of array P3.  LDP31 >= MAX(1,RP1).
C
C     LDP32   INTEGER
C             The second dimension of array P3.   LDP32 >= MAX(1,CP2).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (CP1)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Given real polynomial matrices
C
C                DP1            i
C        P1(x) = SUM (A(i+1) * x ),
C                i=0
C
C                DP2            i
C        P2(x) = SUM (B(i+1) * x ),
C                i=0
C
C                DP3            i
C        P3(x) = SUM (C(i+1) * x )
C                i=0
C
C     and a real scalar alpha, the routine computes the coefficients
C     d ,d ,..., of the polynomial matrix
C      1  2
C
C        P(x) = P1(x) * P2(x) + alpha * P3(x)
C
C     from the formula
C
C                 s
C        d    =  SUM (A(k+1) * B(i-k+1)) + alpha * C(i+1),
C         i+1    k=r
C
C     where i = 0,1,...,DP1+DP2 and r and s depend on the value of i
C     (e.g. if i <= DP1 and i <= DP2, then r = 0 and s = i).
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     FURTHER COMMENTS
C
C     Other elementary operations involving polynomial matrices can
C     easily be obtained by calling the appropriate BLAS routine(s).
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC03AD by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary polynomial operations, input output description,
C     polynomial matrix, polynomial operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           CP1, CP2, DP1, DP2, DP3, INFO, LDP11, LDP12,
     $                  LDP21, LDP22, LDP31, LDP32, RP1
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), P1(LDP11,LDP12,*), P2(LDP21,LDP22,*),
     $                  P3(LDP31,LDP32,*)
C     .. Local Scalars ..
      LOGICAL           CFZERO
      INTEGER           DPOL3, E, H, I, J, K
C     .. External Functions ..
      DOUBLE PRECISION  DDOT
      EXTERNAL          DDOT
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLASET, DSCAL, XERBLA
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( RP1.LT.0 ) THEN
         INFO = -1
      ELSE IF( CP1.LT.0 ) THEN
         INFO = -2
      ELSE IF( CP2.LT.0 ) THEN
         INFO = -3
      ELSE IF( DP1.LT.-1 ) THEN
         INFO = -4
      ELSE IF( DP2.LT.-1 ) THEN
         INFO = -5
      ELSE IF( DP3.LT.-1 ) THEN
         INFO = -6
      ELSE IF( ( DP1.EQ.-1 .AND. LDP11.LT.1               ) .OR.
     $         ( DP1.GE. 0 .AND. LDP11.LT.MAX( 1, RP1 ) ) ) THEN
         INFO = -9
      ELSE IF( ( DP1.EQ.-1 .AND. LDP12.LT.1               ) .OR.
     $         ( DP1.GE. 0 .AND. LDP12.LT.MAX( 1, CP1 ) ) ) THEN
         INFO = -10
      ELSE IF( ( DP2.EQ.-1 .AND. LDP21.LT.1               ) .OR.
     $         ( DP2.GE. 0 .AND. LDP21.LT.MAX( 1, CP1 ) ) ) THEN
         INFO = -12
      ELSE IF( ( DP2.EQ.-1 .AND. LDP22.LT.1               ) .OR.
     $         ( DP2.GE. 0 .AND. LDP22.LT.MAX( 1, CP2 ) ) ) THEN
         INFO = -13
      ELSE IF( LDP31.LT.MAX( 1, RP1 ) ) THEN
         INFO = -15
      ELSE IF( LDP32.LT.MAX( 1, CP2 ) ) THEN
         INFO = -16
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MC03MD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( RP1.EQ.0 .OR. CP2.EQ.0 )
     $   RETURN
C
      IF ( ALPHA.EQ.ZERO )
     $   DP3 = -1
C
      IF ( DP3.GE.0 ) THEN
C
C        P3(x) := ALPHA * P3(x).
C
         DO 40 K = 1, DP3 + 1
C
            DO 20 J = 1, CP2
               CALL DSCAL( RP1, ALPHA, P3(1,J,K), 1 )
   20       CONTINUE
C
   40    CONTINUE
      END IF
C
      IF ( ( DP1.EQ.-1 ) .OR. ( DP2.EQ.-1 ) .OR. ( CP1.EQ.0 ) )
     $   RETURN
C
C     Neither of P1(x) and P2(x) is the zero polynomial.
C
      DPOL3 = DP1 + DP2
      IF ( DPOL3.GT.DP3 ) THEN
C
C        Initialize the additional part of P3(x) to zero.
C
         DO 80 K = DP3 + 2, DPOL3 + 1
            CALL DLASET( 'Full', RP1, CP2, ZERO, ZERO, P3(1,1,K),
     $                   LDP31 )
   80    CONTINUE
C
         DP3 = DPOL3
      END IF
C                                                              k-1
C     The inner product of the j-th row of the coefficient of x    of P1
C                                                i-1
C     and the h-th column of the coefficient of x    of P2(x) contribute
C                                                 k+i-2
C     the (j,h)-th element of the coefficient of x      of P3(x).
C
      DO 160 K = 1, DP1 + 1
C
         DO 140 J = 1, RP1
            CALL DCOPY( CP1, P1(J,1,K), LDP11, DWORK, 1 )
C
            DO 120 I = 1, DP2 + 1
               E = K + I - 1
C
               DO 100 H = 1, CP2
                  P3(J,H,E) = DDOT( CP1, DWORK, 1, P2(1,H,I), 1 ) +
     $                        P3(J,H,E)
  100          CONTINUE
C
  120       CONTINUE
C
  140    CONTINUE
C
  160 CONTINUE
C
C     Computation of the exact degree of P3(x).
C
      CFZERO = .TRUE.
C     WHILE ( DP3 >= 0 and CFZERO ) DO
  180 IF ( ( DP3.GE.0 ) .AND. CFZERO ) THEN
         DPOL3 = DP3 + 1
C
         DO 220 J = 1, CP2
C
            DO 200 I = 1, RP1
               IF ( P3(I,J,DPOL3 ).NE.ZERO ) CFZERO = .FALSE.
  200       CONTINUE
C
  220    CONTINUE
C
         IF ( CFZERO ) DP3 = DP3 - 1
         GO TO 180
      END IF
C     END WHILE 180
C
      RETURN
C *** Last line of MC03MD ***
      END


PROGRAM LA_DGGLSE_EXAMPLE
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => DP
   USE F95_LAPACK, ONLY: LA_GGLSE
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.2))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER  :: I, INFO, M, N, P
!  .. LOCAL ARRAYS ..
   REAL(WP), ALLOCATABLE :: AA(:,:), BB(:,:), CC(:), DD(:)
   REAL(WP), ALLOCATABLE :: A(:, :), B(:,:), C(:), D(:), X(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MATMUL
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'DGGLSE Example Program Results'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) M, N, P
   PRINT *, 'M = ', M, ' N = ', N, ' P = ', P
   ALLOCATE ( A(M,N), AA(M,N), B(P,N), BB(P,N), C(M), CC(M), D(P), DD(P), X(N) )
   READ (NIN,*) AA, BB, CC, DD
   A = AA; B=BB; C = CC; D = DD
   WRITE(NOUT,*) 'The matrix A'
   DO I = 1, M; WRITE (NOUT,FMT) A(I,:); ENDDO
   WRITE(NOUT,*) 'The RHS matrix B:'
   DO I = 1, P; WRITE (NOUT,FMT) B(I,:); ENDDO
   WRITE(NOUT,*) 'The vector C:'; WRITE (NOUT,FMT) C
   WRITE(NOUT,*) 'The vector D:'; WRITE (NOUT,FMT) D
!
   WRITE ( NOUT, * )'--------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_DGELSE LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GGLSE (A, B, C, D, X)'
   A = AA; B=BB; C = CC; D = DD
   CALL LA_GGLSE (A, B, C, D, X)
   WRITE(NOUT,*)' C - MATMUL(AA, X), MATMUL(BB, X), X'
   WRITE (NOUT,FMT) C - MATMUL( AA, X )
   WRITE (NOUT,FMT) MATMUL( BB, X )
   WRITE(NOUT,FMT) X
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GGLSE (A, B, C, D, X, INFO)'
   A = AA; B=BB; C = CC; D = DD
   CALL LA_GGLSE (A, B, C, D, X, INFO)
   WRITE(NOUT,*)'INFO = ', INFO, ' C - MATMUL(AA, X), MATMUL(BB, X), X'
   WRITE (NOUT,FMT) C - MATMUL( AA, X )
   WRITE (NOUT,FMT) MATMUL( BB, X )
   WRITE(NOUT,FMT) X
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GGLSE (A(:,1:N-1), B, C, D, X, INFO)'
   A = AA; B=BB; C = CC; D = DD
   CALL LA_GGLSE (A(:,1:N-1), B, C, D, X, INFO)
   WRITE(NOUT,*)'INFO = ', INFO
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GGLSE (A, B(1:1,:), C, D, X, INFO)'
   A = AA; B=BB; C = CC; D = DD
   CALL LA_GGLSE (A, B(1:1,:), C, D, X, INFO)
   WRITE(NOUT,*)'INFO = ', INFO
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GGLSE (A, B, C(1:1), D, X, INFO)'
   A = AA; B=BB; C = CC; D = DD
   CALL LA_GGLSE (A, B, C(1:1), D, X, INFO)
   WRITE(NOUT,*)'INFO = ', INFO
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GGLSE (A, B, C, D(1:1), X, INFO)'
   A = AA; B=BB; C = CC; D = DD
   CALL LA_GGLSE (A, B, C, D(1:1), X, INFO)
   WRITE(NOUT,*)'INFO = ', INFO
!
   WRITE (NOUT,*)
   WRITE (NOUT,*) 'CALL LA_GGLSE (A, B, C, D, X(1:1))'
   A = AA; B=BB; C = CC; D = DD
   CALL LA_GGLSE (A, B, C, D, X(1:1))
   WRITE(NOUT,*)'INFO = ', INFO
!
END!PROGRAM LA_DGGLSE_EXAMPLE