From:	SMTP%"carl@SOL1.GPS.CALTECH.EDU"  6-JUN-1994 11:55:57.46
To:	EVERHART
CC:	
Subj:	Re: trapping control C in VMS Fortran

From: carl@SOL1.GPS.CALTECH.EDU (Carl J Lydick)
X-Newsgroups: comp.os.vms
Subject: Re: trapping control C in VMS Fortran
Date: 3 Jun 1994 23:21:08 GMT
Organization: HST Wide Field/Planetary Camera
Lines: 188
Distribution: world
Message-Id: <2sodt4$758@gap.cco.caltech.edu>
Reply-To: carl@SOL1.GPS.CALTECH.EDU
Nntp-Posting-Host: sol1.gps.caltech.edu
To: Info-VAX@CRVAX.SRI.COM
X-Gateway-Source-Info: USENET

In article <Pine.3.89.9406031747.F17786-0100000@poseidon.ifctr.mi.cnr.it>, lucio@ifctr.mi.cnr.it (Lucio Chiappetti) writes:
=I'd like to trap control-C pressing in a Fortran program, i.e for
="gracious" interruption of a loop.
=
=I tried the following demo program :
=
=       program testbreak
=       integer i,ibase
=       logical z_break
=       ibase=0
=       do 1 i=1,1000
=       write(*,*)i+ibase
=       IF(Z_BREAK())THEN
=          write(*,*)' interrupt detecvted'
=          ibase=ibase+1000
=*          GOTO 2
=       endif
= 1     continue
= 2     continue
=       write(*,*)'stopped'
=       stop
=       end
=
=which should print 1000 numbers, and each time control-C is pressed
=adds 1000 to the value is printing (this is just to test MULTIPLE
=uses of control-C in the same program, not just to terminate the
=program). The routine I use for trapping is :
=
=       LOGICAL FUNCTION Z_BREAK()
=       INTEGER ICODE,IERR,SYS$QIOW,SYS$ASSIGN,SYS$DASSGN
=       INTEGER NTIMES
=       INTEGER   CHAN
=       LOGICAL CTLC
=       COMMON /CTLCCOMMON/CTLC
=       EXTERNAL CONTROLC
=       INCLUDE '($IODEF)'
=       DATA NTIMES /0/
=C
=       IF(NTIMES.EQ.0)THEN
=          CTLC=.FALSE.
=          IERR=SYS$ASSIGN('TT',CHAN,,)
=          write(*,*)' channel ',chan,ierr         <------------ A
=          ICODE=IO$_SETMODE+IO$M_CTRLCAST
=          NTIMES=1
=       endif                                      <------------ B1
=          IERR=SYS$QIOW( ,%VAL(CHAN),%VAL(ICODE),,,,
=     .    %REF(CONTROLC),0,0,0,0,0)
=*         write(*,*)'QIO ',ierr                   <------------ C
=*      ENDIF                                      <------------ B2
=       Z_BREAK=CTLC
=       CTLC=.FALSE.
=       RETURN
=       END
=C
=       SUBROUTINE CONTROLC
=       LOGICAL CTLC
=       COMMON /CTLCCOMMON/CTLC
=       CTLC=.TRUE.
=       RETURN
=       END
=
=I am unsure whether I shall call QIOW all the times or just once, and/or
=whether I have to reset anything.

You have to call QIOW every time a control-C is entered.  That means you
probably want to call it from the AST routine.

=B.t.w. if I put a WRITE statement in the CONTROLC routine I get an
=       error saying "recursive i/o"

Yup.  You're trying to use non-reentrant code from an AST.  That's a no-no.

=       It looks like I must have the first write (A) in, otherwise
=       interrupts are ignored (i.e. I must issue a write after ASSIGN) 

No, you don't.

=       If I disable the endif B1 and enable B2, only the first control-C
=       I type is honoured, therefore I am calling QIO all the times.
=       I.e. second endif commented.

In that case, you're setting up multiple ASTs on the channel.

=       In this case I am getting an unreproducible behaviour :
=       sometimes I get QIO system service request failed Exceeded quota
=       when I press control-C (with write statement C uncommented)

Yup.  You're pressing enough control-C'S that you're exceeding your AST quota.
You only want to reenable the AST after it's been delivered, not every time you
check to see whether it's been delivered.

=       sometimes I get that the first two interrupts are trapped and then
=       funny things happen (like the above error or other unexplained
=       error messages). Sometimes even the program stops after 20-30
=       steps in the DO-loop without any interrupt.
=
=I would very much appreciate a suggestion on how to make things straight,
=preferably by e-mail. Many thanks.

There are enough problems with your code that I won't go into them one by one,
but instead will simply give you a working version:

	PROGRAM TESTBREAK
	INTEGER I,IBASE, SETUPAST
	LOGICAL Z_BREAK
	INTEGER IERR
	INTEGER*2   CHAN
	LOGICAL CTLC
	COMMON /CTLCCOMMON/CTLC, CHAN, IERR

	IBASE=0
	WRITE(*,*) 'STARTING'
	CALL Z_BREAK()
	DO 1 I=1,1000
	WRITE(*,*)I+IBASE
 	IF(Z_BREAK())THEN
	    WRITE(*,*)' INTERRUPT DETECTED'
	    IBASE=IBASE+1000
	    IF(.NOT. IERR) THEN
		WRITE(*,*) 'I/O FAILED.  STATUS = ', IERR
	    ENDIF
	ENDIF
1	CONTINUE
	WRITE(*,*)'STOPPED'
	STOP
	END
C
	LOGICAL FUNCTION Z_BREAK()
	INTEGER ICODE,IERR,SYS$ASSIGN,SYS$DASSGN
	INTEGER NTIMES
	INTEGER*2   CHAN
	LOGICAL CTLC
	COMMON /CTLCCOMMON/CTLC, CHAN, IERR
	DATA NTIMES /0/
C
	IF(NTIMES.EQ.0)THEN
	   IERR=SYS$ASSIGN('TT',CHAN,,)
	   IF(.NOT. IERR) THEN
		Z_BREAK = .FALSE.
		RETURN
	   ENDIF
	   CALL SETUPAST()
	   IF(.NOT. IERR) THEN
		Z_BREAK = .FALSE.
		RETURN
	   ENDIF
	   NTIMES=1
	   CTLC=.FALSE.
	ENDIF
	Z_BREAK=CTLC
	CTLC=.FALSE.
	RETURN
	END
C
	SUBROUTINE CONTROLC
	LOGICAL CTLC
	INTEGER*2 CHAN
	INTEGER IERR, SETUPAST
	COMMON /CTLCCOMMON/CTLC, CHAN, IERR
	CTLC=.TRUE.
	CALL SETUPAST()
	RETURN
	END

	SUBROUTINE SETUPAST()
	EXTERNAL CONTROLC
	LOGICAL CTLC
	INTEGER*2 CHAN, IOSB(4)
	INTEGER IERR, SYS$QIOW
	COMMON /CTLCCOMMON/CTLC, CHAN, IERR
	INCLUDE '($IODEF)'
C
	ICODE=IO$_SETMODE+IO$M_CTRLCAST
	IERR = SYS$QIOW( ,%VAL(CHAN),%VAL(ICODE),IOSB,,,
	1   %REF(CONTROLC),0,0,0,0,0)
	IF(IERR) THEN
	    IERR = IOSB(1)
	ENDIF
	RETURN
	END
--------------------------------------------------------------------------------
Carl J Lydick | INTERnet: CARL@SOL1.GPS.CALTECH.EDU | NSI/HEPnet: SOL1::CARL

Disclaimer:  Hey, I understand VAXen and VMS.  That's what I get paid for.  My
understanding of astronomy is purely at the amateur level (or below).  So
unless what I'm saying is directly related to VAX/VMS, don't hold me or my
organization responsible for it.  If it IS related to VAX/VMS, you can try to
hold me responsible for it, but my organization had nothing to do with it.

