Commit cfa1fa4b authored by Junchao Zhang's avatar Junchao Zhang
Browse files

Ported more F90 tests to F08

The new tests include: io, spawn, topo, timer, profile, ext, info, init and misc

No review since F08 binding is experimental now.
parent eb8837de
......@@ -1545,17 +1545,26 @@ AC_OUTPUT(maint/testmerge \
f90/ext/testlist \
f90/io/Makefile \
f90/misc/Makefile \
f90/profile/Makefile \
f90/profile/Makefile \
f08/Makefile \
f08/util/Makefile \
f08/pt2pt/Makefile \
f08/coll/Makefile \
f08/datatype/Makefile \
f08/attr/Makefile \
f08/comm/Makefile \
f08/rma/Makefile \
f08/subarray/Makefile \
cxx/Makefile \
f08/attr/Makefile \
f08/datatype/Makefile \
f08/util/Makefile \
f08/coll/Makefile \
f08/comm/Makefile \
f08/pt2pt/Makefile \
f08/rma/Makefile \
f08/subarray/Makefile \
f08/topo/Makefile \
f08/io/Makefile \
f08/init/Makefile \
f08/info/Makefile \
f08/spawn/Makefile \
f08/timer/Makefile \
f08/ext/Makefile \
f08/misc/Makefile \
f08/profile/Makefile \
cxx/Makefile \
cxx/util/Makefile \
cxx/attr/Makefile \
cxx/pt2pt/Makefile \
......
# -*- Mode: Makefile; -*-
# vim: set ft=automake :
#
# (C) 2014 by Argonne National Laboratory.
# See COPYRIGHT in top-level directory.
#
include $(top_srcdir)/Makefile_f08.mtest
EXTRA_DIST = testlist.in
# allocmemf is an "extra" program because it requires a Fortran extension
EXTRA_PROGRAMS = allocmemf90
noinst_PROGRAMS = c2f2cf90 ctypesinf90 c2f90mult
allocmemf90_SOURCES = allocmemf90.f90
c2f2cf90_SOURCES = c2f2cf90.f90 c2f902c.c
ctypesinf90_SOURCES = ctypesinf90.f90 ctypesfromc.c
# C programs get a different mtest utility object
c2f90mult_LDADD = $(top_builddir)/util/mtest.o
c2f90mult_SOURCES = c2f90mult.c
## add1size.h will be distributed because it's listed in AC_CONFIG_FILES/AC_OUTPUT
# ensure that dependent tests will be rebuilt when add1size.h is updated
# we don't get this from Makefile_f90.mtest and we don't include Makefile.mtest
$(top_builddir)/util/mtest.o:
(cd $(top_builddir)/util && $(MAKE) mtest.o)
BUILT_SOURCES = c2f902c.c ctypesfromc.c
# FIXME what's up with these rules? They appear to copy a file to itself in
# non-VPATH builds...
c2f902c.c: $(srcdir)/../../f90/ext/c2f902c.c
cp $(srcdir)/../../f90/ext/c2f902c.c c2f902c.c
ctypesfromc.c: $(srcdir)/../../f77/ext/ctypesfromc.c
cp $(srcdir)/../../f77/ext/ctypesfromc.c ctypesfromc.c
! -*- Mode: Fortran; -*-
!
! (C) 2014 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
program main
use mpi_f08
use, intrinsic :: iso_c_binding
real, pointer :: a(:,:)
integer (kind=MPI_ADDRESS_KIND) asize
type(c_ptr) cptr
integer ierr, sizeofreal, errs
integer i,j
!
errs = 0
call mtest_init(ierr)
call mpi_type_size( MPI_REAL, sizeofreal, ierr )
! Make sure we pass in an integer of the correct type
asize = sizeofreal * 100 * 100
call mpi_alloc_mem( asize,MPI_INFO_NULL,cptr,ierr )
call c_f_pointer(cptr, a, [100, 100])
do i=1,100
do j=1,100
a(i,j) = -1
enddo
enddo
a(3,5) = 10.0
call mpi_free_mem( a, ierr )
call mtest_finalize(errs)
call mpi_finalize(ierr)
end
! -*- Mode: Fortran; -*-
!
! (C) 2014 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
program main
use mpi_f08
integer errs, toterrs, ierr
integer wrank, wsize
type(MPI_Group) wgroup
type(MPI_Info) info
type(MPI_Request) req
integer fsize, frank
!integer comm, group, type, op, errh, result
type(MPI_Comm) comm
type(MPI_Group) group
type(MPI_Datatype) type
type(MPI_Op) op
type(MPI_Errhandler) errh
integer result
integer c2fcomm, c2fgroup, c2ftype, c2finfo, c2frequest, &
& c2ferrhandler, c2fop
character value*100
logical flag
errs = 0
call mpi_init( ierr )
!
! Test passing a Fortran MPI object to C
call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
errs = errs + c2fcomm( MPI_COMM_WORLD%MPI_VAL)
call mpi_comm_group( MPI_COMM_WORLD, wgroup, ierr )
errs = errs + c2fgroup( wgroup%MPI_VAL )
call mpi_group_free( wgroup, ierr )
call mpi_info_create( info, ierr )
call mpi_info_set( info, "host", "myname", ierr )
call mpi_info_set( info, "wdir", "/rdir/foo", ierr )
errs = errs + c2finfo( info%MPI_VAL )
call mpi_info_free( info, ierr )
errs = errs + c2ftype( MPI_INTEGER%MPI_VAL )
call mpi_irecv( 0, 0, MPI_INTEGER, MPI_ANY_SOURCE, MPI_ANY_TAG, &
& MPI_COMM_WORLD, req, ierr )
call mpi_cancel( req, ierr )
errs = errs + c2frequest( req%MPI_VAL )
call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
errs = errs + c2ferrhandler( MPI_ERRORS_RETURN%MPI_VAL )
errs = errs + c2fop( MPI_SUM%MPI_VAL )
!
! Test using a C routine to provide the Fortran handle
call mpi_comm_size( MPI_COMM_WORLD, wsize, ierr )
call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
call f2ccomm( comm )
call mpi_comm_size( comm, fsize, ierr )
call mpi_comm_rank( comm, frank, ierr )
if (fsize.ne.wsize .or. frank.ne.wrank) then
errs = errs + 1
print *, "Comm(fortran) has wrong size or rank"
endif
call f2cgroup( group )
call mpi_group_size( group, fsize, ierr )
call mpi_group_rank( group, frank, ierr )
if (fsize.ne.wsize .or. frank.ne.wrank) then
errs = errs + 1
print *, "Group(fortran) has wrong size or rank"
endif
call mpi_group_free( group, ierr )
call f2ctype( type )
if (type .ne. MPI_INTEGER) then
errs = errs + 1
print *, "Datatype(fortran) is not MPI_INT"
endif
call f2cinfo( info )
call mpi_info_get( info, "host", 100, value, flag, ierr )
if (.not. flag) then
errs = errs + 1
print *, "Info test for host returned false"
else if (value .ne. "myname") then
errs = errs + 1
print *, "Info test for host returned ", value
endif
call mpi_info_get( info, "wdir", 100, value, flag, ierr )
if (.not. flag) then
errs = errs + 1
print *, "Info test for wdir returned false"
else if (value .ne. "/rdir/foo") then
errs = errs + 1
print *, "Info test for wdir returned ", value
endif
call mpi_info_free( info, ierr )
call f2cop( op )
if (op .ne. MPI_SUM) then
errs = errs + 1
print *, "Fortran MPI_SUM not MPI_SUM in C"
endif
call f2cerrhandler( errh )
if (errh .ne. MPI_ERRORS_RETURN) then
errs = errs + 1
print *,"Fortran MPI_ERRORS_RETURN not MPI_ERRORS_RETURN in C"
endif
!
! Summarize the errors
!
call mpi_allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM, &
& MPI_COMM_WORLD, ierr )
if (wrank .eq. 0) then
if (toterrs .eq. 0) then
print *, ' No Errors'
else
print *, ' Found ', toterrs, ' errors'
endif
endif
call mpi_finalize( ierr )
end
/* This file created from test/mpi/f77/ext/c2fmult.c with f77tof90 */
/* -*- Mode: C; c-basic-offset:4 ; indent-tabs-mode:nil ; -*- */
/*
* (C) 2001 by Argonne National Laboratory.
* See COPYRIGHT in top-level directory.
*/
/*
Check that MPI_xxxx_c2f, applied to the same object several times,
yields the same handle. We do this because when MPI handles in
C are a different length than those in Fortran, care needs to
be exercised to ensure that the mapping from one to another is unique.
(Test added to test a potential problem in ROMIO for handling MPI_File
on 64-bit systems)
*/
#include "mpi.h"
#include <stdio.h>
#include "mpitest.h"
int main( int argc, char *argv[] )
{
MPI_Fint handleA, handleB;
int rc;
int errs = 0;
int buf[1];
MPI_Request cRequest;
MPI_Status st;
int tFlag;
MTest_Init( &argc, &argv );
/* Request */
rc = MPI_Irecv( buf, 1, MPI_INT, 0, 0, MPI_COMM_WORLD, &cRequest );
if (rc) {
errs++;
printf( "Unable to create request\n" );
}
else {
handleA = MPI_Request_c2f( cRequest );
handleB = MPI_Request_c2f( cRequest );
if (handleA != handleB) {
errs++;
printf( "MPI_Request_c2f does not give the same handle twice on the same MPI_Request\n" );
}
}
MPI_Cancel( &cRequest );
MPI_Test( &cRequest, &tFlag, &st );
MPI_Test_cancelled( &st, &tFlag );
if (!tFlag) {
errs++;
printf( "Unable to cancel MPI_Irecv request\n" );
}
/* Using MPI_Request_free should be ok, but some MPI implementations
object to it imediately after the cancel and that isn't essential to
this test */
MTest_Finalize( errs );
MPI_Finalize();
return 0;
}
! -*- Mode: Fortran; -*-
!
! (C) 2014 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
program main
use mpi_f08
integer ierr
integer errs, wrank
integer f2ctype
!
call mtest_init( ierr )
call mpi_comm_rank( MPI_COMM_WORLD, wrank, ierr )
!
errs = 0
!
errs = errs + f2ctype( MPI_CHAR, 0 )
errs = errs + f2ctype( MPI_SIGNED_CHAR, 1 )
errs = errs + f2ctype( MPI_UNSIGNED_CHAR, 2 )
errs = errs + f2ctype( MPI_WCHAR, 3 )
errs = errs + f2ctype( MPI_SHORT, 4 )
errs = errs + f2ctype( MPI_UNSIGNED_SHORT, 5 )
errs = errs + f2ctype( MPI_INT, 6 )
errs = errs + f2ctype( MPI_UNSIGNED, 7 )
errs = errs + f2ctype( MPI_LONG, 8 )
errs = errs + f2ctype( MPI_UNSIGNED_LONG, 9 )
errs = errs + f2ctype( MPI_FLOAT, 10 )
errs = errs + f2ctype( MPI_DOUBLE, 11 )
errs = errs + f2ctype( MPI_FLOAT_INT, 12 )
errs = errs + f2ctype( MPI_DOUBLE_INT, 13 )
errs = errs + f2ctype( MPI_LONG_INT, 14 )
errs = errs + f2ctype( MPI_SHORT_INT, 15 )
errs = errs + f2ctype( MPI_2INT, 16 )
if (MPI_LONG_DOUBLE .ne. MPI_TYPE_NULL) then
errs = errs + f2ctype( MPI_LONG_DOUBLE, 17 )
errs = errs + f2ctype( MPI_LONG_DOUBLE_INT, 21 )
endif
if (MPI_LONG_LONG .ne. MPI_TYPE_NULL) then
errs = errs + f2ctype( MPI_LONG_LONG_INT, 18 )
errs = errs + f2ctype( MPI_LONG_LONG, 19 )
errs = errs + f2ctype( MPI_UNSIGNED_LONG_LONG, 20 )
endif
!
! Summarize the errors
!
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
c2f2cf90 1
c2f90mult 1
ctypesinf90 1
allocmemf90 1
# -*- Mode: Makefile; -*-
# vim: set ft=automake :
#
# (C) 2014 by Argonne National Laboratory.
# See COPYRIGHT in top-level directory.
#
include $(top_srcdir)/Makefile_f08.mtest
EXTRA_DIST = testlist
# avoid having to write many "foo_SOURCES = foo.f90" lines
AM_DEFAULT_SOURCE_EXT = .f90
noinst_PROGRAMS = infotestf90 infotest2f90
! -*- Mode: Fortran; -*-
!
! (C) 2014 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
program main
use mpi_f08
integer ierr, errs
type(MPI_Info) i1, i2
integer nkeys, i, j, sumindex, vlen, ln, valuelen
logical found, flag
character*(MPI_MAX_INFO_KEY) keys(6)
character*(MPI_MAX_INFO_VAL) values(6)
character*(MPI_MAX_INFO_KEY) mykey
character*(MPI_MAX_INFO_VAL) myvalue
!
data keys/"Key1", "key2", "KeY3", "A Key With Blanks","See Below", &
& "last"/
data values/"value 1", "value 2", "VaLue 3", "key=valu:3","false", &
& "no test"/
!
errs = 0
call mtest_init( ierr )
! Note that the MPI standard requires that leading an trailing blanks
! are stripped from keys and values (Section 4.10, The Info Object)
!
! First, create and initialize an info
call mpi_info_create( i1, ierr )
call mpi_info_set( i1, keys(1), values(1), ierr )
call mpi_info_set( i1, keys(2), values(2), ierr )
call mpi_info_set( i1, keys(3), values(3), ierr )
call mpi_info_set( i1, keys(4), values(4), ierr )
call mpi_info_set( i1, " See Below", values(5), ierr )
call mpi_info_set( i1, keys(6), " no test ", ierr )
!
call mpi_info_get_nkeys( i1, nkeys, ierr )
if (nkeys .ne. 6) then
print *, ' Number of keys should be 6, is ', nkeys
endif
sumindex = 0
do i=1, nkeys
! keys are number from 0 to n-1, even in Fortran (Section 4.10)
call mpi_info_get_nthkey( i1, i-1, mykey, ierr )
found = .false.
do j=1, 6
if (mykey .eq. keys(j)) then
found = .true.
sumindex = sumindex + j
call mpi_info_get_valuelen( i1, mykey, vlen, flag, ierr )
if (.not.flag) then
errs = errs + 1
print *, ' no value for key', mykey
else
call mpi_info_get( i1, mykey, MPI_MAX_INFO_VAL, &
& myvalue, flag, ierr )
if (myvalue .ne. values(j)) then
errs = errs + 1
print *, ' Value for ', mykey, ' not expected'
else
do ln=MPI_MAX_INFO_VAL,1,-1
if (myvalue(ln:ln) .ne. ' ') then
if (vlen .ne. ln) then
errs = errs + 1
print *, ' length is ', ln, &
& ' but valuelen gave ', vlen, &
& ' for key ', mykey
endif
goto 100
endif
enddo
100 continue
endif
endif
endif
enddo
if (.not.found) then
print *, i, 'th key ', mykey, ' not in list'
endif
enddo
if (sumindex .ne. 21) then
errs = errs + 1
print *, ' Not all keys found'
endif
!
! delete 2, then dup, then delete 2 more
call mpi_info_delete( i1, keys(1), ierr )
call mpi_info_delete( i1, keys(2), ierr )
call mpi_info_dup( i1, i2, ierr )
call mpi_info_delete( i1, keys(3), ierr )
!
! check the contents of i2
! valuelen does not signal an error for unknown keys; instead, sets
! flag to false
do i=1,2
flag = .true.
call mpi_info_get_valuelen( i2, keys(i), valuelen, flag, ierr )
if (flag) then
errs = errs + 1
print *, ' Found unexpected key ', keys(i)
endif
myvalue = 'A test'
call mpi_info_get( i2, keys(i), MPI_MAX_INFO_VAL, &
& myvalue, flag, ierr )
if (flag) then
errs = errs + 1
print *, ' Found unexpected key in MPI_Info_get ', keys(i)
else
if (myvalue .ne. 'A test') then
errs = errs + 1
print *, ' Returned value overwritten, is now ', myvalue
endif
endif
enddo
do i=3,6
myvalue = ' '
call mpi_info_get( i2, keys(i), MPI_MAX_INFO_VAL, &
& myvalue, flag, ierr )
if (.not. flag) then
errs = errs + 1
print *, ' Did not find key ', keys(i)
else
if (myvalue .ne. values(i)) then
errs = errs + 1
print *, ' Found wrong value (', myvalue, ') for key ', &
& keys(i)
endif
endif
enddo
!
! Free info
call mpi_info_free( i1, ierr )
call mpi_info_free( i2, ierr )
call mtest_finalize( errs )
call mpi_finalize( ierr )
end
! -*- Mode: Fortran; -*-
!
! (C) 2014 by Argonne National Laboratory.
! See COPYRIGHT in top-level directory.
!
! Simple info test
program main
use mpi_f08
type(MPI_Info) i1, i2
integer i, errs, ierr
integer valuelen
parameter (valuelen=64)
character*(valuelen) value
logical flag
!
errs = 0
call MTest_Init( ierr )
call mpi_info_create( i1, ierr )
call mpi_info_create( i2, ierr )
call mpi_info_set( i1, "key1", "value1", ierr )
call mpi_info_set( i2, "key2", "value2", ierr )
call mpi_info_get( i1, "key2", valuelen, value, flag, ierr )
if (flag) then
print *, "Found key2 in info1"
errs = errs + 1
endif
call MPI_Info_get( i1, "key1", 64, value, flag, ierr )
if (.not. flag ) then
print *, "Did not find key1 in info1"
errs = errs + 1
else
if (value .ne. "value1") then
print *, "Found wrong value (", value, "), expected value1"
errs = errs + 1
else
! check for trailing blanks
do i=7,valuelen
if (value(i:i) .ne. " ") then
print *, "Found non blank in info value"
errs = errs + 1
endif
enddo
endif
endif
call mpi_info_free( i1, ierr )
call mpi_info_free( i2, ierr )
call MTest_Finalize( errs )
call MPI_Finalize( ierr )
end
infotestf90 1
infotest2f90 1
# -*- Mode: Makefile; -*-
# vim: set ft=automake :