1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
C -*- Mode: Fortran; -*-
C
C (C) 2003 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C
program main
implicit none
include 'mpif.h'
character*(MPI_MAX_OBJECT_NAME) cname
integer rlen, ln
integer ntype1, ntype2, errs, ierr
errs = 0
call MTest_Init( ierr )
call mpi_type_vector( 10, 1, 100, MPI_INTEGER, ntype1, ierr )
rlen = -1
cname = 'XXXXXX'
call mpi_type_get_name( ntype1, cname, rlen, ierr )
if (rlen .ne. 0) then
errs = errs + 1
print *, ' Expected length 0, got ', rlen
endif
rlen = 0
do ln=MPI_MAX_OBJECT_NAME,1,-1
if (cname(ln:ln) .ne. ' ') then
rlen = ln
goto 100
endif
enddo
100 continue
if (rlen .ne. 0) then
errs = errs + 1
print *, 'Datatype name is not all blank'
endif
C
C now add a name, then dup
call mpi_type_set_name( ntype1, 'a vector type', ierr )
call mpi_type_dup( ntype1, ntype2, ierr )
rlen = -1
cname = 'XXXXXX'
call mpi_type_get_name( ntype2, cname, rlen, ierr )
if (rlen .ne. 0) then
errs = errs + 1
print *, ' (type2) Expected length 0, got ', rlen
endif
rlen = 0
do ln=MPI_MAX_OBJECT_NAME,1,-1
if (cname(ln:ln) .ne. ' ') then
rlen = ln
goto 110
endif
enddo
110 continue
if (rlen .ne. 0) then
errs = errs + 1
print *, ' (type2) Datatype name is not all blank'
endif
call mpi_type_free( ntype1, ierr )
call mpi_type_free( ntype2, ierr )
call MTest_Finalize( errs )
end
|
