(* 1---Module 04---1 *)

  PROCEDURE setfatpointer(loc, val : integer);

    VAR
      i, r           : integer;

    BEGIN (* setfatpointer *)
    i := ((loc * 3) DIV 2) +1;
    r := (fat[i] OR (fat[i+1] shl 8));
    IF odd(loc) THEN r := ((r AND $f) OR (val shl 4))
    ELSE r := ((r AND $f000) OR (val AND $fff));
    fat[i] := (r AND $ff); fat[i+1] := ((r shr 8) AND $ff);
    END; (* setfatpointer *)

  (* 1---------------1 *)

  PROCEDURE writems_dos;

    VAR
      filename       : str20;
      unambiguous    : str20;
      infile         : FILE;
      errorcode      : integer;
      i              : integer;
      stop           : boolean;
      recspercluster : integer;
      remaining      : integer;
      nrecs          : integer;
      fat_marker     : integer;
      lastmarker     : integer;

    (* 2---------------2 *)

    FUNCTION firstfree(start : integer) : integer;

      VAR
        i              : integer;

      BEGIN (* firstfree *)
      i := start;
      WHILE (i < nclusters + 2) AND (fatpointer(i) <> 0) DO i := succ(i);
      firstfree := i;
      IF (i = nclusters + 2) THEN bioserror := true;
      END; (* firstfree *)

    (* 2---------------2 *)

    PROCEDURE rewritems_dos(fn : nameary; ft : typeary);

      VAR
        errorcode      : integer;
        s              : str20;

      BEGIN (* rewritems_dos *)
      s := '????????.???'; volumename := false;
      subdirname := false;
      searchfirstall(s, errorcode);
      WHILE (errorcode <> mtdirectory) AND (errorcode <> eodirectory)
            OR volumename OR subdirname DO
        searchnextall(s, errorcode);
      IF (errorcode = eodirectory) THEN bioserror := true
      ELSE BEGIN
        dos_fcb^.name := fn;
        dos_fcb^.extention := ft;
        dos_fcb^.attribute := 0;
        FOR i := 12 TO 21 DO dos_fcb^.rsrvd[i] := 0;
        dos_fcb^.time := 0; dos_fcb^.date := 0;
        fat_marker := firstfree(2);
        dos_fcb^.clusterno := fat_marker; END;
      END; (* rewritems_dos *)

    (* 2---------------2 *)

    PROCEDURE closems_dos(size : integer);
    { Size is filesize / 128 }

      VAR
        size2          : integer;

      BEGIN (* closems_dos *)
      size2 := hi(size shr 1);          { prevent overflow }
      size := ((size AND $1ff) shl 7);
      dos_fcb^.filesize[1] := lo(size);
      dos_fcb^.filesize[2] := hi(size);
      dos_fcb^.filesize[3] := lo(size2);
      dos_fcb^.filesize[4] := hi(size2);
      IF (size = 0) THEN (* DOS_FCB^.Cluster := $FFF *)
      ELSE setfatpointer(lastmarker, $fff);
      writesector(dirsector, dirtrack, addr(dirbuffer), true);
      putfat;
      END; (* closems_dos *)

    (* 2---------------2 *)

    PROCEDURE copyfiles;

      BEGIN (* copyfiles *)
      REPEAT
        unambiguous := '';
        FOR i := 1 TO namesize DO
          IF NOT (cpm_fcb.name[i] = ' ') THEN
            unambiguous := unambiguous + cpm_fcb.name[i];
        unambiguous := unambiguous + '.';
        FOR i := 1 TO typesize DO
          IF NOT (cpm_fcb.extention = ' ') THEN
            unambiguous := unambiguous + cpm_fcb.extention[i];
        assign(infile, unambiguous); reset(infile);

        searchfirst(unambiguous, errorcode);
        writeln;
        write(cpm_drivech + ':', unambiguous);
        IF (errorcode = founddir) THEN
          write(' Exists, must erase first')
        ELSE BEGIN
          rewritems_dos(cpm_fcb.name, cpm_fcb.extention);
          IF NOT bioserror THEN BEGIN
            remaining := filesize(infile);
            WHILE (remaining > 0) AND NOT stop DO BEGIN
              IF (remaining > recspercluster) THEN
                nrecs := recspercluster
              ELSE BEGIN
                nrecs := remaining;
                FOR i := 1 TO recspercluster * 128 DO
                  clusterbuffer[i] := chr(0); END;
              blockread(infile, clusterbuffer, nrecs);
              setfatpointer(fat_marker, firstfree(fat_marker + 1));
              writecluster(fat_marker);
              lastmarker := fat_marker;
              fat_marker := firstfree(succ(fat_marker));
              stop := bioserror OR stop;
              remaining := remaining - nrecs; END;
            closems_dos(filesize(infile)); END; (* not bioserror *)
          END; (* if founddir *)
        IF bioserror THEN BEGIN
          stop := true; writeln;
          writeln('MS-DOS Write Error or Disk or Directory Full'); END
        ELSE BEGIN
          searchfilecpm(unambiguous, errorcode, first);
          IF (errorcode = 0) THEN
            searchfilecpm(filename, errorcode, next); END;
        stop := (stop OR break OR bioserror);
      UNTIL (errorcode = $ff) OR stop;
      END; (* copyfiles *)

    (* 2---------------2 *)

    BEGIN (* writems_dos *)
    identifyms_dos;
    IF NOT (identity = unidentified) THEN BEGIN
      REPEAT
        clrscr;
        write('File Transfer From CP/M to MS-DOS, CP/M directory');
        dircpm(false); writeln;
        write('File Name to Get From CP/M: ');
        readln(filename);
        stop := (pos(':', filename) <> 0);
        IF stop THEN BEGIN
          write('DriveCode = ', cpm_drivech);
          writeln(', Do Not Include In Name.');
          continue; END;
      UNTIL NOT stop;
      recspercluster := secspercluster * sectorsize DIV 128;
      stop := filename = '';
      IF NOT stop THEN BEGIN
        searchfilecpm(filename, errorcode, first);
        IF (errorcode = $ff) THEN write('File Not Found, ')
        ELSE BEGIN
          write('Transfering -'); copyfiles; writeln; END;
        END;
      IF stop THEN write('Aborted, ');
      continue; END;
    END; (* writems_dos *)

  (* 1-End Module 04-1 *)