C C C CPMINT.FOR C C Library of CP/M Function Subroutines for C Microsoft FORTRAN-80. C C C Originally written: November, 1981 C C Pre-release modifications: C Dec. 10, 1981 - Added EXIST routine C Dec. 18, 1981 - Revised options for INCHR and INKEY C C Released to CP/M User's Group as: C Version 1.0 C January 12, 1982 C C Author: William R. Brandoni C C Language: Microsoft F80 (FORTRAN-80 compiler) Version 3.4 (26-Nov-80) C C C C C + + + + + + + + + + + + + + HIGH LEVEL ROUTINES + + + + + + + + + + + + + + C C Primary Entry Points C into the Library C C C * * * * * * * * * * C * * C * E R A S E * C * * C * * * * * * * * * * C C SUBROUTINE ERASE ( NDRIVE, STRING, NBYTES ) C C NDRIVE = < integer > C STRING = < byte array > C NBYTES = < integer > C C Erase a CP/M file. C C The file being erased should be closed before this routine C is called. Otherwise, duplicate FCB's will exist for the C file and unpredictable results may occur. C C Input Arguments: C NDRIVE ... Drive number (1=A:, 2=B:, etc.) C If entered as zero, then the currently-logged C drive is used unless the STRING array contains C a drive specification in the file name. C STRING ... A byte array containing a valid CP/M file name. C The name may contain a drive specification if C desired. C NBYTES ... The number of bytes in the STRING array. C If entered as zero, the STRING will be assumed C to be 11 bytes long, with the file name blank C filled (in the same format as for a Microsoft C OPEN call). In this mode, the drive cannot be C passed in the file name. C C Note: The drive may be specified in several ways. If more C than one specification is used, they must all agree C or a DRIVE CONFLICT error will be generated. C If the file to be erased cannot be found, C a NO FILE error will be generated. C C Output Arguments: C (none) C C C Examples of valid calls: C C CALL ERASE ( 0, 'b:ab.x', 6 ) C CALL ERASE ( 2, 'AB.X', 4 ) C CALL ERASE ( 2, 'AB X ', 11 ) C CALL ERASE ( NDR, FILNAM, NLONG ) C C Assuming that, in the last example, NDR = 2, FILNAM is a byte C array containing "ab.x", and NLONG = 4, then all of the C examples will erase the file AB.X on drive B:. C IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N ) C DIMENSION FCB (36) DIMENSION STRING (1) DIMENSION SUBNAM (6) C DATA SUBNAM / 'E','R','A','S','E',' ' / C C The following data statement sets CERROR to 0FFH, C which is the return code for an error (file not found). C DATA CERROR /.TRUE./ C C Set Up the FCB C LSTRNG = NBYTES IF ( NBYTES .EQ. 0 ) LSTRNG = 11 CALL FCB$ ( STRING, LSTRNG, FCB ) C C Get the drive number, C set NDR to the maximum of these values, C and test for any conflicts. C NDRFCB = FCB(1) NDR = MAX0 ( NDRIVE, NDRFCB ) IF ( NDRFCB .LE. 0 .OR. NDRIVE .LE. 0 ) GOTO 20 IF ( NDRIVE .NE. NDRFCB ) GOTO 90 C 20 FCB(1) = NDR C C Call BDOS function 19 C CALL CPMF19 ( FCB, CODE ) C C Error Handling Routines C C NO FILE TO ERASE error IF ( CODE .NE. CERROR ) GOTO 100 CALL ERROR$ ( 1, SUBNAM, FCB ) GOTO 100 C DRIVE CONFLICT error 90 CALL ERROR$ ( 3, SUBNAM, FCB ) C C Return to calling program C 100 RETURN END C * * * * * * * * * * C * * C * E X I S T * C * * C * * * * * * * * * * C C SUBROUTINE EXIST ( NDRIVE, STRING, NBYTES, IOK ) C C NDRIVE = < integer > C STRING = < byte array > C NBYTES = < integer > C IOK = < integer > C C Test to see if a file exists. C C C Input Arguments: C NDRIVE ... Drive number (1=A:, 2=B:, etc.) C If entered as zero, then the currently-logged C drive is used unless the STRING array contains C a drive specification in the file name. C STRING ... A byte array containing a valid CP/M file name. C The name may contain a drive specification if C desired. C NBYTES ... The number of bytes in the STRING array. C If entered as zero, the STRING will be assumed C to be 11 bytes long, with the file name blank C filled (in the same format as for a Microsoft C OPEN call). In this mode, the drive cannot be C passed in the file name. C C Note: The drive may be specified in several ways. If more C than one specification is used, they must all agree C or a DRIVE CONFLICT error will be generated. C If the file to be erased cannot be found, C a NO FILE error will be generated. C C Output Arguments: C IOK ...... Returned value: C 0 = file doesn't exist C 1 = file exists C IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N ) DIMENSION FCB (36) DIMENSION STRING (1) DIMENSION SUBNAM (6) DATA CERROR /.TRUE./ DATA SUBNAM / 'E','X','I','S','T',' ' / C C Set Up the FCB C LSTRNG = NBYTES IF ( NBYTES .EQ. 0 ) LSTRNG = 11 CALL FCB$ ( STRING, LSTRNG, FCB ) C C Get the drive number, C set NDR to the maximum of these values, C and test for any conflicts. C NDRFCB = FCB(1) NDR = MAX0 ( NDRIVE, NDRFCB ) IF ( NDRFCB .LE. 0 .OR. NDRIVE .LE. 0 ) GOTO 20 IF ( NDRIVE .NE. NDRFCB ) GOTO 90 C 20 FCB(1) = NDR C C Call BDOS function 17 C CALL CPMF17 ( FCB, CODE ) IOK = 1 IF ( CODE .EQ. CERROR ) IOK = 0 GOTO 100 C C Error Handling Routines C C DRIVE CONFLICT error 90 CALL ERROR$ ( 3, SUBNAM, FCB ) C C Return to calling program C 100 RETURN END C * * * * * * * * * * C * * C * G E T C M D * C * * C * * * * * * * * * * C C SUBROUTINE GETCMD ( ARRAY ) C C ARRAY = < byte array > C C This routine will get the "command line tail" and pass it C into the calling program. C Leading blanks are stripped off. C C The "tail" is that part of the command line that follows C the program name. For example, if the following line C were typed at the console following a CP/M prompt: C C b:foo options:a,c,d,f,l C C the system would load program FOO.COM from drive B: and the C "tail" would be the character string OPTIONS:A,C,D,F,L. C C CP/M will always map the command line to upper case. C C The user's program must interpret the "tail". All this C routine does is pass it to the FORTRAN program, after C leading blanks are stripped off. C C Some other considerations: C C You MUST get the "tail" before any disk operations C are performed in the program. Otherwise, CP/M may C overwrite the command line buffer during a disk C operation. Thus, you should call this routine as C one of the first activities in your program. C C You should scan the "tail" carefully, watching out C for trailing and imbedded blanks. The line C will be passed exactly as typed except for mapping C to upper case. C C Input arguments: C (none) C C Output arguments: C ARRAY .... This is a byte array, which must be dimensioned C in the calling program to a length sufficient to C hold the entire "tail". Otherwise, important C data or program instructions may be overwritten C by the command line information. Dimensioning C the variable to 80 bytes is usually sufficient. C The FIRST BYTE of the returned array will contain C the number of characters to follow. Only these C characters are valid. The remainder of the array C will be unchanged from its original contents, or C will contain "garbage". C IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N ) DIMENSION ARRAY (1) DATA BLANK / ' ' / DATA ONE / 1 / DATA ZERO / 0 / C C Get the command line as typed C CALL CPMFNA ( ARRAY ) C C Strip off leading blanks C by shifting contents left one byte. C 100 IF ( ARRAY(1) .LE. ONE ) GOTO 500 IF ( ARRAY(2) .NE. BLANK ) GOTO 500 ARRAY(1) = ARRAY(1) - ONE NBYTES = ARRAY(1) DO 200 N = 1, NBYTES N1 = N + 1 N2 = N + 2 200 ARRAY(N1) = ARRAY(N2) GOTO 100 C C Return, making sure a one-character C command isn't a blank. C 500 CONTINUE IF ( ARRAY(1) .NE. 1 ) GOTO 550 IF ( ARRAY(2) .EQ. BLANK ) ARRAY(1) = ZERO 550 RETURN END C * * * * * * * * * * C * * C * I N C H R * C * * C * * * * * * * * * * C C SUBROUTINE INCHR ( NOPT, CHAR ) C C NOPT = < integer > C CHAR = < byte > C C This subroutine reads a character from the console. C The character is immediately echoed to the console. C It is also returned as the value of the argument CHAR. C C If no character is pending at the console, execution C halts until a character is typed. C C The character is transmitted as soon as it is typed. C The RETURN or ENTER key is not required to complete the C entry. C C Input Arguments: C NOPT ..... Option for interpretation of input character. C (Add the following values together to determine C the value to use.) C 0 = (no option) C 1 = (no option) C 2 = map lower case alphabet to upper case C 4 = stop execution if ctrl-C C C Output Arguments: C CHAR ..... The resulting character. C IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N ) C DATA CTRLC / 3 / C CALL CPMF1 ( A ) CHAR = A IF ( NOPT .AND. 2 ) CALL MAP$ ( A, CHAR ) IF ( (NOPT .AND. 4) .AND. (A .EQ. CTRLC) ) STOP RETURN END C * * * * * * * * * * C * * C * I N K E Y * C * * C * * * * * * * * * * C C SUBROUTINE INKEY ( NOPT, CHAR ) C C NOPT = < integer > C CHAR = < byte > C C This function reads a character from the console. C The character is not echoed to the console. C It is returned as the value of the argument CHAR. C C If no character is pending at the console, the C NUL character (ASCII 0) is returned and execution C of the program continues. C C The character is transmitted as soon as it is typed. C The RETURN or ENTER key is not required to complete the C entry. C C Input Arguments: C NOPT ..... Option for interpretation of input character. C (Add the following values together to determine C the value to use.) C 0 = (no option) C 1 = wait for a character to be typed C 2 = map lower case alphabet to upper case C 4 = stop execution if ctrl-C C C Output Arguments: C CHAR ..... The resulting character. C IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N ) C DATA CTRLC / 3 / DATA FF /.TRUE./ DATA ZERO / 0 / C 10 CALL CPMF6 ( FF, A ) IF ( (NOPT .AND. 1) .AND. (A .EQ. ZERO) ) GOTO 10 CHAR = A IF ( NOPT .AND. 2 ) CALL MAP$ ( A, CHAR ) IF ( (NOPT .AND. 4) .AND. (A .EQ. CTRLC) ) STOP RETURN END C * * * * * * * * * * C * * C * R E N A M E * C * * C * * * * * * * * * * C C SUBROUTINE RENAME ( NDRIVE, FNOLD, FNNEW, NBOLD, NBNEW ) C C NDRIVE = < integer > C FNOLD = < byte array > C FNNEW = < byte array > C NBOLD = < integer > C NBNEW = < integer > C C Rename a CP/M file. C C The file being renamed should be closed before this routine C is called. Otherwise, duplicate FCB's will exist for the C file and unpredictable results may occur. C C Input Arguments: C NDRIVE ... Drive number (1=A:, 2=B:, etc.) C If entered as zero, then the currently-logged C drive is used unless the FNOLD or FNNEW array C contains a drive specification in the file name. C FNOLD .... A byte array containing a valid CP/M file name. C FNNEW .... A byte array containing a valid CP/M file name. C The name may contain a drive specification if C desired. C FNOLD is the old name; FNNEW is the new name. C NBOLD ... The number of bytes in the FNOLD array. C NBNEW ... The number of bytes in the FNNEW array. C If entered as zero, the array will be assumed C to be 11 bytes long, with the file name blank C filled (in the same format as for a Microsoft C OPEN call). In this mode, the drive cannot be C passed in the file name. C C Note: The drive may be specified in several ways. If more C than one specification is used, they must all agree C or a DRIVE CONFLICT error will be generated. C If the new file name already exists, a FILE ALREADY C EXISTS error will be generated. If the old file C cannot be found, a NO FILE error will be generated. C C Output Arguments: C (none) C C C Examples of valid calls: C C CALL RENAME ( 0, 'b:ab.x', 'cd.y', 6, 4 ) C CALL RENAME ( 0, 'ab.x', 'b:cd.y', 4, 6 ) C CALL RENAME ( 2, 'ab.x', 'cd.y', 4, 4 ) C CALL RENAME ( 2, 'AB X ', 'CD Y ', 0, 0 ) C CALL RENAME ( NDR, FIL1, FIL2, NB1, NB2 ) C C Assuming that, in the last example, NDR = 2, FIL1 is a byte C array containing "ab.x", FIL2 is a byte array containing C "cd.y", NB1 = 4, and NB2 = 4, then all of the C examples will rename the file AB.X to CD.Y on drive B:. C IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N ) C DIMENSION FCB (36) DIMENSION FNOLD (1) DIMENSION FNNEW (1) DIMENSION SUBNAM (6) C DATA SUBNAM / 'R','E','N','A','M','E' / DATA ONE / 1 / DATA ZERO / 0 / C C The following data statement sets CERROR to 0FFH, C which is the return code for an error (file not found). C DATA CERROR /.TRUE./ C C C C Get the drive info from each string, C set NDR to the maximum of these values, C and test for any conflicts. C CALL FNAME$ ( FNOLD, NBOLD, NDROLD, FCB ) CALL FNAME$ ( FNNEW, NBNEW, NDRNEW, FCB ) NDR = MAX0 ( NDRIVE, NDROLD, NDRNEW ) DRIVES = ZERO IF ( NDROLD .GT. 0 ) DRIVES = DRIVES + ONE IF ( NDRNEW .GT. 0 ) DRIVES = DRIVES + ONE IF ( NDRIVE .GT. 0 ) DRIVES = DRIVES + ONE IF ( DRIVES .LE. ONE ) GOTO 20 IF ( NDRIVE .LE. 0 ) GOTO 10 C NDRIVE was specified, so compare to it DRIVES = DRIVES - ONE IF ( NDROLD .LE. 0 ) GOTO 5 IF ( NDRIVE .NE. NDROLD ) GOTO 90 5 IF ( NDRNEW .LE. 0 ) GOTO 10 IF ( NDRIVE .NE. NDRNEW ) GOTO 90 C See if the two string drives need to be tested C and do it. 10 IF ( DRIVES .LE. ONE ) GOTO 20 IF ( NDROLD .NE. NDRNEW ) GOTO 90 C C See if the New File already exists C 20 CONTINUE CALL FCB$ ( FNNEW, NBNEW, FCB ) FCB(1) = NDR CALL CPMF17 ( FCB, CODE ) IF ( CODE .NE. CERROR ) GOTO 80 C C Perform the RENAME operation C by setting up the proper format C for the FCB. C LSTRNG = NBOLD IF ( NBOLD .EQ. 0 ) LSTRNG = 11 CALL FCB$ ( FNOLD, LSTRNG, FCB ) LSTRNG = NBNEW IF ( NBNEW .EQ. 0 ) LSTRNG = 11 CALL FNAME$ ( FNNEW, NBNEW, NDRNEW, FCB(17) ) FCB(17) = ZERO C C Call BDOS function 23 C CALL CPMF23 ( FCB, CODE ) C C Error handling routines C C RENAME function error IF ( CODE .NE. CERROR ) GOTO 100 CALL ERROR$ ( 1, SUBNAM, FCB ) GOTO 100 C NEW FILE EXISTS error 80 CALL ERROR$ ( 2, SUBNAM, FCB ) GOTO 100 C DRIVE CONFLICT error 90 CALL ERROR$ ( 3, SUBNAM, FCB ) C C Return to calling program C 100 RETURN END C C C + + + + + + + + + + + + + + LOW LEVEL ROUTINES + + + + + + + + + + + + + + C C Service Routines for C High-Level Routines C C C C * * * * * * * * * * C * * C * F C B $ * C * * C * * * * * * * * * * C C SUBROUTINE FCB$ ( STRING, LSTRNG, FCB ) C C STRING = < byte array > C LSTRNG = < integer > C FCB = < byte array > C C Subroutine to build a valid File Control Block (FCB) C C Input arguments: C STRING ... Input string ( a byte array ) of length LSTRNG C LSTRNG ... Integer value is length of STRING array in bytes. C C Output arguments: C FCB ...... The completed FCB ( a byte array ) which must C be 36 bytes long. The first 12 bytes will be C initialized to the drive and file specified C in STRING. The remainder will be zeroed. C IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N ) DIMENSION STRING(LSTRNG) DIMENSION FCB(36) DATA ZERO / 0 / C C Zero the FCB array C DO 100 K = 1, 36 100 FCB(K) = ZERO C C Fill out the file information C CALL FNAME$ ( STRING, LSTRNG, NDRIVE, FCB ) C C That's all, folks. C RETURN END C * * * * * * * * * * C * * C * F N A M E $ * C * * C * * * * * * * * * * C C SUBROUTINE FNAME$ ( STRING, LSTRNG, NDRIVE, FILNAM ) C C STRING = < byte array > C LSTRNG = < integer > C NDRIVE = < integer > C FILNAM = < byte array > C C Subroutine to extract a CP/M file name from an input C character string. C Complete error trapping is NOT included in this routine. C Thus, the programmer should excercize some caution in C the use of this routine. C Asterisks (*) are expanded into questions for the file C name and file type, and drive information is extracted C if it is included in the string as the first character C followed by a colon (:). C Thus, all valid CP/M file descriptions will be handled C properly. C C Input Arguments: C STRING ... Input string ( a byte array ) of length LSTRNG C LSTRNG ... Integer value is length of STRING array in bytes. C C Output Arguments: C NDRIVE ... Integer value of drive number: C 0 = logged in drive C 1 = drive A: C 2 = drive B: C etc. C FILNAM ... Output string ( a byte array ) of length 12. C The first byte duplicates the drive value in C NDRIVE. The remaining bytes are the name and C extension, blank-filled to exactly 11 characters. C C The format of the output arguments is such that they serve C two purposes: C C 1) To construct a Microsoft FORTRAN call to the OPEN subroutine, C use the form: C CALL OPEN ( lun, FILNAM(2), NDRIVE ) C where 'lun' is the unit number. Specifying FILNAM(2) in C the argument list passes the address of the second element C which is the first character of the 11-byte file name. C C 2) To construct a CP/M file control block (FCB), use the C FILNAM array as the first 12 bytes of the FCB, and the C drive specification will be placed in the first byte as C required. C C C IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N ) C C DIMENSION FILNAM(12) DIMENSION STRING(LSTRNG) DIMENSION WORKER(14) C C DATA BLANK / ' ' / DATA COLON / ':' / DATA PERIOD / '.' / DATA QUEST / '?' / DATA STAR / '*' / C C First, transfer STRING to WORKER array C and map any lower case to upper case. C C Blank-fill WORKER C Blank-fill FILNAM C NDRIVE = 0 C DO 10 K = 1, 12 WORKER(K) = BLANK 10 FILNAM(K) = BLANK C WORKER(13) = BLANK WORKER(14) = BLANK FILNAM( 1) = NDRIVE C C Search for first non-blank in STRING C KSTART = 0 C DO 20 K = 1, LSTRNG IF ( STRING(K) .EQ. BLANK ) GOTO 20 KSTART = K GOTO 50 20 CONTINUE C GOTO 300 C C Transfer STRING into WORKER C starting at first non-blank. C Mapping to upper case takes place here. C Also, search for PERIOD character. C 50 KOUNT = 0 KDOT = 0 C DO 100 K = KSTART, LSTRNG KOUNT = KOUNT + 1 IF ( KOUNT .GT. 14 ) GOTO 110 WORKER(KOUNT) = STRING(K) IF ( WORKER(KOUNT) .EQ. PERIOD ) KDOT = KOUNT CALL MAP$ ( WORKER(KOUNT), WORKER(KOUNT) ) 100 CONTINUE C C Then, check for drive specification. C This is true only if the second character C is a colon. C 110 NDRIVE = 0 KSTART = 1 IF ( WORKER(2) .NE. COLON ) GOTO 200 KSTART = 3 C C Drive is specified. Convert as follows: C C A: or 0: set to 1 C B: or 1: set to 2 C C: or 2: set to 3 C D: or 3: set to 4 C IF ( WORKER(1) .GE. 65 ) WORKER(1) = WORKER(1) - 17 NDRIVE = WORKER(1) - 47 C C Set up the FILNAM vector. C 200 CONTINUE FILNAM(1) = NDRIVE C C Transfer the file name (first 8 characters). C Test to see if first character is a star (*). C If so, make file name all questions (?). C KOUNT = 1 KSTOP = KSTART + 7 QSTAR = .FALSE. IF ( WORKER(KSTART) .EQ. STAR ) QSTAR = .TRUE. C DO 210 K = KSTART, KSTOP KOUNT = KOUNT + 1 KSAVE = K IF ( QSTAR ) GOTO 205 IF ( WORKER(K) .EQ. PERIOD ) GOTO 220 FILNAM(KOUNT) = WORKER(K) GOTO 210 205 FILNAM(KOUNT) = QUEST 210 CONTINUE C C Transfer the file type (last 3 characters). C Test to see if first character is a star (*). C If so, make file type all questions (?). C 220 KOUNT = 9 KSTART = KSAVE + 1 IF ( KDOT .GT. 0 ) KSTART = KDOT + 1 KSTOP = KSTART + 2 QSTAR = .FALSE. IF ( WORKER(KSTART) .EQ. STAR ) QSTAR = .TRUE. C DO 250 K = KSTART, KSTOP KOUNT = KOUNT + 1 IF ( QSTAR ) GOTO 240 FILNAM(KOUNT) = WORKER(K) GOTO 250 240 FILNAM(KOUNT) = QUEST 250 CONTINUE C C That's all, folks! C 300 CONTINUE RETURN END C * * * * * * * * * * C * * C * M A P $ * C * * C * * * * * * * * * * C C SUBROUTINE MAP$ ( AIN, AOUT ) C C AIN = < byte > C AOUT = < byte > C C Map a lower case character to upper case. C C If the input character is not a lower case alphabet C character, no mapping takes place. C C Input Arguments: C AIN ..... The one-byte value to be mapped. C C Output Arguments: C AOUT .... The one-byte value mapped to u.c. C IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N ) C DATA ALOWER / 'a' / DATA AOFSET / 32 / DATA ZLOWER / 'z' / C IF ( AIN .LT. ALOWER ) GOTO 100 IF ( AIN .GT. ZLOWER ) GOTO 100 AOUT = AIN - AOFSET 100 RETURN END C * * * * * * * * * * C * * C * E R R O R $ * C * * C * * * * * * * * * * C C SUBROUTINE ERROR$ ( NERROR, ANAME, ARRAY ) C C NERROR = < integer > C ANAME = < byte array > C ARRAY = < byte array > C C C Error printing routine. C C Input Arguments: C NERROR ... Number of the error message to print. C ANAME .... A six-byte name for the routine which called C the error. C ARRAY .... A byte array, the contents of which depend on C the error being processed. C C Output Arguments: C (none) C IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N ) DIMENSION ANAME(6), ARRAY(1) C The ALPHA variable maps the drive number to upper C case alphabet. DATA ALPHA / 64 / C The LIO variable defines the output device for error C messages. Device 3 is the default device used by C Microsoft for FORTRAN run-time errors. DATA LIO / 3 / C The NMAX variable defines the maximum error code C available in this version. DATA NMAX / 3 / DATA ZERO / 0 / C C IF ( NERROR .LT. 1 .OR. NERROR .GT. NMAX ) GOTO 500 GOTO ( 10, 20, 30 ), NERROR C C FILE NOT FOUND error C 10 IF ( ARRAY(1) .EQ. ZERO ) GOTO 11 DRIVE = ARRAY(1) + ALPHA WRITE ( LIO, 9010 ) (ANAME(J), J = 1, 6), DRIVE, A (ARRAY(J), J = 2, 12) GOTO 1000 11 WRITE ( LIO, 9011 ) (ANAME(J), J = 1, 6), A (ARRAY(J), J = 2, 12) GOTO 1000 C C FILE ALREADY EXISTS error C 20 IF ( ARRAY(1) .EQ. ZERO ) GOTO 21 DRIVE = ARRAY(1) + ALPHA WRITE ( LIO, 9020 ) (ANAME(J), J = 1, 6), DRIVE, A (ARRAY(J), J = 2, 12) GOTO 1000 21 WRITE ( LIO, 9021 ) (ANAME(J), J = 1, 6), A (ARRAY(J), J = 2, 12) GOTO 1000 C C DRIVE CONFLICT error C 30 WRITE ( LIO, 9030 ) (ANAME(J), J = 1, 6) GOTO 1000 C C Undefined Error C 500 WRITE ( LIO, 9500 ) (ANAME(J), J = 1, 6) C C Return to calling routine C 1000 RETURN C C Formats C 9010 FORMAT (1X, 6A1, ' error - no file ', A1, ': ', 11A1 ) 9011 FORMAT (1X, 6A1, ' error - no file ', 11A1 ) 9020 FORMAT (1X, 6A1, ' error - ', A1, ':', A 11A1, ' already exists.') 9021 FORMAT (1X, 6A1, ' error - ', A 11A1, ' already exists.') 9030 FORMAT (1X, 6A1, ' error - drive conflict.') 9500 FORMAT (1X, 6A1, ' - undefined error.') END