module PASS_3_M

! Final assembly and output

  use BCD_TO_ASCII_M, only: Ascii_To_Bcd, Bcd_To_Ascii, GroupMark, RecordMark
  use ERROR_M, only: AddrErr, BadStatement, Do_Error, ErrCode, ERROR, LabelErr, &
    & MacroErr, NoBXLErr, NoErr, N_Errors, OpErr, Overcall, SymErr, UndefOrg
  use IO_UNITS, only: U_SCRATCH, U_LIST, U_OBJ, U_TAPE
  use LITERALS_M, only: LITERALS
  use OPERAND_M, only: K_ACTUAL, K_ADCON_LIT, K_ADDR_CON, K_AREA_DEF, &
    & K_ASTERISK, K_BLANK_CON, K_CHAR_LIT, K_DEVICE, K_NUM_LIT, K_SYMBOLIC, &
    & OPERANDS, X00
  use OP_CODES_M, only: OPT, OP_CODES, PRO, REQ
  use SYMTAB_M, only: DUMP_SYMTAB, SYMBOLS
  use ZONE_M, only: NUM_TO_ADDR, ZONED

  implicit NONE
  private

  character, public :: BootLoader = 'I' ! I for IBM
                                        ! N for None
                                        ! V for Van's Favorite 3-card loader
                                        ! W for Van's Favorite 2-card loader
                                        ! X for Van's Favorite 1-card loader
  integer, public :: CoreSize = 16000   ! 1400, 2000, 8000, 12000 or 16000
  logical, save, public :: Interleave   ! Interleave object deck into listing
  integer,save,public :: MaxLine = 53   ! Lines per page
  logical, save,public :: NotIn_1_80    ! Error if code in 1..80

  public :: Pass_3

contains

  subroutine Pass_3 ( Do_List, Do_Object, Do_Tape )

    logical, intent(in) :: Do_List      ! Make a listing
    logical, intent(in) :: Do_Object    ! Make an object "deck"
    logical, intent(in) :: Do_Tape      ! Make an object "tape"

    character(71) :: BOOTSTRAP = & ! Bootstrap card
      & ',008015,022029,036040,047054,061068,072/061039              ,0010011040'
    character(*), parameter :: BOOT_T = &    ! Tape bootstrap record
      & 'U%U1B.L%U1020RB001L.020 BOOTSTRAP'
    character(*), parameter :: BOOT_V = &    ! Van's favorite bootstrap/clear card
      & ',008047/047046       /000H025B022100  4/061046,054061,068072,0010401040'
    character(*), parameter :: BOOT_TW = &   ! Word marks for BOOT_T
      & '1    11       1    1   1'
    character(71) :: CARD
    integer :: CARD_NO
    character(71) :: CS1_4 = & ! First clear-storage card -- IBM 4K
      & ',008015,019026,030,034041,045,053,0570571026                           '
      !  1      1      1   1      1   1   1      1   1       1   1
    character(71) :: CS1_6 = & ! First clear-storage card -- IBM 16K
      & ',008015,022026,030037,044,049,053053N000000N00001026                   '
      !  1      1      1      1   1   1      1      1    1   1
    character(71) :: CS2_4 = & ! Second clear-storage card -- IBM 4K
      & 'L068112,102106,113/101099/I99,027A070028)027B0010270B0261,001/001113I0 '
      !  1      1      1   1      14  1   1      1   1       1   32   2      2
    character(71) :: CS2_6 = & ! Second clear-storage card -- IBM 16K
      & 'L068116,105106,110117B101/I9I#071029C029056B026/B001/0991,001/001117I0?'
      !  1      1      1      1   1   1      1      1    1   3   22   2      2
    character(*), parameter :: CST = &   ! Clear-storage record for tape
      & ',200/000H008V0052001L051115L/100099L%U1001R/007199 CLEAR STORAGE'
    character(*), parameter :: CSTW = &  ! Word marks for CST
      & '1   1   1   1       1      11      1       1       '
    character(*), parameter :: CS_V = &  ! Van's favorite clear bootstrap card
      & ',008015,022026,030040/019,001L020100   ,047054,061068,072072)0810811022'
    character :: D
    character(5) ::Deck_Id         ! From the JOB card, for 76:80 of obj deck
    integer :: DIGIT
    character(71) :: EX1 = & ! First "restart after EX" card
      & ',015022)024056,029036,040047,0540611001,001008B001     ,001008B001     '
    character(71) :: EX2 = & ! Second "restart after EX" card
      & ',068072)063067/061039                                       ,0010011040'
    character :: GMARK             ! Group Mark
    integer :: I
    integer :: INDEX
    integer :: IxLab               ! Index in Symbols of a label
    integer :: Last_Obj_P          ! Last position loaded by object record
    character(80) :: LINE          ! Input line
    integer :: LINE_NO             ! Line number in the page
    character(len=71) :: Loader(3) ! Loader cards
    character(len=21) :: LoadPrefix(3) ! For the listing
    character :: MachineOp
    logical :: NeedCS              ! Need to emit clear-storage cards
    logical :: NeedEX              ! Need to emit re-bootstrap after EX or XFR
                                   ! These are needed because Autocoder wants
                                   ! to put the next deck-id into them if a
                                   ! JOB card follows EX or XFR
    integer :: Nrecs               ! Operands(1) if DA
    integer :: Num_Load_Cds        ! Number of load cards
    integer :: Num_Load_Ops        ! In load area of object card
    integer :: Num_Operands        ! in the scratch record
    integer :: Num_Swms            ! Number of set word mark instructions in TSWMS
    character(8) :: Object         ! Where some object output is built up
    integer :: OBJ_POS             ! Last used in data area
    integer :: OP_IX
    integer :: ORG                 ! Used as a surrogate for P
    character(52) :: OUTPUT        ! Where some printed output is built up
    integer :: P                   ! Program counter
    integer :: PAGE_NO             ! Page number
    character(52) :: Page_Head     ! Page heading -- from JOB card
    integer :: P_DA                ! P as of last DA
    integer :: P_IN                ! P from the input -- ignored
    integer :: P_SAVE              ! In case DA has numeric label
    integer :: RECSIZ              ! Operands(2) if DA
    character :: RMARK             ! Record Mark
    integer :: SEQ                 ! Sequence number
    character :: SFX
    character :: SKIP              ! Page skip for heading, initially '0', then '1'
    character(56) :: TSWMS         ! Set word mark instructions for tape output
    character(5) :: WHY            ! Code for scratch record
    integer :: WIDTH               ! of the code generated from a scratch record
    character :: X                 ! to print X for indexed EQU

    card_no = 1
    obj_pos = 0
    deck_id = ''
    gmark = bcd_to_ascii(groupMark)
    last_obj_p = -1
    line_no = 0
    needCS = bootLoader /= 'N'
    needEX = .false.
    num_load_ops = 0
    num_swms = 0
    p = 333
    page_head = ''
    page_no = 0
    rmark = bcd_to_ascii(recordMark)
    seq = 100
    sfx = ' '
    skip = '0'
    if ( bootLoader == 'N' ) skip = ' '
    if ( do_object ) then
      card(1:39) = ''
      card(40:67) = 'L001001,040040,040040,040040'
      card(68:) = ''
    end if
    rewind ( u_scratch )
    do
      read ( u_scratch, 200, end=999 ) why, line, ixLab, p_in, width, &
        & errCode, num_operands, operands(:num_operands)
200   format ( a5, a80, 3i6, a1, i6, 4(3i6,a2,a1,a6))
      if ( line(6:6) /= '*' .and. line(16:20) == 'JOB' ) then
        deck_id = line(76:80)
        page_head = line(21:72)
      end if
      if ( needCS ) then
        num_load_cds = 3
        select case ( bootLoader )
        case ( 'B')
          num_load_cds = 1
          loader(1) = boot_v
          loadPrefix(1) = ' BOOTSTRAP NO CLEAR  '
        case ( 'I' )
          if ( coreSize <= 4000 ) then
            loader = (/ cs1_4, cs2_4, bootstrap /)
          else
            loader = (/ cs1_6, cs2_6, bootstrap /)
          end if
          call num_to_addr ( coreSize-1, 0, loader(2)(27:29) )
          loadPrefix = (/ ' CLEAR STORAGE 1     ', &
                       &  ' CLEAR STORAGE 2     ', &
                       &  ' BOOTSTRAP           ' /)
        case ( 'V' )
          num_load_cds = 2
          loader(1:2) = (/ cs_v, boot_v /)
          loadPrefix(1:2) = (/ ' BOOTSTRAP FOR CLEAR ', &
                            &  ' CLEAR OR BOOTSTRAP  ' /)
        end select
        do i = 1, num_load_cds        
          if ( do_list ) &
            & write ( u_list, '(a21,a71,i23)' ) loadPrefix(i), loader(i), i
          if ( do_object ) then
            card = loader(i)
            call finish_obj
          end if
        end do
        line_no = 3
        if ( do_object .and. interleave ) line_no = 5
        if ( do_tape ) then
          call write_tape ( cst, cstw, 80 )
          call write_tape ( boot_t, boot_tw, 80 )
        end if
        needCS = .false.
      end if
      if ( needEX .and. bootLoader /= 'N') then
        card = ex1
        call finish_obj
        card = ex2
        if ( bootLoader == 'V' ) card = boot_v
        call finish_obj
        if ( do_tape ) call write_tape ( boot_t, boot_tw, 80 )
        needEX = .false.
      end if
      output = ''
      p_in = p
      if ( line(6:6) == '*' ) then
        if ( do_list ) then
          if ( line_no >= maxLine .or. skip /= '1' ) call heading
          if ( why == '     ' ) then
            seq = seq + 1
            write ( u_list, 300 ) seq, line(1:2), line(3:5), trim(line(6:))
300         format ( i5, 1x, a2, 1x, a3, 2x, a )
          else
            write ( u_list, 310 ) line(1:2), line(3:5), line(6:), why
310         format ( 6x, a2, 1x, a3, 2x, a75, t106, a5)
          end if
          line_no = line_no + 1
        end if
        cycle
      end if
      select case ( why )
      case ( 'FIELD' )
        org = p_da + operands(1)%addr - 1
        if ( org > 0 .and. org <= 80 .and. notIn_1_80 ) errCode = addrErr
        do i = 1, nrecs
          seq = seq + 1
          if ( do_object ) then
            if ( num_load_ops >= 6 ) call finish_obj ( '1040' )
          end if
          call sw ( org )
          org = org + recsiz
        end do
        call listing ( loc = p_da + operands(2)%addr - 1 )
      case ( 'MACRO' )
        seq = seq + 1
        call listing
      case ( 'SBFLD' )
        seq = seq + 1
        org = p_da + operands(1)%addr - 1
        if ( org > 0 .and. org <= 80 .and. notIn_1_80 ) errCode = addrErr
        call listing ( loc = p_da + operands(1)%addr - 1 )
      case default
        if ( why /= 'LIT' .and. why /= 'AREA' .and. why /= 'ADCON' ) seq = seq + 1
        if ( line(16:18) == ' ' ) then
          machineOp = line(19:19)
          d = line(20:20)
          if ( ascii_to_bcd(iachar(d)) == groupMark .and. why == '' ) &
            & why = 'GMARK'
          op_ix = 0
        else
          do op_ix = 1, ubound(op_codes,1)
            if ( line(16:20) == op_codes(op_ix)%op ) then
              machineOp = op_codes(op_ix)%machineOp
              exit
            end if
          end do
          d = ' '
        end if
        if ( machineOp == ' ' ) then
          p_in = p + width - 1
          select case ( line(16:20) )
          case ( 'CTL' )
            call listing
          case ( 'DA' )
            call test_p ( p )
            p_save = p
            if ( ixlab < 0 ) p = -ixlab
            if ( p > 0 .and. p <= 80 .and. notIn_1_80 ) errCode = addrErr
            p_da = p
            width = 0
            nrecs = operands(1)%addr
            recsiz = operands(2)%addr
            if ( operands(3)%label(3:3) == rmark ) recsiz = recsiz + 1
            org = p + nrecs*recsiz
            call listing ( loc=p, org=org-1 )
            if ( operands(3)%label(2:2) == 'G' ) org = org + 1
            line = ''
            line(16:) = 'DC   @' // rmark // '@'
            p_in = p
            do i = 1, nrecs
            ! At least in the case of one record, autocoder clears the whole
            ! area, including the area for the record mark, then backs up
            ! and emits the record mark.
              if ( operands(3)%label(1:1) == 'C' ) then
                call clear ( recsiz, ' ' )
              else
                p = p + recsiz
              end if
              if ( num_load_ops >= 6 ) call finish_obj ( '1040' )
              call sw ( p_in )
              p_in = p_in + recsiz
              why = 'RMARK'
              if ( operands(3)%label(3:3) == rmark ) then
                p = p - 1
                call dc ( rmark, ' ', p, 0 )
                call listing ( 1, p-1, card=card_no )
              end if
            end do
            why = 'GMARK'
            line(16:) = 'DCW  @' // gmark // '@'
            if ( operands(3)%label(2:2) == 'G' ) then
              call dc ( gmark, 'W', p, 0 )
              call listing ( 1, p-1, card=card_no )
            end if
            if ( p + width /= org ) print *, 'What went wrong with DA in Pass 3?'
            if ( ixlab < 0 ) p = p_save
          case ( 'DC', 'DCW' )
            call test_p ( p_in )
            if ( ixLab < 0 ) p_in = -ixLab + width - 1
            select case ( operands(1)%kind )
            case ( k_actual, k_num_lit )
              if ( width <= 0 ) then
                errCode = BadStatement
              else if ( line(21:21) == '+' .or. line(21:21) == '&' .or. &
                & line(21:21) == '-' ) then
                output(:width) = line(22:)
                digit = ichar(output(width:width)) - ichar('0')
                i = 2
                if ( line(21:21) /= '-' ) i = 3
                output(width:width) = zoned(digit,i)
              else
                output(:width) = line(21:)
              end if
              call dc ( output(:width), line(18:18), p_in, ixLab )
              call listing ( width, p_in, card=card_no )
            case ( k_adcon_lit )
              org = literals(operands(1)%addr)%addr
              call num_to_addr ( org, 0, output(1:3) )
              call dc ( output(:3), line(18:18), p_in, ixLab )
              call listing ( 3, p_in, output, card=card_no )
            case ( k_addr_con )
              if ( operands(1)%addr < 0 ) then
                org = -1
                index = 0
              else
                org = symbols(operands(1)%addr)%value
                if ( org >= 0 ) then
                  org = org + operands(1)%offset
                  if ( line(21:21) == '-' ) org = 16000 - org
                end if
                index = symbols(operands(1)%addr)%index
              end if
              if ( operands(1)%index /= ' ' ) &
                & read ( operands(1)%index, '(i1)' ) index
              call num_to_addr ( org, index, output(1:3) )
              if ( output(1:3) == '###' ) errCode = symErr
              call dc ( output(:3), line(18:18), p_in, ixLab )
              call listing ( 3, p_in, output, card=card_no )
            case ( k_area_def, k_blank_con )
              call clear ( width, line(18:18) )
              call listing ( width, p_in, card=card_no )
            case ( k_char_lit )
              call dc ( line(22:21+width), line(18:18), p_in, ixLab )
              if ( width == 1 .and. &
                & ascii_to_bcd(iachar(line(22:22))) == groupMark .and. &
                & why == '' ) why = 'GMARK'
              call listing ( width, p_in, card=card_no )
            end select
          case ( 'DS' )
            call test_p ( p_in )
            call listing ( loc=p_in )
            p = p + width
          case ( 'DSA' )
            call test_p ( p_in )
            if ( ixLab < 0 ) p_in = -ixLab + width - 1
            select case ( operands(1)%kind )
            case ( k_actual )
              org = operands(1)%addr + operands(1)%offset
              read ( operands(1)%index, '(i1)' ) index
              call num_to_addr ( org, index, output(1:3) )
              call dc ( output(:3), 'W', p+2, p_in )
              call listing ( 3, p_in, output, card=card_no )
            case ( k_asterisk )
              org = p + 2 + operands(1)%offset
              read ( operands(1)%index, '(i1)' ) index
              call num_to_addr ( org, index, output(1:3) )
              call dc ( output(:3), 'W', p+2, p_in )
              call listing ( 3, p_in, output, card=card_no )
            case ( k_symbolic )
              org = symbols(operands(1)%addr)%value + operands(1)%offset
              index = symbols(operands(1)%addr)%index
              if ( operands(1)%index /= ' ' ) &
                & read ( operands(1)%index, '(i1)' ) index
              call num_to_addr ( org, index, output(1:3) )
              call dc ( output(:3), 'W', p+2, p_in )
              call listing ( 3, p_in, output, card=card_no )
            end select
          case ( 'END' )
            select case ( operands(1)%kind )
            case ( k_actual )
              org = operands(1)%addr
            case ( k_symbolic )
              org = symbols(operands(1)%addr)%value
            end select
            object = '/   080'
            call num_to_addr ( org, 0, object(2:4) )
            if ( object(2:4) == '###' ) errCode = symErr
            call spread ( (/ 1, 3, 3 /) )
            if ( do_object ) then
              if ( obj_pos > 0 .or. num_load_ops > 0 ) call finish_obj ( '1040' )
              card(40:71) = object(1:7)
              call finish_obj
            end if
            if ( do_tape ) call write_tape ( object(:8), '1      1', 61 )
            call listing ( output=output )
          case ( 'EQU' )
            x = ''
            if ( operands(1)%index >= '1' .and. operands(1)%index <= '3' ) &
             & x = 'X'
            select case ( operands(1)%kind )
            case ( k_actual )
              call listing ( loc=operands(1)%addr+operands(1)%offset, x=x )
            case ( k_asterisk )
              call listing ( loc=p-1+operands(1)%offset, x=x )
            case ( k_symbolic )
              if ( symbols(operands(1)%addr)%dev == '' ) then
                if ( abs(symbols(operands(1)%addr)%value) > 15999 ) &
                  errCode = symErr
                call listing ( &
                  & loc=symbols(operands(1)%addr)%value+operands(1)%offset, x=x )
              else
                call listing ( dev=symbols(operands(1)%addr)%dev )
              end if
            case ( k_device )
              call listing ( dev=operands(1)%label )
            end select
          case ( 'EX', 'XFR' )
            width = 0  ! width on scratch file is num_lits
            select case ( operands(1)%kind )
            case ( k_actual )
              org = operands(1)%addr
            case ( k_symbolic )
              org = symbols(operands(1)%addr)%value
            end select
            object(1:1) = 'B'
            call num_to_addr ( org, 0, object(2:4) )
            if ( object(2:4) == '###' ) errCode = symErr
            call spread ( (/ 1, 3 /) )
            if ( do_object ) then
              call finish_obj ( '1040' )
              card(40:46) = 'N000000'
              card(68:71) = object(1:4)
              call finish_obj
              needEX = .true.
            end if
            if ( do_tape ) then
              call write_tape ( 'N000000' // object(1:4) // ' ', &
                &               '1      1   1', 61 )
              needEX = .true.
            end if
            call listing ( output=output, card=card_no )
          case ( 'JOB' )
            call heading
            call listing
          case ( 'LTORG', 'ORG' )
            call do_org
          case ( 'SFX' )
            sfx = line(21:21)
            call listing
          end select
        else
          call test_p ( p )
          object(1:1) = machineOp
          if ( op_codes(op_ix)%d /= opt .and. op_codes(op_ix)%d /= pro .and. &
               op_codes(op_ix)%d /= req ) d = op_codes(op_ix)%d
          select case ( width )
          case ( 1 )
            output(1:1) = object(1:1)
          case ( 2 )
            object(2:2) = operands(1)%d
            call spread ( (/ 1, 1 /) )
          case ( 4 )
            call do_operand ( 1, object(2:4) )
            call spread ( (/ 1, 3 /) )
          case ( 5 )
            call do_operand ( 1, object(2:4) )
            object(5:5) = d
            if ( num_operands >= 2 ) object(5:5) = operands(2)%d
            call spread ( (/ 1, 3, 1 /) )
          case ( 7 )
            call do_operand ( 1, object(2:4) )
            call do_operand ( 2, object(5:7) )
            call spread ( (/ 1, 3, 3 /) )
          case ( 8 )
            call do_operand ( 1, object(2:4) )
            call do_operand ( 2, object(5:7) )
            if ( num_operands >= 3 ) d = operands(3)%d
            object(8:8) = d
            call spread ( (/ 1, 3, 3, 1 /) )
          end select
          call dc ( object(:width), 'W', p+width-1, 0 )
          if ( ascii_to_bcd(iachar(d)) == groupMark .and. why == '' ) why = 'GMARK'
          call listing ( width, p-width, output, card=card_no )
       end if
      end select
    end do
999 continue
    if ( do_list ) then
      call heading_job
      write ( u_list, 400 )
400   format ( '0', 7('SYMBOL  ADDRESS  ') / )
      call dump_symtab ( u_list, sort=.true. )
    end if
    rewind ( u_scratch )

  contains

    subroutine CLEAR ( HOW_MUCH, WM )
      integer, intent(in) :: HOW_MUCH
      character, intent(in) :: WM            ! 'W' for a word mark
      character :: MyWM
      integer :: N                           ! How much to do on one DC call
      integer :: REMAIN                      ! How much remains to be done
      myWM = wm
      output = ' '
      remain = how_much
      do while ( remain > 0 )
        n = min(remain,39)
        call dc ( output(:n), myWM, p+n-1, ixlab )
        myWM = ' '
        remain = remain - n
      end do
    end subroutine CLEAR

    subroutine DC ( WHAT, WM, WHERE, IXLAB )
      character(len=*), intent(in) :: WHAT   ! Stuff to store
      character, intent(in) :: WM            ! Set a word mark if 'W'
      integer, intent(in) :: WHERE           ! Low order end
      integer, intent(in) :: IXLAB           ! Don't increment P if < 0
      integer :: I                           ! Index in WHAT
      integer :: L                           ! Length for current piece
      integer :: MyP                         ! Copy of WHERE, maybe incremented
      character :: MyWm
      integer :: Remain                      ! How much remains to be output
      character(61) :: TDATA, TWMS           ! Tape data and word marks
      myP = where - len(what) + 1
      if ( myP > 0 .and. myP <= 80 .and. notIn_1_80 ) errCode = addrErr
      myWm = wm
      if ( do_object ) then
        i = 1
        remain = len(what)
        if ( obj_pos + remain > 39 .or. &
          & obj_pos > 0 .and. last_obj_p+1 /= myP .or. &
          & num_load_ops >= 6 .and. myWm == 'W' ) &
            call finish_obj ( '1040' )
        do while ( remain > 0 )
          l = min(remain,39-obj_pos)
          card(obj_pos+1:39) = what(i:l+i-1)
          if ( obj_pos == 0 ) then
            if ( myWm /= 'W' ) then
              card(47:47) = ')'
              call num_to_addr ( myP, 0, card(48:50) )
              card(51:53) = card(48:50)
              num_load_ops = 2
            end if
          else if ( myWm == 'W' ) then
            if ( num_load_ops == 6 ) call finish_obj ( '1040' )
            call sw ( myP, .true. ) ! .true. means "calling from DC"
          end if
          i = i + l
          myP = myP + l
          last_obj_p = myP - 1
          myWm = ' '
          obj_pos = obj_pos + l
          if ( obj_pos == 39 ) call finish_obj ( '1040' )
          remain = remain - l
        end do
      end if
      if ( do_tape ) then
        if ( num_swms > 0 ) call output_swms
        i = 1
        remain = len(what)
        do while ( remain > 0 )
          if ( what(i:i) /= '}' ) then
            l = min(remain,32)
            tdata(:15) = 'L      N000B007'
            twms       = '1      1   1   1'
            write ( tdata(2:4), '(i3.3)' ) l+34
            call num_to_addr ( myP+l-1, 0, tdata(5:7) )
            if ( myWm == ' ' ) then
              tdata(8:8) = ')'
              call num_to_addr ( myP, 0, tdata(9:11) )
            end if
            tdata(16:) = what(i:i+l-1)
          else
            l = min(remain,14)
            tdata(:23) = ',043L      )043043B007 '
            twms       = '1   1      1      1   1'
            write ( tdata(6:8), '(i3.3)' ) l+42
            call num_to_addr ( myP+l-1, 0, tdata(9:11) )
            if ( myWm == ' ' ) call num_to_addr ( myP, 0, tdata(16:18) )
            tdata(24:) = what(i:i+l-1)
          end if
          if ( l <= 8 ) tdata(34:53) = line(16:35)
          call write_tape ( tdata, twms, 61 )
          myWm = ''
          remain = remain - l
          i = i + l
        end do
      end if
      if ( ixlab >= 0 ) p = p + len(what)
    end subroutine DC

    subroutine DO_OPERAND ( WHICH, WHERE )
    ! Process an operand indexed by WHICH, putting the equivalent address
    ! in WHERE.
      integer, intent(in) :: WHICH
      character(3), intent(out) :: WHERE
      integer :: ADDR, INDEX
      index = 0
      where = ''
      select case ( operands(which)%kind )
      case ( k_actual )
        addr = operands(which)%addr
      case ( k_asterisk )
        addr = p + width - 1
      case ( k_adcon_lit, k_addr_con, k_area_def, k_char_lit, k_num_lit )
        addr = literals(operands(which)%addr)%addr
      case ( k_symbolic )
        addr = symbols(operands(which)%addr)%value
        index = symbols(operands(which)%addr)%index
        where = symbols(operands(which)%addr)%dev
      end select
      if ( operands(which)%index /= ' ' ) &
        & read ( operands(which)%index, '(i1)' ) index
      if ( operands(which)%kind /= k_device ) then
        if ( where == '' ) then
          call num_to_addr ( addr+operands(which)%offset, index, where )
          if ( where == '###' ) errCode = symErr
        end if
      else
        where = operands(which)%label
      end if
      if ( which == 1 .and. op_codes(op_ix)%a /= opt .and. &
        & op_codes(op_ix)%a /= pro .and. op_codes(op_ix)%a /= req ) then
        where(1:1) = '%'
        where(2:2) = op_codes(op_ix)%a
      end if
    end subroutine DO_OPERAND

    subroutine DO_ORG
      p_in = p
      select case ( operands(1)%kind )
      case ( k_actual )
        p = operands(1)%addr
      case ( k_asterisk )
      case ( k_symbolic )
        p = symbols(operands(1)%addr)%value
        if ( p < 0 ) errCode = undefOrg
      end select
      if ( operands(1)%offset == x00 ) then
        p = p + 99
        p = p - mod(p,100)
      else
        p = p + operands(1)%offset
      end if
      if ( ixlab <= 0 ) then
        call listing ( org=p )
      else
        call listing ( loc=p_in, org=p )
      end if
    end subroutine DO_ORG

    subroutine FINISH_OBJ ( TOUCH )
    ! Finish a card or tape record
      character(*), intent(in), optional :: TOUCH ! Finishing touch, for cc 68-71
      if ( do_object ) then
        if ( obj_pos > 0 ) then
          card(40:40) = 'L'
          write ( card(41:43), '(i3.3)' ) obj_pos
          call num_to_addr ( last_obj_p, 0, card(44:46) )
        end if
        if ( present(touch) ) card(68:71) = '1040'
        write ( u_obj, 100 ) card, card_no, deck_id
100     format ( a71, i4.4, a5 )
        if ( do_list .and. interleave ) then
          if ( line_no >= maXline .or. skip /= '1' ) call heading
          write ( u_list, 110 ) card, card_no, deck_id
110       format ( '&', a71, i4.4, a5 )
          line_no = line_no + 1
        end if
        card(1:39) = ''
        card(40:67) = 'L001001,040040,040040,040040'
        card(68:) = ''
        card_no = card_no + 1
      end if
      obj_pos = 0
      num_load_ops = 0
    end subroutine FINISH_OBJ

    subroutine HEADING
      if ( do_list ) then
        call heading_job
        write ( u_list, 110 )
110     format ( '0 SEQ PG LIN  LABEL  OP    OPERANDS',44x, &
          &      'SFX CT  LOCN  INSTRUCTION TYPE  CARD' )
        write ( u_list, * )
        line_no = line_no + 2
      end if
    end subroutine HEADING

    subroutine HEADING_JOB
      page_no = page_no + 1
      write ( u_list, 100 ) skip, page_head, deck_id, page_no
100   format ( a1, 26x, a52, 7x, a5, 15x, 'PAGE', i5 )
      if ( skip == '1' ) line_no = 0
      line_no = line_no + 1
      skip = '1'
    end subroutine HEADING_JOB

    subroutine LISTING ( WIDTH, LOC, OUTPUT, ORG, CARD, DEV, X )
      integer, intent(in), optional :: WIDTH, LOC, ORG, CARD
      character(len=*), optional :: OUTPUT, DEV, X
      character(len=24) :: EndLine ! Stuff between SFX and WHY
      character(len=13) :: ErrorMsg
      character(len=132) :: PrintLine   ! To assemble the line, so it can be trimmed
      character(len=5) :: PrintCard ! to print CARD (or not)
      character(len=5) :: PrintSeq ! to print SEQ (or not)
      if ( do_list ) then
        if ( line_no >= maxLine .or. skip /= '1' ) call heading
        if ( why == '' .or. why == 'MACRO' .or. why == 'GMARK' &
          & .or. why == 'GEN' .or. why == 'FIELD' .or. why == 'SBFLD' ) then
          write ( printSeq, '(i5)' ) seq
        else
          printSeq = ' '
        end if
        endLine = ''
        errorMsg = ''
        printCard = ''
        if ( present(width) ) write ( endLine(1:4), '(i4)' ) width
        if ( present(loc) ) write ( endLine(5:10), '(i6.4)' ) loc
        if ( present(org) ) write ( endLine(11:17), '(i7.4)' ) org
        if ( present(x) ) endLine(12:12) = x
        if ( present(output) ) endLine(13:) = output
        if ( present(card) .and. do_object ) then
          write ( printCard, '(i5)' ) card
          if ( obj_pos == 0 ) write ( printCard, '(i5)' ) card - 1
        end if
!       if ( present(dev) ) endLine(15:17) = dev
        if ( present(dev) ) endLine(7:9) = dev
        if ( errCode /= noErr ) n_errors = n_errors + 1
        select case ( errCode )
        case ( AddrErr )      ! 1 <= address <= 80
          errorMsg = 'ADDR'
        case ( LabelErr )     ! Duplicate
          errorMsg = 'LABEL'
        case ( MacroErr )     ! MACRO ERROR
          errorMsg = 'MACRO ERROR'
        case ( NoBXLErr )     ! No bXl in a DA
          errorMsg = 'NO BXL'
        case ( OpErr )        ! Invalid mnemonic op code
          errorMsg = 'OP'
        case ( SymErr )       ! Undefined symbol
          errorMsg = 'SYM'
        case ( UndefOrg )     ! Undefined ORG or LTORG
          errorMsg = 'UNDEF ORG'
        case ( BadStatement ) ! Lots of reasons
          errorMsg = 'BAD STATEMENT'
        end select
        write ( printLine, 10 ) printSeq, line(1:2), line(3:5), line(6:11), &
          & line(16:20), line(21:72), sfx, endLine, why, printCard, errorMsg
10      format ( a5, 1x, a2, 1x, a3, 2x, a6, 1x, a5, 1x, a52, 1x, a1, a24, &
          & a5, a5, a15 )
        write ( u_list, '(a)' ) trim(printLine)
        line_no = line_no + 1
      end if
    end subroutine LISTING

    subroutine OUTPUT_SWMS
      ! Output the buffer of set word mark instructions to the object tape
      integer :: I, N
      character(54) :: WMBUF       ! Word marks for set word mark instructions
      if ( num_swms > 0 .and. do_tape ) then
        n = 3*num_swms + num_swms / 2 + 2
        i = 1
        wmbuf = ''
        do while ( i < n )
          wmbuf(i:i) = '1'
          i = min(i+7,n)
        end do
        wmbuf(i:i+4) = '1   1'
        tswms(i:) = 'B007'
        call write_tape ( tswms, wmbuf, 61 )
        num_swms = 0
      end if
    end subroutine OUTPUT_SWMS

    subroutine SPREAD ( HOW_MANY )
      ! Spread OBJECT into OUTPUT.  HOW_MANY is an array, each element of
      ! which indicates the number of characters in a field.
      integer, intent(in) :: HOW_MANY(:)
      integer :: I, J, K ! Indices for how_many, output, object
      integer :: N
      k = 1
      j = 1
      do i = 1, ubound(how_many,1)
        n = how_many(i)
        output(j:j+n-1) = object(k:k+n-1)
        j = j + n + 1
        k = k + n        
      end do
    end subroutine SPREAD

    subroutine SW ( MyP, FromDC )
      ! Generate a set word mark instruction in the load area
      integer, intent(in) :: MyP
      logical, intent(in), optional :: FromDC     ! "Called from DC"
      integer :: J                           ! Index in CARD for SW address
      if ( myP > 0 .and. myP <= 80 .and. notIn_1_80 ) errCode = addrErr
      if ( do_object ) then
        j = 3*num_load_ops + num_load_ops / 2 + 48
        call num_to_addr ( myP, 0, card(j:j+2) )
        num_load_ops = num_load_ops + 1
      end if
      if ( do_tape .and. .not. present(fromDC) ) then
        if ( num_swms == 0 ) then
          tswms = ',      ,      ,      ,      ,      ,      ,'
        else if ( num_swms >= 14 ) then
          call OUTPUT_SWMS
        end if
        j = 3*num_swms + num_swms / 2 + 2
        call num_to_addr ( myP, 0, tswms(j:j+2) )
        num_swms = num_swms + 1
      end if
    end subroutine SW

    subroutine TEST_P ( P_TO_TEST )
      ! If ixLab > 0, test whether its P is the same as P_TO_TEST
      integer, intent(in) :: P_TO_TEST
      character(6) :: P_Before, P_Now
      if ( ixLab <= 0 ) return
      if ( symbols(ixlab)%value /= p_to_test .and. &
        & symbols(ixlab)%value >= 0 .and. p_to_test >= 0 ) then
        write ( p_before, '(i6)' ) symbols(ixlab)%value
        write ( p_now, '(i6)' ) p_to_test
        call do_error ( 'Definition of ' // trim(line(6:11)) // ' (' // &
          & trim(adjustl(p_before)) // ') different from current P (' // &
          & trim(adjustl(p_now)) // ')' )
        errCode = symErr
      end if
    end subroutine TEST_P

    subroutine WRITE_TAPE ( DATA, WMS, N )
      ! Write data with word marks.  Put the first four characters of the ID
      ! at the end of the record.  The last position gets a group mark and
      ! word mark.
      ! The format is a three-digit total length (including word marks),
      ! then a three-digit data-only length, followed by the data.
      ! A word mark is represented by =.
      character(len=*), intent(in) :: DATA, WMS   ! Data and Word Marks
      integer, intent(in) :: N     ! Data length, either 80 or 61
      character(160) :: Buffer     ! Room for 80 characters and word marks
      integer :: I, J              ! Input, Buffer positions
      j = 0
      do i = 1, max(len(data),len(wms))
        if ( i <= len(wms) ) then
          if ( wms(i:i) == '1' ) then
            j = j + 1
            buffer(j:j) = '='
          end if
        end if
        if ( i <= len(data) ) then
          j = j + 1
          buffer(j:j) = data(i:i)
        end if
      end do
      i = len(data)
      buffer(j+1:n-5-i+j) = ' '
      buffer(n-4-i+j:n+1-i+j) = deck_id(1:4) // '=}'
      write ( u_tape, '(2i3,a)' ) n+1-i+j, n, buffer(:n+1-i+j)
    end subroutine WRITE_TAPE

  end subroutine Pass_3

end module PASS_3_M
