c************
c   Description: General purpose 3D plotter
c
c   Author:    JGS   4/95
c
c   $Revision: 1.1 $
c   $Modtime:   20 Jul 1997 06:59:26  $
c
c	11-03 JLR/EHG  DR 500002 For Intel Compiler, changed .not. to not and type to write.
c
c************
	program XP3D
	include 'xp3d.inc'
 
	call M$CHECKIN
	call XP3D_INIT ()

	call M$SYNC ()
	call XP3D_PLOT ()

	do while (Gx.status .ge. 0 .and. .not. (Mx.breakflag.or.Mc.break))
	  Gx.status = 0
	  call XP3D_EVENT ()
	  call XP3D_MESSAGE ()
	  if (Gx.status .eq. 0) call M$PAUSE(Mc.pause)
	enddo

	call XP3D_END ()
	call M$RETURN

	end


	subroutine XP3D_INIT ()
	include 'xp3d.inc'
c
c init parameters
	Gx.status = 0
	Gx.view = max(1,min(2,M$GET_SWITCH('VIEW')))   ! 1=XY 2=persp 
	Gx.spec = M$GET_SWITCH('SPECS') .ne. 0  ! Display mouse specs text
	Gx.axes = M$GET_SWITCH('AXES') .ne. 0	! Display axes on plots
	Gx.split= M$GET_PSWITCH('SPLIT')	! Split zoom mode
	Gx.cbar = M$GET_PSWITCH('CBAR')		! display colorbar
	Gx.prop = .false.			! Proportional X/Y/Z
	Gx.autof = .false.			! Auto Fast mode
	Gx.cross= .false.			! Crosshairs on cursor
	Gx.fast = .false.			! Fast plot mode 
	Gx.pan  = .true.			! Enable panning on zooms
	Gx.hide = .false.			! Hidden lines
	Gx.hold = .false.			! Disable hold mode
	Gx.zk = 1				! last zoom level
	Gx.zs = 0				! last split mode
	Gx.zspec = 0
	Gx.speed = 0.040		! min display time in seconds (25 Hz)
	Gx.pdis = 4
	Gx.azim = 0
	Gx.elev = 0
	Gx.roll = 0
	call XP3D_RESET (4)
	call XP3D_CROSS (0)
c
c set sefault line modes
	Gx.t2mode = 2**P_MESH + 2**P_MESHC + 2**P_DOTSC + 
     &			2**P_FILLC + 2**P_CONT + 2**P_CONTC
c
c open X-window display and root window
	Mx.origin = 1
	call MX$GRAPHICSINIT()
	call MXF$SETUP (Mx,Mc.width,Mc.height) 
	call MX$OPEN ('X-P3D')
c
c backing store setup
	Gx.bs = M$GET_SWITCH('BS') .ne. 0
	do k = 1,L_stack
	  Gx.bsmap(k).ip = 0
	enddo
c
c get control mode
	Gx.cntrls = M$GET_SWITCH ('XCNT')
	if (Gx.cntrls.gt.2 .or. Gx.cntrls.lt.0) Gx.cntrls = 1
c
c init scales
	call XP3D_RESET (-1)
	Gx.c1 = 0
	Gx.c2 = 1
	Gx.ncolors = 16
c
c init the layer files (FILE1|FILE2|FILE3...)
	Gx.nlayer = 0
	call XP3D_LOAD (P_LAYER, M$APICK(1))
	call XP3D_AUTOSCALE (0)
c
c loop through the positionally independent parameters
	i = 2
	do while (M$PPICK(i))
	  str = M$UPICK(i)
	  j = M$SEARCH(str,'=')
	  if (j.eq.0) then
	    call M$WARNING ('Argument is not PosInd: '//str)	
	  elseif (M$A2D(str(j+1:),dval).le.0) then
	    call M$WARNING ('Problem parsing key value: '//str)	
	  else
	    call XP3D_SETD (str(1:j-1),-1,dval)
	  endif
	  i = i+1
	enddo
c
c define the colormap
	Gx.cmap = M$GET_SWITCH('XC')
	if (Gx.cmap.le.0) Gx.cmap = 2
	if (M$GET_USWITCH('XCF',str).le.0) str = ' '
	call XP3D_COLORS (0,str)
c
c rubberband for images
	call MX$DRAW_MODE (901)
c
c init the facilities structures
	call XP3D_FACILITIES (0)
	Gx.xf.msgid   = M$GET_SWITCH ('MSGID')
	Gx.xf.msgmask = max (0, M$GET_SWITCH ('MASK'))
c
	return
	end

	subroutine XP3D_SETD (key,info,dval)
	include 'xp3d.inc'
	pointer (ply,ly)
	integer*4 ncolors,info
	character key*(*)

	if     (key .eq. 'NC' .or. key .eq. 'CD') then
	  ncolors = Gx.ncolors
	  if (key.eq.'NC') Gx.ncolors = dval
	  if (key.eq.'CD') Gx.ncolors = max(1, NINT( (Gx.c2-Gx.c1)/dval ) )
	  if (Gx.ncolors .ne. ncolors .and. info.ge.0)
     &	    call MX$COLORMAP (Gx.color(Gx.cmap), Gx.ncolors)
	elseif (key .eq. 'C1') then
	  Gx.c1 = dval
	elseif (key .eq. 'C2') then
	  Gx.c2 = dval
	elseif (key .eq. 'XU') then
	  Gx.xu = dval
	elseif (key .eq. 'X1') then
	  Gx.x1 = dval
	elseif (key .eq. 'X2') then
	  Gx.x2 = dval
	elseif (key .eq. 'YU') then
	  Gx.yu = dval
	elseif (key .eq. 'Y1') then
	  Gx.y1 = dval
	elseif (key .eq. 'Y2') then
	  Gx.y2 = dval
	elseif (key .eq. 'ZU') then
	  Gx.zu = dval
	elseif (key .eq. 'Z1') then
	  Gx.z1 = dval
	elseif (key .eq. 'Z2') then
	  Gx.z2 = dval
	elseif (key .eq. 'VIEW') then
	  Gx.view = max(1,min(2,NINT(dval))) 
	elseif (key .eq. 'PAN') then
	  Gx.pan = dval .gt. 0
	elseif (key .eq. 'BS') then
	  Gx.bs = dval .gt. 0
	elseif (key .eq. 'SPLIT') then
	  Gx.split = dval .gt. 0
	elseif (key .eq. 'AUTOF') then
	  Gx.autof = dval .gt. 0
	elseif (key .eq. 'CROSS') then
	  Gx.cross = dval .gt. 0
	elseif (key .eq. 'AXES') then
	  Gx.axes = dval .gt. 0
	elseif (key .eq. 'ASPECT') then
	  Gx.prop = dval .gt. 0
	elseif (key .eq. 'SPECS') then
	  Gx.spec = dval .gt. 0
	elseif (key .eq. 'CBAR') then
	  Gx.cbar = dval .gt. 0
	elseif (key .eq. 'FAST') then
	  Gx.fast = dval .gt. 0
	elseif (key .eq. 'HIDE') then
	  Gx.hide = dval .gt. 0
	elseif (key .eq. 'HOLD') then
	  Gx.hold = dval .gt. 0
	elseif (key .eq. 'ENABLE' .or. key .eq. 'LAYER' 
     &			.and. info .gt. 0) then
          lval = dval
          ply = Gx.lloc(info)
          if (lval.eq.0) ly.enable = JIBCLR(ly.enable,PM_GLOBAL)
          if (lval.eq.1) ly.enable = JIBSET(ly.enable,PM_GLOBAL)
          if (lval.gt.1) ly.enable = lval
 	elseif (key .eq. 'XCNT') then
	  Gx.cntrls = dval
	elseif (key .eq. 'T2MODE') then
	  Gx.t2mode = dval
	else
	  call M$WARNING ('Unrecognized key: '//key)
	endif
	if (Gx.ncolors .ne. ncolors .and. ncolors.gt.0) then
	endif
	return
	end


	subroutine XP3D_LOAD (type,string)
	include 'xp3d.inc'
	pointer (ply,ly)
	record /HEADER/ hcb
	integer*4 type
	character string*(*)

	if (type.eq.P_LAYER) then				! layer files
	  str = string
	  do while (M$LENGTH(str).gt.0)
	    j = M$SEARCH(str,'|')
	    if (j.eq.0) j = M$LENGTH(str)+1
	    hcb.file_name = str(1:j-1)
	    i = M$APICK_POST (hcb.file_name, j-1)
	    call M$MALLOC (L_layersz,ply)
	    call XP3D_GET_DATA (ly,hcb.file_name,0)
	    if (ly.nelem .ge. 0) then
	      Gx.nlayer = Gx.nlayer+1
	      Gx.lloc(Gx.nlayer) = ply
	    else
	      call MX$MESSAGE ('Couldnt open file: '//str(1:j-1),1.0)
	      call M$FREE (ply)
	    endif
	    str = str(j+1:)
	  enddo

	endif

	return
	end


	subroutine XP3D_UNLOAD (type)
	include 'xp3d.inc'
	pointer (ply,ly)
	integer*4 type

	if (type.eq.P_LAYER .or. type.eq.0) then	! layers
	  do n = Gx.nlayer,1,-1
	    ply = Gx.lloc(n) 
	    if (BTEST(ly.enable,PM_BS)) Gx.bsmask = 0
	    call M$FREE (ly.bufloc)
	    call M$FREE (ply)
	  enddo
	  Gx.nlayer = 0
	endif

	return
	end


	subroutine XP3D_RELOAD (type,index)
	include 'xp3d.inc'
	pointer (ply,ly)
	integer*4 type,index

	if (type.eq.1 .or. type.eq.0) then	! layers
	  do n = Gx.nlayer,1,-1
	    if (n.eq.index .or. index.eq.0) then
	      ply = Gx.lloc(n) 
	      if (BTEST(ly.enable,PM_BS)) Gx.bsmask = 0
	      call M$FREE (ly.bufloc)
	      call XP3D_GET_DATA (ly,ly.name,1)
	    endif
	  enddo
	endif

	return
	end


	subroutine XP3D_PLOT ()
	include 'xp3d.inc'
	call XP3D_RESET (0)
	call XP3D_REFRESH (0)
	return
	end


	subroutine XP3D_RESET (flag)
	! flag: 0=normal -1=init 1=base 2=wide -2=narrow 3=resize
	include 'xp3d.inc'
c
c transformation matix
	if (flag .eq. 4) then
	  call M$MATRIX_IDN (Gx.M)
	  call M$MATRIX_ROT (Gx.M, dble(Gx.roll), P_ROLL)
	  call M$MATRIX_ROT (Gx.M, dble(Gx.elev), P_ELEV)
	  call M$MATRIX_ROT (Gx.M, dble(Gx.azim), P_AZIM)
	  call M$MATRIX_INV (Gx.M, Gx.MI)
	  return
	endif
c
c initialization pass
	if (flag .eq. -1) then
	  Gx.x1 = 0
	  Gx.x2 = 1
	  Gx.y1 = 0
	  Gx.y2 = 1
	  Gx.z1 = 0
	  Gx.z2 = 1
	  Gx.x1p = -1.4
	  Gx.x2p = 1.4
	  Gx.y1p = -1.4
	  Gx.y2p = 1.4
	  Mx.level = 1
	endif
	Gx.bsmask = 0
c
c set text size
	m = min(8,Mx.width/102)
	call MX$SETFONT (m)
	if (flag.eq.3) return
c
c initialize plot request range
	k = Mx.level
	Mx.level = 1
	if (flag .eq. 2 .or. flag.eq.-2) then   ! wide/narrow view
	  dval = 6
	  if (flag.eq.2) dval = 1/dval
	  Mx.stk(1).xmin = Mx.stk(1).xmin * dval
	  Mx.stk(1).xmax = Mx.stk(1).xmax * dval
	  Mx.stk(1).ymin = Mx.stk(1).ymin * dval
	  Mx.stk(1).ymax = Mx.stk(1).ymax * dval
	elseif (Gx.view .eq. 1) then
	  if (flag.eq.1) then
	    Gx.x1 = Mx.stk(k).xmin
	    Gx.x2 = Mx.stk(k).xmax
	    Gx.y1 = Mx.stk(k).ymin
	    Gx.y2 = Mx.stk(k).ymax
	  endif
	  Mx.stk(1).xmin = Gx.x1
	  Mx.stk(1).xmax = Gx.x2
	  Mx.stk(1).ymin = Gx.y1
	  Mx.stk(1).ymax = Gx.y2
	else
	  if (flag.eq.1) then
	    Gx.x1p = Mx.stk(k).xmin
	    Gx.x2p = Mx.stk(k).xmax
	    Gx.y1p = Mx.stk(k).ymin
	    Gx.y2p = Mx.stk(k).ymax
	  endif
	  Mx.stk(1).xmin = Gx.x1p
	  Mx.stk(1).xmax = Gx.x2p
	  Mx.stk(1).ymin = Gx.y1p
	  Mx.stk(1).ymax = Gx.y2p
	  if (Gx.split) then
	    ! no adjustments
	  elseif (Mx.width .gt. Mx.height) then
	    ratio = float(Mx.width)/float(Mx.height)
	    Mx.stk(k).xmin = Mx.stk(k).xmin * ratio
	    Mx.stk(k).xmax = Mx.stk(k).xmax * ratio
	  else
	    ratio = float(Mx.height)/float(Mx.width)
	    Mx.stk(k).ymin = Mx.stk(k).ymin * ratio
	    Mx.stk(k).ymax = Mx.stk(k).ymax * ratio
	  endif
	endif
	return
	end

	subroutine XP3D_REFRESH (flag)
	! flag: 0=normal -1=nullbs 1=zoom 2=fast 3=fast/NoBS 4=justgrid
	include 'xp3d.inc'
c
c invalidate BS masks at all levels ?
	k = Mx.level
	if (Gx.bsmask.eq.0 .or. (Gx.zs.neqv.Gx.split) .or. flag.eq.-1) then
	  do i = 1,k
	    Gx.bsmap(i).mask = 0
	  enddo
	endif
	if (Gx.hold) return ! handle multiple messages before refresh
	if (Mx.icon) return ! dont draw when iconified
c
c split mode clears
	if (Gx.zs .and. Gx.zk.gt.1) call XP3D_DRAW_SZZ ()
	if ((flag.eq.-1) .or. (Gx.zs.neqv.Gx.split) .or. 
     &	    (Gx.zk.gt.1 .and. k.eq.1) ) call MX$CLEAR_WINDOW ()
c
c draw view
	if (Gx.split .and. k.gt.1 .and. 
     &		(flag.le.0 .or. Gx.bsmask.eq.0) ) then
	  Mx.level = 1
	  call XP3D_REFRESH_VIEW (flag)
	  call XP3D_FACILITIES (2)
	  Mx.level = k
	endif
	call XP3D_REFRESH_VIEW (flag)
	call XP3D_FACILITIES (1)
c
c draw split zoom region rubber box
	if (Gx.split .and. k.gt.1) then
	  Gx.zx = (Mx.stk(k).xmin-Mx.stk(1).xmin)/Mx.stk(1).xscl+Mx.stk(1).x1
	  Gx.zy = (Mx.stk(1).ymax-Mx.stk(k).ymax)/Mx.stk(1).yscl+Mx.stk(1).y1
	  Gx.zw = (Mx.stk(k).xmax-Mx.stk(k).xmin)/Mx.stk(1).xscl
	  Gx.zh = (Mx.stk(k).ymax-Mx.stk(k).ymin)/Mx.stk(1).yscl
	  call XP3D_DRAW_SZZ ()
	endif
	Gx.zk = k
	Gx.zs = Gx.split
	Gx.bsmask = -1
c
c draw colorbar
	if (flag.lt.2) call XP3D_CBAR ()
c
c draw specs
	if (Gx.spec) call XP3D_SPECS ()
	Mx.stk(k+1) = Mx.stk(k)
	return
	end


	subroutine XP3D_REFRESH_VIEW (flag)
	include 'xp3d.inc'
	pointer (ply,ly)
	integer*4 curmask,newmask,addmask,delmask,bsmask,drawmask
	logical*4 oldfast
c
c set window borders
	k = Mx.level
	ii = Mx.width
	if (Gx.cbar) ii = ii - Mx.text_w*3
	if (Gx.cbar .and. Gx.axes) ii = ii - Mx.text_w*5
	if (Gx.split .and. k.eq.1) then
	  ix1 = 0
	  ix2 = ii/2
	elseif (Gx.split) then
	  ix1 = ii/2
	  ix2 = ii
	else
	  ix1 = 0
	  ix2 = ii
	endif
	iy1 = 0
	iy2 = Mx.height
	if (Gx.spec) iy2 = iy2 - Mx.text_h*2

	if (Gx.axes) then
	  Mx.stk(k).x1 = ix1 + Mx.text_w*6
	  Mx.stk(k).x2 = ix2 - Mx.text_w*3
	  Mx.stk(k).y1 = iy1 + Mx.text_h*2
	  Mx.stk(k).y2 = iy2 - Mx.text_h*2
	else
	  Mx.stk(k).x1 = ix1 + 2
	  Mx.stk(k).x2 = ix2 - 4
	  Mx.stk(k).y1 = iy1 + 2
	  Mx.stk(k).y2 = iy2 - 4
	endif
	if (Gx.pan .and. k.gt.1 .and. .not.Gx.axes) then
	  Mx.stk(k).y1 = Mx.stk(k).y1 + Mx.text_h
	  Mx.stk(k).x2 = Mx.stk(k).x2 - Mx.text_h
	endif

	ix =  (Mx.stk(k).x2-Mx.stk(k).x1)
	iy =  (Mx.stk(k).y2-Mx.stk(k).y1)
	Mx.stk(k).xscl = (Mx.stk(k).xmax-Mx.stk(k).xmin)/ix
	Mx.stk(k).yscl = (Mx.stk(k).ymax-Mx.stk(k).ymin)/iy
	if (Gx.view.gt.1 .or. Gx.prop) then
	  dval =  Mx.stk(k).yscl / Mx.stk(k).xscl 
	  if (dval .gt. 1.d0) then
	    Mx.stk(k).xscl = Mx.stk(k).yscl
	    if (Gx.view.gt.1) then
	      dval = (Mx.stk(k).xmax+Mx.stk(k).xmin)*.5
	      Mx.stk(k).xmin = dval-ix*Mx.stk(k).xscl*.5
	      Mx.stk(k).xmax = dval+ix*Mx.stk(k).xscl*.5
	    else
	      i = (Mx.stk(k).x2-Mx.stk(k).x1)/2
	      ii = (Mx.stk(k).x2+Mx.stk(k).x1)/2
	      Mx.stk(k).x1 = ii - i/dval
	      Mx.stk(k).x2 = ii + i/dval
	    endif
	  else
	    Mx.stk(k).yscl = Mx.stk(k).xscl
	    if (Gx.view.gt.1) then
	      dval = (Mx.stk(k).ymax+Mx.stk(k).ymin)*.5
	      Mx.stk(k).ymin = dval-iy*Mx.stk(k).yscl*.5
	      Mx.stk(k).ymax = dval+iy*Mx.stk(k).yscl*.5
	    else
	      i = (Mx.stk(k).y2-Mx.stk(k).y1)/2
	      ii = (Mx.stk(k).y2+Mx.stk(k).y1)/2
	      Mx.stk(k).y1 = ii - i*dval
	      Mx.stk(k).y2 = ii + i*dval
	    endif
	  endif
	endif
c
c init transformations
	call DRAW_INIT()
c
c invoke clip region
	call MX$CLIP (Mx.stk(k).x1, Mx.stk(k).y1,
     &    Mx.stk(k).x2-Mx.stk(k).x1, Mx.stk(k).y2-Mx.stk(k).y1)
c
c backing store layer masks
	oldfast = Gx.fast
	curmask = Gx.bsmap(k).mask
	if (Gx.bsmap(k).ip.eq.0 .or. flag.ne.0) curmask = 0
	newmask = 0
	bsmask = 0
	do n = 1,Gx.nlayer
	  ply = Gx.lloc(n)
	  if (XP3D_ENABLED(ly.enable,flag)) newmask = JIBSET (newmask,n)
	  if (BTEST(ly.enable,PM_BS)) bsmask = JIBSET (bsmask,n)
	enddo
c--CODE CHANGE: (.not. to not) for Intel Compiler JLR/EHG
	delmask = curmask .and. not(newmask)  
	if (delmask .ne. 0) curmask = 0
	addmask = newmask .and. not(curmask) 
c--	
	if (flag.eq.4) Gx.fast = .true. ! Fast mode
	if (flag.ge.2 .and. Gx.autof) Gx.fast = .true. ! Fast mode
	if (curmask.ne.0) then
	  call MX$MAP (Gx.bsmap(k),0,0,0,0,L_PutMap)
	  call MX$CLEAR_AREA (ix1,iy1,ix2-ix1,Mx.stk(k).y1-iy1)
	  call MX$CLEAR_AREA (ix1,Mx.stk(k).y2,ix2-ix1,iy2-Mx.stk(k).y2)
	  call MX$CLEAR_AREA (ix1,iy1,Mx.stk(k).x1-ix1,iy2-iy1)
	  call MX$CLEAR_AREA (Mx.stk(k).x2,iy1,ix2-Mx.stk(k).x2,iy2-iy1)
	else
	  call MX$CLEAR_AREA (ix1,iy1,ix2-ix1,iy2-iy1)
	endif
c
c draw 3D axes 
	if (Gx.axes) call XP3D_AXES (Gx.view, 0.0,0.0,0.0)
c
c draw pan bars
	ii = XP3D_PAN_HANDLE (0,i) 
c
c plot layers
	drawmask = addmask .and. bsmask
	do n = 1,Gx.nlayer
	  if (BTEST(drawmask,n)) call XP3D_DRAW_LAYER (%val(Gx.lloc(n)))
	enddo
	if (Gx.bs .and. drawmask.ne.0 .and. flag.le.2) ! Update BS pixmap
     +	    call MX$MAP (Gx.bsmap(k),Mx.stk(k).x1,Mx.stk(k).y1,
     +		Mx.stk(k).x2-Mx.stk(k).x1,Mx.stk(k).y2-Mx.stk(k).y1,L_NewMap)
c--CODE CHANGE: (.not. to not) for Intel Compiler JLR/EHG
	drawmask = addmask .and. not(bsmask) 
c--	
	do n = 1,Gx.nlayer
	  if (BTEST(drawmask,n)) call XP3D_DRAW_LAYER (%val(Gx.lloc(n)))
	enddo
	if (flag.gt.2 .or. .not. Gx.bs) newmask = 0
	Gx.bsmap(k).mask = newmask .and. bsmask
c
c clear clip
	call MX$CLIP (0,0,0,0)
	Gx.fast = oldfast
c
	return
	end


	subroutine XP3D_AXES (flag, x,y,z)
	include 'xp3d.inc'
	integer*4 L_axes
	parameter (L_axes=12)
	integer*4 pairs(2,L_axes), lc, ntrans
	real*4 buf(3,L_axes),buft(3,L_axes),bufc(3,8), x,y,z
	record /IPIXSTRUCT/ ipix(L_axes)
	data buf / 0,0,0, 1,0,0, 0,1,0, 0,0,1, 	-1,-1,-1, -1,-1,1, -1,1,1, 
     &		-1,1,-1, 1,-1,-1, 1,-1,1, 1,1,1, 1,1,-1 /
	data pairs / 5,9, 5,8, 5,6, 6,10, 7,11, 8,12, 6,7, 
     &			7,8, 9,10, 10,11, 11,12, 12,9 /
	data bufc / -1,-1,0, -1,1,0, 1,1,0, 1,-1,0,
     &		0,-1,0, 0,1,0, -1,0,0, 1,0,0 /
	character cax(3) /'X','Y','Z'/
	save

	if (flag.eq.1) then
	  call MX$DRAWAXIS (5, 5, Gx.xu, Gx.yu, .false.)
	  return

	elseif (flag.eq.2) then
	  call TRANSFORM (buf, buft, ipix, L_axes)
	  do k = 1,L_axes
	    i = pairs(1,k)
	    j = pairs(2,k)
	    if (k.le.3) then
	      lc = -1
	      call MX$COLORTEXT( lc, ipix(j).x+5, ipix(j).y+5, cax(k))
	    else
	      lc = PC_GREY1
	    endif
	    call MX$DRAW_LINE( lc, ipix(i).x, ipix(i).y, 
     &				   ipix(j).x, ipix(j).y)
	  enddo

	elseif (flag.eq.-2) then
	  lc = -2	! rubberband
	  do k = 1,8
	    bufc(3,k) = z
	  enddo
	  bufc(1,5) = x
	  bufc(1,6) = x
	  bufc(2,7) = y
	  bufc(2,8) = y
	  call TRANSFORM (bufc, buft, ipix, 8)
	  call MX$DRAW_LINE( lc, ipix(1).x,ipix(1).y,ipix(2).x,ipix(2).y)
	  call MX$DRAW_LINE( lc, ipix(2).x,ipix(2).y,ipix(3).x,ipix(3).y)
	  call MX$DRAW_LINE( lc, ipix(3).x,ipix(3).y,ipix(4).x,ipix(4).y)
	  call MX$DRAW_LINE( lc, ipix(4).x,ipix(4).y,ipix(1).x,ipix(1).y)
	  if (x.gt.-1.0 .and. x.lt.1.0) 
     &	  call MX$DRAW_LINE( lc, ipix(5).x,ipix(5).y,ipix(6).x,ipix(6).y)
	  if (y.gt.-1.0 .and. y.lt.1.0) 
     &	  call MX$DRAW_LINE( lc, ipix(7).x,ipix(7).y,ipix(8).x,ipix(8).y)
	endif

	return
	end


	subroutine XP3D_CROSS (flag)
	include 'xp3d.inc'
	integer*4 ixc,iyc,izc
	real*4 x,y,z
	logical*4 cross
	save
	
	k = Mx.level

	if (flag.gt.0) then
	  if (Gx.split .and. k.gt.1 .and. Mx.xpos.lt.Mx.stk(1).x2) k=1
	  cross = Gx.cross 
     &	.and.  Mx.xpos.ge.Mx.stk(k).x1 .and. Mx.xpos.le.Mx.stk(k).x2
     &	.and.  Mx.ypos.ge.Mx.stk(k).y1 .and. Mx.ypos.le.Mx.stk(k).y2
	  ixc = Mx.xpos
	  iyc = Mx.ypos
	  x = (Gx.retx-Gx.x1)/(Gx.x2-Gx.x1) *2-1
	  y = (Gx.rety-Gx.y1)/(Gx.y2-Gx.y1) *2-1
	  z = 0
	elseif (flag.lt.0) then
	  if (Gx.split .and. k.gt.1 .and. ixc.lt.Mx.stk(1).x2) k=1
	else
	  cross = .false.
	endif

	if (cross) then
	  call MX$RCLIP (Mx.stk(k).x1, Mx.stk(k).y1,
     &      Mx.stk(k).x2-Mx.stk(k).x1, Mx.stk(k).y2-Mx.stk(k).y1)
	  if (Gx.view.eq.1) then
	    call MX$RUBBERLINE (Mx.stk(k).x1,iyc,Mx.stk(k).x2,iyc)
	    call MX$RUBBERLINE (ixc,Mx.stk(k).y1,ixc,Mx.stk(k).y2)
	  else
	    x = 2*(Gx.retx-Gx.x1)/(Gx.x2-Gx.x1) - 1
	    y = 2*(Gx.rety-Gx.y1)/(Gx.y2-Gx.y1) - 1
	    z = 2*(Gx.retz-Gx.z1)/(Gx.z2-Gx.z1) - 1
	    call XP3D_AXES (-2, x,y,z)
	  endif
	  call MX$RCLIP (0,0,0,0)
	  if (flag.lt.0) cross = .false.
	endif

	return
	end


	subroutine XP3D_T2MODE (mask,flag)
	include 'xp3d.inc'
	integer*4 mask
	if (flag.eq.-1) then
	  ii = Mx.xpos
	  jj = Mx.ypos
 1	  Mx.xpos = ii
	  Mx.ypos = jj
	  str =  'T2 MODE;-Mesh,-MeshColor,-Dots,-DotColor,'//
     &		'-Fill,-FillColor,-Contours,-ContourColor'
	  i = M$SEARCH(str,'-Mesh')
	  if (BTEST(mask,P_MESH))  str(i:i) = '+'
	  i = M$SEARCH(str,'-MeshC')
	  if (BTEST(mask,P_MESHC))  str(i:i) = '+'
	  i = M$SEARCH(str,'-Dots')
	  if (BTEST(mask,P_DOTS))  str(i:i) = '+'
	  i = M$SEARCH(str,'-DotC')
	  if (BTEST(mask,P_DOTSC))  str(i:i) = '+'
	  i = M$SEARCH(str,'-Fill')
	  if (BTEST(mask,P_FILL))  str(i:i) = '+'
	  i = M$SEARCH(str,'-FillC')
	  if (BTEST(mask,P_FILLC))  str(i:i) = '+'
	  i = M$SEARCH(str,'-Cont')
	  if (BTEST(mask,P_CONT))  str(i:i) = '+'
	  i = M$SEARCH(str,'-ContourC')
	  if (BTEST(mask,P_CONTC))  str(i:i) = '+'
	  m = MX$MENU(0,str)
	  if (m.eq.0) return
	  if (m.eq.1) mask = mask .xor. JIBSET (0,P_MESH)
	  if (m.eq.2) mask = mask .xor. JIBSET (0,P_MESHC)
	  if (m.eq.3) mask = mask .xor. JIBSET (0,P_DOTS)
	  if (m.eq.4) mask = mask .xor. JIBSET (0,P_DOTSC)
	  if (m.eq.5) mask = mask .xor. JIBSET (0,P_FILL)
	  if (m.eq.6) mask = mask .xor. JIBSET (0,P_FILLC)
	  if (m.eq.7) mask = mask .xor. JIBSET (0,P_CONT)
	  if (m.eq.8) mask = mask .xor. JIBSET (0,P_CONTC)
	  goto 1
	endif
	return
	end

        function XP3D_ENABLED (enables,flag)
        include 'xp3d.inc'
        logical*4 ok
        integer*4 enables
	ok = BTEST(enables,PM_GLOBAL)
	if (flag.ge.2) then
	  if (Mx.level.eq.1 .and. .not.BTEST(enables,PM_FBASE)) ok=0
	  if (Mx.level.gt.1 .and. .not.BTEST(enables,PM_FZOOM)) ok=0
	else
	  if (Mx.level.eq.1 .and. .not.BTEST(enables,PM_BASE) ) ok=0
	  if (Mx.level.gt.1 .and. .not.BTEST(enables,PM_ZOOM) ) ok=0
	endif
	if (flag .eq. -9) then
	  enables = MX$MENUPLUS (enables,'ENABLES;Global,Labels,'//
     &	  'BackStore,Base,Zoom,FastBase,FastZoom', -1, 0, 0)
	endif
        XP3D_ENABLED = ok
        return
        end


	subroutine XP3D_AUTOSCALE (flag)
	include 'xp3d.inc'
	real*4 b(1),x1,x2,y1,y2,z1,z2,c1,c2
	pointer (ply,ly),(pb,b)

	x1 = +1e30
	x2 = -1e30
	y1 = +1e30
	y2 = -1e30
	z1 = +1e30
	z2 = -1e30
	c1 = +1e30
	c2 = -1e30

	do n = 1,Gx.nlayer
	  ply = Gx.lloc(n)
	  pb = ly.bufloc + ly.offset
	  i = 0
	  if (ly.type .eq. 1998 .or. ly.type .eq. 1999) then
	   if (ly.dim .eq. 3) then
	    do while (i .lt. ly.nelem*ly.spa)
	     if (b(i+2) .eq. -999) then
	      i = i + ly.spa * 3
	     else
	      if (b(i+3) .lt. x1) x1 = b(i+3)
	      if (b(i+5) .gt. x2) x2 = b(i+5)
	      if (b(i+4) .lt. y1) y1 = b(i+4)
	      if (b(i+6) .gt. y2) y2 = b(i+6)
	      if (b(i+2) .lt. z1) z1 = b(i+2)
	      if (b(i+2) .gt. z2) z2 = b(i+2)
	      i = i + ly.spa * NINT(b(i+1)+3)
	     endif
	    enddo
	   elseif (ly.dim .eq. 4) then
	    do while (i .lt. ly.nelem*ly.spa)
	     if (b(i+2) .eq. -999) then
	      i = i + ly.spa * 3
	     else
	      if (b(i+4) .lt. x1) x1 = b(i+4)
	      if (b(i+7) .gt. x2) x2 = b(i+7)
	      if (b(i+5) .lt. y1) y1 = b(i+5)
	      if (b(i+8) .gt. y2) y2 = b(i+8)
	      if (b(i+6) .lt. z1) z1 = b(i+6)
	      if (b(i+9) .gt. z2) z2 = b(i+9)
	      if (b(i+2) .lt. c1) c1 = b(i+2)
	      if (b(i+2) .gt. c2) c2 = b(i+2)
	      i = i + ly.spa * NINT(b(i+1)+3)
	     endif
	    enddo
	   endif

	  elseif (ly.type .eq. 2000) then
	    x1 = min(x1, ly.x1 + ly.xd*(ly.nx-1)/2 - abs(ly.xd)*ly.nx/2)
	    x2 = max(x2, ly.x1 + ly.xd*(ly.nx-1)/2 + abs(ly.xd)*ly.nx/2)
	    y1 = min(y1, ly.y1 + ly.yd*(ly.ny-1)/2 - abs(ly.yd)*ly.ny/2)
	    y2 = max(y2, ly.y1 + ly.yd*(ly.ny-1)/2 + abs(ly.yd)*ly.ny/2)
	    do i = 1,ly.nelem
	      if (b(i) .lt. z1) z1 = b(i)
	      if (b(i) .gt. z2) z2 = b(i)
	    enddo

	  ! the rest are type 3000
	  elseif (ly.dim .eq. 1) then
	    do while (i .lt. ly.nelem*ly.spa)
	      if (b(i+1) .lt. x1) x1 = b(i+1)
	      if (b(i+1) .gt. x2) x2 = b(i+1)
	      i = i + ly.spa
	    enddo
	  elseif (ly.dim .eq. 2) then
	    do while (i .lt. ly.nelem*ly.spa)
	      if (b(i+1) .lt. x1) x1 = b(i+1)
	      if (b(i+1) .gt. x2) x2 = b(i+1)
	      if (b(i+2) .lt. y1) y1 = b(i+2)
	      if (b(i+2) .gt. y2) y2 = b(i+2)
	      i = i + ly.spa
	    enddo
	  elseif (ly.dim .eq. 3) then
	    do while (i .lt. ly.nelem*ly.spa)
	      if (b(i+1) .lt. x1) x1 = b(i+1)
	      if (b(i+1) .gt. x2) x2 = b(i+1)
	      if (b(i+2) .lt. y1) y1 = b(i+2)
	      if (b(i+2) .gt. y2) y2 = b(i+2)
	      if (b(i+3) .lt. z1) z1 = b(i+3)
	      if (b(i+3) .gt. z2) z2 = b(i+3)
	      i = i + ly.spa
	    enddo
	  elseif (ly.dim .eq. 4) then
	    do while (i .lt. ly.nelem*ly.spa)
	      if (b(i+1) .lt. x1) x1 = b(i+1)
	      if (b(i+1) .gt. x2) x2 = b(i+1)
	      if (b(i+2) .lt. y1) y1 = b(i+2)
	      if (b(i+2) .gt. y2) y2 = b(i+2)
	      if (b(i+3) .lt. z1) z1 = b(i+3)
	      if (b(i+3) .gt. z2) z2 = b(i+3)
	      if (b(i+4) .lt. c1) c1 = b(i+4)
	      if (b(i+4) .gt. c2) c2 = b(i+4)
	      i = i + ly.spa
	    enddo
	  endif
	  if (ly.dim .eq. 1) then
	    c1 = min(c1,x1)
	    c2 = max(c2,x2)
	  elseif (ly.dim .eq. 2) then
	    c1 = min(c1,y1)
	    c2 = max(c2,y2)
	  elseif (ly.dim .eq. 3) then
	    c1 = min(c1,z1)
	    c2 = max(c2,z2)
	  endif
	enddo

	if (flag .eq. 0) then
	  Gx.x1 = x1
	  Gx.x2 = x2
	  Gx.y1 = y1
	  Gx.y2 = y2
	  Gx.z1 = z1
	  Gx.z2 = z2
	  Gx.c1 = c1
	  Gx.c2 = c2
	  if (Gx.x2-Gx.x1 .eq. 0) Gx.x1 = Gx.x2-1
	  if (Gx.y2-Gx.y1 .eq. 0) Gx.y1 = Gx.y2-1
	  if (Gx.z2-Gx.z1 .eq. 0) Gx.z1 = Gx.z2-1
	  if (Gx.c2-Gx.c1 .eq. 0) Gx.c1 = Gx.c2-1
	endif

	return
	end



	subroutine XP3D_DRAW_SZZ ()
	include 'xp3d.inc'
	call MX$DRAW_BOX (-2,Gx.zx,Gx.zy,Gx.zw,Gx.zh)
	i = 10
	ix = Gx.zx + Gx.zw/2
	iy = Gx.zy + Gx.zh/2
	call MX$DRAW_LINE (-2,ix,iy-i,ix,iy+i)
	call MX$DRAW_LINE (-2,ix-i,iy,ix+i,iy)
	return
	end



	subroutine XP3D_EVENT ()
	include 'xp3d.inc'
	external XP3D_SPECS, XP3D_SETTINGS
	pointer (ply,ly)
	real*8 t1,t2
	integer*4 optmask

	do while ( MX$IFEVENT() )
	 Gx.status = Gx.status + 1
	 call XP3D_CROSS (-1)

	if ( XP3D_PAN_HANDLE(1,i) ) then
	  if (i.gt.0) then
	    call XP3D_REFRESH (2)
	    call M$PAUSE (0.2)
	    ii = MX$IFEVENT()
	  endif
	  m = 3
	  do while (Mx.button_release.eq.0)
	    ii = XP3D_PAN_HANDLE(2,i)
	    if (i.gt.0) then
	      fval = SECNDS(0.0)
	      call XP3D_REFRESH (m)
	      ii = MX$IFEVENT()
	      fval = SECNDS(fval)
	      if (fval.lt.Gx.speed) call M$PAUSE (Gx.speed-fval)
	      if (fval.gt.0.5) m = 4
	    else
	      call MX$EVENT()
	    endif
	  enddo
	  call XP3D_REFRESH (0)
	  ii = XP3D_PAN_HANDLE(3,i)

	elseif (Mx.motion_notify) then
	  call XP3D_SPECS ()
	  if (Gx.cntrls.eq.2) then
	    call M$DRSLT (Mx.xtag,Gx.retx)
	    call M$DRSLT (Mx.ytag,Gx.rety)
	    call M$DRSLT (Mx.ztag,Gx.retz)
	  endif

	elseif (Mx.button_press.eq.2 .or. Mx.key_upchar.eq.'M') then

	  m = MX$MENU (0,'X-P3D;Refresh,Viewpoint,Colormap,'//
     &		'Utilities,Scale,Layers,T2 Mode,Options,Key Info,Exit')

	  if (m.eq.1) then				! refresh
	    call XP3D_REFRESH (-1)

	  elseif (m.eq.2) then				! viewpoint
	    n = Gx.view
	    Gx.view = MX$MENU (n,'VIEWPOINT;X/Y Flat,X/Y/Z Persp')
	    if (Gx.view.ge.2) then
	      call MX$FPROMPT ('Azim: ',Gx.azim)
	      call MX$FPROMPT ('Elev: ',Gx.elev)
	      call MX$FPROMPT ('Roll: ',Gx.roll)
	      call MX$FPROMPT ('Prepective distance: ',Gx.pdis)
	      call XP3D_RESET (4)
	    endif
	    if (Gx.view.ne.n .or. Gx.view.ge.2) then
	      call XP3D_RESET (0)
	      call XP3D_REFRESH (0)
	    endif

	  elseif (m.eq.3) then				! colormap
	    call XP3D_COLORS (-1,' ')

	  elseif (m.eq.4) then				! utilities
	    n = MX$MENU (0,'UTILS;Cntrls,Speed,Boxes,Points,Annotate')
	    if (n.eq.1) then
	      n = Gx.cntrls
	      Gx.cntrls = MX$MENU (Gx.cntrls+3, 'CONTROLS OPTIONS;'//
     &	'-Continuous,-LM Click, Off,+LM Click,+Continuous, Assign,') - 3
	      if (Gx.cntrls .eq. 3) then
		Gx.cntrls = n
		call MX$PROMPT ('Mouse X -> ', Mx.xtag)
		call M$UPPERCASE (Mx.xtag)
		call MX$PROMPT ('Mouse Y -> ', Mx.ytag)
		call M$UPPERCASE (Mx.ytag)
		call MX$PROMPT ('Mouse Z -> ', Mx.ztag)
		call M$UPPERCASE (Mx.ztag)
	      endif
	    elseif (n.eq.2) then
	      j = NINT(1.0/Gx.speed)
	      call MX$LVAL ('Max frame rate (Hz): ',j,1,50,1,0)
	      Gx.speed = 1./float(j)
	    elseif (n.ge.3 .and. n.le.5) then
	      call XP3D_FACILITIES (n)
	    endif

	  elseif (m.eq.5) then				! scale
 	    ix = Mx.xpos
	    iy = Mx.ypos
  16	    Mx.xpos = ix
	    Mx.ypos = iy
	    n = MX$MENU (0, 'SCALE;Xminmax,Yminmax,Zminmax,Cminmax')
	    if (n.eq.1) call MX$DPROMPT ('X-min: ', Gx.x1)
	    if (n.eq.1) call MX$DPROMPT ('X-max: ', Gx.x2)
	    if (n.eq.2) call MX$DPROMPT ('Y-min: ', Gx.y1)
	    if (n.eq.2) call MX$DPROMPT ('Y-max: ', Gx.y2)
	    if (n.eq.3) call MX$DPROMPT ('Z-min: ', Gx.z1)
	    if (n.eq.3) call MX$DPROMPT ('Z-max: ', Gx.z2)
	    if (n.eq.4) call MX$DPROMPT ('C-min: ', Gx.c1)
	    if (n.eq.4) call MX$DPROMPT ('C-max: ', Gx.c2)
	    if (n.ne.0) goto 16
	    call XP3D_REFRESH(-1)

	  elseif (m.eq.6) then				! layers
	    goto 17

	  elseif (m.eq.7) then				! lines 

	    n = Gx.t2mode 
	    n = MX$MENUPLUS(Gx.t2mode,'T2 MODE;Mesh,MeshColor,'//
     &		'Dots,DotColor,Fill,FillColor,Contours,ContourColor',
     &		-1, 0, 0)
	    if (n.ne.Gx.t2mode) then
	      Gx.t2mode = n
	      call XP3D_REFRESH (-1)
	    endif

	  elseif (m.eq.8) then				! Options

	    optmask = 0
	    do i = 1,16
	      if (Gx.options(i)) optmask = IBSET(optmask,i)
            enddo
	    optmask = MX$MENUPLUS (optmask, 'OPTIONS;Axes,AutoFast,'//
     &	'Cross,Specs,Aspect,Panning,SplitScr,CBar,BStore,Fast,'//
     &	'HideLines,Hold', -1, L_CBenable, XP3D_SETTINGS)

	  elseif (m.eq.9) then					! keypress info
	    call MX$MHELP ('X-P3D','Key Info')

	  elseif (m.eq.10) then					! exit
	    if (Mx.noexit.gt.1) then
	      call MX$MESSAGE ('Exit disabled', 1.0)
	    else
	      Gx.status = -1
	      return
	    endif
	  endif

	elseif (Mx.button_press.eq.1) then

	  call MX$RUBBERBOX (ix1,iy1,ix2,iy2,XP3D_SPECS)
	  if (ix2-ix1.lt.5 .and. iy2-iy1.lt.5) then		! set origin
	    call XP3D_SPECS ()
	    Gx.mrkx = Gx.retx
	    Gx.mrky = Gx.rety
	    Gx.mrkz = Gx.retz
	    call MSGDO (MSK_MARK, Mx.level)
	    if (Gx.cntrls.eq.1) then
	      call M$DRSLT (Mx.xtag,Gx.retx)
	      call M$DRSLT (Mx.ytag,Gx.rety)
	      call M$DRSLT (Mx.ztag,Gx.retz)
	    endif
	    call XP3D_REFRESH (0)
	  elseif (ix2-ix1.gt.5 .and. iy2-iy1.gt.5) then		! zoom
	    call XP3D_ZOOM (ix1,iy1,ix2,iy2)
	  endif

	elseif (Mx.button_press.eq.3) then	
	  k = Mx.level
	  if (k.gt.1) then					! unzoom
	    if (Gx.bsmap(k).ip.ne.0) 
     &		call MX$MAP (Gx.bsmap(k),0,0,0,0,L_FreeMap)
	    Mx.level = k-1
	    call XP3D_REFRESH (0)
	    call MSGDO (MSK_UNZOOM, Mx.level)
	  endif

	elseif (Mx.key_upchar.eq.'A') then		! toggle abscissa
	  call XP3D_REFRESH (0)	    
	elseif (Mx.key_upchar.eq.'S') then		! toggle specs
	  Gx.spec = .not. Gx.spec
	  call XP3D_REFRESH (-1)	    
	elseif (Mx.key_upchar.eq.'Q') then		! toggle crosshairs
	  Gx.cross = .not. Gx.cross

	elseif (Mx.key_upchar.eq.'B') then		! boxes facility
	  call XP3D_FACILITIES (-3)
	elseif (Mx.key_upchar.eq.'P') then		! points facility
	  call XP3D_FACILITIES (-4)

	elseif (Mx.key_upchar.eq.'C') then		! toggle controls
	  Gx.cntrls = -Gx.cntrls
	  call XP3D_SPECS ()

	elseif (Mx.key_char.eq.'w') then		! wide view 
	  call XP3D_RESET (-2)
	  call XP3D_REFRESH (0)
	elseif (Mx.key_char.eq.'W') then		! narrow view 
	  call XP3D_RESET (2)
	  call XP3D_REFRESH (0)

	elseif (Mx.key_upchar.eq.'V') then		! toggle view 
	  if (Mx.key_char.eq.'V') then
	    Gx.view = Gx.view - 1
	    if (Gx.view.le.0) Gx.view = 2
	  else
	    Gx.view = Gx.view + 1
	    if (Gx.view.gt.2) Gx.view = 1
	  endif
	  call XP3D_RESET (0)
	  call XP3D_REFRESH (0)

	elseif (Mx.key_upchar .eq. 'L') then            ! layers hot-key
	  goto 17

	elseif (Mx.key_upchar .eq. 'H') then		! hardcopy
	  str = 'xp3d'
	  if (MX$HARDCOPY_OPEN(str, -1)) then
	    call XP3D_REFRESH (-1)
	    call MX$HARDCOPY_CLOSE()
	  endif

	elseif (Mx.key_upchar .eq. 'F') then		! fast
	  Gx.fast = .not. Gx.fast
	  call XP3D_REFRESH (-1)
 
	elseif (Mx.key_press.eq.13 .and. Mx.noexit.le.0) then   ! the END
	  Gx.status = -1
	  return

	endif
	goto 18

  17	ix = Mx.xpos				! really do layers
	iy = Mx.ypos
	n = 1
	do while (n.ne.0)
	  j = 15
	  str = 'LAYERS;Newfile,'
	  do k = 1,Gx.nlayer
	    ply = Gx.lloc(k)
	    str(j+1:) = '-- '//ly.name
	    if (BTEST(ly.enable,PM_GLOBAL)) then
	      if (BTEST(ly.enable,PM_BASE)) str(j+1:j+1) = '+'
	      if (BTEST(ly.enable,PM_ZOOM)) str(j+2:j+2) = '+'
	    endif
	    j = M$LENGTH(str)+1
	    str(j:j) = ','
	  enddo
	  Mx.xpos = ix
	  Mx.ypos = iy
	  n = MX$MENU (0,str(1:j-1))
	  if (n.eq.1) then			! newfile
	    str = ' '
	    if (MX$FILES(str(1:80)) .gt. 0) then
	      j = M$CLEAN(str,str)-1
	      call XP3D_LOAD (P_LAYER,str(1:j))
	      call XP3D_REFRESH (0)
	    endif
	  elseif (n.gt.1) then		! modify layer
	    k = n-1
	    call XP3D_LAYER_MOD (k)
	    Mx.exposure = .true.	! cue up mods
	  endif	
	enddo
	if (Mx.exposure) call XP3D_REFRESH (0)
  18	continue

	if (Mx.resize) then
	  call XP3D_RESET (3)
	  call XP3D_REFRESH (0)
	elseif (Mx.exposure) then
	  call XP3D_REFRESH (0)
	endif

	call XP3D_CROSS (1)
	enddo
	return
	end

        subroutine XP3D_SETTINGS (cb)
        include 'xp3d.inc'
        record /CBSTRUCT/ cb
        Gx.options(cb.item) = .not. Gx.options(cb.item)
        if (cb.item.eq.7 .and. Mx.level.eq.1) call XP3D_RESET (0)
        if (cb.item.ge.1 .and. cb.item.le.11) then
          call XP3D_REFRESH (-1)
        else
          call XP3D_REFRESH (0)
        endif
        cb.status = L_CBokaction
        return
        end


	subroutine XP3D_MESSAGE ()
	include 'xp3d.inc'
	include 'qmessdef.inc'
	include 'qmessdecl.inc'
	pointer (ply,ly)
	byte options(16)
	integer*4 sid,color,msgid,mimic,info

	do while (M$GET_MSG(MQH,MQD,L_mqd,0.0,0) .eq. 1)
	  Gx.status = Gx.status + 1
	  call XP3D_CROSS (-1)

	  Gx.xf.mqdloc.p = %loc(MQD)
	  Gx.xf.iarg = MQH.info
	  sid = MQH.sender
	  info = MQH.info
	  msgid = Gx.xf.msgid
	  mimic = Gx.mimic

	if (MX$GRAPHICS_MSG(Mx,MQH,MQD,Gx.xf.msgid,Gx.xf.msgmask).ne.0) then
	  if (Mx.breakflag) then
	    Gx.status = -1
	    return
	  endif

	elseif (MX$MIMIC_MSG(MQH,MQD,mimic).lt.0) then
	  ! info message but not from who we're mimicing

	elseif (MQH.name .eq. '?ACK') then
	   call M$SEND_MSGL ('=ACK',0,sid,Gx.status,0,0,' ',0,0)

	elseif (MQH.name .eq. MQH_REFRESH.name) then
	  Gx.hold = .false.
	  if (MQH.info .eq. 1) call XP3D_RESET (0)
	  call XP3D_REFRESH (0)

	elseif (MQH.name .eq. MQH_REREAD.name) then
	  k = MQH.info
	  call XP3D_RELOAD (P_LAYER,k)	  
	  call XP3D_REFRESH (0)

	elseif (MQH.name .eq. MQH_ZOOM.name) then
	  k = min(L_stack-1,Mx.level+1)
	  Mx.stk(k).xmin = MQD.ZOOM.xmin
	  Mx.stk(k).xmax = MQD.ZOOM.xmax
	  Mx.stk(k).ymin = MQD.ZOOM.ymin
	  Mx.stk(k).ymax = MQD.ZOOM.ymax
	  Mx.level = k
	  call XP3D_REFRESH (0)

	elseif (MQH.name .eq. MQH_UNZOOM.name) then
	  k = Mx.level
	  if (k.gt.1) then
	    if (Gx.bsmap(k).ip.ne.0) 
     &		call MX$MAP (Gx.bsmap(k),0,0,0,0,L_FreeMap)
	    Mx.level = k-1
	    call XP3D_REFRESH (0)
	    call MSGDO (MSK_UNZOOM, Mx.level)
	  endif

	elseif (MQH.name .eq. MQH_PAN.name) then
	  k = Mx.level
	  Mx.stk(k).xmin = MQD.PAN.xmin
	  Mx.stk(k).xmax = MQD.PAN.xmax
	  Mx.stk(k).ymin = MQD.PAN.ymin
	  Mx.stk(k).ymax = MQD.PAN.ymax
	  call XP3D_REFRESH (1)

	elseif (MQH.name .eq. MQH_HARDCOPY.name) then
	  if (MX$HARDCOPY_OPEN(MQD.HARDCOPY.file, MQH.info)) then
	    call XP3D_REFRESH (-1)
	    call MX$HARDCOPY_CLOSE()
	  endif

	elseif (MQH.name .eq. MQH_NEWFILE.name) then
	  call XP3D_UNLOAD (info)
	  call XP3D_LOAD (info,MQD.NEWFILE.filename)
	  call XP3D_REFRESH (0)

	elseif (MQH.name .eq. MQH_OVERLAY.name) then
	  call XP3D_LOAD (info,MQD.OVERLAY.text)
	  call XP3D_REFRESH (0)

	elseif (MQH.name .eq. MQH_SET.name .or. 
     &		MQH.name .eq. MQH_SETD.name) then
	  i = MQH.info
	  if (MQH.name .eq. MQH_SET.name) MQD.SETD.value = i
	  call M$MOVE (Gx.options,options,16) ! save current
	  call XP3D_SETD (MQD.SETD.object, i, MQD.SETD.value)
	  if (M$CHK(Gx.options,options,11).eq.0) Gx.bsmask = 0 ! changed BS
	  if (M$CHK(Gx.options,options,16).eq.0 .or.
     &	      MQH.name .eq. MQH_SETD.name) call XP3D_REFRESH (0)

	elseif (MQH.name .eq. MQH_TRACE.name) then
	  n = MQH.info
	  if (n.lt.0) n = Gx.nlayer +1+n
	  if (n.le.0 .or. n.gt.Gx.nlayer) call M$ERROR 
     &		('TRACE message to non-existent layer')
	  ply = Gx.lloc(n)
	  call MX$TRACE_MSG (MQD, ly.line, ly.thick, 
     &			ly.symbol, ly.radius, ly.color)
	  if (BTEST(ly.enable,PM_BS)) Gx.bsmask = 0
	  call XP3D_REFRESH (0)

	elseif (MQH.name .eq. 'SETVIEW') then
	  Gx.view = iabs(MQH.info)
	  Gx.split = MQH.info .lt. 0
	  Gx.x1 = MQD.dbuf(1)
	  Gx.x2 = MQD.dbuf(2)
	  Gx.y1 = MQD.dbuf(3)
	  Gx.y2 = MQD.dbuf(4)
	  Gx.z1 = MQD.dbuf(5)
	  Gx.z2 = MQD.dbuf(6)
	  Gx.c1 = MQD.dbuf(7)
	  Gx.c2 = MQD.dbuf(8)
	  Gx.azim = MQD.dbuf(9)
	  Gx.elev = MQD.dbuf(10)
	  Gx.roll = MQD.dbuf(11)
	  call XP3D_RESET (4)
	  call XP3D_REFRESH (-1)

	elseif (MQH.name .eq. MQH_COLOR.name) then
	  k = MQH.info
	  if (k.ge.1 .and. k.le.Gx.ncolors) then
	    if (i.ge.0) call MX$COLORTAB (k, Mc.colormap(4), i)
	    if (i.lt.0) call MX$COLORTAB (k, MQD.COLOR, -2)
	  endif

	elseif (MQH.name .eq. 'SETCOLOR') then
	  k = MQH.info
	  if (k.gt.0 .and. k.le.Gx.nlayer) then
	    ply = Gx.lloc(k)
	    if (BTEST(ly.enable,PM_BS)) Gx.bsmask = 0
	    ly.color = MQD.dbuf(1)
	  endif
	  call XP3D_REFRESH (0)

	elseif (MQH.name .eq. MQH_QUERY.name) then
	  if (MQD.QUERY.object .eq. MQH_BOXINFO.name) then
	    call INFOMSG (MSK_BOXES, info, sid)
	  elseif (MQD.QUERY.object .eq. MQH_COLORINFO.name) then
	    call INFOMSG (MSK_COLOR, info, sid)
	  elseif (MQD.QUERY.object .eq. MQH_MARKINFO.name) then
	    call INFOMSG (MSK_MARK, info, sid)
	  elseif (MQD.QUERY.object .eq. MQH_PANINFO.name) then
	    call INFOMSG (MSK_PANX, info+1, sid)
	  elseif (MQD.QUERY.object .eq. MQH_POINTINFO.name) then
	    call INFOMSG (MSK_POINTS, info, sid)
	  elseif (MQD.QUERY.object .eq. MQH_ZOOMINFO.name) then
	    call INFOMSG (MSK_ZOOM, info+1, sid)
	  elseif (MQD.QUERY.object .eq. '=SETVIEW') then
	    k = 1
	    i = Gx.view 
	    if (Gx.split) i = -i
	    MQD.dbuf(1) = Mx.stk(k).xmin
	    MQD.dbuf(2) = Mx.stk(k).xmax
	    MQD.dbuf(3) = Mx.stk(k).ymin
	    MQD.dbuf(4) = Mx.stk(k).ymax
	    MQD.dbuf(5) = Gx.azim
	    MQD.dbuf(6) = Gx.elev
	    MQD.dbuf(7) = Gx.roll 
	    call M$SEND_MSGL ('=SETVIEW',0,sid,i,0,7,'D',MQD,0)
	  elseif (MQD.QUERY.object .eq. '=FILES') then
	    if (MQH.info .eq. 1) then	! layers
	      j = 0
	      do k = 2,Gx.nlayer
		ply = Gx.lloc(k)
	        str(j+1:) = ly.name
	        j = M$LENGTH(str)+1
	        str(j:j) = '|'
	      enddo
	      MQD.sbuf(1:80) = str(1:j-1)
	    endif
	    i = MQH.info
	    call M$SEND_MSGL ('=FILES',0,sid,i,0,1,'S[80]',MQD,0)
	  else
	    call M$WARNING ('Unknown QUERY object: '//MQD.QUERY.object)
	  endif

	elseif (MQH.name(1:3).eq.'BOX' .or. MQH.name(1:5).eq.'POINT') then
	  if (MQH.name .eq. MQH_BOXDELETE.name .or.
     &	      MQH.name .eq. MQH_POINTDELETE.name) then
	    call MX$FACILITIES (Gx.xf, MQH.name(1:1), 4)
	  else
	    i = 2
	    if (MQH.info .le. -1) i = L_OneShot
	    if (MQH.name .eq. MQH_BOXADD.name) Gx.xf.iarg = Gx.xf.nbox+1
	    if (MQH.name .eq. MQH_POINTADD.name) Gx.xf.iarg = Gx.xf.npoint+1
	    if (MQH.name .eq. MQH_BOXADD.name .or.
     &		MQH.name .eq. MQH_POINTADD.name .or.
     &	      	MQH.name .eq. MQH_BOXALTER.name .or.
     &		MQH.name .eq. MQH_POINTALTER.name) 
     &		call MX$FACILITIES (Gx.xf, MQH.name(1:1), i)
	  endif

	else
	  call M$WARNING('Unrecognized message: '//MQH.name)

	endif

	call XP3D_CROSS (1)
	enddo
	return
	end



	function XP3D_PAN_HANDLE (m,i) 
	include 'xp3d.inc'
	include 'xwidgets.inc'
	! m = 0:draw  1:check  2:drag  3:release
	! mode = 1:splitbox  2:vertical  3:horizontal  4:box  5/6:controldrag
	save
	real*8 d1,d2,d3, px,py,pz
	logical*4 act, inbox
	integer*4 junk,jx,jy,jb,panmode
	record /SCROLLBAR/ sbx,sby

c init returns
	i = 0
	k = Mx.level 
	act = .false.
	ix = Mx.xpos
	iy = Mx.ypos
	sbx.flag = -12
	sby.flag = -12

c handle calling mode
	if (m.eq.3) then
	  panmode = 0
	  goto 9
	elseif (m.eq.1) then
	  panmode = 0
	  sbx.action = 0
	  sby.action = 0
	  jb = Mx.button_press
	  if (jb.eq.0) goto 9
	  if (IAND(Mx.state_mask,L_ControlKeyMask).ne.0) jb = -jb
	elseif (m.eq.2) then
	  Mx.button_press = iabs(jb)
	endif
	if (.not. Gx.pan) goto 9
	if (k.eq.1) goto 7

c split box drag
	ix1 = ix - (Gx.zx+Gx.zw/2) 
	iy1 = iy - (Gx.zy+Gx.zh/2)
	if (m.eq.0) then
	  ! nothing to draw
	elseif (panmode.eq.1 .or. (panmode.eq.0 .and. 
     &		Gx.split .and. jb.eq.1 .and. 
     &		iabs(ix1).lt.10 .and. iabs(iy1).lt.10) )then
	  act = .true.
	  panmode = 1
	  if (iabs(ix1).gt.1 .or. iabs(iy1).gt.1) then
	    i = i+1
	    d1 = ix1 * Mx.stk(1).xscl
	    Mx.stk(k).xmin = Mx.stk(k).xmin + d1
	    Mx.stk(k).xmax = Mx.stk(k).xmax + d1
	    d1 = -iy1 * Mx.stk(1).yscl
	    Mx.stk(k).ymin = Mx.stk(k).ymin + d1
	    Mx.stk(k).ymax = Mx.stk(k).ymax + d1
	  endif
	endif

c vertical
	ix1 = Mx.stk(k).x2 + Mx.text_w
	ix2 = ix1 + Mx.text_w
	iy1 = Mx.stk(k).y1 + 3*Mx.text_w
	iy2 = Mx.stk(k).y2
	if (m.eq.0) then
	  junk = MX$SCROLLBAR (0,ix1,ix2,iy1,iy2,
     &	    Mx.stk(k).ymin,Mx.stk(k).ymax,Mx.stk(1).ymin,Mx.stk(1).ymax)
	elseif (panmode.eq.2 .or. (panmode.eq.0 .and.
     &		ix.gt.ix1-25*(m-1).and.iy.gt.iy1.and.iy.lt.iy2) )then
	  act = .true.
	  panmode = 2
	  d1 = Mx.stk(k).ymin
	  d2 = Mx.stk(k).ymax
	  junk = MX$SCROLLBAR (sby,ix1,ix2,iy1,iy2,
     &	    Mx.stk(k).ymin,Mx.stk(k).ymax,Mx.stk(1).ymin,Mx.stk(1).ymax)
	  if (Mx.stk(k).ymin.ne.d1 .or. Mx.stk(k).ymax.ne.d2) i = i+1
	endif

c horizontal
	ix1 = Mx.stk(k).x1
	ix2 = Mx.stk(k).x2 - 3*Mx.text_w
	if (Gx.axes .and. Gx.view.eq.1) ix1 = min(ix2-40,ix1 + Mx.text_w*30)
	iy2 = Mx.stk(k).y1 - Mx.text_w
	iy1 = iy2 - Mx.text_w
	if (m.eq.0) then
	  junk = MX$SCROLLBAR (0,ix1,ix2,iy1,iy2,
     &	    Mx.stk(k).xmin,Mx.stk(k).xmax,Mx.stk(1).xmin,Mx.stk(1).xmax)
	elseif (panmode.eq.3 .or. (panmode.eq.0 .and.
     &		ix.gt.ix1.and.ix.lt.ix2.and.iy.lt.iy2+25*(m-1)) )then
	  act = .true.
	  panmode = 3
	  d1 = Mx.stk(k).xmin
	  d2 = Mx.stk(k).xmax
	  junk = MX$SCROLLBAR (sbx,ix1,ix2,iy1,iy2,
     &	    Mx.stk(k).xmin,Mx.stk(k).xmax,Mx.stk(1).xmin,Mx.stk(1).xmax)
	  if (Mx.stk(k).xmin.ne.d1 .or. Mx.stk(k).xmax.ne.d2) i = i+1
	endif

c box move
 7	ix1 = Mx.stk(k).x2 - 2*Mx.text_w
	iy1 = Mx.stk(k).y1 - 2*Mx.text_w
	if (k.eq.1 .and. .not. Gx.axes) then
	  ix1 = ix1 - 2*Mx.text_w
	  iy1 = iy1 + 2*Mx.text_w
	endif
	ix2 = ix1 + 4*Mx.text_w
	iy2 = iy1 + 4*Mx.text_w
	inbox = ix.ge.ix1.and.ix.le.ix2.and.iy.ge.iy1.and.iy.lt.iy2 
	if (k.eq.1 .and. (Gx.split .or. Gx.view.eq.1)) then
	  ! nobox
	elseif (m.le.0) then
	  call MX$TEXTLINE(ix1,iy1,ix2,iy1)
	  call MX$TEXTLINE(ix2,iy1,ix2,iy2)
	  call MX$TEXTLINE(ix2,iy2,ix1,iy2)
	  call MX$TEXTLINE(ix1,iy2,ix1,iy1)
	elseif ((panmode.eq.4 .or. panmode.eq.0) .and. inbox) then
	  act = .true.
	  panmode = 4
	  goto 8
	endif

c control drag and box move handler
	if (panmode.ge.5 .or. (panmode.eq.0 .and. jb.lt.0)) then
	  act = .true.
	  if (panmode.eq.0) then
	    jx = ix
	    jy = iy
	    panmode = 5
	    if (Gx.split .and. ix.le.Mx.stk(1).x2) k = 1
	    if (k.eq.1) panmode = 6
	  endif
	  goto 8

	endif
	goto 10
 8	d1 = 0
	d2 = 0
	d3 = 0
	if (panmode.eq.6) k = 1
	if (iabs(jb).eq.2 .or. (jb.eq.-1.and.Gx.view.eq.1)) then	! shift
	  if (panmode.eq.4 .and. inbox) then
	    d1 = (2*ix-(ix1+ix2)) * Mx.stk(k).xscl
	    d2 = ((iy1+iy2)-2*iy) * Mx.stk(k).yscl
	    if (jb.lt.0) d1 = -d1
	    if (jb.lt.0) d2 = -d2
	  elseif (panmode.gt.4) then
	    d1 = (jx-ix) * Mx.stk(k).xscl
	    d2 = (iy-jy) * Mx.stk(k).yscl
	  endif
	  if (d1.ne.0.d0 .or. d2.ne.0.d0) i = i+1
	  Mx.stk(k).xmin = Mx.stk(k).xmin + d1
	  Mx.stk(k).xmax = Mx.stk(k).xmax + d1
	  Mx.stk(k).ymin = Mx.stk(k).ymin + d2
	  Mx.stk(k).ymax = Mx.stk(k).ymax + d2
	elseif (jb.eq.-1 .and. Gx.view.gt.1) then	! rotate
	  if (panmode.eq.4 .and. inbox) then
	    d1 = -20.0 * (2*ix-(ix1+ix2))/(8*Mx.text_w)
	    d2 = 20.0 * (2*iy-(iy1+iy2))/(8*Mx.text_w)
	  elseif (panmode.gt.4) then
	    ix1 = Mx.stk(k).x2-Mx.stk(k).x1
	    iy1 = Mx.stk(k).y2-Mx.stk(k).y1
	    px = 2.0*(ix-Mx.stk(k).x1)/ix1 - 1
	    py = 2.0*(iy-Mx.stk(k).y1)/iy1 - 1
	    pz = max(0.d0, 1-sqrt(px*px+py*py) )
	    d1 = pz * 180.0 * (jx-ix) / min(ix1,iy1)
	    d2 = pz * 180.0 * (iy-jy) / min(ix1,iy1)
	    d3 = (pz-1)*180.0 * 
     &           ( (jx-ix)*py + (iy-jy)*px ) / min(ix1,iy1)
	  endif
	  if (d1.ne.0.d0 .or. d2.ne.0.d0 .or. d3.ne.0.d0) i = i+1
	  call M$MATRIX_ROT( Gx.M, d3, P_AZIM)
	  call M$MATRIX_ROT( Gx.M, d1, P_ELEV)
	  call M$MATRIX_ROT( Gx.M, d2, P_ROLL)
	  call M$MATRIX_INV (Gx.M, Gx.MI)
!	  Gx.azim = mod( Gx.azim+d3+540, 360.d0 ) - 180.d0
!	  Gx.elev = mod( Gx.elev+d1+540, 360.d0 ) - 180.d0
!	  Gx.roll = mod( Gx.roll+d2+540, 360.d0 ) - 180.d0
	  k = 1
	elseif (iabs(jb).eq.3 .or. (jb.eq.1.and.inbox)) then		! in/out
	  if (panmode.eq.4 .and. inbox) then
	    if (jb.lt.0) d2 = -0.1*(2*iy-(iy1+iy2))/(8*Mx.text_w)
	    if (jb.gt.0) d2 = 0.1 * dble(ix-ix1+iy-iy1)/(8*Mx.text_w)
	    if (jb.eq.1) d2 = -d2
	    i = i+1
	  elseif (panmode.gt.4) then
	    d2 = 2 * dble(jy-iy) / Mx.height
	    if (d2.ne.0.d0) i = i+1
	  endif
	  d1 = (Mx.stk(k).xmax - Mx.stk(k).xmin) * d2
	  Mx.stk(k).xmin = Mx.stk(k).xmin - d1
	  Mx.stk(k).xmax = Mx.stk(k).xmax + d1
	  d1 = (Mx.stk(k).ymax - Mx.stk(k).ymin) * d2 
	  Mx.stk(k).ymin = Mx.stk(k).ymin - d1
	  Mx.stk(k).ymax = Mx.stk(k).ymax + d1
	endif
	jx = ix
	jy = iy
	if (i.gt.0 .and. k.eq.1) Gx.bsmask = 0
10	continue

 9	XP3D_PAN_HANDLE = act
	return
	end


	subroutine MSGDO (bit, iarg)
	include 'xp3d.inc'
	integer*4 bit, iarg
	if (Gx.xf.msgid.ge.0 .and. BTEST(Gx.xf.msgmask,bit)) 
     &		call INFOMSG (bit, iarg, Gx.xf.msgid)
	return
	end


	subroutine INFOMSG (bit, iarg, rid)

	include 'xp3d.inc'
	include 'qmessdef.inc'
	include 'qmessdecl.inc'
	integer*4 iarg, rid, bit

	if (bit .eq. MSK_BOXES) then
	  Gx.xf.iarg = iarg
	  Gx.xf.mqdloc.p = %loc(MQD.BOXINFO)
	  call MX$FACILITIES (Gx.xf, 'B', 3) 
	  MQH_BOXINFO.boxid = Gx.xf.iarg
	  call M$SEND_MSG (MQH_BOXINFO, MQD.BOXINFO, rid, 0)
	elseif (bit .eq. MSK_POINTS) then
	  Gx.xf.iarg = iarg
	  Gx.xf.mqdloc.p = %loc(MQD.POINTINFO)
	  call MX$FACILITIES (Gx.xf, 'P', 3)
	  MQH_POINTINFO.pointid = Gx.xf.iarg
	  call M$SEND_MSG (MQH_POINTINFO, MQD.POINTINFO, rid, 0)
	elseif (bit .eq. MSK_COLOR) then
	  call MX$COLORTAB (iarg, MQD.COLORINFO, -3)
	  MQH_COLORINFO.colorid = iarg
	  call M$SEND_MSG (MQH_COLORINFO, MQD.COLORINFO, rid, 0)
	elseif (bit .eq. MSK_EXIT) then
	  call M$SEND_MSG (MQH_EXITINFO, MQD, rid, 0)
	elseif (bit .eq. MSK_MARK) then
	  MQD.MARKINFO.x = Gx.mrkx
	  MQD.MARKINFO.y = Gx.mrky
	  MQD.MARKINFO.z = Gx.mrkz
	  MQH_MARKINFO.info = Mx.state_mask
	  call M$SEND_MSG (MQH_MARKINFO, MQD.MARKINFO, rid, 0)
	elseif (bit .eq. MSK_ZOOM .or. bit .eq. MSK_UNZOOM) then
	  if (iarg.lt.1) i = max(1,Mx.level+iarg)
	  if (iarg.ge.1) i = min(iarg,Mx.level)
	  MQD.PLOTINFO.xmin = min (Mx.stk(i).xmin, Mx.stk(i).xmax)
	  MQD.PLOTINFO.xmax = max (Mx.stk(i).xmin, Mx.stk(i).xmax)
	  MQD.PLOTINFO.ymin = min (Mx.stk(i).ymin, Mx.stk(i).ymax)
	  MQD.PLOTINFO.ymax = max (Mx.stk(i).ymin, Mx.stk(i).ymax)
	  if (bit .eq. MSK_ZOOM) then
	    MQH_ZOOMINFO.level = i - 1
	    call M$SEND_MSG (MQH_ZOOMINFO, MQD.PLOTINFO, rid, 0)
	  elseif (bit .eq. MSK_UNZOOM) then
	    MQH_UNZOOMINFO.level = i - 1
	    call M$SEND_MSG (MQH_UNZOOMINFO, MQD.PLOTINFO, rid, 0)
	  endif
	else
	  call M$WARNING ('Unknown bit for INFOMSG')
	endif

	return
	end




	subroutine XP3D_END ()
	include 'xp3d.inc'
	call XP3D_UNLOAD (0)
	call XP3D_FACILITIES (-1)
	do k = 1,L_stack
	  if (Gx.bsmap(k).ip.ne.0)
     &          call MX$MAP (Gx.bsmap(k),0,0,0,0,L_FreeMap)
	enddo
	call MX$CLOSE
	return
	end


	subroutine XP3D_ZOOM (ix1,iy1,ix2,iy2)
	include 'xp3d.inc'
	k = Mx.level
	if (Gx.split .and. k.gt.1 .and. ix1+ix2.lt.Mx.width) k=1
	if (k.eq.L_stack-1) then
	  call MX$MESSAGE ('No more stack levels',1.0)
	else
	  Mx.stk(k+1).xmin = Mx.stk(k).xmin + 
     &		(ix1-Mx.stk(k).x1)*Mx.stk(k).xscl
	  Mx.stk(k+1).xmax = Mx.stk(k).xmin + 
     &		(ix2-Mx.stk(k).x1)*Mx.stk(k).xscl
	  Mx.stk(k+1).ymin = Mx.stk(k).ymin + 
     &		(Mx.stk(k).y2-iy2)*Mx.stk(k).yscl
	  Mx.stk(k+1).ymax = Mx.stk(k).ymin + 
     &		(Mx.stk(k).y2-iy1)*Mx.stk(k).yscl
	  Mx.level = k+1
	  Gx.bsmap(k+1).mask = 0
	  call XP3D_REFRESH (1)
	  call MSGDO (MSK_ZOOM, Mx.level)
	endif
	return
	end



	subroutine XP3D_FACILITIES (n)
	include 'xp3d.inc'
	external XP3D_SPECS
c
c handle annotate, boxes and points facilities
	k = Mx.level
	if (n.eq.1 .or. n.eq.2) then	! draw
	  if (Gx.view.eq.1) then
	    if (Gx.xf.nbox.gt.0) call MX$FACILITIES (Gx.xf,'B',L_Draw)
	    if (Gx.xf.npoint.gt.0) call MX$FACILITIES (Gx.xf,'P',L_Draw)
	  endif
	  if (n.eq.1) then
	    if (Gx.xf.nannt.gt.0) call MX$FACILITIES (Gx.xf,'A',L_Draw)
	  endif
	elseif (n.eq.0) then	! init
#if _PGF77|_HPUX
	  Gx.xf.ROUTINE.p = get_address(XP3D_SPECS)
#else
	  Gx.xf.ROUTINE.p = %loc(XP3D_SPECS)
#endif
	  Gx.xf.xy = .true.
	  Gx.xf.mannt = 20
	  Gx.xf.mbox = 20
	  Gx.xf.mpoint = 100
	  call MX$FACILITIES (Gx.xf,'BPA',L_InitFacilities)
	elseif (n.eq.-1) then	! exit
	  call MX$FACILITIES (Gx.xf,'BPA',L_CleanExit)
	elseif (n.eq.5) then	! 
	  call MX$FACILITIES (Gx.xf,'A',L_Interactive)
	elseif (Gx.view.ne.1) then
	  call MX$MESSAGE ('Points & Boxes in XY only',-1.0)
	elseif (n.eq.3) then	! 
	  call MX$FACILITIES (Gx.xf,'B',L_Interactive)
	elseif (n.eq.4) then	! 
	  call MX$FACILITIES (Gx.xf,'P',L_Interactive)
	elseif (n.eq.-3) then	! 
	  call MX$FACILITIES (Gx.xf,'B',L_Oneshot)
	elseif (n.eq.-4) then	! 
	  call MX$FACILITIES (Gx.xf,'P',L_Oneshot)
	endif
	return
	end


	subroutine XP3D_SPECS ()
	include 'xp3d.inc'

	save
	character chara*62, cz
	real*8 retx,rety,retz,rretx,rrety,rretz,p2
	real*8 dx,dy,dz
c
c valid range check (none)
	ix = Mx.xpos
	iy = Mx.ypos
c
c adjust/scale for segments and Y inversion
	k = Mx.level
	if (Gx.split .and. k.gt.1 .and. ix.lt.Mx.stk(1).x2) k=1
c
c viewpoint transformation
	if (Gx.view .eq.1) then
	  retx = Mx.stk(k).xmin + (ix-Mx.stk(k).x1)*Mx.stk(k).xscl
	  rety = Mx.stk(k).ymin + (Mx.stk(k).y2-iy)*Mx.stk(k).yscl
	  Gx.retx = retx
	  Gx.rety = rety
	else
	  kk = Mx.level
	  if (Gx.split) Mx.level = k
	  if (Gx.split) call DRAW_INIT ()
	  call TRANSFORM_PIX2XYZ (ix,iy, Gx.retx,Gx.rety,Gx.retz)
	  if (Gx.split) Mx.level = kk
	endif
c
c calculate range
	dx = Gx.retx-Gx.mrkx
	dy = Gx.rety-Gx.mrky
	dz = Gx.retz-Gx.mrkz
c
c get z-level if into the colorbar
	ii = Mx.width - Mx.text_w*2
	if (Gx.axes) ii = ii - Mx.text_w*5
	if (Gx.cbar .and. ix.gt.ii) then
	  rety = dble(iy-Mx.stk(k).y2)/(Mx.stk(k).y1-Mx.stk(k).y2)
	  Gx.retz = Gx.c1 + rety*(Gx.c2-Gx.c1)
	  dz = 0
	  cz = 'c'
	else
	  cz = 'z'
	endif
c
c display updated specs
	if (Gx.spec) then
	  iy = NINT(Mx.height-Mx.text_h*1.2)
	  write (chara,1001) Gx.retx,Gx.rety,cz,Gx.retz
 1001	  format(' x:',1pg16.9,'  y:',1pg16.9,'  ',1a,':',1pg16.9)
	  call MX$TEXT(Mx.text_w,iy,chara)
	  write (chara,1002) dx,dy,cz,dz
 1002	  format('dx:',1pg16.9,' dy:',1pg16.9,' d',1a,':',1pg16.9)
	  call MX$TEXT(Mx.text_w,iy+Mx.text_h,chara)
	  if (Gx.fast) call MX$TEXT(Mx.text_w*61,iy,'F')
	endif
c
	return
	end



	subroutine TRIM_NAME (filename, target)
c
	character*(*)   filename,target
	integer*4       i,j
c
c trim name of path and extensions
	i = M$SEARCHB(filename,']')
	if (i.eq.0) i = M$SEARCHB(filename,'/')
	if (i.eq.0) i = M$SEARCHB(filename,':')
	j = M$SEARCH(filename(i+1:),'.') - 1
	if (j.lt.0) j = M$LENGTH(filename) - i
	target = filename(i+1:i+j)
	call M$UPPERCASE (target(1:j))
c
	return
	end


	subroutine XP3D_COLORS (mm,str)
	include 'xp3d.inc'
	record /HEADER/ hcb

	integer*2 map5(28)    / 0,0,20,40, 33,0,45,54, 50,0,55,55,
     &    50,30,85,47, 84,73,41,25, 100,100,100,95, 100,100,100,100 /

	integer*2 map(4,L_colors)

	if (mm.eq.0) then

	  call M$MOVE (Mc.colormap,Gx.color(1),4*28*2)
	  call M$MOVE (map5,Gx.color(5),1*28*2)
	  if (Gx.ncolors.le.0) Gx.ncolors = L_colors	! default colors
	  call MX$COLORMAP (Gx.color(Gx.cmap), Gx.ncolors)
	  call MX$COLORLAB (PC_GREY2,'#AAAAAAAAAAAA')
	  call MX$COLORLAB (PC_GREY1,'#444444444444')
	  if (str.ne.' ') call XP3D_COLORS_FILE (hcb, map)


	elseif (mm.eq.-1) then

 2	  m = MX$MENU (1,'COLORMAP;OK,Select Map,Alter Map,Alter Color,'//
     &			'Load,Save')
	  if (m.eq.2) then
	    Gx.cmap = MX$MENU(Gx.cmap, 'COLORMAP;Greyscale,'//
     &		'Ramp Colormap,Color Wheel,Spectrum,Local')
	    call MX$COLORMAP (Gx.color(Gx.cmap), Gx.ncolors)
	  elseif (m.eq.3) then
	    call MX$COLORMAP (Gx.color(Gx.cmap), -1)
	  elseif (m.eq.4) then
	    Mx.xpos = Mx.width/2
	    Mx.ypos = Mx.height/2
	    call MX$COLORTAB (n,map,-1)
	    do n = 1,Gx.ncolors
	      call MX$COLORTAB (n,map(1,n),-3)
	    enddo
	  elseif (m.eq.5) then
	    hcb.file_name = ' '
	    call MX$PROMPT ('Filename: ',hcb.file_name)
	    call XP3D_COLORS_FILE (hcb, map)
	  elseif (m.eq.6) then
	    hcb.file_name = ' '
	    call MX$PROMPT ('Filename: ',hcb.file_name)
	    call M$INITIALIZE (hcb)
	    hcb.format = 'QI'
	    hcb.switch = 'NOABORT'
	    hcb.size = Gx.ncolors
	    call M$ALLOCATE (hcb)
	    if (hcb.open) then
	      call M$FILAD (hcb,map,Gx.ncolors)
	      call M$CLOSE (hcb)
	    else
	      call MX$MESSAGE ('Error opening colormap file',-1.0)
	    endif
	  endif
	  if (m.ne.1) goto 2
	endif
	return
	end

	subroutine XP3D_COLORS_FILE (hcb, map)
	include 'xp3d.inc'
	record /HEADER/ hcb
	integer*2 map(4,L_colors)

 	hcb.type_allow = '1000'	    
	hcb.format_allow = 'QI'	    
	hcb.switch = 'NOABORT'
	call M$INOK (hcb)
	if (hcb.open) then
	  n = min(NINT(hcb.size),L_colors)
	  call M$GRAB (hcb,map,1.d0,n,-1)
	  call M$CLOSE (hcb)
	  do i = 1,n
	    call MX$COLORTAB (i,map(1,i),-2)
	  enddo
	  Gx.ncolors = n
	else
	  call MX$MESSAGE ('Error opening colormap file',-1.0)
	endif
	return
	end

	subroutine XP3D_DRAW_LAYER (ly)
	include 'xp3d.inc'
	record /LAYER/ lyt, lyc, lys
	integer*4 lpix,dec,lm,maxlines,junkloc
	pointer (plys, lys)
c
c init parms
	lm = ly.t2mode
	if (lm.eq.0) lm = Gx.t2mode
c
c thin data in fast mode
	flag = 0
	if (Gx.fast) then
	 if (ly.type .ge. 1000 .and. ly.type.le.1999) then
	  flag = -1 
	 elseif (ly.type .eq. 2000 .and. ly.nelem .gt. 256) then
	  flag = 1
	  dec = max(1, (ly.nx+ly.ny)/16/2)
	  lyt = ly
	  lyt.nx = ly.nx / dec
	  lyt.ny = ly.ny / dec
	  lyt.xd = ly.xd * dec
	  lyt.yd = ly.yd * dec
	  lyt.nelem = lyt.nx * lyt.ny
	  call M$MALLOC (lyt.nelem*4, lyt.bufloc)
	  do i = 0,lyt.ny-1
	    call M$VMOV (%val(ly.bufloc+i*dec*ly.nx*4),dec,
     &			%val(lyt.bufloc+i*lyt.nx*4),1, lyt.nx)
	  enddo
	  plys = %loc(lyt)
	 elseif (ly.type .eq. 3000 .and. ly.nelem .gt. 100) then
	  flag = 1
	  lyt = ly
	  dec = max(1, ly.nelem/100)
	  lyt.nelem = ly.nelem / dec
	  call M$MALLOC (lyt.nelem*lyt.spa*4, lyt.bufloc)
	  call M$VMOVN (%val(ly.bufloc),dec, %val(lyt.bufloc),1, 
     &			lyt.nelem, lyt.spa*4)
	 endif
	endif
c
c form and plot contours first (except in fast mode)
	if (ly.type.eq.2000 .and. BTEST(lm,P_CONT) ) then
	  plys = %loc(ly)
	  if (flag.eq.1) plys = %loc(lyt)
	  lyc = lys
	  lyc.type = 1997
	  lyc.spa = 2
	  lyc.dim = 3
	  lyc.color = PC_GREY1
	  if (BTEST(lm,P_CONTC)) lyc.color = 0
	  maxlines = 8192 ! max contour segments
	  call M$MALLOC (maxlines*8, lyc.bufloc)
	  call M$MALLOC (maxlines*4, lpix)
	  call M$MALLOC (lys.nelem*4, junkloc)
	  do k = 1, Gx.ncolors
	    fval = Gx.z1 + (k-.5)*(Gx.z2-Gx.z1)/(Gx.ncolors)
	    call MX$CONTOUR (fval, 0.0, 1, %val(lys.bufloc), 
     &		%val(junkloc), %val(lyc.bufloc), lyc.nelem, maxlines*8, 
     &		lys.nx, lys.ny, lys.x1, lys.xd, lys.y1, lys.yd)
	    call DRAWF (lyc, %val(lyc.bufloc), %val(lpix), lyc.nelem)
	  enddo
	  call M$FREE (junkloc)
	  call M$FREE (lpix)
	  call M$FREE (lyc.bufloc)
	endif
c
c plot the data
	if (flag.eq.0) then
	  call M$MALLOC (ly.nelem*4, lpix)
	  call DRAWF (ly, %val(ly.bufloc+ly.offset), %val(lpix), ly.nelem)
	  call M$FREE (lpix)
	elseif (flag.eq.1) then
	  call M$MALLOC (lyt.nelem*4, lpix)
	  call DRAWF (lyt, %val(lyt.bufloc+lyt.offset), %val(lpix), lyt.nelem)
	  call M$FREE (lyt.bufloc)
	  call M$FREE (lpix)
	endif
c
	call MX$XFLUSH()
	return
	end


	subroutine DRAW_INIT ()
	include 'xp3d.inc'
c
	record /PIXSTRUCT/ pix(*)
	record /PIXSTRUCT/ fillpix(5)
	record /IPIXSTRUCT/ ipix(*)
	real*4 fbuf(*),ftmp,fbuft(*)
	integer*4 nelem,istat,istatb,type,color
c
	SAVE
c
	integer*4 npts,nplot,ic,lat,lon,jspa,jdim,mode,fpm
	real*4 Vtop,Vleft,Vback,Vlow
	real*4 xscale,yscale,zscale,cscale
	real*4 xmin,xmax,ymin,ymax,zmin,zmax,cmin,cmax
	real*4 xmid,ymid,zmid,xscl,yscl,zscl
	real*4 x,y,z,xx,yy,zz,ax,ay,dx,dy,ff,f1,r,vr,zzl
	real*4 sr,cr,se,ce,sa,ca
	real*4 a11,a12,a13,a21,a22,a23,a31,a32,a33
	real*4 ai11,ai12,ai13,ai21,ai22,ai23,ai31,ai32,ai33
	real*4 zz1,zz2,zz3,zz4
	integer*4 kx1,kx2,kxi,ky1,ky2,kyi
	integer*4 x1,x2,y1,y2,idmax, ltmp, t2mode
	integer*4 iix, iiy
	real*8 retx,rety,retz
	! these are in a common block to make them contiguous
	common /MATRIX/ a11,a12,a13,a21,a22,a23,a31,a32,a33,
     &		ai11,ai12,ai13,ai21,ai22,ai23,ai31,ai32,ai33
c
	k = Mx.level
	xmin   = Gx.x1
	xmax   = Gx.x2
	ymin   = Gx.y1
	ymax   = Gx.y2
	zmin   = Gx.z1
	zmax   = Gx.z2
	cmin   = Gx.c1
	cmax   = Gx.c2
	xscale = 1./Mx.stk(k).xscl
	yscale = -1./Mx.stk(k).yscl
	zscale = Gx.ncolors/(zmax-zmin)
	cscale = Gx.ncolors/(cmax-cmin)
	Vleft  = Mx.stk(k).xmin - Mx.stk(k).x1*Mx.stk(k).xscl
	Vtop   = Mx.stk(k).ymax + Mx.stk(k).y1*Mx.stk(k).yscl
	Vback  = zmin - 1./zscale
	Vlow   = cmin - 1./cscale
	ix1 = Mx.stk(k).x1
	ix2 = Mx.stk(k).x2
	iy1 = Mx.stk(k).y1
	iy2 = Mx.stk(k).y2
	idmax = max( ix2-ix1, iy2-iy1 )/2
c
c perspective setup
	if (Gx.view .eq. 1) then
	  xmin   = Mx.stk(k).xmin
	  xmax   = Mx.stk(k).xmax
	  ymin   = Mx.stk(k).ymin
	  ymax   = Mx.stk(k).ymax
	  call M$VMOVN (0.0,0, a11,1, 9,4)
	  fpm = 1	! fill poly mode
	else
	  call M$REFORMAT( Gx.M,'D', a11,'F', 9)
	  call M$REFORMAT( Gx.MI,'D', ai11,'F', 9)
	  xmid = (xmax+xmin)*.5
	  xscl = 2./(xmax-xmin)
	  ymid = (ymax+ymin)*.5
	  yscl = 2./(ymax-ymin)
	  zmid = (zmax+zmin)*.5
	  zscl = 2./(zmax-zmin)
	  fpm = 0	! fill poly mode
	endif
	return
c
c 3D axis mapping
	entry TRANSFORM (fbuf, fbuft, ipix, nelem)
	jj = 0
	do i = 1,nelem
	  x = fbuf(jj+1)
	  y = fbuf(jj+2)
	  z = fbuf(jj+3)
	  xx = x*a11 + y*a21 + z*a31
	  yy = x*a12 + y*a22 + z*a32
	  zz = x*a13 + y*a23 + z*a33
	  fbuft(jj+1) = xx
	  fbuft(jj+2) = yy
	  fbuft(jj+3) = zz
	  ff = Gx.pdis/(Gx.pdis-zz)
	  xx = xx*ff
	  yy = yy*ff
	  ipix(i).x = max(-32000,min(32000,INT((xx-Vleft)*xscale)))
	  ipix(i).y = max(-32000,min(32000,INT((yy-Vtop)*yscale)))
	  jj = jj+3
	enddo
	return

c
c 3D axis unmapping
	entry TRANSFORM_PIX2XYZ (iix,iiy, retx,rety,retz)
	xx = iix / xscale + Vleft
	yy = iiy / yscale + Vtop
	if (abs(ai33).lt.1e-5) then
	  zz = 0
	else
	  if (IAND(Mx.state_mask,L_ShiftKeyMask).ne.0) then
	    ! solve equation for constant X&Y, unknown Z (Real World)
	    if (abs(ai31).gt.abs(ai32)) then	! fix Y
	      retx = (Gx.retx-xmid)*xscl
	      zz = (retx - xx*ai11 - yy*ai21) / 
     &		(ai31 - xx*ai11/Gx.pdis - yy*ai21/Gx.pdis)
	    else				! fix X
	      rety = (Gx.rety-ymid)*yscl
	      zz = (rety - xx*ai12 - yy*ai22) / 
     &		(ai32 - xx*ai12/Gx.pdis - yy*ai22/Gx.pdis)
	    endif
	    ff = Gx.pdis/(Gx.pdis-zz)
	    Gx.zspec = max(-1.0, min(1.0, 
     &		xx/ff*ai13 + yy/ff*ai23 + zz*ai33))
	  endif
	  ! solve equation for constant Gx.zspec (Real World Z)
	  ! with unknown zz (Screen Coord Z)
	  zz = (Gx.zspec - xx*ai13 - yy*ai23) / 
     &		(ai33 - xx*ai13/Gx.pdis - yy*ai23/Gx.pdis)
	endif
	ff = Gx.pdis/(Gx.pdis-zz)
	xx = xx/ff
	yy = yy/ff
	retx = xx*ai11 + yy*ai21 + zz*ai31
	rety = xx*ai12 + yy*ai22 + zz*ai32
	retz = xx*ai13 + yy*ai23 + zz*ai33
	retx = max(-1.01d0, min(1.01d0, retx)) / xscl + xmid 
	rety = max(-1.01d0, min(1.01d0, rety)) / yscl + ymid
	retz = max(-1.01d0, min(1.01d0, retz)) / zscl + zmid
	return

	entry DRAWF (ly, fbuf, pix, nelem)
c
c plot segments
	j = 0
	mode = 0
	istat = 1
	istatb = 0
	ic = ly.color
	color = ly.color
	jspa = ly.spa
	jdim = ly.dim
	type = ly.type
	call MX$DRAW_MODE (ly.thick)
	if (type.eq.2000) then
	  npts = nelem
	  mode = -1
	  ax = ly.x1
	  ay = ly.y1
	  dx = ly.xd
	  dy = ly.yd
	  t2mode = ly.t2mode
	  if (t2mode.le.0) t2mode = Gx.t2mode
	elseif (type.eq.3000) then
	  npts = nelem
	  mode = -1
	endif
	do while (j.lt.nelem*jspa)
c
c prep segment mode 0=header 1=data
	if (mode.eq.0) then
	  npts  = fbuf(j+1)
	  nplot = 2
	  jj = j+jspa
	  if (fbuf(j+2).ne.-999 .and. istatb.eq.4) mode = 1
	  if (type.lt.0 .and. Gx.view.gt.1) mode = 1
	endif
	if (mode.eq.1) then
	  nplot = npts
	  jj = j+jspa*3
	elseif (mode.eq.-1) then
	  nplot = npts
	  jj = j
	endif
c
c transform segment to pixels in X/Y mode
	if (Gx.view .eq.1) then
	  if (mode.eq.0) then
	    istat = 0
	    if (fbuf(jj+1)     .gt. xmax) goto 90
	    if (fbuf(jj+2)     .gt. ymax) goto 90
	    if (fbuf(jj+jspa+1) .lt. xmin) goto 90
	    if (fbuf(jj+jspa+2) .lt. ymin) goto 90
	    istat = 1
	    if (fbuf(j+2) .eq. -999 .and. 
     &		fbuf(jj+1)     .gt. xmin .and.
     &		fbuf(jj+2)     .gt. ymin .and.
     &		fbuf(jj+jspa+1) .lt. xmax .and.
     &		fbuf(jj+jspa+2) .lt. ymax ) istat = 4
	    goto 90
	  endif
	  if (type.eq.2000) then
	    do i = 1,nplot
	      pix(i).x = max(-32000,min(32000,INT((ax-Vleft)*xscale)))
	      pix(i).y = max(-32000,min(32000,INT((ay-Vtop)*yscale)))
	      ax = ax+dx
	      jj = jj+1
	      if (jj.ge.ly.nx) then
		ax = ly.x1
		ay = ay+dy
		jj = 0
	      endif
	    enddo
	  else
	    do i = 1,nplot
	      pix(i).x = max(-32000,min(32000,INT((fbuf(jj+1)-Vleft)*xscale)))
	      pix(i).y = max(-32000,min(32000,INT((fbuf(jj+2)-Vtop)*yscale)))
	      jj = jj+jspa
	    enddo
	  endif
c
c transform segment to pixels in X/Y/Z mode
	else
	  if (mode.eq.0) goto 90
	  do i = 1,nplot
	    if (type.eq.2000) then
	      x = xscl*( ax - xmid)
	      y = yscl*( ay - ymid)
	      z = zscl*( fbuf(i) - zmid)
	      ax = ax+dx
	      jj = jj+1
	      if (jj.eq.ly.nx) then
		ax = ly.x1
		ay = ay+dy
		jj = 0
	      endif
	    else
	      x = xscl*( fbuf(jj+1) - xmid)
	      y = yscl*( fbuf(jj+2) - ymid)
	      if (jspa.ge.3) then
	        z = zscl*( fbuf(jj+3) - zmid)
	      elseif (type.eq.1999 .or. type.eq.1998) then
	        z = zscl*( fbuf(j+2) - zmid)
	      else
	        z = -1
	      endif
	      jj = jj+jspa
	    endif
	    xx = x*a11 + y*a21 + z*a31
	    yy = x*a12 + y*a22 + z*a32
	    if (Gx.pdis.lt.100) then
	      zz = x*a13 + y*a23 + z*a33
	      ff = Gx.pdis/(Gx.pdis-zz)
	      xx = xx*ff
	      yy = yy*ff
	    endif
	    pix(i).x = max(-32000,min(32000,INT((xx-Vleft)*xscale)))
	    pix(i).y = max(-32000,min(32000,INT((yy-Vtop)*yscale)))
	  enddo
	endif
c
c plot pixels
	if (type.eq.1999 .or. type.eq.1997) then
	  if (color.eq.0) ic = max(1,min(Gx.ncolors,
     &			INT((fbuf(j+2)-Vlow)*cscale)))
	  call MX$DRAW_LINES (ic,pix,nplot)

	elseif (type.eq.1998) then
	  if (color.eq.0) ic = max(1,min(Gx.ncolors,
     &			INT((fbuf(j+2)-Vlow)*cscale)))
	  call MX$FILL_POLY (ic,pix,nplot,fpm)

	elseif (type.eq.3000 .and. color.ne.0) then
	  if (ly.symbol.ne.0) 
     &	    call MX$DRAW_SYMBOLS(ic,pix,nplot,ly.symbol,ly.radius)
	  if (ly.line.ne.0) 
     &	    call MX$DRAW_LINES(ic,pix,nplot)

	elseif (type.eq.3000) then
	  jj = j + min(4,jdim)
	  do i = 1,nplot
	    ic = max(1,min(Gx.ncolors,INT((fbuf(jj)-Vlow)*cscale)))
	    if (ly.symbol.ne.0) 
     &	      call MX$DRAW_SYMBOLS(ic,pix(i),1,ly.symbol,ly.radius)
	    if (ly.line.ne.0 .and. i.gt.1) 
     &	      call MX$DRAW_LINES(ic,pix(i-1),2)
	    jj = jj+jspa
	  enddo

	elseif (type.eq.2000 .and. Gx.hide) then
	  ! determine plotting order
	  zz1 =  a13 + a23 
	  zz2 = -a13 + a23 
	  zz3 = -a13 - a23 
	  zz4 =  a13 - a23 
	  if (zz1+zz4 .ge. zz2+zz3 .eqv. ly.xd .gt. 0) then
	    kx1 = 0
	    kx2 = ly.nx-2
	    kxi = 1
	  else
	    kx1 = ly.nx-2
	    kx2 = 0
	    kxi = -1
	  endif
	  if (zz1+zz2 .ge. zz3+zz4 .eqv. ly.yd .gt. 0) then
	    ky1 = 0
	    ky2 = ly.ny-2
	    kyi = 1
	  else
	    ky1 = ly.ny-2
	    ky2 = 0
	    kyi = -1
	  endif
	  do iy = ky1, ky2, kyi
	    do ix = kx1, kx2, kxi
	      i = iy*ly.nx + ix + 1
	      fillpix(1) = pix(i)
	      fillpix(2) = pix(i+1)
	      fillpix(3) = pix(i+ly.nx+1)
	      fillpix(4) = pix(i+ly.nx)
	      fillpix(5) = pix(i)
	      z = 0.25*(fbuf(i)+fbuf(i+1)+fbuf(i+ly.nx+1)+fbuf(i+ly.nx))
              ic = max(1,min(Gx.ncolors,INT((z-Vlow)*cscale)))
	      if (.not.BTEST(t2mode,P_FILL)) then
	        call MX$FILL_POLY (0,fillpix,4,fpm)
	      elseif (BTEST(t2mode,P_FILLC)) then
	        call MX$FILL_POLY (ic,fillpix,4,fpm)
	      else
	        call MX$FILL_POLY (PC_GREY1,fillpix,4,0)
	      endif
	      if (.not.BTEST(t2mode,P_MESH)) then
	      elseif (BTEST(t2mode,P_MESHC)) then
	        call MX$DRAW_LINES (ic,fillpix,5)
	      else
	        call MX$DRAW_LINES (PC_GREY1,fillpix,5)
	      endif
	      if (.not.BTEST(t2mode,P_DOTS)) then
	      elseif (BTEST(t2mode,P_DOTSC)) then
	        call MX$DRAW_DOTS(ic,fillpix,4,ly.thick)
	      else
	        call MX$DRAW_DOTS(PC_GREY1,fillpix,4,ly.thick)
	      endif
	    enddo
	  enddo

	elseif (type.eq.2000) then
	  if (BTEST(t2mode,P_FILL)) then
	    ic = PC_GREY1
	    if (color.eq.0 .and. .not. BTEST(t2mode,P_FILLC)) color = -1
	    do iy = 0,ly.ny-2
	      do ix = 1,ly.nx-1
		i = iy*ly.nx + ix
		fillpix(1) = pix(i)
		fillpix(2) = pix(i+1)
		fillpix(3) = pix(i+ly.nx+1)
		fillpix(4) = pix(i+ly.nx)
		if (color.eq.0) then
		  z = 0.5*(fbuf(i)+fbuf(i+1))
	          ic = max(1,min(Gx.ncolors,INT((z-Vlow)*cscale)))
		endif
		call MX$FILL_POLY (ic,fillpix,4,fpm)
	      enddo
	    enddo
	  endif
	  if (BTEST(t2mode,P_MESH)) then
	    do iy = 0,ly.ny-1
	      if (BTEST(t2mode,P_MESHC)) then
		do ix = 1,ly.nx-1
		  i = iy*ly.nx + ix
		  z = 0.5*(fbuf(i)+fbuf(i+1))
	          ic = max(1,min(Gx.ncolors,INT((z-Vlow)*cscale)))
	          call MX$DRAW_LINES (ic,pix(i),2)
		enddo
	      else
	        call MX$DRAW_LINES (PC_GREY1,pix(iy*ly.nx+1),ly.nx)
	      endif
	    enddo
	    call M$MALLOC (ly.ny*4, ltmp)
	    do ix = 1,ly.nx
	      call M$VMOV( pix(ix),ly.nx, %val(ltmp),1, ly.ny)
	      if (BTEST(t2mode,P_MESHC)) then
		do iy = 0,ly.ny-2
		  i = iy*ly.nx + ix
		  z = 0.5*(fbuf(i)+fbuf(i+ly.nx))
	          ic = max(1,min(Gx.ncolors,INT((z-Vlow)*cscale)))
	          call MX$DRAW_LINES (ic,%val(ltmp+iy*4),2)
		enddo
	      else
	        call MX$DRAW_LINES (PC_GREY1,%val(ltmp),ly.ny)
	      endif
	    enddo
	    call M$FREE (ltmp)
	  endif
	  if (BTEST(t2mode,P_DOTS)) then
	    if (BTEST(t2mode,P_DOTSC)) then
	      do i = 1,nplot
	        ic = max(1,min(Gx.ncolors,INT((fbuf(i)-Vlow)*cscale)))
	        call MX$DRAW_DOTS(ic,pix(i),1,ly.thick)
	      enddo
	    else
	      do i = 1,nplot
	        call MX$DRAW_DOTS(PC_GREY1,pix(i),1,ly.thick)
	      enddo
	    endif
	  endif
	endif
c
c finish the mode
 90	if (mode.eq.0) then
	  if (istat.eq.0) then
	    mode = 1
	  elseif (fbuf(j+2).eq.-999) then
	    istatb = istat
	    npts = 0
	    mode = 1
	  endif
	endif
	if (mode.ne.0) j = j + (3+npts)*jspa
	mode = 1-mode
	enddo
	call MX$DRAW_MODE (0)
	return

	end

	subroutine XP3D_GET_DATA (ly,name,m)
	include 'xp3d.inc'
	character name*(*), keyval*8
	record /HEADER/ hcb
c
c open input file
	hcb.file_name = name
	hcb.type_allow = '1000,2000,3000,5000'
	hcb.format_allow = 'S*,C*,V*'
	hcb.switch = 'NOABORT'
	call M$INOK (hcb)
	hcb.buf_type = 'F'

	ly.type = 0
	ly.nelem = 0
	ly.bufloc = 0
	ly.offset = 0
	ly.t2mode = 0
	ly.line  = 1
	ly.thick = 1
	ly.symbol = 0
	ly.radius = 1
	ly.color = 0

	if (.not. hcb.open) then
	  ly.nelem = -1

	elseif (hcb.type .eq. 1998 .or. hcb.type .eq. 1999) then
	  ly.type = hcb.type
	  ly.spa  = hcb.spa
	  ly.dim  = ly.spa+1	! for now
	  ly.nelem  = hcb.size
	  ly.bufsize = ly.nelem * hcb.spa * max(hcb.bps,4)

	elseif (hcb.class .eq. 1) then
	  ly.type   = 3000
	  ly.spa  = hcb.spa
	  ly.dim  = ly.spa	! for now
	  ly.nelem  = hcb.size
	  ly.bufsize = ly.nelem * hcb.spa * max(hcb.bps,4)

	elseif (hcb.class .eq. 2) then
	  ly.type   = 2000
	  ly.spa  = hcb.spa
	  ly.dim  = 3
	  ly.nx  = hcb.subsize
	  ly.ny  = hcb.size
	  ly.nelem  = ly.nx * ly.ny
	  ly.x1 = hcb.xstart
	  ly.xd = hcb.xdelta
	  ly.y1 = hcb.ystart
	  ly.yd = hcb.ydelta
	  ly.bufsize = ly.nelem * max(hcb.bps,4)
	  if (hcb.spa .ne. 1) call M$ERROR 
     &	  ('Type 2000 files must contain type scalar data')
	  call M$FORCE1000 (hcb)

	elseif (hcb.class .eq. 3 .or. hcb.class .eq. 5) then
	  ly.type   = 3000
	  ly.spa  = hcb.bpe / hcb.bps
	  i = 1
	  if (M$GET_UQUALIFIER(hcb,'NAME',keyval).gt.0) then
	    i = M$SUB_FIND (hcb,keyval)
	    if (i.le.0) call M$WARNING ('Subrecord not found: '//keyval)
	    i = max(1,i)
	  endif
	  ly.dim  = M$SPA(hcb.subr(i).format)
	  if (ly.dim.eq.1) ly.dim = min(4,hcb.subrecords)
	  ly.offset = M$SUB_OFFSET(hcb,i) / hcb.bps * 4
	  ly.color  = 0
	  ly.line  = 0
	  ly.symbol = L_SquareSymbol
	  ly.nelem  = hcb.size
	  ly.bufsize = ly.nelem * max(hcb.bpe, ly.spa*4)

	endif

	if (hcb.open) then	! generic operations
	  if (M$GET_KEYWORD(hcb,'COLORNAME',keyval) .gt. 0) then
	    if (keyval.eq.'GRID') ly.color = -1
	  endif	  
	  call M$MALLOC (ly.bufsize,ly.bufloc)
	  call M$GRAB (hcb,%val(ly.bufloc),1.d0,ly.nelem,-1)
	  call TRIM_NAME (hcb.file_name, ly.name) 
	  call M$CLOSE (hcb)
	  ly.enable = M$GET_QUALIFIER(hcb,'EM')
	  if (ly.enable .eq. -1) ly.enable = P_ENABLE
	else
	  ly.enable = P_DISABLE
	endif

c	write(*,*) ly.type, ly.spa, ly.dim, ly.nelem, ly.offset
c
	return
	end	  


	subroutine XP3D_LAYER_MOD (k)
	include 'xp3d.inc'
	pointer (ply,ly)
	logical*4 modified
	character c

	ply = Gx.lloc(k)
	modified = .false.
	m = MX$MENU(0,'LAYER;Enables,Delete,Rename,'//
     &		'LineType,Thickness,Symbols,Radius,Color')
	if (m .eq. 1) then
	  ii = ly.enable
	  if (XP3D_ENABLED(ly.enable,-9)) continue
	  modified = ly.enable .ne. ii
	elseif (m.eq.2) then
	  Gx.bsmask = 0
	  call M$FREE (ly.bufloc)
	  call M$FREE (Gx.lloc(k))
	  Gx.nlayer = Gx.nlayer - 1
	  do k = k,Gx.nlayer
	    Gx.lloc(k) = Gx.lloc(k+1)
	  enddo
	  return
	elseif (m.eq.3) then
	  call MX$PROMPT ('New Name: ',ly.name)
	elseif (m.eq.4) then
	  ii = ly.line
	  ly.line = MX$MENU(ly.line+1,'LINE TYPE;None,'//
     &		'Verticals,Horizontals,Connecting')-1
	  modified = ly.line .ne. ii
	elseif (m.eq.5) then
	  ii = ly.thick
	  call MX$LVAL ('Line Thickness: ',ly.thick,-8,8,1,0)
	  modified = ly.thick .ne. ii
	elseif (m.eq.6) then
	  ii = ly.symbol
	  i = MX$MENU(min(8,ii)+1, 'SYMBOLS;'//
     &        'None,Pixels,Circles,Squares,Plusses,X''s,'//
     &        'Triangles,Downward Triangles,ASCII...') - 1
	  if (i.eq.8) then
	    c = ' '
	    if (ii.gt.ICHAR(' ')) c = CHAR(ii)
	    call MX$PROMPT('ASCII Character: ', c)
	    if (c .ne. ' ') ly.symbol = ICHAR(c)
	  else
	    ly.symbol = i
	  endif
	  modified = ly.symbol .ne. ii
	elseif (m.eq.7) then
	  ii = ly.radius
	  call MX$LVAL ('Symbol Radius: ',ly.radius,-16,16,1,0)
	  modified = ly.radius .ne. ii
	elseif (m.eq.8) then
	  ii = ly.color
	  call MX$LPROMPT ('Color: ',ly.color)
	  modified = ly.color .ne. ii
	endif
	if (modified .and. BTEST(ly.enable,PM_BS)) Gx.bsmask=0
	end


	subroutine XP3D_CBAR
	include 'xp3d.inc'
	integer*4 i1, i2, j1, j2, ih, iw, jl, istrx, istry, ic, nsk
	character strx*6, stry*6
	real*8 dexp

	if (Gx.cbar) then	! along right edge
	  i1 = Mx.width - Mx.text_w*2
	  j1 = Mx.stk(1).y1
	  iw = Mx.text_w 
	  ih = Mx.stk(1).y2 - Mx.stk(1).y1
	  if (Gx.axes) i1 = i1 - Mx.text_w*5
	elseif (.not. Gx.spec) then
	  return
	else			! in specs space
	  i1 = Mx.width - Mx.text_w*2
	  j1 = Mx.height - Mx.text_h*2.5
	  iw = Mx.text_w 
	  ih = Mx.text_h * 2
	endif
	i2 = i1 + iw
	j2 = j1 + ih
	do j = 2, ih-2
	  ic = Gx.ncolors*(j-2)/(ih-3) + 1
	  call MX$DRAW_LINE (ic, i1, j2-j, i2 ,j2-j)
	enddo
	call MX$DRAW_BOX (-1, i1-2, j1, iw+4, j2-j1)
	if (Gx.cbar .and. Gx.axes) then
	  jl = -100
	  dexp = max( dabs(Gx.c1), dabs(Gx.c2) )
	  istrx = M$D2A_FORM(dexp,strx,'ENG')
	  istrx = M$SEARCH(strx,'E')
	  if (istrx.gt.0) then
	    read (strx(istrx+1:),*) dexp
	    dexp = 10.0 ** (-dexp)
	  else
	    dexp = 1
	  endif
	  nsk = 1
	  do n = 1,Gx.ncolors,nsk
	    dval = Gx.c2 + (Gx.c1-Gx.c2)*(n-.5)/Gx.ncolors
	    j = j1 + ih*(n-.5)/Gx.ncolors + Mx.text_h*.25
	    istry = M$D2A (dval*dexp,stry)
	    call MX$TEXT (i2,j,stry(1:istry))
	  enddo
	  if (istrx.gt.0) call MX$TEXT(i2,j2+Mx.text_h,strx(istrx:))
	endif
	return
	end

