module lines
  !
  ! Variables for current command line
  character(len=256) :: code,comm,chain
  integer :: lcode,lcomm
  !
  ! Variables for previous command line
  character(len=256) :: code_last,comm_last
  integer :: lcode_last = 0
  integer :: lcomm_last = 0
  !
  ! Buffer for consecutive comment lines
  integer, parameter :: mbuffer = 20
  integer :: ibuffer = 0
  character(len=256) :: comm_buffer(mbuffer)
  !
  character(len=256), parameter :: empty = ' '
  integer :: ispace
  !
end module lines
!
module stdio
  !
  integer, parameter :: stdout = 6
  integer, parameter :: stderr = 0
  integer, parameter :: stdin  = 5
  !
end module stdio
!
module processor_variables
  logical :: do_declar        ! Convert non standard declarations
  logical :: do_byte          ! Convert BYTE declarations
  integer(kind=4) :: ngood
  integer(kind=4) :: lpinc,lbyte,laddr
  integer(kind=4) :: w_comm  ! Write out comments a position W_COMM
  ! -1 : Other line, 0 Do not write; <72 at least a W_COMM; >73 In column 73
  !
  integer(kind=4), parameter :: mgood=10
  integer(kind=4) :: lgsys(mgood)
  character(len=1) :: csuite
  character(len=6) :: goodsys(mgood)
  character(len=80) :: pinc,byte,address
end module processor_variables
!
program processor
  use lines
  use stdio
  use processor_variables
  !---------------------------------------------------------------------
  ! PROCESSOR Main program
  !    Pre-Process a Fortran file. Makes the program "nice", by
  !    appropriate indentation of the source code.
  ! Use
  !    Uses standard input (FOR005), standard output (FOR006) and
  !    standard error for error messages (to be defined for Unix
  !    systems, SYS$ERROR for VMS), so that it can be used on a pipe.
  ! Restrictions
  !    Program must execute where the include files are.
  !---------------------------------------------------------------------
  ! Global
  integer :: lenc,lsign
  ! Local
  character(len=3) :: arg
  character(len=40) :: date
  character(len=20) :: processed,customize
  character(len=8192) :: fortran
  character(len=1) :: tab
  integer :: iarg,lc,lf,ic,i,level,step,iline,fcode
  logical :: asuite,keepcase,keepblank
  integer :: void,ier
  !
  ! --- Customize here ---
  step = 2                     ! Smaller than for Fortran-77
  keepcase = .true.            ! Should case be kept?
  keepblank = .true.           ! Should blank lines be kept?
  ! ----------------------
  !
  ! Command line option parsing
  do iarg=1,command_argument_count()
    call get_command_argument(iarg,arg)
    if (arg.eq.'-l')  keepcase = .false.   ! -l lowercase
    if (arg.eq.'-u')  keepblank = .false.  ! -u unblank
  enddo
  !
  ! Initializations
  void = 0
  call load_processor
  level = 0
  tab = char(9)
  date = ' '
  fortran = ' '
  lf = 1                       ! To get started
  ispace = 0                   ! Itou
  !
  ! lc = len(date)
  ! call sic_c_datetime(date,lc)
  ! lc = lenc(date)
  ! date(lc-2:)=':00 '
  ! print *,'Date ',date
  ! To make differences between 2 consecutive versions, I prefer
  ! to skip the seconds (procedure cdiff).  Agree ?
  processed = '! Last processed by '
  ! Don't write it anymore
  ! write(stdout,'(a)') processed//'indent on '//date(1:lc)
  customize = '! Customized for : '
  lc = 1
  do i=1,ngood
    chain(lc:) = goodsys(i)
    lc = lenc(chain)
    lc=lc+1
    chain(lc:)=', '
    lc=lc+2
  enddo
  if (lc.gt.3) lc = lc-3
  ! write(stdout,'(a)') customize//chain(1:lc)
  iline = 0
  !
  ! Loop on lines
  do while (.true.)
    read(stdin,'(A)',end=10,iostat=ier) chain
    if (void.gt.100) goto 10
    ! print *,'Chain ',iline,ier,chain
    iline = iline+1
    if (iline.eq.1) then
      if (chain(2:20).eq.processed(2:)) cycle  ! Loop
    elseif (iline.eq.2) then
      if (chain(2:20).eq.customize(2:)) cycle  ! Loop
    endif
    lc = lenc(chain)
    if (lc.eq.0) then
      if (chain(1:1).eq.char(12)) then
        write(stdout,'(A)') '!<FF>'    ! A Pseudo Form-Feed
      endif
      void = void+1
      if (.not.keepblank)  cycle  ! Loop
    endif
    void = 0
    !
    ! Format Here...
    lcode = lc
    call nice(chain,code,lcode,comm,lcomm,fortran,lf,asuite)
    !
    ! Compiler or cpp directives must not be indented:
    if (lcode.eq.-1) then
      call purge_all()
      write(stdout,'(A)') trim(chain)
    !
    ! Line is a comment
    elseif (lcode.eq.0) then
      if (lcode_last.gt.0) then
        ! There is a code line pending (>0), and we have currently a
        ! comment: we do not print code line yet, since this line
        ! might be continued. Store comment line in buffer:
        ibuffer = ibuffer+1
        comm_buffer(ibuffer) = comm(1:lcomm)
        !
        if (ibuffer.ge.mbuffer) then
          ! Ok, comment buffer is full. Let's purge it, hoping that pending
          ! code line need not to be continued. If yes, an error will be
          ! raised later on.
          !
          call purge_all()  ! Purge pending lines, reset comm_buffer
          !
        endif
      else
        ! No code line pending, write current comment line now
        write(stdout,'(A)') trim(empty(1:ispace)//comm(1:lcomm))
      endif
    !
    ! Normal lines
    else
      !
      ! Obsolete: call translate (code,lcode)
      !
      ! Compute indentations
      call indent(code,lcode,level,step,fortran,lf,asuite,ispace)
      if (level.lt.0) then
        write(stderr,*) 'Internal error: negative level (',level,')'
        call crash
      endif
      !
      if (.not.keepcase) then
        lcode = lenc(chain)
        call sic_white(chain,lcode)  ! Convert to lower case
      endif
      !
      chain = empty(1:ispace)//chain
      lcode = lenc(chain)
      !
      ! Check continuation mark...
      fcode = lsign(chain,lcode)
      if (chain(fcode:fcode).eq.'&' .or.asuite) then
        ic = abs(lcode_last)
        if (code_last(ic:ic).ne.'&') then
          !
          ! Add a Fortran-95 continuation mark on previous line
          if (lcode_last.gt.0) then
            ic = ic+1
            code_last(ic:ic+3) = '   &'
            lcode_last = ic+3
          else
            write (stderr,*) 'Inconsistent continuation line...'
            call crash
          endif
        endif
      endif
      !
      ! Write previous line
      if (lcode_last.gt.0) then
        ic = lcode_last
        asuite = code_last(ic:ic).eq.'&'
        !
        call purge_all()
      else
        asuite = .false.
      endif
      !
      ! Move to buffer
      code_last = chain
      lcode_last = lcode
      comm_last  = comm
      lcomm_last = lcomm
      !
      ! Recompute ispace such as next comment lines are correctly aligned in
      ! blocks
      ispace = step*level
      !
    endif
    !
  enddo
  !
  10 continue
  call purge_all()
  !
end program processor
!
subroutine print_last
  use lines
  use stdio
  !---------------------------------------------------------------------
  ! Print last code line pending
  !---------------------------------------------------------------------
  ! Local
  character(len=256) :: chain_last
  integer :: icomm
  !
  if (lcode_last.lt.0)  return  ! Nothing to print
  !
  chain_last = code_last
  !
  ! Add last chain comment if any before printing it
  if (lcomm_last.ne.0) then
    icomm = max(32,4*((lcode_last+5)/4))
    chain_last(icomm:) = comm_last(1:lcomm_last)
  endif
  !
  ! Print it
  write(stdout,'(A)') trim(chain_last)
  lcode_last = -lcode_last  ! < 0 means that line has already been printed
  !
end subroutine print_last
!
subroutine purge_all
  use lines
  use stdio
  !---------------------------------------------------------------------
  ! Purge last pending code line and intermediate comment lines
  !---------------------------------------------------------------------
  ! Local
  integer :: i
  !
  ! Print last code line
  call print_last()
  !
  ! Print pending comments
  do i=1,ibuffer
    write(stdout,'(A)') trim(empty(1:ispace)//comm_buffer(i))
  enddo
  ibuffer = 0
  !
end subroutine purge_all
!
subroutine crash
  write(6,'(A)') '%PRE-F-ABORT,  Syntax error in input file'
  stop 1
end
!
subroutine nice(cin,cout,lc,comm,lcomm,fortran,lf,asuite)
  ! use stdio
  !---------------------------------------------------------------------
  ! - 'cin' is the input chain. It can be modified (suppression of
  !   leading spaces, change of continuation markers) but its case is
  !   kept.
  ! - 'cout' is 'cin' converted into uppercase, such as it can be used
  !   to recognize commands.
  ! - 'comm' is the comment found (if any) on line, such as 'cin' is
  !   split 'cout' and 'comm'
  !---------------------------------------------------------------------
  character(len=*), intent(inout) :: cin      ! Chain-in (but can be modified)
  character(len=*), intent(out)   :: cout     ! Chain-out
  integer,          intent(inout) :: lc       ! Length of cin/cout
  character(len=*), intent(out)   :: comm     ! Comment found
  integer,          intent(out)   :: lcomm    ! Length of 'comm'
  character(len=*), intent(inout) :: fortran  ! Previous line(s), used to detect continuations
  integer,          intent(inout) :: lf       ! Length of 'fortran'
  logical,          intent(out)   :: asuite   ! Input line is a continuation
  ! Local
  logical :: start, string
  character(len=1) :: tab,space,delimiter
  integer :: in,out,i,is,lsign
  character(len=256) :: chain  ! Local copy of 'cin', computed during the processing
  ! Data
  data space/' '/, string/.false./
  save string, delimiter
  !
  lcomm = 0
  asuite = .false.
  !
  if (lc.le.0)  return
  !
  ! Pseudo-Standard comment
  if (cin(1:1).eq.'*' .or. cin(1:1).eq.'D' .or. cin(1:1).eq.'d' .or.  &
      cin(1:1).eq.'C' .or. cin(1:1).eq.'c' .or. cin(1:1).eq.'$') then
    comm = cin
    comm(1:1) = '!'
    lcomm = lc
  elseif (cin(1:1).eq.'!') then
    comm = cin
    lcomm = lc
  endif
  !
  if (lcomm.ne.0) then
    ! Found a comment, nothing more to do
    lc = 0
    return
  endif
  !
  ! Check for fixed-form continuation lines
  is = lsign(cin,lc)
  !
  ! Old continuation marks at beginning of line, column 6
  if (is.eq.6 .and. cin(is:is).ne.' ' .and. cin(is:is).ne.'0') then
    cin(is:is) = '&'
    in = is+1
  elseif (cin(1:1).eq.'$') then  ! $something:  assume compiler directive
    comm = cin
    lcomm = lc
    lc = -1
    return
  elseif (cin(1:1).eq.'#') then  ! #something:  assume cpp directive
    comm = cin
    lcomm = lc
    lc = -1
    return
  else
    in = is
  endif
  !
  ! Case for Fortran-90 continuation
  if (fortran(lf:lf).eq.'&') then
    ! write(stderr,*) 'Found a continuation ',fortran(1:lf)
    lf = lf-1
    asuite = .true.
  elseif (cin(is:is).ne.'&') then
    fortran = ' '
    lf = 1
    string = .false.
    asuite = .false.
  else
    ! write(stderr,*) 'Found a F77 continuation ',CIN
    ! write(stderr,*) Fortran(1:lf)
    asuite = .true.
  endif
  !
  start = .true.
  tab = char(9)
  cout  = ' '
  chain = ' '
  out = 1
  do i=in,lc
    if (string) then
      cout(out:out) = cin(i:i)
      chain(out:out) = cin(i:i)
      out = out+1
    elseif (cin(i:i).eq.space .or. cin(i:i).eq.tab) then
      if (.not.start) then
        cout(out:out) = space
        chain(out:out) = space
        out = out+1
      endif
    else
      if (cin(i:i).eq.'!') then
        comm = cin(i:lc)
        lcomm = lc-i+1
        goto 20
      endif
      start = .false.
      ! Upcase 'cin'
      if (cin(i:i).ge.'a' .and. cin(i:i).le.'z') then
        cout(out:out) = char(ichar(cin(i:i)) + ichar('A')-ichar('a'))
      else
        cout(out:out) = cin(i:i)
      endif
      ! Keep case for 'chain'
      chain(out:out) = cin(i:i)
      out = out+1
    endif
    ! if (cin(i:i).eq.'''') string = .not.string
    if (string) then
      if (cin(i:i).eq.delimiter) string = .false.
    elseif  (cin(i:i).eq.'''') then
      string = .true.
      delimiter = ''''
    elseif  (cin(i:i).eq.'"') then
      string = .true.
      delimiter = '"'
    endif
  enddo
  !
  20 continue
  lc = len_trim(cout)
  cin = chain  ! On return 'cin' is stripped of comments and surrounding blanks
  !
  ! Horrible but useful patch:
  ! i = index(cout,'END IF')
  ! if (i.ne.0) cout(i:i+5) = 'ENDIF '
  ! i = index(cout,'END DO')
  ! if (i.ne.0) cout(i:i+5) = 'ENDDO '
  ! i = index(cout,'ELSEIF ')
  ! if (i.ne.0) cout(i:i+6) = 'ELSEIF '
  !
  if (lc.ge.1) then
    ! Append code in 'fortran' variable
    fortran(lf:) = cout(1:lc)
    lf = lf+lc-1
  else
    ! Nothing on this line, add a comment mark
    comm(1:1) = '!'
  endif
end
!
subroutine indent (cin,lc,level,step,merged,lm,asuite,ispace)
  character(len=*), intent(in)    :: cin     ! Chain-in
  integer,          intent(in)    :: lc      ! Length of 'cin'
  integer,          intent(inout) :: level   ! Indentation level
  integer,          intent(in)    :: step    ! Indentation per level
  character(len=*), intent(in)    :: merged  ! Merged lines in case of continuations
  integer,          intent(in)    :: lm      ! Length of 'merged'
  logical                         :: asuite  !
  integer,          intent(out)   :: ispace  ! Spaces to use for current line
  ! Local
  logical :: akey
  integer :: posi,start,is
  !
  ! 1/ Compute the spaces to add at the beginning of input line
  if (.not.asuite) then
  ! if (cin(6:6).ne.' ') then
  !   posi = 7+step*level
  !   asuite = .true.
  ! else
    !
    ! a) Single instructions indented to the left. They do not change the
    !    current general indentation.
    if (cin.eq.'ELSE') then
      posi = 1+step*(level-1)
    elseif (cin(:4).eq.'CASE') then
      posi = 1+step*(level-1)
    elseif (cin.eq.'ELSEWHERE') then
      posi = 1+step*(level-1)
    !
    ! b) Instructions which terminate blocks and indent all to the left
    else
      if (cin.eq.'ENDDO' .or. cin.eq.'ENDIF') then
        level = level-1
      elseif (cin(:3).eq.'END') then
        call isakey(merged,lm,'END',akey)
        if (akey) level = level-1
      elseif (cin(:6).eq.'ELSEIF') then
        call isakey(merged,lm,'ELSEIF',akey)
        if (akey) level = level-1
      elseif (cin(:7).eq.'ELSE IF') then
        level = level-1
      elseif (ichar(cin(1:1)).ge.ichar('0') .and.   &
              ichar(cin(1:1)).le.ichar('9')) then
        is = index(cin,' ')-1           ! Support of labeled DO loops:
        call islabel(cin(1:is),akey)    ! "100 CONTINUE". Must indent to the
        do while (akey)                 ! left. Several might end on the same
          level = level-1               ! labeled instruction
          call islabel(cin(1:is),akey)
        enddo
      endif
      posi = 1+step*level
    endif
  else
    posi = 3+step*level  ! For a continued line
  endif
  !
  ! Where is it written...
  ispace = posi-1
  !
  ! 2/ Change level?
  ! First check if instruction started by a label
  start = 1
  if (ichar(merged(start:start)).ge.ichar('0') .and.  &
      ichar(merged(start:start)).le.ichar('9')) then
    start = index(merged,' ')
    do while (merged(start:start).eq.' ')
      start = start+1
    enddo
  endif
  !
  ! Then analyse line
  if (merged(start:start+1).eq.'DO' .and. .not.asuite) then
    call isakey(merged,lm,'DO',akey)
    if (akey) level = level+1
  elseif (lc.ge.4.and.cin(lc-3:lc).eq.'THEN') then
    if (merged(start:start+1).eq.'IF') then
      call isakey(merged,lm,'IF',akey)
    elseif (merged(start:start+5).eq.'ELSEIF') then
      call isakey(merged,lm,'ELSEIF',akey)
    elseif (merged(start:start+6).eq.'ELSE IF') then
      akey = .true.
    else
      akey = .false.
    endif
    if (akey) level = level+1
  elseif (cin(:11).eq.'SUBROUTINE ') then
    level = level+1
  elseif (cin(:21).eq.'RECURSIVE SUBROUTINE ') then
    level = level+1
  elseif (cin(:9).eq.'FUNCTION ') then
    level = level+1
  elseif (cin(:9).eq.'INTERFACE') then
    level = level+1
  elseif (cin(:7).eq.'MODULE ') then
    level = level+1
  elseif (cin(:8).eq.'PROGRAM ') then
    level = level+1
  elseif (cin(:7).eq.'SELECT ') then
    level = level+1
  elseif (cin(:6).eq.'WHERE ') then
    level = level+1
  elseif (cin(:5).eq.'TYPE ') then
    call isakey(merged,lm,'TYPE',akey)
    if (akey) level = level+1
  elseif (cin(:5).eq.'BLOCK') then
    call isakey(merged,lm,'BLOCK',akey)
    if (akey) level = level+1
  elseif (cin(:17).eq.'INTEGER FUNCTION ') then
    level = level+1
  elseif (cin(:19).eq.'INTEGER*8 FUNCTION ') then
    level = level+1
  elseif (cin(:14).eq.'REAL FUNCTION ') then
    level = level+1
  elseif (cin(:17).eq.'LOGICAL FUNCTION ') then
    level = level+1
  elseif (cin(:16).eq.'REAL*8 FUNCTION ') then
    level = level+1
  elseif (cin(:16).eq.'REAL*4 FUNCTION ') then
    level = level+1
  endif
  !
end
!
subroutine isakey (line,nl,key,akey)
  use stdio
  !-----------------------------------------------------------------------
  !  Detect if KEY is a Fortran statement (keyword) or a simple
  !  variable.
  !-----------------------------------------------------------------------
  character(len=*)     :: line  !
  integer              :: nl    !
  character(len=*)     :: key   !
  logical, intent(out) :: akey  !
  ! Global
  logical :: lexpr
  integer :: lenc
  ! Local
  integer :: ni,i,level,nk,ik
  character(len=12) :: label
  !
  akey = .false.
  nk = lenc(key)
  !
  ik = index(line,key)
  level = 0
  !
  ! BYTE declaration
  if (key.eq.'BYTE') then
    do i=ik+4,nl
      if (line(i:i).eq.'=') return
    enddo
  !
  ! IF or ELSEIF Statement
  elseif (key.eq.'ELSEIF') then
    akey = lexpr(line(ik+6:nl),nl-ik-1)
  elseif (key.eq.'IF') then
    akey = lexpr(line(ik+2:nl),nl-ik-1)
  !
  ! DO Statement
  elseif (key.eq.'DO') then
    ni = 0
    do i=ik+2,nl
      if (line(i:i).eq.'=') then
        ni = i
        goto 20
        ! Check this is a DO WHILE  (Expression), and not DOWHILE(I) = 3
      elseif (line(i:i).eq.'(') then
        if (index(line(1:i),'WHILE').ne.0) then
          akey = lexpr(line(i:nl),nl-i+1)
        endif
        return
        ! Assume loop index is not a structure element...
      elseif (line(i:i).eq.'.') then
        return
      endif
    enddo
    !
    20 continue
    if (ni.eq.0) return        ! Must be DOUBLE PRECISION Something...
    !
    ! Now count parenthesis level, and search for comma at zero level
    ! if one is found, this is a DO statement.
    i = ni+1
    do while (i.le.nl)
      if (line(i:i).eq.'(') then
        level = level+1
      elseif (line(i:i).eq.')') then
        level = level-1
      elseif (level.eq.0) then
        if (line(i:i).eq.',') then
          akey = .true.
          goto 30
        endif
      endif
      i = i+1
    enddo
    !
    30 continue
    if (akey) then
      ! Search for possible label, to locate Label CONTINUE for indentation
      ! later
      do i=ik+2,ni-1
        if (line(i:i).ne.' ' .and. line(i:i).lt.'0' .or. line(i:i).gt.'9') then
          if (i.eq.ik+2) return
          label = line(ik+2:i-1)
          if (lenc(label).ne.0) call set_label(label)
          return
        endif
      enddo
    endif
    return
  !
  ! END* statements
  elseif (key.eq.'END' .or. key.eq.'ENDDO' .or. key.eq.'ENDIF') then
    if (index (line,'=').ne.0) then
      akey = .false.
    else
      akey = .true.
    endif
  !
  ! OPEN statement
  elseif (key.eq.'OPEN') then
    ni = 0
    do i=ik+4,nl
      if (line(i:i).eq.'(') then
        ni = i
        goto 10
      elseif (line(i:i).eq.'=') then
        ! OPEN = something
        return
      elseif (line(i:i).eq.'.') then
        ! OPEN.field.subfield
        return
      endif
    enddo
    10 continue
    if (ni.eq.0) then
      write(stderr,*) 'Syntax error in statement'
      write(stderr,*) line(1:nl)
      return
    endif
    if (line(ik:ni-1).ne.'OPEN') then
      return
    endif
    !
    ! May be OPEN(I,J) = something
    level = 1
    ik = ni+1
    !
    ! Find closing parentheses
    do while (level.ne.0)
      if (ik.gt.nl) then
        write(stderr,*) 'OPEN : Unbalanced parentheses'
        write(stderr,*) line(1:nl)
        return
      endif
      if (line(ik:ik).eq.'(') then
        level = level+1
      elseif (line(ik:ik).eq.')') then
        level = level-1
      endif
      ik = ik+1
    enddo
    !
    ! Search for a possible = sign after it
    do i=ik,nl
      if (line(i:i).eq.'=') return
    enddo
    akey = .true.
    return
  !
  ! TYPE declaration
  elseif (key.eq.'TYPE') then
    akey = .false.
    do i=ik+4,nl
      if (line(i:i).eq.'*') return
      if (ichar(line(i:i)).ge.0 .and. ichar(line(i:i)).le.9) return
      if (line(i:i).eq.'(') return
      if (line(i:i).eq.'=') return
      if (line(i:i).ne.' ') then
        akey = .true.
        return
      endif
    enddo
  !
  ! BLOCK DATA routine
  elseif (key.eq.'BLOCK') then
    akey = .false.
    i = index(line,'DATA')
    if (i.eq.0) return
    if (line(ik+5:i-1).ne.' ') return
    !
    ik = i+4
    do i=ik,nl
      if (ichar(line(i:i)).ge.0 .and. ichar(line(i:i)).le.9) return
      if (line(i:i).eq.'(') return
      if (line(i:i).eq.'=') return
      if (line(i:i).ne.' ') then
        akey = .true.
        return
      endif
    enddo
  endif
end
!
function lexpr(line,nl)
  logical string,lexpr,begin
  integer nl,i
  character*(*) line
  character*1 quote, lp,ln
  data quote /''''/
  !
  string = .false.
  begin = .true.
  do i=1,nl
    if (begin) then
      if (line(i:i).eq.'(') then
        begin = .false.
      elseif (line(i:i).ne.' ') then
        lexpr = .false.
        return
      endif
    else
      if (string) then
        if (line(i:i).eq.quote) string = .false.
      elseif (line(i:i).eq.'=') then
        lp = line(i-1:i-1)
        ln = line(i+1:i+1)
        if (lp.ne.'<' .and. lp.ne.'/' .and. lp.ne.'=' .and.  &
            lp.ne.'>' .and. ln.ne.'=') then
          lexpr = .false.
          return
        endif
      elseif (line(i:i).eq.quote) then
        string = .true.
      endif
    endif
  enddo
  lexpr = .true.
end
!
subroutine load_processor
  use processor_variables
  !
  csuite = '&'
  w_comm = 42
  pinc = 'gbl_'
  lpinc = 4
  !
  ngood = 5
  goodsys(1) = 'IEEE'
  goodsys(2) = 'LINUX'
  goodsys(3) = 'UNIX'
  goodsys(4) = 'F77'
  goodsys(5) = 'MOTIF'
  lgsys(1) = 4
  lgsys(2) = 6
  lgsys(3) = 4
  lgsys(4) = 3
  lgsys(5) = 5
end
!
subroutine set_label (label)
  character*(*) label
  logical akey
  integer mdo
  parameter (mdo=100)
  integer ilabel,alabel(mdo),jlabel,i,k,ier
  save ilabel,alabel
  ! Data
  data ilabel/0/
  ! Code
  ilabel = ilabel+1
  read(label,*) alabel(ilabel)
  return
  !
  entry islabel(label,akey)
  read(label,*,iostat=ier) jlabel  !
  akey = .false.               !
  if (ier.ne.0) return         !
  do i=1,ilabel
    if (alabel(i).eq.jlabel) then
      akey = .true.
      do k=i+1,ilabel
        alabel(k-1) = alabel(k)
      enddo
      ilabel = ilabel-1
      return
    endif
  enddo
  akey = .false.
end
!
subroutine translate (code,lcode)
  use processor_variables
  character*(*) code
  integer lcode
  !
  character*1 quote
  character*80 chain
  integer i,j,l,lenc
  data quote /''''/
  !
  ! Check for commands that need special processing:
  ! DO ENDDO
  ! INTEGER*4, REAL*8, BYTE
  i = 1
  ! INCLUDE: expand file name
  if (code(i:i+6).eq.'INCLUDE') then
    ! Opening quote:
    i = i+index(code(i:),quote)-1
    ! Handle INC:
    l = index(code(i+1:),':')
    if (l.eq.0) then
      l = index(code(i+1:),'gbl_')
      if (l.ne.0) l = l+3
    endif
    if (l.ne.0) i=i+l
    ! Closing quote:
    j = index(code(i+1:),quote)
    if (j.eq.0) j = lcode+1
    j = i+j-1
    !
    ! Force lower case for include file name. Not necessarily a good idea in
    ! the long term, but usefull for conversion of old VMS code.
    call sic_lower (code(i+1:j))
    if (l.ne.0) then
      chain = pinc(1:lpinc)//code(i+1:j)
    else
      chain = code(i+1:j)
    endif
    if (index(chain,'$').ne.0) then
      ! write(stderr,*) 'Warning, system Include file '
      ! write(stderr,*) chain(1:lenc(chain))
    endif
    code = 'INCLUDE '//quote//chain(1:lenc(chain))//quote
    lcode = lenc(code)
    !
    ! ADDRESS Tag
  elseif (code(i:i+14).eq.'INTEGER(KIND=4)') then
    if (laddr.ne.0) then
      chain = '      '//address(1:laddr)//code(i+15:lcode)
      lcode = lcode+laddr-15
      code = chain(1:lcode)
    endif
    !
    ! ADDRESS Tag
  elseif (code(i:i+10).eq.'INTEGER*(4)') then
    if (laddr.ne.0) then
      chain = '      '//address(1:laddr)//code(i+11:lcode)
      lcode = lcode+laddr-11
      code = chain(1:lcode)
    endif
    !
    ! BYTE declarations
  elseif (do_byte) then
    if (code(i:i+3).eq.'BYTE') then
      chain = '      '//byte(1:lbyte)//code(i+4:lcode)
      lcode = lcode+lbyte-4
      code = chain(1:lcode)
    endif
  elseif (do_declar) then
    ! Non standard
    if (code(i:i+9).eq.'INTEGER*4 ') then
      chain = '      INTEGER '//code(i+10:lcode)
      lcode = lcode-2
      code = chain(1:lcode)
    elseif (code(i:i+6).eq.'REAL*4 ') then
      chain = '      REAL '//code(i+7:lcode)
      lcode = lcode-2
      code = chain(1:lcode)
    elseif (code(i:i+6).eq.'REAL*8 ') then
      chain = '      DOUBLEPRECISION '//code(i+7:lcode)
      lcode = lcode+9
      code = chain(1:lcode)
    endif
  endif
end
!
function lenc(c)
  !----------------------------------------------------------------------
  ! SIC	External routine : Integer function
  !
  !	Returns the location of the last SIGNIFICANT character in a
  !       string. Control characters and spaces are non significant...
  ! Arguments :
  !	C	C*(*)	Character string			Input
  !----------------------------------------------------------------------
  character*(*) c
  integer lenc
  integer i,lc
  !
  lc = len(c)
  do i=lc,1,-1
    if (c(i:i).gt.' ') then
      lenc = i
      return
    endif
  enddo
  lenc = 0
end
!
subroutine sic_upper(c)
  !----------------------------------------------------------------------
  ! SIC	External routine.
  !
  !	Converts a character string to uppercase.
  !	Slow if called frequently to convert a single character.
  ! Arguments :
  !	C	C*(*)	Character string			Input/Output
  !----------------------------------------------------------------------
  character *(*) c
  integer i,ic,lc
  !
  lc = len(c)
  do i=1,lc
    if (c(i:i).ge.'a' .and. c(i:i).le.'z') then
      ic=ichar(c(i:i))+ichar('A')-ichar('a')
      c(i:i)=char(ic)
    endif
  enddo
end
!
subroutine sic_lower(c)
  !----------------------------------------------------------------------
  ! SIC	External routine.
  !
  !	Converts a character string to LOWER CASE.
  !	Slow if called frequently to convert a single character.
  ! Arguments :
  !	C	C*(*)	Character string		Input/Output
  !----------------------------------------------------------------------
  character *(*) c
  integer i,ic,lc
  !
  lc = len(c)
  do i=1,lc
    if (c(i:i).ge.'A' .and. c(i:i).le.'Z') then
      ic=ichar(c(i:i))+ichar('a')-ichar('A')
      c(i:i)=char(ic)
    endif
  enddo
end
!
subroutine sic_white(c,n)
  !----------------------------------------------------------------------
  ! SIC	External routine
  !
  !	Character strings "abcd... " are not modified.
  !	Convert to upper case all characters.
  ! Arguments :
  !	C	C*(*)	Character string to be formatted	Input/Output
  !	N	I	Length of C				Input/Output
  !----------------------------------------------------------------------
  character*(*) c
  integer n
  !
  integer i,ic
  logical chaine
  character string*1
  save chaine, string
  data chaine/.false./
  data string/' '/
  !
  if (n.eq.0) return
  !
  do i=1,n
    !
    ! Skip character strings
    if (.not.chaine) then
      if (c(i:i).eq.'"') then
        chaine = .true.
        string = '"'
      elseif  (c(i:i).eq.'''') then
        chaine = .true.
        string = ''''
      else
        !
        ! Convert to lower case
        if (c(i:i).ge.'A' .and. c(i:i).le.'Z') then
          ic=ichar(c(i:i))+ichar('a')-ichar('A')
          c(i:i)=char(ic)
        endif
      endif
    else
      if (c(i:i).eq.string) chaine=.false.
    endif
  enddo
end
!
function lsign(chain,length)
  integer lsign, length
  character*(*) chain
  integer i
  !
  lsign = 0
  do i=1,length
    if (chain(i:i).ne.' ') then
      lsign = i
      return
    endif
  enddo
end
