libgomp/testsuite/libgomp.fortran/device_uid.f90

   1 program main
   2   use omp_lib
   3   implicit none (type, external)
   4   integer :: i, j, dev
   5   character(:), pointer :: str
   6   type t
   7     character(:), pointer :: str
   8   end type t
   9   type(t), allocatable :: strs(:)
  10
  11   allocate(strs(0:omp_get_num_devices ()))
  12
  13   do i = omp_invalid_device - 1, omp_get_num_devices () + 1
  14     str => omp_get_uid_from_device (i)
  15     dev = omp_get_device_from_uid (str)
  16 ! print *, i, str, dev
  17     if (i < omp_initial_device .or. i > omp_get_num_devices ()) then
  18       if (dev /= omp_invalid_device .or. associated(str)) &
  19         stop 1
  20       cycle
  21     end if
  22     if (.not. associated(str)) &
  23       stop 2
  24     if (i == omp_initial_device .or. i == omp_get_num_devices ()) then
  25       if ((dev /= omp_initial_device .and. dev /= omp_get_num_devices ()) &
  26           .or. str /= "OMP_INITIAL_DEVICE") & ! /* GCC impl. choice */
  27        stop 3
  28       dev = omp_get_num_devices ()
  29     else if (dev /= i .or. len(str) == 0) then
  30       stop 4
  31     end if
  32     strs(dev)%str => str
  33
  34     block
  35       ! Check substring handling
  36       character(len=100) :: long_str
  37       integer :: dev2
  38       long_str = str // "ABCDEF"
  39       dev2 = omp_get_device_from_uid (long_str(1:len(str)))
  40       if (i == omp_initial_device .or. i == omp_get_num_devices ()) then
  41         if (dev2 /= omp_initial_device .and. dev2  /= omp_get_num_devices ()) &
  42           stop 5
  43       else if (dev /= dev2) then
  44         stop 6
  45       end if
  46     end block
  47   end do
  48
  49   do i = 0, omp_get_num_devices () - 1
  50     do j = i + 1, omp_get_num_devices ()
  51       if (strs(i)%str == strs(j)%str) &
  52         stop 7
  53     end do
  54   end do
  55   deallocate (strs)
  56 end