program hello
real*4 function urand()
USE IFPORT; USE IFCORE ! базовые модули языка
USE ABD_INC
USE HEADERS, dummy_urand => urand ! объявления глобальных переменных и интерфейсов, в т.ч. интерфейса к urand.
! Поэтому во избежание конфликта имен urand из HEADERS надо экранировать
integer*4, save :: ini=0 ! ini - статическая переменная, сохраняется между вызовами, инициализируется один раз
real*4 r ! временная переменная для баг-трекинга
c
c Инициализация генератора случайным числом (только 1 раз при первом вызове):
if (ini == 0) call seed(RND$TIMESEED); ini=1
c
100 call random(r); ! r должно быть значением от 0 до 1, но ФАКТ: ИЗРЕДКА СЮДА ВОЗВРАЩАЕТСЯ r=NAN ?!?!
if (isNaN(r)) then ! Согласно справке фортрана, условие не должно выполняться НИКОГДА, но....
dos_line=' Random='; call r4_to_bit(r,dos_line(11:42)) ! Запись R4 в строку dos_line в виде 32-битной маски
call append(r); call append_history() ! Запись R4 в строку dos_line в виде real-числа и дамп
end if
if (isNaN(r)) goto 100 ! В тестовой проге этот goto, естественно, закомментирован
urand = r ! Возвращаемое значение функции. Кто бы мог подумать, что его надо проверять...
end
end program hello