C C STAR FLEET COMMAND UTILITY PROGRAM C WRITTEN BY TREVOR SORENSEN C DIMENSION N(10),T(40,10),ND(40,10),LST(40,10),RTG(40,10), &SNUM(40,10),DATEM(3,40,10),SHIP(16,40,10),NROMD(40,10), &DTE(3),NLOST(10),ISB(2),IPRL(6),DAT(3),NSHIP(16),DT(3),NPL(40,10) DIMENSION IU(4),IUIC(4) C REAL*8 PASSWD,INPUT,NAME8,NAME,PASWD,PSWD,VAR8 LOGICAL TSTAT,TAP,TPROH,TMESS,TEST LOGICAL*1 ANS,DUMMY(8),SHIP,NSHIP,SHP(16),PASWD1(8),ARRAY1(8), &IMAGE(71),BUFFER(71),LINE(120),IANS C EQUIVALENCE (SHP(1),NSHIP(1)),(DT(1),DAT(1)) &,(ARRAY1(1),PASWD1(1)),(VAR8,PASWD),(IMAGE(1),BUFFER(1)) C DATA INPUT,PASSWD,DUMMY/2*' ',8*' '/ DATA IEFN,IPRL(2)/1,72/ DATA SHP,DT/16*' ',3*' '/ DATA DATEM,SHIP,SNUM/1200*' ',6400*' ',400*' '/ C 200 TYPE 201 201 FORMAT(1X,'ENTER PASSWORD: ',$) CALL GETADR(IPRL(1),INPUT) CALL WTQIO("1020,5,IEFN,,ISB,IPRL) DUMMY(1)="123 !PASSWORD IS "SFHQ" DUMMY(2)="106 DUMMY(3)="110 DUMMY(4)="121 DECODE(8,901,DUMMY)PASSWD 901 FORMAT(A8) IF(INPUT.EQ.PASSWD)GOTO 130 TYPE 171 171 FORMAT(/1X,'**** IMPOSTERS ARE NASTY PEOPLE! ****') STOP 130 TYPE 131 131 FORMAT(//1X,'SECTION? ',$) READ(5,21,ERR=130)ANS TSTAT=.FALSE. TPROH=.FALSE. TMESS=.FALSE. IF(ANS.EQ.'M')CALL CHKMIS IF(ANS.EQ.'M')GOTO 130 IF(ANS.EQ.'S')TSTAT=.TRUE. IF(TSTAT)GOTO 13 IF(ANS.EQ.'H')TPROH=.TRUE. IF(TPROH)GOTO 2 IF(ANS.EQ.'M')TMESS=.TRUE. IF(TMESS)GOTO 10 IF(ANS.EQ.'E')GOTO 640 IF(ANS.NE.'P')GOTO 130 OPEN(UNIT=1,NAME='[200,200]STARFLEET.NAM',TYPE='UNKNOWN',FORM= &'UNFORMATTED') GOTO 1 13 OPEN(UNIT=1,NAME='[200,200]STAT.DAT',TYPE='UNKNOWN',FORM= &'UNFORMATTED') GOTO 1 2 OPEN(UNIT=1,NAME='[200,200]STARFLEET.PRO',TYPE='UNKNOWN',FORM= &'UNFORMATTED') 1 REWIND 1 10 TYPE 11 11 FORMAT(//1X,'COMMAND? ',$) 20 READ(5,21,ERR=10)ANS 21 FORMAT(A1) TAP=.FALSE. IF(ANS.EQ.'S')STOP IF(ANS.NE.'R')GOTO 65 750 TYPE 751 751 FORMAT(/1X,'DATA FILE RESET - IS COMMAND CONFIRMED? ',$) READ(5,21,ERR=750)IANS IF(IANS.EQ.'N')GOTO 10 IF(IANS.NE.'Y')GOTO 750 65 IF(TMESS)GOTO 64 IF(TPROH .AND. ANS.EQ.'L')GOTO 8 IF(.NOT.TSTAT)GOTO 8 IF(ANS.EQ.'L')GOTO 6 IF(ANS.NE.'R' .AND. ANS.NE.'M')GOTO 10 8 IF(TSTAT)GOTO 32 IF(ANS.EQ.'A')GOTO 14 IF(ANS.EQ.'M')GOTO 15 IF(ANS.EQ.'L')GOTO 25 IF(ANS.NE.'R')GOTO 10 IF(TPROH)WRITE(1)0,'000 ',0,0,0. IF(TPROH)GOTO 30 NAME8=' ' PSWD=' ' WRITE(1)NAME8,PSWD,0,0,0,0.,0,0,0,0 GOTO 30 32 IF(ANS.EQ.'R')GOTO 500 OPEN(UNIT=2,TYPE='SCRATCH',FORM='UNFORMATTED', &ERR=130) 470 TYPE 471 471 FORMAT(1X/1X,'MISSION NUMBER? ',$) READ(5,421,ERR=470)SMN 421 FORMAT(A4) 430 READ(1,END=33)SEQN,DAT,NSHIP,IR,TM,NDS,IDS,NRD,RATING,NP IF(SEQN.NE.SMN)GOTO 450 TYPE 111,0,SEQN,DAT,NSHIP,NDS,NRD,TM,IDS,RATING,NP 440 TYPE 441 441 FORMAT(/1X,'DELETE? ',$) READ(5,21,ERR=440)ANS IF(ANS.EQ.'Y')GOTO 430 IF(ANS.NE.'N')GOTO 440 450 WRITE(2)SEQN,DAT,NSHIP,IR,TM,NDS,IDS,NRD,RATING,NP GOTO 430 33 REWIND 1 REWIND 2 460 READ(2,END=17)SEQN,DAT,NSHIP,IR,TM,NDS,IDS,NRD,RATING,NP WRITE(1)SEQN,DAT,NSHIP,IR,TM,NDS,IDS,NRD,RATING,NP GOTO 460 500 TYPE 501 501 FORMAT(/1X,'DATA FILE RESET - IS COMMAND CONFIRMED? ',$) READ(5,21,ERR=500)ANS IF(ANS.EQ.'N')GOTO 10 IF(ANS.NE.'Y')GOTO 500 WRITE(1)'000 ',DT,SHP,0,0.,0,0,0,0.,0 30 TYPE 31 31 FORMAT(/1X,'RESET COMPLETED') GOTO 5 6 IF(.NOT.TSTAT)GOTO 25 DO 7 I=1,10 N(I)=0 NLOST(I)=0 7 CONTINUE 40 READ(1,END=50)SEQN,DAT,NSHIP,IR,TM,NDS,IDS,NRD,RATING,NP IF(IR.GT.0 .AND. IR.LE.10)GOTO 22 TYPE 81,SEQN 81 FORMAT(1X,'*** WARNING: IR out of range. SEQN = ',A4) GOTO 40 22 IF(IDS.EQ.1)NLOST(IR)=NLOST(IR)+1 N(IR)=N(IR)+1 IF(N(IR).LE.40)GOTO 44 IF(N(IR).GT.41)GOTO 40 TYPE 991,IR 991 FORMAT(1X,'*** WARNING: MORE THAN 40 ENTRIES FOR RANK',I3) GOTO 40 44 J=N(IR) T(J,IR)=TM ND(J,IR)=NDS LST(J,IR)=IDS NROMD(J,IR)=NRD SNUM(J,IR)=SEQN NPL(J,IR)=NP DO 12 I=1,16 IF(I.LE.3)DATEM(I,J,IR)=DAT(I) IF(NSHIP(I).EQ."0)NSHIP(I)=' ' SHIP(I,J,IR)=NSHIP(I) 12 CONTINUE RTG(J,IR)=RATING GOTO 40 50 TYPE 51 51 FORMAT(/5X,'RANK',10X,'NO. OF ENTRIES',5X,'S.S. DEST.'/1X,47(1H-)) DO 99 IR=1,10 TYPE 61,IR,N(IR),NLOST(IR) 61 FORMAT(5X,I3,17X,I3,13X,I3) 99 CONTINUE 70 TYPE 71 71 FORMAT(/1X,'DO YOU WANT A COMPLETE LISTING OF ENTRIES? ',$) READ(5,21,ERR=70)ANS IF(ANS.EQ.'N')GOTO 1 IF(ANS.NE.'Y')GOTO 70 CALL DATE(DTE) 90 TYPE 91,DTE 91 FORMAT(//////1X,'STATISTICS FOR S-T',40X,3A4// +1X,T5,'SEQ.N',T14,'DATE',T27,'SHIP',T38,'N.DST R.DST', &T50,'DAYS SS-LOST RTNG NP'/ &1X,T5,5(1H=),T14,'====',T27,'====',T38, &5(1H=),1X,5(1H=),1X,'====',1X,7(1H=),2X,4(1H=),2X,'==') DO 3 IR=1,10 TYPE 101,IR 101 FORMAT(/1X,'RANK',I3) NDTOT=0 IF(N(IR).EQ.0)N(IR)=1 IF(N(IR).GT.40)N(IR)=40 DO 4 J=1,N(IR) TYPE 111,J,SNUM(J,IR),(DATEM(K,J,IR),K=1,3),(SHIP(L,J,IR),L=1,16), &ND(J,IR),NROMD(J,IR),T(J,IR),LST(J,IR),RTG(J,IR),NPL(J,IR) 111 FORMAT(1X,I2,T6,A4,T11,2A4,A1,T21,16A1,T39,I3,T45,I2,T49,F5.1, &T58,I2,T61,F6.1,1X,I3) NDTOT=NDTOT+ND(J,IR) 4 CONTINUE TYPE 121,NDTOT,NLOST(IR) 121 FORMAT(1X,T38,5(1H-),T55,7(1H-)/5X,'TOTAL',T38,I4,T57,I3) 3 CONTINUE GOTO 1 14 CALL CLOSE(1) TAP=.TRUE. CALL FDBSET(1,'APPEND') IF(.NOT.TPROH)CALL ASSIGN(1,'STARFLEET.NAM') IF(TPROH)CALL ASSIGN(1,'STARFLEET.PRO') IF(TPROH)GOTO 260 GOTO 140 15 REWIND 1 OPEN(UNIT=2,TYPE='SCRATCH',FORM='UNFORMATTED') 25 NP=0 NPS=0 IF(ANS.NE.'M')GOTO 42 320 TYPE 321 321 FORMAT(1X/1X,'NP? ',$) READ(5,331,ERR=320)NPS 331 FORMAT(I3) 42 IF(TPROH)GOTO 340 CALL DATE(DTE) 220 TYPE 221,DTE 221 FORMAT(//1X,'STAR FLEET PERSONNEL LIST',20X,3A4//1X, &'NP',T8,'NAME',T17,'PASSWORD',T27,'SHIP',T33,'RANK',T40,'NM', &T46,'AVG',T55,'UIC',T64,'LOGIN'/1X,71(1H-)) 230 READ(1,END=16)NAME8,PASWD,NSHP,IRNK,NG,AVG,IUIC NP=NP+1 C ENCODE(8,701,PASWD1)PASWD INCLUDE 'VEN.' IF(ANS.EQ.'M' .AND. NPS.EQ.0)GOTO 140 IF(ANS.EQ.'M' .AND. NP.NE.NPS)GOTO 410 TYPE 241,NP,NAME8,PASWD,NSHP,IRNK,NG,AVG,IUIC 241 FORMAT(1X,I3,T7,A8,T17,A8,T27,I3,T34,I3,T39,I3,T44,F6.2,T50, &2(2X,'[',O3,',',O3,']')) IF(ANS.EQ.'L')GOTO 230 9 IF(.NOT.TPROH)GOTO 140 340 READ(1,END=16)NPLA,SEQN,IRNK,NG,AVG IF(ANS.EQ.'L')GOTO 290 IF(NPLA.NE.NPS)GOTO 350 290 TYPE 291,NPLA,SEQN,IRNK,NG,AVG 291 FORMAT(1X/1X,I3,2X,A4,2X,'IR=',I3,2X,'NG=',I3,2X,F7.2,'%') IF(ANS.EQ.'L')GOTO 340 TYPE 441 READ(5,21,ERR=260)ANS IF(ANS.EQ.'Y')GOTO 340 GOTO 260 140 TYPE 141,'NAME' 141 FORMAT(1X/1X,A8,': ',$) READ(5,151,ERR=140)NC,NAME 151 FORMAT(Q,A8) IF(NC.NE.0)NAME8=NAME 160 TYPE 141,'PASSWORD' READ(5,151,ERR=160)NC,PSWD IF(NC.NE.0)PASWD=PSWD GOTO 620 260 TYPE 141,'NPL' READ(5,181,ERR=260)NC,NP IF(NC.NE.0)NPLA=NP 270 TYPE 141,'SEQN' READ(5,281,ERR=270)NC,SEQ 281 FORMAT(Q,A4) IF(NC.NE.0)SEQN=SEQ IF(TPROH)GOTO 170 620 TYPE 141,'SHIP ID' READ(5,181,ERR=620)NC,IS IF(NC.NE.0)NSHP=IS 170 TYPE 141,'IRANK' READ(5,181,ERR=170)NC,IR 181 FORMAT(Q,I3) IF(NC.NE.0)IRNK=IR 190 TYPE 141,'N.GAMES' READ(5,181,ERR=170)NC,NGAM IF(NC.NE.0)NG=NGAM 210 TYPE 141,'AVG.' READ(5,251,ERR=210)NC,AVRG 251 FORMAT(Q,F10.0) IF(NC.NE.0)AVG=AVRG IF(TPROH)GOTO 19 630 TYPE 141,'UIC''S' READ(5,631,ERR=630)NC,IU 631 FORMAT(Q,4O3) IF(NC.EQ.0)GOTO 410 DO 23 I=1,4 IUIC(I)=IU(I) 23 CONTINUE C 410 ENCODE(8,701,PASWD1)PASWD INCLUDE 'VEN1.' 19 IF(TAP)GOTO 300 IF(TPROH)GOTO 350 400 WRITE(2)NAME8,PASWD,NSHP,IRNK,NG,AVG,IUIC GOTO 230 350 WRITE(2)NPLA,SEQN,IRNK,NG,AVG GOTO 340 16 IF(ANS.EQ.'L')GOTO 18 REWIND 1 REWIND 2 310 IF(.NOT.TPROH)READ(2,END=17)NAME8,PASWD,NSHP,IRNK,NG,AVG, &IUIC IF(TPROH)READ(2,END=17)NPLA,SEQN,IRNK,NG,AVG 300 IF(.NOT.TPROH)WRITE(1)NAME8,PASWD,NSHP,IRNK,NG,AVG,IUIC IF(TPROH)WRITE(1)NPLA,SEQN,IRNK,NG,AVG IF(.NOT.TAP)GOTO 310 17 IF(.NOT.TAP)CALL CLOSE(2) 18 CALL CLOSE(1) GOTO 130 5 CALL CLOSE(1) STOP 64 IF(ANS.EQ.'L' .OR. ANS.EQ.'M')GOTO 53 IF(ANS.NE.'A')GOTO 130 CALL FDBSET(2,'APPEND') CALL ASSIGN(2,'SFHQ.MSG') TEST=.TRUE. TYPE 591 591 FORMAT(1X,'ENTER NEW MESSAGE:') GOTO 610 53 OPEN(UNIT=1,NAME='[200,200]SFHQ.MSG',TYPE='UNKNOWN') IF(ANS.EQ.'L')GOTO 520 510 TYPE 321 READ(5,331,ERR=510)NPS OPEN(UNIT=2,NAME='[200,200]SCRATCH.TMP',TYPE='SCRATCH') 520 READ(1,521,END=48,ERR=48)IMAGE 521 FORMAT(71A1) C DO 888 ILM=1,71 IMAGE(ILM)=.NOT.IMAGE(ILM) 888 CONTINUE C TEST=.FALSE. IF(ANS.EQ.'L')GOTO 550 DECODE(2,531,IMAGE,ERR=520)NUM 531 FORMAT(I2) IF(NUM.NE.NPS)GOTO 46 550 TYPE 551,IMAGE 551 FORMAT(1X,71A1) IF(ANS.EQ.'L')GOTO 520 600 TYPE 601 601 FORMAT(1X,'*',$) TEST=.FALSE. 610 READ(5,611,ERR=600)NC,BUFFER 611 FORMAT(Q,71A1) IF(.NOT.TEST)GOTO 55 IF(ANS.EQ.'M' .AND. NC.EQ.1 .AND. BUFFER(1).EQ.'/')GOTO 520 IF(ANS.EQ.'A' .AND. NC.EQ.1 .AND. BUFFER(1).EQ.'/')GOTO 56 GOTO 49 55 IF(NC.EQ.1 .AND. BUFFER(1).EQ.'D')GOTO 520 IF(NC.EQ.0)GOTO 46 IF(NC.EQ.1 .AND. BUFFER(1).EQ.'I')TEST=.TRUE. IF(TEST)GOTO 46 49 DO 45 I=1,71 IF(I.GT.NC)BUFFER(I)=' ' IMAGE(I)=BUFFER(I) 45 CONTINUE 46 DO 47 I=1,71 IMAGE(I)=.NOT.IMAGE(I) 47 CONTINUE 560 WRITE(2,521)IMAGE IF(TEST)GOTO 610 GOTO 520 48 IF(ANS.EQ.'L')GOTO 52 REWIND 1 REWIND 2 540 READ(2,521,END=52)IMAGE WRITE(1,521)IMAGE GOTO 540 52 CALL CLOSE(1) 56 IF(ANS.NE.'L')CALL CLOSE(2) GOTO 130 C C STAR FLEET ACADEMY FINAL EXAMINATION SECTION C 640 TYPE 641 641 FORMAT(/1X,'S.F. ACADEMY EXAMINATION REVIEW BOARD') 650 TYPE 11 READ(5,21,ERR=650)ANS TEST=.FALSE. IF(ANS.EQ.'S')GOTO 130 IF(ANS.EQ.'R' .OR. ANS.EQ.'E')GOTO 35 IF(ANS.NE.'T')GOTO 650 TEST=.TRUE. 660 TYPE 661 661 FORMAT(1X,'OLD OR NEW FILE TO BE TRANSLATED? ',$) READ(5,21,ERR=660)ANS IF(ANS.NE.'O' .AND. ANS.NE.'N')GOTO 660 IF(ANS.EQ.'N')GOTO 26 OPEN(UNIT=1,NAME='[200,200]STREK.EXM',TYPE='OLD',ACCESS= &'DIRECT',RECORDSIZE=120,READONLY,SHARED,FORM='FORMATTED',ERR=34, &CARRIAGECONTROL='NONE') 35 OPEN(UNIT=2,NAME='[200,200]EXAM.TMP',TYPE='UNKNOWN',ACCESS='DIRECT', &RECORDSIZE=120,FORM='FORMATTED',CARRIAGECONTROL='NONE',ERR=34) IF(ANS.EQ.'E')GOTO 690 GOTO 27 26 OPEN(UNIT=1,NAME='[200,200]EXAM.TMP',TYPE='OLD',ACCESS='DIRECT', &DISPOSE='DELETE',RECORDSIZE=120,FORM='FORMATTED',ERR=34, &CARRIAGECONTROL='NONE') OPEN(UNIT=2,NAME='[200,200]STREK.EXM',TYPE='UNKNOWN',ACCESS= &'DIRECT',RECORDSIZE=120,FORM='FORMATTED',CARRIAGECONTROL='NONE' &,ERR=34) 27 DO 29 I=1,100 IF(ANS.NE.'R')READ(1'I,671)LINE 671 FORMAT(120A1) DO 28 J=1,120 IF(ANS.EQ.'R')LINE(J)=' ' IF(ANS.NE.'R')LINE(J)=.NOT.LINE(J) 28 CONTINUE WRITE(2'I,671)LINE 29 CONTINUE GOTO 34 690 TYPE 691 691 FORMAT(1X,'QUESTION NUMBER? ',$) READ(5,331,ERR=690)NQ IF(NQ.LT.0 .OR. NQ.GT.100)GOTO 690 IF(NQ.EQ.0)GOTO 34 READ(2'NQ,671)LINE TYPE 731,LINE 731 FORMAT(1X,60A1/6X,60A1) 710 TYPE 711,NQ 711 FORMAT(1X,T60,':'/1X,I3,$) READ(5,721,ERR=710)NC,(LINE(I),I=4,60) 721 FORMAT(Q,57A1) IF(NC.EQ.0)GOTO 690 TYPE 681 681 FORMAT(6X,$) READ(5,741,ERR=710)(LINE(I),I=61,120) 741 FORMAT(60A1) ENCODE(3,331,LINE)NQ WRITE(2'NQ,671)LINE GOTO 690 34 IF(TEST)CALL CLOSE(1) CALL CLOSE(2) GOTO 640 END C C SUBROUTINE CHKMIS C DIMENSION DAT(3),STD(2),DUM(2) LOGICAL TOUT,TEST LOGICAL*1 ANS,ANS1 C TYPE 131 131 FORMAT(/1X,'MISSIONS STATUS SECTION') 140 TYPE 141 141 FORMAT(1X,'COMMAND? ',$) READ(5,71,ERR=140)ANS 71 FORMAT(A1) IF(ANS.EQ.'E')RETURN 150 TYPE 151 151 FORMAT(1X,'OUTMIS OR FINMIS? ',$) READ(5,71,ERR=150)ANS1 IF(ANS1.NE.'O' .AND. ANS1.NE.'F')GOTO 140 TOUT=.FALSE. IF(ANS1.EQ.'O')TOUT=.TRUE. IF(ANS.EQ.'L')GOTO 5 IF(ANS.EQ.'M')GOTO 1 IF(ANS.NE.'R')GOTO 140 TYPE 191 191 FORMAT(1X,'RESET ORDERED - CONFIRMED? ',$) READ(5,71,ERR=140)ANS IF(ANS.NE.'Y')GOTO 140 IF(TOUT)OPEN(UNIT=1,NAME='[200,200]OUTMIS.DAT',TYPE='OLD',FORM= &'UNFORMATTED',ERR=140) IF(.NOT.TOUT)OPEN(UNIT=1,NAME='[200,200]FINMIS.DAT',TYPE='OLD', &FORM='UNFORMATTED',ERR=140) AF=' ' WRITE(1)0,AF,AF,AF,AF,0 CALL CLOSE(1) GOTO 140 5 IF(.NOT.TOUT)OPEN(UNIT=1,NAME='[200,200]FINMIS.DAT',TYPE='OLD', &FORM='UNFORMATTED',READONLY,SHARED) IF(TOUT)OPEN(UNIT=1,NAME='[200,200]OUTMIS.DAT',TYPE='OLD',FORM= &'UNFORMATTED',READONLY,SHARED,ERR=140) TEST=.FALSE. IF(TOUT)GOTO 100 160 TYPE 161 161 FORMAT(1X,'ENTER STARTING DATE: ',$) READ(5,171,ERR=160)DUM 171 FORMAT(2A4) IF(DUM(1).EQ.'ALL')TEST=.TRUE. ENCODE(8,21,STD)DUM 21 FORMAT(1X,A4,A3) 100 READ(1,END=4)NPL,AF,DAT,N IF(TOUT .OR. TEST)GOTO 30 IF(DAT(1).NE.STD(1) .OR. DAT(2).NE.STD(2))GOTO 100 TEST=.TRUE. 30 TYPE 31,NPL,AF,DAT,N 31 FORMAT(1X,I3,1X,A4,1X,3A4,1X,I1) GOTO 100 1 IF(TOUT)OPEN(UNIT=1,NAME='[200,200]OUTMIS.DAT',TYPE='OLD',FORM= &'UNFORMATTED',ERR=140) IF(.NOT.TOUT)OPEN(UNIT=1,NAME='[200,200]FINMIS.DAT',TYPE='OLD', &FORM='UNFORMATTED',ERR=140) OPEN(UNIT=2,TYPE='SCRATCH',FORM='UNFORMATTED') TYPE 81 81 FORMAT(1X,'NP? ',$) READ(5,91)NP 91 FORMAT(I3) 50 READ(1,END=3)NPL,AF,DAT,N IF(NP.NE.NPL)GOTO 120 TYPE 31,NPL,AF,DAT,N 110 TYPE 111 111 FORMAT(1X,'DELETE? ',$) READ(5,71)ANS IF(ANS.EQ.'Y')GOTO 50 IF(ANS.NE.'N')GOTO 110 120 WRITE(2)NPL,AF,DAT,N GOTO 50 3 REWIND 1 REWIND 2 130 READ(2,END=2)NPL,AF,DAT,N WRITE(1)NPL,AF,DAT,N GOTO 130 2 CALL CLOSE(2) 4 CALL CLOSE(1) GOTO 140 END