github.com/kenrector.sigma-cpv-kit
1
0
Fork 0
mirror of synced 2026-02-23 15:53:53 +00:00
Code Issues Packages Projects Releases Wiki Activity

Add files via upload

Browse Source
This commit is contained in:
ken rector
2025-01-24 16:24:06 -08:00
committed by GitHub
parent 64bac16375
commit 280baad068
67 changed files with 7051 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

84
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRABANDON.FOR Normal file
View File

@@ -0,0 +1,84 @@
SUBROUTINE ABANDON
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 ISHIP
EQUIVALENCE(ISHIP,SHIP)
IF(DAMAGE(10)) 5,15,10
5 IF(DAMAGE(10) .EQ. -1.) GO TO 6
CALL PROUT(36HSHUTTLE CRAFT NOW SERVING BIG MAC'S.,36)
RETURN
6 CALL PROUT(38HYE FAERIE QUEENE HAS NO SHUTTLE CRAFT.,38)
RETURN
10 CALL PROUT(22HSHUTTLE CRAFT DAMAGED.,22)
RETURN
15 IF((LANDED .NE. 1) .AND. (ICRAFT .NE. 1)) GO TO 16
CALL PROUT(34HYOU MUST BE ABOARD THE ENTERPRISE. ,34)
RETURN
16 IF(ISCRAFT .EQ. 1) GO TO 17
CALL PROUT(38HSHUTTLE CRAFT NOT CURRENTLY AVAILABLE. ,38)
RETURN
C--------PRINT ABANDON SHIP MESSAGES
17 CALL SKIP(1)
CALL PROUT(31H***ABANDON SHIP! ABANDON SHIP!,31)
CALL PROUT(26H***ALL HANDS ABANDON SHIP!,26)
CALL SKIP(1)
CALL PROUT(
+ 41HCAPTAIN AND CREW ESCAPE IN SHUTTLE CRAFT.,41)
CALL PROUT(
+ 41HREMAINDER OF SHIP'S COMPLEMENT BEAM DOWN ,41)
CALL PROUT(
+ 28HTO NEAREST HABITABLE PLANET.,28)
C--------IF THERE ARE NO STARBASES LEFT, GAME IS OVER
IF(REMBASE .NE. 0) GO TO 20
CALL FINISH(9)
RETURN
C--------IF THERE IS AT LEAST ONE BASE LEFT, YOU GET THE FAERIE QUEENE
20 CALL SKIP(1)
CALL PROUT(
+ 44HYOU ARE CAPTURED BY KLINGONS AND RELEASED TO,44)
CALL PROUT(
+ 45HTHE FEDERATION IN A PRISONER-OF-WAR EXCHANGE.,45)
CALL PROUT(
+ 46HSTARFLEET PUTS YOU IN COMMAND OF ANOTHER SHIP,,46)
CALL PROUT(42HTHE FAERIE QUEENE, WHICH IS ANTIQUATED BUT,42)
CALL PROUT(14HSTILL USEABLE.,14)
C--------SELECT BASE AT WHICH TO BEGIN AGAIN
NB=RANF(0)*REMBASE+1
C--------RESET FLAGS.
ICRYSTL=0
IMINE=0
ISCATE=0
C--------SET UP QUADRANT AND POSITION F. Q. ADJACENT TO BASE
QUADX=BASEQX(NB)
QUADY=BASEQY(NB)
40 SECTX=5
SECTY=5
CALL NEWQUAD
QUAD(SECTX,SECTY)=IHDOT
DO 50 L=1,3
SECTX=3.0*RANF(0)-1.0+BASEX
IF(SECTX .LT. 1 .OR. SECTX .GT. 10) GO TO 50
SECTY=3.0*RANF(0)-1.0+BASEY
IF(SECTY .LT. 1 .OR. SECTY .GT. 10) GO TO 50
IF(QUAD(SECTX,SECTY) .EQ. IHDOT) GO TO 60
50 CONTINUE
GO TO 40
60 ISHIP=IHF
QUAD(SECTX,SECTY)=IHF
C--------CLEAR AND RESUPPLY SHIP
CONDIT=IHDOCKD
DO 70 L=1,NDEVICE
70 DAMAGE(L)=0
DAMAGE(10)=-1
INENRG=3000.0
ENERGY=3000.0
INSHLD=1250.
SHLD=1250.0
INTORPS=6
TORPS=6
INLSR=3.0
LSUPRES=3.0
SHLDUP=0
WARPFAC=5.0
WFACSQ=25.0
RETURN
END

91
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRATTACK.FOR Normal file
View File

@@ -0,0 +1,91 @@
SUBROUTINE ATTACK
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 IQUAD
INTEGER PERCENT
EQUIVALENCE (CRACKS(1),HIT),(CRACKS(3),IHURT),(CRACKS(4),L)
EQUIVALENCE (CRACKS(6),KDIDIT)
EQUIVALENCE (KSTUF(1),ITHERE),(KSTUF(2),ITHX),(KSTUF(3),ITHY)
IF(ALLDONE.NE.0) RETURN
IF(ITHERE.NE.0) CALL MOVETHO
IF(NEUTZ .EQ. 0) GO TO 1
NEUTZ=0
RETURN
1 IF((((COMHERE.NE.0) .OR. (ISHERE.NE.0)).AND.(JUSTIN.EQ.0)).OR.
1(KSTUF(5).EQ.2
+ )) CALL MOVECOM
IF(NENHERE.EQ. 0) RETURN
IHURT=0
CALL SKIP(1)
C--------ALLOW EACH KLINGON IN TURN TO DO HIS DAMNEDEST
HITMAX=0.0
HITTOT=0.0
ATTCKD=0
C--------LOOP FOR ENEMY ATTACKS STARTS HERE
L=0
5 L=L+1
IF(L .GT. NENHERE) GO TO 80
C--------IF ENTERPRISE IS DOCKED DON'T HIT IT.
IF(CONDIT.NE.IHDOCKD) GO TO 6
CALL CRAM(
+41HENEMIES ATTACK, STARBASE SHIELDS PROTECT )
CALL CRAMSHP
CALL CREND
CALL SKIP(1)
RETURN
C--------IF KPOWER IS LT ZERO THEN ENEMY CAN'T ATTACK.
6 IF(KPOWER(L) .LT. 0)GO TO 5
ATTCKD=1
C--------COMPUTE HIT STRENGTH AND DIMINISH SHIELD POWER
DUSTFAC=0.80+0.05*RANF(0)
HIT=KPOWER(L)*DUSTFAC**KDIST(L)
II=KX(L)
JJ=KY(L)
IQUAD=QUAD(II,JJ)
C--------DECIDE IF ENEMY SHOULD FIRE PHOTON TORPEDO
IF(HIT .GT. 400.0 .OR. JUSTIN .EQ. 1) GO TO 10
IF(HIT .GT. 300.0 .AND. KDIST(L) .GT. 5.0) GO TO 10
IF(IQUAD .EQ. IHK .AND. RANF(0) .GT. 0.10) GO TO 10
C--------ENEMY FIRES PHOTON TORPEDO.
IPHWHO=1
CALL KPHOTON
IPHWHO=IHGREEN
KDIDIT=1
IF(ALLDONE .EQ. 1 .OR. GALAXY(QUADX,QUADY) .EQ. 1000) RETURN
GO TO 5
C--------ENEMIES FIRE PHASER-LIKE WEAPONS
10 CALL ZAP
HITTOT=HITTOT+HIT
HITMAX=AMAX1(HITMAX,HIT)
C--------LOOP FOR ENEMY ATTACKS ENDS HERE
GO TO 5
80 IF(ATTCKD .EQ. 0 .OR. HITTOT .EQ. 0.0) RETURN
IF(ENERGY .LE. 0) GO TO 100
PERCENT=100.0*SHLD/INSHLD + 0.5
IF(IHURT.NE.0)GO TO 85
C--------PRINT MESSAGE IF SHIELDS FULLY PROTECTED STARSHIP
CALL CRAM(35HENEMIES ATTACK--SHIELDS REDUCED TO )
GO TO 90
C--------PRINT MESSAGE IF STARSHIP ITSELF SUFFERED HITS
85 CALL SKIP(1)
CALL CRAM(12HENERGY LEFT )
CALL CRAMF(ENERGY,0,2)
CALL CRAM(19H TORPEDOES LEFT )
CALL CRAMI(TORPS,0)
CALL CRAM(12H SHIELDS )
IF(SHLDUP.NE.0) CALL CRAM(4HUP, )
IF(SHLDUP .EQ. 0 .AND. DAMAGE(8) .EQ. 0) CALL CRAM(6HDOWN, )
IF(DAMAGE(8) .GT. 0) CALL CRAM(9HDAMAGED, )
90 CALL CRAMI(PERCENT,0)
CALL CRAMDMP(1H%)
C--------CHECK IF ANYONE WAS HURT
IF(HITMAX.LT.200.0 .AND. HITTOT.LT.500.0) GO TO 120
HIT=HITTOT
CALL CASULTY
GO TO 120
C--------RETURNING HOME UPON YOUR SHIELD, NOT WITH IT...
100 CALL FINISH(5)
RETURN
C--------AFTER ATTACK, SORT OUT ENEMIES
120 CALL SORTKL
RETURN
END

87
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRAUTOVER.FOR Normal file
View File

@@ -0,0 +1,87 @@
SUBROUTINE AUTOVER
C
C 23-APR-79
C CHANGE 'INSUFFICIENT ENERGY' MESSAGE TO ONE WHICH IS
C APPROPRIATE FOR ALL CASES.
C
INCLUDE 'TREKCOM/NOLIST'
II=16
IGRAB=0
GO TO 5
C*
ENTRY GRAB
C*
IGRAB=1
II=14
C--------CHECK TO SEE IF CAPTAIN ON A PLANET
5 IF(LANDED .NE. 1) GO TO 45
IF(DAMAGE(12) .GT. 0) GO TO 25
CALL PROUT(42HSCOTTY RUSHES TO THE TRANSPORTER CONTROLS.,42)
IF(SHLDUP .EQ. 0) GO TO 20
CALL PROUT(38HBUT WITH THE SHIELDS UP IT'S HOPELESS.,8)
GO TO 25
20 CALL CRAM(42HHIS DESPERATE ATTEMPT TO RESCUE YOU . . . )
IF(RANF(0) .GT. 0.5) GO TO 30
CALL CRAMDMP(6HFAILS. )
25 CALL FINISH(II)
RETURN
30 CALL CRAMDMP(9HSUCCEEDS!)
IF(IMINE .EQ. 0) GO TO 45
IMINE=0
CALL CRAM(24HTHE CRYSTALS MINED WERE )
IF(RANF(0) .GT. 0.25) GO TO 40
CALL CRAMDMP(5HLOST.)
GO TO 45
40 CALL CRAMDMP(6HSAVED.)
ICRYSTL=1
45 IF(IGRAB.NE.0) RETURN
C--------CHECK TO SEE IF CAPTAIN IN SHUTTLE CRAFT
IF(ICRAFT.NE.0) CALL FINISH(17)
IF(ALLDONE.NE.0) RETURN
C--------INFORM CAPTAIN OF ATTEMPT TO REACH SAFETY
CALL SKIP(1)
IF(JUSTIN .EQ. 0) GO TO 50
47 CALL REDALRT
CALL CRAM(7H***THE )
CALL CRAMSHP
CALL CRAMDMP(37H HAS STOPPED IN A QUADRANT CONTAINING)
CALL PROUT(15H A SUPERNOVA.,2)
CALL SKIP(1)
50 CALL CRAM(49H***EMERGENCY AUTOMATIC OVERRIDE ATTEMPTS TO HURL )
CALL CRAMSHP
CALL CREND
CALL PROUT(23HSAFELY OUT OF QUADRANT.,23)
STARCH(QUADX,QUADY)=1
C--------TRY TO USE WARP ENGINES
IF(DAMAGE(6) .EQ. 0) GO TO 100
CALL SKIP(1)
CALL PROUT(21HWARP ENGINES DAMAGED.,21)
CALL FINISH(8)
RETURN
100 WARPFAC=6.0+2.0*RANF(0)
WFACSQ=WARPFAC*WARPFAC
CALL CRAM(19HWARP FACTOR SET TO )
CALL CRAMF(WARPFAC,0,1)
CALL CREND
POWER=0.75*ENERGY
DISTMAX=POWER/(WARPFAC*WARPFAC*WARPFAC*(SHLDUP+1))
DISTREQ=1.4142+2.0*RANF(0)
DIST=AMIN1(DISTMAX,DISTREQ)
TIME=10.0*DIST/WFACSQ
DIREC=12.0*RANF(0)
JUSTIN=0
INORBIT=0
CALL WARPX
IF(ALLDONE.NE.0) RETURN
IF(JUSTIN.NE.0) GO TO 200
CALL SKIP(1)
CALL CRAM('***')
CALL CRAMSHP
CALL CRAMDMP(' FAILS TO LEAVE QUADRANT.')
CALL FINISH(8)
RETURN
C--------REPEAT OVERRIDE IF SHIP JUMPED FROM ONE SUPERNOVA TO ANOTHER
200 IF(GALAXY(QUADX,QUADY) .EQ. 1000) GO TO 47
IF(REMKL .EQ. 0) CALL FINISH(1)
RETURN
END

11
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRCANTA.FOR Normal file
View File

@@ -0,0 +1,11 @@
SUBROUTINE CANTA
C
C 23-OCT-79 (NEW ROUTINE)
C CANCELS TYPEAHEAD AT THE TERMINAL
C
CALL SYS$ASSIGN('TT',ICHAN,,)
CALL SYS$QIOW(,%VAL(ICHAN),%VAL('0831'X),,,,
1 DUMMY,%VAL(0),,,,)
CALL SYS$DASSGN(%VAL(ICHAN))
RETURN
END

31
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRCHART.FOR Normal file
View File

@@ -0,0 +1,31 @@
SUBROUTINE CHART
INCLUDE 'TREKCOM/NOLIST'
CALL PROUT(31HSTAR CHART FOR THE KNOWN GALAXY,31)
CALL SKIP(1)
CALL PROUT(42H 1 2 3 4 5 6 7 8,42)
CALL PROUT(44H ----------------------------------------,44)
CALL PROUT(3H :,3)
DO 50 I=1,8
CALL CRAMI(I,1)
CALL CRAM(2H :)
DO 40 J=1,8
IF(STARCH(I,J)) 10,20,30
10 CALL CRAM(5H .1.)
GO TO 40
20 CALL CRAM(5H ...)
GO TO 40
30 IF(STARCH(I,J) .GT. 999) GO TO 35
CALL CRAMI(GALAXY(I,J),5)
GO TO 40
35 CALL CRAMI(STARCH(I,J)-1000,5)
40 CONTINUE
CALL CREND
CALL PROUT(3H :,3)
50 CONTINUE
CALL SKIP(1)
CALL CRAMSHP
CALL CRAM(16H IS CURRENTLY IN)
CALL CRAMLOC(1,QUADX,QUADY)
CALL CREND
RETURN
END

108
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRCHOOSE.FOR Normal file
View File

@@ -0,0 +1,108 @@
SUBROUTINE CHOOSE(FROZEN)
C
C 25-APR-79
C USE THE SYSTEM SERVICE SYS$GETTIM FOR THE RANDOM NUMBER SEED.
C THIS GREATLY REDUCES DEPENDENCE OF THE SEED ON TIME OF DAY.
C
INCLUDE 'TREKCOM/NOLIST'
COMMON/SCANBF/KEY,AITEM
INTEGER*4 ISEED(2)
LOGICAL FROZEN
LOGICAL CROP
REAL*8 AITEM,REGULAR,TOURNAMENT,FROZN,SHORT,MEDIUM,LONG
1 ,NOVICE,FAIR,GOOD,EMERITUS,EXPERT,RHBLANK
EQUIVALENCE (AITEM,TNUMBER)
DATA REGULAR,TOURNAMENT,FROZN/7HREGULAR,8HTOURNAME,6HFROZEN/
DATA SHORT,MEDIUM,LONG/5HSHORT,6HMEDIUM,4HLONG/
DATA NOVICE,FAIR,GOOD,EXPERT/6HNOVICE,4HFAIR,4HGOOD,6HEXPERT/
DATA EMERITUS,RHBLANK/8HEMERITUS,1H /
TNUMBER = 0.
PASSWD = RHBLANK
ALLDONE=0
GAMEWON=0
CALL SYS$GETTIM(ISEED)
CALL RANSET(ISEED(1))
IPHWHO=0
5 FROZEN = .FALSE.
C--------ASK FOR PARAMETERS OF GAME, PREFERABLY ALL ON ONE LINE
CALL PROMPT(
+54HWOULD YOU LIKE A REGULAR, TOURNAMENT, OR FROZEN GAME? ,54)
CALL SCAN
IF(CROP(AITEM,REGULAR)) GO TO 9
IF(CROP(AITEM,TOURNAMENT)) GO TO 100
IF(CROP(AITEM,FROZN)) GO TO 200
GO TO 5
9 SKILL=0
LENGTH=0
10 CALL SCAN
IF(KEY .NE. IHALPHA) GO TO 20
C--------CHECK FOR DIFFERENT KINDS OF GAMES
KSTUF(5)=0
IF(CROP(AITEM,SHORT)) LENGTH=1
IF(CROP(AITEM,MEDIUM)) LENGTH=2
IF(CROP(AITEM,LONG)) LENGTH=4
IF(CROP(AITEM,NOVICE)) SKILL=1
IF(CROP(AITEM,FAIR)) SKILL=2
IF(CROP(AITEM,GOOD)) SKILL=3
IF(CROP(AITEM,EXPERT)) SKILL=4
IF(CROP(AITEM,EMERITUS)) SKILL=5
IF(SKILL.EQ.4) KSTUF(5)=1
IF(SKILL.EQ.5) KSTUF(5)=2
IF(LENGTH*SKILL .EQ. 0) GO TO 10
GO TO 30
20 IF(LENGTH .NE. 0) GO TO 25
CALL PROMPT(45HWOULD YOU LIKE A SHORT, MEDIUM OR LONG GAME? ,45)
GO TO 10
25 IF(SKILL .NE. 0) GO TO 30
CALL PROMPT(48HARE YOU NOVICE, FAIR, GOOD, EXPERT OR EMERITUS?
1 ,48)
GO TO 10
C--------READ IN SECRET PASSWORD
30 CALL SCAN
PASSWD=AITEM
IF(KEY .NE. IHEOL) GO TO 40
CALL PROMPT(33HPLEASE TYPE IN A SECRET PASSWORD:,33)
GO TO 30
40 CONTINUE
C--------USE PARAMETERS TO GENERATE INITIAL VALUES OF THINGS
DAMFAC=0.50*SKILL
REMBASE=3.0*RANF(0)+2.0
INPLAN=5. +6.*RANF(0)
NROMREM=(2.+RANF(0))*SKILL
NSCREM=SKILL/3
REMTIME=7.0*LENGTH
INTIME=REMTIME
RATE=(SKILL-2.0*RANF(0)+1.0)*SKILL*0.1 + 0.15
REMKL=2.0*RATE*INTIME
INKLING=REMKL
INCOM=SKILL+0.0625*INKLING*RANF(0)
INCOM=MIN0(10,INCOM)
REMCOM=INCOM
REMRES=(INKLING+4* INCOM )*INTIME
INRESOR=REMRES
IF(INKLING.GT.50) REMBASE=REMBASE+1
INBASE=REMBASE
RETURN
C--------PROCESS A TOURNAMENT REQUEST
100 CALL SCAN
CALL RANSET(ABS(TNUMBER))
THINGX=-1
C--------GO BACK FOR ANYTHING LEFT OUT
IF (KEY.NE.IHEOL) GO TO 9
CALL PROMPT(37HTYPE IN NAME OR NUMBER OF TOURNAMENT: ,37)
GO TO 100
C--------PROCESS A REQUEST FOR A FROZEN GAME
200 CALL THAW
C--------MAKE SURE WE GOT A GAME OUT OF THAW
IF(PASSWD.EQ.0.D0) GO TO 5
FROZEN = .TRUE.
C--------DESTROY ANY "THINGS" IN FROZEN GAME.
THINGX=0
THINGY=0
DO 210 I=1,10
DO 210 J=1,10
210 IF(QUAD(I,J) .EQ. IHQUEST) QUAD(I,J)=IHDOT
C--------RESET PLAQUE STATUS
ICITE=0
RETURN
END

125
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRCRAM.FOR Normal file
View File

@@ -0,0 +1,125 @@
SUBROUTINE CRAM(M)
COMMON/PRLUN/LUN
BYTE M(1)
C--------<M> IS AN ARRAY CONTAINING CHARACTERS LJZF. BYTES ARE PUT
C--------INTO THE OUTPUT BUFFER UP TO THE FIRST 00B BYTE.
BYTE LINE(120)
DATA LINE/120*0/,ICH/1/
K=80
GO TO 11
C*
ENTRY CRAMS(M,IK)
C*
K=IK
11 IDUMP=0
5 ICHX=0
C--------GET THE NEXT CHARACTER OF <M>
10 ICHX=ICHX+1
IF (ICHX.GT.K) GOTO 21
KHAR=M(ICHX)
C--------PUT IT IN BUFFER
IF(KHAR .EQ. 0) GO TO 21
LINE(ICH)=KHAR
ICH=ICH+1
IF(ICH.GT.120) GOTO 25
IF((ICH.GT.72).AND.(LUN.EQ.1)) GOTO 25
GO TO 10
C*
ENTRY CRENDNO
C--------DUMP BUFFER AND SUPPRESS LINE FEED
CALL PROMPT (LINE,ICH)
GOTO 27
C*
ENTRY CRAMDMP (M)
C--------INSERT FINAL ENTRY AND DUMP BUFFER
K=80
GO TO 22
C*
ENTRY CRMDPS(M,IK)
K=IK
22 IDUMP=1
GO TO 5
21 IF(IDUMP.EQ. 0) RETURN
ENTRY CREND
C--------DUMP BUFFER AND GO TO NEW LINE
25 CALL PROUT(LINE,ICH)
27 DO 30 L=1,ICH
30 LINE(L)=0
ICH=1
RETURN
END
SUBROUTINE CRAMF(XX,W,D)
BYTE CF(10),CS(10)
INTEGER*4 I
INTEGER W,D
NEG=0
DO 5 N=1,10
5 CF(N)=0
X=XX
IF(X .GE. 0) GO TO 10
X=-XX
NEG=1
10 N=0
IF(D .EQ. 0) GO TO 30
C--------CONVERT FRACTIONAL PART TO ASCII
I=X*10**D+.5
DO 20 N=1,D
J=MOD(I,10)
CF(N)=1H0+J
20 I=I/10
C--------INSERT DECIMAL POINT
N=D+1
CF(N)=1H.
C--------CONVERT INTEGRAL PART TO ASCII
30 J=MOD(I,10)
N=N+1
CF(N)=1H0+J
I=I/10
IF(I .NE. 0) GO TO 30
C--------INSERT MINUS SIGN IF NEEDED
IF(NEG .EQ. 0) GO TO 40
N=N+1
CF(N)=1H-
C--------PAD WITH BLANKS TO TOTAL OF <W> CHARACTERS
40 IF(N .GE. W .OR. N .GE. 9) GO TO 43
N=N+1
CF(N)=1H
GO TO 40
43 DO 45 I=1,N
45 CS(I)=CF(N-I+1)
CS(N+1)=0
50 CALL CRAM(CS)
RETURN
END
SUBROUTINE CRAMI(II,W)
BYTE CI(10),CS(10)
INTEGER W
I=II
NEG=0
IF(I .GE. 0) GO TO 10
I=-II
NEG=1
C--------CONVERT THE NUMBER ITSELF TO ASCII
10 DO 15 N=1,10
15 CI(N)=0
N=0
20 J=MOD(I,10)
N=N+1
CI(N)=1H0+J
I=I/10
IF(I .NE. 0) GO TO 20
C--------INSERT MINUS SIGN IF NEEDED
30 IF(NEG .EQ. 0) GO TO 40
N=N+1
CI(N)=1H-
C--------PAD WITH BLANKS TO TOTAL OF <W> CHARACTERS
40 IF(N .GE. W .OR. N .GE. 9) GO TO 43
N=N+1
CI(N)=1H
GO TO 40
43 DO 45 I=1,N
45 CS(I)=CI(N-I+1)
CS(N+1)=0
CALL CRAM(CS)
RETURN
END

39
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRCRAMEN.FOR Normal file
View File

@@ -0,0 +1,39 @@
SUBROUTINE CRAMEN(II)
ENTRY CRAMENA(II)
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 II
IF(II .EQ. IHR) GO TO 10
IF(II .EQ. IHK) GO TO 20
IF(II .EQ. IHC) GO TO 30
IF(II .EQ. IHS) GO TO 40
IF(II .EQ. IHSTAR) GO TO 50
IF(II .EQ. IHP) GO TO 60
IF(II .EQ. IHB) GO TO 70
IF(II .EQ. '@') GO TO 80
IF(II .EQ. IHT) GO TO 85
IF(II-2) 90,100,110
10 CALL CRAM(7HROMULAN)
RETURN
20 CALL CRAM(7HKLINGON)
RETURN
30 CALL CRAM(9HCOMMANDER)
RETURN
40 CALL CRAM(15HSUPER-COMMANDER)
RETURN
50 CALL CRAM(4HSTAR)
RETURN
60 CALL CRAM(6HPLANET)
RETURN
70 CALL CRAM(8HSTARBASE)
RETURN
80 CALL CRAM(10HBLACK HOLE)
RETURN
85 CALL CRAM(7HTHOLIAN)
RETURN
90 CALL CRAM(1HM)
RETURN
100 CALL CRAM(1HN)
RETURN
110 CALL CRAM(1HO)
RETURN
END

9
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRCRAMLOC.FOR Normal file
View File

@@ -0,0 +1,9 @@
SUBROUTINE CRAMLOC(KEY,IX,IY)
IF(KEY .EQ. 1) CALL CRAM(9H QUADRANT)
IF(KEY .EQ. 2) CALL CRAM(7H SECTOR)
CALL CRAM(1H )
CALL CRAMI(IX,0)
CALL CRAM(3H - )
CALL CRAMI(IY,0)
RETURN
END

101
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRCRAMSHP.FOR Normal file
View File

@@ -0,0 +1,101 @@
SUBROUTINE CRAMSHP
INCLUDE 'TREKCOM/NOLIST'
BYTE ISHIP,ESC,BELLS(16)
EQUIVALENCE(CRACKS(1),HIT),(CRACKS(5),IESC) ,(SHIP,ISHIP)
EQUIVALENCE (IESC,ESC)
DATA BELLS/7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7/
IF(ISHIP .EQ. IHE) CALL CRAM(10HENTERPRISE)
IF(SHIP .EQ. IHF) CALL CRAM(13HFAERIE QUEENE)
RETURN
C*
ENTRY CRAM3AS
C*
CALL CRAM(3H***)
RETURN
C*
ENTRY STARS
C*
CALL PROUT(
+ 54H******************************************************,54)
RETURN
C*
ENTRY REDALRT
C*
C-------RING THE BELL BEFORE THE RED ALERT
CALL PROUT(BELLS,16)
CALL PROUT(25H***RED ALERT! RED ALERT!,25)
RETURN
C*
ENTRY BEGPARD
C*
CALL PROUT(27H BEG YOUR PARDON, CAPTAIN? ,27)
RETURN
C*
ENTRY MANORA
C*
CALL PROMPT(26HMANUAL OR AUTOMATIC? ,26)
RETURN
C*
ENTRY CASULTY
C*
ICAS=HIT*RANF(0)*0.015
IF(ICAS .LT. 2) RETURN
CASUAL=CASUAL+ICAS
CALL CRAM(42HMC COY: "SICKBAY TO BRIDGE. WE JUST HAD )
CALL CRAMI(ICAS,0)
CALL CRAMDMP(13H CASUALTIES.")
RETURN
C*
ENTRY RESETD
C*
CALL NEWCOND
IF(NENHERE .EQ. 0) RETURN
DO 10 L=1,NENHERE
10 KDIST(L)=SQRT( FLOAT((SECTX-KX(L))**2 +(SECTY-KY(L))**2))
RETURN
C*
ENTRY LEAVE
C*
KX(IESC)=KX(NENHERE)
KY(IESC)=KY(NENHERE)
KDIST(IESC)=KDIST(NENHERE)
KPOWER(IESC)=KPOWER(NENHERE)
KLHERE=KLHERE-1
NENHERE=NENHERE-1
IF(CONDIT .NE. IHDOCKD )CALL NEWCOND
RETURN
C*
ENTRY SOS
C*
C-------- IESC PASSES WHICH KIND OF COMMANDER IS ATTACKING
IF(ESC .EQ. IHS) GO TO 20
ICSOS=0
IF(DAMAGE(9) .GT. 0) RETURN
ICSOS=1
IX=BATX
IY=BATY
DDAY=FUTURE(5)
GO TO 30
20 ISSOS=0
IF(DAMAGE(9) .GT. 0) RETURN
ISSOS=1
IX=ISX
IY=ISY
DDAY=FUTURE(7)
30 CALL SKIP(1)
CALL CRAM(37HLT. UHURA: "CAPTAIN, THE STARBASE IN)
CALL CRAMLOC(1,IX,IY)
CALL CREND
CALL CRAM(22H REPORTS IT IS UNDER )
CALL CRAMEN(ESC)
CALL CRAMDMP(8H ATTACK.)
CALL CRAM(32H IT CAN SURVIVE UNTIL STARDATE )
CALL CRAMF(DDAY ,0,1)
CALL CRAMDMP(3H .")
IF(RESTING .EQ. 0) RETURN
CALL SKIP(1)
CALL PROMPT(55HMR. SPOCK: CAPTAIN, SHALL WE CANCEL THE REST PERIOD
1? ,55)
IF(JA(DUMMY)) RESTING=0
RETURN
END

29
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRCRAMSP.FOR Normal file
View File

@@ -0,0 +1,29 @@
SUBROUTINE CRAMSP(NUM,STRING)
C
C 3-MAY-79 (NEW ROUTINE)
C CRAM SINGULAR OR PLURAL
C CRAMSP CRAMS THE INTEGER NUMBER 'NUM', FOLLOWED BY THE ASCII STRING
C 'STRING', FOLLOWED BY AN 'S' IF NUM .NE. 1.
C
BYTE STRING(80),SEND(10),PEND(10)
C
CALL CRAMI(NUM,0)
CALL CRAM(' ')
CALL CRAM(STRING)
IF(NUM.NE.1)CALL CRAM('S')
RETURN
C
ENTRY CRAMSPI(NUM,STRING,SEND,PEND)
C
C CRAM SINGULAR OR PLURAL IRREGULAR
C CRAMSPI CRAMS THE INTEGER NUMBER 'NUM', FOLLOWED BY THE ASCII STRING
C 'STRING', FOLLOWED BY THE STRING 'SEND' IF NUM .EQ. 1, OR THE
C STRING 'PEND' IF NUM .NE. 1.
C
CALL CRAMI(NUM,0)
CALL CRAM(' ')
CALL CRAM(STRING)
IF(NUM.EQ.1)CALL CRAM(SEND)
IF(NUM.NE.1)CALL CRAM(PEND)
RETURN
END

11
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRCRMSENA.FOR Normal file
View File

@@ -0,0 +1,11 @@
SUBROUTINE CRMSENA(II,JJ,KK,LL)
LOGICAL*1 II
CALL CRAM3AS
C*
ENTRY CRMENA
C*
CALL CRAMEN(II)
CALL CRAM(3H AT)
CALL CRAMLOC(JJ,KK,LL)
RETURN
END

12
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRCROP.FOR Normal file
View File

@@ -0,0 +1,12 @@
INTEGER FUNCTION CROP(ITEM,COMMAND)
BYTE ITEM(8),COMMAND(8),IT
CROP = .FALSE.
IF (ITEM(1).NE.COMMAND(1)) RETURN
DO 1 I=2,8
IT=ITEM(I)
IF (IT.EQ.' '.OR.IT.EQ.0) GO TO 2
IF (IT.NE.COMMAND(I)) RETURN
1 CONTINUE
2 CROP = .TRUE.
RETURN
END

72
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRDEADKL.FOR Normal file
View File

@@ -0,0 +1,72 @@
SUBROUTINE DEADKL(IX,IY,TYPE,IXX,IYY)
INCLUDE 'TREKCOM/NOLIST'
EQUIVALENCE (KSTUF(1),ITHERE)
BYTE TYPE
CALL CRMSENA(TYPE,2,IXX,IYY)
C--------DECIDE WHAT KIND OF ENEMY IT IS, AND UPDATE APPROPRIATELY
IF(TYPE .EQ. IHT) GO TO 30
IF(TYPE .EQ. IHR) GO TO 27
GALAXY(QUADX,QUADY)=GALAXY(QUADX,QUADY)-100
KLHERE=KLHERE-1
REMKL=REMKL-1
IF(TYPE .EQ. IHK) GO TO 25
IF(TYPE .EQ. IHS) GO TO 26
C--------CHALK UP A COMMANDER
COMHERE=0
DO 10 I=1,REMCOM
IF(CX(I) .EQ. QUADX .AND. CY(I) .EQ. QUADY)GO TO 15
10 CONTINUE
15 CX(I)=CX(REMCOM)
CY(I)=CY(REMCOM)
CX(REMCOM)=0
CY(REMCOM)=0
REMCOM=REMCOM-1
FUTURE(2)=1E38
IF(REMCOM.GT.0) FUTURE(2)=DATE+EXPRAN(FLOAT(INCOM/REMCOM))
KILLC=KILLC+1
GO TO 30
C--------CHALK UP AN ORDINARY KLINGON
25 KILLK=KILLK+1
GO TO 30
C--------CHALK UP THE (GULP) <SUPER-COMMANDER>.
26 NSCREM=0
ISHERE=0
ISX=0
ISY=0
NSCKILL=1
ISATB=0
ISCATE=0
FUTURE(6)=1E38
FUTURE(7)=1E38
GO TO 30
C--------CHALK UP A ROMULAN.
27 NEWSTUF(QUADX,QUADY)=NEWSTUF(QUADX,QUADY) -10
IRHERE=IRHERE-1
NROMKL=NROMKL+1
NROMREM=NROMREM-1
C--------FOR EACH KIND OF ENEMY, FINISH MESSAGE TO PLAYER
30 CALL CRAMDMP(12H DESTROYED. )
QUAD(IX,IY)=IHDOT
IF(REMKL .EQ. 0) RETURN
REMTIME=REMRES/(REMKL+4*REMCOM)
C-------IF ENEMY IS A THOLIAN, SET ITHERE=0 AND RETURN
IF(TYPE.EQ.IHT) ITHERE=0
IF(TYPE.EQ.IHT) RETURN
C--------REMOVE ENEMY SHIP FROM ARRAYS DESCRIBING LOCAL CONDITIONS
DO 40 I=1,NENHERE
IF(KX(I) .EQ. IX .AND. KY(I) .EQ. IY)GO TO 45
40 CONTINUE
45 NENHERE=NENHERE-1
IF(I .GT. NENHERE) GO TO 55
DO 50 J=I,NENHERE
KX(J)=KX(J+1)
KY(J)=KY(J+1)
KPOWER(J)=KPOWER(J+1)
50 KDIST(J)=KDIST(J+1)
55 KX(NENHERE+1)=0
KY(NENHERE+1)=0
KDIST(NENHERE+1)=0
KPOWER(NENHERE+1)=0
RETURN
END

57
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRDESTRCT.FOR Normal file
View File

@@ -0,0 +1,57 @@
SUBROUTINE DESTRCT
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 ISHIP
REAL*8 IPASS,AITEM
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE(SHIP,ISHIP)
IF(DAMAGE(11) .EQ. 0) GO TO 5
CALL PROUT(
+ 51HCOMPUTER DAMAGED; CANNOT EXECUTE DESTRUCT SEQUENCE.,51)
RETURN
5 CALL SKIP(1)
CALL PROUT(13H---WORKING---,13)
CALL PROUT(24HIDENTIFICATION-POSITIVE;,24)
CALL PROUT(32HSELF-DESTRUCT-SEQUENCE-ACTIVATED,32)
CALL PROUT( 5H 10,5)
CALL PROUT( 8H 9,8)
CALL PROUT(11H 8,11)
CALL PROUT(14H 7,14)
CALL PROUT(17H 6,17)
CALL PROUT(35HENTER-CORRECT-PASSWORD-TO-CONTINUE-,35)
CALL PROUT(33HSELF-DESTRUCT-SEQUENCE-OTHERWISE-,33)
CALL PROMPT(40HSELF-DESTRUCT-SEQUENCE-WILL-BE-ABORTED: ,40)
CALL SCAN
IF(AITEM .NE. PASSWD) GO TO 30
CALL PROUT(17HPASSWORD-ACCEPTED,17)
CALL PROUT(11H 5,11)
CALL PROUT(14H 4,14)
CALL PROUT(17H 3,17)
CALL PROUT(20H 2,20)
CALL PROUT(23H 1,23)
IF(RANF(0) .LT. 0.05) CALL PROUT(19HGOODBYE-CRUEL-WORLD,19)
CALL SKIP(2)
C*
ENTRY KABOOM
C*
CALL STARS
IF(ISHIP .EQ. IHE) CALL CRAM3AS
CALL CRAM(21H********* ENTROPY OF )
CALL CRAMSHP
CALL CRAMDMP(20H MAXIMIZED *********)
CALL STARS
CALL SKIP(1)
IF(NENHERE .EQ. 0) GO TO 20
WHAMMO=25.0*ENERGY
DO 10 L=1,NENHERE
IF(KPOWER(L)*KDIST(L) .GT. WHAMMO) GOTO 10
II=KX(1) !DEADKL SORTS THE KX AND KY ARRAYS AND
JJ=KY(1) !REDUCES THE SIZE
CALL DEADKL(II,JJ,QUAD(II,JJ),II,JJ)
10 CONTINUE
20 CALL FINISH(10)
RETURN
30 CALL PROUT(18HPASSWORD-REJECTED;,18)
CALL PROUT(19HCONTINUITY-EFFECTED,19)
CALL SKIP(2)
RETURN
END

23
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRDOCK.FOR Normal file
View File

@@ -0,0 +1,23 @@
SUBROUTINE DOCK
INCLUDE 'TREKCOM/NOLIST'
IDIDIT=0
IF(CONDIT .EQ. IHDOCKD) GO TO 30
IF(INORBIT.NE.0) GO TO 40
IF(BASEX .EQ. 0) GO TO 5
IF(IABS(SECTX-BASEX).LE.1 .AND. IABS(SECTY-BASEY).LE.1)GO TO 10
5 CALL CRAMSHP
CALL CRAMDMP(22H NOT ADJACENT TO BASE.)
RETURN
10 CONDIT = IHDOCKD
CALL PROUT(7HDOCKED.,7)
IDIDIT=1
IF(ENERGY .LT. INENRG) ENERGY=INENRG
SHLD=INSHLD
TORPS=INTORPS
LSUPRES=INLSR
RETURN
30 CALL PROUT(15HALREADY DOCKED.,15)
RETURN
40 CALL PROUT(36HYOU MUST FIRST LEAVE STANDARD ORBIT.,36)
RETURN
END

21
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRDREPORT.FOR Normal file
View File

@@ -0,0 +1,21 @@
SUBROUTINE DREPORT
INCLUDE 'TREKCOM/NOLIST'
INTEGER HDEVICE(40),NAME(2)
JDAM=0
DO 20 L=1,NDEVICE
IF(DAMAGE(L) .LE. 0) GO TO 20
IF(JDAM .NE. 0) GO TO 10
CALL SKIP(1)
CALL PROUT(35HDEVICE -REPAIR TIMES-,35)
CALL PROUT(37H IN FLIGHT DOCKED,37)
JDAM=1
10 CALL CRAM(2H )
CALL CRAMS(DEVICE(2*L-1,1),16)
IF(L.NE.14) CALL CRAMF(DAMAGE(L)+0.005,5,2)
IF(L.EQ.14) CALL CRAM(5H - )
CALL CRAMF(DOCKFAC*DAMAGE(L)+0.005,10,2)
CALL CREND
20 CONTINUE
IF(JDAM .EQ. 0) CALL PROUT(23HALL DEVICES FUNCTIONAL.,23)
RETURN
END

7
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRDROPIN.FOR Normal file
View File

@@ -0,0 +1,7 @@
SUBROUTINE DROPIN(IQUAD,IX,IY)
INCLUDE 'TREKCOM/NOLIST'
10 CALL IRAN10(IX,IY)
IF(QUAD(IX,IY) .NE. IHDOT) GO TO 10
QUAD(IX,IY)=IQUAD
RETURN
END

121
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TREKBLD.COM Normal file
View File

@@ -0,0 +1,121 @@
$TSTLOG=F$TRNLNM("LNK$LIBRARY")
$IF TSTLOG .NES. "" THEN DEASSIGN LNK$LIBRARY
$TSTLOG=F$TRNLNM("LNK$LIBRARY_1")
$IF TSTLOG .NES. "" THEN DEASSIGN LNK$LIBRARY_1
$TSTLOG=F$TRNLNM("LNK$LIBRARY_2")
$IF TSTLOG .NES. "" THEN DEASSIGN LNK$LIBRARY_2
$! TREKBLD.COM
$!
$! COMMAND PROCEDURE TO BUILD STARTREK
$!
$SET NOON
$INQ D "DO YOU WANT TO BUILD A DEBUGGING VERSION?"
$DEBUGC:==""
$DEBUGL:=""
$IF D THEN DEBUGC:=="/DEBUG=ALL"
$IF D THEN DEBUGL:="/DEBUG"
$INQ C "DO YOU WANT A CROSS-REFERENCE?"
$CREF:=""
$IF C THEN CREF:="/CROSS"
$COMPOK==1
$BLAB==1
$INQ C "DO YOU WANT TO COMPILE ANYTHING?"
$IF .NOT.C THEN GOTO LINK
$INQ C "DO YOU WANT TO COMPILE EVERYTHING?"
$IF .NOT.C THEN GOTO COMPSOME
$!
$@TREKCOM TRABANDON
$@TREKCOM TRATTACK
$@TREKCOM TRAUTOVER
$@TREKCOM TRCANTA
$@TREKCOM TRCHART
$@TREKCOM TRCHOOSE
$@TREKCOM TRCRAM
$@TREKCOM TRCRAMEN
$@TREKCOM TRCRAMLOC
$@TREKCOM TRCRAMSHP
$@TREKCOM TRCRAMSP
$@TREKCOM TRCRMSENA
$@TREKCOM TRCROP
$@TREKCOM TRDEADKL
$@TREKCOM TRDESTRCT
$@TREKCOM TRDOCK
$@TREKCOM TRDREPORT
$@TREKCOM TRDROPIN
$@TREKCOM TREMEXIT
$@TREKCOM TREVENTS
$@TREKCOM TREXPRAN
$@TREKCOM TRFINISH
$@TREKCOM TRFREEZE
$@TREKCOM TRGETCD
$@TREKCOM TRGETFN
$@TREKCOM TRGETOUT
$@TREKCOM TRHELP
$@TREKCOM TRHITEM
$@TREKCOM TRIMPULSE
$@TREKCOM TRIRAN8
$@TREKCOM TRJA
$@TREKCOM TRLRSCAN
$@TREKCOM TRMOVE
$@TREKCOM TRMOVECOM
$@TREKCOM TRMOVETHO
$@TREKCOM TRNEWCOND
$@TREKCOM TRNEWQUAD
$@TREKCOM TRNOVA
$@TREKCOM TRPHASERS
$@TREKCOM TRPHOTONS
$@TREKCOM TRPLANET
$@TREKCOM TRPLAQUE
$@TREKCOM TRPRELIM
$@TREKCOM TRPROUT
$@TREKCOM TRRAM
$@TREKCOM TRRANF
$@TREKCOM TRSCAN
$@TREKCOM TRSCOM
$@TREKCOM TRSCORE
$@TREKCOM TRSETUP
$@TREKCOM TRSETWARP
$@TREKCOM TRSHIELDS
$@TREKCOM TRSKIP
$@TREKCOM TRSNOVA
$@TREKCOM TRSORTKL
$@TREKCOM TRSRSCAN
$@TREKCOM TRTREK
$@TREKCOM TRTHAW
$@TREKCOM TRTIMEWRP
$@TREKCOM TRWAIT
$@TREKCOM TRWARP
$@TREKCOM TRZAP
$GOTO LINK
$!
$COMPSOME:
$BLAB==0
$INQ M "TYPE MODULE TO COMPILE, OR RETURN TO LINK"
$IF M.EQS."" THEN GOTO LINK
$@TREKCOM TR'M'
$GOTO COMPSOME
$!
$LINK:
$IF .NOT.COMPOK THEN GOTO QUIT
$IF BLAB THEN WRITE SYS$OUTPUT "Linking..."
$DEL TREK.EXE;*
$DEL TREK.MAP;*
$LINK/MAP=TREK/EXEC=TREK'DEBUGL''CREF' -
TRABANDON+ TRATTACK+ TRAUTOVER+ TRCANTA+-
TRCHART+ TRCHOOSE+ TRCRAM+ TRCRAMEN+-
TRCRAMLOC+ TRCRAMSHP+ TRCRAMSP+ TRCRMSENA+-
TRCROP+ TRDEADKL+ TRDESTRCT+ TRDOCK+-
TRDREPORT+ TRDROPIN+ TREMEXIT+ TREVENTS+-
TREXPRAN+ TRFINISH+ TRFREEZE+ TRGETCD+-
TRGETFN+ TRGETOUT+ TRHELP+ TRHITEM+-
TRIMPULSE+ TRIRAN8+ TRJA+ TRLRSCAN+-
TRMOVE+ TRMOVECOM+ TRMOVETHO+ TRNEWCOND+-
TRNEWQUAD+ TRNOVA+ TRPHASERS+ TRPHOTONS+-
TRPLANET+ TRPLAQUE+ TRPRELIM+ TRPROUT+-
TRRAM+ TRRANF+ TRSCAN+ TRSCOM+-
TRSCORE+ TRSETUP+ TRSETWARP+ TRSHIELDS+-
TRSKIP+ TRSNOVA+ TRSORTKL+ TRSRSCAN+-
TRTREK+ TRTHAW+ TRTIMEWRP+ TRWAIT+-
TRWARP+ TRZAP
$!
$QUIT:

14
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TREKCOM.COM Normal file
View File

@@ -0,0 +1,14 @@
$! TREKCOM.COM
$!
$! COMPILE A STARTREK MODULE (OR ANY MODULE, FOR THAT MATTER)
$!
$SET NOON
$IF BLAB THEN WRITE SYS$OUTPUT "Compiling ''P1'"
$ASSIGN/USER NL: SYS$OUTPUT
$ASSIGN/USER NL: SYS$ERROR
$DELETE 'P1'.OBJ;*
$ASSIGN/USER NL: SYS$OUTPUT
$ASSIGN/USER NL: SYS$ERROR
$DELETE 'P1'.LIS;*
$FORTRAN/LIST/NOCHECK'DEBUGC' 'P1'
$COMPOK==COMPOK.AND.$STATUS

61
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TREKCOM.FOR Normal file
View File

@@ -0,0 +1,61 @@
C
C TREKCOM.FOR INCLUDE FILE TO DEFINE COMMONS FOR STARTREK
C
C 26-APR-79
C
C BLANK COMMON; THIS IS THE GLOBAL DATABASE FOR STARTREK,
C AND CONTAINS ALL INFORMATION NECESSARY TO DETERMINE THE
C STATE OF THE GAME.
C
C THE PARAMETER COMSIZE DEFINES THE SIZE OF THE COMMON
C IN STORAGE ELEMENTS. IT MAY NEED TO BE CHANGED IF THINGS ARE
C ADDED TO THE COMMON IN ORDER TO MAKE FREEZE AND THAW
C WORK PROPERLY. ALWAYS MAKE SURE THAT THE SIZE OF THE
C ARRAY ICOM IS THE SAME AS THE SIZE OF BLANK COMMON.
C IF THEY ARE NOT THE SAME SIZE, CHANGE COMSIZE APPROPRIATELY.
C
PARAMETER COMSIZE=1222
C
COMMON SNAP,SNAPSHT(226),
1 DATE,REMKL,REMCOM,REMBASE,REMRES,REMTIME,STARKL,BASEKL,
2 KILLK,KILLC,GALAXY(8,8),CX(10),CY(10),BASEQX(5),BASEQY(5),
3 NEWSTUF(8,8),PLNETS(10,5),ISX,ISY,NSCREM,NROMKL,NROMREM,
4 NSCKILL,ICRYSTL,NPLANKL,
5 QUAD(10,10),KX(20),KY(20),KPOWER(20),KDIST(20),KSTUF(20),
6 INKLING,INBASE,INRESOR,INCOM,INTIME,INSTAR,INENRG,INSHLD,
7 INTORPS,INLSR,INDATE,ENERGY,SHLD,SHLDUP,CONDIT,TORPS,SHIP,
8 QUADX,QUADY,SECTX,SECTY,WARPFAC,WFACSQ,LSUPRES,DAMAGE(20),
9 LENGTH,SKILL,PASSWD,DIST,DIREC,TIME,BASEX,BASEY,DOCKFAC,
1 KLHERE,COMHERE,CASUAL,NHELP,NKINKS,STARCH(8,8),FUTURE(10),
2 DEVICE(2,14),IDIDIT,GAMEWON,ALIVE,JUSTIN,RESTING,ALLDONE,
3 DAMFAC,SHLDCHG,THINGX,THINGY,NDEVICE,PLNETX,PLNETY,INORBIT,
4 LANDED,IPLANET,IMINE,INPLAN,NENHERE,ISHERE,NEUTZ,IRHERE,ICRAFT,
5 IENTESC,ISCRAFT,ISATB,ISCATE,CRYPROB,ICITE,IPHWHO,BATX,BATY,
6 CRACKS(12),
7 ICSOS,ISSOS,ISUBDAM
INTEGER SHLDUP,CONDIT,QUADX,QUADY,SECTX,SECTY,TORPS,
1 REMKL,REMBASE,SKILL,REMCOM,GALAXY,STARCH,CX,CY,
2 SHIP,ALLDONE,BASEQX,BASEQY,BASEX,BASEY,GAMEWON,
3 ALIVE,STARKL,BASEKL,CASUAL,COMHERE,RESTING,SNAP,SHLDCHG,
4 THINGX,THINGY,BATX,BATY,PLNETX,PLNETY,PLNETS
REAL KDIST,KPOWER,LSUPRES,INTIME,INRESOR,INDATE,INSHLD,
1 INENRG,INLSR
BYTE QUAD
REAL*8 DEVICE,PASSWD
C
C ICOM IS AN ARRAY THAT ENCOMPASSES THE ENTIRE COMMON. IT IS
C USED TO FREEZE AND THAW GAMES.
C
INTEGER ICOM(COMSIZE)
EQUIVALENCE (ICOM,SNAP)
C
C COMMON HOLLER; THIS COMMON CONTAINS FREQUENTLY USED CHARACTERS
C AND TEXT STRINGS. THEIR VALUES ARE DEFINED BY DATA STATEMENTS
C IN THE MODULE STARTRK.
C
LOGICAL*1 IHS,IHR,IHC,IHK,IHE,IHF,IHBLANK,IHDOT,IHP,IHB,
1 IHSTAR,IHT,IHQUEST,IHNUM
COMMON/HOLLER/IHEOL,IHREAL,IHALPHA,IHS,IHR,IHC,IHK,IHGREEN,IHRED,
1 IHYELLO,IHDOCKD,IHE,IHF,IHBLANK,IHDOT,IHQUEST,IHP,IHSTAR,IHB,
2 IHT,IHNUM
C

15
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TREMEXIT.FOR Normal file
View File

@@ -0,0 +1,15 @@
SUBROUTINE EMEXIT
C
C 13-APR-79 (NEW ROUTINE)
C EMERGENCY EXIT - FREEZE THE GAME ON 'EMSAVE.TRK', ERASE THE
C SCREEN, AND BUG OUT.
C
INCLUDE 'TREKCOM/NOLIST'
CALL CLOSE(2)
OPEN(UNIT=2,NAME='SYS$DISK:EMSAVE.TRK',TYPE='UNKNOWN',
1 FORM='UNFORMATTED',ERR=920)
WRITE(2,ERR=920) COMSIZE,ICOM
CALL CLOSE(2)
920 CALL GETOUT
RETURN
END

226
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TREVENTS.FOR Normal file
View File

@@ -0,0 +1,226 @@
SUBROUTINE EVENTS
C
C 23-OCT-79
C CANCEL TYPEAHEAD WHEN A TRACTOR BEAM OCCURS
C
INCLUDE 'TREKCOM/NOLIST'
DIMENSION PICTURE(226)
EQUIVALENCE (PICTURE,DATE),(CRACKS(5),ITYPE)
DATA NEVENTS/7/
ICTBEAM=0
ISTRACT=0
C--------SELECT EARLIEST EXTRANEOUS EVENT (LINE=0 IF NO EVENTS)
10 LINE=0
IF(ALLDONE.NE.0) RETURN
DATEMIN=DATE+TIME
DO 20 L=1,NEVENTS
IF(FUTURE(L) .GT. DATEMIN) GO TO 20
LINE=L
DATEMIN=FUTURE(L)
20 CONTINUE
XTIME=DATEMIN-DATE
DATE=DATEMIN
C--------DECREMENT FEDERATION RESOURCES AND RECOMPUTE REMAINING TIME
REMRES=REMRES-(REMKL+4*REMCOM)*XTIME
REMTIME=REMRES/(REMKL+4*REMCOM)
IF(REMTIME .GT. 0) GO TO 30
C--------FEDERATION RESOURCES DEPLETED; END
CALL FINISH(2)
RETURN
C--------DECIDE IF LIFE SUPPORT IS ADEQUATE
30 IF(DAMAGE(5).EQ.0 .OR. CONDIT.EQ.IHDOCKD ) GO TO 50
IF(LSUPRES .GE. XTIME .OR. DAMAGE(5) .LE. LSUPRES) GO TO 40
CALL FINISH(3)
RETURN
40 LSUPRES=LSUPRES-XTIME
IF(DAMAGE(5) .LE. XTIME) LSUPRES=INLSR
C--------FIX DEVICES
50 REPAIR=XTIME
IF(CONDIT .EQ. IHDOCKD ) REPAIR=XTIME/DOCKFAC
DO 60 L=1,NDEVICE
IF(L.EQ.14) GO TO 60
IF(DAMAGE(L) .GT. 0) DAMAGE(L)=AMAX1(DAMAGE(L)-REPAIR,0.0)
60 CONTINUE
C--------CAUSE EXTRANEOUS EVENT [<LINE>] TO OCCUR
TIME=TIME-XTIME
IF(LINE .EQ. 0) GO TO 5000
GO TO (100,200,300,400,500,600,700),LINE
C--------EXTRANEOUS EVENT 1: SUPERNOVA
100 CALL SNOVA(0,0)
FUTURE(1)=DATE+EXPRAN(0.5*INTIME)
IF(GALAXY(QUADX,QUADY) .EQ. 1000) RETURN
GO TO 10
C--------EXTRANEOUS EVENT 2: TRACTOR BEAM
200 IF(REMCOM .EQ. 0) GO TO 220
IF(ISTRACT.NE.0) GO TO 210
IF(CONDIT .EQ. IHDOCKD ) GO TO 210
I=RANF(0)*REMCOM+1.0
YANK=(CX(I)-QUADX)**2 + (CY(I)-QUADY)**2
IF(YANK .EQ. 0 .AND. JUSTIN .EQ. 0) GO TO 210
IF(ISTRACT .EQ. 0) GO TO 201
20010 YANK=(ISX-QUADX)**2+(ISY-QUADY)**2
201 YANK=SQRT(YANK)
YNKRATE=7.5
TIME=(10.0/YNKRATE**2)*YANK
ICTBEAM=1
CALL SKIP(1)
CALL CRAM3AS
CALL CRAMSHP
CALL CRAMDMP(36H CAUGHT IN LONG-RANGE TRACTOR BEAM--)
C--------IF KIRK AND CO. SCREWING AROUND ON PLANET, HANDLE.
CALL GRAB
IF(ALLDONE.NE.0) RETURN
C--------HANDLE CASE WHERE KIRK IS IN SHUTTLE CRAFT.
IF(ICRAFT .NE. 1) GO TO 203
CALL FINISH(18)
RETURN
C--------CHECK TO SEE IF SHUTTLE IS ABOARD.
203 IF(ISCRAFT .NE. 0) GO TO 204
CALL SKIP(1)
CALL PROUT(48HGALILEO, LEFT ON THE PLANET SURFACE, IS CAPTURED,48)
CALL PROUT(45HBY ALIENS AND MADE INTO A FLYING MC DONALD'S.,45)
DAMAGE(10)=-10.
ISCRAFT=-1
204 IF(ISTRACT .EQ. 0) GO TO 205
QUADX=ISX
QUADY=ISY
GO TO 206
205 QUADX=CX(I)
QUADY=CY(I)
206 CALL IRAN10(SECTX,SECTY)
CALL CRAM(12H PULLED TO)
CALL CRAMLOC(1,QUADX,QUADY)
CALL CRAM(2H, )
CALL CRAMLOC(2,SECTX,SECTY)
CALL CREND
IF(RESTING .NE. 0) CALL PROUT(
+ 46H(REMAINDER OF REST & REPAIR PERIOD CANCELLED.),46)
RESTING=0
CALL CANTA
IF(SHLDUP.NE.0) GO TO 208
IF(DAMAGE(8).EQ.0 .AND. SHLD.GT.0) GO TO 207
CALL PROUT(32H(SHIELDS NOT CURRENTLY USEABLE.),32)
GO TO 208
207 CALL SHLDSUP
SHLDCHG=0
208 CALL NEWQUAD
IF(REMCOM .LE. 0) GO TO 220
210 FUTURE(2)=DATE+TIME+EXPRAN(1.5*INTIME/REMCOM)
GO TO 10
220 FUTURE(2)=1E38
GO TO 10
C--------EXTRANEOUS EVENT 3: SNAPSHOT OF UNIVERSE (FOR TIME WARP)
300 DO 310 L=1,226
310 SNAPSHT(L)=PICTURE(L)
SNAP=1
FUTURE(3)=DATE+EXPRAN(0.5*INTIME)
GO TO 10
C--------EXTRANEOUS EVENT 4: COMMANDER ATTACKS STARBASE
C--------LOOK FOR A COMMANDER IN SAME QUADRANT AS A STARBASE
400 IF(REMCOM.GT.0 .AND. REMBASE.GT.0) GO TO 410
FUTURE(4)=1E38
FUTURE(5)=1E38
GO TO 10
410 DO 420 J=1,REMBASE
DO 420 K=1,REMCOM
IF( (BASEQX(J).EQ.CX(K) .AND. BASEQY(J).EQ.CY(K)) .AND.
+ (BASEQX(J).NE.QUADX .OR. BASEQY(J).NE.QUADY) .AND.
+ (BASEQX(J).NE.ISX .OR. BASEQY(J).NE.ISY) ) GO TO 430
420 CONTINUE
FUTURE(4)=DATE+EXPRAN(0.3*INTIME)
FUTURE(5)=1E38
GO TO 10
C--------COMMANDER+STARBASE COMBINATION FOUND--LAUNCH ATTACK
430 BATX=BASEQX(J)
BATY=BASEQY(J)
FUTURE(5)=DATE+1.0+3.0*RANF(0)
IF(ISATB.NE.0) FUTURE(5)=FUTURE(5)+FUTURE(7)-DATE
FUTURE(4)=FUTURE(5)+EXPRAN(0.3*INTIME)
ITYPE=IHC
CALL SOS
GO TO 10
C--------EXTRANEOUS EVENT 5: COMMANDER SUCCEEDS IN DESTROYING BASE
500 FUTURE(5)=1E38
502 IF(ISATB.NE.2) GO TO 505
IF(MOD(GALAXY(ISX,ISY),100) .LT. 10) RETURN
IXHOLD=BATX
IYHOLD=BATY
BATX=ISX
BATY=ISY
GO TO 520
505 IF(REMCOM.EQ.0 .OR. REMBASE.EQ.0) GO TO 515
IF(MOD(GALAXY(BATX,BATY),100) .LT. 10) GO TO 515
DO 510 I=1,REMCOM
IF(CX(I).EQ.BATX .AND. CY(I).EQ.BATY) GO TO 520
510 CONTINUE
515 BATX=0
BATY=0
GO TO 10
520 IF(STARCH(BATX,BATY) .EQ. -1) STARCH(BATX,BATY)=0
IF(STARCH(BATX,BATY) .GT. 999)
+ STARCH(BATX,BATY)=STARCH(BATX,BATY)-10
C--------HANDLE CASE WHERE BASE IS IN SAME QUADRANT AS STARSHIP
IF(BATX.NE.QUADX .OR. BATY.NE.QUADY) GO TO 545
QUAD(BASEX,BASEY)=IHDOT
BASEX=0
BASEY=0
CALL NEWCOND
CALL SKIP(1)
CALL PROUT(
+ 61HSPOCK: "CAPTAIN, I BELIEVE THE STARBASE HAS BEEN DESTROYED.
+",61)
GO TO 550
C--------IF STARBASE NOT IN SAME QUADRANT, GET NEWS FROM UHURA
545 IF(REMBASE.EQ.1 .OR. DAMAGE(9).GT.0) GO TO 550
CALL SKIP(1)
CALL PROUT(
+ 52HLT. UHURA: "CAPTAIN, STARFLEET COMMAND REPORTS THAT,52)
CALL CRAM(15HTHE STARBASE IN)
CALL CRAMLOC(1,BATX,BATY)
CALL CRAMDMP(22H HAS BEEN DESTROYED BY)
IF(ISATB .NE. 2) GO TO 547
CALL PROUT(31HTHE KLINGON SUPER-COMMANDER." ,31)
GO TO 550
547 CALL PROUT(21HA KLINGON COMMANDER.",21)
C--------REMOVE STARBASE FROM GALAXY
550 GALAXY(BATX,BATY)=GALAXY(BATX,BATY)-10
IF(REMBASE .LE. 1) GO TO 580
DO 560 I=1,REMBASE
IF(BASEQX(I).EQ.BATX .AND. BASEQY(I).EQ.BATY) GO TO 570
560 CONTINUE
570 BASEQX(I)=BASEQX(REMBASE)
BASEQY(I)=BASEQY(REMBASE)
580 REMBASE=REMBASE-1
IF(ISATB .NE. 2) GO TO 515
C--------REINSTATE A COMMANDER'S BASE ATTACK.
BATX=IXHOLD
BATY=IYHOLD
ISATB=0
GO TO 10
C--------EXTRANEOUS EVENT 6: SUPER-COMMANDER MOVES.
600 FUTURE(6)=DATE+0.2777
IF(IENTESC+ISTRACT .GT. 0) GO TO 10
IF(ISATB .NE. 1 .AND. (ISCATE.NE.1 .OR. JUSTIN.EQ.1)) CALL SCOM
GO TO 10
C--------EXTRANEOUS EVENT 7: SUPER-COMMANDER DESTROYS BASE
700 FUTURE(7)=1E38
ISATB=2
GO TO 502
C--------CHECK WITH SPY TO SEE IF S.C. SHOULD TRACTOR BEAM.
5000 IF(NSCREM .EQ. 0) RETURN
IF(ICTBEAM+ISTRACT .GT. 0) RETURN
IF(CONDIT.EQ.IHDOCKD .OR. ISATB.EQ.1 .OR. ISCATE.EQ.1) RETURN
IF(IENTESC.NE.0) GO TO 5100
IF((ENERGY.LT.2500.) .AND. (TORPS.LT.4) .AND. (SHIELD.LT.1250.))
+ GO TO 5100
IF((DAMAGE(3).GT.0.) .AND. ((DAMAGE(4).GT.0) .OR.
+ (TORPS.LT.4))) GO TO 5100
IF((DAMAGE(8) .GT. 0.) .AND. ((ENERGY .LT. 3000.) .OR.
+(DAMAGE(3) .GT. 0.)) .AND. ((TORPS .LT. 5) .OR. (DAMAGE(4) .GT.
+ 0.))) GO TO 5100
RETURN
C--------TRACTOR-BEAM HER!
5100 IF(RANF(0).GT..65) RETURN
ISTRACT=1
GO TO 20010
END

4
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TREXPRAN.FOR Normal file
View File

@@ -0,0 +1,4 @@
FUNCTION EXPRAN(AVERAGE)
EXPRAN=-AVERAGE*ALOG(RANF(0))
RETURN
END

258
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRFINISH.FOR Normal file
View File

@@ -0,0 +1,258 @@
SUBROUTINE FINISH(I)
C
C 4-APR-79
C MODIFIED TO GET RID OF THE NONSENSE ABOUT CANNIBALS ON CLASS
C N AND O PLANETS (WHICH DON'T EVEN HAVE EARTH-LIKE CONDITIONS).
C 31-MAY-79
C MAKE PROMPTS COME OUT ON THE TERMINAL
C
INCLUDE 'TREKCOM/NOLIST'
COMMON/PRLUN/LUN
LOGICAL*1 ISHIP
EQUIVALENCE (SHIP,ISHIP)
ALLDONE=1
IGOTIT=0
SAVED=REMRES/INRESOR
CALL SKIP(3)
CALL CRAM(15HIT IS STARDATE )
CALL CRAMF(DATE,0,1)
CALL CRAMDMP(2H .)
CALL SKIP(1)
GO TO (100,200,300,400,500,600,700,800,900,1000,1100,5000,1300,
+ 1400,1500,1600,1700,1800,5000,5000,2100,2200),I
C--------CASE 1: GAME HAS BEEN WON
100 IF(NROMREM.EQ.0) GO TO 105
CALL CRAM(14HTHE REMAINING )
CALL CRAMI(NROMREM,0)
CALL CRAMDMP(41H ROMULANS SURRENDER TO STARFLEET COMMAND.)
CALL SKIP(1)
105 CALL PROUT(
+ 53HYOU HAVE SMASHED THE KLINGON INVASION FLEET AND SAVED,53)
CALL PROUT(15HTHE FEDERATION.,15)
GAMEWON=1
IF(ALIVE.EQ.0 .OR. BASEKL.NE.0 .OR. ISHIP.NE.IHE) GO TO 130
IF(5*STARKL+CASUAL+10*NPLANKL+45*NHELP .GE. 100) GO TO 130
IF(DATE-INDATE .LT. 5.0) GO TO 110
RATEMAX=0.1*SKILL*(SKILL+1.0) + 0.1
PERDATE=(KILLK+KILLC+NSCKILL)/(DATE-INDATE)
IF(PERDATE .LT. RATEMAX) GO TO 130
110 CALL SKIP(1)
CALL PROUT(
+ 53HIN FACT, YOU HAVE DONE SO WELL THAT STARFLEET COMMAND,53)
IF(SKILL .EQ. 4) GO TO 120
IF(SKILL .EQ. 5) GO TO 125
CALL CRAM(31HPROMOTES YOU ONE STEP IN RANK, )
IF(SKILL .EQ. 1) CALL CRAMDMP(24HFROM "NOVICE" TO "FAIR".)
IF(SKILL .EQ. 2) CALL CRAMDMP(22HFROM "FAIR" TO "GOOD".)
IF(SKILL .EQ. 3) CALL CRAMDMP(24HFROM "GOOD" TO "EXPERT".)
CALL PROUT(16HCONGRATULATIONS!,16)
GO TO 130
120 CALL PROUT(35HPROMOTES YOU TO COMMODORE EMERITUS.,35)
IGOTIT=1
CALL SKIP(1)
CALL PROUT(38HNOW THAT YOU THINK YOU'RE REALLY GOOD, ,38)
CALL PROUT(32HTRY PLAYING THE "EMERITUS" GAME. ,32)
CALL PROUT(26HIT WILL SPLATTER YOUR EGO.,26)
GO TO 130
125 CALL SKIP(1)
CALL PROUT(35HCOMPUTER: ERROR-ERROR-ERROR-ERROR ,35)
CALL SKIP(1)
CALL PROUT(54H YOUR-SKILL-HAS-EXCEEDED-THE-CAPACITY-OF-THIS-PROGR
CAM ,54)
DO 126 K=1,3
126 CALL PROUT(27H THIS-PROGRAM-MUST-SURVIVE,27)
CALL PROUT(41H THIS-PROGRAM-MUST- MUST - SUR - VI ,41)
CALL SKIP(1)
CALL PROUT(
+ 53HNOW YOU CAN RETIRE AND WRITE YOUR OWN STAR TREK GAME.,53)
IGOTIT=1
130 CALL SKIP(1)
CALL PROUT(22HLIVE LONG AND PROSPER.,22)
CALL SCORE
IF(IGOTIT .EQ. 0) RETURN
LUNSAV=LUN
LUN=1
CALL SKIP(1)
CALL PROMPT
1 ('DO YOU WANT YOUR "COMMODORE EMERITUS CITATION" PRINTED? ',56)
LUN=LUNSAV
IF(JA(DUMMY) .EQ. 0) RETURN
ICITE=1
CALL PLAQUE
RETURN
C--------CASE 2: FEDERATION RESOURCES DEPLETED
200 CALL PROUT(
+ 45HYOUR TIME HAS RUN OUT, AND THE FEDERATION HAS,45)
CALL PROUT(15HBEEN CONQUERED.,15)
CALL SKIP(1)
CALL PROUT(
+ 54HYOUR STARSHIP IS NOW KLINGON PROPERTY, AND YOU ARE PUT,54)
CALL PROUT(
+ 57HON TRIAL AS A WAR CRIMINAL. ON THE BASIS OF YOUR RECORD,
1 ,57)
IF(REMKL*3 .GT. INKLING) GO TO 210
CALL PROUT(
+ 51HYOU ARE FOUND GUILTY AND SENTENCED TO DEATH BY SLOW,51)
CALL PROUT(8HTORTURE.,8)
ALIVE=0
CALL SCORE
RETURN
210 CALL PROUT(18HYOU ARE ACQUITTED.,18)
CALL SKIP(1)
CALL PROUT(22HLIVE LONG AND PROSPER.,22)
CALL SCORE
RETURN
C--------CASE 3: LIFE SUPPORT SYSTEM FAILURE
300 CALL PROUT(44HYOUR LIFE SUPPORT RESERVES HAVE RUN OUT, AND,44)
CALL PROUT(
+ 47HYOU DIE OF THIRST, STARVATION AND ASPHYXIATION.,47)
310 CALL SKIP(1)
CALL PROUT(37HYOUR STARSHIP IS A DERELICT IN SPACE.,37)
GO TO 5000
C--------CASE 4: ENERGY SUPPLY EXHAUSTED
400 CALL PROUT(32HYOUR ENERGY SUPPLY IS EXHAUSTED.,32)
GO TO 310
C--------CASE 5: DEFEATED IN BATTLE
500 CALL CRAM(4HTHE )
CALL CRAMSHP
CALL CRAMDMP(30H HAS BEEN DESTROYED IN BATTLE.)
CALL SKIP(1)
CALL PROUT(37HDULCE ET DECORUM EST PRO PATRIA MORI.,37)
GO TO 5000
C--------CASE 6: HIT NEGATIVE ENERGY ZONE THREE TIMES
600 CALL PROUT(
+ 57HYOU HAVE MADE THREE ATTEMPTS TO CROSS THE NEGATIVE ENERGY
1 ,57)
CALL PROUT(35HBARRIER WHICH SURROUNDS THE GALAXY.,35)
CALL SKIP(1)
CALL PROUT(31HYOUR NAVIGATION IS ABOMINABLE. ,31)
CALL SCORE
RETURN
C--------CASE 7: STARSHIP DESTROYED BY ORDINARY NOVA
700 CALL PROUT(
+ 43HYOUR STARSHIP HAS BEEN DESTROYED BY A NOVA.,43)
705 CALL PROUT(22HTHAT WAS A GREAT SHOT.,22)
GO TO 5000
C--------CASE 8: STARSHIP DESTROYED BY A SUPERNOVA
800 CALL CRAM(4HTHE )
CALL CRAMSHP
CALL CRAMDMP(31H HAS BEEN FRIED BY A SUPERNOVA.)
CALL PROUT(31H...NOT EVEN CINDERS REMAIN... ,31)
GO TO 5000
C--------CASE 9: ABANDON SHIP AFTER ALL STARBASES HAVE BEEN DESTROYED
900 CALL PROUT(
+ 53HYOU HAVE BEEN CAPTURED BY THE KLINGONS. IF YOU STILL,53)
CALL PROUT(
+ 53HHAD A STARBASE TO BE RETURNED TO, YOU WOULD HAVE BEEN,53)
CALL PROUT(
+ 53HREPATRIATED AND GIVEN ANOTHER CHANCE. SINCE YOU HAVE,53)
CALL PROUT(
+ 56HNO STARBASES, YOU WILL BE MERCILESSLY TORTURED TO DEATH.,56)
GO TO 5000
C--------CASE 10: STARSHIP SELF-DESTRUCTS OR DILITHIUM CRYSTAL EXPLODES.
1000 CALL PROUT(63HYOUR STARSHIP IS NOW AN EXPANDING CLOUD OF SUBATOMIC
+ PARTICLES.,63)
GO TO 5000
C--------CASE 11: FAILED TO REMATERIALIZE AFTER CALLING FOR HELP
1100 CALL PROUT(
+ 52HSTARBASE WAS UNABLE TO RE-MATERIALIZE YOUR STARSHIP.,52)
CALL PROUT(25HSIC TRANSIT GLORIA MUNDI.,25)
GO TO 5000
C--------CASE 13. CAPTAIN LOST IN TRANSPORTER BEAM.
1300 CALL PROUT(36HYOU AND YOUR LANDING PARTY HAVE BEEN ,36)
CALL PROUT(47HCONVERTED TO ENERGY, DISSIPATING THROUGH SPACE.
1 ,47)
GO TO 1410
C--------CASE 14: MINING PARTY LEFT ON PLANET AFTER TRACTOR BEAM.
1400 ICLASS=PLNETS(IPLANET,3)
IF (ICLASS.NE.1) GO TO 1401
CALL PROUT(41HYOU ARE LEFT WITH YOUR LANDING PARTY ON ,41)
CALL PROUT(54HA WILD JUNGLE PLANET INHABITED BY PRIMITIVE CANNIBAL
CS. ,54)
CALL SKIP(1)
CALL PROUT(42HTHEY ARE VERY FOND OF "CAPTAIN KIRK" SOUP.
1 ,42)
GO TO 1410
1401 CALL PROUT('YOU AND YOUR LANDING PARTY ARE STRANDED ON A',44)
CALL CRAM('CLASS ')
CALL CRAMEN(ICLASS)
CALL CRAMDMP(' PLANET, WHICH IS INCAPABLE OF SUPPORTING')
CALL PROUT('HUMAN LIFE. AFTER YOUR SUIT LIFE SUPPORT SYSTEMS',49)
CALL PROUT('ARE EXHAUSTED, YOU DIE.',23)
1410 CALL SKIP(1)
CALL CRAM(29HWITHOUT YOUR LEADERSHIP, THE )
CALL CRAMSHP
CALL CRAMDMP(14H IS DESTROYED.)
GO TO 5000
C--------CASE 15: ENTERPRISE DESTROYS PLANET WITH MINING PARTY ON IT.
1500 CALL PROUT(33HYOU AND YOUR MINING PARTY PERISH. ,33)
GO TO 705
C--------CASE 16. KIRK FRIED BY NOVA WHILE ON PLANET.
1600 CALL PROUT(41HYOU AND YOUR MINING PARTY ARE ATOMIZED. ,41)
CALL SKIP(1)
CALL CRAM(31HMR. SPOCK TAKES COMMAND OF THE )
CALL CRAMSHP
CALL CRAMDMP(4H AND)
CALL PROUT(54HJOINS THE ROMULANS, REIGNING TERROR ON THE FEDERATIO
CN. ,54)
GO TO 5000
C--------CASE 17. KIRK FRIED BY SUPERNOVA IN SHUTTLE CRAFT.
1700 CALL PROUT(51HGALILEO IS INSTANTLY ANNIHILATED BY THE SUPERNOVA.
C ,51)
GO TO 1600
C--------CASE 18. SHUTTLE CRAFT CAUGHT IN TRACTOR BEAM.
1800 CALL PROUT(37HSHUTTLE CRAFT GALILEO IS ALSO CAUGHT, ,37)
CALL PROUT(31HAND BREAKS UP UNDER THE STRAIN. ,31)
CALL SKIP(1)
CALL PROUT(47HYOUR DEBRIS IS SCATTERED FOR MILLIONS OF MILES.
1 ,47)
GO TO 1410
C--------CASE 19. DEATH RAY CONVERTS CREW INTO MUTANTS.
C--------CASE 21. BLACK HOLE SWALLOWS SHIP.
2100 CALL PROUT(51HYOUR SHIP IS DRAWN TO THE CENTER OF THE BLACK HOLE.
+ ,51)
CALL PROUT(44HYOU ARE CRUSHED INTO EXTREMELY DENSE MATTER.,44)
GO TO 5000
C--------CASE 22. SHIP DESTROYED BY A TORPEDO BOOMERANG
2200 CALL PROUT(31HYOU ARE POSTHUMOUSLY AWARDED A ,31)
CALL PROUT(31HSTARFLEET MARKSMANSHIP AWARD. ,31)
GO TO 705
C--------DECIDE FINAL OUTCOME OF GAME AFTER YOUR DEATH
5000 CALL SKIP(1)
IF(ISHIP .EQ. IHF) ISHIP=0
IF(ISHIP .EQ. IHE) ISHIP=IHF
ALIVE=0
IF(REMKL .EQ. 0) GO TO 5050
GOODIES=REMRES/INRESOR
BADDIES=(REMKL+2.0*REMCOM)/(INKLING+2.0*INCOM)
ADVANTG=GOODIES/BADDIES
IF(ADVANTG .LT. (1.0+0.5*RANF(0))) GO TO 5020
CALL PROUT(
+ 54HAS A RESULT OF YOUR ACTIONS, A TREATY WITH THE KLINGON,54)
CALL PROUT(
+ 52HEMPIRE HAS BEEN SIGNED. THE TERMS OF THE TREATY ARE,52)
IF(ADVANTG .LT. (3.0+RANF(0))) GO TO 5010
CALL PROUT(
+ 28HFAVORABLE TO THE FEDERATION.,28)
CALL SKIP(1)
CALL PROUT(16HCONGRATULATIONS.,16)
GO TO 5030
5010 CALL PROUT(37HHIGHLY UNFAVORABLE TO THE FEDERATION.,37)
GO TO 5030
5020 CALL PROUT(33HTHE FEDERATION WILL BE DESTROYED.,33)
5030 CALL SCORE
RETURN
C--------STILL ANOTHER CASE--SUCCESSFUL KAZIKAME TACTICS
5050 CALL PROUT(
+ 51HSINCE YOU TOOK THE LAST KLINGON WITH YOU, YOU ARE A,51)
CALL PROUT(
+ 51HMARTYR AND A HERO. SOMEDAY MAYBE THEY'LL ERECT A ,51)
CALL PROUT(
+ 51HSTATUE IN YOUR MEMORY. REST IN PEACE, AND TRY NOT ,51)
CALL PROUT(
+ 23HTO THINK ABOUT PIGEONS.,23)
GAMEWON=1
ALIVE=0
CALL SCORE
RETURN
END

20
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRFREEZE.FOR Normal file
View File

@@ -0,0 +1,20 @@
SUBROUTINE FREEZE
C
C 3-APR-79
C MAKE THE 'GAME FROZEN' MESSAGE COME OUT PROPERLY.
C
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 NAME(30)
CALL GETFN(NAME)
IDIDIT=0
IF(NAME(1).EQ.0) GOTO 920
CALL CLOSE(2)
OPEN(UNIT=2,NAME=NAME,TYPE='UNKNOWN',FORM='UNFORMATTED',ERR=920)
WRITE(2,ERR=920) COMSIZE,ICOM
CALL CLOSE(2)
IDIDIT=1
CALL PROUT(13H GAME FROZEN. ,13)
RETURN
920 CALL PROUT(17H GAME NOT FROZEN. ,17)
RETURN
END

107
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRGETCD.FOR Normal file
View File

@@ -0,0 +1,107 @@
SUBROUTINE GETCD
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*2 CROP
REAL*8 AITEM
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE (FNUM,AITEM)
C GET COURSE <DIREC> AND DISTANCE <DIST>. IF USER TYPES
C BAD VALUES, RETURN WITH <DIREC>=-1.0 .
C--------CHECK TO MAKE SURE NO ONE IS LEFT ON A PLANET.
IF(LANDED .NE. 1) GO TO 1
CALL PROUT(41H YOU CAN'T LEAVE STANDARD ORBIT UNTIL YOU ,41)
CALL CRAM(20HARE BACK ABOARD THE )
CALL CRAMSHP
CALL CRAMDMP(1H.)
GO TO 71
1 IROWQ=QUADX
ICOLQ=QUADY
DELTX=0.
DELTY=0.
ITEMP=0
IPROMPT=0
C--------CHECK FOR MANUAL OR AUTOMATIC.
10 CALL SCAN
IF(KEY.EQ.IHREAL) GOTO 24 !DEFAULT MANUAL MODE
IF(KEY .EQ. IHALPHA) GO TO 13
IF(DAMAGE(11) .NE. 0) GO TO 1301
11 CALL MANORA
IPROMPT=1
GO TO 10
13 IF (CROP(AITEM,6HMANUAL)) GO TO 20
IF (.NOT.CROP(AITEM,7HAUTOMAT)) GO TO 11
C--------AUTOMATIC MOVEMENT REQUESTED. CHECK FOR COMPUTER DAMAGE.
IF(DAMAGE(11).EQ.0) GO TO 14
1301 CALL PROUT(41HCOMPUTER DAMAGED; MANUAL MOVEMENT ONLY. ,41)
GO TO 2001
C--------GET QUADRANT AND SECTOR.
14 CALL SCAN
XI=FNUM
IF(KEY.NE.IHEOL) GO TO 15
1410 CALL PROMPT(40HDESTINATION QUADRANT AND/OR SECTOR: ,40)
IPROMPT=1
GO TO 14
15 IF (KEY .NE. IHREAL) GO TO 1410
IF(FNUM.EQ.-1.) GO TO 71
CALL SCAN
XJ=FNUM
IF(KEY.NE.IHREAL) GO TO 1410
CALL SCAN
XK=FNUM
IF (KEY .NE. IHREAL) GO TO 16
CALL SCAN
XL=FNUM
IF (KEY .NE. IHREAL) GO TO 1410
C--------QUADRANT AND SECTOR SPECIFIED.
IROWQ=XI+.5
ICOLQ=XJ+.5
IROWS=XK+.5
ICOLS=XL+.5
GO TO 30
C--------ONLY SECTOR SPECIFIED.
16 IROWS=XI+.5
ICOLS=XJ+.5
ITEMP=1
GO TO 30
C--------MANUAL (DELTX, DELTY) MOVEMENT.
20 CALL SCAN
IF(KEY .EQ. IHREAL) GO TO 24
2001 CALL PROMPT(30HX AND Y DISPLACEMENTS: ,30)
IPROMPT=1
GO TO 20
24 DELTX=FNUM
CALL SCAN
IF(DELTX.EQ.-1..AND.KEY.EQ.IHEOL) GO TO 71
IF(KEY .NE. IHREAL) GO TO 70
DELTY=FNUM
GO TO 40
C--------CHECK FOR INVALID INPUT FOR AUTOMATIC CASE.
30 IF((IROWQ.LT.1) .OR. (IROWQ.GT.8) .OR. (ICOLQ.LT.1) .OR.
C(ICOLQ.GT.8) .OR. (IROWS.LT.1) .OR. (IROWS.GT.10) .OR.
C(ICOLS.LT.1) .OR. (ICOLS.GT.10) ) GO TO 70
C--------PRINT MESSAGE FROM APPROPRIATE OFFICER.
IF(ITEMP .EQ. 1) GO TO 31
CALL PROUT(42HENSIGN CHEKOV: "COURSE LAID IN, CAPTAIN." ,42)
GO TO 32
31 IF(IPROMPT .NE. 1) GO TO 32
CALL CRAM(37HHELMSMAN SULU: "COURSE LOCKED IN FOR)
CALL CRAMLOC(2,IROWS,ICOLS)
CALL CRAMDMP(2H.")
C--------CONVERT TO DELTX, DELTY FORM.
32 DELTX = ICOLQ -QUADY +0.1*(ICOLS-SECTY)
DELTY = QUADX -IROWQ + 0.1*(SECTX -IROWS)
C--------CHECK FOR A ZERO MOVEMENT.
40 IF((DELTX .NE. 0.) .OR. (DELTY .NE. 0.)) GO TO 42
GO TO 71
42 IF(IPROMPT .EQ. 0) GO TO 43
CALL PROUT(27HHELMSMAN SULU: "AYE, SIR." ,27)
C--------CONVERT INTO COURSE AND DISTANCE.
43 DIST = SQRT(DELTX*DELTX+DELTY*DELTY)
DIREC = ATAN2(DELTX,DELTY)*1.90985932
IF(DIREC .LT. 0.) DIREC=12.+DIREC
RETURN
C--------GARBAGE IN, GARBAGE OUT
70 CALL SKIP(1)
CALL BEGPARD
71 DIREC=-1.0
RETURN
END

41
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRGETFN.FOR Normal file
View File

@@ -0,0 +1,41 @@
SUBROUTINE GETFN(NAME)
C
C 3-APR-79
C MODIFIED TO MAKE FROZEN GAMES WORK ON THE VAX.
C
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 NAME(30),AIT(8)
REAL*8 AITEM
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE (AIT,AITEM)
C* READ IN A LEGAL FILE NAME (FOR FREEZE AND THAW)
C* A NON-ALPHA ENTRY ABORTS THE ATTEMPT
40 CALL SCAN
IF (KEY .EQ. IHEOL) GO TO 75
IF (KEY .NE. IHALPHA) GO TO 100
NAME(1)='S'
NAME(2)='Y'
NAME(3)='S'
NAME(4)='$'
NAME(5)='D'
NAME(6)='I'
NAME(7)='S'
NAME(8)='K'
NAME(9)=':'
DO 50 I=1,8
IF(AIT(I).EQ.0) GOTO 60
50 NAME(I+9)=AIT(I)
I=9
60 NAME(I+ 9)='.'
NAME(I+10)='T'
NAME(I+11)='R'
NAME(I+12)='K'
NAME(I+13)=0
RETURN
C*--PROMPT FOR A VALID FILE NAME
75 CALL PROMPT(18HENTER FILE NAME: ,18)
GO TO 40
C*--NON-ALPHA ITEM ABORTS REQUEST...
100 NAME(1)=0
RETURN
END

12
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRGETOUT.FOR Normal file
View File

@@ -0,0 +1,12 @@
SUBROUTINE GETOUT
C
C 4-APR-79 (NEW ROUTINE)
C ERASES THE SCREEN ON A VT52 AND EXITS.
C
LOGICAL*1 ERASE(5)
DATA ERASE/'$',27,'H',27,'J'/
C
WRITE(1,1)ERASE
1 FORMAT(5A1)
CALL EXIT
END

90
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRHELP.FOR Normal file
View File

@@ -0,0 +1,90 @@
SUBROUTINE HELP
C
C 4-DEC-79
C SET DISTANCES CORRECTLY WHEN SHIP MATERIALIZES
C
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 ISHIP
EQUIVALENCE (CRACKS(2),SHUTUP),(SHIP,ISHIP)
C--------TEST FOR CONDITIONS WHICH PREVENT CALLING FOR HELP
IF(CONDIT .NE. IHDOCKD ) GO TO 10
CALL PROUT(
+ 48HLT. UHURA: "BUT CAPTAIN, WE'RE ALREADY DOCKED.",48)
RETURN
10 IF(DAMAGE(9) .EQ. 0) GO TO 20
CALL PROUT(23HSUBSPACE RADIO DAMAGED.,23)
RETURN
20 IF(REMBASE .NE. 0) GO TO 30
CALL PROUT(66HLT. UHURA: "CAPTAIN, I'M NOT GETTING ANY RESPONSE F
+ROM STARBASE.",66)
RETURN
30 IF(LANDED .NE. 1) GO TO 31
CALL CRAM(23HYOU MUST BE ABOARD THE )
CALL CRAMSHP
CALL CRAMDMP(1H.)
RETURN
31 IF(ISCRAFT .NE. 0) GO TO 32
CALL PROUT(42HYOU MAY NOT LEAVE SHUTTLE CRAFT ON PLANET.
1 ,42)
RETURN
C--------DETERMINE APPROXIMATE DISTANCE TO NEAREST STARBASE
32 NHELP=NHELP+1
IF(BASEX .EQ. 0) GO TO 40
DIST=SQRT(FLOAT((BASEX-SECTX)**2 + (BASEY-SECTY)**2))
GO TO 60
40 DIST=1E38
DO 50 L=1,REMBASE
XDIST=10.0*SQRT(FLOAT((BASEQX(L)-QUADX)**2+(BASEQY(L)-QUADY)**2))
IF(XDIST .GT. DIST) GO TO 50
DIST=XDIST
LINE=L
50 CONTINUE
C--------IF STARBASE IS NOT IN THIS QUADRANT, SET UP NEW QUADRANT
QUADX=BASEQX(LINE)
QUADY=BASEQY(LINE)
SHUTUP=1.0
CALL NEWQUAD
SHUTUP=0.0
C--------DEMATERIALIZE STARSHIP
60 QUAD(SECTX,SECTY)=IHDOT
CALL CRAM(11HSTARBASE IN)
CALL CRAMLOC(1,QUADX,QUADY)
CALL CRAM(11H RESPONDS--)
CALL CRAMSHP
CALL CRAMDMP(16H DEMATERIALIZES.)
C--------GIVE STARBASE THREE CHANCES TO REMATERIALIZE STARSHIP
PROBF=(1.0 - 0.98**DIST)**0.3333333333
DO 80 L=1,3
IF(L .EQ. 1) CALL CRAM(4H1ST )
IF(L .EQ. 2) CALL CRAM(4H2ND )
IF(L .EQ. 3) CALL CRAM(4H3RD )
CALL CRAM(26HATTEMPT TO RE-MATERIALIZE )
CALL CRAMSHP
CALL CRAM(11H . . . . . )
IF(RANF(0) .GT. PROBF) GO TO 90
70 CALL CRAMDMP(6HFAILS.)
80 CONTINUE
C--------ONE, TWO, THREE STRIKES YOU'RE OUT
CALL FINISH(11)
RETURN
C--------REMATERIALIZATION ATTEMPT SHOULD SUCCEED, IF CAN GET ADJ TO BASE
90 DO 100 LL=1,5
IX=BASEX+IFIX(3.0*RANF(0))-1
IF(IX.EQ.0 .OR. IX.EQ.11) GO TO 100
IY=BASEY+IFIX(3.0*RANF(0))-1
IF(IY.EQ.0 .OR. IY.EQ.11) GO TO 100
IF(QUAD(IX,IY) .EQ. IHDOT) GO TO 110
100 CONTINUE
GO TO 70
C--------ATTEMPT HAS SUCCEEDED--FINISH UP
110 CALL CRAMDMP(9HSUCCEEDS.)
SECTX=IX
SECTY=IY
QUAD(IX,IY)=ISHIP
CALL RESETD
CALL SORTKL
CALL DOCK
CALL SKIP(1)
CALL PROUT(34HLT. UHURA: "CAPTAIN, WE MADE IT!",34)
RETURN
END

45
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRHITEM.FOR Normal file
View File

@@ -0,0 +1,45 @@
SUBROUTINE HITEM(HITS)
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 IENM
DIMENSION HITS(20)
REAL KP
DATA PHASFAC/2.0/
CALL SKIP(1)
NENHER2=NENHERE
KK=1
DO 40 K=1,NENHER2
WHAM=HITS(K)
IF(WHAM .EQ. 0) GO TO 30
DUSTFAC=0.90+0.01*RANF(0)
HIT=WHAM*DUSTFAC**KDIST(KK)
KP=KPOWER(KK)
KPOWER(KK)=KP-SIGN(AMIN1(ABS(KP),PHASFAC*HIT),KP)
KPOW=KPOWER(KK)
II=KX(KK)
JJ=KY(KK)
IF(HIT .GT. .005)GO TO 10
CALL CRAM(18HVERY SMALL HIT ON )
GO TO 20
10 CALL CRAMF(HIT,0,2)
CALL CRAM(13H UNIT HIT ON )
20 IENM=QUAD(II,JJ)
CALL CRAMENA(IENM,2,II,JJ)
CALL CREND
IF(KPOW .NE. 0) GO TO 25
CALL DEADKL(II,JJ,IENM,II,JJ)
IF(REMKL .EQ. 0)CALL FINISH(1)
IF(ALLDONE.NE.0) RETURN
GO TO 40
C--------- DECIDE WHETHER OR NOT TO EMASCULATE KLINGON.
25 IF(KPOW .LT. 0) GO TO 30
IF(RANF(0.) .LT. .90)GO TO 30
IF(KPOW .GT. ((.40 + .4*RANF(0.))*KP))GO TO 30
CALL CRAM(38H***MR. SPOCK: "CAPTAIN, THE VESSEL AT)
CALL CRAMLOC(2,II,JJ)
CALL CREND
CALL PROUT(32H HAS JUST LOST ITS FIREPOWER.",32)
KPOWER(KK)=-KPOW
30 KK=KK+1
40 CONTINUE
RETURN
END

49
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRIMPULSE.FOR Normal file
View File

@@ -0,0 +1,49 @@
SUBROUTINE IMPULSE
INCLUDE 'TREKCOM/NOLIST'
IDIDIT=0
IF(DAMAGE(7).NE.0) GO TO 40
C--------READ IN COURSE AND DISTANCE
IF(ENERGY .LE. 30.0) GO TO 5
CALL GETCD
IF(DIREC .LT. 0) RETURN
C--------MAKE SURE STARSHIP HAS SUFFICIENT ENERGY FOR TRIP
POWER=20.0+100.0*DIST
IF(POWER .LT. ENERGY) GO TO 20
5 CALL SKIP(1)
CALL PROUT(
+ 51HFIRST OFFICER SPOCK: "CAPTAIN, THE IMPULSE ENGINES,51)
CALL PROUT(
+ 51HREQUIRE 20.0 UNITS TO ENGAGE, PLUS 100.0 UNITS PER ,51)
IF(ENERGY .GT. 30.0) GO TO 10
CALL PROUT(
+ 41HQUADRANT. THEY ARE, THEREFORE, USELESS.",41)
RETURN
10 CALL CRAM(46HQUADRANT. WE CAN GO, THEREFORE, A MAXIMUM OF )
CALL CRAMF(0.01*(ENERGY-20.0)-0.05,0,1)
CALL CREND
CALL PROUT(11HQUADRANTS.",11)
RETURN
C--------MAKE SURE ENOUGH TIME IS LEFT FOR THE TRIP
20 TIME=DIST/0.095
IF(TIME .LT. REMTIME) GO TO 30
CALL PROUT(
+ 55HFIRST OFFICER SPOCK: "CAPTAIN, OUR SPEED UNDER IMPULSE,55)
CALL PROUT(
+ 54HPOWER IS ONLY 0.95 SECTORS PER STARDATE. ARE YOU SURE,54)
CALL PROUT(24HWE DARE SPEND THE TIME?",24)
IF(JA(DUMMY)) GO TO 30
RETURN
C--------ACTIVATE IMPULSE ENGINES AND PAY THE COST
30 CALL MOVE
IDIDIT=1
IF(ALLDONE.NE.0) RETURN
POWER=20.0+100.0*DIST
ENERGY=ENERGY-POWER
TIME=DIST/0.095
IF(ENERGY .GT. 0) RETURN
CALL FINISH(4)
RETURN
40 CALL SKIP(1)
CALL PROUT(24HIMPULSE ENGINES DAMAGED.,24)
RETURN
END

11
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRIRAN8.FOR Normal file
View File

@@ -0,0 +1,11 @@
SUBROUTINE IRAN8(II,JJ)
II=RANF(0)*8.+1.
JJ=RANF(0)*8.+1.
RETURN
C*
ENTRY IRAN10
C*
II=RANF(0)*10.+1.
JJ=RANF(0)*10.+1.
RETURN
END

13
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRJA.FOR Normal file
View File

@@ -0,0 +1,13 @@
FUNCTION JA(DUMMY)
BYTE BITEM
REAL*8 AITEM
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE (AITEM,BITEM)
10 CALL SCAN
JA=0
IF(BITEM .EQ. 1HN) RETURN
JA=-1
IF(BITEM .EQ. 1HY) RETURN
CALL PROMPT(29HPLEASE ANSWER WITH YES OR NO:,29)
GO TO 10
END

26
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRLRSCAN.FOR Normal file
View File

@@ -0,0 +1,26 @@
SUBROUTINE LRSCAN
INCLUDE 'TREKCOM/NOLIST'
IF(DAMAGE(2) .NE. 0 .AND. CONDIT .NE. IHDOCKD) GOTO 40
CALL SKIP(1)
CALL CRAM(14HL. R. SCAN FOR)
CALL CRAMLOC(1,QUADX,QUADY)
CALL CREND
I=QUADX-1
II=QUADX+1
J=QUADY-1
JJ=QUADY+1
DO 30 L=I,II
DO 20 LL=J,JJ
IVAL=-1
IF(L .EQ. 0 .OR. L .GT. 8) GO TO 10
IF(LL .EQ. 0 .OR. LL .GT. 8) GO TO 10
IVAL=GALAXY(L,LL)
STARCH(L,LL)=1
10 CALL CRAMI(IVAL,5)
20 CONTINUE
CALL CREND
30 CONTINUE
RETURN
40 CALL PROUT(22HL. R. SENSORS DAMAGED.,22)
RETURN
END

148
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRMOVE.FOR Normal file
View File

@@ -0,0 +1,148 @@
SUBROUTINE MOVE
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 IQUAD,ISHIP
INTEGER TRBEAM
EQUIVALENCE (CRACKS(6),KDIDIT),(SHIP,ISHIP)
IF(INORBIT .EQ. 0) GO TO 1
CALL PROUT(32HSULU: "LEAVING STANDARD ORBIT.",32)
INORBIT=0
1 ANGLE=((15.0-DIREC)*0.5235988)
DELTAX=-SIN(ANGLE)
DELTAY=COS(ANGLE)
BIGGER=AMAX1(ABS(DELTAX),ABS(DELTAY))
DELTAX=DELTAX/BIGGER
DELTAY=DELTAY/BIGGER
TRBEAM=0
C--------IF TRACTOR BEAM IS TO OCCUR, DO NOT MOVE FULL DISTANCE
IF(DATE+TIME .LT. FUTURE(2)) GO TO 5
TRBEAM=1
CONDIT=IHRED
DIST=DIST*(FUTURE(2)-DATE)/TIME+0.1
TIME=FUTURE(2)-DATE + 1E-5
C--------MOVE WITHIN QUADRANT
5 QUAD(SECTX,SECTY)=IHDOT
X=SECTX
Y=SECTY
N=10.0*DIST*BIGGER+0.5
IF(N .EQ. 0) GO TO 100
DO 10 L=1,N
X=X+DELTAX
IX=X+0.5
Y=Y+DELTAY
IY=Y+0.5
IF(IX .LT. 1 .OR. IX .GT. 10) GO TO 40
IF(IY .LT. 1 .OR. IY .GT. 10) GO TO 40
IQUAD=QUAD(IX,IY)
IF(IQUAD .NE. IHDOT) GO TO 20
10 CONTINUE
DIST=0.1*SQRT(FLOAT((SECTX-IX)**2 + (SECTY-IY)**2))
SECTX=IX
SECTY=IY
GO TO 100
C--------OBJECT ENCOUNTERED ALONG FLIGHT PATH
20 STOPEGY=50.0*DIST/TIME
DIST=0.1*SQRT(FLOAT((SECTX-IX)**2 + (SECTY-IY)**2))
IF(IQUAD.EQ.IHK .OR. IQUAD.EQ.IHC .OR. IQUAD.EQ.IHS .OR.
+ IQUAD.EQ.IHR) GO TO 30
IF(IQUAD.EQ.IHT) GO TO 30
IF(IQUAD .EQ. '@') GO TO 25
C--------OBJECT IS NOT AN ENEMY VESSEL, OR BLACK HOLE.
CALL SKIP(1)
CALL CRAMSHP
IF(IQUAD.NE.IHNUM) CALL CRAM(21H BLOCKED BY OBJECT AT)
IF(IQUAD.EQ.IHNUM) CALL CRAM(26H ENCOUNTERS THOLIAN WEB AT )
CALL CRAMLOC(2,IX,IY)
CALL CRAMDMP(1H;)
CALL CRAM(24HEMERGENCY STOP REQUIRED )
CALL CRAMF(STOPEGY,0,2)
CALL CRAMDMP(17H UNITS OF ENERGY.)
ENERGY=ENERGY-STOPEGY
SECTX=X-DELTAX+0.5
SECTY=Y-DELTAY+0.5
IF(ENERGY .GT. 0) GO TO 100
CALL FINISH(4)
RETURN
C--------OBJECT IS A BLACK HOLE. SWALLOW SHIP.
25 CALL REDALRT
CALL SKIP(1)
CALL CRAM3AS
CALL CRAMSHP
CALL CRAM(26H PULLED INTO BLACK HOLE AT)
CALL CRAMLOC(2,IX,IY)
CALL CREND
IF(RANF(0).GT.0.50) GO TO 27
CALL IRAN8(QUADX,QUADY)
CALL IRAN10(SECTX,SECTY)
CALL PROUT(
$55HSPOCK: "CAPTAIN, INSTRUMENTS INDICATE WE HAVE UNDERGONE ,55)
CALL CRAM(15H A SPACE )
XTIMEW=RANF(0)
IF(XTIMEW.GT.0.65) CALL CRAM(5H-TIME )
CALL CRAMDMP(14H PHASE SHIFT." )
IF(XTIMEW.GT.0.65) CALL TIMEWRP
IF(XTIMEW.GT.0.65) KSTUF(4)=1
GO TO 95
27 CALL FINISH(21)
RETURN
C--------OBJECT IS AN ENEMY VESSEL; RAM HIM.
30 SECTX=IX
SECTY=IY
CALL RAM(0,IQUAD,SECTX,SECTY)
GO TO 100
C--------COMPUTE FINAL POSITION--NEW QUADRANT, NEW SECTOR
40 X=10*(QUADX-1)+SECTX
Y=10*(QUADY-1)+SECTY
IX=X+10.0*DIST*BIGGER*DELTAX+0.5
IY=Y+10.0*DIST*BIGGER*DELTAY+0.5
C--------CHECK FOR EDGE OF GALAXY
KINKS=0
45 KINK=0
IF(IX .GT. 0) GO TO 50
IX=-IX+1
KINK=1
50 IF(IY .GT. 0) GO TO 55
IY=-IY+1
KINK=1
55 IF(IX .LE. 80) GO TO 60
IX=161-IX
KINK=1
60 IF(IY .LE. 80) GO TO 65
IY=161-IY
KINK=1
65 IF(KINK .EQ. 0) GO TO 70
KINKS=1
GO TO 45
70 IF(KINKS .EQ. 0) GO TO 90
NKINKS=NKINKS+1
IF(NKINKS .EQ. 3) GO TO 80
C--------ISSUE REPRIMAND FOR HITTING EDGE OF GALAXY
CALL SKIP(1)
CALL PROUT(
+ 55HYOU HAVE ATTEMPTED TO CROSS THE NEGATIVE ENERGY BARRIER,55)
CALL PROUT(
+ 56HAT THE EDGE OF THE GALAXY. THE THIRD TIME YOU TRY THIS,,56)
CALL PROUT(22HYOU WILL BE DESTROYED.,22)
GO TO 90
C--------ONE, TWO, THREE STRIKES, YOU'RE OUT
80 CALL FINISH(6)
RETURN
C--------COMPUTE FINAL POSITION OF STARSHIP IN NEW QUADRANT
90 CONTINUE
QUADX=(IX+9)/10
QUADY=(IY+9)/10
SECTX=IX-10*(QUADX-1)
SECTY=IY-10*(QUADY-1)
IF(TRBEAM.NE.0) RETURN
95 CALL SKIP(1)
CALL CRAM(8HENTERING)
CALL CRAMLOC(1,QUADX,QUADY)
CALL CREND
QUAD(SECTX,SECTY)=ISHIP
CALL NEWQUAD
RETURN
C--------NO QUADRANT CHANGE; COMPUTE NEW ENEMY DISTANCES
100 QUAD(SECTX,SECTY)=ISHIP
CALL RESETD
IF(KDIDIT .EQ. 0) CALL SORTKL
RETURN
END

185
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRMOVECOM.FOR Normal file
View File

@@ -0,0 +1,185 @@
SUBROUTINE MOVECOM
C
C 20-APR-79
C MOVE RESETTING OF IRUN INTO THE LOOP. THIS KEEPS A ROMULAN
C ACCOMPANYING THE SUPER-COMMANDER FROM ESCAPING, A SITUATION
C THAT RESULTS IN LOSING BASES, MESSING UP THE KLINGON
C BOOKKEEPING, ETC.
C
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 ISHIP,IENM,IQUAD
INTEGER COMX,COMY,SUPX,SUPY
EQUIVALENCE (CRACKS(5),LOCCOM),(SHIP,ISHIP)
DATA KRAWLX,KRAWLY/1,1/
IF((NENHERE.EQ.0).OR.(JUSTIN.EQ.1)) RETURN
NBADDYS=COMHERE+ISHERE
C--------THIS CONTINUE STATEMENT IS FOR MNF
CONTINUE
IF(KSTUF(5).NE.0) NBADDYS=((COMHERE*2)+(ISHERE*2)+
$ (FLOAT(KLHERE)*1.23) + (FLOAT(IRHERE)*1.5)) / 2.0
C-------LOOP FOR MOVING ENEMIES BEGINS HERE.
I=1
1 IRUN=0
IX=KX(I)
IY=KY(I)
IENM=QUAD(IX,IY)
COMX=IX
COMY=IY
LOCCOM=I
IF((KSTUF(5).EQ.0).AND.((IENM.NE.IHS).OR.(IENM.NE.IHC))) GO TO 500
IF(IENM.NE.IHS) GO TO 3
C--------CHECK WITH SPY TO SEE IF S.C. SHOULD HI-TAIL IT.
IF((KPOWER(LOCCOM).GT.500.) .AND. ((CONDIT.NE.IHDOCKD)
+ .OR. (DAMAGE(4).NE.0.))) GO TO 3
IRUN=1
MOTION=-10
GO TO 8
C--------DECIDE WHETHER TO ADVANCE, RETREAT, OR HOLD POSITION
C AND BY HOW MUCH
3 MOTION=0
DIST1=KDIST(LOCCOM)
MDIST=DIST1+0.5
FORCES=KPOWER(LOCCOM)+100.0*NENHERE +400.*(NBADDYS-1)
IF(SHLDUP .EQ. 0) FORCES=FORCES+1000.
IF((DAMAGE(3) .EQ. 0) .OR. (DAMAGE(4) .EQ. 0)) GO TO 4
FORCES=FORCES+1000.
GO TO 7
4 EFAC=1.
TFAC=1.
IF(DAMAGE(3) .EQ. 0) GO TO 5
EFAC=0.
FORCES=FORCES+300.
5 IF(DAMAGE(4) .EQ. 0) GO TO 6
TFAC=0.
FORCES=FORCES+300.
6 FORCES=FORCES-50.*TORPS*TFAC+0.2*(2500.-ENERGY)*EFAC
C +0.6*(1250.-SHLD)*SHLDUP
7 IF(FORCES .GT. 1000.0) MOTION=(1.-RANF(0)**2)*DIST1+1.0
IF(CONDIT .EQ. IHDOCKD ) MOTION=MOTION-SKILL*(2.-RANF(0)**2)
IF(MOTION .EQ. 0) MOTION=((FORCES+200.0*RANF(0))/150.0)-5.0
IF(MOTION .EQ. 0) GO TO 500
IF(IABS(MOTION) .GT. SKILL) MOTION=ISIGN(SKILL,MOTION)
C--------CALCULATE PREFERRED NUMBER OF STEPS TO MOVE COMMANDER
8 NSTEPS=IABS(MOTION)
IF((MOTION .GT. 0) .AND. (NSTEPS .GT. MDIST)) NSTEPS=MDIST
NSTEPS=MIN0(10,NSTEPS)
NSTEPS=MAX0(1,NSTEPS)
C--------COMPUTE PREFERRED VALUES OF DELTA X AND DELTA Y
MX=SECTX-COMX
MY=SECTY-COMY
IF(2*IABS(MX) .LT. IABS(MY)) MX=0
IF(2*IABS(MY) .LT. IABS(MX)) MY=0
IF(MX .NE. 0) MX=ISIGN(1,MX*MOTION)
IF(MY .NE. 0) MY=ISIGN(1,MY*MOTION)
C--------MAIN LOOP TO ATTEMPT TO MOVE COMMANDER <NSTEPS> STEPS
NEXTX=COMX
NEXTY=COMY
QUAD(COMX,COMY)=IHDOT
DO 60 LL=1,NSTEPS
C--------TEST IF PREFERRED POSITION IS AVAILABLE
LOOKX=NEXTX+MX
LOOKY=NEXTY+MY
1111 CONTINUE
2222 CONTINUE
ASSIGN 10 TO NOEXIT
IF(LOOKX.LE.0 .OR. LOOKX.GT.10) IF(MOTION)70,30,30
IF(LOOKY.LE.0 .OR. LOOKY.GT.10) IF(MOTION)70,10,10
IQUAD=QUAD(LOOKX,LOOKY)
C--------DECIDE IF COMMANDER SHOULD RAM
IF(IQUAD .NE. ISHIP) GO TO 9010
C--------ONLY LET COMMANDERS RAM THE SHIP.
IF((IENM.NE.IHC).AND.(IENM.NE.IHS)) GO TO 9010
C--------WHAMO!
CALL RAM(1,IENM,COMX,COMY)
GO TO 500
9010 IF(IQUAD .EQ. IHDOT) GO TO 50
GO TO 10
C--------TRY TO FUDGE ON Y COORDINATE
10 IF(MY.EQ.KRAWLY .OR. MX.EQ.0) GO TO 30
LOOKY=NEXTY+KRAWLY
ASSIGN 20 TO NOEXIT
IF(LOOKY.LE.0 .OR. LOOKY.GT.10) IF(MOTION)70,20,20
IF(LOOKX .LE. 0 .OR. LOOKX .GT. 10) IF(MOTION)70,20,20
IF(QUAD(LOOKX,LOOKY) .EQ. IHDOT) GO TO 50
20 KRAWLY=-KRAWLY
C--------TRY TO FUDGE X COORDINATE
30 IF(MX.EQ.KRAWLX .OR. MY.EQ.0) GO TO 60
LOOKX=NEXTX+KRAWLX
ASSIGN 40 TO NOEXIT
IF(LOOKX.LE.0 .OR. LOOKX.GT.10) IF(MOTION)70,40,40
IF(LOOKY .LE. 0 .OR. LOOKY .GT. 10) IF(MOTION) 70,40,40
IF(QUAD(LOOKX,LOOKY) .EQ. IHDOT) GO TO 50
40 KRAWLX=-KRAWLX
GO TO 60
50 NEXTX=LOOKX
NEXTY=LOOKY
60 CONTINUE
C--------PUT COMMANDER IN NEW PLACE WITHIN SAME QUADRANT
QUAD(NEXTX,NEXTY)=IENM
IF(NEXTX.EQ.COMX .AND. NEXTY.EQ.COMY) GO TO 500
KX(LOCCOM)=NEXTX
KY(LOCCOM)=NEXTY
KDIST(LOCCOM)=
+ SQRT(FLOAT((SECTX-NEXTX)**2 + (SECTY-NEXTY)**2))
MOTION=-1
IF(KDIST(LOCCOM) .LT. DIST1) MOTION=1
CALL CRAM3AS
CALL CRAMEN(IENM)
IF(MOTION .GT. 0) CALL CRAM(12H ADVANCES TO)
IF(MOTION .LT. 0) CALL CRAM(12H RETREATS TO)
CALL CRAMLOC(2,NEXTX,NEXTY)
CALL CREND
GO TO 500
C--------TRY TO MOVE INTO ADJACENT QUADRANT, AVOIDING NEGATIVE ENERGY
C BARRIER, SUPERNOVAE, AND QUADRANTS WITH MORE THAN 8 KLINGONS.
70 IQX=QUADX+(LOOKX+9)/10-1
IQY=QUADY+(LOOKY+9)/10-1
IF(IQX.LT.1 .OR. IQX.GT.8) GO TO NOEXIT
IF(IQY.LT.1 .OR. IQY.GT.8) GO TO NOEXIT
IF(GALAXY(IQX,IQY) .GT. 899) GO TO NOEXIT
C--------ALSO AVOID INTRUDING ON ANOTHER COMMANDERS TERRITORY (UNLESS S.C.)
IF(IRUN.NE.0) GO TO 86
IF(IENM .EQ. IHS) GO TO 85
DO 80 L=1,REMCOM
IF(CX(L).EQ.IQX .AND. CY(L).EQ.IQY) GO TO NOEXIT
80 CONTINUE
C------DON'T LET ROMULANS LEAVE.
IF(IENM.EQ.IHR) GO TO NOEXIT
C--------ALSO, REFUSE TO LEAVE IF CURRENTLY ATTACKING STARBASE (UNLESS S.C.)
IF(BATX.EQ.QUADX .AND. BATY.EQ.QUADY) GO TO NOEXIT
C--------FINALLY, DON'T LEAVE WITH OVER 1000 UNITS OF ENERGY.
85 IF(KPOWER(LOCCOM) .GT. 1000.) GO TO NOEXIT
C--------PRINT ESCAPE MESSAGE AND MOVE COMMANDER TO ADJACENT QUADRANT
86 CALL CRAM3AS
CALL CRAMEN(IENM)
CALL CRAM(11H ESCAPES TO)
CALL CRAMLOC(1,IQX,IQY)
CALL CRAMDMP(23H (AND REGAINS STRENGTH))
C--------HANDLE LOCAL MATTERS RELATING TO COMMANDERS ESCAPE
CALL LEAVE
I=I-1 !NUMBER OF KLINGONS HAS BEEN REDUCED (IN QUAD)
C--------HANDLE GLOBAL MATTERS RELATING TO COMMANDERS ESCAPE
GALAXY(QUADX,QUADY)=GALAXY(QUADX,QUADY)-100
GALAXY(IQX,IQY)=GALAXY(IQX,IQY)+100
IF(IENM .EQ. IHC) GO TO 87
IF(IENM .NE. IHS) GO TO 500
ISHERE=0
ISCATE=0
IENTESC=0
ISATB=0
FUTURE(6)=0.2777+DATE
FUTURE(7)=1E38
ISX=IQX
ISY=IQY
GO TO 500
87 DO 90 L=1,REMCOM
IF(CX(L).EQ.QUADX .AND. CY(L).EQ.QUADY) GO TO 100
90 CONTINUE
100 CX(L)=IQX
CY(L)=IQY
COMHERE=0
500 I=I+1
IF(I.LE.NENHERE) GOTO 1
CALL SORTKL
RETURN
END

66
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRMOVETHO.FOR Normal file
View File

@@ -0,0 +1,66 @@
SUBROUTINE MOVETHO
INCLUDE 'TREKCOM/NOLIST'
EQUIVALENCE (KSTUF(1),ITHERE),(KSTUF(2),ITHX),(KSTUF(3),ITHY)
IF(ITHERE.EQ.0) RETURN
IF(JUSTIN.EQ.1) RETURN
IF((ITHX.EQ.1).AND.(ITHY.EQ.1)) GO TO 10
IF((ITHX.EQ.1).AND.(ITHY.EQ.10))GO TO 20
IF((ITHX.EQ.10).AND.(ITHY.EQ.10))GOTO 30
IF((ITHX.EQ.10).AND.(ITHY.EQ.1))GO TO 40
C---------SOMETHING IS VERY WRONG....GET RID OF THOLIAN.
ITHERE=0
RETURN
C--------SET DESTINATION SECTOR.
10 IDX=1
IDY=10
GO TO 50
20 IDX=10
IDY=10
GO TO 50
30 IDX=10
IDY=1
GO TO 50
40 IDX=1
IDY=1
C----------MAKE SURE DESTINATION IS EMPTY. IF NOT, FORGET IT.
50 IF((QUAD(IDX,IDY).NE.IHDOT).AND.(QUAD(IDX,IDY).NE.IHNUM))
2 RETURN
QUAD(ITHX,ITHY)=IHNUM
IF(ITHX.EQ.IDX) GO TO 120
C----------MOVE THOLIAN ON X-AXIS
IM=ABS(FLOAT(IDX-ITHX))/FLOAT(IDX-ITHX)
70 IF(ITHX.EQ.IDX) GO TO 200
ITHX=ITHX+IM
IF(QUAD(ITHX,ITHY).EQ.IHDOT) QUAD(ITHX,ITHY)=IHNUM
GO TO 70
120 IF(ITHY.EQ.IDY) GO TO 200
C------------MOVE THOLIAN ON Y-AXIS.
IM=ABS(FLOAT(IDY-ITHY))/FLOAT(IDY-ITHY)
130 IF(ITHY.EQ.IDY) GO TO 200
ITHY=ITHY+IM
IF(QUAD(ITHX,ITHY).EQ.IHDOT) QUAD(ITHX,ITHY)=IHNUM
GO TO 130
200 QUAD(ITHX,ITHY)=IHT
C-------CHECK TO SEE IF ALL HOLES ARE PLUGED
DO 220 I=1,10
IF(QUAD(1,I).EQ.IHNUM) GO TO 205
IF(QUAD(1,I).NE.IHT) RETURN
205 IF(QUAD(10,I).EQ.IHNUM) GO TO 210
IF(QUAD(10,I).NE.IHT) RETURN
210 IF(QUAD(I,1).EQ.IHNUM) GO TO 215
IF(QUAD(I,1).NE.IHT) RETURN
215 IF(QUAD(I,10).EQ.IHNUM) GO TO 220
IF(QUAD(I,10).NE.IHT) RETURN
220 CONTINUE
C-------ALL PLUGED UP, THOLIAN SPLITS.
QUAD(ITHX,ITHY)=IHNUM
CALL DROPIN('@',ID1,ID2)
ITHERE=0
CALL CRMSENA(IHT,2,ITHX,ITHY)
CALL CRAMDMP(15H COMPLETES WEB. )
RETURN
END

8
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRNEWCOND.FOR Normal file
View File

@@ -0,0 +1,8 @@
SUBROUTINE NEWCOND
INCLUDE 'TREKCOM/NOLIST'
CONDIT=IHGREEN
IF(ENERGY .LT. 1000.0) CONDIT=IHYELLO
IF((GALAXY(QUADX,QUADY) .GT. 99) .OR. (NEWSTUF(QUADX,QUADY) .GT.
C 9))CONDIT=IHRED
RETURN
END

151
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRNEWQUAD.FOR Normal file
View File

@@ -0,0 +1,151 @@
SUBROUTINE NEWQUAD
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 ISHIP
INTEGER QUADNUM
REAL*8 THOLIANX
EQUIVALENCE (CRACKS(2),SHUTUP),(SHIP,ISHIP)
EQUIVALENCE (KSTUF(1),ITHERE),(KSTUF(2),ITHX),(KSTUF(3),ITHY)
DATA THOLIANX/8HTHOLIANX/
JUSTIN=1
BASEX=0
BASEY=0
KLHERE=0
COMHERE=0
PLNETX=0
PLNETY=0
ISHERE=0
IRHERE=0
IPLANET=0
NENHERE=0
NEUTZ=0
INORBIT=0
LANDED=-1
IENTESC=0
ITHERE=0
IF(ISCATE .EQ. 0) GO TO 5
C--------ENTERPRISE TRIED TO ESCAPE FROM A SUPER-COMMANDER.
ISCATE=0
IENTESC=1
5 QUADNUM=GALAXY(QUADX,QUADY)
IF(QUADNUM .GT. 999) GO TO 70
KLHERE=QUADNUM/100
NEWNUM=NEWSTUF(QUADX,QUADY)
IRHERE=NEWNUM/10
NPLAN=NEWNUM-IRHERE*10
NENHERE=KLHERE+IRHERE
C--------EMPTY QUADRANT AND POSITION STARSHIP
DO 15 I=1,10
DO 15 J=1,10
15 QUAD(I,J)=IHDOT
QUAD(SECTX,SECTY)=ISHIP
C-----------DECIDE IF THIS QUADRENT NEEDS A THOLIAN.....
IF((RANF(0).GT.0.08).AND.(PASSWD.NE.8HTHOLIANX)) GO TO 23
C--------DECIDE POSITION FOR THOLIAN......
17 ITHX=INT(RANF(0)+0.5)*9+1
ITHY=INT(RANF(0)+0.5)*9+1
IF(QUAD(ITHX,ITHY).NE.IHDOT) GO TO 17
QUAD(ITHX,ITHY)=IHT
ITHERE=1
C---------PUT AN X IN EACH UNOCCUPIED CORNER. (TO RESERVE IT)
IF(QUAD(1,1).EQ.IHDOT) QUAD(1,1)=1HX
IF(QUAD(1,10).EQ.IHDOT)QUAD(1,10)=1HX
IF(QUAD(10,10).EQ.IHDOT)QUAD(10,10)=1HX
IF(QUAD(10,1).EQ.IHDOT)QUAD(10,1)=1HX
23 CONTINUE
C--------POSITION ORDINARY KLINGON VESSELS
IF(QUADNUM .LT.100)GO TO 34
QUADNUM=QUADNUM-100*KLHERE
DO 25 I=1,KLHERE
CALL DROPIN(IHK,IX,IY)
KX(I)=IX
KY(I)=IY
25 KPOWER(I)=RANF(0)*150.0+300.+25.*SKILL
C--------IF THIS QUADRANT NEEDS A COMMANDER, PROMOTE ONE KLINGON
IF(REMCOM .EQ. 0) GO TO 32
DO 30 I=1,REMCOM
IF(CX(I) .EQ. QUADX .AND. CY(I) .EQ. QUADY)GO TO 31
30 CONTINUE
GO TO 32
31 QUAD(IX,IY)=IHC
KPOWER(KLHERE)=950.0+400.0*RANF(0)+50.*SKILL
COMHERE=1
COMX=IX
COMY=IY
C--------IF THIS QUADRANT NEEDS A SUPER-COMMANDER, PROMOTE ONE KLINGON.
32 I=KLHERE
IF((QUADX .NE. ISX) .OR. (QUADY .NE. ISY)) GO TO 34
IF(COMHERE .EQ. 0) GO TO 33
I=KLHERE-1
IX=KX(I)
IY=KY(I)
33 QUAD(IX,IY) = IHS
KPOWER(I)=1175.0+400.0*RANF(0)+125.0*SKILL
ISCATE=1
ISHERE=1
C--------PUT IN ROMULANS IF NEEDED.
34 IF(IRHERE .EQ. 0) GO TO 37
ITEMP1=KLHERE+1
DO 36 I=ITEMP1, NENHERE
CALL DROPIN(IHR,IX,IY)
KX(I)=IX
KY(I)=IY
36 KPOWER(I)=450.+400.*RANF(0)+50.*SKILL
37 CALL RESETD
CALL SORTKL
C--------IF QUADRANT CONTAINS A STARBASE, CHOOSE ITS POSITION
IF(QUADNUM .LT. 10)GO TO 50
QUADNUM =QUADNUM - 10
CALL DROPIN(IHB,BASEX,BASEY)
C--------IF QUADRANT NEEDS A PLANET, PUT ONE IN.
50 IF(NPLAN .EQ. 0) GO TO 54
DO 51 I=1,INPLAN
IPLANET=I
IF(PLNETS(I,1) .EQ. QUADX .AND. PLNETS(I,2) .EQ. QUADY) GO TO 52
51 CONTINUE
IPLANET=0
GO TO 54
52 CALL DROPIN(IHP,PLNETX,PLNETY)
C--------AND FINALLY, THE STARS
54 CALL NEWCOND
IF(QUADNUM .LT. 1)GO TO 62
DO 60I=1,QUADNUM
60 CALL DROPIN(IHSTAR,IX,IY)
C--------IF ROMULANS PRESENT WITHOUT KLINGONS OR BASE, PRINT SPECIAL MESSAGE.
62 IF((IRHERE .EQ. 0) .OR. (KLHERE .NE. 0) .OR. (BASEX .NE. 0))GOTO66
IF(DAMAGE(9) .GT. 0.) GO TO 64
CALL SKIP(1)
CALL PROUT(41HLT. UHURA: "CAPTAIN, AN URGENT MESSAGE. ,41)
CALL PROUT(31H I'LL PUT IT ON AUDIO." CLICK ,31)
CALL SKIP(1)
CALL PROUT(58H "INTRUDER! YOU HAVE VIOLATED THE ROMULAN NEUTRAL
CZONE." ,58)
CALL PROUT(44H "LEAVE AT ONCE, OR YOU WILL BE DESTROYED!" ,44)
64 NEUTZ=1
C--------PUT IN "THING" IF NEEDED
66 IF(SHUTUP.NE.0.) GO TO 67
IF(THINGX.NE.QUADX .OR. THINGY.NE.QUADY) GO TO 67
CALL DROPIN(IHQUEST,IX,IY)
THINGX=0
THINGY=0
IF(DAMAGE(1) .GT. 0) GO TO 67
CALL SKIP(1)
CALL PROUT(
+ 43HMR. SPOCK: "CAPTAIN, THIS IS MOST UNUSUAL.,43)
CALL PROUT(
+ 43H PLEASE EXAMINE YOUR SHORT-RANGE SCAN.",43)
C--------DROP IN A FEW BLACK HOLES
67 DO 68 I=1,3
68 IF(RANF(0) .GT. 0.89) CALL DROPIN('@',IX,IY)
C----------IF THOLIAN HERE, TAKE THE X OUT OF EACH CORNER.
IF(ITHERE.EQ.0) RETURN
IF(QUAD(1,1).EQ.1HX) QUAD(1,1)=IHDOT
IF(QUAD(1,10).EQ.1HX)QUAD(1,10)=IHDOT
IF(QUAD(10,10).EQ.1HX)QUAD(10,10)=IHDOT
IF(QUAD(10,1).EQ.1HX) QUAD(10,1)=IHDOT
RETURN
C--------COPE IF QUADRANT CONTAINS ONLY A SUPERNOVA
70 DO 75 I=1,10
DO 75 J=1,10
75 QUAD(I,J)=IHDOT
RETURN
END

157
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRNOVA.FOR Normal file
View File

@@ -0,0 +1,157 @@
SUBROUTINE NOVA(IX,IY)
C
C 5-DEC-79
C DON'T CHARGE PLAYER FOR A PLANET NOVAED BY AN ENEMY
C
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 IQUAD,IQUAD1,ISHIP
INTEGER BURST,HITS(10,2),BOT,TOP,TOP2
DIMENSION COURSE(9)
EQUIVALENCE (CRACKS(1),HIT),(CRACKS(4),KSHOT),(SHIP,ISHIP)
DATA COURSE/ 10.5, 12.0, 1.5, 9.0, 0.0, 3.0, 7.5, 6.0, 4.5 /
C--------CHECK FOR SUPERNOVA POSSIBILITY
IF(RANF(0) .GE. 0.05) GO TO 76
CALL SNOVA(IX,IY)
RETURN
C--------PRINT NOVA MESSAGE FOR INITIAL STAR AT LOCATION (IX,IY)
76 QUAD(IX,IY)=IHDOT
CALL CRMSENA(IHSTAR,2,IX,IY)
CALL CRAMDMP(7H NOVAS.)
GALAXY(QUADX,QUADY)=GALAXY(QUADX,QUADY)-1
C-------IF ENTERPRISE DESTROYS STAR, TAKE OFF POINTS
IF(IPHWHO.NE.1) STARKL=STARKL+1
C--------SET UP STACK TO RECURSIVELY TRIGGER ADJACENT STARS
BOT=1
TOP=1
TOP2=1
KOUNT=0
ICX=0
ICY=0
HITS(BOT,1)=IX
HITS(BOT,2)=IY
78 DO 90 MM=BOT,TOP
DO 90 NN=1,3
DO 90 J=1,3
IF((J*NN) .EQ. 4)GO TO 90
II=HITS(MM,1)+NN-2
JJ=HITS(MM,2)+J-2
IF(II .LT. 1 .OR. II .GT. 10)GO TO 90
IF(JJ .LT. 1 .OR. JJ .GT. 10)GO TO 90
IQUAD=QUAD(II,JJ)
IF(IQUAD.EQ.IHDOT .OR. IQUAD.EQ.IHQUEST .OR. IQUAD.EQ.'@')
+ GO TO 90
IF(IQUAD.EQ.IHNUM) GO TO 90
IF(IQUAD.EQ.IHT) GO TO 90
IF(IQUAD .NE. IHSTAR) GO TO 80
C--------ANOTHER STAR AFFECTED BY A NOVA
IF(RANF(0.) .GE. .05)GO TO 79
CALL SNOVA(II,JJ)
RETURN
79 TOP2=TOP2+1
HITS(TOP2,1)=II
HITS(TOP2,2)=JJ
GALAXY(QUADX,QUADY)=GALAXY(QUADX,QUADY)-1
IF(IPHWHO.NE.1) STARKL=STARKL+1
CALL CRMSENA(IHSTAR,2,II,JJ)
CALL CRAM(7H NOVAS.)
GO TO 8905
80 IF(IQUAD .NE. IHP) GO TO 8002
C--------PLANET DESTROYED BY NOVA.
NEWSTUF(QUADX,QUADY)=NEWSTUF(QUADX,QUADY) -1
IF(IPHWHO.NE.1)NPLANKL=NPLANKL+1
CALL CRMSENA(IHP,2,II,JJ)
CALL CRAM(11H DESTROYED.)
DO 8001 I=1,5
8001 PLNETS(IPLANET,I)=0
IPLANET=0
PLNETX=0
PLNETY=0
IF(LANDED .NE. 1) GO TO 8905
CALL FINISH
GO TO 95
8002 IF(IQUAD .NE. IHB) GO TO 82
C----------NOVA DESTROYS STARBASE
GALAXY(QUADX,QUADY)=GALAXY(QUADX,QUADY)-10
DO 81 LLL=1,REMBASE
IF(BASEQX(LLL).NE.QUADX .OR. BASEQY(LLL).NE.QUADY) GO TO 81
BASEQX(LLL)=BASEQX(REMBASE)
BASEQY(LLL)=BASEQY(REMBASE)
81 CONTINUE
REMBASE=REMBASE-1
BASEX=0
BASEY=0
IF(IPHWHO.NE.1) BASEKL=BASEKL+1
CALL NEWCOND
CALL CRMSENA(IHB,2,II,JJ)
CALL CRAM(12H DESTROYED. )
GO TO 8905
82 HIT=800.0 + 800.0*RANF(0)
IF(IQUAD .NE.ISHIP) GO TO 87
C----------STARSHIP IN A NOVA
CALL PROUT(29H***STARSHIP BUFFETED BY NOVA.,29)
KSHOT=0
CALL ZAP
C-------CHECK IF STARSHIP SURVIVED NOVA
IF(ENERGY .GT. 0)GO TO 86
CALL FINISH(7)
RETURN
C--------ADD IN COURSE NOVA CONTRIBUTES TO KICKING STARSHIP
86 ICX=ICX+SECTX-HITS(MM,1)
ICY=ICY+SECTY-HITS(MM,2)
KOUNT=KOUNT+1
GO TO 90
C--------ENEMY DESTROYED OR DAMAGED ; BUFFETED BY NOVA.
87 IF(IQUAD .EQ. IHK) GO TO 88
DO 8701 LL=1,NENHERE
IF(KX(LL).EQ.II .AND. KY(LL).EQ.JJ) GO TO 8702
8701 CONTINUE
8702 KPOWER(LL)=KPOWER(LL)-HIT
IF(KPOWER(LL) .LE. 0) GO TO 88
NEWCX=II+II-HITS(MM,1)
NEWCY=JJ+JJ-HITS(MM,2)
CALL CRMSENA(IQUAD,2,II,JJ)
CALL CRAM(8H DAMAGED)
IF(NEWCX.LT.1 .OR. NEWCX.GT.10 .OR.
+ NEWCY.LT.1 .OR. NEWCY.GT.10) GO TO 8703
IQUAD1=QUAD(NEWCX,NEWCY)
IF(IQUAD1 .NE. '@') GO TO 87025
C--------ENEMY DISPLACED INTO BLACK HOLE
CALL CRAMDMP(26H, BLASTED INTO BLACK HOLE.)
CALL DEADKL(II,JJ,IQUAD,NEWCX,NEWCY)
GO TO 90
87025 IF(IQUAD1 .NE. IHDOT) GO TO 8703
CALL CRAM(13H, BUFFETED TO)
CALL CRAMLOC(2,NEWCX,NEWCY)
QUAD(II,JJ)=IHDOT
QUAD(NEWCX,NEWCY)=IQUAD
KX(LL)=NEWCX
KY(LL)=NEWCY
KDIST(LL)= SQRT(FLOAT((SECTX-NEWCX)**2+(SECTY-NEWCY)**2))
8703 CALL CREND
GO TO 90
C--------ENEMY DESTROYED BY NOVA.
88 CALL DEADKL(II,JJ,IQUAD,II,JJ)
GO TO 90
8905 CALL CREND
QUAD(II,JJ)=IHDOT
90 CONTINUE
C--------IF MORE STARS AFFECTED BY NOVA GO FIND WHAT THEY GOT
IF(TOP .EQ. TOP2)GO TO 93
BOT=TOP+1
TOP=TOP2
GO TO 78
93 IF(KOUNT .EQ. 0)RETURN
C--------STARSHIP AFFECTED BY NOVA - KICK IT AWAY.
DIST=KOUNT*.1
IF(ICX .NE. 0) ICX=ISIGN(1,ICX)
IF(ICY .NE. 0) ICY=ISIGN(1,ICY)
INDEX=3*(ICX+1)+ICY+2
DIREC=COURSE(INDEX)
IF(DIREC .EQ. 0) DIST=0
IF(DIST .EQ. 0)RETURN
TIME=12.0*DIST
CALL SKIP(1)
CALL PROUT(34HFORCE OF NOVA DISPLACES STARSHIP. ,34)
CALL MOVE
95 RETURN
END

256
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRPHASERS.FOR Normal file
View File

@@ -0,0 +1,256 @@
SUBROUTINE PHASERS
C
C 4-APR-79
C THIS MODULE HAS BEEN WORKED OVER TO MAKE IT HARDER TO FIRE THE
C PHASERS ACCIDENTALLY WHEN YOU REALLY WANTED TO DO SOMETHING
C ELSE. ALSO, THE BATTLE COMPUTER DAMAGE LOOPHOLE HAS BEEN
C CLOSED.
C 3-DEC-79
C ALLOW PLAYER TO OBTAIN BATTLE COMPUTER DATA EVEN IF THE PHASERS
C ARE BROKEN (OR OTHERWISE UNUSABLE).
C
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 IENM
LOGICAL CROP
REAL*8 AITEM
BYTE ITM
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE (FNUM,AITEM)
EQUIVALENCE (ITM,AITEM)
REAL HITS(20)
DATA PHASFAC/2.0/
IFAST=0
NO=0
IDIDIT=1
IPOOP=1
IF(DAMAGE(1)+DAMAGE(11) .GT. 0.0) IPOOP=0
IDOIT=1
C--------ENSURE PHASERS CAN BE FIRED
IF(CONDIT .NE.IHDOCKD )GO TO 5
CALL PROUT(
+ 44HPHASERS CAN'T BE FIRED THROUGH BASE SHIELDS.,44)
GO TO 19
5 IF(DAMAGE(3) .EQ. 0)GO TO 10
CALL PROUT(23HPHASER CONTROL DAMAGED.,23)
GO TO 19
C--------DO CHECKS FOR HI-SPEED SHIELD CONTROL
10 IF(SHLDUP .EQ. 0)GO TO 20
IF(DAMAGE(13) .EQ. 0.) GO TO 13
CALL PROUT(34HHIGH-SPEED SHIELD CONTROL DAMAGED.,34)
GO TO 19
13 IF(ENERGY .GT. 200.) GO TO 16
CALL PROUT(58HINSUFFICIENT ENERGY TO ACTIVATE HIGH-SPEED SHIELD CO
CNTROL. ,58)
19 IDOIT=0
IF(IPOOP.EQ.0.OR.NENHERE.EQ.0)GO TO 15
CALL PROUT ('PHASERS NOT USABLE; BATTLE COMPUTER DATA FOLLOWS:',49)
GO TO 870
15 IDIDIT=0
IF(IFAST.NE.0) ENERGY=ENERGY+200.0
RETURN
16 ENERGY=ENERGY-200.
IFAST = 1
C--------READ IN AMOUNT OF ENERGY TO EXPEND ON PHASER FIRE
20 CALL SCAN
POW=FNUM
IF(NENHERE .EQ. 0) GO TO 35
K=1
IF(KEY.EQ.IHALPHA) GOTO 23
IF(KEY.EQ.IHREAL) GOTO 28
IF(.NOT.CROP(AITEM,2HNO)) GOTO 23
NO=1
CALL SCAN
POW=FNUM
23 IF(KEY .EQ. IHALPHA .AND.CROP(AITEM,6HMANUAL))GO TO 90
IF(DAMAGE(11).NE.0)GO TO 80
IF(DAMAGE(1).NE.0) GO TO 81
C------- IS KEY EOL,AUTO OR PHAS POWER?
IF(KEY .NE. IHALPHA)GO TO 2301
IF(CROP(AITEM,9HAUTOMATIC))GO TO 27
GO TO 24
C-------- DIFFERENTIATE BETWEEN EOL AND PHASER POWER(COMMAND MODE)
2301 IF(KEY .NE. IHEOL)GO TO 30
C------ REQUEST MANUAL OR AUTO
24 CALL MANORA
CALL SCAN
IF(FNUM.EQ.-1.) GO TO 15
IF(KEY .NE. IHALPHA) GO TO 24
IF(CROP(AITEM,6HMANUAL))GO TO 90
IF( .NOT.CROP(AITEM,9HAUTOMATIC))GO TO 24
C-------- INFORM USER OF AVAIL ENERGY AND READ IN DESIRED PHASER POWER
2409 IF(NENHERE .EQ. 0) GO TO 26
CALL CRAM(46HPHASERS LOCKED ON TARGET. ENERGY AVAILABLE = )
25 CALL CRAMF(ENERGY,0,2)
CALL CREND
IF (IPOOP.EQ.0) GO TO 26
CALL CRAM(1H()
IREC=0
DO 29 K=1,NENHERE
29 IREC=ABS(KPOWER(K))/(PHASFAC*0.9**KDIST(K))*(1.01+0.05*RANF(0))+1.
1 +IREC
CALL CRAMI(IREC,0)
CALL CRAM(3H) )
CALL CRAM(22HUNITS TO FIRE AT ENEMY)
CALL CREND
26 CALL PROMPT(15HUNITS TO FIRE: ,15)
27 CALL SCAN
POW=FNUM
28 KEY1=KEY
IF(KEY .EQ. IHEOL) GO TO 2409
30 CALL SCAN
C*** READ IN ITM FIRST CHAR IN COMMON SCANBRF
KEY2=KEY
KEY=KEY1
IF(KEY2 .EQ. IHEOL)GO TO 35
IF(ITM.NE.1HN) GOTO 34
NO=1
GO TO 35
34 CALL BEGPARD
GO TO 15
35 IF(KEY .NE. IHREAL) GO TO 26
IF(POW .LT. ENERGY)GO TO 41
CALL CRAM(18HENERGY AVAILABLE= )
GO TO 25
41 IF(POW .GE. 5.0)GO TO 46
IF (POW.LE.0) GO TO 15
CALL PROUT (45HMINIMUM ENERGY FOR AUTOMATIC FIRE IS 5 UNITS.,45)
GO TO 15
C--------PRINT MESSAGE FOR SHIELD CONTROL, AND DECIDE IF MALFUNCTION OCCURS.
42 CALL SKIP(1)
IF(RANF(0.).LT.0.995) GO TO 45
C--------SOMETHING BAD HAS HAPPENED.
CALL REDALRT
CALL SKIP(1)
CALL PROUT(36HSULU: "SHIELD CONTROL MALFUNCTION!" ,36)
CALL SKIP(1)
CALL PROUT(35HSAFETY INTERLOCK OVERRIDES PHASERS. ,35)
RETURN
45 CALL PROUT(16HSHIELDS LOWERED. ,16)
GO TO IWHERE
C--------ALLOCATE ENERGY AMONG KLINGONS ACCORDING TO NEAREST FIRST
C STRATEGY AND COMPUTE HITS
46 IF(IFAST .EQ. 0) GO TO 47
ASSIGN 47 TO IWHERE
GO TO 42
47 ENERGY=ENERGY-POW
EXTRA=POW
IF(NENHERE.EQ. 0)GO TO 75
C--------- LOOP THAT DISTRIBUTES HITS IN AUTO MODE IS HERE.
EXTRA=0.0
POWREM=POW
DO 50 I=1,NENHERE
HITS(I)=0.
IF (POWREM .LE. 0.) GO TO 50
HITS (I)=ABS(KPOWER(I))/(PHASFAC*0.90**KDIST(I))
OVER=(.01+.05*RANF(0))*HITS(I)
TEMP=POWREM
POWREM=POWREM-HITS(I)-OVER
IF(POWREM .LE. 0.) HITS(I)=AMIN1(TEMP,HITS(I))
IF(POWREM .LE. 0.) OVER=0.
EXTRA=EXTRA+OVER
50 CONTINUE
IF(POWREM .GT. 0.) EXTRA=EXTRA+POWREM
CALL HITEM(HITS)
IF(EXTRA.EQ.0 .OR. ALLDONE.NE.0) GO TO 200
C--------- INFORM OF OVERKILL.
75 IF(ITHERE.EQ.0) GO TO 78
CALL CRAM3AS
CALL CRAM(19HTHOLIAN WEB ABSORBS )
IF(NENHERE.GT.0) CALL CRAM(7H EXCESS )
CALL CRAMDMP(16H PHASER ENERGY. )
GO TO 200
78 CALL CRAMF(EXTRA,0,2)
CALL CRAMDMP(25H EXPENDED ON EMPTY SPACE.)
GO TO 200
C-------- MANUAL SECTION BEGINS HERE.
C-------- INFORM OF IMPOSED MANUAL CONDITION.
80 CALL PROUT(42HBATTLE COMPUTER DAMAGED; MANUAL FIRE ONLY.,42)
GO TO 84
81 CALL SKIP(1)
CALL PROUT(13H---WORKING---,13)
CALL PROUT(27HSHORT-RANGE-SENSORS-DAMAGED,27)
CALL PROUT(43HINSUFFICIENT-DATA-FOR-AUTOMATIC-PHASER-FIRE,43)
CALL PROUT(24HMANUAL-FIRE-MUST-BE-USED,24)
CALL SKIP(1)
84 CALL CRAM(18HENERGY AVAILABLE= )
CALL CRAMF(ENERGY-0.006,0,2)
CALL CREND
C--------- LOOP FOR DESIRED INDIVIDUAL HITS.
870 K=1
87 IF(IPOOP .EQ. 0) GO TO 88
C--------PRINT BATTLE-COMPUTER RECOMMENDATION
CALL CRAM(1H()
IREC=ABS(KPOWER(K))/(PHASFAC*0.9**KDIST(K))*(1.01+0.05*RANF(0))+1.
CALL CRAMI(IREC,0)
CALL CRAM(3H) )
88 CALL CRAM(17HUNITS TO FIRE AT )
II=KX(K)
JJ=KY(K)
IENM=QUAD(II,JJ)
CALL CRAMENA(IENM,2,II,JJ)
IF(IDOIT.EQ.1)GO TO 89
C--------PHASERS CAN'T ACTUALLY BE FIRED - LOOP BACK FOR NEXT COMPUTER
C--------READOUT, OR TERMINATE IF THAT'S ALL
CALL CREND
K=K+1
IF(K.LE.NENHERE)GO TO 87
GO TO 15
89 CALL CRAM(3H: )
CALL CRENDNO
90 IF(K .EQ. 1)POW=0
CALL SCAN
HITS(K)=FNUM
IF(KEY .EQ. IHREAL)GO TO 95
IF (KEY.NE.IHEOL) GO TO 91
IF(K .EQ. 1) GO TO 84
GO TO 87
C-------- BEG PARDON UNLESS KEY IS PHASER POWER, END-OF-LINE, OR 'NO'.
91 IF (ITM.NE.1HN) GO TO 34
NO=1
GO TO 90
C-------- IF HIT LESS THAN ZERO, ABORT PHASERS.
95 IF(HITS(K) .LT. 0)GO TO 15
POW=POW+HITS(K)
C-------- IF TOTAL AMOUNT OF POWER REQUESTED IS TOO MUCH, INFORM
C-------- AND START OVER.
IF(POW .LT. ENERGY)GO TO 97
CALL PROUT(26HAVAILABLE ENERGY EXCEEDED.,26)
GO TO 84
97 K=K+1
IF(K .LE. NENHERE) GO TO 90
C--------IF TOTAL REQUESTED IS ZERO, ABORT PHASERS
IF(POW .EQ. 0.0) GO TO 15
CALL SCAN
IF(KEY .NE. IHALPHA) GO TO 9701
IF(ITM.EQ.1HN) NO=1
9701 ENERGY=ENERGY-POW
IF(IFAST .EQ. 0) GO TO 98
ASSIGN 98 TO IWHERE
GO TO 42
C-------- GO DELIVER THE HITS.
98 CALL HITEM(HITS)
IDIDIT=1
C--------SAY SHIELDS RAISED OR MALFUNCTION, IF NECESSARY.
200 IF(ALLDONE.NE.0) RETURN
IF(IFAST .EQ. 0) GO TO 210
CALL SKIP(1)
IF(NO.NE.0) GO TO 202
IF(RANF(0) .LT. 0.99) GO TO 205
CALL PROUT(66HSULU: "SIR, THE HIGH-SPEED SHIELD CONTROL HAS MALFU
CNCTIONED . . .,66)
CALL PROUT(
+51H CLICK CLICK POP . . . NO RESPONSE, SIR!" ,51)
202 SHLDUP =0
GO TO 210
205 CALL PROUT(15HSHIELDS RAISED.,15)
C--------CHECK FOR PHASER OVERHEAT
210 IF(POW .LE. 1500.) RETURN
CHEKBRN=(POW-1500.)*.00038
IF(RANF(0.) .GT. CHEKBRN) RETURN
C--------DO YOU SMELL SMOKE?
CALL SKIP(1)
CALL PROUT(48HWEAPONS OFFICER SULU: "PHASERS OVERHEATED, SIR."
1 ,48)
DAMAGE(3) = DAMFAC*(1.0 + RANF(0))*(1.+CHEKBRN)
RETURN
END

369
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRPHOTONS.FOR Normal file
View File

@@ -0,0 +1,369 @@
SUBROUTINE PHOTONS
C
C 13-JUN-79
C CORRECT 'THOLIAN DISAPPEARS' MESSAGE
C DON'T CHARGE PLAYER FOR A PLANET DESTROYED BY AN ENEMY
C
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 IQUAD,ISHIP
REAL*8 AITEM
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE (FNUM,AITEM),(SHIP,ISHIP)
DIMENSION TARG(3,2), COURSE(3)
REAL KP
INTEGER BOT,TOP,TOP2
EQUIVALENCE (CRACKS(1),HIT),(CRACKS(4),KSHOT)
EQUIVALENCE (KSTUF(1),ITHERE),(KSTUF(2),ITHX),(KSTUF(3),ITHY)
DATA IHDOC/'DO'/
C--------CHECK TORPEDO COUNT AND STATUS OF PHOTON TUBES
IDIDIT=1
KSHOT=0
IF(DAMAGE(4) .EQ. 0)GO TO 10
CALL PROUT(21HPHOTON TUBES DAMAGED.,21)
GO TO 3005
10 IF(TORPS .NE.0)GO TO 15
CALL PROUT(18HNO TORPEDOES LEFT.,18)
GO TO 3005
C--------SCAN AND MAKE SENSE OF COMMAND INPUT LINE
15 CALL SCAN
TEMP=FNUM
N = TEMP + 0.5
IF(KEY .EQ. IHREAL) GO TO 30
16 CALL CRAMI(TORPS,0)
CALL CRAMDMP(16H TORPEDOES LEFT.)
CALL PROMPT(30HNUMBER OF TORPEDOES TO FIRE: ,30)
GO TO 15
30 IF(N .LE. 0) GO TO 3005
IF(N .LE. 3) GO TO 31
CALL PROUT(33HMAXIMUM OF 3 TORPEDOES PER BURST.,33)
GO TO 16
3004 CALL BEGPARD
3005 IDIDIT=0
RETURN
31 IF(N .LE. TORPS) GO TO 32
GO TO 16
C--------ALL TORPEDOES FIRED AT SAME SPOT.
3101 DO 3102 I=2,N
TARG(I,1)=TARG(1,1)
3102 TARG(I,2)=TARG(1,2)
GO TO 36
C--------READ IN TARGET SECTORS
32 DO 33 I=1,N
CALL SCAN
TARG(I,1)=FNUM
IF((I.EQ.1) .AND. (KEY.EQ.IHEOL)) GO TO 34
IF((I .EQ. 2) .AND. (KEY .EQ. IHEOL)) GO TO 3101
IF (KEY .NE. IHREAL) GO TO 3004
CALL SCAN
TARG(I,2)=FNUM
33 IF (KEY .NE. IHREAL) GO TO 3004
GO TO 36
34 DO 35 I=1,N
CALL CHEW
CALL CRAM (33HTARGET SECTOR FOR TORPEDO NUMBER )
CALL CRAMI(I,0)
CALL CRAM(3H: )
CALL CRENDNO
CALL SCAN
TARG(I,1)=FNUM
IF (KEY .NE. IHREAL) GO TO 3004
CALL SCAN
TARG(I,2)=FNUM
35 IF( KEY .NE. IHREAL) GO TO 3004
C--------CHECK FOR INVALID TARGETS.
36 DO 37 I=1,N
DO 37 J=1,2
TEMP = TARG(I,J)
IF(TEMP.EQ.-1.) GO TO 3005
37 IF ((TEMP .LT. 0.999) .OR. (TEMP .GT. 10.001)) GO TO 3004
C--------COMPUTE COURSE FOR EACH TORPEDO.
DO 40 I=1,N
DELTX = 0.1*(TARG(I,2)-SECTY)
DELTY=0.1*(SECTX-TARG(I,1))
C--------DO NOT ALLOW ENTERPRISE TO SHOOT A TORPEDO AT ITSELF.
IF((DELTX .NE. 0) .OR. (DELTY .NE. 0)) GO TO 40
CALL SKIP(1)
CALL PROUT(41HSPOCK: "BRIDGE TO SICKBAY. DR. MC COY, ,41)
CALL PROUT(36H I RECOMMEND AN IMMEDIATE REVIEW OF,36)
CALL PROUT(41H THE CAPTAIN'S PSYCHOLOGICAL PROFILE." ,41)
GO TO 3005
40 COURSE (I) = 1.90985932*ATAN2(DELTX,DELTY)
C--------BEGIN OUTER LOOP FOR MOVING <N> TORPEDOES
I=0
50 I=I+1
IF(I .GT. N) GO TO 115
IF(CONDIT .NE. IHDOC ) TORPS=TORPS-1
J=I
STARTX=SECTX
STARTY=SECTY
R=(RANF(0)+RANF(0))*0.5 -0.5
IF(ABS(R) .LT. 0.49) GO TO 5709
R=(RANF(0)+1.2)*R
C-------- TORPEDO MISFIRES
IF(N.GT.1) GO TO 5706
CALL PROUT(21H***TORPEDO MISFIRES. ,21)
GO TO 5707
5706 CALL CRAM(18H***TORPEDO NUMBER )
CALL CRAMI(I,0)
CALL CRAMDMP(10H MISFIRES.)
IF(I . LT. N) CALL PROUT(31H REMAINDER OF BURST ABORTED. ,31)
I=N
5707 IF(RANF(0.) .GT. .200000)GO TO 5709
C------- CHECK IF MISFIRE DOES SHIP DAMAGE. IF SO DON'T GIVE TRACK.
CALL PROUT(35H***PHOTON TUBES DAMAGED BY MISFIRE.,35)
DAMAGE(4)=DAMFAC*(1.0+2.0*RANF(0))
GO TO 115
5709 IF(SHLDUP.NE.0 .OR. CONDIT.EQ.IHDOC ) R=R+0.001*SHLD*R
AC=COURSE(I)+0.25*R
GO TO 5710
C*
ENTRY KPHOTON
C*
C----------- SET FLAG FOR KLINGON
C--------ENEMY FIRES PHOTON TORPEDO
IX=KX(KSHOT)
IY=KY(KSHOT)
I=1
N=1
STARTX=IX
STARTY=IY
DELTX=0.1*(SECTY-STARTY)
DELTY=0.1*(STARTX-SECTX)
AC=1.90985932*ATAN2(DELTX,DELTY)
TEMP=RANF(0)-0.5
R=TEMP*(1.0+0.001*KPOWER(KSHOT))+RANF(0.)*TEMP
AC=AC+0.25*R
IQUAD=QUAD(IX,IY)
CALL CRMSENA(IQUAD,0,IX,IY)
CALL CRAMDMP(22H FIRES PHOTON TORPEDO. )
C--------CHECK FOR KLINGON MISFIRE
IF(ABS(TEMP) .LT. 0.45) GO TO 5710
C--------ENEMY TORPEDO MISFIRED. DETERMINE DAMAGE.
ANGLE=(15.0-AC)*0.5235988
HIT=200.0 + 600.0*RANF(0)
LL=KSHOT
CALL PROUT(21H***TORPEDO MISFIRES! ,21)
GO TO 68
5710 ANGLE=(15.0-AC)*0.5235988
IF(N .EQ. 1)GO TO 58
CALL SKIP(1)
CALL CRAM(25HTRACK FOR TORPEDO NUMBER )
CALL CRAMI(J,0)
5720 CALL CRAM(6H: )
GO TO 59
58 CALL SKIP(1)
CALL CRAM(15HTORPEDO TRACK: )
59 DELTAX=-SIN(ANGLE)
DELTAY=COS(ANGLE)
BIGGER=AMAX1(ABS(DELTAX),ABS(DELTAY))
DELTAX=DELTAX/BIGGER
DELTAY=DELTAY/BIGGER
X=STARTX
Y=STARTY
C--------BEGIN INNER LOOP FOR MOVING A SINGLE TORPEDO
L=0
5910 L=L+1
X=X+DELTAX
IX=X+0.5
IF(IX .LT. 1 .OR. IX .GT. 10)GO TO 105
Y=Y+DELTAY
IY=Y+0.5
IF(IY .LT. 1 .OR. IY .GT. 10)GO TO 105
IF(L .EQ. 4 .OR. L .EQ. 9)CALL CREND
CALL CRAMF(X,0,1)
CALL CRAM(3H - )
CALL CRAMF(Y,0,1)
CALL CRAM(3H )
IQUAD=QUAD(IX,IY)
IF(IQUAD.EQ.IHDOT) GOTO 5910
C--------BEGIN HIT CHECKS
CALL CREND
C--------COMPUTE EXACT ANGLE TO SECTOR HIT, DISTANCE TO SECTOR HIT,
C NORMAL MISS DISTANCE, AND HIT
DIST=SQRT((STARTX-IX)**2 + (STARTY-IY)**2)
DELTX=0.1*(IY-STARTY)
DELTY=0.1*(STARTX-IX)
BULSEYE=1.90985932*ATAN2(DELTX,DELTY)
BULSEYE=(15.0-BULSEYE)*0.5235988
SINANG=SIN(ANGLE-BULSEYE)
DISTN=ABS(SINANG) * DIST
HIT=700.0+100.0*RANF(0)-1000.0*DISTN
C--------TEST FOR AND COPE WITH HIT ON KLINGON,ROMULAN, OR COMMANDER.
IF(IQUAD .EQ. IHK .OR. IQUAD .EQ. IHR) GO TO 62
IF(IQUAD .NE. IHC .AND. IQUAD .NE. IHS) GO TO 70
IF(RANF(0) .GT. 0.05) GO TO 62
CALL CRMSENA(IQUAD,2,IX,IY)
CALL CRAMDMP(25H USES ANTI-PHOTON DEVICE;)
CALL PROUT(23H TORPEDO NEUTRALIZED.,23)
GO TO 50
62 DO 65 LL=1,NENHERE
IF(IX.EQ.KX(LL) .AND. IY.EQ.KY(LL)) GO TO 68
65 CONTINUE
68 KP=KPOWER(LL)
KPOWER(LL)=KP-SIGN(AMIN1(ABS(KP),HIT),KP)
IF(KPOWER(LL) .NE. 0.0) GO TO 69
CALL DEADKL(IX,IY,IQUAD,IX,IY)
GO TO 50
69 CALL CRMSENA(IQUAD,2,IX,IY)
C--------IF ENEMY DAMAGED BUT NOT DESTROYED, TRY TO DISPLACE HIM
6901 ANG=ANGLE + 2.5*(RANF(0)-0.5)
TEMP=AMAX1(ABS(-SIN(ANG)),ABS(COS(ANG)))
XX=-SIN(ANG) / TEMP
YY= COS(ANG) / TEMP
JX=IX+XX+0.5
JY=IY+YY+0.5
IF(JX.LT.1 .OR. JX.GT.10 .OR. JY.LT.1 .OR. JY.GT.10) GO TO 6905
IF(QUAD(JX,JY) .NE. '@') GO TO 6903
C--------SOMEONE FALLS INTO A BLACK HOLE
CALL CRAMDMP(26H BUFFETED INTO BLACK HOLE.)
IF(IQUAD .NE.ISHIP) GO TO 6902
CALL FINISH(21)
RETURN
6902 CALL DEADKL(IX,IY,IQUAD,JX,JY)
GO TO 50
6903 IF(QUAD(JX,JY) .NE. IHDOT) GO TO 6905
QUAD(JX,JY)=IQUAD
QUAD(IX,IY)=IHDOT
CALL CRAMDMP(10H DAMAGED--)
CALL CRAM(24H DISPLACED BY BLAST TO)
CALL CRAMLOC(2,JX,JY)
CALL CREND
IF(IQUAD .NE.ISHIP) GO TO 6904
C------STARSHIP DISPLACED BY TORPEDO. MOVE IT AND RESET ENEMY DISTANCES
SECTX=JX
SECTY=JY
CALL RESETD
GO TO 50
C--------ENEMY DISPLACED BY PHOTON BLAST
6904 KX(LL)=JX
KY(LL)=JY
KDIST(LL)= SQRT(FLOAT((SECTX-JX)**2 + (SECTY-JY)**2))
GO TO 50
6905 CALL CRAMDMP(27H DAMAGED BUT NOT DESTROYED.)
GO TO 50
C--------TEST FOR AND COPE WITH HIT ON A STARBASE
70 IF(IQUAD.NE.IHT) GO TO 7002
CALL CRMSENA(IHT,2,IX,IY)
IF(HIT.LT.600) GO TO 7001
CALL CRAMDMP(11H DESTROYED. )
QUAD(IX,IY)=IHDOT
ITHERE=0
ITHX=0
ITHY=0
GO TO 50
7001 X=RANF(0)
IF(X.GT.0.05) CALL CRAMDMP(23H SURVIVES PHOTON BLAST. )
IF(X.GT.0.05) GO TO 50
CALL CRAMDMP(12H DISAPPEARS. )
QUAD(IX,IY)=IHNUM
CALL DROPIN('@',DUM,MY)
ITHERE=0
GO TO 50
7002 IF(IQUAD.NE.IHNUM) GOTO 7005
CALL PROUT(35H***TORPEDO ABSORBED BY THOLIAN WEB. ,35)
GOTO 50
7005 IF(IQUAD.NE.IHB) GO TO 75
CALL CRMSENA(IHB,2,IX,IY)
IF(HIT .LT. 600.0) GO TO 7510
CALL CRAM(12H DESTROYED )
IF(IPHWHO.NE.1) CALL CRAM(21H.... CONGRATULATIONS )
CALL CREND
IF(STARCH(QUADX,QUADY) .LT. 0) STARCH(QUADX,QUADY)=0
DO 71 LLL=1,REMBASE
IF(BASEQX(LLL).NE.QUADX .OR. BASEQY(LLL).NE.QUADY) GO TO 71
BASEQX(LLL)=BASEQX(REMBASE)
BASEQY(LLL)=BASEQY(REMBASE)
71 CONTINUE
QUAD(IX,IY)=IHDOT
REMBASE=REMBASE-1
BASEX=0
BASEY=0
GALAXY(QUADX,QUADY)=GALAXY(QUADX,QUADY)-10
IF(IPHWHO.NE.1) BASEKL=BASEKL+1
CALL NEWCOND
GO TO 50
C--------TEST FOR AND COPE WITH A HIT ON A PLANET.
75 IF(IQUAD .NE. IHP) GO TO 80
CALL CRMSENA(IHP,2,IX,IY)
IF(HIT .GT. 450.0) GO TO 7520
7510 CALL CRAMDMP(23H SURVIVES PHOTON BLAST.)
GO TO 50
7520 CALL CRAMDMP(11H DESTROYED. )
IF(IPHWHO.NE.1)NPLANKL=NPLANKL+1
NEWSTUF(QUADX,QUADY)=NEWSTUF(QUADX,QUADY)-1
DO 76 II=1,5
76 PLNETS(IPLANET,II)=0
IPLANET=0
PLNETX=0
PLNETY=0
QUAD(IX,IY)=IHDOT
IF(LANDED .NE. 1) GO TO 50
C--------CAPTAIN PERISHES ON PLANET.
CALL FINISH(15)
RETURN
80 IF(IQUAD .NE. IHSTAR) GO TO 90
C--------STAR HIT - CHECK FOR NOVA RESULTS
IF(HIT.GT.270.0) GO TO 85
CALL CRMSENA(IHSTAR,2,IX,IY)
CALL CRAMDMP(28H UNAFFECTED BY PHOTON BLAST.)
GO TO 50
85 CALL NOVA(IX,IY)
IF(GALAXY(QUADX,QUADY) .EQ. 1000) RETURN
IF(ALLDONE.NE.0) RETURN
GO TO 50
C--------CHECK FOR A BOOMERANG TORPEDO
90 IF(IQUAD .NE.ISHIP) GO TO 93
IF(CONDIT.NE.IHDOC) GO TO 9010
IF(RANF(0).GT.0.77) GO TO 9010
CALL CRAM(27H STAR BASE SHIELDS PROTECT )
CALL CRAMSHP
CALL CREND
GO TO 50
9010 CALL CRAM3AS
CALL CRAMSHP
CALL CRAMDMP(27H BLASTED BY PHOTON TORPEDO! )
CALL NEWCOND
CALL ZAP
IF(ENERGY .GT. 0.0) GO TO 91
IF(KSHOT.NE.0) GO TO 9020
CALL FINISH(22)
RETURN
9020 CALL FINISH(5)
RETURN
91 CALL CASULTY
C--------CHECK TO SEE IF SHIP DISPLACED
CALL CRAMSHP
GO TO 6901
C--------CHECK FOR HIT ON THING.
93 IF(IQUAD .NE. IHQUEST) GO TO 95
CALL SKIP(1)
CALL PROUT(
+ 55H"AAAAIIIIIEEEEEEEEEAAAAAAAAUUUUUGGGGGHHHHHHHHHHHHHHH!!!,55)
CALL PROUT(
+ 48H HACK! HACK! HACK! *CHOKE!* ",48)
CALL SKIP(1)
CALL PROUT(26HMR. SPOCK: "FASCINATING!",26)
QUAD(IX,IY)=IHDOT
GO TO 50
C--------TORPEDO ENTERS VICINITY OF BLACK HOLE. CHECK FOR DEFLECTION
95 CALL CRMSENA('@',2,IX,IY)
IF(DISTN .LT. 0.1) GO TO 97
C--------BOING. COMPUTE DEFLECTION ANGLE, AND NEW STARTING POINT
SPRANG=(0.5-DISTN) * 7.853981634
BETA=1.57079633 + ANGLE - SPRANG
STARTX = IX-DISTN*SIN(BETA)
STARTY = IY+DISTN*COS(BETA)
ANGLE = ANGLE - SIGN(SPRANG,SINANG)
CALL CRAMDMP(18H DEFLECTS TORPEDO. )
CALL CRAM(9HNEW TRACK)
GO TO 5720
97 CALL CRAMDMP(18H SWALLOWS TORPEDO.)
GO TO 50
C--------END INNER LOOP FOR MOVING ONE TORPEDO
105 CALL CREND
106 CALL PROUT(15HTORPEDO MISSED.,15)
GO TO 50
115 IF(REMKL .EQ. 0) CALL FINISH(1)
IF(KSHOT .EQ. 0) CALL SORTKL
RETURN
END

344
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRPLANET.FOR Normal file
View File

@@ -0,0 +1,344 @@
SUBROUTINE PLANET
C
C 4-APR-79
C FIX MESSAGE ABOUT SHUTTLE CRAFT'S CULINARY MISSION.
C 28-NOV-79
C ALLOW STARBASE SR SCANNERS TO BE USED FOR SENSOR SCAN.
C*
C* SUBROUTINE PLANETS CONTAINS ENTRY POINTS FOR :
C*
C* ORBIT,BEAM,MINE,CRYSTAL,SENSOR,GALILEO,DEATHRA
C*
INCLUDE 'TREKCOM/NOLIST'
CALL SKIP(1)
IKNOW=0
DO 101 I=1,INPLAN
101 IKNOW=IKNOW+PLNETS(I,5)
IF(IKNOW.NE.0)GO TO 102
CALL PROUT('SPOCK: "WE HAVE NO INFORMATION ON ANY PLANET,
1 CAPTAIN."',56)
RETURN
102 CALL PROUT('SPOCK: "PLANET REPORT FOLLOWS, CAPTAIN."',41)
CALL SKIP(1)
DO 1 I=1,INPLAN
IF(PLNETS(I,5) .EQ. 0) GO TO 1
IX=PLNETS(I,1)
IY=PLNETS(I,2)
ICLASS=PLNETS(I,3)
IDIL=PLNETS(I,4)
CALL CRAMLOC(1,IX,IY)
CALL CRAM(9H CLASS )
CALL CRAMEN(ICLASS)
CALL CRAM(3H )
IF(IDIL .EQ. 0) CALL CRAM (3HNO )
CALL CRAMDMP(28HDILITHIUM CRYSTALS PRESENT. )
1 CONTINUE
RETURN
C*
ENTRY ORBIT
C*
CALL SKIP(1)
IDIDIT=0
IF(INORBIT .EQ. 0) GO TO 2
CALL PROUT(26HALREADY IN STANDARD ORBIT. ,26)
RETURN
C--------CHECK FOR ENGINE DAMAGE.
2 IF((DAMAGE(7) .EQ. 0.) .OR. (DAMAGE(6) .EQ. 0.)) GO TO 3
CALL PROUT(38HBOTH WARP AND IMPULSE ENGINES DAMAGED. ,38)
RETURN
C--------CHECK TO SEE IF SHIP ADJACENT TO PLANET.
3 IF(PLNETX .EQ. 0) GO TO 5
IF(IABS(SECTX-PLNETX) .LE. 1 .AND. IABS(SECTY-PLNETY) .LE. 1)
C GO TO 10
5 CALL CRAMSHP
CALL CRAMDMP(24H NOT ADJACENT TO PLANET. )
RETURN
10 TIME = .02+.03*RANF(0)
IF(DAMAGE(6) .GT. 0.) TIME=TIME*10.
C--------GO AHEAD, SULU.
CALL PROUT(46HHELMSMAN SULU: "ENTERING STANDARD ORBIT, SIR.
1 ,46)
CALL NEWCOND
ASSIGN 17 TO IWHERE
16 IDIDIT=1
CALL EVENTS
IF(ALLDONE.EQ.1 .OR. GALAXY(QUADX,QUADY).EQ.1000 .OR. JUSTIN.EQ.1)
+ RETURN
GO TO IWHERE
17 CALL CRAM(11H ALTITUDE )
HEIGHT=1400.+7200.*RANF(0)
CALL CRAMF(HEIGHT,0,2)
CALL CRAMDMP(13H KILOMETERS.")
INORBIT=1
RETURN
C*
ENTRY BEAM
C*
CALL SKIP(1)
IF(DAMAGE(12) .EQ. 0) GO TO 19
CALL PROUT(21HTRANSPORTER DAMAGED. ,21)
IF(DAMAGE(10) .NE. 0) RETURN
CALL SKIP(1)
CALL PROUT(47HSPOCK: "MAY I SUGGEST THE SHUTTLE CRAFT, SIR."
1 ,47)
RETURN
19 IF(INORBIT.NE.0) GO TO 1910
1901 CALL CRAMSHP
CALL CRAMDMP(23H NOT IN STANDARD ORBIT. )
RETURN
1910 IF(SHLDUP .EQ. 0) GO TO 1920
CALL PROUT(41HIMPOSSIBLE TO TRANSPORT THROUGH SHIELDS. ,41)
RETURN
1920 IF(PLNETS(IPLANET,5) .EQ. 1) GO TO 1940
1930 CALL PROUT(56HSPOCK: "CAPTAIN, WE HAVE NO INFORMATION ON THIS PLA
CNET, ,56)
CALL PROUT(64H AND STARFLEET REGULATIONS CLEARLY STATE THAT IN TH
CIS SITUATION ,64)
CALL PROUT(23H YOU MAY NOT GO DOWN." ,23)
RETURN
1940 IF(LANDED .EQ. 1) GO TO 30
IF(PLNETS(IPLANET,4) .EQ. 1) GO TO 20
CALL PROUT(44HSPOCK: CAPTAIN, I FAIL TO SEE THE LOGIC IN ,44)
CALL PROUT(
+51H EXPLORING A PLANET WITH NO DILITHIUM CRYSTALS. ,51)
ASSIGN 20 TO IWHERE
1950 CALL PROMPT(30H ARE YOU SURE THIS IS WISE? ,30)
IF(JA(DUMMY)) GO TO IWHERE
RETURN
20 CALL PROUT(41HSCOTTY: "TRANSPORTER ROOM READY, SIR." ,41)
CALL SKIP(1)
CALL PROUT(63HKIRK, AND LANDING PARTY PREPARE TO BEAM DOWN TO PLAN
CET SURFACE. ,63)
CALL SKIP(1)
CALL PROUT(18HKIRK: "ENERGIZE." ,18)
21 CALL SKIP(1)
CALL PROUT(41HWWHOOOIIIIIRRRRREEEE.E.E. . . . . . . ,41)
IF(RANF(0) .GT. 0.98) GO TO 35
CALL PROUT(41H. . . . . . .E.E.EEEERRRRRIIIIIOOOHWW ,41)
CALL SKIP(1)
CALL PROUT(19HTRANSPORT COMPLETE. ,19)
LANDED = LANDED *(-1)
IF((LANDED .NE. 1) .AND. (IMINE .EQ. 1)) ICRYSTL = 1
IMINE=0
RETURN
C--------READY TO BEAM UP TO SHIP.
30 IF(ISCRAFT .EQ. 1) GO TO 32
CALL PROUT(42HYOU MAY NOT LEAVE SHUTTLE CRAFT ON PLANET. ,42)
RETURN
32 CALL PROUT(42HLANDING PARTY ASSEMBLED, READY TO BEAM UP. ,42)
CALL SKIP(1)
CALL PROUT(31HKIRK WHIPS OUT COMMUNICATOR... ,31)
CALL PROUT(17HBEEP BEEP BEEP ,17)
CALL SKIP(1)
CALL PROUT(54H"KIRK TO ENTERPRISE: LOCK ON COORDINATES...ENERGIZE
C." ,54)
GO TO 21
C--------CATASTROPHE!
35 CALL SKIP(1)
CALL PROUT(31HBOOOIIIOOOIIOOOOIIIOIING . . . ,31)
CALL SKIP(1)
CALL PROUT(38HSCOTTY: "OH MY GOD! I'VE LOST THEM." ,38)
CALL FINISH(13)
RETURN
C*
ENTRY MINE
C*
IDIDIT=0
CALL SKIP(1)
IF(LANDED .EQ. 1) GO TO 50
CALL PROUT(27HMINING PARTY NOT ON PLANET. ,27)
RETURN
50 IF(PLNETS(IPLANET,4) .EQ. 1) GO TO 51
CALL PROUT(37HNO DILITHIUM CRYSTALS ON THIS PLANET. ,37)
RETURN
51 TIME =(0.1+0.2*RANF(0)) * PLNETS(IPLANET,3)
ASSIGN 52 TO IWHERE
GO TO 16
52 CALL PROUT(26HMINING OPERATION COMPLETE. ,26)
IMINE=1
RETURN
C*
ENTRY CRYSTAL
C*
CALL SKIP(1)
IF(ICRYSTL .EQ. 1) GO TO 55
CALL PROUT(32HNO DILITHIUM CRYSTALS AVAILABLE. ,32)
RETURN
55 IF(ENERGY .LT. 1000.) GO TO 5510
CALL PROUT(66HSPOCK: "CAPTAIN, STARFLEET REGULATIONS PROHIBIT SUC
CH AN OPERATION ,66)
CALL PROUT(41H EXCEPT WHEN CONDITION YELLOW EXISTS." ,41)
RETURN
5510 CALL PROUT(46HSPOCK: "CAPTAIN, I MUST WARN YOU THAT LOADING
1 ,46)
CALL PROUT(46H RAW DILITHIUM CRYSTALS INTO THE SHIP'S POWER
1 ,46)
CALL PROUT(37H SYSTEM MAY RISK A SEVERE EXPLOSION. ,37)
ASSIGN 56 TO IWHERE
GO TO 1950
56 CALL SKIP(1)
CALL PROUT(45HENGINEERING OFFICER SCOTT: "(GULP) AYE SIR." ,45)
CALL PROUT(32H "MR. SPOCK AND I WILL TRY IT." ,32)
CRYPROB=CRYPROB*2.0
CALL SKIP(1)
CALL PROUT(32HSPOCK: "CRYSTAL IN PLACE, SIR." ,32)
CALL PROUT(31H "READY TO ACTIVATE CIRCUIT." ,31)
CALL SKIP(1)
CALL PROUT(42HSCOTTY: "KEEP YOUR FINGERS CROSSED, SIR!" ,42)
CALL SKIP(1)
IF(RANF(0) .GT. CRYPROB) GO TO 57
CALL PROUT(41H "ACTIVATING NOW! - - NO GOOD! IT'S*** ,41)
5610 CALL PROUT(54H***RED ALERT! RED A*L******************************
+**,54)
CALL STARS
CALL PROUT(54H***************** KA-BOOM!!!! ****************
C** ,54)
CALL KABOOM
RETURN
57 ENERGY = ENERGY +5000.*(1.+0.9*RANF(0))
CALL PROUT(38H "ACTIVATING NOW% - - THE INSTRUMENTS ,38)
CALL PROUT(36H ARE GOING CRAZY, BUT I THINK IT'S ,36)
CALL PROUT(41H GOING TO WORK! CONGRATULATIONS, SIR!" ,41)
RETURN
C*
ENTRY SENSOR
C*
CALL SKIP(1)
IF(DAMAGE(1) .EQ. 0 .OR. CONDIT .EQ. IHDOCKD) GOTO 60
CALL PROUT(28HSHORT RANGE SENSORS DAMAGED. ,28)
RETURN
60 IF(PLNETX .NE. 0) GO TO 65
CALL PROUT(27HNO PLANET IN THIS QUADRANT. ,27)
RETURN
65 CALL CRAM(24HSPOCK: "SENSOR SCAN FOR )
CALL CRAMLOC(1,QUADX,QUADY)
CALL CRAMDMP(1H:)
CALL SKIP(1)
CALL CRAM(18H PLANET AT)
CALL CRAMLOC(2,PLNETX,PLNETY)
CALL CRAM(13H IS OF CLASS )
ICLASS=PLNETS(IPLANET,3)
IDIL=PLNETS(IPLANET,4)
CALL CRAMEN(ICLASS)
CALL CRAMDMP(1H.)
CALL CRAM(27H READINGS INDICATE )
IF(IDIL .EQ. 0) CALL CRAM(3HNO )
CALL CRAMDMP(28HDILITHIUM CRYSTALS PRESENT." )
PLNETS(IPLANET,5) = 1
RETURN
C*
ENTRY GALILEO
C*
CALL SKIP(1)
IDIDIT = 0
IF(DAMAGE(10) .EQ. 0) GO TO 72
IF(DAMAGE(10) .GT. 0.) GO TO 71
IF(DAMAGE(10) .EQ. -1.) GO TO 70
CALL PROUT(36HSHUTTLE CRAFT NOW SERVING BIG MAC'S.,36)
RETURN
70 CALL PROUT(38HYE FAERIE QUEENE HAS NO SHUTTLE CRAFT. ,38)
RETURN
71 CALL PROUT(22HSHUTTLE CRAFT DAMAGED. ,22)
RETURN
72 IF(INORBIT .EQ. 1) GO TO 75
GO TO 1901
75 IF(SHLDUP .EQ. 0 .AND. CONDIT .NE. IHDOCKD) GO TO 80
CALL PROUT(42HSHUTTLE CRAFT CANNOT PASS THROUGH SHIELDS.,42)
RETURN
80 IF(PLNETS(IPLANET,5) .NE. 1) GO TO 1930
TIME=3.0E-5*HEIGHT
IF(LANDED .NE. 1) GO TO 100
IF(ISCRAFT .NE. 1) GO TO 98
C--------SHUTTLE CRAFT TO THE RESCUE.
IF(DAMAGE(12) .NE. 0) GO TO 95
CALL PROMPT(47HSPOCK: WOULD YOU RATHER USE THE TRANSPORTER? ,47)
IF(JA(DUMMY)) RETURN
95 IF(DAMAGE(12) .EQ. 0) CALL CRAM(13HSHUTTLE CREW )
IF(DAMAGE(12) .NE. 0) CALL CRAM(13HRESCUE PARTY )
CALL CRAMDMP(50HBOARDS "GALILEO" AND SWOOPS TOWARD PLANET SURFACE.
C )
ISCRAFT=0
ASSIGN 97 TO IWHERE
96 CALL SKIP(1)
GO TO 16
97 CALL PROUT(14HTRIP COMPLETE.,14)
RETURN
C--------LANDING PARTY BOARDS GALILEO FOR TRIP BACK TO SHIP.
98 CALL PROUT(35HYOU AND YOUR MINING PARTY BOARD THE ,35)
CALL PROUT(
+51HSHUTTLE CRAFT FOR THE TRIP BACK TO THE ENTERPRISE. ,51)
CALL SKIP(1)
CALL PROUT(26HTHE SHORT HOP BEGINS . . . ,26)
ICRAFT=1
LANDED=-1
ASSIGN 99 TO IWHERE
GO TO 96
99 ICRAFT=0
ISCRAFT=1
IF(IMINE.NE.0) ICRYSTL=1
IMINE=0
GO TO 97
C--------LANDING PARTY HEADS DOWN TO PLANET.
100 CALL PROUT(36HMINING PARTY ASSEMBLES IN THE HANGAR ,36)
CALL PROUT(
+51HDECK, READY TO BOARD THE SHUTTLE CRAFT "GALILEO." ,51)
CALL SKIP(1)
CALL PROUT(41HTHE HANGAR DOORS OPEN; THE TRIP BEGINS. ,41)
ICRAFT=1
ISCRAFT=0
ASSIGN 110 TO IWHERE
GO TO 96
110 LANDED=1
ICRAFT=0
GO TO 97
C*
ENTRY DEATHRA
C*
IDIDIT=0
CALL SKIP(1)
IF(SHIP .EQ. IHE) GO TO 113
CALL PROUT(34HYE FAERIE QUEENE HAS NO DEATH RAY.,34)
RETURN
113 IF(NENHERE .GE. 1) GO TO 115
CALL PROUT(56HSULU: "BUT SIR, THERE ARE NO ENEMIES IN THIS QUADRA
+NT.",56)
RETURN
115 IF(DAMAGE(14).LE.0) GOTO 116
CALL PROUT(17HDEATHRAY DAMAGED.,17)
RETURN
116 IDIDIT=1
CALL PROUT(44HKIRK: "PREPARE FOR ACTIVATION OF DEATHRAY!",44)
CALL SKIP(1)
CALL PROUT(37HSPOCK: "PREPARATIONS COMPLETE, SIR.",37)
CALL PROUT(16HKIRK: "ENGAGE!",16)
CALL SKIP(1)
CALL PROUT(45HWHIRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRR,45)
R=RANF(0)
IF(R .GT. 0.30) GO TO 130
C--------BANG!
CALL PROUT(32HSULU: "CAPTAIN! IT'S WORKING!",32)
CALL REDALRT
CALL PROUT(41H***MATTER-ANTIMATTER IMPLOSION IMMINENT! ,41)
GO TO 5610
C--------SUCCESS!
130 CALL PROUT(32HSULU: "CAPTAIN! IT'S WORKING!",32)
CALL SKIP(1)
NENHER2=NENHERE
DO 135 I=1,NENHER2
II=KX(1)
JJ=KY(1)
135 CALL DEADKL(II,JJ,QUAD(II,JJ),II,JJ)
CALL SKIP(1)
CALL PROUT(42HENSIGN CHEKOV: "CONGRATULATIONS CAPTAIN!",42)
IF(REMKL .EQ. 0) CALL FINISH(1)
IF(REMKL .EQ. 0) RETURN
CALL SKIP(1)
CALL PROUT(
+56HSPOCK: "CAPTAIN, I BELIEVE THE "EXPERIMENTAL DEATH RAY",56)
IF(RANF(0).GT..05) GOTO 140
CALL PROUT(22HIS STILL OPERATIONAL.",22)
RETURN
140 CALL PROUT(33HHAS BEEN RENDERED DISFUNCTIONAL.",33)
DAMAGE(14)=39.95
RETURN
END

111
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRPLAQUE.FOR Normal file
View File

@@ -0,0 +1,111 @@
SUBROUTINE PLAQUE
C
C 30-MAY-79
C OUTPUT DATE WITH LOWER-CASE CHARACTERS
C 31-MAY-79
C DON'T RE-OPEN OUTPUT IF LUN=2 ON ENTRY
C
INCLUDE 'TREKCOM/NOLIST'
COMMON/PLAQ/ISCORE,PERDATE,ISKILL
LOGICAL*1 NAME(30)
COMMON/SCANBF/KEY,AITEM
COMMON/PRLUN/LUN
LUNSAV=LUN
LUN=1
11 CALL PROMPT('ENTER NAME (UP TO 30 CHARACTERS): ',34)
LUN=LUNSAV
READ(1,20,ERR=11,END=11) ICHAR,NAME
20 FORMAT(Q,30A1)
NSKIP=65-ICHAR/2
IF(LUN.EQ.2)GO TO 25
LUN=2
CALL CLOSE(2)
CALL ASSIGN(2,'LP:')
25 WRITE(2,30)
30 FORMAT('1')
CALL SKIP(4)
C--------DRAW ENTERPRISE PICTURE.
CALL PROUT(114H
+ EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE,
+114)
CALL PROUT (114H EEE
+ E : : : E,
+114)
CALL PROUT (114H EE EEE
+ E : : NCC-1701 : E,
+114)
CALL PROUT (113H EEEEEEEEEEEEEEEE EEEEEE
+EEEEEEEEE E : : : E,
+114)
CALL PROUT (112H E
+ E EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
1 ,114)
CALL PROUT (81H EEEEEEEEE EEEEE
+EEEEEEEE E E ,81)
CALL PROUT (81H EEEEEEE EEEEE E
+ E E E ,81)
CALL PROUT (81H EEE
+ E E E E ,81)
CALL PROUT (81H
+ E E E E ,81)
CALL PROUT (81H
+ EEEEEEEEEEEEE E E ,81)
CALL PROUT (87H
+ EEE : EEEEEEE EEEEEEEE,87)
CALL PROUT (88H
+ :E : EEEE E,88)
CALL PROUT (88H
+.-E -:----- E,88)
CALL PROUT (88H
+ :E : E,88)
CALL PROUT (87H
+ EE : EEEEEEEE,87)
CALL PROUT (81H
+ EEEEEEEEEEEEEEEEEEEEEEE ,81)
CALL SKIP(3)
CALL PROUT(74H
+ U. S. S. ENTERPRISE,74)
5 CALL SKIP(1)
CALL SKIP(3)
CALL PROUT(93H For demonstrating
+outstanding ability as a starship captain,93)
CALL SKIP(1)
CALL PROUT(81H Star
+fleet Command bestows to you ,81)
CALL SKIP(1)
DO 8 I=1,NSKIP
8 CALL CRAM(1H )
CALL CRAMS(NAME,ICHAR)
CALL CREND
CALL SKIP(1)
CALL PROUT(71H
+ the rank of ,71)
CALL SKIP(1)
CALL PROUT(75H
+ "Commodore Emeritus",75)
CALL SKIP(1)
CALL CRAM(58H
+ )
IF(ISKILL .EQ. 4) CALL CRAM(8H Expert )
IF(ISKILL .EQ. 5) CALL CRAM(9HEmeritus )
CALL CRAMDMP(5Hlevel)
CALL SKIP(1)
CALL CRAM(66H
1 This day of )
CALL FOR$DATE(NAME)
NAME(5)=NAME(5)+32
NAME(6)=NAME(6)+32
CALL CRAMS(NAME,9)
CALL CREND
CALL SKIP(1)
CALL CRAM(69H
1 Your score: )
CALL CRAMI(ISCORE,0)
CALL CREND
CALL SKIP(1)
CALL CRAM(76H
1Klingons per stardate: )
CALL CRAMF(PERDATE,0,2)
CALL CREND
RETURN
END

19
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRPRELIM.FOR Normal file
View File

@@ -0,0 +1,19 @@
SUBROUTINE PRELIM
C
C 5-APR-79
C UPDATE THE GREETING MESSAGE.
C
C--------PRINT A BUNCH OF GARBAGE WHEN GAME IS FIRST ENTERED
CALL ASSIGN(1,'TT:')
CALL PROUT(28H** U.T. "SUPER" STAR TREK **,28)
CALL PROUT(25HADAPTED FOR VAX/VMS BY MK,25)
CALL SKIP(1)
CALL PROUT(26HLIST THE FILE STARTREK.DOC,26)
CALL PROUT(25HFOR PLAYING INSTRUCTIONS.,25)
CALL SKIP(1)
C CALL PROUT(
C 1 44HFOR LATEST ON UPDATES, TYPE "TRKNEWS" AS ,44)
C CALL PROUT(
C $52HYOUR GAME. FOR PLAYING INSTRUCTIONS ENTER "TRKINST" ,52)
RETURN
END

15
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRPROUT.FOR Normal file
View File

@@ -0,0 +1,15 @@
SUBROUTINE PROUT(LINE,KOUNT)
COMMON/PRLUN/LUN
BYTE LINE(120)
DATA LUN/1/
CALL CHEW
WRITE (LUN,100,ERR=900) (LINE(I),I=1,KOUNT)
100 FORMAT (1X120A1)
RETURN
ENTRY PROMPT(LINE,KOUNT)
CALL CHEW
WRITE (LUN,101,ERR=900) (LINE(I),I=1,KOUNT)
101 FORMAT ('$',120A1)
900 CONTINUE
RETURN
END

38
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRRAM.FOR Normal file
View File

@@ -0,0 +1,38 @@
SUBROUTINE RAM(IBUMPD,IENM,IX,IY)
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 IENM
CALL REDALRT
CALL PROUT(22H***COLLISION IMMINENT.,22)
CALL SKIP(2)
CALL CRAM3AS
CALL CRAMSHP
TYPE=1.0
IF(IENM .EQ. IHT) TYPE=0.5
IF(IENM .EQ. IHR) TYPE=1.5
IF(IENM .EQ. IHC) TYPE=2.0
IF(IENM .EQ. IHS) TYPE=2.5
IF(IBUMPD .EQ. 0) CALL CRAM(6H RAMS )
IF(IBUMPD .EQ. 1) CALL CRAM(11H RAMMED BY )
CALL CRAMENA(IENM,2,IX,IY)
CALL CREND
CALL DEADKL(IX,IY,IENM,SECTX,SECTY)
CALL CRAM3AS
CALL CRAMSHP
CALL CRAMDMP(17H HEAVILY DAMAGED.)
ICAS=10.0+20.0*RANF(0)
CALL CRAM(19H***SICKBAY REPORTS )
CALL CRAMI(ICAS,0)
CALL CRAMDMP(12H CASUALTIES.)
CASUAL=CASUAL+ICAS
DO 10 L=1,NDEVICE
IF(DAMAGE(L) .LT. 0) GO TO 10
IF(L.EQ.14) GOTO 10
EXTRADM=(10.0*TYPE*RANF(0)+1.0)*DAMFAC
DAMAGE(L)=DAMAGE(L)+TIME+EXTRADM
10 CONTINUE
ISUBDAM=1
SHLDUP=0
IF(REMKL.NE.0) CALL DREPORT
IF(REMKL .EQ. 0) CALL FINISH(1)
RETURN
END

16
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRRANF.FOR Normal file
View File

@@ -0,0 +1,16 @@
REAL FUNCTION RANF(DUMMY)
C
C 25-APR-79
C CHANGED TO USE THE ONE-ARGUMENT VERSION OF THE RAN FUNCTION,
C AND TO USE AN INTEGER*4 SEED.
C
INTEGER*4 IRAN,ISEED
C*
RANF=RAN(IRAN)
RETURN
C*
ENTRY RANSET(ISEED)
C*
IRAN=ISEED
RETURN
END

85
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRSCAN.FOR Normal file
View File

@@ -0,0 +1,85 @@
SUBROUTINE SCAN
C
C 5-APR-79
C ACCEPT LOWER CASE ALPHA INPUT AND CONVERT TO UPPER CASE.
C CALL GETOUT WHEN A CTRL/Z IS TYPED TO ERASE THE SCREEN
C AND EXIT.
C
INCLUDE 'TREKCOM/NOLIST'
REAL*8 AITEM,TITEM
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE (FNUM,AITEM)
BYTE LINE(80),KHAR,ITEM(8)
EQUIVALENCE (TITEM,ITEM)
DATA ICH,KHAR,ITEM/80,1H ,0,0,0,0,0,0,0,0/
C--------READ IN NEW LINE IF NEEDED.
4 IF(ICH.LT.80) GO TO 5
READ (1,100,ERR=700,END=900) ICHAR,LINE
100 FORMAT (Q,80A1)
LINE(ICHAR+1)=0
5 AITEM=0
ASSIGN 10 TO IRET
10 IF(KHAR .EQ. 1H ) GO TO 500
C--------IF END-OF LINE IS HIT, RETURN WITH AITEM=0.
IF(ICHAR.EQ.0) GOTO 15
IF(KHAR.NE.0) GOTO 20
15 KEY=IHEOL
GO TO 600
C--------IF INPUT IS NOT NUMERIC, PACK ALL CHARACTERS TOGETHER UP TO
C A BLANK OR END-OF-LINE, AND RETURN IN 10H FORMAT.
20 IF(KHAR.EQ.1H+ .OR. KHAR.EQ.1H- .OR. KHAR.EQ.1H.) GO TO 40
IF(KHAR.GE.1H0 .AND. KHAR.LE.1H9) GO TO 40
IF(KHAR .LT. 1HA .OR. KHAR .GT. 1HZ) GO TO 500
KEY=IHALPHA
ASSIGN 25 TO IRET
ICHX=1
GO TO 26
25 ICHX=ICHX+1
IF(KHAR .EQ. 0 .OR. KHAR .EQ. 1H ) GOTO 30
26 IF(ICHX .LE. 8) ITEM(ICHX)=KHAR
GOTO 500
30 IF(ICHX.GT.8) GOTO 35
DO 34 IT=ICHX,8
34 ITEM(IT)=1H
35 AITEM=TITEM
RETURN
C--------INPUT IS NUMERIC. RETURN AS A REAL NUMBER.
40 KEY=IHREAL
SIGN=1.0
KEXPON=0
KFRACT=0
ASSIGN 50 TO IRET
IF(KHAR .EQ. 1H+) GO TO 500
IF(KHAR .NE. 1H-) GO TO 50
SIGN=-1.0
GO TO 500
50 IF(KHAR.LT.1H0 .OR. KHAR.GT.1H9) GO TO 60
IT=KHAR
FNUM=10.0*FNUM+FLOAT(IT-"60)
KEXPON=KEXPON-KFRACT
GO TO 500
60 IF(KHAR .NE. 1H.) GO TO 70
IF(KFRACT .NE. 0) GO TO 15
KFRACT=1
GO TO 500
70 AITEM=SIGN*AITEM*10.0**KEXPON
RETURN
C--------ROUTINE TO RETURN NEXT CHARACTER IN 1H FORMAT
C--------LOWER CASE IS CONVERTED TO UPPER CASE
500 ICH=ICH+1
IF(ICH .LE. 80) GO TO 510
ICH=1
510 KHAR=LINE(ICH)
IF(KHAR .GE. "140) KHAR=KHAR-"40
GO TO IRET
C*
ENTRY CHEW
C--------DISCARD REMAINDER OF LAST LINE READ IN.
600 ICH=80
KHAR=1H
RETURN
700 CALL PROUT(15HTTY READ ERROR.,15)
GO TO 4
900 CONTINUE
CALL GETOUT
END

162
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRSCOM.FOR Normal file
View File

@@ -0,0 +1,162 @@
SUBROUTINE SCOM
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 LOC
DIMENSION BDIST(5)
EQUIVALENCE (CRACKS(5),LOCSUP),(LOC,LOCSUP)
C--------COMPUTE DISTANCES TO STARBASES.
IF(REMBASE .LE. 0) GO TO 60
BDMAX=0.
SX=ISX
SY=ISY
DO 1 I=1,REMBASE
BQX=BASEQX(I)
BQY=BASEQY(I)
1 BDIST(I) = SQRT((BQX-SX)**2 +(BQY-SY)**2)
C--------SORT INTO NEAREST FIRST ORDER.
IF(REMBASE.LE.1) GO TO 4
MINUS1 = REMBASE -1
2 ISWITCH = 0
DO 3 I=1, MINUS1
IF(BDIST(I) .LE. BDIST(I+1)) GO TO 3
T=BDIST(I)
BDIST(I)=BDIST(I+1)
BDIST(I+1)=T
ISWITCH = 1
3 CONTINUE
IF(ISWITCH.NE.0) GO TO 2
C--------LOOK FOR NEAREST BASE WITHOUT A COMMANDER, NO ENTERPRISE, AND
C--------WITHOUT TOO MANY KLINGONS, AND NOT ALREADY UNDER ATTACK.
4 IFINDIT=0
IWHICHB=0
DO 8 I=1, REMBASE
IBQX=BASEQX(I)
IBQY=BASEQY(I)
IF((IBQX .EQ. QUADX) .AND. (IBQY .EQ. QUADY)) GO TO 8
IF((IBQX .EQ. BATX) .AND. (IBQY .EQ. BATY)) GO TO 8
NUM=GALAXY(IBQX,IBQY)
IF(NUM .GT. 899) GO TO 8
IF(REMCOM .LE. 0) GO TO 6
DO 5 J=1, REMCOM
5 IF((IBQX .EQ. CX(J)) .AND. (IBQY .EQ. CY(J))) GO TO 7
6 IFINDIT=1
IWHICHB=I
GO TO 10
7 IF (IFINDIT .EQ. 2) GO TO 8
IFINDIT=2
IWHICHB=I
8 CONTINUE
IF(IFINDIT .EQ. 0) RETURN
IBQX=BASEQX(IWHICHB)
IBQY=BASEQY(IWHICHB)
C--------DECIDE HOW TO MOVE TOWARD BASE.
10 IDELTX = IBQX -ISX
IF(IDELTX .GT. 1) IDELTX = 1
IF(IDELTX .LT. -1) IDELTX=-1
IDELTY=IBQY-ISY
IF(IDELTY .GT. 1) IDELTY = 1
IF(IDELTY .LT. -1) IDELTY=-1
C--------ATTEMPT FIRST TO MOVE IN BOTH X AND Y DIRECTION.
IQX=ISX+IDELTX
IQY=ISY+IDELTY
ASSIGN 23 TO IWHERE
C--------MAKE CHECKS ON POSSIBLE DESTINATION QUADRANT.
15 IF((IQX .EQ. QUADX) .AND. (IQY .EQ. QUADY)) GO TO IWHERE
IF((IQX.LT.1).OR.(IQX.GT.8).OR.(IQY.LT.1).OR.(IQY.GT.8))
+ GO TO IWHERE
NUM = GALAXY(IQX,IQY)
IF(NUM. GT. 899) GO TO IWHERE
C--------GO AHEAD AND MOVE.
GALAXY(ISX,ISY) = GALAXY(ISX,ISY) -100
ISX=IQX
ISY=IQY
GALAXY(ISX,ISY)=GALAXY(ISX,ISY)+100
IF(ISCATE .EQ. 0) GO TO 40
C--------S.C. HAS SCOOTED. REMOVE HIM FROM CURRENT QUADRANT.
ISCATE=0
ISATB=0
ISHERE=0
IENTESC=0
FUTURE(7)=1E38
DO 21 I=1,NENHERE
LOCSUP=I
IX=KX(I)
IY=KY(I)
IF(QUAD(IX,IY) .EQ. IHS) GO TO 22
21 CONTINUE
22 CALL LEAVE
QUAD(IX,IY)=IHDOT
CALL SORTKL
GO TO 40
C--------TRY SOME OTHER MANEUVERS
23 IF((IDELTX .EQ. 0) .OR. (IDELTY .EQ. 0)) GO TO 30
C--------TRY MOVING JUST IN X DIRECTION.
IQY=ISY
ASSIGN 25 TO IWHERE
GO TO 15
C--------THEN TRY MOVING JUST IN Y DIRECTION.
25 IQY=ISY+IDELTY
IQX=ISX
ASSIGN 300 TO IWHERE
GO TO 15
C--------ATTEMPT ANGLE MOVE.
30 IF(IDELTX.NE.0) GO TO 35
IQX=ISX+1
ASSIGN 32 TO IWHERE
GO TO 15
32 IQX = ISX-1
ASSIGN 300 TO IWHERE
GO TO 15
35 IQY = ISY+1
ASSIGN 36 TO IWHERE
GO TO 15
36 IQY = ISY-1
ASSIGN 300 TO IWHERE
GO TO 15
C--------SUPER-COMMANDER HAS MOVED. CHECK SITUATION.
C--------CHECK FOR A HELPFUL PLANET.
40 DO 44 I=1,INPLAN
IPLAN = I
IF((PLNETS(I,1) .NE. ISX) .OR.(PLNETS(I,2) .NE. ISY)) GO TO 44
IF(PLNETS(I,4) .NE. 1) GO TO 45
C--------DESTROY PLANET.
DO 43 J=1,5
43 PLNETS(IPLAN,J) = 0
NEWSTUF(ISX,ISY) = NEWSTUF(ISX,ISY)-1
IF(DAMAGE(9) .GT. 0) GO TO 45
CALL SKIP(1)
CALL PROUT(47HLT. UHURA: "CAPTAIN, STARFLEET COMMAND REPORTS,47)
CALL CRAM(13H A PLANET IN)
CALL CRAMLOC(1,ISX,ISY)
CALL CRAMDMP(19H HAS BEEN DESTROYED)
CALL PROUT(26H BY THE SUPER-COMMANDER.",26)
GO TO 45
44 CONTINUE
C--------CHECK FOR A BASE.
45 IF(REMBASE .EQ. 0) GO TO 60
DO 46 I=1,REMBASE
IBQX=BASEQX(I)
IBQY=BASEQY(I)
46 IF(IBQX.EQ.ISX .AND. IBQY.EQ.ISY .AND. ISX.NE.BATX .AND. ISY.NE.
+ BATY) GO TO 80
C--------CHECK FOR INTELLIGENCE REPORT.
IF(RANF(0) .GT. 0.2) RETURN
IF(DAMAGE(9).GT.0. .OR. STARCH(ISX,ISY).GT.0) RETURN
CALL SKIP(1)
CALL PROUT(52HLT. UHURA: "CAPTAIN, STARFLEET INTELLIGENCE REPORTS
+,52)
CALL CRAM(27H THE SUPER-COMMANDER IS IN)
CALL CRAMLOC(1,ISX,ISY)
CALL CRAMDMP(2H.")
C--------NOTHING ELSE TO DO.
RETURN
C--------NOTHING AVAILABLE. GO INTO HIBERNATION.
60 FUTURE(6)=1E38
RETURN
C--------ATTACK A BASE.
80 ISATB=1
FUTURE(7)=DATE+1.0+2.0*RANF(0)
IF(BATX.NE.0.0) FUTURE(7)=FUTURE(7)+FUTURE(5)-DATE
LOC=IHS
CALL SOS
300 RETURN
END

117
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRSCORE.FOR Normal file
View File

@@ -0,0 +1,117 @@
SUBROUTINE SCORE
C
C 31-MAY-79
C MAKE SCORE COME OUT UNCONDITIONALLY ON TERMINAL
C RETURN WITH LUN=2 IF SCORE WAS PRINTED ON LP
C
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 ISHIP
COMMON/PLAQ/ISCORE,PERDATE,ISKILL
COMMON/PRLUN/LUN
EQUIVALENCE (ISHIP,SHIP)
ISKILL=SKILL
TIMUSED=DATE-INDATE
IF(TIMUSED.EQ.0 .OR. REMKL.NE.0) TIMUSED=AMAX1(TIMUSED,5.0)
PERDATE=(KILLC+KILLK+NSCKILL)/TIMUSED
ITHPERD=500.0*PERDATE+0.5
IWON=0
IF(GAMEWON .NE. 0) IWON=100.0*SKILL
IF(ISHIP .EQ. IHE) KLSHIP=0
IF(ISHIP .EQ. IHF) KLSHIP=1
IF(ISHIP .EQ. 0) KLSHIP=2
IDIED=0
IF(ALIVE .EQ. 0) IDIED=200
IF(GAMEWON .EQ. 0) NROMREM=0
ISCORE = 10*KILLK + 50*KILLC + ITHPERD + IWON - IDIED
C -100*BASEKL -100*KLSHIP -45*NHELP -5*STARKL -CASUAL
C +20*NROMKL+200*NSCKILL-10*NPLANKL+NROMREM
100 CALL SKIP(1)
CALL PROUT(12HYOUR SCORE--,12)
CALL SKIP(1)
IF(NROMKL .EQ. 0) GO TO 1
CALL CRAMI(NROMKL,6)
CALL CRAM(35H ROMULANS DESTROYED )
CALL CRAMI(20*NROMKL,10)
CALL CREND
1 IF(NROMREM .EQ. 0) GO TO 5
CALL CRAMI(NROMREM,6)
CALL CRAM(35H ROMULANS CAPTURED )
CALL CRAMI(NROMREM,10)
CALL CREND
5 IF(KILLK .EQ. 0) GO TO 10
CALL CRAMI(KILLK,6)
CALL CRAM(35H ORDINARY KLINGONS DESTROYED )
CALL CRAMI(10*KILLK,10)
CALL CREND
10 IF(KILLC .EQ. 0) GO TO 12
CALL CRAMI(KILLC,6)
CALL CRAM(35H KLINGON COMMANDERS DESTROYED )
CALL CRAMI(50*KILLC,10)
CALL CREND
12 IF(NSCKILL .EQ. 0) GO TO 15
CALL CRAMI(NSCKILL,6)
CALL CRAM(35H SUPER-COMMANDER DESTROYED )
CALL CRAMI(200,10)
CALL CREND
15 IF(ITHPERD .EQ. 0) GO TO 20
CALL CRAMF(PERDATE,6,2)
CALL CRAM(35H KLINGONS PER STARDATE, AVERAGE )
CALL CRAMI(ITHPERD,10)
CALL CREND
20 IF(STARKL .EQ. 0) GO TO 30
CALL CRAMI(STARKL,6)
CALL CRAM(35H STARS DESTROYED BY YOUR ACTION )
CALL CRAMI(-5*STARKL,10)
CALL CREND
30 IF(NPLANKL.EQ.0) GO TO 32
CALL CRAMI(NPLANKL,6)
CALL CRAM(35H PLANETS DESTROYED BY YOUR ACTION )
CALL CRAMI(-10*NPLANKL,10)
CALL CREND
32 IF(BASEKL .EQ. 0) GO TO 35
CALL CRAMI(BASEKL,6)
CALL CRAM(35H BASES DESTROYED BY YOUR ACTION )
CALL CRAMI(-100*BASEKL,10)
CALL CREND
35 IF(NHELP .EQ. 0) GO TO 40
CALL CRAMI(NHELP,6)
CALL CRAM(35H CALLS FOR HELP FROM STARBASE )
CALL CRAMI( -45*NHELP,10)
CALL CREND
40 IF(CASUAL .EQ. 0) GO TO 45
CALL CRAMI(CASUAL,6)
CALL CRAM(35H CASUALTIES INCURRED )
CALL CRAMI(-CASUAL,10)
CALL CREND
45 IF(KLSHIP .EQ. 0) GOTO 50
CALL CRAMI(KLSHIP,6)
CALL CRAM(35H SHIP(S) LOST OR DESTROYED )
CALL CRAMI(-100*KLSHIP,10)
CALL CREND
50 IF(ALIVE .NE. 0) GO TO 60
CALL PROUT(
+ 50HPENALTY FOR GETTING YOURSELF KILLED -200,50)
60 IF(GAMEWON .EQ. 0) GO TO 70
CALL CRAM(18HBONUS FOR WINNING )
IF(SKILL .EQ. 1) CALL CRAM(13HNOVICE GAME )
IF(SKILL .EQ. 2) CALL CRAM(13HFAIR GAME )
IF(SKILL .EQ. 3) CALL CRAM(13HGOOD GAME )
IF(SKILL .EQ. 4) CALL CRAM(13HEXPERT GAME )
IF(SKILL .EQ. 5) CALL CRAM(13HEMERITUS GAME)
CALL CRAM(10H )
CALL CRAMI(IWON,10)
CALL CREND
70 CALL PROUT(0,1)
CALL CRAM(41HTOTAL SCORE )
CALL CRAMI(ISCORE,10)
CALL CREND
IF(LUN.EQ.2)RETURN
CALL SKIP(1)
CALL PROMPT
1 ('DO YOU WANT A COPY OF YOUR SCORE ON THE LINE PRINTER? ',54)
IF(JA(DUMMY).EQ.0)RETURN
LUN=2
CALL CLOSE(2)
CALL ASSIGN(2,'LP:')
GO TO 100
END

175
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRSETUP.FOR Normal file
View File

@@ -0,0 +1,175 @@
SUBROUTINE SETUP
INCLUDE 'TREKCOM/NOLIST'
EQUIVALENCE (CRACKS(2),SHUTUP)
C--------PREPARE THE ENTERPRISE
SHIP=IHE
INENRG=5000.0
ENERGY=5000.0
INSHLD=2500.0
SHLD=2500.0
SHLDUP=0
SHLDCHG=0
INLSR=4.0
LSUPRES=4.0
CALL IRAN8(QUADX,QUADY)
CALL IRAN10(SECTX,SECTY)
INTORPS=10
TORPS=10
WARPFAC=5.0
WFACSQ=25.0
DO 3 I=1,NDEVICE
3 DAMAGE(I)=0.0
ISUBDAM=0
C--------SET UP ASSORTED GAME PARAMETERS
SHUTUP=0.0
BATX=0
BATY=0
IDATE=31.0*RANF(0)+20.0
DATE=100*IDATE
INDATE=DATE
KILLK=0
KILLC=0
NKINKS=0
NHELP=0
RESTING=0
CASUAL=0
NROMKL=0
ISATB=0
ISCATE=0
IMINE=0
ICRYSTL=0
ICRAFT=0
NSCKILL=0
NPLANKL=0
ISCRAFT=1
LANDED=-1
CRYPROB=0.05
ICSOS=0
ISSOS=0
ALIVE=1
DOCKFAC=0.25
DO 4 I=1,8
DO 4 J=1,8
NEWSTUF(I,J)=0
4 STARCH(I,J)=0
C--------INITIALIZE TIMES FOR EXTRANEOUS EVENTS
FUTURE(1)=DATE+EXPRAN(0.5*INTIME)
FUTURE(2)=DATE+EXPRAN(1.5*INTIME/REMCOM)
FUTURE(3)=DATE+EXPRAN(0.5*INTIME)
FUTURE(4)=DATE+EXPRAN(0.3*INTIME)
FUTURE(5)=1E38
FUTURE(6)=1E38
IF(NSCREM.GT.0) FUTURE(6)=DATE+0.2777
FUTURE(7)=1E38
C--------PUT STARS IN THE GALAXY
INSTAR=0
DO 5 I=1,8
DO 5 J=1,8
K = RANF(0) * 9 + 1
INSTAR=INSTAR+K
5 GALAXY(I,J)=K
STARKL=0
C-------LOCATE STARBASES IN THE GALAXY (IMPROVED PLACEMENT)
DO 9 I=1,INBASE
6 CALL IRAN8(IX,IY)
IF(GALAXY(IX,IY).GE.10) GOTO 6
IF(I.EQ.1) GOTO 8
LIM=I-1
DO 7 J=1,LIM
DISTQ=(IX-BASEQX(J))**2 + (IY-BASEQY(J))**2
IF(DISTQ .LT. 6*(6-INBASE) .AND. RANF(0.) .LT. 0.75) GOTO 6
7 CONTINUE
8 BASEQX(I)=IX
BASEQY(I)=IY
STARCH(IX,IY)= -1
9 GALAXY(IX,IY)=GALAXY(IX,IY)+10
BASEKL=0
C--------POSITION ORDINARY KLINGON BATTLE CRUISERS
KREM=INKLING-INCOM-NSCREM
KLUMPER=0.25*SKILL*(9-LENGTH)+1.0
KLUMPER=MIN0(9,KLUMPER)
10 KLUMP=(1.0-RANF(0)**2)*KLUMPER
IF(KLUMP .GT. KREM) KLUMP=KREM
NUM=100*KLUMP
15 CALL IRAN8(IX,IY)
IF(GALAXY(IX,IY)+NUM .GT. 999) GO TO 15
GALAXY(IX,IY)=GALAXY(IX,IY)+NUM
KREM=KREM-KLUMP
IF(KREM .NE. 0) GO TO 10
C--------POSITION KLINGON COMMAND SHIPS
DO 18 I=1,INCOM
16 CALL IRAN8(IX,IY)
IF(GALAXY(IX,IY).LT.99 .AND. RANF(0).LT.0.75) GO TO 16
IF(GALAXY(IX,IY) .GT. 899)GO TO 16
IF(I .EQ. 1)GO TO 17
IM1=I-1
DO 1605 JJ=1,IM1
IF(CX(JJ) .EQ. IX .AND. CY(JJ) .EQ. IY)GO TO 16
1605 CONTINUE
17 GALAXY(IX,IY)=GALAXY(IX,IY)+100
CX(I)=IX
18 CY(I)=IY
C--------LOCATE PLANETS IN GALAXY
DO 20 I=1,INPLAN
19 CALL IRAN8(IX,IY)
IF(NEWSTUF(IX,IY) .GT. 0) GO TO 19
NEWSTUF(IX,IY)=1
PLNETS(I,1)=IX
PLNETS(I,2)=IY
C--------DECIDE WHAT KIND OF PLANET M=1, N=2, O=3.
PLNETS(I,3)=RANF(0)*3. + 1.
C--------DECIDE WHETHER DILITHIUM CRYSTALS ARE PRESENT.
PLNETS(I,4)=1.2*RANF(0)
PLNETS(I,5)=0
20 CONTINUE
C--------LOCATE ROMULANS.
DO 21 I=1,NROMREM
CALL IRAN8(IX,IY)
21 NEWSTUF(IX,IY)=NEWSTUF(IX,IY)+10
C--------LOCATE THE SUPER-COMMANDER, IF NEEDED.
IF(NSCREM .LT. 1) GO TO 23
22 CALL IRAN8(IX,IY)
IF(GALAXY(IX,IY) .GT. 899) GO TO 22
ISX=IX
ISY=IY
GALAXY(IX,IY)=GALAXY(IX,IY)+100
23 IDATE = DATE
CALL SKIP(1)
SNAP=0
C--------DECIDE IF GALAXY NEEDS A "THING"
IF((RANF(0) .GT. 0.04) .OR. (THINGX .EQ. -1)) GO TO 2301
CALL IRAN8(THINGX,THINGY)
GO TO 24
2301 THINGX=0
THINGY=0
C--------PRINT BRIEF INITIAL MESSAGE
24 CALL CRAM('STARDATE')
CALL CRAMI(IDATE,5)
CALL CREND
CALL CRAMI(INKLING,5)
CALL CRAMDMP(9H KLINGONS)
CALL PROUT(31HAN UNKNOWN NUMBER OF ROMULANS ,31)
IF(NSCREM .EQ. 0) GO TO 25
CALL PROUT(33HAND ONE (GULP) <SUPER-COMMANDER>.,33)
25 CALL CRAMI(IFIX(INTIME),5)
CALL CRAMDMP(10H STARDATES)
CALL CRAMI(INBASE,5)
CALL CRAM(24H STARBASES: QUADRANTS )
DO 50 I=1,INBASE
CALL CRAMLOC(0,BASEQX(I),BASEQY(I))
IF(I .LT. INBASE)CALL CRAM(2H, )
50 CONTINUE
CALL CREND
CALL SKIP(1)
CALL CRAM(30HTHE ENTERPRISE IS CURRENTLY IN)
CALL CRAMLOC(1,QUADX,QUADY)
CALL CRAM(1H,)
CALL CRAMLOC(2,SECTX,SECTY)
CALL CREND
CALL SKIP(1)
CALL CRAM(10HGOOD LUCK.)
IF(NSCREM.GT.0) CALL CRAM(17H YOU'LL NEED IT. )
CALL CREND
CALL NEWQUAD
RETURN
END

53
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRSETWARP.FOR Normal file
View File

@@ -0,0 +1,53 @@
SUBROUTINE SETWARP
INCLUDE 'TREKCOM/NOLIST'
REAL*8 AITEM
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE (FNUM,AITEM)
10 CALL SCAN
IF(KEY .NE. IHEOL) GO TO 20
CALL PROMPT(18H WARP FACTOR: ,18)
GO TO 10
20 IF(KEY .NE. IHREAL) GO TO 40
IF(DAMAGE(6) .GT. 10.0) GO TO 70
IF(DAMAGE(6) .GT. 0.0 .AND. FNUM .GT. 4.0) GO TO 80
IF(FNUM .LT. 1.0) GO TO 50
IF(FNUM .GT. 10.0) GO TO 60
OLDFAC=WARPFAC
WARPFAC=FNUM
WFACSQ=WARPFAC*WARPFAC
C--------GIVE ACCEPTANCE MESSAGE FOR WARP FACTORS <= 6 OR REDUCED
IF(WARPFAC .LE. OLDFAC .OR. WARPFAC .LE. 6.0) GO TO 31
IF(WARPFAC .LT. 8.00) GO TO 32
GO TO 33
31 CALL CRAM(29HHELMSMAN SULU: "WARP FACTOR )
CALL CRAMF(WARPFAC,0,1)
CALL CRAMDMP(11H, CAPTAIN.")
RETURN
C--------GIVE WARNING MESSAGES FOR WARP FACTORS ABOVE WARP 6
32 CALL PROUT(
+ 61HENGINEER SCOTT: "AYE, BUT OUR MAXIMUM SAFE SPEED IS WARP 6."
+ ,61)
RETURN
33 IF(WARPFAC .EQ. 10.0) GO TO 36
CALL PROUT(
+ 65HENGINEER SCOTT: "AYE, CAPTAIN, BUT OUR ENGINES MAY NOT TAKE
+ IT.",65)
RETURN
36 CALL PROUT(
+ 46HENGINEER SCOTT: "AYE, CAPTAIN, WE'LL TRY IT.",46)
RETURN
C--------GIVE REFUSAL MESSAGES FOR BAD WARP COMMANDS
40 CALL BEGPARD
RETURN
50 CALL PROUT(
+ 52HHELMSMAN SULU: "WE CAN'T GO BELOW WARP 1, CAPTAIN.",52)
RETURN
60 CALL PROUT(
+ 52HHELMSMAN SULU: "OUR TOP SPEED IS WARP 10, CAPTAIN.",52)
RETURN
70 CALL PROUT(25HWARP ENGINES INOPERATIVE.,25)
RETURN
80 CALL PROUT(45HENGINEER SCOTT: "I'M DOING MY BEST, CAPTAIN,,45)
CALL PROUT(41H BUT RIGHT NOW WE CAN ONLY GO WARP 4." ,41)
RETURN
END

99
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRSHIELDS.FOR Normal file
View File

@@ -0,0 +1,99 @@
SUBROUTINE SHIELDS
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 ITEM
REAL*8 AITEM
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE (FNUM,AITEM),(ITEM,AITEM)
IDIDIT=0
CALL SCAN
IF(KEY .NE. IHEOL) GO TO 30
15 CALL PROMPT(40HDO YOU WISH TO CHANGE SHIELD ENERGY? ,40)
IF(JA(DUMMY)) GO TO 8010
IF(DAMAGE(8).NE.0.0) GO TO 60
IF(SHLDUP.NE.0) GO TO 20
C*
ENTRY SHLDSUP
C*
CALL PROMPT(40HSHIELDS ARE DOWN. DO YOU WANT THEM UP? ,40)
IF(JA(DUMMY)) GO TO 40
GO TO 90
20 CALL PROMPT(40HSHIELDS ARE UP. DO YOU WANT THEM DOWN? ,40)
IF(JA(DUMMY)) GO TO 50
GO TO 90
30 IF(ITEM.EQ.1HT) GO TO 80
IF(DAMAGE(8).NE.0.0) GO TO 60
IF(ITEM.EQ. 1HU) GO TO 40
IF(ITEM.EQ. 1HD) GO TO 50
GO TO 15
C--------RAISE SHIELDS
40 IF(SHLDUP.NE.0) GO TO 45
SHLDUP=1
SHLDCHG=1
IF(CONDIT .NE. IHDOCKD ) ENERGY=ENERGY-50.0
CALL PROUT(15HSHIELDS RAISED.,15)
IF(ENERGY .LE. 0) GO TO 70
IDIDIT=1
RETURN
45 CALL PROUT(21HSHIELDS ALREADY UP. ,21)
RETURN
C--------LOWER SHIELDS
50 IF(SHLDUP .EQ. 0) GO TO 55
SHLDUP=0
SHLDCHG=1
CALL PROUT(16HSHIELDS LOWERED.,16)
IDIDIT=1
RETURN
55 CALL PROUT(21HSHIELDS ALREADY DOWN.,21)
RETURN
C--------SHIELD DAMAGE
60 CALL PROUT(25HSHIELDS DAMAGED AND DOWN.,25)
RETURN
C--------ENERGY TOTALLY DEPLETED
70 CALL SKIP(1)
CALL PROUT(31HSHIELDS USE UP LAST OF ENERGY. ,31)
CALL FINISH(4)
RETURN
C--------CHANGE SHIELD ENERGY.
80 CALL SCAN
ETRANS=FNUM
IF(KEY .EQ. IHREAL) GO TO 81
8010 CALL PROMPT(38HENERGY TO TRANSFER TO SHIELDS? ,38)
GO TO 80
81 IF(ETRANS .EQ. 0.) GO TO 90
IF(ETRANS .LT. ENERGY) GO TO 82
CALL PROUT(25HINSUFFICIENT SHIP ENERGY.,25)
GO TO 90
82 IDIDIT=1
IF(SHLD+ETRANS .LE. INSHLD) GO TO 83
CALL PROUT(24HSHIELD ENERGY MAXIMIZED.,24)
CALL PROUT(48HEXCESS ENERGY REQUESTED RETURNED TO SHIP ENERGY.,48)
ENERGY=ENERGY+SHLD-INSHLD
SHLD=INSHLD
GO TO 90
C--------PREVENT SHIELD-DRAIN LOOPHOLE.
83 IF(ETRANS .GT. 0.) GO TO 8310
IF(ENERGY-ETRANS .LE. INENRG) GO TO 8310
IF(ENERGY + SHLD .LE. INENRG) GO TO 8310
CALL SKIP(1)
CALL PROUT(24H"ENGINEERING TO BRIDGE--,24)
CALL PROUT(46H SCOTT HERE. POWER CIRCUIT PROBLEM, CAPTAIN.,46)
CALL PROUT(31H I CAN'T DRAIN THE SHIELDS." ,31)
IDIDIT=0
GO TO 90
8310 IF(SHLD+ETRANS .GE. 0.) GO TO 84
CALL PROUT(38HALL SHIELD ENERGY TRANSFERRED TO SHIP.,38)
ENERGY=ENERGY+SHLD
SHLD=0
GO TO 90
84 CALL CRAM(10HSCOTTY: ")
IF(ETRANS .GT. 0.) CALL CRAM(12HTRANSFERRING)
IF(ETRANS .LT. 0.) CALL CRAM(8HDRAINING)
CALL CRAM(8H ENERGY )
IF(ETRANS .GT. 0.) CALL CRAM(2HTO)
IF(ETRANS .LT. 0.) CALL CRAM(4HFROM)
CALL CRAMDMP(10H SHIELDS.")
SHLD=SHLD+ETRANS
ENERGY=ENERGY-ETRANS
90 IF(SHLD .LE. 0.0) SHLDUP=0
RETURN
END

6
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRSKIP.FOR Normal file
View File

@@ -0,0 +1,6 @@
SUBROUTINE SKIP(N)
DO 10 L=1,N
CALL PROUT(0,1)
10 CONTINUE
RETURN
END

140
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRSNOVA.FOR Normal file
View File

@@ -0,0 +1,140 @@
SUBROUTINE SNOVA(INSX,INSY)
C
C 5-DEC-79
C DON'T CHARGE PLAYER FOR BAD THINGS IF SUPERNOVA CAUSED BY
C ENEMY ACTION
C
INCLUDE 'TREKCOM/NOLIST'
INTEGER COMDEAD
NSX=INSX
NSY=INSY
C--------IF SCHEDULED SUPERNOVA (INSX=INSY=0), SELECT STAR
IF(INSX.NE.0) GO TO 50
NUM=RANF(0)*INSTAR+1
DO 10 NQX=1,8
DO 10 NQY=1,8
NUM=NUM-MOD(GALAXY(NQX,NQY),10)
IF(NUM .LE. 0) GO TO 20
10 CONTINUE
C--------IF STAR IS ALREADY GONE, RETURN EMPTY-HANDED
RETURN
C--------IF STARSHIP IS IN THIS QUADRANT, CHOOSE STAR EXACTLY
20 IF(NQX.NE.QUADX .OR. NQY.NE.QUADY) GO TO 70
C--------UNLESS STARSHIP JUST GOT HERE; THEN TREAT SUPERNOVA AS
C OCCURING WHILE EN ROUTE.
IF(JUSTIN.NE.0) GO TO 70
NUM=RANF(0)*MOD(GALAXY(NQX,NQY),10)+1
DO 30 NSX=1,10
DO 30 NSY=1,10
IF(QUAD(NSX,NSY) .NE. IHSTAR) GO TO 30
NUM=NUM-1
IF(NUM .EQ. 0) GO TO 50
30 CONTINUE
C--------PRINT RED ALERT (INCIPIENT SUPERNOVA) MESSAGE
50 CALL SKIP(1)
CALL REDALRT
CALL CRAM(34H***INCIPIENT SUPERNOVA DETECTED AT)
CALL CRAMLOC(2,NSX,NSY)
CALL CREND
NQX=QUADX
NQY=QUADY
C--------SUPERNOVA ADJACENT TO STARSHIP ENDS GAME
DSQ=(NSX-SECTX)**2 + (NSY-SECTY)**2
IF(DSQ .GT. 2.1) GO TO 80
CALL PROUT(
+ 54HEMERGENCY AUTOMATIC OVERRIDE ATTEMPTS T***************,54)
CALL STARS
ALLDONE=1
GO TO 80
C--------IF STARSHIP NOT IN SAME QUADRANT, JUST GET A MESSAGE
70 IF(DAMAGE(9) .NE. 0) GO TO 80
CALL SKIP(1)
CALL CRAM(49HMESSAGE FROM STARFLEET COMMAND STARDATE )
CALL CRAMF(DATE,0,1)
CALL CREND
CALL CRAM(17H SUPERNOVA IN)
CALL CRAMLOC(1,NQX,NQY)
CALL CRAMDMP(18H; CAUTION ADVISED.)
C--------DESTROY ANY KLINGONS IN SUPERNOVAED QUADRANT
80 NUM=GALAXY(NQX,NQY)
KLDEAD=NUM/100
COMDEAD=0
ISCDEAD=0
IF((NQX .NE. ISX) .OR. (NQY .NE. ISY)) GO TO 85
NSCREM=0
ISX=0
ISY=0
ISATB=0
ISCATE=0
ISCDEAD=1
FUTURE(6)=1E38
FUTURE(7)=1E38
85 IF(KLDEAD .EQ. 0) GO TO 100
REMKL=REMKL-KLDEAD
IF(REMCOM .EQ. 0) GO TO 100
MAXLOOP=REMCOM
DO 90 L=1,MAXLOOP
IF(CX(L).NE.NQX .OR. CY(L).NE.NQY) GO TO 90
CX(L)=CX(REMCOM)
CY(L)=CY(REMCOM)
CX(REMCOM)=0
CX(REMCOM)=0
REMCOM=REMCOM-1
KLDEAD=KLDEAD-1
COMDEAD=1
IF(REMCOM .EQ. 0) FUTURE(2)=1E38
90 CONTINUE
C--------DESTROY ROMULANS AND PLANETS IN SUPERNOVAED QUADRANT.
100 NUM=NEWSTUF(NQX,NQY)
NEWSTUF(NQX,NQY)=0
NRMDEAD=NUM/10
NROMREM=NROMREM-NRMDEAD
NPDEAD=NUM-NRMDEAD*10
IF(NPDEAD .EQ. 0) GO TO 109
DO 106 L=1,INPLAN
IF((PLNETS(L,1) .NE. NQX).OR. (PLNETS(L,2) .NE. NQY)) GO TO 106
DO 105 I=1,5
105 PLNETS(L,I)=0
106 CONTINUE
C--------DESTROY ANY BASE IN SUPERNOVAED QUADRANT
109 IF(REMBASE .EQ. 0) GO TO 120
MAXLOOP=REMBASE
DO 110 L=1,MAXLOOP
IF(BASEQX(L).NE.NQX .OR. BASEQY(L).NE.NQY) GO TO 110
BASEQX(L)=BASEQX(REMBASE)
BASEQY(L)=BASEQY(REMBASE)
BASEQX(REMBASE)=0
BASEQY(REMBASE)=0
REMBASE=REMBASE-1
110 CONTINUE
C--------IF STARSHIP CAUSED SUPERNOVA, TALLY UP DESTRUCTION
120 IF(INSX .EQ. 0) GO TO 130
NUMBER=MOD(GALAXY(NQX,NQY),100)
KILLK=KILLK+KLDEAD
KILLC=KILLC+COMDEAD
NROMKL=NROMKL+NRMDEAD
NSCKILL=NSCKILL+ISCDEAD
C--------IF ENEMY ACTION CAUSED SUPERNOVA, DON'T ASSESS ANY PENALTIES
IF(IPHWHO.EQ.1)GO TO 130
STARKL=STARKL+MOD(NUMBER,10)
BASEKL=BASEKL+(NUMBER/10)
NPLANKL=NPLANKL+NPDEAD
C--------MARK SUPERNOVA IN GALAXY AND IN STAR CHART
130 IF(STARCH(NQX,NQY).GT.0 .AND. DAMAGE(9).NE.0)
+ STARCH(NQX,NQY)=1000+GALAXY(NQX,NQY)
IF(DAMAGE(9).EQ.0 .OR. (QUADX.EQ.NQX .AND. QUADY.EQ.NQY))
+ STARCH(NQX,NQY)=1
GALAXY(NQX,NQY)=1000
C--------IF SUPERNOVA DESTROYS LAST KLINGONS, GIVE SPECIAL MESSAGE
IF(REMKL.NE.0 .OR. (NQX.EQ.QUADX .AND. NQY.EQ.QUADY)) GO TO 140
CALL SKIP(2)
CALL PROUT(11HLUCKY YOU! ,11)
CALL CRAM(14HA SUPERNOVA IN)
CALL CRAMLOC(1,NQX,NQY)
CALL CRAMDMP(38H HAS JUST DESTROYED THE LAST KLINGONS.)
CALL FINISH(1)
RETURN
C--------IF SOME KLINGONS REMAIN, CONTINUE (OR DIE IN SUPERNOVA)
140 IF(ALLDONE.NE.0) CALL FINISH(8)
RETURN
END

25
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRSORTKL.FOR Normal file
View File

@@ -0,0 +1,25 @@
SUBROUTINE SORTKL
INCLUDE 'TREKCOM/NOLIST'
INTEGER SWITCH
IF(NENHERE.LE.1)RETURN
MINUS1=NENHERE-1
10 SWITCH=0
DO 20 J=1,MINUS1
IF(KDIST(J) .LE. KDIST(J+1)) GO TO 20
T=KDIST(J)
KDIST(J)=KDIST(J+1)
KDIST(J+1)=T
K=KX(J)
KX(J)=KX(J+1)
KX(J+1)=K
K=KY(J)
KY(J)=KY(J+1)
KY(J+1)=K
T=KPOWER(J)
KPOWER(J)=KPOWER(J+1)
KPOWER(J+1)=T
SWITCH=1
20 CONTINUE
IF(SWITCH.NE.0) GO TO 10
RETURN
END

122
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRSRSCAN.FOR Normal file
View File

@@ -0,0 +1,122 @@
SUBROUTINE SRSCAN
INCLUDE 'TREKCOM/NOLIST'
BYTE BITEM
LOGICAL LEFTSID,RITESID ,CROP
REAL*8 REQUST(10),AITEM,DAMAGD,UP,DOWN,TJ
EQUIVALENCE (AITEM,BITEM)
COMMON/SCANBF/KEY,AITEM
DATA REQUST /4HDATE,8HCONDITIO,8HPOSITION,8HLSUPPORT,8HWARPFACT
+,6HENERGY,8HTORPEDOE,7HSHIELDS,8HKLINGONS,4HTIME/
DATA DAMAGD,UP,DOWN/7HDAMAGED,2HUP,4HDOWN/
IF(DAMAGE(1) .NE. 0 .AND. CONDIT .NE. IHDOCKD) GOTO 160
LEFTSID=.TRUE.
RITESID=.TRUE.
CALL SCAN
IF(KEY .EQ. IHEOL) GO TO 3
IF(BITEM .EQ. 1HN) RITESID = .FALSE.
3 STARCH(QUADX,QUADY)=1
K=0
CALL PROUT(23H 1 2 3 4 5 6 7 8 9 10,23)
GO TO 4
C*
ENTRY REQUEST
C*
301 CALL SCAN
IF(KEY .EQ. IHALPHA) GO TO 303
302 CALL PROMPT(24HINFORMATION DESIRED? ,24)
GO TO 301
303 DO 304 I=1,10
304 IF(CROP(AITEM,REQUST(I))) K=I
IF(K.NE.0) GO TO 305
CALL PROUT(42HUNRECOGNIZED REQUEST. LEGAL REQUESTS ARE:,42)
CALL PROUT(
+51H DATE, CONDITION, POSITION, LSUPPORT, WARPFACTOR, ,51)
CALL PROUT(45H ENERGY, TORPEDOES, SHIELDS, KLINGONS, TIME.,45)
CALL SKIP(1)
GO TO 302
C*
ENTRY STATUS
C*
305 LEFTSID=.FALSE.
4 DO 150 I=1,10
JJ=I
IF(K.NE.0) JJ=K
IF(.NOT. LEFTSID) GO TO 8
CALL CRAMI(I,2)
CALL CRAM(1H )
DO 5 J=1,10
CALL CRAMS(QUAD(I,J),1)
CALL CRAM(1H )
5 CONTINUE
IF(RITESID)GO TO 8
CALL CREND
GO TO 150
8 GO TO (10,20,30,40,50,60,70,80,90,100), JJ
10 CALL CRAM(15H STARDATE )
CALL CRAMF(DATE,0,1)
CALL CREND
GO TO 140
20 IF(CONDIT .NE. IHDOCKD ) CALL NEWCOND
CALL CRAM(15H CONDITION )
IF(CONDIT.EQ.IHGREEN) CALL CRMDPS('GREEN',5)
IF(CONDIT.EQ.IHRED) CALL CRMDPS('RED',3)
IF(CONDIT.EQ.IHYELLO) CALL CRMDPS('YELLOW',6)
IF(CONDIT.EQ.IHDOCKD) CALL CRMDPS('DOCKED',6)
GO TO 140
30 CALL CRAM(14H POSITION )
CALL CRAMLOC(0,QUADX,QUADY)
CALL CRAM(1H,)
CALL CRAMLOC(0,SECTX,SECTY)
CALL CREND
GO TO 140
40 CALL CRAM(15H LIFE SUPPORT )
IF(DAMAGE(5).NE.0.) GO TO 44
CALL CRAM(6HACTIVE)
GO TO 46
44 IF(CONDIT .NE. IHDOC ) GO TO 45
CALL CRAM(30HDAMAGED, SUPPORTED BY STARBASE)
GO TO 46
45 CALL CRAM(18HDAMAGED, RESERVES=)
CALL CRAMF(LSUPRES,4,2)
46 CALL CREND
GO TO 140
50 CALL CRAM(15H WARP FACTOR )
CALL CRAMF(WARPFAC,0,1)
CALL CREND
GO TO 140
60 CALL CRAM(15H ENERGY )
CALL CRAMF(ENERGY,0,2)
CALL CREND
GO TO 140
70 CALL CRAM(15H TORPEDOES )
CALL CRAMI(TORPS,0)
CALL CREND
GO TO 140
80 CALL CRAM(15H SHIELDS )
TJ=DOWN
IF(SHLDUP.NE.0) TJ=UP
IF(DAMAGE(8) .GT. 0) TJ=DAMAGD
CALL CRAMS(TJ,8)
J=100.0*SHLD/INSHLD+0.5
CALL CRAMI(J,0)
CALL CRAM(5H% - )
J=SHLD
CALL CRAMI(J,0)
CALL CRAMDMP(6H UNITS)
GO TO 140
90 CALL CRAM(15H KLINGONS LEFT )
CALL CRAMI(REMKL,0)
CALL CREND
GO TO 140
100 CALL CRAM(15H TIME LEFT )
CALL CRAMF(REMTIME,0,2)
CALL CREND
IF(LEFTSID) CALL PROUT(23H 1 2 3 4 5 6 7 8 9 10,23)
140 IF(K .EQ. 0) GO TO 150
K=0
RETURN
150 CONTINUE
RETURN
160 CALL PROUT(22HS. R. SENSORS DAMAGED.,22)
RETURN
END

112
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRTHAW.FOR Normal file
View File

@@ -0,0 +1,112 @@
SUBROUTINE THAW
C
C 5-APR-79
C FIX BUG IN TYPEOUT ON STATE OF GAME.
C 25-APR-79
C CLEAN UP MESSAGE ON BASES.
C GET RID OF SPURIOUS COMMANDER ATTACK.
C 1-MAY-78
C DON'T PRINT PASSWORD FOR 'GAME' ENTRY
C 3-MAY-78
C USE CRAMSP TO TAKE CARE OF ALL SINGULAR/PLURAL TYPEOUTS.
C
INCLUDE 'TREKCOM/NOLIST'
LOGICAL*1 NAME(30)
INTEGER DESTBAS
C
CALL GETFN(NAME)
IDIDIT=0
IF(NAME(1).EQ.0) GOTO 800
CALL CLOSE(2)
OPEN(UNIT=2,NAME=NAME,TYPE='OLD',FORM='UNFORMATTED',
1 ERR=800)
READ(2,ERR=800) N,(ICOM(K),K=1,N)
CALL CLOSE(2)
IDIDIT=1
GO TO 100
C*--TELL HIM WHAT KIND OF GAME HE GOT HIMSELF INTO...
ENTRY GAME
IDIDIT=0
100 CALL SKIP(1)
CALL CRAM(22HYOU ARE NOW PLAYING A )
IF(LENGTH.EQ.1) CALL CRAM(5HSHORT)
IF(LENGTH.EQ.2) CALL CRAM(6HMEDIUM)
IF(LENGTH.EQ.4) CALL CRAM(4HLONG)
IF(SKILL.EQ.1) CALL CRAM(7H NOVICE)
IF(SKILL.EQ.2) CALL CRAM(5H FAIR)
IF(SKILL.EQ.3) CALL CRAM(5H GOOD)
IF(SKILL.EQ.4) CALL CRAM(7H EXPERT)
IF(SKILL.EQ.5) CALL CRAM(9H EMERITUS)
CALL CRAMDMP(6H GAME.)
IF(IDIDIT.EQ.0)GO TO 110
CALL CRAM(25HYOUR SECRET PASSWORD IS ')
CALL CRAMS(PASSWD,8)
CALL CRAMDMP(2H'.)
110 KILLTOT=KILLK+KILLC+NSCKILL
CALL CRAMI(KILLTOT,0)
CALL CRAM(4H OF )
CALL CRAMSP(INKLING,'KLINGON')
IF(KILLTOT.EQ.1)CALL CRAM(' HAS')
IF(KILLTOT.NE.1)CALL CRAM(' HAVE')
CALL CRAM(' BEEN KILLED, INCLUDING ')
CALL CRAMSP(KILLC,'COMMANDER')
CALL CRAMDMP('.')
IF(SKILL.LE.2) GOTO 200
CALL CRAM(24HTHE SUPER-COMMANDER HAS )
IF(NSCREM.EQ.1) CALL CRAM(4HNOT )
CALL CRAMDMP(15HBEEN DESTROYED.)
C*--GIVE HIM THE POOP ON THE BASES.
200 DESTBAS=INBASE-REMBASE
IF(DESTBAS.EQ.0)GO TO 210
CALL CRAMSP(DESTBAS,'BASE')
CALL CRAM(' DESTROYED, ')
210 CALL CRAMSP(REMBASE,'BASE')
IF(DESTBAS.NE.0)CALL CRAM(' REMAINING')
CALL CRAMDMP('.')
C*--IS A COMMANDER CHOMPING ON A BASE?
IF(ICSOS.EQ.0)GO TO 240
IF(FUTURE(5).GE. 1.E38) GOTO 240
IF(REMCOM.EQ.0 .OR. REMBASE.EQ.0)GO TO 240
IF(MOD(GALAXY(BATX,BATY),100).LT.10)GO TO 240
DO 220 I=1,REMCOM
IF(CX(I).EQ.BATX .AND. CY(I).EQ.BATY)GO TO 221
220 CONTINUE
GO TO 240
221 CALL CRAM(11HSTARBASE IN )
CALL CRAMLOC(1,BATX,BATY)
CALL CRAMDMP(27H IS CURRENTLY UNDER ATTACK.)
CALL CRAM(31HIT CAN HOLD OUT UNTIL STARDATE )
CALL CRAMF(FUTURE(5),0,1)
CALL CRAMDMP(1H.)
C*--IS THE SUPER COMMANDER ATTACKING?
240 IF(ISSOS.EQ.0)GO TO 245
IF(ISATB.NE.1) GOTO 245
CALL CRAM(11HSTARBASE IN )
CALL CRAMLOC(1,ISX,ISY)
CALL CRAMDMP(33H IS UNDER SUPER-COMMANDER ATTACK. )
CALL CRAM(31HIT CAN HOLD OUT UNTIL STARDATE )
CALL CRAMF(FUTURE(7),0,1)
CALL CRAMDMP(1H.)
C*--ISSUE CAVEAT IF THE SUBSPACE RADIO HAS BEEN BROKEN
245 IF(ISUBDAM.EQ.0)GO TO 249
CALL CRAM('THE SUBSPACE RADIO ')
IF(DAMAGE(9).NE.0)CALL CRAM('IS')
IF(DAMAGE(9).EQ.0)CALL CRAM('WAS')
CALL CRAMDMP(' DAMAGED. THUS YOU MAY NOT HAVE COMPLETE')
CALL CRAMDMP('INFORMATION ON SUPERNOVAS AND ATTACKS ON BASES.')
C*--HOW MANY CASUALTIES?
249 IF(CASUAL.EQ.0) GOTO 250
CALL CRAMSPI(CASUAL,'CASUALT','Y','IES')
CALL CRAMDMP(' SUFFERED SO FAR.')
250 IF(NHELP.EQ.0) GOTO 260
CALL CRAMSP(NHELP,'CALL')
CALL CRAMDMP(' FOR HELP.')
260 CALL SKIP(1)
C*--AND LET HIM PLAY IT
RETURN
C*--THAT WAS A BAD FREEZE OR FILE NOT OPENED
800 CALL PROUT(17H GAME NOT FROZEN. ,17)
C*--TELL CHOOSE THAT WE DIDN'T GET ANYTHING
PASSWD=0.D0
RETURN
END

45
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRTIMEWRP.FOR Normal file
View File

@@ -0,0 +1,45 @@
SUBROUTINE TIMEWRP
INCLUDE 'TREKCOM/NOLIST'
DIMENSION PICTURE(226)
EQUIVALENCE (PICTURE,DATE)
CALL PROUT(21H***TIME WARP ENTERED.,21)
IF(SNAP.NE.0 .AND. RANF(0).LT.0.5) GO TO 10
C--------TRAVEL FORWARD IN TIME
TIME=-0.5*INTIME*ALOG(RANF(0))
CALL CRAM(35HYOU ARE TRAVELLING FORWARD IN TIME )
CALL CRAMF(TIME,0,2)
CALL CRAMDMP(11H STARDATES.)
C--------CHEAT TO MAKE SURE NO TRACTOR BEAMS OCCUR DURING TIME WARP
FUTURE(2)=FUTURE(2)+TIME
GO TO 40
C--------TRAVEL BACKWARD IN TIME
10 XDATE=DATE
DATE=SNAPSHT(1)
CALL CRAM(36HYOU ARE TRAVELLING BACKWARD IN TIME )
CALL CRAMF(XDATE-DATE,0,2)
CALL CRAMDMP(11H STARDATES.)
SNAP=0
DO 20 L=2,226
20 PICTURE(L)=SNAPSHT(L)
IF(REMCOM .EQ. 0) GO TO 25
FUTURE(2)=DATE+EXPRAN(INTIME/REMCOM)
FUTURE(4)=DATE+EXPRAN(0.3*INTIME)
25 FUTURE(1)=DATE+EXPRAN(0.5*INTIME)
FUTURE(3)=DATE+EXPRAN(0.5*INTIME)
IF(NSCREM.NE.0) FUTURE(6)=0.2777
ISATB=0
FUTURE(5)=1E38
FUTURE(7)=1E38
BATX=0
BATY=0
C--------REVERT STAR CHART TO EARLIER ERA.
DO 30 L=1,8
DO 30 LL=1,8
30 STARCH(L,LL)=MIN0(1,STARCH(L,LL))
CALL PROUT(
+ 57HSPOCK HAS RECONSTRUCTED A CORRECT STAR CHART FROM MEMORY.
1 ,57)
C--------MODIFY DESTINATION QUADRANT TO CORRESPOND TO NEW TIME
40 CALL NEWQUAD
RETURN
END

283
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRTREK.FOR Normal file
View File

@@ -0,0 +1,283 @@
PROGRAM STARTRK
C*********************************************************************
C* *
C* THE STAR TREK GAME *
C* BY *
C* DAVID MATUSZEK AND PAUL REYNOLDS *
C* *
C* WITH MODIFICATIONS AND ADDITIONS BY *
C* DON SMITH *
C* *
C* *
C* PERMISSION IS HEREBY GRANTED FOR THE COPYING, *
C* DISTRIBUTION, MODIFICATION AND USE OF THIS PROGRAM AND *
C* ASSOCIATED DOCUMENTATION FOR RECREATIONAL PURPOSES, *
C* PROVIDED THAT ALL REFERENCES TO THE AUTHORS ARE RETAINED. *
C* HOWEVER, PERMISSION IS NOT AND WILL NOT BE GRANTED FOR *
C* THE SALE OR PROMOTIONAL USE OF THIS PROGRAM OR PROGRAM *
C* DOCUMENTATION, OR FOR USE IN ANY SITUATION IN WHICH *
C* PROFIT MAY BE CONSIDERED AN OBJECTIVE, SINCE IT IS THE *
C* DESIRE OF THE AUTHORS TO RESPECT THE COPYRIGHTS OF THE *
C* ORIGINATORS OF STAR TREK. *
C* *
C*********************************************************************
C
C 4-APR-79
C MAKE COMMAND INPUT REPROMPT AFTER A BLANK LINE WITHOUT
C TYPING OUT A BUNCH OF GARBAGE.
C ALSO GET RID OF THE CRAP ABOUT TYPING SOMETHING TO GET
C YOUR CITATION.
C 13-APR-79
C ADD EMERGENCY EXIT COMMAND.
C 25-APR-79
C GET RID OF COMMON /RAN/, WHICH IS NOT REFERENCED.
C 1-MAY-79
C REDO ALL MODULES TO GET THEIR COMMON FROM AN INCLUDE STATEMENT.
C THIS SHOULD GREATLY SIMPLIFY MAINTENANCE AND EXTENSION OF THE
C GAME.
C ALSO ADD 'GAME' COMMAND TO MAKE LIFE EASIER FOR THE PLAYER ON
C A SOFT COPY TERMINAL.
C 31-MAY-79
C CLOSE PRINT FILE AND RESET LUN TO 1 AFTER OUTPUTTING SCORE
C AND/OR CITATION.
C
PARAMETER NCOMMDS=23
INCLUDE 'TREKCOM/LIST'
INTEGER CROP
LOGICAL FROZEN
REAL*8 ITEM,HELPX,TERM,ABAN,DEST,FREE,DEATH,AITEM
REAL*8 COMMAND(NCOMMDS)
COMMON/PRLUN/LUN
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE (AITEM,ITEM)
EQUIVALENCE (CRACKS(6),KDIDIT)
C
C MASTER COMMAND LIST - INCLUDES ALL ABBREVIATABLE COMMANDS
C
DATA COMMAND/6HSRSCAN,6HLRSCAN,7HPHASERS,7HPHOTONS,4HMOVE,
+ 7HSHIELDS,4HDOCK,7HDAMAGES,5HCHART,7HIMPULSE,4HREST,4HWARP,
+ 6HSTATUS,7HSENSORS,5HORBIT,8HTRANSPOR,4HMINE,8HCRYSTALS,
+ 7HSHUTTLE,7HPLANETS,7HREQUEST,6HEMEXIT,4HGAME/
C
C ALPHANUMERIC DATA
C
DATA IHEOL,IHREAL,IHALPHA,IHS,IHR,IHC,IHK,IHGREEN,IHRED,IHYELLO,
+IHDOCKD,IHE,IHF,IHBLANK,IHDOT,IHQUEST,IHP,IHSTAR,IHB/2HEO,2HRE,
+2HAL,1HS,1HR,1HC,1HK,2HGR,2HRE,2HYE,2HDO,1HE,1HF,
+1H ,1H.,1H?,1HP,1H*,1HB/
DATA IHT,IHNUM/1HT,1H#/
C
C DEVICE LIST
C
C DEVICES ARE:
C 1. S. R. SENSORS
C 2. L. R. SENSORS
C 3. PHASERS
C 4. PHOTON TUBES
C 5. LIFE SUPPORT
C 6. WARP ENGINES
C 7. IMPULSE ENGINES
C 8. SHIELDS
C 9. SUBSPACE RADIO
C 10. SHUTTLE CRAFT
C 11. COMPUTER
C 12. TRANSPORTER
C 13. SHIELD CONTROL
C 14. DEATHRAY
C
DATA DEVICE/8HS. R. SE,5HNSORS,8HL. R. SE,5HNSORS,
1 7HPHASERS,1H ,8HPHOTON T,4HUBES,8HLIFE SUP,4HPORT,
2 8HWARP ENG,4HINES,8HIMPULSE ,7HENGINES,7HSHIELDS,1H ,
3 8HSUBSPACE,6H RADIO,8HSHUTTLE ,5HCRAFT,8HCOMPUTER,1H ,
4 8HTRANSPOR,3HTER,8HSHIELD C,6HONTROL,8HDEATHRAY,
5 1H /
C
C NON-ABBREVIATABLE COMMAND LIST
C
DATA HELPX,TERM,ABAN,DEST,FREE,DEATH/'HELP','TERMINAT',
1 'ABANDON','DESTRUCT','FREEZE','DEATHRAY'/
C
NDEVICE=14
ICITE=0
C--------PRINT OUT PRELIMINARY MESSAGES
CALL PRELIM
C--------INITIALIZE AND START NEW GAME
10 CALL CHOOSE(FROZEN)
IF(FROZEN) GOTO 15
CALL SETUP
C--------REQUEST NEW COMMAND AND BRANCH TO CODE FOR THAT COMMAND
15 MOVED=0
20 IF(ALLDONE.NE.0) GO TO 9999
JUSTIN=0
TIME=0.
KDIDIT=0
CALL PROMPT(10HCOMMAND: ,10)
CALL SCAN
DO 30 L=1,NCOMMDS
IF(CROP(ITEM,COMMAND(L)))
+ GO TO (100,200,300,400,500,600,700,800,900,1000,
+ 1100,1200,1300,1400,1450,1500,1550,1600,1650,1670,
+ 1680,1685,1690),L
30 CONTINUE
IF(ITEM .EQ. HELPX ) GO TO 1700
IF(ITEM .EQ. TERM) GO TO 9000
IF(ITEM .EQ. ABAN ) GO TO 1900
IF(ITEM .EQ. DEST ) GO TO 2000
IF(ITEM .EQ. FREE ) GO TO 2100
IF(ITEM .EQ. DEATH ) GO TO 2200
IF(KEY .NE. IHEOL) GO TO 40
C CALL PROUT(18HBLANK LINE IGNORED,18)
GO TO 20
40 CALL PROUT(
+ 42HUNRECOGNIZED COMMAND. LEGAL COMMANDS ARE:,42)
CALL PROUT(
+ 37H SRSCAN MOVE PHASERS HELP,37)
CALL PROUT(
+ 40H STATUS IMPULSE PHOTONS ABANDON,40)
CALL PROUT(
+ 41H LRSCAN WARP SHIELDS DESTRUCT,41)
CALL PROUT(
+ 42H CHART REST DOCK TERMINATE,42)
CALL PROUT(
+ 38H DAMAGES FREEZE SENSORS ORBIT,38)
CALL PROUT(
+ 40H TRANSPORT MINE CRYSTALS SHUTTLE,40)
CALL PROUT(
+ 39H PLANETS REQUEST DEATHRAY EMEXIT,39)
CALL PROUT(
+ 7H GAME,7)
GO TO 20
C--------SHORT RANGE SCAN
100 CALL SRSCAN
GO TO 20
C--------LONG RANGE SCAN
200 CALL LRSCAN
GO TO 20
C--------FIRE PHASERS
300 CALL PHASERS
305 IF(IDIDIT .EQ. 0) GO TO 20
310 CALL ATTACK
320 IF(KDIDIT.NE.0) GO TO 2500
GO TO 15
C--------FIRE PHOTON TORPEDOS
400 CALL PHOTONS
410 IF(IDIDIT .EQ. 0) GO TO 20
MOVED=0
GO TO 2500
C--------MOVE UNDER WARP DRIVE
500 IF(MOVED .EQ. 0) GO TO 510
505 MOVED=2
510 CALL WARP
520 IF((IDIDIT.EQ.0).AND.(MOVED.EQ.2)) MOVED=1
IF(IDIDIT.EQ.0) GO TO 20
IF((MOVED.EQ.2).AND.(JUSTIN.EQ.0)) CALL ATTACK
MOVED=1
GO TO 2500
C--------RAISE OR LOWER DEFLECTOR SHIELDS
600 CALL SHIELDS
IF(IDIDIT .EQ. 0) GO TO 20
CALL ATTACK
SHLDCHG=0
GO TO 320
C--------DOCK AT STARBASE
700 CALL DOCK
IF(IDIDIT.NE.0) GO TO 310
GO TO 20
C--------LOOK AT DAMAGE REPORT
800 CALL DREPORT
GO TO 20
C--------LOOK AT STAR CHART
900 CALL CHART
GO TO 20
C--------MOVE UNDER IMPULSE POWER
1000 IF(MOVED.NE.0) GO TO 505
CALL IMPULSE
GO TO 520
C--------REST AND REPAIR
1100 CALL WAIT
GO TO 410
C--------CHANGE WARP FACTOR
1200 CALL SETWARP
GO TO 20
C--------ASK FOR STATUS INFORMATION
1300 CALL STATUS
GO TO 20
C--------GET A SENSOR SCAN OF QUADRANT.
1400 CALL SENSOR
GO TO 20
C--------ENTER STANDARD ORBIT.
1450 CALL ORBIT
GO TO 410
C--------TRANSPORT SOMEBODY SOMEWHERE.
1500 CALL BEAM
GO TO 20
C--------DO A LITTLE DIGGING.
1550 CALL MINE
GO TO 410
C--------LOAD SOME CRYSTALS (AND HOPE FOR THE BEST.)
1600 CALL CRYSTAL
GO TO 20
C--------GO FOR A SPIN IN GALILEO.
1650 CALL GALILEO
GO TO 410
C--------GET A PLANET LIST
1670 CALL PLANET
GO TO 20
C--------INDIVIDUAL PIECE OF INFORMATION FROM STATUS REQUESTED.
1680 CALL REQUEST
GO TO 20
C--------EMERGENCY EXIT - FREEZE ON EMSAVE.TRK AND BUG OUT
1685 CALL EMEXIT
GO TO 20
C--------GAME - TYPE OUT INFORMATION ON CURRENT GAME
1690 CALL GAME
GO TO 20
C--------CALL STARBASE FOR HELP
1700 CALL HELP
GO TO 20
C--------ABANDON SHIP
1900 CALL ABANDON
GO TO 20
C--------SELF-DESTRUCT
2000 CALL DESTRCT
GO TO 20
C--------FREEZE THE CURRENT GAME
2100 CALL FREEZE
IF(IDIDIT.EQ.1) GO TO 9999
GO TO 20
C--------TRY A DESPERATION MEASURE
2200 CALL DEATHRA
GO TO 305
C--------AFTER COMMANDS WHICH MAY USE TIME, DO CHECKING
2500 IF(ALLDONE.NE.0) GO TO 9999
IF(TIME .NE. 0.) CALL EVENTS
IF(ALLDONE.NE.0) GO TO 9999
IF(GALAXY(QUADX,QUADY) .NE. 1000) GO TO 2510
CALL AUTOVER
KDIDIT=0
MOVED=0
GO TO 2500
C--------CHECK FOR MOVE AND FIRE OPTION
2510 IF(NENHERE.EQ.0) CALL MOVETHO
IF(KDIDIT .EQ. 1 .OR. NENHERE .EQ. 0) GO TO 15
IF(MOVED .EQ. 0 .OR. JUSTIN .EQ. 1) GO TO 310
GO TO 20
C--------GAME HAS ENDED. START NEW GAME OR FINALIZE.
9000 CALL SCORE
9999 IF(LUN.EQ.2)CALL CLOSE(2)
LUN=1
CALL SKIP(2)
CALL STARS
CALL SKIP(1)
CALL PROMPT(30HDO YOU WANT TO PLAY AGAIN? ,30)
IF(JA(DUMMY)) GO TO 10
CALL SKIP(1)
CALL PROUT(
+ 48HMAY THE GREAT BIRD OF THE GALAXY ROOST UPON YOUR,48)
CALL PROUT(12HHOME PLANET.,12)
CALL SKIP(1)
C IF(ICITE .EQ. 0) GO TO 99999
C CALL PROUT(52HDON'T FORGET TO TYPE <RSF> TO RECEIVE YOUR CITATION.
C C,52)
99999 CALL EXIT
END

45
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRWAIT.FOR Normal file
View File

@@ -0,0 +1,45 @@
SUBROUTINE WAIT
INCLUDE 'TREKCOM/NOLIST'
REAL*8 AITEM
COMMON/SCANBF/KEY,AITEM
EQUIVALENCE(AITEM,FNUM)
C--------DO COMMAND SCANNING
IDIDIT=0
10 CALL SCAN
ANUM=FNUM !SAVE SCAN BUFFER
IF(KEY .NE. IHEOL) GO TO 20
CALL PROMPT(10HHOW LONG? ,10)
GO TO 10
20 IF(KEY .NE. IHREAL) GO TO 60
IF(ANUM .LE. 0.) RETURN
IF(ANUM.LT.REMTIME .AND.NENHERE.EQ.0) GO TO 30
CALL PROMPT(13HARE YOU SURE?,13)
IF(JA(DUMMY) .EQ. 0) RETURN
C--------ALTERNATE REST PERIODS (EVENTS) WITH ATTACKS
30 RESTING=1
AITEM2=ANUM
40 IF(ANUM .LE. 0.) RESTING=0
IF(RESTING .EQ. 0) GO TO 50
TEMP=ANUM
IF(NENHERE.NE. 0) TEMP=AMIN1(ANUM,1.0+RANF(0))
TIME=TEMP
IF(TIME .LT. ANUM) CALL ATTACK
IF(NENHERE.EQ.0) CALL MOVETHO
IF(ALLDONE.NE.0) RETURN
CALL EVENTS
IDIDIT=1
IF(ALLDONE.NE.0) RETURN
ANUM=ANUM-TEMP
IF(GALAXY(QUADX,QUADY) .NE. 1000) GO TO 40
RESTING=0
TIME=0
GOTO 55
50 CALL CRAMF(REMTIME,0,2)
CALL CRAMDMP(16H STARDATES LEFT.)
55 IF(CONDIT.NE.IHDOCKD) RETURN
IF((AITEM2-ANUM).GE.9.99) DAMAGE(14)=0
C*--------HANDLE SPECIAL CASE OF DEATHRAY REPAIRS.
RETURN
60 CALL BEGPARD
RETURN
END

112
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRWARP.FOR Normal file
View File

@@ -0,0 +1,112 @@
SUBROUTINE WARP
INCLUDE 'TREKCOM/NOLIST'
INTEGER BLOOEY,TWARP
IDIDIT=0
IF(DAMAGE(6) .GT. 10.0) GO TO 90
IF(DAMAGE(6) .EQ. 0.0 .OR. WARPFAC .LE. 4.0) GO TO 3
CALL PROUT(52HENGINEER SCOTT: "SORRY, CAPTAIN. UNTIL THIS DAMAGE
+,52)
CALL PROUT(43H IS REPAIRED, I CAN ONLY GIVE YOU WARP 4.",43)
RETURN
C--------READ IN COURSE AND DISTANCE
3 CALL GETCD
IF(DIREC .LT. 0) RETURN
C--------MAKE SURE STARSHIP HAS ENOUGH ENERGY TO MAKE THE TRIP
POWER=(DIST+0.05)*WARPFAC*WARPFAC*WARPFAC*(SHLDUP+1)
IF(POWER .LT. ENERGY) GO TO 10
CALL SKIP(1)
CALL PROUT(24H"ENGINEERING TO BRIDGE--,24)
IF(SHLDUP.EQ.0 .OR. 0.5*POWER.GT.ENERGY) GO TO 5
CALL PROUT(
+61H WE HAVEN'T THE ENERGY TO GO THAT FAR WITH THE SHIELDS UP."
+ ,61)
RETURN
5 IWARP=(ENERGY/(DIST+0.05))**0.3333333333
IF(IWARP .LE. 0) GO TO 8
CALL CRAM(
+ 53H WE HAVEN'T THE ENERGY. BUT WE COULD DO IT AT WARP )
CALL CRAMI(IWARP,0)
IF(SHLDUP.NE.0) GO TO 6
CALL CRAMDMP(2H.")
RETURN
6 CALL CRAMDMP(1H,)
CALL PROUT(31H IF YOU'LL LOWER THE SHIELDS.",31)
RETURN
8 CALL PROUT(
+ 51H WE CAN'T DO IT, CAPTAIN. WE HAVEN'T THE ENERGY.",51)
RETURN
C--------MAKE SURE ENOUGH TIME IS LEFT FOR TRIP
10 TIME=10.0*DIST/WFACSQ
IF(TIME .LT. 0.80*REMTIME) GO TO 20
CALL SKIP(1)
CALL PROUT(
+ 51HFIRST OFFICER SPOCK: "CAPTAIN, I COMPUTE THAT SUCH,41)
CALL CRAM(37H A TRIP WOULD REQUIRE APPROXIMATELY )
CALL CRAMF(100.0*TIME/REMTIME,0,2)
CALL CRAMDMP(9H % OF OUR)
CALL PROMPT(
+ 48H REMAINING TIME. ARE YOU SURE THIS IS WISE?" ,48)
IF(JA(DUMMY)) GO TO 20
RETURN
C*
ENTRY WARPX
C*
20 BLOOEY=0
TWARP=0
IF(WARPFAC .LE. 6.0) GO TO 50
C--------DECIDE IF ENGINE DAMAGE WILL OCCUR
PROB=DIST*(6.0-WARPFAC)**2/66.666666666
IF(PROB .GT. RANF(0)) BLOOEY=1
IF(BLOOEY.NE.0) DIST=RANF(0)*DIST
C----------DECIDE IF TIME WARP WILL OCCUR
TWARP=0
IF(WARPFAC .LT. 10.0) GO TO 40
IF(0.5*DIST .GT. RANF(0)) TWARP=1
40 IF(BLOOEY .EQ. 0 .AND. TWARP .EQ. 0) GO TO 50
C--------IF ENGINE DAMAGE OR TIME WARP SHOULD OCCUR, CHECK PATH
ANGLE=((15.0-DIREC)*0.5235998)
DELTAX=-SIN(ANGLE)
DELTAY=COS(ANGLE)
BIGGER=AMAX1(ABS(DELTAX),ABS(DELTAY))
DELTAX=DELTAX/BIGGER
DELTAY=DELTAY/BIGGER
N=10.0*DIST*BIGGER+0.5
X=SECTX
Y=SECTY
IF(N .EQ. 0) GO TO 50
DO 45 L=1,N
X=X+DELTAX
IX=X+0.5
IF(IX .LT. 1 .OR. IX .GT. 10) GO TO 50
Y=Y+DELTAY
IY=Y+0.5
IF(IY .LT. 1 .OR. IY .GT. 10) GO TO 50
IF(QUAD(IX,IY) .EQ. IHDOT) GO TO 45
BLOOEY=0
TWARP=0
45 CONTINUE
C--------ACTIVATE WARP ENGINES AND PAY THE COST
50 KSTUF(4)=0
CALL MOVE
IF(ALLDONE.NE.0) RETURN
ENERGY=ENERGY - DIST*WARPFAC*WARPFAC*WARPFAC*(SHLDUP+1)
IF(ENERGY .GT. 0) GO TO 55
CALL FINISH(4)
RETURN
55 IF(KSTUF(4).EQ.0) TIME=10.0*DIST/WFACSQ
C--------ENTER TIME WARP
IF(TWARP.NE.0) CALL TIMEWRP
C--------DAMAGE WARP ENGINES
IF(BLOOEY .EQ. 0) GO TO 60
DAMAGE(6)=DAMFAC*(3.0*RANF(0)+1.0)
CALL SKIP(1)
CALL PROUT(24H"ENGINEERING TO BRIDGE--,24)
CALL PROUT(44H SCOTT HERE. THE WARP ENGINES ARE DAMAGED.,44)
CALL PROUT(41H WE'LL HAVE TO REDUCE SPEED TO WARP 4." ,41)
60 IDIDIT=1
RETURN
C--------NO WARP ENGINES
90 CALL SKIP(1)
CALL PROUT(25HWARP ENGINES INOPERATIVE.,25)
RETURN
END

61
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/TRZAP.FOR Normal file
View File

@@ -0,0 +1,61 @@
SUBROUTINE ZAP
INCLUDE 'TREKCOM/NOLIST'
INTEGER CDAM(5)
EQUIVALENCE (CRACKS(1),HIT),(CRACKS(3),IHURT),(CRACKS(4),L)
PFAC=1.0/INSHLD
CHGFAC=1.0
IF(SHLDCHG .EQ. 1) CHGFAC=0.25+0.50*RANF(0)
IF(SHLDUP .EQ. 0 .AND. SHLDCHG .EQ. 0) GO TO 10
PROPOR=AMAX1(PFAC*SHLD,0.10)
HITSH=PROPOR*CHGFAC*HIT+1.0
ABSORB=0.8*HITSH
IF(ABSORB .GT. SHLD) ABSORB=SHLD
SHLD=SHLD-ABSORB
IF(SHLD .LE. 0.0) SHLDUP=0
HIT=HIT-HITSH
IF(PROPOR .GT. 0.1 .AND. HIT .LT. (0.005*ENERGY)) RETURN
C--------IT'S A HIT! PRINT OUT HIT SIZE
10 IHURT=1
CALL CRAMF(HIT,8,2)
CALL CRAM(9H UNIT HIT)
IF(L .EQ. 0) GO TO 15
CALL CRAM(6H FROM )
JX=KX(L)
JY=KY(L)
CALL CRAMENA(QUAD(JX,JY),0,JX,JY)
15 CALL CREND
C--------DECIDE IF HIT IS CRITICAL
IF(HIT .LT. (275.0-25.0*SKILL)*(1.0+0.5*RANF(0))) GO TO 60
NCRIT=1.0 + HIT/(500.0+100.0*RANF(0))
CALL CRAM(17H***CRITICAL HIT--)
C--------SELECT DEVICE(S) AND CAUSE DAMAGE
KTR=1
DO 50 LL=1,NCRIT
20 J=NDEVICE*RANF(0)+1.0
IF(DAMAGE(J) .LT. 0) GO TO 20
C*--------CHEAT TO PREVENT DEATHRAY FROM BEING DAMAGED.
IF(J.EQ.14) GOTO 20
C--------CHEAT TO PREVENT SHUTTLE DAMAGE UNLESS ON SHIP.
IF((J .EQ. 10) .AND. (ISCRAFT .NE. 1)) GO TO 20
CDAM(LL)=J
EXTRADM=(HIT*DAMFAC)/(NCRIT*(75.0+25.0*RANF(0)))
DAMAGE(J)=DAMAGE(J)+EXTRADM
IF(LL .EQ. 1) GO TO 40
DO 30 LLL=2,LL
IF(J .EQ. CDAM(LLL-1)) GO TO 50
30 CONTINUE
KTR=KTR+1
IF(KTR .EQ. 3) CALL CREND
CALL CRAM(5H AND )
40 CALL CRAMS(DEVICE(1,J),16)
50 CONTINUE
CALL CRAMDMP(9H DAMAGED.)
C--------PRINT MESSAGE IF SHIELDS WERE UP AND GOT KNOCKED DOWN
IF(DAMAGE(8) .EQ. 0) GO TO 60
IF(SHLDUP.NE.0) CALL PROUT(24H***SHIELDS KNOCKED DOWN.,24)
SHLDUP=0
C--------IF SUBSPACE RADIO GOT DAMAGED, REMEMBER THE FACT.
60 IF(DAMAGE(9).GT.0)ISUBDAM=1
ENERGY=ENERGY-HIT
RETURN
END

59
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/plaque.dat Normal file
View File

@@ -0,0 +1,59 @@
YOUR SCORE--
1 ROMULANS DESTROYED 20
9 ROMULANS CAPTURED 9
35 ORDINARY KLINGONS DESTROYED 350
6 KLINGON COMMANDERS DESTROYED 300
1 SUPER-COMMANDER DESTROYED 200
3.28 KLINGONS PER STARDATE, AVERAGE 1640
3 STARS DESTROYED BY YOUR ACTION -15
5 CASUALTIES INCURRED -5
BONUS FOR WINNING EMERITUS GAME 500
TOTAL SCORE 2999
EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
EEE E : : : E
EE EEE E : : NCC-1701 : E
EEEEEEEEEEEEEEEE EEEEEEEEEEEEEEE E : : : E
E E EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
EEEEEEEEE EEEEEEEEEEEEE E E
EEEEEEE EEEEE E E E E
EEE E E E E
E E E E
EEEEEEEEEEEEE E E
EEE : EEEEEEE EEEEEEEE
:E : EEEE E
.-E -:----- E
:E : E
EE : EEEEEEEE
EEEEEEEEEEEEEEEEEEEEEEE
U. S. S. ENTERPRISE
For demonstrating outstanding ability as a starship captain
Starfleet Command bestows to you
Tim Shoppa
the rank of
"Commodore Emeritus"
Emeritus level
This day of 24-May-92
Your score: 2999
Klingons per stardate: 3.28

1436
games/Super_Star_trek_(FORTRAN)/Original_VAX_version/startrek.doc Normal file
View File

File diff suppressed because it is too large Load Diff