! ftp://ftp.numerical.rl.ac.uk/pub/MandR/convert.f90
!
! Copyright CERN, Geneva 1991, 1997 - Copyright and any other
! appropriate legal protection of these computer programs
! and associated documentation reserved in all countries
! of the world.
! Author: Michael Metcalf (MichaelMetcalf@compuserve.com)
!
! Requires the option -qcharlen=14400 with IBM's xlf.
!
! Version 1.5. Differs from previous versions in that:
! (19/12/96)
! Code modified to be Fortran 95 and ELF
! compatible (no functional changes).
!
!***********************************************************************
! *
! *
! A program to convert FORTRAN 77 source form to Fortran 90 source *
! form. It also formats the code by indenting the bodies of DO-loops *
! and IF-blocks by ISHIFT columns. Statement keywords are *
! followed if necessary by a blank, and blanks within tokens are *
! are suppressed; this handling of blanks is optional. *
! If a CONTINUE statement terminates a single DO loop, it is *
! replaced by END DO. *
! Procedure END statements have the procedure name added, if *
! blanks are handled. *
! Statements like INTEGER*2 are converted to INTEGER(2), if blanks *
! are handled. Depending on the target processor, a further global *
! edit might be required (e.g. where 2 bytes correspond to KIND=1). *
! Typed functions and assumed-length character specifications are *
! treated similarly. The length specification *4 is removed for all *
! data types except CHARACTER, as is *8 for COMPLEX. This *
! treatment of non-standard type declarations includes any *
! non-standard IMPLICIT statements. *
! Optionally, interface blocks only may be produced; this requires *
! blanks processing to be requested. The interface blocks are *
! compatible with both the old and new source forms. *
! *
! Usage: the program reads one data record in free format from the *
! default input unit. This contains: *
! *
! name of file *
! indentation depth *
! maximum indentation level *
! whether significant blanks should be handled *
! whether interface blocks only are required *
! *
! The default values in the absence of this record are: *
! name 3 10 T F *
! To do nothing but change the source form of a file prog.f type *
! prog 0 0 F F *
! or simply *
! prog / *
! For more extensive processing type, say, *
! prog 3 10 t f *
! and for interface blocks only type *
! prog 0 0 t t *
! The input is read from prog.f, the output is written to prog.f90; *
! there should be no tabs in the input. *
! *
! Restrictions: The program does not indent FORMAT statements or *
! any statement containing a character string with an *
! embedded multiple blank. *
! The order of comment lines and Fortran statements *
! is slightly modified if there are sequences of *
! more than KKLIM (=200) comment lines. *
! If there are syntax errors, continued lines do not *
! have a trailing &. *
! When producing interface blocks, a check is required*
! that any dummy argument that is a procedure has a *
! corresponding EXTERNAL statement. Also, since no *
! COMMON blocks or PARAMETER statements are copied, *
! part of an assumed-size array declaration may be *
! missing. Similarly, parts of an assumed-length *
! character symbolic constant might be copied and have *
! to be deleted. BLOCK DATA statements are copied and *
! must be deleted. These problems would normally be *
! detected by a compiler and are trivially corrected. *
! Within a given keyword, the case must be all upper *
! or all lower, and lower case programs require *
! blank handling for correct indenting. *
! *
!***********************************************************************
!
MODULE STRUCTURE
!
!***********************************************************************
! Define maximum level of DO-loop nesting, and maximum length of *
! a Fortran statement. LEN may be reduced for *
! compilers accepting a maximum character *
! length below 2640 and this will cause any excess *
! continuation lines and all following lines to be copied unchanged. *
! KKLIM defines the length of the comment line buffer. If this *
! length is exceeded, the statement preceding the comments will *
! appear after them. *
!***********************************************************************
implicit none
public
INTEGER, PARAMETER :: NEST = 32 , LEN = 2640 , KKLIM = 200, &
KLEN = 72*KKLIM
!
INTEGER :: KNTDO , KNTIF , KNTCOM , LABEL , LENST , LABLNO, NOARG
INTEGER, DIMENSION(NEST) :: LABLDO
!
LOGICAL :: SYNERR, BLNKFL, INTFL
!
CHARACTER(LEN=LEN) :: STAMNT
CHARACTER(LEN=KLEN):: CBUF
CHARACTER(LEN=42) :: NAME
!
END MODULE STRUCTURE
MODULE DATA
implicit none
public
!
INTEGER, SAVE :: ISHIFT , MXDPTH , NIN , NOUT, TIME0
LOGICAL, SAVE :: BLANKS, INTBFL
!
END MODULE DATA
MODULE STATISTICS
implicit none
public
!
INTEGER, SAVE :: MXDO , MXIF , KARD , KNTPU
!
LOGICAL, SAVE :: SYNTAX, OVFLW, NONSTD
!
END MODULE STATISTICS
MODULE ALL_PROCEDURES
private
public :: start, program_units, terminate
CONTAINS
!***********************************************************************
SUBROUTINE ARGUMENT(ARGNAM, LENARG, STAMNT, LENST, NOARG)
implicit none
!
! To store the argument names and function name, if any, for later
! use in checking whether a specification statement is relevant to an
! interface block.
CHARACTER(LEN=*), INTENT(IN OUT), dimension(:) :: ARGNAM
CHARACTER(LEN=*), INTENT(IN) :: STAMNT
INTEGER, INTENT(OUT), dimension(:) :: LENARG
INTEGER, INTENT(IN OUT) :: NOARG
INTEGER, INTENT(IN) :: LENST
!
integer :: ind1, ind2, newind
!
! Correct length of function name
IF (NOARG == 1) LENARG(1) = LEN_TRIM(ARGNAM(1))
!
! Get any other arguments
IND1 = index(STAMNT(:LENST), '(') + 1
IF (IND1 /= 1 .AND. STAMNT(IND1:IND1) /= ')') THEN
NEWIND = index(STAMNT(IND1+1:LENST), '(')
IF (NEWIND /= 0) IND1 = NEWIND + 1 + IND1
3 IND2 = index(STAMNT(IND1:LENST), ',') - 1
IF (IND2 == -1) IND2 = index(STAMNT(IND1:LENST), ')') - 1
IND2 = IND2 + IND1 - 1
IF (STAMNT(IND1+1:IND1+1) /= '*' ) THEN
NOARG = NOARG +1
ARGNAM(NOARG) = STAMNT(IND1:IND2)
LENARG(NOARG) = IND2 - IND1 +1
END IF
IF (STAMNT(IND2+1:IND2+1) == ')') GO TO 4
IND1 = IND2 + 3
GO TO 3
END IF
4 LENARG(:NOARG) = MIN(LENARG(:NOARG), 6)
!
RETURN
END SUBROUTINE ARGUMENT
SUBROUTINE BLANK( )
!
! To suppress all blanks in the statement, and then to place
! a blank on each side of =, +, -, * and / (but not ** or //), a
! blank after each ) and , and a blank before each (.
! No changes are made within character strings or FORMAT statememts.
!
USE DATA
!
USE STATISTICS
!
USE STRUCTURE
implicit none
!
CHARACTER(LEN=LEN) :: BUFFER
integer :: l1, l2, lchar, napost, lenold
!
! Reduce length to that of significant characters
BLNKFL = .FALSE.
LENST = LEN_TRIM(STAMNT(1:LENST))
IF (.NOT.BLANKS) THEN
IF (LEN-LENST >= 2) STAMNT(LENST+1:LENST+2) = ' '
LENST = MIN(LENST+2, LEN)
GO TO 99
END IF
BLNKFL = .TRUE.
!
! Suppress blanks (add 2 to catch
! odd number of apostrophes on a line in REFORM).
LCHAR = 0
NAPOST = 0
DO L1 = 1, LENST
IF (STAMNT(L1:L1) == "'") NAPOST = 1-NAPOST
IF (NAPOST == 0 .AND. STAMNT(L1:L1) == ' ') CYCLE
LCHAR = LCHAR+1
BUFFER(LCHAR:LCHAR) = STAMNT(L1:L1)
END DO
IF (LEN-LCHAR >= 2) BUFFER(LCHAR+1:LCHAR+2) = ' '
LCHAR = MIN(LCHAR+2, LEN)
!
! Eliminate FORMATS
IF( LABEL /= 0 .AND. &
& LCHAR >= 11 .AND.(BUFFER(:7) == 'FORMAT(' .OR. &
& BUFFER(:7) == 'format(') .AND. &
& BUFFER(LCHAR-2:LCHAR-2) == ')') THEN
IF (LEN-LENST >= 2) STAMNT(LENST+1:LENST+2) = ' '
LENST = MIN(LENST+2, LEN)
GO TO 99
END IF
!
! Insert blanks
LENOLD = LENST
LENST = 0
NAPOST = 0
DO L2 = 1, LCHAR
!
! Check size of statement
IF(LENST+3 > LEN) THEN
LENST = LCHAR
STAMNT(:LENST) = BUFFER(:LENST)
OVFLW = .TRUE.
GO TO 99
END IF
!
! Whether inside character string
IF (BUFFER(L2:L2) == "'") NAPOST = 1-NAPOST
IF (NAPOST == 1) GO TO 3
!
! Add blank padding according to character
SELECT CASE (BUFFER(L2:L2))
CASE ( ')' )
STAMNT(LENST+1:LENST+2) = ') '
LENST = LENST+2
CASE ( '(' )
STAMNT(LENST+1:LENST+2) = ' ('
LENST = LENST + 2
CASE ( ',' )
STAMNT(LENST+1:LENST+2) = ', '
LENST = LENST + 2
CASE ( '=' )
STAMNT(LENST+1:LENST+3) = ' = '
LENST = LENST + 3
CASE ( '*' )
IF (BUFFER(L2-1:L2-1) /= '*' .AND. BUFFER(L2+1:L2+1) &
/= '*') THEN
STAMNT(LENST+1:LENST+3) = ' * '
LENST = LENST + 3
ELSE
GO TO 3
END IF
CASE ( '/' )
IF (BUFFER(L2-1:L2-1) /= '/' .AND. BUFFER(L2+1:L2+1) &
/= '/') THEN
STAMNT(LENST+1:LENST+3) = ' / '
LENST = LENST + 3
ELSE
GO TO 3
END IF
CASE ('+')
IF (BUFFER(L2-1:L2-1) /= 'E' .AND. &
BUFFER(L2-1:L2-1) /= 'e' .AND. &
BUFFER(L2-1:L2-1) /= 'D' .AND. &
BUFFER(L2-1:L2-1) /= 'd' .OR. &
LLT(BUFFER(L2+1:L2+1), '0') .AND. LGT(BUFFER(L2+1:L2+1), '9')&
) THEN
STAMNT(LENST+1:LENST+3) = ' + '
LENST = LENST + 3
ELSE
GO TO 3
END IF
CASE ('-')
IF (BUFFER(L2-1:L2-1) /= 'E' .AND. &
BUFFER(L2-1:L2-1) /= 'e' .AND. &
BUFFER(L2-1:L2-1) /= 'D' .AND. &
BUFFER(L2-1:L2-1) /= 'd' .OR. &
LLT(BUFFER(L2+1:L2+1), '0') .AND. LGT(BUFFER(L2+1:L2+1), '9')&
) THEN
STAMNT(LENST+1:LENST+3) = ' - '
LENST = LENST + 3
ELSE
GO TO 3
END IF
CASE DEFAULT
GO TO 3
END SELECT
CYCLE
3 STAMNT(LENST+1:LENST+1) = BUFFER(L2:L2)
LENST = LENST +1
END DO
!
! Blank out end of statement
IF (LENOLD > LENST) STAMNT(LENST+1:LENOLD) = ' '
IF (LENST < LEN .AND. MOD(LENST, 66) /= 0) &
STAMNT(LENST+1: LENST+66-MOD(LENST, 66)) = ' '
!
99 RETURN
END SUBROUTINE BLANK
SUBROUTINE IDENTIFY (IRET)
!
!***********************************************************************
! To identify statement as beginning or end of DO-loop or *
! IF-block, or as probable FORMAT. *
! Attempt to scan as few of the input characters as possible. *
!***********************************************************************
!
USE STRUCTURE
USE DATA
implicit none
!
CHARACTER(LEN=5), PARAMETER :: ENDIF='ENDIF' , THEN='NEHT)', &
THENLC='neht)'
CHARACTER(LEN=3), PARAMETER :: BIF='IF('
CHARACTER(LEN=2), PARAMETER :: DO='DO'
CHARACTER(LEN=7), PARAMETER :: FORMAT='FORMAT('
CHARACTER(LEN=4), PARAMETER :: ELSE='ELSE'
CHARACTER(LEN=5) :: INTFIL
INTEGER, INTENT(OUT) :: IRET
!
integer :: l1, l2, l3, l4, l5, l6, l7, l8, l9, l10, l11, l12, &
k1, k2, k3, k5, k6, k7, k8, lparen, kntch, napos
!
IRET = 0
!
! Check whether end of DO-loop
IF (KNTDO /= 0) THEN
IF (LABEL == LABLDO(KNTDO)) THEN
IRET = 2
GO TO 99
END IF
END IF
!
! Check whether any of remaining possibilities
DO L7 = 1 , LENST
IF (STAMNT(L7:L7) == ' ') CYCLE
IF (STAMNT(L7:L7) == 'E') THEN
DO L11 = L7+1 , LENST
IF (STAMNT(L11:L11) == ' ') CYCLE
IF (STAMNT(L11:L11) == ENDIF(2:2)) GO TO 6
IF (STAMNT(L11:L11) == ELSE(2:2)) GO TO 3
GO TO 99
END DO
END IF
IF (STAMNT(L7:L7) == BIF(:1)) GO TO 9
IF (STAMNT(L7:L7) == DO(:1)) GO TO 15
IF (STAMNT(L7:L7) == FORMAT(:1)) GO TO 31
GO TO 99
END DO
GO TO 99
!
! Check whether ELSE or ELSEIF
3 K8 = 3
DO L12 = L11+1 , LENST
IF (STAMNT(L12:L12) == ' ') CYCLE
IF (STAMNT(L12:L12) /= ELSE(K8:K8)) GO TO 99
IF (K8 == 4) GO TO 5
K8 = K8+1
END DO
GO TO 99
5 IF (L12 >= LENST) THEN
IRET = 6
GO TO 99
END IF
IF (STAMNT(L12+1:LENST) == ' ') THEN
IRET = 6
GO TO 99
END IF
K2 = 1
IRET = 6
L7 = L12
GO TO 10
!
! Check whether end of IF-block
6 K1 = 3
DO L1 = L11+1 , LENST
IF (STAMNT(L1:L1) == ' ') CYCLE
IF (STAMNT(L1:L1) /= ENDIF(K1:K1)) GO TO 99
IF (K1 == 5) EXIT
K1 = K1+1
END DO
IF (L1 >= LENST) THEN
IRET = 4
GO TO 99
END IF
IF (STAMNT(L1+1:LENST) == ' ') IRET = 4
GO TO 99
!
! Check whether beginning of IF-block
9 K2 = 2
IRET = 3
10 DO L2 = L7+1 , LENST
IF (STAMNT(L2:L2) == ' ') CYCLE
IF (STAMNT(L2:L2) /= BIF(K2:K2)) THEN
IRET = 0
GO TO 99
END IF
IF (K2 == 3) GO TO 12
K2 = K2+1
END DO
IRET = 0
GO TO 99
!
! Backward search for )THEN at end of IF statement (to save
! scanning the condition).
12 K3 = 1
DO L3 = LENST , L2+1 , -1
IF (STAMNT(L3:L3) == ' ') CYCLE
IF (STAMNT(L3:L3) /= THEN(K3:K3) .AND. &
STAMNT(L3:L3) /= THENLC(K3:K3)) THEN
IRET = 0
GO TO 99
END IF
IF (K3 == 5) GO TO 99
K3 = K3+1
END DO
IRET = 0
GO TO 99
!
! Check whether beginning of DO-loop
15 DO L4 = L7+1 , LENST
IF (STAMNT(L4:L4) == ' ') CYCLE
IF (STAMNT(L4:L4) == DO(2:2)) GO TO 17
GO TO 99
END DO
GO TO 99
!
! Have DO - check label
17 K5 = 0
INTFIL = ' '
DO L5 = L4+1 , LENST
IF (STAMNT(L5:L5) == ' ') CYCLE
IF (LLT(STAMNT(L5:L5) , '0') .OR. LGT(STAMNT(L5:L5) , '9')) &
EXIT
K5 = K5+1
IF (K5 > 5) GO TO 20
INTFIL(K5:K5) = STAMNT(L5:L5)
END DO
IF (K5 == 0) GO TO 99
20 READ (INTFIL , '(BN , I5)') LABLNO
IF (LABLNO == 0) GO TO 99
!
! Have label - check comma
DO L8 = L5, LENST
IF (STAMNT(L8:L8) == ' ') CYCLE
IF (STAMNT(L8:L8) == ',') EXIT
GO TO 23
END DO
IRET = 1
GO TO 99
!
! Have a DO and label with no comma.
! Check for variable whose first of maximum of six
! characters is alphabetic, followed by an equals sign,
! followed by a character string containing a comma which is
! not enclosed in parentheses.
23 K6 = 0
DO L9 = L8 , LENST
IF (STAMNT(L9:L9) == ' ') CYCLE
IF (K6 == 0) THEN
IF ((LLT(STAMNT(L9:L9), 'A') .OR. LGT(STAMNT(L9:L9), 'Z')) &
.AND.(LLT(STAMNT(L9:L9), 'a') .OR. LGT(STAMNT(L9:L9), 'z')))&
GO TO 99
K6 = 1
ELSE IF (LGE(STAMNT(L9:L9) , 'A') .AND. LLE(STAMNT(L9:L9),'Z')&
.OR. LGE(STAMNT(L9:L9) , 'a') .AND. LLE(STAMNT(L9:L9) ,'z')&
.OR. LGE(STAMNT(L9:L9) , '0') .AND. LLE(STAMNT(L9:L9) , '9')) &
THEN
K6 = K6+1
IF (K6 == 6) GO TO 26
ELSE
IF (K6 == 0) GO TO 99
GO TO 25
END IF
END DO
GO TO 99
!
! Expect an equals sign
25 L9=L9-1
26 DO L10 = L9+1 , LENST
IF (STAMNT(L10:L10) == ' ') CYCLE
IF (STAMNT(L10:L10) == '=') GO TO 28
GO TO 99
END DO
GO TO 99
!
! Search for bare comma
28 LPAREN = 0
KNTCH = 0
NAPOS = 0
DO L6 = L10+1 , LENST
IF (STAMNT(L6:L6) == ' ') CYCLE
IF (STAMNT(L6:L6) == "'") NAPOS = 1 - NAPOS
IF (NAPOS == 1) CYCLE
IF (STAMNT(L6:L6) == ',') THEN
IF (KNTCH /= 0) THEN
IF (LPAREN == 0) GO TO 30
CYCLE
ELSE
GO TO 99
END IF
ELSE IF (STAMNT(L6:L6) == '(') THEN
LPAREN = LPAREN+1
ELSE IF (STAMNT(L6:L6) == ')') THEN
LPAREN = LPAREN-1
END IF
KNTCH = 1
END DO
GO TO 99
30 IRET = 1
!
! Insert blank after label
IF (.NOT.BLANKS .OR. LENST >= LEN) GO TO 99
DO L10 = LENST, L5, -1
STAMNT(L10+1:L10+1) = STAMNT(L10:L10)
END DO
STAMNT(L5:L5) = ' '
LENST = LENST + 1
GO TO 99
!
! Identify FORMAT statement
31 IF (LABEL == 0) GO TO 99
K7 = 2
DO L11 = L7+1 , LENST
IF (STAMNT(L11:L11) == ' ') CYCLE
IF (STAMNT(L11:L11) /= FORMAT(K7:K7)) GO TO 99
IF (K7 == 7) GO TO 33
K7 = K7+1
END DO
GO TO 99
33 IRET = 5
!
99 RETURN
END SUBROUTINE IDENTIFY
SUBROUTINE KEYWORD(ASSIGN, SKIP)
!
! To check whether those initial keywords of the statement which
! require it are followed by a blank, to add one if necessary, and
! to suppress any embedded blanks.
!
USE STATISTICS
!
USE STRUCTURE
implicit none
!
LOGICAL, INTENT(OUT) :: ASSIGN, SKIP
!
INTEGER, PARAMETER :: NKEY = 42, MAXLEN = 15
CHARACTER(LEN=MAXLEN) :: BEGIN
CHARACTER(LEN=LEN) :: BUFFER
CHARACTER(LEN=3) :: THREE
CHARACTER(LEN=32) :: NAMEOF
CHARACTER(LEN=6), SAVE :: ARGNAM(445)
LOGICAL :: IFASS
INTEGER, SAVE :: LENARG(445)
!
CHARACTER(LEN=MAXLEN), PARAMETER, dimension(nkey) :: KEYS = (/ &
'ASSIGN ', 'BACKSPACE ', 'BLOCKDATA ', &
'CALL ', 'CHARACTER ', 'CLOSE ', &
'COMMON ', 'COMPLEX ', 'CONTINUE ', &
'DATA ', 'DIMENSION ', 'DOUBLEPRECISION', &
'DO ', 'ELSEIF ', 'ELSE ', &
'ENDFILE ', 'ENDIF ', 'ENTRY ', &
'EXTERNAL ', 'EQUIVALENCE ', 'FORMAT ', &
'FUNCTION ', 'GOTO ', 'IF ', &
'IMPLICIT ', 'INQUIRE ', 'INTEGER ', &
'INTRINSIC ', 'LOGICAL ', 'OPEN ', &
'PARAMETER ', 'PAUSE ', 'PRINT ', &
'PROGRAM ', 'READ ', 'REAL ', &
'RETURN ', 'REWIND ', 'SAVE ', &
'STOP ', 'SUBROUTINE ', 'WRITE '/)
INTEGER, PARAMETER, dimension(nkey) :: LK = &
(/6, 9, 9, 4, &
9, 5, 6, 7, 8, 4, &
9,15, 2, 6, 4, &
7, 5, 5, 8,11, &
6, 8, 4, 2, 8, 7, &
7, 9, 7, 4, 9, &
5, 5, 7, 4, 4, 6, &
6, 4, 4,10, 5 /)
LOGICAL, PARAMETER, dimension(nkey) :: BLANK = &
(/.TRUE., .TRUE., .TRUE., .TRUE., &
.TRUE., .FALSE., .TRUE., .TRUE., .FALSE., .TRUE., &
.TRUE., .TRUE., .TRUE., .FALSE., .FALSE., &
.TRUE., .FALSE., .TRUE., .TRUE., .FALSE., &
.FALSE., .TRUE., .TRUE., .FALSE., .TRUE., .FALSE., &
.TRUE., .TRUE., .TRUE., .FALSE., .TRUE., &
.TRUE., .TRUE., .TRUE., .TRUE., .TRUE., .TRUE., &
.TRUE., .TRUE., .TRUE., .TRUE., .FALSE./)
LOGICAL, PARAMETER, dimension(nkey) :: FOLLOW = &
(/.TRUE., .TRUE., .FALSE., .TRUE., &
.FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., &
.FALSE., .FALSE., .FALSE., .FALSE., .FALSE., &
.TRUE., .FALSE., .FALSE., .FALSE., .FALSE., &
.FALSE., .FALSE., .TRUE., .FALSE., .FALSE., .FALSE., &
.FALSE., .FALSE., .FALSE., .FALSE., .FALSE., &
.TRUE., .TRUE., .FALSE., .TRUE., .FALSE., .TRUE., &
.TRUE., .FALSE., .TRUE., .FALSE., .FALSE./)
!
CHARACTER(LEN=MAXLEN), PARAMETER, dimension(nkey) :: KEYSLC = (/ &
'assign ', 'backspace ', 'blockdata ', &
'call ', 'character ', 'close ', &
'common ', 'complex ', 'continue ', &
'data ', 'dimension ', 'doubleprecision', &
'do ', 'elseif ', 'else ', &
'endfile ', 'endif ', 'entry ', &
'external ', 'equivalence ', 'format ', &
'function ', 'goto ', 'if ', &
'implicit ', 'inquire ', 'integer ', &
'intrinsic ', 'logical ', 'open ', &
'parameter ', 'pause ', 'print ', &
'program ', 'read ', 'real ', &
'return ', 'rewind ', 'save ', &
'stop ', 'subroutine ', 'write '/)
!
integer :: l1, l2, l3, l4, l5, l6, l7, l20, lparen, kntap, kntch,&
lc, lcc, l33, next, l8, napos, lsave, name_length
!
! Test for statement function statement or assignment statement
SKIP = INTFL
ASSIGN = .FALSE.
IFASS = .FALSE.
THREE = ' '
LPAREN = 0
KNTAP = 0
KNTCH = 0
DO L1 = 1, LENST
IF (STAMNT(L1:L1)==' ') CYCLE
IF (STAMNT(L1:L1)=='=') THEN
IF (KNTCH==0) SYNERR = .TRUE.
IF (LPAREN==0 .AND. KNTAP==0) THEN
ASSIGN = .TRUE.
GO TO 9
ELSE
EXIT
END IF
ELSE IF (STAMNT(L1:L1)=='(') THEN
LPAREN = LPAREN+1
ELSE IF (STAMNT(L1:L1)==')') THEN
LPAREN = LPAREN-1
ELSE IF (STAMNT(L1:L1)=="'") THEN
KNTAP = 1-KNTAP
END IF
KNTCH = KNTCH+1
IF (KNTCH<=3) THREE(KNTCH:KNTCH) = STAMNT(L1:L1)
END DO
!
! Suppress blanks in first 15 non-blank characters
10 BEGIN = ' '
LC = 0
DO L2 = 1, LENST
IF (STAMNT(L2:L2)==' ') CYCLE
LC = LC+1
BEGIN(LC:LC) = STAMNT(L2:L2)
IF (LC==MAXLEN) GO TO 3
END DO
L2 = L2-1
!
! Is this a keyword? Failure of this test is not fatal, in order to
! allow for non-standard syntax extensions.
3 DO L3 = 1, NKEY
IF (BEGIN(:LK(L3)) == KEYS(L3)(:LK(L3))) THEN
GO TO 5
ELSE IF (BEGIN(:LK(L3)) == KEYSLC(L3)(:LK(L3))) THEN
LCC = 0
DO L33 = 1, L2
IF (STAMNT(L33:L33) == ' ') CYCLE
LCC = LCC + 1
IF (LCC == LK(L3)) EXIT
END DO
STAMNT(:L33) = KEYS(L3)(:LK(L3))
GO TO 5
END IF
END DO
NONSTD = .TRUE.
GO TO 98
!
! Test for embedded blanks in keyword
5 IF (L2 /= LC) THEN
LC = 0
DO L4 =1, LENST
IF (STAMNT(L4:L4)==' ') CYCLE
LC = LC+1
IF (LC==LK(L3)) GO TO 7
END DO
GO TO 8
7 IF (L4==LC) GO TO 8
STAMNT(:L4) = KEYS(L3)(:LC)
GO TO 99
END IF
!
! Keyword has no blanks - is it followed by a blank if it needs one?
8 IF (.NOT.BLANK(L3)) GO TO 99
NEXT = 0
DO L8 = 1, LK(L3)
17 NEXT = NEXT+1
IF (STAMNT(NEXT:NEXT)==' ') GO TO 17
END DO
NEXT = NEXT+1
IF (STAMNT(NEXT:NEXT)==' ') GO TO 99
!
! Sometimes a delimiter may be present
IF (L3==2.OR.L3==16.OR.L3==23.OR.L3==35.OR.L3==38) THEN
IF (STAMNT(NEXT:NEXT)=='(') GO TO 99
ELSE IF (L3==5) THEN
IF (STAMNT(NEXT:NEXT)=='*') GO TO 99
ELSE IF (L3==7.OR.L3==39) THEN
IF (STAMNT(NEXT:NEXT)=='/') GO TO 99
END IF
IF (LENST==LEN) THEN
OVFLW = .TRUE.
GO TO 99
END IF
!
! Insert the blank
BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
LENST = LENST+1
STAMNT(NEXT:NEXT) = ' '
STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
BLNKFL = .TRUE.
GO TO 99
!
! Check whether, in fact, a DO-loop
9 IF (THREE(:2) /= 'DO' .AND. THREE(:2) /= 'do') GO TO 12
LPAREN = 0
NAPOS = 0
DO L5 = L1+2, LENST
IF (STAMNT(L5:L5)==' ') CYCLE
IF (STAMNT(L5:L5) == "'") NAPOS = 1 - NAPOS
IF (NAPOS == 1) CYCLE
IF (STAMNT(L5:L5)==',') THEN
IF (LPAREN==0) THEN
ASSIGN = .FALSE.
GO TO 10
END IF
ELSE IF (STAMNT(L5:L5)=='(') THEN
LPAREN = LPAREN+1
ELSE IF (STAMNT(L5:L5)==')') THEN
LPAREN = LPAREN-1
END IF
END DO
GO TO 99
!
! Check whether, in fact, a logical IF followed by an assignment
12 IF (THREE /= 'IF(' .AND. THREE /= 'if(') GO TO 99
IFASS = .TRUE.
DO L6 = L1-1, 1, -1
IF (STAMNT(L6:L6)==' ') CYCLE
IF (STAMNT(L6:L6)==')') THEN
!
! Is there a second pair of first-level parentheses
IF (index(STAMNT(:L6), ')')==0) GO TO 99
LPAREN = 1
DO L7 = L6-1, 4, -1
IF (STAMNT(L7:L7)==' ') CYCLE
IF (STAMNT(L7:L7)==')') THEN
IF (LPAREN==0) THEN
GO TO 14
ELSE
LPAREN = LPAREN+1
END IF
ELSE IF (STAMNT(L7:L7)=='(') THEN
LPAREN = LPAREN-1
END IF
END DO
GO TO 99
14 ASSIGN = .FALSE.
GO TO 10
ELSE
ASSIGN = .FALSE.
GO TO 10
END IF
END DO
!
! Test for non-executable statement keyword
99 IF (ASSIGN) GO TO 98
IF (.NOT.INTFL) GO TO 97
SKIP = L3 == 3.OR.L3 == 5.OR.L3 == 8 &
.OR.L3 == 11.OR.L3 == 12.OR.L3 == 19.OR.L3 == 22 &
.OR.L3 == 25.OR.L3 == 27.OR.L3 == 29 &
.OR.L3 == 34.OR.L3 == 36.OR.L3 == 41
SKIP = .NOT.SKIP
IF (SKIP) GO TO 98
!
! Check whether this statement refers to an argument or a function
! name
IF (L3 == 3 .OR. L3 == 22 .OR. L3 == 25 .OR. &
L3 == 34 .OR. L3 == 41) GO TO 97
IF(index(STAMNT(LK(L3)+1:LENST), 'FUNCTION')/= .0 .OR. &
index(STAMNT(LK(L3)+1:LENST), 'function') /= 0) GO TO 97
DO L20 = 1, NOARG
IF(index(STAMNT(LK(L3)+1:LENST), ARGNAM(L20)(:LENARG(L20))) &
/= 0) GO TO 97
END DO
SKIP = .TRUE.
GO TO 98
!
! Keep procedure name for END statement
97 call name_of(nameof, stamnt(lk(l3)+2:lenst), name_length)
IF(L3 == 3.OR.L3 == 22.OR.L3 == 34.OR. &
L3 == 41) NAME = KEYS(L3)(:LK(L3))//NAMEOF(:name_length)
!
! Get argument names for later use in skipping unnecessary
! specifications
21 IF (INTFL) THEN
IF (L3 == 22) THEN
ARGNAM(1) = NAME(10:15)
NOARG = 1
END IF
IF (L3 == 22 .OR. L3 == 41) &
CALL ARGUMENT(ARGNAM, LENARG, STAMNT, LENST, NOARG)
END IF
!
! Deal with awkward cases
LSAVE = L3
IF(L3 == 1.OR.L3 == 5.OR.L3 == 8.OR.L3 == 12 .OR. L3 == 13 &
.OR. L3 == 25 &
.OR.L3 == 24.AND..NOT.IFASS.OR.L3 == 27.OR.L3 == 29.OR.L3 == 36) &
CALL SPECIAL(L3, NEXT, BUFFER, NKEY, KEYS, KEYSLC, LK, FOLLOW)
!
! Was, in fact, a function
IF (INTFL.AND.L3 == 22.AND.LSAVE /= 22) THEN
SKIP = .FALSE.
GO TO 21
END IF
!
! Print procedure name
98 IF(.NOT.ASSIGN.AND.(L3 == 3.OR.L3 == 22.OR.L3 == 34.OR.L3 == 41))&
WRITE (*, '('' Starting '', A)') NAME
RETURN
END SUBROUTINE KEYWORD
subroutine NAME_OF(nameof, HEADER, name_length)
!
implicit none
! Pick out name of procedure
CHARACTER(LEN=*), INTENT(IN) :: HEADER
CHARACTER(LEN=*), INTENT(out):: nameof
integer, intent(out) :: name_length
integer :: ind, indast
!
NAMEOF = ' '
!
! Is there a left parenthesis or an asterisk?
IND = index(HEADER, '(' )
INDAST = index(HEADER, '*')
IF (IND /= 0 .AND. INDAST /= 0) IND = MIN(IND, INDAST)
IF (IND <= LEN(NAMEOF)) THEN
IF (IND == 0) THEN
NAMEOF(2:) = HEADER(:LEN(HEADER))
name_length = min(len(header)+1, len(nameof))
ELSE
NAMEOF(2:IND) = HEADER(:IND-1)
name_length = ind
END IF
END IF
RETURN
END subroutine NAME_OF
SUBROUTINE PROGRAM_UNITS( )
!
!***********************************************************************
! The principal subroutine of CONVERT processes the *
! input stream, which is assumed to contain syntactically correct *
! Fortran program units. To protect itself from bad data, failure *
! to pass a primitive syntax check will cause the program to copy *
! the input stream to the output unit unchanged, until an END line is*
! encountered. *
!***********************************************************************
!
USE DATA
!
USE STATISTICS
!
USE STRUCTURE
implicit none
!
!***********************************************************************
! USER is a character which may be defined to identify lines *
! in the input stream which are to be treated as *
! comment lines ( + in this example). *
!***********************************************************************
!
CHARACTER(LEN=1) :: CONTIN
CHARACTER(LEN=3), PARAMETER :: FIN='END', FINLC='end'
CHARACTER(LEN=66) :: FIELD
CHARACTER(LEN=72) :: LINE
CHARACTER(LEN=72), PARAMETER :: BLANKV=' '
!
LOGICAL :: NEWDO , NEWIF , FORM , ELSEBL , ASSIGN
!
CHARACTER(LEN=*), PARAMETER :: USER = '+'
LOGICAL :: STAT = .FALSE. , SKIP = .FALSE.
!
integer :: l1, l5, l22, kntcon, napo, lab, l9, k1, &
irtcod, nend
!
! Start processing program units
MXDO = 0
MXIF = 0
KARD = 0
KNTPU = 0
SYNTAX = .FALSE.
SYNERR = .FALSE.
OVFLW = .FALSE.
NONSTD = .FALSE.
KNTDO = 0
KNTIF = 0
KNTCOM = 0
NAME = ' '
NOARG = 0
INTFL = INTBFL
!
! Set continuation line counter
1 KNTCON = 0
!
! Set statement length counter
LENST = 0
!
! Read one line into an internal file,
! columns 73-80 of all lines are ignored.
2 READ (NIN , '(A)' , END = 100 , ERR = 100) LINE
KARD = KARD+1
!
! Check whether a comment line and if so copy to buffer.
IF (LINE(:1) == 'C' .OR. LINE(:1) == '*' .OR. LINE(:1) == &
USER .OR. LINE == ' ' .OR. LINE(:1) == 'c' &
.OR. LINE(:1) == '!') THEN
IF (INTFL) GO TO 2
IF (LINE(:1) == 'C' .OR. LINE(:1) == '*' &
.OR. LINE(:1) == 'c') LINE(:1) = '!'
IF (KNTCOM == KKLIM) THEN
WRITE (NOUT , '(A72)') (CBUF(72*L5-71:72*L5) , L5 = 1 , &
KNTCOM) , LINE
KNTCOM = 0
ELSE IF (SYNERR .OR. .NOT.STAT) THEN
WRITE (NOUT , '(A72)') LINE
ELSE
KNTCOM = KNTCOM+1
CBUF(72*KNTCOM-71:72*KNTCOM) = LINE
END IF
GO TO 2
END IF
!
! Some form of embedded comment?
NAPO = 0
DO L22 = 2, 72
IF (LINE(L22:L22) == '''') NAPO = 1 - NAPO
IF (L22 == 6) CYCLE
IF (LINE(L22:L22) /= '!') CYCLE
IF (NAPO /= 0) CYCLE
IF (.NOT. INTFL) THEN
IF (KNTCOM < KKLIM) THEN
KNTCOM = KNTCOM +1
CBUF(72*KNTCOM-71:72*KNTCOM) = &
BLANKV(:L22-1)//LINE(L22:72)
ELSE
WRITE (NOUT, '(A)') BLANKV(:L22-1)//LINE(L22:72)
END IF
END IF
LINE(L22:72) = ' '
IF (LINE == ' ') GO TO 2
EXIT
END DO
!
! Line is some form of statement; re-read.
READ (LINE , '(BN , I5 , A1 , A66)') LAB , CONTIN , FIELD
STAT = .TRUE.
!
! Check on syntax and copy to statement buffer
3 IF (CONTIN == '0') CONTIN = ' '
IF (CONTIN /= ' ') THEN
CONTIN = '&'
IF (SYNERR) THEN
GO TO 6
ELSE IF (LENST == 0 .OR. LENST+66 > LEN .OR. LAB /= 0) THEN
SYNERR = .TRUE.
IF (LENST > 0) THEN
IF (LABEL /= 0) THEN
WRITE (NOUT , '(I5, 1X, A66:"&"/(5X, "&", A66: &
& "&"))') LABEL , &
(STAMNT(66*L9-65:66*L9) , L9 = 1 , (LENST+65)/66)
ELSE
WRITE (NOUT , '(6X, A66:"&"/(5X, "&", A66:"&" &
& ))') (STAMNT(66*L9-65:66*L9) , L9 = 1 , (LENST+65)/66)
END IF
END IF
IF (LAB /= 0) THEN
WRITE (NOUT , 1000) LAB , CONTIN , FIELD
ELSE
WRITE (NOUT , 1006) CONTIN , FIELD
END IF
GO TO 1
ELSE
KNTCON = KNTCON+1
STAMNT(LENST+1:LENST+66) = FIELD
LENST = LENST+66
GO TO 2
END IF
ELSE IF (KNTCON == 0) THEN
IF (LENST /= 0) GO TO 4
STAMNT(1:66) = FIELD
LENST = 66
LABEL = LAB
IF (SYNERR) GO TO 4
GO TO 2
END IF
IF (KNTCON > 0) GO TO 6
!
! Have a complete statement ready for processing (the last line
! read is still waiting in LINE). The statement now needs to be
! identified.
! The END statement is a special case - if found it will be copied
! and the next program unit processed.
4 K1 = 1
DO L1 = 1 , LENST
IF (STAMNT(L1:L1) == ' ') CYCLE
IF (STAMNT(L1:L1) /= FIN(K1:K1) .AND. &
STAMNT(L1:L1) /= FINLC(K1:K1)) THEN
EXIT
ELSE
K1 = K1+1
IF (K1 > 3 .AND. (L1 >= LENST .OR. STAMNT(L1+1:LENST) &
== ' ')) THEN
IF (.NOT.SYNERR) THEN
KNTPU=KNTPU+1
IF (LABEL == 0) THEN
WRITE (NOUT , 1001) FIN, NAME
ELSE
WRITE (NOUT , 1002) LABEL , FIN, NAME
END IF
END IF
!
! Set counters for new program unit
SYNTAX = SYNTAX .OR. SYNERR
KNTDO = 0
KNTIF = 0
SYNERR = .FALSE.
KNTCON = 0
LENST = 0
IF (KNTCOM /= 0) WRITE (NOUT , '(A72)') (CBUF(72*L5-71: &
72*L5) , L5 = 1 , KNTCOM)
KNTCOM = 0
NAME = ' '
NOARG = 0
GO TO 3
ELSE
IF (K1 > 3) EXIT
END IF
END IF
END DO
!
! If syntax error flag set, copy and take next statement
6 IF (SYNERR) THEN
IF (LAB /= 0) THEN
WRITE (NOUT , 1000) LAB , CONTIN , FIELD
ELSE
WRITE (NOUT , 1006) CONTIN , FIELD
END IF
LENST = 0
GO TO 2
END IF
!
! Compress blanks and insert blanks around special characters
CALL BLANK( )
!
! Handle Fortran keywords
NEWDO = .FALSE.
NEWIF = .FALSE.
FORM = .FALSE.
ELSEBL = .FALSE.
ASSIGN = .FALSE.
IF (BLANKS) CALL KEYWORD(ASSIGN, SKIP)
IF (SKIP) GO TO 16
IF (SYNERR) GO TO 6
IF (BLANKS .AND. ASSIGN .AND. LABEL == 0) GO TO 14
!
! Have a valid statement which is not an END line or assignment
! Identify statement as DO
! IF ( ) THEN
! DO terminator
! END IF
! FORMAT
! ELSE or ELSEIF
! none of these.
CALL IDENTIFY(IRTCOD)
SELECT CASE (IRTCOD)
CASE (0)
GO TO 14
!
! New DO-loop
CASE (1)
IF (KNTDO == NEST) GO TO 14
NEWDO = .TRUE.
LABLDO(KNTDO+1) = LABLNO
!
! End of DO-loop(s)
CASE (2)
NEND = 0
DO L5 = KNTDO , 1 , -1
IF (LABLDO(L5) /= LABEL) EXIT
NEND = NEND + 1
END DO
!
! Replace CONTINUE by END DO
KNTDO = KNTDO - NEND
IF (NEND == 1 .AND. LENST == 10 .AND. STAMNT(:LENST) == &
'CONTINUE ') THEN
STAMNT(:8) = 'END DO '
LENST = 6
END IF
!
! Beginning of IF-block
CASE (3)
NEWIF = .TRUE.
!
! End of IF-block
CASE (4)
KNTIF = KNTIF-1
IF (KNTIF < 0) THEN
SYNERR = .TRUE.
KNTIF = 0
END IF
!
! FORMAT statement
CASE (5)
FORM =.TRUE.
!
! Beginning of ELSE-block
CASE (6)
IF (KNTIF > 0) THEN
ELSEBL = .TRUE.
ELSE
SYNERR = .TRUE.
END IF
END SELECT
!
! Reformat statements and write
14 CALL REFORM (FORM , ELSEBL)
!
! Set variables for next statement
IF (NEWDO) KNTDO = KNTDO+1
IF (NEWIF) KNTIF = KNTIF+1
MXDO = MAX(MXDO , KNTDO)
MXIF = MAX(MXIF , KNTIF)
16 KNTCON = 0
LENST = 0
GO TO 3
!
! End of data. Last line must be an END.
100 IF (LABEL == 0) WRITE (NOUT , 1001) FIN, NAME
IF (LABEL /= 0) WRITE (NOUT , 1002) LABEL , FIN, NAME
KNTPU=KNTPU+1
IF (INTFL) WRITE (NOUT, '(6X, ''END INTERFACE'')')
!
! Note: if there is a syntax error, continued
! statements do not have a trailing &
1000 FORMAT(I5 , A1 , A)
1001 FORMAT(TR6 , A3 ,TR1, A)
1002 FORMAT(I5 , TR1 , A3 ,TR1, A)
1006 FORMAT(TR5 , A1 , A66)
!
RETURN
END SUBROUTINE PROGRAM_UNITS
SUBROUTINE REFORM (FORM , ELSEBL)
!
! Performs reformatting and output of accepted statements
!
USE DATA
!
USE STRUCTURE
implicit none
!
INTEGER, PARAMETER :: LLIMIT = LEN-(LEN/66-1)*6
CHARACTER(LEN=LEN) :: OUT
CHARACTER(LEN = 1) :: AMP
!
LOGICAL, INTENT(IN) :: FORM , ELSEBL
!
integer :: ind, ipnt, l6, l2, l3, l4, lout, idepth, kntap, kadd, &
l5, jpnt
!
! If FORMAT statement, do not indent
IF (FORM) GO TO 9
!
! Remove the blanks before commas if no character string
IF (BLNKFL .AND. INDEX(STAMNT(:LENST), "'") == 0) THEN
IPNT = 1
DO
IND = INDEX(STAMNT(IPNT:LENST), ' , ')
IF (IND == 0) EXIT
IND = IPNT + IND - 1
STAMNT(IND:IND+2) = ', '
IPNT = IND + 3
END DO
END IF
!
! Reformat indented statement and write. If reformatting causes it
! to exceed LEN characters, it will be copied unchanged.
IDEPTH = MIN(KNTDO+KNTIF , MXDPTH)
IF (IDEPTH == 0 .AND. .NOT.BLNKFL) GO TO 9
IF (ELSEBL) IDEPTH = IDEPTH-1
IPNT = 1
JPNT = 1
1 IF (MOD(IPNT , 66) == 1) THEN
IF (IPNT+65 > LEN) GO TO 9
OUT(IPNT:IPNT+65) = ' '
IPNT = IPNT+IDEPTH*ISHIFT
END IF
!
! Find first non-blank character
DO L2 = JPNT , LENST
IF (STAMNT(L2:L2) /= ' ') GO TO 3
END DO
IF (JPNT == 1) THEN
SYNERR = .TRUE.
GO TO 9
ELSE
GO TO 10
END IF
!
! Find first multiple blank (but not in a character string)
3 KNTAP = 0
DO L3 = L2, LENST-1
IF (STAMNT(L3:L3) == "'") KNTAP = 1-KNTAP
IF (STAMNT(L3:L3+1) == ' ') THEN
IF (KNTAP == 0) GO TO 5
GO TO 9
END IF
END DO
L3 = LENST
!
! Have section with no multiple blanks. This can be copied to OUT
! if there is room on the current line. Otherwise cut the
! section after the non-alphanumeric character nearest to the end of
! the line, if one exists.
! An apostrophe and period are considered to be alphanumeric
! characters, in order to hold character strings,
! and real and logical constants together;
! underscores and dollars are so treated to handle common extensions,
! and the ** and // operators and real literal constants are treated.
5 KADD = 0
IF (L3-L2 <= 66-MOD(IPNT , 66)) GO TO 8
DO L4 = 66+L2-MOD(IPNT , 66) , L2 , -1
IF (STAMNT(L4:L4) == ' ') GO TO 7
IF (LGE(STAMNT(L4:L4) , 'A') .AND. LLE(STAMNT(L4:L4) , 'Z')) &
CYCLE
IF(LGE(STAMNT(L4:L4), '0') .AND. &
LLE(STAMNT(L4:L4), '9')) CYCLE
IF (STAMNT(L4:L4) == "'" .OR. &
STAMNT(L4:L4) == '_' .OR. STAMNT(L4:L4) == '$' .OR. &
STAMNT(L4:L4) == '.') CYCLE
IF (L4 /= LENST) THEN
IF (STAMNT(L4:L4+1) == '**' .OR. &
STAMNT(L4:L4+1) == '//' ) CYCLE
IF (L4 /= L2) THEN
IF(LGE(STAMNT(L4+1:L4+1), '0') .AND. &
LLE(STAMNT(L4+1:L4+1), '9')) THEN
IF (STAMNT(L4-1:L4) == 'E+' .OR. &
STAMNT(L4-1:L4) == 'e+' .OR. &
STAMNT(L4-1:L4) == 'E-' .OR. &
STAMNT(L4-1:L4) == 'e-' .OR. &
STAMNT(L4-1:L4) == 'D+' .OR. &
STAMNT(L4-1:L4) == 'd+' .OR. &
STAMNT(L4-1:L4) == 'D-' .OR. &
STAMNT(L4-1:L4) == 'd-' ) CYCLE
END IF
END IF
END IF
IF (LGE(STAMNT(L4:L4) , 'a') .AND. LLE(STAMNT(L4:L4) , 'z')) &
CYCLE
GO TO 7
END DO
!
! No break character found
IF (BLNKFL) GO TO 9
L4 = 66-MOD(IPNT , 66)+L2
!
! Cut here
7 L3 = L4
KADD = 1
8 LOUT = IPNT+L3-L2
IF (LOUT > LEN) GO TO 9
OUT(IPNT:LOUT) = STAMNT(L2:L3)
IF (L3 == LENST) GO TO 10
!
! Set pointers for next section of statement
IPNT = LOUT+1
IF (KADD == 1 .AND. MOD(IPNT , 66) /= 1 .OR. MOD(IPNT , 66) &
>= 60) IPNT = ((IPNT+65)/66)*66+1
IF (MOD(IPNT , 66) == 0) IPNT = IPNT+1
JPNT = L3+1
IF (KADD == 0) JPNT = JPNT+1
GO TO 1
!
! Copied statement (if adding 6 cols. to initial line would cause
! total length to exceed 2640, must start it in col.1)
9 LENST = LEN_TRIM(STAMNT(:LENST))
IF (LENST > 66) THEN
AMP = '&'
ELSE
AMP = ' '
END IF
IF (LABEL /= 0) THEN
WRITE (NOUT , 1003) LABEL , STAMNT(:MIN(LENST, 66)), AMP
ELSE
IF (LENST < LEN-6) THEN
WRITE (NOUT , 1004) STAMNT(:MIN(LENST,66)), AMP
ELSE
WRITE (NOUT , '(A,A1)') STAMNT(:MIN(LENST, 66)), AMP
END IF
END IF
IF (LENST > 66) WRITE (NOUT , 1005) &
&('&', STAMNT(66*L6-65:66*L6) , L6 = 2 , (LENST+65)/66)
GO TO 11
!
! Write OUT to output unit
10 LOUT = LEN_TRIM(OUT(:LOUT))
IF (LOUT > 66) THEN
AMP = '&'
ELSE
AMP =' '
END IF
IF (LABEL /= 0) THEN
WRITE (NOUT , 1003) LABEL , OUT(:MIN(LOUT, 66)), AMP
ELSE
WRITE (NOUT , 1004) OUT(:MIN(LOUT, 66)), AMP
END IF
!
! An & is required in col. 6 if statement has more than 2412
! characters, otherwise total length including cols. 1-6 will
! exceed 2640. Also if making interface blocks, in order to be
! compatible with both old and new source forms.
IF (LOUT > 66) THEN
IF (LOUT > LLIMIT .OR. INTFL) THEN
AMP = '&'
ELSE
AMP = ' '
END IF
WRITE (NOUT , 1005) (AMP , OUT(66*L5-65:66*L5) , L5 = 2 , ( &
LOUT+65)/66)
END IF
!
! Write any comments following statement
11 IF (KNTCOM /= 0) THEN
WRITE (NOUT ,'(A72)') (CBUF(72*L5-71:72*L5) , L5 = 1 , KNTCOM)
KNTCOM = 0
END IF
!
1003 FORMAT(I5 , TR1, A, A)
1004 FORMAT(TR6, A, A)
1005 FORMAT(TR5 , A , A:'&' )
!
RETURN
END SUBROUTINE REFORM
SUBROUTINE SPECIAL(L3, NEXT, BUFFER, NKEY, KEYS, KEYSLC, &
LK, FOLLOW)
!
! Special treatment for peculiar Fortran syntax
!
USE STRUCTURE
!
USE STATISTICS
implicit none
!
INTEGER, PARAMETER :: NUMLEN = 5
!
CHARACTER(LEN=*), INTENT(OUT) :: BUFFER
INTEGER, INTENT(IN) :: NKEY
INTEGER, INTENT(IN), dimension(:) :: LK
CHARACTER(LEN=*), INTENT(IN), dimension(:) :: KEYS, KEYSLC
CHARACTER(LEN=32) :: NAMEOF
CHARACTER(LEN=NUMLEN) :: NUMBER
!
INTEGER, INTENT(IN OUT) :: L3, NEXT
LOGICAL, INTENT(IN), dimension(:) :: FOLLOW
LOGICAL :: IFASSIGN
integer :: ind, l20, istar, lparen, napos, ndigit,&
nparen, l10, ilp, isss, limit, name_length
!
IFASSIGN = .FALSE.
!
! Deal with labelled DO WHILE
IF (L3 == 13) THEN
IND = index(STAMNT(:LENST), 'WHILE')
IF (IND == 0) IND = index(STAMNT(:LENST), 'while')
IF (IND /= 0) THEN
IF(LGE(STAMNT(IND-1:IND-1), '0') .AND. &
LLE(STAMNT(IND-1:IND-1), '9')) &
STAMNT(IND:IND+5) = ' WHILE'
END IF
GO TO 99
END IF
!
! Deal with IMPLICIT with non-standard length specifiers
IF (L3 == 25) THEN
IF (index(STAMNT(:LENST), '*') /= 0) THEN
!
! first, CHARACTER*(len)
11 IND = index(STAMNT(:LENST), 'CHARACTER * (')
IF (IND == 0) IND = index(STAMNT(:LENST),'character * (')
IF (IND /= 0) THEN
STAMNT(IND+10:IND+10) = ' '
GO TO 11
END IF
!
! then, type*nn
NPAREN = 0
NAPOS = 0
DO L10 = 15, LENST
IF (STAMNT(L10:L10) == "'") THEN
NAPOS = 1 - NAPOS
ELSE IF (STAMNT(L10:L10) == '(') THEN
IF (NAPOS == 0) NPAREN = NPAREN + 1
ELSE IF (STAMNT(L10:L10) == ')') THEN
IF (NAPOS == 0) NPAREN = NPAREN - 1
ELSE IF (STAMNT(L10:L10) == '*') THEN
IF (NPAREN == 0) THEN
STAMNT(L10:L10+1) = ' ('
ILP = index(STAMNT(L10+2:LENST), '(')
IF (ILP == 0) THEN
SYNERR = .TRUE.
GO TO 99
ELSE
STAMNT(L10+ILP:L10+ILP) = ')'
END IF
IF (STAMNT(L10+1:L10+3) == '(4)') THEN
IF (STAMNT(L10-5:L10-5) /= 'C' .AND. &
STAMNT(L10-5:L10-5) /= 'c') &
STAMNT(L10+1:L10+3) = ' '
ELSE IF (STAMNT(L10-2:L10+3) == 'X (8)' .OR. &
STAMNT(L10-2:L10+3) == 'x (8)')THEN
STAMNT(L10+1:L10+3) = ' '
END IF
END IF
END IF
END DO
END IF
GO TO 99
END IF
!
! An ASSIGN label must be followed by a blank and a * specifier
! converted to (...)
IF(L3 == 1 .AND. STAMNT(:7 ) == 'ASSIGN ' .OR. &
L3 == 5 .AND. STAMNT(:11) == 'CHARACTER *' .OR. &
L3 == 8 .AND. STAMNT(:9 ) == 'COMPLEX *' .OR. &
L3 == 27.AND. STAMNT(:9 ) == 'INTEGER *' .OR. &
L3 == 29.AND. STAMNT(:9 ) == 'LOGICAL *' .OR. &
L3 == 36.AND. STAMNT(:6 ) == 'REAL *' ) THEN
IF (L3 < 8) THEN
ISSS = L3+7
ELSE IF (L3 < 30) THEN
ISSS = 10
ELSE
ISSS = 7
END IF
!
! Extract the length parameter
NDIGIT = 1
NUMBER = ' '
DO L20 = ISSS, LENST
IF(STAMNT(L20:L20) == ' ') CYCLE
NUMBER(:1) = STAMNT(L20:L20)
IF(LGE(STAMNT(L20:L20),'0') .AND. LLE(STAMNT(L20:L20),'9') &
) GO TO 21
GO TO 1
END DO
SYNERR = .TRUE.
GO TO 99
21 DO NEXT = L20+1, LENST
IF(STAMNT(NEXT:NEXT) == ' ') CYCLE
IF(LLT(STAMNT(NEXT:NEXT), '0') .OR. LGT(STAMNT(NEXT:NEXT), &
'9')) GO TO 19
NDIGIT = NDIGIT + 1
IF (NDIGIT > NUMLEN) THEN
SYNERR = .TRUE.
GO TO 99
END IF
NUMBER(NDIGIT:NDIGIT) = STAMNT(NEXT:NEXT)
END DO
SYNERR = .TRUE.
GO TO 99
END IF
GO TO 1
!
! Insert the blank or parentheses
19 IF (LENST >= LEN-1) THEN
OVFLW = .TRUE.
GO TO 99
END IF
BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
IF (L3 == 1) THEN
LENST = LENST+2
STAMNT(NEXT:NEXT+3) = ' TO '
STAMNT(NEXT+4:LENST) = BUFFER(NEXT+2:LENST-2)
ELSE
LENST = LENST+1
STAMNT(NEXT:NEXT) = ' '
STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
IF (L3 /= 5.AND. NDIGIT == 1 .AND. NUMBER(:1) == '4') THEN
STAMNT(NEXT-4:NEXT-1) = ' '
ELSE IF (L3 == 8.AND.NDIGIT == 1 .AND. NUMBER(:1) == '8') &
THEN
STAMNT(NEXT-4:NEXT-1) = ' '
ELSE
STAMNT(NEXT-3-NDIGIT:NEXT-1) = '('//NUMBER(:NDIGIT)//')'
END IF
END IF
GO TO 2
!
! Handle (*) case
1 IF(L3 == 5 .AND. STAMNT(:18) == 'CHARACTER * ( * )') THEN
NEXT = 19
STAMNT(11:11) = ' '
END IF
!
! IF statement may be followed by a keyword
2 IF (L3 == 24 ) THEN
LPAREN = 1
NAPOS = 0
DO NEXT = 5, LENST
IF (STAMNT(NEXT:NEXT) == "'") NAPOS = 1 - NAPOS
IF (NAPOS == 1) CYCLE
IF (STAMNT(NEXT:NEXT) == '(' ) LPAREN = LPAREN+1
IF (STAMNT(NEXT:NEXT) == ')' ) LPAREN = LPAREN-1
IF (LPAREN == 0) GO TO 5
END DO
GO TO 99
5 NEXT = NEXT+1
DO L3 = 1, NKEY
IF (FOLLOW(L3) .AND.(STAMNT(NEXT+1:NEXT+LK(L3)) == KEYS(L3)&
.OR. STAMNT(NEXT+1:NEXT+LK(L3)) == KEYSLC(L3)&
)) THEN
NEXT = NEXT+LK(L3)+1
IF(L3 == 1) IFASSIGN = .TRUE.
GO TO 9
END IF
END DO
ELSE
!
! Typed function
IF(STAMNT(NEXT+1:NEXT+8) == 'FUNCTION' .OR. &
STAMNT(NEXT+1:NEXT+8) == 'function') THEN
NEXT = NEXT+9
call name_of(nameof, stamnt(next:lenst), name_length)
NAME = 'FUNCTION'//NAMEOF(:name_length)
L3 = 22
!
! Deal with any *
LIMIT = index(STAMNT(:LENST), '(')
IF (LIMIT /= 0) THEN
ISTAR = index(STAMNT(:LIMIT), '*')
IF (ISTAR /= 0) THEN
NDIGIT = LIMIT - ISTAR -3
IF (NDIGIT > NUMLEN) THEN
SYNERR = .TRUE.
GO TO 99
END IF
NUMBER(:NDIGIT) = STAMNT(ISTAR+2:LIMIT-2)
STAMNT(NEXT-5+NDIGIT:LIMIT-2) = &
'FUNCTION'//NAME(10:ISTAR-NEXT+8)
STAMNT(NEXT-8:NEXT-6+NDIGIT) = &
'('//NUMBER(:NDIGIT)//') '
IF (NDIGIT == 1 .AND. NUMBER(:1) == '4') THEN
STAMNT(NEXT-8:NEXT-5) = ' '
ELSE IF (NDIGIT == 1 .AND. NUMBER(:1) == '8'.AND.&
(STAMNT(7:7) == 'X'.OR.STAMNT(7:7) == 'x')) THEN
STAMNT(NEXT-8:NEXT-5) = ' '
END IF
NEXT = NEXT + 3 + NDIGIT
END IF
ELSE
SYNERR = .TRUE.
GO TO 99
END IF
GO TO 9
END IF
END IF
GO TO 99
!
! Insert the blank
9 IF (LENST >= LEN-2) THEN
OVFLW = .TRUE.
GO TO 99
END IF
BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
LENST = LENST+1
STAMNT(NEXT:NEXT) = ' '
STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
!
! ASSIGN may follow IF
IF(.NOT.IFASSIGN) GO TO 99
NEXT = index(STAMNT(:LENST), 'TO')
IF (NEXT == 0) NEXT = index(STAMNT(:LENST), 'to')
IF(NEXT == 0) THEN
SYNERR = .TRUE.
GO TO 99
ELSE
LENST = LENST+2
STAMNT(NEXT:NEXT+3) = ' TO '
STAMNT(NEXT+4:LENST) = BUFFER(NEXT+1:LENST-3)
END IF
99 RETURN
END SUBROUTINE SPECIAL
SUBROUTINE START( )
!
! To prepare for PROGRAM_UNITS
!
USE DATA
implicit none
CHARACTER(LEN=16) :: NAME
!
! Prompt for interactive use
WRITE (*,'(" Type name of file, shift, max. indent level, T or F &
&for blank treatment,",/ " T or F for interface blocks only.")')
WRITE (*,'(" For simple use type only the name of the file ", &
&"followed by a slash (/) and RETURN.",/ &
&" Note that the name should be given WITHOUT extension!")')
!
! Does standard input unit contain an input record
NIN = 11
NOUT = 12
ISHIFT = 0
MXDPTH = 0
BLANKS = .FALSE.
INTBFL = .FALSE.
READ (* , * , END = 1 , ERR = 1) NAME, ISHIFT , MXDPTH , &
BLANKS, INTBFL
!
! If record present, check input values are reasonable
ISHIFT = MIN(MAX(ISHIFT , 0) , 10)
MXDPTH = MIN(MAX(MXDPTH , 0) , 36/MAX(ISHIFT,1))
IF (INTBFL.AND..NOT.BLANKS) WRITE (*, '('' Interface block proces&
&sing cancelled as blank processing not requested'')')
INTBFL = BLANKS.AND.INTBFL
GO TO 2
!
! Set default values
1 ISHIFT = 3
MXDPTH = 10
BLANKS = .TRUE.
INTBFL = .FALSE.
NAME = 'name'
2 OPEN (UNIT=NIN, FILE=TRIM(NAME)//'.f', ACTION='READ')
OPEN (UNIT=NOUT, FILE=TRIM(NAME)//'.f90', ACTION='WRITE')
!
! Print values to be used
Write (*,'(" Loop bodies will be indented by",I3/ &
& " Maximum indenting level is ",I3)') &
ISHIFT , MXDPTH
IF (BLANKS) WRITE (*, &
'(" Significant blank proccessing requested")')
IF (INTBFL) WRITE (*, &
'('' Only interface blocks will be produced'')')
IF (INTBFL) WRITE (NOUT, '(6X, ''INTERFACE'')')
!
CALL SYSTEM_CLOCK(TIME0)
RETURN
END SUBROUTINE START
SUBROUTINE TERMINATE( )
!
! To print the final summary
!
USE STATISTICS
USE DATA
implicit none
!
integer :: itick, itime
!
CALL SYSTEM_CLOCK(ITIME, ITICK)
IF (ITICK /= 0) &
WRITE (*,'(" Processing complete in ", F7.3, " seconds")') &
REAL(ITIME-TIME0)/REAL(ITICK)
WRITE (*,'(" Maximum depth of DO-loop nesting ",I3/ &
& " Maximum depth of IF-block nesting",I3/ &
&" No. of lines read ",I17/" No. of program units read ",I8/ &
& " Global syntax error flag",L12)') &
MXDO , MXIF , KARD , KNTPU , SYNTAX
!
IF (OVFLW) WRITE(*, '(" At least one statement was too long to h&
&ave a necessary blank added")')
IF (NONSTD) WRITE (*, '(" At least one statement began with a no&
&n-standard keyword")')
!
RETURN
END SUBROUTINE TERMINATE
END MODULE ALL_PROCEDURES
PROGRAM CONVERT
USE ALL_PROCEDURES
implicit none
!
! Initialize
CALL START( )
!
! Process the lines of program units
CALL PROGRAM_UNITS( )
!
! Print some statistics
CALL TERMINATE( )
STOP
END PROGRAM CONVERT