From: system@isi001.dnet.kfa-juelich.de
Newsgroups: comp.lang.fortran,comp.os.vms
Subject: Re: Turning VAX FORTRAN IOSTAT returns into VMS status codes?
Date: 12 Nov 92 13:34:23 GMT
Reply-To: system@isi001.dnet.kfa-juelich.de ()
Followup-To: comp.lang.fortran
Organization: Forschungszentrum (KFA) Juelich GmbH, Germany

In article <2b022ab8.3aaa@lhn.gns.cri.nz>, mdlcpgs@lhn.gns.cri.nz writes:
|>Path:
|
zam103!Sirius.dfn.de!mailgzrz.TU-Berlin.DE!math.fu-berlin.de!news.belwue
e.de!ira.uka.de!yale.edu!qt.cs.utexas.edu!cs.utexas.edu!wupost!waikato.a
ac.nz!comp.vuw.ac.nz!am.dsir.govt.nz!lhn.gns.cri.nz
|>From: mdlcpgs@lhn.gns.cri.nz
|>Newsgroups: comp.lang.fortran,comp.os.vms
|>Subject: Turning VAX FORTRAN IOSTAT returns into VMS status codes?
|>Message-ID: <2b022ab8.3aaa@lhn.gns.cri.nz>
|>Date: 11 Nov 92 21:58:16 GMT
|>Organization: Institute of Gelogical & Nuclear Sciences, New Zealand.
|>Lines: 6
|>Xref: zam103 comp.lang.fortran:4668 comp.os.vms:19584
|>
|>Hi. I wonder if anyone can tell me how to turn a VAX FORTRAN
|>IOSTAT status return value into a VMS status for signalling
|>by LIB$SIGNAL?  I cant in this application use ERRSNS because ...
|>
Hi Phil,
I'll give you an exaple below

------------------ cut here ---------------------
c
c
	program mbxqio
c
c	this program illustrates handling terminal input
c	using terminal/mailbox interaction. when
c	something is typed at a terminal information is
c	written to its associated mailbox. this
c	triggers an AST which notifies the program of
c	the input.
c
	implicit integer*4 (a-z)
	integer*2 	ttchan, mbxchan
	character	mbxname*7 /'mailbox'/,	ttname*11 /'sys$command'/
	character*80 ttbuf,inp
	integer*2 iosb(4)
	real*8 time
	logical*1 isr
	common ttchan,iosb,ttbuf
	common /test/ i,isr
	external isr_timer
	inp = '0 00:00:10'
	status = sys$bintim(inp,time)
	last3 = %loc(isr_timer)
c
c	create mailbox and assign a channel to it
c
	status = sys$crembx(,mbxchan,,,,,mbxname)
	if( .not. status ) call lib$stop(%val(status))
c
c	associate the mailbox with 'term1'
c
	status = sys$assign(ttname, ttchan,, mbxname)
	if( .not. status ) call lib$stop(%val(status))
c
c	open the terminal
c
	open (unit=1, file=ttname, status='old')
c
c	enable the mailbox AST
c
c	do i =1,3		!CAUTION: Interrupts will be queued
	call enable1 (mbxchan)
c	end do
c
c	hibernate the process
c
	isr = .false.
	status = sys$setimr(,time,%val(last3),)
c	i = 0
c10	continue
c	i = i + 1
c	go to 10
	status = sys$hiber()
	if( .not. status ) call lib$stop(%val(status))
	status = sys$cancel(%val(ttchan))
	call lib$signal(%val(status))
c
c
c	call enable1( mbxchan)
	write(6,'('' interrupt enabled'')')
	call disable1 (mbxchan)
	write(6,'('' interrupt disabled'')')
c
c	hibernate the process
c
	isr = .false.
	status = sys$setimr(,time,%val(last3),)
	status = sys$hiber()
	if( .not. status ) call lib$stop(%val(status))
c
	stop
	end
	subroutine enable1(mbxchan)
c
c	this subroutine enables a write attention AST
c	for mailbox associated with the terminal.
c
	implicit integer*4 (a-z)
	integer*2	mbxchan
	external ast1
	include '($iodef)'
c
	wrt_ast = io$_setmode .or. io$m_wrtattn
	io1 = io$_setmode
	io2 = io$m_wrtattn
c
c	enable AST1
c
	status = sys$qiow(,%val(mbxchan),%val(wrt_ast),,,,ast1,mbxchan,,,,)
	if( .not. status ) call lib$stop(%val(status))
	return
	end
	subroutine ast1(mbxchan)
c
c	this AST service routine processes the terminal
c	input.
c
	implicit integer*4 (a-z)
	integer*2 iosb(4),mbxchan,mbxch,ttchan
	character*80 ttbuf
	character*150 mbxbuf
	common ttchan,iosb,ttbuf
	character ttname*11 /'sys$command'/
	external ast2
	include '($iodef)'
	last2 = %loc(ast2)
c	status = sys$assign(ttname, ttchan,,,)
c	if( .not. status ) call lib$stop(%val(status))
c
c	first, read message in mailbox so next write attention
c	AST not delivered until next message written.
c
	status = sys$qiow(,%val(mbxchan),%val(io$_readvblk),,,,
     *		%ref(mbxbuf),%val(len(mbxbuf)),,,,)
	write(6,*) mbxbuf
	if( .not. status ) call lib$stop(%val(status))
c
c	read input from the terminal and write it back.
c
c	read(1,'(q,a)',end=100) length, ttbuf
	status = sys$qio(,%val(ttchan),%val(io$_readvblk),iosb,
     *	%val(last2),mbxchan,%ref(ttbuf),%val(len(ttbuf)),,,,)
 	if( .not. status) call lib$signal(%val(status))
c	write(6,'('' qio has setup'')')
	return
	end
	subroutine ast2(mbxchan)
	integer*2 iosb(4),mbxchan,ttchan
	character*80 ttbuf
	logical*1 isr
	common ttchan,iosb,ttbuf
	common /test/ i,isr
	length = iosb(2)
	if( length .eq. 0 ) then
		write(1,4)
	else
		write(1,3) ttbuf 
    3   format(' you typed: ',a<length>)
    4	format(' you typed: <CR>')
	end if
	write(6,'('' i = '',i10,'' isr ='',l4)') i,isr
c
c	re-enable AST
c
	call enable1(mbxchan)
	return
c
c	wake process
  100	call sys$wake(,)
	return
	end
	subroutine isr_timer
	integer*4 sys$wake,status,sys$cancel
	logical*1 isr
	integer*2 ttchan,iosb(4)
	character*80 ttbuf
	common ttchan,iosb,ttbuf
	common /test/i,isr
	status = sys$cancel(%val(ttchan))
	call lib$signal(%val(status))
 	write(6,'('' s.r. isr_timer'')')
	isr = .true.
	status = sys$wake(,)
	if( .not. status ) call lib$signal(%val(status))
	return
	end
	subroutine disable1(mbxchan)
c
c
	implicit integer*4 (a-z)
	integer*2	mbxchan
	external ast3
	include '($iodef)'
c
	wrt_ast = io$_setmode 
c
c
	status = sys$qiow(,%val(mbxchan),%val(wrt_ast),,,,ast3,mbxchan,,,,)
	if( .not. status ) call lib$stop(%val(status))
	return
	end
	subroutine ast3(mbxchan)
	integer*2 mbxchan
	write(6,'('' s.r. ast3'')')
	return
	end
c
c
---------------------- cut here ----------------------

I hope it will be helpfully

greetinx
Wolfgang

----------------------------------------------------