PROGRAM nr_elf90
! Attempts to converts Numerical Recipes Fortran 90 code to make it compatible
! with the ELF90 compiler.   The principal remaining problems after conversion
! are:
! 1. SAVE statements will need to be replaced, perhaps by adding extra
!    arguments to routines.
! 2. Some functions have more than one returned result.   These may have
!    to be changed into subroutines.
! 3. Some explicit declarations will have to be changed to assumed array
!    dimensions, e.g. change DIMENSION(4,4) to DIMENSION(:,:).

! The conversions performed are as follows:

! Tabs are replaced with spaces

! Functions are converted from e.g. REAL FUNCTION f(x) to
!     FUNCTION f(x) RESULT(fn_val)

! All occurrences of the function name within the program unit are changed
! to fn_val.

! A RETURN statement is added at the end of each function or subroutine.

! If there are multiple USE statements on a line separated by semi-colons,
! the line is broken.

! In MODULE's, an IMPLICIT NONE statement is added after the last USE, if
! there is not one already.

! ELF90 does not support SAVE statements; if they are found, a warning is given.

! An unnecessary test for lines containing only an END statement has been
! added to prevent the program hanging with non-NR code.

! ELF90 requires a double colon (::) after TYPE; this is added.

! INTENT(INOUT) is changed to INTENT(IN OUT).

! If a function or subroutine has no arguments, `()' is added.   This is also
! done for CALL statements.

! A RETURN is inserted before CONTAINS in subroutines and functions.

! WHERE statements are converted into WHERE constructs.

! Programmer: Alan Miller (Alan.Miller @ mel.dms.csiro.au)
!             WWW-page: http://www.mel.dms.csiro.au/~alan
!             Fax: (+61) 3-9545-8080
! Latest revision - 14 November 1996

! This is public domain software.   It may be used and distributed freely AS IS.
! If you make changes to the code, add comments giving your name and indicating
! what changes have been made.
! No responsibility for errors in the converted code is accepted by the author.

IMPLICIT NONE

TYPE :: code
  CHARACTER (LEN=140)  :: text
  TYPE (code), POINTER :: next
END TYPE code

CHARACTER (LEN=40)     :: infile, outfile
CHARACTER (LEN=140)    :: temp_text
CHARACTER (LEN=4)      :: unit_type
CHARACTER (LEN=32)     :: unit_name
CHARACTER (LEN=9)      :: delimiters = ' =+-*/,()'
CHARACTER (LEN=8)      :: date
CHARACTER (LEN=10)     :: time
CHARACTER (LEN=1)      :: tab
TYPE (code), POINTER   :: head, current, tail, new_line, last_line
INTEGER                :: pos, last, iostatus, count, len_name, length, depth
LOGICAL                :: SAVE_msg, imp_none_needed, ret_needed

tab = CHAR(9)

!     Open the Fortran 90 file
!     Open a file for the output with extension `elf'
DO
  WRITE(*, *)'Enter name of Fortran source file: '
  READ(*, '(a)') infile
  IF (INDEX(infile, '.') == 0) THEN
    last = LEN_TRIM(infile)
    infile(last+1:last+4) = '.f90'
  END IF
  OPEN(8, file=infile, status='old')

  pos = INDEX(infile, '.')
  outfile = infile(1:pos) // 'elf'
  OPEN(9, file=outfile)

  !     Set up a linked list containing the lines of code

  NULLIFY(head, tail)
  ALLOCATE(head)
  tail => head
  READ(8, '(a)') head % text
  IF (head % text(1:1) == tab) head % text = head % text(2:)
  count = 1

  DO
    ALLOCATE(current)
    READ(8, '(a)', IOSTAT=iostatus) current % text
    IF (iostatus /= 0) EXIT
    count = count + 1
    DO
      pos = INDEX(current % text, tab)
      IF (pos > 0) THEN
        current % text = current % text(:pos-1) // '   ' // current % text(pos+1:)
      ELSE
        EXIT
      END IF
    END DO
    NULLIFY(current % next)
    tail % next => current
    tail => current
  END DO

  WRITE(*, *)'File: ', infile, ' No. of lines read =', count

  current => head
  SAVE_msg = .FALSE.

  DO
  !     Find first non-comment or blank line
    DO
      temp_text = ADJUSTL(current % text)
      IF (temp_text(1:1) /= '!' .AND. LEN_TRIM(temp_text) > 0) EXIT
      current => current % next
      IF (.NOT. ASSOCIATED(current)) EXIT
    END DO
    IF (.NOT. ASSOCIATED(current)) EXIT
    imp_none_needed = .FALSE.

  !     Find whether program unit is a MODULE, SUBROUTINE, INTERFACE or FUNCTION

    IF (INDEX(temp_text, 'SUBROUTINE') > 0) THEN
      unit_type = 'SRTN'
      ret_needed = .TRUE.
    ELSE IF (INDEX(temp_text, 'FUNCTION') > 0) THEN
      unit_type = 'FUNC'
      ret_needed = .TRUE.
    ELSE IF (INDEX(temp_text, 'INTERFACE') > 0) THEN
      unit_type = 'INTF'
      ret_needed = .FALSE.
    ELSE
      unit_type = 'MODL'
      imp_none_needed = .TRUE.
      ret_needed = .FALSE.
    END IF

  !     Get the name of the program unit

    pos = INDEX(temp_text, ' ') + 1
    last = INDEX(temp_text, '(') - 1
    IF (last < 0) last = LEN_TRIM(temp_text)
    unit_name = temp_text(pos:last)
    len_name = last + 1 - pos
    CALL convert(unit_type, unit_name, len_name)

    IF (.NOT. ASSOCIATED(current)) EXIT
    current => current % next
    IF (.NOT. ASSOCIATED(current)) EXIT
  END DO

  !--------------------------------------------------------------------------
  !     Output the new file

  current => head
  WRITE(9, '(a)') current % text(1:LEN_TRIM(current % text))
  current => current % next
  CALL DATE_AND_TIME(date, time)
  WRITE(9, '("! Code converted using NR_ELF90 by Alan Miller")')
  WRITE(9, '("! Date: ", a4, "-", a2, "-", a2, "  Time: ", a2, ":", a2,  &
        &    ":", a2)') date(1:4), date(5:6), date(7:8), time(1:2),      &
             time(3:4), time(5:6)

  DO
    IF (.NOT. ASSOCIATED(current)) EXIT
    WRITE(9, '(a)') current % text(1:LEN_TRIM(current % text))
    current => current % next
  END DO

  CLOSE (8)
  CLOSE (9)
END DO

STOP

!--------------------------------------------------------------------------

CONTAINS

!--------------------------------------------------------------------------

RECURSIVE SUBROUTINE convert(unit_type, unit_name, len_name)
IMPLICIT NONE

CHARACTER (LEN=4), INTENT(IN)      :: unit_type
CHARACTER (LEN=32), INTENT(IN OUT) :: unit_name
INTEGER, INTENT(IN)                :: len_name

!     Local variables

CHARACTER (LEN=50)     :: terminator
CHARACTER (LEN=4)      :: new_type
CHARACTER (LEN=32)     :: new_name
INTEGER                :: new_length, i, nbrackets

!     If the program unit is a function, change its form to:
!     FUNCTION unit_name(arguments) RESULT(fn_val)

IF (unit_type == 'FUNC') THEN
  IF (INDEX(current % text, 'RESULT') == 0) THEN
    current % text = current % text(1:LEN_TRIM(current % text)) //   &
                   ' RESULT(fn_val)'
  ELSE
    unit_name = '***'
  END IF
END IF

!     Add () if a function or subroutine has no arguments

IF (unit_type == 'FUNC' .OR. unit_type == 'SRTN') THEN
  IF (INDEX(current % text, '(') == 0) THEN
    length = LEN_TRIM(current % text)
    current % text(length+1:length+2) = '()'
  END IF
END IF

!     Form the terminator for this program unit

IF (unit_type == 'INTF') THEN
  terminator = 'INTERFACE'
ELSE
  pos = INDEX(current % text, 'RECURSIVE')
  IF (pos > 0) THEN
    temp_text = current % text(:pos-1) // current % text(pos+10:)
  ELSE
    temp_text = current % text
  END IF
  pos = INDEX(temp_text, '(') - 1
  IF (pos <= 0) pos = LEN_TRIM(temp_text)
  terminator = ADJUSTL(temp_text(:pos))
END IF

DO
  last_line => current
  current => current % next
  IF (current % text(1:1) == '!') CYCLE            ! Skip comments
  IF (LEN_TRIM(current % text) == 0) CYCLE         ! Skip blank lines
  IF (INDEX(current % text, 'END ') > 0) THEN      ! End of program unit reached
    IF (INDEX(current % text, terminator) > 0) THEN
!     Add RETURN at the end of functions or subroutines, except for CONTAINed
!     functions or subroutines.
      IF (INDEX(last_line % text, ' END ') /= 0) THEN
        IF (INDEX(last_line % text, 'FUNCTION') /= 0 .OR.   &
            INDEX(last_line % text, 'SUBROUTINE') /= 0) ret_needed = .FALSE.
      END IF
      IF (ret_needed) THEN
        ALLOCATE(new_line)
        last_line % next => new_line
        CALL calc_indent()
        new_line % text = temp_text(1:depth) // 'RETURN'
        new_line % next => current
        last_line => new_line
      END IF
      RETURN
    END IF
  END IF

  temp_text = ADJUSTL(current % text)            ! Unnecessary test for a line
  IF (LEN_TRIM(temp_text) == 3) THEN             ! containing only `END'
    IF (temp_text(1:3) == 'END' .OR. temp_text(1:3) == 'end' .OR.   &
        temp_text(1:3) == 'End') THEN
      current % text = terminator
!     Add RETURN at the end of functions or subroutines
      IF (INDEX(last_line % text, ' END ') /= 0) THEN
        IF (INDEX(last_line % text, 'FUNCTION') /= 0 .OR.   &
            INDEX(last_line % text, 'SUBROUTINE') /= 0) ret_needed = .FALSE.
      END IF
      IF (ret_needed) THEN
        ALLOCATE(new_line)
        last_line % next => new_line
        CALL calc_indent()
        new_line % text = temp_text(1:depth) // 'RETURN'
        new_line % next => current
        last_line => new_line
      END IF
      RETURN
    END IF
  END IF

  IF (INDEX(current % text, 'END ') == 0) THEN
    pos = INDEX(current % text, 'FUNCTION')
    IF (pos > 0) THEN
      new_type = 'FUNC'
    ELSE
      pos = INDEX(current % text, 'SUBROUTINE')
      IF (pos > 0) THEN
        new_type = 'SRTN'
      ELSE
        pos = INDEX(current % text, 'INTERFACE')
        IF (pos > 0) new_type = 'INTF'
      END IF
    END IF

    IF (pos > 0) THEN
                                                 ! Convert inner program unit
      last = pos + INDEX(current % text(pos:), '(') - 2
      pos = pos + INDEX(current % text(pos:), ' ')
      new_name = current % text(pos:last)
      new_length = last + 1 - pos
      IF (new_type == 'FUNC' .OR. new_type == 'SRTN') THEN
        imp_none_needed = .TRUE.
        IF (unit_type == 'INTF') THEN
          ret_needed = .FALSE.
        ELSE
          ret_needed = .TRUE.
        END IF
      ELSE
        imp_none_needed = .FALSE.
        ret_needed = .FALSE.
      END IF
      CALL convert(new_type, new_name, new_length)
      IF (unit_type == 'MODL') THEN
        ret_needed = .FALSE.
      ELSE
        ret_needed = .TRUE.
      END IF
      CYCLE
    END IF
  END IF

  IF (INDEX(current % text, 'USE ') > 0) THEN
                                                 ! Look for semi-colon after USE
                                                 ! If found, break the line
    pos = INDEX(current % text, ';')
    IF (pos > 0) THEN
      ALLOCATE(new_line)
      length = LEN_TRIM(current % text)
      CALL calc_indent()
      IF (depth > 0) THEN
        new_line % text = temp_text(1:depth) // ADJUSTL(current % text(pos+1:length))
      ELSE
        new_line % text = ADJUSTL(current % text(pos+1:length))
      END IF
      current % text(pos:) = ' '
      new_line % next => current % next
      current % next => new_line
    END IF

  ELSE                                           ! Insert IMPLICIT NONE
    IF (imp_none_needed) THEN
      IF (INDEX(current % text, 'IMPLICIT NONE') == 0) THEN
        IF (INDEX(last_line % text, '&') == 0) THEN
          ALLOCATE(new_line)
          CALL calc_indent()
          new_line % text = temp_text(1:depth) // 'IMPLICIT NONE'
          imp_none_needed = .FALSE.
          last_line % next => new_line
          new_line % next => current
        END IF
      ELSE
        imp_none_needed = .FALSE.
      END IF
    END IF
  END IF

  IF (unit_type == 'FUNC') THEN
                                         ! Change function name
    last = 1
    DO
      length = LEN_TRIM(current % text)
      pos = INDEX(current % text(last:length), unit_name(:len_name))
      IF (pos > 0) THEN
        pos = pos + last - 1
                                           ! Check that there are delimiters
                                           ! at each end of name
        IF (pos == 1 .OR. SCAN(current % text(pos-1:pos-1), delimiters) > 0) THEN
          IF (SCAN(current % text(pos+len_name:pos+len_name), delimiters) > 0) THEN
            current % text = current % text(1:pos-1) // 'fn_val' //   &
                             current % text(pos+len_name:length)
          END IF
        END IF
        last = pos + len_name
      ELSE
        EXIT
      END IF
    END DO
  END IF
                                       ! Cannot handle SAVE statements
                                       ! Issue warning message
  pos = INDEX(current % text, 'SAVE')
  IF (pos > 0 .AND. .NOT. SAVE_msg) THEN
                                       ! Check that there are delimiters
                                       ! at each end of name
    IF (pos == 1 .OR. SCAN(current % text(pos-1:pos-1), delimiters) > 0) THEN
      IF (SCAN(current % text(pos+4:pos+4), delimiters) > 0) THEN
        WRITE(*, *) 'SAVE found in file:', infile
        WRITE(*, *) 'ELF90 does not allow SAVE statements'
        SAVE_msg = .TRUE.
      END IF
    END IF
  END IF

  temp_text = ADJUSTL(current % text)            ! Insert :: after TYPE
  IF (temp_text(1:4) == 'TYPE') THEN
    IF (INDEX(temp_text, '::') == 0) THEN
      pos = INDEX(current % text, 'TYPE')
      current % text = current % text(:pos+3) // ' ::' // current % text(pos+4:)
    END IF
  END IF

  pos = INDEX(current % text, 'INOUT')           ! Change INOUT to IN OUT
  IF (pos > 0) THEN
    current % text = current % text(:pos+1) // ' ' // current % text(pos+2:)
  END IF

  IF (INDEX(current % text, 'call ') /= 0) THEN  ! Insert () if a subroutine
    IF (INDEX(current % text, '(') == 0) THEN    ! has no arguments
      length = LEN_TRIM(current % text)
      current % text(length+1:length+2) = '()'
    END IF
  END IF

                                                 ! Insert RETURN before CONTAINS
  IF (INDEX(current % text, 'CONTAINS') /= 0) THEN
    IF (unit_type == 'SRTN' .OR. unit_type == 'FUNC') THEN
      ALLOCATE(new_line)
      last_line % next => new_line
      CALL calc_indent()
      new_line % text = temp_text(1:depth) // 'RETURN'
      new_line % next => current
      last_line => new_line
    END IF
  END IF

!     Convert WHERE statements to WHERE constructs

  pos = INDEX(current % text, 'where')
  IF (pos > 0) THEN                              ! Find closing bracket of
    length = LEN_TRIM(current % text)            ! the condition
    nbrackets = 0
    DO i = pos+5, length
      IF (current % text(i:i) == '(') THEN
        nbrackets = nbrackets + 1
      ELSE IF (current % text(i:i) == ')') THEN
        nbrackets = nbrackets - 1
        IF (nbrackets == 0) EXIT
      END IF
    END DO
    IF (i < length) THEN                         ! If nothing follows, it is
      ALLOCATE(new_line)                         ! a WHERE construct
      CALL calc_indent()
      new_line % text = temp_text(:depth+3) // current % text(i+1:length)
      current % text(i+1:) = ' '
      new_line % next => current % next
      current % next => new_line
      current => new_line
                                                 ! Skip lines ending with '&'
      DO
        pos = LEN_TRIM(current % text)
        IF (current % text(pos:pos) == '&') THEN
          current => current % next
        ELSE
          EXIT
        END IF
      END DO
      ALLOCATE(new_line)
      new_line % text = temp_text(:depth) // 'END where'
      new_line % next => current % next
      current % next => new_line
      current => new_line
    END IF
  END IF

END DO

RETURN
END SUBROUTINE convert


SUBROUTINE calc_indent()
IMPLICIT NONE

depth = 1
DO
  IF (current % text(depth:depth) == ' ') THEN
    depth = depth + 1
  ELSE
    EXIT
  END IF
END DO
depth = depth - 1
temp_text = ' '

RETURN
END SUBROUTINE calc_indent


END PROGRAM nr_elf90