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

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