SUBROUTINE PUTEVT (LUN,NEVENT,NWORDS,IBUF,IER)
C
C	IDENT	/01JUN7/	;09:35:00, LV
C	.ENTRY	PUTEVT - WRITE EVENT TO Q TAPE
C;+
C - P U T E V T
C
C PURPOSE:	SUBROUTINE WRITES A USER SPECIFIED EVENT TO THE Q TAPE.
C
C INTERFACE:	CALLING SEQUENCE: (FORTRAN-CALLABLE SUBROUTINE)
C			CALL PUTEVT(LUN,NEVENT,NWORDS,IBUF,IER)
C
C		INPUT:	LUN(INTEGER) =	 THE LOGICAL UNIT # TO BE USED FOR 
C					 QIO'S TO QA
C			NEVENT(INTEGER) = THE EVENT #
C			NWORDS(INTEGER) = THE # OF 16-BIT WORDS IN THE EVENT
C				(0<NWORDS<256)
C				256 WORDS ARE THE MAXIMUM NUMBER OF
C 				WORDS IN AN EVENT (ONE BYTE)
C			IBUF =	FIRST WORD ADDRESS OF BUFFER CONTAINING
C				EVENT DATA.
C			IER(INTEGER) =	AN ERROR FLAG, A POSITIVE NUMBER 
C					MEANS SUCCESS
C				THE FOLLOWING NEGATIVE NUMBERS INDICATE FAILURE
C					-1 (TAPING NOT ENABLED)
C					-2 (RUN CANNOT BE SUSPENDED)
C					-3 (QIO DIRECTIVE FAILURE TO QA)
C					-4 (QA UNABLE TO PERFORM TAPE WRITE)
C					-5 (RUN CANNOT BE RESUMED)
C					-6 (SEND DIRECTIVE FAILURE)
C
C METHOD:	THIS SUBROUTINE TAKES THE FOLLOWING ACTION:
C		CHECK THE TAPING FLAG, IF TAPING NOT ENABLED-RETURN
C		SEND DATA TO QCNTRL TO SUSPEND THE RUN, IF A RUN IS IN
C		PROGRESS.
C		DO A QIO TO QA TO DO THE TAPE WRITING.
C		RESUME THE RUN, IF ONE WAS IN PROGRESS.
C
C		THE ERROR FLAG (IER) WILL REFLECT ANY ERROR CONDITIONS.
C
C		THIS SUBROUTINE USES EVENT FLAG 24. TO DETECT I/O COMPLETION.
C
C LANGUAGE:	FORTRAN
C
C RESTRICTIONS:	TASKS USING THIS SUBROUTINE MUST BE TASK BUILT WITH THE
C		FOLLOWING STATEMENTS:
C			COMMON = QCOM1:RW
C			ASG=QA:LUN# (THE SAME NUMBER AS GIVEN AS AN
C				ARGUMENT TO THE SUBROUTINE)
C;-
C REVISIONS:
C 01-JUN-77	LV	UPDATED TO CONFORM TO STANDARDS
C
	REAL*8RNAME
	COMMON/QCOM1/IQC,IQN,IQRIP,IRUN,IQREC,LOCK,IQTAPE,IQTAPN,ISTATE
	DIMENSION ISTAT(2),IPRM(6)
	DIMENSION IDATA(13)
	DATA NSEC/90/,IEFN/24/
	DATA RNAME/'QCNTRL'/
C
C IS TAPING ENABLED?
C
	IF(IQTAPE.EQ.0) GO TO 1000
C
C YES. IS A RUN IN PROGRESS?
C
C CHECK THAT WE ARE IN A RUN STATE
	IF(ISTATE.NE.3) GO TO 100
	IF(IQRIP.LE.0) GO TO 100
C
C YES CALL QCNTRL TO SUSPEND IT - WITHOUT WRITING EOF'S.
C
	IDATA(1)=6
	CALL SEND (RAD50(RNAME),IDATA,IDS)
	IF(IDS.LT.0) GO TO 6000
C
C WAIT FOR RUN TO BE SUSPENDED.
	ICNT=0
50	IF(ISTATE.EQ.4) GO TO 100
	CALL WAIT (1,2,IDS)
	ICNT=ICNT+1
	IF(ICNT.LT.NSEC) GO TO 50
C
C CAN'T SUSPEND RUN - GIVE ERROR
C
	GO TO 2000
C
C
C DO QIO TO QA TO WRITE TO TAPE
C ENABLE TAPING IN THE HANDLER
100	IQTAPN=1
C SET PARAMETERS FOR QIO
	IPRM(1)=NEVENT
	IPRM(2)=NWORDS
	CALL GETADR(IPRM(3),IBUF)
	CALL WTQIO ("11000,LUN,IEFN,,ISTAT,IPRM,IDS)
C DISABLE TAPING IN THE HANDLER
	IQTAPN=0
C WERE WE SUCCESSFUL?
	IF(IDS.LT.0) GO TO 3000
	IF(ISTAT(1).NE.1) GO TO 4000
C
C RESUME THE RUN IN PROGRESS
C WAS A RUN IN PROGRESS?
	IF(ISTATE.NE.3) GO TO 200
	IF(IQRIP.LE.0) GO TO 200
C
C YES-RESUME IT
C
	IDATA(1)=3
	CALL SEND(RAD50(RNAME),IDATA,IDS)
C CHECK IF DIRECTIVE FAILED
	IF(IDS.LT.0) GO TO 6000
C
C WAIT FOR RUN TO BE RESUMED
C
	ICNT=0
150	IF(ISTATE.EQ.3) GO TO 200
C WAIT 1 SECOND
	CALL WAIT (1,2,IDS)
	ICNT=ICNT+1
C TRY NSEC SECONDS
	IF(ICNT.LT.NSEC) GO TO 150
C
C CAN'T RESUME THE RUN-GIVE ERROR
	GO TO 5000
C SUCCESS
200	IER=1
	GO TO 9000
C TAPING NOT ENABLED
1000	IER=-1
	GO TO 9000
C RUN CANN0T BE SUSPENDED
2000	IER=-2
	GO TO 9000
C QIO DIRECTIVE FAILURE
3000	IER=-3
	GO TO 9000
C QA UNABLE TO PERFORM SERVICE
4000	IER=-4
	GO TO 9000
C RUN CANNOT BE RESUMED
5000	IER=-5
	GO TO 9000
C SEND DIRECTIVE FAILURE
6000	IER=-6
9000	RETURN
	END