program ncar_fonts
!
!*******************************************************************************
!
!! NCAR_FONTS creates a binary font data file for the NCAR graphics library.
!
!
!  Discussion:
!
!    Because of the difficulty of porting a binary file, the database
!    for the PWRITX package is supplied on the distribution tape in
!    the four ASCII files:
!
!      pwritx.c1
!      pwritx.c2
!      pwritx.d1
!      pwritx.d2
!
!    PWRITX uses a binary file as its database.  This program converts the 
!    four card-image files mentioned above into one binary file having 
!    four records.
!
!    After the binary file has been created, it calls two short test 
!    routines to make sure that accessing of all records works correctly.  
!    A message is printed as to the success or failure of the test routines.
!
!    Before executing this program, the implementation-dependent constants in
!    the blockdata DPORT must be set.  Also, make the four files
!    pwritx.c1, pwritx.c2, pwritx.d1, and pwritx.d2 available on the
!    units specified in blockdata dport.  Ready the unit specified
!    in blockdata DPORT to receive the created binary output file
!    (the file which will ultimately be used by PWRITX.)
!
  integer dumrea
  logical flag
  integer i
  integer, parameter :: icnum1 = 49
  integer, parameter :: icnum2 = 575
  integer idd(8625)
  integer iddlen
  integer ierr
  integer ind(789)
  integer indlen
  integer, parameter :: iout = 7
  integer, parameter :: iu1 = 1
  integer, parameter :: iu2 = 2
  integer, parameter :: iu3 = 3
  integer, parameter :: iu4 = 4
  integer iwork(8625)
  integer lenwor
  integer ma15
  integer mask
  integer mask15(15)
  integer, save :: nbwd
  integer num15
!
!  The size of  idd, ind, and iwork  may have to be modified
!  to contain the number of elements equal to the value of  iddlen and
!  indlen  as computed in the code below.
!
  common /pwrc0/ idd, ind
  common /idc0/ lenwor, iwork
!
!  For initialization of constants in CREBIN.
!
  common /idc2/ mask15
!
!  For initialization of constants in crebin and creb15
!
  common /idc1/ ma15
!
!  For initialization of machine dependent constants
!
  common /pinit2/ flag
!
!  Constants defined in block data dport.
!
  common /idc3/ iddlen, indlen

  external dport
!
  write ( *, * ) ' '
  write ( *, * ) 'NCAR_FONTS'
  write ( *, * ) '  Read 4 text files containing NCAR font information.'
  write ( *, * ) '  Create a single binary data file for use by PWRITX.'

  open ( unit = iu1, file = 'pwritx.c1', status = 'old' )
  open ( unit = iu2, file = 'pwritx.c2', status = 'old' )
  open ( unit = iu3, file = 'pwritx.d1', status = 'old' )
  open ( unit = iu4, file = 'pwritx.d2', status = 'old' )

  open ( unit = iout, file = 'pwritx.dat', status = 'replace', &
    form = 'unformatted' )
!
!  Initialization pass
!
!  Check if done
!
  if ( .not. flag ) then

    flag = .true.
!
!   Get the number of bits per integer word.
!
    nbwd = bit_size ( nbwd )
!
!  Find the number of 15 bit parcels per word
!
    num15 = nbwd / 15
!
!  Calculate the length of arrays iwork, idd, ind required on this machine.
!
    lenwor = ( icnum2*16*15-1 ) / nbwd +1
    iddlen = lenwor
    indlen = ( icnum1*16-1 ) / num15 + 1
!
!  Generate masks for the leftmost 1-15 bits in a word
!
    mask = 1
    mask = ishft ( mask, (nbwd-1) )
    mask15(1) = 0

    do i = 2, 15
      mask15(i) = ishft ( mask15(i-1), -1 )
      mask15(i) = ior ( mask, mask15(i) )
    end do

  end if
!
!  End initialization
!
!  For digitization of complex character set.
!
!  Create 1 binary record on file IOUT containing the contents of the
!  array ind in PWRITX.
!
  call creb15 ( iu1, iout, icnum1, iwork, lenwor )
!
!  Create 1 binary record on file IOUT containing the contents of the
!  array idd in PWRITX.
!
  call crebin ( iu2, iout, icnum2, iwork, lenwor )
!
!  For digitization of duplex character set.
!
!  Create 1 binary record on file IOUT containing the contents of the
!  array ind in PWRITX.
!
  call creb15 ( iu3, iout, icnum1, iwork, lenwor )
!
!  Create 1 binary record on file IOUT containing the contents of the
!  array idd in PWRITX.
!
  call crebin ( iu4, iout, icnum2, iwork, lenwor )

  endfile iout

  close ( unit = iu1 )
  close ( unit = iu2 )
  close ( unit = iu3 )
  close ( unit = iu4 )

  write ( *, * ) ' '
  write ( *, * ) 'NCAR_FONTS created the binary file.'
!
!  Read the 2 records representing the complex character set.
!
  rewind iout
  read ( iout ) ind(1:indlen)
  read ( iout ) idd(1:iddlen)
  rewind iout
!
!  Test the accessing of the complex character set.
!
  call ccheck ( ierr )

  write ( *, * ) ' '
  write ( *, * ) 'NCAR_FONTS'
  write ( *, * ) '  Test complex set.'
  write ( *, * ) ' '

  if ( ierr == 0 ) then
    write ( *, * ) ' '
    write ( *, * ) 'NCAR_FONTS'
    write ( *, * ) '  6 bit test successful.'
    write ( *, * ) '  12 bit test successful.'
  else if ( ierr == 1 ) then
    write ( *, * ) ' '
    write ( *, * ) 'NCAR_FONTS'
    write ( *, * ) '  6 bit test failed.'
    write ( *, * ) '  12 bit test successful.'
  else if (ierr == 2 ) then
    write ( *, * ) ' '
    write ( *, * ) 'NCAR_FONTS'
    write ( *, * ) '  6 bit test successful.'
    write ( *, * ) '  12 bit test failed.'
  else
    write ( *, * ) ' '
    write ( *, * ) 'NCAR_FONTS'
    write ( *, * ) '  6 bit test failed.'
    write ( *, * ) '  12 bit test failed.'
  end if
!
!  Load the 2 records representing the duplex character set.
!
  rewind iout
  read ( iout ) dumrea
  read ( iout ) dumrea
  read ( iout ) ind(1:indlen)
  read ( iout ) idd(1:iddlen)
  rewind iout
!
!  Test accessing of duplex character set.
!
  call dcheck ( ierr )

  write ( *, * ) ' '
  write ( *, * ) 'NCAR_FONTS'
  write ( *, * ) '  Test duplex set.'
  write ( *, * ) ' '

  if ( ierr == 0 ) then
    write ( *, * ) ' '
    write ( *, * ) 'NCAR_FONTS'
    write ( *, * ) '  6 bit test successful.'
    write ( *, * ) '  12 bit test successful.'
  else if ( ierr == 1 ) then
    write ( *, * ) ' '
    write ( *, * ) 'NCAR_FONTS'
    write ( *, * ) '  6 bit test failed.'
    write ( *, * ) '  12 bit test successful.'
  else if (ierr == 2 ) then
    write ( *, * ) ' '
    write ( *, * ) 'NCAR_FONTS'
    write ( *, * ) '  6 bit test successful.'
    write ( *, * ) '  12 bit test failed.'
  else
    write ( *, * ) ' '
    write ( *, * ) 'NCAR_FONTS'
    write ( *, * ) '  6 bit test failed.'
    write ( *, * ) '  12 bit test failed.'
  end if

  close ( unit = iout )

  write ( *, * ) ' '
  write ( *, * ) 'NCAR_FONTS'
  write ( *, * ) '  Normal end of execution.'

  stop
end
subroutine crebin ( inunit, ioutun, innum, itemp, lentem )
!
!*******************************************************************************
!
!! CREBIN copies ASCII integer records to a binary file.
!
!
!  Parameters:
!
!    Input, integer INUNIT, the index of a file which contains INNUM card 
!    images.  Each card image contains 16 integers, each in an I5 format. 
!    Each integer represents a positive 15 bit value.  The information on 
!    INUNIT can be read by CREBIN.  On return, file INUNIT has been rewound.
!
!    Input, integer IOUTUN, the index of a file where CREBIN can write a 
!    record.  IOUTUN is assumed to be properly positioned for input.
!    On output, a binary record has been created on unit IOUTUN which 
!    contains the first NUMOUT words of the array ITEMP as one long bit 
!    string, where NUMOUT is exactly 1+(INNUM*15*16-1)/NBWD, and NBWD
!    is the number of bits per word.
!
!    Input, integer INNUM,the number of records to be read from unit INUNIT.
!
!    Output, integer ITEMP(LENTEM), contains the integers from unit INUNIT
!    stored consecutively without considering word boundaries.
!
!    Input, integer LENTEM, the size of ITEMP.  LENTEM must be at least
!      1+(INNUM*15*16-1)/NBWD, where NBWD is the number of bits per word.
!
  integer lentem
!
  integer i
  integer icard(16)
  integer iin15
  integer in15
  integer innum
  integer inunit
  integer ioutun
  integer ipos
  integer itemp(lentem)
  integer iword
  integer j
  integer ma15
  integer mask15(15)
  integer nbwd
!
!  See block data dport for meaning of constants in common blocks.
!
  common /idc1/ ma15
  common /idc2/ mask15
!
!  Local variables:
!
!   iword - the entry in the ITEMP which is currently being filled.
!   in15 - contains 15 bit unit, right justified.
!   iin15 - contains the 15 bit unit - or part of it - at the position
!           which it will have in itemp(iword)
!   ipos - the number of the first bit in the word itemp(iword), where
!          the next 15 bit unit will be stored - 1 .
!          (count from left to right, start with 0)
!   icard - temporary storage for 1 card image.
!
  rewind inunit

  iword = 1
  ipos = 0
  itemp(1) = 0
  nbwd = bit_size ( nbwd )
!
!  Loop through all card images.
!
  do i = 1, innum

    read ( inunit, '(16i5)' ) icard(1:16)
!
!  Loop through all 15 bit units on a card image.
!
    do j = 1, 16

      in15 = icard(j)
!
!  Store 15 bit unit as a whole if possible or left part of it if it
!  hits word boundary.
!
      iin15 = ishft ( iand ( in15, ma15 ), nbwd-15-ipos )
      itemp(iword) = ior ( itemp(iword), iin15 )
      ipos = ipos + 15
!
!  Word boundary reached.  Store right part of unit into next word.
!
      if ( ipos >= nbwd ) then
        ipos = ipos - nbwd
        iword = iword + 1
        itemp(iword) = 0
        iin15 = ishft ( iand ( in15, ma15 ), nbwd-ipos )
        itemp(iword) = ior ( itemp(iword), iin15 )
        itemp(iword) = iand ( itemp(iword), mask15(ipos+1) )
      end if

    end do

  end do

  write ( ioutun ) itemp(1:iword)

  rewind inunit

  return
end
block data dport
!
!*******************************************************************************
!
!! DPORT contains block data for initialization of constants.
!
  logical flag
  integer ibit15
  integer iddlen
  logical ifrst
  integer indlen
  integer iwork(8625)
  integer last12
  integer last6
  integer lenwor
  integer ma15
  integer mask(4)
  integer mask12(64)
  integer mask14
  integer mask15(15)
  integer mask6(64)
  integer nbwd1
  integer num15u
!
  common /idc1/ ma15
!
! for initialization of constants in routine crebin.
!
  common /idc2/ mask15
!
! for initialization of constants in the main program.
!
  common /idc3/ iddlen, indlen
!
!  note that iwork may be changed to contain the number of elements
!  equal to the value of lenwor.
!
  common /idc0/ lenwor, iwork
!
!  initialization flag for pcrbin
!
  common /pinit2/ flag
!
!  initialization for mask generation
!
  common /pinit1/ ifrst
!
!  masking and other machine dependent constants which must be calculated.
!
  common /pinit/ mask,mask6,mask12,last6,last12,ibit15,mask14,num15u,nbwd1
!
!  flag is used by pcrbin to decide if initialization has been completed.
!
  data flag /.false./
!
!  ifrst is used by xtch to decide if masks have been generated
!
  data ifrst /.false./
!
!  ma15 masks the rightmost 15 bits of a word(77777b)
!
  data ma15 /32767/

end
subroutine creb15 ( inunit, ioutun, innum, itemp, lentem )
!
!*******************************************************************************
!
!! CREB15 stores a sequence of integers into an array.
!
!
!  Parameters:
!
!    Input, integer INUNIT, is a file which contains innum card images. 
!    Each card image contains 16 integers, each in an i5 format.  Each 
!    integer represents a positive 15 bit value.  INUNIT can be read by
!    CREB15.  On output, file INUNIT is rewound but otherwise unchanged.
!
!    Input, integer IOUTUN, is a unit number where CREB15 can write a record.
!    IOUTUN is assumed to be positioned right.
!
!    Input, integer INNUM, the number of card images on file inunit.
!
!    Output, integer ITEMP(LENTEM), contains the integers from file INUNIT 
!    stored left justified as 15 bit units with as many units per word as
!    possible without crossing word boundaries.  A binary record is written 
!    on unit IOUTUN which contains the first NUMOUT words of the array 
!    ITEMP as one long bit string.  NUMOUT is exactly (INNUM*16-1)/NUM15+1 
!    and NUM15 is the number of 15 bit units which fit as a whole into 1
!    word.
!
!    Input, integer LENTEM, must be (INNUM*16-1)/NUM15+1 or bigger, where 
!    NUM15 is the number of 15 bit units which fit as a whole into 1 word.
!
  integer lentem
!
  integer i
  integer icard(16)
  integer iin15
  integer in15
  integer innum
  integer inunit
  integer ioutun
  integer ipos
  integer itemp(lentem)
  integer iword
  integer j
  integer ma15
  integer nbwd
  integer num15
!
  common /idc1/ ma15
!
!  local variables:
!
!  iword - the entry in the array itemp which is currently being filled
!  in15 - contains 15 bit unit, right justified.
!  iin15 - contains the 15 bit unit - or part of it - at the position
!    which it will have in itemp(iword)
!  ipos - the number of 15 bit units already stored in the current word + 1 .
!  icard - temporary storage for 1 card image.
!
!
!  NUM15 is the number of 15 bit units which fit as a whole into one word.
!
  nbwd = bit_size ( nbwd )
  num15 = nbwd / 15

  rewind inunit
  ipos = 1
  iword = 1
  itemp(1) = 0
!
!  Read the integers from file inunit and store them into the
!  array itemp as whole units, left justified.
!
!  Loop through all card images.
!
  do i = 1, innum

    read ( inunit, '(16i5)' ) icard(1:16)
!
!  Loop through all 15 bit units on a card image.
!
    do j = 1, 16

      in15 = icard(j)
!
!  Store 15 bit unit at correct position in word.
!
      iin15 = ishft ( iand(in15,ma15), nbwd-ipos*15 )
      itemp(iword) = ior ( iin15, itemp(iword) )
      ipos = ipos + 1
!
!  Start a new word.
!
      if ( ipos > num15 ) then
        ipos = 1
        iword = iword + 1
        itemp(iword) = 0
      end if

    end do

  end do
!
!  Write 1 record in a binary file.
!
  write ( ioutun ) itemp(1:iword)

  rewind inunit

  return
end
subroutine ccheck ( ierr )
!
!***********************************************************************
!
!! CCHECK checks the complex character set.
!
!
!  Discussion:
!
!    test 1
!      retrieve digitization of character + with default function codes
!      and compare it to the correct digitization.
!      (test 6 bit digitization units)
!
!    test 2
!      retrieve digitization of character defined by the octal number 751
!      and compare it with the correct digitization.
!      (test 12 bit digitization units)
!
!  Parameters:
!
!    Output, integer IERR, error flag.
!    0, if both tests of the digitization retrieval process were successful.
!    1, if the 6 bit test failed and the 12 bit test succeeded.
!    2, if the 6 bit test succeeded and the 12 bit test failed.
!    3, if both tests failed.
!
  integer ier
  integer ier1
  integer ier2
  integer, parameter :: ipass = 2
  integer, parameter :: iplusn = 14
  integer, parameter :: iplusp = 37
  integer, parameter :: ioctn = 30
  integer, parameter :: ioctp = 489
  integer lc(150)
  integer, parameter, dimension ( 30 ) :: lcocor = &
    (/ -9, 9, -5, 39, -5, 0, -5, -39, -2048, 0, &
       -4, 39, -4, 0, -4, -39, -2048, 0, -5, 39, &
        6, 39, -2048, 0, -5, -39, 6, -39, -2048, -2048 /)
  integer, parameter, dimension ( 14 ) :: lcpcor = &
    (/ -13, 13, 0, 9, 0, -9, -2048, 0, -9, 0, 9, 0, -2048, -2048 /)
  integer nact1
  integer nact2
!
  common /pwrc1/ lc
!
  ier1 = 0
  ier2 = 0
!
!  Retrieve the digitization of the character "+".
!
  call xtch ( iplusp, ipass, nact1 )
!
!  Compare the number of digitization units retrieved to the correct number.
!
  if ( nact1 /= iplusn ) then

    ier1 = 1
!
!  Compare each of the retrieved digitization units to the correct unit.
!
  else

    do i = 1, nact1
      if ( lc(i) /= lcpcor(i) ) then
        ier1 = 1
        exit
      end if
    end do

  end if
!
!  Retrieve digitization of character defined by octal number 751.
!
  call xtch ( ioctp, ipass, nact2 )
!
!  Compare the number of digitization units retrieved to the correct number.
!
  if ( nact2 /= ioctn ) then
    ier2 = 2
    ierr = ier1 + ier2
    return
  end if
!
!  Compare each of the retrieved digitization units to the correct unit.
!
  do i = 1, nact2
    if ( lc(i) /= lcocor(i) ) then
      ier2 = 2
      ierr = ier1 + ier2
      return
    end if
  end do

  ierr = ier1 + ier2

  return
end
subroutine xtch ( ipoint, ipass, lcnum )
!
!***********************************************************************
!
!! XTCH retrieves character digitization.
!
!
!  Parameters:
!
!    Common input, integer IND(789), contains 15 bit units.  Each word 
!    contains as many units as fit as a whole into one word on this 
!    particular implementation.  Each unit represents a pointer into 
!    the array IDD and an indication of the format of the data which 
!    can be found there.  In each unit, the 14 bits to the right 
!    represent the number of the entry in IDD (for 60 bit words) where 
!    the corresponding digitization starts.  If the first bit to the 
!    left is 1 we expect 12 bit units in IDD; if it is 0 we expect 6 
!    bit units in IDD.
!
!   idd-an array containing character digitizations. the digitizations
!       can consist of either 12bit or 6 bit units. the digitizations
!       are stored as a bit stream crossing word boundaries if necessary
!       for 60 bit words they start at the beginning of a word.
!       the end of a digitization is indicated by 2 consecutive units
!       with all bits 0.
!
!   ipoint - an integer indicating the ipoint-th unit stored in the
!            array ind
!
! on entry
!
!   lc - an array. entries can have any value.
!
!   ipass = 2 return digitization of character identified by parameter
!             ipoint in array lc
!         = 1  return only first and second unit of digitization in
!              lc(1) and lc(2)
!   lcnum - any value
!
! on exit
!   idd - unchanged
!   ind - unchanged
!   ipoint - unchanged
!   ipass - unchanged
!   lc - if no digitization found, unchanged
!        otherwise
!        lc(i) contains the i-th unit of the digitization of the
!        character that we get when we retrieve the ipoin-th unit in the
!        array ind, interpret the first bit to the left as an indication
!        of a 12 bit or 6 bit digitization and the 14 bits to the right
!        as the number of the entry in the array idd (for 60 bit words)
!        where the digitization of the character starts.
!        notice that each unit goes through a transformation before it
!        is stored in lc. from 6 bit units 32 is subtracted, from 12
!        bit units 2048 is subtracted. also a special indicator (-2048)
!        is put into lc for units with all bits zero.
!
!   lcnum - if no digitization found, 0
!           otherwise
!           the number of the entry in the array lc which contains the
!           last unit of the digitization of the character.
!           it can algorithmically be defined as the number of units
!           which can be encountered before 2 consecutive units with
!           all 0 units were found.assume that the starting point was
!           found as described above when describing the array lc.
!
  integer idd(8625)
  logical ifrst
  integer ind(789)
  integer, parameter :: indzer = -2048
  integer lc(150)
  integer lcnum
  integer, parameter :: nbpp = 15
!
! pwrc0 and pwrc1 are for communication with routine pwritx.
! routine xtch receives values in pwrc0 and returns values in pwrc1.
!
  common /pwrc1/ lc
!
!  note the size of idd and ind may be modifed to contain the number of
!  elements equal to the value of iddlen and indlen computed in pwritx.
!
  common/pwrc0/ idd, ind
!
!  masking and other machine dependent constants which must be calculated.
!
  common /pinit/ mask(4),mask6(64),mask12(64),last6,last12,ibit15, &
    mask14,num15u,nbwd
!
!  initialization flag
!
  common /pinit1/ ifrst
!
! maxun - array containing maximum number of units to be retrieved.
!
  dimension maxun(2)
!
! the number of bits in a 6 bit unit.
!
  data nbpu6 /6/
!
! the number of bits in a 12 bit unit.
!
  data nbpu12 /12/
!
! for 6 bit units.  lc(i) = i-th unit - ihalf6.
!
  data ihalf6 /32/
!
! for 12 bit units.  lc(i) = i-th unit - ihal12.
!
  data ihal12 /2048/
!
! the number of units to be retrieved if ipass is equal to 1.
!
  data maxun(1) /2/
!
! the maximum number of units to be retrieved if ipass is 2.
!
  data maxun(2) /150/
!
! local variables
!
! idd - array containing digitizations of characters.
! ind - array containing pointers into these digitizations.
! lc - array to contain the digitization of 1 character, 1 unit per word.
! iword - the word in the array ind containing the ipoint-th 15 bit
!         unit.
! ipos - the ipos-th unit in ind(iword) is the ipoint-th unit in the
!        array ind.
! ififtn - the ipoint-th 15 bit unit.
! imode - the mode of the digitization
!         =0  6 bit mode
!         =1  12 bit mode
! idigp - pointer to the start of the digitization
! nummax - the maximum number of digitization units to be retrieved
! bit - the number of the bit in array idd at which the digitization
!        starts
! iddwor - word in array idd containing bit ibit
! npos - position of bit ibit in word iddwor
! nright - number of bits to the right of bit npos in word + 1
! lctem - contains left part of digitization unit, if unit crosses
!         word boundaries
! idigp - entry in the array idd (assumed 60 bit words) where the
!         digitization starts
!         =0  no digitization found
! indzer - an indication that an all 0 bits unit was encountered.
!
!  Initialization of masks
!
  if ( .not. ifrst ) then
    ifrst = .true.
    call mkmsk
  end if
!
!                  part  1
! find idigp, entry in array idd where digitization of character starts.
! find imode, indication for format of digitization (12 bit, 6 bit).
!
!
! initialize the number of units contained in lc to zero.
!
  lcnum = 0
!
!  Find the word in the array ind which contains the ipoint- th unit.
!
  iword = ( ipoint - 1 ) / num15u + 1
!
!  Find the number of the ipoint-th unit within the word iword.
!
  ipos = ipoint - (iword-1) * num15u
!
!  Retrieve the 15 bit unit .
!
  ififtn = iand ( mask(ipos), ind(iword) )
!
!  Shift the 15 bit unit to the right end of the word.
!
  ififtn = ishft ( ififtn, ipos*nbpp-nbwd )
!
!  Retrieve the mode of the digitization pointed to.
!
  imode = iand(ififtn,ibit15)

  if ( imode /= 0 ) then
    imode = 1
  end if
!
!  Retrieve the number of the entry in the idd array where the
!  digitization starts.
!
  idigp = iand (ififtn, mask14 )
!
!  Return if no digitization exists for this pointer.
!
  if ( idigp == 0 ) then
    return
  end if
!
!  part 2
!
!  Store digitization of character into array lc, 1 unit per word.
!
!
!  Define the maximum number of units to be retrieved.
!
  nummax = maxun(ipass)
!
!  Branch depending on format of digitization.
!
  imode = imode + 1
!
! six bit format.
!
  if ( imode == 1 ) then
!
!  Find the bit where the digitization of the character starts.
!
    bit = real ( ( idigp - 1 ) * 60 + 1 )
    iddwor = int ( bit / real ( nbwd ) ) + 1
    npos = int ( bit - real ( iddwor - 1 ) * real ( nbwd ) )
!
!  Loop for maximum number of units or till end of digitization reached.
!
    do i = 1, nummax
!
!  Increment the number of units stored in lc.
!
      lcnum = lcnum + 1
!
!  Store unit into lc(i), right justified.
!
      lc(i) = iand ( idd(iddwor), mask6(npos) )
      nright = nbwd - npos + 1
      lc(i) = ishft(lc(i),nbpu6-nright)
!
!  This part is only for machines where nbwd cannot be divided by 6.
!
      if ( nright < nbpu6 ) then
        lctem = iand (idd(iddwor), mask6(npos) )
        lctem = ishft(lctem,nbpu6-nright)
        lc(i) = iand ( idd(iddwor+1), mask6(1) )
        lc(i) = ishft(lc(i),nbpu6-nright-nbwd)
        lstore = nbwd-nbpu6+nright+1
        lc(i) = iand ( lc(i), mask6(lstore) )
        lc(i) = ior(lc(i),lctem)
      end if
!
!  End of part for NBWD not dividable by 6.
!
      lc(i) = iand(last6,lc(i))
!
!  Interpret unit as positive or negative displacement.
!
      lc(i) = lc(i) - ihalf6
!
!  If this unit has all zero bits, set indicator .
!
      if ( lc(i) == -ihalf6 ) then
        lc(i) = indzer
      end if
!
!  Check for end of digitization (2 all zero units in a row).
!
      if ( i > 1 ) then
        if ( lc(i) == indzer .and. lc(i-1) == indzer ) go to 3
      end if
!
!  Define the next digitization unit.
!
      npos = npos + nbpu6

      if ( npos >= nbwd ) then
        iddwor = iddwor + 1
        npos = npos - nbwd
      end if

    end do
!
!  Twelve bit format.
!
  else if ( imode == 2 ) then

    bit = real ( ( idigp - 1 ) * 60 + 1 )
    iddwor = int ( bit / real ( nbwd ) ) + 1
    npos = int ( bit - real ( iddwor - 1 ) * real ( nbwd ) )

    do i = 1, nummax

      lcnum = lcnum + 1
      lc(i) = iand ( idd(iddwor), mask12(npos) )
      nright = nbwd - npos + 1
      lc(i) = ishft ( lc(i), nbpu12-nright )
!
!  This part is only for machines where NBWD cannot be divided by 12.
!
      if ( nright < nbpu12 ) then
        lctem = iand ( idd(iddwor), mask12(npos) )
        lctem = ishft(lctem,nbpu12-nright)
        lc(i) = iand(idd(iddwor+1),mask12(1))
        lc(i) = ishft(lc(i),nbpu12-nright-nbwd)
        lstore = nbwd - nbpu12 + nright + 1
        lc(i) = iand(lc(i),mask12(lstore))
        lc(i) = ior(lc(i),lctem)
      end if
!
!  End of part for NBWD not divisible by 12.
!
      lc(i) = iand(last12,lc(i))
      lc(i) = lc(i) - ihal12

      if ( lc(i) == -ihal12 ) then
        lc(i) = indzer
      end if

      if ( i /= 1 ) then
        if ( lc(i) == indzer .and. lc(i-1) == indzer ) then
          exit
        end if
      end if

      npos = npos + nbpu12

      if ( npos >= nbwd ) then
        iddwor = iddwor + 1
        npos = npos - nbwd
      end if

    end do

  end if

  return
end
subroutine mkmsk
!
!***********************************************************************
!
!! MKMSK generates the machine dependent data values used by XTCH.
!
!
  integer i
  integer ibit15
  integer imsk1
  integer imsk2
  integer imsk3
  integer iprct
  integer iprct2
  integer itemp
  integer last12
  integer last6
  integer leftjs
  integer mask(4)
  integer mask12(64)
  integer mask14
  integer mask6(64)
  integer nbwd
  integer num15u
!
  common /pinit/ mask, mask6, mask12, last6, last12, ibit15, mask14, &
    num15u, nbwd
!
!  Mask for 15 bit parcels (77777b)
!
  imsk1 = 32767
!
!  Find the number of bits per word.
!
  nbwd = bit_size ( nbwd )
!
!  Compute the number of 15 bit parcels
!
  num15u = nbwd / 15
!
!  IPRCT and iprct2 are used to prevent sign extension when doing left shifts.
!
  itemp = ishft(imsk1,(nbwd-16))
  iprct = itemp
  it1 = num15u-1

  do i = 1, it1
    iprct = ishft ( iprct, -15 )
    iprct = ior(itemp,iprct)
  end do

  iprct = ior(iprct,imsk1)
  iprct2 = ishft(iprct,-14)
!
!  left justify
!
  leftjs = nbwd-15
  imsk1 = ishft(imsk1,leftjs)
!
!  Generate the masks for the 15 bit parsals
!
  do i = 1, num15u

    mask(i) = imsk1
!
!  Shift for next parsal
!
    imsk1 = ishft(imsk1,-15)
!
!  Protect from sign extension(revelant only on first pass)
!
    imsk1 = iand(imsk1,iprct2)

  end do
!
!  mask for 6 bit parcels (77b)
!
  imsk2 = 63
!
!  mask for 12 bit parcels (7777b)
!
  imsk3 = 4095
!
!  left justify
!
  leftjs = nbwd-6
  imsk2 = ishft(imsk2,leftjs)

  leftjs = nbwd-12
  imsk3 = ishft(imsk3,leftjs)
!
!  set up all possible 6 and 12 bit units
!  note that masks will also be used when units cross word boundries
!
  do i = 1, nbwd
!
!  6 bit masks
!
    mask6(i) = imsk2
    imsk2 = ishft(imsk2,-1)
!
!  Protection from sign extension (relevant only on the first pass)
!
    imsk2 = iand(imsk2,iprct)
!
!  12 bit masks
!
    mask12(i) = imsk3
    imsk3 = ishft(imsk3,-1)
!
!  Protect from sign extension (relevant only on the first pass)
!
    imsk3 = iand(imsk3,iprct)

  end do
!
!  mask for 6 bit right justifed unit (77b)
!
  last6 = 63
!
!  mask for 12 bit right justifed unit (7777b)
!
  last12 = 4095
!
!  mask for 15-th bit from the right (40000b)
!
  ibit15 = 16384
!
!  mask for 14 bit right justifed unit (37777b)
!
  mask14 = 16383

  return
end
subroutine dcheck ( ierr )
!
!***********************************************************************
!
!! DCHECK checks the duplex character set.
!
!
!  Discussion:
!
!    Test 1
!      Retrieve the digitization of the character "+" with default function 
!      codes and compare it to the correct digitization.
!      (test 6 bit digitization units)
!
!    Test 2
!      retrieve digitization of character defined by the octal number 751
!      and compare it with the correct digitization.
!      (test 12 bit digitization units)
!
!  Modified:
!
!    19 May 2001
!
!  Parameters:
!
!    Output, integer IERR, error flag.
!    0, if 2 short tests of the digitization retrieval process
!       were successful
!    2, if the test was successful for 6 bit digitization units
!       but not successful for 12 bit digitization units
!    1, if the test was successful for 12 bit digitization units
!       but not successful for 6 bit digitization units.
!    3, if neither of the 2 tests was successful.
!
  integer i
  integer ier1
  integer ier2
  integer ierr
  integer, parameter :: ioctn = 30
  integer, parameter :: ioctp = 489
  integer, parameter :: ipass = 2
  integer, parameter :: iplusn = 26
  integer, parameter :: iplusp = 37
  integer lcocor(30)
  integer lcpcor(26)
!
! pwrc1 is for communication with subroutine xtch.
!
  common /pwrc1/ lc(150)
!
!        ** data for test 1 **
!
!
! the correct digitization of character +.
!
  data lcpcor(1) /-12/
  data lcpcor(2) /13/
  data lcpcor(3) /0/
  data lcpcor(4) /-7/
  data lcpcor(5) /0/
  data lcpcor(6) /5/
  data lcpcor(7) /-2048/
  data lcpcor(8) /0/
  data lcpcor(9) /1/
  data lcpcor(10)/5/
  data lcpcor(11)/1/
  data lcpcor(12)/-7/
  data lcpcor(13)/-2048/
  data lcpcor(14)/0/
  data lcpcor(15)/6/
  data lcpcor(16)/-1/
  data lcpcor(17)/-5/
  data lcpcor(18)/-1/
  data lcpcor(19)/-2048/
  data lcpcor(20)/0/
  data lcpcor(21)/-5/
  data lcpcor(22)/0/
  data lcpcor(23)/6/
  data lcpcor(24)/0/
  data lcpcor(25)/-2048/
  data lcpcor(26)/-2048/
!
!        ** data for test 2 **
!
!
! the correct digitization of the character defined by the octal
! number 751.
!
  data lcocor(1) /-9/
  data lcocor(2) /9/
  data lcocor(3) /-5/
  data lcocor(4) /39/
  data lcocor(5) /-5/
  data lcocor(6) /0/
  data lcocor(7) /-5/
  data lcocor(8) /-39/
  data lcocor(9) /-2048/
  data lcocor(10) /0/
  data lcocor(11) /-4/
  data lcocor(12) /39/
  data lcocor(13) /-4/
  data lcocor(14) /0/
  data lcocor(15) /-4/
  data lcocor(16) /-39/
  data lcocor(17) /-2048/
  data lcocor(18) /0/
  data lcocor(19) /-5/
  data lcocor(20) /39/
  data lcocor(21) /6/
  data lcocor(22) /39/
  data lcocor(23) /-2048/
  data lcocor(24) /0/
  data lcocor(25) /-5/
  data lcocor(26) /-39/
  data lcocor(27) /6/
  data lcocor(28) /-39/
  data lcocor(29) /-2048/
  data lcocor(30) /-2048/
!
  ier1 = 0
  ier2 = 0
!
!  Test 1.
!
!  Retrieve digitization of character +.
!
  call xtch ( iplusp, ipass, nact1 )
!
!  Compare the number of digitization units retrieved to the correct number.
!
  if ( nact1 /= iplusn ) then

    ier1 = 1
!
!  Compare each of the retrieved digitization units to the correct unit.
!
  else

    do i = 1, nact1
      if ( lc(i) /= lcpcor(i) ) then
        ier1 = 1
        exit
      end if
    end do

  end if
!
!  Test 2
!
!  Retrieve digitization of character defined by octal number 751.
!
  call xtch ( ioctp, ipass, nact2 )
!
!  Compare the number of digitization units retrieved to the correct number.
!
  if ( nact2 /= ioctn ) then

    ier2 = 2
!
!  Compare each of the retrieved digitization units to the correct unit.
!
  else

    do i = 1, nact2
      if ( lc(i) /= lcocor(i) ) then
        ier2 = 2
        exit
      end if
    end do

  end if

  ierr = ier1 + ier2

  return
end