DataMuseum.dk

top - download

    Length: 16086 (0x3ed6)
    Types: TextFile
    Names: »subsd.f«

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

TextFile

*************************************************************************
*
* subroutine rstotbl does the following:
*  (reset segments overlapping table)
*     + (re) initialize segments overlapping table
*************************************************************************
	subroutine rstotbl
	common/ovlap/iovlap(21,21)
c
	   do 20 i=1,21
	      do 30 j=1,21
	           iovlap(i,j)=0
30            continue
20         continue
	return
	end
*************************************************************************
*
* subroutine ckovlap(itemnum) does the following:
*  (check overlapping)
*      + segment number (itemnum)
*      + special case:
*       - check if segment overlaps segment page
*         (boundary of page)
*      + general case:
*       - check if segment overlaps other segments
*************************************************************************
	subroutine ckovlap(itemnum)
	integer itemnum
	common/num/numitms
c
c check overlapping between segment page & segment itemnum.
	i=itemnum
	call stovlap(i,21)
	   if(numitms.gt.1)then
	       do 30 j=1,i-1
	           call stovlap(i,j)
30	       continue
	        do 40 k=i+1,numitms
	           call stovlap(i,k)
40	        continue
	    endif
	return
	end
************************************************************************
*
* subroutine stovlap(segone,segtwo) does the following:
* (segments overlaps)
*     + segments numbers are (segone) and (segtwo)
*     + set segment page flag (ipgflag) to zero
*       (in case one of the segments is the page 
*        segment then ipgflag will be set to one
*        to handle it differently from other segments)
*     + box each segment
*     + compare segments for overlapping one way
*     + compare segments the other way (in case one 
*       segment contained fully the other one and the 
*       first check did not pick it up)
*     + segments overlaps?
*      - yes-->
*         * set the corresponding entries in the 
*           overlapping table
*      - no-->
*         * return
************************************************************************
	subroutine stovlap(segone,segtwo)
	integer segone,segtwo
	common/pgflg/ipgflag
	real a(8),b(8)
	integer overlap
c
	ipgflag=0
	call boxitm(segone,a)
	call boxitm(segtwo,b)
	call compare(a,b,overlap)
	if(overlap.eq.0.and.ipgflag.eq.0)then
	   call compare(b,a,overlap)
	endif
	  if(overlap.eq.1)then
	         call setovlp(segone,segtwo)
	  endif
	return
	end
**************************************************************************
*
* subroutine boxitm(oneitm,box) does the following:
* (box item)
*     + segment number (oneitm)
*     + (box) holds boxs four corner coords
*     + special case:
*      - yes-->
*        * page segment
*          # set page flag (ipgflag=1)
*          # access auxiliary table to get pages (blc)
*            and (trc)
*          # build box
*        * background segment
*          # box contains zeros
*        * (ucp)
*          # box contains ones
*     + general case:
*      - yes-->
*        * box a standard item (square,rectangle,triangle
*          , circle,line)
**************************************************************************
	subroutine boxitm(oneitm,box)
	integer oneitm
	real box(8)
	common/table/tblitms(20,10),icolor(20),items(20)
	common/at/asegtbl(2,10),isgclr(2),seg(2)
	common/pgflg/ipgflag
	character*1 items,seg
	real xb,yb,xt,yt
c
	if(oneitm.eq.21)then
	   ipgflag=1
	   xb=asegtbl(1,2)
	   yb=asegtbl(1,3)
	   xt=asegtbl(1,4)
	   yt=asegtbl(1,5)
	   call boxit(xb,yb,xt,yt,box)
	else
	if(items(oneitm).eq.'b')then
	     do 22 i=1,8
	        box(i)=0.0
22	     continue
	elseif(items(oneitm).eq.'u')then
	     do 23 j=1,8
	        box(j)=1.0
23	     continue
	else
	     call boxsitm(oneitm,box)
	endif
	endif
	return
	end
******************************************************************************
*
* subroutine boxsitm(itemno,array) does the following:
* (box a standard item)
*    + segment number (itemno)
*    + box is (array)
*    + access (pwb) for (blc),(trc) and side length
*    + (square,rectangle,line)
*      - pass (blc) and (trc) to build box routine (boxit)
*    + (triangle)
*      - calculate (trc)
*      - pass (blc) and (trc) to build box routine (boxit)
*    + (circle)
*      - calculate (blc) and (trc)
*      - pass (blc) and (trc) to build box routine (boxit)
******************************************************************************
	subroutine boxsitm(itemno,array)
	integer itemno
	real array(8)
	common/table/tblitms(20,10),icolor(20),items(20)
	character*1 items
	real xb,yb,xt,yt,slen,xtemp,ytemp
c
	slen=tblitms(itemno,1)
	xb=tblitms(itemno,2)
	yb=tblitms(itemno,3)
	xt=tblitms(itemno,4)
	yt=tblitms(itemno,5)
c
	if(items(itemno).eq.'s'.or.items(itemno).eq.'r'.or.
     *     items(itemno).eq.'l')then
	     call boxit(xb,yb,xt,yt,array)
	elseif(items(itemno).eq.'c')then
	     xtemp=xb
	     ytemp=yb
	     xb=xb-slen
	     yb=yb-slen
	     xt=xtemp+slen
	     yt=ytemp+slen
	     call boxit(xb,yb,xt,yt,array)
	elseif(items(itemno).eq.'t')then
	     xt=xb+slen
	     yt=yb+slen
	     call boxit(xb,yb,xt,yt,array)
	else
	     continue
	endif
	return
	end
****************************************************************************
*
* subroutine boxout(segbox,answer) does the following:
* (box out of page bounds)
*    + segment box (segbox)
*    + box is out?
*     - yes-->
*        * return (answer=1)
*     - no-->
*        * return (answer=0)
*    + check segbox four corners against page bounds
*    + if one corner is out then item considered out
*      return now with (answer=1)
*    + if all corners in item considered in return 
*      (answer=0)
****************************************************************************
	subroutine boxout(segbox,answer)
	real segbox(8)
	integer answer,out
	real tempnt(2)
c
	j=1
	do 35 i=1,4
	   tempnt(1)=segbox(j)
	   tempnt(2)=segbox(j+1)
	   call checkit(tempnt,out)
	      if(out.eq.1)then
	                      answer=1
                              return
	      else
	                      j=j+2
	      endif
35	continue
	answer=0
	return
	end
******************************************************************************
*
* subroutine checkit(point,reply) does the following:
* (check it)
*     + check if point (point) lies out of page bounds
*      - yes-->
*        * return (reply=1)
*      - no-->
*        * return (reply=0)
******************************************************************************
	subroutine checkit(point,reply)
	real point(2)
	integer reply
c
	if(point(1).lt.0.0.or.point(1).gt.10.0.or.
     *     point(2).lt.0.0.or.point(2).gt.10.0)then
	      reply=1
	else
	      reply=0
	endif
	return
	end
***************************************************************************
*
* subroutine isboxpg(box,reply) does the following:
*  (is box page--is box coords equals page coords)
*     + segment box is (box)
*     + check if they are equal?
*      - yes-->
*       * return (reply=1)
*      - no-->
*       * return (reply=0)
***************************************************************************
	subroutine isboxpg(box,reply)
	real box(8)
	integer reply
c
	reply=0
	if(box(1).eq.0.0.and.box(2).eq.10.0.and.
     *     box(5).eq.10.0.and.box(6).eq.10.0)then
	   reply=1
	endif
	return
	end
**************************************************************************
*
* subroutine pobound(pnt,reply) does the following:
* (point overlap boundary)
*   + point coords is (pnt)
*   + check if point (pnt) lies on page bounds?
*    - yes-->
*     * return (reply=1)
*    - no-->
*     * return (reply=0)
**************************************************************************
	subroutine pobound(pnt,reply)
	real pnt(2)
	integer reply
c
	reply=0
	if(pnt(1).eq.0.0.or.pnt(1).eq.10.0.or.
     *     pnt(2).eq.0.0.or.pnt(2).eq.10.0)then
	   reply=1
	endif
	return
	end
*****************************************************************************
*
* subroutine boxit(x1,y1,x2,y2,bbox) does the following:
*  (box it)
*      + items (blc) and (trc) are (x1,y1) and (x2,y2)
*        respectivly
*      + build boxs four corners and store in (bbox)
*      + return (bbox)
*****************************************************************************
	subroutine boxit(x1,y1,x2,y2,bbox)
	real x1,y1,x2,y2,bbox(8)
c
	bbox(1)=x1
	bbox(2)=y1
	bbox(3)=x2
	bbox(4)=y1
	bbox(5)=x2
	bbox(6)=y2
	bbox(7)=x1
	bbox(8)=y2
	return
	end
****************************************************************************
*
* subroutine compare(boxone,boxtwo,ovlpflg) does the following:
*  (compare)
*       + segments boxes are (boxone) and (boxtwo)
*       + check if boxes overlaps?
*        - yes-->
*         * return (ovlpflg=1)
*        - no-->
*         * return (ovlpflg=0)
*       + special cases:
*        - either (boxone) or (boxtwo) is
*          * (ucp) or (bkgd)
*          * (ucp)-- (ovlpflg=1)
*          * (bkgd)-- (ovlpflg=0)
*        - either (boxone) or (boxtwo) is
*          * horizontal line (hl) or vertical line (vl)
*          * handle seperatly by calling (boxlin)
*       + general cases:
*        - check the four corners of (boxone) 
*          against (boxtwo)
*        - if one corner overlaps return now
*          with (ovlpflg=1)
*        -if four corners in return (ovlpflg=0)
****************************************************************************
	subroutine compare(boxone,boxtwo,ovlpflg)
	integer ovlpflg,reply
	real boxone(8),boxtwo(8),tempnt(2)
	integer ans1,ans2,ans3,ans4
c
	call zeroone(boxone,ans1)
	call zeroone(boxtwo,ans2)
	call isblin(boxtwo,ans3)
	call isblin(boxone,ans4)
	if(ans1.eq.0.or.ans2.eq.0)then
	      ovlpflg=0
	elseif(ans1.eq.1.or.ans2.eq.1)then
	      ovlpflg=1
	elseif(ans3.eq.1.or.ans3.eq.2)then
	      call boxlin(boxone,boxtwo,ans3,ovlpflg)
	elseif(ans4.eq.1.or.ans4.eq.2)then
	      call boxlin(boxtwo,boxone,ans4,ovlpflg)
	else
	      j=1
	      do 25 i=1,4
	         tempnt(1)=boxone(j)
	         tempnt(2)=boxone(j+1)
	         call check(boxtwo,tempnt,reply)
	         if(reply.eq.1)then
	           ovlpflg=1
	           return
	
	         else
	           j=j+2
	         endif
25	      continue
	      ovlpflg=0
	endif
	return
	end
*****************************************************************************
*
* subroutine isblin(boxx,boxans) does the following:
* (is box a line )
*     + items box (boxx)
*     + if line is horizontal return (boxans=1)
*     + if line is vertical return (boxans=2)
*     + else return (boxans=0)
******************************************************************************
	subroutine isblin(boxx,boxans)
	real boxx(8)
	integer boxans
c
	if(boxx(2).eq.boxx(6))then
	          boxans=1
	elseif(boxx(1).eq.boxx(3))then
	          boxans=2
	else
	          boxans=0
	endif
	return
	end

******************************************************************************
*
*  SUBROUTINE BONDRY
*                    + draw the boundary of the image.
******************************************************************************


c
	subroutine bondry
	call clr
	call sec(18)
	call scl(10.0,10.0)
	call sqr
	return
	end


******************************************************************************
*
* subroutine boxlin(boxa,boxb,ansbox,ovlpln) does the following:
*  ( box line - at least one box is a (hl) or (vl) )
*       + items boxes are (box) and (boxb)
*       + type of line (ansbox)
*       + overlapping answer (ovlpln)
*       + special case:
*        - (boxa) is page segment
*         * check if any of (boxb)s four corners lies on page
*           bounds
*          # yes-->
*            -- return (ovlpln=1)
*          # no-->
*            -- return (ovlpln=0)
*       + general case:
*        - (hl)
*          * check if (boxb)--(hl) lies anywhere between
*            (boxa)s (ymin,ymax) if so return (ovlpln=1)
*            else (ovlpln=0).
*        - (vl)
*          * check if (boxb)--(vl) lies anywhere between
*            (boxa)s (xmin,xmax) if so return (ovlpln=1)
*            else (ovlpln=0)
*
*****************************************************************************
	subroutine boxlin(boxa,boxb,ansbox,ovlpln)
	common/pgflg/ipgflag
	real boxa(8),point(2),boxb(8)
	integer ansbox,ovlpln,anspnt
c
	ovlpln=0
	if(ipgflag.eq.1)then
	    j=1
	    do 20 i=1,2
	       point(1)=boxb(j)
	       point(2)=boxb(j+1)
	       call pobound(point,anspnt)
	       if(anspnt.eq.1)then
	          ovlpln=1
	          return
	       else
	          j=j+4
	       endif
20	    continue
	else
	    if(ansbox.eq.1)then
	       if((boxb(2).ge.boxa(2)).and.(boxb(2).le.boxa(6)))then
	              ovlpln=1
	              return
	       endif
	    elseif(ansbox.eq.2)then
	       if((boxb(1).ge.boxa(1)).and.(boxb(1).le.boxa(3)))then
	              ovlpln=1
	              return
	       endif
	    else
	       continue
	    endif
	endif
	return
	end
***************************************************************************
*
* subroutine zeroone(array,ans) does the following:
* (zeros or ones)
*       + check if (array) contains :
*        - all zeros return (ans=0)
*        - all ones return (ans=1)
*        - otherwise return (ans=2)
**************************************************************************
	subroutine zeroone(array,ans)
	real array(8)
	integer ans,flag
c
	flag=100
	j=1
10	if(j.le.8)then
	   if(array(j).eq.0.0)then
	              j=j+1
	   else
	              j=flag
	   endif
	go to 10
	endif
c
	if(j.ne.flag)then
	     ans=0
	     return
	else
	   j=1
20	   if(j.le.8)then
	      if(array(j).eq.1.0)then
	             j=j+1
	      else
	             j=flag
	      endif
	    go to 20
	    endif
c
	    if(j.ne.flag)then
	         ans=1
	         return
	    else
	         ans=2
	    endif
	endif
	return
	end
*****************************************************************************
*
* subroutine check(itmbox,point,answer) does the following:
* (check)
*       + check if one points coords (point) lies within
*         one items box ,if so return (answer=1) else
*         return (answer=0)
*       + special case:
*        - (itmbox) represent boxed segment page
*        - check if (point) actually lies on page bounds
*       + general case:
*        - check if (point)s x-coords between (itmbox)s
*          (xmin,xmax) and (point)s y-coords between
*          (itmbox)s (ymin,ymax) return (answer) accordingly.
*
*****************************************************************************
	subroutine check(itmbox,point,answer)
	real itmbox(8),point(2)
	integer answer,yesorno
	common/pgflg/ipgflag
c
	if(ipgflag.eq.1)then
	   call pobound(point,yesorno)
	   if(yesorno.eq.1)then
	         answer=1
	   else
	         answer=0
	   endif
	else
	if(point(1).ge.itmbox(1).and.point(1).le.itmbox(3).and.
     *     point(2).ge.itmbox(2).and.point(2).le.itmbox(6))then
c
c
	answer=1
	else
	answer=0
	endif
	endif
	return
	end
*****************************************************************************
*
* subroutine setovlp(itmone,itmtwo) does the following:
* ( set overlapping)
*        + segments numbers (itmone) and (itmtwo)
*        + access overlapping table (iovlap)
*          to set corresponding entries.
*
*****************************************************************************
	subroutine setovlp(itmone,itmtwo)
	integer itmone,itmtwo
	common/ovlap/iovlap(21,21)
c
	iovlap(itmone,itmtwo)=1
	iovlap(itmtwo,itmone)=1
	return
	end
****************************************************************************
*
* subroutine upotbl(itemno) does the following:
*  (update segments overlapping table)
*      + after deleting a segment update table
*        to show changes.
*
****************************************************************************
	subroutine upotbl(itemno)
	integer itemno
	common/num/numitms
	common/ovlap/iovlap(21,21)
c
c update the rows first.
	do 25 i=itemno,numitms-1
	   do 30 j=1,21
	      iovlap(i,j)=iovlap(i+1,j)
30	   continue
25	continue
c update the columns next.
	do 35 j=itemno,numitms-1
	   do 40 i=1,21
	      iovlap(i,j)=iovlap(i,j+1)
40	   continue
35	continue
	return
	end