-+-+-+-+-+-+-+-+ START OF PART 3 -+-+-+-+-+-+-+-+
X     _     KEY         = (1:15:CHARACTER),
X     _     ERR         = 22              ,
X     _     UNIT        = 20              ,
X     _     IOSTAT      = IOS)
X      KEY_FIELD        = USER
X      IOS              = 0
X      CALL LIB$DATE_TIME( TODAYS_DATE )
X      WRITE (*,11) TODAYS_DATE(1:12)
X      WRITE (*,13)
X      WRITE (*,17)
X      DO WHILE( IOS .EQ. 0 )
X          READ(UNIT    = 20              ,
X     _          IOSTAT = IOS             ,
X     _          ERR    = 2 )
X     _    USER_STRUCTURE
X          IF (USER_STRUCTURE.DATE_TIME(1:12) .EQ. TODAYS_DATE(1:12)) THEN
X               WRITE(*,14) USER_STRUCTURE.USERNAME, USER_STRUCTURE.PNAME,
X     _                     USER_STRUCTURE.DATE_TIME,USER_STRUCTURE.TIMES,
X     _                     USER_STRUCTURE.FLAGS
X
X               INUM_USERS = INUM_USERS + 1
X               INUM_TIMES = INUM_TIMES + USER_STRUCTURE.TIMES
X               IICNT = IICNT + 1
X               IF ( IICNT .EQ. 20 ) THEN
X                  CALL LIB$GET_INPUT( DUMMY, '`5Bpress RETURN to continue`5D
V',I)
X                  IICNT = 0
X               ENDIF
X          ENDIF
X      END DO
X  2   CONTINUE
X 21   CLOSE(20)
X      WRITE (*,17)
X      WRITE (*,18) INUM_USERS
X 22   RETURN
X      END
X
X
X
X
X
X      SUBROUTINE    CHANGE_ALL_USERS
X      CHARACTER*4   FLAGS
X      CHARACTER*80  DATA_DIR
X      CHARACTER*132 DATAFILE
X      INCLUDE       '($JPIDEF)'
X      STRUCTURE /USR/
X         CHARACTER*15 USERNAME
X         CHARACTER*15 PNAME
X         CHARACTER*23 DATE_TIME
X         CHARACTER*4  FLAGS
X         INTEGER  *4  TIMES
X      END STRUCTURE
X      RECORD /USR/ USER_STRUCTURE
X
X      CALL GET_JPI( JPI$_IMAGNAME, DATA_DIR , IDUMMY )
X      DATAFILE = DATA_DIR(1:II)//'BATTLESHIP_UAF.DAT'
X
X      OPEN(FILE        = DATAFILE        ,
X     _     STATUS      = 'OLD'           ,
X     _     ORGANIZATION= 'INDEXED'       ,
X     _     ACCESS      = 'KEYED'         ,
X     _     RECORDTYPE  = 'VARIABLE'      ,
X     _     FORM        = 'UNFORMATTED'   ,
X     _     CARRIAGECONTROL = 'NONE'      ,
X     _     RECL        = 61              ,
X     _     KEY         = (1:15:CHARACTER),
X     _     ERR         = 22              ,
X     _     UNIT        = 20              ,
X     _     IOSTAT      = IOS)
X      KEY_FIELD        = USER
X      IOS              = 0
X      CALL LIB$GET_INPUT( FLAGS, 'New flag setting: ',IID )
X      IF ( IID .NE. 0 ) THEN
X           DO I = 1, 4, 1
X                 IF((FLAGS(I:I).NE.'0').AND.(FLAGS(I:I).NE.'1'))
X     _           FLAGS(I:I)='0'
X           END DO
X      ELSE
X           IOS = -1
X
X      ENDIF
X
X      DO WHILE( IOS .EQ. 0 )
X          READ(UNIT    = 20              ,
X     _          IOSTAT = IOS             ,
X     _          ERR    = 2 )
X     _    USER_STRUCTURE
X
X
X          USER_STRUCTURE.FLAGS = FLAGS
X          REWRITE(UNIT=20,ERR=21) USER_STRUCTURE
X
X      END DO
X  2   CONTINUE
X 21   CLOSE(20)
X 22   RETURN
X      END
X
X
X
X
X
X      SUBROUTINE    DRAW_MENU
X      WRITE (*,*) ' Command       Description '
X      WRITE (*,*) ' --------------------------------------------------'
X      WRITE (*,*) ' INITialize  - 1) Initializes new user access file.'
X      WRITE (*,*) '                  All existing records will be '//
X     _                               'erased.'
X      WRITE (*,*) '               2) Creates files necessary for mailb'
X     _                               //'ox'
X      WRITE (*,*) '                   name exchange.'
X      WRITE (*,*) ' VSingle     - View stats for a single user.'
X      WRITE (*,*) ' CSingle     - Change the flags for a single user.'
X      WRITE (*,*) ' VAll        - View the stats for all users.'
X      WRITE (*,*) ' CAll        - Change the flags for all users.'
X      WRITE (*,*) ' VFlags      - View the default flags for new users.'
X      WRITE (*,*) ' CFlags      - Change the default flags for new '//
X     _                            'users.'
X      WRITE (*,*) ' VTime       - View the current times the game can'
X      WRITE (*,*) '               be played.'
X      WRITE (*,*) ' CTime         Change the times the game can be '//
X     _                            'played.'
X      WRITE (*,*) ' .E          - Exits BATTLESHIP UAF utility.'
X      WRITE (*,*) ' '
X      WRITE (*,*) ' MEnu, ?, HElp provides you with this listing. '
X      WRITE (*,*) ' --------------------------------------------------'
X      RETURN
X      END
X
X
X      SUBROUTINE    INITIALIZE_DATAFILE
X      CHARACTER*12  NODE
X      CHARACTER*80  DATA_DIR
X      CHARACTER*132 DATAFILE
X      INCLUDE       '($JPIDEF)'
X      STRUCTURE /USR/
X         CHARACTER*15 USERNAME
X         CHARACTER*15 PNAME
X         CHARACTER*23 DATE_TIME
X         CHARACTER*4  FLAGS
X         INTEGER  *4  TIMES
X      END STRUCTURE
X      RECORD /USR/ USER_STRUCTURE
X 1    FORMAT( 1X, 'User Access File has been created.' )
X 2    FORMAT( 1X, 'Could not create ',A<IIJ> )         `20
X 3    FORMAT( 1X, 'Enter the name of the node you wish to install'  )
X 4    FORMAT( 1X, 'and press `5Breturn`5D.  Press `5Breturn`5D on an empty'
V )
X 5    FORMAT( 1X, 'prompt when you have finished all nodes.'        )
X      CALL GET_JPI( JPI$_IMAGNAME, DATA_DIR , IDUMMY )
X      DATAFILE = DATA_DIR(1:II)//'BATTLESHIP_UAF.DAT'
X
X      OPEN(FILE        = DATAFILE        ,
X     _     STATUS      = 'NEW'           ,
X     _     ORGANIZATION= 'INDEXED'       ,
X     _     ACCESS      = 'KEYED'         ,
X     _     RECORDTYPE  = 'VARIABLE'      ,
X     _     FORM        = 'UNFORMATTED'   ,
X     _     CARRIAGECONTROL = 'NONE'      ,
X     _     RECL        = 61              ,
X     _     KEY         = (1:15:CHARACTER),
X     _     ERR         = 22              ,
X     _     UNIT        = 20              ,
X     _     IOSTAT      = IOS)
X
X     `20
X      WRITE (*,3)
X      WRITE (*,4)
X      WRITE (*,5)
X      WRITE (*,*) ' '
X      IID = 1
X      DO WHILE( IID .NE. 0 )
X         CALL LIB$GET_INPUT( NODE, 'Node: ', IID )
X         CALL STR$UPCASE( NODE, NODE )
X         IF ( IID .NE. 0 ) THEN
X         OPEN(FILE=DATA_DIR(1:II)//'BATTLESHIP_'//NODE(1:IID)//'.DAT',
X     _        UNIT=1,STATUS='NEW')
X          CLOSE(UNIT=1)
X         ENDIF
X      END DO
X      RETURN
X 22   IIJ = INDEX( DATAFILE, ' ' )
X      WRITE (*,2) 'Could not create '//DATAFILE(1:IIJ-1)
X      END
X
X
X      SUBROUTINE  GET_JPI(  CODE, RETVAL , II)
X      INTEGER     STATUS, LIB$GETJPI, CODE
X      CHARACTER*(*) RETVAL
X
X      STATUS = LIB$GETJPI( CODE,,,,RETVAL, II )
X      IF (.NOT. STATUS ) CALL LIB$SIGNAL( %VAL(STATUS) )
X
X      RETURN
X      END
X
$ CALL UNPACK BATTLESHIP_MAINT.FOR;1 1494293226
$ create 'f'
XMTWTFSS TIME
X....... 00
X....... 01
X....... 02
X....... 03
X....... 04
X....... 05
X....... 06
X....... 07
X....... 08
X....... 09
X....... 10
X....... 11
X....... 12
X....... 13
X....... 14
X....... 15
X....... 16
X....... 17
X....... 18
X....... 19
X....... 20
X....... 21
X....... 22
X....... 23
X
X
X
X
$ CALL UNPACK BATTLESHIP_TIMES.DAT;1 826890193
$ create 'f'
X!
X!  BATTLE_ARRAY.INC
X!
X!  Contains the status messages of the ships as their strengths are
X!  being changed.
X!
X!  Ray Renteria
X!  RR62C22B@SWTEXAS    ACM_CSA@SWTEXAS
X!  Southwest Texas State University
X!  (512) 396 - 7216
X!
X!
X
X      CHARACTER*9        BATTLESHIP( BAT_STRENGTH ),
X     _                   CRUISER   ( CRU_STRENGTH ),
X     _                   DESTROYER ( DES_STRENGTH ),
X     _                   PT_BOAT   ( PT_STRENGTH  ),
X     _                   SUBMARINE ( SUB_STRENGTH ),
X     _                   CARRIER   ( CAR_STRENGTH )
X
X      BATTLESHIP(1) = 'Critical'
X      CRUISER(1)    = 'Critical'
X      DESTROYER(1)  = 'Critical'
X      PT_BOAT(1)    = 'Critical'
X      SUBMARINE(1)  = 'Critical'
X      CARRIER(1)    = 'Critical'
X
X      BATTLESHIP(2) = 'Crippled'
X      CRUISER(2)    = 'Nominal'
X      DESTROYER(2)  = 'Crippled'
X      PT_BOAT(2)    = 'Undamaged'
X      SUBMARINE(2)  = 'Nominal'
X      CARRIER(2)    = 'Crippled' `20
X
X      BATTLESHIP(3) = 'Nominal'
X      CRUISER(3)    = 'Undamaged'
X      DESTROYER(3)  = 'Damaged'
X      SUBMARINE(3)  = 'Undamaged'
X      CARRIER(3)    = 'Damaged'
X
X      BATTLESHIP(4) = 'Damaged'
X      DESTROYER(4)  = 'Undamaged'
X      CARRIER(4)    = 'Undamaged'
X
X      BATTLESHIP(5) = 'Undamaged'
$ CALL UNPACK BATTLE_ARRAY.INC;1 643586462
$ create 'f'
X$  FORTRAN BATTLE
X$  FORTRAN BATTLESHIP_MAINT
X$  LINK BATTLE
X$  LINK BATTLESHIP_MAINT
X$  DELETE/NOCONFIRM *.OBJ;*
X$  WRITE SYS$OUTPUT "Now RUN BATTLESHIP_MAINT to initialize everything."
X$  EXIT
$ CALL UNPACK BUILD.COM;1 238421646
$ create 'f'
XC
XC  COMLINK.FOR
XC
XC  Ray Renteria
XC  RR02026@SWTEXAS    ACM_CSA@SWTEXAS
XC  Southwest Texas State University
XC  (512) 396 - 7216
XC
XC  Contains:
XC
XC    CLOSE_LINK     Close communications link.  Empty transfer file of mbxna
Vm.
XC    LEFT_JUSTIFY   Left justify a character string.
XC    LOOK_AT_FILE   Opens main xfer file to exchange mailbox names with oppo
Vnent
XC    MESSAGE_2      Displays a message when a successful file-open has occur
Ved
XC    PAUSE_1        Displays an error message when primary file can't be ope
Vned.
XC    SETUP_COMLINK  Exchanges mailbox names with opponent.
XC
X
X      SUBROUTINE   SETUP_COMLINK
X      CHARACTER*42 LINE
X      EXTERNAL     ABORT_GAME, HELP_ROUTINE
X   1  FORMAT( '+', A12, 1X, A12, 1X, A15 )
X      INCLUDE 'BATTLE.INC'
X      INCLUDE '($SSDEF)'
X      IIBAD_MAILBOX = 0
X   2  CALL LOOK_AT_FILE
X      IF ( WERE_FIRST ) THEN
X         CALL SET_WRITE_ATTENTION
X         CALL MESSAGE( 'Your challenge has been made, sir.'//
X     _                 '  Waiting for an opponent. . .' )
X
X         WAITING_FOR_COMLINK = .TRUE.
X         CALL GET_THEIR_INFO
X         WAITING_FOR_COMLINK = .FALSE.
X
X         II = INDEX( THEIR.MBX_NAME, ':' )
X         CALL ASSIGN_CHANNEL( THEIR.MBX_NAME(1:II) )
X         II = ILN( THEIR.UIC )
X         IJ = ILN( THEIR.NICKNAME )
X         CALL MESSAGE( 'You have a challenger sir! It is '//
X     _                 THEIR.UIC(1:II)//'!!' )
X
X
X      ELSE
X         CALL SET_WRITE_ATTENTION
X         II = INDEX( THEIR.MBX_NAME, ':' )
X         STATUS=SYS$ASSIGN(THEIR.MBX_NAME(1:II),THEIR.MBX_CHAN,,)
X         IF ( STATUS .NE. SS$_NORMAL ) THEN
X                IIBAD_MAILBOX = IIBAD_MAILBOX + 1
X                IF ( IIBAD_MAILBOX .GT. 3 ) THEN
X                     CALL MESSAGE('Sir, there seems to be a problem'//
X     _                            ' initiating a communications' )
X                     CALL MESSAGE('link.  We will have to abort. Pr'//
X     _                            'ess any key to exit the game.' )
X                     IIJ = INKEY()
X                     CALL CANCELLED_THE_GAME
X                ENDIF
X                GOTO 2
X         ENDIF
X
X         WRITE ( LINE, 1 ) OUR.MBX_NAME, OUR.UIC, OUR.NICKNAME
X
X         CALL WRITE_TO_MAILBOX_RAW( LINE )
X
X         II = ILN( THEIR.UIC )
X         IJ = ILN( THEIR.NICKNAME )
X         CALL MESSAGE( 'Your opponent is '//THEIR.UIC(1:II)//
X     _                 ', ('//THEIR.NICKNAME(1:IJ)//').' )
X
X      ENDIF
X
X      CALL CONTROL( 'A', ABORT_GAME   )
X      CALL CONTROL( 'H', HELP_ROUTINE )
X      RETURN
X      END
X
X      SUBROUTINE    LOOK_AT_FILE
X      INCLUDE       'BATTLE.INC'
X      CHARACTER*100  MASTER_FILE
X   1  FORMAT( 1X, A12, 1X, A12, 1X, A15 )
X      II     = ILN( IMAGE_DEFAULT_DIR )
X      IJ     = ILN( CURR_NODE )
X      ICOUNT = 0
X
X      MASTER_FILE = IMAGE_DEFAULT_DIR(1:II)//
X     _              'BATTLESHIP_'          //
X     _              CURR_NODE(1:IJ)        //
X     _              '.DAT'
X
X
X      THEIR.MBX_NAME = ' '
X  19  OPEN( FILE=MASTER_FILE, STATUS='OLD', UNIT=20, ERR=21 )
X      CALL MESSAGE_2( ICOUNT )
X
X      READ( 20, 1, END=20 ) THEIR.MBX_NAME, THEIR.UIC, THEIR.NICKNAME
X      CALL LEFT_JUSTIFY( THEIR.MBX_NAME )
X      CALL LEFT_JUSTIFY( THEIR.UIC      )
X
X  20  IF ( THEIR.MBX_NAME(1:1) .EQ. ' ' ) THEN
X           REWIND(20)
X           WRITE( 20, 1 ) OUR.MBX_NAME, OUR.UIC, OUR.NICKNAME
X           WERE_FIRST = .TRUE.
X
X      ELSE
X           REWIND(20)
X           WRITE( 20, 1 ) ' ', ' ', ' '
X           WERE_FIRST = .FALSE.
X
X      ENDIF
X      CLOSE(20)
X      RETURN `20
X
X  21  ICOUNT = ICOUNT + 1
X      CALL PAUSE_1( ICOUNT )
X      GOTO 19
X
X      END
X
X      SUBROUTINE LEFT_JUSTIFY( STRING )
X      CHARACTER*(*) STRING
X      II = LEN( STRING )
X      IJ = 1
X      DO WHILE(( STRING(IJ:IJ) .EQ. ' ' ) .AND. ( IJ .LT. II ))
X          IJ = IJ + 1
X      END DO
X      STRING(1:) = STRING(IJ:)
X      RETURN
X      END
X
X      SUBROUTINE PAUSE_1( ICOUNT )
X      IF     ( ICOUNT .EQ. 1 ) THEN
X         CALL MESSAGE( 'Could not open primary datafile, sir!' )
X         CALL LIB$WAIT( 1.0 )
X         CALL MESSAGE( 'Trying again. . .' )
X         CALL LIB$WAIT( 0.2 )
X
X      ELSEIF ( ICOUNT .EQ. 2 ) THEN
X         CALL MESSAGE( 'Sir! We still can''t get it open!' )
X         CALL LIB$WAIT( 1.0 )
X         CALL MESSAGE( 'We''re going to attempt it again, sir!')
X         CALL LIB$WAIT( 0.2 )
X
X      ELSEIF ( ICOUNT .EQ. 3 ) THEN
X            CALL MESSAGE( 'We''re still trying to pry it open!' )
X           `20
X      ELSE
X         CALL MESSAGE( 'Sir, I regret to inform you that after '//
X     _                    'all our efforts, ' )
X         CALL MESSAGE( 'we could not open the primary comlink.' )
X         CALL EXIT
X      ENDIF
X      RETURN
X      END
X
X
X      SUBROUTINE MESSAGE_2( ICOUNT )
X      IF ( ICOUNT .EQ. 1 ) THEN
X          CALL MESSAGE( 'GOT IT, SIR! We opened the data file!' )
X      ELSEIF( ICOUNT .EQ. 2 ) THEN
X          CALL MESSAGE( 'Sir!  The data file gave way, we''re in!')
X      ELSEIF( ICOUNT .EQ. 3 ) THEN
X          CALL MESSAGE( 'IT''S A MIRACLE! WE''VE PENETATED!' )
X      ENDIF
X      RETURN
X      END
X
X
X      SUBROUTINE CLOSE_LINK
X      INCLUDE 'BATTLE.INC'
X      CALL SMG$DISABLE_BROADCAST_TRAPPING( PASTEID )
X      CALL SYS$DELMBX(%DESCR('BATTLE$MBX'))
X      CALL SMG$DELETE_PASTEBOARD( PASTEID )
X      CALL EXIT
X      END
X
$ CALL UNPACK COMLINK.FOR;1 659385963
$ create 'f'
XC
XC  SCREEN1.FOR
XC
XC  Ray Renteria
XC  RR02026@SWTEXAS    ACM_CSA@SWTEXAS
+-+-+-+-+-+-+-+-  END  OF PART 3 +-+-+-+-+-+-+-+-