teshsuite/smpi/mpich3-test/f90/datatype/structf.f90

   1 !
   2 !  (C) 2004 by Argonne National Laboratory.
   3 !      See COPYRIGHT in top-level directory.
   4 !
   5 ! Thanks to
   6 ! William R. Magro
   7 ! for this test
   8 !
   9 ! It has been modifiedly slightly to work with the automated MPI
  10 ! tests.
  11 !  WDG.
  12 !
  13 ! It was further modified to use MPI_Get_address instead of MPI_Address
  14 ! for MPICH, and to fit in the MPICH test harness - WDG
  15 !
  16       program bustit
  17       implicit none
  18       use mpi
  19
  20       integer comm
  21       integer newtype
  22       integer me
  23       integer position
  24       integer type(5)
  25       integer length(5)
  26       integer (kind=MPI_ADDRESS_KIND) disp(5)
  27       integer bufsize
  28       integer errs, toterrs
  29       parameter (bufsize=100)
  30       character buf(bufsize)
  31       character name*(10)
  32       integer status(MPI_STATUS_SIZE)
  33       integer i, size
  34       double precision x
  35       integer src, dest
  36       integer ierr
  37
  38       errs = 0
  39 !     Enroll in MPI
  40       call mpi_init(ierr)
  41
  42 !     get my rank
  43       call mpi_comm_rank(MPI_COMM_WORLD, me, ierr)
  44       call mpi_comm_size(MPI_COMM_WORLD, size, ierr )
  45       if (size .lt. 2) then
  46          print *, "Must have at least 2 processes"
  47          call MPI_Abort( 1, MPI_COMM_WORLD, ierr )
  48          stop
  49       endif
  50
  51       comm = MPI_COMM_WORLD
  52       src = 0
  53       dest = 1
  54
  55       if(me.eq.src) then
  56           i=5
  57           x=5.1234d0
  58           name="Hello"
  59
  60           type(1)=MPI_CHARACTER
  61           length(1)=5
  62           call mpi_get_address(name,disp(1),ierr)
  63
  64           type(2)=MPI_DOUBLE_PRECISION
  65           length(2)=1
  66           call mpi_get_address(x,disp(2),ierr)
  67
  68           call mpi_type_create_struct(2,length,disp,type,newtype,ierr)
  69           call mpi_type_commit(newtype,ierr)
  70           call mpi_barrier( MPI_COMM_WORLD, ierr )
  71           call mpi_send(MPI_BOTTOM,1,newtype,dest,1,comm,ierr)
  72           call mpi_type_free(newtype,ierr)
  73 !         write(*,*) "Sent ",name(1:5),x
  74       else
  75 !         Everyone calls barrier incase size > 2
  76           call mpi_barrier( MPI_COMM_WORLD, ierr )
  77           if (me.eq.dest) then
  78              position=0
  79
  80              name = " "
  81              x    = 0.0d0
  82              call mpi_recv(buf,bufsize,MPI_PACKED, src,                    &
  83      &            1, comm, status, ierr)
  84
  85              call mpi_unpack(buf,bufsize,position,                         &
  86      &            name,5,MPI_CHARACTER, comm,ierr)
  87              call mpi_unpack(buf,bufsize,position,                         &
  88      &            x,1,MPI_DOUBLE_PRECISION, comm,ierr)
  89 !            Check the return values (/= is not-equal in F90)
  90              if (name /= "Hello") then
  91                 errs = errs + 1
  92                 print *, "Received ", name, " but expected Hello"
  93              endif
  94              if (abs(x-5.1234) .gt. 1.0e-6) then
  95                 errs = errs + 1
  96                 print *, "Received ", x, " but expected 5.1234"
  97              endif
  98           endif
  99       endif
 100 !
 101 !     Sum up errs and report the result
 102       call mpi_reduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, 0,         &
 103      &                 MPI_COMM_WORLD, ierr )
 104       if (me .eq. 0) then
 105          if (toterrs .eq. 0) then
 106             print *, " No Errors"
 107          else
 108             print *, " Found ", toterrs, " errors"
 109          endif
 110       endif
 111
 112       call mpi_finalize(ierr)
 113
 114       end