MODULE STRUCTURE !*****************************************************************************80 ! !! STRUCTURE is a module defining the maximum DO nesting and statement length. ! !*********************************************************************** ! 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 !*****************************************************************************80 ! !! DATA is a module. ! implicit none public ! INTEGER, SAVE :: ISHIFT , MXDPTH , NIN , NOUT, TIME0 LOGICAL, SAVE :: BLANKS, INTBFL ! END MODULE DATA MODULE STATISTICS !*****************************************************************************80 ! !! STATISTICS is a module. ! implicit none public ! INTEGER, SAVE :: MXDO , MXIF , KARD , KNTPU ! LOGICAL, SAVE :: SYNTAX, OVFLW, NONSTD ! END MODULE STATISTICS MODULE ALL_PROCEDURES !*****************************************************************************80 ! !! ALL_PROCEDURES is a module containing all the procedures. ! private public :: start, program_units, terminate CONTAINS SUBROUTINE ARGUMENT(ARGNAM, LENARG, STAMNT, LENST, NOARG) !*****************************************************************************80 implicit none ! !! ARGUMENT stores the names of a routine and its arguments. ! ! 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( ) !*****************************************************************************80 ! !! BLANK reformats the statement so a single blank separates most tokens. ! ! 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) !*****************************************************************************80 ! !! IDENTIFY identifies statements belonging to DO's, IF's or FORMAT's. ! !*********************************************************************** ! 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) !*****************************************************************************80 ! !! KEYWORD cleans up a keyword that has been read. ! ! 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) !*****************************************************************************80 ! !! NAMEOF picks out the name of a procedure. ! implicit none ! 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( ) !*****************************************************************************80 ! !! PROGRAM_UNITS is the principal subroutine. ! ! 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) !*****************************************************************************80 ! !! REFORM reformats and outputs 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) !*****************************************************************************80 ! !! SPECIAL applies 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( ) !*****************************************************************************80 ! !! START prepares 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( ) !*****************************************************************************80 ! !! TERMINATE prints 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 !*****************************************************************************80 ! !! CONVERT is the main program for converting F77 to 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. * ! 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