program main use iso_c_binding, only: c_intptr_t, c_ptr, c_associated #ifndef USE_OMP_HEADER use omp_lib #endif implicit none (type, external) #ifdef USE_OMP_HEADER include "omp_lib.h" #endif integer(omp_interop_kind) :: interop = omp_interop_none integer(omp_interop_rc_kind) :: ret_code integer(omp_interop_fr_kind) :: fr integer(omp_interop_property_kind) :: ipr integer(c_intptr_t) :: ival type(c_ptr) :: ptr character(len=:), pointer :: str if (omp_irc_no_value /= 1) stop 1 if (omp_irc_success /= 0) stop 2 if (omp_irc_empty /= -1) stop 3 if (omp_irc_out_of_range /= -2) stop 4 if (omp_irc_type_int /= -3) stop 5 if (omp_irc_type_ptr /= -4) stop 6 if (omp_irc_type_str /= -5) stop 7 if (omp_irc_other /= -6) stop 8 ! Check values, including invalid values. do ret_code = omp_irc_other - 1, omp_irc_no_value + 1 str => omp_get_interop_rc_desc (interop, ret_code) if (ret_code < omp_irc_other & & .or. ret_code > omp_irc_no_value) then ! Assume disassociated for an invalid value. if (associated (str)) stop 9 else if (ret_code == omp_irc_other) then ! Likely not to exist in an implementation; esp. not for ! omp_interop_none. Thus, assume disassociated. ! In GCC, omp_irc_other is used on the device side, only, to ! complain about omp_get_interop_{int,ptr,str} usage. if (associated (str)) stop 10 else ! Assume that omp_get_interop_rc_desc handles all of those and ! not only omp_irc_empty (and possibly omp_irc_out_of_range), ! which do occur for omp_interop_none. ! Assume some sensible message, i.e. at least 5 characters. if (len_trim (str) <= 5) stop 11 end if end do if (omp_ifr_last < omp_ifr_hsa) stop 12 do fr = omp_ifr_cuda, omp_ifr_last select case (fr) ! Expect the id values from the additional-definition document. case (omp_ifr_cuda) if (fr /= 1) stop 13 case (omp_ifr_cuda_driver) if (fr /= 2) stop 14 case (omp_ifr_opencl) if (fr /= 3) stop 15 case (omp_ifr_sycl) if (fr /= 4) stop 16 case (omp_ifr_hip) if (fr /= 5) stop 17 case (omp_ifr_level_zero) if (fr /= 6) stop 18 case (omp_ifr_hsa) if (fr /= 7) stop 19 case default ! Valid, but unexpected to have more interop types. stop 20 end select end do if (omp_ipr_first > omp_ipr_targetsync & & .or. (omp_ipr_fr_id & & >= omp_get_num_interop_properties (interop))) & & stop 21 do ipr = omp_ipr_first, & & omp_get_num_interop_properties (interop) - 1 ! As interop == omp_interop_none, NULL is permissible; ! nonetheless, require != NULL for the GCC implementation. str => omp_get_interop_name (interop, ipr) select case (ipr) case (omp_ipr_fr_id) if (ipr /= -1 .or. str /= "fr_id") & & stop 21 case (omp_ipr_fr_name) if (ipr /= -2 .or. str /= "fr_name") & & stop 22 case (omp_ipr_vendor) if (ipr /= -3 .or. str /= "vendor") & & stop 23 case (omp_ipr_vendor_name) if (ipr /= -4 .or. str /= "vendor_name") & & stop 24 case (omp_ipr_device_num) if (ipr /= -5 .or. str /= "device_num") & & stop 25 case (omp_ipr_platform) if (ipr /= -6 .or. str /= "platform") & & stop 26 case (omp_ipr_device) if (ipr /= -7 .or. str /= "device") & & stop 27 case (omp_ipr_device_context) if (ipr /= -8 .or. str /= "device_context") & & stop 28 case (omp_ipr_targetsync) if (ipr /= -9 .or. str /= "targetsync") & & stop 29 case default ! Valid, but unexpected to have more interop types, ! especially not for interop == omp_interop_none. stop 30 end select ! As interop == omp_interop_none, expect NULL. if (associated (omp_get_interop_type_desc (interop, ipr))) & & stop 31 ret_code = omp_irc_success ival = omp_get_interop_int (interop, ipr, ret_code) if (ret_code /= omp_irc_empty) stop 32 if (ival /= 0) stop 33 ! Implementation choice str => omp_get_interop_rc_desc (interop, ret_code) if (len_trim (str) <= 5) stop 34 if (str /= "provided interoperability object is equal to " & & // "omp_interop_none") & & stop 35 ! GCC implementation choice. ival = omp_get_interop_int (interop, ipr) if (ival /= 0) stop 33 ! Implementation choice ret_code = omp_irc_success ptr = omp_get_interop_ptr (interop, ipr, ret_code) if (ret_code /= omp_irc_empty) stop 36 if (c_associated (ptr)) stop 37 ! Obvious implementation choice. str => omp_get_interop_rc_desc (interop, ret_code) if (len_trim (str) <= 5) stop 38 if (str /= "provided interoperability object is equal to " & & // "omp_interop_none") & & stop 39 ! GCC implementation choice. ptr = omp_get_interop_ptr (interop, ipr) if (c_associated (ptr)) stop 37 ! Obvious implementation choice. ret_code = omp_irc_success str => omp_get_interop_str (interop, ipr, ret_code) if (ret_code /= omp_irc_empty) stop 40 if (associated (str)) stop 41 ! Obvious mplementation choice str => omp_get_interop_rc_desc (interop, ret_code) if (len_trim (str) <= 5) stop 42 if (str /= "provided interoperability object is equal to " & & // "omp_interop_none") & & stop 43 ! GCC implementation choice. str => omp_get_interop_str (interop, ipr) if (associated (str)) stop 41 ! Obvious mplementation choice end do ! Invalid ipr. ! Valid are either omp_irc_empty (due to omp_interop_none) or ! omp_irc_out_of_range; assume omp_irc_out_of_range with GCC. ! omp_ipr_targetsync-1, i.e < lower bound. ret_code = omp_irc_success ival = omp_get_interop_int (interop, omp_ipr_targetsync-1, & & ret_code) if (ret_code /= omp_irc_out_of_range) stop 44 if (ival /= 0) stop 45 ! Implementation choice. str => omp_get_interop_rc_desc (interop, ret_code) if (len_trim (str) <= 5) stop 46 ! GCC implementation choice. if (str /= "property ID is out of range") stop 47 ival = omp_get_interop_int (interop, omp_ipr_targetsync-1) if (ival /= 0) stop 45 ! Implementation choice. ret_code = omp_irc_success ptr = omp_get_interop_ptr (interop, omp_ipr_targetsync-1, & & ret_code) if (ret_code /= omp_irc_out_of_range) stop 48 if (c_associated (ptr)) stop 49 ! Obvious implementation choice. str => omp_get_interop_rc_desc (interop, ret_code) if (len_trim (str) <= 5) stop 50 ! GCC implementation choice. if (str /= "property ID is out of range") stop 51 ptr = omp_get_interop_ptr (interop, omp_ipr_targetsync-1) if (c_associated (ptr)) stop 49 ! Obvious implementation choice. ret_code = omp_irc_success str => omp_get_interop_str (interop, omp_ipr_targetsync-1, & & ret_code) if (ret_code /= omp_irc_out_of_range) stop 52 if (associated (str)) stop 53 ! Obvious implementation choice. str => omp_get_interop_rc_desc (interop, ret_code) if (len_trim (str) <= 5) stop 54 ! GCC implementation choice. if (str /= "property ID is out of range") stop 55 str => omp_get_interop_str (interop, omp_ipr_targetsync-1) if (associated (str)) stop 53 ! Obvious implementation choice. ! omp_get_num_interop_properties (), i.e > upper bound. ret_code = omp_irc_success ival = omp_get_interop_int (interop, & & omp_get_num_interop_properties (interop), & & ret_code) if (ret_code /= omp_irc_out_of_range) stop 56 if (ival /= 0) stop 57 ! Implementation choice. str => omp_get_interop_rc_desc (interop, ret_code) if (len_trim (str) <= 5) stop 58 ! GCC implementation choice. if (str /= "property ID is out of range") stop 59 ret_code = omp_irc_success ptr = omp_get_interop_ptr (interop, & & omp_get_num_interop_properties (interop), ret_code) if (ret_code /= omp_irc_out_of_range) stop 60 if (c_associated (ptr)) stop 61 ! Obvious implementation choice. str => omp_get_interop_rc_desc (interop, ret_code) if (len_trim (str) <= 5) stop 62 ! GCC implementation choice. if (str /= "property ID is out of range") stop 63 ret_code = omp_irc_success str => omp_get_interop_str (interop, & & omp_get_num_interop_properties (interop), ret_code) if (ret_code /= omp_irc_out_of_range) stop 64 if (associated (str)) stop 65 ! Obvious implementation choice. str => omp_get_interop_rc_desc (interop, ret_code) if (len_trim (str) <= 5) stop 66 ! GCC implementation choice. if (str /= "property ID is out of range") stop 67 end