Listing of file='SUBS.FOR;09' 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)
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