mirror of
https://github.com/OpenMP/Examples.git
synced 2025-04-10 08:22:11 +01:00
85 lines
2.5 KiB
Fortran
85 lines
2.5 KiB
Fortran
! @@name: target_offload_control.1
|
|
! @@type: F-free
|
|
! @@operation: run
|
|
! @@expect: success
|
|
! @@version: omp_5.0
|
|
! @@env: OMP_TARGET_OFFLOAD=default
|
|
module offload_policy
|
|
implicit none
|
|
integer, parameter :: LEN_POLICY=10
|
|
contains
|
|
character(LEN_POLICY) function get_offload_policy()
|
|
character(64) :: env
|
|
integer :: length, i
|
|
env=repeat(' ',len(env))
|
|
!policy is blank if not found *
|
|
call get_environment_variable("OMP_TARGET_OFFLOAD",env,length)
|
|
|
|
do i = 1,len(env) !Makes a-z upper case
|
|
if(iachar(env(i:i))>96) env(i:i)=achar(iachar(env(i:i))-32)
|
|
end do
|
|
|
|
get_offload_policy = trim(adjustl(env)) !remove peripheral spaces
|
|
|
|
if(length==0) get_offload_policy="NOTSET"
|
|
|
|
return
|
|
|
|
end function
|
|
|
|
end module
|
|
|
|
program policy_test
|
|
|
|
use omp_lib
|
|
use offload_policy
|
|
|
|
integer :: i, device_num
|
|
logical :: on_init_dev
|
|
character(LEN_POLICY) :: policy
|
|
|
|
policy = get_offload_policy() !!Get OMP_TARGET_OFFLOAD value
|
|
|
|
if (OPENMP_VERSION < 201811) then
|
|
print*,"Warning: OMP_TARGET_OFFLOAD NOT supported by VER.", &
|
|
OPENMP_VERSION
|
|
print*," If OMP_TARGET_OFFLOAD is set, it will be ignored."
|
|
endif
|
|
|
|
! Set target device number to an unavailable device
|
|
! to test offload policy.
|
|
device_num = omp_get_num_devices() + 1
|
|
|
|
!! Report OMP_TARGET_OFFOAD value
|
|
select CASE (policy)
|
|
case("MANDATORY")
|
|
print*,"Policy: MANDATORY-Terminate if dev. not avail."
|
|
case("DISABLED")
|
|
print*,"Policy: DISABLED-(if supported) Only on Host."
|
|
case("DEFAULT")
|
|
print*,"Policy: DEFAULT On host if device not avail."
|
|
case("NOTSET")
|
|
print*," OMP_TARGET_OFFLOAD is not set."
|
|
case DEFAULT
|
|
print*," OMP_TARGET_OFFLOAD has unknown value."
|
|
print*," UPPER CASE VALUE=",policy
|
|
end select
|
|
|
|
|
|
on_init_dev = .FALSE.
|
|
!! device# out of range--not supported
|
|
!$omp target device(device_num) map(tofrom: on_init_dev)
|
|
on_init_dev=omp_is_initial_device()
|
|
!$omp end target
|
|
|
|
if (policy=="MANDATORY" .and. OPENMP_VERSION>=201811) then
|
|
print*,"OMP ERROR: ", &
|
|
"OpenMP 5.0 implementation ignored MANDATORY policy."
|
|
print*," Termination should have occurred", &
|
|
" at target directive."
|
|
endif
|
|
|
|
print*, "Target executed on init dev (T|F): ", on_init_dev
|
|
|
|
end program policy_test
|