C C C ************************************************** C * * C * SUBROUTINE TO PROMOTE PLAYER IF QUALIFIED * C * * C ************************************************** C SUBROUTINE PROMOT(RATING,RANK,TEXAM,II,JJ) C COMMON/MISC2/NPROB,L5,L8,GASP,ITASK,SDATE,AFILE(4),CFILE(4),DTLSTH COMMON/PERS/NAME1(16),NPL,NG,AVGTOT,PSWRD,IRNK,NSHP,IUIC(4) COMMON/RATNG/NBASD,NRESC,NFRES,NROMD,NCAPAL,NPRTKN COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD COMMON/RENEG/TRENEG,TSLAP,TSHOOT,TBAN DIMENSION IU(4),DAT(3) C REAL*8 PNAME(2),WORDS8(2),PSWRD,VAR8 LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, & TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD LOGICAL TNEWP,TRENEG,TSLAP,TSHOOT,TBAN,TEST,TEST1,TEXAM LOGICAL*1 NAME1,ANS,PRANK(13),PSWRD1(8),ENDS,ARRAY1(8),IMAGE(60) C EQUIVALENCE (PSWRD1(1),ARRAY1(1)),(PSWRD,VAR8) C DATA TNEWP,TEST1/2*.FALSE./ C IF(TEXAM)GOTO 5 IF(NBASD.EQ.0)GOTO 6 CALL CRTMTL IF(TRENEG)GOTO 8 6 IF(RATING.LT.0.)RETURN IF(IRNK.LE.2)GOTO 1 IF(IRNK.GT.10 .OR. RANK.LT.FLOAT(IRNK))RETURN CALL AWARD(AFILE(3),RATING) !GIVE AWARD? 1 NG=ISIGN(NG+1,NG) NM=IABS(NG) XNG=NM IF(NG.GT.5)XNG=5. AVRTNG=(AVGTOT*(XNG-1.)+RATING)/XNG AVGTOT=AVRTNG ENDS='s' IF(NG.EQ.1)ENDS="0 TYPE 61,NM,ENDS,IRNK,AVRTNG 61 FORMAT(/1X, &'You have completed',I3,' mission',A1,' of Rank',I3,' with an'/1X, &'overall efficiency rating of',F7.2,' %.') WRITE(3,61)NM,ENDS,IRNK,AVRTNG IF(TLOST .OR. TRENEG .OR. IRNK.GT.10)GOTO 2 IF(IRNK.EQ.1 .AND. NM.GE.2)GOTO 22 IF(IRNK.GT.1 .AND. NM.GE.5 .AND. AVRTNG.GE.75.)GOTO 5 GOTO 2 22 CALL EXAM(IRNK,TEST,II,JJ) IF(TEXAM)OPEN(UNIT=3,TYPE='SCRATCH',ACCESS='APPEND',FORM= &'FORMATTED',SHARED) IF(TEST)GOTO 5 IF(TEXAM)STOP NG=ISIGN(NG,-1) GOTO 2 5 IF(IRNK.EQ.10)GOTO 23 IRNK=IRNK+1 8 CALL RUNMCR('[200,200]STARFLEET.PRO',22,'U') OPEN(UNIT=1,NAME='[200,200]STARFLEET.PRO',ACCESS='APPEND', &TYPE='OLD',FORM='UNFORMATTED',SHARED,ERR=99) WRITE(1,ERR=99)NPL,AFILE(3),IRNK,NG,AVRTNG 99 CALL CLOSE(1) IF(IRNK.LT.0)GOTO 2 NG=0 AVRTNG=0. AVGTOT=AVRTNG CALL SETRNK(IRNK,PRANK,1) GOTO 10 23 OPEN(UNIT=1,NAME='[200,200]STARFLEET.PRO',TYPE='OLD', &FORM='UNFORMATTED',READONLY,SHARED,ERR=2) 220 READ(1,END=24)NP,SQNUM,IR,ING,AVR IF(NP.NE.NPL .OR. IR.GT.0 .OR. ING.NE.-7)GOTO 220 CALL CLOSE(1) GOTO 2 24 CALL CLOSE(1) 10 TYPE 11,NAME1 11 FORMAT(//1X,'****** CONGRATULATIONS ',16A1,'! ******') WRITE(3,11)NAME1 IF(IRNK.EQ.2)GOTO 27 IF(IRNK.EQ.10 .AND. NG.GE.5)GOTO 180 TYPE 71 71 FORMAT(1X, &'BY ORDER OF STAR FLEET COMMAND, DUE TO YOUR DEMONSTRATED'/1X, &'BRAVERY, EXPERIENCE AND ABILITIES, YOU ARE HEREBY') WRITE(3,71) GOTO 90 27 CALL STRDAT(DAT) OPEN(UNIT=1,NAME='[200,200]FLEET.MSG',TYPE='OLD',ACCESS='APPEND', &SHARED,ERR=80) WRITE(1,231,ERR=25)DAT,NAME1 231 FORMAT(1X,'** MESSAGE FROM STAR FLEET ACADEMY (',2A4,A1,'):'/ &1X,'WE ARE PLEASED TO ANNOUNCE THAT CADET ',16A1/ &1X,'HAS JUST GRADUATED FROM THE ACADEMY. STAR FLEET ACADEMY OUT.') 25 CALL CLOSE(1) 80 TYPE 81 81 FORMAT(1X,'You have completed your training and have now graduated &'/1X,'from Star Fleet Academy. You can now be given command of'/ &1X,'a Federation Starship. Just remember that in the real world'/ &1X,'Klingons move, there are Romulans and other dangers.'//1X, &'BY THE AUTHORITY GRANTED STAR FLEET ACADEMY UNDER ARTICLE 52,'/1X, &'PARAGRAPH 4, OF THE ARTICLES OF FEDERATION, YOU ARE HEREBY') WRITE(3,81) 90 TYPE 91,PRANK,IRNK 91 FORMAT(1X,'PROMOTED TO THE RANK OF *** ',13A1,' ***.'//1X, &'You will now be qualified for missions of Rank',I3,'.') WRITE(3,91)PRANK,IRNK IF(IRNK.LE.2)GOTO 2 CALL STRDAT(DAT) OPEN(UNIT=1,NAME='[200,200]FLEET.MSG',TYPE='OLD',ACCESS='APPEND', &SHARED,ERR=2) WRITE(1,241,ERR=26)DAT,NAME1,PRANK,AFILE(3) 241 FORMAT(1X,'** MESSAGE FROM FLEET OPERATIONS, SFC (',2A4,A1,'):'/ &1X,16A1,' HAS JUST BEEN PROMOTED TO ',13A1/ &1X,'AFTER MISSION #',A3,'. FLEET OPERATIONS OUT.') 26 CALL CLOSE(1) IF(IRNK.EQ.6)GOTO 100 GOTO 2 180 TYPE 181 181 FORMAT(/1X, &'YOU HAVE SUCCESSFULLY COMPLETED ALL RANK GRADES AVAILABLE'/ &1X,'IN STAR FLEET. IT IS NOT POSSIBLE TO BE PROMOTED ANY'/ &1X,'HIGHER, BUT IN RECOGNITION OF THIS AUSPICIOUS OCCASION'/ &1X,'YOUR ARE HEREBY GRANTED:'/ &1X,' THE HONORARY RANK OF **ADMIRAL EMERITUS**') WRITE(3,181) OPEN(UNIT=1,NAME='[200,200]STARFLEET.PRO',TYPE='OLD',ACCESS= &'APPEND',FORM='UNFORMATTED',SHARED) WRITE(1)NPL,AFILE(3),-IRNK,-7,0. CALL CLOSE(1) GOTO 2 100 TYPE 101 101 FORMAT(/1X,'In recognition of your service to Star Fleet, you are' &/1X, 'eligible to be assigned permanently to a Cruiser of'/ &1X, 'your choice. This will be your default ship. You may'/ &1X, 'still, if you wish, choose another ship for any'/ &1X, 'particular mission. Your permanent ship can be changed' &/1X, 'by sending a request to Star Fleet Headquarters.') WRITE(3,101) 110 TYPE 111 111 FORMAT(/1X,'Would you like to select a permanent ship? ',$) 120 READ(5,121,ERR=110)ANS 121 FORMAT(A1) CALL CAPMSK(ANS,1) IF(ANS.EQ.'N')GOTO 2 IF(ANS.NE.'Y')GOTO 110 GOTO 14 130 TYPE 131,PRANK,NAME1 131 FORMAT(/1X,'Sorry ',13A1,1X,16A1', but that ship has already been &assigned.'/1X,'Do you wish to choose another? ',$) GOTO 120 14 OPEN(UNIT=1,NAME='[200,200]SHIPS.NAM',TYPE='OLD',READONLY,SHARED) 140 READ(1,141,ERR=9,END=9)IMAGE 141 FORMAT(60A1) CALL CROP(IMAGE,60) TYPE 151,IMAGE 151 FORMAT(1X,60A1) GOTO 140 9 CALL CLOSE(1) OPEN(UNIT=1,NAME='[200,200]STARFLEET.NAM',TYPE='OLD',FORM= &'UNFORMATTED',READONLY,SHARED,ERR=160) N=0 TYPE 211 211 FORMAT(1X,'The following ships have already been assigned:'/1X, &'12A',$) 200 READ(1,END=16,ERR=16)WORDS8,ISN,IR,ING,AVR,IU N=N+1 IF(ISN.GT.0)TYPE 191,ISN 191 FORMAT(1H+,',',I2,$) GOTO 200 16 CALL CLOSE(1) TYPE 221 221 FORMAT(1H+,1X) 160 TYPE 161 161 FORMAT(/1X,'Enter number of your Starship: ',$) 170 READ(5,171,ERR=160)NSHP 171 FORMAT(I3) IF(NSHP.LT.0 .OR. NSHP.GT.30)GOTO 160 TEST1=.TRUE. GOTO 13 C 2 TEST1=.FALSE. 13 CALL RUNMCR('[200,200]STARFLEET.NAM',22,'U') OPEN(UNIT=1,NAME='[200,200]STARFLEET.NAM',TYPE='UNKNOWN',FORM= &'UNFORMATTED',SHARED,ERR=7) OPEN(UNIT=2,TYPE='SCRATCH',FORM='UNFORMATTED') DECODE(8,21,NAME1)PNAME 21 FORMAT(2A8) N=0 TEST=.FALSE. 30 READ(1,END=3,ERR=4)WORDS8,ISN,IR,ING,AVR,IU N=N+1 IF(NSHP.NE.0 .AND. NSHP.EQ.ISN)TEST=.TRUE. IF(TEST .AND. TEST1)GOTO 4 IF(N.NE.NPL)GOTO 40 IR=IRNK IF(NSHP.NE.0)ISN=NSHP ING=NG AVR=AVRTNG DO 12 I=1,4 IU(I)=IUIC(I) 12 CONTINUE 40 WRITE(2)WORDS8,ISN,IR,ING,AVR,IU GOTO 30 3 IF(NPL.GT.N)TNEWP=.TRUE. IF(TNEWP)GOTO 4 REWIND 1 REWIND 2 50 READ(2,END=4,ERR=4)WORDS8,ISN,IR,ING,AVR,IU WRITE(1,ERR=4)WORDS8,ISN,IR,ING,AVR,IU GOTO 50 4 CALL CLOSE(1) CALL CLOSE(2) IF(TEST .AND. TEST1)GOTO 130 IF(.NOT.TNEWP)GOTO 7 CALL RUNMCR('[200,200]STARFLEET.NAM',22,'U') OPEN(UNIT=1,NAME='[200,200]STARFLEET.NAM',ACCESS='APPEND', &TYPE='OLD',FORM='UNFORMATTED',SHARED,ERR=15) IRNK=1 ISN=0 CALL A8TOA1(PSWRD,PSWRD1) INCLUDE 'VEN.' WRITE(1,ERR=15)PNAME(1),PSWRD,ISN,IRNK,NG,AVRTNG,IUIC 15 CALL CLOSE(1) 7 IF(.NOT.TRENEG)RETURN CALL CLOSE(3) STOP END C C C ******************************************* C * * C * SUBROUTINE TO CONVENE COURTMARTIAL * C * * C ******************************************* C SUBROUTINE CRTMTL C COMMON/MISC2/NPROB,L5,L8,GASP,ITASK,SDATE,AFILE(4),CFILE(4),DTLSTH COMMON/RATNG/NBASD,NRESC,NFRES,NROMD,NCAPAL,NPRTKN COMMON/WRDS/COND,KL,RM,GRN,RED,DCKD,DEST(2),DISAB(2),SHIP(16) COMMON/PERS/NAME1(16),NPL,NG,AVGTOT,PSWRD,IRNK,NSHP,IUIC(4) COMMON/RENEG/TRENEG,TSLAP,TSHOOT,TBAN DIMENSION FILE(3),DAT(3) C REAL*8 CRT(2),COND,KL,RM,GRN,RED,DCKD,DEST,DISAB,PSWRD LOGICAL TRENEG,TSLAP,TSHOOT,TBAN LOGICAL*1 NAME1,ANS,PRANK(13),CRT1(16),DUM1(8),DUM2(8),EE, & IMAGE(65),SHIP C EQUIVALENCE (CRT1(1),DUM1(1)),(CRT1(9),DUM2(1)) C DATA CRT/2*' '/ C CRT(1)='BOARD OF' CRT(2)=' INQUIRY' IF(.NOT.TRENEG)GOTO 1 CRT(1)='COURT MA' CRT(2)='RTIAL' 1 CALL A8TOA1(CRT(1),DUM1) CALL A8TOA1(CRT(2),DUM2) CALL CROP(CRT1,16) CALL SETRNK(IRNK,PRANK,1) EE='s' IF(NBASD.EQ.1)EE="0 TYPE 11,CRT1,PRANK,NAME1,NBASD,EE,SHIP 11 FORMAT(////1X,'*** STAR FLEET COMMAND HAS CONVENED A ',16A1/5X, &'TO REVIEW THE CASE OF ',13A1,1X,16A1,'.'//1X, &'CHARGE:'/1X, &'You are hereby charged with turning renegade, and being a'/1X, &'traitor to the United Federation of Planets, by the act of'/1X, &'premeditated, cold-blooded and wanton destruction of'/1X, &I1,' starbase',A1,', while in command of the United Starship'/1X, &'Cruiser ',16A1,'.') WRITE(3,11)CRT1,PRANK,NAME1,NBASD,EE,SHIP 20 TYPE 21 21 FORMAT(/1X,'How do you plead? ',$) READ(5,31,ERR=20)ANS 31 FORMAT(A1) CALL CAPMSK(ANS,1) IF(ANS.NE.'G' .AND. ANS.NE.'N' .AND. ANS.NE.'I')GOTO 20 PLEA='NOT ' IF(ANS.EQ.'G')PLEA="0 TYPE 41,PLEA 41 FORMAT(1X,'You have entered a plea of ',A4,'GUILTY.') WRITE(3,41)PLEA IF(ANS.EQ.'G')GOTO 60 TYPE 51 51 FORMAT(1X,'PLEASE STANDBY -- Star Fleet Command is reviewing &the evidence') WRITE(3,51) C PLEA='NOT ' IF(TRENEG)PLEA="0 OPEN(UNIT=1,NAME='[200,200]FLEET.MSG',TYPE='OLD',ACCESS='APPEND', &SHARED,ERR=3) CALL STRDAT(DAT) WRITE(1,141,ERR=7)DAT,CRT1,PRANK,NAME1,NBASD,EE,AFILE(3),PLEA 141 FORMAT(1X,'*** MESSAGE FROM FLEET OPERATIONS, SFC (',2A4,A1,'):'/ &1X,'A ',16A1,' HAS CONVENED TO JUDGE'/ &1X,13A1,1X,16A1,', WHO HAS DESTROYED',I3,' STARBASE',A1/ &1X,'DURING MISSION #',A3,'. THE VERDICT IS ',A3,'GUILTY.') 7 CALL CLOSE(1) C 3 CALL PAUSE(2) 60 TYPE 61,CRT1,PLEA 61 FORMAT(/1X,'THIS STAR FLEET ',16A1,' HAS REACHED A DECISION:'/1X, &'You have been found ',A3,'GUILTY of the charges brought &against you.') WRITE(3,61)CRT1,PLEA IF(TRENEG)GOTO 4 TYPE 71 71 FORMAT(1X, &' However, you are hereby officially reprimanded for negligence' &/1X,'in the course of your mission, for having accidentally'/1X, &'destroyed a Federation Starbase. Do not let it happen again.'/ &'This hearing is closed.') WRITE(3,71) RETURN 4 IRNK=ISIGN(IRNK+(NBASD*5)-1,-1) II=0 JJ=0 DO 6 I=1,INT(SECNDS(0.)/100.) RX=RAN(II,JJ) 6 CONTINUE NG=INT(RAN(II,JJ)*11.)+1 AVGTOT=0. CALL PAUSE(2) TYPE 81,IABS(IRNK) 81 FORMAT(1X, &'You are hereby reduced to the Rank of Ensign,'/1X, &'and sentenced to serve',I3,' years of:') WRITE(3,81)IABS(IRNK) OPEN(UNIT=1,NAME='[200,200]STARFLEET.DAT',TYPE='OLD',READONLY, &SHARED,ERR=130) REWIND 1 NS=30+NG READ(1,91)NMAX,N 91 FORMAT(I2,1X,I2) 100 READ(1,101,ERR=130)NUM 101 FORMAT(I2) IF(NUM-NS)100,110,130 110 READ(1,111,END=5,ERR=130)NUM,IMAGE 111 FORMAT(I2,1X,65A1) IF(NUM.NE.NS)GOTO 5 CALL CROP(IMAGE,65) TYPE 121,IMAGE 121 FORMAT(1X,65A1) WRITE(3,121)IMAGE GOTO 110 130 TYPE 131 131 FORMAT(1X,'HARD LABOR AT PENAL COLONY 13 ON THE PLANET HADES') WRITE(3,131) NG=0 5 CALL CLOSE(1) RETURN END C C C ****************************************************** C * * C * SUBROUTINE TO AWARD COMMENDATIONS & DECORATIONS * C * * C ****************************************************** C SUBROUTINE AWARD(SQNUM,RATING) C COMMON/PERS /NAME1(16),NPL,NG,AVGTOT,PSWRD,IRNK,NSHP,IUIC(4) COMMON/RATNG/NBASD,NRESC,NFRES,NROMD,NCAPAL,NPRTKN C DIMENSION DAT(3) C REAL*8 PSWRD,FEDMEM(5) LOGICAL*1 NAME1,PRANK(13),BUFFER(45),IMAGE(72) C DATA FEDMEM/'SOL','VULCAN','VEGAN','ALPHAN','TELLAR'/ C AWDRTG=110-((IRNK+1)/2)*5 IF(RATING.LT.AWDRTG)RETURN LVLDEC=0 DO 1 I=1,5 X=I IF(RATING.LT.AWDRTG+X*5.)LVLDEC=I IF(LVLDEC.NE.0)GOTO 2 1 CONTINUE LVLDEC=6 2 OPEN(UNIT=1,NAME='[200,200]STARFLEET.PRO',TYPE='OLD',FORM= &'UNFORMATTED',READONLY,SHARED,ERR=999) NN=1 10 READ(1,END=3,ERR=3)N,SEQN,IR,NMS,RTNG IF(N.NE.NPL .OR. NMS.GE.0)GOTO 10 IF(IABS(NMS).EQ.LVLDEC)NN=NN+1 GOTO 10 3 CALL CLOSE(1) OPEN(UNIT=1,NAME='[200,200]STARFLEET.PRO',TYPE='OLD',ACCESS= &'APPEND',FORM='UNFORMATTED',SHARED,ERR=999) WRITE(1)NPL,SQNUM,-IRNK,-LVLDEC,RATING CALL CLOSE(1) CALL SETRNK(IRNK,PRANK,1) TYPE 21,PRANK,NAME1 21 FORMAT(/1X,'** SPECIAL COMMUNICATION FROM STAR FLEET COMMAND:'/ &5X,13A1,1X,16A1,', in recognition of your outstanding'/ &5X,'abilities of command demonstrated in your latest mission,'/ &5X,'it is our pleasure to inform you, that you have hereby'/ &5X,'been awarded:'/) WRITE(3,21)PRANK,NAME1 OPEN(UNIT=1,NAME='[200,200]STARFLEET.DAT',TYPE='OLD',READONLY, &SHARED) 30 READ(1,31,END=999,ERR=999)NUM 31 FORMAT(I2) IF(NUM.LT.40+LVLDEC)GOTO 30 IF(LVLDEC.EQ.6)GOTO 4 IFAC=4 IF(LVLDEC.EQ.1 .OR. LVLDEC.EQ.3)IFAC=3 IF(NN.GT.IFAC)NN=NN-IFAC N=MOD(NN,3) IF(N.EQ.0)N=3 GOTO 14 4 N=1 IF(NN.GT.3)NN=NN-3 14 DO 5 I=1,N READ(1,41,END=999,ERR=999)BUFFER 41 FORMAT(3X,45A1) 5 CONTINUE CALL CROP(BUFFER,45) GOTO(110,6,7,8,9,12),LVLDEC 6 IF(MOD(NN,4).NE.0)GOTO 110 ENCODE(72,51,IMAGE)BUFFER 51 FORMAT('Oak Leaf Cluster to your ',45A1) GOTO 13 7 IF(MOD(NN,3).NE.1)GOTO 110 NFM=NN/3+1 CALL CROP(FEDMEM(NFM),8) ENCODE(72,61,IMAGE)FEDMEM(NFM),BUFFER 61 FORMAT(A8,1X,45A1) GOTO 13 8 IF(MOD(NN,4).NE.0)GOTO 110 ENCODE(72,71,IMAGE)BUFFER 71 FORMAT('A Shield to your ',45A1) GOTO 13 9 IF(MOD(NN,4).NE.0)GOTO 110 ENCODE(72,81,IMAGE)BUFFER 81 FORMAT('Swords to your ',45A1) GOTO 13 12 GOTO(110,90,100),MOD(NN,4) 90 ENCODE(72,91,IMAGE)BUFFER 91 FORMAT('Meteors to your ',45A1) GOTO 13 100 ENCODE(72,101,IMAGE)BUFFER 101 FORMAT('Diamonds to your ',45A1,' & Meteors') GOTO 13 110 ENCODE(72,111,IMAGE)BUFFER 111 FORMAT(45A1) 13 CALL CROP(IMAGE,72) TYPE 121,IMAGE 121 FORMAT(7X,72A1//5X,'WELL DONE!') WRITE(3,121)IMAGE 999 CALL CLOSE(1) IF(LVLDEC.LT.3)RETURN CALL STRDAT(DAT) OPEN(UNIT=1,NAME='[200,200]FLEET.MSG',TYPE='OLD',ACCESS='APPEND', &SHARED,ERR=998) WRITE(1,131,ERR=998)DAT,PRANK,NAME1,LVLDEC,SQNUM,NRESC,NCAPAL, &NPRTKN 131 FORMAT(1X,'** MESSAGE FROM FLEET OPERATIONS, SFC (',2A4,A1,'):'/ &1X,13A1,1X,16A1,' HAS JUST RECEIVED A LEVEL',I2,' AWARD'/ &1X,'FOR MISSION #',A3,'. NBR=',I2,' NSD=',I2,' NPD=',I3/ &1X,'FLEET OPERATIONS OUT.') CALL CLOSE(1) 998 RETURN END