DataMuseum.dk

top - metrics - download

    Length: 3912 (0xf48)
    Types: TextFile
    Names: »subs6.f«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─⟦this⟧ »EUUGD11/euug-87hel/sec1/utep/subs6.f« 

TextFile

**************************************************************************
*
* subroutine dfr(iclr,xx1,yy1,xx2,yy2)
* does the following:
*   + draw a filled rectangle with
*     bottom left corner at (xx1,yy1)
*     and top right corner at (xx2,yy2)
*     were filling color is (iclr).
*   + within call move,(blc) transformed 
*     into device coords ,move to (blc)
*     then decode (blc) and insert into
*     (jpage).
*   + transform (trc) to device coords
*   + set filling color to (iclr).
*   + insert ascii code equivalent
*     to decimal code (111) for (dfr)
*     into (jpage).
*   + decode (trc) and insert into (jpage)
*
***************************************************************************
	subroutine dfr(iclr,xx1,yy1,xx2,yy2)
	integer iclr
	real xx1,yy1,xx2,yy2,sx2,sy2
	integer idrect,i2,j2
	character*1 drect

	idrect=111
	call move(xx1,yy1)
	call wdscrn(xx2,yy2,sx2,sy2)
	call driver(sx2,sy2,i2,j2)
c set the color to iclr.
	call sec(iclr)
c insert the code for (dfr)=111
	drect=char(idrect)
	call store(drect)
	call xyaed(i2,j2)
	return
	end
****************************************************************************
*
* subroutine sec(jclr) does the following:
*    + insert the equivalent ascii code
*      for decimal (67) into (jpage)
*      for change color.
*    + insert the character for (jclr)
*       in jpage.
*
*****************************************************************************
	subroutine  sec(jclr)
	integer jclr,ic
	character*1 c
c
	ic=67
	c=char(ic)
	call store(c)
	call zaed(jclr)
	return
	end
**************************************************************************
*
* subroutine ifl does the following:
*    + interior fill any polygon containing 
*      current access position (cap) with
*      current color.
*    + insert ascii equivalent to
*      decimal (73) for (ifl) into
*      (jpage).
*
**************************************************************************
	subroutine ifl
	integer ifill
	character*1 fill
c
	ifill=73
	fill=char(ifill)
	call store(fill)
	return
	end
***************************************************************************
*
* subroutine dcl(rad) does the following:
*      + transform (rad) into device coords (ir)
*      + draws circle centered at (cap) with
*        radius (ir)
*        ( ir between and including 0,127 decimal)
******************************************************************************
	subroutine dcl(rad)
	real rad
	common/worldc/xlast,ylast
	real theta,pi,ang,x1,y1,sx1,sy1,sxlast,sylast
	integer ii,jj,icentr,jcentr,ir,icircl
	character*1 circl
c
c insert code for circle in display file.
c
	icircl=79
	circl=char(icircl)
	call store(circl)
c
	theta=45.0
	pi=3.14159265
	ang=((pi/180.0)*theta)
c
	x1=rad*cos(ang)+xlast
	y1=rad*sin(ang)+ylast
c
	call wdscrn(x1,y1,sx1,sy1)
	call driver(sx1,sy1,ii,jj)
	call wdscrn(xlast,ylast,sxlast,sylast)
	call driver(sxlast,sylast,icentr,jcentr)
c now compute the radius of the circle.
	ir=int(sqrt((float(ii-icentr)**2)+(float(jj-jcentr)**2)))
c check if raduis is within and including (0,127)
c if so insert the character value into (jpage)
c else if raduis greater than (127)d then set
c it to (127)d
	if((ir.ge.0).and.(ir.le.127))then
	call zaed(ir)
	endif
c
	if(ir.gt.127)then
	         ir=127
	          call zaed(ir)
	endif
	return
	end
***************************************************************************
*
* subroutine star(iclr) does the following:
*      + set color to (iclr)
*      + draws star boundary centered on
*        a window(0.0,1.0,0.0,1.0)
*        the data is given below.
*
*************************************************************************
	subroutine star(iclr)
	integer iclr
c
	real x(10),y(10)
	data x/0.61,1.0,0.7,0.79,0.5,0.21,0.3,0.0,0.38,0.5/
	data y/0.65,0.65,0.37,0.0,0.23,0.0,0.37,0.65,0.65,1.0/
	call sec(iclr)
	call move(0.5,1.0)
	do 400 i=1,10
	call line(x(i),y(i))
400	continue
	return
	end