C C C ********************************************* C * * C * SUBROUTINE FOR CHECKING SERVICE RECORD * C * * C ********************************************* C SUBROUTINE SRVRCD(TEXAM,II,JJ,NGAM) C COMMON/PERS /NAME1(16),NPL,NG,AVGTOT,PSWRD,IRNK,NSHP,IUIC(4) COMMON/TESTS2/TNEW,TTMOUT,TOVER,TSHLD,TBASLO,TSLFDS,TWARN,THELLO, &TBOSS DIMENSION GDATE(3),DAT(3),ISB(2),IPRL(6),IU(4),IBUFF(16) C REAL*8 NAME(2),PNAME,PSWRD,PSWRD8,VAR8,SENDER LOGICAL TNEW,TTMOUT,TOVER,TSHLD,TBASLO,TSLFDS,TWARN,THELLO,TBOSS LOGICAL TPASS,TEST,TLSSN,TEST1,TSFPO,TCOPY,TEXAM,TVIEW LOGICAL*1 PSWRD1(8),PRANK(13),NAME1,DUM1(8),DUM2(8),NSHIP(16), & DUMMY(8),ANS,IMAGE(71),ARRAY1(8),BUFFER(65),ANS2(2), & ID(3),SRANK(13),ORANK(13),ONAME1(16),SNAME(16) C EQUIVALENCE (NAME1(1),DUM1(1)),(NAME1(9),DUM2(1)), & (PSWRD1(1),ARRAY1(1)),(PSWRD,VAR8),(IMAGE(1),BUFFER(1)) C DATA INPUT,IEFN,IPRL(2)/' ',1,72/,IUIC/4*0/ C CALL STRDAT(GDATE) 1000 CALL RUNMCR('[200,200]STARFLEET.NAM',22,'U') OPEN(UNIT=1,NAME='[200,200]STARFLEET.NAM',TYPE='UNKNOWN', &FORM='UNFORMATTED',SHARED,ERR=999) C 10 TYPE 11 11 FORMAT(1X,'What is your surname? ',$) READ(5,21,ERR=10)NAME 21 FORMAT(2A8) CALL CAPMSK(NAME,16) CALL A8TOA1(NAME(1),DUM1) CALL A8TOA1(NAME(2),DUM2) CALL CROP(NAME1,16) NPL=0 IRNK=0 NSHP=0 NG=0 NOP=0 TLSSN=.FALSE. TSFPO=.FALSE. TEST1=.FALSE. CALL GETTSK(IBUFF) DO 25 I=1,2 J=I*8 IUIC(2*I-1)=ISHFT(IBUFF(J).AND."177400,-8) IUIC(2*I)=IBUFF(J).AND."377 25 CONTINUE 30 READ(1,END=6,ERR=6)PNAME,PSWRD,IS,IR,NGAM,AVRTNG,IU NPL=NPL+1 CALL CAPMSK(PNAME,8) IF(PNAME.NE.NAME(1))GOTO 30 IF(NOP.NE.0 .AND. NPL.LE.NOP+1)GOTO 30 IRNK=IR NSHP=IS NG=IABS(NGAM) AVGTOT=AVRTNG IF(NPL.NE.1)GOTO 40 CALL SIR IF(.NOT.TBOSS)GOTO 999 GOTO 1 40 TYPE 41 41 FORMAT(1X,'The name is on file, but you must prove your identity') CALL A8TOA1(PSWRD,PSWRD1) INCLUDE 'VEN.' IF(TPASS(PSWRD1,0))GOTO 1 NOP=NPL GOTO 30 1 CALL CLOSE(1) NOP=0 IF(IRNK.GE.0)GOTO 12 CALL PRISON(TEST1,IX) !CHECK PRISONER STATUS IF(IX.EQ.0)RETURN IF(IX.EQ.34)GOTO 34 IF(IX.EQ.13)GOTO 13 12 CALL SETRNK(IRNK,PRANK,1) NOFF=NPL DO 67 I=1,16 IF(I.LE.13)ORANK(I)=PRANK(I) ONAME1(I)=NAME1(I) 67 CONTINUE TVIEW=.FALSE. 50 TYPE 51,PRANK,NAME1 51 FORMAT(/1X,'WELCOME ',13A1,1X,16A1,'!') IF(IRNK.GE.6 .AND. NSHP.GT.0)TYPE 571 571 FORMAT(1X,'Your ship has been refurbished and is ready for action, &'/1X,'if you decide to use it.') 34 CALL RUNMCR('[200,200]SFCMD.MSG',15,'U') OPEN(UNIT=1,NAME='[200,200]SFCMD.MSG',TYPE='OLD',SHARED, &READONLY) TSFPO=.FALSE. GOTO 310 64 CALL RUNMCR('[200,200]SFPO.MSG',14,'U') OPEN(UNIT=1,NAME='[200,200]SFPO.MSG',TYPE='OLD',SHARED, &READONLY) TSFPO=.TRUE. 310 READ(1,311,END=63,ERR=63)NUM 311 FORMAT(I3) IF(NUM.EQ.NPL)GOTO 62 GOTO 310 63 IF(TSFPO)GOTO 65 CALL CLOSE(1) GOTO 64 62 CALL CLOSE(1) TSFPO=.FALSE. CALL RUNMCR('[200,200]SFCMD.MSG',15,'U') OPEN(UNIT=1,NAME='[200,200]SFCMD.MSG',TYPE='UNKNOWN',SHARED) TYPE 641 641 FORMAT(1X,'PLEASE STANDBY - there is some mail for you') GOTO 37 38 TSFPO=.TRUE. CALL RUNMCR('[200,200]SFPO.MSG',14,'U') OPEN(UNIT=1,NAME='[200,200]SFPO.MSG',TYPE='UNKNOWN',SHARED) 37 OPEN(UNIT=2,TYPE='SCRATCH') N=0 TEST=.FALSE. TCOPY=.FALSE. 420 READ(1,421,END=18,ERR=18)IMAGE 421 FORMAT(71A1) IF(TCOPY)GOTO 460 DECODE(12,431,IMAGE,ERR=460)NUM,PNAME 431 FORMAT(I3,1X,A8) CALL CAPMSK(PNAME,8) IF(NUM.NE.NPL .OR. PNAME.NE.NAME(1))GOTO 460 TEST=.TRUE. IF(.NOT.TSFPO)GOTO 320 DECODE(39,651,IMAGE,ERR=460)NUM,PNAME,IDS,SENDER,SRANK 651 FORMAT(I3,1X,A8,1X,I3,1X,A8,1X,13A1) CALL CROP(SRANK,13) CALL CROP(SENDER,8) ENCODE(3,281,ID)IDS 281 FORMAT(I3) DO 47 I=1,3 IF(ID(I).EQ.' ' .OR. ID(I).EQ."0)ID(I)='0' 47 CONTINUE 320 READ(1,321,END=18,ERR=18)NUM,BUFFER 321 FORMAT(I3,1X,65A1) IF(BUFFER(1).EQ.'/')GOTO 22 IF(NUM.NE.NPL)GOTO 740 N=N+1 IF(N.NE.1)GOTO 44 IF(.NOT.TSFPO)TYPE 451 451 FORMAT(/1X,'We have a sealed message for you from Star Fleet &Headquarters.') IF(TSFPO)TYPE 661,SRANK,SENDER,ID 661 FORMAT(/1X,'We have a message for you from ',13A1,1X,A8,1X, &'(SF',3A1,').') 670 TYPE 671 671 FORMAT(1X,'MESSAGE FOLLOWS:'/) 44 CALL CROP(BUFFER,65) TYPE 331,BUFFER 331 FORMAT(1X,65A1) GOTO 320 740 WRITE(2,321)NUM,BUFFER 22 TEST=.FALSE. IF(TSFPO)TCOPY=.TRUE. GOTO 420 460 WRITE(2,421)IMAGE 46 IF(TEST)GOTO 320 GOTO 420 18 IF(N.EQ.0)GOTO 19 REWIND 1 REWIND 2 470 READ(2,421,END=19)IMAGE WRITE(1,421)IMAGE GOTO 470 19 CALL CLOSE(2) 65 CALL CLOSE(1) IF(N.NE.0)GOTO 490 IF(.NOT.TSFPO)GOTO 38 TEST=.TRUE. 54 CALL SFNEWS(TEST) 35 IF(IRNK.LT.0)STOP 5000 TYPE 5001 5001 FORMAT(/1X,'SIGN-ON OPTION [hit for list of options]? ',$) READ(5,5011,ERR=5000)ANS2 5011 FORMAT(2A1) CALL CAPMSK(ANS2,2) TSFPO=.FALSE. TEST=.FALSE. CALL SETRNK(IRNK,PRANK,1) IF(ANS2(1).EQ.'M')GOTO 39 IF(ANS2(1).EQ.'D')GOTO 2 IF(ANS2(1).EQ.'R')GOTO 32 IF(ANS2(1).EQ.'H')GOTO 27 IF(ANS2(1).EQ.'F')GOTO 36 IF(ANS2(1).EQ.'S')GOTO 8 IF(ANS2(1).EQ.'E')GOTO 29 IF(ANS2(1).EQ.'C')GOTO 5 IF(ANS2(1).EQ.'P')GOTO 42 IF(ANS2(1).EQ.'L')GOTO 28 IF(ANS2(1).EQ.'N')GOTO 54 IF(ANS2(1).EQ.'V')GOTO 9 TYPE 5021 5021 FORMAT(/1X,'AVAILABLE OPTIONS:'/ &1X,'OPTION',T20,'PURPOSE'/1X,6(1H-),T20,7(1H-)/1X, &'C - to continue on into mission (exit options)'/1X, &'D - to list decorations and criteria for earning'/1X, &'E - to sit for the Academy Final Exam '/1X, &'P - to list the Status of Star Fleet Personnel'/1X, &'H - to review your Promotion History'/1X, &'F - to list the Heavy Cruiser Starships in Star Fleet'/1X, &'L1 - to review Lesson 1 from Star Fleet Academy'/1X, &'L2 - to review Lesson 2 from Star Fleet Academy'/1X, &'MH - to send a message to Star Fleet Headquarters (SFHQ)'/1X, &'MO - to leave a message for other Star Fleet Officers'/1X, &'N - to obtain latest issue of STAR FLEET NEWS'/1X, &'S - to obtain your current standing towards promotion'/1X, &'R - to review your Service Record'/1X, &'V - to view another officer''s Service Record') GOTO 5000 9 IF(.NOT.TVIEW)GOTO 200 210 TYPE 211 211 FORMAT(1X,'Do you wish to reset to your own records? ',$) READ(5,121,ERR=210)ANS CALL CAPMSK(ANS,1) IF(ANS.EQ.'N')GOTO 200 IF(ANS.NE.'Y')GOTO 210 68 NOFF=NPL DO 66 I=1,16 IF(I.LE.13)ORANK(I)=PRANK(I) ONAME1(I)=NAME1(I) 66 CONTINUE TVIEW=.FALSE. GOTO 5000 200 TYPE 201 201 FORMAT(/1X,'Enter ID# & name of officer whose records you wish & to view') CALL CHKOID(NOFF,ORANK,ONAME1,TVIEW) IF(.NOT.TVIEW)GOTO 68 TYPE 221,ORANK,ONAME1 221 FORMAT(1X, &'You will now view the records for ',13A1,1X,16A1/1X, &'if you callup the following options:'/5X, &'R - SERVICE MISSIONS RECORD; H - PROMOTIONS & AWARDS'/1X, &'To reset to your own, callup "V" again.') GOTO 5000 39 IF(ANS2(2).EQ.'H')GOTO 550 IF(ANS2(2).NE.'O')GOTO 900 680 TYPE 681 681 FORMAT(1X,'STAR FLEET POST OFFICE'/1X, &'Enter ID# & name of officer you wish to leave message for:') CALL CHKOID(IDS,SRANK,SNAME,TEST) IF(.NOT.TEST)GOTO 35 DECODE(16,691,SNAME)SENDER,DUMMY 691 FORMAT(A8,8A1) TSFPO=.TRUE. GOTO 43 550 TYPE 551 551 FORMAT(/1X'Do you want to send a message to Star Fleet Headquarter &s [YES]? ',$) GOTO 560 490 TYPE 491 491 FORMAT(/1X,'Do you wish to reply? ',$) 560 READ(5,121,ERR=490)ANS CALL CAPMSK(ANS,1) IF(ANS.EQ.'N')GOTO 49 43 OPEN(UNIT=1,TYPE='SCRATCH') IF(TSFPO)GOTO 58 WRITE(1,511,ERR=520)PRANK,NAME1,IUIC(1),IUIC(2),GDATE 511 FORMAT(1X,'** MESSAGE FROM ',13A1,1X,16A1,2X,'[',O3,',',O3,']', &1X,'(',2A4,A1,'):') GOTO 520 58 CALL A8TOA1(SENDER,DUMMY) DO 48 I=1,8 IF(DUMMY(I).EQ."0)DUMMY(I)=' ' 48 CONTINUE DECODE(8,701,DUMMY)SENDER WRITE(1,721,ERR=520)IDS,SENDER,NPL,NAME(1),PRANK 721 FORMAT(I3,1X,A8,1X,I3,1X,A8,1X,13A1) WRITE(1,761)IDS,GDATE 761 FORMAT(I3,1X,'STARDATE: ',3A4) 520 TYPE 521 521 FORMAT(1X,'To exit message, enter "/" as first character in line'/ &1X,'ENTER MESSAGE:',T54,'END OF LINE^') 530 READ(5,421,ERR=520)IMAGE IF(TSFPO)GOTO 730 IF(IMAGE(1).EQ.'/')GOTO 56 WRITE(1,421)IMAGE GOTO 530 730 WRITE(1,321)IDS,BUFFER IF(BUFFER(1).NE.'/')GOTO 530 56 REWIND 1 IF(TSFPO)GOTO 59 CALL RUNMCR('[200,200]FLEET.MSG',15,'U') OPEN(UNIT=2,NAME='[200,200]FLEET.MSG',TYPE='OLD',ACCESS='APPEND', &SHARED,ERR=57) GOTO 770 59 CALL RUNMCR('[200,200]SFPO.MSG',14,'U') OPEN(UNIT=2,NAME='[200,200]SFPO.MSG',TYPE='OLD',ACCESS='APPEND', &SHARED,ERR=57) 770 READ(1,421,END=57,ERR=57)IMAGE WRITE(2,421)IMAGE GOTO 770 57 CALL CLOSE(2) 23 CALL CLOSE(1) 49 IF(ANS2(1).EQ.'M')GOTO 35 IF(.NOT.TSFPO .OR. N.NE.0)GOTO 38 GOTO 35 32 CALL RECRDS(NOFF,NPL,ORANK,ONAME1,GDATE) !SERVICE RECORD GOTO 5000 27 CALL PROHIS(NOFF,NPL) GOTO 5000 2 CALL LSTDEC GOTO 5000 8 IF(TBOSS .OR. IRNK.GE.10)GOTO 5000 160 TYPE 161 161 FORMAT(/1X,'This is how you presently stand towards promotion:'// +X,T30,'CURRENT',T40,'REQUIRED',T50,'DIFF.'/1X,T30,7(1H-),T40, +8(1H-),T50,5(1H-)) IRANK=IRNK NREQ=5 IF(IRANK.EQ.0)IRANK=1 IF(IRNK.LE.1)NREQ=2 TYPE 171,IRANK,NG,NREQ,NG-NREQ,AVRTNG,AVRTNG-75. 171 FORMAT(1X,'No. of Missions at Rank',I3,T32,I3,T42,I3,T50,I3/1X, +'Overall Efficiency Rating',T30,F7.2,T42,'75.0',T49,F6.2) IF(IRNK.EQ.1)GOTO 5000 IF(NG.LT.4)GOTO 5000 XAV=375.-AVRTNG*4. TYPE 241,XAV 241 FORMAT(/1X,'TO BE PROMOTED, YOU WOULD REQUIRE A',F7.2,'% RATING'/ &1X,'IN YOUR NEXT MISSION.') GOTO 5000 42 CALL PRSLST !LIST STATUS OF STAR FLEET PERSONNEL GOTO 5000 36 CALL FLEET GOTO 5000 150 TYPE 151 151 FORMAT(/1X,'NAME ON RECORD, WRONG PASSWORD - Are you a new recruit &? ',$) READ(5,121,ERR=150)ANS 121 FORMAT(A1) CALL CAPMSK(ANS,1) IF(ANS.EQ.'Y')GOTO 13 STOP 6 CALL CLOSE(1) IF(NOP.NE.0)GOTO 150 5 IF(IRNK.GT.0 .AND. PSWRD.EQ.' ')GOTO 130 IF(TLSSN .OR. IRNK.NE.1 .OR. NG.NE.1)GOTO 7 OPEN(UNIT=1,NAME='[200,200]OUTMIS.DAT',TYPE='OLD', &FORM='UNFORMATTED',READONLY,SHARED) 270 READ(1,END=33)NP,SNUM,DAT,N IF(NP.NE.NPL)GOTO 270 CALL CLOSE(1) GOTO 7 33 CALL CLOSE(1) GOTO 26 7 IF(IRNK.NE.0)RETURN 180 TYPE 181,NAME1 181 FORMAT(1X,'The name "',16A1,'" is not registered with Star Fleet & Command.'/1X,'Are you a new recruit? ',$) READ(5,121,ERR=180)ANS CALL CAPMSK(ANS,1) IF(ANS.EQ.'Y')GOTO 13 IF(ANS.NE.'N')GOTO 180 190 TYPE 191 191 FORMAT(1X,'Do you wish to reenter the name? ',$) READ(5,121,ERR=190)ANS CALL CAPMSK(ANS,1) IF(ANS.EQ.'Y')GOTO 1000 IF(ANS.NE.'N')GOTO 190 STOP C 28 CALL LESSON(ANS2(2),IER) !ACADEMY LESSONS IF(IER.EQ.1)GOTO 900 GOTO 5000 13 CALL SFA(TLSSN) !STAR FLEET ACADEMY 15 IF(IRNK.GT.1 .OR. NG.GT.0)GOTO 5000 16 IF(.NOT.TEST1 .AND. IRNK.EQ.0)GOTO 130 NG=0 IRNK=1 NSHP=0 AVGTOT=0. IX=0 CALL UPDTPF(IX) RETURN 29 IF(IRNK.EQ.1 .AND. NGAM.LT.0)GOTO 52 IF(IRNK.GT.1)GOTO 52 TYPE 611 611 FORMAT(/1X,'Sorry, but only qualified Senior Cadets can take the &exam.') GOTO 5000 52 CALL EXAM(IRNK,TEXAM,II,JJ) IF(TEXAM)RETURN GOTO 5000 130 TYPE 131 131 FORMAT(/1X,'Enter a password (8 letters max) which will in the &future verify your ID'/1X,'PASSWORD: ',$) PSWRD=' ' READ(5,701,ERR=130)PSWRD TYPE 251 251 FORMAT(/1X, +'If you ever wish to change your password, contact SFHQ') IF(IRNK.NE.0)RETURN CALL A8TOA1(PSWRD,PSWRD1) INCLUDE 'VEN1.' C CALL RUNMCR('[200,200]STARFLEET.NAM',22,'U') CALL FDBSET(1,'APPEND') CALL ASSIGN(1,'[200,200]STARFLEET.NAM') NPL=NPL+1 NG=0 IRNK=1 NSHP=0 AVGTOT=0. WRITE(1)NAME(1),PSWRD,NSHP,IRNK,NG,AVGTOT,IUIC 4 CALL CLOSE(1) ENCODE(3,281,ID)NPL DO 24 I=1,3 IF(ID(I).EQ.' ' .OR. ID(I).EQ."0)ID(I)='0' 24 CONTINUE TYPE 91,ID 91 FORMAT(1X,'YOUR STAR FLEET ID# IS: SF',3A1) OPEN(UNIT=1,NAME='[200,200]FLEET.MSG',TYPE='OLD',ACCESS='APPEND', &SHARED,ERR=26) WRITE(1,591)GDATE,NAME1,ID 591 FORMAT(1X,'** MESSAGE FROM STAR FLEET ACADEMY (',2A4,A1,'):'/ &1X,'WE HAVE JUST ADMITTED A NEW CADET TO THE ACADEMY.'/ &1X,'NAME: ',16A1,10X,'ID#: SF',3A1) CALL CLOSE(1) 26 RETURN 999 CALL CLOSE(1) STOP 900 TYPE 901 901 FORMAT(1X,'*** INVALID OPTION ***') GOTO 5000 END