.title	FEHLER	abort a program with message & status
;
;	w.j.m. ??? (FORTRAN version)
;	change apr 85: do not rely on own msg definition,
;			use "shared" msg instead.
;			disadvantage: unwinding become unwieldy,
;				message is output in any case
;
;	entry:	FEHLER(string)
;
;
;	note: this program had to written in MACRO to allow
;		access to the address of the stringdescriptor
;		passed by the calling routine!
;	      the FORTRAN program included does not work since
;	      literal strings are passed to it without descriptor!!
;
;
;*****
;
	.psect	$LOCAL,pic,usr,con,rel,lcl,noshr,noexe,rd,wrt,novec
;
fehler_name:	.ascid	"FEHLER"	;.ADDRESS is not (PIC,SHR) !!
;
;
	.psect	$CODE,pic,usr,con,rel,lcl,shr,exe,rd,nowrt,novec
;
	.entry	fehler,^m<>
;
;=		subroutine fehler(strdsc)
;=		implicit none
;=		integer*4 strdsc(2)	! actual argument is character*(*) !
;=	c
;=		integer*4 msgvec(4)
;=		external shr$_text
;=	c
;
msgvec=-<4*4>	;(fp)
;
	moval	msgvec(fp),sp
;
;=	c
;=		msgvec(1)=3
;=		msgvec(2)=(%loc(shr$_text).and.'0000fff8'x) + 4 + '08000000'x
;=	c		! # force fatal status
;=	c		! # fake (user) facility other than "ss$_"
;=	c		!   to allow for $fao argument
;=		msgvec(3)=1			! # fao
;=		msgvec(4)=%loc(strdsc)		! need %loc of descriptor here
;
	movl	#3,msgvec(fp)
	movl	#<<shr$_text&^x0000fff8>!^x08000004>,msgvec+<1*4>(fp)
	movl	#1,msgvec+<2*4>(fp)
	moval	@1*4(ap),msgvec+<3*4>(fp)
;
;=		call sys$putmsg(msgvec,,'FEHLER',)
;
	$putmsg_s	msgvec=msgvec(fp),-
			facnam=fehler_name
;
;=		call lib$stop(%val(msgvec(2).or.'10000000'x))	! no more output,
;=	c							! but ggf. trace
;
	bisl3	msgvec+<1*4>(fp),#^x10000000,-(sp)
	calls	#1,g^lib$stop
;
;=		end
;
	ret
;
	.end