C C C ****************************************** C * * C * SUBROUTINE TO CHECK OFFICER'S ID * C * * C ****************************************** C SUBROUTINE CHKOID(NOFF,ORANK,ONAME1,TEST) C DIMENSION IU(4) REAL*8 NAME8(2),PNAME,PSWRD8 LOGICAL TEST LOGICAL*1 ORANK(13),ONAME1(16) C TEST=.FALSE. 10 TYPE 11 11 FORMAT(1X,'SF',$) READ(5,21,ERR=10)NC,NOFF,NAME8 21 FORMAT(Q,I3,1X,2A8) IF(NC.EQ.0)RETURN CALL CAPMSK(NAME8,16) CALL RUNMCR('[200,200]STARFLEET.NAM',22,'U') OPEN(UNIT=1,NAME='[200,200]STARFLEET.NAM',TYPE='OLD',FORM= &'UNFORMATTED',READONLY,SHARED,ERR=2) N=0 30 READ(1,END=40,ERR=2)PNAME,PSWRD8,IS,IR,NM,AV,IU N=N+1 IF(N.NE.NOFF)GOTO 30 CALL CAPMSK(PNAME,8) IF(PNAME.EQ.NAME8(1) .AND. PNAME.NE.' ')TEST=.TRUE. IF(TEST)GOTO 50 40 TYPE 41 41 FORMAT(1X,'**** ID# and name do not match - CHECK PERSONNEL LIST') GOTO 2 50 ENCODE(16,51,ONAME1)NAME8 51 FORMAT(2A8) CALL CROP(ONAME1,16) CALL SETRNK(IR,ORANK,1) 2 CALL CLOSE(1) RETURN END C C C ******************************************************** C * * C * SUBROUTINE TO LIST OUT STAR FLEET HEAVY CRUISERS * C * * C ******************************************************** C C C SUBROUTINE FLEET C LOGICAL*1 BUFFER(71) C OPEN(UNIT=1,NAME='[200,200]SHIPS.NAM',TYPE='OLD',READONLY, &SHARED) 10 READ(1,11,ERR=7,END=7)BUFFER 11 FORMAT(71A1) CALL CROP(BUFFER,71) TYPE 21,BUFFER 21 FORMAT(1X,71A1) GOTO 10 7 CALL CLOSE(1) RETURN C ENTRY LSTDEC !LIST DECORATIONS/AWARDS C OPEN(UNIT=1,NAME='[200,200]AWARDS.DAT',TYPE='OLD',READONLY, &SHARED) GOTO 10 END C C C ********************************************************* C * * C * SUBROUTINE TO LIST STATUS OF STAR FLEET PERSONNEL * C * * C ********************************************************* C SUBROUTINE PRSLST C DIMENSION IU(4),GDATE(3) REAL*8 PNAME,PSWRD8 LOGICAL*1 PRANK(13),ID(3) C CALL STRDAT(GDATE) 260 TYPE 261,GDATE 261 FORMAT(/10X,'STATUS OF STAR FLEET PERSONNEL',5X,2A4,A1/ &10X,30(1H=)/1X, &'NOTES: N.M.= no. of missions completed at current Rank'/ &8X, 'AVG = total average for current Rank'/ &8X, 'SHIP= ID# of Officer''s (> Rank 5) permanent ship'/ &8X, 'Names are first 8 letters only') TYPE 811 811 FORMAT(1X,53(1H-)/2X, &'ID#',T9,'NAME',T20,'RANK',T32,'LEVEL',T39,'N.M.',T46,'AVG', &T51,'SHIP'/1X,53(1H-)) CALL RUNMCR('[200,200]STARFLEET.NAM',22,'U') OPEN(UNIT=1,NAME='[200,200]STARFLEET.NAM',TYPE='OLD',FORM= &'UNFORMATTED',READONLY,SHARED,ERR=7) N=0 NN=0 270 READ(1,END=7,ERR=7)PNAME,PSWRD8,IS,IR,NM,AV,IU N=N+1 IF(N.EQ.2)GOTO 270 CALL CAPMSK(PNAME,8) IF(PNAME.EQ.'DELETED')GOTO 270 ENCODE(3,281,ID)N 281 FORMAT(I3) CALL SETRNK(IR,PRANK,0) IF(IR.LT.0)IR=0 DO 33 I=1,13 IF(PRANK(I).EQ."0)PRANK(I)=' ' IF(I.GT.3)GOTO 33 IF(ID(I).EQ.' ')ID(I)='0' 33 CONTINUE NN=NN+1 IF(NN.LE.15)GOTO 290 NN=0 TYPE 601 601 FORMAT(10X,'** HIT TO CONTINUE **') READ(5,121)ANS 121 FORMAT(A1) TYPE 811 290 TYPE 291,ID,PNAME,PRANK,IR,IABS(NM),AV,IS 291 FORMAT(1X,'SF',3A1,T8,A8,T17,13A1,T33,I2,T39,I3,T44,F6.2,T52,I2) GOTO 270 7 CALL CLOSE(1) RETURN END C C C ******************************************************* C * * C * SUBROUTINE TO DISPLAY SERVICE RECORD (MISSIONS) * C * * C ******************************************************* C SUBROUTINE RECRDS(NOFF,NPL,ORANK,ONAME1,GDATE) C DIMENSION DAT(3),GDATE(3) C LOGICAL TEST LOGICAL*1 NSHIP(16),ONAME1(16),ORANK(13) C IF(NOFF.GT.2 .OR. NPL.LE.2)GOTO 1 TYPE 11 11 FORMAT(1X,'*** SORRY, THE SERVICE RECORD REQUESTED IS CLASSIFIED') RETURN 1 TEST=.FALSE. CALL RUNMCR('[200,200]STAT.DAT',17,'U') OPEN(UNIT=1,NAME='[200,200]STAT.DAT',TYPE='OLD',FORM= &'UNFORMATTED',READONLY,SHARED,ERR=3) 60 TYPE 61,ORANK,ONAME1,GDATE 61 FORMAT(//1X,'***** RECENT SERVICE RECORD OF ',13A1,1X,16A1,6X, &2A4,A2/1X,71(1H=)/6X,'MSSN',T43,'TOT. ROM.',T62,'USS'/1X, &'RANK NO.',T13,'STARDATE',T30,'SHIP',T43,'DEST DEST',T55, &'DAYS LOST RTNG'/1X,71(1H-)) 70 READ(1,END=3,ERR=3)SEQN,DAT,NSHIP,IR,TM,NDS,LST,NRD,RTNG,N IF(N.NE.NOFF)GOTO 70 TEST=.TRUE. DO 2 I=16,1,-1 IF(NSHIP(I).NE."0)GOTO 80 NSHIP(I)=' ' 2 CONTINUE 80 TYPE 81,IR,SEQN,DAT,NSHIP,NDS,NRD,TM,LST,RTNG 81 FORMAT(1X,I2,3X,A4,T12,2A4,A1,5X,16A1,T43,I3,T50,I2,T54,F5.1,T63, &I2,T66,F6.1) GOTO 70 3 IF(.NOT.TEST)TYPE 141 141 FORMAT(1X,'Service Record is empty - no recent missions &recorded') CALL CLOSE(1) RETURN END