?? NEWTITLE := '~~~~~   common deck DSI$TERMINATION_EDD_DUMP', EJECT ??

{ PURPOSE:
{   Dump the NOS/VE environment to the dump file.  The format of this file
{   is the same as an EDD dump tape excluding memory used by the 170
{   OS and anything that can not be retrieved without damaging the
{   170 process.

  PROCEDURE nosve_edd_dump;

?? PUSH (LISTEXT := ON) ??
*copyc dst$dft_puf_subfunctions
*copyc dst$dft_request_codes
*copyc dsi$dft_types_and_constants
*copyc dst$iou_number
*copyc ost$central_memory_model_number
*copyc ost$hardware_subranges
*copyc ost$iou_model_number
*copyc ost$processor_model_number
?? PUSH (LISTEXT := OFF) ??

    TYPE
      char_arr = PACKED ARRAY [1 .. 10] OF 0 .. 63;

    TYPE
      edd_register_format = PACKED ARRAY [1 .. 10] OF 0 .. 7777(8);

*copyc pxiotyp

{ PURPOSE:
{   Open binary labelled tape file as local file.

    PROCEDURE [XREF] bi#olt
      (VAR binary_file: file;
           file_name: string ( * );
           status: file_status;
           mode: file_mode;
           position: file_position);

    PROCEDURE [XREF] bi#put_tape ALIAS 'bi#putt'
      (    binary_file: file;
           pointer_to_source: ^cell;
           length_of_source: integer);

    PROCEDURE [XREF] bi#weof_tape ALIAS 'bi#weft'
      (    binary_file: file);

    PROCEDURE [XREF] p32to60
      (    word_count: integer;
           unpacked_data: ^cell;
           packed_data: ^cell);

    PROCEDURE [XREF] get_date_time ALIAS 'gtdttm'
      (VAR date: char_arr;
       VAR time: char_arr);

?? NEWTITLE := '~~~~~   procedure read_register', EJECT ??

{ PURPOSE:
{   Read a maintenance register either from the maintenance channel
{   via SDA (SDA passes a request to DFT) or from the ssr_register
{   list provided in the call.  The ssr register list register value
{   pre-empts the hardware value.
{
{   NOTE: The maintenance register port code for reading the maintenance
{   register is passed in 'pp_table.port_code' by the caller.

    TYPE
      register_list = ^ARRAY [1 .. * ] OF register_record;

    VAR
      register_block_buffer: PACKED RECORD
        tape_block_header: cell,
        register: ARRAY [1 .. 50] OF edd_register_format,
      RECEND,
      ssr_registers: register_list;

    PROCEDURE read_register
      (VAR edd_data: edd_register_format;
           register_number: integer;
           ssr_register_list: register_list;
           iou_number: dst$iou_number;
           maintenance_register_port_code: 0 .. 0fff(16));

{  Define type definition for DFT request to read a maintenance register.
{  It is defined in a 60 bit world but will be passed to DFT as 60 bits
{  in 64 bits right justified.

      TYPE
        dft_read_maintenance_register = PACKED RECORD

{  Word 0.

          response: 0 .. 0f(16),
          request: 0 .. 0ff(16),
          iou_number: 0 .. 0ff(16),
          unused: 0 .. 0ff(16),
          maintenance_register_port: 0 .. 0ffff(16),
          maintenance_register_number: 0 .. 0ffff(16),

{  word 1.

          maintenance_register_value_p: dst$r_pointer,
        RECEND,

{  Define type definition to describe format of maintenance register returned
{  by DFT.

        dft_maintenance_register_format = PACKED RECORD

{  Word 0.

          unused_1: 0 .. 0f(16),
          byte_1: 0 .. 0ff(16),
          unused_2: 0 .. 0ff(16),
          byte_2: 0 .. 0ff(16),
          unused_3: 0 .. 0ff(16),
          byte_3: 0 .. 0ff(16),
          unused_4: 0 .. 0ff(16),
          byte_4: 0 .. 0ff(16),

{  Word 1.

          unused_5: 0 .. 0f(16),
          byte_5: 0 .. 0ff(16),
          unused_6: 0 .. 0ff(16),
          byte_6: 0 .. 0ff(16),
          unused_7: 0 .. 0ff(16),
          byte_7: 0 .. 0ff(16),
          unused_8: 0 .. 0ff(16),
          byte_8: 0 .. 0ff(16),
        RECEND;

      VAR
        dft_request: dft_read_maintenance_register,
        ei_copy_memory_header: memory_copy_header,
        found: boolean,
        i: integer,
        maintenance_register: dft_maintenance_register_format,
        register: register_record,
        sda_request: pp_data_type;

      found := FALSE;
      register.length := 8;
      register.number := register_number;
      edd_data [1] := 8;
      edd_data [2] := register_number;

      IF ssr_register_list <> NIL THEN

      /check_saved_registers/
        FOR i := 1 TO UPPERBOUND (ssr_register_list^) DO
          IF ssr_register_list^ [i].number = register_number THEN
            register := ssr_register_list^ [i];
            found := TRUE;
            EXIT /check_saved_registers/;
          IFEND;
        FOREND /check_saved_registers/;
      IFEND;

      IF NOT found THEN

{  Read the register by passing a DFT request through SDA.

        dft_request.response := 0;
        dft_request.request := dsc$dft_read_maint_register;
        dft_request.iou_number := iou_number;
        dft_request.maintenance_register_port :=
              maintenance_register_port_code;
        dft_request.maintenance_register_number := register_number;
        dft_request.maintenance_register_value_p := dft_request_r_pointer;
        dft_request.maintenance_register_value_p.offset :=
              dft_request.maintenance_register_value_p.offset + 2;
        dft_request.maintenance_register_value_p.length := 2;

        sda_request.dft_request_length := 2;
        sda_request.ve_dft_request_p.offset := dft_request_r_pointer.offset;
        sda_request.ve_dft_request_p.rupper := dft_request_r_pointer.rupper;
        sda_request.ve_dft_request_p.rlower := dft_request_r_pointer.rlower;
        sda_request.os_170_dft_request_p := ^dft_request;
        callsda (write_dft_request_block, sda_request);

        IF dft_request.response <> normal_dft_response THEN
          dyfstring ('ERROR READING MAINTENANCE REGISTER.', user_dayf);
        IFEND;

{  Copy memory from where DFT returned register information to a local
{  variable.

        ei_copy_memory_header.pva_type := dft_request_pva_type;
        ei_copy_memory_header.byte_rma := dft_request_byte_rma + (2 * 8);
        ei_copy_memory_header.copy_method := ve60_to_nos60;
        ei_copy_memory_header.length := 2;
        copy_memory (ei_copy_memory_header, ^maintenance_register);

{  Move register to EDD format variable.

        edd_data [3] := maintenance_register.byte_1;
        edd_data [4] := maintenance_register.byte_2;
        edd_data [5] := maintenance_register.byte_3;
        edd_data [6] := maintenance_register.byte_4;
        edd_data [7] := maintenance_register.byte_5;
        edd_data [8] := maintenance_register.byte_6;
        edd_data [9] := maintenance_register.byte_7;
        edd_data [10] := maintenance_register.byte_8;
      ELSE

{  Reformat register data from saved registers.

        FOR i := 1 TO 8 DO
          edd_data [i + 2] := register.register_value [i];
        FOREND;
      IFEND;

    PROCEND read_register;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure create_dump_identifier_record', EJECT ??

{ PURPOSE:
{   Write the dump identifier record, DID, to the dump file.

    PROCEDURE create_dump_identifier_record;

      CONST
        all_nve_memory = 1,
        critical_nve_memory = 3,
        dual_state_dump_utility_version = 1,
        no_nve_memory = 2,
        nve_run_dump = 1;

      VAR
        did_record: PACKED RECORD
          tape_block_header: cell,
          ident: 0 .. 0ffff(16),
          memory_dumped: 0 .. 0ffff(16),
          fill1: 0 .. 0fffffff(16),
          fill2: integer,
        RECEND;

      format_edd_header ('DID', 0, dual_state_dump_utility_version);

      did_record.fill1 := 0;
      did_record.fill2 := 0;
      did_record.ident := 1;
      IF (memory_to_be_dumped = 'CRITICAL') THEN
        did_record.memory_dumped := critical_nve_memory;
      ELSEIF memory_to_be_dumped = 'NONE' THEN
        did_record.memory_dumped := no_nve_memory;
      ELSE
        did_record.memory_dumped := all_nve_memory;
      IFEND;

      bi#put_tape (vedump, ^did_record, 2);

    PROCEND create_dump_identifier_record;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure format_edd_header', EJECT ??

{ PURPOSE:
{   Write a header to the dump tape in EDD format.

    PROCEDURE format_edd_header
      (    idname: string (3);
           fwa: integer;
           dump_length: integer);

      TYPE
        dst$header_word_1 = PACKED RECORD
          ident: 0 .. 777777(8),
          radial: 0 .. 77(8),
          fwa: 0 .. 777777(8),
          length: 0 .. 777777(8),
        RECEND,

        dst$edd_header = PACKED RECORD
          word1: ALIGNED dst$header_word_1,
          word2: integer,
          word3: char_arr,
          word4: char_arr,
        RECEND;

      VAR
        dc_string: ^ARRAY [1 .. 4] OF PACKED ARRAY [0 .. 9] OF 0 .. 77(8),
        edd_header: [STATIC] string (20) := '***G******DSMTRM  00',
        si: ost$string_index,
        dcci: 0 .. 9,
        eol: boolean,
        i: integer,
        output_buffer: PACKED RECORD
          tape_block_header: cell,
          edd_header: dst$edd_header,
        RECEND;

      i := 1;
      dcci := 0;
      si := 1;
      eol := TRUE;
      dc_string := #LOC (output_buffer.edd_header.word1);
      edd_header (1, 3) := idname;
      utp$convert_string_to_dc_string (utc$ascii64, dc_string^, i, dcci,
            edd_header, si, eol);

      output_buffer.edd_header.word1.radial := pp_table.port_code DIV 100(16);
      output_buffer.edd_header.word1.fwa := fwa;
      output_buffer.edd_header.word1.length := dump_length;
      output_buffer.edd_header.word3 := os_date;
      output_buffer.edd_header.word4 := os_time;
      bi#put_tape (vedump, ^output_buffer, 4);

    PROCEND format_edd_header;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_iou_registers', EJECT ??

{ PURPOSE:
{   Dump the iou maintenance registers.

    PROCEDURE dump_iou_registers
      (    iou_info: dst$cc_iou_info);

      CONST
        max_number_of_imr = 30,

{  mr_offset is used in accessing the maintenance register values in the
{  options_installed_registers array.  This is necessary since the
{  procedure read_register returns byte zero of the desired maintenance
{  register in location 3 of the array.

        mr_offset = 3;

      VAR
        edd_header_id: string (3),
        i: 1 .. 4,

{  Define 2 dimensional array of IOU maintenance registers to dump.  The first
{  array is for I1 and I2 IOUs, the second is for I4 IOUs and the third is
{  for I4C IOUs.

        iou_registers: [STATIC] PACKED ARRAY [1 .. 4] OF PACKED ARRAY
          [1 .. max_number_of_imr] OF 0 .. 7777(8) := [ [0(16), 10(16),
          12(16), 18(16), 21(16), 30(16), 40(16), 80(16), 81(16), 0a0(16),
          0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],
          [0(16), 10(16), 12(16), 16(16), 18(16), 1c(16),
          21(16), 25(16), 30(16), 34(16), 40(16), 44(16), 80(16), 81(16),
          84(16), 85(16), 0a0(16), 0a4(16), 0b0(16), 0b1(16), 0b2(16),
          0b3(16), 0b4(16), 0b5(16), 0b6(16), 0b7(16), 0b8(16), 0b9(16),
          0, 0],
          [0(16), 10(16), 12(16), 18(16), 21(16), 30(16), 40(16), 80(16),
          81(16), 0a0(16), 0b0(16), 0b1(16), 0b2(16), 0b3(16), 0b4(16),
          0b5(16), 0b6(16), 0b7(16), 0b8(16), 0b9(16), 0c0(16), 0c1(16),
          0c2(16), 0c3(16), 0c4(16), 0c5(16), 0c6(16), 0c7(16), 0c8(16),
          0c9(16)],
          [0(16), 10(16), 12(16), 18(16), 21(16), 30(16), 40(16), 80(16),
          81(16), 0a0(16), 0b0(16), 0b1(16), 0b2(16), 0b3(16), 0, 0, 0,
          0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]],
        j: 1 .. max_number_of_imr,
        length: integer,
        number_of_imr_to_dump: 1 .. max_number_of_imr,
        options_installed_registers: edd_register_format;

{  Process IOU maintenance registers (IMx record).

      dyfstring ('DUMPING IMX', debug_log);

      IF ious_observed <> 0 THEN
        STRINGREP (edd_header_id (1, 3), length, ious_observed:3);
        edd_header_id (1, 2) := 'IM';  { Set header for secondary IOU.
      ELSE
        edd_header_id (1, 3) := 'IMR';  { Set header for primary IOU.
      IFEND;

      format_edd_header (edd_header_id, 0, 0);

{  Select the set of registers to be dumped.  This is a common set of
{  registers for all IOU's except for the I4 with the CIO subsystem and
{  for the I4C.  For an I4 with the CIO subsystem, two different cases
{  are processed:  the second barrel present or not.  The set of
{  registers to be dumped is specific to the I4 with the CIO subsystem in
{  both cases.  Registers b5 - b9 will only be dumped when both barrels
{  are present.  For an I4C registers b0 - b9 and c0 - c9 are dumped in
{  addition to the standard set of registers.

      i := 1;  { Default IOU type of I1 or I2.
      number_of_imr_to_dump := 10;

      CASE iou_info.element_id.model_number OF
      = osc$imn_40 =
        read_register (options_installed_registers, 12(16), NIL,
              ious_observed, iou_info.port_code);
        IF ((options_installed_registers[mr_offset+7] DIV 80(16))
          MOD 2) <> 0 THEN { CIO subsystem present
          i := 2;  { IOU type is I4.
          number_of_imr_to_dump := 23;
          read_register (options_installed_registers, 16(16), NIL,
                ious_observed, iou_info.port_code);
          IF ((options_installed_registers[mr_offset+2] DIV 2)
            MOD 2) <> 0 THEN { barrel 1 present
            number_of_imr_to_dump := 28;
          IFEND;
        IFEND;
      = osc$imn_44 =
        i := 3;
        number_of_imr_to_dump := 20;
        read_register (options_installed_registers, 12(16), NIL,
              ious_observed, iou_info.port_code);
        IF ((options_installed_registers[mr_offset+2] DIV 4(16))
          MOD 2) <> 0 THEN { barrel 2 is present
          IF ((options_installed_registers[mr_offset+2] DIV 8(16))
            MOD 2) <> 0 THEN { barrel 3 is present
            number_of_imr_to_dump := number_of_imr_to_dump + 10;
          ELSE
            number_of_imr_to_dump := number_of_imr_to_dump + 5;
          IFEND;
        IFEND;

     = osc$imn_42 =
       i := 4;
       number_of_imr_to_dump := 14
      ELSE

      CASEND;

      FOR j := 1 TO number_of_imr_to_dump DO
        read_register (register_block_buffer.register [j],
              iou_registers [i] [j], NIL, ious_observed, iou_info.port_code);
      FOREND;

      register_block_buffer.register [number_of_imr_to_dump + 1] [1] := 0;

      bi#put_tape (vedump, ^register_block_buffer,
            (number_of_imr_to_dump * 2) + 1);

      ious_observed := ious_observed + 1;

    PROCEND dump_iou_registers;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure determine_assigned_channels', EJECT ??

{ PURPOSE:
{   Determine which channels are assigned to NOS/VE by calling VER.

    PROCEDURE determine_assigned_channels
      (    max_number_of_chs: integer;
           iou_number: dst$iou_number;
       VAR channel_request: ver_request_block);

      VAR
        i: integer;

      FOR i := 1 TO max_number_of_chs DO
        IF i < 13 THEN  { Process NIO channels 0 - 13(8).
          channel_request.channels [i].primary := i - 1;
          channel_request.channels [i].kind := nio_channel;
        ELSEIF i > 24 THEN  { Process CIO channels 0 - 11(8).
          channel_request.channels [i].primary := i - 25;
          channel_request.channels [i].kind := cio_channel;
          { Note that it is not necessary to distinguish between barrel 0
          { and barrel 1 for the stct VER request.
        ELSE  { Process NIO channels 20 - 33(8).
          channel_request.channels [i].primary := i + 3;
          channel_request.channels [i].kind := nio_channel;
        IFEND;
        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
          channel_request.channels [i].kind := 0;
        IFEND;
        channel_request.channels [i].fill := 0;
        channel_request.channels [i].status := 0;
      FOREND;

      IF iou_number = 0 THEN

{  Primary IOU, call VER to determine which channels are assigned to NOS/VE.
{  All channels are assumed to be assigned to NOS/VE in secondary IOUs.

        channel_request.length := max_number_of_chs;
        channel_request.general_status := 0;
        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
          { use pre NOS 2.5.1 request code
          callver (channel_request, stch, TRUE);
        ELSE
          { use NOS 2.5.1 request code
          callver (channel_request, stct, TRUE);
        IFEND;
      IFEND;

    PROCEND determine_assigned_channels;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure determine_assigned_pps', EJECT ??

{ PURPOSE:
{   Determine which PPs are assigned to NOS/VE by calling VER.

    PROCEDURE determine_assigned_pps
      (    max_number_of_pps: integer;
           iou_number: dst$iou_number;
           cri: integer);

      VAR
        i: integer,
        offset: integer,
        pp_off: dst$cc_barrel_vector;

      FOR i := 1 TO max_number_of_pps DO
        IF i < 11 THEN  { Process non-driver pp's (numbered 0 - 11(8)).
          ver_request.pps [i].primary := i - 1;
          ver_request.pps [i].kind := non_driver_pp;
        ELSEIF i > 20 THEN  { Process CIO pp's (numbered 0 - 11(8)).
          ver_request.pps [i].primary := i - 21;
          ver_request.pps [i].kind := cio_cluster_0;
          { Note that it is not necessary to distinguish between barrel 0
          { and barrel 1 for the stpt VER request.
        ELSE  { Process driver pp's (numbered 20(8) - 31(8)).
          ver_request.pps [i].primary := i + 5;
          ver_request.pps [i].kind := driver_pp;
        IFEND;
        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
          ver_request.pps [i].kind := 0;
        IFEND;
        ver_request.pps [i].fill := 0;
        ver_request.pps [i].status := 0;
      FOREND;

      IF iou_number = 0 THEN

{  For IOU0, call VER to determine which PPs are assigned to NOS/VE.

        ver_request.length := max_number_of_pps;
        ver_request.general_status := 0;
        IF d7ty.eicb_version < dsc$eicb_version_4 THEN
          { use pre NOS 2.5.1 request code
          callver (ver_request, stpp, TRUE);
        ELSE
          { use NOS 2.5.1 request code
          callver (ver_request, stpt, TRUE);
        IFEND;
      ELSE

{  For IOU1, examine the IOU descriptor to determine which PPs could be assigned to NOS/VE.

        FOR i := 1 TO max_number_of_pps DO
          IF i < 11 THEN
            pp_off := configuration_record [cri].iou.pps_physically_missing.barrel_0;
            offset := 0;
          ELSEIF (i > 10) AND (i < 21) THEN
            pp_off := configuration_record [cri].iou.pps_physically_missing.barrel_1;
            offset := 10;
          ELSEIF i > 20 THEN
            pp_off := configuration_record [cri].iou.cpps_physically_missing;
            offset := 20;
          IFEND;
          IF pp_off [i - offset - 1] THEN
            ver_request.pps [i].status := 2;
          IFEND;
        FOREND;
      IFEND;

    PROCEND determine_assigned_pps;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure get_CIO_channel_status', EJECT ??

{ PURPOSE:
{   Read the corresponding B or C register to get the CIO channel status.

    PROCEDURE get_cio_channel_status
      (    cio_channel_number: integer;
           iou_number: dst$iou_number;
           iou_port_code: 0 .. 0fff(16);
       VAR channel_status: 0 .. 0f(16));

      TYPE
        b_register_bit_level = PACKED RECORD
          CASE register_fields OF
          = field_level =
            field: 0 .. 7777(8),
          = bit_level =
            fill: 0 .. 1777(8),
            bit1: 0 .. 1,
            bit2: 0 .. 1,
          CASEND,
        RECEND;

      TYPE
        register_fields = (bit_level, field_level);

      CONST
        channel_status_offset = 8,
        max_number_of_b_reg = 10,
        max_number_of_c_reg = 10;

      VAR
        b_registers: [STATIC] PACKED ARRAY [0 .. max_number_of_b_reg - 1] OF
          0 .. 7777(8) := [ 0b0(16), 0b1(16), 0b2(16), 0b3(16), 0b4(16),
          0b5(16), 0b6(16), 0b7(16), 0b8(16), 0b9(16)],
        bc_register_contents: edd_register_format,
        c_registers: [STATIC] PACKED ARRAY [0 .. max_number_of_c_reg - 1] OF
          0 .. 7777(8) := [ 0c0(16), 0c1(16), 0c2(16), 0c3(16), 0c4(16),
          0c5(16), 0c6(16), 0c7(16), 0c8(16), 0c9(16)],
        change_bits_around: b_register_bit_level,
        save_one_bit: 0 .. 1;

      CASE cio_channel_number OF
      = 0 .. 11(8) =
        read_register (bc_register_contents, b_registers [CIO_channel_number],
          NIL, iou_number, iou_port_code);
      = 20(8) .. 31(8) =
        read_register (bc_register_contents, c_registers [CIO_channel_number-20(8)],
          NIL, iou_number, iou_port_code);
      ELSE
        bc_register_contents [channel_status_offset] := 0;
      CASEND;

{  The order of the channel flag bits in the B and C registers is:
{     bit  44 active flag
{          45 full flag
{          46 channel error flag
{          47 channel flag
{  In the dump output record, bits 46 and 47 are switched around.
{  Therefore, the following code is needed to change the channel
{  flag and the channel error flag around.

      change_bits_around.field := bc_register_contents [channel_status_offset];
      save_one_bit := change_bits_around.bit1;
      change_bits_around.bit1 := change_bits_around.bit2;
      change_bits_around.bit2 := save_one_bit;

      channel_status := change_bits_around.field;

    PROCEND get_cio_channel_status;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure move_apqk_to_output_record', EJECT ??

{ PURPOSE:
{   Read the PP A, P, Q and K registers and format them into the EDD
{   output buffer.

    PROCEDURE move_apqk_to_output_record
      (VAR cm_header: memory_copy_header;
       VAR output_buffer: PACKED ARRAY [0 .. 8] OF 0 .. 0fff(16));

      TYPE
        temp_apqk_hold = PACKED RECORD
          fill1: 0 .. 0ffff(16),
          p1: 0 .. 0ff(16),
          p2: 0 .. 0ff(16),
          fill2: 0 .. 0ffff(16),
          q1: 0 .. 0ff(16),
          q2: 0 .. 0f(16),
          q3: 0 .. 0f(16),
          fill3: 0 .. 0ffff(16),
          k1: 0 .. 0ff(16),
          k2: 0 .. 0ff(16),
          fill4: 0 .. 3fff(16),
          a1: 0 .. 3(16),
          a2: 0 .. 0ff(16),
          a3: 0 .. 0ff(16),
        RECEND;

      VAR
        temp_apqk_buffer: temp_apqk_hold;

      copy_memory (cm_header, ^temp_apqk_buffer);

{  Move registers to the output buffer.

      output_buffer [0] := temp_apqk_buffer.p1;
      output_buffer [1] := temp_apqk_buffer.p2;
      output_buffer [2] := temp_apqk_buffer.q1;
      output_buffer [3] := temp_apqk_buffer.q2 * 10(16) + temp_apqk_buffer.q3;
      output_buffer [4] := temp_apqk_buffer.k1;
      output_buffer [5] := temp_apqk_buffer.k2;
      output_buffer [6] := temp_apqk_buffer.a1;
      output_buffer [7] := temp_apqk_buffer.a2;
      output_buffer [8] := temp_apqk_buffer.a3;

   PROCEND move_apqk_to_output_record;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure move_ch_status_to_output_record', EJECT ??

{ PURPOSE:
{   Read the channel status data and format it into the EDD output
{   buffer.

    PROCEDURE move_ch_status_to_output_record
      (VAR cm_header: memory_copy_header;
       VAR output_buffer: 0 .. 0f(16));

{  When the channel status is copied from 64 to 60 bit memory, the status
{  is at the beginning of the second 60-bit word.  Therefore, in the
{  following record the integers simply create fill for unused areas.

      TYPE
        temp_status_hold = PACKED RECORD
          fill1: integer,
          status: 0 .. 0f(16),
          fill2: integer,
        RECEND;

      VAR
        temp_status_buffer: temp_status_hold;

      copy_memory (cm_header, ^temp_status_buffer);
      output_buffer := temp_status_buffer.status;

   PROCEND move_ch_status_to_output_record;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_iou_contents', EJECT ??

{ PURPOSE:
{   Dump the A, P, Q and K registers and the contents of each pp
{   assigned to NOS/VE.  Also, dump the channel status for each
{   channel assigned to NOS/VE.

    PROCEDURE dump_iou_contents
      (    iou_number: dst$iou_number;
           iou_port_code: 0 .. 0fff(16);
           cri: integer);

{  Define the type definition for the DFT requests to dump PP information
{  and channel status.  In the DFT world these are 64 bit word  structures
{  but are defined such that the requests can be constructed in 60 bit and
{  each 60 bit word is moved into a 64 bit word right justified.

      TYPE
        dft_request_block = PACKED RECORD
          CASE dft_request_block_types OF
          = pp_utility_functions =

{  Word 0.

            pp_dft_response: 0 .. 0f(16),
            pp_dft_function: 0 .. 0ff(16),
            pp_iou_number: 0 .. 0ff(16),
            cio: 0 .. 0ff(16),
            pp_number: 0 .. 0ff(16),
            subfunction: 0 .. 0ff(16),
            pp_resume_address: 0 .. 0ffff(16),

{  Word 1.

            pp_dump_buffer: dst$r_pointer,
          = channel_status_function =

{  Word 0.

            c_dft_response: 0 .. 0f(16),
            c_dft_function: 0 .. 0ff(16),
            c_iou_number: 0 .. 0ff(16),
            channel_number: 0 .. 0ff(16),
            fill2: 0 .. 0ffffffff(16),

{  Word 1.

            c_dump_buffer: dst$r_pointer,
          CASEND,
        RECEND;

      TYPE
        dft_request_block_types = (pp_utility_functions,
                                   channel_status_function);

      CONST
        apqk_register_bytes_per_pp = 9,
        apqk_register_bytes_per_record = apqk_register_bytes_per_pp * 2 *
              max_pps_in_record,
        ch_status_bytes_per_record = max_channels_in_record * 2,
        cio_pp = 1,
        csf_record_cm_word_size = (max_channels_in_record * 8 * 2 + 59) DIV 60,
        data_rec_length_for_i4_mem = 2188,
        data_rec_length_for_non_i4_mem = 1096,
        dft_request_length = 2,
        max_channels_in_record = 38,
        max_number_of_nio_chs = 28,
        max_number_of_cio_chs = 10,
        max_number_of_nio_pps = 20,
        max_number_of_cio_pps = 10,
        max_pps_in_record = max_number_of_nio_pps + max_number_of_cio_pps,
        nio_pp = 0,
        prb_record_cm_word_size = ((apqk_register_bytes_per_pp * 2) *
              max_pps_in_record) DIV 5;

      VAR
        addr: integer,
        apqk_data: PACKED ARRAY [0 .. apqk_register_bytes_per_pp - 1]
              OF 0 .. 0fff(16),
        assigned_chs_buffer: ARRAY [1 .. max_channels_in_record] OF
              iou_resource,
        channel_data: 0 .. 0f(16),
        cm_header: memory_copy_header,

{  In the dump output record, the channel status is four bits and is right
{  justified in an 8-bit byte (ie 4/fill, 4/status).  If these 8-bit
{  bytes are packed into 60-bit words (170 CYBIL) there are four bits
{  left over in each word.  Therefore, the following variable is defined
{  in terms of 4-bit fields and the length is multiplied by 2.

        csf_buffer: PACKED RECORD
          tape_block_header: cell,
          channel_status: PACKED ARRAY [0 ..
                (ch_status_bytes_per_record * 2) - 1] OF 0 .. 0f(16),
        RECEND,
        dft_channel_request_block: dft_request_block,
        dft_pp_request_block: dft_request_block,
        entry: integer,
        i: integer,
        i4_present: boolean,
        i4c_present: boolean,
        j: integer,
        length: integer,
        logical_pp_number_base_8: 0 .. 31,
        max_number_of_chs: max_number_of_nio_chs .. max_number_of_nio_chs +
              max_number_of_cio_chs,
        max_number_of_pps: max_number_of_nio_pps .. max_number_of_nio_pps +
              max_number_of_cio_pps,
        mppn:  0 .. 31,  {  Temporary used to compute logical pp number(8)
        offset: integer,
        pp_buffer: PACKED RECORD
          tape_header_block: cell,
          memory: ALIGNED PACKED ARRAY [1 .. 2200] OF integer,
        RECEND,
        pp_size_cm_words: 0 .. 16383,
        pp_register_buffer: PACKED RECORD
          tape_header_block: cell,
          apqk_data: PACKED ARRAY [0 .. apqk_register_bytes_per_record - 1]
                OF 0 .. 0fff(16),
        RECEND,
        record_id: string (3),
        ver_channel_request: ver_request_block;

      IF nve_memory = 0 THEN
        RETURN;
      IFEND;

{  The IOU record will determine PP size based on IOU model number.
{  SDA dumps only 4K of NIO PPs because they have the 4K attribute
{  and the second 4K cannot be dumped.

      CASE configuration_record [cri].iou.element_id.model_number OF
      = osc$imn_40 =
        i4_present := TRUE;
        i4c_present := FALSE;
      = osc$imn_44 =
        i4_present := FALSE;
        i4c_present := TRUE;
      = osc$imn_42 =
        i4_present := TRUE;
        i4c_present := FALSE;
      ELSE
        i4_present := FALSE;
        i4c_present := FALSE;
      CASEND;

{  Obtain the 170 OS EICB version number.  If the value has already been
{  obtained (it is kept in a global variable external to this common deck),
{  then it will not be retrieved again.  Starting with version 4, a
{  distinction is made between driver and non-driver PP's on an 810/830, and
{  concurrent PP's and channels  may be present.  Due to these changes, there
{  is a new set of VER requests to be used; however, for compatibility, the
{  old versions of the requests need to be used when run with a 170 OS EICB
{  version number less than 4.

      IF NOT got_eicb_d7ty THEN
        get_dscb(dscb_d7ty, ^d7ty, 1);
        { the eicb entry d7ty.eicb_version will be used to choose VER functions
        got_eicb_d7ty:= TRUE;
      IFEND;
      IF (d7ty.eicb_version < dsc$eicb_version_4) OR i4c_present THEN
        max_number_of_pps := max_number_of_nio_pps;
        max_number_of_chs := max_number_of_nio_chs;
      ELSE
        max_number_of_pps := max_number_of_nio_pps + max_number_of_cio_pps;
        max_number_of_chs := max_number_of_nio_chs + max_number_of_cio_chs;
      IFEND;

{  Determine which PPs and channels are assigned to NOS/VE.

      determine_assigned_channels (max_number_of_chs - 4, iou_number,
            ver_channel_request);
      determine_assigned_pps (max_number_of_pps, iou_number, cri);

{  Move the assigned channels data to the assigned_chs_buffer which contains
{  space for channels 14(8) - 17(8).

      FOR i := 1 TO max_number_of_chs DO
        IF i < 12 THEN

{  Process channel data for channels 0 - 13(8).

          assigned_chs_buffer [i] := ver_channel_request.channels [i];

        ELSEIF i < 16 THEN

{  Set channel status for channels 14(8) - 17(8) to not assigned.

          assigned_chs_buffer [i].status := 2;

        ELSE

{  Process channel data for channels 20(8) and up.

          assigned_chs_buffer [i] := ver_channel_request.channels [i - 4];

        IFEND;
      FOREND;

      cm_header.pva_type := dft_request_pva_type;
      cm_header.byte_rma := dft_request_byte_rma +
            (dft_request_length * 8);
      dyfstrnum ('Dump IOU', iou_number, user_dayf);

{  Zero out pp register buffer.  This is the structure that will hold the A,
{  P, Q and K register data until the record is written to the dump file.

      FOR i := 0 TO apqk_register_bytes_per_record - 1 DO
        pp_register_buffer.apqk_data [i] := 0;
      FOREND;

{  Zero out csf_record.  This is the structure that will hold the channel
{  status data until the record is written to the dump file.

      FOR i := 0 TO (ch_status_bytes_per_record - 1) * 2 DO
        csf_buffer.channel_status [i] := 0;
      FOREND;

      pp_table.ve_dft_request_p.offset := dft_request_r_pointer.offset;
      pp_table.ve_dft_request_p.rupper := dft_request_r_pointer.rupper;
      pp_table.ve_dft_request_p.rlower := dft_request_r_pointer.rlower;

{  Initialize SDA request block for function write_dft_request_block.

      pp_table.dft_request_length := dft_request_length;
      pp_table.os_170_dft_request_p := ^dft_pp_request_block;

{  Initialize DFT PP request block to dump APQK only.  The APQK data will
{  be dumped to the SSR PP buffer following the DFT request block.
{  Therefore, the dump buffer r-register offset must be incremented by the
{  length of the DFT request block.

      dft_pp_request_block.pp_dft_function := dsc$dft_process_pp_function;
      dft_pp_request_block.pp_iou_number := iou_number;
      dft_pp_request_block.cio := 0;
      dft_pp_request_block.subfunction := dsc$dpuf_dump_pp_registers;
      dft_pp_request_block.pp_dump_buffer := dft_request_r_pointer;
      dft_pp_request_block.pp_dump_buffer.offset :=
            dft_pp_request_block.pp_dump_buffer.offset + dft_request_length;
      dft_pp_request_block.pp_dump_buffer.length := data_rec_length_for_i4_mem;

{  Initialize DFT channel request block.  The channel status data will
{  be dumped to the SSR PP buffer following the DFT request block.
{  Therefore, the dump buffer r-register offset must be incremented by the
{  length of the DFT request block.

      dft_channel_request_block.c_dft_function :=
            dsc$dft_get_nio_channel_status;
      dft_channel_request_block.c_iou_number := iou_number;
      dft_channel_request_block.fill2 := 0;
      dft_channel_request_block.c_dump_buffer :=
            dft_pp_request_block.pp_dump_buffer;

{  Loop through the PPs and dump the pre-idle set of A,P,Q and K
{  registers for each NOS/VE PP.  DFT dumps the register data to
{  dsc$ssr_pp_controlware_buf in the SSR.  The data is then
{  copied from the SSR, packing the 64 bit data into 60 bit words,
{  and is stored in pp register buffer.

      cm_header.copy_method := ve64_to_nos60;
      cm_header.length := 2;

    /before_idle_apqk_loop/
      FOR i := 0 TO max_number_of_pps - 1 DO
        IF ver_request.pps [i+1].status <= 1 THEN
          IF (i > 19) OR i4c_present THEN
            dft_pp_request_block.cio := cio_pp;
          ELSE
            dft_pp_request_block.cio := nio_pp;
          IFEND;
          dft_pp_request_block.pp_number := ver_request.pps [i+1].primary;
          dft_pp_request_block.pp_dft_response := 0;
          callsda (write_dft_request_block, pp_table);

          IF dft_pp_request_block.pp_dft_response =
                normal_dft_response THEN
            move_apqk_to_output_record (cm_header, apqk_data);
          ELSE

{  DFT request did not complete normally, set all values to a default of zero.

            FOR j := 0 TO 8 DO
              apqk_data [j] := 0;
            FOREND;
          IFEND;

          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2]
                := apqk_data [0];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 1]
                := apqk_data [1];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 2]
                := apqk_data [2];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 3]
                := apqk_data [3];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 4]
                := apqk_data [4];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 5]
                := apqk_data [5];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 6]
                := apqk_data [6];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 7]
                := apqk_data [7];
          pp_register_buffer.apqk_data [i * apqk_register_bytes_per_pp * 2 + 8]
                := apqk_data [8];

        IFEND;
      FOREND /before_idle_apqk_loop/;

{  Get pre-idle channel status.

    /before_idle_ch_status_loop/
      FOR i := 0 TO max_number_of_chs - 1 DO
        IF assigned_chs_buffer [i+1].status <= 1 THEN
          IF (i > 27) OR i4c_present THEN

{  CIO channel - get channel status from the corresponding B or C register.

            get_cio_channel_status (assigned_chs_buffer [i+1].primary,
                  iou_number, iou_port_code, channel_data);

          ELSE

{  NIO channel - get channel status through DFT request.

            dft_channel_request_block.channel_number :=
                  assigned_chs_buffer [i+1].primary;
            pp_table.dft_request_length := dft_request_length;
            pp_table.os_170_dft_request_p := ^dft_channel_request_block;
            dft_channel_request_block.c_dft_response := 0;
            callsda (write_dft_request_block, pp_table);

            IF dft_channel_request_block.c_dft_response =
                  normal_dft_response THEN
              move_ch_status_to_output_record (cm_header, channel_data);
            ELSE

{  DFT request did not complete normally, set channel status to zero.

              channel_data := 0;
            IFEND;
          IFEND;
          csf_buffer.channel_status [(i * 2) + 1] := channel_data;
        IFEND;
      FOREND /before_idle_ch_status_loop/;

{  Set DFT request block to idle PP only.

      dft_pp_request_block.subfunction := dsc$dpuf_idle_pp;
      pp_table.os_170_dft_request_p := ^dft_pp_request_block;
      pp_table.dft_request_length := dft_request_length;

{  Idle all NOS/VE PPs.

    /idle_pp_loop/
      FOR i := 0 TO max_number_of_pps - 1 DO
        IF ver_request.pps [i+1].status <= 1 THEN
          IF (i > 19) OR i4c_present THEN
            dft_pp_request_block.cio := cio_pp;
          ELSE
            dft_pp_request_block.cio := nio_pp;
          IFEND;
          dft_pp_request_block.pp_number := ver_request.pps [i+1].primary;
          dft_pp_request_block.pp_dft_response := 0;
          callsda (write_dft_request_block, pp_table);

          IF dft_pp_request_block.pp_dft_response <> normal_dft_response THEN

{  DFT request did not complete normally, issue dayfile message and continue.

            IF (dft_pp_request_block.cio = nio_pp) OR i4c_present THEN
              dyfstrnum ('Unable to idle pp', i, user_dayf);
            ELSE
              dyfstrnum ('Unable to idle CIO pp', i, user_dayf);
            IFEND;
          IFEND;
        IFEND;
      FOREND /idle_pp_loop/;

{  Get post-idle channel status.

    /after_idle_ch_status_loop/
      FOR i := 0 TO max_number_of_chs - 1 DO
        IF assigned_chs_buffer [i+1].status <= 1 THEN
          IF (i > 27) OR i4c_present THEN

{  CIO channel - get channel status from the corresponding B or C register.

            get_cio_channel_status (assigned_chs_buffer [i+1].primary,
                  iou_number, iou_port_code, channel_data);

          ELSE

{  NIO channel - get channel status through DFT request.

            dft_channel_request_block.channel_number :=
              assigned_chs_buffer [i+1].primary;
            pp_table.dft_request_length := dft_request_length;
            pp_table.os_170_dft_request_p := ^dft_channel_request_block;
            dft_channel_request_block.c_dft_response := 0;
            callsda (write_dft_request_block, pp_table);

            IF dft_channel_request_block.c_dft_response =
                  normal_dft_response THEN
              move_ch_status_to_output_record (cm_header, channel_data);
            ELSE

{  DFT request did not complete normally, set channel status to zero.

              channel_data := 0;
            IFEND;
          IFEND;
          csf_buffer.channel_status [(i * 2) + ch_status_bytes_per_record + 1]
                := channel_data;
        IFEND;
      FOREND /after_idle_ch_status_loop/;

{  Set DFT request block to dump APQK registers and PP memory.

      dft_pp_request_block.subfunction := dsc$dpuf_idle_dump_pp;
      pp_table.os_170_dft_request_p := ^dft_pp_request_block;
      pp_table.dft_request_length := dft_request_length;

{  Loop through the PPs and dump the post-idle set of A,P,Q and K registers
{  and the memory for each NOS/VE PP.  DFT dumps the register data and PP
{  memory to dsc$ssr_pp_controlware_buf in the SSR.  The register data is
{  copied from the SSR, packing the 64 bit data into 60 bit words and
{  storing it in pp register buffer.  Then the PP memory is copied from the
{  SSR to pp buffer, packing the 64 bit SSR contents into 60 bit words.

{  Zero out the pp buffer so that if dumping 8K NIO PPs the second half
{  will be all zeros.

      FOR i := LOWERBOUND(pp_buffer.memory) to UPPERBOUND(pp_buffer.memory) DO
        pp_buffer.memory [i] := 0;
      FOREND;

    /after_idle_apqk_and_memory_loop/
      FOR i := 0 TO max_number_of_pps - 1 DO
        IF ver_request.pps [i+1].status <= 1 THEN
          mppn := ver_request.pps [i+1].primary;
          logical_pp_number_base_8 := (mppn DIV 8) * 10 + mppn MOD 8;
          IF (i > 19) OR i4c_present THEN  { CIO PP being dumped
            dft_pp_request_block.cio := cio_pp;
            pp_size_cm_words := data_rec_length_for_i4_mem;
          ELSE  { NIO PP being dumped
            dft_pp_request_block.cio := nio_pp;
            IF i4_present OR i4c_present THEN
              pp_size_cm_words := data_rec_length_for_i4_mem;
            ELSE
              pp_size_cm_words := data_rec_length_for_non_i4_mem;
            IFEND;
          IFEND;

          dft_pp_request_block.pp_number := ver_request.pps [i+1].primary;
          dft_pp_request_block.pp_dft_response := 0;
          callsda (write_dft_request_block, pp_table);
          cm_header.length := 2;

          IF dft_pp_request_block.pp_dft_response = normal_dft_response THEN
            move_apqk_to_output_record (cm_header, apqk_data);
          ELSE

{  DFT request did not complete normally, set all values to a default of zero.

            FOR j := 0 TO 8 DO
              apqk_data [j] := 0;
            FOREND;
          IFEND;

          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 0] := apqk_data [0];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 1] := apqk_data [1];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 2] := apqk_data [2];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 3] := apqk_data [3];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 4] := apqk_data [4];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 5] := apqk_data [5];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 6] := apqk_data [6];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 7] := apqk_data [7];
          pp_register_buffer.apqk_data [apqk_register_bytes_per_pp *
                (2 * i + 1) + 8] := apqk_data [8];

          IF dft_pp_request_block.pp_dft_response = normal_dft_response THEN

{  Increment cm_header.byte_rma to point past the A,P,Q,K data
{  to the beginning of the PP memory and set the correct length.
{  Note that on an i4c the PPs must be treated as CIO in the
{  DFT requests since that is how DFT treats them.  However, as
{  far as constructing the dump record, they are treated as NIO
{  so the analyst will not have to specify the pp type parameter
{  when using the analyze dump utility.

            cm_header.byte_rma := cm_header.byte_rma + (2 * 8);
            IF i > 19 THEN  { CIO PP being dumped.
              dyfstrnum ('CPP dumped', logical_pp_number_base_8, user_dayf);
              record_id(1) := $CHAR (iou_number + $INTEGER ('D'));

{  Pack all 8K for CIO PPs.

              cm_header.length := data_rec_length_for_i4_mem;
            ELSE  { NIO PP being dumped.
              dyfstrnum ('PP dumped', logical_pp_number_base_8, user_dayf);
              record_id(1) := $CHAR (iou_number + $INTEGER ('I'));

{  Pack only 4K for NIO PPs except for the I4C.

              IF i4c_present THEN
                cm_header.length := data_rec_length_for_i4_mem;
              ELSE
                cm_header.length := data_rec_length_for_non_i4_mem;
              IFEND;
            IFEND;

            record_id(2) := $CHAR (logical_pp_number_base_8 DIV 10 +
                  $INTEGER ('0'));
            record_id(3) := $CHAR (logical_pp_number_base_8 MOD 10 +
                  $INTEGER ('0'));
            format_edd_header (record_id, 0, 0);
            copy_memory (cm_header, ^pp_buffer.memory);
            bi#put_tape (vedump, ^pp_buffer, pp_size_cm_words);

{  Decrement cm_header.byte_rma back to the A,P,Q,K data.

            cm_header.byte_rma := cm_header.byte_rma - (2 * 8);
          IFEND;
        IFEND;
      FOREND /after_idle_apqk_and_memory_loop/;

{  Write PSR (APQK registers) and CSF (channel status) records.

      IF iou_number <> 0 THEN
        STRINGREP (record_id (1, 3), length, iou_number:3);
        record_id (1, 2) := 'PS';  { Set header ID for secondary IOU.
      ELSE
        record_id (1, 3) := 'PSR';  { Set header ID for primary IOU.
      IFEND;

      format_edd_header (record_id, 0, 0);
      bi#put_tape (vedump, ^pp_register_buffer, prb_record_cm_word_size);

      IF iou_number <> 0 THEN
        STRINGREP (record_id (1, 3), length, iou_number:3);
        record_id (1, 2) := 'CS';  { Set header ID for secondary IOU.
      ELSE
        record_id (1, 3) := 'CSF';  { Set header ID for primary IOU.
      IFEND;

      format_edd_header (record_id, 0, 0);
      bi#put_tape (vedump, ^csf_buffer, csf_record_cm_word_size);

    PROCEND dump_iou_contents;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_mem_registers', EJECT ??

{ PURPOSE:
{   Dump the memory maintenance registers.

    PROCEDURE dump_mem_registers
      (    cm_info: dst$cc_central_memory_info);

      CONST
        base_number_of_mmr_to_dump = 6,
        max_number_of_mmr = 13;

      VAR
        i: 1 .. max_number_of_mmr,
        mem_registers: [STATIC] PACKED ARRAY [1 .. max_number_of_mmr]
          OF 0 .. 7777(8) := [0, 10(16), 12(16), 20(16), 21(16), 0a0(16),
          0a1(16), 0a2(16), 0a3(16), 0a4(16), 0a5(16), 0a6(16), 0a7(16)],
        number_of_mmr_to_dump: 1 .. max_number_of_mmr;

{  Process Memory Maintenance registers. (MMR)

      dyfstring ('DUMPING CM', debug_log);

      format_edd_header ('MMR', 0, 0);

      CASE cm_info.element_id.model_number OF

      = osc$cmmn_40, osc$cmmn_41, osc$cmmn_42 = { 990/990E/994/995E
        number_of_mmr_to_dump := base_number_of_mmr_to_dump + 7;

      ELSE

        mem_registers[base_number_of_mmr_to_dump+1] := 0a4(16);
        mem_registers[base_number_of_mmr_to_dump+2] := 0a8(16);
        number_of_mmr_to_dump := base_number_of_mmr_to_dump + 2;

      CASEND;

      FOR i := 1 TO number_of_mmr_to_dump DO
        read_register (register_block_buffer.register [i], mem_registers [i],
               NIL, 0, cm_info.port_code);
      FOREND;
      register_block_buffer.register [number_of_mmr_to_dump + 1] [1] := 0;

      bi#put_tape (vedump, ^register_block_buffer,
            (number_of_mmr_to_dump * 2) + 1);

    PROCEND dump_mem_registers;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure determine_dft_block_length', EJECT ??

{ PURPOSE:
{   Determine the length of the entire DFT block and each buffer making up
{   the DFT block.

    PROCEDURE determine_dft_block_length
      (    number_of_dft_buffers_to_dump: integer;
           dft_control_word: dst$dft_control_word;
       VAR dft_buffer_length_words: integer;
       VAR dft_buffer_lengths_p: ^ARRAY [ 0 .. * ] OF integer);

      VAR
        cm_header: memory_copy_header,
        dft_bi: integer,
        dftb_p_word: r_register_format;

      set_ei_pva (start_of_dft_buffer_0, 1);
      cm_header.byte_rma := 0;
      cm_header.length := 1;
      cm_header.copy_method := ve60_to_nos60;
      cm_header.pva_type := dft_buffer;
      dft_buffer_length_words := 0;

{  Get the length of the fixed part of the DFT buffer.  The length of the
{  fixed part of the DFT buffer has to be determined in one of two ways
{  depending on the revision level of the DFT block.  The PO field was
{  added at revision level 2.

        IF dft_control_word.rl < 2 THEN
          dft_buffer_length_words := dft_buffer_length_words +
                dft_control_word.nbuf + ((dsc$db_fixed_length +
                dsc$db_mainframe_element_l) DIV 8);
          dft_buffer_lengths_p^[0] := dsc$db_fixed_length +
                 dsc$db_mainframe_element_l + (dft_control_word.nbuf * 8);
        ELSEIF dft_control_word.rl < 4 THEN
          dft_buffer_length_words := dft_buffer_length_words +
                dft_control_word.nbuf + dft_control_word.po +
                (dsc$db_mainframe_element_l DIV 8);
          dft_buffer_lengths_p^[0] := ((dft_control_word.po +
                dft_control_word.nbuf) * 8) + dsc$db_mainframe_element_l;
        ELSE
          dft_buffer_length_words := dft_buffer_length_words +
                dft_control_word.po;
          dft_buffer_lengths_p^[0] := (dft_control_word.po * 8);
        IFEND;

{  Determine length of each variable DFT buffer.

        FOR dft_bi := (LOWERBOUND(dft_buffer_lengths_p^) + 1) TO
              number_of_dft_buffers_to_dump - 1 DO
          cm_header.byte_rma := cm_header.byte_rma + 8;
          copy_memory (cm_header, #LOC(dftb_p_word));
          dft_buffer_length_words := dft_buffer_length_words +
                dftb_p_word.length;
          dft_buffer_lengths_p^[dft_bi] := dftb_p_word.length * 8;
        FOREND;

    PROCEND determine_dft_block_length;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_critical_page_table', EJECT ??

{ PURPOSE:
{   Dump the critical page table.

    PROCEDURE dump_critical_page_table
      (    page_size_mask: 0 .. 177(8));

      CONST
        dump_block_size_bytes = dump_block_size * 15 DIV 2;

      VAR
        bytes_dumped_so_far: integer,
        cm_header: memory_copy_header,
        cptp_rma: integer,
        dump_length_60_bit_words: integer,
        dump_length_8_bit_bytes: integer,
        memory_buffer: PACKED RECORD
             tape_block_header: cell,
             words: ALIGNED PACKED ARRAY [1 .. dump_block_size] OF integer,
        RECEND,
        total_record_length: integer;

{  Determine the number of 170 CM words to dump.  This value must be
{  a multiple of 2 because of the conversion algorithm used by EI.
{  If it is not a multiple of 2 170 CM words, EI will abort the job.

      dump_length_60_bit_words := (cptp_r_pointer.length * 64) DIV 60;
      IF ((cptp_r_pointer.length * 64) MOD 60) <> 0 THEN
        dump_length_60_bit_words := dump_length_60_bit_words + 1;
      IFEND;
      IF (dump_length_60_bit_words MOD 2) <> 0 THEN
        dump_length_60_bit_words := dump_length_60_bit_words + 1;
      IFEND;
      format_edd_header ('CPT', page_size_mask, cptp_r_pointer.length);

{  Determine the rma of the critical page table.

      cptp_rma := cptp_r_pointer.rupper * 10000000(8) + cptp_r_pointer.rlower *
           1000(8) + cptp_r_pointer.offset * 10(8);

      dump_length_8_bit_bytes := (cptp_r_pointer.length * 8);
      bytes_dumped_so_far := 0;
      total_record_length := 0;
      cm_header.length := dump_block_size;
      cm_header.copy_method := ve64_to_nos60;
      cm_header.pva_type := start_of_ve;
      cm_header.byte_rma := cptp_rma - load_offset_bytes;

      WHILE (bytes_dumped_so_far + dump_block_size_bytes) < dump_length_8_bit_bytes DO
        copy_memory (cm_header, ^memory_buffer.words);
        bi#put_tape (vedump, ^memory_buffer, #SIZE (memory_buffer.words));
        cm_header.byte_rma := cm_header.byte_rma + dump_block_size_bytes;
        total_record_length := total_record_length + #SIZE (memory_buffer.words);
        bytes_dumped_so_far := bytes_dumped_so_far + dump_block_size_bytes;
      WHILEND;

{  Dump the remainder of the critical page table.

      cm_header.length := dump_length_60_bit_words - total_record_length;
      copy_memory (cm_header, ^memory_buffer.words);

      bi#put_tape (vedump, ^memory_buffer, cm_header.length);

    PROCEND dump_critical_page_table;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_critical_memory', EJECT ??

{ PURPOSE:
{   Dump only the critical NOS/VE memory as defined by the critical page table.

    PROCEDURE dump_critical_memory
      (    page_size_mask: 0 .. 177(8));

      CONST
        dump_block_size_bytes = dump_block_size * 15 DIV 2;

      VAR
        bit_index: 0 .. 63,
        bytes_dumped_so_far: integer,
        cm_header: memory_copy_header,
        cpt_header: memory_copy_header,
        cpt_word: PACKED ARRAY [0 .. 119] OF 0 .. 1,
        cptp_rma: integer,
        end_of_word_reached: boolean,
        fill_words_in_last_page: integer,
        index: 1 .. 7,
        last_page_bit_index: 0 .. 63,
        last_page_found: boolean,
        last_page_length_60_bit_words: integer,
        last_page_length_8_bit_bytes: integer,
        last_page_word_index: integer,
        mask: integer,
        memory_buffer: PACKED RECORD
          tape_block_header: cell,
          words: ALIGNED PACKED ARRAY [1 .. dump_block_size] OF integer,
        RECEND,
        page_dump_length_60_bit_words: integer,
        page_dump_length_8_bit_bytes: integer,
        page_frame_number: integer,
        page_frame_number_left: integer,
        page_frame_number_right: integer,
        page_rma: integer,
        page_size: integer,
        total_record_length: integer,
        word_index: integer;

      dyfstring ('cm dump - critical memory.', system_dayf);

{  Determine the page size from the page size mask.

      page_size := 512;
      mask := page_size_mask;

      FOR index := 1 TO 7 DO
        IF (mask MOD 2) = 0 THEN
          page_size := page_size * 2;
          mask := mask DIV 2;
        IFEND;
      FOREND;

{  Initialize copy memory parameters for reading each word of the critical page table.

      cpt_header.length := 2;
      cpt_header.copy_method := ve64_to_nos60;
      cpt_header.pva_type := start_of_ve;
      cptp_rma := cptp_r_pointer.rupper * 10000000(8) + cptp_r_pointer.rlower *
           1000(8) + cptp_r_pointer.offset * 10(8);
      cpt_header.byte_rma := cptp_rma - load_offset_bytes + (cptp_r_pointer.length - 1);

{  Initialize parameters for reading each page of memory.

      page_dump_length_60_bit_words := ((page_size DIV 8) * 64) DIV 60;
      IF (((page_size DIV 8) * 64) MOD 60) <> 0 THEN
        page_dump_length_60_bit_words := page_dump_length_60_bit_words + 1;
      IFEND;
      IF (page_dump_length_60_bit_words MOD 2) <> 0 THEN
        page_dump_length_60_bit_words := page_dump_length_60_bit_words + 1;
      IFEND;
      page_dump_length_8_bit_bytes := (page_dump_length_60_bit_words * 60) DIV 8;

      last_page_length_60_bit_words := ((page_size DIV 8) * 64) DIV 60;
      fill_words_in_last_page := 0;
      IF (((page_size DIV 8) * 64) MOD 60) <> 0 THEN
        fill_words_in_last_page := 1;
      IFEND;
      IF (last_page_length_60_bit_words MOD 2) <> 0 THEN
        last_page_length_60_bit_words := last_page_length_60_bit_words - 1;
        fill_words_in_last_page := fill_words_in_last_page + 1;
      IFEND;
      last_page_length_8_bit_bytes := (last_page_length_60_bit_words * 60) DIV 8;

      cm_header.copy_method := ve64_to_nos60;
      cm_header.pva_type := start_of_ve;

{  Find the bit that corresponds to the last page of NOS/VE assigned memory.  Memory must be
{  dumped in 60 bit words and EI requires an even number of 60 bit words to be dumped.  Therefore,
{  if the number of 64 bit words does not fit exactly into 60 bit words or if the number of 60 bit
{  words is not even, then the number of 60 bit words is rounded up.  This works fine for all pages
{  except the last page of NOS/VE assigned memory.  Rounding up for the last page would cause an
{  attempt to dump a few bytes past the end of NOS/VE assigned memory and EI would abort the NVE
{  subsystem.  Therefore, for the last page only, the number of 60 bit words is rounded down instead
{  of up when copied through EI.  Then when written to the dump tape, an extra word of fill is
{  written, if necessary, to ensure that the dump tape record is at least a full page.

      cpt_header.byte_rma := cptp_rma - load_offset_bytes + ((cptp_r_pointer.length - 1) * 8);
      word_index := cptp_r_pointer.length - 1;
      last_page_found := FALSE;
      WHILE NOT last_page_found DO
        copy_memory (cpt_header, ^cpt_word);
        cpt_header.byte_rma := cpt_header.byte_rma - 8;

{  Scan this word backwards to see if it contains the last bit set in the critical page table.

        bit_index := 63;
        end_of_word_reached := FALSE;
        WHILE NOT end_of_word_reached DO
          IF cpt_word [bit_index] = 1 THEN
            last_page_word_index := word_index;
            last_page_bit_index := bit_index;
            last_page_found := TRUE;
            end_of_word_reached := TRUE;
          IFEND;
          IF bit_index = 0 THEN
            end_of_word_reached := TRUE;
          ELSE
            bit_index := bit_index - 1;
          IFEND;
        WHILEND;
        word_index := word_index - 1;
      WHILEND;

{  Scan the critical page table and dump the corresponding page of memory for each bit that is set.

      cpt_header.byte_rma := cptp_rma - load_offset_bytes;
      FOR word_index := 0 TO cptp_r_pointer.length - 1 DO

{  Get the next word from the critical page table.

        copy_memory (cpt_header, ^cpt_word);
        cpt_header.byte_rma := cpt_header.byte_rma + 8;

{  Scan each bit in this critical page table word.  If set, then dump the corresponding page of memory.

        FOR bit_index := 0 TO 63 DO
          IF cpt_word [bit_index] = 1 THEN

{  Determine the page frame number and write the EDD header record.

            page_frame_number := word_index * 64 + bit_index;
            page_frame_number_left := page_frame_number DIV 1000000(8);
            page_frame_number_right := page_frame_number MOD 1000000(8);
            format_edd_header ('CCM', page_frame_number_left, page_frame_number_right);

{  Copy the page of memory to the dump tape.

            bytes_dumped_so_far := 0;
            total_record_length := 0;
            page_rma := page_frame_number * page_size;
            cm_header.byte_rma := page_rma - load_offset_bytes;
            cm_header.length := dump_block_size;

            IF (word_index <> last_page_word_index) OR (bit_index <> last_page_bit_index) THEN

              WHILE (bytes_dumped_so_far + dump_block_size_bytes) < page_dump_length_8_bit_bytes DO
                copy_memory (cm_header, ^memory_buffer.words);
                bi#put_tape (vedump, ^memory_buffer, #SIZE (memory_buffer.words));
                cm_header.byte_rma := cm_header.byte_rma + dump_block_size_bytes;
                total_record_length := total_record_length + #SIZE (memory_buffer.words);
                bytes_dumped_so_far := bytes_dumped_so_far + dump_block_size_bytes;
              WHILEND;

{  Dump the remainder of the critical page.

              cm_header.length := page_dump_length_60_bit_words - total_record_length;
              copy_memory (cm_header, ^memory_buffer.words);

              bi#put_tape (vedump, ^memory_buffer, cm_header.length);

            ELSE

{  Dump the last page of NOS/VE memory.

              WHILE (bytes_dumped_so_far + dump_block_size_bytes) < last_page_length_8_bit_bytes DO
                copy_memory (cm_header, ^memory_buffer.words);
                bi#put_tape (vedump, ^memory_buffer, #SIZE (memory_buffer.words));
                cm_header.byte_rma := cm_header.byte_rma + dump_block_size_bytes;
                total_record_length := total_record_length + #SIZE (memory_buffer.words);
                bytes_dumped_so_far := bytes_dumped_so_far + dump_block_size_bytes;
              WHILEND;

{  Dump the remainder of the last page.

              cm_header.length := last_page_length_60_bit_words - total_record_length;
              copy_memory (cm_header, ^memory_buffer.words);

              IF (((page_size DIV 8) * 64) MOD 60) <> 0 THEN

{  A word of fill is needed.

                bi#put_tape (vedump, ^memory_buffer, cm_header.length + 1);

              ELSE

                bi#put_tape (vedump, ^memory_buffer, cm_header.length);

              IFEND;
            IFEND;
          IFEND;
        FOREND;
      FOREND;

    PROCEND dump_critical_memory;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure get_page_size_mask', EJECT ??

{ PURPOSE:
{   Get the page size mask from the CPU register, 4A.

    PROCEDURE get_page_size_mask
      (VAR page_size_mask: 0 .. 177(8));

      VAR
        cpu_port_code: 0 .. 0fff(16),
        cpu_register_4a_contents: edd_register_format,
        index: integer,
        port_code_found: boolean;

{  Find a CPU port code to use.

      port_code_found := FALSE;
      index := LOWERBOUND(configuration_record);
      REPEAT
        CASE configuration_record [index].processor.id OF
        = dsc$id_processor_info =
          port_code_found := TRUE;

        ELSE

          index := index + 1;

        CASEND;

      UNTIL port_code_found = TRUE;

      cpu_port_code := configuration_record [index].processor.port_code;

{  Read CPU register 4A.

      read_register (cpu_register_4a_contents, 4A(16), ssr_registers, 0, cpu_port_code);
      page_size_mask := cpu_register_4a_contents [10];

    PROCEND get_page_size_mask;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_memory', EJECT ??

{ PURPOSE:
{   Dump the memory used by NOS/VE (if specified by the *DUMP= command), the DFT buffers
{   if they exist and the EI control block (EICB).

    PROCEDURE dump_memory;

      CONST
        dump_block_size_bytes = dump_block_size * 15 DIV 2;

      TYPE
        dst$dscb_d7ty = PACKED RECORD
          fill: 0 .. 3f(16),
          date: 0 .. 3ffff(16),
          time: 0 .. 3ffff(16),
          os_type_170: 0 .. 3f(16),
          interface_block_version_number: 0 .. 3f(16),
          interface_block_level_number: 0 .. 3f(16),
        RECEND,

        dst$dscb_d8ty = PACKED RECORD
          fill: 0 .. 3ffffffff(16),
          ei_version_number: 0 .. 0ff(16),
          os_type_180: 0 .. 3f(16),
          interface_block_version_number: 0 .. 3f(16),
          interface_block_level_number: 0 .. 3f(16),
        RECEND,

        dst$four_bit_array = PACKED ARRAY [1 .. (dump_block_size * 15)] OF
              0 .. 0f(16);

      PROCEDURE catenate_64_to_60
        (    fba_p: ^dst$four_bit_array;
             byte_count: integer;
             mw170_p: ^dst$four_bit_array;
         VAR mwfbi: integer);

{ PURPOSE:
{   The purpose of this procedure is to catenate a buffer of 64 bit data in
{   60 bit words with a previously dumped buffer of similar data that is not
{   word aligned so that the 64 bit data will be contiguous when written to a
{   file.  The 170 word buffer is written to the dump file when it is full.
{
{     FBA_P: pointer to the 64 bit data to be catenated.
{
{     BYTE_COUNT: number of bytes (8 bits/byte) to catenate.
{
{     MW170_P: pointer to the 170 word buffer where the data is to be moved to.
{
{     MWFBI: index to the next 4 bit position in the 170 word buffer.
{
{     The variable 'memory_buffer' which is not passed as a parameter is
{ assumed to be the buffer that 'mw170_p' points to.  This is the buffer
{ that is emptied when IO has to be done.

        VAR
          fbi: integer,
          four_bit_count: integer;


        four_bit_count := byte_count * 2;

        FOR fbi := LOWERBOUND(fba_p^) to four_bit_count DO
          mw170_p^ [mwfbi] := fba_p^ [fbi];
          mwfbi := mwfbi + 1;
          IF mwfbi > (dump_block_size_bytes * 2) THEN
            bi#put_tape (vedump, ^memory_buffer, #SIZE(mw170_p^));
            mwfbi := LOWERBOUND(mw170_p^);
          IFEND;
        FOREND;

      PROCEND catenate_64_to_60;


      VAR
        cm_header: memory_copy_header,
        dft_bi: integer,
        dft_buffer_lengths_p: ^ARRAY [ 0 .. * ] OF integer,
        dft_buffer_length_words: integer,
        dft_control_word: dst$dft_control_word,
        dftb_p_word: r_register_format,
        dscb_d7ty_word: dst$dscb_d7ty,
        dscb_d8ty_word: dst$dscb_d8ty,
        dump_length: integer,
        fba_p: ^dst$four_bit_array,
        four_bit_array: dst$four_bit_array,
        fwa: integer,
        i: integer,
        mwfbi: integer,
        memory_buffer: PACKED RECORD
          tape_block_header: cell,
          words: ALIGNED PACKED ARRAY [1 .. dump_block_size] OF integer,
        RECEND,
        mw_p: ^dst$four_bit_array,
        number_of_dft_buffers_to_dump: integer,
        page_size_mask: 0 .. 177(8),
        total_record_length: integer;

      IF nve_memory = 0 THEN
        RETURN;
      IFEND;

{  Check the EI version number to ensure that it can process this
{  request and the interface block version number to ensure that the DFT
{  block exists.

      get_dscb (dscb_d8ty, #LOC(dscb_d8ty_word), 1);
      get_dscb (dscb_d7ty, #LOC(dscb_d7ty_word), 1);

      IF (dscb_d8ty_word.ei_version_number >= 15(16)) AND (dscb_d7ty_word.
            interface_block_version_number >= 3) THEN

        set_ei_pva (start_of_dft_buffer_0, 1);
        cm_header.byte_rma := 0;
        cm_header.length := 1;
        cm_header.copy_method := ve60_to_nos60;
        cm_header.pva_type := dft_buffer;

{  Read the DFT control word to get the DFT version number and set the
{  number of DFT buffers to be dumped accordingly.

        copy_memory (cm_header, #LOC(dft_control_word));

        IF dft_control_word.rl <= 3 THEN
          number_of_dft_buffers_to_dump := 4;
        ELSE
          number_of_dft_buffers_to_dump := dft_control_word.po;
        IFEND;

        PUSH dft_buffer_lengths_p: [ 0 .. number_of_dft_buffers_to_dump ];

        determine_dft_block_length (number_of_dft_buffers_to_dump,
              dft_control_word, dft_buffer_length_words, dft_buffer_lengths_p);
        format_edd_header ('DFT', 0, dft_buffer_length_words);

{  Dump DFT buffers.

        cm_header.copy_method := ve64_to_nos60;
        cm_header.pva_type := dft_buffer;
        fba_p := ^four_bit_array;
        mw_p := #LOC(memory_buffer.words);
        mwfbi := LOWERBOUND(memory_buffer.words);

        FOR dft_bi := LOWERBOUND(dft_buffer_lengths_p^) TO
              number_of_dft_buffers_to_dump - 1 DO
          dump_length := dft_buffer_lengths_p^[dft_bi];

          IF dump_length > 0 THEN
            cm_header.length := dump_block_size;
            cm_header.byte_rma := 0;
            total_record_length := 0;
            set_ei_pva (dft_bi * 100(16) + dft_buffer, 1);

            WHILE (cm_header.byte_rma + dump_block_size_bytes) < dump_length DO
              copy_memory (cm_header, #LOC(four_bit_array));
              catenate_64_to_60 (fba_p, dump_block_size_bytes, mw_p, mwfbi);
              cm_header.byte_rma := cm_header.byte_rma + dump_block_size_bytes;
              total_record_length := total_record_length +
                    #SIZE (memory_buffer.words);
            WHILEND;

 {  Convert the number of remaining bytes to dump to 170 CM words.  This value
 {  must be a multiple of 2 because of the conversion algorithm used by EI.
 {  If it is not a multiple of 2 170 CM words, EI will abort the job.

            i := (dump_length - cm_header.byte_rma) * 8;
            cm_header.length := i DIV 60;

            IF (i MOD 60) <> 0 THEN
              cm_header.length := cm_header.length + 1;
            IFEND;

            IF (cm_header.length MOD 2) <> 0 THEN
              cm_header.length := cm_header.length + 1;
            IFEND;

            copy_memory (cm_header, #LOC(four_bit_array));
            catenate_64_to_60 (fba_p, i DIV 8, mw_p, mwfbi);
          IFEND;
        FOREND;

        IF mwfbi > LOWERBOUND(memory_buffer.words) THEN

 {  There is data in the memory buffer, write it to the dump file.

          mwfbi := mwfbi - 1;
          i := mwfbi DIV 15;

          IF (mwfbi MOD 15) <> 0 THEN
            i := i + 1;
          IFEND;

          bi#put_tape (vedump, ^memory_buffer, i);
        IFEND;

      IFEND;

{  Dump NOS/VE memory.  If *DUMP=NONE was specified, no NOS/VE memory is dumped.
{  If *DUMP=CRITICAL was specified, only critical memory (as defined by the critical
{  page table) is dumped as *CCM* records.  Otherwise, all of NOS/VE memory is
{  dumped as one *MEM* record.

      get_page_size_mask (page_size_mask);

      IF memory_to_be_dumped <> 'NONE' THEN
        IF cptp_r_pointer.length <> 0 THEN
          dump_critical_page_table (page_size_mask);
        IFEND;
        IF memory_to_be_dumped = 'CRITICAL' THEN
          dump_critical_memory (page_size_mask);
        ELSE
          dyfstrnum ('cm dump fwa', load_offset_bytes, system_dayf);
          dyfstrnum ('cm dump length', nve_memory, system_dayf);
          fwa := load_offset_bytes DIV bytes_per_octal_1k_words;
          dump_length := nve_memory DIV bytes_per_octal_1k_words;
          format_edd_header ('MEM', fwa, dump_length);

          dump_length := nve_memory;
          total_record_length := 0;
          cm_header.length := dump_block_size;
          cm_header.byte_rma := 0;
          cm_header.copy_method := ve64_to_nos60;
          cm_header.pva_type := start_of_ve;

          WHILE (cm_header.byte_rma + dump_block_size_bytes) < dump_length DO
            copy_memory (cm_header, ^memory_buffer.words);
            bi#put_tape (vedump, ^memory_buffer, #SIZE (memory_buffer.words));
            cm_header.byte_rma := cm_header.byte_rma + dump_block_size_bytes;
            total_record_length := total_record_length +
                  #SIZE (memory_buffer.words);
          WHILEND;

{  Dump remainder of memory.

          i := (dump_length - cm_header.byte_rma) * 2;
          cm_header.length := (i DIV 30) * 2;
          copy_memory (cm_header, ^memory_buffer.words);

          i := (i + 14) DIV 15;
          i := ((total_record_length + i + 63) DIV 64) * 64 - total_record_length;
          bi#put_tape (vedump, ^memory_buffer, i);
        IFEND;
      IFEND;

{  Dump EICB.

{  Determine the number of 170 CM words to dump.  This value must be
{  a multiple of 2 because of the conversion algorithm used by EI.
{  If it is not a multiple of 2 170 CM words, EI will abort the job.

      dump_length := (dscb_dscbl * 64) DIV 60;
      IF ((dscb_dscbl * 64) MOD 60) <> 0 THEN
        dump_length := dump_length + 1;
      IFEND;
      IF (dump_length MOD 2) <> 0 THEN
        dump_length := dump_length + 1;
      IFEND;

      format_edd_header ('DSB', 0, dump_length);
      cm_header.copy_method := ve64_to_nos60;
      cm_header.pva_type := interface_block;
      cm_header.length := dump_length;
      cm_header.byte_rma := dscb_d7ty * 8;
      copy_memory (cm_header, ^memory_buffer.words);
      bi#put_tape (vedump, ^memory_buffer, dump_length);

    PROCEND dump_memory;
?? OLDTITLE ??
?? NEWTITLE := '~~~~~   procedure dump_cpu_registers', EJECT ??

{ PURPOSE:
{   First dump the processor maintenance registers from the live registers
{   updating them from the register save area in the SSR if present.
{   Then if the MPS register is defined in the SSR, dump the exchange
{   package image from the memory referenced by MPS.

    PROCEDURE dump_cpu_registers
      (    cpu_info: dst$cc_processor_info);

      CONST
       base_number_of_pmr_to_dump = 12,
       max_number_of_pmr = 27,
       mps_reg_number = 41(16);

      VAR
        cm_header: memory_copy_header,
        cpu_registers: [STATIC] PACKED ARRAY [1 .. max_number_of_pmr]
          OF 0 .. 7777(8) := [0, 10(16), 11(16), 12(16), 13(16), 30(16),
          41(16), 48(16), 49(16), 4a(16), 61(16), 80(16), 81(16), 82(16),
          83(16), 84(16), 85(16), 86(16), 87(16), 88(16), 89(16), 8a(16),
          8b(16), 8c(16), 8d(16), 8e(16), 8f(16)],
        xp_buffer: PACKED RECORD
          tape_block_header: cell,
          xp_registers: ARRAY [0 .. 63] OF integer,
        RECEND,
        i: integer,
        left: integer,
        mps_reg: integer,
        mps_reg_found: boolean,
        number_of_pmr_to_dump: integer,
        reg: edd_register_format,
        ri: 1 .. max_number_of_pmr,
        right: integer,
        ssr_header: memory_copy_header;

      VAR
        ssr_block: PACKED RECORD
          f0: 0 .. 0fffffff(16),
          rn0: 0 .. 0ffff(16),
          rn1: 0 .. 0ffff(16),
          f1: 0 .. 0fffffff(16),
          rn2: 0 .. 0ffff(16),
          rn3: 0 .. 0ffff(16),
          rv0: c180_word,
          rv1: c180_word,
          rv2: c180_word,
          rv3: c180_word,
        RECEND;

      PROCEDURE build_register
        (    rn: integer;
             rv: c180_word);

        VAR
          j: integer,
          v1: integer,
          v2: integer;

        dyfstrnum ('BUILD REG', rn, debug_log);
        v1 := rv.left;
        v2 := rv.right;
        FOR j := 1 TO 4 DO
          ssr_registers^ [ri].register_value [5 - j] := v1 MOD 256;
          ssr_registers^ [ri].register_value [9 - j] := v2 MOD 256;
          v1 := v1 DIV 256;
          v2 := v2 DIV 256;
        FOREND;
        ssr_registers^ [ri].number := rn;
        ri := ri + 1;

      PROCEND build_register;

{  Process Processor Maintenance Registers. (PMR)

      IF cpu_info.status.processor_down THEN
        dyfstrnum ('SKIPPING CPU', cpus_observed, debug_log);
        cpus_observed := cpus_observed + 1;
        RETURN;
      IFEND;

      dyfstrnum ('DUMPING CPU', cpus_observed, debug_log);

      pp_table.port_code := cpu_info.port_code;
      format_edd_header ('PMR', 0, 0);
      ssr_registers := NIL;
      IF ssr_address_words <> 0 THEN
        find_ssr_entry ('RSAV', left);
        get_ssr_directory_entry (left, left, right);
        ssr_header.pva_type := start_of_ssr;
        ssr_header.copy_method := ve64_to_nos32;
        ssr_header.length := #SIZE (ssr_block);
        ssr_header.byte_rma := right * 8 + 16 * 8 * cpus_observed;
        PUSH ssr_registers: [1 .. 8];
        ri := 1;
        FOR i := 1 TO 2 DO
          copy_memory (ssr_header, ^ssr_block);
          ssr_header.byte_rma := ssr_header.byte_rma + 5 * 8;
          build_register (ssr_block.rn0, ssr_block.rv0);
          build_register (ssr_block.rn1, ssr_block.rv1);
          build_register (ssr_block.rn2, ssr_block.rv2);
          build_register (ssr_block.rn3, ssr_block.rv3);
        FOREND;
      IFEND;

      CASE cpu_info.element_id.model_number OF

      = osc$cyber_180_model_815, osc$cyber_180_model_825 =
        cpu_registers[base_number_of_pmr_to_dump + 1] := 90(16);
        cpu_registers[base_number_of_pmr_to_dump + 2] := 93(16);
        number_of_pmr_to_dump := base_number_of_pmr_to_dump + 2;

      = osc$cyber_180_model_810, osc$cyber_180_model_830 = { includes 810A/830A
        { 810/830/810A/830A
        cpu_registers[base_number_of_pmr_to_dump + 2] := 90(16);
        cpu_registers[base_number_of_pmr_to_dump + 3] := 91(16);
        cpu_registers[base_number_of_pmr_to_dump + 4] := 93(16);
        number_of_pmr_to_dump := base_number_of_pmr_to_dump + 4;

      = osc$cyber_180_model_835 =
        cpu_registers[base_number_of_pmr_to_dump + 2] := 90(16);
        cpu_registers[base_number_of_pmr_to_dump + 3] := 92(16);
        number_of_pmr_to_dump := base_number_of_pmr_to_dump + 3;

      = osc$cyber_180_model_840, osc$cyber_180_model_840s,
        osc$cyber_180_model_845, osc$cyber_180_model_845s,
        osc$cyber_180_model_850, osc$cyber_180_model_855,
        osc$cyber_180_model_855s, osc$cyber_180_model_860,
        osc$cyber_180_model_9601, osc$cyber_180_model_9603 =

        { 840/845/850/855/860/840S/845S/855S/840A/850A/860A/870A.
        number_of_pmr_to_dump := base_number_of_pmr_to_dump + 9;

      = osc$cyber_180_model_990, osc$cyber_180_model_990e,
        osc$cyber_180_model_994 = { 990/990E/994/995E
        number_of_pmr_to_dump := base_number_of_pmr_to_dump + 0f(16);

      ELSE

        number_of_pmr_to_dump := base_number_of_pmr_to_dump;

      CASEND;

      FOR ri := 1 TO number_of_pmr_to_dump DO
        read_register (register_block_buffer.register [ri],
              cpu_registers [ri], ssr_registers, 0, cpu_info.port_code);
      FOREND;
      register_block_buffer.register [number_of_pmr_to_dump + 1] [1] := 0;

      bi#put_tape (vedump, ^register_block_buffer,
            (number_of_pmr_to_dump * 2) + 1);

{  Process Processor Exchange Package.

      mps_reg_found := FALSE;
      IF ssr_address_words <> 0 THEN
        FOR i := 1 TO UPPERBOUND (ssr_registers^) DO
          IF ssr_registers^ [i].number = mps_reg_number THEN
            mps_reg_found := TRUE;
          IFEND;
        FOREND;
      IFEND;

      IF mps_reg_found THEN
        read_register (reg, mps_reg_number, ssr_registers, 0,
              cpu_info.port_code);

        mps_reg := 0;
        FOR i := 3 TO 10 DO
          mps_reg := mps_reg * 100(16) + reg [i];
        FOREND;

        IF (mps_reg > load_offset_bytes) AND (load_offset_bytes <> 0) THEN
          format_edd_header ('PXP', 0, 0);

          cm_header.copy_method := ve64_to_nos60;
          cm_header.pva_type := start_of_ve;
          cm_header.byte_rma := mps_reg - load_offset_bytes;
          cm_header.length := 64;
          copy_memory (cm_header, ^xp_buffer.xp_registers);

          bi#put_tape (vedump, ^xp_buffer, 56);
        IFEND;
      IFEND;
      cpus_observed := cpus_observed + 1;

    PROCEND dump_cpu_registers;
?? OLDTITLE, EJECT ??

{ PURPOSE:
{   Dump the NOS/VE environment to the dump file.

    VAR
      cpus_observed: integer,
      index: integer,
      iou_number: integer,
      ious_observed: integer,
      os_date: char_arr,
      os_time: char_arr,
      total_size: integer,
      vedump: ^cell,
      vedump_file: string (7);

{  Initialize for dumping the NOS/VE environment.

    vedump_file := 'CHKTAPE';
    bi#olt (vedump, vedump_file, new#, output#, first#);

    get_date_time (os_date, os_time);
    IF load_offset_bytes <> 0 THEN
      set_ei_pva (start_of_ve, load_offset_bytes DIV 8);
    IFEND;
    total_size := 0;
    index := LOWERBOUND(configuration_record);
    cpus_observed := 0;
    ious_observed := 0;

    create_dump_identifier_record;

{  Dump the maintenance registers for those elements defined in the
{  mainframe reconfiguration table.

    WHILE configuration_record [index].iou.size > 0 DO

      CASE configuration_record [index].iou.id OF

      = dsc$id_iou_info =
        dump_iou_registers (configuration_record [index].iou);

      = dsc$id_central_memory_info =
        dump_mem_registers (configuration_record [index].memory);

      = dsc$id_processor_info =
        dump_cpu_registers (configuration_record [index].processor);

      ELSE

      CASEND;

      index := index + 1;
    WHILEND;

    dump_memory;

{  Dump IOU contents for each IOU.

    iou_number := 0;
    index := LOWERBOUND(configuration_record);

    WHILE configuration_record [index].iou.size > 0 DO

      CASE configuration_record [index].iou.id OF

      = dsc$id_iou_info =
        dump_iou_contents (iou_number,
              configuration_record [index].iou.port_code, index);
        iou_number := iou_number + 1;
      ELSE

{  Ignore other records.

      CASEND;

      index := index + 1;
    WHILEND;

{  Close the dump file.

    bi#weof_tape (vedump);
    bi#close (vedump, asis#);

  PROCEND nosve_edd_dump;
?? OLDTITLE ??
