Context Navigation

convert.f90

Last change on this file was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 58.3 KB

Rev	Line
[2759]	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 INTEGER2 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	!
	308	99 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	!
	543	99 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(72L5-71:72L5) , 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(72KNTCOM-71:72KNTCOM) = 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(72KNTCOM-71:72KNTCOM) = &
	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(66L9-65:66L9) , L9 = 1 , (LENST+65)/66)
	991	ELSE
	992	WRITE (NOUT , '(6X, A66:"&"/(5X, "&", A66:"&" &
	993	& ))') (STAMNT(66L9-65:66L9) , 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(66L6-65:66L6) , 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(66L5-65:66L5) , 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(72L5-71:72L5) , 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
	1612	99 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.

Download in other formats:

Original Format