C C C ****************************************************** C * * C * SUBROUTINE TO OUTPUT PROMOTION HISTORY & AWARDS * C * * C ****************************************************** C SUBROUTINE PROHIS(NOFF,NPL) C REAL*8 FEDMEM(5) INTEGER AWARDS(10) LOGICAL*1 DECBUF(3,45),PRANK(13),BUFFER(45),IMAGE(72) LOGICAL TEST,TEST1 C DATA DECBUF/135*' '/ DATA FEDMEM/'SOL','VULCAN','VEGAN','ALPHAN','TELLAR'/ C IF(NOFF.GT.2 .OR. NPL.LE.2)GOTO 24 TYPE 211 211 FORMAT(1X,'*** SORRY, DATA REQUESTED ARE CLASSIFIED') RETURN 24 TEST=.FALSE. TEST1=.FALSE. DO 95 I=1,10 AWARDS(I)=0 95 CONTINUE TYPE 11 11 FORMAT(/1X,'PROMOTION HISTORY:'/1X,17(1H-)) CALL RUNMCR('[200,200]STARFLEET.PRO',22,'U') OPEN(UNIT=1,NAME='[200,200]STARFLEET.PRO',TYPE='OLD',FORM= &'UNFORMATTED',READONLY,SHARED,ERR=9) 20 READ(1,END=3,ERR=3)N,SEQN,IR,NM,RTNG IF(N.NE.NOFF)GOTO 20 TEST=.TRUE. CALL SETRNK(IABS(IR),PRANK,1) IF(IR.LT.0)GOTO 1 TYPE 31,PRANK,SEQN,NM,RTNG 31 FORMAT(1X,'Promoted to ',13A1,' after Mission ',A3,':',I4, &' missions, Avg=',F7.2,'%') GOTO 20 1 IF(NM)2,50,40 40 TYPE 41,SEQN,IABS(IR) 41 FORMAT(1X,'Demoted to ENSIGN after Mission ',A3,' for being a &renegade.'/1X,'Served',I3,' year sentence.') GOTO 20 50 TYPE 51,PRANK,RTNG 51 FORMAT(1X,'Demoted to ',13A1,', Stardate',F8.2,' by order of & Star Fleet Command') GOTO 20 2 NM=IABS(NM) !FIND AWARD IF(NM.GT.10)GOTO 20 !VERIFY AWARDS(NM)=AWARDS(NM)+1 !INCREMENT TALLY TEST1=.TRUE. GOTO 20 3 IF(.NOT.TEST)TYPE 61 61 FORMAT(1X,'No promotions on record') CALL CLOSE(1) TYPE 221 221 FORMAT(1X,'*** HIT TO CONTINUE ***') READ(5,231,ERR=70)I 231 FORMAT(I2) 70 TYPE 71 71 FORMAT(/1X,'COMMENDATIONS and AWARDS:'/1X,24(1H-)) IF(TEST1)GOTO 4 80 TYPE 81 81 FORMAT(1X,'No commendations or awards on record.') RETURN 4 OPEN(UNIT=1,NAME='[200,200]STARFLEET.DAT',TYPE='OLD',READONLY, &SHARED,ERR=80) READ(1,91,ERR=80)N,N 91 FORMAT(I2,1X,I2) 100 READ(1,101)NUM 101 FORMAT(I2) IF(NUM.LT.40)GOTO 100 NFM=0 DO 5 I=1,10 IF(AWARDS(I).EQ.0)GOTO 5 110 READ(1,101)NUM IF(NUM.NE.40+I)GOTO 110 IFAC=1 IG=AWARDS(I) IF(I.EQ.1 .OR. I.EQ.3 .OR. I.EQ.6)IFAC=3 IF(I.EQ.2 .OR. I.EQ.4 .OR. I.EQ.5)IFAC=4 IF(IFAC.NE.1)IG=(AWARDS(I)-1)/IFAC +1 DO 6 J=1,IG TEST=.FALSE. NI=IFAC NN=MOD(AWARDS(I),IFAC) IF(NN.EQ.0 .OR. J.LT.IG)TEST=.TRUE. IF(I.EQ.6 .AND. NN.EQ.2)TEST=.TRUE. IF(J.EQ.IG)NI=NN IF(NI.EQ.0)NI=IFAC DO 19 N=1,NI IF(J.GT.1)GOTO 7 IF(N.GT.3 .OR. (N.GT.1 .AND. I.GE.6)) GOTO 23 DO 8 I1=1,45 DECBUF(N,I1)=' ' 8 CONTINUE READ(1,121,ERR=6)NC,NUM,(DECBUF(N,I1),I1=1,45) 121 FORMAT(Q,I2,1X,45A1) IF(NUM.NE.40+I)GOTO 5 7 DO 9 J1=1,45 BUFFER(J1)=' ' BUFFER(J1)=DECBUF(N,J1) 9 CONTINUE 23 CALL CROP(BUFFER,45) CALL BLANKS(IMAGE) GOTO(190,12,13,14,15,16,190,190,190,190),I 12 IF(.NOT.TEST .OR. N.NE.1)GOTO 22 ENCODE(72,131,IMAGE)BUFFER 131 FORMAT(45A1,' with Oak Leaf Cluster') GOTO 18 13 IF(N.NE.1)GOTO 190 NFM=NFM+1 IF(NFM.GT.5)NFM=1 CALL CROP(FEDMEM(NFM),8) ENCODE(72,141,IMAGE)FEDMEM(NFM),BUFFER 141 FORMAT(A8,1X,45A1) GOTO 18 14 IF(.NOT.TEST .OR. N.NE.1)GOTO 22 ENCODE(72,151,IMAGE)BUFFER 151 FORMAT(45A1,' with Shield') GOTO 18 15 IF(.NOT.TEST .OR. N.NE.1)GOTO 22 ENCODE(72,161,IMAGE)BUFFER 161 FORMAT(45A1,' with Swords') GOTO 18 16 IF(.NOT.TEST)GOTO 190 IF(N.GT.1)GOTO 6 IF(J.LT.IG .OR. NN.EQ.0)GOTO 180 ENCODE(72,171,IMAGE)BUFFER 171 FORMAT(45A1,' with Meteors') GOTO 18 180 ENCODE(72,181,IMAGE)BUFFER 181 FORMAT(45A1,' with Meteors and Diamonds') GOTO 18 22 IF(TEST .AND. N.EQ.IFAC)GOTO 6 190 ENCODE(72,191,IMAGE)BUFFER 191 FORMAT(45A1) 18 CALL CROP(IMAGE,72) TYPE 201,IMAGE 201 FORMAT(1X,72A1) 19 CONTINUE 6 CONTINUE 5 CONTINUE CALL CLOSE(1) RETURN END