      subroutine frmbk(n,lda,nb,a,y,b,work,info,me,nprocs,
     &              colsthisproc)
      implicit none

*
*     -- NPAC, Syracuse University
*
*     written by David Koester
*     November 1993
*     
*     block forward substitution for dense matrices
*
      integer n,lda,nb,info,j,jb,nprocs,me
      integer proc,mydone,mycols,mypanel,mp
      integer i1,i2,j1,j2
      integer nextinring,colsthisproc
      integer PanelMsgType
      integer t3,t4
      real*8  a(*),y(*),b(*),work(*), one
      parameter (one=1.0e0)

      COMMON /LOCN/ PROC, MYDONE, MYCOLS, MYPANEL

      data PanelMsgType /3000/

      mypanel = 0
      mydone  = 0
      proc    = 0
      mycols  = colsthisproc

*     ** for one processor,set nb = n
      if (nb .eq. n) then
        do j1 = 1,n
          y(j1) = b(j1) / a( (((j1-1)*n)+j1) )
          do i1 = (j1+1),n
           b(i1) = b(i1) - (y(j1) * a( (((j1-1)*n)+i1) ) )
          enddo
        enddo
      else
*        ** use blocked code **
         if (me .eq. 0) then
          do j1 = 1,nb
           y(j1) = b(j1) / a( (((j1-1)*n)+j1) )
           do i1 = (j1+1),nb
             b(i1) = b(i1) - (y(j1) * a( (((j1-1)*n)+i1) ) )
           enddo
          enddo
*        ** generate the updates for the remaining blocks **
            do j1 = 1,nb
             do i1 = nb+1,n
              work(i1) = work(i1) + (y(j1) * a( (((j1-1)*n)+i1) ) )
             enddo
            enddo
	    call bcastdoublesd((n-nb),1,work(nb+1),'N',(PanelMsgType+1))
         endif

      DO 40 J = 1,(N-nb),NB
	    jb = min ((n-j),nb)
	    if (proc.eq.me) then
*              ** update variables **
   	       mypanel = mypanel + 1
	       mydone = mydone + jb
	    else
*              ** receive panel **
               call bcastdoublerc(t3,t4,work(j+nb),'N',
     &                                (PanelMsgType+j))
            endif

            proc = nextinring(proc)

            if ( (mycols-mydone) .gt. 0) then
               if (proc .eq. me) then
	          jb = min(n-(j+nb-1),nb)
*                 ** i'm the next processor to reduce a panel **
*                 ** so only update first panel **
                  i2 = (mypanel*nb*nprocs) + (nb*me)
                  do i1 = 1,jb
                    b(i2+i1) = b(i2+i1) - work(i2+i1)
                  enddo
*                 ** then reduce the panel and send it **
                  do j1 = 1,jb
                    j2 = mydone+j1
                    y(i2+j1) = b(i2+j1) / a( (((j2-1)*n)+(i2+j1)) )
                    do i1 = (j1+1),jb
                      b(i2+i1) = b(i2+i1) - 
     &                        (y(i2+j1) * a((((j2-1)*n)+(i2+i1))))
                    enddo
                  enddo
*                 ** generate the updates for the remaining blocks **
                  if (j .le. (n-2*nb)) then
                    do j1 = 1,nb
                     j2 = mydone+j1
                     do i1 = (i2+nb),n
                      work(i1) = work(i1) + 
     &                      (y(i2+j1) * a(((j2-1)*n)+(i2+i1)))
                     enddo
                    enddo
                    call bcastdoublesd((n-(j+2*nb-1)),1,
     &                   work((j+2*nb)),'N',(PanelMsgType+j+nb))
                  endif
               endif

          	if (me .eq. proc) then
                  mp = (mypanel+1)
                else
                  mp = mypanel
                endif

                i2 = (mp*nb*nprocs) + (nb*me)
                do while (i2 .lt. n)
                   do i1 = 1,nb
                     b(i2+i1) = b(i2+i1) - work(i2+i1)
                   enddo
                  i2 = i2 + nb*nprocs
                enddo

            endif

   40 CONTINUE

      ENDIF

      RETURN
*
*     End of FRMBK .
*
      END





