examples/smpi/NAS/SP/error.f

   1
   2 c---------------------------------------------------------------------
   3 c---------------------------------------------------------------------
   4
   5        subroutine error_norm(rms)
   6
   7 c---------------------------------------------------------------------
   8 c---------------------------------------------------------------------
   9
  10 c---------------------------------------------------------------------
  11 c this function computes the norm of the difference between the
  12 c computed solution and the exact solution
  13 c---------------------------------------------------------------------
  14
  15        include 'header.h'
  16        include 'mpinpb.h'
  17
  18        integer c, i, j, k, m, ii, jj, kk, d, error
  19        double precision xi, eta, zeta, u_exact(5), rms(5), rms_work(5),
  20      >                  add
  21
  22        do   m = 1, 5
  23           rms_work(m) = 0.0d0
  24        end do
  25
  26        do   c = 1, ncells
  27           kk = 0
  28           do   k = cell_low(3,c), cell_high(3,c)
  29              zeta = dble(k) * dnzm1
  30              jj = 0
  31              do   j = cell_low(2,c), cell_high(2,c)
  32                 eta = dble(j) * dnym1
  33                 ii = 0
  34                 do   i = cell_low(1,c), cell_high(1,c)
  35                    xi = dble(i) * dnxm1
  36                    call exact_solution(xi, eta, zeta, u_exact)
  37
  38                    do   m = 1, 5
  39                       add = u(ii,jj,kk,m,c)-u_exact(m)
  40                       rms_work(m) = rms_work(m) + add*add
  41                    end do
  42                    ii = ii + 1
  43                 end do
  44                 jj = jj + 1
  45              end do
  46              kk = kk + 1
  47           end do
  48        end do
  49
  50        call mpi_allreduce(rms_work, rms, 5, dp_type,
  51      >                 MPI_SUM, comm_setup, error)
  52
  53        do    m = 1, 5
  54           do    d = 1, 3
  55              rms(m) = rms(m) / dble(grid_points(d)-2)
  56           end do
  57           rms(m) = dsqrt(rms(m))
  58        end do
  59
  60        return
  61        end
  62
  63
  64
  65        subroutine rhs_norm(rms)
  66
  67        include 'header.h'
  68        include 'mpinpb.h'
  69
  70        integer c, i, j, k, d, m, error
  71        double precision rms(5), rms_work(5), add
  72
  73        do    m = 1, 5
  74           rms_work(m) = 0.0d0
  75        end do
  76
  77        do   c = 1, ncells
  78           do   k = start(3,c), cell_size(3,c)-end(3,c)-1
  79              do   j = start(2,c), cell_size(2,c)-end(2,c)-1
  80                 do   i = start(1,c), cell_size(1,c)-end(1,c)-1
  81                    do   m = 1, 5
  82                       add = rhs(i,j,k,m,c)
  83                       rms_work(m) = rms_work(m) + add*add
  84                    end do
  85                 end do
  86              end do
  87           end do
  88        end do
  89
  90
  91
  92        call mpi_allreduce(rms_work, rms, 5, dp_type,
  93      >                 MPI_SUM, comm_setup, error)
  94
  95        do   m = 1, 5
  96           do   d = 1, 3
  97              rms(m) = rms(m) / dble(grid_points(d)-2)
  98           end do
  99           rms(m) = dsqrt(rms(m))
 100        end do
 101
 102        return
 103        end
 104
 105