examples/smpi/NAS/SP/pinvr.f

   1
   2 c---------------------------------------------------------------------
   3 c---------------------------------------------------------------------
   4
   5        subroutine pinvr(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 i, j, k, c
  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 * r1
  33                 t2 = 0.5d0 * ( r4 + r5 )
  34
  35                 rhs(i,j,k,1,c) =  bt * ( r4 - r5 )
  36                 rhs(i,j,k,2,c) = -r3
  37                 rhs(i,j,k,3,c) =  r2
  38                 rhs(i,j,k,4,c) = -t1 + t2
  39                 rhs(i,j,k,5,c) =  t1 + t2
  40              end do
  41           end do
  42        end do
  43
  44        return
  45        end
  46
  47
  48