DataMuseum.dk

top - metrics - download

    Length: 3273 (0xcc9)
    Types: TextFile
    Names: »sector.f.orig«

└─⟦b20c6495f⟧ Bits:30007238 EUUGD18: Wien-båndet, efterår 1987
    └─⟦this⟧ »EUUGD18/General/Empire/sector.f.orig« 

TextFile

	subroutine sector ( amap )
c
c	This subroutine display sector jector from map ii
c	if isec=jector, map will not be displayed again
c
	IMPLICIT INTEGER(A-Z)

	include 'common.h'
C
	character amap ( 6000 )

	width = cols - 10
	height = lines - 4

20	if ( jector .eq. -1 ) goto 200
	if ( mode .ne. 1 ) return
	if ( contained(isec, jector) .eq. 1) return
	if ( isec .ne. jector ) goto 100
	if ( newrnd .eq. 1 ) goto 1300
	return
100	isec=jector
	goto 300
200	call topmsg ( 1, 'Sector? ' )
	jector=iphase(getchx())
	if ((jector.lt.0).or.(jector.gt.9)) goto 200
	isec=jector
	jector=-1
comment	let main know that updating sector isn't used
300	continue
	call cflush
	call delay ( 45 )
comment	delay before zapping old sector

	call clear
	call topini
	line=kline(ki,isec)
	linefi=line+ 100 * height
comment	linefi=line after last line of sector
	linec=line-100
comment	get set for line 400
400	linec=linec+100
comment	goto next line
	if (linec.ge.linefi) goto 1000
comment	check for end of sector
	kstart = ki + 1
comment	if line is broken, kstart will be modified
500	do 600 j=kstart,ki+width
comment	ki itself is not in sector
	ab = amap ( j + linec )
comment	get character
600	if (ab.ne.' ') goto 700
comment	find first non-blank spot
	goto 400
comment	no characters in this line
700	kinit = j
comment	ab is already calculated
	g2(j)=ab
comment	avoids repitition
	do 800 j=kinit+1,ki+width
comment	look for blank character
	ab=amap(j+linec)
comment	get character
	if (ab.eq.' ') goto 900
comment	exit loop if blank
800	g2(j)=ab
comment	put char. string in an array
900	kfinal=j-1
comment	set end  of char. string
	call cursor(kinit-line+linec-ki+300)
comment	position cursor
c	encode (kfinal-kinit+2,999,jnkbuf)(g2(j),j=kinit,kfinal),0
c999	format(<kfinal-kinit+2>a1)
	call encpri (g2, kinit, kfinal)
	if (kfinal.ge.ki+width) goto 400
comment	next line
	kstart = kfinal + 1
comment	look at rest of line
	goto 500
1000	kursor = (lines - 1) * 100
c
c	Print x coordinates
c
	do 1100 i = ki, ki + width, 10
	call tpos ( lines, i - ki + 1 )
	ptr = 0
	call addint ( i, jnkbuf, ptr )
	jnkbuf ( ptr + 1 ) = '\0'
	call strout ( jnkbuf )
1100	continue
c
c	Print y coordinates
c
	xkursor = cols - 8
	ykursor = 4
	max = line / 100 + height - 1
1110	do 1200 i=line/100,max,2
c	call cursor ( kursor )
	call tpos ( ykursor + i - line / 100, xkursor + 1 )
	ptr = 0
	call addint ( i, jnkbuf, ptr )
	jnkbuf ( ptr + 1 ) = '\0'
	call strout ( jnkbuf )
c	kursor=kursor+200
1200	continue
	call cflush

cc	do 1314 ptr = 1, 3
cc	jnkbuf ( ptr ) = ' '
cc1314	continue
cc	ptr = 1
cc	call addint ( mdate, jnkbuf, ptr )
comment	date in jnkbuf

	call strpos (  5, cols - 2, 'S' )
	call strpos (  6, cols - 2, 'e' )
	call strpos (  7, cols - 2, 'c' )
	call strpos (  8, cols - 2, 't' )
	call strpos (  9, cols - 2, 'o' )
	call strpos ( 10, cols - 2, 'r' )

	call bufpos ( 12, cols - 2, char(isec + 48), 1 )

	call strpos ( 14, cols - 2, 'R' )
	call strpos ( 15, cols - 2, 'o' )
	call strpos ( 16, cols - 2, 'u' )
	call strpos ( 17, cols - 2, 'n' )
	call strpos ( 18, cols - 2, 'd' )

cc	call bufpos ( 20, cols - 2, jnkbuf ( 1 ), 1 )
cc	call bufpos ( 21, cols - 2, jnkbuf ( 2 ), 1 )
cc	call bufpos ( 22, cols - 2, jnkbuf ( 3 ), 1 )
	call round ( mdate )
	call cflush

1300	continue
	newrnd = 0
	return
	end