Fortran is "ok"

[HRM Resident]

1983 vintage CP/M system running Fortran:


F0>type sort.for
C
C THIS ROUTINE IS A DEMOSTRATION OF A SHELL SORT
C
INTEGER T,A,D,FLAG,TIME(6),DATE(6),START,END
DIMENSION A(2000)
TYPE 'Shell sort'
TYPE
C
C GET HOW MANY NUMBERS TO SORT
C
88 ACCEPT 'How many numbers (2-2000) ',NN
IF (NN .LT. 2.OR.NN .GT. 2000)STOP
C
C GENERATE ARRAY OF NUMBERS TO SORT
C
DO 10 I=1,NN
10 A(I)=(RAND(0)*NN)+1
TYPE 'Starting sort'
D=NN
FLAG=0
C
100 D=IFIX((D+1)/2)
C
C TYPE OUT INTERMEDIATE STUFF
C
TYPE 'D=',D
C
110 ND=NN-D
DO 150 N=1,ND
IF (A(N) .LE. A(N+D))GO TO 150
NPD=N+D
T=A(N)
A(N)=A(NPD)
A(NPD)=T
FLAG=1
C
150 CONTINUE
IF (FLAG .EQ. 1)THEN
FLAG=0
GO TO 110
ENDIF
IF (D .GT. 1)GO TO 100
TYPE 'All done'
TYPE
C
C TYPE OUT SORTTED ARRAY
C
TYPE (A(I),I=1,NN)
GO TO 88
END

F0>
F0>
F0>fort sort

NEVADA FORTRAN 3.0 (MOD 0)
Copyright (C) 1979, 1980, 1981, 1982, 1983 Ian Kettleborough

***** ROUTINE: MAIN *****

No Compile errors



NO ASSEMBLY ERRORS. 47 LABELS WERE DEFINED.


RunCPM Version 6.0 (CP/M 60K)

F0>frun sort
Shell sort

How many numbers (2-2000) 500
Starting sort
D= 250
D= 125
D= 63
D= 32
D= 16
D= 8
D= 4
D= 2
D= 1
All done

6 6 6 8 8 9
10 12 13 16 16 16
17 18 18 19 20 22
23 24 24 24 26 26
27 29 30 30 31 32
33 34 34 35 37 37
38 38 38 39 39 40
41 42 44 47 48 49
49 49 50 55 57 57
58 58 58 58 59 59
61 62 66 66 68 68
71 72 75 75 78 79
81 82 82 84 85 85
85 86 87 87 87 88
91 92 92 92 93 94
96 96 99 100 101 101
102 102 102 103 103 105
105 108 109 112 112 114
116 120 121 123 125 127
130 130 130 131 131 133
133 133 134 135 136 140
140 143 144 145 147 147
149 150 150 151 151 155
158 160 161 163 164 164
165 165 167 168 168 168
169 172 172 173 174 175
177 178 179 179 179 181
183 183 183 184 184 186
187 189 189 191 192 194
195 197 197 199 199 200
201 201 204 205 207 209
209 210 211 211 213 213
213 213 215 215 216 216
219 221 222 222 223 224
224 225 226 227 227 228
228 228 230 231 233 236
237 238 238 240 240 242
243 243 244 244 245 246
248 248 249 250 250 253
254 254 255 255 258 259
260 260 262 262 263 263
265 266 267 268 268 268
269 269 269 270 270 271
271 274 275 275 275 275
277 280 281 282 282 282
283 283 284 285 285 285
287 287 289 289 289 290
290 290 291 292 294 294
295 296 296 298 298 298
299 301 302 303 303 304
306 307 307 309 309 312
315 316 317 319 319 320
320 321 321 322 322 325
326 327 328 328 329 330
330 330 331 331 336 336
340 340 341 342 345 346
347 347 348 348 348 348
349 351 353 354 355 356
360 361 361 361 362 365
366 366 368 368 368 368
373 373 374 375 375 376
377 377 378 379 381 381
383 383 384 386 386 396
397 397 397 398 399 399
400 404 406 406 406 407
407 407 409 409 410 410
410 411 411 414 414 415
417 421 421 423 423 424
424 424 425 426 427 430
431 431 434 435 435 435
438 438 441 441 441 443
444 444 446 447 448 448
449 449 452 453 454 454
454 454 456 460 461 462
463 463 463 464 464 464
464 464 465 466 468 468
468 468 469 470 470 471
472 473 473 474 475 476
477 477 478 479 479 479
480 481 482 482 484 485
485 485 485 488 489 490
492 493 493 494 494 494
495 495 496 498 499 499
499 499
How many numbers (2-2000) 0
STOP

F0>

--
HRM Resident

[James Warren]

Man, that's ugly.

[HRM Resident]

James Warren <jwwar...@gmail.com> writes:


>
> Man, that's ugly.

It is, because it was written by a 1980s FORTRAN burnout.

This is a real program:


{$R-,U-}

Program DIGIT(input,output);

{****************************************************************************}
{* *}
{* Program name: DIGIT ( analog to DIGITal conversion ) *}
{* *}
{* Operating System: MS-DOS 2.10 *}
{* *}
{* Function: This program responds to interrupts generated by the AM9513 *}
{* system timing controller on the 'Scientific Solutions' Lab *}
{* Master board. As each interrupt is detected, a 12 bit *}
{* digital data word is acquired from each of 4 channels on *}
{* the 6812A analog to digital converter module. *}
{* *}
{****************************************************************************}


const

{ DOS uses IRQ0 for the clock, IRQ1 for the keyboard, and IRQ6 for the }
{ NEC PD765 floppy disc controller. In addition, if a Winchester disc }
{ is installed, IRQ5 is reserved for this purpose. Therefore, IRQ2, }
{ IRQ3, IRQ4, and IRQ7 are available for user applications. The Lab }
{ Master board must be jumpered as per the IRQ selected. }

IRQ_CLK = 0;
IRQ_KBD = 1;
IRQ_2 = 2;
IRQ_3 = 3;
IRQ_AD_DONE = 4;
IRQ_5 = 5;
IRQ_6 = 6;
IRQ_TIMER = 7;

{ When the 8259 PIC generates an interrupt vector address, it produces }
{ a number equal to the IRQ line triggered plus a 5 bit offset that is }
{ set by the host computer during initialization. On the IBM PC this }
{ number is: 0 0 0 0 1 + x x x; where x x x is the IRQ requesting }
{ service. Therefore, the vector table entry is 8 + IRQ_line. }

IBM_PC_int_offset = 8; { 8259 offset used by IBM PC }

{ Turbo adds instructions to the start of the ISR procedures. }

overhead = 7;
base_address = $0710; { Base address of the Lab Master }
max_pix = 155;
vertical_pixels = 95;
maximum_12_bit_number = 4096;
plot_window : array[0..3,0..3] of integer = ( ( 1, 1, 156, 97 ),
( 162, 1, 317, 97 ),
( 1, 101, 156, 198 ),
( 162, 101, 317, 198 ) );



type
three_char = string[3]; { Three digit hex number }
two_char = string[2]; { Result of function Hex8 }

var
keyboard_vector_table_entry : integer;
AD_Done_vector_table_entry : integer;
timer_vector_table_entry : integer;

{ Original vector table entries }

system_keyboard_offset : integer;
system_keyboard_segment : integer;
system_AD_Done_offset : integer;
system_AD_Done_segment : integer;
system_timer_offset : integer;
system_timer_segment : integer;

IO_status : integer;

output_file_name : string[80];
output_file : text;

keyboard_scan_code : byte;
control_byte : byte;
reset_control_byte : byte;

interrupted : boolean;
done_conversion : boolean;
word : integer;
data_word : array[0..3] of integer;
mask : integer;
channel : integer;
AM9513_control : integer;
AM9513_data : integer;
rplot : real;
pixel_array : array[0..3,1..max_pix] of integer;
reset_AD : byte;

dsave : integer absolute cseg:$0006;




Procedure Get_Vector_Address(var offset, segment : integer;
vector : integer);

var
first_word, second_word : integer;

begin
first_word := vector * 4;
second_word := first_word + 2;
offset := memW[0000:first_word];
segment := memW[0000:second_word];
end;



Procedure Set_Vector_Address(offset, segment, vector : integer);

var
first_word, second_word : integer;

begin
first_word := vector * 4;
second_word := first_word + 2;

{ Disable interrupts while the vector table is modified }

inline($FA); { CLI }

memW[0000:first_word] := offset;
memW[0000:second_word] := segment;

inline($FB); { STI }
end;



Procedure Restore_Interrupt_Vector_Table;

begin

{ Restore original interrupt vectors so we leave the system }
{ as it was. }

Set_Vector_Address(system_keyboard_offset,
system_keyboard_segment,
keyboard_vector_table_entry);

Set_Vector_Address(system_AD_Done_offset,
system_AD_Done_segment,
AD_Done_vector_table_entry);

Set_Vector_Address(system_timer_offset,
system_timer_segment,
timer_vector_table_entry);

end;



Procedure Enable_IRQx(IRQx : byte);

{ The BIOS masks out all un-used interrupts upon initialization. This }
{ mask must be cleared before hardware interrupts from IRQx will be }
{ passed on to the CPU. }

var
imr, mask : integer;

begin
mask := not ( 1 shl IRQx );
imr := port[$21]; { Get Interrupt Mask Register from 8259 }
imr := imr and mask; { clear mask for IRQx ( bit x ) }
port[$21] := imr; { and return to interrupt controller }
end;



Procedure Disable_IRQx(IRQx : byte);

{ Set IRQx mask bit so interrupts from this source will not be passed }
{ on to the 8086. }

var
imr, mask : integer;

begin
mask := 1 shl IRQx;
imr := port[$21];
imr := imr or mask;
port[$21] := imr;
end;




Procedure ID;

begin
write(' Program DIGIT: ');
end;



Procedure Heading;

begin
clrscr;
ID; write('4 Channel A/D Conversion Program.');
write(' Version 1.01');
end;



Function Hex8(number : integer) : two_char;

const
table : array[$0000..$000F] of char = '0123456789ABCDEF';

var
hex_str : two_char;

begin
hex_str[2] := table[( number and $000F ) ];
hex_str[1] := table[( number and $00F0 ) shr 4 ];
hex_str[0] := char(2);
Hex8 := hex_str;
end;



Function Hex12(number : integer) : three_char;

const
table : array[$0000..$000F] of char = '0123456789ABCDEF';

var
hex_str : three_char;

begin
hex_str[3] := table[( number and $000F ) ];
hex_str[2] := table[( number and $00F0 ) shr 4 ];
hex_str[1] := table[( number and $0F00 ) shr 8 ];
hex_str[0] := char(3);
Hex12 := hex_str;
end;



Procedure Disk_Error(error : integer);

begin

{ Turn off acquisition when disk errors are detected }

Disable_IRQx(IRQ_TIMER);
Disable_IRQx(IRQ_AD_DONE);

{ Put system back the way it was }

Restore_Interrupt_Vector_Table;

Enable_IRQx(IRQ_KBD);

writeln;
ID; writeln('Disk error ',Hex8(error),' encountered with file ',
output_file_name);

writeln;

{ Try to close file, but don't worry about subsequent errors }

{$I-} close(output_file); {$I+}
ID; writeln('Aborting on file error');
halt;
end;



Procedure Get_Output_File_Name;

var
index : integer;
IO_status : integer;
file_exists : boolean;
answer : char;

begin
gotoxy(1,20);
ID; write('File name ( ''return'' = C:AD_DATA.HEX ) ? ');
read(output_file_name);
writeln;
if length(output_file_name) = 0 then
output_file_name := 'C:AD_DATA.HEX';

{ Convert file name to upper case for display }

for index := 1 to length(output_file_name) do
output_file_name[index] := upcase(output_file_name[index]);

assign(output_file,output_file_name);
{$I-} reset(output_file); {$I+}
IO_status := IOResult;
if ( IO_status <> 0 ) and ( IO_status <> 1 ) then Disk_Error(IO_status);
file_exists := ( IO_status = 0 );

if ( file_exists ) then
begin
repeat
Heading;
gotoxy(1,20);
ID; writeln('Disk already has a file named ',output_file_name);
ID; write('Over-write existing copy (Y/N) ? ');
read(kbd,answer);
answer := upcase(answer);
until ( answer in['Y','N'] );
if ( answer = 'N' ) then
begin
{$I-} close(output_file); {$I+}
halt;
end;
end;
end;



Procedure Create_File;


begin
assign(output_file,output_file_name);
{$I-} rewrite(output_file); {$I+}
IO_status := IOResult;
if not ( IO_status = 0 ) then Disk_Error(IO_status);
end;




Procedure Keyboard_ISR;


{ Handles interrupts generated by the keyboard }

begin

{ Save system state }

inline($FB { STI }
/$1E { PUSH DS }
/$50 { PUSH AX }
/$53 { PUSH BX }
/$51 { PUSH CX }
/$52 { PUSH DX }
/$57 { PUSH DI }
/$56 { PUSH SI }
/$06); { PUSH ES }

inline($8C/$C8/ { MOV AX,CS }
$8E/$D8/ { MOV DS,AX }
$A1/dsave/ { MOV AX,dsave }
$8E/$D8); { MOV DS,AX }

{ Get scan code for key pressed. Mask off MSB }

keyboard_scan_code := ($7F and port[$60]);

{ Reset controller }

control_byte := port[$61];
reset_control_byte := ( control_byte or $80 );
port[$61] := reset_control_byte;
port[$61] := control_byte;

{ Non-specific EOI to 8259 }

inline($FA/ { CLI }

$B0/$20/ { MOV AL,020H }
$E6/$20); { OUT 020H,AL }

{ Restore system state before returning from interrupt. }

inline( $07 { POP ES }
/$5E { POP SI }
/$5F { POP DI }
/$5A { POP DX }
/$59 { POP CX }
/$5B { POP BX }
/$58 { POP AX }
/$1F { POP DS }
/$CF); { IRET }

{ IRET re-enables further interrrupts }

end;




Procedure AD_Done_ISR;

begin

{ Save system state }

inline($FB { STI }
/$1E { PUSH DS }
/$50 { PUSH AX }
/$53 { PUSH BX }
/$51 { PUSH CX }
/$52 { PUSH DX }
/$57 { PUSH DI }
/$56 { PUSH SI }
/$06); { PUSH ES }

inline($8C/$C8/ { MOV AX,CS }
$8E/$D8/ { MOV DS,AX }
$A1/dsave/ { MOV AX,dsave }
$8E/$D8); { MOV DS,AX }


done_conversion := true;
word := ( port[ base_address + 5] ) or
( port[ base_address + 6] shl 8 );
word := word and $0FFF;

{ Non-specific EOI to 8259 }

inline($FA/ { CLI }

$B0/$20/ { MOV AL,020H }
$E6/$20); { OUT 020H,AL }


{ Restore system state before returning from interrupt. }

inline( $07 { POP ES }
/$5E { POP SI }
/$5F { POP DI }
/$5A { POP DX }
/$59 { POP CX }
/$5B { POP BX }
/$58 { POP AX }
/$1F { POP DS }
/$CF); { IRET }

{ IRET re-enables further interrrupts }

end;


Procedure Timer_ISR;

begin

{ Save system state }

inline($FB { STI }
/$1E { PUSH DS }
/$50 { PUSH AX }
/$53 { PUSH BX }
/$51 { PUSH CX }
/$52 { PUSH DX }
/$57 { PUSH DI }
/$56 { PUSH SI }
/$06); { PUSH ES }

inline($8C/$C8/ { MOV AX,CS }
$8E/$D8/ { MOV DS,AX }
$A1/dsave/ { MOV AX,dsave }
$8E/$D8); { MOV DS,AX }


interrupted := true;
reset_AD := port[base_address + 6];

for channel := 0 to 3 do
begin
done_conversion := false;
port[base_address + 5] := channel;
port[base_address + 6] := $FF;
Enable_IRQx(IRQ_AD_DONE);
repeat until done_conversion;
Disable_IRQx(IRQ_AD_DONE);
data_word[channel] := word;
end;

port[base_address + 7] := $FF;

{ Non-specific EOI to 8259 }

inline($FA/ { CLI }

$B0/$20/ { MOV AL,020H }
$E6/$20); { OUT 020H,AL }


{ Restore system state before returning from interrupt. }

inline( $07 { POP ES }
/$5E { POP SI }
/$5F { POP DI }
/$5A { POP DX }
/$59 { POP CX }
/$5B { POP BX }
/$58 { POP AX }
/$1F { POP DS }
/$CF); { IRET }

{ IRET re-enables further interrrupts }

end;




Procedure Integrity_Check( off, seg : integer);

{ Because of the variable overhead generated by compiler directives }
{ an integrity check is performed to ensure that the vector address }
{ actually contains the ISR. }

const
ISR_preamble : array[0..8] of byte =
( $FB, { STI }
$1E, { PUSH DS }
$50, { PUSH AX }
$53, { PUSH BX }
$51, { PUSH CX }
$52, { PUSH DX }
$57, { PUSH DI }
$56, { PUSH SI }
$06 ); { PUSH ES }

var
index : integer;


Procedure ISR_Error;

begin
ID; writeln('ISR vector is pointing to the wrong address.');
writeln;
ID; writeln('Check compiler directives');
writeln;
ID; writeln('Aborted ');
halt;
end;


begin
for index := 0 to 8 do
if not ( mem[seg:off + index] = ISR_preamble[index] ) then ISR_Error;
end;



Procedure Set_Keyboard_Vector_Table;

{ This routine modifies the IBM PC interrupt vector table in low }
{ memory to point to the local service routine for the interrupt }
{ generated by the keyboard. }

var
local_offset, local_segment : integer;

begin

local_offset := ofs(Keyboard_ISR) + overhead;
local_segment := cseg;
Set_Vector_Address(local_offset,local_segment,
keyboard_vector_table_entry);
Integrity_Check(local_offset,local_segment);
end;



Procedure Set_AD_Done_Vector_Table;

{ This routine modifies the IBM PC interrupt vector table in low }
{ memory to point to the local service routine for the interrupt }
{ generated by the the AD converter. }

var
local_offset, local_segment : integer;

begin

local_offset := ofs(AD_Done_ISR) + overhead;
local_segment := cseg;
Set_Vector_Address(local_offset,local_segment,
AD_Done_vector_table_entry);
Integrity_Check(local_offset,local_segment);
end;



Procedure Set_Timer_Vector_Table;

{ This routine modifies the IBM PC interrupt vector table in low }
{ memory to point to the local service routine for the interrupt }
{ generated by the the AM9513 timer. }

var
local_offset, local_segment : integer;

begin

local_offset := ofs(Timer_ISR) + overhead;
local_segment := cseg;
Set_Vector_Address(local_offset,local_segment,
timer_vector_table_entry);
Integrity_Check(local_offset,local_segment);
end;




Procedure Initialize_Variables;

begin
dsave := Dseg;
AM9513_data := base_address + 8;
AM9513_control := base_address + 9;

{ Apply PC offset to each interrupt source }

keyboard_vector_table_entry := IRQ_KBD + IBM_PC_int_offset;
AD_Done_vector_table_entry := IRQ_AD_DONE + IBM_PC_int_offset;
Timer_vector_table_entry := IRQ_TIMER + IBM_PC_int_offset;

{ Reset various program counters and control variables. }

interrupted := false;
keyboard_scan_code := 0;
end;




Procedure Re_Define_Vector_Table;

{ Replace existing interrupt vectors with ones pointing to }
{ local ISR's }

begin

{ Get existing interrupt vector values so we can restore them at }
{ the end of the program. }


Get_Vector_Address(system_keyboard_offset,
system_keyboard_segment,
keyboard_vector_table_entry);

Get_Vector_Address(system_AD_Done_offset,
system_AD_Done_segment,
AD_Done_vector_table_entry);

Get_Vector_Address(system_Timer_offset,
system_Timer_segment,
Timer_vector_table_entry);


Set_Keyboard_Vector_Table;
Set_AD_Done_Vector_Table;
Set_Timer_Vector_Table;
end;



Procedure Initialize_Lab_Master;

const
control_byte = $D0; { Bit 7 1 - disable auto-increment }
{ Bit 6 1 - interrupt when done }
{ Bit 5 0 - no interrupt on overrun }
{ Bit 4 1 - interrupt on timer output }
{ Bit 3 0 - no interrupt on ports }
{ Bit 2 0 - no external start conv. }
{ Bit 1 0 - no gain select 1 }
{ Bit 0 0 - no gain select 0 }

master_mode_select = $17; { Bit 7 0 - not used }
{ Bit 6 0 - not used }
{ Bit 5 0 - not used }
{ Bit 4 1 - E2 ( Element pointers ) }
{ Bit 3 0 - E1 }
{ Bit 2 1 - G4 ( Group pointers ) }
{ Bit 1 1 - G2 }
{ Bit 0 1 - G1 }

lower_control_byte = $00; { Bit 7 0 - Bits 7 - 4 are the FOUT }
{ Bit 6 0 source ( 0000 = F1 ) }
{ Bit 5 0 }
{ Bit 4 0 }
{ Bit 3 0 - comparator 1 disabled }
{ Bit 2 0 - comparator 2 disabled }
{ Bit 1 0 - time of day disabled }
{ Bit 0 0 }

upper_control_byte = $81; { Bit 7 1 - scalar control BCD division }
{ Bit 6 0 - enable increment }
{ Bit 5 0 - 8 bit bus width }
{ Bit 4 0 - FOUT on }
{ Bit 3 0 - bits 3- 0 are the FOUT }
{ Bit 2 0 divider ( 0001 = divide by }
{ Bit 1 0 1 ) }
{ Bit 0 1 }


disarm = $90; { Bit 7 1 - ( Bits 7 - 5 are the disarm }
{ Bit 6 0 command. ) }
{ Bit 5 0 }
{ Bit 4 1 - ( Bits 4 - 0 select the }
{ Bit 3 0 register. 10000 = 5 ) }
{ Bit 2 0 }
{ Bit 1 0 }
{ Bit 0 0 }

counter_mode_5 = $05; { Bit 7 0 - not used }
{ Bit 6 0 - not used }
{ Bit 5 0 - not used }
{ Bit 4 0 - E2 ( Element pointers ) }
{ Bit 3 0 - E1 }
{ Bit 2 1 - G4 ( Group pointers ) }
{ Bit 1 0 - G2 }
{ Bit 0 1 - G1 }

lower_counter_byte = $35; { Bit 7 0 - disable special gate }
{ Bit 6 0 - reload from load }
{ Bit 5 1 - count repetitively }
{ Bit 4 1 - BCD count }
{ Bit 3 0 - count down }
{ Bit 2 1 - active low terminal }
{ Bit 1 0 - count pulse }
{ Bit 0 1 }

upper_counter_byte = $0F; { Bit 7 0 - bits 7 -5 are the gating }
{ Bit 6 0 control ( 000 = no gating ) }
{ Bit 5 0 }
{ Bit 4 0 - bits 4 - 0 specify the }
{ Bit 3 1 count source ( 01111 = F5, }
{ Bit 2 1 100 Hz ) }
{ Bit 1 1 }
{ Bit 0 1 }

load_pointer_5 = $0D; { Bit 7 0 - not used }
{ Bit 6 0 - not used }
{ Bit 5 0 - not used }
{ Bit 4 0 - E2 ( Element pointers ) }
{ Bit 3 1 - E1 }
{ Bit 2 1 - G4 ( Group pointers ) }
{ Bit 1 0 - G2 }
{ Bit 0 1 - G1 }

BCD_99 = $99; { Bit 7 1 }
{ Bit 6 0 B }
{ Bit 5 0 C }
{ Bit 4 1 D }
{ Bit 3 1 }
{ Bit 2 0 9 }
{ Bit 1 0 9 }
{ Bit 0 1 }

BCD_03 = $03; { Bit 7 0 }
{ Bit 6 0 B }
{ Bit 5 0 C }
{ Bit 4 0 D }
{ Bit 3 0 }
{ Bit 2 0 0 }
{ Bit 1 1 3 }
{ Bit 0 1 }

load_and_arm = $70; { Bit 7 0 - bits 7 -5 are the load and }
{ Bit 6 1 arm command }
{ Bit 5 1 }
{ Bit 4 1 - bits 4 - 0 select the }
{ Bit 3 0 register ( 10000 = 5 ) }
{ Bit 2 0 }
{ Bit 1 0 }
{ Bit 0 0 }



begin

{ Set up the AM9513 as a low going pulse generator with no hardware }
{ gating. In this mode, the gate input does not effect counter }
{ operation. Once armed, the counter will count to TC repetitivly. }
{ On each TC the counter will re-load itself from the Load register; }
{ hence the load register value determines the time between TC's. A }
{ low going pulse is obtained by specifing the active low terminal }
{ count pulse mode in the Control Mode register. The 8259 PIC on the }
{ PC triggers on the rising edge of the wave. }

port[base_address + 4] := control_byte;

port[AM9513_control ] := disarm;

port[AM9513_control ] := master_mode_select;
port[AM9513_data ] := lower_control_byte;
port[AM9513_data ] := upper_control_byte;

port[AM9513_control ] := counter_mode_5;
port[AM9513_data ] := lower_counter_byte;
port[AM9513_data ] := upper_counter_byte;

port[AM9513_control ] := load_pointer_5;
port[AM9513_data ] := BCD_99;
port[AM9513_data ] := BCD_03;

port[AM9513_control ] := load_and_arm;
end;



Procedure Reset_Timer;

begin
port[AM9513_control] := $FF; { Master reset and clear any counters }
port[AM9513_control] := $5F; { that may be at TC }
end;



Procedure Frame(upper_left_X, upper_left_Y,
lower_right_X, lower_right_Y : integer );

begin
Draw( upper_left_X, upper_left_Y,
lower_right_X, upper_left_Y, 1 );

Draw(lower_right_X, upper_left_Y,
lower_right_X, lower_right_Y, 1 );

Draw(lower_right_X, lower_right_Y,
upper_left_X, lower_right_Y, 1 );

Draw( upper_left_X, lower_right_Y,
upper_left_X, upper_left_Y, 1 );
end;



Procedure Initialize_Graph;

var
index, loop, box : integer;

begin
GraphMode;
for box := 0 to 3 do
begin
Frame( plot_window[box,0] - 1, plot_window[box,1] - 1,
plot_window[box,2] + 1, plot_window[box,3] + 1);
for index := 1 to max_pix do
pixel_array[box,index] := 0;
end;
end;



Procedure Calculate_Pixels(box : integer);

var
index : integer;

begin
mask := ( data_word[box] and $0800 );
if not ( mask = 0 ) then
data_word[box] := 2048 - ( not ( data_word[box] and $07FF ) );
word := word + 2048;
for index := max_pix downto 2 do pixel_array[box,index] :=
pixel_array[box,index - 1];
rplot := int(data_word[box]);
rplot := rplot * vertical_pixels / maximum_12_bit_number;
pixel_array[box,1] := round(rplot) + 1;
end;



Procedure Plot_Graph(box : integer);

var
x, y1, y0, index : integer;

begin
x := plot_window[box,0] + 1;
for index := 1 to ( max_pix - 1 ) do
begin
if not ( pixel_array[box,index] = 0 ) then
begin
y0 := plot_window[box,3] - pixel_array[box,index];
y1 := plot_window[box,3] - pixel_array[box,index + 1];
plot(x, y1, 0 );
plot(x, y0, 1 );
end;
x := x + 1;
end;
end;



Procedure Display_Initial_Message;

var
dummy : char;

begin
Heading;
Get_Output_File_Name;
Heading;
gotoxy(5,20);
ID; write('Strike any key to initiate acquisition...');
read(kbd,dummy);
end;



Procedure Update_Disc;

var
index : integer;

begin
for index := 0 to 3 do write(output_file,' ',Hex12(data_word[index]));
writeln(output_file);
end;



Procedure Process_Acquired_Data;

var
channel : integer;

begin
Update_Disc;
for channel := 0 to 3 do
begin
Calculate_Pixels(channel);
Plot_Graph(channel);
end;
end;



begin
Initialize_Variables;
Display_Initial_Message;
Create_File;
Initialize_Graph;
Reset_Timer;
Initialize_Lab_Master;
Re_Define_Vector_Table;

port[base_address + 7] := $FF;

Enable_IRQx(IRQ_TIMER);

repeat
if ( interrupted ) then
begin
Process_Acquired_Data;
port[base_address + 7] := $FF;
interrupted := false;
end;
until keyboard_scan_code = $3C;

Disable_IRQx(IRQ_TIMER);
Disable_IRQx(IRQ_AD_DONE);

Restore_Interrupt_Vector_Table;
Reset_Timer;

TextMode(2);

{$I-} close(output_file); {$I+}
IO_status := IOResult;
if not ( IO_status = 0 ) then Disk_Error(IO_status);

end.

--
HRM Resident

[James Warren]

I'll credit you with claiming that it works.

The really interesting part is what you do with the data once
acquired.