c************
c  Description:	This module contains the non-XWindows graphics support
c		for routines that use FACILITIES.  The FACILITIES
c		themselves are not defined here.
c
c  Author:	JGS   4//90
c		Split from glibf.for 6/9/93
c
c  $Revision: 1.3 $
c  $Modtime:   31 Jul 1997 18:22:34  $
c  
c************

c************
c Actual routine called by MX$FACILITIES passing the Mx structure.  
c MX$FACILITIES is a C jacket in gjackets.c that passes its global 
c pointer to the Mx structure along with the other arguments.  See HELP 
c MX$FACILITIES for more info.
c************

	subroutine MXF$FACILITIES (Mx, Xf, type, mode)

	implicit none

	include 'types.inc'
	include 'midas.inc'
	include 'xprim.inc'
	include 'xfacilities.inc'
	include 'xwidgets.inc'
	include 'qmessdef.inc'
c arguments
	record /XFACILITIES/ Xf
	character*(*) type	! 'A'nnotate,'B'oxes,'C'ontrolPanel,'P'oints
	integer*4 mode		! see flags in xfacilities.inc
c locals
	record /MQD_NEWFILE/ MQD_NEWFILE
	record /MQD_TRACE/ MQD_TRACE
	character   fac, tag*4, sval*80, switch*128
	integer*4 i, n, is, PARSE_TAG, j
	real*8 dval
c code

	if (mode.eq.L_InitFacilities) then

	  do i = 1, M$LENGTHQ (type)

	    fac = type(i:i)

	    if (fac.eq.'A') then

	      Xf.annt.p = 0
	      Xf.adefault.p = 0
	      Xf.aview = .true.
	      Xf.nannt = 0
	      Xf.clip = .false.

	      if (Xf.mannt .lt. 0) then
		Xf.mannt = -Xf.mannt
	      elseif (M$GET_USWITCH('XFA',switch).gt.0) then
		if (M$SEARCH(switch,'=').ne.0) then
		  is = 1
		  do while (PARSE_TAG(is,switch,tag,sval,dval).ge.0)
		    if (tag.eq.'VIEW') then
		      if (sval .eq. 'OFF') Xf.aview = .false.
		    elseif (tag.eq.'FILE') then
		      MQD_NEWFILE.filename = sval
		      call MXU$ANNOTATE(Mx, Xf, MQD_NEWFILE, L_PreLoad)
		    elseif (tag.eq.'MAX') then
		      if (Xf.annt.p .ne. 0) then
			call M$WARNING('/XFA MAX tag must precede '//
     &			    'FILE tag(s), value ignored.')
		      else
			Xf.mannt = max(0.d0, dval)
		      endif
		    endif
		    is = is + 1
		  enddo
		else
		  Xf.mannt = max(0, M$GET_SWITCH('XFA'))
		endif
	      elseif (M$GET_USWITCH('XA',MQD_NEWFILE.filename).gt.0) then
		call MXU$ANNOTATE(Mx, Xf, MQD_NEWFILE, L_PreLoad)
	      endif

	    elseif (fac.eq.'B') then

	      Xf.box.p = 0
	      Xf.bview = .true.
	      Xf.bnumbers = -1
	      Xf.nbox = 0
	      Xf.clip = .false.

	      if (Xf.mbox .lt. 0) then
		Xf.mbox = -Xf.mbox
	      elseif (M$GET_USWITCH('XFB',switch).gt.0) then
	        if (M$SEARCH(switch,'=').ne.0) then
		  is = 1
		  do while (PARSE_TAG(is,switch,tag,sval,dval).ge.0)
		    if (tag.eq.'VIEW') then
		      if (sval .eq. 'OFF') Xf.bview = .false.
		    elseif (tag.eq.'NUMS') then
		      if (sval .eq. 'OFF') Xf.bnumbers = 0
		      if (sval .eq. 'ANNT') Xf.bnumbers = 1
		    elseif (tag.eq.'FILE') then
		      MQD_NEWFILE.filename = sval
		      call MXU$BOXES(Mx, Xf, MQD_NEWFILE, 
     &			    %val(Xf.ROUTINE.p), L_PreLoad)
		    elseif (tag.eq.'MAX') then
		      if (Xf.box.p .ne. 0) then
			call M$WARNING('/XFB MAX tag must precede '//
     &			    'FILE tag(s), value ignored.')
		      else
			Xf.mbox = max(0.d0, dval)
		      endif
		    endif
		    is = is + 1
		  enddo
		else
		  Xf.mbox = max(0, M$GET_SWITCH('XFB'))
		endif
	      endif


	    elseif (fac.eq.'C') then

	      Xf.con.p = 0
	      Xf.cpsetup.p = 0
	      Xf.current = 0
	      Xf.cmenulit = 0
	      Xf.configure = .false.
	      Xf.cstatus = 0
	      Xf.chcb.p = 0
	      Xf.ncon = 0

	      if (Xf.mcon.lt.0) then
		Xf.mcon = -Xf.mcon
	      elseif (M$GET_PSWITCH('XFC')) then
		Xf.mcon = max(0, M$GET_SWITCH('XFC'))
	      endif
	      call MX$CONTROL_PANEL(Xf, L_InitFacilities)

	    elseif (fac.eq.'P') then

	      Xf.point.p = 0
	      Xf.pwork.p = 0
	      Xf.psort = .true.
	      Xf.pline = 0
	      Xf.pdot = L_CircleSymbol
	      Xf.prad = 3
	      Xf.npoint = 0
	      Xf.clip = .false.

	      if (Xf.mpoint .lt. 0) then
		Xf.mpoint = -Xf.mpoint
	      elseif (M$GET_USWITCH('XFP',switch).gt.0) then
		if (M$SEARCH(switch,'=').ne.0) then
		  is = 1
		  do while (PARSE_TAG(is,switch,tag,sval,dval).ge.0)
		    if (tag.eq.'SORT') then
		      if (sval.eq.'OFF') Xf.psort = .false.
		    elseif (tag.eq.'LINE') then
		      Xf.pline = M$SEARCH('VHC', sval(1:1))
		    elseif (tag.eq.'SYM') then
		      j = 0
		      MQD_TRACE.linetype = 0
		      MQD_TRACE.thick = 0
		      MQD_TRACE.symbol = sval
		      MQD_TRACE.radius = Xf.prad
		      MQD_TRACE.color = L_XORColor
		      call MX$TRACE_MSG(MQD_TRACE, j, j, Xf.pdot, Xf.prad, j)
		    elseif (tag.eq.'RAD') then
		      Xf.prad = dval
		    elseif (tag.eq.'FILE') then
		      MQD_NEWFILE.filename = sval
		      call MXU$POINTS(Mx, Xf, MQD_NEWFILE, 
     &			    %val(Xf.ROUTINE.p), L_PreLoad)
		    elseif (tag.eq.'MAX') then
		      if (Xf.point.p .ne. 0) then
			call M$WARNING('/XFP MAX tag must precede '//
     &			    'FILE tag(s), value ignored.')
		      else
			Xf.mpoint = max(0.d0, dval)
		      endif
		    endif
		    is = is + 1
		  enddo
		else
		  Xf.mpoint = max(0, M$GET_SWITCH('XFP'))
		endif
	      endif
	    endif

	  enddo

	else

	  do i = 1, M$LENGTHQ (type)
	    fac = type(i:i)

	    if (fac.eq.'A' .and. Xf.mannt.gt.0) then
	      call MXU$ANNOTATE(Mx, Xf, %val(Xf.mqdloc.p), mode)

	    elseif (fac.eq.'B' .and. Xf.mbox.gt.0) then
	      call MXU$BOXES(Mx, Xf,
     &		%val(Xf.mqdloc.p), %val(Xf.ROUTINE.p), mode)

	    elseif (fac.eq.'C' .and.
     &	      (Xf.mcon.gt.0 .or. mode.eq.L_OneShot)) then
	      call MX$CONTROL_PANEL(Xf, mode)

	    elseif (fac.eq.'P' .and. Xf.mpoint.gt.0) then
	      call MXU$POINTS(Mx, Xf,
     &		%val(Xf.mqdloc.p), %val(Xf.ROUTINE.p), mode)

	    endif

	  enddo

	endif

	return
	end

	integer*4 function PARSE_TAG (is, string, tag, sval, dval)

	implicit none
	include 'types.inc'
c Arguments
	integer*4	is
	character*(*)	string, tag, sval
	real*8		dval
c Locals
	integer*4 ls, i, j, iis, it
c Code
	PARSE_TAG = -1

	if (string(1:1) .eq. '(') then
	  ls = M$LENGTHD(string) - 1
	  i = 2
	else
	  ls = M$LENGTH(string)
	  i = 1
	endif

	do it = 1, is-1
	  j = M$SEARCH(string(i:ls), ',')
	  if (j.eq.0) return
	  i = i+j
	  if (i.gt.ls) return
	enddo

	j = i + M$SEARCH(string(i:ls), ',') - 1
	if (j.lt.i) j = ls+1
	tag = ' '
	sval = ' '
	if (j.eq.i) return

	it = i + M$SEARCH(string(i:j-1), '=') - 1
	if (it .lt. i) it = j
	tag = string(i:it-1)
	PARSE_TAG = it - i

	if (it .lt. j-1) then
	  ! remove quotes from quoted strings
	  if (string(it+1:it+1).eq.'"' .and. string(j-1:j-1).eq.'"') then
	    if (it+2.le.j-2) then
	      sval = string(it+2:j-2)
	    else
	      sval = ' '
	    endif
	    dval = 0.d0
	  ! copy string as is and attempt numeric conversion
	  else
	    sval = string(it+1:j-1)
	    if (M$A2D(sval,dval).le.0) dval = 0.d0
	  endif
	endif

	return
	end

	subroutine MX$XWIDGET (id)
c
	implicit none
	include 'types.inc'
	include 'midas.inc'
	include 'tables.inc'
	include 'xtypes.inc'
	character*160 mstring
	integer*4 l(4), id, idp, item, ln, ls, lw, n
	real*4 f(4)
	real*8 d(4)
	record /WIDGETSTRUCT/ wcb
	pointer (pwcb,wcb)
c
#if JEFF
	call M$WMAP(id,idp, lw, %val(Mu.sec_ptr(LS_cntrl_widgets)))
#endif
	pwcb = lw
	ln = M$LENGTH(wcb.name)
c
	if (wcb.type.eq.'M') then
	  item = MX$MENU(wcb.msel,wcb.menustr(1:wcb.ls))
	  if (item.ne.0) call M$MWPUT(id,item)
	else if (wcb.type.eq.'L') then
	  call M$MOVE(wcb.lval, l(1), 16)
	  call MX$LVAL(wcb.name(1:ln)//': ',l(1),l(2),l(3),l(4) ,id)
	  call M$LWPUT(id,l(1))
	else if (wcb.type.eq.'F') then
	  call M$MOVE(wcb.fval, f(1), 16)
	  call MX$FVAL(wcb.name(1:ln)//': ',f(1),f(2),f(3),f(4) ,id)
	  call M$FWPUT(id,f(1))
	else if (wcb.type.eq.'D') then
	  call M$MOVE(wcb.dval, d(1), 32)
	  call MX$DVAL(wcb.name(1:ln)//': ',d(1),d(2),d(3),d(4) ,id)
	  call M$DWPUT(id,d(1))
	else
	  call M$WARNING('Unknown widget type "'//wcb.type//'" in XWIDGET')
	endif
c
	return
	end

c**************************************************************************
c
c  ~Subroutine MXF$MSGVAL_POLL (Mx, xw)
c
c  /MX/		  Mx	    The MX graphics structure
c  /XWIDGET/	  xw	    Control panel structur
c  /MQ_QUEUESLOT/ queue(*)  The global message queue
c
c  This routine updates the xw.val field in the XWIDGET struct with the
c  current number of outstanding messages in the message queue, and if
c  the xwidget is displayed, calls a routine to draw message info into
c  its widget box.
c
c**************************************************************************

	subroutine MXF$MSGVAL_POLL (Mx, xw)
c
	implicit none
	include 'types.inc'
	include 'xprim.inc'
	include 'midas.inc'
	include 'tables.inc'
	include 'queue.inc'
	include 'xwidgets.inc'
	include 'xfacilities.inc'

	record /XWIDGET/ xw

	if (Mt.nmessage.le.0 .or. IAND(xw.mask,xfc_monitor).eq.0) then
	  xw.val = 0.d0
	  return
	else
	  xw.val = M$MSGFUNC(MSGF_QUEUED,xw.msgv.rid)
	endif

#if JEFF
	if (IAND(xw.mask,xfc_disp).ne.0) call Q_SCAN
     &	  (Mx, %val(Mu.sec_ptr(LS_messages)+L_message_hdr), xw)
#endif

	return
	end


	subroutine Q_SCAN (Mx, q, xw)
	implicit none
	include 'types.inc'
	include 'midas.inc'
	include 'xprim.inc'
	include 'tables.inc'
	include 'queue.inc'
	include 'xwidgets.inc'

	record /MQ_QUEUESLOT/ q(*)
	record /XWIDGET/ xw
	character 	temp*17
c+++
c DR 5366
c Old
c	integer*4 	ix, iy, n, rid, nmess, mask, buf, junk, Muqmess
c New
#if _PFC
	integer*4 	ix, iy, n, rid, nmess, mask, buf, junk, Muqmess
#else
	integer*4 	ix, iy, n, rid, nmess, mask, buf, junk
	integer*8	Muqmess
#endif
c---
	record /MQ_HEADER/ mqh

	ix = xw.x + Mx.text_w + 3
	iy = xw.y + (4 * Mx.text_h / 3) + 3
	nmess = min(NINT(xw.val), xw.msgv.nmsg)
	mask = MQK_PEEK + MQK_TOP + MQK_NOLOCK + MQK_READER
	rid = xw.msgv.rid

	n = 0
#if JEFF
	Muqmess = Mu.qmess
#endif
	do while (n.lt.nmess)
	  mqh.reader = rid
	  if (M$GET_MSG(mqh,buf,0,0.0,mask).ne.0) then
	    write(temp,10) mqh.name, mqh.sender, mqh.reader
	    iy = iy + Mx.text_h
	    call MX$TEXT(ix, iy, temp)
	    n = n + 1
	    mask = MQK_PEEK + MQK_NOLOCK + MQK_READER
	    junk = M$GET_MSG(mqh,buf,0,0.0,mask+MQK_ADVANCE)
	  else
	    nmess = n
	  endif
	enddo

	if (xw.msgv.last .gt. n) then
	  iy = iy + Mx.text_h * .3
	  call MX$CLEAR_AREA(xw.x+5, iy, xw.w-10, (xw.msgv.last-n)*Mx.text_h)
	endif
	xw.msgv.last = n
#if JEFF
	Mu.qmess = Muqmess
#endif

 10	format (a8,' ',i3,'->',i3)

	return
	end

	subroutine MX$TRACE_MSG (mqd, linetype, thick, symbol, radius, color)
	implicit none
	include 'types.inc'
	include 'xstructures.inc'
	include 'qmessdef.inc'
	record /MQD_TRACE/ mqd
	integer*4 linetype, thick, symbol, radius, color
	integer*4 is, ls, PARSE_TAG
	character tag*8, switch*128, sval*80
	real*8 dval

	if (color .eq. 999) then
	  MQD.linetype = 0
	  MQD.thick = 0
	  MQD.symbol = ' '
	  MQD.radius = 0
	  MQD.color = 0
	  ls  = M$GET_USWITCH('TRACE', switch)
	  if (ls.le.1) then
	  elseif (M$SEARCH(switch(1:ls),'=').ne.0) then
	    is = 1
	    do while (PARSE_TAG(is,switch(1:ls),tag,sval,dval).ge.0)
	      if (tag.eq.'LINE') then
		MQD.linetype = M$SEARCH('NVHCBS', sval(1:1)) - 1
		if (MQD.linetype.le.0) MQD.linetype = -MQD.linetype - 1
	      elseif (tag.eq.'SYM') then
		MQD.symbol = sval
	      elseif (tag.eq.'THK') then
		MQD.thick = dval
	      elseif (tag.eq.'RAD') then
		MQD.radius = dval
	      endif
	      is = is + 1
	    enddo
	  endif
	endif

	if (MQD.linetype.ne.0) linetype = max(0,MQD.linetype)
	if (MQD.thick.ne.0) thick = MQD.thick

	ls = M$LENGTH(mqd.symbol)

	if (ls.eq.0) then
	  ! ignore
	elseif (M$SEARCH('NONE', mqd.symbol(1:ls)).eq.1) then
	  symbol = 0
	  radius = 0
	elseif (M$SEARCH('PIXELS', mqd.symbol(1:ls)).eq.1) then
	  symbol = L_PixelSymbol
	elseif (M$SEARCH('CIRCLES', mqd.symbol(1:ls)).eq.1) then
	  symbol = L_CircleSymbol
	elseif (M$SEARCH('SQUARES', mqd.symbol(1:ls)).eq.1) then
	  symbol = L_SquareSymbol
	elseif (mqd.symbol .eq. '+') then
	  symbol = L_PlusSymbol
	elseif (mqd.symbol .eq. 'X') then
	  symbol = L_XSymbol
	elseif (M$SEARCH('TRIANGLES', mqd.symbol(1:ls)).eq.1) then
	  symbol = L_TriangleSymbol
	elseif (M$SEARCH('ITRIANGLES', mqd.symbol(1:ls)).eq.1) then
	  symbol = L_ITriangleSymbol
	elseif (mqd.symbol(1:6) .eq. 'ASCII:') then
	  symbol = ICHAR(mqd.symbol(7:7))
	else
	  call M$WARNING('TRACE unknown symbol "'//mqd.symbol//'" ignored.')
	endif

	if (MQD.radius.ne.0) radius = MQD.radius
	if (MQD.color.gt.L_NoColor .and. MQD.color.le.L_color) then
	  if (MQD.color .ne. 0) color = MQD.color
	endif

	return
	end
