home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_progs / prog_oth / prep_065.lzh / PREP / VECDEM.F < prev    next >
Text File  |  1991-08-16  |  2KB  |  72 lines
  1.         subroutine waccell(psi, linfac, source, omega)
  2.         use ellipdim
  3.         if (wbypass) return
  4.         werror = .false.
  5.       do 10001 i001 = 1, (  81 -1), 1
  6.       do 10000 i000 = 1, (  81 -1), 1
  7.       basis(i000,i001,1) = psi(i000,i001)
  8.       basis(i000,i001,2) = psi(i000,i001) - psialt(i000,i001,1)
  9.       basis(i000,i001,3) = psi(i000,i001) - 2*psialt(i000,i001,1) + psia
  10.      *lt(i000,i001,2)
  11.       basis(i000,i001,4) = 1
  12. 10000 continue
  13. 10001 continue
  14.       call periodic( mx, my,  basis1  )
  15.       call periodic( mx, my,  basis2  )
  16.       call periodic( mx, my,  basis3  )
  17.       call periodic( mx, my,  basis4  )
  18.       do 12500 i = 1, wdim
  19.       ii = i
  20.       do 12501 j = i, wdim
  21.       jj = j
  22.            call makematl(psi, linfac, source, omega, i, j)
  23. 12501 continue
  24. 12500 continue
  25.       do 12502 i = 1, wdim
  26.            wsource(i) = 0
  27.       do 10003 i001 = 1, (  81 -1), 1
  28.       do 10002 i000 = 1, (  81 -1), 1
  29.             wsource(i) = source(i000,i001)*basis(i000,i001,i) + wsource(
  30.      *i)
  31. 10002 continue
  32. 10003 continue
  33. 12502 continue
  34.         call linsys(wmatrix, wdim, wdim, wsource, wcoeff, ising, lfirst,
  35.      *              lprint, work)
  36.         if (ising .eq.  1) then
  37.            write(*,*) ' WARNING:  W_matrix is singular '
  38.            werror = .true.
  39.            return
  40.         endif
  41.       do 10005 i001 = 1, (  81 -1), 1
  42.       do 10004 i000 = 1, (  81 -1), 1
  43.          psi(i000,i001) = 0
  44. 10004 continue
  45. 10005 continue
  46.       do 12503 i = 1, wdim
  47.       do 10007 i001 = 1, (  81 -1), 1
  48.       do 10006 i000 = 1, (  81 -1), 1
  49.             psi(i000,i001) = psi(i000,i001) + wcoeff(i)*basis(i000,i001,
  50.      *i)
  51. 10006 continue
  52. 10007 continue
  53. 12503 continue
  54.       do 12504 i = 1, wdim
  55.            write(*,100) i, .5*wmatrix(i,i) - wsource(i),
  56.      *                  i, wcoeff(i)
  57. 12504 continue
  58.         action = 0
  59.       do 12505 i = 1, wdim
  60.       do 10008 i000 = 1, ( wdim ), 1
  61.             action = action + wmatrix(i,i000)*wcoeff(i)*wcoeff(i000)
  62. 10008 continue
  63. 12505 continue
  64.         action = action/2
  65.       do 10009 i000 = 1, ( wdim ), 1
  66.          action = action - wsource(i000)*wcoeff(i000)
  67. 10009 continue
  68.         write(*,*) ' new action = ',action
  69.         return
  70. 100     format(' action(',i1')= ',g16.9,'    w_coeff(',i1,')= ', g16.9)
  71.         end
  72.