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

   1 ! -*- Mode: Fortran; -*-
   2 !
   3 !  (C) 2011 by Argonne National Laboratory.
   4 !      See COPYRIGHT in top-level directory.
   5 !
   6 ! This program tests that all of the integer kinds defined in MPI 2.2 are
   7 ! available.
   8 !
   9   program main
  10   use mpi
  11   integer (kind=MPI_ADDRESS_KIND) aint, taint
  12   integer (kind=MPI_OFFSET_KIND) oint, toint
  13   integer (kind=MPI_INTEGER_KIND) iint, tiint
  14   integer s(MPI_STATUS_SIZE)
  15   integer i, wsize, wrank, ierr, errs
  16 !
  17   errs = 0
  18 !
  19   call MTEST_INIT(ierr)
  20   call MPI_COMM_SIZE(MPI_COMM_WORLD,wsize,ierr)
  21   call MPI_COMM_RANK(MPI_COMM_WORLD,wrank,ierr)
  22   if (wsize .lt. 2) then
  23      print *, "This test requires at least 2 processes"
  24      call MPI_ABORT( MPI_COMM_WORLD, 1, ierr )
  25   endif
  26 !
  27 ! Some compilers (e.g., gfortran) will issue an error if, at compile time,
  28 ! an assignment would cause overflow, even if appropriated guarded.  To
  29 ! avoid this problem, we must compute the value in the integer (the
  30 ! code here is simple; there are faster fixes for this but this is easy
  31   if (wrank .eq. 0) then
  32      if (range(aint) .ge. 10) then
  33         aint = 1
  34         do i=1, range(aint)-1
  35            aint = aint * 10
  36         enddo
  37         aint = aint - 1
  38      else
  39         aint = 12345678
  40      endif
  41      if (range(oint) .ge. 10) then
  42         oint = 1
  43         do i=1, range(oint)-1
  44            oint = oint * 10
  45         enddo
  46         oint = oint - 1
  47      else
  48         oint = 12345678
  49      endif
  50      if (range(iint) .ge. 10) then
  51         iint = 1
  52         do i=1, range(iint)-1
  53            iint = iint * 10
  54         enddo
  55         iint = iint - 1
  56      else
  57         iint = 12345678
  58      endif
  59      call MPI_SEND( aint, 1, MPI_AINT, 1, 0, MPI_COMM_WORLD, ierr )
  60      call MPI_SEND( oint, 1, MPI_OFFSET, 1, 1, MPI_COMM_WORLD, ierr )
  61      call MPI_SEND( iint, 1, MPI_INTEGER, 1, 2, MPI_COMM_WORLD, ierr )
  62 !
  63   else if (wrank .eq. 1) then
  64      if (range(taint) .ge. 10) then
  65         taint = 1
  66         do i=1, range(taint)-1
  67            taint = taint * 10
  68         enddo
  69         taint = taint - 1
  70      else
  71         taint = 12345678
  72      endif
  73      if (range(toint) .ge. 10) then
  74         toint = 1
  75         do i=1, range(toint)-1
  76            toint = toint * 10
  77         enddo
  78         toint = toint - 1
  79      else
  80         toint = 12345678
  81      endif
  82      if (range(tiint) .ge. 10) then
  83         tiint = 1
  84         do i=1, range(tiint)-1
  85            tiint = tiint * 10
  86         enddo
  87         tiint = tiint - 1
  88      else
  89         tiint = 12345678
  90      endif
  91      call MPI_RECV( aint, 1, MPI_AINT, 0, 0, MPI_COMM_WORLD, s, ierr )
  92      if (taint .ne. aint) then
  93         print *, "Address-sized int not correctly transferred"
  94         print *, "Value should be ", taint, " but is ", aint
  95         errs = errs + 1
  96      endif
  97      call MPI_RECV( oint, 1, MPI_OFFSET, 0, 1, MPI_COMM_WORLD, s, ierr )
  98      if (toint .ne. oint) then
  99         print *, "Offset-sized int not correctly transferred"
 100         print *, "Value should be ", toint, " but is ", oint
 101         errs = errs + 1
 102      endif
 103      call MPI_RECV( iint, 1, MPI_INTEGER, 0, 2, MPI_COMM_WORLD, s, ierr )
 104      if (tiint .ne. iint) then
 105         print *, "Integer (by kind) not correctly transferred"
 106         print *, "Value should be ", tiint, " but is ", iint
 107         errs = errs + 1
 108      endif
 109 !
 110   endif
 111 !
 112   call MTEST_FINALIZE(errs)
 113   call MPI_FINALIZE(ierr)
 114
 115   end