Compucolor.org – Virtual Media

Listing of file='SUBS.FOR;0A' on disk='vmedia/fortrek-sector.ccvf'

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
	SUBROUTINE DSINFO(K)
	INTEGER D,GALAXY(8,8)
	BYTE K
	BYTE QUDRNT(8,8)
	BYTE U,V,X,Y
	BYTE STATUS,NBASES,NTORPS,NKLING
	BYTE BLK,RED,GRN,YEL,BLU,MGN,CYN,WHT
	BYTE CUR,CX,CY,SLASH,STATE(5,4)
	BYTE TOP(5)

	COMMON /MAP/GALAXY,U,V,QUDRNT,X,Y
	COMMON /INFO/STATUS,DATE,FINDAT,ENERGY,SHIELD,
     *	 NBASES,NTORPS
	COMMON /KLING/NKLING
	COMMON /COLORS/BLK,RED,GRN,YEL,BLU,MGN,CYN,WHT
	DATA CUR,SLASH/3,'/'/
	DATA STATE/18,'G','R','N',X'EF',
     *	           19,'Y','E','L',X'EF',
     *	           17,'R','E','D',X'EF',
     *	           22,'D','C','K',X'EF'/
	DATA TOP/8,18,14,25,X'EF'/

	CX = 3
	GOTO (100,200,300,400,500,600,700),K

  100	CALL OSTR(TOP)
	CALL CO(U+48)
	CALL CO(25)
	CALL CO(V+48)
	CALL CO(25)
	CALL CO(25)
	CALL CO(X+48)
	CALL CO(25)
	CALL CO(Y+48)
	CALL CO(15)
	RETURN

  200	CALL CURSOR(60,20)
	CALL OSTR(STATE(1,STATUS+1))
	RETURN

  300	CY = 3
	D = INT(DATE)
	WRITE(3,350)CUR,CX,CY,YEL,D
  350	FORMAT('+',4A1,I4)
	RETURN

  400	CY = 6
	D = INT(FINDAT-DATE)
	WRITE(3,350)CUR,CX,CY,YEL,D
	RETURN

  500	CX = 0
	CY = 9
	D = INT(ENERGY)
	WRITE(3,350)CUR,CX,CY,GRN,D
	CALL CO(YEL)
	CALL CO(SLASH)
	D = INT(SHIELD)
	CX = 5
	WRITE(3,350)CUR,CX,CY,CYN,D
	RETURN

  600	CY = 12
	WRITE(3,350)CUR,CX,CY,GRN,NTORPS
	RETURN

  700	CY = 15
	WRITE(3,350)CUR,CX,CY,RED,NKLING
	RETURN

	END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
	SUBROUTINE DSPDEV(I)
	BYTE I,DEV(9),D
	BYTE BLK,RED,GRN,YEL,BLU,MGN,CYN,WHT

	COMMON /STAT/DEV
	COMMON /COLORS/BLK,RED,GRN,YEL,BLU,MGN,CYN,WHT

	CALL CURSOR(61,23+I)
	IF(DEV(I).LT.0) GOTO 100
	   CALL CO(GRN)
	   CALL CO('U')
	   CALL CO('P')
	   RETURN
  100	IF(DEV(6).GE.0) GOTO 200
	   CALL CO(RED)
	   CALL CO('D')
	   CALL CO('N')
	   RETURN
  200	IF(DEV(I).LT.-1) GOTO 300
	   CALL CO(YEL)
	   CALL CO('D')
	   CALL CO('N')
	   RETURN
  300	CALL CO(RED)
	CALL CO('D')
	CALL CO('N')
	D = IABS(DEV(I))+48
	CALL CO(D)
	RETURN
	END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
	SUBROUTINE INSERT(Z,P,Q)
	INTEGER GALAXY(8,8)
	BYTE QUDRNT(8,8)
	BYTE Z,P,Q,U,V,X,Y
	BYTE RAN
	COMMON /MAP/GALAXY,U,V,QUDRNT,X,Y

   10	P = RAN(8.0)
	Q = RAN(8.0)
	IF(QUDRNT(P,Q).NE.0) GOTO 10
	QUDRNT(P,Q) = Z
	RETURN
	END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
	SUBROUTINE LRPLOT(P,Q)
	INTEGER GALAXY(8,8)
	BYTE P,Q,U,V
	BYTE NK,NB,NS
	BYTE DIGITS(10),C
	BYTE BLK,RED,GRN,YEL
	COMMON /MAP/GALAXY,U,V
	COMMON /COLORS/BLK,RED,GRN,YEL

	DATA DIGITS/' ','1','2','3','4','5','6','7','8','9'/

	CALL CURSOR(37+Q+Q+Q,1+P+P)
	CALL SPLIT(GALAXY(P,Q),NK,NB,NS)
	IF(P.EQ.U.AND.Q.EQ.V) CALL CO(31)
	C = YEL+NB
	CALL CO(RED)
	CALL CO(DIGITS(NK+1))
	CALL CO(C)
	CALL CO(DIGITS(NS+1))
	IF(P.EQ.U.AND.Q.EQ.V) CALL CO(15)
	RETURN
	END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
	SUBROUTINE LRSCAN
	INTEGER GALAXY(8,8)
	BYTE P,Q,U,V
	BYTE UM,UP,VM,VP
	BYTE DEV(9)
	LOGICAL OUTSID
	COMMON /MAP/GALAXY,U,V
	COMMON /STAT/DEV

	IF(DEV(3).LT.0) RETURN
	UM = U-1
	UP = U+1
	VM = V-1
	VP = V+1
	DO 100 P=UM,UP
	   DO 100 Q=VM,VP
	      IF(OUTSID(P,Q)) GOTO 100
	      CALL LRPLOT(P,Q)
  100	CONTINUE
	RETURN

	END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
	SUBROUTINE NEWMAP
	REAL KLGEGY(9)
	INTEGER GALAXY(8,8)
	BYTE QUDRNT(8,8)
	BYTE I,J,P,Q,U,V,X,Y,Z
	BYTE NK,NB,NS
	BYTE NKLING,KX(9),KY(9)
	BYTE RAN
	COMMON /MAP/GALAXY,U,V,QUDRNT,X,Y
	COMMON /KLING/NKLING,KLGEGY,KX,KY

	DO 100 I=1,8
	   DO 100 J=1,8
  100	      QUDRNT(I,J) = 0
	CALL SPLIT(GALAXY(U,V),NK,NB,NS)
	QUDRNT(X,Y) = 2
	Z = 1
	DO 200 I=1,NS
  200	   CALL INSERT(Z,P,Q)
	IF(NB.NE.0) CALL INSERT(4,P,Q)
	DO 300 I=1,9
	   KX(I) = 0
	   KY(I) = 0
  300	   KLGEGY(I) = 0.0
	Z = 3
	IF(NK.LT.1) RETURN
	DO 400 I=1,NK
	   CALL INSERT(Z,P,Q)
	   KX(I) = P
	   KY(I) = Q
  400	   KLGEGY(I) = 100.0+RAN(200.0)
	CALL SRSCAN
	RETURN
	END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
	LOGICAL FUNCTION OUTSID(X,Y)
	BYTE X,Y

	OUTSID = (X.LT.1).OR.(X.GT.8).OR.(Y.LT.1).OR.(Y.GT.8)
	RETURN
	END


	BYTE FUNCTION RAN(F)
	RAN = INT(F*RND(1.0)+1.0)
	END


	SUBROUTINE SPLIT(Z,NK,NB,NS)
	INTEGER Z
	BYTE NK,NB,NS

	NK = Z/100
	NB = (Z-NK*100)/10
	NS = Z-100*NK-10*NB
	RETURN

	END


	SUBROUTINE SCLCLR(LINE,MAX)
	BYTE LINE,MAX,SPACE
	BYTE X,Y,HEIGHT,WIDTH
	DATA SPACE/' '/
	DATA X,Y,HEIGHT,WIDTH/0,21,11,40/

	LINE = LINE+1
	IF(LINE.LE.MAX) GOTO 10
	LINE = MAX
	CALL SCROLL(X,Y,HEIGHT,WIDTH,.TRUE.)
   10	CALL CURSOR(0,LINE)
	WRITE(3,20)(SPACE,I=1,40)
   20	FORMAT('+',40A1)
	CALL CURSOR(0,LINE)
	RETURN
	END


	SUBROUTINE SRPLOT(K,P,Q)
	BYTE K,P,Q
	BYTE SYMBOL(4,7)

	DATA SYMBOL/18,' ',' ',X'EF',
     *	            19,' ','*',X'EF',
     *	            22,']','O',X'EF',
     *	            17,'>','-',X'EF',
     *              20,'#','#',X'EF',
     *              17,'*','*',X'EF',
     *              23,'*','*',X'EF'/

	CALL CURSOR(8+Q+Q+Q,1+P+P)
	CALL OSTR(SYMBOL(1,K+1))
	RETURN
	END


	SUBROUTINE SRSCAN
	INTEGER GALAXY(8,8)
	BYTE QUDRNT(8,8)
	BYTE DEV(9)
	BYTE I,J,K,U,V,X,Y
	LOGICAL DOWN
	COMMON /MAP/GALAXY,U,V,QUDRNT,X,Y
	COMMON /STAT/DEV
	DATA DOWN/.FALSE./

	IF(DOWN.AND.(DEV(2).LT.0)) GOTO 500
	DOWN = .FALSE.
	DO 200 I=1,8
	   DO 100 J=1,8
	      K = QUDRNT(I,J)
	      IF(DEV(2).GE.0) GOTO 50
	         DOWN = .TRUE.
	         K = 7
   50	      CALL SRPLOT(K,I,J)
  100	   CONTINUE
  200	CONTINUE
	RETURN
  500	CALL SRPLOT(2,X,Y)
	RETURN
	END