      subroutine force(a,n)
      real*8 a(1),rvec(100,100),rval(1000),wrk(1000)
      real*8 sr,wr,p,c,t
      integer n
      if(n.gt.100)print *,'FORCE Dim=',n
      call eigen(n,n,a,rval,wrk,rvec)
      nneg=0
      sr=0.d0
      do 31 k=1,n
         print 1701,k,rval(k)
 1701    format(2x,'force, eigen=',i5,f20.10)
        if(rval(k).lt.0.0)then
           nneg = nneg + 1
           sr = sr + rval(k) + rval(k)
        endif
 31   continue
      wr = (sr*sr*100.0)+1.0
      if(nneg.gt.0)then
         print *,'FORCE ',nneg
         p = rval(nneg+1)
         do 124 k=1,nneg
            c = rval(k)
            rval(k) = p*(sr-c)*(sr-c)/wr
 124     continue
         m=0
         do 125 k=1,n
            do 125 j=k,n
               m=m+1
               t=0.d0
               do 127 L=1,n
                  t=t+rvec(k,L)*rval(L)*rvec(j,L)
 127           continue
            a(m) = t
 125     continue
       print *,'Matrix forced'
      endif   

      return
      end
