program nasadig_fonts
!
!*******************************************************************************
!
!! NASADIG_FONTS creates binary font files from text versions.
!
!
!  Discussion:
!
!    This program will process ASCII formatted sequential
!    files containing font move/draw information into a
!    direct access file for internal use by NASADIG.
!
!  Modified:
!
!    22 November 2000
!
  integer, parameter :: mxregf = 18
  integer, parameter :: mxshdf = 4
  integer, parameter :: maxtot = mxregf + mxshdf
  integer, parameter :: mxstrk = 12000
!
  integer bias(maxtot)
  integer bwidth(95)
  integer bx(150)
  integer bxy(mxstrk)
  integer by(150)
  logical file_exists
  integer i
  integer ibxy
  integer icmax
  integer icmin
  integer ie
  integer ierr
  integer ifill(512)
  integer ihight
  integer ileft
  integer indx(96)
  integer info
  character ( len = 40 ) inpfil
  integer iopflg
  integer ios
  integer ipxcon
  integer iright
  integer is
  integer j
  integer jchar
  integer jst
  character ( len = 80 ) kode
  integer load
  integer lrec
  integer luni
  integer luno
  integer nmchar
  integer nrec
  integer nst
  integer nstrok
  character ( len = 40 ) outfil
  character ( len = 3 ) status
!
  call timestamp ( )

  write ( *, * ) ' '
  write ( *, * ) 'NASADIG_FONTS'
  write ( *, * ) '  Create the NASADIG font database file.'
  write ( *, * ) ' '

  info = 0

  if ( info == 1 ) then
    write ( *, * ) ' '
    write ( *, * ) '  This version of the program incorporates all the'
    write ( *, * ) '  font information into one direct access file. '
    write ( *, * ) '  Whenever the file is written, all fonts must be' 
    write ( *, * ) '  redefined so that the first record of this file can'
    write ( *, * ) '  be updated to reflect where each font definition'
    write ( *, * ) '  begins.'
  end if
!
!  Load new font.
!
  do

    if ( info == 1 ) then
      write ( *, * ) ' '
      write ( *, * ) '  Enter the direct access file name to be created:'
    end if

    read ( *, '(a)', iostat = ios ) outfil

    if ( ios /= 0 ) then
      write ( *, * ) ' '
      write ( *, * ) 'NASADIG_FONTS - Fatal error!'
      write ( *, * ) '  Failure to read user input.'
      stop
    end if

    inquire ( file = outfil, exist = file_exists )

    if ( .not. file_exists ) then
      status = 'new'
      exit
    end if

    write ( *, * ) ' '
    write ( *, * ) '  A file of this name already exists.'
    write ( *, * ) '  Do you want to overwrite it?'

    read ( *, '(a)', iostat = ios ) kode

    if ( ios /= 0 ) then
      write ( *, * ) ' '
      write ( *, * ) 'NASADIG_FONTS - Fatal error!'
      write ( *, * ) '  Failure to read user input.'
      stop
    end if

    if ( kode(1:1) == 'Y' .or. kode(1:1) == 'y' ) then
      exit
    end if

  end do
!
!  Set the record length of the font file.
!
  call syrecl ( 512, lrec )
!
!  Create the font file for direct access unformatted read/write.
!
  iopflg = ipxcon ( 'O_RDWR' ) &
         + ipxcon ( 'O_CREAT' ) &
         + ipxcon ( 'DIRECT' ) &
         + ipxcon ( 'UNFORM' ) &
         + lrec * 256

  call pxfopn ( outfil, iopflg, 0, luno, ios )

  if ( ios /= 0 ) then
    write ( *, * ) ' '
    write ( *, * ) 'NASADIG_FONTS - Fatal error!'
    write ( *, * ) '  Could not open the font database file.'
    write ( *, * ) '  Error code IOS = ', ios
    stop
  end if

  load = 2
  bias(1) = 0
  bias(2) = 1
  nrec = 0

  do

    if ( info == 1 ) then
      write ( *, * ) ' '
      write ( *, * ) '  Enter the file name for font ID #', load
      write ( *, * ) '  or RETURN if done.'
    end if

    read ( *, '(a)', iostat = ios ) inpfil

    if ( ios /= 0 ) then
      write ( *, * ) ' '
      write ( *, * ) 'NASADIG_FONTS - Fatal error!'
      write ( *, * ) '  Failure to read user input.'
      stop
    end if

    if ( inpfil(1:1) == ' ') then
      exit
    end if
!
!  Open the raw font file for sequential access formatted read-only.
!
    iopflg = ipxcon ( 'O_RDONLY' )

    call pxfopn ( inpfil, iopflg, 0, luni, ios )

    if ( ios /= 0 ) then
      write ( *, * ) ' '
      write ( *, * ) 'NASADIG_FONTS - Fatal error!'
      write ( *, * ) '  Could not open the font file ' // trim ( inpfil )
      stop
    end if

    ibxy = 0
!
!  Read in a character from the sequential file and calculate the width.
!
    indx(1) = 1
    rewind ( unit = luni )

    do

      read ( luni, '(18i4)', iostat = ios ) &
        jchar, nstrok, ileft, iright, ( bx(i), by(i), i = 1, 7 )

      if ( ios /= 0 ) then
        exit
      end if

      if ( 32 < jchar .and. jchar < 128 ) then

        jchar = jchar - 32
        bwidth(jchar) = iright - ileft
        nst = nstrok / 2

        if ( nstrok > 16 ) then
          read ( luni, '(18i4)', iostat = ios ) ( bx(i), by(i), i = 8, nst-1 )
          if ( ios /= 0 ) then
            write ( *, * ) ' '
            write ( *, * ) 'NASADIG_FONTS'
            write ( *, * ) '  Error processing font file ' // trim ( inpfil )
            write ( *, * ) '  The value of IOSTAT was ', ios
            stop
          end if
        end if

        nstrok = ( nstrok - 2 ) / 2

        if ( nstrok > 0 ) then
          do i = 1, nstrok
            if ( bx(i) == -999 ) then
              ibxy = ibxy + 1
              if ( by(i) == 0 .or. by(i) == -999 ) then
                bxy(ibxy) = -64
              else
                bxy(ibxy) = by(i)
              end if
            else
              ibxy = ibxy+2
              bxy(ibxy-1) = bx(i) - ileft
              bxy(ibxy) = by(i)
            end if
          end do
        end if

        indx(jchar+1) = ibxy + 1

      end if

    end do

    close ( unit = luni )
!
!  Calculate height from capital A.
!
    is = indx(33)
    ie = indx(34) - 1
    icmax = bxy(is+1)
    icmin = bxy(is+1)
    if ( icmax == -64 ) then
      icmin = bxy(is+2)
      icmax = bxy(is+2)
    end if

    i = is

    do while ( i < ie )

      if ( bxy(i) > -64 ) then
        icmax = max ( icmax, bxy(i+1) )
        icmin = min ( icmin, bxy(i+1) )
      else
        i = i - 1
      end if

      i = i + 2

    end do

    ihight = icmax - icmin

    write ( *, * ) '  Font ', load, ' from file ', trim ( inpfil ), &
      ' Height = ', ihight
!
!  Subtract the Y bias from Y values in BXY to make zero the base
!  of all capital letters.
!
    nmchar = ibxy

    if ( load <= mxregf ) then

      i = 1

      do while ( i < nmchar )

        if ( bxy(i) > -64 ) then
          bxy(i+1) = bxy(i+1) - icmin
        else
          i = i - 1
        end if

        i = i + 2

      end do

    end if
!
!  Initialize the pad array.
!
    ifill(1:512) = 0
!
!  Write out the header record.
!
    nrec = 1 + ( nmchar + 511 ) / 512

    write ( luno, rec = 1, iostat = ios ) load, bias(2:load), ifill(load+1:512)

    if ( ios /= 0 ) then
      write ( *, * ) ' '
      write ( *, * ) 'NASADIG_FONTS - Error!'
      write ( *, * ) '  An I/O error occurred while writing the'
      write ( *, * ) '  first header record to the direct access output file.'
      write ( *, * ) '  The value of IOSTAT was ', ios
      stop
    end if

    write ( luno, rec = 1+bias(load), iostat = ios ) &
      nmchar, ihight, indx(1:96), bwidth(1:95), ifill(1:319)

    if ( ios /= 0 ) then
      write ( *, * ) ' '
      write ( *, * ) 'NASADIG_FONTS - Error!'
      write ( *, * ) '  An I/O error occurred while writing the'
      write ( *, * ) '  second header record to the direct access output file.'
      write ( *, * ) '  The value of IOSTAT was ', ios
      stop
    end if
!
!  Write out the strokes.
!
    jst = 1
    do i = 1, nrec-1

      write ( luno, rec = i+1+bias(load), iostat = ios ) bxy(jst:jst+511)

      if ( ios /= 0 ) then
        write ( *, * ) ' '
        write ( *, * ) 'NASADIG_FONTS'
        write ( *, * ) '  An I/O error occurred while writing the'
        write ( *, * ) '  stroke records to the direct access output file.'
        write ( *, * ) '  The value of IOSTAT was ', ios
        stop
      end if

      jst = jst + 512
    end do

    if ( jst <= nmchar ) then
      write ( luno, rec = nrec+1+bias(load), iostat = ios ) bxy(jst:nmchar)
      if ( ios /= 0 ) then
        write ( *, * ) ' '
        write ( *, * ) 'NASADIG_FONTS'
        write ( *, * ) '  An I/O error occurred while writing the'
        write ( *, * ) '  final stroke record to the direct access output file.'
        write ( *, * ) '  The value of IOSTAT was ', ios
        stop
      end if
    end if

    load = load + 1

    if ( load > maxtot ) then
      write ( *, * ) ' '
      write ( *, * ) 'NASADIG_FONTS'
      write ( *, * ) '  No room for more fonts!'
      exit
    end if

    bias(load) = bias(load-1) + nrec + 1

  end do

  load = load - 1
  close ( unit = luno )

  write ( *, * ) ' '
  write ( *, * ) 'NASADIG_FONTS'
  write ( *, * ) '  Created the direct access font file ' // trim ( outfil )
  write ( *, * ) '  It contains fonts 2 through ', load

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

  stop
end