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       endif
  49
  50       comm = MPI_COMM_WORLD
  51       src = 0
  52       dest = 1
  53
  54       if(me.eq.src) then
  55           i=5
  56           x=5.1234d0
  57           name="Hello"
  58
  59           type(1)=MPI_CHARACTER
  60           length(1)=5
  61           call mpi_get_address(name,disp(1),ierr)
  62
  63           type(2)=MPI_DOUBLE_PRECISION
  64           length(2)=1
  65           call mpi_get_address(x,disp(2),ierr)
  66
  67           call mpi_type_create_struct(2,length,disp,type,newtype,ierr)
  68           call mpi_type_commit(newtype,ierr)
  69           call mpi_barrier( MPI_COMM_WORLD, ierr )
  70           call mpi_send(MPI_BOTTOM,1,newtype,dest,1,comm,ierr)
  71           call mpi_type_free(newtype,ierr)
  72 !         write(*,*) "Sent ",name(1:5),x
  73       else
  74 !         Everyone calls barrier incase size > 2
  75           call mpi_barrier( MPI_COMM_WORLD, ierr )
  76           if (me.eq.dest) then
  77              position=0
  78
  79              name = " "
  80              x    = 0.0d0
  81              call mpi_recv(buf,bufsize,MPI_PACKED, src,                    &
  82      &            1, comm, status, ierr)
  83
  84              call mpi_unpack(buf,bufsize,position,                         &
  85      &            name,5,MPI_CHARACTER, comm,ierr)
  86              call mpi_unpack(buf,bufsize,position,                         &
  87      &            x,1,MPI_DOUBLE_PRECISION, comm,ierr)
  88 !            Check the return values (/= is not-equal in F90)
  89              if (name /= "Hello") then
  90                 errs = errs + 1
  91                 print *, "Received ", name, " but expected Hello"
  92              endif
  93              if (abs(x-5.1234) .gt. 1.0e-6) then
  94                 errs = errs + 1
  95                 print *, "Received ", x, " but expected 5.1234"
  96              endif
  97           endif
  98       endif
  99 !
 100 !     Sum up errs and report the result
 101       call mpi_reduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, 0,         &
 102      &                 MPI_COMM_WORLD, ierr )
 103       if (me .eq. 0) then
 104          if (toterrs .eq. 0) then
 105             print *, " No Errors"
 106          else
 107             print *, " Found ", toterrs, " errors"
 108          endif
 109       endif
 110
 111       call mpi_finalize(ierr)
 112
 113       end