examples/smpi/NAS/SP/tzetar.f

   1
   2 c---------------------------------------------------------------------
   3 c---------------------------------------------------------------------
   4
   5        subroutine  tzetar(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  t1, t2, t3, ac, xvel, yvel, zvel, r1, r2, r3,
  18      >                   r4, r5, btuz, acinv, ac2u, uzik1
  19
  20 c---------------------------------------------------------------------
  21 c      treat only one cell
  22 c---------------------------------------------------------------------
  23        do    k = start(3,c), cell_size(3,c)-end(3,c)-1
  24           do    j = start(2,c), cell_size(2,c)-end(2,c)-1
  25              do    i = start(1,c), cell_size(1,c)-end(1,c)-1
  26
  27                 xvel = us(i,j,k,c)
  28                 yvel = vs(i,j,k,c)
  29                 zvel = ws(i,j,k,c)
  30                 ac   = speed(i,j,k,c)
  31                 acinv = ainv(i,j,k,c)
  32
  33                 ac2u = ac*ac
  34
  35                 r1 = rhs(i,j,k,1,c)
  36                 r2 = rhs(i,j,k,2,c)
  37                 r3 = rhs(i,j,k,3,c)
  38                 r4 = rhs(i,j,k,4,c)
  39                 r5 = rhs(i,j,k,5,c)
  40
  41                 uzik1 = u(i,j,k,1,c)
  42                 btuz  = bt * uzik1
  43
  44                 t1 = btuz*acinv * (r4 + r5)
  45                 t2 = r3 + t1
  46                 t3 = btuz * (r4 - r5)
  47
  48                 rhs(i,j,k,1,c) = t2
  49                 rhs(i,j,k,2,c) = -uzik1*r2 + xvel*t2
  50                 rhs(i,j,k,3,c) =  uzik1*r1 + yvel*t2
  51                 rhs(i,j,k,4,c) =  zvel*t2  + t3
  52                 rhs(i,j,k,5,c) =  uzik1*(-xvel*r2 + yvel*r1) +
  53      >                    qs(i,j,k,c)*t2 + c2iv*ac2u*t1 + zvel*t3
  54
  55              end do
  56           end do
  57        end do
  58
  59        return
  60        end