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

   1 C Thanks to
   2 C William R. Magro
   3 C for this test
   4 C
   5 C It has been modifiedly slightly to work with the automated MPI
   6 C tests.
   7 C  WDG.
   8 C
   9       program bustit
  10       implicit none
  11
  12       include 'mpif.h'
  13
  14       integer ierr
  15       integer comm
  16       integer newtype
  17       integer me
  18       integer position
  19       integer type(5)
  20       integer length(5)
  21       integer disp(5)
  22       integer bufsize
  23       parameter (bufsize=100)
  24       character buf(bufsize)
  25       character name*(10)
  26       integer status(MPI_STATUS_SIZE)
  27       integer i, size
  28       double precision x
  29       integer src, dest
  30
  31 C     Enroll in MPI
  32       call mpi_init(ierr)
  33
  34 C     get my rank
  35       call mpi_comm_rank(MPI_COMM_WORLD, me, ierr)
  36       call mpi_comm_size(MPI_COMM_WORLD, size, ierr )
  37       if (size .lt. 2) then
  38          print *, "Must have at least 2 processes"
  39          call MPI_Abort( 1, MPI_COMM_WORLD, ierr )
  40       endif
  41
  42       comm = MPI_COMM_WORLD
  43       src = 0
  44       dest = 1
  45
  46       if(me.eq.src) then
  47           i=5
  48           x=5.1234d0
  49           name="hello"
  50
  51           type(1)=MPI_CHARACTER
  52           length(1)=5
  53           call mpi_address(name,disp(1),ierr)
  54
  55           type(2)=MPI_DOUBLE_PRECISION
  56           length(2)=1
  57           call mpi_address(x,disp(2),ierr)
  58
  59           call mpi_type_struct(2,length,disp,type,newtype,ierr)
  60           call mpi_type_commit(newtype,ierr)
  61           call mpi_barrier( MPI_COMM_WORLD, ierr )
  62           call mpi_send(MPI_BOTTOM,1,newtype,dest,1,comm,ierr)
  63           call mpi_type_free(newtype,ierr)
  64 C         write(*,*) "Sent ",name(1:5),x
  65       else
  66 C         Everyone calls barrier incase size > 2
  67           call mpi_barrier( MPI_COMM_WORLD, ierr )
  68           if (me.eq.dest) then
  69              position=0
  70
  71              name = " "
  72              x    = 0.0d0
  73              call mpi_recv(buf,bufsize,MPI_PACKED, src,
  74      .            1, comm, status, ierr)
  75
  76              call mpi_unpack(buf,bufsize,position,
  77      .            name,5,MPI_CHARACTER, comm,ierr)
  78              call mpi_unpack(buf,bufsize,position,
  79      .            x,1,MPI_DOUBLE_PRECISION, comm,ierr)
  80              print 1, name, x
  81  1           format( " Received ", a, f7.4 )
  82           endif
  83       endif
  84
  85       call mpi_finalize(ierr)
  86
  87       end