home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol115 / cpmd2.for < prev    next >
Encoding:
Text File  |  1985-02-10  |  9.5 KB  |  315 lines
  1. C************************************************
  2. C*                                              *
  3. C*  CPMD2--CP/M TO DEC DISK TRANSLATER          *
  4. C*                                              *
  5. C*  NOTE:  MUST BE COMPILED '/NOSWAP'           *
  6. C*                                              *
  7. C*  THIS IS A SHORT VERSION OF CPMDEC, FOR USE  *
  8. C*    WHERE THE PROGRAM MUST BE HAND ENTERED.   *
  9. C*    TYPE THIS FILE INTO YOUR DEC SYSTEM,      *
  10. C*    OMITTING THE COMMENTS.  THEN COMPILE IT,  *
  11. C*    THE RESULT WILL BE A SHORT VERSION WHICH  *
  12. C*    WILL ONLY READ CPMDEC FROM THE DISK.      *
  13. C*    YOU MAY THEN COMPILE CPMDEC FOR LATER USE.*
  14. C*                                              *
  15. C*  RUSS BAKKE                02-18-83          *
  16. C*                                              *
  17. C************************************************
  18. C
  19.     PROGRAM CPMD2
  20. C
  21.     BYTE DIR(32,64),CNAME(12),DNAME(12)
  22.     COMMON DIR
  23.     DATA DNAME/ 'D','K','0','C','P','M','D','E','C',
  24.      +    'F','O','R'/
  25.     DATA CNAME/ 'C','P','M','D','E','C',' ',' ','F','O','R',0/
  26. C
  27.     TYPE 100
  28.   100    FORMAT (1X,'CP/M TRANSLATER BOOTSTRAP, V1.0'//
  29.      +    1X,'INSERT CP/M DISK IN DY1: AND PRESS RETURN'/)
  30.     ACCEPT 104,IWANT
  31.   104    FORMAT (1A1)
  32. C
  33. C OPEN CP/M DISK AS NON-FILE STRUCTURED DEVICE:
  34.     CALL DSKOPN(ICHAN)
  35.     CALL GETDIR(ICHAN)
  36. C
  37. C  LOOKUP CNAME IN DISK DIR
  38.     CALL FIND(CNAME,0,IENTRY)
  39.     IF (IENTRY .NE. -1) GOTO 32    !OK
  40.    31    TYPE *,'FILE NOT FOUND'
  41.     GOTO 90
  42. C
  43. C  GET DEC NAME & OPEN
  44.    32    CALL DECOPN(DNAME,IDCHAN)
  45. C  READ FILE AND WRITE TO DEC
  46.     CALL CPYFIL(IENTRY,CNAME,ICHAN,IDCHAN)
  47. C
  48. C  CLOSE
  49.    90    CALL ICLOSE (ICHAN)
  50.     CALL IFREEC (ICHAN)
  51.     CALL EXIT
  52.     END
  53. C
  54.     SUBROUTINE DSKOPN (IDCH)
  55. C****************************************************
  56. C*                                                  *
  57. C*  OPEN FLOPPY DISK DRIVE 1 AS NON-FILE            *
  58. C*  STRUCTURED DEVICE; RETURN CHANNEL NO. IN IDCH.  *
  59. C*                                                  *
  60. C*  RUSS BAKKE                      02-10-83        *
  61. C*                                                  *
  62. C****************************************************
  63. C
  64.     REAL*4 DISK1
  65.     DATA DISK1 /3RDY1   /
  66. C
  67. C  FETCH HANDLER, OPEN A CHANNEL, LOOKUP DEVICE
  68.     IF (IFETCH(DISK1) .NE. 0) STOP 'IFETCH ERROR
  69.      +    IN DSKOPN'
  70.     IDCH=IGETC()
  71.     IF(IDCH.LT.0) STOP' NO CHANNEL AVAILABLE'
  72. C
  73.     IRET = LOOKUP(IDCH,DISK1)
  74.     IF (IRET .GE. 0) GOTO 10
  75. C
  76. C  LOOKUP FAILURE
  77.     TYPE *,'LOOKUP FAILURE TYPE ',IRET
  78.     STOP
  79. C
  80.    10    RETURN
  81.     END
  82. C
  83.     SUBROUTINE GETDIR(ICHAN)
  84. C****************************************************
  85. C*                                                  *
  86. C*  READ DIRECTORY OF CP/M DISK.                    *
  87. C*                                                  *
  88. C*  THE CP/M DISK USES TRACKS 0 AND 1 FOR SYSTEM    *
  89. C*  TRACKS; WE MAY IGNORE THEM.  THE DIRECTORY IS   *
  90. C*  2K OR 16 SECTORS, STARTING ON TRACK 2.          *
  91. C*                                                  *
  92. C*  RUSS BAKKE                  05-06-82            *
  93. C*                                                  *
  94. C****************************************************
  95. C
  96.     BYTE DIR(32,64)
  97.     COMMON DIR
  98. C
  99.     DO 80 INDEX=1,16
  100.     ISECTR=INDEX
  101.     CALL DOSEC(2,ISECTR,DIR(1,4*(ISECTR-1)+1),ICHAN)
  102.    80    C O N T I N U E
  103.     RETURN
  104.     END
  105. C
  106.     SUBROUTINE DOSEC(ITRK,ISEC,BUFF,ICHAN)
  107. C****************************************************
  108. C*                                                  *
  109. C*  READ LOGICAL SECTOR 'ISEC', TRACK 'ITRK', TO    *
  110. C*   'BUFF' (128 BYTES), FROM CHANNEL 'ICHAN'.      *
  111. C*                                                  *
  112. C*  RUSS BAKKE                   02-18-83           *
  113. C*                                                  *
  114. C****************************************************
  115. C
  116.     BYTE BUFF(128),MYBUFF(130)
  117.     INTEGER ITABLE(26)
  118.     DATA ITABLE /1,7,13,19,25,5,11,17,23,3,9,15,21,2,8,
  119.      +    14,20,26,6,12,18,24,4,10,16,22/
  120. C  ITABLE IS THE CP/M SECTOR INTERLEAVE TABLE (26 SECTORS PER TRACK)
  121. C  PHYSICAL SECTOR # [1..26] = ITABLE(LOGICAL SECTOR # [1..26])
  122. C
  123.     IRET=ISPFNW("377,ICHAN,ITRK,MYBUFF,ITABLE(ISEC))
  124. C
  125. C  THE ISPFNW CALL IS AS FOLLOWS:
  126. C  IRET=ISPFNW(FUNC,ICHAN,ITRK,BUFF,SECTOR)
  127. C    FUNC="377 FOR READ, "376 FOR WRITE
  128. C    ICHAN=CHANNEL #, FROM LOOKUP
  129. C    ITRK=ABSOLUTE PHYSICAL TRACK #, 0..76
  130. C    SECTOR=ABSOLUTE PHYSICAL SECTOR #, 1..26
  131. C    BUFF=128 BYTE BUFFER
  132. C    IRET RETURNS:
  133. C    0 NORMAL
  134. C    1  EOF
  135. C    2  HARDWARE ERROR
  136. C    3  CHANNEL NOT OPEN
  137. C
  138.     IF (IRET .EQ. 0) GOTO 40
  139.    30    TYPE 100,RW,ITRK,ISEC
  140.   100    FORMAT (1X,A,2X,'TRACK: ',I3,'   LOG. SECTOR: ',I3)
  141.     IF (IRET .EQ. 1) STOP 'CHANNEL EOF IN DOSEC'
  142.     IF (IRET .EQ. 2) STOP 'HARDWARE ERROR IN DOSEC'
  143.     IF (IRET .EQ. 3) STOP 'CHANNEL NOT OPEN IN DOSEC'
  144.     STOP 'ERROR IN DOSEC'
  145. C
  146. C  WE MUST READ INTO 130 BYTE BUFFER, BECAUSE ISPFNW READS
  147. C  LEADING 0 WORD INTO BUFFER.  (THIS IS DOCUMENTED IN THE
  148. C  SOFTWARE SUPPORT MANUAL BUT NOT IN THE PROGRAMMER'S REFERENCE).
  149.    40    DO 45 I=1,128
  150.     BUFF(I) = MYBUFF(I+2)
  151.    45    C O N T I N U E
  152.     RETURN
  153.     END
  154. C
  155.     SUBROUTINE DECOPN(FNAME,IDCHAN)
  156. C**************************************************
  157. C*                                                *
  158. C*  OPEN A DEC FILE FNAME, RETURNING CHANNEL      *
  159. C*  NUMBER IN IDCHAN.                             *
  160. C*                                                *
  161. C*  RUSS BAKKE               02-18-83             *
  162. C*                                                *
  163. C**************************************************
  164. C
  165.     BYTE FNAME(12)
  166.     REAL*8 FSPEC
  167. C
  168. C  GET A CHANNEL
  169.     IDCHAN=IGETC()
  170.     IF(IDCHAN .LT. 0) STOP' NO CHANNEL AVAILABLE'
  171. C
  172. C  CONVERT FNAME TO RADIX 50
  173.     IDUM=IRAD50(12,FNAME,FSPEC)
  174. C
  175.     IRET=IENTER(IDCHAN,FSPEC,-1)
  176.     IF (IRET .GE. 0) GOTO 90
  177. C  IENTER ERRORS ARE:
  178. C  -1: CHANNEL ALREADY OPEN
  179. C  -2: NO SPACE AVAILABLE
  180. C  -3: DEVICE IN USE
  181. C  -4: FILE EXISTS AND IS PROTECTED
  182. C  -5: CASSETTE ONLY
  183.     TYPE *,'IENTER FAILURE TYPE ',IRET
  184.     STOP
  185. C
  186.    90    RETURN
  187.     END
  188. C
  189.     SUBROUTINE FIND(CNAME,EXT,IENTRY)
  190. C****************************************************
  191. C*                                                  *
  192. C*  FIND CP/M FILE NAMED CNAME IN DIRECTORY (IN     *
  193. C*  DIR, PASSED IN COMMON), EXTENT 'EXT'; RETURN    *
  194. C*  DIRECTORY ENTRY NUMBER IN IENTRY.               *
  195. C*                                                  *
  196. C*  RUSS BAKKE                    05-11-82          *
  197. C*                                                  *
  198. C****************************************************
  199. C
  200.     BYTE DIR(32,64),CNAME(12)
  201.     INTEGER EXT
  202.     COMMON DIR
  203. C
  204.     DO 44 IENTRY=1,64
  205.     IF (DIR(1,IENTRY) .EQ. "345) GOTO 44    !EMPTY, SKIP
  206.     DO 42 ICHAR=2,12
  207.     IF (DIR(ICHAR,IENTRY) .NE. CNAME(ICHAR-1)) GOTO 44
  208.    42    C O N T I N U E
  209. C  FALL THROUGH MEANS A MATCH
  210.     IF (DIR(13,IENTRY) .EQ. EXT) GOTO 90    !FOUND IT
  211. C
  212.    44    C O N T I N U E
  213. C  FALL THROUGH MEANS NO MATCH FOUND
  214.     IENTRY=-1
  215.    90    RETURN
  216.     END
  217. C
  218.     SUBROUTINE CPYFIL(IENTRY,CNAME,ICHAN,IDCHAN)
  219. C*************************************************
  220. C*                                               *
  221. C*  COPY CP/M FILE (ICHAN) TO DEC FILE (IDCHAN). *
  222. C*  CP/M DIRECTORY ENTRY IS 'IENTRY'.            *
  223. C*  CLOSE DEC CHANNEL (IDCHAN) WHEN FINISHED.    *
  224. C*                                               *
  225. C*  RUSS BAKKE                      02-18-83     *
  226. C*                                               *
  227. C*************************************************
  228. C
  229.     BYTE DIR(32,64),DBUFF(1024),CNAME(12)
  230.     COMMON DIR
  231. C
  232.     IDBLK=0    !DISK BLOCK TO WRITE
  233.     IEXT=0    !FIRST EXTENT
  234. C
  235.     8    ICLU=1    !FIRST CLUSTER
  236.     ISIZE=DIR(16,IENTRY)
  237.     IF (ISIZE .LT. 0) ISIZE=ISIZE+256
  238.     IF (ISIZE .EQ. 128) ISIZE=129    !DON'T LET IT COUNT OUT
  239.    10    IF (ISIZE .EQ. 0) GOTO 90
  240.     IBLK=DIR(16+ICLU,IENTRY)
  241.     IF (IBLK .LT. 0) IBLK=IBLK+256
  242. C  (PROBLEM HERE, IS WE GET SIGN EXTENSION ON READING BYTE
  243. C  VALUE INTO INTEGER VARIABLE)
  244.     IF (IBLK .EQ. 0) GOTO 90    !THAT'S ALL
  245. C
  246. C  NEED TO READ 'IBLK' 1K CLUSTER (8 SECTORS)
  247. C
  248. C  CONVERT IBLK TO STARTING SECTOR # AND TRACK #
  249. C  MULTIPLY BY 8 AND REDUCE MODULO 26
  250.     ITEMP=8*IBLK
  251.     ISTTRK=ITEMP/26
  252.     ISTART=ITEMP-26*ISTTRK+1
  253.     ISTTRK=ISTTRK+2    !SKIP SYSTEM TRACKS
  254. C
  255.     DO 60 ISECTR=0,7
  256.     ITEMP=ISTART+ISECTR
  257.     ITRK=ISTTRK
  258.     IF (ITEMP .LE. 26) GOTO 30
  259.     ITEMP=ITEMP-26
  260.     ITRK=ITRK+1
  261.    30    CALL DOSEC(ITRK,ITEMP,DBUFF(128*ISECTR+1),ICHAN)
  262.     ISIZE=ISIZE-1
  263.     IF (ISIZE .LE. 0) GOTO 62
  264.    60    C O N T I N U E
  265. C
  266. C  NOW WRITE BUFF TO IDCHAN
  267. C  SEARCH BUFFER FOR CTL-Z (EOF)
  268.    62    DO 65 INDEX=1,1024
  269.     IF (DBUFF(INDEX) .EQ. 26) GOTO 75
  270.    65    C O N T I N U E
  271. C
  272.    70    IRET=IWRITW(512,DBUFF,IDBLK,IDCHAN)
  273.     IDBLK=IDBLK+2
  274. C  IWRITW RETURNS:
  275. C  -1: EOF
  276. C  -2: HARDWARE ERROR
  277. C  -3: CHANNEL NOT OPEN
  278. C
  279.     IF (IRET .LT. 0) GOTO 95
  280.     ICLU=ICLU+1
  281.     IF (ICLU .LT. 17) GOTO 10    !NEXT SEGMENT
  282. C
  283. C  NOW SEE IF WE HAVE ANOTHER EXTENT
  284.     IEXT=IEXT+1
  285.     CALL FIND(CNAME,IEXT,IENTRY)
  286.     IF (IENTRY .NE. -1) GOTO 8    !NEXT EXTENT
  287.     GOTO 90
  288. C
  289. C  HAVE EOF AT "INDEX"
  290.    75    DO 78 INDEX1=INDEX,1024
  291.     DBUFF(INDEX1)=0        !NULL FILL
  292.    78    C O N T I N U E
  293.     IF (INDEX .GT. 512) GOTO 84
  294. C
  295. C  HAVE PARTIAL BUFFER--WRITE IT OUT.
  296.    83    IRET=IWRITW(256,DBUFF,IDBLK,IDCHAN)
  297.     IDBLK=1
  298.     GOTO 86
  299. C
  300.    84    IRET=IWRITW(512,DBUFF,IDBLK,IDCHAN)
  301.     IDBLK=2
  302.    86    IF (IRET .LT. 0) GOTO 95
  303.    90    IF (IDBLK .EQ. 0) GOTO 94
  304.     CALL ICLOSE(IDCHAN)
  305.    92    CALL IFREEC(IDCHAN)
  306.     RETURN
  307. C
  308. C  FILE OF 0 LENGTH, EAT IT.
  309.    94    CALL PURGE(IDCHAN)
  310.     GOTO 92
  311. C
  312.    95    TYPE *,'WRITE ERROR IN CPYFIL, TYPE ',IRET
  313.     STOP
  314.     END
  315.