source: lmdz_wrf/trunk/WRFV3/external/fftpack/convert.f90 @ 1544

Last change on this file since 1544 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 58.3 KB
Line 
1!     ftp://ftp.numerical.rl.ac.uk/pub/MandR/convert.f90
2!
3!     Copyright CERN, Geneva 1991, 1997 - Copyright and any other
4!     appropriate legal protection of these computer programs
5!     and associated documentation reserved in all countries
6!     of the world.
7!     Author: Michael Metcalf  (MichaelMetcalf@compuserve.com)
8!
9!     Requires the option -qcharlen=14400 with IBM's xlf.
10!
11!     Version 1.5. Differs from previous versions in that:
12!      (19/12/96)
13!                  Code modified to be Fortran 95 and ELF
14!                  compatible (no functional changes).
15!
16!***********************************************************************
17!                                                                      *
18!                                                                      *
19!    A program to convert FORTRAN 77 source form to Fortran 90 source  *
20!  form. It also formats the code by indenting the bodies of DO-loops  *
21!  and IF-blocks by ISHIFT columns. Statement keywords are             *
22!  followed if necessary by a blank, and blanks within tokens are      *
23!  are suppressed; this handling of blanks is optional.                *
24!    If a CONTINUE statement terminates a single DO loop, it is        *
25!  replaced by END DO.                                                 *
26!    Procedure END statements have the procedure name added, if        *
27!  blanks are handled.                                                 *
28!    Statements like INTEGER*2 are converted to INTEGER(2), if blanks  *
29!  are handled. Depending on the target processor, a further global    *
30!  edit might be required (e.g. where 2 bytes correspond to KIND=1).   *
31!  Typed functions and assumed-length character specifications are     *
32!  treated similarly. The length specification *4 is removed for all   *
33!  data types except CHARACTER, as is *8 for COMPLEX. This             *
34!  treatment of non-standard type declarations includes any            *
35!  non-standard IMPLICIT statements.                                   *
36!    Optionally, interface blocks only may be produced; this requires  *
37!  blanks processing to be requested. The interface blocks are         *
38!  compatible with both the old and new source forms.                  *
39!                                                                      *
40!    Usage: the program reads one data record in free format from the  *
41!          default input unit. This contains:                          *
42!                                                                      *
43!                        name of file                                  *
44!                        indentation depth                             *
45!                        maximum indentation level                     *
46!                        whether significant blanks should be handled  *
47!                        whether interface blocks only are required    *
48!                                                                      *
49!   The default values in the absence of this record are:              *
50!                               name 3 10 T F                          *
51!   To do nothing but change the source form of a file prog.f type     *
52!                               prog 0  0 F F                          *
53!       or simply                                                      *
54!                               prog /                                 *
55!   For more extensive processing type, say,                           *
56!                               prog 3 10 t f                          *
57!   and for interface blocks only type                                 *
58!                               prog 0 0 t t                           *
59!   The input is read from prog.f, the output is written to prog.f90;  *
60!   there should be no tabs in the input.                              *
61!                                                                      *
62!   Restrictions:  The program does not indent FORMAT statements or    *
63!                any statement containing a character string with an   *
64!                embedded multiple blank.                              *
65!                  The order of comment lines and Fortran statements   *
66!                is slightly modified if there are sequences of        *
67!                more than KKLIM (=200) comment lines.                 *
68!                  If there are syntax errors, continued lines do not  *
69!                have a trailing &.                                    *
70!                  When producing interface blocks, a check is required*
71!                that any dummy argument that is a procedure has a     *
72!                corresponding EXTERNAL statement. Also, since no      *
73!                COMMON blocks or PARAMETER statements are copied,     *
74!                part of an assumed-size array declaration may be      *
75!                missing. Similarly, parts of an assumed-length        *
76!                character symbolic constant might be copied and have  *
77!                to be deleted. BLOCK DATA statements are copied and   *
78!                must be deleted. These problems would normally be     *
79!                detected by a compiler and are trivially corrected.   *
80!                  Within a given keyword, the case must be all upper  *
81!                or all lower, and lower case programs require         *
82!                blank handling for correct indenting.                 *
83!                                                                      *
84!***********************************************************************
85!
86   MODULE STRUCTURE
87!
88!***********************************************************************
89!   Define maximum level of DO-loop nesting, and maximum length of     *
90!   a Fortran statement. LEN may be reduced for                        *
91!   compilers accepting a maximum character                            *
92!   length below 2640 and this will cause any excess                   *
93!   continuation lines and all following lines to be copied unchanged. *
94!   KKLIM defines the length of the comment line buffer. If this       *
95!   length is exceeded, the statement preceding the comments will      *
96!   appear after them.                                                 *
97!***********************************************************************
98      implicit none
99      public
100      INTEGER, PARAMETER :: NEST = 32 , LEN = 2640 , KKLIM = 200,      &
101      KLEN = 72*KKLIM
102!
103      INTEGER :: KNTDO , KNTIF , KNTCOM , LABEL , LENST , LABLNO, NOARG
104      INTEGER, DIMENSION(NEST) :: LABLDO
105!
106      LOGICAL :: SYNERR, BLNKFL, INTFL
107!
108      CHARACTER(LEN=LEN) :: STAMNT
109      CHARACTER(LEN=KLEN):: CBUF
110      CHARACTER(LEN=42)  :: NAME
111!
112   END MODULE STRUCTURE
113   MODULE DATA
114   implicit none
115   public
116!
117      INTEGER, SAVE :: ISHIFT , MXDPTH , NIN , NOUT, TIME0
118      LOGICAL, SAVE :: BLANKS, INTBFL
119!
120   END MODULE DATA
121   MODULE STATISTICS
122   implicit none
123   public
124!
125      INTEGER, SAVE :: MXDO , MXIF , KARD , KNTPU
126!
127      LOGICAL, SAVE :: SYNTAX, OVFLW, NONSTD
128!
129   END MODULE STATISTICS
130   MODULE ALL_PROCEDURES
131   private
132   public :: start, program_units, terminate
133   CONTAINS
134!***********************************************************************
135   SUBROUTINE ARGUMENT(ARGNAM, LENARG, STAMNT, LENST, NOARG)
136   implicit none
137!
138!   To store the argument names and function name, if any, for later
139!   use in checking whether a specification statement is relevant to an
140!   interface block.
141      CHARACTER(LEN=*), INTENT(IN OUT), dimension(:) :: ARGNAM
142      CHARACTER(LEN=*), INTENT(IN)         :: STAMNT
143      INTEGER, INTENT(OUT), dimension(:)   :: LENARG
144      INTEGER, INTENT(IN OUT) :: NOARG
145      INTEGER, INTENT(IN)    :: LENST
146!
147      integer :: ind1, ind2, newind
148!
149!   Correct length of function name
150      IF (NOARG == 1) LENARG(1) = LEN_TRIM(ARGNAM(1))
151!
152!   Get any other arguments
153      IND1 = index(STAMNT(:LENST), '(') + 1
154      IF (IND1  /=  1 .AND. STAMNT(IND1:IND1)  /=  ')') THEN
155         NEWIND = index(STAMNT(IND1+1:LENST), '(')
156         IF (NEWIND /= 0) IND1 = NEWIND + 1 + IND1
157    3    IND2 = index(STAMNT(IND1:LENST), ',') - 1
158         IF (IND2  ==  -1) IND2 = index(STAMNT(IND1:LENST), ')') - 1
159         IND2 = IND2 + IND1 - 1
160         IF (STAMNT(IND1+1:IND1+1)  /=  '*' ) THEN
161            NOARG = NOARG +1
162            ARGNAM(NOARG) = STAMNT(IND1:IND2)
163            LENARG(NOARG) = IND2 - IND1 +1
164         END IF
165            IF (STAMNT(IND2+1:IND2+1)  ==  ')') GO TO 4
166         IND1 = IND2 + 3
167         GO TO 3
168      END IF
169    4 LENARG(:NOARG) = MIN(LENARG(:NOARG), 6)
170!
171   RETURN
172   END SUBROUTINE ARGUMENT
173   SUBROUTINE BLANK( )
174!
175!   To suppress all blanks in the statement, and then to place
176!   a blank on each side of =,  +, -, * and / (but not ** or //), a
177!   blank after each ) and , and a blank before each (.
178!   No changes are made within character strings or FORMAT statememts.
179!
180      USE DATA
181!
182      USE STATISTICS
183!
184      USE STRUCTURE
185   implicit none
186!
187      CHARACTER(LEN=LEN) :: BUFFER
188      integer :: l1, l2, lchar, napost, lenold
189!
190!   Reduce length to that of significant characters
191      BLNKFL = .FALSE.
192      LENST = LEN_TRIM(STAMNT(1:LENST))
193      IF (.NOT.BLANKS) THEN
194         IF (LEN-LENST >= 2) STAMNT(LENST+1:LENST+2) = '  '
195         LENST = MIN(LENST+2, LEN)
196         GO TO 99
197      END IF
198      BLNKFL = .TRUE.
199!
200!   Suppress blanks (add 2 to catch
201!   odd number of apostrophes on a line in REFORM).
202      LCHAR = 0
203      NAPOST = 0
204      DO L1 = 1, LENST
205         IF (STAMNT(L1:L1)  ==  "'") NAPOST = 1-NAPOST
206         IF (NAPOST == 0 .AND. STAMNT(L1:L1)  ==  ' ') CYCLE
207         LCHAR = LCHAR+1
208         BUFFER(LCHAR:LCHAR) = STAMNT(L1:L1)
209      END DO
210      IF (LEN-LCHAR >= 2) BUFFER(LCHAR+1:LCHAR+2) = '  '
211      LCHAR = MIN(LCHAR+2, LEN)
212!
213!   Eliminate FORMATS
214       IF( LABEL  /=  0 .AND.                                          &
215     & LCHAR  >=  11 .AND.(BUFFER(:7)  ==  'FORMAT(' .OR.              &
216     &                     BUFFER(:7)  ==  'format(') .AND.            &
217     & BUFFER(LCHAR-2:LCHAR-2)  ==  ')') THEN
218         IF (LEN-LENST >= 2) STAMNT(LENST+1:LENST+2) = '  '
219         LENST = MIN(LENST+2, LEN)
220         GO TO 99
221       END IF
222!
223!   Insert blanks
224      LENOLD = LENST
225      LENST = 0
226      NAPOST = 0
227      DO L2 = 1, LCHAR
228!
229!   Check size of statement
230         IF(LENST+3 > LEN) THEN
231            LENST = LCHAR
232            STAMNT(:LENST) = BUFFER(:LENST)
233            OVFLW = .TRUE.
234            GO TO 99
235         END IF
236!
237!   Whether inside character string
238         IF (BUFFER(L2:L2)  ==  "'") NAPOST = 1-NAPOST
239         IF (NAPOST == 1) GO TO 3
240!
241!   Add blank padding according to character
242         SELECT CASE (BUFFER(L2:L2))
243         CASE ( ')' )
244            STAMNT(LENST+1:LENST+2) = ') '
245            LENST = LENST+2
246         CASE ( '(' )
247            STAMNT(LENST+1:LENST+2) = ' ('
248            LENST = LENST + 2
249         CASE ( ',' )
250            STAMNT(LENST+1:LENST+2) = ', '
251            LENST = LENST + 2
252         CASE ( '=' )
253            STAMNT(LENST+1:LENST+3) = ' = '
254            LENST = LENST + 3
255         CASE ( '*' )
256            IF (BUFFER(L2-1:L2-1)  /=  '*' .AND. BUFFER(L2+1:L2+1)     &
257             /=  '*') THEN
258               STAMNT(LENST+1:LENST+3) = ' * '
259               LENST = LENST + 3
260            ELSE
261               GO TO 3
262            END IF
263         CASE ( '/' )
264            IF (BUFFER(L2-1:L2-1)  /=  '/' .AND. BUFFER(L2+1:L2+1)     &
265             /=  '/') THEN
266               STAMNT(LENST+1:LENST+3) = ' / '
267               LENST = LENST + 3
268            ELSE
269               GO TO 3
270            END IF
271         CASE ('+')
272            IF (BUFFER(L2-1:L2-1)  /=  'E' .AND.                       &
273                BUFFER(L2-1:L2-1)  /=  'e' .AND.                       &
274                BUFFER(L2-1:L2-1)  /=  'D' .AND.                       &
275                BUFFER(L2-1:L2-1)  /=  'd' .OR.                        &
276          LLT(BUFFER(L2+1:L2+1), '0') .AND. LGT(BUFFER(L2+1:L2+1), '9')&
277               ) THEN
278               STAMNT(LENST+1:LENST+3) = ' + '
279               LENST = LENST + 3
280            ELSE
281               GO TO 3
282            END IF
283         CASE ('-')
284            IF (BUFFER(L2-1:L2-1)  /=  'E' .AND.                       &
285                BUFFER(L2-1:L2-1)  /=  'e' .AND.                       &
286                BUFFER(L2-1:L2-1)  /=  'D' .AND.                       &
287                BUFFER(L2-1:L2-1)  /=  'd' .OR.                        &
288          LLT(BUFFER(L2+1:L2+1), '0') .AND. LGT(BUFFER(L2+1:L2+1), '9')&
289               ) THEN
290               STAMNT(LENST+1:LENST+3) = ' - '
291               LENST = LENST + 3
292            ELSE
293               GO TO 3
294            END IF
295         CASE DEFAULT
296            GO TO 3
297         END SELECT
298         CYCLE
299    3    STAMNT(LENST+1:LENST+1) = BUFFER(L2:L2)
300         LENST = LENST +1
301      END DO
302!
303!   Blank out end of statement
304      IF (LENOLD > LENST) STAMNT(LENST+1:LENOLD) = ' '
305      IF (LENST < LEN .AND. MOD(LENST, 66) /= 0)                       &
306          STAMNT(LENST+1: LENST+66-MOD(LENST, 66)) = ' '
307!
30899 RETURN
309   END SUBROUTINE BLANK
310   SUBROUTINE IDENTIFY (IRET)
311!
312!***********************************************************************
313!   To identify statement as beginning or end of DO-loop or            *
314!   IF-block, or as probable FORMAT.                                   *
315!   Attempt to scan as few of the input characters as possible.        *
316!***********************************************************************
317!
318      USE STRUCTURE
319      USE DATA
320   implicit none
321!
322      CHARACTER(LEN=5), PARAMETER :: ENDIF='ENDIF' , THEN='NEHT)',     &
323                                     THENLC='neht)'
324      CHARACTER(LEN=3), PARAMETER :: BIF='IF('
325      CHARACTER(LEN=2), PARAMETER :: DO='DO'
326      CHARACTER(LEN=7), PARAMETER :: FORMAT='FORMAT('
327      CHARACTER(LEN=4), PARAMETER :: ELSE='ELSE'
328      CHARACTER(LEN=5)            :: INTFIL
329      INTEGER, INTENT(OUT)        :: IRET
330!
331      integer :: l1, l2, l3, l4, l5, l6, l7, l8, l9, l10, l11, l12,    &
332                 k1, k2, k3, k5, k6, k7, k8, lparen, kntch, napos
333!
334      IRET = 0
335!
336!   Check whether end of DO-loop
337      IF (KNTDO /= 0) THEN
338         IF (LABEL == LABLDO(KNTDO)) THEN
339            IRET = 2
340            GO TO 99
341         END IF
342      END IF
343!
344!   Check whether any of remaining possibilities
345      DO L7 = 1 , LENST
346         IF (STAMNT(L7:L7) == ' ') CYCLE
347         IF (STAMNT(L7:L7) == 'E') THEN
348            DO L11 = L7+1 , LENST
349               IF (STAMNT(L11:L11) == ' ') CYCLE
350               IF (STAMNT(L11:L11) == ENDIF(2:2)) GO TO 6
351               IF (STAMNT(L11:L11) == ELSE(2:2)) GO TO 3
352               GO TO 99
353            END DO
354         END IF
355         IF (STAMNT(L7:L7) == BIF(:1)) GO TO 9
356         IF (STAMNT(L7:L7) == DO(:1)) GO TO 15
357         IF (STAMNT(L7:L7) == FORMAT(:1)) GO TO 31
358         GO TO 99
359      END DO
360      GO TO  99
361!
362!   Check whether ELSE or ELSEIF
363    3 K8 = 3
364      DO L12 = L11+1 , LENST
365         IF (STAMNT(L12:L12) == ' ') CYCLE
366         IF (STAMNT(L12:L12) /= ELSE(K8:K8)) GO TO 99
367         IF (K8 == 4) GO TO 5
368         K8 = K8+1
369      END DO
370      GO TO  99
371    5 IF (L12 >= LENST) THEN
372         IRET = 6
373         GO TO 99
374      END IF
375      IF (STAMNT(L12+1:LENST) == ' ') THEN
376         IRET = 6
377         GO TO 99
378      END IF
379      K2 = 1
380      IRET = 6
381      L7 = L12
382      GO TO  10
383!
384!   Check whether end of IF-block
385    6 K1 = 3
386      DO L1 = L11+1 , LENST
387         IF (STAMNT(L1:L1) == ' ') CYCLE
388         IF (STAMNT(L1:L1) /= ENDIF(K1:K1)) GO TO 99
389         IF (K1 == 5) EXIT
390         K1 = K1+1
391      END DO
392      IF (L1 >= LENST) THEN
393         IRET = 4
394         GO TO 99
395      END IF
396      IF (STAMNT(L1+1:LENST) == ' ') IRET = 4
397      GO TO  99
398!
399!   Check whether beginning of IF-block
400    9 K2 = 2
401      IRET = 3
402   10 DO L2 = L7+1 , LENST
403         IF (STAMNT(L2:L2) == ' ') CYCLE
404         IF (STAMNT(L2:L2) /= BIF(K2:K2)) THEN
405            IRET = 0
406            GO TO 99
407         END IF
408         IF (K2 == 3) GO TO 12
409         K2 = K2+1
410      END DO
411      IRET = 0
412      GO TO  99
413!
414!   Backward search for )THEN at end of IF statement (to save
415!   scanning the condition).
416   12 K3 = 1
417      DO L3 = LENST , L2+1 , -1
418         IF (STAMNT(L3:L3) == ' ') CYCLE
419         IF (STAMNT(L3:L3) /= THEN(K3:K3) .AND.                        &
420             STAMNT(L3:L3) /= THENLC(K3:K3)) THEN
421            IRET = 0
422            GO TO 99
423         END IF
424         IF (K3 == 5) GO TO 99
425         K3 = K3+1
426      END DO
427      IRET = 0
428      GO TO  99
429!
430!   Check whether beginning of DO-loop
431   15 DO L4 = L7+1 , LENST
432         IF (STAMNT(L4:L4) == ' ') CYCLE
433         IF (STAMNT(L4:L4) == DO(2:2)) GO TO 17
434         GO TO 99
435      END DO
436      GO TO  99
437!
438!   Have DO - check label
439   17 K5 = 0
440      INTFIL = ' '
441      DO L5 = L4+1 , LENST
442         IF (STAMNT(L5:L5) == ' ') CYCLE
443         IF (LLT(STAMNT(L5:L5) , '0') .OR. LGT(STAMNT(L5:L5) , '9'))   &
444         EXIT
445         K5 = K5+1
446         IF (K5 > 5) GO TO 20
447         INTFIL(K5:K5) = STAMNT(L5:L5)
448      END DO
449      IF (K5 == 0) GO TO 99
450   20 READ (INTFIL , '(BN , I5)') LABLNO
451      IF (LABLNO == 0) GO TO 99
452!
453!   Have label - check comma
454      DO L8 = L5, LENST
455         IF (STAMNT(L8:L8) == ' ') CYCLE
456         IF (STAMNT(L8:L8) == ',') EXIT
457         GO TO 23
458      END DO
459      IRET = 1
460      GO TO  99
461!
462!   Have a DO and label with no comma.
463!   Check for variable whose first of maximum of six
464!   characters is alphabetic, followed by an equals sign,
465!   followed by a character string containing a comma which is
466!   not enclosed in parentheses.
467   23 K6 = 0
468      DO L9 = L8 , LENST
469         IF (STAMNT(L9:L9) == ' ') CYCLE
470         IF (K6 == 0) THEN
471            IF ((LLT(STAMNT(L9:L9), 'A') .OR. LGT(STAMNT(L9:L9), 'Z')) &
472           .AND.(LLT(STAMNT(L9:L9), 'a') .OR. LGT(STAMNT(L9:L9), 'z')))&
473            GO TO 99
474            K6 = 1
475         ELSE IF (LGE(STAMNT(L9:L9) , 'A') .AND. LLE(STAMNT(L9:L9),'Z')&
476            .OR. LGE(STAMNT(L9:L9) , 'a') .AND. LLE(STAMNT(L9:L9) ,'z')&
477         .OR. LGE(STAMNT(L9:L9) , '0') .AND. LLE(STAMNT(L9:L9) , '9')) &
478         THEN
479            K6 = K6+1
480            IF (K6 == 6) GO TO 26
481         ELSE
482            IF (K6 == 0) GO TO 99
483            GO TO 25
484         END IF
485      END DO
486      GO TO  99
487!
488!   Expect an equals sign
489   25 L9=L9-1
490   26 DO L10 = L9+1 , LENST
491         IF (STAMNT(L10:L10) == ' ') CYCLE
492         IF (STAMNT(L10:L10) == '=') GO TO 28
493         GO TO 99
494      END DO
495      GO TO  99
496!
497!   Search for bare comma
498   28 LPAREN = 0
499      KNTCH = 0
500      NAPOS = 0
501      DO L6 = L10+1 , LENST
502         IF (STAMNT(L6:L6) == ' ') CYCLE
503         IF (STAMNT(L6:L6) == "'") NAPOS = 1 - NAPOS
504         IF (NAPOS == 1) CYCLE
505         IF (STAMNT(L6:L6) == ',') THEN
506            IF (KNTCH /= 0) THEN
507               IF (LPAREN == 0) GO TO 30
508               CYCLE
509            ELSE
510               GO TO 99
511            END IF
512         ELSE IF (STAMNT(L6:L6) == '(') THEN
513            LPAREN = LPAREN+1
514         ELSE IF (STAMNT(L6:L6) == ')') THEN
515            LPAREN = LPAREN-1
516         END IF
517         KNTCH = 1
518      END DO
519      GO TO  99
520   30 IRET = 1
521!
522!   Insert blank after label
523      IF (.NOT.BLANKS .OR. LENST >= LEN) GO TO 99
524      DO L10 = LENST, L5, -1
525         STAMNT(L10+1:L10+1) = STAMNT(L10:L10)
526      END DO
527      STAMNT(L5:L5) = ' '
528      LENST = LENST  + 1
529      GO TO  99
530!
531!   Identify FORMAT statement
532   31 IF (LABEL == 0) GO TO 99
533      K7 = 2
534      DO L11 = L7+1 , LENST
535         IF (STAMNT(L11:L11) == ' ') CYCLE
536         IF (STAMNT(L11:L11) /= FORMAT(K7:K7)) GO TO 99
537         IF (K7 == 7) GO TO 33
538         K7 = K7+1
539      END DO
540      GO TO  99
541   33 IRET = 5
542!
54399 RETURN
544   END SUBROUTINE IDENTIFY
545   SUBROUTINE KEYWORD(ASSIGN, SKIP)
546!
547!   To check whether those initial keywords of the statement which
548!   require it are followed by a blank, to add one if necessary, and
549!   to suppress any embedded blanks.
550!
551      USE STATISTICS
552!
553      USE STRUCTURE
554   implicit none
555!
556      LOGICAL, INTENT(OUT) :: ASSIGN, SKIP
557!
558      INTEGER, PARAMETER    :: NKEY = 42, MAXLEN = 15
559      CHARACTER(LEN=MAXLEN) :: BEGIN
560      CHARACTER(LEN=LEN)    :: BUFFER
561      CHARACTER(LEN=3)      :: THREE
562      CHARACTER(LEN=32)     :: NAMEOF
563      CHARACTER(LEN=6), SAVE :: ARGNAM(445)
564      LOGICAL               :: IFASS
565      INTEGER, SAVE         :: LENARG(445)
566!
567      CHARACTER(LEN=MAXLEN), PARAMETER, dimension(nkey) :: KEYS = (/   &
568      'ASSIGN         ', 'BACKSPACE      ', 'BLOCKDATA      ',         &
569      'CALL           ', 'CHARACTER      ', 'CLOSE          ',         &
570      'COMMON         ', 'COMPLEX        ', 'CONTINUE       ',         &
571      'DATA           ', 'DIMENSION      ', 'DOUBLEPRECISION',         &
572      'DO             ', 'ELSEIF         ', 'ELSE           ',         &
573      'ENDFILE        ', 'ENDIF          ', 'ENTRY          ',         &
574      'EXTERNAL       ', 'EQUIVALENCE    ', 'FORMAT         ',         &
575      'FUNCTION       ', 'GOTO           ', 'IF             ',         &
576      'IMPLICIT       ', 'INQUIRE        ', 'INTEGER        ',         &
577      'INTRINSIC      ', 'LOGICAL        ', 'OPEN           ',         &
578      'PARAMETER      ', 'PAUSE          ', 'PRINT          ',         &
579      'PROGRAM        ', 'READ           ', 'REAL           ',         &
580      'RETURN         ', 'REWIND         ', 'SAVE           ',         &
581      'STOP           ', 'SUBROUTINE     ', 'WRITE          '/)
582      INTEGER, PARAMETER, dimension(nkey) :: LK =                      &
583            (/6, 9, 9, 4,                                              &
584              9, 5, 6, 7, 8, 4,                                        &
585              9,15, 2, 6, 4,                                           &
586              7, 5, 5, 8,11,                                           &
587              6, 8, 4, 2, 8, 7,                                        &
588              7, 9, 7, 4, 9,                                           &
589              5, 5, 7, 4, 4, 6,                                        &
590              6, 4, 4,10, 5    /)
591      LOGICAL, PARAMETER, dimension(nkey) :: BLANK =                   &
592               (/.TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,                    &
593                 .TRUE.,  .FALSE., .TRUE.,  .TRUE.,  .FALSE., .TRUE.,  &
594                 .TRUE.,  .TRUE.,  .TRUE.,  .FALSE., .FALSE.,          &
595                 .TRUE.,  .FALSE., .TRUE.,  .TRUE.,  .FALSE.,          &
596                 .FALSE., .TRUE.,  .TRUE.,  .FALSE., .TRUE.,  .FALSE., &
597                 .TRUE.,  .TRUE.,  .TRUE.,  .FALSE., .TRUE.,           &
598                 .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  &
599                 .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .FALSE./)
600      LOGICAL, PARAMETER, dimension(nkey) :: FOLLOW =                  &
601               (/.TRUE.,  .TRUE.,  .FALSE., .TRUE.,                    &
602                 .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., &
603                 .FALSE., .FALSE., .FALSE., .FALSE., .FALSE.,          &
604                 .TRUE.,  .FALSE., .FALSE., .FALSE., .FALSE.,          &
605                 .FALSE., .FALSE., .TRUE.,  .FALSE., .FALSE., .FALSE., &
606                 .FALSE., .FALSE., .FALSE., .FALSE., .FALSE.,          &
607                 .TRUE.,  .TRUE.,  .FALSE., .TRUE.,  .FALSE., .TRUE.,  &
608                 .TRUE.,  .FALSE., .TRUE.,  .FALSE., .FALSE./)
609!
610      CHARACTER(LEN=MAXLEN), PARAMETER, dimension(nkey) :: KEYSLC = (/ &
611      'assign         ', 'backspace      ', 'blockdata      ',         &
612      'call           ', 'character      ', 'close          ',         &
613      'common         ', 'complex        ', 'continue       ',         &
614      'data           ', 'dimension      ', 'doubleprecision',         &
615      'do             ', 'elseif         ', 'else           ',         &
616      'endfile        ', 'endif          ', 'entry          ',         &
617      'external       ', 'equivalence    ', 'format         ',         &
618      'function       ', 'goto           ', 'if             ',         &
619      'implicit       ', 'inquire        ', 'integer        ',         &
620      'intrinsic      ', 'logical        ', 'open           ',         &
621      'parameter      ', 'pause          ', 'print          ',         &
622      'program        ', 'read           ', 'real           ',         &
623      'return         ', 'rewind         ', 'save           ',         &
624      'stop           ', 'subroutine     ', 'write          '/)
625!
626      integer :: l1, l2, l3, l4, l5, l6, l7, l20, lparen, kntap, kntch,&
627                 lc, lcc, l33, next, l8, napos, lsave, name_length
628!
629!   Test for statement function statement or assignment statement
630      SKIP = INTFL
631      ASSIGN = .FALSE.
632      IFASS = .FALSE.
633      THREE = ' '
634      LPAREN = 0
635      KNTAP = 0
636      KNTCH = 0
637      DO L1 = 1, LENST
638         IF (STAMNT(L1:L1)==' ') CYCLE
639         IF (STAMNT(L1:L1)=='=') THEN
640            IF (KNTCH==0) SYNERR = .TRUE.
641            IF (LPAREN==0 .AND. KNTAP==0) THEN
642               ASSIGN = .TRUE.
643               GO TO 9
644            ELSE
645               EXIT
646            END IF
647         ELSE IF (STAMNT(L1:L1)=='(') THEN
648            LPAREN = LPAREN+1
649         ELSE IF (STAMNT(L1:L1)==')') THEN
650            LPAREN = LPAREN-1
651         ELSE IF (STAMNT(L1:L1)=="'") THEN
652            KNTAP = 1-KNTAP
653         END IF
654         KNTCH = KNTCH+1
655         IF (KNTCH<=3) THREE(KNTCH:KNTCH) = STAMNT(L1:L1)
656      END DO
657!
658!   Suppress blanks in first 15 non-blank characters
659   10 BEGIN = ' '
660      LC = 0
661      DO L2 = 1, LENST
662         IF (STAMNT(L2:L2)==' ') CYCLE
663         LC = LC+1
664         BEGIN(LC:LC) = STAMNT(L2:L2)
665         IF (LC==MAXLEN) GO TO 3
666      END DO
667      L2 = L2-1
668!
669!   Is this a keyword? Failure of this test is not fatal, in order to
670!   allow for non-standard syntax extensions.
671    3 DO L3 = 1, NKEY
672         IF     (BEGIN(:LK(L3)) == KEYS(L3)(:LK(L3))) THEN
673            GO TO 5
674         ELSE IF (BEGIN(:LK(L3)) == KEYSLC(L3)(:LK(L3))) THEN
675            LCC = 0
676            DO  L33 = 1, L2
677               IF (STAMNT(L33:L33) == ' ') CYCLE
678               LCC = LCC + 1
679               IF (LCC == LK(L3)) EXIT
680            END DO
681            STAMNT(:L33) = KEYS(L3)(:LK(L3))
682            GO TO 5
683         END IF
684      END DO
685      NONSTD = .TRUE.
686      GO TO  98
687!
688!   Test for embedded blanks in keyword
689    5 IF (L2 /= LC) THEN
690         LC = 0
691         DO L4 =1, LENST
692            IF (STAMNT(L4:L4)==' ') CYCLE
693            LC = LC+1
694            IF (LC==LK(L3)) GO TO 7
695         END DO
696         GO TO 8
697    7    IF (L4==LC) GO TO 8
698         STAMNT(:L4) = KEYS(L3)(:LC)
699         GO TO 99
700      END IF
701!
702!   Keyword has no blanks - is it followed by a blank if it needs one?
703    8 IF (.NOT.BLANK(L3)) GO TO 99
704      NEXT = 0
705      DO L8 = 1, LK(L3)
706   17    NEXT = NEXT+1
707         IF (STAMNT(NEXT:NEXT)==' ') GO TO 17
708      END DO
709      NEXT = NEXT+1
710      IF (STAMNT(NEXT:NEXT)==' ') GO TO 99
711!
712!   Sometimes a delimiter may be present
713      IF (L3==2.OR.L3==16.OR.L3==23.OR.L3==35.OR.L3==38) THEN
714         IF (STAMNT(NEXT:NEXT)=='(') GO TO 99
715      ELSE IF (L3==5) THEN
716         IF (STAMNT(NEXT:NEXT)=='*') GO TO 99
717      ELSE IF (L3==7.OR.L3==39) THEN
718         IF (STAMNT(NEXT:NEXT)=='/') GO TO 99
719      END IF
720      IF (LENST==LEN) THEN
721         OVFLW = .TRUE.
722         GO TO 99
723      END IF
724!
725!   Insert the blank
726      BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
727      LENST = LENST+1
728      STAMNT(NEXT:NEXT) = ' '
729      STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
730      BLNKFL = .TRUE.
731      GO TO  99
732!
733!   Check whether, in fact, a DO-loop
734    9 IF (THREE(:2) /= 'DO' .AND. THREE(:2) /= 'do') GO TO 12
735      LPAREN = 0
736      NAPOS = 0
737      DO L5 = L1+2, LENST
738         IF (STAMNT(L5:L5)==' ') CYCLE
739         IF (STAMNT(L5:L5) == "'") NAPOS = 1 - NAPOS
740         IF (NAPOS == 1) CYCLE
741         IF (STAMNT(L5:L5)==',') THEN
742            IF (LPAREN==0) THEN
743               ASSIGN = .FALSE.
744               GO TO 10
745            END IF
746         ELSE IF (STAMNT(L5:L5)=='(') THEN
747            LPAREN = LPAREN+1
748         ELSE IF (STAMNT(L5:L5)==')') THEN
749            LPAREN = LPAREN-1
750         END IF
751      END DO
752      GO TO  99
753!
754!   Check whether, in fact, a logical IF followed by an assignment
755   12 IF (THREE /= 'IF(' .AND. THREE /= 'if(') GO TO 99
756      IFASS = .TRUE.
757      DO L6 = L1-1, 1, -1
758         IF (STAMNT(L6:L6)==' ') CYCLE
759         IF (STAMNT(L6:L6)==')') THEN
760!
761!   Is there a second pair of first-level parentheses
762            IF (index(STAMNT(:L6), ')')==0) GO TO 99
763            LPAREN = 1
764            DO L7 = L6-1, 4, -1
765               IF (STAMNT(L7:L7)==' ') CYCLE
766               IF (STAMNT(L7:L7)==')') THEN
767                  IF (LPAREN==0) THEN
768                     GO TO 14
769                  ELSE
770                     LPAREN = LPAREN+1
771                  END IF
772               ELSE IF (STAMNT(L7:L7)=='(') THEN
773                  LPAREN = LPAREN-1
774               END IF
775            END DO
776            GO TO 99
777   14       ASSIGN = .FALSE.
778            GO TO 10
779         ELSE
780            ASSIGN = .FALSE.
781            GO TO 10
782         END IF
783      END DO
784!
785!   Test for non-executable statement keyword
786   99 IF (ASSIGN) GO TO 98
787      IF (.NOT.INTFL) GO TO 97
788      SKIP = L3 ==  3.OR.L3 ==  5.OR.L3 ==  8                          &
789         .OR.L3 == 11.OR.L3 == 12.OR.L3 == 19.OR.L3 == 22              &
790         .OR.L3 == 25.OR.L3 == 27.OR.L3 == 29                          &
791         .OR.L3 == 34.OR.L3 == 36.OR.L3 == 41
792      SKIP = .NOT.SKIP
793      IF (SKIP) GO TO 98
794!
795!   Check whether this statement refers to an argument or a function
796!   name
797      IF (L3 == 3 .OR. L3 == 22 .OR. L3 == 25 .OR.                     &
798                       L3 == 34 .OR. L3 == 41) GO TO 97
799      IF(index(STAMNT(LK(L3)+1:LENST), 'FUNCTION')/= .0 .OR.           &
800         index(STAMNT(LK(L3)+1:LENST), 'function') /= 0) GO TO 97
801      DO L20 = 1, NOARG
802         IF(index(STAMNT(LK(L3)+1:LENST), ARGNAM(L20)(:LENARG(L20)))   &
803          /=  0) GO TO 97
804      END DO
805      SKIP = .TRUE.
806      GO TO 98
807!
808!   Keep procedure name for END statement
809   97 call name_of(nameof, stamnt(lk(l3)+2:lenst), name_length)
810      IF(L3 == 3.OR.L3 == 22.OR.L3 == 34.OR.                           &
811      L3 == 41) NAME = KEYS(L3)(:LK(L3))//NAMEOF(:name_length)
812!
813!   Get argument names for later use in skipping unnecessary
814!   specifications
815   21 IF (INTFL) THEN
816         IF (L3 == 22) THEN
817            ARGNAM(1) = NAME(10:15)
818            NOARG = 1
819         END IF
820         IF (L3 == 22 .OR. L3 == 41)                                   &
821         CALL ARGUMENT(ARGNAM, LENARG, STAMNT, LENST, NOARG)
822      END IF
823!
824!   Deal with awkward cases
825      LSAVE = L3
826      IF(L3 == 1.OR.L3 == 5.OR.L3 == 8.OR.L3 == 12 .OR. L3 == 13       &
827      .OR. L3 == 25                                                    &
828      .OR.L3 == 24.AND..NOT.IFASS.OR.L3 == 27.OR.L3 == 29.OR.L3 == 36) &
829        CALL SPECIAL(L3, NEXT, BUFFER, NKEY, KEYS, KEYSLC, LK, FOLLOW)
830!
831!   Was, in fact, a function
832      IF (INTFL.AND.L3 == 22.AND.LSAVE /= 22) THEN
833         SKIP = .FALSE.
834         GO TO 21
835      END IF
836!
837!   Print procedure name
838   98 IF(.NOT.ASSIGN.AND.(L3 == 3.OR.L3 == 22.OR.L3 == 34.OR.L3 == 41))&
839      WRITE (*, '('' Starting '', A)') NAME
840      RETURN
841   END SUBROUTINE KEYWORD
842   subroutine NAME_OF(nameof, HEADER, name_length)
843!
844   implicit none
845!   Pick out name of procedure
846      CHARACTER(LEN=*), INTENT(IN) :: HEADER
847      CHARACTER(LEN=*), INTENT(out):: nameof
848      integer, intent(out)         :: name_length
849      integer :: ind, indast
850!
851      NAMEOF = ' '
852!
853!   Is there a left parenthesis or an asterisk?
854      IND = index(HEADER, '(' )
855      INDAST = index(HEADER, '*')
856      IF (IND /= 0 .AND. INDAST /= 0) IND = MIN(IND, INDAST)
857      IF (IND <= LEN(NAMEOF)) THEN
858         IF (IND  ==  0) THEN
859            NAMEOF(2:) = HEADER(:LEN(HEADER))
860            name_length = min(len(header)+1, len(nameof))
861         ELSE
862            NAMEOF(2:IND) = HEADER(:IND-1)
863            name_length = ind
864         END IF
865      END IF
866      RETURN
867   END subroutine NAME_OF
868   SUBROUTINE PROGRAM_UNITS( )
869!
870!***********************************************************************
871!   The principal subroutine of CONVERT processes the                  *
872!   input stream, which is assumed to contain syntactically correct    *
873!   Fortran program units. To protect itself from bad data, failure    *
874!   to pass a primitive syntax check will cause the program to copy    *
875!   the input stream to the output unit unchanged, until an END line is*
876!   encountered.                                                       *
877!***********************************************************************
878!
879      USE DATA
880!
881      USE STATISTICS
882!
883      USE STRUCTURE
884   implicit none
885!
886!***********************************************************************
887!   USER is a character which may be defined to identify lines         *
888!   in the input stream which are to be treated as                     *
889!   comment lines ( + in this example).                                *
890!***********************************************************************
891!
892      CHARACTER(LEN=1) :: CONTIN
893      CHARACTER(LEN=3), PARAMETER :: FIN='END', FINLC='end'
894      CHARACTER(LEN=66) :: FIELD
895      CHARACTER(LEN=72) :: LINE
896      CHARACTER(LEN=72), PARAMETER :: BLANKV=' '
897!
898      LOGICAL :: NEWDO , NEWIF , FORM ,  ELSEBL , ASSIGN
899!
900      CHARACTER(LEN=*), PARAMETER :: USER = '+'
901      LOGICAL :: STAT = .FALSE. , SKIP = .FALSE.
902!
903      integer :: l1,             l5, l22, kntcon, napo, lab, l9, k1,   &
904                 irtcod, nend
905!
906!   Start processing program units
907      MXDO = 0
908      MXIF = 0
909      KARD = 0
910      KNTPU = 0
911      SYNTAX = .FALSE.
912      SYNERR = .FALSE.
913      OVFLW = .FALSE.
914      NONSTD = .FALSE.
915      KNTDO = 0
916      KNTIF = 0
917      KNTCOM = 0
918      NAME = ' '
919      NOARG = 0
920      INTFL = INTBFL
921!
922!   Set continuation line counter
923    1 KNTCON = 0
924!
925!   Set statement length counter
926      LENST = 0
927!
928!   Read one line into an internal file,
929!   columns 73-80 of all lines are ignored.
930    2 READ (NIN , '(A)' , END = 100 , ERR = 100) LINE
931      KARD = KARD+1
932!
933!   Check whether a comment line and if so copy to buffer.
934      IF (LINE(:1) == 'C' .OR. LINE(:1) == '*' .OR. LINE(:1) ==        &
935      USER .OR. LINE == ' ' .OR. LINE(:1) == 'c'                       &
936                            .OR. LINE(:1) == '!') THEN
937         IF (INTFL) GO TO 2
938         IF (LINE(:1) == 'C' .OR. LINE(:1) == '*'                      &
939         .OR. LINE(:1) == 'c') LINE(:1) = '!'
940         IF (KNTCOM == KKLIM) THEN
941            WRITE (NOUT , '(A72)') (CBUF(72*L5-71:72*L5) , L5 = 1 ,    &
942            KNTCOM) , LINE
943            KNTCOM = 0
944         ELSE IF (SYNERR .OR. .NOT.STAT) THEN
945            WRITE (NOUT , '(A72)') LINE
946         ELSE
947            KNTCOM = KNTCOM+1
948            CBUF(72*KNTCOM-71:72*KNTCOM) = LINE
949         END IF
950         GO TO 2
951      END IF
952!
953!   Some form of embedded comment?
954      NAPO = 0
955      DO L22 = 2, 72
956         IF (LINE(L22:L22)  ==  '''') NAPO = 1 - NAPO
957         IF (L22 == 6) CYCLE
958         IF (LINE(L22:L22)  /=  '!') CYCLE
959         IF (NAPO  /=  0) CYCLE
960         IF (.NOT. INTFL) THEN
961            IF (KNTCOM  <  KKLIM) THEN
962               KNTCOM = KNTCOM +1
963               CBUF(72*KNTCOM-71:72*KNTCOM) =                          &
964                                BLANKV(:L22-1)//LINE(L22:72)
965            ELSE
966               WRITE (NOUT, '(A)') BLANKV(:L22-1)//LINE(L22:72)
967            END IF
968         END IF
969         LINE(L22:72) = ' '
970         IF (LINE  ==  ' ') GO TO 2
971         EXIT
972      END DO
973!
974!   Line is some form of statement; re-read.
975      READ (LINE , '(BN , I5 , A1 , A66)') LAB , CONTIN , FIELD
976      STAT = .TRUE.
977!
978!   Check on syntax and copy to statement buffer
979    3 IF (CONTIN == '0') CONTIN = ' '
980      IF (CONTIN /= ' ') THEN
981         CONTIN = '&'
982         IF (SYNERR) THEN
983            GO TO 6
984         ELSE IF (LENST == 0 .OR. LENST+66 > LEN .OR. LAB /= 0) THEN
985            SYNERR = .TRUE.
986            IF (LENST > 0) THEN
987               IF (LABEL /= 0) THEN
988                  WRITE (NOUT , '(I5, 1X, A66:"&"/(5X, "&", A66:       &
989     &            "&"))') LABEL ,                                      &
990                  (STAMNT(66*L9-65:66*L9) , L9 = 1 , (LENST+65)/66)
991               ELSE
992                  WRITE (NOUT , '(6X, A66:"&"/(5X, "&", A66:"&"        &
993     &            ))') (STAMNT(66*L9-65:66*L9) , L9 = 1 , (LENST+65)/66)
994               END IF
995            END IF
996            IF (LAB /= 0) THEN
997               WRITE (NOUT , 1000) LAB , CONTIN , FIELD
998            ELSE
999               WRITE (NOUT , 1006) CONTIN , FIELD
1000            END IF
1001            GO TO 1
1002         ELSE
1003            KNTCON = KNTCON+1
1004            STAMNT(LENST+1:LENST+66) = FIELD
1005            LENST = LENST+66
1006            GO TO 2
1007         END IF
1008      ELSE IF (KNTCON == 0) THEN
1009         IF (LENST /= 0) GO TO 4
1010         STAMNT(1:66) = FIELD
1011         LENST = 66
1012         LABEL = LAB
1013         IF (SYNERR) GO TO 4
1014         GO TO 2
1015      END IF
1016      IF (KNTCON > 0) GO TO 6
1017!
1018!   Have a complete statement ready for processing (the last line
1019!   read is still waiting in LINE). The statement now needs to be
1020!   identified.
1021!   The END statement is a special case - if found it will be copied
1022!   and the next program unit processed.
1023    4 K1 = 1
1024      DO  L1 = 1 , LENST
1025         IF (STAMNT(L1:L1) == ' ') CYCLE
1026         IF (STAMNT(L1:L1) /= FIN(K1:K1) .AND.                         &
1027             STAMNT(L1:L1) /= FINLC(K1:K1)) THEN
1028            EXIT
1029         ELSE
1030            K1 = K1+1
1031            IF (K1 > 3 .AND. (L1 >= LENST .OR. STAMNT(L1+1:LENST)      &
1032            == ' ')) THEN
1033               IF (.NOT.SYNERR) THEN
1034                  KNTPU=KNTPU+1
1035                  IF (LABEL == 0) THEN
1036                     WRITE (NOUT , 1001) FIN, NAME
1037                  ELSE
1038                     WRITE (NOUT , 1002) LABEL , FIN, NAME
1039                  END IF
1040               END IF
1041!
1042!   Set counters for new program unit
1043               SYNTAX = SYNTAX .OR. SYNERR
1044               KNTDO = 0
1045               KNTIF = 0
1046               SYNERR = .FALSE.
1047               KNTCON = 0
1048               LENST = 0
1049               IF (KNTCOM /= 0) WRITE (NOUT , '(A72)') (CBUF(72*L5-71: &
1050               72*L5) , L5 = 1 , KNTCOM)
1051               KNTCOM = 0
1052               NAME = ' '
1053               NOARG = 0
1054               GO TO 3
1055            ELSE
1056               IF (K1 > 3) EXIT
1057            END IF
1058         END IF
1059      END DO
1060!
1061!   If syntax error flag set, copy and take next statement
1062    6 IF (SYNERR) THEN
1063         IF (LAB /= 0) THEN
1064            WRITE (NOUT , 1000) LAB , CONTIN , FIELD
1065         ELSE
1066            WRITE (NOUT , 1006) CONTIN , FIELD
1067         END IF
1068         LENST = 0
1069         GO TO 2
1070      END IF
1071!
1072!   Compress blanks and insert blanks around special characters
1073      CALL BLANK( )
1074!
1075!   Handle Fortran keywords
1076      NEWDO = .FALSE.
1077      NEWIF = .FALSE.
1078      FORM  = .FALSE.
1079      ELSEBL = .FALSE.
1080      ASSIGN = .FALSE.
1081      IF (BLANKS) CALL KEYWORD(ASSIGN, SKIP)
1082      IF (SKIP) GO TO 16
1083      IF (SYNERR) GO TO 6
1084      IF (BLANKS .AND. ASSIGN .AND. LABEL == 0) GO TO 14
1085!
1086!   Have a valid statement which is not an END line or assignment
1087!   Identify statement as    DO
1088!                            IF ( ) THEN
1089!                            DO terminator
1090!                            END IF
1091!                            FORMAT
1092!                            ELSE or ELSEIF
1093!                            none of these.
1094      CALL IDENTIFY(IRTCOD)
1095      SELECT CASE (IRTCOD)
1096         CASE (0)
1097            GO TO  14
1098!
1099!   New DO-loop
1100         CASE (1)
1101            IF (KNTDO == NEST) GO TO 14
1102            NEWDO = .TRUE.
1103            LABLDO(KNTDO+1) = LABLNO
1104!
1105!   End of DO-loop(s)
1106         CASE (2)
1107            NEND = 0
1108            DO  L5 = KNTDO , 1 , -1
1109               IF (LABLDO(L5) /= LABEL) EXIT
1110               NEND = NEND + 1
1111            END DO
1112!
1113!   Replace CONTINUE by END DO
1114      KNTDO = KNTDO - NEND
1115      IF (NEND == 1 .AND. LENST == 10 .AND. STAMNT(:LENST) ==          &
1116      'CONTINUE  ') THEN
1117         STAMNT(:8) = 'END DO  '
1118         LENST = 6
1119      END IF
1120!
1121!   Beginning of IF-block
1122         CASE (3)
1123            NEWIF = .TRUE.
1124!
1125!   End of IF-block
1126         CASE (4)
1127            KNTIF = KNTIF-1
1128            IF (KNTIF < 0) THEN
1129               SYNERR = .TRUE.
1130               KNTIF = 0
1131            END IF
1132!
1133!   FORMAT statement
1134         CASE (5)
1135            FORM =.TRUE.
1136!
1137!   Beginning of ELSE-block
1138         CASE (6)
1139            IF (KNTIF  >  0) THEN
1140               ELSEBL = .TRUE.
1141            ELSE
1142              SYNERR = .TRUE.
1143            END IF
1144      END SELECT
1145!
1146!   Reformat statements and write
1147   14 CALL REFORM (FORM , ELSEBL)
1148!
1149!   Set variables for next statement
1150      IF (NEWDO) KNTDO = KNTDO+1
1151      IF (NEWIF) KNTIF = KNTIF+1
1152      MXDO = MAX(MXDO , KNTDO)
1153      MXIF = MAX(MXIF , KNTIF)
1154   16 KNTCON = 0
1155      LENST = 0
1156      GO TO   3
1157!
1158!   End of data. Last line must be an END.
1159  100 IF (LABEL == 0) WRITE (NOUT , 1001) FIN, NAME
1160      IF (LABEL /= 0) WRITE (NOUT , 1002) LABEL , FIN, NAME
1161      KNTPU=KNTPU+1
1162      IF (INTFL) WRITE (NOUT, '(6X, ''END INTERFACE'')')
1163!
1164!   Note: if there is a syntax error, continued
1165!         statements do not have a trailing &
1166 1000 FORMAT(I5 , A1 , A)
1167 1001 FORMAT(TR6 , A3 ,TR1, A)
1168 1002 FORMAT(I5 , TR1 , A3 ,TR1, A)
1169 1006 FORMAT(TR5 , A1 , A66)
1170!
1171   RETURN
1172   END SUBROUTINE PROGRAM_UNITS
1173   SUBROUTINE REFORM (FORM , ELSEBL)
1174!
1175!   Performs reformatting and output of accepted statements
1176!
1177      USE DATA
1178!
1179      USE STRUCTURE
1180   implicit none
1181!
1182      INTEGER, PARAMETER :: LLIMIT = LEN-(LEN/66-1)*6
1183      CHARACTER(LEN=LEN) :: OUT
1184      CHARACTER(LEN = 1) :: AMP
1185!
1186      LOGICAL, INTENT(IN) :: FORM , ELSEBL
1187!
1188      integer :: ind, ipnt, l6, l2, l3, l4, lout, idepth, kntap, kadd, &
1189                 l5, jpnt
1190!
1191!   If FORMAT statement, do not indent
1192      IF (FORM) GO TO 9
1193!
1194!   Remove the blanks before commas if no character string
1195      IF (BLNKFL .AND. INDEX(STAMNT(:LENST), "'") == 0) THEN
1196         IPNT = 1
1197         DO
1198            IND = INDEX(STAMNT(IPNT:LENST), ' , ')
1199            IF (IND == 0) EXIT
1200            IND = IPNT + IND - 1
1201            STAMNT(IND:IND+2) = ',  '
1202            IPNT = IND + 3
1203         END DO
1204      END IF
1205!
1206!   Reformat indented statement and write. If reformatting causes it
1207!   to exceed LEN characters, it will be copied unchanged.
1208      IDEPTH = MIN(KNTDO+KNTIF , MXDPTH)
1209      IF (IDEPTH == 0 .AND. .NOT.BLNKFL) GO TO  9
1210      IF (ELSEBL) IDEPTH = IDEPTH-1
1211      IPNT = 1
1212      JPNT = 1
1213    1 IF (MOD(IPNT , 66) == 1) THEN
1214         IF (IPNT+65 > LEN) GO TO 9
1215         OUT(IPNT:IPNT+65) = ' '
1216         IPNT = IPNT+IDEPTH*ISHIFT
1217      END IF
1218!
1219!   Find first non-blank character
1220      DO  L2 = JPNT , LENST
1221         IF (STAMNT(L2:L2) /= ' ') GO TO 3
1222      END DO
1223      IF (JPNT == 1) THEN
1224         SYNERR = .TRUE.
1225         GO TO 9
1226      ELSE
1227         GO TO 10
1228      END IF
1229!
1230!   Find first multiple blank (but not in a character string)
1231    3 KNTAP = 0
1232      DO  L3 = L2, LENST-1
1233         IF (STAMNT(L3:L3) == "'") KNTAP = 1-KNTAP
1234         IF (STAMNT(L3:L3+1) == '  ') THEN
1235            IF (KNTAP == 0) GO TO 5
1236            GO TO 9
1237         END IF
1238      END DO
1239      L3 = LENST
1240!
1241!   Have section with no multiple blanks. This can be copied to OUT
1242!   if there is room on the current line. Otherwise cut the
1243!   section after the non-alphanumeric character nearest to the end of
1244!   the line, if one exists.
1245!   An apostrophe and period are considered to be alphanumeric
1246!   characters, in order to hold character strings,
1247!   and real and logical constants together;
1248!   underscores and dollars are so treated to handle common extensions,
1249!   and the ** and // operators and real literal constants are treated.
1250    5 KADD = 0
1251      IF (L3-L2  <=  66-MOD(IPNT , 66)) GO TO  8
1252      DO L4 = 66+L2-MOD(IPNT , 66) , L2 , -1
1253         IF (STAMNT(L4:L4) == ' ') GO TO 7
1254         IF (LGE(STAMNT(L4:L4) , 'A') .AND. LLE(STAMNT(L4:L4) , 'Z'))  &
1255         CYCLE
1256         IF(LGE(STAMNT(L4:L4), '0') .AND.                              &
1257                  LLE(STAMNT(L4:L4), '9')) CYCLE
1258         IF (STAMNT(L4:L4)  ==  "'" .OR.                               &
1259         STAMNT(L4:L4)  ==  '_' .OR. STAMNT(L4:L4)  ==  '$' .OR.       &
1260         STAMNT(L4:L4)  ==  '.') CYCLE
1261         IF (L4 /= LENST) THEN
1262            IF (STAMNT(L4:L4+1)  ==  '**' .OR.                         &
1263                STAMNT(L4:L4+1)  ==  '//' ) CYCLE
1264            IF (L4 /= L2) THEN
1265               IF(LGE(STAMNT(L4+1:L4+1), '0') .AND.                    &
1266                  LLE(STAMNT(L4+1:L4+1), '9')) THEN
1267                  IF (STAMNT(L4-1:L4)  ==  'E+' .OR.                   &
1268                      STAMNT(L4-1:L4)  ==  'e+' .OR.                   &
1269                      STAMNT(L4-1:L4)  ==  'E-' .OR.                   &
1270                      STAMNT(L4-1:L4)  ==  'e-' .OR.                   &
1271                      STAMNT(L4-1:L4)  ==  'D+' .OR.                   &
1272                      STAMNT(L4-1:L4)  ==  'd+' .OR.                   &
1273                      STAMNT(L4-1:L4)  ==  'D-' .OR.                   &
1274                      STAMNT(L4-1:L4)  ==  'd-' ) CYCLE
1275               END IF
1276            END IF
1277         END IF
1278         IF (LGE(STAMNT(L4:L4) , 'a') .AND. LLE(STAMNT(L4:L4) , 'z'))  &
1279         CYCLE
1280         GO TO 7
1281      END DO
1282!
1283!   No break character found
1284      IF (BLNKFL) GO TO 9
1285      L4 = 66-MOD(IPNT , 66)+L2
1286!
1287!   Cut here
1288    7 L3 = L4
1289      KADD = 1
1290    8 LOUT = IPNT+L3-L2
1291      IF (LOUT > LEN) GO TO  9
1292      OUT(IPNT:LOUT) = STAMNT(L2:L3)
1293      IF (L3 == LENST) GO TO 10
1294!
1295!   Set pointers for next section of statement
1296      IPNT = LOUT+1
1297      IF (KADD == 1 .AND. MOD(IPNT , 66) /= 1 .OR. MOD(IPNT , 66)      &
1298       >= 60) IPNT = ((IPNT+65)/66)*66+1
1299      IF (MOD(IPNT , 66) == 0) IPNT = IPNT+1
1300      JPNT = L3+1
1301      IF (KADD == 0) JPNT = JPNT+1
1302      GO TO   1
1303!
1304!   Copied statement (if adding 6 cols. to initial line would cause
1305!   total length to exceed 2640, must start it in col.1)
1306    9 LENST = LEN_TRIM(STAMNT(:LENST))
1307      IF (LENST > 66) THEN
1308         AMP = '&'
1309      ELSE
1310         AMP = ' '
1311      END IF
1312      IF (LABEL /= 0) THEN
1313         WRITE (NOUT , 1003) LABEL , STAMNT(:MIN(LENST, 66)), AMP
1314      ELSE
1315         IF (LENST < LEN-6) THEN
1316            WRITE (NOUT , 1004) STAMNT(:MIN(LENST,66)), AMP
1317         ELSE
1318            WRITE (NOUT , '(A,A1)') STAMNT(:MIN(LENST, 66)), AMP
1319         END IF
1320      END IF
1321      IF (LENST > 66) WRITE (NOUT , 1005)                              &
1322     &('&', STAMNT(66*L6-65:66*L6) , L6 = 2 , (LENST+65)/66)
1323      GO TO  11
1324!
1325!   Write OUT to output unit
1326   10 LOUT = LEN_TRIM(OUT(:LOUT))
1327      IF (LOUT > 66) THEN
1328         AMP = '&'
1329      ELSE
1330         AMP =' '
1331      END IF
1332      IF (LABEL /= 0) THEN
1333         WRITE (NOUT , 1003) LABEL , OUT(:MIN(LOUT, 66)), AMP
1334      ELSE
1335         WRITE (NOUT , 1004) OUT(:MIN(LOUT, 66)), AMP
1336      END IF
1337!
1338!   An & is required in col. 6 if statement has more than 2412
1339!   characters, otherwise total length including cols. 1-6 will
1340!   exceed 2640. Also if making interface blocks, in order to be
1341!   compatible with both old and new source forms.
1342      IF (LOUT > 66) THEN
1343         IF (LOUT > LLIMIT .OR. INTFL) THEN
1344            AMP = '&'
1345         ELSE
1346            AMP = ' '
1347         END IF
1348         WRITE (NOUT , 1005) (AMP , OUT(66*L5-65:66*L5) , L5 = 2 , (   &
1349         LOUT+65)/66)
1350      END IF
1351!
1352!   Write any comments following statement
1353   11 IF (KNTCOM /= 0) THEN
1354         WRITE (NOUT ,'(A72)') (CBUF(72*L5-71:72*L5) , L5 = 1 , KNTCOM)
1355         KNTCOM = 0
1356      END IF
1357!
1358 1003 FORMAT(I5 , TR1, A, A)
1359 1004 FORMAT(TR6, A, A)
1360 1005 FORMAT(TR5 , A , A:'&' )
1361!
1362   RETURN
1363   END SUBROUTINE REFORM
1364   SUBROUTINE SPECIAL(L3, NEXT, BUFFER, NKEY, KEYS, KEYSLC,            &
1365      LK, FOLLOW)
1366!
1367!   Special treatment for peculiar Fortran syntax
1368!
1369      USE STRUCTURE
1370!
1371      USE STATISTICS
1372   implicit none
1373!
1374      INTEGER, PARAMETER :: NUMLEN = 5
1375!
1376      CHARACTER(LEN=*), INTENT(OUT) :: BUFFER
1377      INTEGER, INTENT(IN) :: NKEY
1378      INTEGER, INTENT(IN), dimension(:) :: LK
1379      CHARACTER(LEN=*), INTENT(IN), dimension(:) :: KEYS, KEYSLC
1380      CHARACTER(LEN=32)     :: NAMEOF
1381      CHARACTER(LEN=NUMLEN) :: NUMBER
1382!
1383      INTEGER, INTENT(IN OUT) :: L3, NEXT
1384      LOGICAL, INTENT(IN), dimension(:) :: FOLLOW
1385      LOGICAL :: IFASSIGN
1386      integer ::         ind,        l20, istar, lparen, napos, ndigit,&
1387                 nparen, l10, ilp, isss, limit, name_length
1388!
1389      IFASSIGN = .FALSE.
1390!
1391!  Deal with labelled DO WHILE
1392      IF (L3 == 13) THEN
1393         IND = index(STAMNT(:LENST), 'WHILE')
1394         IF (IND == 0) IND = index(STAMNT(:LENST), 'while')
1395         IF (IND /= 0) THEN
1396            IF(LGE(STAMNT(IND-1:IND-1), '0') .AND.                     &
1397               LLE(STAMNT(IND-1:IND-1), '9'))                          &
1398               STAMNT(IND:IND+5) = ' WHILE'
1399         END IF
1400         GO TO 99
1401      END IF
1402!
1403!   Deal with IMPLICIT with non-standard length specifiers
1404      IF (L3  ==  25) THEN
1405         IF (index(STAMNT(:LENST), '*')  /=  0) THEN
1406!
1407!   first, CHARACTER*(len)
1408   11       IND = index(STAMNT(:LENST), 'CHARACTER *  (')
1409            IF (IND  ==  0) IND = index(STAMNT(:LENST),'character *  (')
1410            IF (IND /=  0) THEN
1411               STAMNT(IND+10:IND+10) = ' '
1412               GO TO 11
1413            END IF
1414!
1415!   then, type*nn
1416            NPAREN = 0
1417            NAPOS = 0
1418            DO L10 = 15, LENST
1419               IF (STAMNT(L10:L10)  ==  "'") THEN
1420                  NAPOS = 1 - NAPOS
1421               ELSE IF (STAMNT(L10:L10)  ==  '(') THEN
1422                  IF (NAPOS  ==  0) NPAREN = NPAREN + 1
1423               ELSE IF (STAMNT(L10:L10)  ==  ')') THEN
1424                  IF (NAPOS  ==  0) NPAREN = NPAREN - 1
1425               ELSE IF (STAMNT(L10:L10)  ==  '*') THEN
1426                  IF (NPAREN  ==  0) THEN
1427                     STAMNT(L10:L10+1) = ' ('
1428                     ILP = index(STAMNT(L10+2:LENST), '(')
1429                     IF (ILP  ==  0) THEN
1430                        SYNERR = .TRUE.
1431                        GO TO 99
1432                     ELSE
1433                        STAMNT(L10+ILP:L10+ILP) = ')'
1434                     END IF
1435                     IF (STAMNT(L10+1:L10+3)  ==  '(4)') THEN
1436                        IF (STAMNT(L10-5:L10-5)  /=  'C' .AND.         &
1437                            STAMNT(L10-5:L10-5)  /=  'c')              &
1438                            STAMNT(L10+1:L10+3) = '   '
1439                     ELSE IF (STAMNT(L10-2:L10+3)  ==  'X  (8)' .OR.   &
1440                             STAMNT(L10-2:L10+3)  ==  'x  (8)')THEN
1441                        STAMNT(L10+1:L10+3) = '   '
1442                     END IF
1443
1444                  END IF
1445               END IF
1446            END DO
1447         END IF
1448         GO TO 99
1449      END IF
1450!
1451!   An ASSIGN label must be followed by a blank and a * specifier
1452!   converted to (...)
1453      IF(L3 == 1 .AND. STAMNT(:7 )  ==  'ASSIGN '     .OR.             &
1454         L3 == 5 .AND. STAMNT(:11)  ==  'CHARACTER *' .OR.             &
1455         L3 == 8 .AND. STAMNT(:9 )  ==  'COMPLEX *'   .OR.             &
1456         L3 == 27.AND. STAMNT(:9 )  ==  'INTEGER *'   .OR.             &
1457         L3 == 29.AND. STAMNT(:9 )  ==  'LOGICAL *'   .OR.             &
1458         L3 == 36.AND. STAMNT(:6 )  ==  'REAL *'          ) THEN
1459         IF (L3 < 8) THEN
1460            ISSS = L3+7
1461         ELSE IF (L3 < 30) THEN
1462            ISSS = 10
1463         ELSE
1464            ISSS = 7
1465         END IF
1466!
1467!   Extract the length parameter
1468         NDIGIT = 1
1469         NUMBER = '  '
1470         DO L20 = ISSS, LENST
1471            IF(STAMNT(L20:L20)  ==  ' ') CYCLE
1472            NUMBER(:1) = STAMNT(L20:L20)
1473            IF(LGE(STAMNT(L20:L20),'0') .AND. LLE(STAMNT(L20:L20),'9') &
1474            ) GO TO 21
1475            GO TO 1
1476         END DO
1477         SYNERR = .TRUE.
1478         GO TO 99
1479   21    DO NEXT = L20+1, LENST
1480            IF(STAMNT(NEXT:NEXT)  ==  ' ') CYCLE
1481            IF(LLT(STAMNT(NEXT:NEXT), '0') .OR. LGT(STAMNT(NEXT:NEXT), &
1482            '9')) GO TO 19
1483            NDIGIT = NDIGIT + 1
1484            IF (NDIGIT  >  NUMLEN) THEN
1485               SYNERR = .TRUE.
1486               GO TO 99
1487            END IF
1488            NUMBER(NDIGIT:NDIGIT) = STAMNT(NEXT:NEXT)
1489         END DO
1490         SYNERR = .TRUE.
1491         GO TO 99
1492      END IF
1493      GO TO 1
1494!
1495!   Insert the blank or parentheses
1496   19 IF (LENST >= LEN-1) THEN
1497         OVFLW = .TRUE.
1498         GO TO 99
1499      END IF
1500      BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
1501      IF (L3 == 1) THEN
1502         LENST = LENST+2
1503         STAMNT(NEXT:NEXT+3) = ' TO '
1504         STAMNT(NEXT+4:LENST) = BUFFER(NEXT+2:LENST-2)
1505      ELSE
1506         LENST = LENST+1
1507         STAMNT(NEXT:NEXT) = ' '
1508         STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
1509         IF (L3 /= 5.AND. NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '4') THEN
1510            STAMNT(NEXT-4:NEXT-1) = '    '
1511         ELSE IF (L3 == 8.AND.NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '8') &
1512         THEN
1513            STAMNT(NEXT-4:NEXT-1) = '    '
1514         ELSE
1515            STAMNT(NEXT-3-NDIGIT:NEXT-1) = '('//NUMBER(:NDIGIT)//')'
1516         END IF
1517      END IF
1518      GO TO 2
1519!
1520!   Handle (*) case
1521    1 IF(L3 == 5 .AND. STAMNT(:18)  ==  'CHARACTER *  ( * )') THEN
1522         NEXT = 19
1523         STAMNT(11:11) = ' '
1524      END IF
1525!
1526!   IF statement may be followed by a keyword
1527    2 IF (L3  ==  24 ) THEN
1528         LPAREN = 1
1529         NAPOS = 0
1530         DO NEXT = 5, LENST
1531            IF (STAMNT(NEXT:NEXT)  ==  "'") NAPOS = 1 - NAPOS
1532            IF (NAPOS  ==  1) CYCLE
1533            IF (STAMNT(NEXT:NEXT)  ==  '(' ) LPAREN = LPAREN+1
1534            IF (STAMNT(NEXT:NEXT)  ==  ')' ) LPAREN = LPAREN-1
1535            IF (LPAREN  ==  0) GO TO 5
1536         END DO
1537         GO TO 99
1538    5    NEXT = NEXT+1
1539         DO L3 = 1, NKEY
1540            IF (FOLLOW(L3) .AND.(STAMNT(NEXT+1:NEXT+LK(L3)) == KEYS(L3)&
1541                          .OR. STAMNT(NEXT+1:NEXT+LK(L3)) == KEYSLC(L3)&
1542             )) THEN
1543               NEXT = NEXT+LK(L3)+1
1544               IF(L3 == 1) IFASSIGN = .TRUE.
1545               GO TO 9
1546            END IF
1547         END DO
1548      ELSE
1549!
1550! Typed function
1551         IF(STAMNT(NEXT+1:NEXT+8)  ==  'FUNCTION'  .OR.                &
1552            STAMNT(NEXT+1:NEXT+8)  ==  'function') THEN
1553            NEXT = NEXT+9
1554            call name_of(nameof, stamnt(next:lenst), name_length)
1555            NAME = 'FUNCTION'//NAMEOF(:name_length)
1556            L3 = 22
1557!
1558!   Deal with any *
1559            LIMIT = index(STAMNT(:LENST), '(')
1560            IF (LIMIT /= 0) THEN
1561               ISTAR = index(STAMNT(:LIMIT), '*')
1562               IF (ISTAR  /=  0) THEN
1563                  NDIGIT = LIMIT - ISTAR -3
1564                  IF (NDIGIT  >  NUMLEN) THEN
1565                     SYNERR = .TRUE.
1566                     GO TO 99
1567                  END IF
1568                  NUMBER(:NDIGIT) = STAMNT(ISTAR+2:LIMIT-2)
1569                  STAMNT(NEXT-5+NDIGIT:LIMIT-2) =                      &
1570                                      'FUNCTION'//NAME(10:ISTAR-NEXT+8)
1571                  STAMNT(NEXT-8:NEXT-6+NDIGIT)  =                      &
1572                                      '('//NUMBER(:NDIGIT)//') '
1573                  IF (NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '4') THEN
1574                     STAMNT(NEXT-8:NEXT-5) = '    '
1575                  ELSE IF (NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '8'.AND.&
1576                     (STAMNT(7:7) == 'X'.OR.STAMNT(7:7) == 'x')) THEN
1577                     STAMNT(NEXT-8:NEXT-5) = '    '
1578                  END IF
1579                  NEXT = NEXT + 3 + NDIGIT
1580               END IF
1581            ELSE
1582               SYNERR = .TRUE.
1583               GO TO 99
1584            END IF
1585            GO TO 9
1586         END IF
1587      END IF
1588      GO TO 99
1589!
1590!   Insert the blank
1591    9 IF (LENST >= LEN-2) THEN
1592         OVFLW = .TRUE.
1593         GO TO 99
1594      END IF
1595      BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
1596      LENST = LENST+1
1597      STAMNT(NEXT:NEXT) = ' '
1598      STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
1599!
1600!   ASSIGN may follow IF
1601      IF(.NOT.IFASSIGN) GO TO 99
1602      NEXT = index(STAMNT(:LENST), 'TO')
1603      IF (NEXT == 0) NEXT = index(STAMNT(:LENST), 'to')
1604      IF(NEXT == 0) THEN
1605         SYNERR = .TRUE.
1606         GO TO 99
1607      ELSE
1608         LENST = LENST+2
1609         STAMNT(NEXT:NEXT+3) = ' TO '
1610         STAMNT(NEXT+4:LENST) = BUFFER(NEXT+1:LENST-3)
1611      END IF
161299 RETURN
1613   END SUBROUTINE SPECIAL
1614   SUBROUTINE START( )
1615!
1616!   To prepare for PROGRAM_UNITS
1617!
1618      USE DATA
1619   implicit none
1620      CHARACTER(LEN=16) :: NAME
1621!
1622!   Prompt for interactive use
1623      WRITE (*,'(" Type name of file, shift, max. indent level, T or F &
1624        &for blank treatment,",/ " T or F for interface blocks only.")')
1625      WRITE (*,'(" For simple use type only the name of the file ",    &
1626            &"followed by a slash (/) and RETURN.",/                   &
1627            &" Note that the name should be given WITHOUT extension!")')
1628!
1629!   Does standard input unit contain an input record
1630      NIN = 11
1631      NOUT = 12
1632      ISHIFT = 0
1633      MXDPTH = 0
1634      BLANKS = .FALSE.
1635      INTBFL = .FALSE.
1636      READ (* , * , END = 1 , ERR = 1) NAME, ISHIFT , MXDPTH ,         &
1637      BLANKS, INTBFL
1638!
1639!   If record present, check input values are reasonable
1640      ISHIFT = MIN(MAX(ISHIFT , 0) , 10)
1641      MXDPTH = MIN(MAX(MXDPTH , 0) , 36/MAX(ISHIFT,1))
1642      IF (INTBFL.AND..NOT.BLANKS) WRITE (*, '('' Interface block proces&
1643     &sing cancelled as blank processing not requested'')')
1644      INTBFL = BLANKS.AND.INTBFL
1645      GO TO  2
1646!
1647!   Set default values
1648    1 ISHIFT = 3
1649      MXDPTH = 10
1650      BLANKS = .TRUE.
1651      INTBFL = .FALSE.
1652      NAME = 'name'
1653    2 OPEN (UNIT=NIN, FILE=TRIM(NAME)//'.f', ACTION='READ')
1654      OPEN (UNIT=NOUT, FILE=TRIM(NAME)//'.f90', ACTION='WRITE')
1655!
1656!   Print values to be used
1657      Write (*,'(" Loop bodies will be indented by",I3/                &
1658     &           " Maximum indenting level is     ",I3)')              &
1659              ISHIFT , MXDPTH
1660      IF (BLANKS) WRITE (*,                                            &
1661      '(" Significant blank proccessing requested")')
1662      IF (INTBFL) WRITE (*,                                            &
1663      '('' Only interface blocks will be produced'')')
1664      IF (INTBFL) WRITE (NOUT, '(6X, ''INTERFACE'')')
1665!
1666      CALL SYSTEM_CLOCK(TIME0)
1667      RETURN
1668   END SUBROUTINE START
1669   SUBROUTINE TERMINATE( )
1670!
1671!   To print the final summary
1672!
1673      USE STATISTICS
1674      USE DATA
1675   implicit none
1676!
1677      integer :: itick, itime
1678!
1679      CALL SYSTEM_CLOCK(ITIME, ITICK)
1680      IF (ITICK /= 0)                                                  &
1681      WRITE (*,'(" Processing complete in ", F7.3, " seconds")')       &
1682            REAL(ITIME-TIME0)/REAL(ITICK)
1683      WRITE (*,'(" Maximum depth of DO-loop nesting ",I3/              &
1684     &           " Maximum depth of IF-block nesting",I3/              &
1685     &" No. of lines read  ",I17/" No. of program units read   ",I8/   &
1686     &           " Global syntax error flag",L12)')                    &
1687                MXDO , MXIF , KARD , KNTPU , SYNTAX
1688!
1689      IF (OVFLW) WRITE(*,  '(" At least one statement was too long to h&
1690     &ave a necessary blank added")')
1691      IF (NONSTD) WRITE (*,  '(" At least one statement began with a no&
1692     &n-standard keyword")')
1693!
1694    RETURN
1695    END SUBROUTINE TERMINATE
1696   END MODULE ALL_PROCEDURES
1697   PROGRAM CONVERT
1698   USE ALL_PROCEDURES
1699   implicit none
1700!
1701!   Initialize
1702      CALL START( )
1703!
1704!   Process the lines of program units
1705      CALL PROGRAM_UNITS( )
1706!
1707!   Print some statistics
1708      CALL TERMINATE( )
1709      STOP
1710   END PROGRAM CONVERT
Note: See TracBrowser for help on using the repository browser.