	subroutine primex(ysymbl,error)
#
#	Extraktion der Primitivmuster
# 
# primex liefert dem Parser das Primitivmuster-Symbol ysymbl als Ausgangs-
# Parameter und die Primitivmuster-Attribute im Common-Block pmattr.
# Falls bei Einsprung error=true ist, wird der Kelleruebersetzer re-
# initialisiert; andernfalls setzt er die Analyse der momentanen Bandlinie 
# da fort, wo er zuvor aufgehoert hatte.
# Falls ein Analysefehler auftritt, ist beim Verlassen der Routine error=true,
# sonst error=false.
#
# Externe Routinen:
# Name		File,Bibliothek
# sprod		PRODS		S-Produktion
# aprod		PRODS		A-Produktionen
# bprod		PRODS		B-Produktionen
# cprod		PRODS		C-Produktionen
# dprod		PRODS		D-Produktionen
# eprod		PRODS		E-Produktionen
# fprod		PRODS		F-Produktionen
# pop		SUBS		holt Element aus dem Stack
# push		SUBS		bringt Element in den Stack
# wtyp		SUBS		liefert Winkelsymbol
# awinkl	SUBS		liefert abs. Winkel zur x-Achse
# iround	SUBS 		liefert gerundete Integer-Zahl
# idist		SUBS		liefert Schachbrett-Abstand
# rdist		SUBS		liefert Euklidischen Abstand
# plott		INTERF		plottet das Bild
# mark		INTERF		markiert ein Bandlinien-Element
#
# Version 0.1	16.05.85
#
include defsym.rat
include defstk.rat
#
define	NEXTSY 990	# Label
define	EREXIT 999
#
logical	error		# Error Flag
logical	sharp		# signalisiert scharfe Kurve
logical	show		# mit/ohne Bildschirm-Ausgabe
#
integer	zx,zy		# Zentralpunkt
#
integer	zustnd		# Zustand des Kelleruebersetzers (Kurventyp)
integer	ksymbl		# Keller-Symbol
integer	wsymbl		# Winkelsymbol (Links-,Rechtsknick)
integer	ysymbl		# Output-Symbol (=Input fuer PARSER)
integer	stack(TOPMAX,8)	# Stack mit Symbol und Attributen
integer	top		# Top of Stack
#
integer	tx,ty,ux,uy,	# Anfangs- und Endpunkt der momentanen term.Strecke
	vx,vy		# zugeh. Zentralpunkt
real	bb		# Bandbreite
#			  Primitivmuster-Attribute
integer	tpx,tpy,upx,upy	# Anfangs- und Endpunkt
integer	ap		# A = Winkelaenderung
real	bp		# B = Bandbreite
real	cpx,cpy		# C = Massenschwerpunkt
integer	dp		# D = Abstandsumme
integer ep		# E = Endpunktabstand
real	fp		# F = Flaechenanteil
real	lp		# L = Segmentlaenge
integer	mp		# M = max.Winkelaenderung
integer	np		# N = Elementanzahl
#
integer	w1,w2		# absolute Winkel zur x-Achse
integer	dw		# Differenzwinkel
integer	px,py		# Anknuepfungspunkt
#
byte	kalpha(10)	# Kelleralphabet als ASCII-Zeichen
integer	palpha(7)	# Primitivmuster-Alphabet als ASCII-Zeichen
#
#	Funktionen (Bedeutung s.oben bzw.unten)
#
integer	idist,wtyp,awinkl,dwinkl,iround,mittp
real	rdist,ffunkt
#
#	Diagnose-Variablen
#
integer	mwaend		# mittlere Winkelaenderung
#
common	/zpunkt/zx,zy
common	/status/zustnd,wsymbl,w1,w2,dw
common	/systck/top,stack
common	/punkte/tx,ty,ux,uy,vx,vy,bb
common	/pmattr/ap,bp,cpx,cpy,dp,ep,fp,lp,mp,np,tpx,tpy,upx,upy
common	/flags/show
#
data	kalpha/'S','A','B','C','D','E','F','a','b','$'/
data	palpha/'f_','g_','l_','l#','r_','r#','$_'/
#
#	Statement-Funktionen
#
dwinkl(i,j) = mod(j-i+540,360)-180	# Differenzwinkel 
mittp(i,j) = int(float(i+j)/2.)		# ganzzahlige Mittenkoord.
ffunkt(i,j,k,l) = float(i-k)*(j+l)	# Beitrag zur Flaechenformel
#
#	******* Beginn der Subroutine *******
#
if (show) write(1,10) 
10 format(/' *** PRIMEX ***')
#
if (error)
[	top=1 ; stack(top,SYM)=XX 		# Reinitialisierung
	ksymbl=XS ; bb=0. ; call push(ksymbl,zx,zy,zx,zy,zx,zy,bb,error)
	zustnd=ZJ ; error=.false.
	call plott			
]
goto EREXIT
repeat						# Bandlinien-Analyse
[	call pop(ksymbl,tx,ty,ux,uy,vx,vy,bb,error)
	if (error) goto EREXIT
	if (show) write(1,20) kalpha(ksymbl)
	20 format(/' Keller-Symbol ',a1)
	if	(ksymbl==XS) call sprod(error)
	else if (ksymbl==XA) call aprod(error)
	else if (ksymbl==XB) call bprod(error)
	else if (ksymbl==XC) call cprod(error)
	else if (ksymbl==XD) call dprod(error)
	else if (ksymbl==XE) call eprod(error)
	else if (ksymbl==XF) call fprod(error)
	else if (ksymbl==XAT !! ksymbl==XBT !! ksymbl==XX)
	[	if (zustnd==ZJ) 			# Anfangsstueck
		[	if (ksymbl==XX)
			[	ysymbl=XX ; goto NEXTSY ]
			if (ksymbl==XAT)
			[	w2=awinkl(ux-tx,uy-ty) ; bp=bb 
				ysymbl=EE ; zustnd=ZG ]
			else
			[	ysymbl=YF ; bp=0. ]
			tpx=tx ; tpy=ty ; upx=ux ; upy=uy
			ap=0 ; dp=idist(tx,ty,ux,uy)
			cpx=dp*mittp(tx,ux) ; cpy=dp*mittp(ty,uy)
			fp=ffunkt(tx,ty,ux,uy) ; lp=rdist(tx,ty,ux,uy) 
			mp=0 ; np=1
		]
		else if (zustnd==ZG)			# Geradenstueck
		[	if (ksymbl==XAT)
			[	w1=w2 ; w2=awinkl(ux-tx,uy-ty)
				dw = dwinkl(w1,w2) ; wsymbl=wtyp(dw,zustnd)
				if (wsymbl==ZG)	[ upx=ux ; upy=uy ]
				else [	upx=mittp(tx,ux) ; upy=mittp(ty,uy) ]
				ap=ap+dw ; bp=bp+bb
				i=idist(tx,ty,upx,upy)
				cpx=cpx+i*mittp(tx,upx)
				cpy=cpy+i*mittp(ty,upy)
				dp=dp+i
				fp=fp+ffunkt(tx,ty,upx,upy)
				lp=lp+rdist(tx,ty,upx,upy)
				mp=max0(mp,iabs(dw)) ; np=np+1
				px=upx ; py=upy
				ysymbl=EE ; zustnd=wsymbl
			]
			else 
			[	call push(ksymbl,tx,ty,ux,uy,vx,vy,bb,error)
				ksymbl=EE ; ysymbl=YG ; zustnd=ZH
		]	]
		else if (zustnd==ZL !! zustnd==ZR)	# Links/Rechtskurve
		[	if (ksymbl==XAT)
			[	w1=w2 ; w2=awinkl(ux-tx,uy-ty)
				dw = dwinkl(w1,w2) ; wsymbl=wtyp(dw,zustnd)
				if (wsymbl==zustnd !! wsymbl==ZG)
				[	px=mittp(tx,ux) ; py=mittp(ty,uy)
					ap=ap+dw ; bp=bp+bb
					i=idist(upx,upy,tx,ty)
					cpx=cpx+i*mittp(upx,tx)
					cpy=cpy+i*mittp(upy,ty)
					j=idist(tx,ty,px,py)
					cpx=cpx+j*mittp(tx,px)
					cpy=cpy+j*mittp(ty,py)
					dp=dp+i+j
					fp=fp+ffunkt(upx,upy,tx,ty)
					fp=fp+ffunkt(tx,ty,px,py)
					lp=lp+rdist(upx,upy,tx,ty)
					lp=lp+rdist(tx,ty,px,py)
					upx=px ; upy=py
					mp=max0(mp,iabs(dw))
					np=np+1 ; ysymbl=EE
				]
				else
				[	call push(ksymbl,tx,ty,ux,uy,vx,vy,bb,error)
					ksymbl=EE ; ysymbl=zustnd ; zustnd=ZH
					# wsymbl kennzeichnet Folgekurve!
			]	]
			else
			[	wsymbl=ksymbl
				if (ksymbl==XBT) [ upx=tx ; upy=ty ]
				else [	upx=ux ; upy=uy ]
				i=idist(px,py,upx,upy)
				cpx=cpx+i*mittp(px,upx)
				cpy=cpy+i*mittp(py,upy)
				dp=dp+i
				fp=fp+ffunkt(px,py,upx,upy)
				lp=lp+rdist(px,py,upx,upy)
				call push(ksymbl,tx,ty,ux,uy,vx,vy,bb,error)
				ksymbl=EE ; ysymbl=zustnd ; zustnd=ZH
				# wsymbl kennzeichnet Folgekurve!
		]	]
		else if (zustnd==ZH)			# Folgekurve
		[	if (ksymbl==XX)
			[	ysymbl=XX ; goto NEXTSY ]
			else if (ksymbl==XBT)
			[	tpx=tx ; tpy=ty ; upx=ux ; upy=uy
				ap=0 ; bp=0.
				dp=idist(tx,ty,ux,uy)
				cpx=dp*mittp(tx,ux) ; cpy=dp*mittp(ty,uy)
				fp=ffunkt(tx,ty,ux,uy) ; lp=rdist(tx,ty,ux,uy)
				mp=0 ; np=1
				ysymbl=YF ; zustnd=ZJ
			]
			else
			[	tpx=px ; tpy=py
				upx=mittp(tx,ux) ; upy=mittp(ty,uy)
				ap=dw ; bp=bb
				i=idist(px,py,tx,ty) ; j=idist(tx,ty,upx,upy)
				cpx=i*mittp(px,tx) + j*mittp(tx,upx)
				cpy=i*mittp(py,ty) + j*mittp(ty,upy)
				dp=i+j
				fp=ffunkt(px,py,tx,ty) + ffunkt(tx,ty,upx,upy)
				lp=rdist(px,py,tx,ty) + rdist(tx,ty,upx,upy)
				px=upx ; py=upy
				mp=iabs(dw) ; np=1
				ysymbl=EE ; zustnd=wsymbl
		]	]
		if (ksymbl==XAT !! ksymbl==XBT)
		[	call mark(tx,ty,ux,uy)	# Bandlinien-Element markieren
	]	]
	else error=.true.
NEXTSY
] until (ysymbl<>EE !! error)
if (error) goto EREXIT
#
if (ysymbl<>XX)				# endgueltige Attributwerte berechnen
[	bp=bp/np
	if (dp>>0) [ cpx=cpx/dp ; cpy=cpy/dp ]
	ep=idist(tpx,tpy,upx,upy)
	if (show)
	[	write(1,30) tpx,tpy,upx,upy
		write(1,31) ap,bp
		write(1,32) cpx,cpy
		write(1,33) dp,ep
		write(1,34) fp,lp
		write(1,35) mp,np
		30 format(' Endpunkte',4i4)
		31 format(' A,B      ',i4,f6.2)
		32 format(' C        ',2f6.2)
		33 format(' D,E      ',2i4)
		34 format(' F,L      ',2f6.2)
		35 format(' M,N      ',2i4)
		mwaend=iround(float(ap)/np)	# mittl.Winkelaenderung
		write(1,38) mwaend
		38 format(' mittl.dW ',i4)
	]
	if (ysymbl==ZL !! ysymbl==ZR)			# Kurve sanft/scharf?
	[	ap=iabs(ap) ; sharp=.false.
		if (ap>=90 && lp>=5)
			if (10*lp<<ap !! 30*ep<<ap !! 3*mp>=2*ap) sharp=.true.
		if (ysymbl==ZL) 
			if (sharp)	ysymbl=YL2
			else 		ysymbl=YL1
		else
			if (sharp)	ysymbl=YR2
			else 		ysymbl=YR1
]	]
ysymbl=palpha(ysymbl)
write(1,90) ysymbl
90 format(' *** PRIMEX - Symbol',a4,'***')
return
#
EREXIT	write(1,99) top,kalpha(ksymbl)
99 format(' PRIMEX - Error bei Stack-Top',i4,' Symbol',a3,'***')
error=.true.
return
end
