
*=======================================================================
*     
*  Title:        FORTRANIO package for VMSGREP
*                
*  Abstract:     THESE ROUTINES ARE USED BY VMSGREP.C BECAUSE OF PROBLEMS
*                ASSOCIATED WITH READING BINARY RECORDS WITH THE STANDARD
*                C RUNTIME LIBRARY FUNCTION fgets.
*
*                fortran_open    is used instead of fopen
*                fortran_close   is used instead of fclose
*                fortran_read    is used instead of fgets
*                
*  Environment:  VMS
*                
*  Author:       Eric Andresen of General Research Corporation
*                
*  Date:         21-AUG-1986
*                
*-----------------------------------------------------------------------

      integer function fortran_open( file )

      include 'fortranio.cmn'

      integer   status
      character file*(*), carriage_string*10

      open( unit=IN, name=file, carriagecontrol='list', status='old',
     .      iostat=status, readonly )

      if ( status .eq. 0 ) then

         inquire( unit=IN, carriagecontrol=carriage_string )

         if ( carriage_string .eq. 'FORTRAN' ) then
            carriage_type = FORTRAN

            else if ( carriage_string .eq. 'LIST' ) then
            carriage_type = LIST

            else if ( carriage_string .eq. 'NONE' ) then
            carriage_type = NONE            

            else
            status = 1
            end if

         end if

      if ( status .eq. 0 ) then
         fortran_open = 1  ! TRUE
         else
         fortran_open = 0  ! FALSE
         end if

      return
      end

      integer function fortran_close

      include 'fortranio.cmn'

      integer   status

      close( unit=IN, iostat=status )

      if ( status .eq. 0 ) then
         fortran_close = 1  ! TRUE
         else
         fortran_close = 0  ! FALSE
         end if

      return
      end

      integer function fortran_read( line )
      
      include 'fortranio.cmn'

      integer   len_line, status
      logical   read_fortran_line, read_list_line, read_none_line
      character line*(MAX_LINE), null, dummy_char

      data null, dummy_char / 0, 255 /

      fortran_read = 1  ! ASSUME TRUE

      if ( carriage_type .eq. FORTRAN ) then
         if ( .not. read_fortran_line( line, len_line ) )
     .      fortran_read = 0  ! FALSE
         
         else if ( carriage_type .eq. LIST ) then
         if ( .not. read_list_line( line, len_line ) )
     .      fortran_read = 0  ! FALSE

         else if ( carriage_type .eq. NONE ) then
         if ( .not. read_none_line( line, len_line ) )
     .      fortran_read = 0  ! FALSE
         end if

*     TURN ALL OF THE NULLS INTO CHAR(255) SO THAT C WILL NOT 
*     MESS UP ON BINARY RECORDS THAT CONTAIN EMBEDDED NULLS
*     THE LAST NULL IS KEPT AS A SENTINEL 

      if ( fortran_read .ne. 0 ) then
         do ii = 1, len_line-1
            if ( line(ii:ii) .eq. null ) line(ii:ii) = dummy_char
         end do
         end if

      return
      end

      logical function read_fortran_line( line, len_line )

      include 'fortranio.cmn'

      integer    len_line, status
      character  line*(MAX_LINE), carriage_character*1

      character  cr, lf, ff, null
      data       cr, lf, ff, null / 13, 10, 12, 0 /

      read( IN, 100, iostat=status ) carriage_character, line
100   format( a1, a )

      if ( status .ne. 0 ) then
         read_fortran_line = .false.

         else
         read_fortran_line = .true.

         call str$trim( line, line, len_line )

*        TRUNCATE THE LINE IF IT IS TOO LARGE

         if ( len_line .gt. MAX_LINE - 3 ) then
            len_line = MAX_LINE - 3
            line(len_line:) = ' '
            end if

         if ( carriage_character .eq. '+' ) then
            line(len_line+1:) = cr//null
            len_line = len_line + 2

            else if ( carriage_character .eq. ' ' ) then
            line(len_line+1:) = lf//null
            len_line = len_line + 2

            else if ( carriage_character .eq. '0' ) then
            line(len_line+1:) = lf//lf//null
            len_line = len_line + 3

            else if ( carriage_character .eq. '1' ) then
            line = ff//line(1:len_line)//lf//null
            len_line = len_line + 3

            else
            line(len_line+1:) = lf//null
            len_line = len_line + 2
            end if

         end if

      return
      end

      logical function read_list_line( line, len_line )

      include 'fortranio.cmn'

      integer    len_line, status
      character  line*(MAX_LINE)

      character  cr, lf, ff, null
      data       cr, lf, ff, null / 13, 10, 12, 0 /

      read( IN, 100, iostat=status ) line
100   format( a )

      if ( status .ne. 0 ) then
         read_list_line = .false.

         else
         read_list_line = .true.
   
         call str$trim( line, line, len_line )

*        TRUNCATE THE LINE IF IT IS TOO LARGE

         if ( len_line .gt. MAX_LINE - 3 ) then
            len_line = MAX_LINE - 3
            line(len_line:) = ' '
            end if

*        ADD THE \n AND A NULL

         line(len_line+1:) = lf//null
         len_line = len_line + 2
         end if

      return
      end

      logical function read_none_line( line, len_line )

      include 'fortranio.cmn'

      integer    len_line, status
      character  line*(MAX_LINE) 

      character  cr, lf, ff, null
      data       cr, lf, ff, null / 13, 10, 12, 0 /

      read( IN, 100, iostat=status ) line
100   format( a )

      if ( status .ne. 0 ) then
         read_none_line = .false.

         else
         read_none_line = .true.
   
         call str$trim( line, line, len_line )

*        TRUNCATE THE LINE IF IT IS TOO LARGE

         if ( len_line .gt. MAX_LINE - 3 ) then
            len_line = MAX_LINE - 3
            line(len_line:) = ' '
            end if

*        ADD THE \n AND A NULL or JUST THE NULL IF IT ALREADY HAS ONE

         if ( line(len_line:len_line) .eq. lf ) then
            line(len_line+1:) = null
            len_line = len_line + 1

            else
            line(len_line+1:) = lf//null
            len_line = len_line + 2
            end if

         end if

      return
      end
