examples/smpi/NAS/SP/ninvr.f

   1
   2 c---------------------------------------------------------------------
   3 c---------------------------------------------------------------------
   4
   5        subroutine  ninvr(c)
   6
   7 c---------------------------------------------------------------------
   8 c---------------------------------------------------------------------
   9
  10 c---------------------------------------------------------------------
  11 c   block-diagonal matrix-vector multiplication
  12 c---------------------------------------------------------------------
  13
  14        include 'header.h'
  15
  16        integer  c,  i, j, k
  17        double precision r1, r2, r3, r4, r5, t1, t2
  18
  19 c---------------------------------------------------------------------
  20 c      treat only one cell
  21 c---------------------------------------------------------------------
  22        do k = start(3,c), cell_size(3,c)-end(3,c)-1
  23           do j = start(2,c), cell_size(2,c)-end(2,c)-1
  24              do i = start(1,c), cell_size(1,c)-end(1,c)-1
  25
  26                 r1 = rhs(i,j,k,1,c)
  27                 r2 = rhs(i,j,k,2,c)
  28                 r3 = rhs(i,j,k,3,c)
  29                 r4 = rhs(i,j,k,4,c)
  30                 r5 = rhs(i,j,k,5,c)
  31
  32                 t1 = bt * r3
  33                 t2 = 0.5d0 * ( r4 + r5 )
  34
  35                 rhs(i,j,k,1,c) = -r2
  36                 rhs(i,j,k,2,c) =  r1
  37                 rhs(i,j,k,3,c) = bt * ( r4 - r5 )
  38                 rhs(i,j,k,4,c) = -t1 + t2
  39                 rhs(i,j,k,5,c) =  t1 + t2
  40              enddo
  41           enddo
  42        enddo
  43
  44        return
  45        end