      subroutine hlltbk(n,lda,nb,a,work,info,me,nprocs,colsthisproc)
      implicit none

*
*     -- NPAC, Syracuse University
*
*     modificed by David Koester
*     October 1993
*     
*     block Choleski factorization for dense positive definite matrices
*
      integer n,lda,nb,info,j,jb,nprocs,me
      integer proc,mydone,mycols,mypanel
      integer ncols,mp,workin,offset,tab
      integer nextinring,previnring,colsthisproc
      integer PanelMsgType
      integer t3,t4
      real*8  a(*), work(*), one
      parameter (one=1.0e0)

      COMMON /LOCN/ PROC, MYDONE, MYCOLS, MYPANEL

      data PanelMsgType /3000/

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

*     ** initialize positional variables **
      workin = 1

*     ** for one processor,set nb = n
      if (nb .eq. n) then
*        ** use unblocked code on processor 0 **
         call dlltk(n,a,lda,info)
      else
*        ** use blocked code **
         if (me .eq. 0) then
	    call dlltk(nb,a(1),lda,info)
	    call dtrsm('R','L','T','N',n-nb,nb,one,a(1),lda,
     $                 a(nb+1),lda)
	    call bcastdoublesd(n-nb,nb,a(nb+1),'N',(PanelMsgType+1))
         endif

      DO 40 J = 1,(N-nb),NB
	    jb = min (n-j+1,nb)

	    if (proc.eq.me) then
*              ** update the rest of my panels **
   	       mypanel = mypanel + 1
	       mydone = mydone + jb
	    else
*              ** receive panel **
               call bcastdoublerc(t3,t4,work(workin),'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)
	          ncols = jb
*                 ** i'm the next guy to chol a panel **
*                 ** so only update first panel **
		  call hsyrk('L','N',n-j-nb+1,nb,ncols,
     $                        -one,work(workin),lda,
     $                         one,a(mypanel*lda*nb+j+nb),lda,ncols,
     $                         nprocs)

*                 ** then chol the panel and send it **
	          call dlltk(jb,a(mypanel*lda*nb+j+nb),lda,info)
                  if (j .le. (n-2*nb)) then
		    call dtrsm('R','L','T','N',(n-j-nb-jb+1),jb,one,
     $                        a(mypanel*lda*nb+j+nb),lda,
     $                        a(mypanel*lda*nb+j+nb+jb),lda)
                    call bcastdoublesd( (n-j-nb-jb+1),nb,
     $                    a(mypanel*lda*nb+j+nb+jb),'N',
     &                      (PanelMsgType+j+nb))
                  endif
 	          ncols = mycols - mydone - jb
	          mp = mypanel + 1
	        else
	          ncols = mycols - mydone
	          mp = mypanel
                endif

         	offset = me + mp*nprocs
		tab = offset*nb - j - nb + 1

          	if (me .eq. previnring(proc)) then
                   call hsyrk('L','N',n-offset*nb,jb,n-offset*nb,
     $                        -one,a((mypanel-1)*lda*nb+j+jb+tab),lda,
     $                         one,a(mp*lda*nb+offset*nb+1),lda,ncols,
     $                         nprocs)
        	else
                   call hsyrk('L','N',n-offset*nb,jb,n-offset*nb,
     $                        -one,work(workin+tab),lda,
     $                         one,a(mp*lda*nb+offset*nb+1),lda,ncols,
     $                         nprocs)
 	        endif

            endif

   40 CONTINUE

      ENDIF

      RETURN
*
*     End of HLLTBK .
*
      END





