home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol115 / cpmdec.for < prev    next >
Encoding:
Text File  |  1984-04-29  |  22.6 KB  |  855 lines
  1. C************************************************
  2. C*                                              *
  3. C*  CPMDEC--CP/M TO DEC DISK TRANSLATER         *
  4. C*                                              *
  5. C*  NOTE:  MUST BE COMPILED '/NOSWAP'           *
  6. C*                                              *
  7. C*  PROCESSING SCHEME:                          *
  8. C*    THE (SINGLE DENSITY) CP/M DISK IS PHYS-   *
  9. C*    ICALLY THE SAME AS AN RX-01 DISK.         *
  10. C*    THUS WE OPEN DY1: AS A NON-FILE STRUC-    *
  11. C*    TURED DEVICE AND READ IT WITH THE SYSTEM  *
  12. C*    CALL ISPFNW, DOING OUR OWN INTERLEAVING.  *
  13. C*                                              *
  14. C*    RX-01 READS 64 WORD SECTORS (128 BYTES,   *
  15. C*    SAME AS IBM AND CP/M).  THE ISPFNW CALL   *
  16. C*    ALLOWS READING AND WRITING ABSOLUTE       *
  17. C*    PHYSICAL SECTORS.                         *
  18. C*                                              *
  19. C*    MORE INFORMATION ON RX-01 FORMAT DISKS IS *
  20. C*    IN THE DEC PERIPHERALS HANDBOOK.          *
  21. C*                                              *
  22. C*    EACH DISK CONTAINS 77 TRACKS (0..76), OF  *
  23. C*    26 SECTORS EACH.  CP/M INTERLEAVES THE    *
  24. C*    SECTORS; THIS IS TAKEN CARE OF IN SUB     *
  25. C*    DOSEC.  RX-01 USES A DIFFERENT INTERLEAVE *
  26. C*    SCHEME; BUT THIS IS OF NO CONCERN TO US   *
  27. C*    BECAUSE ISPFNW READS ABSOLUTE PHYSICAL    *
  28. C*    SECTORS.                                  *
  29. C*                                              *
  30. C*    CP/M GROUPS 8 LOGICAL SECTORS INTO A      *
  31. C*    CLUSTER (1K) NUMBERED 0..240.  CLUSTERS   *
  32. C*    ARE NUMBERED SEQUENTIALLY STARTING ON     *
  33. C*    TRACK 2; THE DIRECTORY (2K) IS CLUSTERS   *
  34. C*    0 AND 1.  TRACKS 0 AND 1 ARE SYSTEM       *
  35. C*    TRACKS.                                   *
  36. C*                                              *
  37. C*    EACH DIRECTORY ENTRY IS 32 BYTES:         *
  38. C*      1:  0 IF ACTIVE, 0E5H ("345) INACTIVE   *
  39. C*      2-9:  FILE NAME                         *
  40. C*      10-12:  FILE TYPE                       *
  41. C*      13:  EXTENT # [0...]                    *
  42. C*      14-15:  OF NO CONCERN TO US             *
  43. C*      16:  # OF SECTORS IN THIS EXTENT        *
  44. C*        (0..128)                              *
  45. C*      17-32:  NUMBERS, IN ORDER USED, OF UP   *
  46. C*        TO 16 CLUSTERS. (IF FILE IS OVER 16K, *
  47. C*        ANOTHER DIRECTORY ENTRY IS CREATED    *
  48. C*        WITH THE EXTENT # INCREMENTED; AND UP *
  49. C*        TO 16 MORE CLUSTERS ASSIGNED). UNUSED *
  50. C*        CLUSTER ENTRIES ARE 0.                *
  51. C*                                              *
  52. C*  RUSS BAKKE                02-17-83          *
  53. C*                                              *
  54. C************************************************
  55. C
  56.     PROGRAM CPMDEC
  57. C
  58.     BYTE DIR(32,64),CNAME(12),DNAME(16),LBUFF(80)
  59.     BYTE BITMAP(256),DBUFF(1024),MODE(6)
  60.     COMMON DIR
  61.     DATA DNAME/ 'D','Y','0',':',12*0/
  62.     DATA BITMAP/ 2*1,254*0/, MODE /'A','S','C','I','I',' '/
  63. C
  64.     TYPE 100
  65.   100    FORMAT (1X,'CP/M DISK READER, V1.0'//
  66.      +    1X,'INSERT CP/M DISK IN DY1: AND PRESS RETURN'/)
  67.     ACCEPT 104,IWANT
  68. C
  69. C OPEN CP/M DISK AS NON-FILE STRUCTURED DEVICE:
  70.     CALL DSKOPN(ICHAN)
  71. C
  72. C
  73.    10    IPRINT=0
  74.     TYPE 102,MODE
  75.   102    FORMAT (/,1X,'COPY MODE IS ',6A1,/,
  76.      +    1X,'ENTER NUMBER OF OPTION DESIRED:',/,
  77.      +    1X,'1.  DISPLAY CP/M DIRECTORY.',/,
  78.      +    1X,'2.  PRINT CP/M DIRECTORY.',/,
  79.      +    1X,'3.  COPY A FILE FROM CP/M DISK.',/,
  80.      +    1X,'4.  COPY ALL FILES FROM CP/M DISK TO DY0:',/,
  81.      +    1X,'5.  INITIALIZE A CP/M DISK.',/,
  82.      +    1X,'6.  DELETE A FILE FROM CP/M DISK.',/,
  83.      +    1X,'7.  COPY FILE TO CP/M DISK.',/,
  84.      +    1X,'8.  CHANGE COPY MODE.',/,
  85.      +    1X,'9.  QUIT.')
  86.     ACCEPT 104,IWANT
  87.   104    FORMAT (I2)
  88.     IF (IWANT .LT. 1 .OR. IWANT .GT. 9) GOTO 10
  89.     IF (IWANT .EQ. 1) GOTO 11
  90.     IF (IWANT .EQ. 3) GOTO 30
  91.     IF (IWANT .EQ. 4) GOTO 40
  92.     IF (IWANT .EQ. 5) GOTO 50
  93.     IF (IWANT .EQ. 6) GOTO 60
  94.     IF (IWANT .EQ. 7) GOTO 70
  95.     IF (IWANT .EQ. 8) GOTO 62
  96.     IF (IWANT .EQ. 9) GOTO 99
  97. C
  98. C  FALL THROUGH IS 2 (PRINT DIRECTORY OF CP/M DISK)
  99.     IPRINT=1
  100. C
  101. C  DISPLAY DIRECTORY
  102.    11    CALL GETDIR(ICHAN)    !READ DIRECTORY
  103.     ITOTAL=0
  104. C
  105. C  DISPLAY DIRECTORY
  106.     DO 12 I=1,80    !CLEAR LBUFF
  107.     LBUFF(I) = ' '
  108.    12    C O N T I N U E
  109.     IBFPTR = 0
  110. C
  111.     DO 24 INDEX=1,64
  112.     IF (DIR(1,INDEX) .EQ. "345) GOTO 24    !EMPTY ENTRY
  113.     IF (DIR(13,INDEX) .NE. 0) GOTO 24    !LATER EXTENT
  114.     ISIZE = DIR(16,INDEX)
  115.     IF (ISIZE .LT. 0) ISIZE=ISIZE+256
  116.     IF (ISIZE .EQ. 128) GOTO 14    !MULTIPLE EXTENTS
  117.     ISIZE = (ISIZE+7)/8
  118.     GOTO 22
  119. C
  120. C  MULTIPLE EXTENT FILE; MUST GET SIZE FROM LATER EXTENTS
  121.    14    DO 16 IPTR=2,12
  122.     CNAME(IPTR-1)=DIR(IPTR,INDEX)
  123.    16    C O N T I N U E
  124.     IEXT=1
  125.    18    ISIZE=0
  126.     CALL FIND (CNAME,IEXT,IENTRY)
  127.     IF (IENTRY .EQ. -1) GOTO 20    !NO MORE EXTENTS
  128.     ISIZE=DIR(16,IENTRY)
  129.     IF (ISIZE .LT. 0) ISIZE=ISIZE+256
  130.     IF (ISIZE .NE. 128) GOTO 20    !NO MORE EXTENTS
  131.     IEXT=IEXT+1
  132.     GOTO 18
  133. C
  134.    20    ISIZE=(ISIZE+7)/8 + 16*IEXT
  135. C
  136.    22    ENCODE(16,120,LBUFF(18*IBFPTR+2))
  137.      +    (DIR(J,INDEX),J=2,12),ISIZE
  138.   120    FORMAT (8A,'.',3A,I3,'K')
  139.     ITOTAL=ITOTAL+ISIZE
  140.     IBFPTR = IBFPTR+1
  141.     IF (IBFPTR .LE. 3) GOTO 24
  142. C
  143. C  NEED TO PRINT & CLEAR LBUFF
  144.     IF (IPRINT .EQ. 0) TYPE 122,LBUFF
  145.     IF (IPRINT .EQ. 1) PRINT 122,LBUFF
  146.   122    FORMAT (1X,80A1)
  147.     DO 23 I=1,80
  148.     LBUFF(I) = ' '
  149.    23    C O N T I N U E
  150.     IBFPTR = 0
  151. C
  152.    24    C O N T I N U E
  153.     IF (IPRINT .EQ. 1) GOTO 25
  154.     TYPE 122,LBUFF
  155.     TYPE *,'TOTAL BYTES = ',ITOTAL,'K'
  156.     GOTO 10
  157. C
  158.    25    PRINT 122,LBUFF
  159.     PRINT *,'TOTAL BYTES = ',ITOTAL,'K'
  160.     GOTO 10
  161. C
  162. C COPY A FILE FROM CP/M DISK
  163. C
  164. C GET CP/M NAME
  165.    30    CALL GTCPMF(CNAME)
  166.     CALL GETDIR(ICHAN)
  167. C
  168. C  LOOKUP CNAME IN DISK DIR
  169.     CALL FIND(CNAME,0,IENTRY)
  170.     IF (IENTRY .NE. -1) GOTO 32    !OK
  171.    31    TYPE *,'FILE NOT FOUND'
  172.     GOTO 10
  173. C
  174. C  GET DEC NAME & OPEN
  175.    32    CALL GETFN('OUTPUT',IDCHAN)
  176. C  READ FILE AND WRITE TO DEC
  177.     CALL CPYFIL(IENTRY,CNAME,ICHAN,IDCHAN,MODE(1))
  178. C
  179. C  CPYFIL CLOSES AND FREES THE CHANNEL
  180.    34    TYPE *,'COPY COMPLETED'
  181.     GOTO 10
  182. C
  183. C
  184. C  COPY ALL FILES FROM CP/M DISK TO DY0:
  185.    40    TYPE *,'INSERT BLANK DEC DISK IN DY0: AND PRESS RETURN'
  186.     ACCEPT 104,IWANT
  187.     CALL GETDIR(ICHAN)
  188.     DO 48 IENTRY=1,64
  189.     IF (DIR(1,IENTRY) .EQ. "345) GOTO 48
  190.     IF (DIR(13,IENTRY) .NE. 0) GOTO 48
  191.     DO 42 IPTR=2,12
  192.     CNAME(IPTR-1)=DIR(IPTR,IENTRY)    !SAVE NAME
  193.    42    C O N T I N U E
  194. C  NOW CONVERT CNAME INTO DEC NAME, IN DNAME
  195.     DO 44 IPTR=1,6
  196.     IF (CNAME(IPTR) .EQ. ' ') GOTO 46
  197.     DNAME(IPTR+4) = CNAME(IPTR)
  198.    44    C O N T I N U E
  199.    46    DNAME(IPTR+4)='.'
  200.     DNAME(IPTR+5) = CNAME(9)
  201.     DNAME(IPTR+6) = CNAME(10)
  202.     DNAME(IPTR+7) = CNAME(11)
  203.     DNAME(IPTR+8) = 0
  204.     DNAME(4)=':'
  205. C
  206.     TYPE 124,(CNAME(J),J=1,11),DNAME
  207.   124    FORMAT (1X,'COPYING CP/M FILE ',8A,'.',3A,'  TO DEC FILE ',16A)
  208. C
  209. C  NOW OPEN DEC FILE (AS CHANNEL IDCHAN)
  210.     CALL DECOPN(DNAME,IDCHAN,'O')
  211.     IFILE=IENTRY
  212.     CALL CPYFIL(IFILE,CNAME,ICHAN,IDCHAN,MODE(1))
  213.    48    C O N T I N U E
  214.     GOTO 34
  215. C
  216. C
  217. C  INITIALIZE A CP/M DISK
  218.    50    TYPE *,'INITIALIZE--ARE YOU SURE?'
  219.     ACCEPT 126,IWANT
  220.   126    FORMAT(A1)
  221.     IF (IWANT .NE. 'Y') GOTO 10
  222. C
  223. C  (WRITE E5H THROUGHOUT DIRECTORY)
  224.     DO 54 I=1,32
  225.     DO 52 J=1,64
  226.     DIR(I,J)="345
  227.    52    C O N T I N U E
  228.    54    C O N T I N U E
  229.    56    CALL PUTDIR(ICHAN)
  230.     TYPE *,'COMPLETED'
  231.     GOTO 10
  232. C
  233. C
  234. C  DELETE A CP/M FILE
  235.    60    CALL GTCPMF(CNAME)
  236.     CALL ERASE(CNAME,ICHAN,ISTAT)
  237.     IF (ISTAT .EQ. -1) GOTO 31    !UNSUCCESSFUL
  238.     GOTO 56        !WRITE DIR & RET TO MENU
  239. C
  240. C
  241. C  TOGGLE COPY MODE
  242.    62    IF (MODE(1) .EQ. 'A') GOTO 64
  243.     MODE(1) = 'A'
  244.     MODE(2) = 'S'
  245.     MODE(3) = 'C'
  246.     MODE(4) = 'I'
  247.     MODE(5) = 'I'
  248.     MODE(6) = ' '
  249.     GOTO 10
  250. C
  251.    64    MODE(1) = 'B'
  252.     MODE(2) = 'I'
  253.     MODE(3) = 'N'
  254.     MODE(4) = 'A'
  255.     MODE(5) = 'R'
  256.     MODE(6) = 'Y'
  257.     GOTO 10
  258. C
  259. C
  260. C  WRITE A CP/M FILE
  261. C  GET DEC NAME & OPEN
  262.    70    CALL GETFN('INPUT ',IDCHAN)
  263.     IDBLK=0
  264. C  GET CP/M FILE NAME
  265.     CALL GTCPMF(CNAME)
  266. C
  267. C  IF WE ALREADY HAVE A FILE BY THIS NAME, ERASE IT
  268.     CALL ERASE(CNAME,ICHAN,ISTAT)
  269. C
  270. C  NOW FOR THE HARD PART.
  271. C  WE MUST READ THE CP/M DIRECTORY; MAKE A BIT MAP
  272. C  (ACTUALLY BYTE MAP) OF CLUSTERS USED; CREATE A
  273. C  CP/M DIRECTORY ENTRY; ASSIGN EACH CLUSTER, READ
  274. C  8*128 BYTES WITH IREADW AND WRITE THEM TO THE
  275. C  CP/M DISK.
  276. C
  277.     DO 72 I=1,64
  278.     IF (DIR(1,I) .EQ. "345) GOTO 72    !NOT ALLOCATED
  279.     DO 71 J=17,32
  280.     IDIREN=DIR(J,I)
  281.     IF (IDIREN .EQ. 0) GOTO 72    !NOT ALLOCATED
  282.     IF (IDIREN .LT. 0) IDIREN = IDIREN+256
  283.     IF (IDIREN .LT.0 .OR. IDIREN .GT. 255) STOP 'MAP ERROR'
  284.     BITMAP (IDIREN+1) = 1
  285.    71    C O N T I N U E
  286.    72    C O N T I N U E
  287. C
  288. C  NOW FIND AN OPEN DIR ENTRY
  289.     IEXT=0
  290.    73    DO 74 IENTRY=1,64
  291.     IF (DIR(1,IENTRY) .EQ. "345) GOTO 75
  292.    74    C O N T I N U E
  293.     STOP 'DIRECTORY FULL'
  294. C
  295. C  COPY IN FILE NAME
  296.    75    DIR(1,IENTRY)=0
  297.     DO 76 J=2,12
  298.     DIR(J,IENTRY)=CNAME(J-1)
  299.    76    C O N T I N U E
  300.     DO 77 J=13,32
  301.     DIR(J,IENTRY)=0
  302.    77    C O N T I N U E
  303.     IBLK=1
  304.     ISIZE=0
  305.     DIR(13,IENTRY)=IEXT
  306. C
  307. C ALLOCATE A CLUSTER
  308.    78    DO 79 ICLU=3,241
  309.     IF (BITMAP(ICLU) .EQ. 0) GOTO 80    !FOUND A FREE CLUSTER
  310.    79    C O N T I N U E
  311.     STOP 'CP/M DISK FULL'
  312. C
  313. C  WRITE CLUSTER NUMBER TO DIRECTORY
  314.    80    BITMAP(ICLU)=1
  315.     ICLU=ICLU-1        !0-255 NOT 1-256
  316.     DIR(IBLK+16,IENTRY)=ICLU
  317. C  CONVERT CLUSTER # TO SECTOR AND TRACK
  318.     ITEMP=8*ICLU
  319.     ISTTRK=ITEMP/26
  320.     ISTART=ITEMP-26*ISTTRK+1
  321.     ISTTRK=ISTTRK+2
  322. C
  323. C  READ 8 SECTORS FROM DEC DISK
  324.     IRET=IREADW(512,DBUFF,IDBLK,IDCHAN)
  325.     IDBLK=IDBLK+2
  326. C  ERRORS ARE:
  327. C  -1: EOF
  328. C  -2: HARDWARE ERROR
  329. C  -3: CHANNEL NOT OPEN
  330. C  OR IF IRET = 256, ONLY 1 BLOCK READ
  331.     IF (IRET .EQ. 256) GOTO 96    !1 BLOCK
  332.     IF (IRET .GE. 0) GOTO 81
  333.     IF (IRET .EQ. -1) GOTO 97    !EOF
  334.     TYPE *,'IREAD ERROR TYPE ',IRET
  335.     STOP
  336. C
  337. C  WRITE 8 SECTORS
  338.    81    ILIMIT=7
  339.    83    IF (MODE(1) .EQ. 'B') GOTO 93
  340. C
  341. C  FIND EOF, INSERT CTL-Z (CP/M EOF)
  342.     DO 84 INDEX2=128*(ILIMIT+1),1,-1
  343.     IF (DBUFF(INDEX2) .NE. 0) GOTO 85
  344.    84    C O N T I N U E
  345.    85    IF (INDEX2 .LT. 128*(ILIMIT+1)) DBUFF(INDEX2+1) = 26 !CTL-Z
  346. C
  347.    93    DO 95 ISEC=0,ILIMIT
  348.     ITEMP=ISTART+ISEC
  349.     ITRK=ISTTRK
  350.     IF (ITEMP .LE. 26) GOTO 94
  351.     ITEMP=ITEMP-26
  352.     ITRK=ITRK+1
  353.    94    CALL DOSEC('W',ITRK,ITEMP,DBUFF(128*ISEC+1),ICHAN)
  354.     ISIZE=ISIZE+1
  355.    95    C O N T I N U E
  356.     IF (IRET .EQ. 0) GOTO 97
  357. C
  358. C  NEED ANOTHER CLUSTER
  359.     IBLK=IBLK+1
  360.     IF (IBLK .LE. 16) GOTO 78
  361. C  NEED A NEW EXTENT
  362.     DIR(16,IENTRY)=128    !SET SECTOR COUNT
  363.     IEXT=IEXT+1
  364.     TYPE *,'WORKING. . .'
  365.     GOTO 73
  366. C
  367. C  ONLY 4 SECTORS READ FROM DEC FILE
  368.    96    ILIMIT=3
  369.     IRET=0
  370.     GOTO 83
  371. C
  372. C  THAT'S ALL
  373.    97    DIR(16,IENTRY)= ISIZE    !SET SIZE
  374. C  WRITE OUT DIRECTORY
  375.     CALL PUTDIR(ICHAN)
  376.     CALL ICLOSE(IDCHAN)
  377.     CALL IFREEC(IDCHAN)
  378.     GOTO 34
  379. C
  380. C
  381. C  CLOSE
  382.    99    CALL ICLOSE (ICHAN)
  383.     CALL IFREEC (ICHAN)
  384.     CALL EXIT
  385.     END
  386. C
  387.     SUBROUTINE DSKOPN (IDCH)
  388. C****************************************************
  389. C*                                                  *
  390. C*  OPEN FLOPPY DISK DRIVE 1 AS NON-FILE            *
  391. C*  STRUCTURED DEVICE; RETURN CHANNEL NO. IN IDCH.  *
  392. C*                                                  *
  393. C*  RUSS BAKKE                      02-10-83        *
  394. C*                                                  *
  395. C****************************************************
  396. C
  397.     REAL*4 DISK1
  398.     DATA DISK1 /3RDY1   /
  399. C
  400. C  FETCH HANDLER, OPEN A CHANNEL, LOOKUP DEVICE
  401.     IF (IFETCH(DISK1) .NE. 0) STOP 'IFETCH ERROR
  402.      +    IN DSKOPN'
  403.     IDCH=IGETC()
  404.     IF(IDCH.LT.0) STOP' NO CHANNEL AVAILABLE'
  405. C
  406.     IRET = LOOKUP(IDCH,DISK1)
  407.     IF (IRET .GE. 0) GOTO 10
  408. C
  409. C  LOOKUP FAILURE
  410.     TYPE *,'LOOKUP FAILURE TYPE ',IRET
  411.     STOP
  412. C
  413.    10    RETURN
  414.     END
  415. C
  416.     SUBROUTINE GETDIR(ICHAN)
  417. C****************************************************
  418. C*                                                  *
  419. C*  READ DIRECTORY OF CP/M DISK.                    *
  420. C*                                                  *
  421. C*  THE CP/M DISK USES TRACKS 0 AND 1 FOR SYSTEM    *
  422. C*  TRACKS; WE MAY IGNORE THEM.  THE DIRECTORY IS   *
  423. C*  2K OR 16 SECTORS, STARTING ON TRACK 2.          *
  424. C*                                                  *
  425. C*  RUSS BAKKE                  05-06-82            *
  426. C*                                                  *
  427. C****************************************************
  428. C
  429.     BYTE DIR(32,64)
  430.     COMMON DIR
  431. C
  432.     DO 80 INDEX=1,16
  433.     ISECTR=INDEX
  434.     CALL DOSEC('R',2,ISECTR,DIR(1,4*(ISECTR-1)+1),ICHAN)
  435.    80    C O N T I N U E
  436.     RETURN
  437.     END
  438. C
  439.     SUBROUTINE PUTDIR(ICHAN)
  440. C****************************************************
  441. C*                                                  *
  442. C*  WRITE DIRECTORY OF CP/M DISK.                   *
  443. C*  (SIMILAR TO GETDIR).                            *
  444. C*                                                  *
  445. C*  RUSS BAKKE                  05-25-82            *
  446. C*                                                  *
  447. C****************************************************
  448. C
  449.     BYTE DIR(32,64)
  450.     COMMON DIR
  451. C
  452.     DO 80 INDEX=1,16
  453.     ISECTR=INDEX
  454.     CALL DOSEC('W',2,ISECTR,DIR(1,4*(ISECTR-1)+1),ICHAN)
  455.    80    C O N T I N U E
  456.     RETURN
  457.     END
  458. C
  459.     SUBROUTINE DOSEC(RW,ITRK,ISEC,BUFF,ICHAN)
  460. C****************************************************
  461. C*                                                  *
  462. C*  READ/WRITE (RW IS DIRECTION) LOGICAL SECTOR     *
  463. C*  'ISEC', TRACK 'ITRK', TO/FROM 'BUFF' (128       *
  464. C*   BYTES), FROM/TO CHANNEL 'ICHAN'.               *
  465. C*                                                  *
  466. C*  RUSS BAKKE                   05-12-82           *
  467. C*                                                  *
  468. C****************************************************
  469. C
  470.     BYTE BUFF(128),MYBUFF(130),RW
  471.     INTEGER ITABLE(26)
  472.     DATA ITABLE /1,7,13,19,25,5,11,17,23,3,9,15,21,2,8,
  473.      +    14,20,26,6,12,18,24,4,10,16,22/
  474. C  ITABLE IS THE CP/M SECTOR INTERLEAVE TABLE (26 SECTORS PER TRACK)
  475. C  PHYSICAL SECTOR # [1..26] = ITABLE(LOGICAL SECTOR # [1..26])
  476. C
  477.     IF (RW .EQ. 'W') GOTO 50
  478.     IRET=ISPFNW("377,ICHAN,ITRK,MYBUFF,ITABLE(ISEC))
  479. C
  480. C  THE ISPFNW CALL IS AS FOLLOWS:
  481. C  IRET=ISPFNW(FUNC,ICHAN,ITRK,BUFF,SECTOR)
  482. C    FUNC="377 FOR READ, "376 FOR WRITE
  483. C    ICHAN=CHANNEL #, FROM LOOKUP
  484. C    ITRK=ABSOLUTE PHYSICAL TRACK #, 0..76
  485. C    SECTOR=ABSOLUTE PHYSICAL SECTOR #, 1..26
  486. C    BUFF=128 BYTE BUFFER
  487. C    IRET RETURNS:
  488. C    0 NORMAL
  489. C    1  EOF
  490. C    2  HARDWARE ERROR
  491. C    3  CHANNEL NOT OPEN
  492. C
  493.     IF (IRET .EQ. 0) GOTO 40
  494.    30    TYPE 100,RW,ITRK,ISEC
  495.   100    FORMAT (1X,A,2X,'TRACK: ',I3,'   LOG. SECTOR: ',I3)
  496.     IF (IRET .EQ. 1) STOP 'CHANNEL EOF IN DOSEC'
  497.     IF (IRET .EQ. 2) STOP 'HARDWARE ERROR IN DOSEC'
  498.     IF (IRET .EQ. 3) STOP 'CHANNEL NOT OPEN IN DOSEC'
  499.     STOP 'ERROR IN DOSEC'
  500. C
  501. C  WE MUST READ INTO 130 BYTE BUFFER, BECAUSE ISPFNW READS
  502. C  LEADING 0 WORD INTO BUFFER.  (THIS IS DOCUMENTED IN THE
  503. C  SOFTWARE SUPPORT MANUAL BUT NOT IN THE PROGRAMMER'S REFERENCE).
  504.    40    DO 45 I=1,128
  505.     BUFF(I) = MYBUFF(I+2)
  506.    45    C O N T I N U E
  507.     RETURN
  508. C
  509. C  WRITING
  510.    50    DO 55 I=1,128
  511.     MYBUFF(I+2)=BUFF(I)
  512.    55    C O N T I N U E
  513.     MYBUFF(1)=0
  514.     MYBUFF(2)=0
  515. C
  516.     IRET=ISPFNW("376,ICHAN,ITRK,MYBUFF,ITABLE(ISEC))
  517.     IF (IRET .NE. 0) GOTO 30
  518.     RETURN
  519.     END
  520. C
  521.     SUBROUTINE GTCPMF(CNAME)
  522. C****************************************************
  523. C*                                                  *
  524. C*  GET CP/M NAME, AND FORMAT INTO CNAME.           *
  525. C*                                                  *
  526. C*  RUSS BAKKE                  05-05-82            *
  527. C*                                                  *
  528. C****************************************************
  529. C
  530.     BYTE CNAME(12),TYPE(3)
  531. C
  532.     TYPE *,'ENTER CP/M FILE NAME:'
  533.     ACCEPT 110,CNAME
  534.   110    FORMAT(12A1)
  535. C
  536. C  NOW REFORMAT TO 8 CHAR NAME & 3 CHAR TYPE
  537. C  FIND '.'
  538.     DO 10 INDEX=1,12
  539.     IF (CNAME(INDEX) .EQ. '.') GOTO 20
  540.    10    C O N T I N U E
  541.     GOTO 90    !NO '.', PASS WHAT WE GOT
  542. C
  543. C  EXTRACT FILE TYPE
  544.    20    DO 30 INDEX2=1,3
  545.     TYPE(INDEX2) = CNAME(INDEX+INDEX2)
  546.    30    C O N T I N U E
  547. C  FILL CNAME FROM PERIOD THROUGH 12 WITH SPACES
  548.     DO 40 INDEX2=INDEX,12
  549.     CNAME(INDEX2) = ' '
  550.    40    C O N T I N U E
  551. C  COPY TYPE INTO CNAME
  552.     DO 50 INDEX2=1,3
  553.     IF (TYPE(INDEX2) .EQ. 0) GOTO 90
  554.     CNAME(8+INDEX2) = TYPE(INDEX2)
  555.    50    C O N T I N U E
  556.    90    RETURN
  557.     END
  558. C
  559.     SUBROUTINE GETFN(PROMPT,IDCHAN)
  560. C********************************************************
  561. C*                                                      *
  562. C*  INPUT A FILE NAME AND OPEN A DEC FILE.  RETURN THE  *
  563. C*  CHANNEL NUMBER IN IDCHAN.                           *
  564. C*                                                      *
  565. C*   RUSS BAKKE             05-11-82                    *
  566. C*                                                      *
  567. C********************************************************
  568. C
  569.     LOGICAL*1 FNAME(16),PROMPT(6)
  570. C
  571.     5    WRITE (7,103) PROMPT
  572.   103    FORMAT (1X,6A1,' FILE SPECIFICATION?')
  573. C
  574.     8    READ (5,105) FNAME
  575.   105    FORMAT (16A1)
  576.     FNAME(16)=0
  577. C    CHECK TO AVOID NULL FILE NAME
  578.     IF (FNAME(1) .EQ. ' ') GOTO 70
  579.     IF (FNAME(3) .EQ. ':' .AND. FNAME(4) .EQ. ' ') GOTO 70
  580.     IF (FNAME(4) .EQ. ':' .AND. FNAME(5) .EQ. ' ') GOTO 70
  581. C
  582.     CALL DECOPN(FNAME,IDCHAN,PROMPT(1))
  583.     RETURN
  584. C
  585.    70    TYPE *,'ERROR IN FILE SPECIFICATION, TRY AGAIN'
  586.     GOTO 5
  587.     END
  588. C
  589.     SUBROUTINE DECOPN(FNAME,IDCHAN,RW)
  590. C**************************************************
  591. C*                                                *
  592. C*  OPEN A DEC FILE FNAME, RETURNING CHANNEL      *
  593. C*  NUMBER IN IDCHAN.  RW IS READ/WRITE.          *
  594. C*                                                *
  595. C*  RUSS BAKKE               05-25-82             *
  596. C*                                                *
  597. C**************************************************
  598. C
  599.     BYTE FNAME(16),RW
  600.     REAL*8 FSPEC
  601. C
  602. C  CONVERT FNAME TO RADIX 50
  603. C
  604. C  REFORMAT AS DL0FNAME_TYP
  605. C  FIRST FIND ':'
  606.     DO 20 I=1,16
  607.     IF (FNAME(I) .EQ. ':') GOTO 25
  608.    20    C O N T I N U E
  609. C  NO ':' FOUND, INSERT 'DL0'
  610.     DO 22 I=13,1,-1
  611.     FNAME(I+3)=FNAME(I)
  612.    22    C O N T I N U E
  613.     FNAME(1)='D'
  614.     FNAME(2)='L'
  615.     FNAME(3)='0'
  616.     GOTO 30
  617. C
  618. C  EAT THE ':'
  619.   25    DO 28 J=I,15
  620.     FNAME(J)=FNAME(J+1)
  621.    28    C O N T I N U E
  622.     FNAME(16)=' '
  623. C
  624. C  NOW FIND '.'
  625.    30    DO 35 I=1,16
  626.     IF (FNAME(I) .EQ. '.') GOTO 36
  627.    35    C O N T I N U E
  628. C  NO '.' FOUND
  629.     GOTO 40
  630. C
  631. C  MOVE TYPE TO LAST 3 CHARS
  632.    36    FNAME(16)=FNAME(I+3)
  633.     FNAME(15)=FNAME(I+2)
  634.     FNAME(14)=FNAME(I+1)
  635.     FNAME(10)=FNAME(14)
  636.     FNAME(11)=FNAME(15)
  637.     FNAME(12)=FNAME(16)
  638. C
  639. C  BLANK FILL
  640.     IF (I .GE. 10) GOTO 40
  641.     DO 38 J=I,9
  642.     FNAME(J)=' '
  643.    38    C O N T I N U E
  644. C
  645. C  CHANGE ALL ILLEGAL CHARACTERS TO '9'
  646.    40    DO 42 INDEX=4,12
  647.     IF (FNAME(INDEX) .GE. 'A' .AND.
  648.      +    FNAME(INDEX) .LE. 'Z') GOTO 42        !OK
  649.     IF (FNAME(INDEX) .GE. '0' .AND.
  650.      +    FNAME(INDEX) .LE. '9') GOTO 42        !OK
  651.     IF (FNAME(INDEX) .EQ. ' ' .OR.
  652.      +    FNAME(INDEX) .EQ. '.') GOTO 42        !OK
  653.     FNAME(INDEX) = '9'
  654.    42    C O N T I N U E
  655. C
  656. C  NOW CONVERT TO RADIX 50
  657.     IDUM=IRAD50(12,FNAME,FSPEC)
  658. C
  659. C  GET A CHANNEL
  660.     IDCHAN=IGETC()
  661.     IF(IDCHAN .LT. 0) STOP' NO CHANNEL AVAILABLE'
  662. C
  663.     IF (RW .EQ. 'O') GOTO 50
  664.     IRET = LOOKUP(IDCHAN,FSPEC)
  665.     IF (IRET .GE. 0) GOTO 90
  666. C
  667. C  LOOKUP FAILURE--TYPES ARE:
  668. C  -1: CHANNEL ALREADY OPEN
  669. C  -2: SPECIFIED FILE NOT FOUND
  670. C  -3: DEVICE IN USE
  671. C  -4: TAPE ONLY
  672.     IF (IRET .NE. -2) GOTO 45
  673.     STOP 'DEC FILE NOT FOUND'
  674. C
  675.    45    TYPE *,'LOOKUP FAILURE TYPE ',IRET
  676.     STOP
  677. C
  678. C  WRITE FILE MUST USE IENTER NOT LOOKUP
  679.    50    IRET=IENTER(IDCHAN,FSPEC,-1)
  680.     IF (IRET .GE. 0) GOTO 90
  681. C  IENTER ERRORS ARE:
  682. C  -1: CHANNEL ALREADY OPEN
  683. C  -2: NO SPACE AVAILABLE
  684. C  -3: DEVICE IN USE
  685. C  -4: FILE EXISTS AND IS PROTECTED
  686. C  -5: CASSETTE ONLY
  687.     TYPE *,'IENTER FAILURE TYPE ',IRET
  688.     STOP
  689. C
  690.    90    RETURN
  691.     END
  692. C
  693.     SUBROUTINE FIND(CNAME,EXT,IENTRY)
  694. C****************************************************
  695. C*                                                  *
  696. C*  FIND CP/M FILE NAMED CNAME IN DIRECTORY (IN     *
  697. C*  DIR, PASSED IN COMMON), EXTENT 'EXT'; RETURN    *
  698. C*  DIRECTORY ENTRY NUMBER IN IENTRY.               *
  699. C*                                                  *
  700. C*  RUSS BAKKE                    05-11-82          *
  701. C*                                                  *
  702. C****************************************************
  703. C
  704.     BYTE DIR(32,64),CNAME(12)
  705.     INTEGER EXT
  706.     COMMON DIR
  707. C
  708.     DO 44 IENTRY=1,64
  709.     IF (DIR(1,IENTRY) .EQ. "345) GOTO 44    !EMPTY, SKIP
  710.     DO 42 ICHAR=2,12
  711.     IF (DIR(ICHAR,IENTRY) .NE. CNAME(ICHAR-1)) GOTO 44
  712.    42    C O N T I N U E
  713. C  FALL THROUGH MEANS A MATCH
  714.     IF (DIR(13,IENTRY) .EQ. EXT) GOTO 90    !FOUND IT
  715. C
  716.    44    C O N T I N U E
  717. C  FALL THROUGH MEANS NO MATCH FOUND
  718.     IENTRY=-1
  719.    90    RETURN
  720.     END
  721. C
  722.     SUBROUTINE CPYFIL(IENTRY,CNAME,ICHAN,IDCHAN,MODE)
  723. C*************************************************
  724. C*                                               *
  725. C*  COPY CP/M FILE (ICHAN) TO DEC FILE (IDCHAN). *
  726. C*  CP/M DIRECTORY ENTRY IS 'IENTRY'.            *
  727. C*  MODE IS "BINARY" OR "ASCII ".                *
  728. C*  CLOSE DEC CHANNEL (IDCHAN) WHEN FINISHED.    *
  729. C*                                               *
  730. C*  RUSS BAKKE                      02-02-83     *
  731. C*                                               *
  732. C*************************************************
  733. C
  734.     BYTE DIR(32,64),DBUFF(1024),CNAME(12),MODE
  735.     COMMON DIR
  736. C
  737.     IDBLK=0    !DISK BLOCK TO WRITE
  738.     IEXT=0    !FIRST EXTENT
  739. C
  740.     8    ICLU=1    !FIRST CLUSTER
  741.     ISIZE=DIR(16,IENTRY)
  742.     IF (ISIZE .LT. 0) ISIZE=ISIZE+256
  743.     IF (ISIZE .EQ. 128) ISIZE=129    !DON'T LET IT COUNT OUT
  744.    10    IF (ISIZE .EQ. 0) GOTO 90
  745.     IBLK=DIR(16+ICLU,IENTRY)
  746.     IF (IBLK .LT. 0) IBLK=IBLK+256
  747. C  (PROBLEM HERE, IS WE GET SIGN EXTENSION ON READING BYTE
  748. C  VALUE INTO INTEGER VARIABLE)
  749.     IF (IBLK .EQ. 0) GOTO 90    !THAT'S ALL
  750. C
  751. C  NEED TO READ 'IBLK' 1K CLUSTER (8 SECTORS)
  752. C
  753. C  CONVERT IBLK TO STARTING SECTOR # AND TRACK #
  754. C  MULTIPLY BY 8 AND REDUCE MODULO 26
  755.     ITEMP=8*IBLK
  756.     ISTTRK=ITEMP/26
  757.     ISTART=ITEMP-26*ISTTRK+1
  758.     ISTTRK=ISTTRK+2    !SKIP SYSTEM TRACKS
  759. C
  760.     DO 60 ISECTR=0,7
  761.     ITEMP=ISTART+ISECTR
  762.     ITRK=ISTTRK
  763.     IF (ITEMP .LE. 26) GOTO 30
  764.     ITEMP=ITEMP-26
  765.     ITRK=ITRK+1
  766.    30    CALL DOSEC('R',ITRK,ITEMP,DBUFF(128*ISECTR+1),ICHAN)
  767.     ISIZE=ISIZE-1
  768.     IF (ISIZE .LE. 0) GOTO 80
  769.    60    C O N T I N U E
  770. C
  771. C  NOW WRITE BUFF TO IDCHAN
  772. C  SEARCH BUFFER FOR CTL-Z (EOF) UNLESS BINARY MODE.
  773.     IF (MODE .EQ. 'B') GOTO 70
  774.    62    DO 65 INDEX=1,1024
  775.     IF (DBUFF(INDEX) .EQ. 26) GOTO 75
  776.    65    C O N T I N U E
  777. C
  778.    70    IRET=IWRITW(512,DBUFF,IDBLK,IDCHAN)
  779.     IDBLK=IDBLK+2
  780. C  IWRITW RETURNS:
  781. C  -1: EOF
  782. C  -2: HARDWARE ERROR
  783. C  -3: CHANNEL NOT OPEN
  784. C
  785.     IF (IRET .LT. 0) GOTO 95
  786.     ICLU=ICLU+1
  787.     IF (ICLU .LT. 17) GOTO 10    !NEXT SEGMENT
  788. C
  789. C  NOW SEE IF WE HAVE ANOTHER EXTENT
  790.     IEXT=IEXT+1
  791.     CALL FIND(CNAME,IEXT,IENTRY)
  792.     IF (IENTRY .NE. -1) GOTO 8    !NEXT EXTENT
  793.     GOTO 90
  794. C
  795. C  HAVE EOF AT "INDEX"
  796.    75    DO 78 INDEX1=INDEX,1024
  797.     DBUFF(INDEX1)=0        !NULL FILL FOR DEC
  798.    78    C O N T I N U E
  799.     IF (INDEX .LE. 512) GOTO 83
  800.     GOTO 84
  801. C
  802. C  HAVE PARTIAL BUFFER--WRITE IT OUT.
  803.    80    IF (MODE .EQ. 'A') GOTO 62
  804.     DO 82 IPTR=128*(ISECTR+1)+1,1024
  805.     DBUFF(IPTR)=0
  806.    82    C O N T I N U E
  807.     IF (ISECTR .GT. 3) GOTO 84
  808.    83    IRET=IWRITW(256,DBUFF,IDBLK,IDCHAN)
  809.     IDBLK=1
  810.     GOTO 86
  811. C
  812.    84    IRET=IWRITW(512,DBUFF,IDBLK,IDCHAN)
  813.     IDBLK=2
  814.    86    IF (IRET .LT. 0) GOTO 95
  815.    90    IF (IDBLK .EQ. 0) GOTO 94
  816.     CALL ICLOSE(IDCHAN)
  817.    92    CALL IFREEC(IDCHAN)
  818.     RETURN
  819. C
  820. C  FILE OF 0 LENGTH, EAT IT.
  821.    94    CALL PURGE(IDCHAN)
  822.     GOTO 92
  823. C
  824.    95    TYPE *,'WRITE ERROR IN CPYFIL, TYPE ',IRET
  825.     STOP
  826.     END
  827. C
  828.     SUBROUTINE ERASE (CNAME,ICHAN,ISTAT)
  829. C****************************************************
  830. C*                                                  *
  831. C*  ERASE CP/M FILE 'CNAME' VIA CHANNEL ICHAN.      *
  832. C*   RET ISTAT=0 IF OK, ELSE -1.                    *
  833. C*                                                  *
  834. C*  RUSS BAKKE               12-07-82               *
  835. C*                                                  *
  836. C****************************************************
  837. C
  838.     BYTE DIR(32,64),CNAME(12)
  839.     COMMON DIR
  840. C
  841.     CALL GETDIR(ICHAN)
  842.     CALL FIND(CNAME,0,IENTRY)
  843.     IF (IENTRY .EQ. -1) GOTO 50    !UNSUCCESSFUL
  844.     IEXT=0
  845.    10    DIR (1,IENTRY)="345        !SET EMPTY
  846.     IEXT=IEXT+1
  847.     CALL FIND(CNAME,IEXT,IENTRY)    !MORE EXTENTS?
  848.     IF (IENTRY .NE. -1) GOTO 10    !YES
  849.     ISTAT=0
  850.     RETURN
  851. C
  852.    50    ISTAT=-1    !UNSUCCESSFUL
  853.     RETURN
  854.     END
  855.