edjames@ic.Berkeley.EDU (Ed James) (12/21/86)
BYTE COMM(30),PHAZE(8)
BYTE IFILE(11),KILL
BYTE COMMAN(20),OKA(5),OKB(5),OKC(5)
BYTE TTY(20)
BYTE MOVEDFLAG(1500)
BYTE J1TS(1600)
BYTE EMAP(6000),RMAP(6000),PMAP(6000),OMAP(6000)
BYTE PAMELA(8),REEED(9)
byte jnkbuf ( 80 )
INTEGER RLMAP(3000)
LOGICAL AUTOMV
COMMON/AB9/AB9,PRIOR,NSHPRF
COMMON/ARMTOT/ARMTOT
COMMON/CHRT/COMMAN,COMM,COMSCN,KBTBL
COMMON/CHR2/IFILE,KILL,TTY
COMMON/CITY/FOUND(70),OWNER(70),PHASE(70)
COMMON/CMYTBL/CMYTBL,KBFUDG
COMMON/COD/CODER
COMMON/CODE/CODEFU,CODELA
COMMON/CRAHL/HITS,TIPE,CRAHIT,CRALOC
COMMON/FIPATH/FIPATH(70)
COMMON/G2/G2
COMMON/IARROW/IARROW(10),ARROW,INDEX,LOPMAX
COMMON/IOTAB/IOTAB
COMMON/J1TS/J1TS
COMMON/KXK/IADJST
COMMON/MAP/D
COMMON/MAPBLK/EMAP,RMAP,PMAP,RLMAP
COMMON/OMAP/OMAP
COMMON/MISC1/TARGET,AR2S,RANGE,RANG
COMMON/MISC2/LOCI(10,11),NUMBER(18),LIMIT,MDATE,VERSION
COMMON/MODE/MODE,JECTOR,ISEC,NEWRND
COMMON/MFLAGS/MOVEDFLAG
COMMON/MYCOD/D2,MYCODE
COMMON/OKS/OKA,OKB,OKC
COMMON/OVRPOP/OVRPOP
COMMON/P1/PHAZE,PHAZEE,PH
COMMON/DAYTIM/PAMELA,REEED
COMMON/PASS/PASS,SPECAL,AUTOMV
COMMON/SAVBUF/SAVBUF
COMMON/SPS/STEP,POSIT,START
COMMON/TEST2/SUCCES,FAILUR,FULL
COMMON/TROOP/TROOPT(6,5)
COMMON/X/X(70)
common /jnkbuf/ jnkbuf, ptr
C
C AGGR: THIS IS A MEASURE OF THE ENEMY SHIPS AGGRESSIVENESS,
C THIS VALUE IS ADDED TO THE COST-EFFECTIVENESS OF ATTACKING AN
C ENEMY UNIT TO DETERMINE IF THE SHIP WILL ATTACK OR RUN FROM THE
C ENEMY.
C ALL CITIES ARE REFERENCED BY CITY NUMBER, AS IN X(N)=LOC OF CITY #N
C CODFU/CODELA: CONTAINS A NUMBER THAT DETERMINES WHAT THAT COMPUTER CRAFT
C IS ASSIGNED TO DO, IS SEPERATED INTO 2 NUMBERS, IFO AND ILA. IFO
C GIVES THE FUNCTION, ILA GIVES DETAILS.
C CODER: USED FOR DEBUG FLAG
C CROWD: USED IF CITY IS SURROUNDED BY ARMIES
C D: ORIGINAL MAP, ENCODED IN MOD 3
C EXPLOR: THIS IS SET TO 1 IF THE ENEMY SHIP IS TO EXPLORE UNKNOWN
C TERRITORY ADJACENT TO IT, 0 IF NOT.
C FIPATH: STASIS # TO BE GIVEN TO FIGHTER IN THAT CITY
C FOUND: COMPLETION DATES FOR CITIES
C IADJST: SUBTRACTED FROM Z6 SO CURSOR WILL NOT BE MOVED OFF SCREEN
C IARROW: ADDED TO Z6 SO MOVES [1,2,3,4,5,6,7,8,9] ARE CONVERTED
C TO [+1,-99,-100,-101,ETC.]
C ISEC: SECTOR TERMINAL IS SHOWING
C IZAP: .TRUE.=SAVE GAME, .FALSE.=INITIALIZE
C JECTOR: SECTOR PROGRAM IS LOOKING AT
C KURSOR: SET TO POSITION OF CURSOR
C MODE: 1=IN MODE 2, 0=IN MODE 1
C OWNER: WHO OWNS THE CITY: 0>NOBODY, 1>PLAYER, 2>COMPUTER
C PASS: SET TO .TRUE. IF IT IS A PRIVILEGED USER
C PHASE: PHASE OF CITY
C X: LOCATIONS OF CITIES
C
ibefor = -100
do 100 i = 1, 9
i1 = z6 + arrow ( i )
ab = rmap ( i1 )
if ( ab .eq. pmap ( i1 )) goto 100
pmap ( i1 ) = ab
if ( jector .eq. -1 ) goto 100
if ( isec .eq. -1 ) goto 100
line = kline ( ki, isec )
iy = ( i1 - 1 ) / 100 * 100
ix = i1 - iy
if (( iy .lt. line ) .or. ( iy .gt. line + 1900 ) .or.
* ( ix .le. ki ) .or. (ix .gt. ki + 70 )) goto 100
i1 = i1 - line - ki
if ( ibefor + 1 .ne. i1 ) call cursor ( i1 + 300 )
ibefor = i1
call putc ( ab )
100 continue
call flush
return
end
FUNCTION SET(XPOS,YPOS,AREA,LS,LIMIT)
IMPLICIT INTEGER(A-Z)
PARAMETER WIDTH=100,HEIGHT=60
BYTE MAP(WIDTH,HEIGHT)
BYTE OWNER(WIDTH,HEIGHT)
BYTE XSTACK(12000)
BYTE YSTACK(12000)
BYTE CSTACK(12000)
BYTE LS
INTEGER XADDS(8),YADDS(8)
DATA XADDS/-1,0,1,-1,1,-1,0,1/
DATA YADDS/-1,-1,-1,0,0,1,1,1/
BYTE EMAP(6000),RMAP(6000),PMAP(6000),OMAP(6000)
INTEGER RLMAP(3000)
COMMON/MAPBLK/EMAP,RMAP,PMAP,RLMAP
COMMON/OMAP/OMAP
EQUIVALENCE (MAP(1,1),OMAP(1)),(OWNER(1,1),RMAP(1))
OWNER(XPOS,YPOS)=AREA
LEVEL=1
X=XPOS
Y=YPOS
100 K=1
200 IF ((X+XADDS(K).LT.2).OR.(X+XADDS(K).GT.99)) GOTO 300
IF ((Y+YADDS(K).LT.2).OR.(Y+YADDS(K).GT.59)) GOTO 300
IF (MAP(X+XADDS(K),Y+YADDS(K)).NE.LS) GOTO 300
IF (OWNER(X+XADDS(K),Y+YADDS(K)).NE.0) GOTO 300
OWNER(X+XADDS(K),Y+YADDS(K))=AREA
XSTACK(LEVEL)=X
YSTACK(LEVEL)=Y
CSTACK(LEVEL)=K
LEVEL=LEVEL+1
IF (LEVEL.GT.LIMIT) THEN
SET=0
RETURN
ENDIF
X=X+XADDS(K)
Y=Y+YADDS(K)
GOTO 100
300 K=K+1
IF (K.LE.8) GOTO 200
LEVEL=LEVEL-1
IF (LEVEL.EQ.0) THEN
SET=1
RETURN
ENDIF
X=XSTACK(LEVEL)
Y=YSTACK(LEVEL)
K=CSTACK(LEVEL)
GOTO 300
END
ccc shipmv - this subroutine handles player's ship moves
subroutine shipmv ( acraloc, acrahit, num, own1, hitmax )
c
c synopsis
c
IMPLICIT INTEGER(A-Z)
PARAMETER IAR=0,IFI=500,IDE=700,ISU=900,ITT=1100,
1 ICR=1200,ICA=1300,IBA=1400
PARAMETER IAR2=1500,IFI2=2000,IDE2=2200,ISU2=2400,ITT2=2600,
1 ICR2=2700,ICA2=2800,IBA2=2900
PARAMETER IDEH=0,ISUH=200,ITTH=400,ICRH=500,ICAH=600,IBAH=700
PARAMETER IDE2H=800,ISU2H=1000,ITT2H=1200,ICR2H=1300,
1 ICA2H=1400,IBA2H=1500
INTEGER G2(100)
INTEGER HITS(15),TIPE(15),CRAHIT(15),CRALOC(15)
INTEGER INDEX(15)
INTEGER CMYTBL(9),KBFUDG(9)
INTEGER LOPMAX(15),COMSCN(40)
INTEGER NSHPRF(4,6)
INTEGER PH(8),OVRPOP(16,2)
INTEGER PRIOR(7)
INTEGER RANGE(200),AR2S(500)
INTEGER ARMTOT(20),CODEFU(1500),CODELA(1500),TARGET(70),LIMIT(16)
INTEGER ARROW(9)
INTEGER D2(3)
INTEGER*2 D(667)
INTEGER MYCODE(1500)
INTEGER RANG(200)
INTEGER IOTAB(16)
INTEGER PHAZEE(8)
integer ptr
BYTE SPECAL,PASS
BYTE AB,AC,AD,AO,E,OWN1,OWN2,OWN !AVOID WORD REFERENCES TO THESE
BYTE KBTBL(9),AB9(9)
BYTE COMM(30),PHAZE(8)
BYTE IFILE(11),KILL
BYTE COMMAN(20),OKA(5),OKB(5),OKC(5)
BYTE TTY(20)
BYTE MOVEDFLAG(1500)
BYTE J1TS(1600)
BYTE EMAP(6000),RMAP(6000),PMAP(6000),OMAP(6000)
BYTE PAMELA(8),REEED(9)
byte jnkbuf ( 80 )
INTEGER RLMAP(3000)
LOGICAL AUTOMV
COMMON/AB9/AB9,PRIOR,NSHPRF
COMMON/ARMTOT/ARMTOT
COMMON/CHRT/COMMAN,COMM,COMSCN,KBTBL
COMMON/CHR2/IFILE,KILL,TTY
COMMON/CITY/FOUND(70),OWNER(70),PHASE(70)
COMMON/CMYTBL/CMYTBL,KBFUDG
COMMON/COD/CODER
COMMON/CODE/CODEFU,CODELA
COMMON/CRAHL/HITS,TIPE,CRAHIT,CRALOC
COMMON/FIPATH/FIPATH(70)
COMMON/G2/G2
COMMON/IARROW/IARROW(10),ARROW,INDEX,LOPMAX
COMMON/IOTAB/IOTAB
COMMON/J1TS/J1TS
COMMON/KXK/IADJST
COMMON/MAP/D
COMMON/MAPBLK/EMAP,RMAP,PMAP,RLMAP
COMMON/OMAP/OMAP
COMMON/MISC1/TARGET,AR2S,RANGE,RANG
COMMON/MISC2/LOCI(10,11),NUMBER(18),LIMIT,MDATE,VERSION
COMMON/MODE/MODE,JECTOR,ISEC,NEWRND
COMMON/MFLAGS/MOVEDFLAG
COMMON/MYCOD/D2,MYCODE
COMMON/OKS/OKA,OKB,OKC
COMMON/OVRPOP/OVRPOP
COMMON/P1/PHAZE,PHAZEE,PH
COMMON/DAYTIM/PAMELA,REEED
COMMON/PASS/PASS,SPECAL,AUTOMV
COMMON/SAVBUF/SAVBUF
COMMON/SPS/STEP,POSIT,START
COMMON/TEST2/SUCCES,FAILUR,FULL
COMMON/TROOP/TROOPT(6,5)
COMMON/X/X(70)
common /jnkbuf/ jnkbuf, ptr
C
C AGGR: THIS IS A MEASURE OF THE ENEMY SHIPS AGGRESSIVENESS,
C THIS VALUE IS ADDED TO THE COST-EFFECTIVENESS OF ATTACKING AN
C ENEMY UNIT TO DETERMINE IF THE SHIP WILL ATTACK OR RUN FROM THE
C ENEMY.
C ALL CITIES ARE REFERENCED BY CITY NUMBER, AS IN X(N)=LOC OF CITY #N
C CODFU/CODELA: CONTAINS A NUMBER THAT DETERMINES WHAT THAT COMPUTER CRAFT
C IS ASSIGNED TO DO, IS SEPERATED INTO 2 NUMBERS, IFO AND ILA. IFO
C GIVES THE FUNCTION, ILA GIVES DETAILS.
C CODER: USED FOR DEBUG FLAG
C CROWD: USED IF CITY IS SURROUNDED BY ARMIES
C D: ORIGINAL MAP, ENCODED IN MOD 3
C EXPLOR: THIS IS SET TO 1 IF THE ENEMY SHIP IS TO EXPLORE UNKNOWN
C TERRITORY ADJACENT TO IT, 0 IF NOT.
C FIPATH: STASIS # TO BE GIVEN TO FIGHTER IN THAT CITY
C FOUND: COMPLETION DATES FOR CITIES
C IADJST: SUBTRACTED FROM Z6 SO CURSOR WILL NOT BE MOVED OFF SCREEN
C IARROW: ADDED TO Z6 SO MOVES [1,2,3,4,5,6,7,8,9] ARE CONVERTED
C TO [+1,-99,-100,-101,ETC.]
C ISEC: SECTOR TERMINAL IS SHOWING
C IZAP: .TRUE.=SAVE GAME, .FALSE.=INITIALIZE
C JECTOR: SECTOR PROGRAM IS LOOKING AT
C KURSOR: SET TO POSITION OF CURSOR
C MODE: 1=IN MODE 2, 0=IN MODE 1
C OWNER: WHO OWNS THE CITY: 0>NOBODY, 1>PLAYER, 2>COMPUTER
C PASS: SET TO .TRUE. IF IT IS A PRIVILEGED USER
C PHASE: PHASE OF CITY
C X: LOCATIONS OF CITIES
C
do 2600 y=1,limit(num)
loc=acraloc+y
if (movedflag(loc).ne.0) goto 2600
z6=rlmap(loc)
if (z6.eq.0) goto 2600
if ((mode.eq.1).and.(poschk(z6,own1).eq.0)) goto 2600
movedflag(loc)=1
do 2500 iturn=1,2
loc=acraloc+y
z6=rlmap(loc)
if (z6.eq.0) goto 2600
jit=acrahit+y
h1=j1ts(jit)
if ((iturn.eq.2).and.(h1.le.hitmax/2)) goto 2600
z7=z6
ab=rmap(z6)
c
c Check to see if ship was destroyed becuase the city
c it was in was captured
c
if ((ab.eq.own1).or.(ab.eq.'O')) goto 100
call head ( own1, y, loc, z6, h1 )
call topmsg ( 2, 'was destroyed' )
call flush
call delay(30)
goto 1500
100 if ((iturn.eq.1).and.(ab.eq.'O')) h1=h1+1 ! repair if in port
if (h1.gt.hitmax) h1=hitmax
call stasis(z6,loc)
200 mycod=mycode(loc) ! get my function code
if (mycod.eq.0) goto 900 ! if zero, skip ahead
if ((mycod.ne.9997).or.((own1.ne.'T').and.(own1.ne.'C')))
1 goto 500 ! check transports and carriers
n = 0 ! for overloading
nt = 2
ia = 1
ib=limit(1)
if (own1.ne.'C') goto 300
nt=1
ia=501
ib=limit(2)+500
300 do 400 j=ia,ib
400 if (rlmap(j).eq.z6) n=n+1
if (n.lt.nt*h1) goto 500
mycode(loc)=0
goto 900
500 if ((mycod.lt.101).or.(mycod.gt.6108)) goto 1100
if (mycod.le.6000) goto 600
if (mycod.gt.6100) goto 700
goto 1100
600 z6=z6+iarrow(mov(z6,mycod)+1) !destination move
goto 800
700 z6=z6+iarrow(mycod-6100+1) !directional move
800 ad=rmap(z6)
if (((ad.eq.'.').or.(ad.eq.'O')).and.(order(z6).eq.0)) goto 1100
z6=z7
900 call sector(pmap(1))
1000 call ltr(z6,iturn)
call mve ( own1, mdate, y, loc, jit, z6, z7, disas, z6-iadjst )
if (disas.eq.-2) goto 200
c
c Move evaluation. z6 = to, z7 = from, check out new location
c
1100 if (omap(z7).ne.'*') rmap(z7)=omap(z7) ! remove unit from map
ac = rmap ( z6 )
ao = omap ( z6 )
if (z6.eq.mycode(loc)) mycode(loc)=0 ! arrived at destination
if ( ac .ne. 'O' ) goto 1200 ! is it our city?
call topmsg ( 3, 'Ship is docked' ) ! ship is in city
call flush
call delay(30)
goto 1800
1200 if ( ao .eq. '.' ) goto 1600 ! if sea, skip ahead
1300 if (.not. fatal(4)) goto 2700
if ((ac.ne.'+').and.(ao.ne.'*')) goto 2400 !check for enemy to fight
1400 continue
ptr = 0
call addidt ( own1, jnkbuf, ptr )
call addstr( ' broke up on the shore', jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = 0
call topmsg ( 2, jnkbuf )
call flush
call delay(30)
goto 1500
1600 if (ac.ne.'.') goto 2400
rmap(z6)=own1 ! normal move
1800 rlmap(loc)=z6
j1ts(jit)=h1
1900 if ((own1.ne.'T').and.(own1.ne.'C')) goto 2500
n=0 ! if we're carring something, bring it along
ia=0 ! set up for transport
ib=limit(1)
nt=2
if (own1.ne.'C') goto 2000
ia=500 ! set up for carrier
ib=limit(2)
nt=1
2000 do 2300 i=ia+1,ia+ib ! find pieces and move them
if (rlmap(i).ne.z7) goto 2300
if (n+1.gt.nt*h1) goto 2050
rlmap(i)=z6
n=n+1
goto 2300
2050 if (rmap(z7).eq.'O') goto 2300
rlmap(i)=0
c
c Tell about peices lost when ship went down
c
ptr = 0
if (own1.eq.'C') goto 2100
call addstr ( 'Army # ', jnkbuf, ptr )
goto 2200
2100 continue
call addstr ( 'Fighter # ', jnkbuf, ptr )
2200 continue
call addint ( i - ia, jnkbuf, ptr )
call addstr ( ' was sunk', jnkbuf, ptr )
jnkbuf ( ptr + 1 ) = 0
call topmsg ( 2, jnkbuf )
call flush
call delay(30)
2300 continue
goto 2500
2400 if ((ac.ge.'A').and.(ac.le.'T')) then
if (.not.fatal(2)) goto 2700
endif
h2=30 ! going to fight another unit
own2=ac
call find(own2,z6,z8,h2)
call fght(z6,h1,h2,own1,own2)
call find(own2,z6,z8,h2)
if (h1.le.0) goto 1500
rmap(z6)=own1 ! put us on the map
if ((own2.ge.'a').and.(own2.le.'t')) call sonar(z6)
if (ao.eq.'.') goto 1800
rmap(z6)=ao ! won the battle, but...
if ((own2.ge.'a').and.(own2.le.'t')) call sonar(z6)
call topmsg ( 2, 'Your ship successfully clears the
* enemy from the beach before, CRUNCH!, grounding itself' )
call flush
call delay(30)
1500 rlmap(loc)=0 ! kill my unit
mycode(loc)=0
call sensor(z6)
h1=0
goto 1900
2500 call sensor(z6)
2600 continue
return
c
c Recover from fatal moves
c
2700 z6=z7 ! restore old location
rmap(z6)=ab ! restore map
goto 900 ! try again
end
SUBROUTINE SONAR(Z6)
C
C UPDATES COMPUTER'S MAP AROUND LOCATION Z6
C
IMPLICIT INTEGER(A-Z)
PARAMETER IAR=0,IFI=500,IDE=700,ISU=900,ITT=1100,
1 ICR=1200,ICA=1300,IBA=1400
PARAMETER IAR2=1500,IFI2=2000,IDE2=2200,ISU2=2400,ITT2=2600,
1 ICR2=2700,ICA2=2800,IBA2=2900
PARAMETER IDEH=0,ISUH=200,ITTH=400,ICRH=500,ICAH=600,IBAH=700
PARAMETER IDE2H=800,ISU2H=1000,ITT2H=1200,ICR2H=1300,
1 ICA2H=1400,IBA2H=1500
INTEGER G2(100)
INTEGER HITS(15),TIPE(15),CRAHIT(15),CRALOC(15)
INTEGER INDEX(15)
INTEGER CMYTBL(9),KBFUDG(9)
INTEGER LOPMAX(15),COMSCN(40)
INTEGER NSHPRF(4,6)
INTEGER PH(8),OVRPOP(16,2)
INTEGER PRIOR(7)
INTEGER RANGE(200),AR2S(500)
INTEGER ARMTOT(20),CODEFU(1500),CODELA(1500),TARGET(70),LIMIT(16)
INTEGER ARROW(9)
INTEGER D2(3)
INTEGER*2 D(667)
INTEGER MYCODE(1500)
INTEGER RANG(200)
INTEGER IOTAB(16)
INTEGER PHAZEE(8)
integer ptr
BYTE SPECAL,PASS
BYTE AB,AC,AD,AO,E,OWN1,OWN2,OWN !AVOID WORD REFERENCES TO THESE
BYTE KBTBL(9),AB9(9)
BYTE COMM(30),PHAZE(8)
BYTE IFILE(11),KILL
BYTE COMMAN(20),OKA(5),OKB(5),OKC(5)
BYTE TTY(20)
BYTE MOVEDFLAG(1500)
BYTE J1TS(1600)
BYTE EMAP(6000),RMAP(6000),PMAP(6000),OMAP(6000)
BYTE PAMELA(8),REEED(9)
byte jnkbuf ( 80 )
INTEGER RLMAP(3000)
LOGICAL AUTOMV
COMMON/AB9/AB9,PRIOR,NSHPRF
COMMON/ARMTOT/ARMTOT
COMMON/CHRT/COMMAN,COMM,COMSCN,KBTBL
COMMON/CHR2/IFILE,KILL,TTY
COMMON/CITY/FOUND(70),OWNER(70),PHASE(70)
COMMON/CMYTBL/CMYTBL,KBFUDG
COMMON/COD/CODER
COMMON/CODE/CODEFU,CODELA
COMMON/CRAHL/HITS,TIPE,CRAHIT,CRALOC
COMMON/FIPATH/FIPATH(70)
COMMON/G2/G2
COMMON/IARROW/IARROW(10),ARROW,INDEX,LOPMAX
COMMON/IOTAB/IOTAB
COMMON/J1TS/J1TS
COMMON/KXK/IADJST
COMMON/MAP/D
COMMON/MAPBLK/EMAP,RMAP,PMAP,RLMAP
COMMON/OMAP/OMAP
COMMON/MISC1/TARGET,AR2S,RANGE,RANG
COMMON/MISC2/LOCI(10,11),NUMBER(18),LIMIT,MDATE,VERSION
COMMON/MODE/MODE,JECTOR,ISEC,NEWRND
COMMON/MFLAGS/MOVEDFLAG
COMMON/MYCOD/D2,MYCODE
COMMON/OKS/OKA,OKB,OKC
COMMON/OVRPOP/OVRPOP
COMMON/P1/PHAZE,PHAZEE,PH
COMMON/DAYTIM/PAMELA,REEED
COMMON/PASS/PASS,SPECAL,AUTOMV
COMMON/SAVBUF/SAVBUF
COMMON/SPS/STEP,POSIT,START
COMMON/TEST2/SUCCES,FAILUR,FULL
COMMON/TROOP/TROOPT(6,5)
COMMON/X/X(70)
common /jnkbuf/ jnkbuf, ptr
C
C AGGR: THIS IS A MEASURE OF THE ENEMY SHIPS AGGRESSIVENESS,
C THIS VALUE IS ADDED TO THE COST-EFFECTIVENESS OF ATTACKING AN
C ENEMY UNIT TO DETERMINE IF THE SHIP WILL ATTACK OR RUN FROM THE
C ENEMY.
C ALL CITIES ARE REFERENCED BY CITY NUMBER, AS IN X(N)=LOC OF CITY #N
C CODFU/CODELA: CONTAINS A NUMBER THAT DETERMINES WHAT THAT COMPUTER CRAFT
C IS ASSIGNED TO DO, IS SEPERATED INTO 2 NUMBERS, IFO AND ILA. IFO
C GIVES THE FUNCTION, ILA GIVES DETAILS.
C CODER: USED FOR DEBUG FLAG
C CROWD: USED IF CITY IS SURROUNDED BY ARMIES
C D: ORIGINAL MAP, ENCODED IN MOD 3
C EXPLOR: THIS IS SET TO 1 IF THE ENEMY SHIP IS TO EXPLORE UNKNOWN
C TERRITORY ADJACENT TO IT, 0 IF NOT.
C FIPATH: STASIS # TO BE GIVEN TO FIGHTER IN THAT CITY
C FOUND: COMPLETION DATES FOR CITIES
C IADJST: SUBTRACTED FROM Z6 SO CURSOR WILL NOT BE MOVED OFF SCREEN
C IARROW: ADDED TO Z6 SO MOVES [1,2,3,4,5,6,7,8,9] ARE CONVERTED
C TO [+1,-99,-100,-101,ETC.]
C ISEC: SECTOR TERMINAL IS SHOWING
C IZAP: .TRUE.=SAVE GAME, .FALSE.=INITIALIZE
C JECTOR: SECTOR PROGRAM IS LOOKING AT
C KURSOR: SET TO POSITION OF CURSOR
C MODE: 1=IN MODE 2, 0=IN MODE 1
C OWNER: WHO OWNS THE CITY: 0>NOBODY, 1>PLAYER, 2>COMPUTER
C PASS: SET TO .TRUE. IF IT IS A PRIVILEGED USER
C PHASE: PHASE OF CITY
C X: LOCATIONS OF CITIES
C
C
DO 1300 I=1,8
LOCUS=Z6+IARROW(I+1) !**
AB=RMAP(LOCUS)
IF (AB.NE.EMAP(LOCUS)) EMAP(LOCUS)=AB
IF ((AB.NE.'*').AND.(AB.NE.'O')) GOTO 400
DO 100 I1=1,70
100 IF (TARGET(I1).EQ.LOCUS) GOTO 1300
DO 200 I1=1,70
200 IF (TARGET(I1).EQ.0) GOTO 300
300 TARGET(I1)=LOCUS
400 IF ((AB.LT.'A').OR.(AB.GT.'T')) GOTO 1300
IF (AB.NE.'A'.AND.AB.NE.'O') GOTO 1100
C
C WE MUST NOW FIGURE OUT IF THE ARMY IS A THREAT TO ANY OF THE COMPUTER'S
C CITIES, I.E. IF IT IS ON THE CONTINENT WITH ANY OF THEM. IF SO, PUT
C THE ARMY IN THE LOCI ARRAY. THE FIRST INDEX IS THE CONTINENT, THE
C SECOND IS THE NTH ARMY DISCOVERED ON THAT CONTINENT - 1. THE (N,1)
C ARGUMENT IS THE DATE OF THE LAST ARMY DISCOVERED ON THE
C NTH CONTINENT. THUS WE HAVE A MEANS OF DETERMINING THE AGE OF THE DATA
C
ARMDEF=0
DO 480 Y=1,LIMIT(9)
IF (RLMAP(IAR2+Y).EQ.0) GOTO 480
IF (IDIST(LOCUS,RLMAP(IAR2+Y)).GT.14) GOTO 480
MOVE=PATH(RLMAP(IAR2+Y),LOCUS,1,OKA,FLAG)
IF (FLAG.NE.0) ARMDEF=ARMDEF+1
480 CONTINUE
IF (ARMDEF.GE.7) GOTO 520
DO 500 K=1,70
IF ((OWNER(K).NE.2).OR.(PHASE(K).EQ.1)) GOTO 500
IF (FOUND(K)-MDATE-5.LE.0) GOTO 500
IF (IDIST(X(K),LOCUS).GT.18) GOTO 500
MOVE=PATH(X(K),LOCUS,1,OKA,FLAG)
IF (FLAG.NE.0) PHASE(K)=-1
500 CONTINUE
C
520 IF (AB.EQ.'O') GOTO 1300
DO 600 K=1,10
IF (LOCI(K,2).EQ.0) GOTO 600
DO 550 J=2,11
IF (LOCI(K,J).EQ.LOCUS) GOTO 800
550 CONTINUE
MOVE=PATH(LOCUS,LOCI(K,2),1,OKA,FLAG)
J=11
IF (FLAG.NE.0) GOTO 800
600 CONTINUE
DO 700 K=1,10
700 IF (LOCI(K,2).EQ.0) GOTO 760
OLDEST=10000
DO 750 J=1,10
IF (LOCI(J,1).LT.OLDEST) THEN
OLDEST=LOCI(J,1)
K=J
ENDIF
750 CONTINUE
760 DO 770 J=2,11
770 LOCI(K,J)=0
GOTO 1000
800 DO 900 J=J,3,-1
900 LOCI(K,J)=LOCI(K,J-1) !SHIFT EVERYTHING UP THE ARRAY
1000 LOCI(K,1)=MDATE
LOCI(K,2)=LOCUS
GOTO 1300
C
1100 ISHIPT=0
IF (AB.EQ.'D') ISHIPT=1
IF (AB.EQ.'S') ISHIPT=2
IF (AB.EQ.'T') ISHIPT=3
IF (AB.EQ.'R') ISHIPT=4
IF (AB.EQ.'C') ISHIPT=5
IF (AB.EQ.'B') ISHIPT=6
IF (ISHIPT.EQ.0) GOTO 1300
DO 1200 IB=1,4
1200 TROOPT(ISHIPT,IB)=TROOPT(ISHIPT,IB+1)
TROOPT(ISHIPT,5)=LOCUS
1300 CONTINUE
EMAP(Z6)=RMAP(Z6)
IF (CODER.EQ.10) CALL SENSOR(Z6)
RETURN
END
SUBROUTINE STASIS(Z6,LOC)
C
C CHECK IF ARMY #LOC, AT Z6, IS NEAR THE ENEMY, IF SO WAKE HIM UP
C
IMPLICIT INTEGER(A-Z)
PARAMETER IAR=0,IFI=500,IDE=700,ISU=900,ITT=1100,
1 ICR=1200,ICA=1300,IBA=1400
PARAMETER IAR2=1500,IFI2=2000,IDE2=2200,ISU2=2400,ITT2=2600,
1 ICR2=2700,ICA2=2800,IBA2=2900
PARAMETER IDEH=0,ISUH=200,ITTH=400,ICRH=500,ICAH=600,IBAH=700
PARAMETER IDE2H=800,ISU2H=1000,ITT2H=1200,ICR2H=1300,
1 ICA2H=1400,IBA2H=1500
INTEGER G2(100)
INTEGER HITS(15),TIPE(15),CRAHIT(15),CRALOC(15)
INTEGER INDEX(15)
INTEGER CMYTBL(9),KBFUDG(9)
INTEGER LOPMAX(15),COMSCN(40)
INTEGER NSHPRF(4,6)
INTEGER PH(8),OVRPOP(16,2)
INTEGER PRIOR(7)
INTEGER RANGE(200),AR2S(500)
INTEGER ARMTOT(20),CODEFU(1500),CODELA(1500),TARGET(70),LIMIT(16)
INTEGER ARROW(9)
INTEGER D2(3)
INTEGER*2 D(667)
INTEGER MYCODE(1500)
INTEGER RANG(200)
INTEGER IOTAB(16)
INTEGER PHAZEE(8)
integer ptr
BYTE SPECAL,PASS
BYTE AB,AC,AD,AO,E,OWN1,OWN2,OWN !AVOID WORD REFERENCES TO THESE
BYTE KBTBL(9),AB9(9)
BYTE COMM(30),PHAZE(8)
BYTE IFILE(11),KILL
BYTE COMMAN(20),OKA(5),OKB(5),OKC(5)
BYTE TTY(20)
BYTE MOVEDFLAG(1500)
BYTE J1TS(1600)
BYTE EMAP(6000),RMAP(6000),PMAP(6000),OMAP(6000)
BYTE PAMELA(8),REEED(9)
byte jnkbuf ( 80 )
INTEGER RLMAP(3000)
LOGICAL AUTOMV
COMMON/AB9/AB9,PRIOR,NSHPRF
COMMON/ARMTOT/ARMTOT
COMMON/CHRT/COMMAN,COMM,COMSCN,KBTBL
COMMON/CHR2/IFILE,KILL,TTY
COMMON/CITY/FOUND(70),OWNER(70),PHASE(70)
COMMON/CMYTBL/CMYTBL,KBFUDG
COMMON/COD/CODER
COMMON/CODE/CODEFU,CODELA
COMMON/CRAHL/HITS,TIPE,CRAHIT,CRALOC
COMMON/FIPATH/FIPATH(70)
COMMON/G2/G2
COMMON/IARROW/IARROW(10),ARROW,INDEX,LOPMAX
COMMON/IOTAB/IOTAB
COMMON/J1TS/J1TS
COMMON/KXK/IADJST
COMMON/MAP/D
COMMON/MAPBLK/EMAP,RMAP,PMAP,RLMAP
COMMON/OMAP/OMAP
COMMON/MISC1/TARGET,AR2S,RANGE,RANG
COMMON/MISC2/LOCI(10,11),NUMBER(18),LIMIT,MDATE,VERSION
COMMON/MODE/MODE,JECTOR,ISEC,NEWRND
COMMON/MFLAGS/MOVEDFLAG
COMMON/MYCOD/D2,MYCODE
COMMON/OKS/OKA,OKB,OKC
COMMON/OVRPOP/OVRPOP
COMMON/P1/PHAZE,PHAZEE,PH
COMMON/DAYTIM/PAMELA,REEED
COMMON/PASS/PASS,SPECAL,AUTOMV
COMMON/SAVBUF/SAVBUF
COMMON/SPS/STEP,POSIT,START
COMMON/TEST2/SUCCES,FAILUR,FULL
COMMON/TROOP/TROOPT(6,5)
COMMON/X/X(70)
common /jnkbuf/ jnkbuf, ptr
C
C AGGR: THIS IS A MEASURE OF THE ENEMY SHIPS AGGRESSIVENESS,
C THIS VALUE IS ADDED TO THE COST-EFFECTIVENESS OF ATTACKING AN
C ENEMY UNIT TO DETERMINE IF THE SHIP WILL ATTACK OR RUN FROM THE
C ENEMY.
C ALL CITIES ARE REFERENCED BY CITY NUMBER, AS IN X(N)=LOC OF CITY #N
C CODFU/CODELA: CONTAINS A NUMBER THAT DETERMINES WHAT THAT COMPUTER CRAFT
C IS ASSIGNED TO DO, IS SEPERATED INTO 2 NUMBERS, IFO AND ILA. IFO
C GIVES THE FUNCTION, ILA GIVES DETAILS.
C CODER: USED FOR DEBUG FLAG
C CROWD: USED IF CITY IS SURROUNDED BY ARMIES
C D: ORIGINAL MAP, ENCODED IN MOD 3
C EXPLOR: THIS IS SET TO 1 IF THE ENEMY SHIP IS TO EXPLORE UNKNOWN
C TERRITORY ADJACENT TO IT, 0 IF NOT.
C FIPATH: STASIS # TO BE GIVEN TO FIGHTER IN THAT CITY
C FOUND: COMPLETION DATES FOR CITIES
C IADJST: SUBTRACTED FROM Z6 SO CURSOR WILL NOT BE MOVED OFF SCREEN
C IARROW: ADDED TO Z6 SO MOVES [1,2,3,4,5,6,7,8,9] ARE CONVERTED
C TO [+1,-99,-100,-101,ETC.]
C ISEC: SECTOR TERMINAL IS SHOWING
C IZAP: .TRUE.=SAVE GAME, .FALSE.=INITIALIZE
C JECTOR: SECTOR PROGRAM IS LOOKING AT
C KURSOR: SET TO POSITION OF CURSOR
C MODE: 1=IN MODE 2, 0=IN MODE 1
C OWNER: WHO OWNS THE CITY: 0>NOBODY, 1>PLAYER, 2>COMPUTER
C PASS: SET TO .TRUE. IF IT IS A PRIVILEGED USER
C PHASE: PHASE OF CITY
C X: LOCATIONS OF CITIES
C
C
DO 200 I=1,8
AB=RMAP(Z6+IARROW(I+1)) !**
IF ((AB.GE.'a').AND.(AB.LE.'t')) GOTO 100
IF (AB.EQ.'X') GOTO 100
IF (AB.NE.'*') GOTO 200
IF (RMAP(Z6).EQ.'F') GOTO 200
100 MYCODE(LOC)=0
GOTO 300
200 CONTINUE
300 RETURN
END
subroutine test4(z6,flag,dir,move1,movnum,beg,end,ag2,flag2)
c
c Test subroutine for path, displays current path progress
c
IMPLICIT INTEGER(A-Z)
PARAMETER IAR=0,IFI=500,IDE=700,ISU=900,ITT=1100,
1 ICR=1200,ICA=1300,IBA=1400
PARAMETER IAR2=1500,IFI2=2000,IDE2=2200,ISU2=2400,ITT2=2600,
1 ICR2=2700,ICA2=2800,IBA2=2900
PARAMETER IDEH=0,ISUH=200,ITTH=400,ICRH=500,ICAH=600,IBAH=700
PARAMETER IDE2H=800,ISU2H=1000,ITT2H=1200,ICR2H=1300,
1 ICA2H=1400,IBA2H=1500
INTEGER G2(100)
INTEGER HITS(15),TIPE(15),CRAHIT(15),CRALOC(15)
INTEGER INDEX(15)
INTEGER CMYTBL(9),KBFUDG(9)
INTEGER LOPMAX(15),COMSCN(40)
INTEGER NSHPRF(4,6)
INTEGER PH(8),OVRPOP(16,2)
INTEGER PRIOR(7)
INTEGER RANGE(200),AR2S(500)
INTEGER ARMTOT(20),CODEFU(1500),CODELA(1500),TARGET(70),LIMIT(16)
INTEGER ARROW(9)
INTEGER D2(3)
INTEGER*2 D(667)
INTEGER MYCODE(1500)
INTEGER RANG(200)
INTEGER IOTAB(16)
INTEGER PHAZEE(8)
integer ptr
BYTE SPECAL,PASS
BYTE AB,AC,AD,AO,E,OWN1,OWN2,OWN !AVOID WORD REFERENCES TO THESE
BYTE KBTBL(9),AB9(9)
BYTE COMM(30),PHAZE(8)
BYTE IFILE(11),KILL
BYTE COMMAN(20),OKA(5),OKB(5),OKC(5)
BYTE TTY(20)
BYTE MOVEDFLAG(1500)
BYTE J1TS(1600)
BYTE EMAP(6000),RMAP(6000),PMAP(6000),OMAP(6000)
BYTE PAMELA(8),REEED(9)
byte jnkbuf ( 80 )
INTEGER RLMAP(3000)
LOGICAL AUTOMV
COMMON/AB9/AB9,PRIOR,NSHPRF
COMMON/ARMTOT/ARMTOT
COMMON/CHRT/COMMAN,COMM,COMSCN,KBTBL
COMMON/CHR2/IFILE,KILL,TTY
COMMON/CITY/FOUND(70),OWNER(70),PHASE(70)
COMMON/CMYTBL/CMYTBL,KBFUDG
COMMON/COD/CODER
COMMON/CODE/CODEFU,CODELA
COMMON/CRAHL/HITS,TIPE,CRAHIT,CRALOC
COMMON/FIPATH/FIPATH(70)
COMMON/G2/G2
COMMON/IARROW/IARROW(10),ARROW,INDEX,LOPMAX
COMMON/IOTAB/IOTAB
COMMON/J1TS/J1TS
COMMON/KXK/IADJST
COMMON/MAP/D
COMMON/MAPBLK/EMAP,RMAP,PMAP,RLMAP
COMMON/OMAP/OMAP
COMMON/MISC1/TARGET,AR2S,RANGE,RANG
COMMON/MISC2/LOCI(10,11),NUMBER(18),LIMIT,MDATE,VERSION
COMMON/MODE/MODE,JECTOR,ISEC,NEWRND
COMMON/MFLAGS/MOVEDFLAG
COMMON/MYCOD/D2,MYCODE
COMMON/OKS/OKA,OKB,OKC
COMMON/OVRPOP/OVRPOP
COMMON/P1/PHAZE,PHAZEE,PH
COMMON/DAYTIM/PAMELA,REEED
COMMON/PASS/PASS,SPECAL,AUTOMV
COMMON/SAVBUF/SAVBUF
COMMON/SPS/STEP,POSIT,START
COMMON/TEST2/SUCCES,FAILUR,FULL
COMMON/TROOP/TROOPT(6,5)
COMMON/X/X(70)
common /jnkbuf/ jnkbuf, ptr
C
C AGGR: THIS IS A MEASURE OF THE ENEMY SHIPS AGGRESSIVENESS,
C THIS VALUE IS ADDED TO THE COST-EFFECTIVENESS OF ATTACKING AN
C ENEMY UNIT TO DETERMINE IF THE SHIP WILL ATTACK OR RUN FROM THE
C ENEMY.
C ALL CITIES ARE REFERENCED BY CITY NUMBER, AS IN X(N)=LOC OF CITY #N
C CODFU/CODELA: CONTAINS A NUMBER THAT DETERMINES WHAT THAT COMPUTER CRAFT
C IS ASSIGNED TO DO, IS SEPERATED INTO 2 NUMBERS, IFO AND ILA. IFO
C GIVES THE FUNCTION, ILA GIVES DETAILS.
C CODER: USED FOR DEBUG FLAG
C CROWD: USED IF CITY IS SURROUNDED BY ARMIES
C D: ORIGINAL MAP, ENCODED IN MOD 3
C EXPLOR: THIS IS SET TO 1 IF THE ENEMY SHIP IS TO EXPLORE UNKNOWN
C TERRITORY ADJACENT TO IT, 0 IF NOT.
C FIPATH: STASIS # TO BE GIVEN TO FIGHTER IN THAT CITY
C FOUND: COMPLETION DATES FOR CITIES
C IADJST: SUBTRACTED FROM Z6 SO CURSOR WILL NOT BE MOVED OFF SCREEN
C IARROW: ADDED TO Z6 SO MOVES [1,2,3,4,5,6,7,8,9] ARE CONVERTED
C TO [+1,-99,-100,-101,ETC.]
C ISEC: SECTOR TERMINAL IS SHOWING
C IZAP: .TRUE.=SAVE GAME, .FALSE.=INITIALIZE
C JECTOR: SECTOR PROGRAM IS LOOKING AT
C KURSOR: SET TO POSITION OF CURSOR
C MODE: 1=IN MODE 2, 0=IN MODE 1
C OWNER: WHO OWNS THE CITY: 0>NOBODY, 1>PLAYER, 2>COMPUTER
C PASS: SET TO .TRUE. IF IT IS A PRIVILEGED USER
C PHASE: PHASE OF CITY
C X: LOCATIONS OF CITIES
C
INTEGER AG2(100)
C
CALL CURSOR(Z6-IADJST)
IF (FLAG.NE.1001) E=GETCHX() !WAIT FOR CHAR IF TRACE MODE
IX='G' !DISPLAY CURRENT MOVE ON MAP
IF (FLAG2.EQ.1) TYPE 999,IX
IX='H'
IF (FLAG2.EQ.2) TYPE 999,IX
IF (FLAG.EQ.1001) RETURN
C PROCESS THIS CHAR
IF (E.EQ.' ') RETURN !SPACE, CONTINUE
IF (E.EQ.'G') GOTO 100 !G, DISPLAY G2 ARRAY
CALL tpos(1,1) !IF NOT SPACE OR "G", SHOW PATH VARIABLES
TYPE 998,Z6,MOVE1,MOVNUM
999 FORMAT('+',A1$)
998 FORMAT(' Z6:',I4,' MOVE1:',I1,' MOVNUM:',I3)
CALL tpos(2,1)
TYPE 997,BEG,END,IADJST,DIR,FLAG
997 FORMAT(' BEG:'I4' END:'I4' IADJST:'I4' TDIR:'I2' FLAG:'I4)
IF (FLAG2 .EQ. 1) TYPE 996
996 FORMAT(' FLAG2: MOVE ')
IF (FLAG2 .EQ. 2) TYPE 995
995 FORMAT(' FLAG2: SHORE')
RETURN
100 CALL tpos(1,1)
TYPE 994,AG2
994 FORMAT(1X,16I5)
RETURN
END
ccc addcnt - add to number of characters on a top line
ccc topini - zero top end of line counts
ccc topmsg - put a message on a top line
subroutine topmsg ( line, string )
integer line
byte string ( 80 )
c
c synopsis
c
c call topmsg ( line, string )
c
c line - line to put message (1, 2, or 3)
c string - zero byte terminated array containing message
c
parameter topsiz = 3
integer strlen, j
integer eolpos ( topsiz ), msglen, i
data eolpos / topsiz*0 /
if (( line .le. 0 ) .or. ( line .gt. topsiz )) line = 1
msglen = strlen ( string )
call bufpos ( line, 1, string, msglen )
call clreol ( line, msglen + 1, eolpos ( line ))
eolpos ( line ) = msglen
goto 100
c
c Add to end of line count
c
entry addcnt ( line, i )
if (( line .le. 0 ) .or. ( line .gt. topsiz )) line = 1
eolpos ( line ) = eolpos ( line ) + i
goto 100
c
c Handle screen clear
c
entry topini
do 100 j = 1, topsiz
eolpos ( j ) = 0
100 continue
return
end
ccc tran - translate old enemy units to new characters
subroutine tran ( ab )
byte ab
c
c synopsis
c
c call tran ( ab )
c
c ab - byte to translate
c
byte olde ( 8 ), newe ( 8 )
data olde / '1', '2', '3', '4', '5', '6', '7', '8' /
data newe / 'a', 'f', 'd', 's', 't', 'r', 'c', 'b' /
do 10 i = 1, 8
10 if ( ab .eq. olde ( i )) ab = newe ( i )
return
end
subroutine troopm
c
c This subroutine handles enemy troop transport moves
c
IMPLICIT INTEGER(A-Z)
PARAMETER IAR=0,IFI=500,IDE=700,ISU=900,ITT=1100,
1 ICR=1200,ICA=1300,IBA=1400
PARAMETER IAR2=1500,IFI2=2000,IDE2=2200,ISU2=2400,ITT2=2600,
1 ICR2=2700,ICA2=2800,IBA2=2900
PARAMETER IDEH=0,ISUH=200,ITTH=400,ICRH=500,ICAH=600,IBAH=700
PARAMETER IDE2H=800,ISU2H=1000,ITT2H=1200,ICR2H=1300,
1 ICA2H=1400,IBA2H=1500
INTEGER G2(100)
INTEGER HITS(15),TIPE(15),CRAHIT(15),CRALOC(15)
INTEGER INDEX(15)
INTEGER CMYTBL(9),KBFUDG(9)
INTEGER LOPMAX(15),COMSCN(40)
INTEGER NSHPRF(4,6)
INTEGER PH(8),OVRPOP(16,2)
INTEGER PRIOR(7)
INTEGER RANGE(200),AR2S(500)
INTEGER ARMTOT(20),CODEFU(1500),CODELA(1500),TARGET(70),LIMIT(16)
INTEGER ARROW(9)
INTEGER D2(3)
INTEGER*2 D(667)
INTEGER MYCODE(1500)
INTEGER RANG(200)
INTEGER IOTAB(16)
INTEGER PHAZEE(8)
integer ptr
BYTE SPECAL,PASS
BYTE AB,AC,AD,AO,E,OWN1,OWN2,OWN !AVOID WORD REFERENCES TO THESE
BYTE KBTBL(9),AB9(9)
BYTE COMM(30),PHAZE(8)
BYTE IFILE(11),KILL
BYTE COMMAN(20),OKA(5),OKB(5),OKC(5)
BYTE TTY(20)
BYTE MOVEDFLAG(1500)
BYTE J1TS(1600)
BYTE EMAP(6000),RMAP(6000),PMAP(6000),OMAP(6000)
BYTE PAMELA(8),REEED(9)
byte jnkbuf ( 80 )
INTEGER RLMAP(3000)
LOGICAL AUTOMV
COMMON/AB9/AB9,PRIOR,NSHPRF
COMMON/ARMTOT/ARMTOT
COMMON/CHRT/COMMAN,COMM,COMSCN,KBTBL
COMMON/CHR2/IFILE,KILL,TTY
COMMON/CITY/FOUND(70),OWNER(70),PHASE(70)
COMMON/CMYTBL/CMYTBL,KBFUDG
COMMON/COD/CODER
COMMON/CODE/CODEFU,CODELA
COMMON/CRAHL/HITS,TIPE,CRAHIT,CRALOC
COMMON/FIPATH/FIPATH(70)
COMMON/G2/G2
COMMON/IARROW/IARROW(10),ARROW,INDEX,LOPMAX
COMMON/IOTAB/IOTAB
COMMON/J1TS/J1TS
COMMON/KXK/IADJST
COMMON/MAP/D
COMMON/MAPBLK/EMAP,RMAP,PMAP,RLMAP
COMMON/OMAP/OMAP
COMMON/MISC1/TARGET,AR2S,RANGE,RANG
COMMON/MISC2/LOCI(10,11),NUMBER(18),LIMIT,MDATE,VERSION
COMMON/MODE/MODE,JECTOR,ISEC,NEWRND
COMMON/MFLAGS/MOVEDFLAG
COMMON/MYCOD/D2,MYCODE
COMMON/OKS/OKA,OKB,OKC
COMMON/OVRPOP/OVRPOP
COMMON/P1/PHAZE,PHAZEE,PH
COMMON/DAYTIM/PAMELA,REEED
COMMON/PASS/PASS,SPECAL,AUTOMV
COMMON/SAVBUF/SAVBUF
COMMON/SPS/STEP,POSIT,START
COMMON/TEST2/SUCCES,FAILUR,FULL
COMMON/TROOP/TROOPT(6,5)
COMMON/X/X(70)
common /jnkbuf/ jnkbuf, ptr
C
C AGGR: THIS IS A MEASURE OF THE ENEMY SHIPS AGGRESSIVENESS,
C THIS VALUE IS ADDED TO THE COST-EFFECTIVENESS OF ATTACKING AN
C ENEMY UNIT TO DETERMINE IF THE SHIP WILL ATTACK OR RUN FROM THE
C ENEMY.
C ALL CITIES ARE REFERENCED BY CITY NUMBER, AS IN X(N)=LOC OF CITY #N
C CODFU/CODELA: CONTAINS A NUMBER THAT DETERMINES WHAT THAT COMPUTER CRAFT
C IS ASSIGNED TO DO, IS SEPERATED INTO 2 NUMBERS, IFO AND ILA. IFO
C GIVES THE FUNCTION, ILA GIVES DETAILS.
C CODER: USED FOR DEBUG FLAG
C CROWD: USED IF CITY IS SURROUNDED BY ARMIES
C D: ORIGINAL MAP, ENCODED IN MOD 3
C EXPLOR: THIS IS SET TO 1 IF THE ENEMY SHIP IS TO EXPLORE UNKNOWN
C TERRITORY ADJACENT TO IT, 0 IF NOT.
C FIPATH: STASIS # TO BE GIVEN TO FIGHTER IN THAT CITY
C FOUND: COMPLETION DATES FOR CITIES
C IADJST: SUBTRACTED FROM Z6 SO CURSOR WILL NOT BE MOVED OFF SCREEN
C IARROW: ADDED TO Z6 SO MOVES [1,2,3,4,5,6,7,8,9] ARE CONVERTED
C TO [+1,-99,-100,-101,ETC.]
C ISEC: SECTOR TERMINAL IS SHOWING
C IZAP: .TRUE.=SAVE GAME, .FALSE.=INITIALIZE
C JECTOR: SECTOR PROGRAM IS LOOKING AT
C KURSOR: SET TO POSITION OF CURSOR
C MODE: 1=IN MODE 2, 0=IN MODE 1
C OWNER: WHO OWNS THE CITY: 0>NOBODY, 1>PLAYER, 2>COMPUTER
C PASS: SET TO .TRUE. IF IT IS A PRIVILEGED USER
C PHASE: PHASE OF CITY
C X: LOCATIONS OF CITIES
C
integer tttc(-1:20,0:50)
monkey = 0
number ( 5 ) = 0
if ( coder .eq. 5 ) type 999
999 format(' Troop transport codes')
do 2300 y=1,limit(13)
z6=rlmap(itt2+y)
if (z6.eq.0) goto 2300
monkey=y
dir=mod(y,2)*2-1 ! set dir to 1 or -1 consistently
ab=rmap(z6)
h1=j1ts(itt2h+y)
if (ab.eq.'X') h1=h1+1
if (h1.gt.3) h1=3
c
c Now compute the number of armies aboard the troop transport
c
numarm=0
do 100 i=1,limit(9)
100 if (z6.eq.rlmap(iar2+i)) numarm=numarm+1
if (numarm.gt.6) numarm=6 ! max # armies = 6
orig=z6
do 2200 iturn=1,2
p=0
z7=z6
ab=rmap(z6)
if ((iturn.eq.2).and.(h1.le.1)) goto 2300
c
c Move selection
c
ifo=codefu(y+itt2-1500)
ila=codela(y+itt2-1500)
c
c 300 is the statement number where the ifo and ila are
c processed to come up with a move, which is then fed thru movcor
c to come up with a final move.
c
c take care of damaged ships or just repaired ships.
c (damaged ships will have an ifo of 8)
c
if (h1.lt.3) goto 200
if (ifo.eq.8) ifo=0
goto 300
200 ifo=8
if (ila.eq.0) goto 250
if (rmap(ila).eq.'X') goto 1300
250 ila=iport(z6)
goto 1300
c
c ifo=10 move toward unexplored territory, location specified by ila
c ifo=7 move in a constant direction specified by ila
c ifo=9 move toward an unowned city specified by ila
c ifo=0-6 ila specifies location of where to move, either
c an army producing city or an army looking for a 't'.
c it could also be a direction. ifo is the number of armies on
c board the troop transport.
c
300 if (ifo.lt.7) ifo=numarm
if (numarm.eq.0) ifo=0
if ((ifo.eq.10).and.(emap(ila).ne.' ')) goto 1000
if (ifo.eq.10) goto 1300
if (ifo.eq.7) goto 1350
if (ifo.ne.9) goto 500
c
c ifo=9
c
do 400 i=1,70
if (target(i).ne.ila) goto 400
move=0
if ((iturn.eq.2).and.(idist(z6,ila).eq.1)) goto 1600
goto 1300
400 continue
if ((idist(z6,ila).lt.10).and.(edger(ila).lt.8).and.(irand(100).gt.10))
1 goto 1300
c
c It seems that it's target is no longer on the hit list,
c meaning it was captured.
c
500 if (ifo.le.2) goto 600
if (ifo.eq.3) then
if (irand(100).lt.96) goto 600
endif
if (ifo.eq.4) then
if (irand(100).lt.90) goto 600
endif
goto 800 ! select a target
c
c Select an army producing city and move towards it.
c pick the closest one.
c
600 if (ila.eq.0.or.ila.gt.500) goto 650
if ((codefu(ila).eq.3).and.(rlmap(iar2+ila).ne.0)) goto 1200
650 aflag=0
id=35
670 do 700 i=1,70
if ((x(i).eq.0).or.(owner(i).ne.2)) goto 700
if (edger(x(i)).eq.0) goto 700
if ((aflag.eq.0).and.(phase(i).ne.1)) goto 700
if (idist(z6,x(i)).ge.id) goto 700
do 680 j=1,limit(13)
if (j.eq.y) goto 680
if (codela(j+itt2-1500).ne.x(i)) goto 680
if (idist(rlmap(j+itt2),x(i)).le.2) goto 700
680 continue
id=idist(z6,x(i))
ila=x(i)
700 continue
if (id.ne.35) goto 1300
if (aflag.eq.1) goto 1000
aflag=1
goto 670
c
c Perform troop transport to target city assignment
c
800 if (number(10).eq.0) goto 1000
tm=0
do 820 i=1,limit(13)
if (rlmap(itt2+i).eq.0) goto 820
if (i.eq.y) goto 810
if (codefu(itt2-1500+i).eq.8) goto 820
if (codefu(itt2-1500+i).le.3) goto 820
810 tm=tm+1
if (codefu(itt2-1500+i).eq.9) codefu(itt2-1500+i)=0
tttc(tm,0)=i
820 continue
cm=0
do 840 i=1,number(10)
if (target(i).eq.0) goto 840
ila=target(i)
if (edger(ila).eq.0) goto 840
cm=cm+1
tttc(0,cm)=ila
tttc(-1,cm)=-1
if (rmap(ila).eq.'O') tttc(-1,cm)=1
840 continue
do 850 i=1,tm
do 850 j=1,cm
tttc(i,j)=idist(rlmap(itt2+tttc(i,0)),tttc(0,j))
850 continue
ac='*'
860 min=1000
do 880 i=1,tm
if (tttc(i,0).eq.0) goto 880
do 880 j=1,cm
if (emap(tttc(0,j)).ne.ac) goto 880
if (tttc(i,j).ge.min) goto 880
if (tttc(-1,j).eq.0) then
do 870 k=1,cm
if (tttc(-1,k).eq.-1) goto 880
870 continue
endif
move=path(rlmap(itt2+tttc(i,0)),tttc(0,j),1,okc,flag)
if (flag.eq.0) then
tttc(i,j)=1000
goto 880
endif
min=tttc(i,j)
ir=i
ic=j
880 continue
if (min.ne.1000) then ! don't change function if dest is <3 from old?
codefu(itt2-1500+tttc(ir,0))=9
codela(itt2-1500+tttc(ir,0))=tttc(0,ic)
call dist(rlmap(itt2+tttc(ir,0)),tttc(0,ic))
tttc(ir,0)=0
tttc(ir,ic)=1001
tttc(-1,ic)=0
goto 860
endif
ifo=codefu(itt2-1500+y)
ila=codela(itt2-1500+y)
if (number(9)+number(10).le.38) then
if (ifo.eq.9) goto 1500
goto 1000
endif
if (ac.eq.'*') then
ac='o'
goto 860
endif
if (ifo.eq.9) goto 1500
c
c Move towards unknown territory
c
1000 ifo=10
ila=expl()
if (ila.eq.0) goto 1100
call dist(z6,ila)
goto 1300
c
c Move in specified direction (ila specifies which)
c
1100 ifo=7
ila=irand(8)+1 !**
goto 1400
c
c Now pick a move according to ifo and ila
c
1200 move=0
if (idist(z6,rlmap(iar2+ila)).eq.1) goto 1600
move=mov(z6,rlmap(iar2+ila))
goto 1500
1300 move=path(z6,ila,dir,okc,flag)
if (flag.eq.0) goto 1100
goto 1500
1350 if (number(10).eq.0) goto 1400
if (irand(100).lt.40) goto 800
1400 move=ila
1500 aggr=-numarm
if ((number(5).gt.10).and.(numarm.eq.0)) aggr=aggr+2
explor=0
if (ifo.gt.6) explor=1
move=move*dir
dest=-1
if ((ifo.eq.9).or.(ifo.eq.10)) dest=ila
move=movcor(ifo,iturn,z6,move,h1,1,aggr,'t',explor,dir,dest,orig,3)
move=iabs(move)
if (ifo.eq.7) ila=move
1600 codefu(itt2-1500+y)=ifo
codela(itt2-1500+y)=ila
z6=z6+iarrow(move+1) !**
if (coder.eq.5) type 997, ifo,ila
997 format(1x,i)
c
if (omap(z7).ne.'*') rmap(z7)=omap(z7)
if (rmap(z6).eq.'.') goto 1700
if (rmap(z6).eq.'X') goto 1800
if ((rmap(z6).eq.'+').or.(omap(z6).eq.'*')) goto 1900
ab=rmap(z6)
if (coder.eq.5) type 996,ab !fix this conditional, kludged
996 format(' attacking ',a1)
if (ab.eq.'.') goto 1700
p=1
h2=30
own1='t'
own2=rmap(z6)
call find(own2,z6,z8,h2)
call fght(z6,h1,h2,own1,own2)
call find(own2,z6,z8,h2)
if (h1.le.0) goto 1900
if (omap(z6).eq.'+') goto 1900
j1ts(itt2h+y)=h1
1700 rmap(z6)='t'
1800 rlmap(itt2+y)=z6
j1ts(itt2h+y)=h1
if (iturn.eq.1) number(5)=number(5)+1
goto 2000
1900 rlmap(itt2+y)=0
j1ts(itt2h+y)=0
2000 n=0
if (p.eq.1) call sensor(z6)
do 2100 u=iar2+1,iar2+limit(9)
if (rlmap(u).ne.z7) goto 2100
if (n+1.gt.h1*2) then
if (rmap(z7).ne.'X') rlmap(u)=0
goto 2100
endif
n=n+1
rlmap(u)=z6
2100 continue
if (numarm.gt.2*h1) numarm=2*h1
call sonar(z6)
2200 continue
2300 continue
limit(13)=monkey
return
end
subroutine write ( beg, lim, num )
IMPLICIT INTEGER(A-Z)
PARAMETER IAR=0,IFI=500,IDE=700,ISU=900,ITT=1100,
1 ICR=1200,ICA=1300,IBA=1400
PARAMETER IAR2=1500,IFI2=2000,IDE2=2200,ISU2=2400,ITT2=2600,
1 ICR2=2700,ICA2=2800,IBA2=2900
PARAMETER IDEH=0,ISUH=200,ITTH=400,ICRH=500,ICAH=600,IBAH=700
PARAMETER IDE2H=800,ISU2H=1000,ITT2H=1200,ICR2H=1300,
1 ICA2H=1400,IBA2H=1500
INTEGER G2(100)
INTEGER HITS(15),TIPE(15),CRAHIT(15),CRALOC(15)
INTEGER INDEX(15)
INTEGER CMYTBL(9),KBFUDG(9)
INTEGER LOPMAX(15),COMSCN(40)
INTEGER NSHPRF(4,6)
INTEGER PH(8),OVRPOP(16,2)
INTEGER PRIOR(7)
INTEGER RANGE(200),AR2S(500)
INTEGER ARMTOT(20),CODEFU(1500),CODELA(1500),TARGET(70),LIMIT(16)
INTEGER ARROW(9)
INTEGER D2(3)
INTEGER*2 D(667)
INTEGER MYCODE(1500)
INTEGER RANG(200)
INTEGER IOTAB(16)
INTEGER PHAZEE(8)
integer ptr
BYTE SPECAL,PASS
BYTE AB,AC,AD,AO,E,OWN1,OWN2,OWN !AVOID WORD REFERENCES TO THESE
BYTE KBTBL(9),AB9(9)
BYTE COMM(30),PHAZE(8)
BYTE IFILE(11),KILL
BYTE COMMAN(20),OKA(5),OKB(5),OKC(5)
BYTE TTY(20)
BYTE MOVEDFLAG(1500)
BYTE J1TS(1600)
BYTE EMAP(6000),RMAP(6000),PMAP(6000),OMAP(6000)
BYTE PAMELA(8),REEED(9)
byte jnkbuf ( 80 )
INTEGER RLMAP(3000)
LOGICAL AUTOMV
COMMON/AB9/AB9,PRIOR,NSHPRF
COMMON/ARMTOT/ARMTOT
COMMON/CHRT/COMMAN,COMM,COMSCN,KBTBL
COMMON/CHR2/IFILE,KILL,TTY
COMMON/CITY/FOUND(70),OWNER(70),PHASE(70)
COMMON/CMYTBL/CMYTBL,KBFUDG
COMMON/COD/CODER
COMMON/CODE/CODEFU,CODELA
COMMON/CRAHL/HITS,TIPE,CRAHIT,CRALOC
COMMON/FIPATH/FIPATH(70)
COMMON/G2/G2
COMMON/IARROW/IARROW(10),ARROW,INDEX,LOPMAX
COMMON/IOTAB/IOTAB
COMMON/J1TS/J1TS
COMMON/KXK/IADJST
COMMON/MAP/D
COMMON/MAPBLK/EMAP,RMAP,PMAP,RLMAP
COMMON/OMAP/OMAP
COMMON/MISC1/TARGET,AR2S,RANGE,RANG
COMMON/MISC2/LOCI(10,11),NUMBER(18),LIMIT,MDATE,VERSION
COMMON/MODE/MODE,JECTOR,ISEC,NEWRND
COMMON/MFLAGS/MOVEDFLAG
COMMON/MYCOD/D2,MYCODE
COMMON/OKS/OKA,OKB,OKC
COMMON/OVRPOP/OVRPOP
COMMON/P1/PHAZE,PHAZEE,PH
COMMON/DAYTIM/PAMELA,REEED
COMMON/PASS/PASS,SPECAL,AUTOMV
COMMON/SAVBUF/SAVBUF
COMMON/SPS/STEP,POSIT,START
COMMON/TEST2/SUCCES,FAILUR,FULL
COMMON/TROOP/TROOPT(6,5)
COMMON/X/X(70)
common /jnkbuf/ jnkbuf, ptr
C
C AGGR: THIS IS A MEASURE OF THE ENEMY SHIPS AGGRESSIVENESS,
C THIS VALUE IS ADDED TO THE COST-EFFECTIVENESS OF ATTACKING AN
C ENEMY UNIT TO DETERMINE IF THE SHIP WILL ATTACK OR RUN FROM THE
C ENEMY.
C ALL CITIES ARE REFERENCED BY CITY NUMBER, AS IN X(N)=LOC OF CITY #N
C CODFU/CODELA: CONTAINS A NUMBER THAT DETERMINES WHAT THAT COMPUTER CRAFT
C IS ASSIGNED TO DO, IS SEPERATED INTO 2 NUMBERS, IFO AND ILA. IFO
C GIVES THE FUNCTION, ILA GIVES DETAILS.
C CODER: USED FOR DEBUG FLAG
C CROWD: USED IF CITY IS SURROUNDED BY ARMIES
C D: ORIGINAL MAP, ENCODED IN MOD 3
C EXPLOR: THIS IS SET TO 1 IF THE ENEMY SHIP IS TO EXPLORE UNKNOWN
C TERRITORY ADJACENT TO IT, 0 IF NOT.
C FIPATH: STASIS # TO BE GIVEN TO FIGHTER IN THAT CITY
C FOUND: COMPLETION DATES FOR CITIES
C IADJST: SUBTRACTED FROM Z6 SO CURSOR WILL NOT BE MOVED OFF SCREEN
C IARROW: ADDED TO Z6 SO MOVES [1,2,3,4,5,6,7,8,9] ARE CONVERTED
C TO [+1,-99,-100,-101,ETC.]
C ISEC: SECTOR TERMINAL IS SHOWING
C IZAP: .TRUE.=SAVE GAME, .FALSE.=INITIALIZE
C JECTOR: SECTOR PROGRAM IS LOOKING AT
C KURSOR: SET TO POSITION OF CURSOR
C MODE: 1=IN MODE 2, 0=IN MODE 1
C OWNER: WHO OWNS THE CITY: 0>NOBODY, 1>PLAYER, 2>COMPUTER
C PASS: SET TO .TRUE. IF IT IS A PRIVILEGED USER
C PHASE: PHASE OF CITY
C X: LOCATIONS OF CITIES
C
do 100 j = beg + 1, beg + lim
k = rlmap ( j )
write ( 1 ) k
if ( num .lt. 9 ) write ( 1 ) mycode(j)
if ( num .gt. 8 ) write ( 1 ) codefu(j-1500),codela(j-1500)
if ( num .eq. 9 ) write ( 1 ) ar2s(j-1500)
if ( num .eq. 2 ) write ( 1 ) range(j-500)
if ( num .eq. 10 ) write ( 1 ) rang(j-2000)
100 continue
return
end
c
c Input-output routines using qio's
c Terminal dependent cursor addressing
c String manuplitation routines
c
c Modify routines ttinit, tpos, and clear for your terminal
c
ccc addint - convert integer to string
subroutine addint(num, string, ptr)
integer num
byte string(80)
integer ptr
c
c synopsis
c
c call addint(num, string, ptr)
c
c num - integer to convert to string
c string - byte array to put string into
c ptr - current length of string
c
parameter buf_size = 10
integer status, ots$cvt_l_ti, dsc(2)
byte junk(buf_size)
data dsc /buf_size, 0/
if (num .ne. 0) goto 100
ptr = ptr + 1
string(ptr) = '0'
goto 200
100 continue
dsc(2) = %loc(junk)
status = ots$cvt_l_ti(num, dsc, , %val(4), )
do 200 i = 1, buf_size
if (junk(i) .eq. ' ') goto 200
ptr = ptr + 1
string(ptr) = junk(i)
200 continue
string(ptr + 1) = 0
return
end
ccc addrel - convert real to string
subroutine addrel(num, width, string, ptr)
real num
integer width
byte string(80)
integer ptr
c
c synopsis
c
c call addrel(num, width, string, ptr)
c
c num - integer to convert to string
c width - width of digits to right of decimal point
c string - byte array to put string into
c ptr - current length of string
c
parameter buf_size = 20
integer status, for$cvt_d_tf, dsc(2)
byte junk(buf_size)
data dsc /buf_size, 0/
dsc(2) = %loc(junk)
status = for$cvt_d_tf(num, dsc, %val(width), , , , )
do 200 i = 1, buf_size
if (junk(i) .eq. ' ') goto 200
ptr = ptr + 1
string(ptr) = junk(i)
200 continue
if (string(ptr) .eq. '.') ptr = ptr - 1 ! remove trailing dot
string(ptr + 1) = 0
return
end
ccc addstr - copy one string onto another
subroutine addstr(one, two, ptr)
byte one(80), two(80)
integer ptr
c
c synopsis
c
c call addstr(one, two, ptr)
c
c one - string to add
c two - string to add onto
c ptr - current length of line
c
integer i
i = 1
100 continue
if (one(i) .eq. 0) return
ptr = ptr + 1
two(ptr) = one(i)
i = i + 1
goto 100
end
ccc bell - output a bell
subroutine bell
c
c synopsis
c
c call bell
c
call bufout(7, 1)
return
end
ccc bufout - output characters
subroutine bufout(string, count)
byte string(80)
integer count
c
c synopsis
c
c call bufout(string, count)
c
c string - byte array of characters
c count - number of chararcters to output
c
c
c Common terminal
c
parameter tt_bufsiz = 750 ! size of buffer in bytes
common /ioempire/ TT_VT52, TT_VT100,
$ TT_ANN, TT_HP, TT_ADM, TT_HZ15,
$ in_chan, out_chan, tt_nbuf, tt_type, tt_flag, tt_buf
integer TT_VT52, TT_VT100
integer TT_ANN, TT_HP, TT_ADM, TT_HZ15
integer in_chan ! input channel
integer out_chan ! output channel
integer tt_nbuf ! number of characters to output
integer tt_type ! terminal type
logical tt_flag ! flag for non-buffered i/o
byte tt_buf(tt_bufsiz) ! the buffer
integer i
if ((tt_bufsiz - 1 - tt_nbuf) .le. count) call flush
do 100 i = 1, count
tt_nbuf = tt_nbuf + 1
tt_buf(tt_nbuf) = string(i)
100 continue
if (tt_flag) call flush
return
end
ccc bufpos - position the cursor and output the buffer
subroutine bufpos(irow, icol, string, size)
integer irow, icol, size
byte string(80)
c
c synopsis
c
c irow - line to position cursor
c icol - column to position cursor
c string - byte array containing characters
c size - number of characters to output
c
call tpos(irow, icol)
call bufout(string, size)
return
end
ccc clear - clear screen
subroutine clear
c
c synopsis
c
c call clear
c
c
c Common terminal
c
parameter tt_bufsiz = 750 ! size of buffer in bytes
common /ioempire/ TT_VT52, TT_VT100,
$ TT_ANN, TT_HP, TT_ADM, TT_HZ15,
$ in_chan, out_chan, tt_nbuf, tt_type, tt_flag, tt_buf
integer TT_VT52, TT_VT100
integer TT_ANN, TT_HP, TT_ADM, TT_HZ15
integer in_chan ! input channel
integer out_chan ! output channel
integer tt_nbuf ! number of characters to output
integer tt_type ! terminal type
logical tt_flag ! flag for non-buffered i/o
byte tt_buf(tt_bufsiz) ! the buffer
byte admclr, annclr (3), vt52clr (4)
byte vt100clr (6), hz15clr(2)
data admclr /"32/
data annclr /"14, 0, 0/
data vt52clr /"33, 'H', "33, 'J'/
data vt100clr /"33, '[', 'H', "33, '[', 'J'/
data hz15clr /'~', "34/
if (tt_type .eq. TT_VT52) goto 1000
if (tt_type .eq. TT_ANN) goto 2000
if (tt_type .eq. TT_ADM) goto 3000
if (tt_type .eq. TT_VT100) goto 4000
if (tt_type .eq. TT_HP) goto 1000
if (tt_type .eq. TT_HZ15) goto 6000
c
c If we don't know the terminal, do nothing
c
return
c
c Handle vt52 and hp2621
c
1000 call bufout(vt52clr, 4)
return
c
c Handle ann arbor
c
2000 call bufout(annclr, 3)
return
c
c Handle adm 3a
c
3000 call bufout(admclr, 1)
return
c
c Handle vt100
c
4000 call bufout(vt100clr, 6)
return
c
c Handle Hazeltine 1500
c
6000 call bufout(hz15clr, 2)
return
end
ccc cr - output a carrige return and line feed
subroutine cr
c
c synopsis
c
c call cr
c
c Null characters are added for some terminals
c
c
c Common terminal
c
parameter tt_bufsiz = 750 ! size of buffer in bytes
common /ioempire/ TT_VT52, TT_VT100,
$ TT_ANN, TT_HP, TT_ADM, TT_HZ15,
$ in_chan, out_chan, tt_nbuf, tt_type, tt_flag, tt_buf
integer TT_VT52, TT_VT100
integer TT_ANN, TT_HP, TT_ADM, TT_HZ15
integer in_chan ! input channel
integer out_chan ! output channel
integer tt_nbuf ! number of characters to output
integer tt_type ! terminal type
logical tt_flag ! flag for non-buffered i/o
byte tt_buf(tt_bufsiz) ! the buffer
integer i
byte string(5)
data string /"15, "12, 0, 0, 0/
i = 2
if (tt_type .eq. TT_ANN) i = 5
call bufout(string, i)
return
end
ccc flush - output the output buffer
subroutine flush
c
c Common terminal
c
parameter tt_bufsiz = 750 ! size of buffer in bytes
common /ioempire/ TT_VT52, TT_VT100,
$ TT_ANN, TT_HP, TT_ADM, TT_HZ15,
$ in_chan, out_chan, tt_nbuf, tt_type, tt_flag, tt_buf
integer TT_VT52, TT_VT100
integer TT_ANN, TT_HP, TT_ADM, TT_HZ15
integer in_chan ! input channel
integer out_chan ! output channel
integer tt_nbuf ! number of characters to output
integer tt_type ! terminal type
logical tt_flag ! flag for non-buffered i/o
byte tt_buf(tt_bufsiz) ! the buffer
integer status, sys$qiow
external SS$_NORMAL, IO$_WRITEVBLK, IO$M_NOFORMAT
if (tt_nbuf .le. 0) return
status = sys$qiow( , %val(out_chan),
* %val(%loc(IO$_WRITEVBLK) .or. %loc(IO$M_NOFORMAT)),
* , , , tt_buf, %val(tt_nbuf), , %val(0), , )
tt_nbuf = 0
if (status .eq. %loc(SS$_NORMAL)) return
write(6, 10) status
10 format (' Error in flush; status is', z9)
return
end
ccc getc - input a single character
subroutine getc(char)
byte char
c
c synopsis
c
c call getc(char)
c
c char - character input
c
integer count
call flush
call getstr(char, 1, count)
return
end
ccc getcq - input a single character without echo
subroutine getcq(char)
byte char
c
c synopsis
c
c call getcq(char)
c
c char - character input
c
integer count
call flush
call getstrq(char, 1, count)
return
end
ccc getif - read a single character, if one is ready
subroutine getif(ch)
byte ch
c
c synopsis
c
c call getif(ch)
c
c ch - character
c
c If a character is available, it is returned. If a character is not,
c then -1 is returned.
c
c
c Common terminal
c
parameter tt_bufsiz = 750 ! size of buffer in bytes
common /ioempire/ TT_VT52, TT_VT100,
$ TT_ANN, TT_HP, TT_ADM, TT_HZ15,
$ in_chan, out_chan, tt_nbuf, tt_type, tt_flag, tt_buf
integer TT_VT52, TT_VT100
integer TT_ANN, TT_HP, TT_ADM, TT_HZ15
integer in_chan ! input channel
integer out_chan ! output channel
integer tt_nbuf ! number of characters to output
integer tt_type ! terminal type
logical tt_flag ! flag for non-buffered i/o
byte tt_buf(tt_bufsiz) ! the buffer
integer ierr, junk, sys$qiow, count
integer*2 iosb(4), status
byte tc
equivalence (status, iosb(1))
equivalence (tc, iosb(3))
external IO$_READVBLK, IO$M_TIMED, IO$M_NOECHO, IO$M_NOFILTR
external SS$_CONTROLY, SS$_NORMAL, SS$_TIMEOUT
call flush
junk = sys$qiow ( , %val (in_chan), %val(%loc(IO$_READVBLK) .or.
* %loc(IO$M_TIMED) .or. %loc(IO$M_NOECHO) .or. %loc(IO$M_NOFILTR)),
* iosb, , , ch, %val(1), %val(0), , , )
ierr = status
if (tc .ne. 0) ch = tc
if (ierr .eq. %loc(SS$_NORMAL)) return
if (ierr .eq. %loc(SS$_CONTROLY)) return
if (ierr .ne. %loc(SS$_TIMEOUT)) goto 900
ch = -1
return
900 write(6, 10) isw
10 format(' Error in getif; status is', z9)
return
end
ccc getstr - read characters from terminal
subroutine getstr(buffer, size, count)
byte buffer(80)
integer size, count
c
c synopsis
c
c call getstr(buffer, size, count)
c
c buffer - buffer to accept input
c size - length of this buffer
c count - number of characters read
c
c
c Common terminal
c
parameter tt_bufsiz = 750 ! size of buffer in bytes
common /ioempire/ TT_VT52, TT_VT100,
$ TT_ANN, TT_HP, TT_ADM, TT_HZ15,
$ in_chan, out_chan, tt_nbuf, tt_type, tt_flag, tt_buf
integer TT_VT52, TT_VT100
integer TT_ANN, TT_HP, TT_ADM, TT_HZ15
integer in_chan ! input channel
integer out_chan ! output channel
integer tt_nbuf ! number of characters to output
integer tt_type ! terminal type
logical tt_flag ! flag for non-buffered i/o
byte tt_buf(tt_bufsiz) ! the buffer
integer status, sys$qiow, junk
integer*2 iosb(4), ierr
byte tc
equivalence (ierr, iosb(1))
equivalence (tc, iosb(3))
external SS$_CONTROLY, SS$_NORMAL, IO$_READVBLK
call flush
junk = sys$qiow( , %val (in_chan), %val(%loc(IO$_READVBLK)),
* iosb, , , buffer, %val(size), , , , )
status = ierr
count = iosb(2)
if (tc .ne. 0) buffer(count + 1) = tc
if (count .eq. 0) count = 1
if (status .eq. %loc(SS$_NORMAL)) return
if (status .eq. %loc(SS$_CONTROLY)) return
900 write(6, 10) status, junk
10 format(' Error in getstr; status is', 2z9)
return
end
ccc getstrq - read characters from terminal without echo
subroutine getstrq(buffer, size, count)
byte buffer(80)
integer size, count
c
c synopsis
c
c call getstrq(buffer, size, count)
c
c buffer - buffer to accept input
c size - length of this buffer
c count - number of characters read
c
c
c Common terminal
c
parameter tt_bufsiz = 750 ! size of buffer in bytes
common /ioempire/ TT_VT52, TT_VT100,
$ TT_ANN, TT_HP, TT_ADM, TT_HZ15,
$ in_chan, out_chan, tt_nbuf, tt_type, tt_flag, tt_buf
integer TT_VT52, TT_VT100
integer TT_ANN, TT_HP, TT_ADM, TT_HZ15
integer in_chan ! input channel
integer out_chan ! output channel
integer tt_nbuf ! number of characters to output
integer tt_type ! terminal type
logical tt_flag ! flag for non-buffered i/o
byte tt_buf(tt_bufsiz) ! the buffer
integer status, sys$qiow, junk
integer*2 iosb(4), ierr
byte tc
equivalence (ierr, iosb(1))
equivalence (tc, iosb(3))
external IO$_READVBLK, IO$M_NOFILTR, IO$M_NOECHO
external SS$_CONTROLY, SS$_NORMAL
call flush
junk = sys$qiow ( , %val (in_chan), %val(%loc(IO$_READVBLK) .or.
* %loc(IO$M_NOFILTR) .or. %loc(IO$M_NOECHO)), iosb,
* , , buffer, %val(size), , , , )
status = ierr
count = iosb(2)
if (tc .ne. 0) buffer(count + 1) = tc
if (count .eq. 0) count = 1
if (status .eq. %loc(SS$_NORMAL)) return
if (status .eq. %loc(SS$_CONTROLY)) return
900 write(6, 10) status
10 format(' Error in getstrq; status is', z9)
return
end
ccc putc - output a single character
subroutine putc(char)
byte char
c
c synopsis
c
c call putc(char)
c
c char - character to output
c
call bufout(char, 1)
return
end
ccc strlen - return size of zero byte terminated string
integer function strlen(string)
byte string(80)
c
c synopsis
c
c status = strlen(string)
c
c status - size of string
c string - byte array terminated with a zero byte
c
integer i
i = 0
1000 i = i + 1
if (string(i) .ne. 0) goto 1000
strlen = i - 1
return
end
ccc strout - output a zero byte terminated string
subroutine strout(string)
byte string(80)
c
c synopsis
c
c call strout(string)
c
c string - a byte array with a zero byte terminator
c
integer i, strlen
i = strlen(string)
call bufout(string, i)
return
end
ccc strpos - position cursor and output string
subroutine strpos(irow, icol, string)
integer irow, icol
byte string(80)
c
c synopsis
c
c call strpos(irow, icol, string)
c
c irow - line to position cursor
c icol - column to position cursor
c string - a byte array with a zero byte terminator
c
integer strlen
call tpos(irow, icol)
call bufout(string, strlen(string))
return
end
ccc tpos - position cursor
subroutine tpos(irow, icol)
integer irow, icol
c
c synopsis
c
c call tpos(irow, icol)
c
c irow - line to position cursor
c icol - column to position cursor
c
c
c Common terminal
c
parameter tt_bufsiz = 750 ! size of buffer in bytes
common /ioempire/ TT_VT52, TT_VT100,
$ TT_ANN, TT_HP, TT_ADM, TT_HZ15,
$ in_chan, out_chan, tt_nbuf, tt_type, tt_flag, tt_buf
integer TT_VT52, TT_VT100
integer TT_ANN, TT_HP, TT_ADM, TT_HZ15
integer in_chan ! input channel
integer out_chan ! output channel
integer tt_nbuf ! number of characters to output
integer tt_type ! terminal type
logical tt_flag ! flag for non-buffered i/o
byte tt_buf(tt_bufsiz) ! the buffer
byte annv(3), admv(4), vt52v(4)
byte vt100v(11), vhp(11), hz15v(4)
data admv /"33, '=', 0, 0/
data annv /"17, 0, 0/
data vt52v /"33, 'Y', 0, 0/
data vt100v /"33, '[', 9*' '/
data vhp /"33, '&', 9*' '/
data hz15v /'~', "21, 0, 0/
if (tt_type .eq. TT_VT52) goto 1000
if (tt_type .eq. TT_ANN) goto 2000
if (tt_type .eq. TT_ADM) goto 3000
if (tt_type .eq. TT_VT100) goto 4000
if (tt_type .eq. TT_HP) goto 5000
if (tt_type .eq. TT_HZ15) goto 6000
c
c Simply return if we don't know the terminal type
c
return
c
c Handle vt52
c
1000 vt52v(3) = irow + 31
vt52v(4) = icol + 31
call bufout(vt52v, 4)
return
c
c Handle ann arbor
c
2000 annv(2) = icol - 1 + ((icol - 1) / 10 * 6)
annv(3) = irow + "77 + ((irow - 1) / 20 * 12)
call bufout(annv, 3)
return
c
c Handle adm 3a
c
3000 admv(3) = irow + 31
admv(4) = icol + 31
call bufout(admv, 4)
return
c
c Handle vt100
c
4000 i = 2
call addint(irow, vt100v, i)
i = i + 1
vt100v(i) = ';'
call addint(icol, vt100v, i)
i = i + 1
vt100v(i) = 'H'
call bufout(vt100v, i)
return
c
c Handle hp2621
c
5000 i = 1
call addint(irow, vhp, i)
i = i + 1
vhp(i) = ';'
call addint(icol, vhp, i)
i = i + 1
vhp(i) = 'a'
call bufout(vhp, i)
return
c
c Handle Hazeltine 1500
c
6000 hz15v(3) = icol
hz15v(4) = irow
call bufout(hz15v, 4)
return
end
ccc ttinit - initiliaze for i/o
subroutine ttinit
c
c synopsis
c
c call ttinit
c
c
c Common terminal
c
parameter tt_bufsiz = 750 ! size of buffer in bytes
common /ioempire/ TT_VT52, TT_VT100,
$ TT_ANN, TT_HP, TT_ADM, TT_HZ15,
$ in_chan, out_chan, tt_nbuf, tt_type, tt_flag, tt_buf
integer TT_VT52, TT_VT100
integer TT_ANN, TT_HP, TT_ADM, TT_HZ15
integer in_chan ! input channel
integer out_chan ! output channel
integer tt_nbuf ! number of characters to output
integer tt_type ! terminal type
logical tt_flag ! flag for non-buffered i/o
byte tt_buf(tt_bufsiz) ! the buffer
integer status, in_len, out_len
integer sys$assign, sys$trnlog, sys$getchn
integer*2 prilen
character*63 in_name, out_name
character*100 pribuf
byte info(8), iosb(8)
external SS$_NORMAL, SS$_NOTRAN
external TT$_VT52, TT$_VT100, TT$_FT1, TT$_FT2, TT$_FT3, TT$_FT4
c
c Figure out values for terminal types
c
TT_VT52 = %loc(TT$_VT52)
TT_VT100 = %loc(TT$_VT100)
TT_ANN = %loc(TT$_FT1)
TT_HP = %loc(TT$_FT2)
TT_ADM = %loc(TT$_FT3)
TT_HZ15 = %loc(TT$_FT4)
c
c Set default to do buffered i/o
c
tt_flag = .false.
c
c Translate device names for input and output
c
cc status = sys$trnlog('SYS$INPUT', in_len, in_name, , , )
cc if (status .eq. %loc(SS$_NOTRAN)) goto 100
cc status = sys$trnlog('SYS$OUTPUT', out_len, out_name, , , )
cc if (status .ne. %loc(SS$_NOTRAN)) goto 200
c
c Translation of sys$input or sys$output failed; translate 'TT' instead
c
100 continue
status = sys$trnlog('TT', in_len, in_name, , , )
out_name = in_name
out_len = in_len
c
c Now assign channels for input and output
c
200 continue
cc status = sys$assign(in_name(5:in_len), in_chan, , )
cc status = sys$assign(out_name(5:out_len), out_chan, , )
status = sys$assign(in_name, in_chan, , )
status = sys$assign(out_name, out_chan, , )
c
c Get terminal characteristics
c
status = sys$getchn(%val(out_chan), prilen, pribuf, , )
status = ichar(pribuf(6:6))
tt_type = -1
if (status .eq. TT_ADM) tt_type = TT_ADM
if (status .eq. TT_ANN) tt_type = TT_ANN
if (status .eq. TT_VT52) tt_type = TT_VT52
if (status .eq. TT_VT100) tt_type = TT_VT100
if (status .eq. TT_HZ15) tt_type = TT_HZ15
c
c Zero output buffer
c
tt_nbuf = 0
return
end
ccc ittype - return terminal type
subroutine ittype(term)
integer term
c
c synopsis
c
c call ittype(term)
c
c term - integer containing terminal type
c
c
c Common terminal
c
parameter tt_bufsiz = 750 ! size of buffer in bytes
common /ioempire/ TT_VT52, TT_VT100,
$ TT_ANN, TT_HP, TT_ADM, TT_HZ15,
$ in_chan, out_chan, tt_nbuf, tt_type, tt_flag, tt_buf
integer TT_VT52, TT_VT100
integer TT_ANN, TT_HP, TT_ADM, TT_HZ15
integer in_chan ! input channel
integer out_chan ! output channel
integer tt_nbuf ! number of characters to output
integer tt_type ! terminal type
logical tt_flag ! flag for non-buffered i/o
byte tt_buf(tt_bufsiz) ! the buffer
term = tt_type
return
end
ccc upper - convert string to upper case
subroutine tupper(string, leng)
byte string(80)
integer leng
c
c synopsis
c
c call upper(string, leng)
c
c string - byte array with string
c leng - length of the string
c
integer i
do 100 i = 1, leng
if ((string(i) .lt. 'a') .or. (string(i) .gt. 'z')) goto 100
string(i) = string(i) - "40
100 continue
return
end
SHAR_EOF
if test 290280 -ne "`wc -c < 'empire.for'`"
then
echo shar: error transmitting "'empire.for'" '(should have been 290280 characters)'
fi
fi # end of overwriting check
if test -f 'getnow.for'
then
echo shar: will not over-write existing file "'getnow.for'"
else
cat << \SHAR_EOF > 'getnow.for'
subroutine getnow ( now )
implicit none
integer now(7)
integer i, status, sys$numtim
integer*2 vmsnow(7)
status = sys$numtim ( vmsnow, )
i = 1
23000 if (.not.(i .le. 6))goto 23002
now(i) = vmsnow(i)
23001 i = i + 1
goto 23000
23002 continue
now(7) = vmsnow(7) * 10
return
end
SHAR_EOF
if test 349 -ne "`wc -c < 'getnow.for'`"
then
echo shar: error transmitting "'getnow.for'" '(should have been 349 characters)'
fi
fi # end of overwriting check
if test -f 'link.com'
then
echo shar: will not over-write existing file "'link.com'"
else
cat << \SHAR_EOF > 'link.com'
$ del empire.exe;*
$ link empire,rndlb,getnow
SHAR_EOF
if test 46 -ne "`wc -c < 'link.com'`"
then
echo shar: error transmitting "'link.com'" '(should have been 46 characters)'
fi
fi # end of overwriting check
if test -f 'rndlb.for'
then
echo shar: will not over-write existing file "'rndlb.for'"
else
cat << \SHAR_EOF > 'rndlb.for'
subroutine rndseq ( value, multiplier, increment, modulus )
integer*4 value, multiplier, increment, modulus
value = mod ( value * multiplier + increment, modulus )
return
end
subroutine rndini ( seed1, seed2 )
integer seed1, seed2
integer idx
integer now(7)
integer*4 value1, value2, mult1, mult2, inc1, inc2, modu1, modu2,
*table
common /rndcom/ value1, value2, mult1, mult2, inc1, inc2,modu1,
*modu2, table(200)
mult1 = 1541
inc1 = 3501
modu1 = 16384
mult2 = 5146
inc2 = 4100
modu2 = 19683
call getnow ( now )
if (.not.( seed1 .ne. 0 ))goto 23000
value1 = seed1
goto 23001
23000 continue
value1 = ( ( now(3) * 10 + now(4) ) * 10 + now(5) ) * 10 + now(6)
23001 continue
value1 = mod ( value1, modu1 )
if (.not.( seed2 .ne. 0 ))goto 23002
value2 = seed2
goto 23003
23002 continue
value2 = ( ( now(6) * 10 + now(5) ) * 10 + now(4) ) * 10 + now(3)
23003 continue
value2 = mod ( value2, modu2 )
idx=1
23004 if (.not.(idx .le. 200))goto 23006
call rndseq ( value2, mult2, inc2, modu2 )
table(idx) = value2
23005 idx=idx+1
goto 23004
23006 continue
return
end
real function rnd ( dummy )
integer dummy
integer idx
integer*4 value1, value2, mult1, mult2, inc1, inc2, modu1, modu2,
*table
common /rndcom/ value1, value2, mult1, mult2, inc1, inc2,modu1,
*modu2, table(200)
call rndseq ( value1, mult1, inc1, modu1 )
idx = ifix ( float(value1) / float(modu1) * 200 ) + 1
rnd = float(table(idx)) / float(modu2)
call rndseq ( value2, mult2, inc2, modu2 )
table(idx) = value2
return
end
real function rnduni ( rlow, rhigh )
real rlow, rhigh
real rnd
rnduni = rnd(0) * (rhigh-rlow) + rlow
return
end
integer function rndint ( ilow, ihigh )
integer ilow, ihigh
real rnd
rndint = ifix ( rnd(0) * float(ihigh-ilow+1) ) + ilow
return
end
real function rndnor ( mean, stddev )
real mean, stddev
real rnd, v1, v2, z
23007 continue
v1 = -alog(1.0-rnd(0))
v2 = -alog(1.0-rnd(0))
23008 if (.not.( 2.0*v1 .ge. (v2-1.0)**2 ))goto 23007
23009 continue
if (.not.( rnd(0) .gt. 0.5 ))goto 23010
z = 1.0
goto 23011
23010 continue
z = -1.0
23011 continue
rndnor = stddev * z * v2 + mean
return
end
real function rndexp ( mean )
real mean
real rnd
rndexp = - alog ( 1.0 - rnd(0) ) * mean
return
end
real function rndchi ( v )
integer v
integer k, x
real rndexp, rndnor
k = v / 2
rndchi = 0.0
x=1
23012 if (.not.(x .le. k))goto 23014
rndchi = rndchi + rndexp ( 1.0 )
23013 x=x+1
goto 23012
23014 continue
rndchi = rndchi * 2.0
if (.not.( k * 2 + 1 .eq. v ))goto 23015
rndchi = rndchi + rndnor(0.0,1.0)**2
23015 continue
return
end
real function rndbta ( v1, v2 )
integer v1, v2
real y1, y2, rndchi
y1 = rndchi ( v1 )
y2 = rndchi ( v2 )
rndbta = y1 / (y1+y2)
return
end
real function rndF ( v1, v2 )
integer v1, v2
real y1, y2, rndchi
y1 = rndchi ( v1 )
y2 = rndchi ( v2 )
rndF = (y1*v2) / (y2*v1)
return
end
real function rndt ( v )
integer v
real y1, y2, rndnor, rndchi
y1 = rndnor ( 0.0, 1.0 )
y2 = rndchi ( v )
rndt = y1 / sqrt ( y2/v )
return
end
integer function rndgeo ( prob )
real prob
real rnd
if (.not.( prob .lt. 0.0 .or. prob .gt. 1.0 ))goto 23017
rndgeo = 0
goto 23018
23017 continue
if (.not.( prob .eq. 1.0 ))goto 23019
rndgeo = 1
goto 23020
23019 continue
rndgeo = aint ( alog(1.0-rnd(0)) / alog(1.0-prob) + 0.999999 )
23020 continue
23018 continue
return
end
integer function rndbin ( trials, prob )
integer trials
real prob
integer i
real rnd
rndbin = 0
i=1
23021 if (.not.(i .le. trials))goto 23023
if (.not.( rnd(0) .le. prob ))goto 23024
rndbin = rndbin + 1
23024 continue
23022 i=i+1
goto 23021
23023 continue
return
end
integer function rndpoi ( mean )
real mean
real p, q, rnd
p = exp ( -mean )
rndpoi = 0
q = 1.0
23026 continue
q = q * rnd(0)
if (.not.( q .lt. p ))goto 23029
goto 23028
23029 continue
rndpoi = rndpoi + 1
23027 goto 23026
23028 continue
return
end
SHAR_EOF
if test 4685 -ne "`wc -c < 'rndlb.for'`"
then
echo shar: error transmitting "'rndlb.for'" '(should have been 4685 characters)'
fi
fi # end of overwriting check
cd ..
# End of shell archive
exit 0