examples/smpi/NAS/BT/setup_mpi.f

   1
   2 c---------------------------------------------------------------------
   3 c---------------------------------------------------------------------
   4
   5       subroutine setup_mpi
   6
   7 c---------------------------------------------------------------------
   8 c---------------------------------------------------------------------
   9
  10 c---------------------------------------------------------------------
  11 c set up MPI stuff
  12 c---------------------------------------------------------------------
  13
  14       implicit none
  15       include 'mpinpb.h'
  16       include 'npbparams.h'
  17       integer error, color, nc
  18
  19       call mpi_init(error)
  20
  21       call mpi_comm_size(MPI_COMM_WORLD, total_nodes, error)
  22       call mpi_comm_rank(MPI_COMM_WORLD, node, error)
  23
  24       if (.not. convertdouble) then
  25          dp_type = MPI_DOUBLE_PRECISION
  26       else
  27          dp_type = MPI_REAL
  28       endif
  29
  30 c---------------------------------------------------------------------
  31 c     compute square root; add small number to allow for roundoff
  32 c---------------------------------------------------------------------
  33       nc = dint(dsqrt(dble(total_nodes) + 0.00001d0))
  34
  35 c---------------------------------------------------------------------
  36 c We handle a non-square number of nodes by making the excess nodes
  37 c inactive. However, we can never handle more cells than were compiled
  38 c in.
  39 c---------------------------------------------------------------------
  40
  41       if (nc .gt. maxcells) nc = maxcells
  42       if (node .ge. nc*nc) then
  43          active = .false.
  44          color = 1
  45       else
  46          active = .true.
  47          color = 0
  48       end if
  49
  50       call mpi_comm_split(MPI_COMM_WORLD,color,node,comm_setup,error)
  51       if (.not. active) return
  52
  53       call mpi_comm_size(comm_setup, no_nodes, error)
  54       call mpi_comm_dup(comm_setup, comm_solve, error)
  55       call mpi_comm_dup(comm_setup, comm_rhs, error)
  56
  57 c---------------------------------------------------------------------
  58 c     let node 0 be the root for the group (there is only one)
  59 c---------------------------------------------------------------------
  60       root = 0
  61
  62       return
  63       end
  64