|
DataMuseum.dkPresents historical artifacts from the history of: DKUUG/EUUG Conference tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DKUUG/EUUG Conference tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: T s
Length: 21743 (0x54ef)
Types: TextFile
Names: »subsc.f«
└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
└─⟦this⟧ »EUUGD11/euug-87hel/sec1/utep/subsc.f«
***************************************************************************
*
* subroutine dmove does the following:
* ( define move)
* + explain command m - move and fill
* to user
* + display commands options
**************************************************************************
subroutine dmove
c
write(0,7)
7 format(5x,'This command is intended to let the user fill',/,
* 5x,'user constructed polygon or background of image with',/,
* 5x,'color')
call mfoptns
return
end
****************************************************************************
*
* subroutine mfoptns does the following:
* ( command move and fill options)
* + display options
* + ask user to make a selection
****************************************************************************
subroutine mfoptns
c
write(0,17)
17 format(5x,'u- to color User constructed polygons',/,
* 5x,'b- to color Background of image')
write(0,27)
27 format(5x,'Input your selection')
return
end
****************************************************************************
*
* subroutine mvwhere does the following:
* (move where)
* + This routine called after displaying
* command 'm' options
* + read command
* + valid command?
* - yes-->
* * process command
* - no-->
* * error-try again
****************************************************************************
subroutine mvwhere
character*1 choice
c
do 23 i=1,4
read(5,33)choice
33 format(a1)
c
if(choice.eq.'u'.or.choice.eq.'U')then
call splyflg
i=5
elseif(choice.eq.'b'.or.choice.eq.'B')then
call clrbkgd
i=5
else
call error(3)
call mfoptns
endif
23 continue
return
end
****************************************************************************
*
* subroutine splyflg does the following:
* (set polygon flag)
* + user constructed polygon (ucp)
* under construction.
* + user allowed to build up to 5 (ucp)
* + check number of (ucp) in image
* - numpoly <= limit
* * yes-->
* # increment their number (numpoly)
* # set (ucp) flag on
* # set number of lines in polygon to zero
* (lncontr)
* # IMPORTANT!-- user responsibility to
* construct a CLOSED polygon
* using ONLY lines.
* * no-->
* # display warning message-limit have been
* used
****************************************************************************
subroutine splyflg
common/poly/iflag,numpoly,ifivply(5)
common/llist/lnlist(5,2),lncontr
common/aucp/iaucp
common/num/numitms
c
numpoly=numpoly+1
if(numpoly.le.5)then
iflag=1
lncontr=0
write(0,14)
14 format(5x,'To construct a CLOSED polygon use command',/,5x,
* 'l-line ONLY from items menu,coming up!')
c
c
if(iaucp.eq.1)then
do 34 i=1,19
if(numitms.lt.20)then
if(iflag.eq.1)then
call itmmenu
call ditem
else
i=20
endif
else
write(0,44)
44 format(5x,'WARNING: You have used the limit '
* 'of items/page')
i=20
endif
34 continue
endif
else
write(0,24)
24 format(5x,'Warning:You have used the limit of polygons/page')
numpoly=numpoly-1
endif
return
end
*****************************************************************************
*
* subroutine upolyln does the following:
* (line belongs to user constructed polygon)
* + set this lines deletion flag to zero
* to protect user against accidental
* deletion,will be set back to one
* after deletion of its (ucp).
* + increment (ucp) line counter (lncontr)
*****************************************************************************
subroutine upolyln
common/num/numitms
common/table/tblitms(20,10),icolor(20),items(20)
common/llist/lnlist(5,2),lncontr
character*1 items
c
tblitms(numitms,10)=0.0
lncontr=lncontr+1
return
end
****************************************************************************
*
* subroutine sbpovlp(bp,itsnum) does the following:
* (set background or user polygon overlapping)
* + segment type (bp)
* - segment background (bp='b')
* * does not overlap any other segment
* - segment (ucp) (bp='u')
* * segment overlaps all segments
* + segment number (itsnum)
***************************************************************************
subroutine sbpovlp(bp,itsnum)
integer itsnum
character*1 bp
common/ovlap/iovlap(21,21)
c
if(bp.eq.'b')then
do 25 i=1,21
iovlap(itsnum,i)=0
iovlap(i,itsnum)=0
25 continue
else
do 50 i=1,21
iovlap(itsnum,i)=1
iovlap(i,itsnum)=1
50 continue
endif
iovlap(itsnum,itsnum)=0
return
end
****************************************************************************
*
* subroutine usrpoly does the following:
* ( user constructed polygon - (ucp))
* + segment type -'u'
* + enter segment info in (pwb)
* + enter segment info in (ucp)s
* common block
****************************************************************************
subroutine usrpoly
common/poly/iflag,numpoly,ifivply(5)
common/num/numitms
common/llist/lnlist(5,2),lncontr
character*1 uply
c
uply='u'
call enterbp(uply)
ifivply(numpoly)=numitms
lnlist(numpoly,1)=numitms
lnlist(numpoly,2)=lncontr
return
end
***************************************************************************
*
* subroutine clrbkgd does the following:
* (color background )
* + search if segment background has been
* created already
* - yes-->
* * error--cannot create another background
* segment
* - no-->
* * search if image contain outlined items
* - yes-->
* # error--cannot change color of background
* segment
* - no-->
* # enter segment info in (pwb)
* # show change in color on screen
* # list content of segment table to show
* changes
***************************************************************************
subroutine clrbkgd
common/table/tblitms(20,10),icolor(20),items(20)
common/num/numitms
common/contr/icnt
common/space/ifree
character*1 bg,items
integer kclr
c
call srchtbl(kclr)
if(kclr.ne.0)then
call error(11)
else
bg='b'
write(0,10)
10 format(5x,'Now you are going to change the background color')
call enterbp(bg)
call tempinf(numitms)
tblitms(numitms,8)=icnt
call showbg
tblitms(numitms,9)=icnt-1
ifree=icnt
call sendcod(numitms)
do 20 i=1,numitms
call tempinf(i)
call sndscd(i)
20 continue
call lsitems
endif
return
end
**************************************************************************
*
* subroutine enterbp(borp) does the following:
* (enter background or (ucp))
* + segment type (borp-'b' or 'u')
* + choose segment color
* + enter segment info in (pwb)
* + enter segment overlapping info
* in overlapping table
**************************************************************************
subroutine enterbp(borp)
common/table/tblitms(20,10),icolor(20),items(20)
common/num/numitms
integer ioneclr
character*1 items,borp
c
call pickclr(ioneclr)
numitms=numitms+1
icolor(numitms)=ioneclr
tblitms(numitms,7)=1.0
if(borp.eq.'b')then
items(numitms)='b'
tblitms(numitms,1)=10.0
tblitms(numitms,2)=0.0
tblitms(numitms,3)=0.0
tblitms(numitms,4)=10.0
tblitms(numitms,5)=10.0
else
items(numitms)='u'
do 20 i=1,5
tblitms(numitms,i)=0.0
20 continue
endif
call sbpovlp(borp,numitms)
return
end
**********************************************************************
*
* subroutine showbg does the following:
* (show background)
* + build background segment from (twb).
*
*********************************************************************
subroutine showbg
common/info/color,len,width,x1,y1,x2,y2,item
common/minfo/sorhitm
character*1 item
integer color
real x1,y1,x2,y2,len,width
c
call clr
call dfr(color,x1,y1,x2,y2)
return
end
*****************************************************************************
*
* subroutine showbp does the following:
* ( show a (ucp) )
* + build segment code in (df)
* + enter segment info in (pwb)
* + show segment on (AED) screen
*****************************************************************************
subroutine showbp
common/table/tblitms(20,10),icolor(20),items(20)
common/contr/icnt
common/space/ifree
common/num/numitms
character*1 items
real xbp,ybp
integer bpclr
c
bpclr=icolor(numitms)
tblitms(numitms,8)=icnt
call clr
call sec(bpclr)
write(0,10)
10 format(5x,'Need to move to an interior point')
call makemov(xbp,ybp)
call ifl
tblitms(numitms,9)=icnt-1
ifree=icnt
tblitms(numitms,2)=xbp
tblitms(numitms,3)=ybp
call sendcod(numitms)
return
end
****************************************************************************
*
* subroutine ispdone does the following:
* ( is polygon done with)
* + interactivly ask user if current (ucp)
* done with?
* - yes-->
* * enter (ucp) in (pwb)
* * show finished (ucp) on (AED) screen
* * set (ucp) flag off (ready for next
* (ucp))
* - no-->
* * continue drawing
* - otherwise-->
* * error- undefined answer try again
****************************************************************************
subroutine ispdone
common/poly/iflag,numpoly,ifivply(5)
character*1 ans
c
do 40 j=1,4
write(0,44)
44 format(5x,'Are you done with current polygon,answer:',
* /,5x,'y-yes , n-no')
read(5,48)ans
48 format(a1)
if(ans.eq.'y'.or.ans.eq.'Y')then
call usrpoly
call showbp
iflag=0
j=5
elseif(ans.eq.'n'.or.ans.eq.'N')then
j=5
else
call error(1)
endif
40 continue
return
end
**************************************************************************
*
* subroutine uppoly(polyno) does the following:
* ( update polygons common block)
* + This routine is called after user has
* issued a deletion command for (ucp)
* number (polyno)
* + search for (polyno)s entry in list of (ucp)s
* + delete entry and update list
* + decrement number of (ucp)s (numpoly)
***************************************************************************
subroutine uppoly(polyno)
integer polyno
common/poly/iflag,numpoly,ifivply(5)
common/llist/lnlist(5,2),lncontr
integer num1
c
call srchlst(polyno,pentry)
do 25 k=pentry+1,numpoly
lnlist(k,1)=lnlist(k,1)-1
ifivply(k)=ifivply(k)-1
25 continue
c
if(polyno.eq.1.and.numpoly.eq.1)then
num1=1
else
num1=numpoly-1
endif
c
do 45 i=pentry,num1
do 55 j=1,2
lnlist(i,j)=lnlist(i+1,j)
55 continue
ifivply(i)=ifivply(i+1)
45 continue
numpoly=numpoly-1
return
end
****************************************************************************
*
* subroutine srchlst(numply,ientry) does the following:
* ( search list of (ucp)s )
* + search for polygon number (numply)s
* entry in list of polygons
* + found?
* - yes-->
* * return value in (ientry)
* - no-->
* * return zero
****************************************************************************
subroutine srchlst(numply,ientry)
integer numply,ientry
common/llist/lnlist(5,2),lncontr
common/poly/iflag,numpoly,ifivply(5)
c
do 35 i=1,numpoly
if(lnlist(i,1).eq.numply)then
ientry=i
return
endif
35 continue
ientry=0
return
end
*****************************************************************************
*
* subroutine dfplyln(plynum) does the following:
* set(deletion flags of polygon lines).
* + This routine is called after user has
* issued a command to delete a (ucp) with
* number (plynum)
* + search for its entry in list of (ucp)
* + find how many line it have
* + access (pwb) to set their deletion flags
* back to ones to enable user to erase them
* if he/she chooses to.
*****************************************************************************
subroutine dfplyln(plynum)
integer plynum
common/table/tblitms(20,10),icolor(20),items(20)
common/llist/lnlist(5,2),lncontr
character*1 items
integer index,ibegin,iend,nolines
c
call srchlst(plynum,index)
c if(index.ne.0)then
nolines=lnlist(index,2)
ibegin=plynum-nolines
iend=plynum-1
do 27 i=ibegin,iend
tblitms(i,10)=1.0
27 continue
c endif
return
end
****************************************************************************
*
* subroutine delucp(number) does the following:
* ( delete (ucp) )
* + This routine is called after user has issued
* a deletion command for (ucp)s number (number)
* + display guiding messages to user to help him/
* her erasing the polygon correctly (because
* (ucp) are special cases)
* + erase (ucp)
* * restructure and display image properly
* (draw segment according to priorities)
* + update segment table
* + update (df)
* + update polygons common block
* + set its lines deletion flag back to ones
****************************************************************************
subroutine delucp(number)
integer number,entry
common lstovlp(380),jo
c
write(0,10)
10 format(5x,'The way to erase a user constructed polygon',/,
* 5x,'is to follow the construction procedure in reverse',/,
* 5x,'like this')
write(0,20)
20 format(5x,'The program will fill interior with background',
* /,5x,'color,then you need to erase the lines one by one')
call eraucp(number)
call issovlp(number)
call search(number,entry)
call dlentry(entry)
jo=jo-1
call sendsgs
call updf(number)
call upentry(number)
call uppoly(number)
call dfplyln(number)
return
end
**************************************************************************
*
* subroutine eraucp(numucp) does the following:
* (erase (ucp) )
* + erase (ucp)s number (numucp)
* + search for background color
* + rebuild segment code with background color
* + display erased (ucp) on (AED) screen
*************************************************************************
subroutine eraucp(numucp)
integer numucp
common/table/tblitms(20,10),icolor(20),items(20)
character*1 items
integer ibclr,itclr
c
itclr=icolor(numucp)
call srchtbl(ibclr)
icolor(numucp)=ibclr
call buldcod(numucp)
call sendcod(numucp)
icolor(numucp)=itclr
return
end
*****************************************************************************
*
* subroutine dlbkgd(ibgnum) does the following:
* (delete back ground segment)
* + segment number (ibgnum)
* + search if there is any outlined items
* in image
* - yes-->
* * error--cannot change color hollow polygons
* exist in image
* - no-->
* * erasing color is black
* * rebuild segment with new color
* * show black background on screen
* * update segment
* * update (df)
* * update segment table
* * update (ucp)s numbers
******************************************************************************
subroutine dlbkgd(ibgnum)
integer ibgnum
common/table/tblitms(20,10),icolor(20),items(20)
common/at/asegtbl(2,10),isgclr(2),seg(2)
common/info/color,len,width,x1,y1,x2,y2,item
common/num/numitms
common/contr/icnt
character*1 items,item,seg
integer color,ipbeg,ipend
real x1,y1,x2,y2,len,width
c
call tempinf(ibgnum)
color=0
icnt=tblitms(ibgnum,8)
call showbg
tblitms(ibgnum,9)=icnt-1
call sendcod(ibgnum)
call updf(ibgnum)
call upentry(ibgnum)
call cpnums(ibgnum)
c
c draw page boundary.
c
ipbeg=asegtbl(1,8)
ipend=asegtbl(1,9)
call intrprt(ipbeg,ipend)
c
c redraw image by sending one segment at a time.
c
do 20 i=1,numitms
call tempinf(i)
call sndscd(i)
20 continue
return
end
*******************************************************************************
*
* subroutine buldcod(elmnum) does the following:
* ( build segment code )
* + This routine handles special case segments
* segment background and segment (ucp) only.
* + segment number (elmnum)
* + build segment code in (df)
* + save its (df) begin and end position in (pwb)
*******************************************************************************
subroutine buldcod(elmnum)
integer elmnum
common/table/tblitms(20,10),icolor(20),items(20)
common/contr/icnt
real x,y
integer elmclr
character*1 items
c
elmclr=icolor(elmnum)
icnt=tblitms(elmnum,8)
x=tblitms(elmnum,2)
y=tblitms(elmnum,3)
call clr
call sec(elmclr)
call move(x,y)
call ifl
tblitms(elmnum,9)=icnt-1
return
end
*****************************************************************************
*
* subroutine sendcod(tbentry) does the following:
* ( send code )
* + segment number (tbentry)
* + special case:
* - segment page (boundary)
* * find its starting and endig position
* in (df) by accessing auxiliary table
* + general case:
* - any segment
* * find its starting and ending position
* in (df) by accessing segment table
* + interpret code on (AED) screen
*****************************************************************************
subroutine sendcod(tbentry)
integer tbentry
common/table/tblitms(20,10),icolor(20),items(20)
common/at/asegtbl(2,10),isgclr(2),seg(2)
character*1 items,seg
integer begpnt,endpnt
c
if(tbentry.eq.21)then
begpnt=asegtbl(1,8)
endpnt=asegtbl(1,9)
else
begpnt=tblitms(tbentry,8)
endpnt=tblitms(tbentry,9)
endif
call intrprt(begpnt,endpnt)
return
end
******************************************************************************
*
* subroutine sendsgs does the following:
* (send segments)
* + send all segments in the sorted list of
* overlapping segments (lstovlp)
* (segment will be displayed according
* to their priorities because list is
* sorted in ascending manner)
******************************************************************************
subroutine sendsgs
common lstovlp(380),jo
c
do 24 j=1,jo
if(lstovlp(j).eq.21)then
call sendcod(21)
else
call tempinf(lstovlp(j))
call sndscd(lstovlp(j))
endif
24 continue
return
end
******************************************************************************
*
* subroutine sndscd(oneseg) does the following:
* (send segment code)
* + segment number (oneseg)
* + erase segment (for better image)
* + spacial case:
* - (ucp)
* * build (ucp)
* + general case:
* - any segment
* * build segment code
* + display segment on (AED) screen
******************************************************************************
subroutine sndscd(oneseg)
integer oneseg
common/table/tblitms(20,10),icolor(20),items(20)
common/contr/icnt
character*1 items
c
if(items(oneseg).eq.'b')then
continue
elseif(items(oneseg).eq.'u')then
call eraucp(oneseg)
call buldcod(oneseg)
call sendcod(oneseg)
else
call eraitm(oneseg)
icnt=tblitms(oneseg,8)
call showitm
tblitms(oneseg,9)=icnt-1
call sendcod(oneseg)
endif
return
end
******************************************************************************
*
* subroutine sctable does the following:
* (set color table)
* + create 12 extra colors on top
* of the default (AED) color table
* + colors are:
* - grey
* - orange
* - light brown
* - brown
* - dark blue
* - violet
* - turqoise
* - dark green
* - (additional colors for demonstration purposes)
* (light green, sky blue, dirty blue, light orange,
* dark yellow, burgandy).
******************************************************************************
subroutine sctable
c
c
call sct(8,1,150,150,150)
call sct(9,1,250,100,0)
call sct(10,1,250,150,0)
call sct(11,1,200,100,0)
call sct(12,1,0,100,150)
call sct(13,1,180,0,250)
call sct(14,1,0,250,200)
call sct(15,1,90,150,0)
call sct(16,1,0,250,150)
call sct(17,1,0,200,250)
call sct(18,1,0,100,100)
call sct(19,1,250,150,0)
call sct(20,1,250,200,0)
call sct(21,1,200,50,200)
return
end
*****************************************************************************
*
* subroutine sct(iaddr,n,ir,ig,ib) does the following:
* (set up color look up table)
* + addr-is first location
* + n-is number of consecutive location to set up
* + ir-red color value
* + ig-green color value
* + ib-blue color value
*****************************************************************************
subroutine sct(iaddr,n,ir,ig,ib)
integer iaddr,n,ir,ig,ib,isctt
character*1 sctt
c
isctt=75
sctt=char(isctt)
call store(sctt)
call zaed(iaddr)
call zaed(n)
call zaed(ir)
call zaed(ig)
call zaed(ib)
return
end
******************************************************************************
*
* subroutine rstplst does the following:
* (reset polygons list)
* + (re) initialize (ucp) common block
******************************************************************************
subroutine rstplst
common/poly/iflag,numpoly,ifivply(5)
common/llist/lnlist(5,2),lncontr
c
do 65 i=1,5
do 55 j=1,2
lnlist(i,j)=0
55 continue
ifivply(i)=0
65 continue
iflag=0
numpoly=0
lncontr=0
return
end