mirror of
https://github.com/SEPPDROID/Digital-Research-Source-Code.git
synced 2025-10-26 18:04:07 +00:00
Upload
Digital Research
This commit is contained in:
@@ -0,0 +1,758 @@
|
||||
|
||||
/************************************************************
|
||||
* NOTE: This program contains Digital Research proprietary *
|
||||
* information and must not be reproduced, copied, or *
|
||||
* transcribed in any form whatsoever. *
|
||||
*************************************************************
|
||||
|
||||
|
||||
COPYRIGHT (C) 1981
|
||||
DIGITAL RESEARCH
|
||||
BOX 579
|
||||
PACIFIC GROVE, CA. 93950 */
|
||||
|
||||
prod_root:
|
||||
/***********************************************************
|
||||
* *
|
||||
*<2A><>Thi<68><69> modul<75><6C> i<> th<74> roo<6F> modul<75> fo<66><6F> controllin<69><6E> th<74> *
|
||||
*<2A><>productio<69><6F> an<61><6E> serializatio<69> o<><6F> al<61><6C> products<74><73> I<> *
|
||||
*<2A><>call<6C><6C><EFBFBD> overlay<61><79> t<><74> d<><64> th<74><68> serializatio<69><6F> o<><6F> each *
|
||||
*<2A><>product<63><74> thu<68> allowin<69> fo<66> individua<75> optimizatio<69> o<> *
|
||||
*<2A><>th<74><68> desig<69> o<> th<74> serializatio<69><6F> process<73><73> Th<54><68> roo<6F> *
|
||||
*<2A><>modul<75><6C> contain<69><6E> globa<62> variable<6C> an<61> prompt<70> t<><74> th<74> *
|
||||
*<2A><>operato<74> fo<66> productio<69> information. *
|
||||
* *
|
||||
***********************************************************/
|
||||
|
||||
proc options(main);
|
||||
%replace true by '1'b,
|
||||
false by '0'b;
|
||||
|
||||
/* global variables */
|
||||
dcl
|
||||
(srce_drive char(1),
|
||||
dest_drive char(1),
|
||||
debug_flag bit(1),
|
||||
sec_per_trk fixed bin(15),
|
||||
copy_init_flag bit(1),
|
||||
seri_init_flag bit(1),
|
||||
org_number bit(16),
|
||||
ser_number bit(16)) external;
|
||||
|
||||
/* local variables */
|
||||
dcl
|
||||
ctrl_drive char(1),
|
||||
ctrl_drive_number fixed bin(7),
|
||||
srce_drive_number fixed bin(7),
|
||||
dest_drive_number fixed bin(7),
|
||||
first_time_flag bit(1),
|
||||
prod_number fixed bin(7),
|
||||
media_number fixed bin(7),
|
||||
prod_code char(3),
|
||||
response char(1),
|
||||
number_of_products fixed bin(7),
|
||||
system_flag bit(1),
|
||||
phy_sector_size fixed bin(15),
|
||||
skew_factor fixed bin(15),
|
||||
origin_number fixed dec(8,0),
|
||||
serial_number fixed dec(8,0),
|
||||
one_decimal fixed dec(1,0) static initial(1),
|
||||
initial_serial_number fixed dec(8,0),
|
||||
final_serial_number fixed dec(8,0);
|
||||
|
||||
/* th<74><68> serializatio<69> progra<72> calle<6C> i<> determine<6E> b<> th<74>
|
||||
<09><><EFBFBD>produc<75><63> numbe<62><65> selecte<74><65> b<> th<74><68> operato<74><6F> fro<72><6F> th<74>
|
||||
<09><><EFBFBD>produc<75><63> menu<6E><75> an<61><6E> mus<75><73> hav<61><76> th<74><68> filenam<61><6D> 'SERI-
|
||||
<09><><EFBFBD><product_code><3E> wher<65> <product_code<64> i<> <20> thre<72><65> digi<67>
|
||||
<09><><EFBFBD>numbe<62><65> whic<69> correspond<6E> t<> th<74> produc<75> numbe<62> i<> th<74>
|
||||
<09><><EFBFBD>menu<6E> Thi<68> fil<69> i<> loade<64> a<> a<> overla<6C> ove<76> th<74> roo<6F>
|
||||
<09><><EFBFBD>an<61><6E> cop<6F> overlay<61><79> fro<72> th<74> defaul<75> driv<69> befor<6F><72> th<74>
|
||||
<09><><EFBFBD>maste<74> cop<6F> dis<69> i<> inserte<74> */
|
||||
dcl
|
||||
serial_program char(10);
|
||||
|
||||
/* direct CP/M call for resetting drives */
|
||||
dcl
|
||||
curdsk entry returns(fixed bin(7)),
|
||||
select entry(fixed bin(7)),
|
||||
reset entry;
|
||||
|
||||
/* determine production control drive */
|
||||
ctrl_drive_number = curdsk();
|
||||
ctrl_drive = ascii(ctrl_drive_number + 65);
|
||||
|
||||
/* set up error conditions */
|
||||
on error(1)
|
||||
begin;
|
||||
put skip(2) list
|
||||
('Non-Fatal Error in Data Entry. Restarting.');
|
||||
put skip(2);
|
||||
goto operator_prompt;
|
||||
end;
|
||||
|
||||
/* write banner */
|
||||
put page skip(3) edit
|
||||
('DIGITAL RESEARCH PRODUCTION SERIALIZER',
|
||||
'******* ******** ********** **********')
|
||||
(2(x(15),a,skip));
|
||||
first_time_flag = true;
|
||||
|
||||
/* initialize production variables */
|
||||
do while(true);
|
||||
operator_prompt:
|
||||
copy_init_flag = false;
|
||||
seri_init_flag = false;
|
||||
put skip(5) list('Debugging Diagnostics On (Y or N) ? ');
|
||||
get list(response);
|
||||
response = upper(response);
|
||||
if response = 'Y' then
|
||||
debug_flag = true;
|
||||
else
|
||||
debug_flag = false;
|
||||
if debug_flag then
|
||||
put skip edit
|
||||
('Prod control drive -- ',ctrl_drive,':')
|
||||
(a,a(1),a);
|
||||
|
||||
call display_product_menu;
|
||||
put skip(2) list('Product Number ? ');
|
||||
get list(prod_number);
|
||||
if prod_number = 0 then system_flag = true;
|
||||
else if prod_number = 2 then system_flag = true;
|
||||
else if prod_number = 4 then system_flag = true;
|
||||
else if prod_number = 8 then system_flag = true;
|
||||
else if prod_number = 9 then system_flag = true;
|
||||
else if prod_number = 10 then system_flag = true;
|
||||
else system_flag = false;
|
||||
prod_code = convert(prod_number);
|
||||
|
||||
call media_defaults;
|
||||
|
||||
put skip list('Origin Number ? ');
|
||||
get list(origin_number);
|
||||
if origin_number > 65535 then
|
||||
signal error(1);
|
||||
put skip list('Starting Serial Number ? ');
|
||||
get list(initial_serial_number);
|
||||
if initial_serial_number > 65535 then
|
||||
signal error(1);
|
||||
put skip list('Final Serial Number ? ');
|
||||
get list(final_serial_number);
|
||||
if final_serial_number > 65535 |
|
||||
final_serial_number < initial_serial_number then
|
||||
signal error(1);
|
||||
put skip list('Source Drive ? ');
|
||||
get list(srce_drive);
|
||||
srce_drive = upper(srce_drive);
|
||||
srce_drive_number = rank(srce_drive) - 65;
|
||||
if srce_drive_number < 0 | srce_drive_number > 15
|
||||
then signal error(1);
|
||||
put skip list('Destination Drive ? ');
|
||||
get list(dest_drive);
|
||||
dest_drive = upper(dest_drive);
|
||||
dest_drive_number = rank(dest_drive) - 65;
|
||||
if dest_drive_number < 0 | dest_drive_number > 15
|
||||
then signal error(1);
|
||||
|
||||
/* cancel ON ERROR(1) condition */
|
||||
revert error(1);
|
||||
|
||||
/* load serialization overlay */
|
||||
serial_program = ctrl_drive || ':' || 'SERI-' || prod_code;
|
||||
call load_overlay(serial_program);
|
||||
|
||||
/* initialize serialization program before
|
||||
inserting master copy disk in current default drive */
|
||||
/* return with seri_init_flag set to true */
|
||||
call overlay(serial_program);
|
||||
|
||||
/* insert master copy disk */
|
||||
put skip(3) list
|
||||
('Insert Product Master Disk in Drive ' || srce_drive ||
|
||||
': and Type RETURN');
|
||||
get skip(2);
|
||||
call reset();
|
||||
|
||||
/* initialize copy segment from dpb of master disk */
|
||||
/* return with copy_init_flag set to true */
|
||||
call copy_routine;
|
||||
|
||||
/* convert origin number */
|
||||
org_number = dec8_to_bit16((origin_number));
|
||||
|
||||
/* copy and serialization loop */
|
||||
do serial_number = initial_serial_number to final_serial_number by one_decimal;
|
||||
ser_number = dec8_to_bit16((serial_number));
|
||||
put skip(3) edit
|
||||
('Preparing to copy and serialize ',origin_number,' - ',serial_number)
|
||||
(a,f(5));
|
||||
put skip(2) list
|
||||
('Insert new diskette in drive ' || dest_drive || ': and type RETURN');
|
||||
get skip;
|
||||
call reset();
|
||||
call copy_routine;
|
||||
call overlay(serial_program);
|
||||
end;
|
||||
|
||||
/* reselect and reinitialize production drive */
|
||||
if ctrl_drive = srce_drive | ctrl_drive = dest_drive then
|
||||
do;
|
||||
put skip(2) list
|
||||
('Insert Production Control Disk in Drive ' || ctrl_drive ||
|
||||
': and type RETURN');
|
||||
get skip;
|
||||
call reset();
|
||||
end;
|
||||
call select(ctrl_drive_number);
|
||||
first_time_flag = false;
|
||||
end; /* while loop */
|
||||
|
||||
/* utilities for root module */
|
||||
|
||||
display_product_menu:
|
||||
/*<2A>read<61><64> th<74> PRODUCT.DA<44> fil<69> an<61> associate<74><65> wit<69><74> eac<61>
|
||||
<09><><EFBFBD>produc<75><63> <20><> produc<75><63> numbe<62> whic<69> i<> selecte<74><65> b<><62> th<74>
|
||||
<09><><EFBFBD>operato<74> t<> determin<69> productio<69> */
|
||||
|
||||
proc;
|
||||
dcl
|
||||
product file,
|
||||
end_of_file bit(1),
|
||||
product_name char(78) varying,
|
||||
i fixed bin(7);
|
||||
|
||||
/* set return condition */
|
||||
on endfile(product)
|
||||
begin;
|
||||
i = i - 1;
|
||||
number_of_products = i;
|
||||
end_of_file = true;
|
||||
end;
|
||||
|
||||
/* open data file */
|
||||
open file(product) stream input
|
||||
title(ctrl_drive||':'||'PRODUCT.DAT');
|
||||
|
||||
/* display product menu */
|
||||
end_of_file = false;
|
||||
put skip(2) edit
|
||||
('PRODUCT LIST','******* ****') (2(x(7),a,skip));
|
||||
put skip;
|
||||
do i = 1 repeat(i + 1) while(^end_of_file);
|
||||
get file(product) list(product_name);
|
||||
if ^end_of_file then
|
||||
put skip list(product_name);
|
||||
end;
|
||||
close file(product);
|
||||
end display_product_menu;
|
||||
|
||||
media_defaults:
|
||||
/*<2A>displays the current defaults of the skew table and asks
|
||||
if the user would like to change any of the values */
|
||||
|
||||
proc;
|
||||
|
||||
phy_sector_size = 1;
|
||||
skew_factor = 2;
|
||||
put skip(2) edit
|
||||
('The current default values for the skew table are:',
|
||||
'Logical Sectors Per Physical Sector : ',phy_sector_size,
|
||||
'Physical Skew Factor : ',skew_factor,
|
||||
'Do you want to change these values (Y or N) ? ')
|
||||
(a,skip(2),a,f(2),skip,a,f(2),skip(2),a);
|
||||
get list(response);
|
||||
response = upper(response);
|
||||
if response = 'Y' then
|
||||
do;
|
||||
put skip list
|
||||
('New value for Logical Sectors Per Physical Sector ? ');
|
||||
get list(phy_sector_size);
|
||||
put list('New Value for Physical Skew Factor ? ');
|
||||
get list(skew_factor);
|
||||
end;
|
||||
|
||||
end media_defaults;
|
||||
|
||||
convert:
|
||||
/* converts integer to char string with leading zeros */
|
||||
proc(x) returns(char(3));
|
||||
dcl
|
||||
c char(9),
|
||||
x fixed bin(7),
|
||||
y fixed bin(15);
|
||||
y = x;
|
||||
y = y + 1000;
|
||||
c = char(y);
|
||||
return(substr(c,7,3));
|
||||
end convert;
|
||||
|
||||
load_overlay:
|
||||
/* loads .OVL file with drive and filename in 'name' */
|
||||
proc(name);
|
||||
dcl
|
||||
?ovlay entry(char(10),fixed bin(1)),
|
||||
name char(10);
|
||||
call ?ovlay(name,0);
|
||||
end load_overlay;
|
||||
|
||||
overlay:
|
||||
/* used to call .OVL file which has been loaded */
|
||||
proc(name);
|
||||
dcl
|
||||
?ovlay entry(char(10), fixed bin(1)),
|
||||
dummy entry,
|
||||
name char(10);
|
||||
call ?ovlay(name,0);
|
||||
call dummy;
|
||||
end overlay;
|
||||
|
||||
dec8_to_bit16:
|
||||
/* converts dec(8,0) to bit(16) */
|
||||
proc(dec_number) returns(bit(16));
|
||||
dcl
|
||||
dec_number fixed dec(8,0),
|
||||
signed_binary fixed dec(8,0) static initial(32768),
|
||||
sign_bit bit(1),
|
||||
bit_string bit(16);
|
||||
if dec_number >= signed_binary then
|
||||
do;
|
||||
dec_number = dec_number - signed_binary;
|
||||
sign_bit = '1'b;
|
||||
end;
|
||||
else
|
||||
sign_bit = '0'b;
|
||||
substr(bit_string,2) = binary(dec_number,15);
|
||||
substr(bit_string,1,1) = sign_bit;
|
||||
return(bit_string);
|
||||
end dec8_to_bit16;
|
||||
|
||||
upper:
|
||||
/* converts char(1) to upper case */
|
||||
proc(x) returns(char(1));
|
||||
dcl
|
||||
x char(1);
|
||||
return(translate(x,'ABCDEFGHIJKLMNOPQRSTUVWXYZ',
|
||||
'abcdefghijklmnopqrstuvwxyz'));
|
||||
end upper;
|
||||
|
||||
copy_routine:
|
||||
proc;
|
||||
/***********************************************************
|
||||
* *
|
||||
* Thi<68> trac<61> t<> trac<61> cop<6F> wit<69> verif<69> routin<69> i<> calle<6C> *
|
||||
*<2A><>b<EFBFBD><62><EFBFBD> th<74><68> roo<6F><6F> productio<69><6F> modul<75><6C> wit<69><74> th堠 globa<62> *
|
||||
*<2A><>variable<6C><65> fro<72><6F> th<74> roo<6F> module<6C><65> I<> set<65> it<69><74> loca<63> *
|
||||
*<2A><>variable<6C> fro<72> th<74> dis<69> paramete<74> bloc<6F> o<> th<74><68> sourc<72> *
|
||||
*<2A><>disk<73><6B><EFBFBD> an䠠 i<><69><EFBFBD> thu<68><75> intende<64><65> t<><74> b<><62> a<><61><EFBFBD> easil<69> *
|
||||
*<2A><>transportabl<62> a<> possible<6C> *
|
||||
* 01/07/81 DLD *
|
||||
* 07/07/82 DRL *
|
||||
* *
|
||||
***********************************************************/
|
||||
|
||||
/* global variable for the serialize_hex routines
|
||||
of the serializing programs. */
|
||||
dcl
|
||||
sector_offset fixed bin(15) external;
|
||||
|
||||
/* local variables */
|
||||
dcl
|
||||
disk_buffering bit(1), /* T = copy whole disk into RAM
|
||||
F = copy a few tracks at a time */
|
||||
disk_buff_diagnos char(3),
|
||||
k fixed bin(7),
|
||||
default_DMA_ptr ptr,
|
||||
default_DMA char(128) based(default_DMA_ptr),
|
||||
order fixed bin(15),
|
||||
sector fixed bin(15),
|
||||
track_series fixed bin(15),
|
||||
track fixed bin(15),
|
||||
max_track fixed bin(15),
|
||||
initial_track fixed bin(15),
|
||||
final_track fixed bin(15),
|
||||
number_of_tracks fixed bin(15),
|
||||
words_per_buffer fixed bin(15),
|
||||
tpb fixed bin(15), /* tracks per buffer */
|
||||
log_sectors_per_track fixed bin(15),
|
||||
phy_sectors_per_track fixed bin(15);
|
||||
|
||||
/* copy utilities */
|
||||
|
||||
/* direct cp/m functions */
|
||||
dcl
|
||||
seldsk entry (fixed(7)) returns (ptr),
|
||||
settrk entry (fixed(15)),
|
||||
setsec entry (fixed(15)),
|
||||
bstdma entry (ptr),
|
||||
bflush entry,
|
||||
rdsec entry returns (fixed(7)),
|
||||
wrsec entry returns (fixed(7)),
|
||||
sectrn entry (fixed(15),ptr) returns (fixed(15));
|
||||
dcl
|
||||
memptr entry returns (ptr),
|
||||
memsiz entry returns (fixed(15)),
|
||||
memwds entry returns (fixed(15)),
|
||||
dfcb0 entry returns (ptr),
|
||||
dfcb1 entry returns (ptr),
|
||||
dbuff entry returns (ptr),
|
||||
reboot entry,
|
||||
rdcon entry returns (char(1)),
|
||||
wrcon entry (char(1)),
|
||||
rdrdr entry returns (char(1)),
|
||||
wrpun entry (char(1)),
|
||||
wrlst entry (char(1)),
|
||||
coninp entry returns (char(1)),
|
||||
conout entry (char(1)),
|
||||
rdstat entry returns (bit(1)),
|
||||
getio entry returns (bit(8)),
|
||||
setio entry (bit(8)),
|
||||
wrstr entry (ptr),
|
||||
rdbuf entry (ptr),
|
||||
break entry returns (bit(1)),
|
||||
vers entry returns (bit(16)),
|
||||
reset entry,
|
||||
select entry (fixed(7)),
|
||||
open entry (ptr) returns (fixed(7)),
|
||||
close entry (ptr) returns (fixed(7)),
|
||||
sear entry (ptr) returns (fixed(7)),
|
||||
searn entry returns (fixed(7)),
|
||||
delete entry (ptr),
|
||||
rdseq entry (ptr) returns (fixed(7)),
|
||||
wrseq entry (ptr) returns (fixed(7)),
|
||||
make entry (ptr) returns (fixed(7)),
|
||||
rename entry (ptr),
|
||||
logvec entry returns (bit(16)),
|
||||
curdsk entry returns (fixed(7)),
|
||||
setdma entry (ptr),
|
||||
allvec entry returns (ptr),
|
||||
wpdisk entry,
|
||||
rovec entry returns (bit(16)),
|
||||
filatt entry (ptr),
|
||||
getdpb entry returns (ptr),
|
||||
getusr entry returns (fixed(7)),
|
||||
setusr entry (fixed(7)),
|
||||
rdran entry (ptr) returns (fixed(7)),
|
||||
wrran entry (ptr) returns (fixed(7)),
|
||||
filsiz entry (ptr),
|
||||
setrec entry (ptr),
|
||||
resdrv entry (bit(16)),
|
||||
wrranz entry (ptr) returns (fixed(7));
|
||||
|
||||
/* dynamic storage management */
|
||||
dcl
|
||||
maxwds entry returns(fixed bin(15)),
|
||||
allwds entry(fixed bin(15)) returns(ptr);
|
||||
|
||||
/* skew table */
|
||||
dcl
|
||||
skew_table_ptr ptr,
|
||||
skew_table(0:0) fixed bin(15) based(skew_table_ptr);
|
||||
|
||||
/* sector translation table */
|
||||
dcl
|
||||
dph ptr, /* disk parameter header */
|
||||
XLT_ptr ptr based(dph);
|
||||
|
||||
/* buffer management */
|
||||
dcl
|
||||
(buff_ptr, cbuff_ptr) ptr,
|
||||
buffer(0:0) char(128) based(buff_ptr),
|
||||
compare_buffer(0:0) char(128) based(cbuff_ptr);
|
||||
|
||||
/* allocation vector */
|
||||
dcl
|
||||
alloc_ptr ptr,
|
||||
alloc(1:1) bit(8) based(alloc_ptr);
|
||||
|
||||
/* disk parameter table */
|
||||
dcl
|
||||
dpb_ptr ptr,
|
||||
1 dpb based(dpb_ptr),
|
||||
2 spt fixed bin(15),
|
||||
2 bsh fixed bin(7),
|
||||
2 blm fixed bin(7),
|
||||
2 exm fixed bin(7),
|
||||
2 dsm fixed bin(15),
|
||||
2 drm fixed bin(15),
|
||||
2 fill bit(16),
|
||||
2 cks fixed bin(15),
|
||||
2 off fixed bin(7);
|
||||
|
||||
/* initialization */
|
||||
if ^copy_init_flag then
|
||||
do;
|
||||
copy_init_flag = true;
|
||||
|
||||
/* free previously allocated storage? */
|
||||
if ^first_time_flag then
|
||||
do;
|
||||
free skew_table_ptr -> skew_table;
|
||||
free buff_ptr -> buffer;
|
||||
free cbuff_ptr -> compare_buffer;
|
||||
end;
|
||||
|
||||
default_DMA_ptr = dbuff();
|
||||
call select(srce_drive_number);
|
||||
dph = seldsk(curdsk());
|
||||
sector_offset = sectrn(0,XLT_ptr);
|
||||
dpb_ptr = getdpb();
|
||||
sec_per_trk = spt;
|
||||
alloc_ptr = allvec();
|
||||
log_sectors_per_track = spt;
|
||||
phy_sectors_per_track = log_sectors_per_track / phy_sector_size;
|
||||
|
||||
/* initialize skew table */
|
||||
order = phy_sectors_per_track / gcd(skew_factor,phy_sectors_per_track);
|
||||
skew_table_ptr = allwds(log_sectors_per_track);
|
||||
do sector = 0 to log_sectors_per_track - 1;
|
||||
skew_table(sector) = log_skew(sector) + sector_offset;
|
||||
end;
|
||||
|
||||
number_of_tracks = calculate(srce_drive_number);
|
||||
if system_flag then
|
||||
initial_track = 0;
|
||||
else
|
||||
initial_track = off;
|
||||
final_track = off + number_of_tracks - 1;
|
||||
|
||||
tpb = min(calc_trk_buf(),final_track-initial_track+1);
|
||||
if (tpb < 1) then
|
||||
do;
|
||||
pu<70> ski<6B>(4) lis<69>
|
||||
('Insufficien<65> Buffe<66> Space to Perform Track Copying');
|
||||
put skip(3);
|
||||
stop;
|
||||
end;
|
||||
|
||||
/* allocate space for the buffers */
|
||||
words_per_buffer = 64 * spt * tpb;
|
||||
buff_ptr = allwds(words_per_buffer);
|
||||
if ^disk_buffering then
|
||||
cbuff_ptr = allwds(words_per_buffer);
|
||||
|
||||
/* message to operator */
|
||||
put skip(2) edit
|
||||
('Final track to copy: ',final_track)(a,f(6));
|
||||
|
||||
if debug_flag then
|
||||
do;
|
||||
put skip(2) list('Debugging Diagnostics:');
|
||||
if disk_buffering = true then
|
||||
disk_buff_diagnos = 'Yes';
|
||||
else
|
||||
disk_buff_diagnos = ' No';
|
||||
put skip edit
|
||||
('Number of log sec per trk: ',log_sectors_per_track,
|
||||
'Number of phy sec per trk: ',phy_sectors_per_track,
|
||||
'Buffering entire disk ? : ',disk_buff_diagnos,
|
||||
'First track to copy: ',initial_track,
|
||||
'Tracks per buffer: ',tpb,
|
||||
'Sector offset: ',sector_offset,
|
||||
'Skew factor: ',skew_factor,
|
||||
'Skew table:')
|
||||
(2(a,f(6),skip),a,x(3),a,skip,4(a,f(6),skip),a);
|
||||
put skip edit
|
||||
((skew_table(sector)
|
||||
do sector = 0 to log_sectors_per_track - 1))
|
||||
(15f(5),skip);
|
||||
end;
|
||||
return;
|
||||
end; /* of initialization */
|
||||
|
||||
/* track to track copy */
|
||||
put skip;
|
||||
do track_series = initial_track to final_track by tpb;
|
||||
max_track = min(track_series+tpb-1, final_track);
|
||||
put skip(0) edit
|
||||
('Copying tracks: ',track_series,' - ',max_track)
|
||||
(a,column(20),f(3),a,f(3));
|
||||
|
||||
/* read the source tracks if necessary */
|
||||
if ^disk_buffering | serial_number = initial_serial_number then
|
||||
do;
|
||||
call select(srce_drive_number);
|
||||
do track = track_series to max_track;
|
||||
call settrk(track);
|
||||
/* fill buffer from source */
|
||||
do sector = 0 to log_sectors_per_track - 1;
|
||||
call bstdma(addr(buffer(sub(track,sector))));
|
||||
call setsec(skew_table(sector));
|
||||
if rdsec() ^= 0 then
|
||||
do;
|
||||
put skip list('Fatal Read Error on Source');
|
||||
return;
|
||||
end;
|
||||
end; /* do sector */
|
||||
end; /* do track */
|
||||
end; /* if ^disk_buffering ... */
|
||||
call select(dest_drive_number);
|
||||
do track = track_series to max_track;
|
||||
call settrk(track);
|
||||
/* write buffer to destination */
|
||||
do sector = 0 to log_sectors_per_track - 1;
|
||||
call bstdma(addr(buffer(sub(track,sector))));
|
||||
call setsec(skew_table(sector));
|
||||
if wrsec() ^= 0 then
|
||||
do;
|
||||
put skip list('Fatal Write Error on Destination');
|
||||
return;
|
||||
end;
|
||||
end;
|
||||
|
||||
/* reread and compare destination with source */
|
||||
if disk_buffering then
|
||||
do;
|
||||
/* fill default DMA from destination for verification */
|
||||
call bstdma(default_DMA_ptr);
|
||||
do sector = 0 to log_sectors_per_track - 1;
|
||||
call setsec(skew_table(sector));
|
||||
if rdsec() ^= 0 then
|
||||
do;
|
||||
put skip list('Fatal Read Error on Destination');
|
||||
return;
|
||||
end;
|
||||
|
||||
/* compare and verify buffers */
|
||||
if default_DMA ^= buffer(sub(track,sector)) then
|
||||
do;
|
||||
put skip(2) edit
|
||||
('Verify Error on Track ',track,' Sector ',sector)
|
||||
(2(a,f(3)));
|
||||
return;
|
||||
end;
|
||||
end; /* do sector */
|
||||
end; /* if disk_buffering */
|
||||
else
|
||||
do;
|
||||
/* fill compare buffer for verification from destination */
|
||||
do sector = 0 to log_sectors_per_track - 1;
|
||||
call bstdma(addr(compare_buffer(sub(track,sector))));
|
||||
call setsec(skew_table(sector));
|
||||
if rdsec() ^= 0 then
|
||||
do;
|
||||
put skip list('Fatal Read Error on Destination');
|
||||
return;
|
||||
end;
|
||||
end; /* fill compare buffer */
|
||||
|
||||
/* compare buffers */
|
||||
do sector = 0 to log_sectors_per_track - 1;
|
||||
if buffer(sub(track,sector)) ^= compare_buffer(sub(track,sector))
|
||||
then
|
||||
do;
|
||||
put skip(2) edit
|
||||
('Verify Error on Track ',track,' Sector ',sector)
|
||||
(2(a,f(3)));
|
||||
return;
|
||||
end;
|
||||
end; /* compare buffers */
|
||||
end; /* else disk_buffering */
|
||||
end; /* do track */
|
||||
end; /* do track_series */
|
||||
|
||||
|
||||
/* force deblocking buffers to be flushed */
|
||||
call bflush();
|
||||
/* reset directory in memory */
|
||||
call reset();
|
||||
put skip;
|
||||
|
||||
log_skew:
|
||||
proc(x) returns(fixed bin(15));
|
||||
dcl
|
||||
(i,j) fixed bin(15),
|
||||
x fixed bin(15);
|
||||
j = mod(x, phy_sector_size);
|
||||
i = (x - j) / phy_sector_size;
|
||||
i = phy_skew(i);
|
||||
return(i * phy_sector_size + j);
|
||||
end log_skew;
|
||||
|
||||
phy_skew:
|
||||
proc(x) returns(fixed bin(15));
|
||||
dcl
|
||||
(i,j) fixed bin(15),
|
||||
x fixed bin(15);
|
||||
i = mod(x,order);
|
||||
j = (x - i) / order;
|
||||
i = mod(i * skew_factor, phy_sectors_per_track);
|
||||
return(i + j);
|
||||
end phy_skew;
|
||||
|
||||
calculate:
|
||||
proc(x) returns(fixed bin(15));
|
||||
dcl
|
||||
(i,j) fixed bin(15),
|
||||
x fixed bin(7),
|
||||
return_value fixed bin(15),
|
||||
current_drive fixed bin(7),
|
||||
old_dpb_ptr ptr,
|
||||
old_alloc_ptr ptr;
|
||||
|
||||
current_drive = curdsk();
|
||||
if current_drive ^= x then
|
||||
do;
|
||||
old_dpb_ptr = dpb_ptr;
|
||||
old_alloc_ptr = alloc_ptr;
|
||||
call select(x);
|
||||
dpb_ptr = getdpb();
|
||||
alloc_ptr = allvec();
|
||||
end;
|
||||
i = ceil(float(dsm+1) / 8.0);
|
||||
do i = i to 1 by -1 while(alloc(i) = '00'b4);
|
||||
end;
|
||||
do j = 8 to 1 by -1 while(substr(alloc(i),j,1)='0'b);
|
||||
end;
|
||||
return_value = ceil(float((((i-1)*8)+j)*(blm+1))/float(spt));
|
||||
if current_drive ^= x then
|
||||
do;
|
||||
dpb_ptr = old_dpb_ptr;
|
||||
alloc_ptr = old_alloc_ptr;
|
||||
call select(current_drive);
|
||||
end;
|
||||
return(return_value);
|
||||
end calculate;
|
||||
|
||||
calc_trk_buf:
|
||||
proc returns(fixed bin(15));
|
||||
dcl
|
||||
tracks_to_copy fixed bin(15),
|
||||
max_tracks fixed bin(15);
|
||||
|
||||
tracks_to_copy = final_track - initial_track + 1;
|
||||
max_tracks = maxwds() / (64*spt);
|
||||
if max_tracks >= tracks_to_copy then
|
||||
disk_buffering = true;
|
||||
else
|
||||
disk_buffering = false;
|
||||
if ^disk_buffering then
|
||||
max_tracks = max_tracks / 2; /* for track pairs */
|
||||
return(max_tracks);
|
||||
end calc_trk_buf;
|
||||
|
||||
sub:
|
||||
/* calculates the subscript to the buffer */
|
||||
proc(track,sector) returns(fixed bin(15));
|
||||
dcl
|
||||
(track,sector) fixed bin(15);
|
||||
|
||||
return((track-track_series)*spt + sector);
|
||||
end sub;
|
||||
|
||||
gcd:
|
||||
proc(m,n) returns(fixed bin(15)) recursive;
|
||||
/* greatest common divisor */
|
||||
dcl
|
||||
(m,n) fixed bin(15);
|
||||
i<> (<28> <20> 0<> the<68> <20> <20> -m;
|
||||
if (n < 0) then n = -n;
|
||||
if (m = 0) then return(n);
|
||||
if (n = 0) then return(m);
|
||||
if (m > n) then
|
||||
return(gcd(mod(m,n),n));
|
||||
return(gcd(m,mod(n,m)));
|
||||
end gcd;
|
||||
|
||||
end copy_routine;
|
||||
|
||||
end prod_root;
|
||||
Reference in New Issue
Block a user