C C C ******************************************************************** C ******************************************************************** C *** *** C *** *** S T A R F L E E T *** *** C *** *** C *** SOURCE PROGRAM FOR PDP 11/70 *** C *** by TREVOR C. SORENSEN *** C *** *** C *** VERSION: 1.1 - DEC. 1981 *** C *** *** C ******************************************************************** C ******************************************************************** C C BLOCKDATA COMMON/SYMBL/DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR(10,10) COMMON/WRDS/COND,KL,RM,GRN,RED,DCKD,DEST(2),DISAB(2),SHIP(16) COMMON/OBJCTS/D9,S9,E9,K9,B9,R9,M9 COMMON/ALPHA/ALPH(30) COMMON/SHIPS/SHIPSN(16,30),DECKS(24) INTEGER D9,S9,E9,B9,R9 REAL*8 COND,KL,RM,GRN,RED,DCKD,DEST,DISAB LOGICAL*1 DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR,ALPH,SHIP,SHIPSN DATA DOT,STAR,KLIN,BASE,ROM,MINE/'.','*','K','#','R','+'/ DATA D9,S9,E9,K9,B9,R9,M9/0,1,2,3,4,5,6/,SECTOR/100*' '/ DATA KL,RM,GRN,RED,DCKD,DEST,DISAB/'KLINGON','ROMULAN','GREEN', &'*RED*','DOCKED','DESTROYE','D','DISABLED',' '/ DATA ALPH/'A','B','C','D','E','F','G','H','I','J','K','L','M','N' &,'O','P','Q','R','S','T','U','V','W','X','Y','Z','.',',',';','/'/ DATA DECKS/405.,0.,0.,700.,1200.,812.,300.,311.01,112.,0.,0., &805.04,0.,0.,0.,112.,200.,0.,0.,0.,0.,0.,0.,1000./ END C C C *********************************** C * * C * STAR FLEET MAIN PROGRAM * C * * C *********************************** C PROGRAM MAIN C COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/MISC1/ICAPV(5),M1,M2,DATE,IDLN,BEARNG,NCAS(2),CMD,IG2,NPRIS &,IBELL COMMON/MISC2/NPROB,L5,L8,GASP,ITASK,SDATE,AFILE(4),CFILE(4),DTLSTH COMMON/SYMBL/DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR(10,10) COMMON/OBJCTS/D9,S9,E9,K9,B9,R9,M9 COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD COMMON/TESTS2/TNEW,TTMOUT,TOVER,TSHLD,TBASLO,TSLFDS,TWARN,THELLO, &TBOSS COMMON/RENEG/TRENEG,TSLAP,TSHOOT,TBAN COMMON/NAV/CORSD,WF COMMON/PERS/NAME1(16),NPL,NG,AVGTOT,PSWRD,IRNK,NSHP,IUIC(4) INTEGER SECT,QUAD,R1,C1,R,C,SHLD,CMD,H1,A,B,POW,H INTEGER D9,S9,E9,B9,R9 REAL*8 PSWRD LOGICAL TROM1,TROM2,TWON,TLOST,TDISAB,TDAMC,TNEW,TTMOUT,TOVER,TSHL &D,TBASLO,TRESC,TWARN,THELLO,TDEST,TSLFDS,TALTOW,TBOFF,TALERT,TLOOS &,TBALEN,TRESUM,TSTAT,TNAV,TDELIV,TMINBK,TLOG,TALSD,TINTRD,TBOSS, &TINTCP,TAMES,TMRTVR,TEXAM LOGICAL TRENEG,TSLAP,TSHOOT,TBAN LOGICAL*1 DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR,NAME1 BYTE FUNMES(25) C DATA FUNMES/25*0/,TMRTVR/.FALSE./ C NGAM=0 TNEW=.FALSE. 35 CALL NEWGAM(TDAMC,TRESUM,TLOG,DLN,NS,NGAM,TAMES,TEXAM) IF(TEXAM)GOTO 13 IF(.NOT.TRESUM)GOTO 2 CALL RESUME(TDAMC,TLOG,DLN) CALL COMP(TRESUM) CMD=0 2 IF(L5.EQ.1)GOTO 7 49 CALL BASTAK IF(TDEST)GOTO 37 IF(.NOT.TAMES)CALL SAVE(TDAMC,TLOG,DLN,TAMES) IF(CMD.EQ.8)CMD=0 7 CALL COMMND IF(CMD.EQ.14)CALL SAVE(TDAMC,TLOG,DLN,TAMES) IF(CMD.LE.0 .OR. CMD.GT.15)GOTO 7 43 L5=L5+1 IF(POW.GT.0 .OR. SHLD(5).GT.0)GOTO 45 TDISAB=.TRUE. GOTO 37 45 IF(CMD.NE.12)GOTO 14 IF(L5.NE.1)GOTO 80 NGAL(R1,C1)=-1 GOTO 35 80 TYPE 81 81 FORMAT(1X,'SORRY, TOO LATE!') GOTO 7 14 IF(L8.NE.0)GOTO 6 N4=N5 L8=1 6 CALL CHECKS IF(TLOOS)CALL LOOSAL IF(TSHLD)GOTO 7 22 GOTO(23,24,25,26,27,28,29,32,42,3,4,80,38,7,54),CMD 23 CALL NAVIG IF(TLOOS)CALL LOOSAL GOTO 34 24 CALL SSCAN GOTO 7 25 CALL LSCAN GOTO 7 26 CALL SHIELD IF(TLOOS)CALL LOOSAL GOTO 34 27 CALL TORP GOTO 52 28 CALL PHASER GOTO 52 29 CALL DAMCON(0,7,TDAMC) GOTO 7 32 CALL COMP(TRESUM,TNAV) IF(TNAV)CALL NAVIG GOTO 34 42 CALL MINCON(TNAV,TMRTVR,NM) IF(TNAV)CALL NAVIG IF(.NOT.TMRTVR)GOTO 34 N=0 8 CALL AUTRET(TDELIV,TMINBK,TMRTVR,MR,MC) IF(.NOT.TMRTVR)GOTO 9 CALL TRANSP(TMINBK,TMRTVR,MR,MC) N=N+1 IF(N.GE.NM)TMRTVR=.FALSE. IF(TMRTVR)GOTO 8 9 DO 12 I=1,10 DO 12 J=1,10 IF(SECT(I,J).EQ.M9)SECTOR(I,J)='+' 12 CONTINUE GOTO 34 3 CALL TRACBM(TDELIV,TMINBK,TMRTVR,MR,MC) IF(TDELIV)CALL DOCKED(TDELIV,.FALSE.) TDELIV=.FALSE. IF(TMINBK)CALL TRANSP(TMINBK,TMRTVR,MR,MC) 52 IF(TBOFF)CALL LOOSAL GOTO 34 54 CALL SHPLOG(TLOG) GOTO 7 4 CALL TRANSP(.FALSE.,TMRTVR,0,0) 34 IF(TDEST .OR. TDISAB)GOTO 37 IF(TRESC)CALL BASTAK CALL CHKPAT(TINTCP,FUNMES) IF(TINTCP)CALL DOCKED(.FALSE.,TINTCP) IF(TWON)GOTO 1 IF(TDISAB .OR. TDEST .OR. TTMOUT)GOTO 37 IF(TLOST)GOTO 37 GOTO 49 37 IF(RANK.GE.FLOAT(IRNK))CALL FAIL(AFILE(3)) IF(.NOT.TDISAB .OR. POW.GT.0 .OR. SHLD(5).GT.0)GOTO 1 230 TYPE 231 231 FORMAT(/1X,'*** ALL POWER EXPENDED ***') WRITE(3,231) 1 IF((.NOT.TDEST .AND. .NOT.TDISAB) .AND. TOVER)GOTO 49 38 CALL FINISH(DLN,TM,RATING,TSTAT,TAMES,TLOG) IF(.NOT.TSTAT)GOTO 53 CALL STATS(TM,RATING) 13 CALL PROMOT(RATING,RANK,TEXAM,II,JJ) CALL CLOSE(3) IF(TEXAM)STOP IF(TLOG)CALL SHPLOG(TLOG) IF(TLOG)CALL FINLOG(TM,RATING) GOTO 38 53 IF(TNEW)GOTO 35 IF(.NOT.TOVER)GOTO 5 OPEN(UNIT=3,NAME=AFILE,TYPE='OLD',ACCESS='APPEND') 5 IF(CMD.EQ.13)GOTO 7 GOTO 49 END C C C ************************************************ C * * C * SUBROUTINE TO ANALYSE CAPTAIN'S COMMANDS * C * * C ************************************************ C SUBROUTINE COMMND COMMON/MISC1/ICAPV(5),M1,M2,DATE,IDLN,BEARNG,NCAS(2),CMD,IG2,NPRIS &,IBELL COMMON/MISC2/NPROB,L5,L8,GASP,ITASK,SDATE,AFILE(4),CFILE(4),DTLSTH COMMON/ALPHA/ALPH(30) COMMON/CMMND/IMAGE(60),NC,TCANCL COMMON/PERS/NAME1(16),NPL,NG,AVGTOT,PSWRD,IRNK,NSHP,IUIC(4) DIMENSION CMDS(46) INTEGER CMD REAL*8 PSWRD LOGICAL TLETT,TWAIT,TSKTSK,TCANCL LOGICAL*1 ALPH,IMAGE,BLA,ANS,DUMMY(4),NAME1,PRANK(13) DATA BLA,ON,OFF/' ','ON','OFF'/,DUMMY/4*1H / DATA CMDS/ 'NAV','MOV','SHO','SRS','SSC','LON','LRS','LSC','DEF', &'SHI','PHO','TOR','PHA','DAM','COM','CMP','REP','STA','CSR','REC', &'PRO','HYP','GAL','MAP','TAR','CAL','SEL','AUT','SWI','AAS','SSR', &'BAS','SEC','MIN','TRA','INI','REA','STO','NEW','SAV','CAP','LOG', &'CAN','BEL','FUC','HEL'/ C IF(CMD.EQ.8)GOTO 1 IX="12 10 TYPE 11,IX 11 FORMAT(1X,A1,'COMMAND? ',$) 20 READ(5,21,ERR=10)NC,IMAGE 21 FORMAT(Q,60A1) IX="12 IF(NC.GT.59)NC=59 IF(NC.GT.0)GOTO 7 5 CALL CMDLST GOTO 10 7 CMD=0 1 N=0 CALL CAPMSK(IMAGE,NC) DO 16 I=1,4 DUMMY(I)=BLA 16 CONTINUE CALL SETRNK(IRNK,PRANK,1) TLETT=.FALSE. TWAIT=.FALSE. TSKTSK=.FALSE. TCANCL=.FALSE. ITASK=0 DO 2 I=1,NC+1 IF(TWAIT .AND. IMAGE(I).EQ.BLA)RETURN IF(IMAGE(I).EQ.ALPH(28) .OR. IMAGE(I).EQ.BLA)GOTO 6 IF(TWAIT)GOTO 2 N=N+1 DUMMY(N)=IMAGE(I) MASK=IMAGE(I).AND."100 IF(N.EQ.1 .AND. MASK.EQ."100)TLETT=.TRUE. IF(.NOT.TLETT .AND. MASK.EQ."100)GOTO 30 IF(TLETT .AND. MASK.EQ."0)GOTO 30 IF(N.LE.2)GOTO 2 6 IF(.NOT.TWAIT)GOTO 13 TWAIT=.FALSE. GOTO 2 13 IF(.NOT.TLETT)GOTO 200 100 DECODE(4,101,DUMMY,ERR=30)XCMD 101 FORMAT(A4) DO 3 J=1,46 IF(XCMD.EQ.CMDS(J))GOTO 4 3 CONTINUE GOTO 30 200 DECODE(N,201,DUMMY,ERR=30)ICMD 201 FORMAT(I4) IF(CMD.EQ.8)ITASK=ICMD IF(CMD.EQ.8)RETURN CMD=ICMD IF(CMD.EQ.0)GOTO 5 IF(CMD.EQ.8 .AND. IMAGE(I).EQ.ALPH(28))GOTO 15 IF(CMD.GE.1 .AND. CMD.LE.15)RETURN GOTO 30 17 TSKTSK=.TRUE. 30 TYPE 31,PRANK 31 FORMAT(/1X,'SORRY ',13A1,', BUT I DO ',$) IF(.NOT.TSKTSK)TYPE 41 41 FORMAT(1H+,'NOT ',$) 50 TYPE 51 51 FORMAT(1H+,'RECOGNIZE THAT COMMAND') IF(TSKTSK)GOTO 18 60 TYPE 61 61 FORMAT(1X,'FOR THE LIST OF OPTIONS, JUST HIT ') C ! WHEN INSTALLED, C CALL PAUSE(3) ! THESE 3 LINES DELETE THE C CALL BACKSP(105+NC) ! PREVIOUS COMMENT FROM THE C IX="0 ! SCREEN AFTER A PAUSE C GOTO 10 18 IF(J.EQ.10)TYPE 71 71 FORMAT(1X,'AND I THINK YOU''RE DISGUSTING!') IF(J.EQ.45)TYPE 81 81 FORMAT(1X,'AND ALTHOUGH I EXPECTED SOMETHING LIKE THAT FROM A'/1X, &'MENTALITY LIKE YOURS, THERE''S STILL NO NEED TO GET NASTY!') IF(J.EQ.46)TYPE 91 91 FORMAT(1X,'AND THAT''S WHERE YOU''LL END UP IF YOU FAIL IN YOUR MI &SSION!') TSKTSK=.FALSE. GOTO 10 110 TYPE 111 111 FORMAT(/1X'IT''S OBVIOUS THAT YOU NEED ALL THE HELP YOU CAN GET!') GOTO 5 4 IF(J.EQ.1 .OR. J.EQ.2)CMD=1 IF(J.GE.3 .AND. J.LE.5)CMD=2 IF(J.GE.6 .AND. J.LE.8)CMD=3 IF(J.EQ.10 .AND. IMAGE(I+1).EQ.ALPH(20))GOTO 17 IF(J.EQ.9 .OR. J.EQ.10)CMD=4 IF(J.EQ.11 .OR. J.EQ.12)CMD=5 IF(J.EQ.13)CMD=6 IF(J.EQ.14)CMD=7 IF(J.GE.15 .AND. J.LE.33)GOTO 8 IF(J.EQ.34)CMD=9 IF(J.EQ.35 .AND. IMAGE(I+1).EQ.ALPH(3))CMD=10 IF(J.EQ.35 .AND. IMAGE(I+1).EQ.ALPH(14))CMD=11 IF(J.EQ.35 .AND. IMAGE(I+1).EQ.BLA)GOTO 140 IF(J.EQ.36 .OR. J.EQ.37)CMD=12 IF(J.EQ.38 .OR. J.EQ.39)CMD=13 IF(J.EQ.40)CMD=14 IF(J.EQ.41 .OR. J.EQ.42)CMD=15 IF(J.EQ.43 .AND. IMAGE(I+1).EQ.ALPH(3))TCANCL=.TRUE. IF(J.EQ.44)GOTO 9 IF(J.EQ.45 .AND. IMAGE(I+1).EQ.ALPH(11))GOTO 17 IF(J.EQ.46 .AND. IMAGE(I+1).EQ.ALPH(12))GOTO 17 IF(J.EQ.46 .AND. IMAGE(I+1).EQ.ALPH(16))GOTO 110 IF(J.GE.45 .OR. CMD.EQ.0)GOTO 30 IF(CMD.EQ.8)CMD=0 RETURN 9 SWI=ON IF(IBELL.EQ."007)SWI=OFF 120 TYPE 121,SWI 121 FORMAT(/1X,'DO YOU WANT THE BELL (BEEPER) SWITCHED ',A3,'? ',$) 130 READ(5,131,ERR=120)ANS 131 FORMAT(A1) CALL CAPMSK(ANS,1) IF(ANS.EQ.ALPH(14))GOTO 10 IF(ANS.NE.ALPH(25))GOTO 120 IF(IBELL.EQ."007)GOTO 19 IBELL="007 GOTO 10 19 IBELL="0 GOTO 10 140 TYPE 141 141 FORMAT(1X,'I CANNOT TELL IF YOU MEAN "TRACTOR BEAMS" OR "TRANSPORT &ERS".'/1X,'PLEASE BE MORE EXPLICIT.') GOTO 10 8 IF(CMD.EQ.8)GOTO 12 CMD=8 IF(J.GE.17 .OR. J.EQ.15 .AND. IMAGE(I+1).EQ.ALPH(2))GOTO 12 14 TWAIT=.TRUE. TLETT=.FALSE. 15 N=0 2 CONTINUE RETURN 12 ITASK=0 IF(J.EQ.17)ITASK=1 IF(J.EQ.18 .OR. J.EQ.19)ITASK=2 IF(J.EQ.15 .AND. IMAGE(I+1).EQ.ALPH(2))ITASK=2 IF(J.EQ.20 .OR. J.EQ.21)ITASK=3 IF(J.EQ.22)ITASK=4 IF(J.EQ.23 .OR. J.EQ.24)ITASK=5 IF(J.EQ.25 .OR. J.EQ.26)ITASK=6 IF(J.EQ.27)ITASK=7 IF(J.EQ.28 .OR. J.EQ.29 .OR. J.EQ.30)ITASK=8 IF(J.EQ.31 .OR. J.EQ.32)ITASK=9 IF(J.EQ.18 .AND. IMAGE(I+1).EQ.ALPH(18))ITASK=9 IF(J.EQ.33)ITASK=10 RETURN END C C C ***************************************** C * * C * SUBROUTINE TO LIST COMMAND OPTIONS * C * * C ***************************************** C SUBROUTINE CMDLST C 10 TYPE 11 11 FORMAT(/1X,'COMMAND OPTIONS:'/ &1X,'(enter number, command, or abbreviation)'// &10X,'Command',T40,'Abbreviation'/10X,7(1H-),T40,12(1H-)/ &2X,'1. NAVIGATION CONTROL +',T40,'NAV or MOV'/ &2X,'2. SHORT RANGE SENSORS',T40,'SHO or SRS or SSC'/ &2X,'3. LONG RANGE SENSORS',T40,'LON or LRS or LSC'/ &2X,'4. DEFENSIVE SHIELDS CONTROL +',T40,'DEF or SHI'/ &2X,'5. PHOTON TORPEDO CONTROL +',T40,'PHO or TOR'/ &2X,'6. PHASER CONTROL +',T40,'PHA'/ &2X,'7. DAMAGE CONTROL REPORT',T40,'DAM'/ &2X,'8. SHIP''S COMPUTER (10 tasks)*',T40,'COM or CMP'/ &2X,'9. MINE CONTROL +',T40,'MIN'/ &1X'10. TRACTOR BEAM CONTROL +',T40,'TRAC'/ &1X'11. TRANSPORTERS CONTROL +',T40,'TRAN'/ &1X'12. INITIAL REASSIGNMENT',T40,'INI or REA'/ &1X'13. NEW MISSION or STOP',T40,'NEW or STO'/ &1X'14. SAVE GAME',T40,'SAV'/ &1X'15. CAPTAIN''S LOG',T40,'CAP or LOG'// &5X,'BELL (to turn the bell or beeper on or off)'/ &1X,'+ Indicates Command uses time'/ &1x,'* May or may not use time depending on the task chosen') RETURN END C C C ****************************************************** C * * C * SUBROUTINE OF ALIEN HITS ON SHIP (OR STARBASE) * C * * C ****************************************************** C SUBROUTINE HITS COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) INTEGER SECT,QUAD,R1,C1,R,C,H1,POW,SHLD,A,B,H LOGICAL TDEAD C H1=0 KR=0 KC=0 TDEAD=.FALSE. DO 1 J=1,7 CALL ALHITS(.FALSE.,J,KR,KC,TDEAD) IF(TDEAD)RETURN 1 CONTINUE RETURN END C C C ********************************************************** C * * C * SUBROUTINE TO CALCULATE HITS ON SHIP (OR STARBASE) * C * * C ********************************************************** C SUBROUTINE ALHITS(TSDALN,J,KR,KC,TDEAD) COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL COMMON/MISC2/NPROB,L5,L8,GASP,ITASK,SDATE,AFILE(4),CFILE(4),DTLSTH COMMON/SBASE/NBAS,RBAS,CBAS,STBS(5,5),NBASRM,NKDESB,KLATK(5) COMMON/SYMBL/DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR(10,10) COMMON/WRDS/COND,KL,RM,GRN,RED,DCKD,DEST(2),DISAB(2),SHIP(16) COMMON/OBJCTS/D9,S9,E9,K9,B9,R9,M9 COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD INTEGER SECT,QUAD,R1,C1,R,C,H1,POW,SHLD,A,B,H,RBAS,CBAS,STBS,DLN INTEGER CMD,D9,S9,E9,B9,R9 REAL*8 KL,RM,GRN,RED,DCKD,COND,ALIEN,DEST,DISAB,STARBS LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TDAMC,THBAS,TLOOS,TBALEN,TALSD,TINTRD LOGICAL TEST,TEST1,TEST2,TSDALN,TDEAD,TMOVES LOGICAL*1 DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR,SHIP,TARGET(16), &STRBS1(8) DATA TARGET/16*"0/,STARBS/'STARBASE'/ C IF(TSDALN .OR. J.EQ.0)GOTO 35 IF(K(J,1).EQ.0 .OR. K(J,4).EQ.1)RETURN IF(COND.EQ.DCKD)GOTO 15 IR=A IC=B THBAS=.FALSE. DO 8 I=1,16 TARGET(I)=SHIP(I) 8 CONTINUE IF(N6.EQ.0 .OR. RAN(II,JJ).GT.0.5)GOTO 7 15 IR=RBAS IC=CBAS THBAS=.TRUE. CALL A8TOA1(STARBS,STRBS1) DO 9 I=1,16 TARGET(I)="0 IF(I.LE.8)TARGET(I)=STRBS1(I) 9 CONTINUE 7 ALIEN=KL IF(J.GT.6)ALIEN=RM KR=K(J,1) KC=K(J,2) TEST2=.FALSE. IF(THBAS)GOTO 36 IF(CMD.NE.1 .AND. (CMD.LT.8 .OR. CMD.GT.10))GOTO 36 DIST=SQRT(FLOAT((KR-A)**2+(KC-B)**2)) TEST2=TMOVES(DIST,II,JJ) IF(TEST2 .AND. RAN(II,JJ)*15..LT.RANK)TEST2=.FALSE. IF(.NOT.TEST2)GOTO 36 60 TYPE 61,ALIEN 61 FORMAT(2X,A8,' VESSEL IN SECTOR ',$) WRITE(3,61)ALIEN GOTO 37 36 IHIT=SIZHIT(KR,KC,K(J,3),IR,IC) 10 TYPE 11,IHIT,TARGET,ALIEN 11 FORMAT(1X,I4,' UNIT HIT ON ',16A1,' BY ',A8,'IN SECTOR ',$) WRITE(3,11)IHIT,TARGET,ALIEN 37 IF(STATUS(4).LT.0. .AND. (IABS(A-KR).GT.2 .OR. IABS(B-KC).GT.2)) &GOTO 20 IF(TROM2 .OR. ALIEN.EQ.KL) GOTO 30 20 TYPE 21 21 FORMAT(1H+,'UNKNOWN',$) WRITE(3,21) GOTO 4 30 TYPE 31,KR,KC 31 FORMAT(1H+,I3,',',I3,$) WRITE(3,31)KR,KC 4 DTLSTH=DATE IF(.NOT.TEST2)GOTO 80 70 TYPE 71 71 FORMAT(1H+,' MISSED') WRITE(3,71) RETURN 80 TYPE 81 81 FORMAT(1H+,1X) WRITE(3,81) IF(THBAS)GOTO 12 H(J)=IHIT H1=H1+H(J) 35 IF(TSDALN)IHIT=SIZHIT(KR,KC,2106,A,B) IF(TSDALN .OR. J.NE.0)GOTO 38 DIST=SQRT(FLOAT((KR-A)**2+(KC-B)**2)) IHIT=100./(0.1*DIST) 38 SHLD(5)=SHLD(5)-IHIT IF(SHLD(5).GE.0)GOTO 5 IF(SHLD(5).GT.-100)GOTO 39 TDEST=.TRUE. GOTO 1 39 POW=POW+SHLD(5) TYPE 91,IBELL,IBELL 91 FORMAT(/1X,A1,'***** DANGER - ALL SHIELDS HAVE BEEN PENETRATED ** &***'/7X,'HULL PENETRATED - DAMAGE IS SEVERE',A1) WRITE(3,91)"0,"0 5 CALL FDSHLD(NS,TEST,KR,KC,A,B) IF(NS.EQ.0)GOTO 22 IF(.NOT.TEST)GOTO 16 34 SHLD(NS)=SHLD(NS)-IHIT/2 IF(NS.EQ.4)NS=0 SHLD(NS+1)=SHLD(NS+1)-IHIT/2 IF(NS.EQ.0)NS=4 GOTO 18 17 TEST=.FALSE. NS=NS+1 IF(NS.EQ.5)NS=1 GOTO 18 16 SHLD(NS)=SHLD(NS)-IHIT 18 IF(SHLD(NS).GE.0)GOTO 22 IF(SHLD(5).LT.0)GOTO 42 50 TYPE 51,NS 51 FORMAT(/1X,'*** DANGER - DEFENSIVE SHIELD',I2,' HAS BEEN PENETRATE &D ***') WRITE(3,51)NS 43 SHLD(5)=0 42 TDAMC=.FALSE. IZ=0 IC=0 CALL DAMCON(IZ,IC,TDAMC) IF(TDISAB .OR. TDEST)GOTO 1 IF(SHLD(5).LT.-50)GOTO 43 NS1=NS ITR1=0 ITR2=0 19 IX=ABS(FLOAT(SHLD(NS))/2.) IF(IABS(SHLD(NS)).EQ.IX*2)GOTO 23 SHLD(NS)=SHLD(NS)+1 23 NST=NS IF(NS.EQ.4)NST=0 IF(SHLD(NST+1).NE.0)GOTO 27 NST=NS IF(NS.EQ.1)NST=5 IF(SHLD(NST-1).NE.0)GOTO 27 NST=NS IF(NS.EQ.3)NST=-1 IF(NS.EQ.4)NST=0 SHLD(NST+2)=SHLD(NST+2)-2*IX SHLD(NS)=0 GOTO 22 27 NST=NS IF(NS.EQ.4)NST=0 IF(SHLD(NST+1).EQ.0 .AND. SHLD(NS).LT.0 .AND. NS.NE.NS1)GOTO 25 IF(SHLD(NS).GE.0)GOTO 24 SHLD(NST+1)=SHLD(NST+1)-IX IF(SHLD(NST+1).LT.0)ITR1=NST+1 SHLD(NS)=SHLD(NS)+IX 25 NST=NS IF(NS.EQ.1)NST=5 IF(SHLD(NST-1).EQ.0 .AND. SHLD(NS).LT.0 .AND. NS.NE.NS1)GOTO 23 IF(SHLD(NS).GE.0)GOTO 24 SHLD(NST-1)=SHLD(NST-1)-IX IF(SHLD(NST-1).LT.0)ITR2=NST-1 SHLD(NS)=SHLD(NS)+IX 24 IF(ITR1.EQ.0)GOTO 26 NS=ITR1 ITR1=0 GOTO 19 26 IF(ITR2.EQ.0)GOTO 28 NS=ITR2 ITR2=0 GOTO 19 28 IF(SHLD(NS).GE.0)GOTO 22 NST=NS 29 IY=IABS(SHLD(NS)) MAX=MAX0(SHLD(1),SHLD(2),SHLD(3),SHLD(4)) DO 32 I=1,4 IF(SHLD(I).NE.MAX)GOTO 32 SHLD(I)=SHLD(I)-IY SHLD(NST)=0 NST=I IF(SHLD(I))29,22,22 32 CONTINUE GOTO 22 12 STBS(N6,3)=STBS(N6,3)-IHIT IF(STBS(N6,3).GE.0)RETURN 40 TYPE 41,N6 41 FORMAT(/1X,10('*'),' STARBASE',I2,' DESTROYED ',10('*')/) 4000 WRITE(3,41)N6 STBS(N6,1)=0 SECT(RBAS,CBAS)=D9 SECTOR(RBAS,CBAS)=DOT QUAD(R1,C1)=QUAD(R1,C1)-10 NGAL(R1,C1)=QUAD(R1,C1) NBASRM=NBASRM-1 N6=0 IF(COND.NE.DCKD)RETURN TDEST=.TRUE. GOTO 1 22 SHLD(5)=0 DO 33 I=1,4 IF(SHLD(I).LT.0)SHLD(I)=0 SHLD(5)=SHLD(5)+SHLD(I) 33 CONTINUE IF(TEST)GOTO 17 RETURN 1 TDEAD=.TRUE. RETURN END C C C ************************************************** C * * C * SUBROUTINE TO DETERMINE SHIELD ORIENTATION * C * * C ************************************************** C SUBROUTINE FDSHLD(NS,TEST,KR,KC,IA,IB) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD INTEGER DLN,CMD LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TLOOS,TBALEN,TALSD,TINTRD,TEST C TEST=.FALSE. THETA=BEARNG PHIPR=ANGLE(KR,KC,IA,IB) IF(.NOT.TALTOW)GOTO 2 IF(KR.NE.ICAPV(1) .OR. KC.NE.ICAPV(2))GOTO 2 IF(IABS(IA-KR).LE.3 .AND. IABS(IB-KC).LE.3)GOTO 2 IF(AMOD(PHIPR,45.).NE.0.)GOTO 1 PHIPR=PHIPR-180. GOTO 2 1 IF(PHIPR.LT.0.)PHIPR=360.+PHIPR N=INT(PHIPR/45.)+1 IF(N.EQ.4 .OR. N.EQ.7)PHIPR=45. IF(N.EQ.1 .OR. N.EQ.6)PHIPR=135. IF(N.EQ.3 .OR. N.EQ.8)PHIPR=225. IF(N.EQ.2 .OR. N.EQ.5)PHIPR=315. 2 PHI=PHIPR-THETA IF(PHI.LT.0.)PHI=360.+PHI NS=0 IF(PHI.GT.315. .OR. PHI.LT.45.)NS=1 IF(PHI.GT.45. .AND. PHI.LT.135.)NS=2 IF(PHI.GT.135. .AND. PHI.LT.225.)NS=3 IF(PHI.GT.225. .AND. PHI.LT.315.)NS=4 IF(NS.NE.0)RETURN IF(PHI.EQ.45.)NS=1 IF(PHI.EQ.135.)NS=2 IF(PHI.EQ.225.)NS=3 IF(PHI.EQ.315.)NS=4 TEST=.TRUE. RETURN END C C C ************************************* C * * C * SUBROUTINE FOR ALIEN MOVEMENT * C * * C ************************************* C SUBROUTINE ALMOVE(TMOVE,TRACM,I) COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL COMMON/SBASE/NBAS,RBAS,CBAS,STBS(5,5),NBASRM,NKDESB,KLATK(5) COMMON/RATNG/NBASD,NRESC,NFRES,NROMD,NCAPAL,NPRTKN COMMON/SYMBL/DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR(10,10) COMMON/WRDS/COND,KL,RM,GRN,RED,DCKD,DEST(2),DISAB(2),SHIP(16) COMMON/OBJCTS/D9,S9,E9,K9,B9,R9,M9 COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD INTEGER SECT,QUAD,R1,C1,R,C,SHLD,DLN,H1,A,B,POW,RBAS,CBAS,H,STBS INTEGER E9,D9,S9,B9,R9,CMD REAL*8 KL,RM,GRN,RED,DCKD,COND,ALIEN,DEST,DISAB LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TMOVE,TRACM,TEST1,TLOOS,TBALEN,TALSD,TMOVES,TINTRD LOGICAL*1 DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR,SHIP DATA ALIEN/' '/ C IF(TRACM)GOTO 6 IF(K(I,3).LE.100)RETURN X3=N3 IX=0 PROB=10.-((ALOG(RANK)/(0.45*(X3+1.)))**2+ALOG(X3+1.)*ALOG10(RANK)) IF(RAN(II,JJ)*10..LT.PROB) RETURN IF(K(I,1).EQ.0 .OR. K(I,2).EQ.0) RETURN TMOVE=.TRUE. SECT(K(I,1),K(I,2))=D9 SECTOR(K(I,1),K(I,2))=DOT IF(I.GT.6)TROM2=.FALSE. IF(I.LT.7 .OR. RAN(II,JJ).GT.0.03*RANK) GOTO 1 K(I,1)=0 K(I,2)=0 H1=H1-H(I) N2=N2-1 TROM1=.FALSE. 40 TYPE 41 41 FORMAT(/1X,'** REPORT FROM SCIENCE OFFICER:'/1X, &'Sensors indicate that the Romulan warship has left the quadrant') WRITE(3,41) GOTO 2 1 ANGL=RAN(II,JJ)*7.0 IF(ANGL.GT.6.28319)ANGL=0. IWF=RAN(II,JJ)*20. DO 14 J=0,IWF XJ=J IR1=INT(XJ*-SIN(ANGL))+K(I,1) IC1=INT(XJ*COS(ANGL))+K(I,2) IF(IR1.GT.10 .OR. IR1.LT.1 .OR. IC1.GT.10 .OR. IC1.LT.1)GOTO 18 GOTO(15,18,18,18,18,18,15),SECT(IR1,IC1)+1 15 IR2=IR1 IC2=IC1 IF(SECT(IR1,IC1).EQ.M9)GOTO 3 14 CONTINUE 18 IX=IX+1 IF(IR1.NE.K(I,1) .OR. IC1.NE.K(I,2))GOTO 4 IF(IX.LE.100)GOTO 1 TMOVE=.FALSE. IF(I.GT.6)TROM2=.TRUE. GOTO 4 3 TMOVE=.FALSE. M2=M2-1 ALIEN=KL IF(I.GT.6)ALIEN=RM SECT(IR1,IC1)=D9 SECTOR(IR1,IC1)=DOT IF(RAN(II,JJ).LT.0.4) GOTO 20 6 TEST1=.FALSE. IF(K(I,4).EQ.1)TEST1=.TRUE. IF(.NOT.TRACM)GOTO 13 IR1=K(I,1) IC1=K(I,2) ALIEN=KL IF(I.GT.6)ALIEN=RM IF(TEST1)GOTO 10 13 N4=N4-1 10 TYPE 11,ALIEN,DEST,IR1,IC1 11 FORMAT(/1X'**** ',2A8,A1,' BY MINE IN SECTOR ',I3,',',I3,' * &***'/) 1000 WRITE(3,11)ALIEN,DEST,IR1,IC1 DO 12 I1=1,5 K(I,I1)=0 12 CONTINUE IF(TEST1)RETURN H1=H1-H(I) IF(ALIEN.EQ.KL) GOTO 7 TROM1=.FALSE. NROMD=NROMD+1 GOTO 2 7 N3=N3-1 QUAD(R1,C1)=QUAD(R1,C1)-100 NGAL(R1,C1)=QUAD(R1,C1) 2 IF(N3.GT.0 .OR. TROM1)GOTO 9 IF(COND.NE.DCKD)COND=GRN IF(.NOT.TALERT)GOTO 16 IF(COND.NE.GRN .OR. STATUS(6).LT.0. .OR. SHLD(5).EQ.0)GOTO 16 POW=POW+SHLD(5) DO 17 I1=1,5 SHLD(I1)=0 17 CONTINUE 16 IF(N6.EQ.0 .OR. TROM1)GOTO 9 IF(STBS(N6,4).NE.1)GOTO 9 STBS(N6,4)=0 TRESC=.TRUE. 9 IF(N4.LE.0)TWON=.TRUE. RETURN 20 TYPE 21,ALIEN,IR1,IC1 21 FORMAT(/1X,A8,' DAMAGED BY MINE IN SECTOR ',I3,',',I3/) 2000 WRITE(3,21)ALIEN,IR1,IC1 K(I,3)=K(I,3)-100 IF(ALIEN.EQ.RM)TROM2=.TRUE. IF(K(I,3).GT.100)GOTO 4 30 TYPE 31,ALIEN,DISAB(1) 31 FORMAT(1X,'** ',A8,'VESSEL IS ',A8,' **') 3000 WRITE(3,31)ALIEN,DISAB(1) 4 IF(.NOT.TMOVE)GOTO 19 IF(I.GT.6)GOTO 19 DIST=SQRT(FLOAT((K(I,1)-IR2)**2+(K(I,2)-IC2)**2)) IF(DIST.GT.2. .AND. STATUS(4).LT.0.)GOTO 19 TMOVE=TMOVES(DIST,II,JJ) 19 K(I,1)=IR2 K(I,2)=IC2 IF (I.LT.7) GOTO 8 SECT(IR2,IC2)=R9 IF(TROM2)SECTOR(IR2,IC2)=ROM RETURN 8 SECT(IR2,IC2)=K9 SECTOR(IR2,IC2)=KLIN RETURN END C C C *********************************** C * * C * DAMAGE CONTROL SUBROUTINE * C * * C *********************************** C SUBROUTINE DAMCON(IZ1,ICMD,TDAMC) COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL COMMON/WRDS/COND,KL,RM,GRN,RED,DCKD,DEST(2),DISAB(2),SHIP(16) COMMON/OBJCTS/D9,S9,E9,K9,B9,R9,M9 COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD DIMENSION OPSTAT(13,3),OPWD(3),XOPWD(3) REAL*8 COND,KL,RM,GRN,RED,DCKD,DEST,DISAB INTEGER SECT,QUAD,R1,C1,R,C,SHLD,CMD,H1,A,B,POW,H,DLN INTEGER E9,D9,S9,B9,R9 LOGICAL*1 SHIP LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TDAMC,TLOOS,TBALEN,TALSD,TINTRD,TEST C DATA OPWD,XOPWD/' OPE','RATI','ONAL','*INO','PERA','TIVE'/ C IF(ICMD.EQ.7)GOTO 19 IF(TDAMC .OR. ICMD.EQ.99)GOTO 5 IF(ICMD.EQ.98)GOTO 30 IF(ICMD.EQ.97)GOTO 17 IF(IZ1.EQ.13)GOTO 140 GOTO 4 19 DO 22 I=1,13 DO 22 J=1,3 IF(STATUS(I))24,23,23 23 OPSTAT(I,J)=OPWD(J) GOTO 22 24 OPSTAT(I,J)=XOPWD(J) 22 CONTINUE 10 TYPE 11 11 FORMAT(/1X,T20,'*** DAMAGE CONTROL REPORT ***'/1X,T15,'System',T43 &,'Status',T56,'Est.Recovery Time'/1X,35(1H-),T41,11(1H-),T55,18(1H &-)) 20 TYPE 21,((OPSTAT(I,J),J=1,3),ABS(STATUS(I)),I=1,13) 21 FORMAT(2X,'1. NAVIGATION COMPUTER',T40,3A4,T59,F8.4/2X,'2. WARP EN &GINES',T40,3A4,T59,F8.4/2X,'3. IMPULSE ENGINES',T40,3A4,T59,F8.4/ &2X,'4. SHORT RANGE SENSORS',T40,3A4,T59,F8.4/2X,'5. LONG RANGE SEN &SORS',T40,3A4,T59,F8.4/2X,'6. SHIELD CONTROL',T40,3A4,T59,F8.4/2X, &'7. PHOTON TORPEDO CONTROL',T40,3A4,T59,F8.4/2X,'8. PHASER CONTROL &',T40,3A4,T59,F8.4/2X,'9. MINE CONTROL',T40,3A4,T59,F8.4/1X,'10. T &RACTOR BEAM',T40,3A4,T59,F8.4/1X,'11. TRANSPORTERS',T40,3A4,T59,F &8.4/1X,'12. PRIMARY LIFE SUPPORT SYSTEM',T40,3A4,T59,F8.4/1X,'13. &BACKUP LIFE SUPPORT SYSTEM',T40,3A4,T59,F8.4/) 4 IF(TDAMC) GOTO 5 ID8=0 DO 1 I=1,13 IF(STATUS(I).LT.0.) GOTO 2 STATUS(I)=0. GOTO 1 2 ID8=ID8+1 1 CONTINUE IF(ICMD.EQ.7) RETURN IX=SECNDS(0.)/100. DO 8 I=1,IX R3=RAN(II,JJ) 8 CONTINUE TEST=.FALSE. IF(ICMD.EQ.96)GOTO 14 IHIT=0 DO 13 I=1,4 IF(SHLD(I).GE.0)GOTO 13 TEST=.TRUE. NS=I IF(IABS(SHLD(I)).GT.IHIT)IHIT=IABS(SHLD(I)) 13 CONTINUE IF(.NOT.TEST .OR. ID8.LT.13)GOTO 14 TDEST=.TRUE. RETURN 14 IF(TEST)GOTO 30 IF(R3.GT.0.5 .OR. ID8.EQ.13) RETURN 30 TYPE 31 31 FORMAT(/1X,'*** DAMAGE CONTROL REPORT ***') WRITE(3,31) 7 R4=-RAN(II,JJ)*5. IF(ABS(R4).LT.0.1)GOTO 7 IF(ICMD.EQ.96)GOTO 3 IF(SHLD(5).LT.0 .AND. ABS(R4).LT.3.)GOTO 7 IF(ICMD.EQ.98)GOTO 5 NTIME=0 IF(IHIT.LE.25)GOTO 270 3 IZ1=INT(RAN(II,JJ)*15.)+1 IF(IZ1.GT.13) GOTO 3 IF(STATUS(IZ1).LT.0.)GOTO 3 IF(IZ1.EQ.13 .AND. STATUS(12).LT.0.)GOTO 140 IF(ICMD.EQ.96)GOTO 29 GOTO(17,25,25,17,17,17,26,27,26,25,17,17,17),IZ1 25 IF(NS.NE.3)GOTO 28 GOTO 17 26 IF(NS.NE.1)GOTO 28 GOTO 17 27 IF(NS.NE.3)GOTO 17 28 NTIME=NTIME+1 IF(NTIME.LE.10)GOTO 3 29 IF(ICMD.EQ.96 .AND. RAN(II,JJ).GT.1./AINT(RANK))GOTO 5 270 TYPE 271 271 FORMAT(1X,'ONLY MINOR STRUCTURAL DAMAGE SUFFERED - NO CRITICAL SYS &TEMS AFFECTED') WRITE(3,271) R4=1 GOTO 16 17 IF(ICMD.EQ.97 .AND. IZ1.GE.80)GOTO 240 5 GOTO(230,40,50,60,70,80,90,100,120,190,200,18,3),IZ1 230 TYPE 231 231 FORMAT(1X,'NAVIGATION COMPUTER',$) WRITE(3,231) GOTO 6 40 TYPE 41 41 FORMAT(1X,'WARP ENGINES',$) WRITE(3,41) GOTO 6 50 TYPE 51 51 FORMAT(1X,'IMPULSE ENGINES',$) WRITE(3,51) GOTO 6 60 TYPE 61 61 FORMAT(1X,'SHORT RANGE SENSORS',$) WRITE(3,61) GOTO 6 70 TYPE 71 71 FORMAT(1X,'LONG RANGE SENSORS',$) WRITE(3,71) GOTO 6 80 TYPE 81 81 FORMAT(1X,'SHIELD CONTROL',$) WRITE(3,81) GOTO 6 90 TYPE 91 91 FORMAT(1X,'PHOTON TORPEDO CONTROL',$) WRITE(3,91) GOTO 6 100 TYPE 101 101 FORMAT(1X,'PHASER CONTROL',$) WRITE(3,101) GOTO 6 120 TYPE 121 121 FORMAT(1X,'MINE CONTROL',$) WRITE(3,121) GOTO 6 190 TYPE 191 191 FORMAT(1X,'TRACTOR BEAM',$) WRITE(3,191) IF(.NOT.TDAMC .AND. TALTOW)TLOOS=.TRUE. GOTO 6 200 TYPE 201 201 FORMAT(1X,'TRANSPORTERS',$) WRITE(3,201) GOTO 6 18 IBEEP=IBELL IF(ICMD.EQ.99)IBEEP="0 130 TYPE 131,IBEEP 131 FORMAT(1X,'PRIMARY LIFE SUPPORT SYSTEM',A1,$) WRITE(3,131)IBEEP 6 IF(ICMD.EQ.97)GOTO 250 IF(ICMD.NE.99)GOTO 15 220 TYPE 221 221 FORMAT(1H+,' REPAIRED') WRITE(3,221) RETURN 15 IF(STATUS(IZ1).GE.0.)STATUS(IZ1)=R4 TYPE 111,ABS(STATUS(IZ1)) 111 FORMAT(1H+,' OUT- ESTIMATED RECOVERY IN ',F7.4,' STARDATES') WRITE(3,111)ABS(STATUS(IZ1)) IF(IZ1.NE.12)GOTO 9 140 TYPE 141 141 FORMAT(/1X,'BACKUP LIFE SUPPORT SYSTEM',$) WRITE(3,141) IF(IZ1.EQ.13)GOTO 12 TYPE 151 151 FORMAT(1H+,' ON'/) WRITE(3,151) 9 IF(ICMD.EQ.98 .OR. ICMD.EQ.96)GOTO 16 TDAMC=.FALSE. IF(ICMD.GT.0)RETURN 16 ICASL=(ABS(R4)+RAN(II,JJ))*10.0 IF(SHLD(5).LT.0)ICASL=ICASL*2 IF(ICASL+NCAS(1).GT.430)ICASL=430-NCAS(1) NCAS(1)=NCAS(1)+ICASL TYPE 211,ICASL 211 FORMAT(1X,'NUMBER OF CASUALTIES INCURRED:',I4/) WRITE(3,211)ICASL CALL PAUSE(4) RETURN 12 IF(STATUS(12).LT.-5.)GOTO 170 TYPE 161 161 FORMAT(1H+,' DESTROYED',$) WRITE(3,161) GOTO 180 170 TYPE 171 171 FORMAT(1H+,' EXHAUSTED',$) WRITE(3,171) 180 TYPE 181 181 FORMAT(1H+,' - ** ALL LIFE ABOARD TERMINATED **'/) WRITE(3,181) TDISAB=.TRUE. RETURN 240 TYPE 241,MOD(IZ1,10) 241 FORMAT(1X,'Ship''s computer task #',I2,$) WRITE(3,241)MOD(IZ1,10) 250 TYPE 251,ITR(4) 251 FORMAT(1H+,' unavailable due to Level',I2/1X,'security search in p &rogress.'/) WRITE(3,251)ITR(4) RETURN END C C C ******************************************* C * * C * SUBROUTINE TO SET LAYOUT OF QUADRANT * C * * C ******************************************* C SUBROUTINE QADSET COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL COMMON/SBASE/NBAS,RBAS,CBAS,STBS(5,5),NBASRM,NKDESB,KLATK(5) COMMON/SYMBL/DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR(10,10) COMMON/WRDS/COND,KL,RM,GRN,RED,DCKD,DEST(2),DISAB(2),SHIP(16) COMMON/OBJCTS/D9,S9,E9,K9,B9,R9,M9 COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD REAL*8 KL,RM,GRN,RED,DCKD,COND,DEST,DISAB INTEGER SECT,QUAD,R1,C1,R,C,SHLD,H1,A,B,POW,RBAS,CBAS,H,STBS,DLN INTEGER E9,D9,S9,B9,R9,CMD LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TLOOS,TBALEN,TALSD,TINTRD LOGICAL*1 DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR,SHIP C DO 1 I=1,7 DO 12 J=1,5 K(I,J)=0 12 CONTINUE K(I,3)=500 1 CONTINUE IF(.NOT.TALTOW)TALSD=.FALSE. IF(TALTOW .AND. ICAPV(5).NE.2)TALSD=.FALSE. H1=0 M1=0 M2=0 RBAS=0 CBAS=0 TROM1=.FALSE. TROM2=.FALSE. COND=GRN N2=QUAD(R1,C1)/100 N6=QUAD(R1,C1)/10-N2*10 N1=QUAD(R1,C1)-(N2*100+N6*10) IF(N6.EQ.0)GOTO 8 DO 9 I=1,5 IF(STBS(I,1).NE.R1 .OR. STBS(I,2).NE.C1)GOTO 9 N6=I IF(STBS(N6,4).NE.1)GOTO 8 DO 13 J=1,5 K(J,3)=KLATK(J) 13 CONTINUE GOTO 8 9 CONTINUE 8 IF(N2.EQ.0) GOTO 6 COND=RED 6 N3=N2 DO 2 I=1,10 DO 2 J=1,10 SECT(I,J)=D9 SECTOR(I,J)=DOT 2 CONTINUE IF(N1.EQ.0)GOTO 15 DO 3 J1=1,N1 CALL PLACE(I,J) SECT(I,J)=S9 SECTOR(I,J)=STAR 3 CONTINUE 15 IF(N2.EQ.0)GOTO 14 DO 4 J=1,N2 CALL PLACE(K(J,1),K(J,2)) SECT(K(J,1),K(J,2))=K9 SECTOR(K(J,1),K(J,2))=KLIN 4 CONTINUE 14 IF(N6.EQ.0) GOTO 5 CALL PLACE(RBAS,CBAS) SECT(RBAS,CBAS)=B9 SECTOR(RBAS,CBAS)=BASE 5 IF(IG2.NE.0) RETURN 7 A=INT(RAN(II,JJ)*10.)+1 B=INT(RAN(II,JJ)*10.)+1 IF(SECT(A,B).NE.D9) GOTO 7 SECT(A,B)=E9 SECTOR(A,B)=SHP CALL NEWQAD IG2=1 TROM1=.FALSE. RETURN END C C C ************************************************* C * * C * SUBROUTINE TO PLACE OBJECTS IN THE QUADRANT * C * * C ************************************************* C SUBROUTINE PLACE(I,J) COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) INTEGER SECT,QUAD,R1,C1,R,C,SHLD,H1,A,B,POW,H C 1 I=INT(RAN(II,JJ)*10.)+1 J=INT(RAN(II,JJ)*10.)+1 IF(SECT(I,J).NE.0 .OR. I.EQ.R .AND. J.EQ.C) GOTO 1 RETURN END C C C ********************************************* C * * C * SUBROUTINE FOR ENTERING A NEW QUADRANT * C * * C ********************************************* C SUBROUTINE NEWQAD COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL COMMON/SBASE/NBAS,RBAS,CBAS,STBS(5,5),NBASRM,NKDESB,KLATK(5) COMMON/WRDS/COND,KL,RM,GRN,RED,DCKD,DEST(2),DISAB(2),SHIP(16) COMMON/OBJCTS/D9,S9,E9,K9,B9,R9,M9 COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD REAL*8 KL,RM,GRN,RED,DCKD,COND,DEST,DISAB INTEGER SECT,QUAD,R1,C1,R,C,SHLD,H1,A,B,POW,H,DLN,CMD INTEGER RBAS,CBAS,STBS INTEGER E9,D9,S9,B9,R9 LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TLOOS,TBALEN,TALSD,TINTRD LOGICAL*1 SHIP C 10 TYPE 11,R1,C1,A,B,COND 11 FORMAT(/1X,'QUADRANT:',I3,',',I3/1X,'SECTOR: ',I3,',',I3/1X'CONDI &TION: ',A8/) 1000 WRITE(3,11)R1,C1,A,B,COND NGAL(R1,C1)=QUAD(R1,C1) IF(.NOT.TBALEN)GOTO 1 TBALEN=.FALSE. IF(SHLD(5).LT.475*N2)GOTO 1 GOTO 4 1 IF(COND.EQ.GRN) GOTO 3 IF(.NOT.TALERT .OR. SHLD(5).GE.800*N2 .OR. STATUS(6).LT.0.)GOTO 4 IF(POW+SHLD(5).LT.25 .OR. POW.LE.25)GOTO 4 POW=POW+SHLD(5) SHLD(5)=800*N2 IF(POW.LE.SHLD(5))SHLD(5)=POW-25 2 CALL BALERT GOTO 3 4 CALL HITS 3 IF(N6.EQ.0)RETURN TYPE 21,N6,RBAS,CBAS 21 FORMAT(/1X,'** REPORT FROM SCIENCE OFFICER:'/1X, &'Starbase',I2,' is located in Sector',I3,',',I3) WRITE(3,21)N6,RBAS,CBAS RETURN END C C C ************************************************************** C * * C * SUBROUTINE TO CHECK SHIELDS WHEN ENTERING A NEW QUADRANT * C * * C ************************************************************** C SUBROUTINE BALERT COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD INTEGER SECT,QUAD,R1,C1,R,C,SHLD,H1,A,B,POW,H,DLN,CMD LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TLOOS,TBALEN,TALSD,TINTRD C TLOOS=.FALSE. IF(.NOT.TALERT)RETURN IF(.NOT.TROM1) GOTO 5 IF(SHLD(5).GE.H1+2000 .OR. STATUS(6).LT.0.)RETURN IF(POW+SHLD(5).LT.25 .OR. POW.LE.25)RETURN POW=POW+SHLD(5) 2 SHLD(5)=SHLD(5)+2000 IF(POW.LE.SHLD(5))SHLD(5)=POW-25 5 ISH=SHLD(5) IF(POW.GE.4400 .OR. ISH.GT.4000)ISH=4000 IF(ISH.NE.4000 .AND. MOD(ISH,4).NE.0)ISH=SHLD(5)-MOD(ISH,4)*4 POW=POW-ISH SHLD(5)=0 DO 1 I=1,4 SHLD(I)=ISH/4 SHLD(5)=SHLD(5)+SHLD(I) 1 CONTINUE 10 TYPE 11 11 FORMAT(1X'*** RED ALERT - SHIELDS RAISED ***'/) 1000 WRITE(3,11) IF(TROM1) GOTO 4 CALL HITS 4 IF(TALTOW)TLOOS=.TRUE. IG2=1 RETURN END C C C ************************************************** C * * C * SUBROUTINE TO CAUSE A PAUSE IN THE PROGRAM * C * * C ************************************************** C SUBROUTINE PAUSE(N) C IEFN=1 NTIC=N*30 CALL MARK(IEFN,NTIC,1) CALL WAITFR(IEFN) RETURN END C C C *********************************************** C * * C * SUBROUTINE TO BLANK OUT THE ARRAY IMAGE * C * * C *********************************************** C SUBROUTINE BLANKS(IMAGE) LOGICAL*1 IMAGE(72),BLANK1 DATA BLANK1/1H / C DO 1 I=1,72 IMAGE(I)=BLANK1 1 CONTINUE RETURN END C C C ****************************************** C * * C * SUBROUTINE TO BACKSPACE THE CURSOR * C * (ALSO DELETES THE CHARACTERS) * C * * C ****************************************** C SUBROUTINE BACKSP(N) C DO 1 I=1,N TYPE 11,"10 11 FORMAT(1H+,A1,$) 1 CONTINUE RETURN END C C C ************************************************************** C * * C * SUBROUTINE TO CONVERT REAL*8 WORDS TO LOGICAL*1 ARRAYS * C * * C ************************************************************** C SUBROUTINE A8TOA1(WORD8,ARRAY1) REAL*8 WORD8 LOGICAL*1 ARRAY1(8) C ENCODE(8,11,ARRAY1)WORD8 11 FORMAT(A8) RETURN END C C C ***************************************************** C * * C * SUBROUTINE TO CONVERT ALL LETTERS TO CAPITALS * C * * C ***************************************************** C SUBROUTINE CAPMSK(ARRAY,NC) LOGICAL*1 ARRAY(NC) C DO 1 I=1,NC IF((ARRAY(I).AND."100).EQ."0)GOTO 1 ARRAY(I)=ARRAY(I).AND."737 1 CONTINUE RETURN END C C C ****************************************** C * * C * SUBROUTINE TO CROP HOLLERITH LINES * C * * C ****************************************** C SUBROUTINE CROP(IMAGE,NC) C LOGICAL*1 IMAGE(NC) C DO 1 I=NC,2,-1 IF(IMAGE(I).NE.' ')RETURN IMAGE(I)="0 1 CONTINUE RETURN END C C C ******************************************** C * * C * SUBROUTINE FOR RUNNING MCR TASKS * C * * C ******************************************** C SUBROUTINE RUNMCR(FILEID,N,TYP) C COMMON/MISC2/NPROB,L5,L8,GASP,ITASK,SDATE,AFILE(4),CFILE(4),DTLSTH LOGICAL*1 FILEID(22),BUFFER(31),TYP C DATA XMCR/6RMCR.../,BUFFER/31*' '/,IEFN/1/ C IF(TYP.EQ.'D')GOTO 20 10 ENCODE(32,11,BUFFER)(FILEID(I),I=1,N) 11 FORMAT('PIP ',A1,'/NM/UN') GOTO 1 20 ENCODE(18,21,BUFFER)(FILEID(I),I=1,N),AFILE(3) 21 FORMAT('DEL ',A1,'.',A3,';*') 1 NC=N+10 CALL SPAWN(XMCR,,,IEFN,,,,BUFFER,NC) CALL WFLOR(IEFN) RETURN END C C C ****************************************** C * * C * SUBROUTINE FOR DETERMINING RANK * C * * C ****************************************** C SUBROUTINE SETRNK(IR,RANK1,ICAP) C REAL*8 RANK8(2) LOGICAL*1 RANK1(13),DUM1(8),DUM2(8) C EQUIVALENCE (DUM1(1),RANK1(1)),(DUM2(1),RANK1(9)) C RANK8(1)=' ' RANK8(2)=' ' IRNK=IR IF(IR.EQ.0)IRNK=1 IF(IRNK.LT.0)GOTO 13 GOTO(1,2,3,4,5,6,7,8,9,10,11),IRNK 1 RANK8(1)='Cadet' GOTO 14 2 RANK8(1)='Lieutena' RANK8(2)='nt JG' GOTO 14 3 RANK8(1)='Lieutena' RANK8(2)='nt' GOTO 14 4 RANK8(1)='Lt. Comm' RANK8(2)='ander' GOTO 14 5 RANK8(1)='Commande' RANK8(2)='r' GOTO 14 6 RANK8(1)='Captain' GOTO 14 7 RANK8(1)='Commodor' RANK8(2)='e' GOTO 14 8 RANK8(1)='Rear Adm' RANK8(2)='iral' GOTO 14 9 RANK8(1)='Vice Adm' RANK8(2)='iral' GOTO 14 10 RANK8(1)='Admiral' GOTO 14 11 RANK8(1)='Fleet Ad' RANK8(2)='miral' GOTO 14 13 RANK8(1)='PRISONER' 14 CALL A8TOA1(RANK8(1),DUM1) CALL A8TOA1(RANK8(2),DUM2) DO 12 I=1,13 IF(I.LE.8)RANK1(I)=DUM1(I) IF(I.GT.8)RANK1(I)=DUM2(I-8) 12 CONTINUE IF(ICAP.EQ.1)CALL CAPMSK(RANK1,13) CALL CROP(RANK1,13) C RETURN END C C C ******************************************************* C * * C * SUBROUTINE TO TEST IF THE PLAYER IS REALLY * C * THE GRAND ADMIRAL (THE BOSS) * C * * C ******************************************************* C SUBROUTINE SIR COMMON/TESTS2/TNEW,TTMOUT,TOVER,TSHLD,TBASLO,TSLFDS,TWARN,THELLO, &TBOSS INTEGER DUMMY(8) LOGICAL TNEW,TTMOUT,TOVER,TSHLD,TBASLO,TSLFDS,TWARN,THELLO, &TBOSS,TPASS LOGICAL*1 PASSWD(8) C 10 TYPE 11 11 FORMAT(/1X,'SO YOU CLAIM TO BE THE FLEET ADMIRAL. WE''LL SEE...') DO 1 I=1,8 PASSWD(I)="40 1 CONTINUE PASSWD(3)="123 !PASSWRD "TEST" PASSWD(1)="124 PASSWD(4)="124 PASSWD(2)="105 TBOSS=TPASS(PASSWD,0) IF(.NOT.TBOSS)GOTO 30 20 TYPE 21 21 FORMAT(/1X,'IT''S AN HONOR AND A PRIVILEGE TO HAVE YOU ABOARD SIR! &') RETURN 30 TYPE 31 31 FORMAT(/1X,'KLINGON SPY! HOW DARE YOU TRY TO IMPERSONATE THE FLEET & ADMIRAL!') RETURN END C C C ********************************************************** C * * C * SUBROUTINE TO ADJUST SHIP'S BEARING TO AVOID WORKING * C * THROUGH A JUNCTION BETWEEN SHIELDS * C * * C ********************************************************** C SUBROUTINE ADJUST(NS,NS1) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL INTEGER DLN,CMD C IF(NS1.LT.NS .OR. (NS1.EQ.4 .AND. NS.EQ.1))BEARNG=BEARNG-1. IF(NS1.EQ.NS)BEARNG=BEARNG+1. IF(BEARNG.LT.0.)BEARNG=360.+BEARNG IF(BEARNG.GE.360.)BEARNG=BEARNG-360. RETURN END C C C *************************************************** C * * C * SUBROUTINE TO CONVERT REAL DATE TO STARDATE * C * * C *************************************************** C SUBROUTINE STRDAT(STDATE) C DIMENSION STDATE(3) C CALL IDATE(IM,ID,IY) X=IY*100+IM X=X+FLOAT(ID)*0.01 ENCODE(12,11,STDATE)X 11 FORMAT(F8.2,4X) RETURN END C C C ***************************************************** C * * C * FUNCTION TO CALCULATE ANGLE BETWEEN TWO POINTS * C * * C ***************************************************** C FUNCTION ANGLE(I,J,IA,IB) C DEG(ANG)=ANG/0.017453293 C IF(J.NE.IB)GOTO 1 ANGLE=90. IF(IA.LT.I)ANGLE=270. RETURN 1 A=IA B=IB X=I Y=J ANGLE=DEG(ATAN((A-X)/(Y-B))) IF(J.LT.IB)ANGLE=180.+ANGLE IF(ANGLE.LT.0.)ANGLE=360.+ANGLE RETURN END C C C ************************************************ C * * C * FUNCTION TO CALCULATE SIZE OF HIT ON SHIP * C * * C ************************************************ C FUNCTION SIZHIT(KR,KC,KPOW,IA,IB) C DIST=SQRT(FLOAT((KR-IA)**2+(KC-IB)**2)) SIZHIT=INT(FLOAT(KPOW)*(0.8+0.15/DIST)) IF(DIST.GE.2.)SIZHIT=INT(FLOAT(KPOW)/(2.*ALOG(DIST))) RETURN END C C C ************************************************************* C * * C * LOGICAL FUNCTION TO SEE IF VESSEL IS HIT WHEN IT MOVES * C * * C ************************************************************* C LOGICAL FUNCTION TMOVES(DIST,II,JJ) C TMOVES=.TRUE. IF(DIST.LE.6. .AND. RAN(II,JJ).LE.0.6)TMOVES=.FALSE. IF(DIST.GT.6. .AND. RAN(II,JJ).LE.0.2)TMOVES=.FALSE. IF(DIST.LE.2. .AND. RAN(II,JJ).LE.0.95)TMOVES=.FALSE. RETURN END C C C *********************************************** C * * C * LOGICAL FUNCTION FOR CHECKING PASSWORDS * C * * C *********************************************** C LOGICAL FUNCTION TPASS(DUMMY,N) DIMENSION ISB(2),IPRL(6) REAL*8 INPUT,PASSWD LOGICAL*1 DUMMY(8) DATA INPUT,IEFN,IPRL(2)/' ',1,72/ C 10 TYPE 11 11 FORMAT(1X,'ENTER PASSWORD: ',$) CALL GETADR(IPRL(1),INPUT) CALL WTQIO("1020,5,IEFN,,ISB,IPRL) CALL CAPMSK(DUMMY,8) CALL CAPMSK(INPUT,8) DECODE(8,101,DUMMY,ERR=999)PASSWD 101 FORMAT(A8) IF(INPUT.NE.PASSWD)GOTO 1 TPASS=.TRUE. RETURN 1 TPASS=.FALSE. IF(N.EQ.0)RETURN 50 TYPE 51 51 FORMAT(/1X,'IMPOSTERS ARE NASTY PEOPLE!') 999 RETURN END C C C ********************************************************* C * * C * SPECIAL FUNCTION SUBROUTINE TO CLEAR SCREEN etc., * C * (IMLAC TERMINALS ONLY) * C * * C ********************************************************* C SUBROUTINE SPLFNC(ICODE) DIMENSION ISB(2),IPRL(6) DATA IEFN,IPRL(2)/2*1/ C CALL ASSIGN(6,'TI:') CALL GETADR(IPRL(1),ICODE) CALL WTQIO("400,6,IEFN,,ISB,IPRL) CALL CLOSE(6) RETURN END C C ************************************************ C * * C * SUBROUTINE FOR GIVING FINAL ACADEMY EXAM * C * * C ************************************************ C SUBROUTINE EXAM(IRNK,TEXAM,II,JJ) C DIMENSION NQS(20),INQ(3),NL(3),NH(3) BYTE BUFFER(120),ANS(20,2),IANS REAL*8 RESLT LOGICAL TEST,TEXAM C DATA NQS/20*0/,INQ/2,18,20/ DATA NL/1,11,91/,NH/10,60,100/ C TYPE 171 171 FORMAT(///10X,'***** STAR FLEET ACADEMY REVIEW BOARD *****'/ &22X,'FINAL EXAMINATION'/22X,17(1H=)/) IF(IRNK.GT.1)GOTO 180 10 TYPE 11 11 FORMAT(/1X, &'Now that you have completed your courses at the Academy,'/ &1X,'you are required to pass a simple test in order to &graduate.') GOTO 190 180 TYPE 181 181 FORMAT(1X,'As a veteran officer & alumnus of the Academy,'/ &1X,'this examination is provided as a review only. '/ &1X,'RESULTS OF YOUR EXAM ARE NOT RECORDED BY STAR FLEET.') 190 TYPE 191 191 FORMAT(/5X,'THE ANSWERS SHOULD BE GIVEN AS EITHER:'/ &1X,'"T" FOR TRUE, OR "F" FOR FALSE. TO PASS, YOU NEED'/ &1X,'TO GET AT LEAST 70% CORRECT. GOOD LUCK!'/1X,66(1H-)/) C OPEN(UNIT=1,NAME='[200,200]STARFLEET.EXM',TYPE='OLD', &ACCESS='DIRECT',RECORDSIZE=120,READONLY,SHARED,FORM= &'FORMATTED',CARRIAGECONTROL='NONE',ERR=999) K=1 IF(IRNK.EQ.1)GOTO 1 NL(1)=11 NL(2)=61 NH(1)=60 NH(2)=90 INQ(1)=12 1 DO 4 I=1,20 IF(I.GT.INQ(K))K=K+1 2 NQ=RAN(II,JJ)*FLOAT(NH(K))+1. IF(NQ.LT.NL(K) .OR. NQ.GT.NH(K))GOTO 2 DO 3 J=1,20 IF(NQS(J).EQ.NQ)GOTO 2 3 CONTINUE READ(1'NQ,131,ERR=999)BUFFER 131 FORMAT(120A1) CALL UNSCRM(BUFFER,120) IF(BUFFER(4).EQ.' ')GOTO 2 NQS(I)=NQ ANS(I,1)=BUFFER(4) 4 CONTINUE I=0 TEST=.FALSE. 5 I=I+1 80 READ(1'NQS(I),131)BUFFER CALL UNSCRM(BUFFER,120) 20 TYPE 21,I,(BUFFER(J),J=5,60) 21 FORMAT(1X,I2,'.',56A1,$) IF(BUFFER(61).NE.' ')TYPE 151,(BUFFER(J),J=61,115) 151 FORMAT(1X/5X,55A1,$) TYPE 141 141 FORMAT(1H+,': ',$) READ(5,31,ERR=40)ANS(I,2) 31 FORMAT(A1) CALL CAPMSK(ANS(I,2),1) IF(ANS(I,2).NE.'T' .AND. ANS(I,2).NE.'F')GOTO 40 IF(TEST .OR. I.EQ.20)GOTO 50 GOTO 5 40 TYPE 41 41 FORMAT(1X,'*** INVALID ANSWER - USE "T" OR "F" ***') GOTO 20 50 TYPE 51 51 FORMAT(/1X,'DO YOU WISH TO CHANGE ANY OF YOUR ANSWERS? ',$) READ(5,31,ERR=40)IANS CALL CAPMSK(IANS,1) IF(IANS.EQ.'N')GOTO 100 IF(IANS.NE.'Y')GOTO 50 60 TYPE 61 61 FORMAT(1X,'QUESTION NUMBER? ',$) READ(5,71,ERR=60)I 71 FORMAT(I2) TEST=.TRUE. IF(I.GE.1 .AND. I.LE.20)GOTO 80 90 TYPE 91 91 FORMAT(1X,'*** INVALID ENTRY ***') GOTO 60 100 TYPE 101 101 FORMAT(///1X,'NOW FOR THE RESULTS...') CALL PAUSE(4) TYPE 211 211 FORMAT(////1X,T61,'YOUR'/ &15X,'QUESTION',T61,'ANS.',T66,'RESULT'/ &15X,8(1H-),T61,4(1H-),T66,6(1H-)) NCORR=0 DO 6 I=1,20 READ(1'NQS(I),131)BUFFER CALL UNSCRM(BUFFER,120) RESLT='WRONG' IF(ANS(I,1).NE.ANS(I,2))GOTO 110 RESLT='CORRECT' NCORR=NCORR+1 110 TYPE 21,I,(BUFFER(J),J=5,60) IF(BUFFER(61).NE.' ')TYPE 151,(BUFFER(J),J=61,115) TYPE 161,ANS(I,2),RESLT 161 FORMAT(1H+,': ',A1,'-',A7) 6 CONTINUE CALL CLOSE(1) RESLT='*FAILED*' TEXAM=.FALSE. IF(NCORR.GE.14)RESLT='*PASSED*' IF(IRNK.EQ.1 .AND. NCORR.GE.14)TEXAM=.TRUE. TYPE 121,NCORR,NCORR*5,RESLT 121 FORMAT(/1X,'You got',I3,'/20 correct, or',I4,'%.'/1X, &'As a result, you have ',A8,' this examination.') IF(IRNK.GT.1 .OR. TEXAM)RETURN TYPE 201 201 FORMAT(/1X, &'Although you failed the exam now, you can take it again'/1X, &'anytime you sign-on, if you choose the "E" option. When'/1X, &'you eventually pass the exam, you will graduate.'/1X, &'NOTE: REMEMBER THAT THE ANSWERS MUST BE ALWAYS AS STATED,'/ &1X,' NOT JUST SOMETIMES. REVIEW THE INSTRUCTIONS AND'/ &1X,' LESSONS AGAIN - MOST ANSWERS CAN BE FOUND THERE.') RETURN 999 TEXAM=.TRUE. CALL CLOSE(1) RETURN END C C C ************************************************ C * * C * SUBROUTINE TO (UN)SCRAMBLE MESSAGE LINES * C * * C ************************************************ C SUBROUTINE UNSCRM(IMAGE,NC) C BYTE IMAGE(NC) C DO 1 I=1,NC IMAGE(I)=.NOT.IMAGE(I) 1 CONTINUE RETURN END