DataMuseum.dk

top - metrics - download

    Length: 10087 (0x2767)
    Types: TextFile
    Names: »subsg.f«

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

TextFile

************************************************************************
*
* subroutine snpage does the following:
* (save new page)
*     + inquire about number of already 
*       saved pages.
*     + is the limit on the number of 
*       saved page have been used?
*      - yes-->
*        * display an (ATTENTION) message
*          (comming pages will replace 
*           previous ones)
*        * ask user to specify the number
*          of the page that will be replaced
*        * replace page by current page
*      - no-->
*        * save page as a new page
*
************************************************************************
	subroutine snpage 
	common/pnum/numspg
	integer pagno
c
	call howmpg
	if(numspg.eq.5)then
	  write(0,10)
10	  format(5x,'ATTENTION: You have five saved images,following',
     *    /,15x,'images will replace one of the preivous images,',/,15x,
     *    'specify page number >= 1 and <= 5')
	  call whichp(pagno)
	  call replac(pagno)
	elseif(numspg.ge.0)then
	  call openfl
	else
	  continue
	endif
	return
	end
***************************************************************************
*
* subroutine replac(pagnum) does the following:
* (replace)
*     + page number (pagnum)
*     + inquire about the units & files that 
*       pagnum is saved on
*     + open thoes files and have them ready
*       for writing
*     + save new page
*     + close units
*
**************************************************************************
	subroutine replac(pagnum)
	common/pnum/numspg
	integer u1,u2,pagnum
	character*6 f1,f2
c
	call whichu(pagnum,u1,u2)
	call whichf(pagnum,f1,f2)
	call oif(u1,u2,f1,f2)
	call savjpg(u1)
	call savinf(u2)
	call fclose(pagnum)
	return
	end
************************************************************************
*
* subroutine openfl does the following:
* (open files)
*      + open files and save new image
*      + increment number of saved pages
*        (numspg)
*      + inquire about units & files and
*        have them ready for writing
*      + save image
*
***********************************************************************
	subroutine openfl
	common/pnum/numspg
	integer u1,u2
	character*6 f1,f2
c
	numspg=numspg+1
	call whichu(numspg,u1,u2)
	call whichf(numspg,f1,f2)
	open(unit=u1,file=f1,status="new",access="sequential",
     *       form="unformatted")
	rewind(u1)
	call savjpg(u1)
	open(unit=u2,file=f2,status="new",access="sequential",
     *       form="formatted")
	rewind(u2)
	call savinf(u2)
	call fclose(numspg)
	return
	end
************************************************************************
*
* subroutine savjpg(unita) does the following:
*  (save jpage (df))
*       + save (df) content (jpage) on (unita)
*       + set (df) counter (icnt) to end of (df)
*       + save (df) counters (icnt) and (ifree)
*       + unload (df) content (jpage) into (unita)
*
************************************************************************
	subroutine savjpg(unita)
	integer unita
	common/contr/icnt
	common/page/jpage(6000)
	common/space/ifree
	common/table/tblitms(20,10),icolor(20),items(20)
	common/num/numitms
	character*1 jpage,items
c
	icnt=tblitms(numitms,9)
	ifree=tblitms(numitms,9)+1
	icnt=ifree
	write(unita)icnt,ifree
	do 30 i=1,icnt-1
	write(unita)jpage(i)
30	continue
	return
	end
***************************************************************************
*
* subroutine savinf(unitb) does the following:
* (save information)
*     + save image information on (unitb)
*     + save auxiliary table
*     + save segment table
*     + save overlapping table
*     + save (ucp)s common block
*
***************************************************************************
	subroutine savinf(unitb)
	integer unitb
c
	call savat(unitb)
	call savst(unitb)
	call savol(unitb)
	call savup(unitb)
	return
	end
*****************************************************************************
*
* subroutine savat(unitbb) does the following:
* (save auxiliary table)
*      + save auiliary table on (unitbb)
*
****************************************************************************
	subroutine savat(unitbb)
	integer unitbb
	common/at/asegtbl(2,10),isgclr(2),seg(2)
	character*1 seg
c
	do 20 i=1,2
	   do 30 j=1,10
	      write(unitbb,1)asegtbl(i,j)
1	      format(1x,F7.2)
30	   continue
	   write(unitbb,2)isgclr(i)
2	   format(1x,I2)
	   write(unitbb,3)seg(i)
3	   format(1x,a1)
20	continue
	return
	end
*****************************************************************************
*
* subroutine savst(unitbb) does the following:
* (save segment table)
*     + save image segment table on (unitbb)
*     + save number of items (numitms)
*     + save segment table content
*
*****************************************************************************
	subroutine savst(unitbb)
	integer unitbb
	common/num/numitms
	common/table/tblitms(20,10),icolor(20),items(20)
	character*1 items
c
	write(unitbb,1)numitms
1	format(1x,I2)
	do 20 i=1,20
	  do 30 j=1,10
	     write(unitbb,2)tblitms(i,j)
2	     format(1x,F7.2)
30	  continue
	  write(unitbb,3)icolor(i)
3	  format(1x,I2)
	  write(unitbb,4)items(i)
4	  format(1x,a1)
20	continue
	return
	end
****************************************************************************
*
* subroutine savol(unitbb) does the following:
* (save overlapping table)
*     + save segment overlapping table on (unitbb)
*
****************************************************************************
	subroutine savol(unitbb)
	integer unitbb
	common/ovlap/iovlap(21,21)
c
	do 20 i=1,21
	  do 30 j=1,21
	     write(unitbb,1)iovlap(i,j)
1	     format(1x,I1)
30        continue
20	continue
	return
	end
******************************************************************************
*
* subroutine savup(unitbb) does the following:
*  (save (ucp)s common block)
*       + save (ucp)s common block on (unitbb)
*
******************************************************************************
	subroutine savup(unitbb)
	integer unitbb
	common/poly/iflag,numpoly,ifivply(5)
	common/llist/lnlist(5,2),lncontr
c
	write(unitbb,1)numpoly
1	format(1x,I1)
	do 20 i=1,5
	   write(unitbb,2)ifivply(i)
2	   format(1x,I2)
20	continue
c
	do 30 i=1,5
	  do 40 j=1,2
	     write(unitbb,3)lnlist(i,j)
3	     format(1x,I2)
40	  continue
30	continue
	return
	end
******************************************************************************
*
* subroutine rdjpg(unita) does the following:
*  (read jpage (df))
*      + read (df) content into (jpage) from
*        (unita)
*      + position file at its initial position
*        (ready for reading first record)
*      + read (df) counters (icnt) and (ifree)
*      + read (df) content into (jpage) 
*
******************************************************************************
	subroutine rdjpg(unita)
	integer unita
	common/contr/icnt
	common/space/ifree
	common/page/jpage(6000)
	character*1 jpage
c
	rewind (unita)
	read(unita)icnt,ifree
	do 30 i=1,icnt-1
	   read(unita)jpage(i)
30	continue
	return
	end
*****************************************************************************
*
* subroutine rdinf(unitb) does the following:
*  (read information)
*      + read image information from (unitb)
*      + position file at its initial point
*      + read auxiliary table
*      + read segment table
*      + read overlapping table
*      + read (ucp)s common block
*
*****************************************************************************
	subroutine rdinf(unitb)
	integer unitb
c
	rewind (unitb)
	call readat(unitb)
	call readst(unitb)
	call readol(unitb)
	call readup(unitb)
	return
	end
*****************************************************************************
*
* subroutine readat(unitbb) does the following:
* (read auxiliary table)
*     + read auxiliary table content from (unitbb)
*
****************************************************************************
	subroutine readat(unitbb)
	integer unitbb
	common/at/asegtbl(2,10),isgclr(2),seg(2)
	character*1 seg
c
	do 20 i=1,2
	   do 30 j=1,10
	      read(unitbb,1)asegtbl(i,j)
1             format(1x,F7.2)
30	   continue
	   read(unitbb,2)isgclr(i)
2	   format(1x,I2)
	   read(unitbb,3)seg(i)
3	   format(1x,a1)
20 	continue
	return
	end
*******************************************************************************
*
* subroutine readst(unitbb) does the following:
*  (read segment table)
*     + read iamge segment table from (unitbb)
*     + read number of image items (numitms)
*     + read segment table content
*
******************************************************************************** 
	subroutine readst(unitbb)
	integer unitbb
	common/num/numitms
	common/table/tblitms(20,10),icolor(20),items(20)
	character*1 items
c
	read(unitbb,1)numitms
1	format(1x,I2)
	  do 20 i=1,20
	    do 30 j=1,10
	       read(unitbb,2)tblitms(i,j)
2	       format(1x,F7.2)
30	    continue
	    read(unitbb,3)icolor(i)
3	    format(1x,I2)
	    read(unitbb,4)items(i)
4	    format(1x,a1)
20	  continue
	return
	end
*****************************************************************************
*
* subroutine readol(unitbb) does the following:
* (read overlapping table)
*     + read segment overlapping table from (unitbb)
*
****************************************************************************
	subroutine readol(unitbb)
	integer unitbb
	common/ovlap/iovlap(21,21)
c
	do 20 i=1,21
	  do 30 j=1,21
	     read(unitbb,1)iovlap(i,j)
1	     format(1x,I1)
30	  continue
20	continue
	return
	end
**************************************************************************
*
* subroutine readup(unitbb) does the following:
*  (read (ucp)s common block)
*      + read image (ucp)s common block from (unitbb)
*
**************************************************************************
	subroutine readup(unitbb)
	integer unitbb
	common/poly/iflag,numpoly,ifivply(5)
	common/llist/lnlist(5,2),lncontr
c
	iflag=0
	read(unitbb,1)numpoly
1 	format(1x,I1)
	 do 20 i=1,5
	    read(unitbb,2)ifivply(i)
2	    format(1x,I2)
20	 continue
c
	do 30 i=1,5
	  do 40 j=1,2
	     read(unitbb,3)lnlist(i,j)
3	     format(1x,I2)
40	  continue
30	continue
	return
	end