home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / FORTRAN / CPMLIB.ARK / CPMINT.FOR < prev    next >
Text File  |  1982-01-12  |  30KB  |  905 lines
  1. C
  2. C
  3. C     CPMINT.FOR
  4. C
  5. C     Library of CP/M Function Subroutines for
  6. C     Microsoft FORTRAN-80.
  7. C
  8. C
  9. C     Originally written:  November, 1981
  10. C
  11. C     Pre-release modifications:
  12. C     Dec. 10, 1981 - Added EXIST routine
  13. C     Dec. 18, 1981 - Revised options for INCHR and INKEY
  14. C
  15. C     Released to CP/M User's Group as:
  16. C     Version 1.0
  17. C     January 12, 1982
  18. C
  19. C     Author: William R. Brandoni
  20. C
  21. C     Language: Microsoft F80 (FORTRAN-80 compiler) Version 3.4 (26-Nov-80)
  22. C
  23. C
  24. C
  25. C
  26. C + + + + + + + + + + + + + + HIGH LEVEL ROUTINES + + + + + + + + + + + + + +
  27. C
  28. C                             Primary Entry Points
  29. C                             into the Library
  30. C
  31. C
  32. C                             * * * * * * * * * *
  33. C                             *                 *
  34. C                             *    E R A S E    *
  35. C                             *                 *
  36. C                             * * * * * * * * * *
  37. C
  38. C
  39.       SUBROUTINE ERASE ( NDRIVE, STRING, NBYTES )
  40. C
  41. C                NDRIVE = < integer >
  42. C                STRING = < byte array >
  43. C                NBYTES = < integer >
  44. C
  45. C     Erase a CP/M file.
  46. C
  47. C     The file being erased should be closed before this routine
  48. C     is called.  Otherwise, duplicate FCB's will exist for the
  49. C     file and unpredictable results may occur.
  50. C
  51. C     Input Arguments:
  52. C     NDRIVE ... Drive number (1=A:, 2=B:, etc.)
  53. C                If entered as zero, then the currently-logged
  54. C                drive is used unless the STRING array contains
  55. C                a drive specification in the file name.
  56. C     STRING ... A byte array containing a valid CP/M file name.
  57. C                The name may contain a drive specification if
  58. C                desired.
  59. C     NBYTES ... The number of bytes in the STRING array.
  60. C                If entered as zero, the STRING will be assumed
  61. C                to be 11 bytes long, with the file name blank
  62. C                filled (in the same format as for a Microsoft
  63. C                OPEN call).  In this mode, the drive cannot be
  64. C                passed in the file name.
  65. C
  66. C     Note: The drive may be specified in several ways. If more
  67. C           than one specification is used, they must all agree
  68. C           or a DRIVE CONFLICT error will be generated.
  69. C           If the file to be erased cannot be found,
  70. C           a NO FILE error will be generated.
  71. C
  72. C     Output Arguments:
  73. C         (none)
  74. C
  75. C
  76. C     Examples of valid calls:
  77. C
  78. C         CALL ERASE ( 0, 'b:ab.x', 6 )
  79. C         CALL ERASE ( 2, 'AB.X', 4 )
  80. C         CALL ERASE ( 2, 'AB      X  ', 11 )
  81. C         CALL ERASE ( NDR, FILNAM, NLONG )
  82. C
  83. C     Assuming that, in the last example, NDR = 2, FILNAM is a byte
  84. C     array containing "ab.x", and NLONG = 4, then all of the
  85. C     examples will erase the file AB.X on drive B:.
  86. C
  87.       IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N )
  88. C
  89.       DIMENSION FCB (36)
  90.       DIMENSION STRING (1)
  91.       DIMENSION SUBNAM (6)
  92. C
  93.       DATA SUBNAM / 'E','R','A','S','E',' ' /
  94. C
  95. C     The following data statement sets CERROR to 0FFH,
  96. C     which is the return code for an error (file not found).
  97. C
  98.       DATA CERROR /.TRUE./
  99. C
  100. C                             Set Up the FCB
  101. C
  102.       LSTRNG = NBYTES
  103.       IF ( NBYTES .EQ. 0 ) LSTRNG = 11
  104.       CALL FCB$ ( STRING, LSTRNG, FCB )
  105. C
  106. C                             Get the drive number,
  107. C                             set NDR to the maximum of these values,
  108. C                             and test for any conflicts.
  109. C
  110.       NDRFCB = FCB(1)
  111.       NDR    = MAX0 ( NDRIVE, NDRFCB )
  112.       IF ( NDRFCB .LE. 0  .OR.  NDRIVE .LE. 0 ) GOTO 20
  113.       IF ( NDRIVE .NE. NDRFCB ) GOTO 90
  114. C
  115.    20 FCB(1) = NDR
  116. C
  117. C                             Call BDOS function 19
  118. C
  119.       CALL CPMF19 ( FCB, CODE )
  120. C
  121. C                             Error Handling Routines
  122. C
  123. C         NO FILE TO ERASE error
  124.       IF ( CODE .NE. CERROR ) GOTO 100
  125.       CALL ERROR$ ( 1, SUBNAM, FCB )
  126.       GOTO 100
  127. C         DRIVE CONFLICT error
  128.    90 CALL ERROR$ ( 3, SUBNAM, FCB )
  129. C
  130. C                             Return to calling program
  131. C
  132.   100 RETURN
  133.       END
  134. C                             * * * * * * * * * *
  135. C                             *                 *
  136. C                             *    E X I S T    *
  137. C                             *                 *
  138. C                             * * * * * * * * * *
  139. C
  140. C
  141.       SUBROUTINE EXIST ( NDRIVE, STRING, NBYTES, IOK )
  142. C
  143. C                NDRIVE = < integer >
  144. C                STRING = < byte array >
  145. C                NBYTES = < integer >
  146. C                IOK    = < integer >
  147. C
  148. C     Test to see if a file exists.
  149. C
  150. C
  151. C     Input Arguments:
  152. C     NDRIVE ... Drive number (1=A:, 2=B:, etc.)
  153. C                If entered as zero, then the currently-logged
  154. C                drive is used unless the STRING array contains
  155. C                a drive specification in the file name.
  156. C     STRING ... A byte array containing a valid CP/M file name.
  157. C                The name may contain a drive specification if
  158. C                desired.
  159. C     NBYTES ... The number of bytes in the STRING array.
  160. C                If entered as zero, the STRING will be assumed
  161. C                to be 11 bytes long, with the file name blank
  162. C                filled (in the same format as for a Microsoft
  163. C                OPEN call).  In this mode, the drive cannot be
  164. C                passed in the file name.
  165. C
  166. C     Note: The drive may be specified in several ways. If more
  167. C           than one specification is used, they must all agree
  168. C           or a DRIVE CONFLICT error will be generated.
  169. C           If the file to be erased cannot be found,
  170. C           a NO FILE error will be generated.
  171. C
  172. C     Output Arguments:
  173. C     IOK ...... Returned value:
  174. C                0 = file doesn't exist
  175. C                1 = file exists
  176. C
  177.       IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N )
  178.       DIMENSION FCB (36)
  179.       DIMENSION STRING (1)
  180.       DIMENSION SUBNAM (6)
  181.       DATA CERROR /.TRUE./
  182.       DATA SUBNAM / 'E','X','I','S','T',' ' /
  183. C
  184. C                             Set Up the FCB
  185. C
  186.       LSTRNG = NBYTES
  187.       IF ( NBYTES .EQ. 0 ) LSTRNG = 11
  188.       CALL FCB$ ( STRING, LSTRNG, FCB )
  189. C
  190. C                             Get the drive number,
  191. C                             set NDR to the maximum of these values,
  192. C                             and test for any conflicts.
  193. C
  194.       NDRFCB = FCB(1)
  195.       NDR    = MAX0 ( NDRIVE, NDRFCB )
  196.       IF ( NDRFCB .LE. 0  .OR.  NDRIVE .LE. 0 ) GOTO 20
  197.       IF ( NDRIVE .NE. NDRFCB ) GOTO 90
  198. C
  199.    20 FCB(1) = NDR
  200. C
  201. C                             Call BDOS function 17
  202. C
  203.       CALL CPMF17 ( FCB, CODE )
  204.       IOK    = 1
  205.       IF ( CODE .EQ. CERROR ) IOK = 0
  206.       GOTO 100
  207. C
  208. C                             Error Handling Routines
  209. C
  210. C         DRIVE CONFLICT error
  211.    90 CALL ERROR$ ( 3, SUBNAM, FCB )
  212. C
  213. C                             Return to calling program
  214. C
  215.   100 RETURN
  216.       END
  217. C                             * * * * * * * * * *
  218. C                             *                 *
  219. C                             *   G E T C M D   *
  220. C                             *                 *
  221. C                             * * * * * * * * * *
  222. C
  223. C
  224.       SUBROUTINE GETCMD ( ARRAY )
  225. C
  226. C                ARRAY  = < byte array >
  227. C
  228. C     This routine will get the "command line tail" and pass it
  229. C     into the calling program.
  230. C     Leading blanks are stripped off.
  231. C
  232. C     The "tail" is that part of the command line that follows
  233. C     the program name.  For example, if the following line
  234. C     were typed at the console following a CP/M prompt:
  235. C
  236. C            b:foo options:a,c,d,f,l
  237. C
  238. C     the system would load program FOO.COM from drive B: and the
  239. C     "tail" would be the character string OPTIONS:A,C,D,F,L.
  240. C
  241. C     CP/M will always map the command line to upper case.
  242. C
  243. C     The user's program must interpret the "tail". All this
  244. C     routine does is pass it to the FORTRAN program, after 
  245. C     leading blanks are stripped off.
  246. C
  247. C     Some other considerations:
  248. C
  249. C         You MUST get the "tail" before any disk operations
  250. C         are performed in the program.  Otherwise, CP/M may
  251. C         overwrite the command line buffer during a disk
  252. C         operation.  Thus, you should call this routine as
  253. C         one of the first activities in your program.
  254. C
  255. C         You should scan the "tail" carefully, watching out
  256. C         for trailing and imbedded blanks.  The line
  257. C         will be passed exactly as typed except for mapping
  258. C         to upper case.
  259. C
  260. C     Input arguments:
  261. C         (none)
  262. C
  263. C     Output arguments:
  264. C     ARRAY .... This is a byte array, which must be dimensioned
  265. C                in the calling program to a length sufficient to
  266. C                hold the entire "tail".  Otherwise, important
  267. C                data or program instructions may be overwritten
  268. C                by the command line information.  Dimensioning
  269. C                the variable to 80 bytes is usually sufficient.
  270. C                The FIRST BYTE of the returned array will contain
  271. C                the number of characters to follow.  Only these
  272. C                characters are valid.  The remainder of the array
  273. C                will be unchanged from its original contents, or
  274. C                will contain "garbage".
  275. C
  276.       IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N )
  277.       DIMENSION ARRAY (1)
  278.       DATA BLANK / ' ' /
  279.       DATA ONE  / 1 /
  280.       DATA ZERO / 0 /
  281. C
  282. C                             Get the command line as typed
  283. C
  284.       CALL CPMFNA ( ARRAY )
  285. C
  286. C                             Strip off leading blanks
  287. C                             by shifting contents left one byte.
  288. C
  289.   100 IF ( ARRAY(1) .LE. ONE   ) GOTO 500
  290.       IF ( ARRAY(2) .NE. BLANK ) GOTO 500
  291.       ARRAY(1) = ARRAY(1) - ONE
  292.       NBYTES   = ARRAY(1)
  293.       DO 200 N = 1, NBYTES
  294.       N1 = N + 1
  295.       N2 = N + 2
  296.   200 ARRAY(N1) = ARRAY(N2)
  297.       GOTO 100
  298. C
  299. C                             Return, making sure a one-character
  300. C                             command isn't a blank.
  301. C
  302.   500 CONTINUE
  303.       IF ( ARRAY(1) .NE. 1 ) GOTO 550
  304.       IF ( ARRAY(2) .EQ. BLANK ) ARRAY(1) = ZERO
  305.   550 RETURN
  306.       END
  307. C                             * * * * * * * * * *
  308. C                             *                 *
  309. C                             *    I N C H R    *
  310. C                             *                 *
  311. C                             * * * * * * * * * *
  312. C
  313. C
  314.       SUBROUTINE INCHR ( NOPT, CHAR )
  315. C
  316. C                NOPT   = < integer >
  317. C                CHAR   = < byte >
  318. C
  319. C     This subroutine reads a character from the console.
  320. C     The character is immediately echoed to the console.
  321. C     It is also returned as the value of the argument CHAR.
  322. C
  323. C     If no character is pending at the console, execution
  324. C     halts until a character is typed.
  325. C
  326. C     The character is transmitted as soon as it is typed.
  327. C     The RETURN or ENTER key is not required to complete the 
  328. C     entry.
  329. C
  330. C     Input Arguments:
  331. C     NOPT ..... Option for interpretation of input character.
  332. C                (Add the following values together to determine
  333. C                 the value to use.)
  334. C                0 = (no option)
  335. C                1 = (no option)
  336. C                2 = map lower case alphabet to upper case
  337. C                4 = stop execution if ctrl-C
  338. C
  339. C     Output Arguments:
  340. C     CHAR ..... The resulting character.
  341. C
  342.       IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N )
  343. C
  344.       DATA CTRLC  / 3 /
  345. C
  346.       CALL CPMF1 ( A )
  347.       CHAR   = A
  348.       IF ( NOPT .AND. 2 )  CALL MAP$ ( A, CHAR )
  349.       IF ( (NOPT .AND. 4) .AND. (A .EQ. CTRLC) ) STOP
  350.       RETURN
  351.       END
  352. C                             * * * * * * * * * *
  353. C                             *                 *
  354. C                             *    I N K E Y    *
  355. C                             *                 *
  356. C                             * * * * * * * * * *
  357. C
  358. C
  359.       SUBROUTINE INKEY ( NOPT, CHAR )
  360. C
  361. C                NOPT   = < integer >
  362. C                CHAR   = < byte >
  363. C
  364. C     This function reads a character from the console.
  365. C     The character is not echoed to the console.
  366. C     It is returned as the value of the argument CHAR.
  367. C
  368. C     If no character is pending at the console, the
  369. C     NUL character (ASCII 0) is returned and execution
  370. C     of the program continues.
  371. C
  372. C     The character is transmitted as soon as it is typed.
  373. C     The RETURN or ENTER key is not required to complete the 
  374. C     entry.
  375. C
  376. C     Input Arguments:
  377. C     NOPT ..... Option for interpretation of input character.
  378. C                (Add the following values together to determine
  379. C                 the value to use.)
  380. C                0 = (no option)
  381. C                1 = wait for a character to be typed
  382. C                2 = map lower case alphabet to upper case
  383. C                4 = stop execution if ctrl-C
  384. C
  385. C     Output Arguments:
  386. C     CHAR ..... The resulting character.
  387. C
  388.       IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N )
  389. C
  390.       DATA CTRLC  / 3 /
  391.       DATA FF  /.TRUE./
  392.       DATA ZERO   / 0 /
  393. C
  394.    10 CALL CPMF6 ( FF, A )
  395.       IF ( (NOPT .AND. 1) .AND. (A .EQ. ZERO) )  GOTO 10
  396.       CHAR   = A
  397.       IF ( NOPT .AND. 2 ) CALL MAP$ ( A, CHAR )
  398.       IF ( (NOPT .AND. 4) .AND. (A .EQ. CTRLC) ) STOP
  399.       RETURN
  400.       END
  401. C                             * * * * * * * * * *
  402. C                             *                 *
  403. C                             *   R E N A M E   *
  404. C                             *                 *
  405. C                             * * * * * * * * * *
  406. C
  407. C
  408.       SUBROUTINE RENAME ( NDRIVE, FNOLD, FNNEW, NBOLD, NBNEW )
  409. C
  410. C                NDRIVE = < integer >
  411. C                FNOLD  = < byte array >
  412. C                FNNEW  = < byte array >
  413. C                NBOLD  = < integer >
  414. C                NBNEW  = < integer >
  415. C
  416. C     Rename a CP/M file.
  417. C
  418. C     The file being renamed should be closed before this routine
  419. C     is called.  Otherwise, duplicate FCB's will exist for the
  420. C     file and unpredictable results may occur.
  421. C
  422. C     Input Arguments:
  423. C     NDRIVE ... Drive number (1=A:, 2=B:, etc.)
  424. C                If entered as zero, then the currently-logged
  425. C                drive is used unless the FNOLD or FNNEW array
  426. C                contains a drive specification in the file name.
  427. C     FNOLD .... A byte array containing a valid CP/M file name.
  428. C     FNNEW .... A byte array containing a valid CP/M file name.
  429. C                The name may contain a drive specification if
  430. C                desired.
  431. C                FNOLD is the old name; FNNEW is the new name.
  432. C     NBOLD ... The number of bytes in the FNOLD array.
  433. C     NBNEW ... The number of bytes in the FNNEW array.
  434. C                If entered as zero, the array will be assumed
  435. C                to be 11 bytes long, with the file name blank
  436. C                filled (in the same format as for a Microsoft
  437. C                OPEN call).  In this mode, the drive cannot be
  438. C                passed in the file name.
  439. C
  440. C     Note: The drive may be specified in several ways. If more
  441. C           than one specification is used, they must all agree
  442. C           or a DRIVE CONFLICT error will be generated.
  443. C           If the new file name already exists, a FILE ALREADY
  444. C           EXISTS error will be generated.  If the old file 
  445. C           cannot be found, a NO FILE error will be generated.
  446. C
  447. C     Output Arguments:
  448. C         (none)
  449. C
  450. C
  451. C     Examples of valid calls:
  452. C
  453. C         CALL RENAME ( 0, 'b:ab.x', 'cd.y', 6, 4 )
  454. C         CALL RENAME ( 0, 'ab.x', 'b:cd.y', 4, 6 )
  455. C         CALL RENAME ( 2, 'ab.x', 'cd.y', 4, 4 )
  456. C         CALL RENAME ( 2, 'AB      X  ', 'CD      Y  ', 0, 0 )
  457. C         CALL RENAME ( NDR, FIL1, FIL2, NB1, NB2 )
  458. C
  459. C     Assuming that, in the last example, NDR = 2, FIL1 is a byte
  460. C     array containing "ab.x", FIL2 is a byte array containing
  461. C     "cd.y", NB1 = 4, and NB2 = 4,  then all of the
  462. C     examples will rename the file AB.X to CD.Y on drive B:.
  463. C
  464.       IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N )
  465. C
  466.       DIMENSION FCB (36)
  467.       DIMENSION FNOLD (1)
  468.       DIMENSION FNNEW (1)
  469.       DIMENSION SUBNAM (6)
  470. C
  471.       DATA SUBNAM / 'R','E','N','A','M','E' /
  472.       DATA ONE    / 1 /
  473.       DATA ZERO   / 0 /
  474. C
  475. C     The following data statement sets CERROR to 0FFH,
  476. C     which is the return code for an error (file not found).
  477. C
  478.       DATA CERROR /.TRUE./
  479. C
  480. C
  481. C
  482. C                             Get the drive info from each string,
  483. C                             set NDR to the maximum of these values,
  484. C                             and test for any conflicts.
  485. C
  486.       CALL FNAME$ ( FNOLD, NBOLD, NDROLD, FCB )
  487.       CALL FNAME$ ( FNNEW, NBNEW, NDRNEW, FCB )
  488.       NDR    = MAX0 ( NDRIVE, NDROLD, NDRNEW )
  489.       DRIVES = ZERO
  490.       IF ( NDROLD .GT. 0      ) DRIVES = DRIVES + ONE
  491.       IF ( NDRNEW .GT. 0      ) DRIVES = DRIVES + ONE
  492.       IF ( NDRIVE .GT. 0      ) DRIVES = DRIVES + ONE
  493.       IF ( DRIVES .LE. ONE    ) GOTO 20
  494.       IF ( NDRIVE .LE. 0      ) GOTO 10
  495. C         NDRIVE was specified, so compare to it
  496.       DRIVES = DRIVES - ONE
  497.       IF ( NDROLD .LE. 0      ) GOTO  5
  498.       IF ( NDRIVE .NE. NDROLD ) GOTO 90
  499.     5 IF ( NDRNEW .LE. 0      ) GOTO 10
  500.       IF ( NDRIVE .NE. NDRNEW ) GOTO 90
  501. C         See if the two string drives need to be tested
  502. C         and do it.
  503.    10 IF ( DRIVES .LE. ONE    ) GOTO 20
  504.       IF ( NDROLD .NE. NDRNEW ) GOTO 90
  505. C
  506. C                             See if the New File already exists
  507. C
  508.    20 CONTINUE
  509.       CALL FCB$ ( FNNEW, NBNEW, FCB )
  510.       FCB(1) = NDR
  511.       CALL CPMF17 ( FCB, CODE )
  512.       IF ( CODE .NE. CERROR ) GOTO 80
  513. C
  514. C                             Perform the RENAME operation
  515. C                             by setting up the proper format
  516. C                             for the FCB.
  517. C
  518.       LSTRNG = NBOLD
  519.       IF ( NBOLD .EQ. 0 ) LSTRNG = 11
  520.       CALL FCB$ ( FNOLD, LSTRNG, FCB )
  521.       LSTRNG = NBNEW
  522.       IF ( NBNEW .EQ. 0 ) LSTRNG = 11
  523.       CALL FNAME$ ( FNNEW, NBNEW, NDRNEW, FCB(17) )
  524.       FCB(17) = ZERO
  525. C
  526. C                             Call BDOS function 23
  527. C
  528.       CALL CPMF23 ( FCB, CODE )
  529. C
  530. C                             Error handling routines
  531. C
  532. C         RENAME function error
  533.       IF ( CODE .NE. CERROR ) GOTO 100
  534.       CALL ERROR$ ( 1, SUBNAM, FCB )
  535.       GOTO 100
  536. C         NEW FILE EXISTS error
  537.    80 CALL ERROR$ ( 2, SUBNAM, FCB )
  538.       GOTO 100
  539. C         DRIVE CONFLICT error
  540.    90 CALL ERROR$ ( 3, SUBNAM, FCB )
  541. C
  542. C                             Return to calling program
  543. C
  544.   100 RETURN
  545.       END
  546. C
  547. C
  548. C + + + + + + + + + + + + + + LOW  LEVEL ROUTINES + + + + + + + + + + + + + +
  549. C
  550. C                             Service Routines for
  551. C                             High-Level Routines
  552. C
  553. C
  554. C
  555. C                             * * * * * * * * * *
  556. C                             *                 *
  557. C                             *     F C B $     *
  558. C                             *                 *
  559. C                             * * * * * * * * * *
  560. C
  561. C
  562.       SUBROUTINE FCB$ ( STRING, LSTRNG, FCB )
  563. C
  564. C                STRING = < byte array >
  565. C                LSTRNG = < integer >
  566. C                FCB    = < byte array >
  567. C
  568. C     Subroutine to build a valid File Control Block (FCB)
  569. C
  570. C     Input arguments:
  571. C     STRING ... Input string ( a byte array ) of length LSTRNG
  572. C     LSTRNG ... Integer value is length of STRING array in bytes.
  573. C
  574. C     Output arguments:
  575. C     FCB ...... The completed FCB ( a byte array ) which must
  576. C                be 36 bytes long.  The first 12 bytes will be
  577. C                initialized to the drive and file specified
  578. C                in STRING. The remainder will be zeroed.
  579. C
  580.       IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N )
  581.       DIMENSION STRING(LSTRNG)
  582.       DIMENSION FCB(36)
  583.       DATA ZERO   / 0 /
  584. C
  585. C                             Zero the FCB array
  586. C
  587.       DO 100 K = 1, 36
  588.   100 FCB(K) = ZERO
  589. C
  590. C                             Fill out the file information
  591. C
  592.       CALL FNAME$ ( STRING, LSTRNG, NDRIVE, FCB )
  593. C
  594. C                             That's all, folks.
  595. C
  596.       RETURN
  597.       END
  598. C                             * * * * * * * * * *
  599. C                             *                 *
  600. C                             *   F N A M E $   *
  601. C                             *                 *
  602. C                             * * * * * * * * * *
  603. C
  604. C
  605.       SUBROUTINE FNAME$ ( STRING, LSTRNG, NDRIVE, FILNAM )
  606. C
  607. C                STRING = < byte array >
  608. C                LSTRNG = < integer >
  609. C                NDRIVE = < integer >
  610. C                FILNAM = < byte array >
  611. C
  612. C     Subroutine to extract a CP/M file name from an input
  613. C     character string.
  614. C     Complete error trapping is NOT included in this routine.
  615. C     Thus, the programmer should excercize some caution in
  616. C     the use of this routine.
  617. C     Asterisks (*) are expanded into questions for the file
  618. C     name and file type, and drive information is extracted
  619. C     if it is included in the string as the first character
  620. C     followed by a colon (:).
  621. C     Thus, all valid CP/M file descriptions will be handled
  622. C     properly.
  623. C
  624. C     Input Arguments:
  625. C     STRING ... Input string ( a byte array ) of length LSTRNG
  626. C     LSTRNG ... Integer value is length of STRING array in bytes.
  627. C
  628. C     Output Arguments:
  629. C     NDRIVE ... Integer value of drive number:
  630. C                0 = logged in drive
  631. C                1 = drive A:
  632. C                2 = drive B:
  633. C                etc.
  634. C     FILNAM ... Output string ( a byte array ) of length 12.
  635. C                The first byte duplicates the drive value in
  636. C                NDRIVE.  The remaining bytes are the name and
  637. C                extension, blank-filled to exactly 11 characters.
  638. C
  639. C     The format of the output arguments is such that they serve
  640. C     two purposes:
  641. C
  642. C     1) To construct a Microsoft FORTRAN call to the OPEN subroutine,
  643. C        use the form:
  644. C            CALL OPEN ( lun, FILNAM(2), NDRIVE )
  645. C        where 'lun' is the unit number.  Specifying FILNAM(2) in
  646. C        the argument list passes the address of the second element
  647. C        which is the first character of the 11-byte file name.
  648. C
  649. C     2) To construct a CP/M file control block (FCB), use the
  650. C        FILNAM array as the first 12 bytes of the FCB, and the
  651. C        drive specification will be placed in the first byte as
  652. C        required.
  653. C
  654. C
  655. C
  656.       IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N )
  657. C
  658. C
  659.       DIMENSION FILNAM(12)
  660.       DIMENSION STRING(LSTRNG)
  661.       DIMENSION WORKER(14)
  662. C
  663. C
  664.       DATA BLANK  / ' ' /
  665.       DATA COLON  / ':' /
  666.       DATA PERIOD / '.' /
  667.       DATA QUEST  / '?' /
  668.       DATA STAR   / '*' /
  669. C
  670. C                             First, transfer STRING to WORKER array
  671. C                             and map any lower case to upper case.
  672. C
  673. C         Blank-fill WORKER
  674. C         Blank-fill FILNAM
  675. C
  676.       NDRIVE  = 0
  677. C
  678.       DO 10 K = 1, 12
  679.       WORKER(K)  = BLANK
  680.    10 FILNAM(K)  = BLANK
  681. C
  682.       WORKER(13) = BLANK
  683.       WORKER(14) = BLANK
  684.       FILNAM( 1) = NDRIVE
  685. C
  686. C         Search for first non-blank in STRING
  687. C
  688.       KSTART = 0
  689. C
  690.       DO 20 K = 1, LSTRNG
  691.       IF ( STRING(K) .EQ. BLANK ) GOTO 20
  692.       KSTART = K
  693.       GOTO 50
  694.    20 CONTINUE
  695. C
  696.       GOTO 300
  697. C
  698. C         Transfer STRING into WORKER
  699. C         starting at first non-blank.
  700. C         Mapping to upper case takes place here.
  701. C         Also, search for PERIOD character.
  702. C
  703.    50 KOUNT  = 0
  704.       KDOT   = 0
  705. C
  706.       DO 100 K = KSTART, LSTRNG
  707.       KOUNT  = KOUNT + 1
  708.       IF ( KOUNT .GT. 14 ) GOTO 110
  709.       WORKER(KOUNT) = STRING(K)
  710.       IF ( WORKER(KOUNT) .EQ. PERIOD ) KDOT   = KOUNT
  711.       CALL MAP$ ( WORKER(KOUNT), WORKER(KOUNT) )
  712.  100  CONTINUE
  713. C
  714. C                             Then, check for drive specification.
  715. C                             This is true only if the second character
  716. C                             is a colon.
  717. C
  718.   110 NDRIVE = 0
  719.       KSTART = 1
  720.       IF ( WORKER(2) .NE. COLON ) GOTO 200
  721.       KSTART = 3
  722. C
  723. C     Drive is specified.  Convert as follows:
  724. C
  725. C         A:  or  0:  set to  1
  726. C         B:  or  1:  set to  2
  727. C         C:  or  2:  set to  3
  728. C         D:  or  3:  set to  4
  729. C
  730.       IF ( WORKER(1) .GE. 65 ) WORKER(1) = WORKER(1) - 17
  731.       NDRIVE = WORKER(1) - 47
  732. C
  733. C                             Set up the FILNAM vector.
  734. C
  735.  200  CONTINUE
  736.       FILNAM(1) = NDRIVE
  737. C
  738. C         Transfer the file name (first 8 characters).
  739. C         Test to see if first character is a star (*).
  740. C         If so, make file name all questions (?).
  741. C
  742.       KOUNT  = 1
  743.       KSTOP  = KSTART + 7
  744.       QSTAR  = .FALSE.
  745.       IF ( WORKER(KSTART) .EQ. STAR ) QSTAR = .TRUE.
  746. C
  747.       DO 210 K = KSTART, KSTOP
  748.       KOUNT  = KOUNT + 1
  749.       KSAVE  = K
  750.       IF ( QSTAR ) GOTO 205
  751.       IF ( WORKER(K) .EQ. PERIOD ) GOTO 220
  752.       FILNAM(KOUNT) = WORKER(K)
  753.       GOTO 210
  754.   205 FILNAM(KOUNT) = QUEST
  755.   210 CONTINUE
  756. C
  757. C         Transfer the file type (last 3 characters).
  758. C         Test to see if first character is a star (*).
  759. C         If so, make file type all questions (?).
  760. C
  761.   220 KOUNT  = 9
  762.       KSTART = KSAVE + 1
  763.       IF ( KDOT .GT. 0 ) KSTART = KDOT + 1
  764.       KSTOP  = KSTART + 2
  765.       QSTAR  = .FALSE.
  766.       IF ( WORKER(KSTART) .EQ. STAR ) QSTAR = .TRUE.
  767. C
  768.       DO 250 K = KSTART, KSTOP
  769.       KOUNT  = KOUNT + 1
  770.       IF ( QSTAR ) GOTO 240
  771.       FILNAM(KOUNT) = WORKER(K)
  772.       GOTO 250
  773.   240 FILNAM(KOUNT) = QUEST
  774.   250 CONTINUE
  775. C
  776. C                             That's all, folks!
  777. C
  778.  300  CONTINUE
  779.       RETURN
  780.       END
  781. C                             * * * * * * * * * *
  782. C                             *                 *
  783. C                             *     M A P $     *
  784. C                             *                 *
  785. C                             * * * * * * * * * *
  786. C
  787. C
  788.       SUBROUTINE MAP$ ( AIN, AOUT )
  789. C
  790. C                AIN    = < byte >
  791. C                AOUT   = < byte >
  792. C
  793. C     Map a lower case character to upper case.
  794. C
  795. C     If the input character is not a lower case alphabet
  796. C     character, no mapping takes place.
  797. C
  798. C     Input Arguments:
  799. C     AIN ..... The one-byte value to be mapped.
  800. C
  801. C     Output Arguments:
  802. C     AOUT .... The one-byte value mapped to u.c.
  803. C
  804.       IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N )
  805. C
  806.       DATA ALOWER / 'a' /
  807.       DATA AOFSET /  32 /
  808.       DATA ZLOWER / 'z' /
  809. C
  810.       IF ( AIN .LT. ALOWER ) GOTO 100
  811.       IF ( AIN .GT. ZLOWER ) GOTO 100
  812.       AOUT = AIN - AOFSET
  813.  100  RETURN
  814.       END
  815. C                             * * * * * * * * * *
  816. C                             *                 *
  817. C                             *   E R R O R $   *
  818. C                             *                 *
  819. C                             * * * * * * * * * *
  820. C
  821. C
  822.       SUBROUTINE ERROR$ ( NERROR, ANAME, ARRAY )
  823. C
  824. C                NERROR = < integer >
  825. C                ANAME  = < byte array >
  826. C                ARRAY  = < byte array >
  827. C
  828. C
  829. C     Error printing routine.
  830. C
  831. C     Input Arguments:
  832. C     NERROR ... Number of the error message to print.
  833. C     ANAME .... A six-byte name for the routine which called
  834. C                the error.
  835. C     ARRAY .... A byte array, the contents of which depend on
  836. C                the error being processed.
  837. C
  838. C     Output Arguments:
  839. C         (none)
  840. C
  841.       IMPLICIT LOGICAL*1 ( A-H, O-Z ), INTEGER ( I-N )
  842.       DIMENSION ANAME(6), ARRAY(1)
  843. C         The ALPHA variable maps the drive number to upper
  844. C         case alphabet.
  845.       DATA ALPHA / 64 /
  846. C         The LIO variable defines the output device for error
  847. C         messages.  Device 3 is the default device used by
  848. C         Microsoft for FORTRAN run-time errors.
  849.       DATA LIO  / 3 /
  850. C         The NMAX variable defines the maximum error code
  851. C         available in this version.
  852.       DATA NMAX / 3 /
  853.       DATA ZERO / 0 /
  854. C
  855. C
  856.       IF ( NERROR .LT. 1  .OR.  NERROR .GT. NMAX ) GOTO 500
  857.       GOTO ( 10, 20, 30 ), NERROR
  858. C
  859. C                             FILE NOT FOUND error
  860. C
  861.    10 IF ( ARRAY(1) .EQ. ZERO ) GOTO 11
  862.       DRIVE = ARRAY(1) + ALPHA
  863.       WRITE ( LIO, 9010 )  (ANAME(J), J = 1, 6), DRIVE,
  864.      A                     (ARRAY(J), J = 2, 12)
  865.       GOTO 1000
  866.    11 WRITE ( LIO, 9011 )  (ANAME(J), J = 1, 6),
  867.      A                     (ARRAY(J), J = 2, 12)
  868.       GOTO 1000
  869. C
  870. C                            FILE ALREADY EXISTS error
  871. C
  872.    20 IF ( ARRAY(1) .EQ. ZERO ) GOTO 21
  873.       DRIVE = ARRAY(1) + ALPHA
  874.       WRITE ( LIO, 9020 )  (ANAME(J), J = 1, 6), DRIVE,
  875.      A                     (ARRAY(J), J = 2, 12)
  876.       GOTO 1000
  877.    21 WRITE ( LIO, 9021 )  (ANAME(J), J = 1, 6),
  878.      A                     (ARRAY(J), J = 2, 12)
  879.       GOTO 1000
  880. C
  881. C                             DRIVE CONFLICT error
  882. C
  883.    30 WRITE ( LIO, 9030 ) (ANAME(J), J = 1, 6)
  884.       GOTO 1000
  885. C
  886. C                             Undefined Error
  887. C
  888.   500 WRITE ( LIO, 9500 )  (ANAME(J), J = 1, 6)
  889. C
  890. C                             Return to calling routine
  891. C
  892.  1000 RETURN
  893. C
  894. C                             Formats
  895. C
  896.  9010 FORMAT (1X, 6A1, ' error - no file ', A1, ': ', 11A1 )
  897.  9011 FORMAT (1X, 6A1, ' error - no file ', 11A1 )
  898.  9020 FORMAT (1X, 6A1, ' error - ', A1, ':',
  899.      A        11A1, ' already exists.')
  900.  9021 FORMAT (1X, 6A1, ' error - ',
  901.      A        11A1, ' already exists.')
  902.  9030 FORMAT (1X, 6A1, ' error - drive conflict.')
  903.  9500 FORMAT (1X, 6A1, ' - undefined error.')
  904.       END
  905.