lu1slk Subroutine

private subroutine lu1slk(m, n, lena, q, iqloc, a, indc, locc, nslack, w)

Arguments

Type IntentOptional Attributes Name
integer(kind=ip), intent(in) :: m
integer(kind=ip), intent(in) :: n
integer(kind=ip), intent(in) :: lena
integer(kind=ip), intent(in) :: q(n)
integer(kind=ip), intent(in) :: iqloc(m)
real(kind=rp), intent(in) :: a(lena)
integer(kind=ip), intent(in) :: indc(lena)
integer(kind=ip), intent(in) :: locc(n)
integer(kind=ip), intent(out) :: nslack
real(kind=rp), intent(out) :: w(n)

Called by

proc~~lu1slk~~CalledByGraph proc~lu1slk lusol::lu1slk proc~lu1fac lusol::lu1fac proc~lu1fac->proc~lu1slk proc~solve lusol_ez_module::solve proc~solve->proc~lu1fac proc~test_1 main::test_1 proc~test_1->proc~solve proc~test_2 main::test_2 proc~test_2->proc~solve program~main~2 main program~main~2->proc~test_1 program~main~2->proc~test_2

Source Code

  subroutine lu1slk( m, n, lena, q, iqloc, a, indc, locc, nslack, w )

    integer(ip),   intent(in)    :: m, n, lena
    integer(ip),   intent(in)    :: q(n), iqloc(m), indc(lena), locc(n)
    integer(ip),   intent(out)   :: nslack
    real(rp),      intent(in)    :: a(lena)
    real(rp),      intent(out)   :: w(n)

    !------------------------------------------------------------------
    ! lu1slk  sets w(j) > 0 if column j is a unit vector.
    !
    ! 21 Nov 2000: First version.  lu1fad needs it for TCP.
    !              Note that w(*) is nominally an integer(ip) array,
    !              but the only spare space is the double array w(*).
    !
    ! 10 Jan 2010: First f90 version.
    ! 12 Dec 2011: Declare intent and local variables.
    ! 12 Dec 2015: Always call lu1slk from lu1fac to obtain nslack.
    !              Need indc(*) and markr(*) to count 1 slack per row.
    !------------------------------------------------------------------

    integer(ip)   :: markr(m)
    integer(ip)   :: i, j, lc1, lq, lq1, lq2

    nslack     = 0
    markr(1:m) = 0
    w(1:n)     = zero

    ! Check all columns of length 1.

    lq1    = iqloc(1)
    lq2    = n
    if (m > 1) lq2 = iqloc(2) - 1

    do lq = lq1, lq2
       j      = q(lq)
       lc1    = locc(j)
       if (abs( a(lc1) ) == one) then
          i      = indc(lc1)
          if (markr(i) == 0) then
             nslack   = nslack + 1
             markr(i) = i
             w(j)     = one
          end if
       end if
    end do

  end subroutine lu1slk