teshsuite/smpi/mpich-test/pt2pt/secondf.f

   1 C
   2 C    second - test program that sends an array of floats from the first process
   3 C             of a group to the last, using send and recv
   4 C
   5 C
   6       program main
   7       include 'mpif.h'
   8 C
   9       integer rank, size, to, from, tag, count, i, ierr
  10       integer src, dest
  11       integer st_source, st_tag, st_count
  12 C      MPI_Status status
  13       integer status(MPI_STATUS_SIZE)
  14       double precision data(100)
  15
  16       call MPI_INIT( ierr )
  17 C      print *, 'about to call comm rank'
  18       call MPI_COMM_RANK( MPI_COMM_WORLD, rank, ierr )
  19 C      print *, rank, 'about to call comm size'
  20       call MPI_COMM_SIZE( MPI_COMM_WORLD, size, ierr )
  21       print *, 'Process ', rank, ' of ', size, ' is alive'
  22 C
  23 C      src = size - 1
  24 C      dest = 0
  25       dest = size - 1
  26       src = 0
  27 C
  28       if (rank .eq. src) then
  29          to     = dest
  30          count  = 10
  31          tag    = 2001
  32          do 10 i=1, 10
  33             data(i) = i
  34  10      continue
  35          call MPI_SEND( data, count, MPI_DOUBLE_PRECISION, to, tag,
  36      &                  MPI_COMM_WORLD, ierr )
  37          print *, rank, ' sent'
  38          print *, (data(i),i=1,10)
  39       elseif (rank .eq. dest) then
  40          tag   = MPI_ANY_TAG
  41          count = 10
  42          from  = MPI_ANY_SOURCE
  43          call MPI_RECV(data, count, MPI_DOUBLE_PRECISION, from, tag,
  44      &                 MPI_COMM_WORLD, status, ierr )
  45
  46          call MPI_GET_COUNT( status, MPI_DOUBLE_PRECISION,
  47      &                       st_count, ierr )
  48          st_source = status(MPI_SOURCE)
  49          st_tag    = status(MPI_TAG)
  50 c
  51          print *, 'Status info: source = ', st_source,
  52      &             ' tag = ', st_tag, ' count = ', st_count
  53          print *, rank, ' received', (data(i),i=1,10)
  54       endif
  55
  56         call MPI_FINALIZE( ierr )
  57         print *, 'Process ', rank, ' exiting'
  58         end
  59