Fortran90_stuff_interface.pm

#SURFEX_LIC Copyright 1994-2014 Meteo-France 
#SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
#SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
#SURFEX_LIC for details. version 1.

package Fortran90_stuff_interface;
use strict;
use warnings;
require Exporter;
use Data::Dumper;

$Data::Dumper::Indent = 1;

our($nest_par);
our @ISA      = qw(Exporter);
our @EXPORT   = qw(study setup_parse pre_tidy remove_macro expcont 
                   process_include_files tidy tidy_decl getvars 
		   find_unused_vars remove_unused_vars doctor_viol
		   fix_doctor_viol various cont_lines f90_indent
		   writefile readfile create_interface_block
		   add_interface_blocks change_var_names insert_hook
		   remake_arg_decl remove_some_comments parse_prog_unit
		   get_calls_inc insert_use_modi
		   $study_called $name $nest_par);


#==========================================================================
sub study{
# Study statements and put attributes into array $statements
# Attributes assigned:
# $href->{content}       - What statement it is
# $href->{decl}       - true if declaration,
#                       5 means statement function
#                       4 means USE statement,
#                       2 means type decleration
#                       3 means FORMAT statement
#                       1 means the rest
# $href->{in_contain} - true while in internal procedure(s)
# $href->{exec}       - true if executable statement
#                     - 2 means first executable statement in program unit
#                     - 3 means last executable statement in program unit
#                     - 23 means first and last executable statement in program unit
# $href->{prog_unit}  - program unit number (numbered from 0)
# $href->{number}     - statement number (numbered from 0)
 
# Further attributes will be assigned later (action attributes)

  my($statements,$prog_info) = @_;

  our ($name,$nest_par);
  my ($unit_name,@args,$prog_unit,$href,@punit,$current_punit);
  my ($content,$decl,$exec);
  my($type_def)=0;
  my($unit_count)=-1;
  @punit=();
  $current_punit='';
  my $number=-1;
  my $in_contain=0;
  my $in_interface=0;
  my $contain_host='';
  my $current_unit_name='';
  our($study_called);
#  if(! $study_called) {
#    $$prog_info{has_interface_block}=0;
#  }
# Initial "parsing" loop

  foreach $href (@$statements) {
    $href->{in_contain}=$in_contain;
    $href->{contain_host}=$contain_host if($in_contain);
    $number++;
    $_=$href->{statement};
#    print "statement $_ ";
    $content='unknown';
    my $content2='';
    $decl=0;
    $exec=0;

    #décompte du nombre d'espace en début de ligne (10 maximum)
    $href->{indent}="";
    if(/^(\ *)/ && !/^\ *[0-9]/) {
      $href->{indent}=$1;
    }
    elsif(/^[\ 0-9]*/) {
      $href->{indent}="      ";
    }
    elsif(/^\t/) {
      $href->{indent}="    ";
    }
    elsif(/^\t\t/) {
      $href->{indent}="        ";
    }
    elsif(/^\t\t\t/) {
      $href->{indent}="            ";
    }
    elsif(/^\t\t\t\t/) {
      $href->{indent}="                ";
    }

    if($type_def) {
 #     $href->{content}='typedef';
    }
    
# Comment
CRACK:    {
      if(/^\s*!/ || /^\s*$/ || /^\s*\*/) {
	$content='comment';
	last CRACK;
      }
      $_=uc($_)  unless(/^\#/);
      s/^[ \t]*//;
      s/^[0-9]*//;
      s/^[ ]*//;
      s/\!.*\n/\n/g;                        # Remove trailing comments in all lines
 
# Program name statement 
      if($content eq 'unknown' and ! $in_interface) {
	$prog_unit=&parse_prog_unit(\$unit_name,\@args);
	if($prog_unit) {
          $current_unit_name=$unit_name;
	  $content=uc($prog_unit);
	  push(@punit,$prog_unit);
	  $current_punit=$prog_unit;
	  $unit_count++;
	  if(! $study_called) {
	    $$prog_info{'unit_name'}[$unit_count]=uc($unit_name);
	    $$prog_info{'unit_name'}[$unit_count]=uc($unit_name);
#	  $$prog_info{'tokens'}[$unit_count]=[];
	    if($prog_unit eq 'module') {
	      $$prog_info{'is_module'}=1;
	      $$prog_info{'module_name'}=$unit_name;
	    }
	  }
	  last CRACK;
	}
      }
      if($content eq 'unknown') {
	$decl=0;
	$exec=1;
# Executable constructs
	&study_exec(\$content,$prog_info,\$study_called);
	if($content eq 'IF') {
	  s/^IF\s*$nest_par\s*//;
	  &study_exec(\$content2,$prog_info,\$study_called);
	}
      }
      

      if($content eq 'unknown') {
# Specification statemnts
	$exec=0;
	$decl=1;
	if(/^USE\b/) {
	  $content='USE';
	  $decl=4;
	}
	elsif(/^INTEGER\b/) {
	  $content='INTEGER';
	  $decl=2;
	}
	elsif(/^REAL\b/) {
	  $content='REAL';
	  $decl=2;
	}
	elsif(/^LOGICAL\b/) {
	  $content='LOGICAL';
	  $decl=2;
	}
	elsif(/^CHARACTER\b/) {
	  $content='CHARACTER';
	  $decl=2;
	}
	elsif(/^DOUBLE PRECISION\b/) {
	  $content='DOUBLE PRECISION';
	  $decl=2;
	}
	elsif(/^COMPLEX\b/) {
	  $content='COMPLEX';
	  $decl=2;
	}
	elsif(/^TYPE *\(/) {
	  $content='type_decl';
	  $decl=2;
	}
	elsif(/^ALLOCATABLE\b/) {
	  $content='ALLOCATABLE';
	}
	elsif(/^COMMON\b/) {
	  $content='COMMON';
	}
	elsif(/^DATA\b/) {
	  $content='DATA';
	}
	elsif(/^DIMENSION\b/) {
	  $content='DIMENSION';
	}
	elsif(/^EQUIVALENCE\b/) {
	  $content='EQUIVALENCE';
	}
	elsif(/^EXTERNAL\b/) {
	  $content='EXTERNAL';
	}
	elsif(/^\d+\s+FORMAT\b/) {
	  $content='FORMAT';
	  $decl=3;
	}
	elsif(/^FORMAT\b/) {
	  $content='FORMAT';
	  $decl=3;
	}
	elsif(/^IMPLICIT\b\s+NONE\b/) {
	  $content='IMPLICIT NONE';
	}
	elsif(/^IMPLICIT\b/) {
	  $content='IMPLICIT';
	}
	elsif(/^INTENT\b/) {
	  $content='INTENT';
	}
	elsif(/^INTRINSIC\b/) {
	  $content='INTRINSIC';
	}
	elsif(/^NAMELIST\b/) {
	  $content='NAMELIST';
	}
	elsif(/^OPTIONAL\b/) {
	  $content='OPTIONAL';
	}
	elsif(/^PARAMETER\b/) {
	  $content='PARAMETER';
	}
	elsif(/^POINTER\b/) {
	  $content='POINTER';
	}
	elsif(/^PUBLIC\b/) {
	  $content='PUBLIC';
	}
	elsif(/^PRIVATE\b/) {
	  $content='PRIVATE';
	}
	elsif(/^SAVE\b/) {
	  $content='SAVE';
	}
	elsif(/^TARGET\b/) {
	  $content='TARGET';
	}
	elsif(/^SEQUENCE\b/) {
	  $content='SEQUENCE';
	}
	elsif(/^INTERFACE\b/) {
	  $content='INTERFACE';
	  if(! $study_called) {
	    $$prog_info{has_interface_block}=1;
	    $in_interface=1;
	  }
	}
	elsif(/^END ?INTERFACE\b/) {
	  $content='END INTERFACE';
	    $in_interface=0;
	}
	elsif(/^TYPE *[^\( ]/i) {
	  $content='type_def';
	  $type_def=1;
	}
	elsif(/^END TYPE\b/){
	  $content='type_def';
	  $type_def=0;
	}
        elsif( $in_interface ) {
          if(/^MODULE PROCEDURE\b/) {
            $content='MODULE PROCEDURE';
          }
        }
      }
# Other constructs
#print "$content content $_";
      if($content eq 'unknown') {
	$decl=0;
	$exec=0;
	
	if(/^CONTAINS\b/) {
	  $content='CONTAINS';
	  $in_contain=1;
          $contain_host=uc($current_unit_name);
	  if(! $study_called) {
	    $$prog_info{has_contain}=1;
	    $$prog_info{containing}=1;
	  }
	}
	elsif(/^\#include\b/) {
	  $content='include';
	  if(! $study_called) {
	    $$prog_info{has_include}=1;
	  }
	}
	elsif(/^INCLUDE/) {
	  $content='statmf';
	}
	elsif(/^\#/) {
	  $content='cpp';
	}
	elsif(/^\@/) {
	  $content='compiler_directive';
	}
	
	else{
	  if(/^END\b/) {
	    $prog_unit=pop(@punit);
	    $content='END '.uc($prog_unit);
	    if($in_contain) {
	      unless(@punit) {
		$unit_count=0;
		$href->{in_contain}=0;
		$in_contain=0;
	      }
	    }
	  }
	} 
      }
    }
    
    if($in_interface and $content ne 'INTERFACE') {
      $content='in_interface';
      $exec=0;
      $decl=1;
    }
#print STDERR "cont $content \n \n";
#    print "BB $unit_count $content $_";
    if($content  eq 'unknown') {
      print STDERR "Failed to crack statement starting at line $href->{first_line}",
      " - syntax error?? \n";
      print STDERR " $_ ";
#      print STDERR "study_called $study_called in_interface $in_interface \n";
#      print STDERR Dumper($statements);
      die "Failed in study";
    }
#    unless($content eq 'comment') {
#      my @tmpvar=/\b$name\b/g;
#      my $i=0;
#      foreach my $tmp (@tmpvar){ 
#	$href->{'tokens'}[$i]=$tmp;
#	$i++;
#	if(! $study_called and $unit_count > -1) {
#	  $$prog_info{'token_hash'}[$unit_count]{$tmp}++;
#	}
#      }
#    }
               
    $href->{content}=$content;
    $href->{content2}=$content2 if($content2);
    $href->{decl}=$decl;
    $href->{exec}=$exec;
#    $href->{type_decl}=$type_decl;
    $href->{prog_unit}=$unit_count;
    $href->{number}=$number;
    unless($content eq 'comment') {
      $href->{multi_line} = 1 if(tr/\n// > 1);
    }
  }


# Find first executable statement in each program unit
# Also repair statement functions wrongly assigned as executable
  my $prev_unit_count=-2;
  my $stat_func_suspicion=0;
  my @lastexec=();

  foreach $href (@$statements) {
    $exec=$href->{exec};
    $unit_count=$href->{prog_unit};
    if($exec) {
      if($unit_count > $prev_unit_count) {
	$content=$href->{content};
	if($content eq 'array_assign') {
	  $stat_func_suspicion=1;
	  $_=$href->{statement};
	  if(/^\s*$name\s*\(\s*:/){
	    $stat_func_suspicion=0;
#	    print " A $_";
	   } 
	  elsif(/^\s*$name\s*\(\s*$name\s*:/){
	    $stat_func_suspicion=0;
#	    print " B $_";
	  } 
	  elsif(/^\s*$name\s*\(\s*\d+/){
	    $stat_func_suspicion=0;
#	    print " C $_";
	  }
	  else {
	    $href->{exec}=0;
	    $href->{decl}=5;
	    $href->{content}='statmf';
#	    print " D $_";
	    next;
	  }
	}
	$href->{exec}=2;
	$prev_unit_count=$unit_count;
	$content=$href->{content};
      }
      $lastexec[$unit_count]=$href->{number}  unless ($unit_count < 0);  
# No prog_unit assigned, include file?
    }
  }

# Assign last executable statement
  if(@lastexec) {
    foreach my $last (@lastexec) {
      if(defined ($last)) {
	if($$statements[$last]->{exec} == 1) {
	  $$statements[$last]->{exec}=3;
	}
	else{
	  $$statements[$last]->{exec}=23;
	}      
      }
    }
  }
# Consistency checks
  my $fail=0;
  my $prev_exec=0;
  $prev_unit_count=-1;
  foreach $href (@$statements) {
    $content=$href->{content};
    next if($content eq 'comment');
    $unit_count=$href->{prog_unit};
    $exec=$href->{exec};
    $decl=$href->{decl};
    if($unit_count == $prev_unit_count) {
      if($decl and $prev_exec) {
	unless ($content eq 'FORMAT' | $content eq 'DATA' ) {
	  print STDERR "$href->{first_line} $href->{statement}";
	  print STDERR 'Decleration after executable statement';
	  $fail=1;
	}
      }
    }
    $prev_unit_count=$unit_count;
    $prev_exec=$exec;
  }
  if($fail) {
    foreach $href (@$statements) {
      $content=$href->{content};
      $unit_count=$href->{prog_unit};
      $exec=$href->{exec};
      $decl=$href->{decl};
      #print "$content $unit_count $exec $decl $href->{statement}";
    }
    die 'FAIL';
  }
  $study_called=1;
}

#==========================================================================
sub study_exec{
  my($content,$prog_info,$study_called) = @_;
  our ($name,$nest_par);
  if(/^(\w+\s*:\s*)*IF\s*$nest_par\s*THEN/) {
    $$content='IF_construct';
  }
  elsif(/^ELSE *IF *\(/) {
    $$content='ELSEIF';
  }
  elsif(/^ELSE\b\s*($name)*/) {
    $$content='ELSE';
  }
  elsif(/^END *IF\b\s*($name)*/) {
    $$content='ENDIF';
  }
  elsif(/^($name\s*:\s*)*DO\b/) {
    $$content='DO';
  }
  elsif(/^END *DO\b/) {
    $$content='ENDDO';
  }
  elsif(/^ALLOCATE\b/) {
    $$content='ALLOCATE';
  }
  elsif(/^ASSIGN\b/) {
    $$content='ASIGN';
  }
  elsif(/^BACKSPACE\b/) {
    $$content='BACKSPACE';
  }
  elsif(/^CALL\b/) {
    $$content='CALL';
    if(!$$study_called) {
      $$prog_info{no_calls}++;
    }
  }
  elsif(/^CLOSE\b/) {
    $$content='CLOSE';
  }
  elsif(/^(\d+)*\s*CONTINUE\b/) {
    $$content='CONTINUE';
  }
  elsif(/^CYCLE\b/) {
    $$content='CYCLE';
  }
  elsif(/^DEALLOCATE\b/) {
    $$content='DEALLOCATE';
  }
  elsif(/^ENDFILE\b/) {
    $$content='ENDFILE';
  }
  elsif(/^EXIT\b/) {
    $$content='EXIT';
  }
  elsif(/^GO *TO\b/) {
    $$content='GOTO';
  }
  elsif(/^IF\s*\(/) {
    $$content='IF';
  }
  elsif(/^INQUIRE\b/) {
    $$content='INQUIRE';
  }
  elsif(/^NULLIFY\b/) {
    $$content='NULLIFY';
  }
  elsif(/^OPEN\b/) {
    $$content='OPEN';
  }
  elsif(/^PAUSE\b/) {
    $$content='PAUSE';
  }
  elsif(/^PRINT\b/) {
    $$content='PRINT';
  }
  elsif(/^READ\b/) {
    $$content='READ';
  }
  elsif(/^READ\b/) {
    $$content='READ';
  }
  elsif(/^RETURN\b/) {
    $$content='RETURN';
  }
  elsif(/^REWIND\b/) {
    $$content='REWIND';
  }
  elsif(/^STOP\b/) {
    $$content='STOP';
  }
  elsif(/^WHERE\s*$nest_par\s*$name.*=/) {
    $$content='WHERE';
  }
  elsif(/^WRITE\s*\(/) {
    $$content='WRITE';
  }
  elsif(/^($name\s*:\s*)*SELECT\s?CASE\b/) {
    $$content='SELECT CASE';
  }
  elsif(/^CASE\b/) {
    $$content='CASE';
  }
  elsif(/^END *SELECT\b/) {
    $$content='END SELECT';
  }
  elsif(/^WHERE *\(/) {
    $$content='WHERE_construct';
  }
  elsif(/^ELSE *WHERE\b/) {
    $$content='ELSEWHERE';
  }
  elsif(/^END *WHERE\b/) {
    $$content='ENDWHERE';
  }
  elsif(/^$name\s*=/o) {                                 #ZVAR = ....
    $$content='scal_assign';
  }
  elsif(/^$name\s*$nest_par\s*=/o) {                     #ZARR(JL) = ....
    $$content='array_assign';
  }
  elsif(/^$name\s*%\s*$name\s*=/o) {                     #ZMYTYPE%ICOMP = .....
    $$content='scal_assign';
  }
  elsif(/^$name\s*%\s*$name\s*%\s*$name\s*=/o) {                     #ZMYTYPE%ICOMP = .....
    $$content='scal_assign';
  }  
  elsif(/^$name\s*%\s*$name\s*%\s*$name\s*%\s*$name\s*=/o) {                     #ZMYTYPE%ICOMP = .....
    $$content='scal_assign';
  }
  elsif(/^$name\s*%\s*$name\s*%\s*$name\s*%\s*$name\s*%\s*$name\s*=/o) {                     #ZMYTYPE%ICOMP = .....
    $$content='scal_assign';
  }
  
  elsif(/^$name\s*$nest_par\s*%\s*$name\s*=/o) {         #ZMYTYPE(JK)%ICOMP = .....
    $$content='array_assign';
  }
  elsif(/^$name\s*%\s*$name\s*$nest_par\s*=/o) {         #ZMYTYPE%ICOMP(JL) = .....
    $$content='array_assign';
  }
  elsif(/^$name\s*%\s*$name\s*%\s*$name\s*$nest_par\s*=/o) {         #ZMYTYPE%ICOMP(JL) = .....
    $$content='array_assign';
  }
  elsif(/^$name\s*%\s*$name\s*%\s*$name\s*%\s*$name\s*$nest_par\s*=/o) {         #ZMYTYPE%ICOMP(JL) = .....
    $$content='array_assign';
  }  
  elsif(/^$name\s*%\s*$name\s*%\s*$name\s*%\s*$name\s*%\s*$name\s*$nest_par\s*=/o) {         #ZMYTYPE%ICOMP(JL) = .....
    $$content='array_assign';
  }   
  elsif(/^($name\s*($nest_par)*\s*%\s*$name\s*($nest_par)* *)+=/o) { #ZMYTYPE(JK)%ICOMP(JL) = ...
    $$content='array_assign';
  }
  elsif(/^$name\s*($nest_par)($nest_par)\s*=/o) {        #CLNAME(JK)(1:5) = ......
    $$content='array_assign';
  }    
}
#===================================================================================
#sub get_indent {
#
#   my($lines,$indent)=@_
#   foreach (@$lines) {
#	
#	
#   }
#}
#===================================================================================
sub pre_tidy {

# Initial tidying to make the rest work

  my($lines)=@_;
  foreach (@$lines) {

# Substitute tab with four blanks
    s/\t/    /g;
    s/^ *INTEGER /INTEGER_M /i;
    s/^ *REAL /REAL_B /i;
  }
}
#==========================================================================
sub remove_macro {

# Remove INTEGER_M, _ONE_ etc. macros and replace by expanded statement

  my($lines)=@_;

  my($im)=1; # Until I start checking include files
  my($ia)=0;
  my($ib)=0;
  my($rb)=1; # Until I start checking include files
  my($is)=0;
  my($rh)=0;
  my($rm)=0;
  my(@pars,$string);
  for (@$lines) {
    next if(/^ *$/ | /^ *!/);
# The following two substitutions should be restored at end of processing
    s/(\'[^!]*)!+(.*\')/$1\£$2/;   # Protect against mischief 
    s/(["][^!]*)!+(.*["])/$1\£$2/;      # Protect against mischief
    $im=$im+/JPIM\b/i unless($im);
    $rb=$rb+/JPRB\b/i unless($rb);
    $rm=$rm+/JPRM\b/i unless($rm);
    $im=$im+s/\bINTEGER_M\b/INTEGER(KIND=JPIM)/o;
    $ia=$ia+s/\bINTEGER_A\b/INTEGER(KIND=JPIA)/o;
    $ib=$ib+s/\bINTEGER_B\b/INTEGER(KIND=JPIB)/o;
    $is=$is+s/\bINTEGER_S\b/INTEGER(KIND=JPIS)/o;
    $rb=$rb+s/\bREAL_B\b/REAL(KIND=JPRB)/o;
    $rh=$rh+s/\bREAL_H\b/REAL(KIND=JPRH)/o;
    $rm=$rm+s/\bREAL_M\b/REAL(KIND=JPRM)/o;
    $rb=$rb+s/\b_ZERO_\b/0.0_JPRB/og;
    $rb=$rb+s/\b_ONE_\b/1.0_JPRB/og;
    $rb=$rb+s/\b_TWO_\b/2.0_JPRB/og;
    $rb=$rb+s/\b_HALF_\b/0.5_JPRB/og;
  }
  @pars=();
  push(@pars,"JPIM") if $im;
  push(@pars,"JPRB") if $rb;
  push(@pars,"JPRM") if $rm;
  push(@pars,"JPIA") if $ia;
  push(@pars,"JPIB") if $ib;
  push(@pars,"JPIS") if $is;
  ($string=join('     ,',@pars))=~s/ *$//;
  for (@$lines) {
    next unless (/^\#/);
    if(@pars) {
      s/^#include +"tsmbkind.h"/USE PARKIND1  ,ONLY : $string/ ;
    }
    else {
      s/^#include +"tsmbkind.h"//;
    }
#    if($rh) {
      s/^#include +"hugekind.h"/USE PARKIND2  ,ONLY : JPRH/ ;
#    }
#    else {
#      s/^#include +"hugekind.h"// ;
#    }
  }
}

#==========================================================================
sub readfile  {
# Read file 
  my($fname)=@_;
  my(@lines);
  if(!open(INFIL,$fname)) {
    print STDERR "Can't open $fname for reading\n";
    die("Can't open $fname for reading\n");
  }
  @lines=<INFIL>;
  close INFIL;
  (@lines);
}

#==========================================================================
sub writefile  {
# Write file
  my($fname,$lines)=@_;
  if(!open(OUTFIL,">".$fname)) {
    print STDERR "Can't open $fname for writing\n";
    exit;
  }
  print OUTFIL @$lines;
  close OUTFIL;
}

#==========================================================================
sub expcont {
#
# Expand continuation lines into statements for free-format Fortran while
# maintaining line-breaking and all comments
# Put statements onto array of references to anonymous hashes as key 'statement'
# Also put into the hash the linenumber of first line of statement as key 'first_line'
  my($lines,$statements) = @_;
  my($statm,$prev,$rec,$line,$first_line);
  $prev=0;
  my $line_number=0;
  foreach $line (@$lines) {
    $_=$line;
    $line_number++;
    if(/^ *&/) {
      s/^( *)&(.*)$/$1$2/s;
#      print " 1 $_";
    }
    if( !/^ *!.*$/ && /^.+&(?: *!.*)* *$/ && !/^.+!.*&.*$/) {
      s/(.+)&(.+)/$1$2/s;
      $statm.=$_;
      $first_line=$line_number unless($prev);
      $prev=1;
#      print " 2 $_";
      next;
    }
    elsif($prev && /^ *!/) {
      $statm.=$_;
#      print " 3 $_";
      next;
    }
    elsif($prev && /^ *$/) {
#      print " 4 $_";
      next;
    }
    else {
#      print " 5 $_";
      $first_line=$line_number unless($prev);
      $statm.=$_;
      {
	my $rec={};
	$rec->{'statement'}=$statm;
	$rec->{'first_line'}=$first_line;
	push(@$statements,$rec);
      }
      $statm = "";
      $prev=0;
    }
  }
}
#==========================================================================

sub cont_lines {
#
# Put back continuation character in correct place and execute delayed actions
#
  my($statements,$lines,$line_hash) = @_;
  my(@temp,$i,$iup,$href);


# Put back continuation characters and split statements into lines as they were
  @$lines=();
  @$line_hash=();
  foreach $href (@$statements) {
    $_=$href->{statement};
    if (/\n.*\n/){                      # This is a multi-line statement
      @temp=split /\n/;                 # Split statement into lines (removes EOL)
      $iup=scalar(@temp);               # Number of lines in statement
      for ($i=0;$i < $iup;$i++) {       # Loop through lines
	$_=$temp[$i];
	if($i == 0 ){                   # First line
	  if(/^([^!]+)(!.*)$/) {        # Line has trailing comment
	    s/^([^!]+)(!.*)$/$1&$2\n/;  # Put back & at end of line before comment
	  }
	  else {                        # No trailing comment
	    s/^([^!]+)$/$1&\n/;         # Put back & and EOL at end of line
	  }	    
	}
	elsif ($i == ($iup-1)) {        # Last line
#	  s/^( *)(.*)$/$1& $2 \n/;      # Put back & at beginning of line
	  s/^( *)(.*)$/$1$2\n/;      # Put back & at beginning of line
	}
	else {                          # Other lines
	  if (/^ *!/) {                 # Line is comment line
	    $_=$_."\n";                 # Restore EOL for comments
	  }
	  else {
	    if(/^( *)([^!]*)(!.*)$/) {  # Line has trailing comment
#	      s/^( *)([^!]*)(!.*)*$/$1& $2&$3\n/;  # & at beginning and end of line
     	      s/^( *)([^!]*)(!.*)*$/$1$2&$3\n/;  # & at beginning and end of line
	    }
	    else {                      # No trailing comment
#	      s/^( *)([^!]*)$/$1& $2&\n/; # & at beggining and end of line
      	      s/^( *)([^!]*)$/$1$2&\n/; # & at beggining and end of line
	    }	 
	  }  
	}
	if($i == 0        && exists $href->{pre_insert}) {
	  my @templines=split('\n',$href->{pre_insert});
	  foreach my $tline (@templines) {
	    my $rec={};
	    $rec->{'content'}='unknown';
	    $rec->{'line'}=$tline."\n";
	    push(@$lines,$rec->{'line'});
	    push(@$line_hash,$rec);
	  }
	}
	unless(exists $href->{remove}) {
	  my $rec={};
	  $rec->{'line'}=$_;
	  if($i == 0) {
	    $rec->{'content'}=$href->{content};
	  }
	  else {
	    $rec->{'content'}='cont_line';
	  }
	  push(@$lines,$rec->{'line'});
	  push(@$line_hash,$rec);
	}
	if($i == ($iup-1) && exists $href->{post_insert}) {
	  my @templines=split('\n',$href->{post_insert});
	  foreach my $tline (@templines) {
	    my $rec={};
	    $rec->{'content'}='unknown';
	    $rec->{'line'}=$tline."\n";
	    push(@$lines,$rec->{'line'});
	    push(@$line_hash,$rec);
	  }
	}
      }
    }
    else {  # Not multiline statement
      if(exists $href->{pre_insert}) {
	my @templines=split('\n',$href->{pre_insert});
	foreach my $tline (@templines) {
	  my $rec={};
	  $rec->{'content'}='unknown';
	  $rec->{'line'}=$tline."\n";
	  push(@$lines,$rec->{'line'});
	  push(@$line_hash,$rec);
	}
      }
      unless(exists $href->{remove}) {
	my $rec={};
	$rec->{'line'}=$_;
	$rec->{'content'}=$href->{content};
	push(@$lines,$rec->{'line'});
	push(@$line_hash,$rec);
#	print $rec;
      }
      if(exists $href->{post_insert}) {
	my @templines=split('\n',$href->{post_insert});
	foreach my $tline (@templines) {
	  my $rec={};
	  $rec->{'content'}='unknown';
	  $rec->{'line'}=$tline."\n";
	  push(@$lines,$rec->{'line'});
	  push(@$line_hash,$rec);
	}
      }
    }
  }
}
#==========================================================================
sub getvars {
# Return list of locally declared variables with type and scope information
# 
  my($statements,$prog_info,$vars,$use_vars) = @_;
  my ($test,$type,@vars1,$func,$prog_unit,$dum,$tmp_name,@pu_args);
  my ($preserve,$rank,$href);
  our($nest_par,$name);

  %$vars=();
  $func="";
  $prog_unit=0;
  %$use_vars=();
  foreach $href (@$statements) {
    next if($href->{content} eq 'comment');           # Skip comments
    next if($href->{exec});                        # Don't look in executable statements
    next if($$prog_info{is_module} and ! $href->{in_contain}); # Unless inside CONTAIN skip module 
    $prog_unit=$href->{prog_unit};
    if($href->{content} eq 'FUNCTION') {
      $_=$href->{statement};
      my $dum=&parse_prog_unit(\$func,\@pu_args);          # Get name of FUNCTION
#      print "GETVARS FUNCTION $func \n";
      $func=uc($func);
    }
    if($href->{decl} == 2 or $href->{content} eq 'EXTERNAL'){  # Real parse starts
      $_=$href->{statement};
      $_=uc($_);                                   # Upcase to avoid /.../i
      s/^ *//;                                     # remove leading blanks
      if($href->{decl} == 2) {
	$type=lc(substr($href->{content},0,1));
      }
      else {
	$type='e';
      }
      s/\!.*\n/\n/g;                               # Remove trailing comments in all lines
      $preserve=$_;
      s/(.+)::(.+)/$2/s;                           #REAL(KIND=JPRB) :: zsig(:) -> zsig(:),
      s/^EXTERNAL (.+)$/$1/;
      s/\s+//g;                                    # Remove all white-space
      if($href->{content} eq 'CHARACTER') {
	s/($name)\*\d+/$1/g;
	s/($name)\*$nest_par/$1/g;
	s/($name)$nest_par\*\w+/$1/g;
      }
      s#=\(/.+/\)##;      # ZVAL(1:2)=(/1.0,2.0/) -> ZVAL(1:2)
#?      s/=[^,\n]+//g;
      s/$nest_par//g;     # ISEC3(SIZE(NSEC3)),ISEC4(SIZE(NSEC4)) -> ISEC3,ISEC4
      s/=\w+//g;          # ZVAL=1.0 -> ZVAL
      s@/.*/@@;           # What?
      @vars1=split(',',$_);
      for(@vars1) {
	next unless /^$name$/;          # A bit of security
	if($preserve =~ /\b$_\b *\(/ | $preserve =~ /DIMENSION/) {
	  $rank=1;        # Variable is array
	}
	else {
	  $rank=0;        # Variable is scalar
	}
	if($_ eq $func) {
	  $$vars{$_}{type_spec}="f";
	} 
	else {
	  if($href->{content} eq 'FUNCTION') {
	    $$vars{$_}{type_spec}='f';
	  }
	  else {
	    $$vars{$_}{type_spec}=$type;
	  }
	}
	$$vars{$_}{scope}=$prog_unit;
	$$vars{$_}{rank}=$rank;
	$$vars{$_}{usage}='local';
      }
    }
# Perhaps the variable is really a statement function?
    if($href->{decl} == 5) {
      $_=$href->{statement};
      s/\s+//g;                                    # Remove all white-space
      /^($name)\((.+)\)=/i;
      my $tvar=uc($1);
      my @stmf_args=split(',',$2);
      if (exists($$vars{$tvar})) {
	$$vars{$tvar}{type_spec}='s';
#	print "STATMF OK $tvar \n ";
      }
      for (@stmf_args) {
	if (exists($$vars{$_})) {
	  $$vars{$_}{type_spec}='s';
#	  print "STATMF ARG OK $_ \n ";
	}
      }
    }
  }
# Perhaps instead the variable is a declaration of an external function?
  my @extract=();                  # Extract part of statements for efficiency
  foreach $href (@$statements) {
    if($href->{exec}) {                 # Function call must be in executable stat.
      next if($href->{content} eq 'CALL'); # A call can't contain an undeclared function
      push(@extract,$href->{statement});
    }
  }
  
  foreach my $var (keys (%$vars)) {
    next if($$vars{$var}{rank} > 0);   # Can't be a function if rank > 0
    next if($$vars{$var}{type_spec} eq 's' | $$vars{$var}{type_spec} eq 'f');
    my $dec_unit=$$vars{$var}{scope};
    my $regex1=qr/\b$var\b\s*\(/i;      # As var's rank=0 this could be function call
    for(@extract) {
      if(/${regex1}/) {
	s/\!.*\n/\n/g;                       # Remove trailing comments in all lines
	s/\s+//g;                            # Remove all white-space
	if(/${regex1}/) {
	  if($$vars{$var}{type_spec} eq 'c') {   # Avoid CLVAR(1:3) etc.
	    next if(/${regex1}\s*(\d+|$name)*\s*:\s*(\d+|$name)*\s*\)/);
	  }
#	  print "TYPE changed to function $var $_ \n";
	  $$vars{$var}{type_spec}='f';
	  last;
	}