examples/smpi/NAS/SP/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, nc, color
  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
  43       if (node .ge. nc*nc) then
  44          active = .false.
  45          color = 1
  46       else
  47          active = .true.
  48          color = 0
  49       end if
  50
  51       call mpi_comm_split(MPI_COMM_WORLD,color,node,comm_setup,error)
  52       if (.not. active) return
  53
  54       call mpi_comm_size(comm_setup, no_nodes, error)
  55       call mpi_comm_dup(comm_setup, comm_solve, error)
  56       call mpi_comm_dup(comm_setup, comm_rhs, error)
  57
  58 c---------------------------------------------------------------------
  59 c     let node 0 be the root for the group (there is only one)
  60 c---------------------------------------------------------------------
  61       root = 0
  62
  63       return
  64       end
  65