xref: /phasta/phSolver/common/fillsparse.f (revision 712d3df0b59ebebaaeaea358162c8d2c043c6e08)

	subroutine fillsparseI(	iens, xKebe,	lhsK,
     &                               xGoC,      lhsP,
     1			             row,	col)
c
c
c
	include "common.h"
	real*8	xKebe(npro,9,nshl,nshl), xGoC(npro,4,nshl,nshl)
	integer	ien(npro,nshl),	col(nshg+1), row(nshg*nnz)
	real*8	lhsK(9,nnz_tot),	lhsP(4,nnz_tot)
c
	integer	aa,	b,	c,	e,	i,	k,	n
c
	integer sparseloc

	integer iens(npro,nshl)
c
c prefer to show explicit absolute value needed for cubic modes and
c higher rather than inline abs on pointer as in past versions
c iens is the signed ien array ien is unsigned
c
	ien=abs(iens)
c
c.... Accumulate the lhs
c
	do e = 1, npro ! loop over the elements
	    do aa = 1, nshl ! loop over the local equation numbers
		i = ien(e,aa) ! finds the global equation number or
			      ! block-row of our matrix
		c = col(i)    ! starting point to look for the matching column
		n = col(i+1) - c  !length of the list of entries in rowp
		do b = 1, nshl ! local variable number tangent respect
			       ! to
c function that searches row until it finds the match that gives the
c		   global equation number

		    k = sparseloc( row(c), n, ien(e,b) ) + c-1
c
c                                             *         *
c                   dimension egmass(npro,ndof,nenl,ndof,nenl)
c
c compressible      lhsT(1:5,1:5,k)=lhsT(1:5,1:5,k)+egmass(e,1:5,aa,1:5,b)
c
		    lhsK(1,k) = lhsK(1,k) + xKebe(e,1,aa,b)
		    lhsK(2,k) = lhsK(2,k) + xKebe(e,2,aa,b)
		    lhsK(3,k) = lhsK(3,k) + xKebe(e,3,aa,b)
		    lhsK(4,k) = lhsK(4,k) + xKebe(e,4,aa,b)
		    lhsK(5,k) = lhsK(5,k) + xKebe(e,5,aa,b)
		    lhsK(6,k) = lhsK(6,k) + xKebe(e,6,aa,b)
		    lhsK(7,k) = lhsK(7,k) + xKebe(e,7,aa,b)
		    lhsK(8,k) = lhsK(8,k) + xKebe(e,8,aa,b)
		    lhsK(9,k) = lhsK(9,k) + xKebe(e,9,aa,b)
c
		    lhsP(1,k) = lhsP(1,k) + xGoC(e,1,aa,b)
		    lhsP(2,k) = lhsP(2,k) + xGoC(e,2,aa,b)
		    lhsP(3,k) = lhsP(3,k) + xGoC(e,3,aa,b)
		    lhsP(4,k) = lhsP(4,k) + xGoC(e,4,aa,b)
		enddo
	    enddo
	enddo
c
c.... end
c
	return
	end


	subroutine fillsparseC(	iens, EGmass,	lhsK,
     1			             row,	col)
c
c-----------------------------------------------------------
c This routine fills up the spasely stored LHS mass matrix
c
c Nahid Razmra, Spring 2000. (Sparse Matrix)
c-----------------------------------------------------------
c
c

	include "common.h"

 	real*8	EGmass(npro,nedof,nedof)
        integer	ien(npro,nshl),	col(nshg+1), row(nnz*nshg)
        real*8 lhsK(nflow*nflow,nnz_tot)

c
        integer aa, b, c, e, i, k, n, n1
        integer f, g, r, s, t
c
	integer sparseloc

	integer iens(npro,nshl)
c
c prefer to show explicit absolute value needed for cubic modes and
c higher rather than inline abs on pointer as in past versions
c iens is the signed ien array ien is unsigned
c
	ien=abs(iens)
c
c.... Accumulate the lhsK
c
      do e = 1, npro
        do aa = 1, nshl  !loop over matrix block column index
          i = ien(e,aa)  !get mapping from aath node of element e to
                         ! the ith row of lhsk

          c = col(i)     !Get the mapping from the ith row of lhsk to
                         ! to the corresponding location in row
          n = col(i+1) - c   !number of nonzero blocks in the row
          r = (aa-1)*nflow   !starting index of the ath node in EGmass
          do b = 1, nshl
            s = (b-1)*nflow  !starting index of the bth node's
                             !contribution to node aa.
            k = sparseloc( row(c), n, ien(e,b) ) + c-1
                !Find the index of row which corresponds to node b of
                !element e. This is where contributions from EGmass
                !will actually get stored.

            do g = 1, nflow    !loop over columns in a block
               t = (g-1)*nflow
               do f = 1, nflow !loop over rows in a block
                 lhsK(t+f,k) = lhsK(t+f,k) + EGmass(e,r+f,s+g)
               enddo
            enddo
          enddo
        enddo
      enddo

      return
      end

      subroutine fillsparseC_BC(    iens, EGmass,
     &                              lhsk, row,    col)
!
!-----------------------------------------------------------
! This routine adds contributions from heat flux BCs to the
! spasely stored LHS mass matrix. This routine is modified
! from fillsparseC.
!
! Nicholas Mati, Summer 2014. (Sparse Matrix)
!-----------------------------------------------------------
!
      include "common.h"

      real*8     EGmass(npro, nshl, nshl)  !only contains term (5,5)
      integer    ien(npro,nshl),    col(nshg+1), row(nnz*nshg)
      real*8     lhsK(nflow*nflow,nnz_tot)

      integer aa, b, c, e, i, k, n, n1
      integer f, g, r, s, t

      integer sparseloc
      integer iens(npro,nshl)
c
c prefer to show explicit absolute value needed for cubic modes and
c higher rather than inline abs on pointer as in past versions
c iens is the signed ien array ien is unsigned
c
      ien=abs(iens)

      !Accumulate the lhsK
      do e = 1, npro
        do aa = 1, nshl  !loop over matrix block column index
          i = ien(e,aa)  !get mapping from aath node of element e to
                         ! the ith row of lhsk

          c = col(i)     !Get the mapping from the ith row of lhsk to
                         ! to the corresponding location in row
          n = col(i+1) - c   !number of nonzero blocks in the row
!          r = (aa-1)*nflow   !starting index of the ath node in EGmass
          do b = 1, nshl
!            s = (b-1)*nflow  !starting index of the bth node's
                             !contribution to node aa.
            k = sparseloc( row(c), n, ien(e,b) ) + c-1
                !Find the index of row which corresponds to node b of
                !element e. This is where contributions from EGmass
                !will actually get stored.

            lhsk(25, k) = lhsk(25, k) + EGmass(e, aa, b)
!            do g = 1, nflow    !loop over columns in a block
!               t = (g-1)*nflow
!               do f = 1, nflow !loop over rows in a block
!                 lhsK(t+f,k) = lhsK(t+f,k) + EGmass(e,r+f,s+g)
!               enddo
!            enddo
          enddo !loop over node b
        enddo !loop over node a
      enddo !loop over elements

      !end
      return
      end


      subroutine fillsparseSclr(   iens,      xSebe,    lhsS,
     1                         row,    col)

      include "common.h"
      real*8    xSebe(npro,nshl,nshl)
      integer    ien(npro,nshl),    col(nshg+1), row(nshg*nnz)
      real*8    lhsS(nnz_tot)

      integer    aa,    b,    c,    e,    i,    k,    n

      integer sparseloc

      integer iens(npro,nshl)
c
c prefer to show explicit absolute value needed for cubic modes and
c higher rather than inline abs on pointer as in past versions
c iens is the signed ien array ien is unsigned
c
      ien=abs(iens)
c
c.... Accumulate the lhs
c
      do e = 1, npro
        do aa = 1, nshl
        i = ien(e,aa)
        c = col(i)
        n = col(i+1) - c
        do b = 1, nshl
            k = sparseloc( row(c), n, ien(e,b) ) + c-1
c
            lhsS(k) = lhsS(k) + xSebe(e,aa,b)
        enddo
        enddo
      enddo
c
c.... end
c
      return
      end

      integer    function sparseloc( list, n, target )

c-----------------------------------------------------------
c This function finds the location of the non-zero elements
c of the LHS matrix in the sparsely stored matrix
c lhsK(nflow*nflow,nnz*numnp)
c
c Nahid Razmara, Spring 2000.     (Sparse Matrix)
c-----------------------------------------------------------

      integer    list(n),    n,    target
      integer    rowvl,    rowvh,    rowv

c
c.... Initialize
c
      rowvl = 1
      rowvh = n + 1
c
c.... do a binary search
c
100    if ( rowvh-rowvl .gt. 1 ) then
        rowv = ( rowvh + rowvl ) / 2
        if ( list(rowv) .gt. target ) then
        rowvh = rowv
        else
        rowvl = rowv
        endif
        goto 100
      endif
c
c.... return
c
      sparseloc = rowvl
c
      return
      end