examples/smpi/NAS/BT/error.f

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