submodule(forlab_linalg) forlab_linalg_svd

    implicit none

contains

    module procedure svd_sp
    integer :: m, n, i, its, i1, j, k, kk, k1, l, ll, l1, mn
    integer, dimension(:), allocatable :: idx
    real(sp) :: c, f, g, h, s, scale, tst1, tst2, x, y, z
    real(sp), dimension(:), allocatable :: rv1
    real(sp), dimension(:, :), allocatable :: opt_u, opt_v
    logical :: outu, outv, opt_d, outierr
    real(sp), parameter::zero = 0.0_sp, one = 1.0_sp
    outu = .false.
    outv = .false.
    opt_d = .true.
    outierr = .false.
    m = size(a, 1)
    n = size(a, 2)
    if (.not. allocated(w)) allocate (w(n))
    allocate (rv1(n), opt_u(m, n), opt_v(n, n))
    opt_u = a
    if (present(d)) opt_d = d
    if (present(u)) outu = .true.
    if (present(v)) outv = .true.
    if (present(ierr)) outierr = .true.
    ! Householder reduction to bidiagonal form
    !==========================================
    g = zero
    scale = zero
    x = zero
    do i = 1, n
        l = i + 1
        rv1(i) = scale*g
        g = zero
        s = zero
        scale = zero
        if (i <= m) then
            scale = sum(abs(opt_u(i:m, i)))
            if (scale /= zero) then
                opt_u(i:m, i) = opt_u(i:m, i)/scale
                s = sum(opt_u(i:m, i)**2)
                f = opt_u(i, i)
                g = -sign(sqrt(s), f)
                h = f*g - s
                opt_u(i, i) = f - g
                if (i /= n) then
                    do j = l, n
                        s = dot_product(opt_u(i:m, i), opt_u(i:m, j))
                        opt_u(i:m, j) = opt_u(i:m, j) + s*opt_u(i:m, i)/h
                    end do
                end if
                opt_u(i:m, i) = scale*opt_u(i:m, i)
            end if
        end if
        w(i) = scale*g
        g = zero
        s = zero
        scale = zero
        if ((i <= m) .and. (i /= n)) then
            scale = sum(abs(opt_u(i, l:n)))
            if (scale /= zero) then
                opt_u(i, l:n) = opt_u(i, l:n)/scale
                s = sum(opt_u(i, l:n)**2)
                f = opt_u(i, l)
                g = -sign(sqrt(s), f)
                h = f*g - s
                opt_u(i, l) = f - g
                rv1(l:n) = opt_u(i, l:n)/h
                if (i /= m) then
                    do j = l, m
                        s = dot_product(opt_u(j, l:n), opt_u(i, l:n))
                        opt_u(j, l:n) = opt_u(j, l:n) + s*rv1(l:n)
                    end do
                end if
                opt_u(i, l:n) = scale*opt_u(i, l:n)
            end if
        end if
        x = max(x, abs(w(i)) + abs(rv1(i)))
    end do
    ! Accumulation of right-hand transformations
    !============================================
    if (outv) then
        do i = n, 1, -1
        if (i /= n) then
            if (g /= zero) then
                opt_v(l:n, i) = (opt_u(i, l:n)/opt_u(i, l))/g
                do j = l, n
                    s = dot_product(opt_u(i, l:n), opt_v(l:n, j))
                    opt_v(l:n, j) = opt_v(l:n, j) + s*opt_v(l:n, i)
                end do
            end if
            opt_v(i, l:n) = zero
            opt_v(l:n, i) = zero
        end if
        opt_v(i, i) = one
        g = rv1(i)
        l = i
        end do
    end if
    ! Accumulation of left-hand transformations
    !===========================================
    if (outu) then
        mn = min(m, n)
        do i = min(m, n), 1, -1
            l = i + 1
            g = w(i)
            if (i /= n) opt_u(i, l:n) = zero
            if (g /= zero) then
                if (i /= mn) then
                    do j = l, n
                        s = dot_product(opt_u(l:m, i), opt_u(l:m, j))
                        f = (s/opt_u(i, i))/g
                        opt_u(i:m, j) = opt_u(i:m, j) + f*opt_u(i:m, i)
                    end do
                end if
                opt_u(i:m, i) = opt_u(i:m, i)/g
            else
                opt_u(i:m, i) = zero
            end if
            opt_u(i, i) = opt_u(i, i) + one
        end do
    end if
    ! Diagonalization of the bidiagonal form
    !========================================
    tst1 = x
    do kk = 1, n
        k1 = n - kk
        k = k1 + 1
        its = 0
        ! Test for splitting
        !====================
520     continue
        do ll = 1, k
            l1 = k - ll
            l = l1 + 1
            tst2 = tst1 + abs(rv1(l))
            if (tst2 == tst1) goto 565
            tst2 = tst1 + abs(w(l1))
            if (tst2 == tst1) exit
        end do
        ! Cancellation of rv1(l) if L greater than 1
        !============================================
        c = zero
        s = one
        do i = l, k
            f = s*rv1(i)
            rv1(i) = c*rv1(i)
            tst2 = tst1 + abs(f)
            if (tst2 == tst1) goto 565
            g = w(i)
            h = pythag_sp(f, g)
            w(i) = h
            c = g/h
            s = -f/h
            if (outu) then
                do j = 1, m
                    y = opt_u(j, l1)
                    z = opt_u(j, i)
                    opt_u(j, l1) = y*c + z*s
                    opt_u(j, i) = -y*s + z*c
                end do
            end if
        end do
        ! Test for convergence
        !======================
565     continue
        z = w(k)
        if (l == k) goto 650
        ! Shift from bottom 2 by 2 minor
        !================================
        if (its >= 30) then
            if (outierr) ierr = k
            return
        end if
        its = its + 1
        x = w(l)
        y = w(k1)
        g = rv1(k1)
        h = rv1(k)
        f = one/2*(((g + z)/h)*((g - z)/y) + y/h - h/y)
        g = pythag_sp(f, one)
        f = x - (z/x)*z + (h/x)*(y/(f + sign(g, f)) - h)
        ! Next QR transformation
        !========================
        c = one
        s = one
        do i1 = l, k1
            i = i1 + 1
            g = rv1(i)
            y = w(i)
            h = s*g
            g = c*g
            z = pythag_sp(f, h)
            rv1(i1) = z
            c = f/z
            s = h/z
            f = x*c + g*s
            g = -x*s + g*c
            h = y*s
            y = y*c
            if (outv) then
                do j = 1, n
                    x = opt_v(j, i1)
                    z = opt_v(j, i)
                    opt_v(j, i1) = x*c + z*s
                    opt_v(j, i) = -x*s + z*c
                end do
            end if
            z = pythag_sp(f, h)
            w(i1) = z
            ! Rotation can be arbitrary if Z is zero
            !========================================
            if (z /= zero) then
                c = f/z
                s = h/z
            end if
            f = c*g + s*y
            x = -s*g + c*y
            if (outu) then
                do j = 1, m
                    y = opt_u(j, i1)
                    z = opt_u(j, i)
                    opt_u(j, i1) = y*c + z*s
                    opt_u(j, i) = -y*s + z*c
                end do
            end if
        end do
        rv1(l) = zero
        rv1(k) = f
        w(k) = x
        go to 520
        ! Convergence
        !=============
650     continue
        if (z <= zero) then
            w(k) = -z
            if (outv) then
                opt_v(1:n, k) = -opt_v(1:n, k)
            end if
        end if
    end do
    ! Sort singular values
    !======================
    if (opt_d) then
        idx = argsort(w, 2)
        w = w(idx)
        if (present(u)) u = opt_u(:, idx)
        if (present(v)) v = opt_v(:, idx)
    else
        if (present(u)) u = opt_u
        if (present(v)) v = opt_v
    end if
    return
    end procedure svd_sp

    function pythag_sp(x1, x2) result(pythag)
        real(sp), intent(in) :: x1, x2
        real(sp):: r, s, t, u
        real(sp)::pythag
        real(sp), parameter::zero = 0.0_sp, one = 1.0_sp
        pythag = max(abs(x1), abs(x2))
        if (pythag /= zero) then
            r = (min(abs(x1), abs(x2))/pythag)**2
            do
                t = 4*one + r
                if (t == 4*one) exit
                s = r/t
                u = one + 2*s
                pythag = u*pythag
                r = (s/u)**2*r
            end do
        end if
        return
    end function pythag_sp
    module procedure svd_dp
    integer :: m, n, i, its, i1, j, k, kk, k1, l, ll, l1, mn
    integer, dimension(:), allocatable :: idx
    real(dp) :: c, f, g, h, s, scale, tst1, tst2, x, y, z
    real(dp), dimension(:), allocatable :: rv1
    real(dp), dimension(:, :), allocatable :: opt_u, opt_v
    logical :: outu, outv, opt_d, outierr
    real(dp), parameter::zero = 0.0_dp, one = 1.0_dp
    outu = .false.
    outv = .false.
    opt_d = .true.
    outierr = .false.
    m = size(a, 1)
    n = size(a, 2)
    if (.not. allocated(w)) allocate (w(n))
    allocate (rv1(n), opt_u(m, n), opt_v(n, n))
    opt_u = a
    if (present(d)) opt_d = d
    if (present(u)) outu = .true.
    if (present(v)) outv = .true.
    if (present(ierr)) outierr = .true.
    ! Householder reduction to bidiagonal form
    !==========================================
    g = zero
    scale = zero
    x = zero
    do i = 1, n
        l = i + 1
        rv1(i) = scale*g
        g = zero
        s = zero
        scale = zero
        if (i <= m) then
            scale = sum(abs(opt_u(i:m, i)))
            if (scale /= zero) then
                opt_u(i:m, i) = opt_u(i:m, i)/scale
                s = sum(opt_u(i:m, i)**2)
                f = opt_u(i, i)
                g = -sign(sqrt(s), f)
                h = f*g - s
                opt_u(i, i) = f - g
                if (i /= n) then
                    do j = l, n
                        s = dot_product(opt_u(i:m, i), opt_u(i:m, j))
                        opt_u(i:m, j) = opt_u(i:m, j) + s*opt_u(i:m, i)/h
                    end do
                end if
                opt_u(i:m, i) = scale*opt_u(i:m, i)
            end if
        end if
        w(i) = scale*g
        g = zero
        s = zero
        scale = zero
        if ((i <= m) .and. (i /= n)) then
            scale = sum(abs(opt_u(i, l:n)))
            if (scale /= zero) then
                opt_u(i, l:n) = opt_u(i, l:n)/scale
                s = sum(opt_u(i, l:n)**2)
                f = opt_u(i, l)
                g = -sign(sqrt(s), f)
                h = f*g - s
                opt_u(i, l) = f - g
                rv1(l:n) = opt_u(i, l:n)/h
                if (i /= m) then
                    do j = l, m
                        s = dot_product(opt_u(j, l:n), opt_u(i, l:n))
                        opt_u(j, l:n) = opt_u(j, l:n) + s*rv1(l:n)
                    end do
                end if
                opt_u(i, l:n) = scale*opt_u(i, l:n)
            end if
        end if
        x = max(x, abs(w(i)) + abs(rv1(i)))
    end do
    ! Accumulation of right-hand transformations
    !============================================
    if (outv) then
        do i = n, 1, -1
        if (i /= n) then
            if (g /= zero) then
                opt_v(l:n, i) = (opt_u(i, l:n)/opt_u(i, l))/g
                do j = l, n
                    s = dot_product(opt_u(i, l:n), opt_v(l:n, j))
                    opt_v(l:n, j) = opt_v(l:n, j) + s*opt_v(l:n, i)
                end do
            end if
            opt_v(i, l:n) = zero
            opt_v(l:n, i) = zero
        end if
        opt_v(i, i) = one
        g = rv1(i)
        l = i
        end do
    end if
    ! Accumulation of left-hand transformations
    !===========================================
    if (outu) then
        mn = min(m, n)
        do i = min(m, n), 1, -1
            l = i + 1
            g = w(i)
            if (i /= n) opt_u(i, l:n) = zero
            if (g /= zero) then
                if (i /= mn) then
                    do j = l, n
                        s = dot_product(opt_u(l:m, i), opt_u(l:m, j))
                        f = (s/opt_u(i, i))/g
                        opt_u(i:m, j) = opt_u(i:m, j) + f*opt_u(i:m, i)
                    end do
                end if
                opt_u(i:m, i) = opt_u(i:m, i)/g
            else
                opt_u(i:m, i) = zero
            end if
            opt_u(i, i) = opt_u(i, i) + one
        end do
    end if
    ! Diagonalization of the bidiagonal form
    !========================================
    tst1 = x
    do kk = 1, n
        k1 = n - kk
        k = k1 + 1
        its = 0
        ! Test for splitting
        !====================
520     continue
        do ll = 1, k
            l1 = k - ll
            l = l1 + 1
            tst2 = tst1 + abs(rv1(l))
            if (tst2 == tst1) goto 565
            tst2 = tst1 + abs(w(l1))
            if (tst2 == tst1) exit
        end do
        ! Cancellation of rv1(l) if L greater than 1
        !============================================
        c = zero
        s = one
        do i = l, k
            f = s*rv1(i)
            rv1(i) = c*rv1(i)
            tst2 = tst1 + abs(f)
            if (tst2 == tst1) goto 565
            g = w(i)
            h = pythag_dp(f, g)
            w(i) = h
            c = g/h
            s = -f/h
            if (outu) then
                do j = 1, m
                    y = opt_u(j, l1)
                    z = opt_u(j, i)
                    opt_u(j, l1) = y*c + z*s
                    opt_u(j, i) = -y*s + z*c
                end do
            end if
        end do
        ! Test for convergence
        !======================
565     continue
        z = w(k)
        if (l == k) goto 650
        ! Shift from bottom 2 by 2 minor
        !================================
        if (its >= 30) then
            if (outierr) ierr = k
            return
        end if
        its = its + 1
        x = w(l)
        y = w(k1)
        g = rv1(k1)
        h = rv1(k)
        f = one/2*(((g + z)/h)*((g - z)/y) + y/h - h/y)
        g = pythag_dp(f, one)
        f = x - (z/x)*z + (h/x)*(y/(f + sign(g, f)) - h)
        ! Next QR transformation
        !========================
        c = one
        s = one
        do i1 = l, k1
            i = i1 + 1
            g = rv1(i)
            y = w(i)
            h = s*g
            g = c*g
            z = pythag_dp(f, h)
            rv1(i1) = z
            c = f/z
            s = h/z
            f = x*c + g*s
            g = -x*s + g*c
            h = y*s
            y = y*c
            if (outv) then
                do j = 1, n
                    x = opt_v(j, i1)
                    z = opt_v(j, i)
                    opt_v(j, i1) = x*c + z*s
                    opt_v(j, i) = -x*s + z*c
                end do
            end if
            z = pythag_dp(f, h)
            w(i1) = z
            ! Rotation can be arbitrary if Z is zero
            !========================================
            if (z /= zero) then
                c = f/z
                s = h/z
            end if
            f = c*g + s*y
            x = -s*g + c*y
            if (outu) then
                do j = 1, m
                    y = opt_u(j, i1)
                    z = opt_u(j, i)
                    opt_u(j, i1) = y*c + z*s
                    opt_u(j, i) = -y*s + z*c
                end do
            end if
        end do
        rv1(l) = zero
        rv1(k) = f
        w(k) = x
        go to 520
        ! Convergence
        !=============
650     continue
        if (z <= zero) then
            w(k) = -z
            if (outv) then
                opt_v(1:n, k) = -opt_v(1:n, k)
            end if
        end if
    end do
    ! Sort singular values
    !======================
    if (opt_d) then
        idx = argsort(w, 2)
        w = w(idx)
        if (present(u)) u = opt_u(:, idx)
        if (present(v)) v = opt_v(:, idx)
    else
        if (present(u)) u = opt_u
        if (present(v)) v = opt_v
    end if
    return
    end procedure svd_dp

    function pythag_dp(x1, x2) result(pythag)
        real(dp), intent(in) :: x1, x2
        real(dp):: r, s, t, u
        real(dp)::pythag
        real(dp), parameter::zero = 0.0_dp, one = 1.0_dp
        pythag = max(abs(x1), abs(x2))
        if (pythag /= zero) then
            r = (min(abs(x1), abs(x2))/pythag)**2
            do
                t = 4*one + r
                if (t == 4*one) exit
                s = r/t
                u = one + 2*s
                pythag = u*pythag
                r = (s/u)**2*r
            end do
        end if
        return
    end function pythag_dp

end submodule forlab_linalg_svd


PROGRAM lat_id_driver
  use niggli
  use num_types
  implicit none

  real(dp) :: lat_vecs(3,3), niggli(3,3) Nu(3,3), No(3,3), O(3,3)
  integer :: id, Cu(3,3), Co(3,3), i

  character(300) :: line

  open(1,file="POSCAR",status="old")

  read(1,'(a300)') line
  read(1,'(a300)') line
  do i=1,3
     read(1,*) lat_vecs(:,i)
  end do
  close(1)

  call id_cell(lat_vecs,Nu,Cu,O,No,Co,id)
  call reduce_cell(lat_vecs,niggli,Nu)

  print *, "The cell is niggle cell number: ", id

  open(2,file="Reduced",status="new")
  do i=1,3
     write(2,(' ','3F3.8')) niggli(:,i)
  end do

end PROGRAM lat_id_driver


c----------------------------------------------------------------------
      subroutine dgeco(a,lda,n,ipvt,rcond,z)
c----------------------------------------------------------------------
      integer lda,n,ipvt(1)
      double precision a(lda,1),z(1)
      double precision rcond
c
c     dgeco factors a double precision matrix by gaussian elimination
c     and estimates the condition of the matrix.
c
c     if  rcond  is not needed, dgefa is slightly faster.
c     to solve  a*x = b , follow dgeco by dgesl.
c     to compute  inverse(a)*c , follow dgeco by dgesl.
c     to compute  determinant(a) , follow dgeco by dgedi.
c     to compute  inverse(a) , follow dgeco by dgedi.
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        rcond   double precision
c                an estimate of the reciprocal condition of  a .
c                for the system  a*x = b , relative perturbations
c                in  a  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  a  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  a  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     linpack dgefa
c     blas saxpy,ddot,sscal,dasum
c     fortran dabs,dmax1,dsign
c
c     internal variables
c
      double precision ddot,ek,t,wk,wkm
      double precision anorm,s,dasum,sm,ynorm
      integer info,j,k,kb,kp1,l
c
c
c     compute 1-norm of a
c
      anorm = 0.0d0
      do 10 j = 1, n
         anorm = dmax1(anorm,dasum(n,a(1,j),1))
   10 continue
c
c     factor
c
      call dgefa(a,lda,n,ipvt,info)
c
c     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
c     estimate = norm(z)/norm(y) where  a*z = y  and  trans(a)*y = e .
c     trans(a)  is the transpose of a .  the components of  e  are
c     chosen to cause maximum local growth in the elements of w  where
c     trans(u)*w = e .  the vectors are frequently rescaled to avoid
c     overflow.
c
c     solve trans(u)*w = e
c
      ek = 1.0d0
      do 20 j = 1, n
         z(j) = 0.0d0
   20 continue
      do 100 k = 1, n
         if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
         if (dabs(ek-z(k)) .le. dabs(a(k,k))) go to 30
            s = dabs(a(k,k))/dabs(ek-z(k))
            call dscal(n,s,z,1)
            ek = s*ek
   30    continue
         wk = ek - z(k)
         wkm = -ek - z(k)
         s = dabs(wk)
         sm = dabs(wkm)
         if (a(k,k) .eq. 0.0d0) go to 40
            wk = wk/a(k,k)
            wkm = wkm/a(k,k)
         go to 50
   40    continue
            wk = 1.0d0
            wkm = 1.0d0
   50    continue
         kp1 = k + 1
         if (kp1 .gt. n) go to 90
            do 60 j = kp1, n
               sm = sm + dabs(z(j)+wkm*a(k,j))
               z(j) = z(j) + wk*a(k,j)
               s = s + dabs(z(j))
   60       continue
            if (s .ge. sm) go to 80
               t = wkm - wk
               wk = wkm
               do 70 j = kp1, n
                  z(j) = z(j) + t*a(k,j)
   70          continue
   80       continue
   90    continue
         z(k) = wk
  100 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
c     solve trans(l)*y = w
c
      do 120 kb = 1, n
         k = n + 1 - kb
         if (k .lt. n) z(k) = z(k) + ddot(n-k,a(k+1,k),1,z(k+1),1)
         if (dabs(z(k)) .le. 1.0d0) go to 110
            s = 1.0d0/dabs(z(k))
            call dscal(n,s,z,1)
  110    continue
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
  120 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
      ynorm = 1.0d0
c
c     solve l*v = y
c
      do 140 k = 1, n
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
         if (k .lt. n) call daxpy(n-k,t,a(k+1,k),1,z(k+1),1)
         if (dabs(z(k)) .le. 1.0d0) go to 130
            s = 1.0d0/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  130    continue
  140 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
c     solve  u*z = v
c
      do 160 kb = 1, n
         k = n + 1 - kb
         if (dabs(z(k)) .le. dabs(a(k,k))) go to 150
            s = dabs(a(k,k))/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  150    continue
         if (a(k,k) .ne. 0.0d0) z(k) = z(k)/a(k,k)
         if (a(k,k) .eq. 0.0d0) z(k) = 1.0d0
         t = -z(k)
         call daxpy(k-1,t,a(1,k),1,z(1),1)
  160 continue
c     make znorm = 1.0
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
      if (anorm .ne. 0.0d0) rcond = ynorm/anorm
      if (anorm .eq. 0.0d0) rcond = 0.0d0
      return
      end
c----------------------------------------------------------------------
      subroutine dgedi(a,lda,n,ipvt,det,work,job)
c----------------------------------------------------------------------
      integer lda,n,ipvt(1),job
      double precision a(lda,1),det(2),work(1)
c
c     dgedi computes the determinant and inverse of a matrix
c     using the factors computed by dgeco or dgefa.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output from dgeco or dgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from dgeco or dgefa.
c
c        work    double precision(n)
c                work vector.  contents destroyed.
c
c        job     integer
c                = 11   both determinant and inverse.
c                = 01   inverse only.
c                = 10   determinant only.
c
c     on return
c
c        a       inverse of original matrix if requested.
c                otherwise unchanged.
c
c        det     double precision(2)
c                determinant of original matrix if requested.
c                otherwise not referenced.
c                determinant = det(1) * 10.0**det(2)
c                with  1.0 .le. dabs(det(1)) .lt. 10.0
c                or  det(1) .eq. 0.0 .
c
c     error condition
c
c        a division by zero will occur if the input factor contains
c        a zero on the diagonal and the inverse is requested.
c        it will not occur if the subroutines are called correctly
c        and if dgeco has set rcond .gt. 0.0 or dgefa has set
c        info .eq. 0 .
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy,sscal,ap
c     fortran dabs,mod
c
c     internal variables
c
      double precision t
      double precision ten
      integer i,j,k,kb,kp1,l,nm1
c
c
c     compute determinant
c
      if (job/10 .eq. 0) go to 70
         det(1) = 1.0d0
         det(2) = 0.0d0
         ten = 10.0d0
         do 50 i = 1, n
            if (ipvt(i) .ne. i) det(1) = -det(1)
            det(1) = a(i,i)*det(1)
c        ...exit
            if (det(1) .eq. 0.0d0) go to 60
   10       if (dabs(det(1)) .ge. 1.0d0) go to 20
               det(1) = ten*det(1)
               det(2) = det(2) - 1.0d0
            go to 10
   20       continue
   30       if (dabs(det(1)) .lt. ten) go to 40
               det(1) = det(1)/ten
               det(2) = det(2) + 1.0d0
            go to 30
   40       continue
   50    continue
   60    continue
   70 continue
c
c     compute inverse(u)
c
      if (mod(job,10) .eq. 0) go to 150
         do 100 k = 1, n
            a(k,k) = 1.0d0/a(k,k)
            t = -a(k,k)
            call dscal(k-1,t,a(1,k),1)
            kp1 = k + 1
            if (n .lt. kp1) go to 90
            do 80 j = kp1, n
               t = a(k,j)
               a(k,j) = 0.0d0
               call daxpy(k,t,a(1,k),1,a(1,j),1)
   80       continue
   90       continue
  100    continue
c
c        form inverse(u)*inverse(l)
c
         nm1 = n - 1
         if (nm1 .lt. 1) go to 140
         do 130 kb = 1, nm1
            k = n - kb
            kp1 = k + 1
            do 110 i = kp1, n
               work(i) = a(i,k)
               a(i,k) = 0.0d0
  110       continue
            do 120 j = kp1, n
               t = work(j)
               call daxpy(n,t,a(1,j),1,a(1,k),1)
  120       continue
            l = ipvt(k)
            if (l .ne. k) call dswap(n,a(1,k),1,a(1,l),1)
  130    continue
  140    continue
  150 continue
      return
      end
c-----------------------------------------------------------------------
      subroutine dgefa(a,lda,n,ipvt,info)
c-----------------------------------------------------------------------
      integer lda,n,ipvt(1),info
      double precision a(lda,1)
c
c     dgefa factors a double precision matrix by gaussian elimination.
c
c     dgefa is usually called by dgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgesl or dgedi will divide by zero
c                     if called.  use  rcond  in dgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c
c     internal variables
c
      double precision t
      integer idamax,j,k,kp1,l,nm1
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = idamax(n-k+1,a(k,k),1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0d0) go to 40
c
c          interchange if neceary
c
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0d0/a(k,k)
            call dscal(n-k,t,a(k+1,k),1)
c
c           row elimination with column indexing
c
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0d0) info = n
      return
      end
c----------------------------------------------------------------------
      subroutine dgesl(a,lda,n,ipvt,b,job)
c----------------------------------------------------------------------
      integer lda,n,ipvt(1),job
      double precision a(lda,1),b(1)
c
c     dgesl solves the double precision system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgeco or dgefa.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output from dgeco or dgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from dgeco or dgefa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b  where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgeco has set rcond .gt. 0.0
c        or dgefa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgeco(a,lda,n,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgesl(a,lda,n,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c
c     internal variables
c
      double precision ddot,t
      integer k,kb,l,nm1
c
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve  l*y = b
c
         if (nm1 .lt. 1) go to 30
         do 20 k = 1, nm1
            l = ipvt(k)
            t = b(l)
            if (l .eq. k) go to 10
               b(l) = b(k)
               b(k) = t
   10       continue
            call daxpy(n-k,t,a(k+1,k),1,b(k+1),1)
   20    continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            call daxpy(k-1,t,a(1,k),1,b(1),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            t = ddot(k-1,a(1,k),1,b(1),1)
            b(k) = (b(k) - t)/a(k,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (nm1 .lt. 1) go to 90
         do 80 kb = 1, nm1
            k = n - kb
            b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1)
            l = ipvt(k)
            if (l .eq. k) go to 70
               t = b(l)
               b(l) = b(k)
               b(k) = t
   70       continue
   80    continue
   90    continue
  100 continue
      return
      end
      subroutine dpoco(a,lda,n,rcond,z,info)
      integer lda,n,info
      double precision a(lda,1),z(1)
      double precision rcond
c
c     dpoco factors a double precision symmetric positive definite
c     matrix and estimates the condition of the matrix.
c
c     if  rcond  is not needed, dpofa is slightly faster.
c     to solve  a*x = b , follow dpoco by dposl.
c     to compute  inverse(a)*c , follow dpoco by dposl.
c     to compute  determinant(a) , follow dpoco by dpodi.
c     to compute  inverse(a) , follow dpoco by dpodi.
c
c     on entry
c
c        a       double precision(lda, n)
c                the symmetric matrix to be factored.  only the
c                diagonal and upper triangle are used.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix  r  so that  a = trans(r)*r
c                where  trans(r)  is the transpose.
c                the strict lower triangle is unaltered.
c                if  info .ne. 0 , the factorization is not complete.
c
c        rcond   double precision
c                an estimate of the reciprocal condition of  a .
c                for the system  a*x = b , relative perturbations
c                in  a  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  a  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.  if info .ne. 0 , rcond is unchanged.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  a  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c                if  info .ne. 0 , z  is unchanged.
c
c        info    integer
c                = 0  for normal return.
c                = k  signals an error condition.  the leading minor
c                     of order  k  is not positive definite.
c
c     linpack.  this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     linpack dpofa
c     blas daxpy,ddot,dscal,dasum
c     fortran dabs,dmax1,dreal,dsign
c
c     internal variables
c
      double precision ddot,ek,t,wk,wkm
      double precision anorm,s,dasum,sm,ynorm
      integer i,j,jm1,k,kb,kp1
c
c
c     find norm of a using only upper half
c
      do 30 j = 1, n
         z(j) = dasum(j,a(1,j),1)
         jm1 = j - 1
         if (jm1 .lt. 1) go to 20
         do 10 i = 1, jm1
            z(i) = z(i) + dabs(a(i,j))
   10    continue
   20    continue
   30 continue
      anorm = 0.0d0
      do 40 j = 1, n
         anorm = dmax1(anorm,z(j))
   40 continue
c
c     factor
c
      call dpofa(a,lda,n,info)
      if (info .ne. 0) go to 180
c
c        rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
c        estimate = norm(z)/norm(y) where  a*z = y  and  a*y = e .
c        the components of  e  are chosen to cause maximum local
c        growth in the elements of w  where  trans(r)*w = e .
c        the vectors are frequently rescaled to avoid overflow.
c
c        solve trans(r)*w = e
c
         ek = 1.0d0
         do 50 j = 1, n
            z(j) = 0.0d0
   50    continue
         do 110 k = 1, n
            if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
            if (dabs(ek-z(k)) .le. a(k,k)) go to 60
               s = a(k,k)/dabs(ek-z(k))
               call dscal(n,s,z,1)
               ek = s*ek
   60       continue
            wk = ek - z(k)
            wkm = -ek - z(k)
            s = dabs(wk)
            sm = dabs(wkm)
            wk = wk/a(k,k)
            wkm = wkm/a(k,k)
            kp1 = k + 1
            if (kp1 .gt. n) go to 100
               do 70 j = kp1, n
                  sm = sm + dabs(z(j)+wkm*a(k,j))
                  z(j) = z(j) + wk*a(k,j)
                  s = s + dabs(z(j))
   70          continue
               if (s .ge. sm) go to 90
                  t = wkm - wk
                  wk = wkm
                  do 80 j = kp1, n
                     z(j) = z(j) + t*a(k,j)
   80             continue
   90          continue
  100       continue
            z(k) = wk
  110    continue
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
c
c        solve r*y = w
c
         do 130 kb = 1, n
            k = n + 1 - kb
            if (dabs(z(k)) .le. a(k,k)) go to 120
               s = a(k,k)/dabs(z(k))
               call dscal(n,s,z,1)
  120       continue
            z(k) = z(k)/a(k,k)
            t = -z(k)
            call daxpy(k-1,t,a(1,k),1,z(1),1)
  130    continue
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
c
         ynorm = 1.0d0
c
c        solve trans(r)*v = y
c
         do 150 k = 1, n
            z(k) = z(k) - ddot(k-1,a(1,k),1,z(1),1)
            if (dabs(z(k)) .le. a(k,k)) go to 140
               s = a(k,k)/dabs(z(k))
               call dscal(n,s,z,1)
               ynorm = s*ynorm
  140       continue
            z(k) = z(k)/a(k,k)
  150    continue
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
         ynorm = s*ynorm
c
c        solve r*z = v
c
         do 170 kb = 1, n
            k = n + 1 - kb
            if (dabs(z(k)) .le. a(k,k)) go to 160
               s = a(k,k)/dabs(z(k))
               call dscal(n,s,z,1)
               ynorm = s*ynorm
  160       continue
            z(k) = z(k)/a(k,k)
            t = -z(k)
            call daxpy(k-1,t,a(1,k),1,z(1),1)
  170    continue
c        make znorm = 1.0
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
         ynorm = s*ynorm
c
         if (anorm .ne. 0.0d0) rcond = ynorm/anorm
         if (anorm .eq. 0.0d0) rcond = 0.0d0
  180 continue
      return
      end
      subroutine dpodi(a,lda,n,det,job)
      integer lda,n,job
      double precision a(lda,1)
      double precision det(2)
c
c     dpodi computes the determinant and inverse of a certain
c     double precision symmetric positive definite matrix (see below)
c     using the factors computed by dpoco, dpofa or dqrdc.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output  a  from dpoco or dpofa
c                or the output  x  from dqrdc.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        job     integer
c                = 11   both determinant and inverse.
c                = 01   inverse only.
c                = 10   determinant only.
c
c     on return
c
c        a       if dpoco or dpofa was used to factor  a  then
c                dpodi produces the upper half of inverse(a) .
c                if dqrdc was used to decompose  x  then
c                dpodi produces the upper half of inverse(trans(x)*x)
c                where trans(x) is the transpose.
c                elements of  a  below the diagonal are unchanged.
c                if the units digit of job is zero,  a  is unchanged.
c
c        det     double precision(2)
c                determinant of  a  or of  trans(x)*x  if requested.
c                otherwise not referenced.
c                determinant = det(1) * 10.0**det(2)
c                with  1.0 .le. det(1) .lt. 10.0
c                or  det(1) .eq. 0.0 .
c
c     error condition
c
c        a division by zero will occur if the input factor contains
c        a zero on the diagonal and the inverse is requested.
c        it will not occur if the subroutines are called correctly
c        and if dpoco or dpofa has set info .eq. 0 .
c
c     linpack.  this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal
c     fortran mod
c
c     internal variables
c
      double precision t
      double precision s
      integer i,j,jm1,k,kp1
c
c     compute determinant
c
      if (job/10 .eq. 0) go to 70
         det(1) = 1.0d0
         det(2) = 0.0d0
         s = 10.0d0
         do 50 i = 1, n
            det(1) = a(i,i)**2*det(1)
c        ...exit
            if (det(1) .eq. 0.0d0) go to 60
   10       if (det(1) .ge. 1.0d0) go to 20
               det(1) = s*det(1)
               det(2) = det(2) - 1.0d0
            go to 10
   20       continue
   30       if (det(1) .lt. s) go to 40
               det(1) = det(1)/s
               det(2) = det(2) + 1.0d0
            go to 30
   40       continue
   50    continue
   60    continue
   70 continue
c
c     compute inverse(r)
c
      if (mod(job,10) .eq. 0) go to 140
         do 100 k = 1, n
            a(k,k) = 1.0d0/a(k,k)
            t = -a(k,k)
            call dscal(k-1,t,a(1,k),1)
            kp1 = k + 1
            if (n .lt. kp1) go to 90
            do 80 j = kp1, n
               t = a(k,j)
               a(k,j) = 0.0d0
               call daxpy(k,t,a(1,k),1,a(1,j),1)
   80       continue
   90       continue
  100    continue
c
c        form  inverse(r) * trans(inverse(r))
c
         do 130 j = 1, n
            jm1 = j - 1
            if (jm1 .lt. 1) go to 120
            do 110 k = 1, jm1
               t = a(k,j)
               call daxpy(k,t,a(1,j),1,a(1,k),1)
  110       continue
  120       continue
            t = a(j,j)
            call dscal(j,t,a(1,j),1)
  130    continue
  140 continue
      return
      end
      subroutine dpofa(a,lda,n,info)
      integer lda,n,info
      double precision a(lda,1)
c
c     dpofa factors a double precision symmetric positive definite
c     matrix.
c
c     dpofa is usually called by dpoco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dpoco) = (1 + 18/n)*(time for dpofa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the symmetric matrix to be factored.  only the
c                diagonal and upper triangle are used.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix  r  so that  a = trans(r)*r
c                where  trans(r)  is the transpose.
c                the strict lower triangle is unaltered.
c                if  info .ne. 0 , the factorization is not complete.
c
c        info    integer
c                = 0  for normal return.
c                = k  signals an error condition.  the leading minor
c                     of order  k  is not positive definite.
c
c     linpack.  this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas ddot
c     fortran dsqrt
c
c     internal variables
c
      double precision ddot,t
      double precision s
      integer j,jm1,k
c     begin block with ...exits to 40
c
c
         do 30 j = 1, n
            info = j
            s = 0.0d0
            jm1 = j - 1
            if (jm1 .lt. 1) go to 20
            do 10 k = 1, jm1
               t = a(k,j) - ddot(k-1,a(1,k),1,a(1,j),1)
               t = t/a(k,k)
               a(k,j) = t
               s = s + t*t
   10       continue
   20       continue
            s = a(j,j) - s
c     ......exit
            if (s .le. 0.0d0) go to 40
            a(j,j) = dsqrt(s)
   30    continue
         info = 0
   40 continue
      return
      end
      subroutine dppco(ap,n,rcond,z,info)
      integer n,info
      double precision ap(1),z(1)
      double precision rcond
c
c     dppco factors a double precision symmetric positive definite
c     matrix stored in packed form
c     and estimates the condition of the matrix.
c
c     if  rcond  is not needed, dppfa is slightly faster.
c     to solve  a*x = b , follow dppco by dppsl.
c     to compute  inverse(a)*c , follow dppco by dppsl.
c     to compute  determinant(a) , follow dppco by dppdi.
c     to compute  inverse(a) , follow dppco by dppdi.
c
c     on entry
c
c        ap      double precision (n*(n+1)/2)
c                the packed form of a symmetric matrix  a .  the
c                columns of the upper triangle are stored sequentially
c                in a one-dimensional array of length  n*(n+1)/2 .
c                see comments below for details.
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        ap      an upper triangular matrix  r , stored in packed
c                form, so that  a = trans(r)*r .
c                if  info .ne. 0 , the factorization is not complete.
c
c        rcond   double precision
c                an estimate of the reciprocal condition of  a .
c                for the system  a*x = b , relative perturbations
c                in  a  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  a  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.  if info .ne. 0 , rcond is unchanged.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  a  is singular to working precision, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c                if  info .ne. 0 , z  is unchanged.
c
c        info    integer
c                = 0  for normal return.
c                = k  signals an error condition.  the leading minor
c                     of order  k  is not positive definite.
c
c     packed storage
c
c          the following program segment will pack the upper
c          triangle of a symmetric matrix.
c
c                k = 0
c                do 20 j = 1, n
c                   do 10 i = 1, j
c                      k = k + 1
c                      ap(k) = a(i,j)
c             10    continue
c             20 continue
c
c     linpack.  this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     linpack dppfa
c     blas daxpy,ddot,dscal,dasum
c     fortran dabs,dmax1,dreal,dsign
c
c     internal variables
c
      double precision ddot,ek,t,wk,wkm
      double precision anorm,s,dasum,sm,ynorm
      integer i,ij,j,jm1,j1,k,kb,kj,kk,kp1
c
c
c     find norm of a
c
      j1 = 1
      do 30 j = 1, n
         z(j) = dasum(j,ap(j1),1)
         ij = j1
         j1 = j1 + j
         jm1 = j - 1
         if (jm1 .lt. 1) go to 20
         do 10 i = 1, jm1
            z(i) = z(i) + dabs(ap(ij))
            ij = ij + 1
   10    continue
   20    continue
   30 continue
      anorm = 0.0d0
      do 40 j = 1, n
         anorm = dmax1(anorm,z(j))
   40 continue
c
c     factor
c
      call dppfa(ap,n,info)
      if (info .ne. 0) go to 180
c
c        rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
c        estimate = norm(z)/norm(y) where  a*z = y  and  a*y = e .
c        the components of  e  are chosen to cause maximum local
c        growth in the elements of w  where  trans(r)*w = e .
c        the vectors are frequently rescaled to avoid overflow.
c
c        solve trans(r)*w = e
c
         ek = 1.0d0
         do 50 j = 1, n
            z(j) = 0.0d0
   50    continue
         kk = 0
         do 110 k = 1, n
            kk = kk + k
            if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
            if (dabs(ek-z(k)) .le. ap(kk)) go to 60
               s = ap(kk)/dabs(ek-z(k))
               call dscal(n,s,z,1)
               ek = s*ek
   60       continue
            wk = ek - z(k)
            wkm = -ek - z(k)
            s = dabs(wk)
            sm = dabs(wkm)
            wk = wk/ap(kk)
            wkm = wkm/ap(kk)
            kp1 = k + 1
            kj = kk + k
            if (kp1 .gt. n) go to 100
               do 70 j = kp1, n
                  sm = sm + dabs(z(j)+wkm*ap(kj))
                  z(j) = z(j) + wk*ap(kj)
                  s = s + dabs(z(j))
                  kj = kj + j
   70          continue
               if (s .ge. sm) go to 90
                  t = wkm - wk
                  wk = wkm
                  kj = kk + k
                  do 80 j = kp1, n
                     z(j) = z(j) + t*ap(kj)
                     kj = kj + j
   80             continue
   90          continue
  100       continue
            z(k) = wk
  110    continue
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
c
c        solve r*y = w
c
         do 130 kb = 1, n
            k = n + 1 - kb
            if (dabs(z(k)) .le. ap(kk)) go to 120
               s = ap(kk)/dabs(z(k))
               call dscal(n,s,z,1)
  120       continue
            z(k) = z(k)/ap(kk)
            kk = kk - k
            t = -z(k)
            call daxpy(k-1,t,ap(kk+1),1,z(1),1)
  130    continue
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
c
         ynorm = 1.0d0
c
c        solve trans(r)*v = y
c
         do 150 k = 1, n
            z(k) = z(k) - ddot(k-1,ap(kk+1),1,z(1),1)
            kk = kk + k
            if (dabs(z(k)) .le. ap(kk)) go to 140
               s = ap(kk)/dabs(z(k))
               call dscal(n,s,z,1)
               ynorm = s*ynorm
  140       continue
            z(k) = z(k)/ap(kk)
  150    continue
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
         ynorm = s*ynorm
c
c        solve r*z = v
c
         do 170 kb = 1, n
            k = n + 1 - kb
            if (dabs(z(k)) .le. ap(kk)) go to 160
               s = ap(kk)/dabs(z(k))
               call dscal(n,s,z,1)
               ynorm = s*ynorm
  160       continue
            z(k) = z(k)/ap(kk)
            kk = kk - k
            t = -z(k)
            call daxpy(k-1,t,ap(kk+1),1,z(1),1)
  170    continue
c        make znorm = 1.0
         s = 1.0d0/dasum(n,z,1)
         call dscal(n,s,z,1)
         ynorm = s*ynorm
c
         if (anorm .ne. 0.0d0) rcond = ynorm/anorm
         if (anorm .eq. 0.0d0) rcond = 0.0d0
  180 continue
      return
      end
      subroutine dppdi(ap,n,det,job)
      integer n,job
      double precision ap(1)
      double precision det(2)
c
c     dppdi computes the determinant and inverse
c     of a double precision symmetric positive definite matrix
c     using the factors computed by dppco or dppfa .
c
c     on entry
c
c        ap      double precision (n*(n+1)/2)
c                the output from dppco or dppfa.
c
c        n       integer
c                the order of the matrix  a .
c
c        job     integer
c                = 11   both determinant and inverse.
c                = 01   inverse only.
c                = 10   determinant only.
c
c     on return
c
c        ap      the upper triangular half of the inverse .
c                the strict lower triangle is unaltered.
c
c        det     double precision(2)
c                determinant of original matrix if requested.
c                otherwise not referenced.
c                determinant = det(1) * 10.0**det(2)
c                with  1.0 .le. det(1) .lt. 10.0
c                or  det(1) .eq. 0.0 .
c
c     error condition
c
c        a division by zero will occur if the input factor contains
c        a zero on the diagonal and the inverse is requested.
c        it will not occur if the subroutines are called correctly
c        and if dpoco or dpofa has set info .eq. 0 .
c
c     linpack.  this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal
c     fortran mod
c
c     internal variables
c
      double precision t
      double precision s
      integer i,ii,j,jj,jm1,j1,k,kj,kk,kp1,k1
c
c     compute determinant
c
      if (job/10 .eq. 0) go to 70
         det(1) = 1.0d0
         det(2) = 0.0d0
         s = 10.0d0
         ii = 0
         do 50 i = 1, n
            ii = ii + i
            det(1) = ap(ii)**2*det(1)
c        ...exit
            if (det(1) .eq. 0.0d0) go to 60
   10       if (det(1) .ge. 1.0d0) go to 20
               det(1) = s*det(1)
               det(2) = det(2) - 1.0d0
            go to 10
   20       continue
   30       if (det(1) .lt. s) go to 40
               det(1) = det(1)/s
               det(2) = det(2) + 1.0d0
            go to 30
   40       continue
   50    continue
   60    continue
   70 continue
c
c     compute inverse(r)
c
      if (mod(job,10) .eq. 0) go to 140
         kk = 0
         do 100 k = 1, n
            k1 = kk + 1
            kk = kk + k
            ap(kk) = 1.0d0/ap(kk)
            t = -ap(kk)
            call dscal(k-1,t,ap(k1),1)
            kp1 = k + 1
            j1 = kk + 1
            kj = kk + k
            if (n .lt. kp1) go to 90
            do 80 j = kp1, n
               t = ap(kj)
               ap(kj) = 0.0d0
               call daxpy(k,t,ap(k1),1,ap(j1),1)
               j1 = j1 + j
               kj = kj + j
   80       continue
   90       continue
  100    continue
c
c        form  inverse(r) * trans(inverse(r))
c
         jj = 0
         do 130 j = 1, n
            j1 = jj + 1
            jj = jj + j
            jm1 = j - 1
            k1 = 1
            kj = j1
            if (jm1 .lt. 1) go to 120
            do 110 k = 1, jm1
               t = ap(kj)
               call daxpy(k,t,ap(j1),1,ap(k1),1)
               k1 = k1 + k
               kj = kj + 1
  110       continue
  120       continue
            t = ap(jj)
            call dscal(j,t,ap(j1),1)
  130    continue
  140 continue
      return
      end
      subroutine dppfa(ap,n,info)
      integer n,info
      double precision ap(1)
c
c     dppfa factors a double precision symmetric positive definite
c     matrix stored in packed form.
c
c     dppfa is usually called by dppco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dppco) = (1 + 18/n)*(time for dppfa) .
c
c     on entry
c
c        ap      double precision (n*(n+1)/2)
c                the packed form of a symmetric matrix  a .  the
c                columns of the upper triangle are stored sequentially
c                in a one-dimensional array of length  n*(n+1)/2 .
c                see comments below for details.
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        ap      an upper triangular matrix  r , stored in packed
c                form, so that  a = trans(r)*r .
c
c        info    integer
c                = 0  for normal return.
c                = k  if the leading minor of order  k  is not
c                     positive definite.
c
c
c     packed storage
c
c          the following program segment will pack the upper
c          triangle of a symmetric matrix.
c
c                k = 0
c                do 20 j = 1, n
c                   do 10 i = 1, j
c                      k = k + 1
c                      ap(k) = a(i,j)
c             10    continue
c             20 continue
c
c     linpack.  this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas ddot
c     fortran dsqrt
c
c     internal variables
c
      double precision ddot,t
      double precision s
      integer j,jj,jm1,k,kj,kk
c     begin block with ...exits to 40
c
c
         jj = 0
         do 30 j = 1, n
            info = j
            s = 0.0d0
            jm1 = j - 1
            kj = jj
            kk = 0
            if (jm1 .lt. 1) go to 20
            do 10 k = 1, jm1
               kj = kj + 1
               t = ap(kj) - ddot(k-1,ap(kk+1),1,ap(jj+1),1)
               kk = kk + k
               t = t/ap(kk)
               ap(kj) = t
               s = s + t*t
   10       continue
   20       continue
            jj = jj + j
            s = ap(jj) - s
c     ......exit
            if (s .le. 0.0d0) go to 40
            ap(jj) = dsqrt(s)
   30    continue
         info = 0
   40 continue
      return
      end
      subroutine dppsl(ap,n,b)
      integer n
      double precision ap(1),b(1)
c
c     dppsl solves the double precision symmetric positive definite
c     system a * x = b
c     using the factors computed by dppco or dppfa.
c
c     on entry
c
c        ap      double precision (n*(n+1)/2)
c                the output from dppco or dppfa.
c
c        n       integer
c                the order of the matrix  a .
c
c        b       double precision(n)
c                the right hand side vector.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains
c        a zero on the diagonal.  technically this indicates
c        singularity but it is usually caused by improper subroutine
c        arguments.  it will not occur if the subroutines are called
c        correctly and  info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dppco(ap,n,rcond,z,info)
c           if (rcond is too small .or. info .ne. 0) go to ...
c           do 10 j = 1, p
c              call dppsl(ap,n,c(1,j))
c        10 continue
c
c     linpack.  this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c
c     internal variables
c
      double precision ddot,t
      integer k,kb,kk
c
      kk = 0
      do 10 k = 1, n
         t = ddot(k-1,ap(kk+1),1,b(1),1)
         kk = kk + k
         b(k) = (b(k) - t)/ap(kk)
   10 continue
      do 20 kb = 1, n
         k = n + 1 - kb
         b(k) = b(k)/ap(kk)
         kk = kk - k
         t = -b(k)
         call daxpy(k-1,t,ap(kk+1),1,b(1),1)
   20 continue
      return
      end
      subroutine dspco(ap,n,kpvt,rcond,z)
      integer n,kpvt(1)
      double precision ap(1),z(1)
      double precision rcond
c
c     dspco factors a double precision symmetric matrix stored in
c     packed form by elimination with symmetric pivoting and estimates
c     the condition of the matrix.
c
c     if  rcond  is not needed, dspfa is slightly faster.
c     to solve  a*x = b , follow dspco by dspsl.
c     to compute  inverse(a)*c , follow dspco by dspsl.
c     to compute  inverse(a) , follow dspco by dspdi.
c     to compute  determinant(a) , follow dspco by dspdi.
c     to compute  inertia(a), follow dspco by dspdi.
c
c     on entry
c
c        ap      double precision (n*(n+1)/2)
c                the packed form of a symmetric matrix  a .  the
c                columns of the upper triangle are stored sequentially
c                in a one-dimensional array of length  n*(n+1)/2 .
c                see comments below for details.
c
c        n       integer
c                the order of the matrix  a .
c
c     output
c
c        ap      a block diagonal matrix and the multipliers which
c                were used to obtain it stored in packed form.
c                the factorization can be written  a = u*d*trans(u)
c                where  u  is a product of permutation and unit
c                upper triangular matrices , trans(u) is the
c                transpose of  u , and  d  is block diagonal
c                with 1 by 1 and 2 by 2 blocks.
c
c        kpvt    integer(n)
c                an integer vector of pivot indices.
c
c        rcond   double precision
c                an estimate of the reciprocal condition of  a .
c                for the system  a*x = b , relative perturbations
c                in  a  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  a  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  a  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c
c     packed storage
c
c          the following program segment will pack the upper
c          triangle of a symmetric matrix.
c
c                k = 0
c                do 20 j = 1, n
c                   do 10 i = 1, j
c                      k = k + 1
c                      ap(k) = a(i,j)
c             10    continue
c             20 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     linpack dspfa
c     blas daxpy,ddot,dscal,dasum
c     fortran dabs,dmax1,iabs,dsign
c
c     internal variables
c
      double precision ak,akm1,bk,bkm1,ddot,denom,ek,t
      double precision anorm,s,dasum,ynorm
      integer i,ij,ik,ikm1,ikp1,info,j,jm1,j1
      integer k,kk,km1k,km1km1,kp,kps,ks
c
c
c     find norm of a using only upper half
c
      j1 = 1
      do 30 j = 1, n
         z(j) = dasum(j,ap(j1),1)
         ij = j1
         j1 = j1 + j
         jm1 = j - 1
         if (jm1 .lt. 1) go to 20
         do 10 i = 1, jm1
            z(i) = z(i) + dabs(ap(ij))
            ij = ij + 1
   10    continue
   20    continue
   30 continue
      anorm = 0.0d0
      do 40 j = 1, n
         anorm = dmax1(anorm,z(j))
   40 continue
c
c     factor
c
      call dspfa(ap,n,kpvt,info)
c
c     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
c     estimate = norm(z)/norm(y) where  a*z = y  and  a*y = e .
c     the components of  e  are chosen to cause maximum local
c     growth in the elements of w  where  u*d*w = e .
c     the vectors are frequently rescaled to avoid overflow.
c
c     solve u*d*w = e
c
      ek = 1.0d0
      do 50 j = 1, n
         z(j) = 0.0d0
   50 continue
      k = n
      ik = (n*(n - 1))/2
   60 if (k .eq. 0) go to 120
         kk = ik + k
         ikm1 = ik - (k - 1)
         ks = 1
         if (kpvt(k) .lt. 0) ks = 2
         kp = iabs(kpvt(k))
         kps = k + 1 - ks
         if (kp .eq. kps) go to 70
            t = z(kps)
            z(kps) = z(kp)
            z(kp) = t
   70    continue
         if (z(k) .ne. 0.0d0) ek = dsign(ek,z(k))
         z(k) = z(k) + ek
         call daxpy(k-ks,z(k),ap(ik+1),1,z(1),1)
         if (ks .eq. 1) go to 80
            if (z(k-1) .ne. 0.0d0) ek = dsign(ek,z(k-1))
            z(k-1) = z(k-1) + ek
            call daxpy(k-ks,z(k-1),ap(ikm1+1),1,z(1),1)
   80    continue
         if (ks .eq. 2) go to 100
            if (dabs(z(k)) .le. dabs(ap(kk))) go to 90
               s = dabs(ap(kk))/dabs(z(k))
               call dscal(n,s,z,1)
               ek = s*ek
   90       continue
            if (ap(kk) .ne. 0.0d0) z(k) = z(k)/ap(kk)
            if (ap(kk) .eq. 0.0d0) z(k) = 1.0d0
         go to 110
  100    continue
            km1k = ik + k - 1
            km1km1 = ikm1 + k - 1
            ak = ap(kk)/ap(km1k)
            akm1 = ap(km1km1)/ap(km1k)
            bk = z(k)/ap(km1k)
            bkm1 = z(k-1)/ap(km1k)
            denom = ak*akm1 - 1.0d0
            z(k) = (akm1*bk - bkm1)/denom
            z(k-1) = (ak*bkm1 - bk)/denom
  110    continue
         k = k - ks
         ik = ik - k
         if (ks .eq. 2) ik = ik - (k + 1)
      go to 60
  120 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
c     solve trans(u)*y = w
c
      k = 1
      ik = 0
  130 if (k .gt. n) go to 160
         ks = 1
         if (kpvt(k) .lt. 0) ks = 2
         if (k .eq. 1) go to 150
            z(k) = z(k) + ddot(k-1,ap(ik+1),1,z(1),1)
            ikp1 = ik + k
            if (ks .eq. 2)
     *         z(k+1) = z(k+1) + ddot(k-1,ap(ikp1+1),1,z(1),1)
            kp = iabs(kpvt(k))
            if (kp .eq. k) go to 140
               t = z(k)
               z(k) = z(kp)
               z(kp) = t
  140       continue
  150    continue
         ik = ik + k
         if (ks .eq. 2) ik = ik + (k + 1)
         k = k + ks
      go to 130
  160 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
      ynorm = 1.0d0
c
c     solve u*d*v = y
c
      k = n
      ik = n*(n - 1)/2
  170 if (k .eq. 0) go to 230
         kk = ik + k
         ikm1 = ik - (k - 1)
         ks = 1
         if (kpvt(k) .lt. 0) ks = 2
         if (k .eq. ks) go to 190
            kp = iabs(kpvt(k))
            kps = k + 1 - ks
            if (kp .eq. kps) go to 180
               t = z(kps)
               z(kps) = z(kp)
               z(kp) = t
  180       continue
            call daxpy(k-ks,z(k),ap(ik+1),1,z(1),1)
            if (ks .eq. 2) call daxpy(k-ks,z(k-1),ap(ikm1+1),1,z(1),1)
  190    continue
         if (ks .eq. 2) go to 210
            if (dabs(z(k)) .le. dabs(ap(kk))) go to 200
               s = dabs(ap(kk))/dabs(z(k))
               call dscal(n,s,z,1)
               ynorm = s*ynorm
  200       continue
            if (ap(kk) .ne. 0.0d0) z(k) = z(k)/ap(kk)
            if (ap(kk) .eq. 0.0d0) z(k) = 1.0d0
         go to 220
  210    continue
            km1k = ik + k - 1
            km1km1 = ikm1 + k - 1
            ak = ap(kk)/ap(km1k)
            akm1 = ap(km1km1)/ap(km1k)
            bk = z(k)/ap(km1k)
            bkm1 = z(k-1)/ap(km1k)
            denom = ak*akm1 - 1.0d0
            z(k) = (akm1*bk - bkm1)/denom
            z(k-1) = (ak*bkm1 - bk)/denom
  220    continue
         k = k - ks
         ik = ik - k
         if (ks .eq. 2) ik = ik - (k + 1)
      go to 170
  230 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
c     solve trans(u)*z = v
c
      k = 1
      ik = 0
  240 if (k .gt. n) go to 270
         ks = 1
         if (kpvt(k) .lt. 0) ks = 2
         if (k .eq. 1) go to 260
            z(k) = z(k) + ddot(k-1,ap(ik+1),1,z(1),1)
            ikp1 = ik + k
            if (ks .eq. 2)
     *         z(k+1) = z(k+1) + ddot(k-1,ap(ikp1+1),1,z(1),1)
            kp = iabs(kpvt(k))
            if (kp .eq. k) go to 250
               t = z(k)
               z(k) = z(kp)
               z(kp) = t
  250       continue
  260    continue
         ik = ik + k
         if (ks .eq. 2) ik = ik + (k + 1)
         k = k + ks
      go to 240
  270 continue
c     make znorm = 1.0
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
      if (anorm .ne. 0.0d0) rcond = ynorm/anorm
      if (anorm .eq. 0.0d0) rcond = 0.0d0
      return
      end
      subroutine dspfa(ap,n,kpvt,info)
      integer n,kpvt(1),info
      double precision ap(1)
c
c     dspfa factors a double precision symmetric matrix stored in
c     packed form by elimination with symmetric pivoting.
c
c     to solve  a*x = b , follow dspfa by dspsl.
c     to compute  inverse(a)*c , follow dspfa by dspsl.
c     to compute  determinant(a) , follow dspfa by dspdi.
c     to compute  inertia(a) , follow dspfa by dspdi.
c     to compute  inverse(a) , follow dspfa by dspdi.
c
c     on entry
c
c        ap      double precision (n*(n+1)/2)
c                the packed form of a symmetric matrix  a .  the
c                columns of the upper triangle are stored sequentially
c                in a one-dimensional array of length  n*(n+1)/2 .
c                see comments below for details.
c
c        n       integer
c                the order of the matrix  a .
c
c     output
c
c        ap      a block diagonal matrix and the multipliers which
c                were used to obtain it stored in packed form.
c                the factorization can be written  a = u*d*trans(u)
c                where  u  is a product of permutation and unit
c                upper triangular matrices , trans(u) is the
c                transpose of  u , and  d  is block diagonal
c                with 1 by 1 and 2 by 2 blocks.
c
c        kpvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if the k-th pivot block is singular. this is
c                     not an error condition for this subroutine,
c                     but it does indicate that dspsl or dspdi may
c                     divide by zero if called.
c
c     packed storage
c
c          the following program segment will pack the upper
c          triangle of a symmetric matrix.
c
c                k = 0
c                do 20 j = 1, n
c                   do 10 i = 1, j
c                      k = k + 1
c                      ap(k)  = a(i,j)
c             10    continue
c             20 continue
c
c     linpack. this version dated 08/14/78 .
c     james bunch, univ. calif. san diego, argonne nat. lab.
c
c     subroutines and functions
c
c     blas daxpy,dswap,idamax
c     fortran dabs,dmax1,dsqrt
c
c     internal variables
c
      double precision ak,akm1,bk,bkm1,denom,mulk,mulkm1,t
      double precision absakk,alpha,colmax,rowmax
      integer idamax,ij,ijj,ik,ikm1,im,imax,imaxp1,imim,imj,imk
      integer j,jj,jk,jkm1,jmax,jmim,k,kk,km1,km1k,km1km1,km2,kstep
      logical swap
c
c
c     initialize
c
c     alpha is used in choosing pivot block size.
      alpha = (1.0d0 + dsqrt(17.0d0))/8.0d0
c
      info = 0
c
c     main loop on k, which goes from n to 1.
c
      k = n
      ik = (n*(n - 1))/2
   10 continue
c
c        leave the loop if k=0 or k=1.
c
c     ...exit
         if (k .eq. 0) go to 200
         if (k .gt. 1) go to 20
            kpvt(1) = 1
            if (ap(1) .eq. 0.0d0) info = 1
c     ......exit
            go to 200
   20    continue
c
c        this section of code determines the kind of
c        elimination to be performed.  when it is completed,
c        kstep will be set to the size of the pivot block, and
c        swap will be set to .true. if an interchange is
c        required.
c
         km1 = k - 1
         kk = ik + k
         absakk = dabs(ap(kk))
c
c        determine the largest off-diagonal element in
c        column k.
c
         imax = idamax(k-1,ap(ik+1),1)
         imk = ik + imax
         colmax = dabs(ap(imk))
         if (absakk .lt. alpha*colmax) go to 30
            kstep = 1
            swap = .false.
         go to 90
   30    continue
c
c           determine the largest off-diagonal element in
c           row imax.
c
            rowmax = 0.0d0
            imaxp1 = imax + 1
            im = imax*(imax - 1)/2
            imj = im + 2*imax
            do 40 j = imaxp1, k
               rowmax = dmax1(rowmax,dabs(ap(imj)))
               imj = imj + j
   40       continue
            if (imax .eq. 1) go to 50
               jmax = idamax(imax-1,ap(im+1),1)
               jmim = jmax + im
               rowmax = dmax1(rowmax,dabs(ap(jmim)))
   50       continue
            imim = imax + im
            if (dabs(ap(imim)) .lt. alpha*rowmax) go to 60
               kstep = 1
               swap = .true.
            go to 80
   60       continue
            if (absakk .lt. alpha*colmax*(colmax/rowmax)) go to 70
               kstep = 1
               swap = .false.
            go to 80
   70       continue
               kstep = 2
               swap = imax .ne. km1
   80       continue
   90    continue
         if (dmax1(absakk,colmax) .ne. 0.0d0) go to 100
c
c           column k is zero.  set info and iterate the loop.
c
            kpvt(k) = k
            info = k
         go to 190
  100    continue
         if (kstep .eq. 2) go to 140
c
c           1 x 1 pivot block.
c
            if (.not.swap) go to 120
c
c              perform an interchange.
c
               call dswap(imax,ap(im+1),1,ap(ik+1),1)
               imj = ik + imax
               do 110 jj = imax, k
                  j = k + imax - jj
                  jk = ik + j
                  t = ap(jk)
                  ap(jk) = ap(imj)
                  ap(imj) = t
                  imj = imj - (j - 1)
  110          continue
  120       continue
c
c           perform the elimination.
c
            ij = ik - (k - 1)
            do 130 jj = 1, km1
               j = k - jj
               jk = ik + j
               mulk = -ap(jk)/ap(kk)
               t = mulk
               call daxpy(j,t,ap(ik+1),1,ap(ij+1),1)
               ijj = ij + j
               ap(jk) = mulk
               ij = ij - (j - 1)
  130       continue
c
c           set the pivot array.
c
            kpvt(k) = k
            if (swap) kpvt(k) = imax
         go to 190
  140    continue
c
c           2 x 2 pivot block.
c
            km1k = ik + k - 1
            ikm1 = ik - (k - 1)
            if (.not.swap) go to 160
c
c              perform an interchange.
c
               call dswap(imax,ap(im+1),1,ap(ikm1+1),1)
               imj = ikm1 + imax
               do 150 jj = imax, km1
                  j = km1 + imax - jj
                  jkm1 = ikm1 + j
                  t = ap(jkm1)
                  ap(jkm1) = ap(imj)
                  ap(imj) = t
                  imj = imj - (j - 1)
  150          continue
               t = ap(km1k)
               ap(km1k) = ap(imk)
               ap(imk) = t
  160       continue
c
c           perform the elimination.
c
            km2 = k - 2
            if (km2 .eq. 0) go to 180
               ak = ap(kk)/ap(km1k)
               km1km1 = ikm1 + k - 1
               akm1 = ap(km1km1)/ap(km1k)
               denom = 1.0d0 - ak*akm1
               ij = ik - (k - 1) - (k - 2)
               do 170 jj = 1, km2
                  j = km1 - jj
                  jk = ik + j
                  bk = ap(jk)/ap(km1k)
                  jkm1 = ikm1 + j
                  bkm1 = ap(jkm1)/ap(km1k)
                  mulk = (akm1*bk - bkm1)/denom
                  mulkm1 = (ak*bkm1 - bk)/denom
                  t = mulk
                  call daxpy(j,t,ap(ik+1),1,ap(ij+1),1)
                  t = mulkm1
                  call daxpy(j,t,ap(ikm1+1),1,ap(ij+1),1)
                  ap(jk) = mulk
                  ap(jkm1) = mulkm1
                  ijj = ij + j
                  ij = ij - (j - 1)
  170          continue
  180       continue
c
c           set the pivot array.
c
            kpvt(k) = 1 - k
            if (swap) kpvt(k) = -imax
            kpvt(k-1) = kpvt(k)
  190    continue
         ik = ik - (k - 1)
         if (kstep .eq. 2) ik = ik - (k - 2)
         k = k - kstep
      go to 10
  200 continue
      return
      end
      subroutine dspsl(ap,n,kpvt,b)
      integer n,kpvt(1)
      double precision ap(1),b(1)
c
c     dsisl solves the double precision symmetric system
c     a * x = b
c     using the factors computed by dspfa.
c
c     on entry
c
c        ap      double precision(n*(n+1)/2)
c                the output from dspfa.
c
c        n       integer
c                the order of the matrix  a .
c
c        kpvt    integer(n)
c                the pivot vector from dspfa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero may occur if  dspco  has set rcond .eq. 0.0
c        or  dspfa  has set info .ne. 0  .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dspfa(ap,n,kpvt,info)
c           if (info .ne. 0) go to ...
c           do 10 j = 1, p
c              call dspsl(ap,n,kpvt,c(1,j))
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     james bunch, univ. calif. san diego, argonne nat. lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c     fortran iabs
c
c     internal variables.
c
      double precision ak,akm1,bk,bkm1,ddot,denom,temp
      integer ik,ikm1,ikp1,k,kk,km1k,km1km1,kp
c
c     loop backward applying the transformations and
c     d inverse to b.
c
      k = n
      ik = (n*(n - 1))/2
   10 if (k .eq. 0) go to 80
         kk = ik + k
         if (kpvt(k) .lt. 0) go to 40
c
c           1 x 1 pivot block.
c
            if (k .eq. 1) go to 30
               kp = kpvt(k)
               if (kp .eq. k) go to 20
c
c                 interchange.
c
                  temp = b(k)
                  b(k) = b(kp)
                  b(kp) = temp
   20          continue
c
c              apply the transformation.
c
               call daxpy(k-1,b(k),ap(ik+1),1,b(1),1)
   30       continue
c
c           apply d inverse.
c
            b(k) = b(k)/ap(kk)
            k = k - 1
            ik = ik - k
         go to 70
   40    continue
c
c           2 x 2 pivot block.
c
            ikm1 = ik - (k - 1)
            if (k .eq. 2) go to 60
               kp = iabs(kpvt(k))
               if (kp .eq. k - 1) go to 50
c
c                 interchange.
c
                  temp = b(k-1)
                  b(k-1) = b(kp)
                  b(kp) = temp
   50          continue
c
c              apply the transformation.
c
               call daxpy(k-2,b(k),ap(ik+1),1,b(1),1)
               call daxpy(k-2,b(k-1),ap(ikm1+1),1,b(1),1)
   60       continue
c
c           apply d inverse.
c
            km1k = ik + k - 1
            kk = ik + k
            ak = ap(kk)/ap(km1k)
            km1km1 = ikm1 + k - 1
            akm1 = ap(km1km1)/ap(km1k)
            bk = b(k)/ap(km1k)
            bkm1 = b(k-1)/ap(km1k)
            denom = ak*akm1 - 1.0d0
            b(k) = (akm1*bk - bkm1)/denom
            b(k-1) = (ak*bkm1 - bk)/denom
            k = k - 2
            ik = ik - (k + 1) - k
   70    continue
      go to 10
   80 continue
c
c     loop forward applying the transformations.
c
      k = 1
      ik = 0
   90 if (k .gt. n) go to 160
         if (kpvt(k) .lt. 0) go to 120
c
c           1 x 1 pivot block.
c
            if (k .eq. 1) go to 110
c
c              apply the transformation.
c
               b(k) = b(k) + ddot(k-1,ap(ik+1),1,b(1),1)
               kp = kpvt(k)
               if (kp .eq. k) go to 100
c
c                 interchange.
c
                  temp = b(k)
                  b(k) = b(kp)
                  b(kp) = temp
  100          continue
  110       continue
            ik = ik + k
            k = k + 1
         go to 150
  120    continue
c
c           2 x 2 pivot block.
c
            if (k .eq. 1) go to 140
c
c              apply the transformation.
c
               b(k) = b(k) + ddot(k-1,ap(ik+1),1,b(1),1)
               ikp1 = ik + k
               b(k+1) = b(k+1) + ddot(k-1,ap(ikp1+1),1,b(1),1)
               kp = iabs(kpvt(k))
               if (kp .eq. k) go to 130
c
c                 interchange.
c
                  temp = b(k)
                  b(k) = b(kp)
                  b(kp) = temp
  130          continue
  140       continue
            ik = ik + k + k + 1
            k = k + 2
  150    continue
      go to 90
  160 continue
      return
      end


! ============================================================================
! name        : driver_fem_1d_fortran_eclipse.f90
! author      : amir
! version     :
! copyright   : your copyright notice
! description : hello world in fortran
! ============================================================================
program driver_fem_1d_fortran_eclipse
use linearsolvers
use fem_geometry
use material_behavior
use fem_libs
    implicit none
!     ================================================================
!                           the variables
!     ================================================================
      integer :: icalib !calibration parameter
!     ================================================================
!                      solution variables
!     ================================================================
      real*8,allocatable::glk(:,:)
      real*8,allocatable::glf(:) !the global source vector
      real*8,allocatable::glu(:) !the global solution
      real*8,allocatable::glp(:) !the previus degrees of freedom vector
      real*8,allocatable::glb(:) !the before previus degrees of freedom

      real*8,allocatable::glu_ref(:) !the global solution from refrence configuration
      real*8,allocatable::glp_ref(:) !the previus degrees of freedom vector
      real*8,allocatable::glb_ref(:) !the before previus degrees of freedom
!     ================================================================
!                      solver variables
!     ================================================================
      real*8,allocatable::gls(:) !the sulution vector out of linear solver
      real*8,allocatable::glq(:) !internal force vector
      real*8,allocatable::glt(:) !external fource vector
      real*8,allocatable::glr(:) !total residual vector
!     ============================iteration variables
      real*8::  eps,error,normal !the error tolerance and error
      integer:: itmax !maxumim number of iteration
      integer:: iter ! iteration counter
      logical:: successful,converge
!     ================================================================
!                      file unit
!     ================================================================
      integer::curved_node !curved node for
!     ================================================================
!                      time variables
!     ================================================================
!      integer::ntime
!      real*8::deltime
      real*8::loadfactor    ! time
      real*8::freq
      real*4::timearray, telapse
      integer ( kind = 4 )start_stamp_v(8),end_stamp_v(8),values(8)
      character*8::ctime(2)
      integer :: clck_counts_beg, clck_counts_end, clck_rate
      real ::  beg_cpu_time, end_cpu_time
!     ================================================================
      real*8::k00,k01,labda01
      real*8::labda_e_01,k_e_00,k_e_01
      real*8::labda_k_01,k_k_00,k_k_01
!     ================================================================
      integer::inode,jnode,ibond,jbond ,i,j,id,in
!     ================================================================
      integer::igauss,ngauss
!     =======================trivial meshing arrays the meshing seed parameters
      integer ::neldirectional(dimen)
      real*8  ::length(dimen)
!     ================================================================
      common/iteration/iter
      common/visco_elastic/k00,k01,labda01,            &
                          k_e_00,k_e_01,labda_e_01,     &
                          k_k_00,k_k_01,labda_k_01
!     ===============================================================
!                       p r e p r o c e s s o r   u n i t
!     ===============================================================
      call system_clock ( clck_counts_beg, clck_rate)
      call cpu_time (beg_cpu_time)
      call timestamp()
!     ===============================================================
!     reading iteration and convergence critria's
!     ===============================================================
      itmax=30;eps=1e-2
!     ======================== ve formulation
      k00=1.0 ; k01=0.0; labda01=0.0
      k_e_00=0.4 ; k_e_01=0.25; labda_e_01=0.5 ;
      k_k_00=1.0 ; k_k_01=0.0; labda_k_01=0.0 ;
!     ===============================================================
!     reading time increment varibales
!     ===============================================================
      dtime=1.0;freq=0.1
      ntime=100

    length=10.0
    neldirectional(1)=100
      call geometry_1D(neldirectional,length)
!      call printMatrix(coords,'c')
!      call printMatrix_int(nod,'nod')
!     ===============================================================
!     define the solution parameters
!     ===============================================================
      nnm=size(coords,dim=1)
      nem=size(nod,dim=1)
      neq  = nnm*ndf;     nn=npe*ndf;
      ipdf = iel+1;    ngauss=(ipdf**dimen)*nem
!     ===============================================================
!     reading the boundary conditions
!     ===============================================================
      call bounday_1D()
      allocate(glk(neq,neq),glu(neq),glq(neq),glt(neq),glr(neq))
      glu=0.0d0;glt=0.0d0;glr=0.0d0;
      call  form_history(ngauss,dimen,ipdf,nem)
!     ===============================================================
!                        time increment starts here
!     ===============================================================
      vspvt=vspv
      vssvt=vssv

      do itime=0,ntime
      time(1)=dtime;time(2)=itime*dtime

     loadfactor=1.0d0*time(2)

!      loadfactor=250*sawtooth(time(2)*freq)*1.0

!     loadfactor=250*sin(2.0*pi*time(2)*freq)*1.0e3

      vspv=loadfactor*vspvt
      vssv=loadfactor*vssvt

      glt=0.0d0;
      glu(bnd_no_pr_vec)=0.0d0;
!     ===============================================================
!                 nonlinear solution iteration starts here
!     ===============================================================
      iter=0;CONVERGE=.false.;   ;
130   iter=iter+1;
!      write(1,*)'iter',iter
      if(iter.gt.itmax)then; write(*,330);goto 500;endif
!     ===============================================================
!                        forming the global matrices
!     ===============================================================
      glk=0.0d0;glq=0.0d0;!
!      write(1,*)'glu=',(glu(i),i=1,neq);
      call glbmatrcs(glu,glk,glq)
!      write(1,*)'glq=',(glq(i),i=1,neq);
!     ===============================================================
!                             newton raphson sprocedure
!     ===============================================================
      glt(bnd_no_se_vec) = vssv ;
      glr=glt-glq ;

!      write(1,*)'glt=',(glt(i),i=1,neq);
!      write(1,*)'glr=',(glr(i),i=1,neq);

!     ===============================================================
!                        solving the linear system of equations
!     ===============================================================
      call symmetric_primary_bounday(glk,glr)
      vspv=0.0d0
!!      write(1,*)'glr=',(glr(i),i=1,neq);

      call gaussian_elimination_solver(glk,glr);  gls=glr
!!      write(1,*)'gls=',(gls(i),i=1,neq);
!     call lapack_gesv( glk, glr ); gls=glr
!     ===============================================================
!     call result_printer_1D(iter,glr)
      glu=glu+gls
!
      normal=norm_vect(glu);if(normal.eq.0)then;normal=1;endif
      error=norm_vect(gls)
      error=error/normal

      write(out,*)'time',time
      write(out,*)'error',error
      write(out,*)'iter',iter
!

      if(error.gt.eps)then;converge=.false. ;goto 130;endif;
      converge=.true.
!     ===============================================================
!                        time increment ends here
!     ===============================================================
!      glu_ref=glu+glu_ref
!      glb_ref=glp_ref
!      glp_ref=glu_ref
!
!      glb=glp
!      glp=glu

!      call update_history(ngauss,dimen)
!     ======================updatng coordinates  updated lagrangian
!      forall(i=1:nnm) coords(1:dimen,i)=
!     1 coords(1:dimen,i)+glu((i-1)*ndf+[1:dimen])
!     ===============================================================
!     plotting the converged result
!     ===============================================================
    call result_printer_1D(iter,glu)

    enddo !itime=0,ntime

500   call system_clock ( clck_counts_end, clck_rate )
      write (*, *)'elapsed system clock=', &
      (clck_counts_end - clck_counts_beg) / real (clck_rate)
      call cpu_time (end_cpu_time)
      write (*, *)'elapsed cpu clock=', end_cpu_time - beg_cpu_time
      call timestamp ()

999 FORMAT (11(:,1X,F8.5) )
330   FORMAT(/,5X,'***** CONVERGENCE CRITERION IS NOT SATISFIED *****')
end program


program test
    use integrators
    implicit none
    integer(8), parameter :: n = 2
    real :: q = 1e-3
    real(8), dimension(n) :: masses
    real(8), dimension(n, 3) :: positions, velocities, poses, vels, poses_low, &
            vels_low, poses_high, vels_high, accels, gal_positions, &
            gal_velocities
    real(8) :: dt, g
    integer(8) :: i
    masses = (/1. - q, q/)
    positions(1, :) = (/-q, 0., 0./)
    positions(2, :) = (/1. - q, 0., 0./)
    velocities(1, :) = (/0., -q, 0./)
    velocities(2, :) = (/0., 1. - q, 0./)
    gal_positions(1, :) = (/1., 0., 0./)
    gal_positions(2, :) = (/1., 0., 0./)
    gal_velocities(1, :) = (/0., 0.43948513, 0./)
    gal_velocities(2, :) = (/0., 0.25373686, 0./)
    g = 1.
    dt = 1e-3

    call euler_forward(n, masses, positions, velocities, dt, g, poses, vels)
    print *, "Euler forward:"
    do i=1, n
        print *, poses(i, :)
    end do
    do i=1, n
        print *, vels(i, :)
    end do
    print *, ""

    call kdk(n, masses, positions, velocities, dt, g, poses, vels)
    print *, "Kick Drift Kick:"
    print *, poses
    print *, vels
    print *, ""

    call rk_pde(n, masses, positions, velocities, g, poses, vels)
    print *, "Runge Kutta PDE"
    print *, poses
    print *, vels
    print *, ""

    call rk3_classic(n, masses, positions, velocities, dt, g, poses, vels)
    print *, "Runge Kutta Classic 3:"
    print *, poses
    print *, vels

    call rkf45(n, masses, positions, velocities, dt, g, poses_low, vels_low, &
            poses_high, vels_high)
    print *, "Runge Kutta Fehlberg 4-5:"
    print *, poses_high
    print *, vels_high
    print *, ""

    call kdk_gal(n, masses, gal_positions, gal_velocities, dt, g, poses, vels)
    print *, "Kick Drift Kick Galaxy:"
    print *, poses
    print *, vels
    print *, ""

end program test


! =============================================================================
!                       Test ellipsoid reflection
!
!         This unit test checks the reflection of parcels which is
!         applied after splitting to ensure the centres of the child
!         parcels are within the domain.
! =============================================================================
program test_ellipsoid_reflection
    use unit_test
    use options, only : verbose
    use constants, only : pi, zero, one, two, three, six, f12, f13, f14, f18, f23, twopi
    use parcel_container, only : parcel_alloc   &
                               , parcel_dealloc &
                               , n_parcels      &
                               , parcels
    use parcel_bc, only : apply_reflective_bc
    use parcel_ellipsoid, only : get_abc        &
                               , get_angles     &
                               , get_B33
    use parameters, only : update_parameters, lower, dx, vcell, extent, nx, ny, nz
    implicit none

    integer :: iter_t, iter_p
    double precision :: abc, abc23, B11, B12, B13, B22, B23, error, a2, b2, c2
    double precision :: st, sp, ct, cp, theta, phi

    call parse_command_line

    nx = 2
    ny = 2
    nz = 2
    lower  = (/zero, zero, zero/)
    extent = (/one, one, one/)

    call update_parameters

    n_parcels = 1
    call parcel_alloc(1)

    error = zero

    parcels%volume(1) = f18 * vcell

    abc = get_abc(parcels%volume(1))
    abc23 = abc ** f23
    a2 = six * abc23
    b2 = f12 * abc23
    c2 = f13 * abc23

    if (verbose) then
        open(80, file='original_position_and_Bmatrix.asc')
        open(81, file='reflected_position_and_Bmatrix.asc')
    endif

    do iter_t = 0, 359
        do iter_p = 0, 179
            theta = dble(iter_t) * pi / 180.0d0     ! azimuthal angle, [0, 2pi[
            phi = dble(iter_p) * pi / 180.0d0       ! polar angle, [0, pi]

            st = dsin(theta)
            ct = dcos(theta)

            sp = dsin(phi)
            cp = dcos(phi)

            B11 = a2 * ct ** 2 * sp ** 2 + b2 * st ** 2 + c2 * ct ** 2 * cp ** 2
            B12 = a2 * st * ct * sp ** 2 - b2 * st * ct + c2 * st * ct * cp ** 2
            B13 = (a2 - c2) * ct * sp * cp
            B22 = a2 * st ** 2 * sp ** 2 + b2 * ct ** 2 + c2 * st ** 2 * cp ** 2
            B23 = (a2 - c2) * st * sp * cp
            ! B33 = a2 * cp ** 2 + c2 * sp ** 2

            !
            ! lower boundary check
            !
            parcels%position(:, 1) = (/f12, f12, - f12 * dx(3)/)
            parcels%B(1, 1) = B11
            parcels%B(2, 1) = B12
            parcels%B(3, 1) = B13
            parcels%B(4, 1) = B22
            parcels%B(5, 1) = B23

            if (verbose) then
                write(80, *) parcels%position(:, 1), parcels%B(:, 1), &
                             get_B33(parcels%B(:, 1), parcels%volume(1))
            endif

            call apply_reflective_bc(parcels%position(:, 1), parcels%B(:, 1))

            if (verbose) then
                write(81, *) parcels%position(:, 1), parcels%B(:, 1), &
                             get_B33(parcels%B(:, 1), parcels%volume(1))
            endif

            call check_result('lower')

            !
            ! upper boundary check
            !
            parcels%position(:, 1) = (/f12, f12, one + f12 * dx(3)/)
            parcels%B(1, 1) = B11
            parcels%B(2, 1) = B12
            parcels%B(3, 1) = B13
            parcels%B(4, 1) = B22
            parcels%B(5, 1) = B23

            call apply_reflective_bc(parcels%position(:, 1), parcels%B(:, 1))

            call check_result('upper')
        enddo
    enddo

    if (verbose) then
        close(80)
        close(81)
    endif

    call print_result_dp('Test ellipsoid reflection', error, atol=3.0e-13)

    call parcel_dealloc

    contains

        subroutine check_result(bc)
            character(*), intent(in) :: bc
            double precision         :: angles(2)

            error = max(error, abs(parcels%B(1, 1) - B11))
            error = max(error, abs(parcels%B(2, 1) - B12))
            error = max(error, abs(parcels%B(3, 1) + B13))
            error = max(error, abs(parcels%B(4, 1) - B22))
            error = max(error, abs(parcels%B(5, 1) + B23))

            ! (/azimuth, polar/)
            angles = get_angles(parcels%B(:, 1), parcels%volume(1))

            ! -pi <= theta <= pi
            if (angles(1) < 0) then
                angles(1) = twopi + angles(1)
            endif

            ! rotated by pi/2
            if (dabs(dabs(theta - angles(1)) - pi) < 10000.0d0 * epsilon(pi)) then
                if (theta > angles(1)) then
                    angles(1) = pi + angles(1)
                else
                    angles(1) = angles(1) - pi
                endif
            endif

            ! 0 <= angles(2) <= pi/2
            if (phi > pi/2) then
                angles(2) = pi - dabs(angles(2))
            endif

            ! Neglect if phi = 0, pi/2 and pi, since then theta does not matter
            if ((iter_p .ne. 0) .and. (iter_p .ne. 90) .and. (iter_p .ne. 180)) then
                error = max(error, abs(theta - angles(1)))
            endif

            error = max(error, dabs(dabs(phi) - dabs(angles(2))))

            error = max(error, abs(f12 - parcels%position(1, 1)))
            error = max(error, abs(f12 - parcels%position(2, 1)))

            if (bc == 'lower') then
                error = max(error, abs(f12 * dx(3) - parcels%position(3, 1)))
            else
                error = max(error, abs(one - f12 * dx(3) - parcels%position(3, 1)))
            endif
        end subroutine check_result

end program test_ellipsoid_reflection


c
c ---------------------------------------------------------------
c
      subroutine centrd(p,xc,yc,area)
      implicit double precision (a-h,o-z)
      dimension p(10,2)
      dimension xcen(10),ycen(10),subar(10)
c
c     # Compute the centroid (xc,yc) of the polygon p.  Also returns
c     # the area.
c
      epsar = 1d-7
      x0 = p(1,1)
      y0 = p(1,2)
      do 100 i=3,10
         if (p(i+1,1) .eq. -11) then
           if (i.eq.3) then
             write(6,*) 'degenerate polygon in centrd'
             stop
             endif
           go to 200
           endif
c
c        # Compute centroid of triangle with vertices 1, i-1, and i
c
         x1 = p(i-1,1)
         y1 = p(i-1,2)
         x2 = p(i,1)
         y2 = p(i,2)
         xcen(i) = (x1+x2+x0)/3.d0
         ycen(i) = (y1+y2+y0)/3.d0
c
c        # compute area:
c
         subar(i) = 0.5d0 * ((y0+y1)*(x1-x0) + (y1+y2)*(x2-x1)
     &                     + (y2+y0)*(x0-x2))
c
  100    continue
      write(6,*) 'error in centrd:  too many vertices'
      stop
c
  200 continue
c
c     # take weighted average of triangle centroids to find centroid
c     # of polygon:
c
      area = 0.d0
      xc = 0.d0
      yc = 0.d0
      do 220 j=3,i-1
         area = area + subar(j)
         xc = xc + subar(j)*xcen(j)
         yc = yc + subar(j)*ycen(j)
  220    continue
c     if (area.eq.0.d0) then
      if (area.eq.1.d-16) then
          xc = x0
          yc = y0
        else
          xc = xc/area
          yc = yc/area
        endif
c
      return
      end


module constants
  use utils, only:fp,ip
  implicit none
  real(fp), parameter :: hbar=1.054571726e-34_fp
  real(fp), parameter :: pi=3.141592656_fp

end module constants


      PROGRAM LA_SGESVD_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GESVD
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, M, N
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), S(:), U(:,:), V(:,:), VT(:,:), WW(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GESVD Example Program Results'
      N = 5; M=3
      ALLOCATE( A(M,N), AA(M,N), S(MIN(M,N)), U(M,M), V(N,N), VT(N,N), WW(MIN(M,N)-1))

      OPEN(UNIT=21,FILE='gesvd.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,M
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      AA=A

      WRITE(*,*)'Matrix A:'
      DO I=1,M; WRITE(*,"(5(I3,1X))") INT(A(I,:)); ENDDO

      WRITE(*,*)
      WRITE(*,*) 'CALL LA_GESVD( A, S )'
!      CALL LA_GESVD( A, S )

      WRITE(*,*) 'S on exit : '
      WRITE(*,"(3(F10.5,1X))") S(:)

      WRITE(*,*)
      WRITE(*,*)' * EXAMPLE 2 * '
      WRITE(*,*) "CALL LA_GESVD( A, S, VT=VT, WW=WW, JOB='U', INFO=INFO )"
      CALL LA_GESVD( AA, S, VT=VT, WW=WW, JOB='U', INFO=INFO )

      WRITE(*,*) 'A on exit : '
      DO I=1,M;
         WRITE(*,"(5(E14.6,1X))") AA(I,:);
      ENDDO

      WRITE(*,*) 'VT on exit : '
      DO I=1,N;
         WRITE(*,"(5(E14.6,1X))") VT(I,:);
      ENDDO

      WRITE(*,*)'WW on exit : '
      WRITE(*,"(5(E14.6,1X))") WW(:)

      WRITE(*,*) ' INFO = ', INFO

      END PROGRAM LA_SGESVD_EXAMPLE