#! /usr/bin/perl
# This script enforces some coding rules on a single Fortran module or a collection of modules from a 
# specific subdirectory or, from current directory and all Src_* subdirectories.

# Copyright (C) 2001-2005 ABINIT group (LSi)
# This file is distributed under the terms of the
# GNU General Public License, see ~ABINIT/Infos/copyright
# or http://www.gnu.org/copyleft/gpl.txt .
# For the initials of contributors, see ~ABINIT/Infos/contributors .

# NOTE : under Unix, an abirules script will be automatically generated by 
# the command  make perl  in the ~ABINIT directory.
#
# USAGE :
# unix shell: abirules [-l] [-p] [-r] [-v] [-d subdirectory | sourcefile]
# Windows DOS box: [perl] abirules.pl [-l] [-p] [-r] [-v] [-d subdirectory | sourcefile]
# Options:
# -l	reorder variables declarations line by line (dcl on different lines won't be merged, nor reordered)
# -p	original source files will be preserved; new files with .abirule
# suffix will be written into same subdirectory
# -r	don't reorder variables declarations
# -v	verbose mode
# -d	handle files in subdirectory instead of all files in Src_*
#
$, = ' ';               # set output field separator
$\ = "\n";              # set output record separator

# list of supported file types and corresponding file suffixes:
%Fsufix = ('Fortran','.F90'	
#	,'C','.c'							# a future enhancement might include C files
	);		
@Ftypes = keys(%Fsufix);	# list of file types only
#
@Modules = values(%Fsufix);	# modules list defaults to suffixes list
@SourceDirs = <. Src_*>;	# directories list defaults to all source subdirs
$FirstLine = "!{\\src2tex{textfont=tt}}\n";	# very first line of each source file
# Robodoc definitions
$RobodocBegin = '!!****';	# Robodoc begin marker
$RobodocModule = 'm*';	# header type for module
$RobodocProgram = 'p*';	# header type for module
$RobodocFunction = 'f*';	# header type for function
$RobodocInterFun = 'if*';	# header type for internal function
$ProjectABI = 'ABINIT/';		# project identifier in first line
# required items in the specified order:
@RobodocRequ = ('NAME','FUNCTION','COPYRIGHT','INPUTS','OUTPUT','SOURCE');
@RobodocOpts = ('SIDE','NOTES','WARNINGS','TODO','BUGS','PARENTS','CHILDREN');	# optional items
$RobodocLast = '!!***';		# should be last line of each source file
# required items at the begininning of the SOURCE section:
@SourceBegin1 = ('ProgModSubFunc','use','implicit');		# statement name
@SourceBegin2 = ('*','defs_basis','none');		# statement option
$NoRules = '!no_abirules';	# directive to suspend variables lists processing
# The following string is used for sorting variables types in the order:
# 	Integer,Real,Complex,Logical,Character,Type()
# ans restoring the original type after sort.
$typeSort = 'irclct';
# Having the same initial as complex, character deserves a special treatment:
$charSort = 4;
$debug = 0;			# verbose mode defaults to off
$byLine = 0;	# default is merge and reorder all similar declarations
$reorder = 1;	# default is reorder variables declarations
$preserve = 0;	# default is modify source files
# analyze options and parameters
$CurARG = 0;
while (1) {
	if ($ARGV[$CurARG] eq '-l') {
		$byLine = 1;	# reorder declarations one line at a time, without merging/reordering lines
		$CurARG++;
		next;
		}
	if ($ARGV[$CurARG] eq '-v') {
#	$debug = 1;	# verbose mode on
	 $debug = 2;	# intensive debugging mode
		$CurARG++;
		next;
		}
	if ($ARGV[$CurARG] eq '-r') {
		$reorder = 0;	# don't reorder variables
		$CurARG++;
		next;
		}
	if ($ARGV[$CurARG] eq '-p') {
		$preserve = 1;	# leave original source files unchanged
		print 'Source files will be kept unchanged' if ($debug > 0);
		$CurARG ++;
		next;
		}
	last;
	}
if ($ARGV[$CurARG] eq '-d') {	# check if -d subdir
	if (! -d $ARGV[$CurARG+1]) {
		print "Error, directory $ARGV[$CurARG+1] not found";
		exit 16;
		}	
	@SourceDirs = ($ARGV[$CurARG+1]);	# sources subdirectory
	$CurARG += 2;
	}
elsif ($ARGV[$CurARG] ne '') {
	$fname = $ARGV[$CurARG];
	$dotx = index($fname,'.');
	$suffix = substr($fname,$dotx);	# get file suffix
 	while (($ftyp,$fsfx) = each(%Fsufix)) {
		$filetyp = $ftyp if ($suffix eq $fsfx);
		}
	if ($filetyp eq '') {
		print "Unrecognized suffix for file $fname";
		exit 12;
		}
	if (! -e $fname) {
		print "Error, file $fname not found";
		exit 16;
		}
	@Modules = ($fname);	# single module file
	%ModTypes = ($fname,$filetyp);
	@SourceDirs = ();	# empty directories list
	$CurARG ++;
	}
if ($ARGV[$CurARG] ne '') {
	print "Unexpected argument: $ARGV[$CurARG]";
	exit 8;
	}
#
print "Analyzing modules @Modules in directories @SourceDirs";
# build modules list
foreach $dir (@SourceDirs) {
	foreach $ftyp (@Ftypes) {
		if (! -d $dir) {
			print "Skipping $dir, not a directory" if ($debug > 0);
			next;
			}
		print "Searching $dir for $ftyp modules" if ($debug > 0);
		@Files = (<${dir}/*${Fsufix{$ftyp}}> );
		foreach $fname (@Files) {
			%ModTypes = (%ModTypes,
			$fname,$ftyp);
			}
		}
	}
#
if ($debug > 0) {	# print modules list
	foreach $filetyp (@Ftypes) {
		@Files = ();
		while (($fname,$ftype) = each (%ModTypes)) {
			@Files = (@Files,$fname) if ($ftype eq $filetyp);
			}
		print "$filetyp modules:",@Files;
		}
	}
# get current year for copyright
($sec,$min,$hour,$mday,$ymon,$yyear,$wday,$yday,$isdst)=localtime(time);
$yyear +=1900;	# yyear was relative to 1900
# for each module, read the source file and find the Robodoc section
foreach $fname (keys(%ModTypes)) {
	$rc = open(FILEIN,"<$fname");
	if ($rc eq '') {
		print "Unable to open file $fname, error $rc";
		exit 64;
		}
  print "\nChecking rules in module $fname" if ($debug > 0);
#
	open(FILEOUT,">$fname.abirules") || die "Unable to open FILEOUT";
# pick file name in path
	$ix = index($fname,'/');
	$modname = $ix >= 0 ? substr($fname,$ix+1) : $fname;
	$dotx = index($modname,'.');
	$modname = substr($modname,0,$dotx);	# suppress suffix
	$added = ' ';		# list of added items
	$replc = '';		# replaced item(s)
	$repchar = '';	# replaced character
	$repcont = '';	# replaced continue
	$repend = '';		# replaced end
# read the source file
  $linect = 0;		# line counter
	$phase = 0;		# phase number 0 to 6
	$ProgLvl = 0;	# program/subroutine level
	$cppif = 0;		# flag for preprocessor if block
	$suspend = 0;		# flag for suspending variables lists processing
	$DEBUGblk = 0;	# flag for DEBUG block
	$CopyR = 0;		# flag for single copyright
	$ModIntFc = 0;	# flag for interface within a Fortran module
	$assumeFun = 0;	# function assumed if first line of header	is missing
	READLOOP:
	while ($line = <FILEIN>) {
# Phase 0: make sure src2tex directive is ahead
		$len = length($line);
		$linect ++;
		if ($phase == 0) {
			$len1 = length($FirstLine);
			&WriteLine($FirstLine,$len1);		# always write src2tex directive
			$phase = 1;
			next if ($line eq $FirstLine);		# read next line if expected directive
			print 'Inserting src2tex directive ahead' if ($debug > 1);
			$added = ' src2tex ';
			}
		($wd1,$wd2,$wd3,$wd4,$wd5,$wd6,$wd7,$wd8,$wd9,$wd10,$wd11,$wd12,$wd13,$wd14,$wd15) = split(' ',$line);
# Phase 1: make sure Robodoc module header follows
		if ($phase == 1) {
			$wd1head = substr($wd1,0,6);
			$phase = 2;
			$itemNum = 0;
			$section = '';
			$saveline = '';
			$EndRobodoc = 0;	# flag for end of Robodoc header
			if ($wd1head eq $RobodocBegin) {
				$hdrtyp = substr($wd1,6);
# check project
				$ix = index($wd2,'/');
				if($ix > 0) {
					$pjct = substr($wd2,0,$ix+1);		# get what should be the project name
					$sub = substr($wd2,$ix+1);	# get what should be the subroutine/module name
					print "Robodoc header $hdrtyp $pjct $sub begins at line $linect" if ($debug > 1);
					}
				else {
					$pjct = '';
					$sub = '';
					}
				if ($hdrtyp eq $RobodocModule || $hdrtyp eq $RobodocProgram || $hdrtyp eq $RobodocFunction) {
# starting header for program, module or stand-alone function, check name
					if ( $sub ne $modname ) {
						print "Warning: found \'$sub\' instead of module name in first header line" if ($debug > 0);
						}
					$subname = $sub ne '' ? $sub : $modname;	# use module or sub name
					if ($pjct ne $ProjectABI ) {
						print "Warning: found \'$pjct\' as project name in first header line" if ($debug > 0);
						$line1 = "$RobodocBegin$hdrtyp $ProjectABI$subname\n";	# correct...
						$len1 = length($line1);
						&WriteLine($line1,$len1);		# ...first line of header and write it
						$replc .= 'Project ';
	  				next;		# ignore wrong line
						}
					}
				if ($hdrtyp eq $RobodocInterFun) {
					if ($sub eq $modname) {
						print "Warning: found \'$sub\' as internal subroutine name same as module " if ($debug > 0);
						}
					$subname = $sub;	# use name from first header line
					}
				}
			else {
				if ($ModIntFc == 0) {
					if ($wd1 eq 'subroutine' || $wd1 eq 'function') {
# subroutine found instead of header outside an interface; drop subroutine (arguments
						$ix = index($wd2,'(');
						$subname = $ix > 0 ? substr($wd2,0,$ix) : $wd2;
						$hdrtyp = $RobodocInterFun;
						$FunType = ' internal';
						}
					else {
						$subname = $modname;
						$assumeFun = 1;
						$hdrtyp = $RobodocFunction;
						$FunType = '';
						}
					$line1 = "$RobodocBegin$hdrtyp $ProjectABI$subname\n";	# build first line of header
					$len1 = length($line1);
					&WriteLine($line1,$len1);		# write first header line if missing, function assumed
					print "Missing first line of header has been inserted assuming:$FunType function $subname" if ($debug > 0);
					$added .= $hdrtyp;
					}
				}
			}
# Phase 2: check the presence of defined Robodoc sections
		$wd1char1 = substr($wd1,0,1);
		if ($phase == 2) {
			if ($wd1 ne '' && $wd1char1 ne '!') {
# save current line and insert SOURCE
				print "Found \'$wd1 $wd2\' at line $linect while expecting $RobodocRequ[$itemNum]; SOURCE inserted" if ($debug > 0);
			  $saveline = $line;
				$savelen = $len;
				$line = "!! SOURCE\n";
				$len = length($line);
				$wd1 = '!!';
				$wd2 = 'SOURCE';
				}
			if ($wd1 eq '!!') {
				if ($section eq 'NAME') {	# check subroutine name
					$line1 = "!! $subname\n";
					$len1 = length($line1);
					&WriteLine($line1,$len1);		# write subroutine name
					$section = '';
					next if ($wd2 eq $subname);		# skip if expected name
					print "Warning: found \'$wd2\' instead of $subname in subroutine NAME section" if ($debug > 0);
					$replc .= 'Name ';
					($item = $wd2) =~ tr/a-z/A-Z/;	# copy, then translate lowercase to uppercase
					next if ($item ne $wd2);		# ignore line if no Robodoc section name
					}
				if ($section eq 'COPYRIGHT' && $wd2 eq 'Copyright' && $wd3 eq '(C)') { # check current year
					$len2 = length($wd4);
					$wd4tail = substr($wd4,-4,4);	# $wd4 should be yyyy or yyy1-yyy2
					$wd4ix = index($line,$wd4);
					$line1 = $line;
					if ($wd4tail ne $yyear) {
						if ($len2 == 4) {
							substr($line1,$wd4ix,4) = $wd4.'-'.$yyear;
							}
						elsif ($len2 == 9) {
							substr($line1,$wd4ix+4,5) = '-'.$yyear;
							}
						else {
							print "Copyright year format error: $wd4";
							}
						}
					$section = '';
					if ($line1 ne $line) {
						$len1 = length($line1);
						&WriteLine($line1,$len1);		# write Copyright line
						print "Copyright year $wd4 has been corrected" if ($debug > 1);
						$replc .= 'CopyYear ';
						next;		# ignore wrong line
						}
					$CopyR = 1;		# set Copyrignt found
					}
				($item = $wd2) =~ tr/a-z/A-Z/;	# copy, then translate lowercase to uppercase
				if ($item eq $wd2) {		# was already uppercased ?
					if ($wd2 eq $RobodocRequ[$itemNum]) {	# expected section ?
						print "Found $wd2 item at line $linect" if ($debug > 1);
						if ($wd2 eq 'SOURCE') {
							$phase = 3;		# phase 3: read source
							$itemNum = 0;
							}
						else {
							$section = $wd2;
							$itemNum ++;
							}
						}
					elsif ($RobodocRequ[$itemNum] eq 'SOURCE') {	# check for optional section preceding SOURCE
						for ($ix = 0; $ix <= $#RobodocOpts; $ix ++) {
							if ($wd2 eq $RobodocOpts[$ix]) {
								print "Found optional item $wd2 at line $linect" if ($debug > 1);
								$section = $wd2;
								last;
								}
							}
						}
					else {		# check for misplaced required section
						for ($ix = 0; $ix <= $#RobodocRequ; $ix ++) {
							last if ($wd2 eq $RobodocRequ[$ix]);
							}
						if ($ix <= $#RobodocRequ) {
							print "Warning, expecting item $RobodocRequ[$itemNum], found $wd2 at line $linect" if ($debug > 1);
							if ($ix < $itemNum) {
								print "Duplicate section $wd2 skipped" if ($debug > 0);
								next;
								}
							else {
	# write missing sections
								for ($iy = $itemNum ; $iy < $ix; $iy ++) {
									$sectype = 'dummy';
									$line1 = "!! $RobodocRequ[$iy]\n";	# Robodoc section name
									$len1 = length($line1);
									if ($RobodocRequ[$iy] eq 'COPYRIGHT') {
										if ($CopyR == 0) {
											&WriteLine($line1,$len1);		# write section name
											$line1 = "!! Copyright (C) $yyear ABINIT group ( ).\n";	# initials left blank
											$len1 = length($line1);
											&WriteLine($line1,$len1);		# write copyright line 1
											$line1 = "!! This file is distributed under the terms of the\n";
											$len1 = length($line1);
											&WriteLine($line1,$len1);		# write copyright line 2
											$line1 = "!! GNU General Public License, see ~ABINIT/Infos/copyright\n";
											$len1 = length($line1);
											&WriteLine($line1,$len1);		# write copyright line 3
											$line1 = "!! or http://www.gnu.org/copyleft/gpl.txt .\n";
											$len1 = length($line1);
											&WriteLine($line1,$len1);		# write copyright line 4
											$line1 = "!! For the initials of contributors, see ~ABINIT/Infos/contributors .\n";
											$len1 = length($line1);
											&WriteLine($line1,$len1);		# write copyright line 5
											$sectype = '';
											$CopyR = 1;
											}
										else {
											$sectype = 'skip';
											print 'COPYRIGHT item will only be written once';
											}
										}
									else {
										&WriteLine($line1,$len1);		# write section name
										if ($RobodocRequ[$iy] eq 'NAME') {
											$line1 = "!! $subname\n";
											$len1 = length($line1);
											&WriteLine($line1,$len1);		# write subroutine name
											$sectype = '';
											}
										}
									if ($sectype ne 'skip') {
										$line1 = "!!\n";
										$len1 = length($line1);
										&WriteLine($line1,$len1);		# write robodoc empty line
										print "Wrote $sectype $RobodocRequ[$iy] section" if ($debug > 0);
										$added .= $RobodocRequ[$iy].' ';
										}
									}	# end for $iy							
								if ($wd2 eq 'SOURCE') {
									if ($saveline ne '') {
									  &WriteLine($line,$len) ;	# write SOURCE
										$line = $saveline;		# restore saved line
										$len = $savelen;	
										($wd1,$wd2,$wd3,$wd4,$wd5,$wd6,$wd7,$wd8,$wd9,$wd10,$wd11,$wd12,$wd13,$wd14,$wd15) = split(' ',$line);
										$saveline = '';
										}
									$phase = 3;		# phase 3: read source
									$itemNum = 0;
									}
								else {
									$section = $wd2;
									$itemNum = $ix + 1;
									}
								}
							}
						}
					}
				}
			}
# end of phase 2 processing
# phases 3 and subsequent: check Robodoc last line
		if ($phase >= 3) {
			if ($wd1 eq "$RobodocBegin$RobodocInterFun" || $wd1 eq "$RobodocBegin$RobodocFunction") {
# internal function header type has been found, prepare to process it
# check project
				$ix = index($wd2,'/');
				$pjct = substr($wd2,0,$ix+1) if($ix > 0);	# get what should be the project name
				$subname = substr($wd2,$ix+1);	# get the subroutine/module name
				if ($pjct ne $ProjectABI) {
					print "Warning: project name \'$pjct\' found in header" if ($debug > 0);
					}
				print "Header with (internal) function type found at line $linect, sub= $subname" if ($debug >= 2);
				print "Warning ! Function header begins in the middle of an interface section" if ($ModIntFc == 1 && $debug > 0);
				if ($EndRobodoc == 0) {
					print "Writing Robodoc fence before header, line $linect" if ($debug > 1);
					&WriteLine("$RobodocLast\n",6);		# insert Robodoc fence if missing
					$added .= '*** ';
					}
				$phase = 2;
				$EndRobodoc = 0;
				$ProgLvl = 0;	# reset program/subroutine level
				$cppif = 0;		# flag for preprocessor if block
				$suspend = 0;		# flag for suspending variables lists processing
				$DEBUGblk = 0;	# flag for DEBUG block
				$itemNum = 0;
				$section = '';
				}
			elsif ($EndRobodoc == 1) {
				print "Warning: unexpected source line follows Robodoc fence in file $fname, line $linect";
				$EndRobodoc = 2;	# to print above error message only once
				}
# turn flag on if Robodoc last line was found
			if ($EndRobodoc == 0 && $wd1 eq $RobodocLast) {
				print "Robodoc fence encountered at line $linect" if ($debug > 1);
				$EndRobodoc = 1;
				$phase = 1;		# search for a possible following robodoc header if
				}
			}
		$char1 = substr($line,0,1);
		$wd2head = substr($wd2,0,9);
		if ($phase == 3) {
# phase 3: process SOURCE section
# handle cpp directives - identify #if - #endif blocks
  		if ($char1 eq '#') {
				if ($wd1 eq '#if' || ($wd1 eq '#' && $wd2 eq 'if')) {
					$cppif ++;		# remember cpp if-block
					if ($cppif == 1) {
						$saveif = $line;
						$savetell = tell(FILEOUT);	# save for possible backing up
						}
					}
				elsif ($wd1 eq '#endif' || ($wd1 eq '#' && $wd2 eq 'endif')) {
					$cppif --;		# end of cpp if-block
					$saveif = '' if ($cppif == 0);
					}
				}
# check for neither comment, nor cpp directive, nor continuation, nor null line
			elsif ($char1 ne '!' && $char1 ne '&' && $char1 ne "\n" && $wd1 ne '') {	# ignore line
# first line should be program or subroutine definition
				if ($SourceBegin1[$itemNum] eq 'ProgModSubFunc') {
					if ($wd1 eq 'program' || $wd1 eq 'module' || $wd1 eq 'interface' || $wd1 eq 'subroutine' || $wd1 eq 'function') {
					  &HndlProg($wd1,$wd2);
						}
					elsif ( ($wd2 eq 'function') && ($wd1 eq 'integer' || $wd1 eq 'complex' || $wd1 eq 'logical') ){
					  &HndlProg($wd2,$wd3);
						}
					elsif ( ($wd3 eq 'function') && $wd1 eq 'double' && $wd2 eq 'precision') {
					  &HndlProg($wd3,$wd4);
						}
					elsif ( $wd1 eq 'end') {
						$ProgLvl --;
						$ModIntFc = 0 if ( $wd2 eq 'interface' || ( $wd2 eq '' && $ProgType[$ProgLvl] eq 'interface' ) );
						}
					else {
						print "Error: found $wd1 at line $linect while expecting program/subroutine";
						last;
						}
					}
				else {
					for ($ii = 1; $ii <= $#SourceBegin1; $ii ++) {
						if ($wd1 eq $SourceBegin1[$ii] && $wd2 eq $SourceBegin2[$ii]) {
							print "Found $wd1 $wd2 at line $linect - skipped" if ($debug > 1);
							next READLOOP;
							}
						}	# end for $ii
					if ($SourceBegin1[$itemNum] eq 'use' && $wd1 ne 'use') {
						if ($cppif >= 1 && $saveif ne '') {
						  die "Perl ERROR: 0 returned by tell" if ($savetell == 0);
							seek(FILEOUT,$savetell,0);
							print "Backing up to $savetell before #if block" if ($debug > 1);
							}
# implicit MUST be inserted AFTER ALL use and BEFORE the first include EVEN IF THE LATTER IS
# IN A #if-#endif BLOCK
# insert implicit before 1st line that is neither blank, nor use
						print "$SourceBegin1[2] statement inserted before $wd1" if ($debug > 1);
						$line2 = " \n $SourceBegin1[2] $SourceBegin2[2]\n \n";
						$len2 = length($line2);
						&WriteLine($line2,$len2);		# overlay #if with implicit
						if ($cppif >= 1 && $saveif ne '') {
							$len2 = length($saveif);
							&WriteLine($saveif,$len2);	# rewrite #if
							$saveif = '';
							}
						$replc .= $SourceBegin1[2].' ';
						$itemNum ++;
						}
					} # end if $SourceBegin1[$itemNum]
				}	# end if $char1
			elsif ($wd1 eq '') {
				next READLOOP;
				}
			else {
# SOURCE subsections: arguments, local variables, executable
				$wd1hd20 = substr($wd1,0,20);
				if (($wd1 eq '!Arguments' && $wd2head eq '---------') || $wd1hd20 eq '!Arguments----------') {
					if ($SourceBegin1[$itemNum] eq 'use') {
# insert implicit before arguments subsection
						print "$SourceBegin1[2] statement inserted before $wd1hd20" if ($debug > 1);
						$line2 = " \n $SourceBegin1[2] $SourceBegin2[2]\n \n";
						$len2 = length($line2);
						&WriteLine($line2,$len2);
						$replc .= $SourceBegin1[2].' ';
						}
					print "Arguments subsection encountered at line $linect" if ($debug > 1);
					$phase = 4;
					$nodeclar = 0;	# counter for unrecognized declarations
					}
				}
			}	# end of phase 3 processing
		if ($phase == 4) {
# Phase 4: record arguments
			if ($wd1 eq $NoRules) {
				$suspend = 1;		# turn on flag to suspend variables lists processing
				&WriteDefs('arguments') if($byLine == 0);		# write all arguments
				}
			$wd1ch1 = substr($wd1,0,1);
			if ($wd1 eq '!Local' && $wd2head eq 'variables') {
				print "Local variables subsection encountered at line $linect" if ($debug > 1);
				&WriteDefs('arguments') if($byLine == 0);		# write all arguments
				$line2 = " \n";
				&WriteLine($line2,2);
				$phase = 5;
				$suspend = 0;		# make sure flag is off to resume variables lists processing
				$nodeclar = 0;	# counter for unrecognized declarations
				}
			elsif ($char1 ne '!' && $wd1 ne '' && $wd1ch1 ne '!') {	# ignore comments and null lines
				&BuildVarList;	# build list of associated arrays for arguments
				&WriteDefs('arguments') if($byLine == 1);		# write arguments declared in this line
				next;		# skip copy to FILEOUT
				}
			elsif ($wd1 eq '' || $wd1 eq '!scalars' || $wd1 eq '!arrays') {
				next READLOOP;	# skip copy to FILEOUT
				}
			}
# Phase 5: record local variables
		if ($phase == 5) {
			if ($wd1 eq $NoRules) {
				$suspend = 1;		# turn on flag to suspend variables lists processing
				&WriteDefs('local vars') if($byLine == 0);		# write all local variables
				}
			$wd1ch1 = substr($wd1,0,1);
			$wd1head = substr($wd1,0,10);
			if ($wd1head eq '!*********' || $wd1head eq '!Interface' || ($wd1 eq '!' && $wd2head eq '*********')) {
				print "Executable subsection encountered at line $linect" if ($debug > 1);
				&WriteDefs('local vars') if($byLine == 0);		# write all local variables
				$line2 = " \n";
				&WriteLine($line2,2);
				$phase = 6;
				}
			elsif ($char1 ne '!' && $wd1 ne '' && $wd1ch1 ne '!') {	# ignore comments and null lines
				&BuildVarList;	# build list of associated arrays for local variables
				&WriteDefs('local vars') if($byLine == 1);		# write local variables declared in this line
				next;		# skip copy to FILEOUT
				}
			elsif ($wd1 eq '' || $wd1 eq '!scalars' || $wd1 eq '!arrays') {
				next READLOOP;	# skip copy to FILEOUT
				}
			}
# Phase 6:
# a) check DEBUG blocks
		$wd1char1 = substr($wd1,0,1);
		if ($phase == 6) {
			if ($wd1 eq '!DEBUG' || ($wd1 eq '!' && $wd2 eq 'DEBUG') ) {	# test begin of DEBUG block
				$DEBUGblk = $linect;
				}
			elsif ($wd1 eq '!ENDDEBUG' || $wd1 eq '!ENDEBUG' || ($wd1 eq '!' && $wd2 eq 'ENDDEBUG') || ($wd1 eq '!END' && $wd2 eq 'DEBUG') ) {	# test end of DEBUG block
				$DEBUGblk = 0;
				}
			elsif ($DEBUGblk > 0 && $wd1char1 ne '!' && $wd1 ne '') {	# non commented line within DEBUG block ?
				print "Warning ! Uncommented line found at line $linect within DEBUG block";
				$DEBUGblk = 0;	# reset flag to print above message only once
				}
# b) reformat enddo, endif
			if ($char1 ne '!') {
				$line =~ s/enddo/end do/i;
				$line =~ s/endif/end if/i if ($char1 ne "#");
				$len = length($line);
# c) check for goto
				$ix = index ($line,'goto');
				print "Warning ! goto statement found at line $linect" if ($ix >= 0);
				}
# d) record subprogram type and name to check subsequent end statement
			if ($wd1 eq 'subroutine' || $wd1 eq 'interface' || $wd1 eq 'function') {
			  &HndlProg($wd1,$wd2);
				}
			elsif (($wd2 eq 'function') && ($wd1 eq 'integer' || $wd1 eq 'complex' || $wd1 eq 'logical') ){
			  &HndlProg($wd2,$wd3);
				}
			elsif ($wd3 eq 'function' && $wd1 eq 'double' && $wd2 eq 'precision') {
			  &HndlProg($wd3,$wd4);
				}
# e) check end statements
			if ($wd1 eq 'end' && ($wd2 eq 'subroutine' || $wd2 eq 'module' || $wd2 eq 'interface' || $wd2 eq 'function' || $wd2 eq '') ) {
				$ProgLvl --;
				if ($ProgType[$ProgLvl] ne $wd2 || $ProgName[$ProgLvl] ne $wd3) {
					$line = "end $ProgType[$ProgLvl] $ProgName[$ProgLvl]\n";
					$len = length($line);
					$repend = 'end ';
					}
				print "End $ProgType[$ProgLvl] $ProgName[$ProgLvl] level $ProgLvl encountered at line $linect" if ($debug > 1);
				if ($ModIntFc == 1) {		# reset for next subroutine if any
					$itemNum = 0;
					$phase = 3;
					}
				$ModIntFc = 0 if ($ProgType[$ProgLvl] eq 'interface');
				}
# f) record do labels to replace subsequent continue by end do[s]
			if ($wd1 eq 'do' && ($wd2 =~ m/^[0-9]+/) ) {
				if ($LabCnt{$wd2} eq '') {
					$LabCnt{$wd2} = 1;
					}
				else {
					$LabCnt{$wd2} ++;
					}
				$line =~ s/ $wd2 / /;
				$len = length($line);
				}
# g) replace continue statements that terminate a do loop
			if (($wd1 =~ m/[0-9]+/) && $wd2 eq 'continue') {
				if ($LabCnt{$wd1} ne '') {
					for ($ix =0; $ix < $LabCnt{$wd1};$ix ++) {
						&WriteLine("end do\n",7);
						}
					delete $LabCnt{$wd1};
					$repcont = 'continue ';
					next;
					}
				}
			}
# Phases 2 and subsequent: copy line from input file to FILEOUT
		&WriteLine($line,$len);
		}	# end while <FILEIN
# end of file has been hit
# Phase 6: make sure Robodoc last line is present
  if ($phase == 6 && $EndRobodoc == 0) {
		print "Writing Robodoc fence after line $linect" if ($debug > 1);
		&WriteLine("$RobodocLast\n",6);		# insert Robodoc fence at end of file
		$added .= '*** ';
		}
	close (FILEOUT);
	close (FILEIN);
# were all sections and statements encountered ?
  if ($phase < 6) {
		print "ERROR: end of file $fname hit before SOURCE section - $RobodocRequ[$itemNum] was expected" if ($phase == 2);
    if ($phase == 3) {
			if ($itemNum < $#SourceBegin1) {
				print "ERROR: end of file $fname hit before encountering $SourceBegin1[$itemNum]";
				}
			else {
				print "ERROR: end of file $fname hit before encountering Arguments section";
				}
			}
		print "ERROR: end of file $fname hit before encountering Local variables section" if ($phase == 4);
		print "ERROR: delimitor for executable section missing in $fname" if ($phase == 5);
		unlink ("$fname.abirules") if ($debug <= 1);		# remove work file
		%definitions = ();	# clear associative array
    next;		# process next subroutine
    }
# rename files if preserve option (-p) has not been specified
	if ($preserve == 0) {
		unlink ("$fname.old");	# suppress .old file
		$rc = rename($fname,"$fname.old");
		if ($rc != 1) {
			print "Error $! renaming $fname to $fname.old";
			exit 120;
			}
		$rc = rename("$fname.abirules","$fname");
		if ($rc != 1) {
			print "Error $! renaming $fname.abirules to $fname";
			exit 140;
			}
		}
	$replc .= $repchar.$repcont.$repend;
	print "Added:$added; Replaced: $replc" if ($debug >= 1);
	print "Module $fname processing completed";
	print "  phase $phase item $itemNum " if($debug > 1);
	}

exit;
# ***************************
sub BuildVarList {
# Purpose: build definition lists for arguments (phase 4) or local variables (phase 5)
# Common variables: $line,$char1,$wd1,$len,$linect
	if ($reorder == 0 || $suspend == 1) {
		&WriteLine($line,$len);		# copy declaration without processing (no reorder)
		return;
		}
	$linect1 = $linect;
# handle declarations within cpp #if-#endif block
# handle cpp directives - identify #if - #endif blocks
  if ($char1 eq '#') {
		if ($wd1 eq '#if' || ($wd1 eq '#' && $wd2 eq 'if')) {
			$cppif ++;		# remember cpp if-block
			}
		elsif ($wd1 eq '#endif' || ($wd1 eq '#' && $wd2 eq 'endif')) {
			$cppif --;		# end of cpp if-block
			}
		&WriteLine($line,$len);		# copy cpp directive without processing
		return;
		}
# handle declarations within cpp #if-#endif block
	if ($cppif > 0 && $byLine == 0) {
		&WriteLine($line,$len);		# copy declaration without processing (no reorder)
		return;
		}
# handle in-line comments
	$ix = index ($line,'!');
	if ($ix >= 0) {
		$line2 = substr($line,$ix);	 # copy comment
		$len2 = length($line2);
		&WriteLine($line2,$len2);		# write comment here as a separate line
		$line = substr($line,0,$ix)."\n";	# drop comment, append newline
		$len = $ix + 1;
		}
# handle continuations
	while (1) {
		$_ = $line;
		$hit = m/(.*)(&\s*$)/;    # search trailing &
		last if (! $hit);
		$line = $1;     # drop &
		while (1) {
			$line2 = <FILEIN>;
			$linect ++;
			$char2 = substr($line2,0,1);
			last if ($char2 ne '!');
			$len2 = length($line2);
			&WriteLine($line2,$len2);		# write comment line here
			}
		$_ = $line2;
		$hit = m/(^\s*&)(.*$)/;    # search leading &
		$line .= $hit ? $2."\n" : $line2;    # drop &
# handle in-line comments in continuations
		$ix = index ($line,'!');
		if ($ix >= 0) {
			$line2 = substr($line,$ix);	 # copy comment
			$len2 = length($line2);
			&WriteLine($line2,$len2);		# write comment here as a separate line
			$line = substr($line,0,$ix)."\n";	# drop comment, append newline
			}
		$len = length($line);
		}
#
	$_ = $line;
	y/ //d;	# strip blanks off $_
# Replace character(*) statements
	$ix = s/character\(\*\)/character(len=\*)/;
  $iy = $ix;
# Replace character* statements
	if ( /character\*/ ) {
		if ( /character\*\(/ ) {
			$ix = s/character\*\(([^\)]*)\)(.*)/character(len=$1)$2/;
			$iy = $iy +$ix;
			}
		else {
			$ix = s/character\*([0-9]+)(.*)/character(len=$1)$2/;
			$iy = $iy +$ix;
			}
		}
	$repchar = 'character ' if ($iy > 0);
  print "character statement at line $linect1 changed to:$_" if ($iy > 0 && $debug > 1);
	$hit = m/(.*)(::)(.*)/;	# check for general form declaration statement
	if ($hit) {
# general form declaration
# WARNING ! attributes containing commas are not yet supported
		($_,@attrib) = split(',',$1);	# separate type from attributes list
# sort attributes list - declarations with attributes in different order will be merged
		@Attr = sort(@attrib);
# attrSort is a character used for sorting declarations: 1-6 for priority attribute,
# 7 for no attribute, 8-9 for low-priority attribute
		$attrSort = '7';	# no attribute
		foreach $atrb (@Attr) {		# set digit for sorting declarations according to some attribute
			$atr19 = substr($atrb,0,9);
			if ($atr19 eq 'dimension') {	# dimension attribute is not allowed (comma, parenthesis)
				print "Warning ! Dimension attribute found - line $linect1 not processed";
				&WriteLine($line,$len);		# copy declaration without processing (no reorder)
				return;			
				}
			if ($atrb eq 'parameter') {
				$attrSort = '1' ;
				last;
				}
			elsif ($atrb eq 'save') {
				$attrSort = '2' ;
				last;
				}
			elsif ($atrb eq 'allocatable') {
				$attrSort = '8' ;
				}
			else {	# non-priority attribute
				$attrSort = '9' if ($attrSort eq '7');
				}
			}
		$attributes = $attrSort.join(',',@Attr);
		$VarList = $3;
		}
	else { # old fashion declaration
		$attributes = '7';	# no attribute
		$VarList = '';	# remember old fashion
		}
# check type against some patterns
	$hitparam = m/(parameter\()(.*)/i;
	if ($hitparam) {
		print "Warning ! Parameter statement found - line $linect1 not processed";
		&WriteLine($line,$len);		# copy attribute without merging with declaration
		return;			
		}
	$TypeAttr = '';
	$hitchar = m/(character\*?)(.*)/i if ($2 eq '::');	# general form character
	$TypeAttr = $1.$2 if ($hitchar);
	if ($VarList eq '') {		# old fashion character
		$hitchar = m/(character\()(len=.*\))(.*)/i;
		if ($hitchar) {
# WARNING ! $1,$2,$3 are LOCAL to the block
			if ( $3 ne '') {
				$VarList = $3;
				$TypeAttr = $1.$2;
				}
			else {
				print "Warning ! Unable to decode character statement - line $linect1 not processed";
				&WriteLine($line,$len);		# copy statement without processing (no reorder)
				return;			
				}
			}
		}
	$hitint = m/(integer)(\*[24])?(.*)/i;
	$hitdouble = m/(double)(precision)(.*)/i;
	$hitreal4 = m/(real)(\*4)(.*)/i;
	$hitreal8 = $hitreal4 ? 0 : m/(real)(\*8)?(.*)/i;
	$hitrealk = m/(real)(kind\(.*\))(.*)/i;
	$hitrealdp = m/(real)(\(dp\))(.*)/i;
	$hitcplx = m/(complex)(\(cdp\))?(.*)/i;
	$hitcplxk = m/(complex)(kind\(.*\))(.*)/i;
	$hitlogi = m/(logical)(\*[14])?(.*)/i;
	$hittype = m/(type)(\(.*\))(.*)/i;
	if ($hitdouble || $hitreal8) {
		$TypeAttr = 'real(dp)';
		}
	elsif ($TypeAttr eq '') {
		$TypeAttr = $1.$2;
		}
	$type1 = substr($TypeAttr,0,1);		# first letter of type will be repaced ...
	substr($TypeAttr,0,1) = $hitchar ? $charSort : index($typeSort,$type1);	# ... by digit for non-alphabetic sort
	$VarList = $3 if ($VarList eq '');	# old fashion
	if (! ($hitint || $hitreal4 || $hitreal8 || $hitrealk|| $hitdouble || $hitreadldp || $hitcplx || $hitcplxk || $hitchar || $hitlogi || $hittype)) {
# if the lines is longer than 80, try to split it after commas
		if ($len > 80) {
			while (1) {
				$ix = rindex($line,',',80);
				last if ($ix <= 0);
				$line1 = substr($line,0,$ix+1)."&\n";
				$len1 = length($line1);
				&WriteLine($line1,$len1);
				$line = '& '.substr($line,$ix+1);
				$len = length($line);
				}
			}
		&WriteLine($line,$len);
		$nodeclar ++;
		return if ($nodeclar > 10);
		print "Error, at least 10 declarations could not be identified" if ($nodeclar == 10);
		print "Warning ! Unrecognized declaration at line $linect1 around $_" if ($debug >= 1 && $nodeclar < 10);
		return;
		}
# WARNING ! If some variable receives an initial value and the declaration type is character,
# the initial value may have been corrupted when the blanks were stripped off. So, this
# declaration line will be written now to the output as it is, i.e. without continuations
	$ix = index($VarList,'=');
	if ($hitchar && $ix >= 0) {
		print "Warning ! Character string with initial value found at line $linect1" if ($debug >= 1);
		&WriteLine($line,$len);
		return;
		}
# split variables list; pay attention to the comma since it is simultanously variable name
# separator & indices separator in arrays !
	$_ = $VarList;
	$ScalarList = '';
	$ArrayList = '';
Parse:
	while (1) {
		$hit = m/(.+)([=])(.+)/;	# search for initialization value
		if ($hit) {
# WARNING ! multiple parameter arrays declarations in a single statement not yet supported
			$P3char12=substr($3,0,2);
			$P3charnd=substr($3,-2,2);
			if ($P3char12 eq '(/' || $P3charnd eq '/)' ){ 	# array initialization value
				if (length($_) > 80) {
					print "Warning ! Array declaration with value longer than 80 chars was found - line $linect1 may be mishandled";
					}
				$ArrayList .= $_;
				last;			# end of processing
				}				
			$hit = m/(.*)([,])(.+)/;	# search for first comma FROM RIGHT TO LEFT
			if ($hit) {
				$ScalarList .= $3.' ';	# comma separator found - change it to blank
				$_ = $1;
				next;		# continue processing with left part
				}
			else {
				$ScalarList .= $_;
				last;			# end of processing
				}
			}
		$hit = m/(.*)([)])(.*)/;	# search for right parenthesis FROM RIGHT TO LEFT
		if (! $hit) {
			$hit = m/(.*)([,])(.+)/;	# no parenthesis - search for first comma FROM RIGHT TO LEFT
			if ($hit) {
				$ScalarList .= $3.' ';	# comma separator found - change it to blank
				$_ = $1;
				next;		# continue processing with left part
				}
			else {
				$ScalarList .= $_;
				last;			# end of processing
				}
			}
		if ($3 ne '') {	# right parenthesis followed by something
			$save = $1;
			$_ = $3;
			$hit = m/(.*)([,])(.+)/;	# search for first comma
			if ($hit) {
				$ScalarList .= $3.' ';	# change comma separator to blank
				$_ = $save.')'.$1;
				next;		# continue processing with string left of comma
				}
			}
# WARNING ! The following algorithm needs further checkings
# scan the string backward from the right
		$ParLvl = 0;		# parenthesis level
		for ($ix = length($_) - 1;$ix >= 0;$ix --) {
			$charx = substr($_,$ix,1);
			if ($charx  eq ')' ) {
				$ParLvl ++;
				next;
				}
			if ($charx  eq '(' ) {
				$ParLvl --;
				next;
				}
			if ($charx eq ',' && $ParLvl == 0) {	# comma found outside parentheses
				$ArrayList .= substr($_,$ix+1).' ';
				$_ = substr($_,0,$ix);
				next Parse;
				}
			}
		$ArrayList .= $_;
		last;			# end of processing		
		}
# build type-attributes lists as an associative array
# declarations will be sorted with scalars first, put a 0 ahead type,attributes
	if ($ScalarList ne '') {
		$TypeSattr = '0'.$TypeAttr.','.$attributes;
		print "$TypeSattr declaration at line $linect1" if ($debug >= 2);
		print "Scalar List= $ScalarList" if ($debug >= 2);
		if ($definitions{$TypeSattr} eq '') {
			%definitions = (%definitions,
				$TypeSattr,$ScalarList);		# define new entry in assoc array
			}
		else {		# append new variables to list
			$definitions{$TypeSattr} .= ' '.$ScalarList;
			}
		}
	if ($ArrayList ne '') {
# declarations will be sorted with arrays next, put a 1 ahead type,attributes
		$TypeAattr = '1'.$TypeAttr.','.$attributes;
		print "$TypeAattr declaration at line $linect1" if ($debug >= 2);
		print "Array List= $ArrayList" if ($debug >= 2);
		if ($definitions{$TypeAattr} eq '') {
			%definitions = (%definitions,
				$TypeAattr,$ArrayList);		# define new entry in assoc array
			}
		else {		# append new variables to list
			$definitions{$TypeAattr} .= ' '.$ArrayList;
			}
		}
	return;
	}
# ***************************
sub WriteDefs {
	local ($list) = @_;
# Purpose: write definitions sorted lists for arguments (phase 4) or local variables (phase 5)
	print "Writing $list list before line $linect" if ($debug >= 2);
	print " types encountered:",keys(%definitions) if ($debug >= 2);
	$ScalArr = '-'; 		# scalar/array flag undefined for now
	foreach $TypeAttr (sort (keys %definitions)) {
		$type0 = substr($TypeAttr,0,1);		# scalar/array for sorting
		if ($type0 ne $ScalArr) {
			$line1 = $type0 eq '0' ? "!scalars\n" : "!arrays\n";
			$len1 = length($line1);
			&WriteLine($line1,$len1);		# write comment before declarations
			$ScalArr = $type0; 		# remember current scalar/array flag
			}
		$type1 = substr($TypeAttr,1,1);		# character at offset 1 of type (early changed into digit for sorting) ...
		@VarsList = split(' ',$definitions{$TypeAttr});
		@SortedList = sort(@VarsList);
		substr($TypeAttr,1,1) = substr($typeSort,$type1,1);	# is restored with the corresponding letter
		$ix = index($TypeAttr,',');
		$attrSort = substr($TypeAttr,$ix+1,1);		# digit for sorting according to some attribute
# drop the 2 characters used for sorting (0/1 at offset 0 for scalar/array & next to comma for attributes sorting)
		$TypeAttr = $attrSort eq '7' ? substr($TypeAttr,1,$ix-1) : substr($TypeAttr,1,$ix).substr($TypeAttr,$ix+2);	# remove attrSort
		$line1 = ' '.$TypeAttr.' :: ';
		$lenh = length($line1);
		$len1 = $lenh;
		foreach $var(@SortedList) {
			$len2 = $len1+length($var)+1;	# estimate length of output line, NL-terminated
			if ($len2 > 80 && $len1 > $lenh) {
				substr($line1,-1,1)="\n";	# replace separator by NL
				&WriteLine($line1,$len1);
				$line1 = ' '.$TypeAttr.' :: '.$var.',';
				$len1 = $lenh+length($var)+1;
				}
			else {
				$line1 = $line1.$var.',';
				$len1 = $len2;
				}
			}
		if ($len1 > $lenh) {			# non empty line left ?
			substr($line1,-1,1)="\n";	# replace separator by NL
			&WriteLine($line1,$len1);	# write last row
			}
		}
	%definitions = ();	# clear associative array
	return;
	}
# ***************************
sub HndlProg { local ($type,$name) = @_;
  local ($ix);
# Purpose: build a stack of program/subroutine/function definitions
#   apply rules if first Program/Module/Subroutine/Function
# Arguments: program/module/interface/subroutine/function type and name
# Common variables: $ProgLvl, $itemNum
# drop subroutine/function (parameters
	$ix = index($name,'(');
	$name = substr($name,0,$ix) if ($ix > 0);
# stack (sub)program type and name to check subsequent end statement
	$ProgType[$ProgLvl] = $type;
	$ProgName[$ProgLvl] = $name;
# check for interface within module
	if ($SourceBegin1[$itemNum] eq 'ProgModSubFunc') {
# handle first Program/Module/Subroutine
		print "$type $name statement encountered at line $linect" if ($debug > 0);
		if ($assumeFun == 1 && $type ne 'subroutine' && $type ne 'interface') {
    	print "WARNING, assumption of function for $subname in first line of header defeated for $type $name" if ( $debug > 0);
			$assumeFun = 0;
			}
		&WriteLine("\n",1);		# write 1 blank line before Program/Module/Subroutine
		while (1) {
# handle in-line comments
			$ix = rindex ($line,'!');
			$_ = $ix < 0 ? $line : substr($line,0,$ix);
			$hit = m/(.*)(&\s*$)/;    # search trailing &
			last if (! $hit);
			&WriteLine($line,$len);		# write this line
			$line = <FILEIN>;				# and read the next one
			$len = length($line);
			$linect ++;
			}
		if ($ProgType[0] eq 'module' && $type eq 'interface') {
			$ModIntFc = 1;
# leaving itemNum unchanged will search for next subroutine/function...
			}
		else {
			&WriteLine($line,$len);
# following statement should be use
			print "$SourceBegin1[1] statement inserted after $wd1" if ($debug > 1);
			$line = "\n $SourceBegin1[1] $SourceBegin2[1]\n";
			$len = length($line);
			$replc .= $SourceBegin1[1].' ';
			$itemNum ++;		# continue with other use statements
			}
		}
	else {
		print "Sub/Func $ProgName[$ProgLvl] level $ProgLvl encountered at line $linect" if ($debug > 1);
		}
	print "Warning $type name found is $name instead of $subname" if ($name ne $subname && $debug > 1);
	$ProgLvl ++;	# bump stack pointer
	return;
	}
# ***************************
sub WriteLine {	local ($line,$llen) = @_;
  local ($rc);
# Purpose: write one line to FILEOUT and check return code
# Arguments:  $line, $llen = line to be written and length
# Common variable: $fname
	$rc = syswrite(FILEOUT,$line,$llen);
	if ($rc != $llen) {
		print "Error $rc writing to $fname.abirule";
		exit 100;
		}
	return;
	}
