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       use mpi
  18       implicit none
  19
  20
  21       integer comm
  22       integer newtype
  23       integer me
  24       integer position
  25       integer type(5)
  26       integer length(5)
  27       integer (kind=MPI_ADDRESS_KIND) disp(5)
  28       integer bufsize
  29       integer errs, toterrs
  30       parameter (bufsize=100)
  31       character buf(bufsize)
  32       character name*(10)
  33       integer status(MPI_STATUS_SIZE)
  34       integer i, size
  35       double precision x
  36       integer src, dest
  37       integer ierr
  38
  39       errs = 0
  40 !     Enroll in MPI
  41       call mpi_init(ierr)
  42
  43 !     get my rank
  44       call mpi_comm_rank(MPI_COMM_WORLD, me, ierr)
  45       call mpi_comm_size(MPI_COMM_WORLD, size, ierr )
  46       if (size .lt. 2) then
  47          print *, "Must have at least 2 processes"
  48          call MPI_Abort( MPI_COMM_WORLD, 1, ierr )
  49          stop
  50       endif
  51
  52       comm = MPI_COMM_WORLD
  53       src = 0
  54       dest = 1
  55
  56       if(me.eq.src) then
  57           i=5
  58           x=5.1234d0
  59           name="Hello"
  60
  61           type(1)=MPI_CHARACTER
  62           length(1)=5
  63           call mpi_get_address(name,disp(1),ierr)
  64
  65           type(2)=MPI_DOUBLE_PRECISION
  66           length(2)=1
  67           call mpi_get_address(x,disp(2),ierr)
  68
  69           call mpi_type_create_struct(2,length,disp,type,newtype,ierr)
  70           call mpi_type_commit(newtype,ierr)
  71           call mpi_barrier( MPI_COMM_WORLD, ierr )
  72           call mpi_send(MPI_BOTTOM,1,newtype,dest,1,comm,ierr)
  73           call mpi_type_free(newtype,ierr)
  74 !         write(*,*) "Sent ",name(1:5),x
  75       else
  76 !         Everyone calls barrier incase size > 2
  77           call mpi_barrier( MPI_COMM_WORLD, ierr )
  78           if (me.eq.dest) then
  79              position=0
  80
  81              name = " "
  82              x    = 0.0d0
  83              call mpi_recv(buf,bufsize,MPI_PACKED, src,                    &
  84      &            1, comm, status, ierr)
  85
  86              call mpi_unpack(buf,bufsize,position,                         &
  87      &            name,5,MPI_CHARACTER, comm,ierr)
  88              call mpi_unpack(buf,bufsize,position,                         &
  89      &            x,1,MPI_DOUBLE_PRECISION, comm,ierr)
  90 !            Check the return values (/= is not-equal in F90)
  91              if (name /= "Hello") then
  92                 errs = errs + 1
  93                 print *, "Received ", name, " but expected Hello"
  94              endif
  95              if (abs(x-5.1234) .gt. 1.0e-6) then
  96                 errs = errs + 1
  97                 print *, "Received ", x, " but expected 5.1234"
  98              endif
  99           endif
 100       endif
 101 !
 102 !     Sum up errs and report the result
 103       call mpi_reduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, 0,         &
 104      &                 MPI_COMM_WORLD, ierr )
 105       if (me .eq. 0) then
 106          if (toterrs .eq. 0) then
 107             print *, " No Errors"
 108          else
 109             print *, " Found ", toterrs, " errors"
 110          endif
 111       endif
 112
 113       call mpi_finalize(ierr)
 114
 115       end