source: LMDZ6/branches/LMDZ-COSP/tools/fcm/lib/Ecmwf/Fortran90_stuff.pm @ 5018

Last change on this file since 5018 was 1578, checked in by jghattas, 13 years ago
  • Add fcm in LMDZ5/tools directory

It is no longer needed to have fcm in your environement PATH variable.
Now makelmdz_fcm takes by default this fcm. It is still possible to use
another fcm, using -fcm_path argument in makelmdz_fcm.
File size: 70.9 KB
Line 
1#!/usr/bin/perl
2# ------------------------------------------------------------------------------
3# NAME
4#   Ecmwf::Fortran90_stuff
5#
6# DESCRIPTION
7#   This is a module for analysing Fortran 9X code. It is used by the FCM
8#   system to generate interface blocks for Fortran 9X free source files.
9#
10# ABOUT THIS MODULE:
11#   The original version of this module was developed by the European Centre
12#   for Medium-Range Weather Forecasts (ECMWF). This version has been modified
13#   by UK Met Office to become part of the FCM system.
14# ------------------------------------------------------------------------------
15
16package Ecmwf::Fortran90_stuff;
17
18# Standard pragmas
19use strict;
20use warnings;
21
22# Standard modules
23require Exporter;
24
25our @ISA      = qw(Exporter);
26our @EXPORT   = qw(study setup_parse pre_tidy remove_macro expcont
27                   process_include_files tidy tidy_decl getvars
28                   find_unused_vars remove_unused_vars doctor_viol
29                   fix_doctor_viol various cont_lines f90_indent
30                   writefile readfile create_interface_block
31                   add_interface_blocks change_var_names insert_hook
32                   remake_arg_decl remove_some_comments parse_prog_unit
33                   get_calls_inc);
34
35# ------------------------------------------------------------------------------
36
37# Module variables
38
39my $fname = '';
40
41# ------------------------------------------------------------------------------
42# SYNPOSIS
43#   $file = &Ecmwf::Fortran90_stuff::fname ();
44#   &Ecmwf::Fortran90_stuff::fname ($file);
45#
46# DESCRIPTION
47#   This function returns the value in the module variable $fname, which is the
48#   name of the input Fortran source file from FCM. If an argument exists, the
49#   value of $fname is set to the value of the argument.
50#
51# ------------------------------------------------------------------------------
52
53sub fname {
54  $fname = $_[0] if @_;
55  return $fname;
56}
57
58#==========================================================================
59sub study{
60# Study statements and put attributes into array $statements
61# Attributes assigned:
62# $href->{content}       - What statement it is
63# $href->{decl}       - true if declaration,
64#                       5 means statement function
65#                       4 means USE statement,
66#                       2 means type decleration
67#                       3 means FORMAT statement
68#                       1 means the rest
69# $href->{in_contain} - true while in internal procedure(s)
70# $href->{exec}       - true if executable statement
71#                     - 2 means first executable statement in program unit
72#                     - 3 means last executable statement in program unit
73#                     - 23 means first and last executable statement in program unit
74# $href->{prog_unit}  - program unit number (numbered from 0)
75# $href->{number}     - statement number (numbered from 0)
76 
77# Further attributes will be assigned later (action attributes)
78
79  my($statements,$prog_info) = @_;
80
81  our ($name,$nest_par);
82  my ($unit_name,@args,$prog_unit,$href,@punit,$current_punit);
83  my ($content,$decl,$exec);
84  my($type_def)=0;
85  my($unit_count)=-1;
86  @punit=();
87  $current_punit='';
88  my $number=-1;
89  my $in_contain=0;
90  my $in_interface=0;
91  my $contain_host='';
92  my $current_unit_name='';
93  our($study_called);
94#  if(! $study_called) {
95#    $$prog_info{has_interface_block}=0;
96#  }
97# Initial "parsing" loop
98
99  foreach $href (@$statements) {
100    $href->{in_contain}=$in_contain;
101    $href->{contain_host}=$contain_host if($in_contain);
102    $number++;
103    $_=$href->{statement};
104    $content='unknown';
105    my $content2='';
106    $decl=0;
107    $exec=0;
108
109    if($type_def) {
110 #     $href->{content}='typedef';
111    }
112   
113# Comment
114CRACK:    {
115      if(/^\s*(?:!|$)/) {
116        $content='comment';
117        last CRACK;
118      }
119
120      $_ = uc unless /^#/;
121      s/^\s*//;
122      s/\!.*\n/\n/g; # Remove trailing comments in all lines
123#      print "AA $_";
124 
125# Program name statement
126      if($content eq 'unknown' and ! $in_interface) {
127        $prog_unit=&parse_prog_unit(\$unit_name,\@args);
128        if($prog_unit) {
129          $current_unit_name=$unit_name;
130          $content=uc($prog_unit);
131          push(@punit,$prog_unit);
132          $current_punit=$prog_unit;
133          $unit_count++;
134          if(! $study_called) {
135            $$prog_info{'unit_name'}[$unit_count]=uc($unit_name);
136            $$prog_info{'unit_name'}[$unit_count]=uc($unit_name);
137#         $$prog_info{'tokens'}[$unit_count]=[];
138            if($prog_unit eq 'module') {
139              $$prog_info{'is_module'}=1;
140              $$prog_info{'module_name'}=$unit_name;
141            }
142          }
143          last CRACK;
144        }
145      }
146      if($content eq 'unknown') {
147        $decl=0;
148        $exec=1;
149# Executable constructs
150        &study_exec(\$content,$prog_info,\$study_called);
151        if($content eq 'IF') {
152          s/^IF\s*$nest_par\s*//;
153          &study_exec(\$content2,$prog_info,\$study_called);
154        }
155      }
156     
157
158      if($content eq 'unknown') {
159# Specification statemnts
160        $exec=0;
161        $decl=1;
162        if(/^USE\b/) {
163          $content='USE';
164          $decl=4;
165        }
166        elsif(/^INTEGER\b/) {
167          $content='INTEGER';
168          $decl=2;
169        }
170        elsif(/^REAL\b/) {
171          $content='REAL';
172          $decl=2;
173        }
174        elsif(/^LOGICAL\b/) {
175          $content='LOGICAL';
176          $decl=2;
177        }
178        elsif(/^CHARACTER\b/) {
179          $content='CHARACTER';
180          $decl=2;
181        }
182        elsif(/^DOUBLE\s*PRECISION\b/) {
183          $content='DOUBLE PRECISION';
184          $decl=2;
185        }
186        elsif(/^COMPLEX\b/) {
187          $content='COMPLEX';
188          $decl=2;
189        }
190        elsif(/^TYPE *\(/) {
191          $content='type_decl';
192          $decl=2;
193        }
194        elsif(/^ALLOCATABLE\b/) {
195          $content='ALLOCATABLE';
196        }
197        elsif(/^COMMON\b/) {
198          $content='COMMON';
199        }
200        elsif(/^DATA\b/) {
201          $content='DATA';
202        }
203        elsif(/^DIMENSION\b/) {
204          $content='DIMENSION';
205        }
206        elsif(/^EQUIVALENCE\b/) {
207          $content='EQUIVALENCE';
208        }
209        elsif(/^EXTERNAL\b/) {
210          $content='EXTERNAL';
211        }
212        elsif(/^\d+\s+FORMAT\b/) {
213          $content='FORMAT';
214          $decl=3;
215        }
216        elsif(/^IMPLICIT\b\s+NONE\b/) {
217          $content='IMPLICIT NONE';
218        }
219        elsif(/^IMPLICIT\b/) {
220          $content='IMPLICIT';
221        }
222        elsif(/^INTENT\b/) {
223          $content='INTENT';
224        }
225        elsif(/^INTRINSIC\b/) {
226          $content='INTRINSIC';
227        }
228        elsif(/^NAMELIST\b/) {
229          $content='NAMELIST';
230        }
231        elsif(/^OPTIONAL\b/) {
232          $content='OPTIONAL';
233        }
234        elsif(/^PARAMETER\b/) {
235          $content='PARAMETER';
236          $decl = 2;
237        }
238        elsif(/^POINTER\b/) {
239          $content='POINTER';
240        }
241        elsif(/^PUBLIC\b/) {
242          $content='PUBLIC';
243        }
244        elsif(/^PRIVATE\b/) {
245          $content='PRIVATE';
246        }
247        elsif(/^SAVE\b/) {
248          $content='SAVE';
249        }
250        elsif(/^TARGET\b/) {
251          $content='TARGET';
252        }
253        elsif(/^SEQUENCE\b/) {
254          $content='SEQUENCE';
255        }
256        elsif(/^INTERFACE\b/) {
257          $content='INTERFACE';
258          if(! $study_called) {
259            $$prog_info{has_interface_block}=1;
260            $in_interface=1;
261          }
262        }
263        elsif(/^END ?INTERFACE\b/) {
264          $content='END INTERFACE';
265            $in_interface=0;
266        }
267        elsif(/^TYPE *[^\( ]/i) {
268          $content='type_def';
269          $type_def=1;
270        }
271        elsif(/^END\s*TYPE\b/){
272          $content='type_def';
273          $type_def=0;
274        }
275        elsif( $in_interface ) {
276          if(/^MODULE PROCEDURE\b/) {
277            $content='MODULE PROCEDURE';
278          }
279        }
280      }
281# Other constructs
282      if($content eq 'unknown') {
283        $decl=0;
284        $exec=0;
285       
286        if(/^CONTAINS\b/) {
287          $content='CONTAINS';
288          $in_contain=1;
289          $contain_host=uc($current_unit_name);
290          if(! $study_called) {
291            $$prog_info{has_contain}=1;
292            $$prog_info{containing}=1;
293          }
294        }
295        elsif(/^(?:INCLUDE|#include)\b/) {
296          $content='include';
297          if(! $study_called) {
298            $$prog_info{has_include}=1;
299          }
300        }
301        elsif(/^\#/) {
302          $content='cpp';
303        }
304        elsif(/^\@/) {
305          $content='compiler_directive';
306        }
307       
308        else{
309          if(/^END\b/ and ! $in_interface) {
310            $prog_unit=pop(@punit);
311            $content='END '.uc($prog_unit);
312            if($in_contain) {
313              unless(@punit) {
314                $unit_count=0;
315                $href->{in_contain}=0;
316                $in_contain=0;
317              }
318            }
319          }
320        } 
321      }
322    }
323   
324    if($in_interface and $content ne 'INTERFACE') {
325      $content='in_interface';
326      $exec=0;
327      $decl=1;
328    }
329
330#    print "BB $unit_count $content $_";
331    if($content  eq 'unknown') {
332      print STDERR $fname, ': failed to crack statement starting at line ',
333                   $href->{first_line}, ', - syntax error?', "\n";
334      print STDERR ' ', $_, "\n";
335#      print STDERR "study_called $study_called in_interface $in_interface \n";
336#      print STDERR Dumper($statements);
337      #die "Failed in study";
338    }
339#    unless($content eq 'comment') {
340#      my @tmpvar=/\b$name\b/g;
341#      my $i=0;
342#      foreach my $tmp (@tmpvar){
343#       $href->{'tokens'}[$i]=$tmp;
344#       $i++;
345#       if(! $study_called and $unit_count > -1) {
346#         $$prog_info{'token_hash'}[$unit_count]{$tmp}++;
347#       }
348#      }
349#    }
350               
351    $href->{content}=$content;
352    $href->{content2}=$content2 if($content2);
353    $href->{decl}=$decl;
354    $href->{exec}=$exec;
355#    $href->{type_decl}=$type_decl;
356    $href->{prog_unit}=$unit_count;
357    $href->{number}=$number;
358    unless($content eq 'comment') {
359      $href->{multi_line} = 1 if(tr/\n// > 1);
360    }
361  }
362
363
364# Find first executable statement in each program unit
365# Also repair statement functions wrongly assigned as executable
366  my $prev_unit_count=-2;
367  my $stat_func_suspicion=0;
368  my @lastexec=();
369
370  foreach $href (@$statements) {
371    $exec=$href->{exec};
372    $unit_count=$href->{prog_unit};
373    if($exec) {
374      if($unit_count > $prev_unit_count) {
375        $content=$href->{content};
376        if($content eq 'array_assign') {
377          $stat_func_suspicion=1;
378          $_=$href->{statement};
379          if(/^\s*$name\s*\(\s*:/){
380            $stat_func_suspicion=0;
381#           print " A $_";
382           } 
383          elsif(/^\s*$name\s*\(\s*$name\s*:/){
384            $stat_func_suspicion=0;
385#           print " B $_";
386          } 
387          elsif(/^\s*$name\s*\(\s*\d+/){
388            $stat_func_suspicion=0;
389#           print " C $_";
390          }
391          else {
392            $href->{exec}=0;
393            $href->{decl}=5;
394            $href->{content}='statmf';
395#           print " D $_";
396            next;
397          }
398        }
399        $href->{exec}=2;
400        $prev_unit_count=$unit_count;
401        $content=$href->{content};
402      }
403      $lastexec[$unit_count]=$href->{number}  unless ($unit_count < 0); 
404# No prog_unit assigned, include file?
405    }
406  }
407
408# Assign last executable statement
409  if(@lastexec) {
410    foreach my $last (@lastexec) {
411      if(defined ($last)) {
412        if($$statements[$last]->{exec} == 1) {
413          $$statements[$last]->{exec}=3;
414        }
415        else{
416          $$statements[$last]->{exec}=23;
417        }     
418      }
419    }
420  }
421# Consistency checks
422  my $fail=0;
423  my $prev_exec=0;
424  $prev_unit_count=-1;
425  foreach $href (@$statements) {
426    $content=$href->{content};
427    next if($content eq 'comment');
428    $unit_count=$href->{prog_unit};
429    $exec=$href->{exec};
430    $decl=$href->{decl};
431    if($unit_count == $prev_unit_count) {
432      if($decl and $prev_exec) {
433        unless ($content eq 'FORMAT' | $content eq 'DATA' ) {
434          die $fname, ': declaration after executable statement', "\n",
435              $href->{first_line}, ' ', $href->{statement}, "\n";
436        }
437      }
438    }
439    $prev_unit_count=$unit_count;
440    $prev_exec=$exec;
441  }
442
443  $study_called=1;
444}
445
446#==========================================================================
447sub study_exec{
448  my($content,$prog_info,$study_called) = @_;
449  our ($name,$nest_par);
450  if(/^(\w+\s*:\s*)*IF\s*$nest_par\s*THEN/) {
451    $$content='IF_construct';
452  }
453  elsif(/^ELSE\s*IF\s*\(/) {
454    $$content='ELSEIF';
455  }
456  elsif(/^ELSE\b\s*($name)*/) {
457    $$content='ELSE';
458  }
459  elsif(/^END\s*IF\b\s*($name)*/) {
460    $$content='ENDIF';
461  }
462  elsif(/^(?:\d+\s+)?($name\s*:\s*)*DO(\s+WHILE)?\b/) {
463    $$content='DO';
464  }
465  elsif(/^(?:\d+\s+)?END\s*DO\b/) {
466    $$content='ENDDO';
467  }
468  elsif(/^(?:\d+\s+)?ALLOCATE\b/) {
469    $$content='ALLOCATE';
470  }
471  elsif(/^ASSIGN\b/) {
472    $$content='ASIGN';
473  }
474  elsif(/^(?:\d+\s+)?BACKSPACE\b/) {
475    $$content='BACKSPACE';
476  }
477  elsif(/^(?:\d+\s+)?CALL\b/) {
478    $$content='CALL';
479    if(!$$study_called) {
480      $$prog_info{no_calls}++;
481    }
482  }
483  elsif(/^(?:\d+\s+)?CLOSE\b/) {
484    $$content='CLOSE';
485  }
486  elsif(/^(?:\d+\s+)?CONTINUE\b/) {
487    $$content='CONTINUE';
488  }
489  elsif(/^(?:\d+\s+)?CYCLE\b/) {
490    $$content='CYCLE';
491  }
492  elsif(/^(?:\d+\s+)?DEALLOCATE\b/) {
493    $$content='DEALLOCATE';
494  }
495  elsif(/^ENDFILE\b/) {
496    $$content='ENDFILE';
497  }
498  elsif(/^(?:\d+\s+)?EXIT\b/) {
499    $$content='EXIT';
500  }
501  elsif(/^(?:\d+\s+)?GO\s*TO\b/) {
502    $$content='GOTO';
503  }
504  elsif(/^(?:\d+\s+)?IF\s*\(/) {
505    $$content='IF';
506  }
507  elsif(/^(?:\d+\s+)?INQUIRE\b/) {
508    $$content='INQUIRE';
509  }
510  elsif(/^(?:\d+\s+)?NULLIFY\b/) {
511    $$content='NULLIFY';
512  }
513  elsif(/^(?:\d+\s+)?OPEN\b/) {
514    $$content='OPEN';
515  }
516  elsif(/^(?:\d+\s+)?PAUSE\b/) {
517    $$content='PAUSE';
518  }
519  elsif(/^(?:\d+\s+)?PRINT\b/) {
520    $$content='PRINT';
521  }
522  elsif(/^(?:\d+\s+)?(?:READ|BUFFER\s*IN)\b/) {
523    $$content='READ';
524  }
525  elsif(/^(?:\d+\s+)?RETURN\b/) {
526    $$content='RETURN';
527  }
528  elsif(/^(?:\d+\s+)?REWIND\b/) {
529    $$content='REWIND';
530  }
531  elsif(/^(?:\d+\s+)?STOP\b/) {
532    $$content='STOP';
533  }
534  elsif(/^(?:\d+\s+)?(?:WRITE|BUFFER\s*OUT)\s*\(/) {
535    $$content='WRITE';
536  }
537  elsif(/^(?:\d+\s+)?($name\s*:\s*)*SELECT\s*CASE\b/) {
538    $$content='SELECT CASE';
539  }
540  elsif(/^(?:\d+\s+)?CASE\b/) {
541    $$content='CASE';
542  }
543  elsif(/^(?:\d+\s+)?END\s*SELECT\b/) {
544    $$content='END SELECT';
545  }
546  elsif(/^(?:\d+\s+)?WHERE\s*$nest_par\s*$name.*=/) {
547    $$content='WHERE';
548  }
549  elsif(/^(?:\d+\s+)?WHERE\s*\(/) {
550    $$content='WHERE_construct';
551  }
552  elsif(/^ELSE\s*WHERE\b/) {
553    $$content='ELSEWHERE';
554  }
555  elsif(/^END\s*WHERE\b/) {
556    $$content='ENDWHERE';
557  }
558  elsif(/^(?:\d+\s+)?FORALL\s*\(/) {
559    $$content='FORALL';
560  }
561  elsif(/^END\s*FORALL\b/) {
562    $$content='ENDFORALL';
563  }
564  elsif(/^(?:\d+\s+)?$name(?:\s*%\s*$name)*\s*=/o) {
565    $$content='scal_assign';
566  }
567  elsif(/^(?:\d+\s+)?$name(?:\s*$nest_par)*(?:\s*%\s*$name(?:\s*$nest_par)?)*\s*=/o) {
568    $$content='array_assign';
569  }
570}
571#===================================================================================
572sub pre_tidy {
573
574# Initial tidying to make the rest work
575
576  my($lines)=@_;
577  foreach (@$lines) {
578
579# Substitute tab with four blanks
580    s/\t/    /g;
581    s/^ *INTEGER /INTEGER_M /i;
582    s/^ *REAL /REAL_B /i;
583  }
584}
585#==========================================================================
586sub remove_macro {
587
588# Remove INTEGER_M, _ONE_ etc. macros and replace by expanded statement
589
590  my($lines)=@_;
591
592  my($im)=1; # Until I start checking include files
593  my($ia)=0;
594  my($ib)=0;
595  my($rb)=1; # Until I start checking include files
596  my($is)=0;
597  my($rh)=0;
598  my($rm)=0;
599  my(@pars,$string);
600  for (@$lines) {
601    next if(/^ *$/ | /^ *!/);
602# The following two substitutions should be restored at end of processing
603    s/(\'[^!]*)!+(.*\')/$1\£$2/;   # Protect against mischief
604    s/(["][^!]*)!+(.*["])/$1\£$2/;      # Protect against mischief
605    $im=$im+/JPIM\b/i unless($im);
606    $rb=$rb+/JPRB\b/i unless($rb);
607    $rm=$rm+/JPRM\b/i unless($rm);
608    $im=$im+s/\bINTEGER_M\b/INTEGER(KIND=JPIM)/o;
609    $ia=$ia+s/\bINTEGER_A\b/INTEGER(KIND=JPIA)/o;
610    $ib=$ib+s/\bINTEGER_B\b/INTEGER(KIND=JPIB)/o;
611    $is=$is+s/\bINTEGER_S\b/INTEGER(KIND=JPIS)/o;
612    $rb=$rb+s/\bREAL_B\b/REAL(KIND=JPRB)/o;
613    $rh=$rh+s/\bREAL_H\b/REAL(KIND=JPRH)/o;
614    $rm=$rm+s/\bREAL_M\b/REAL(KIND=JPRM)/o;
615    $rb=$rb+s/\b_ZERO_\b/0.0_JPRB/og;
616    $rb=$rb+s/\b_ONE_\b/1.0_JPRB/og;
617    $rb=$rb+s/\b_TWO_\b/2.0_JPRB/og;
618    $rb=$rb+s/\b_HALF_\b/0.5_JPRB/og;
619  }
620  @pars=();
621  push(@pars,"JPIM") if $im;
622  push(@pars,"JPRB") if $rb;
623  push(@pars,"JPRM") if $rm;
624  push(@pars,"JPIA") if $ia;
625  push(@pars,"JPIB") if $ib;
626  push(@pars,"JPIS") if $is;
627  ($string=join('     ,',@pars))=~s/ *$//;
628  for (@$lines) {
629    next unless (/^\#/);
630    if(@pars) {
631      s/^#include +"tsmbkind.h"/USE PARKIND1  ,ONLY : $string/ ;
632    }
633    else {
634      s/^#include +"tsmbkind.h"//;
635    }
636#    if($rh) {
637      s/^#include +"hugekind.h"/USE PARKIND2  ,ONLY : JPRH/ ;
638#    }
639#    else {
640#      s/^#include +"hugekind.h"// ;
641#    }
642  }
643}
644
645#==========================================================================
646sub readfile  {
647# Read file
648  my($fname)=@_;
649  my(@lines);
650  if(!open(INFIL,$fname)) {
651    print STDERR "Can't open $fname for reading\n";
652    die("Can't open $fname for reading\n");
653  }
654  @lines=<INFIL>;
655  close INFIL;
656  (@lines);
657}
658
659#==========================================================================
660sub writefile  {
661# Write file
662  my($fname,$lines)=@_;
663  if(!open(OUTFIL,">".$fname)) {
664    print STDERR "Can't open $fname for writing\n";
665    exit;
666  }
667  print OUTFIL @$lines;
668  close OUTFIL;
669}
670
671#==========================================================================
672sub expcont {
673#
674# Expand continuation lines into statements for free-format Fortran while
675# maintaining line-breaking and all comments
676# Put statements onto array of references to anonymous hashes as key 'statement'
677# Also put into the hash the linenumber of first line of statement as key 'first_line'
678  my ($lines, $statements) = @_;
679  my ($statm, $first_line);
680
681  my $prev        = 0;
682  my $line_number = 0;
683
684  for (@$lines) {
685    $line_number++;
686
687    s/^([^'"]*)(?:\s*!.*)$/$1/; # Remove trailing comments
688
689    s/^(\s*)&(.*)$/$1$2/s;
690
691    if (!/^\s*!.*$/ && /^.+?&(?:\s*!.*)*\s*$/) {
692      s/(.+?)&(.+)/$1\n/s;
693
694      $statm     .= $_;
695      $first_line = $line_number unless $prev;
696      $prev       = 1;
697      next;
698
699    } elsif ($prev && /^\s*(?:!|$)/) { # ignore blank/comment lines
700      next;
701
702    } else {
703      s/!.*?$//;
704
705      $statm     .= $_;
706      push @$statements, {
707        'statement'  => $statm,
708        'first_line' => $prev ? $first_line : $line_number,
709      };
710
711      $statm = "";
712      $prev  = 0;
713    }
714  }
715}
716#==========================================================================
717
718sub cont_lines {
719#
720# Put back continuation character in correct place and execute delayed actions
721#
722  my($statements,$lines,$line_hash) = @_;
723  my(@temp,$i,$iup,$href);
724
725
726# Put back continuation characters and split statements into lines as they were
727  @$lines=();
728  @$line_hash=();
729  foreach $href (@$statements) {
730    $_=$href->{statement};
731    if (/\n.*\n/){                      # This is a multi-line statement
732      @temp=split /\n/;                 # Split statement into lines (removes EOL)
733      $iup=scalar(@temp);               # Number of lines in statement
734      for ($i=0;$i < $iup;$i++) {       # Loop through lines
735        $_=$temp[$i];
736        if($i == 0 ){                   # First line
737          if(/^([^!]+)(!.*)$/) {        # Line has trailing comment
738            s/^([^!]+)(!.*)$/$1&$2\n/;  # Put back & at end of line before comment
739          }
740          else {                        # No trailing comment
741            s/^([^!]+)$/$1&\n/;         # Put back & and EOL at end of line
742          }         
743        }
744        elsif ($i == ($iup-1)) {        # Last line
745          s/^( *)(.*)$/$1& $2 \n/;      # Put back & at beginning of line
746        }
747        else {                          # Other lines
748          if (/^ *!/) {                 # Line is comment line
749            $_=$_."\n";                 # Restore EOL for comments
750          }
751          else {
752            if(/^( *)([^!]*)(!.*)$/) {  # Line has trailing comment
753              s/^( *)([^!]*)(!.*)*$/$1& $2&$3\n/;  # & at beginning and end of line
754            }
755            else {                      # No trailing comment
756              s/^( *)([^!]*)$/$1& $2&\n/; # & at beggining and end of line
757            }   
758          } 
759        }
760        if($i == 0        && exists $href->{pre_insert}) {
761          my @templines=split('\n',$href->{pre_insert});
762          foreach my $tline (@templines) {
763            my $rec={};
764            $rec->{'content'}='unknown';
765            $rec->{'line'}=$tline."\n";
766            push(@$lines,$rec->{'line'});
767            push(@$line_hash,$rec);
768          }
769        }
770        unless(exists $href->{remove}) {
771          my $rec={};
772          $rec->{'line'}=$_;
773          if($i == 0) {
774            $rec->{'content'}=$href->{content};
775          }
776          else {
777            $rec->{'content'}='cont_line';
778          }
779          push(@$lines,$rec->{'line'});
780          push(@$line_hash,$rec);
781        }
782        if($i == ($iup-1) && exists $href->{post_insert}) {
783          my @templines=split('\n',$href->{post_insert});
784          foreach my $tline (@templines) {
785            my $rec={};
786            $rec->{'content'}='unknown';
787            $rec->{'line'}=$tline."\n";
788            push(@$lines,$rec->{'line'});
789            push(@$line_hash,$rec);
790          }
791        }
792      }
793    }
794    else {  # Not multiline statement
795      if(exists $href->{pre_insert}) {
796        my @templines=split('\n',$href->{pre_insert});
797        foreach my $tline (@templines) {
798          my $rec={};
799          $rec->{'content'}='unknown';
800          $rec->{'line'}=$tline."\n";
801          push(@$lines,$rec->{'line'});
802          push(@$line_hash,$rec);
803        }
804      }
805      unless(exists $href->{remove}) {
806        my $rec={};
807        $rec->{'line'}=$_;
808        $rec->{'content'}=$href->{content};
809        push(@$lines,$rec->{'line'});
810        push(@$line_hash,$rec);
811#       print $rec;
812      }
813      if(exists $href->{post_insert}) {
814        my @templines=split('\n',$href->{post_insert});
815        foreach my $tline (@templines) {
816          my $rec={};
817          $rec->{'content'}='unknown';
818          $rec->{'line'}=$tline."\n";
819          push(@$lines,$rec->{'line'});
820          push(@$line_hash,$rec);
821        }
822      }
823    }
824  }
825}
826#==========================================================================
827sub getvars {
828# Return list of locally declared variables with type and scope information
829#
830  my($statements,$prog_info,$vars,$use_vars) = @_;
831  my ($test,$type,@vars1,$func,$prog_unit,$dum,$tmp_name,@pu_args);
832  my ($preserve,$rank,$href);
833  our($nest_par,$name);
834
835  %$vars=();
836  $func="";
837  $prog_unit=0;
838  %$use_vars=();
839  foreach $href (@$statements) {
840    next if($href->{content} eq 'comment');           # Skip comments
841    next if($href->{exec});                        # Don't look in executable statements
842    next if($$prog_info{is_module} and ! $href->{in_contain}); # Unless inside CONTAIN skip module
843    $prog_unit=$href->{prog_unit};
844    if($href->{content} eq 'FUNCTION') {
845      $_=$href->{statement};
846      my $dum=&parse_prog_unit(\$func,\@pu_args);          # Get name of FUNCTION
847#      print "GETVARS FUNCTION $func \n";
848      $func=uc($func);
849    }
850    if($href->{decl} == 2 or $href->{content} eq 'EXTERNAL'){  # Real parse starts
851      $_=$href->{statement};
852      $_=uc($_);                                   # Upcase to avoid /.../i
853      s/^ *//;                                     # remove leading blanks
854      if($href->{decl} == 2) {
855        $type=lc(substr($href->{content},0,1));
856      }
857      else {
858        $type='e';
859      }
860      s/\!.*\n/\n/g;                               # Remove trailing comments in all lines
861      $preserve=$_;
862      s/(.+)::(.+)/$2/s;                           #REAL(KIND=JPRB) :: zsig(:) -> zsig(:),
863      s/^EXTERNAL (.+)$/$1/;
864      s/\s+//g;                                    # Remove all white-space
865      if($href->{content} eq 'CHARACTER') {
866        s/($name)\*\d+/$1/g;
867        s/($name)\*$nest_par/$1/g;
868        s/($name)$nest_par\*\w+/$1/g;
869      }
870      s#=\(/.+/\)##;      # ZVAL(1:2)=(/1.0,2.0/) -> ZVAL(1:2)
871#?      s/=[^,\n]+//g;
872      s/$nest_par//g;     # ISEC3(SIZE(NSEC3)),ISEC4(SIZE(NSEC4)) -> ISEC3,ISEC4
873      s/=\w+//g;          # ZVAL=1.0 -> ZVAL
874      s@/.*/@@;           # What?
875      @vars1=split(',',$_);
876      for(@vars1) {
877        next unless /^$name$/;          # A bit of security
878        if($preserve =~ /\b$_\b *\(/ | $preserve =~ /DIMENSION/) {
879          $rank=1;        # Variable is array
880        }
881        else {
882          $rank=0;        # Variable is scalar
883        }
884        if($_ eq $func) {
885          $$vars{$_}{type_spec}="f";
886        } 
887        else {
888          if($href->{content} eq 'FUNCTION') {
889            $$vars{$_}{type_spec}='f';
890          }
891          else {
892            $$vars{$_}{type_spec}=$type;
893          }
894        }
895        $$vars{$_}{scope}=$prog_unit;
896        $$vars{$_}{rank}=$rank;
897        $$vars{$_}{usage}='local';
898      }
899    }
900# Perhaps the variable is really a statement function?
901    if($href->{decl} == 5) {
902      $_=$href->{statement};
903      s/\s+//g;                                    # Remove all white-space
904      /^($name)\((.+)\)=/i;
905      my $tvar=uc($1);
906      my @stmf_args=split(',',$2);
907      if (exists($$vars{$tvar})) {
908        $$vars{$tvar}{type_spec}='s';
909#       print "STATMF OK $tvar \n ";
910      }
911      for (@stmf_args) {
912        if (exists($$vars{$_})) {
913          $$vars{$_}{type_spec}='s';
914#         print "STATMF ARG OK $_ \n ";
915        }
916      }
917    }
918  }
919# Perhaps instead the variable is a declaration of an external function?
920  my @extract=();                  # Extract part of statements for efficiency
921  foreach $href (@$statements) {
922    if($href->{exec}) {                 # Function call must be in executable stat.
923      next if($href->{content} eq 'CALL'); # A call can't contain an undeclared function
924      push(@extract,$href->{statement});
925    }
926  }
927 
928  foreach my $var (keys (%$vars)) {
929    next if($$vars{$var}{rank} > 0);   # Can't be a function if rank > 0
930    next if($$vars{$var}{type_spec} eq 's' | $$vars{$var}{type_spec} eq 'f');
931    my $dec_unit=$$vars{$var}{scope};
932    my $regex1=qr/\b$var\b\s*\(/i;      # As var's rank=0 this could be function call
933    for(@extract) {
934      if(/${regex1}/) {
935        s/\!.*\n/\n/g;                       # Remove trailing comments in all lines
936        s/\s+//g;                            # Remove all white-space
937        if(/${regex1}/) {
938          if($$vars{$var}{type_spec} eq 'c') {   # Avoid CLVAR(1:3) etc.
939            next if(/${regex1}\s*(\d+|$name)*\s*:\s*(\d+|$name)*\s*\)/);
940          }
941#         print "TYPE changed to function $var $_ \n";
942          $$vars{$var}{type_spec}='f';
943          last;
944        }
945      }
946    }
947  }
948# ---------------------------------------------------------------------
949# Assign  "usage" in Doctor sense to variable (default usage is 'local')
950#
951  foreach $href (@$statements) {
952# Is the varaible a dummy argument
953    if($href->{content} eq 'FUNCTION' or $href->{content} eq 'SUBROUTINE') {
954      $_=$href->{statement};
955      @pu_args=();
956      my $dum=&parse_prog_unit(\$func,\@pu_args);   # Get arguments
957      for(@pu_args) {
958        if( exists $$vars{$_} ) {
959          if($$vars{$_}{scope} == $href->{prog_unit}) {
960            $$vars{$_}{usage}='arg';
961          }
962
963        } else {
964          print STDERR "Argument $_ has not got a corresponding declaration " .
965                       "statement\n";
966          print STDERR "Bailing out at this point\n";
967          die "Bailing out";
968        }
969      }
970    }
971# Does the variable appear in a NAMELIST
972# We want to distinguish this for more lenient Doctor check
973    if($href->{content} eq 'NAMELIST') {
974      $_=$href->{statement};
975      s/\!.*\n/\n/g;     # Remove trailing comments in all lines
976      s/\s+//g;          # Remove all white-space
977      m:NAMELIST/\w+/(.+):;
978      my @namvars=split(',',uc($1));
979      for (@namvars) {
980        if( exists $$vars{$_} ) {
981          if($$vars{$_}{scope} == $href->{prog_unit}) {
982            $$vars{$_}{usage}='namvar';
983          }
984        }
985      }
986    }
987    if(exists $href->{inc_statm}) { # We also have to look in include files
988      my $incs=$href->{inc_statm};
989      foreach my $hrefi (@$incs) {
990        if($hrefi->{content} eq 'NAMELIST') {
991          $_=$hrefi->{statement};
992          s/\!.*\n/\n/g;     # Remove trailing comments in all lines
993          s/\s+//g;          # Remove all white-space
994        m:NAMELIST/\w+/(.+):;
995          my @namvars=split(',',uc($1));
996          for (@namvars) {
997            if( exists $$vars{$_} ) {
998              if($$vars{$_}{scope} == $href->{prog_unit}) {
999                $$vars{$_}{usage}='namvar';
1000              }
1001            }
1002          }
1003        }
1004      }
1005    }
1006  }
1007# -----------------------------------------------------------------------------
1008# Find use variables
1009  my %use_count=();
1010  foreach $href (@$statements) {
1011    if($href->{content} eq 'USE') {
1012      $prog_unit=$href->{prog_unit};
1013      $_=$href->{statement};
1014      s/\!.*\n/\n/g;                               # Remove trailing comments in all lines
1015      s/\s+//g;                                    # Remove all white-space
1016      $_=uc($_);                                   # Upcase to avoid /.../i
1017      if(/^USE($name),ONLY:(.+)$/){
1018        my $modname=$1;
1019        if( exists $use_count{$modname}) {
1020          if($prog_unit == $use_count{$modname}) {
1021            print STDERR "-> $href->{statement}";
1022            print STDERR "USE $modname appears more than once in program unit $prog_unit \n\n";
1023
1024          }
1025        }
1026        $use_count{$modname} = $prog_unit;
1027        my @usevars = split /,/ ,$2;
1028        my %usevars=();
1029        foreach my $usevar (@usevars) {
1030          $usevars{$usevar}++;
1031          $$use_vars{$usevar}{module}=$modname;
1032          $$use_vars{$usevar}{scope}=$prog_unit;
1033          $$use_vars{$usevar}{count}++;
1034        }
1035        foreach my $usevar (keys (%usevars)) {
1036          if($usevars{$usevar} >1) {
1037            print STDERR "DUPLICATE USE ONLY VARIABLE ",
1038            "$modname $usevar $prog_unit \n";
1039            $_=$href->{statement};
1040            s/\b$usevar\b//i;
1041            s/,\s*,/,/;
1042            s/,\s*\n$/\n/;
1043            s/\n *\n/\n/;
1044            s/^(.+:\s*),/$1/;
1045            $href->{statement}=$_;
1046          }
1047        }
1048      }
1049      else {
1050#       print "WARNING:USE without ONLY \n";
1051      }
1052    }
1053  }
1054}
1055#==========================================================================
1056sub find_unused_vars {
1057# Find declared variables not used
1058  my($statements,$vars,$unused_vars,$use_vars,$unused_use_vars) = @_;
1059  my ($var,@tokens,$href);
1060  @tokens=();
1061# Find all tokens in file
1062  foreach $href (@$statements) {
1063    next if($href->{content} eq 'comment');
1064    if(exists $href->{inc_statm}) {  # Look also in include files
1065      my $incs=$href->{inc_statm};
1066      foreach my $hrefi (@$incs) {
1067        die "FUV $href->{content} $href->{statement}" unless exists $hrefi->{statement};
1068        $_=$hrefi->{statement};
1069        if(/\b[a-zA-Z]\w*\b/) {
1070          push(@tokens,/\b[a-zA-Z]\w*\b/g);
1071        }
1072      }
1073    }
1074    else {
1075      $_=$href->{statement};
1076      push(@tokens,/\b[a-zA-Z]\w*\b/g);
1077    }
1078  }
1079  @tokens= map {uc} @tokens; # Upcase array of tokens, the variables are upper-case
1080
1081# Find out how many times the variable appears in array tokens
1082  foreach $var (keys (%$vars)) {
1083    $$vars{$var}{uses}=0;
1084  }
1085  foreach $var (keys (%$use_vars)) {
1086    $$use_vars{$var}{uses}=0;
1087  }
1088  for (@tokens) {
1089    if(exists($$vars{$_})){
1090      $$vars{$_}{uses}++; 
1091    }
1092    if(exists($$use_vars{$_})){
1093      $$use_vars{$_}{uses}++; 
1094    }
1095  }
1096# If it appears only one time (which must be in a declaration) it is unused
1097  @$unused_vars=();
1098  foreach $var (keys (%$vars)) {
1099    push(@$unused_vars,$var) if($$vars{$var}{uses} < 2);
1100  }
1101  @$unused_use_vars=();
1102  foreach $var (keys (%$use_vars)) {
1103    push(@$unused_use_vars,$var) if($$use_vars{$var}{uses} < 2);
1104  }
1105}
1106#==========================================================================
1107sub remove_unused_vars {
1108# Does what it says on the tin
1109  my($statements,$unused_vars,$unused_use_vars) = @_;
1110  my ($var,$href);
1111  our $nest_par;
1112  for (@$unused_vars) {
1113    $var=$_;
1114    foreach $href (@$statements) {
1115      $_=$href->{statement};
1116      next unless(($href->{decl}) | ($href->{content} eq 'comment'));
1117      if($href->{content} eq 'comment') {
1118        next unless(/^ *!\$OMP/);
1119      }
1120      if(/\b$var\b/i) {
1121#       print $_;
1122       
1123        if(/\b$var\b *\(/i) {
1124#         print "ZYZ $var $_";
1125          s/\b$var\b *$nest_par *(=\s*\(\/.*\/\))*//si;
1126#         print "ZZZ $var $_";
1127        }
1128        s/\b$var\b\s*=\s*\d+(\.\d*)*//i;
1129        s/\b$var\b *(\* *\d+)*//i if($href->{content} eq 'CHARACTER') ;
1130        s/\b$var\b//i; 
1131#       print $_;
1132        s/^.+:: *\n$//;
1133        s/^.+:: *\!.*\n$//;
1134#       print $_;
1135        s/,\s*,/,/;
1136#       print $_;
1137        s/, *\n$/\n/;
1138#       print $_;
1139        s/(::\s*),(.+)$/$1$2/s;
1140        s/\n *\n/\n/;
1141        s/\n *!.*\n/\n/;
1142        s/, *\n$/\n/;
1143# Remove "empty" lines
1144        s/^.+::\s*$//;
1145        s/^.+::\s*=.*$//;
1146        s/^.+::\s*!.*$//;
1147#       print $_;
1148        s/^CHARACTER *\*\d+ *\n$//i if($href->{content} eq 'CHARACTER') ;
1149        $href->{statement}=$_;
1150      }
1151    }
1152  }
1153  for (@$unused_use_vars) {
1154    $var=$_;
1155    foreach $href (@$statements) {
1156      next unless($href->{decl} == 4);
1157      $_=$href->{statement};
1158      next if(/PARKIND/); #I am sure this could be done betterh
1159
1160      if(/\b$var\b/i) {
1161        s/\b$var\b//i;
1162        s/,\s*,/,/;
1163        s/,\s*\n$/\n/;
1164        s/\n *\n/\n/;
1165        s/^(.+:\s*),/$1/;
1166        s/^.+:\s*$//;
1167        $href->{statement}=$_;
1168      }
1169    }
1170  }
1171}
1172#==========================================================================
1173sub tidy_decl {
1174# Tidy up declarions
1175  my($statements) = @_;
1176  my($href,$content);
1177
1178  foreach $href (@$statements) {
1179    next unless($href->{decl} == 2);
1180    $_=$href->{statement};
1181    $content=$href->{content};
1182   
1183    if($content eq 'CHARACTER') {
1184      s/CHARACTER *\* *(\w+)/CHARACTER \(LEN = $1\)/i; 
1185      s/CHARACTER *\* *\(\*\)/CHARACTER \(LEN = \*\)/i;
1186      s/CHARACTER *\* *\( *(\w+) *\)/CHARACTER \(LEN = $1)/i;
1187    }
1188    if($content eq 'INTEGER') {
1189      if(/^ *INTEGER[^\(]/i) {
1190        s/INTEGER\b/INTEGER(KIND=JPIM)/;
1191      }
1192    }
1193    unless (/::/) {
1194      s/^( *LOGICAL )/$1:: /i;
1195      s/^( *INTEGER\(KIND=JPI\w\) )/$1:: /;
1196      s/^( *REAL\(KIND=JPR\w\) )/$1:: /;
1197      if(/^ *CHARACTER/i) {
1198        if( s/^( *CHARACTER *\( *LEN *= *\w+ *\))/$1 :: /i) {
1199          $href->{statement}=$_;
1200          next;
1201        }
1202        if(s/^( *CHARACTER *\( *LEN *= *\* *\))/$1 :: /i) {
1203          $href->{statement}=$_;
1204          next;
1205        }
1206        s/^( *CHARACTER )/$1:: /i;
1207      }
1208    }
1209    $href->{statement}=$_;
1210  }
1211}
1212#==========================================================================
1213
1214sub doctor_viol {
1215# Find Doctor violations
1216
1217  my($vars,$fix_doc) = @_;
1218  my ($var,$type,$zz,$prog_unit,$usage);
1219  %$fix_doc=();
1220
1221  foreach $var (keys (%$vars)) {
1222    $type=$$vars{$var}{type_spec};
1223    $prog_unit=$$vars{$var}{scope};
1224    $usage=$$vars{$var}{usage};
1225#    print "DOC $var $type $prog_unit $usage \n";
1226    if($zz=&doc_char($type,$usage,$var)) {
1227#      print "DOCTOR VIOL - ",$var," $type $zz $prog_unit\n";
1228      $$fix_doc{$var}=$zz.'_'.$var.','.$prog_unit
1229    }
1230  } 
1231}
1232#==========================================================================
1233
1234sub fix_doctor_viol {
1235# Fix Doctor violations
1236  my($statements,$fix_doc) = @_;
1237  my($doc_viol,$repl,$prog_unit,$cur_prog_unit,@allowed,$href,$content);
1238  my($tmp_name,@pu_args);
1239
1240  @allowed=('NRGRI'); # Hack
1241
1242  VIOL:foreach $doc_viol (keys (%$fix_doc)) {
1243    # Let's allow some violations
1244    for (@allowed){ 
1245      next VIOL if($doc_viol eq $_);
1246    }
1247
1248    ($repl,$prog_unit)=split(',',$$fix_doc{$doc_viol});
1249
1250    print "FIX $repl $prog_unit \n";
1251    foreach $href (@$statements) {
1252      $content=$href->{content};
1253      $_=$href->{statement};
1254      if($href->{content} eq 'comment') {
1255        next unless(/^ *!\$OMP/);
1256      }
1257      $cur_prog_unit=$href->{prog_unit};
1258      if($prog_unit == $cur_prog_unit) {  # Could be fine in other program units
1259        if(/\b$doc_viol\b/i) {
1260          s/%$doc_viol\b/_X_$doc_viol/ig; # Protect type-components
1261          s/\b$doc_viol\b/$repl/ig;
1262          s/_X_$doc_viol\b/%$doc_viol/ig; # Restore type-components
1263        }
1264      }
1265      $href->{statement}=$_;
1266    }
1267  }
1268 
1269}
1270#==========================================================================
1271sub various{
1272#
1273  my($statements,$prog_info,$vars) = @_;
1274  my($punit,@args,$tmp_name,$cont,$statm);
1275  my($href,$exec);
1276  our $nest_par;
1277#------------------------------------------------------------------
1278# Remove unneccesary RETURN statement
1279  foreach $href (@$statements) {
1280    $cont=$href->{content};
1281    if($cont eq 'RETURN') {
1282      if($href->{exec} == 3) {   # $href->{exec} == 3 means last executable statement
1283        $href->{remove} = 1;     # Post remove line for later
1284      }
1285    }
1286  }
1287
1288
1289# Make sure all CALL MPL_... has a CDSTRING argument
1290  foreach $href (@$statements) {
1291    $cont=$href->{content};
1292    if($href->{content} eq 'CALL' ) {
1293      $_=$href->{statement};
1294      if(/^\s*CALL\s+MPL_/i) {
1295        next if(/^\s*CALL\s+MPL_ABORT/i);
1296        next if(/^\s*CALL\s+MPL_WRITE/i);
1297        next if(/^\s*CALL\s+MPL_READ/i);
1298        next if(/^\s*CALL\s+MPL_OPEN/i);
1299        next if(/^\s*CALL\s+MPL_CLOSE/i);
1300        next if(/^\s*CALL\s+MPL_INIT/i);
1301        next if(/^\s*CALL\s+MPL_GROUPS_CREATE/i);
1302        next if(/^\s*CALL\s+MPL_BUFFER_METHOD/i);
1303        next if(/^\s*CALL\s+MPL_IOINIT/i);
1304        next if(/^\s*CALL\s+MPL_CART_COORD/i);
1305#       print "CDSTRING=$$prog_info{'unit_name'}[$href->{prog_unit}]: \n";
1306        unless(/CDSTRING\s*=/i) {
1307          s/\)(\s)$/,CDSTRING=\'$$prog_info{'unit_name'}[$href->{prog_unit}]:\'\)$1/;
1308          $href->{statement}=$_;
1309        }
1310      }
1311    }
1312  }
1313       
1314
1315
1316#------------------------------------------------------------------
1317# Add Standard Modification Line
1318
1319  my $start=0;
1320  foreach $href (@$statements) {
1321    $cont=$href->{content};
1322    if($cont eq 'comment') {
1323      $_=$href->{statement};
1324      if($start) {                        # Found header - look for end of mod lines
1325        if(/^ *$/ || /^! *------------------------/) {
1326          $href->{pre_insert} = "!        M.Hamrud      01-Oct-2003 CY28 Cleaning\n";
1327          last;
1328        }
1329        next;
1330      }
1331      $start=1 if(/^! +Modifications/i) ;  # This how the header should look
1332      next;
1333    }
1334    last if($href->{exec});                # We have failed - bail out
1335  }
1336
1337# Change subroutine and call multi-line statements so that the comma
1338# beetwen variables comes at the end of the line
1339  my @lines=();
1340  foreach $href (@$statements) {
1341    if(exists $href->{multi_line}) {
1342      $cont=$href->{content};
1343      if($cont eq 'SUBROUTINE' | $cont eq 'CALL' ) {
1344        $statm=$href->{statement};
1345        @lines=split "\n", $statm;
1346        @lines = reverse @lines;
1347        my $append_comma=0;
1348        for (@lines) {
1349#         print "A $append_comma $_ \n";
1350          next if(/^ *!/);
1351          if($append_comma) {
1352            if(/\S *!.*$/) {
1353              s/(\S)( *!.*)$/$1,$2/;
1354            }
1355            else {
1356              s/(\S) *$/$1,/;
1357            }
1358          }
1359          $append_comma=s/^ *,//;
1360#         print "B $append_comma $_ \n";
1361        }
1362        @lines = reverse @lines;
1363        $statm=join  "\n",@lines;
1364        $statm=$statm."\n";
1365        $href->{statement}=$statm;
1366      }
1367    }
1368  }
1369  our $name;
1370  foreach $href (@$statements) {
1371    if($href->{content} eq 'USE') {
1372      $_=$href->{statement};
1373      unless(/^\s*USE\s+$name\s*,\s*ONLY\s*:/i){
1374        print $_;
1375        print "WARNING:USE without ONLY \n";
1376      }
1377    }
1378  }   
1379}
1380#==========================================================================
1381sub insert_hook{
1382#
1383  my($statements,$prog_info,$vars) = @_;
1384  my($punit,@args,$tmp_name,$cont,$statm);
1385  my($href,$exec);
1386  our $nest_par;
1387#------------------------------------------------------------------
1388# Add HOOK function
1389  my $unit_name='';
1390  my $last_use=0;
1391  my $hook_status=0;
1392  my $in_contain=0;
1393  my $prev_prog=0;
1394  my ($decl,$remember);
1395  foreach $href (@$statements) {
1396    $cont=$href->{content};
1397    next if($cont eq 'comment');
1398
1399    $decl=$href->{decl};
1400    $exec=$href->{exec};
1401    $in_contain=$href->{in_contain};
1402    if(! $in_contain and $href->{prog_unit} > $prev_prog) {
1403      $hook_status=0;
1404      $prev_prog=$href->{prog_unit};
1405      print "resetting hook status \n";
1406    }
1407
1408    if($cont eq 'FUNCTION' or $cont eq 'SUBROUTINE' or 
1409       $cont eq 'PROGRAM'){ # Need name of routine
1410      $_=$href->{statement};
1411      &parse_prog_unit(\$unit_name,\@args);
1412      $unit_name=uc($unit_name);
1413# If in module pre-pend module name
1414      $unit_name=$$prog_info{module_name}.':'.$unit_name if($$prog_info{is_module}); 
1415      $remember=0;
1416    }
1417
1418    if($hook_status == 0) {   # $hook_status == 0 means we have not done anything yet
1419      if($cont eq 'USE') {    # Add USE YOMHOOK as second use statement
1420        $href->{post_insert}="USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\n";
1421        $hook_status=1;
1422      }
1423      elsif($cont eq 'IMPLICIT NONE') { # No previous USE, add USE YOMHOOK before IMPLICIT NONE
1424        $href->{pre_insert} ="USE PARKIND1  ,ONLY : JPRB\n".
1425          "USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK\n";
1426        $hook_status=1;
1427      } 
1428    }
1429    $remember=$href->{number} if($decl == 2); 
1430
1431#   Use statement added ($hook_status == 1), now insert HOOK switch on statement
1432#   before first executable statement in program unit ($exec == 2)
1433    if($hook_status == 1 && $exec == 2) {
1434      if($remember) {
1435        $$statements[$remember]->{post_insert}="REAL(KIND=JPRB) :: ZHOOK_HANDLE\n";
1436        $href->{pre_insert}="IF (LHOOK) CALL DR_HOOK(\'${unit_name}\',0,ZHOOK_HANDLE)\n";
1437      }
1438      else {
1439        $href->{pre_insert}="REAL(KIND=JPRB) :: ZHOOK_HANDLE\n".
1440            "IF (LHOOK) CALL DR_HOOK(\'${unit_name}\',0,ZHOOK_HANDLE)\n";
1441      }   
1442      if($cont eq 'IF') {
1443        if($href->{content2} eq 'RETURN') {
1444          $_=$href->{statement};
1445          s/(\s*IF\s*$nest_par).*\n/$1/i;
1446          s/\)$/ .AND. LHOOK\)/;
1447          $href->{pre_insert}=$href->{pre_insert}."$_ CALL DR_HOOK(\'${unit_name}\',1,ZHOOK_HANDLE)\n";
1448        }
1449      }
1450      $hook_status=2;
1451    }
1452#   Hook switched on($hook_status == 2), switch off after last executable statement
1453#   ($exec == 3)
1454    elsif($hook_status == 2) {
1455      if($exec == 3 or $exec == 23) {
1456        $href->{post_insert}="IF (LHOOK) CALL DR_HOOK(\'${unit_name}\',1,ZHOOK_HANDLE)\n";
1457        $hook_status=3;
1458      }
1459      elsif($cont eq 'RETURN') {
1460        $href->{pre_insert}="IF (LHOOK) CALL DR_HOOK(\'${unit_name}\',1,ZHOOK_HANDLE)\n";
1461      }
1462      elsif($cont eq 'IF') {
1463        if($href->{content2} eq 'RETURN') {
1464          $_=$href->{statement};
1465          s/(\s*IF\s*$nest_par).*\n/$1/i;
1466          s/\)$/ .AND. LHOOK\)/;
1467          $href->{pre_insert}="$_ CALL DR_HOOK(\'${unit_name}\',1,ZHOOK_HANDLE)\n";
1468        }
1469      } 
1470    }
1471    $hook_status=1 if($in_contain && $hook_status==3); # Reset hook status in CONTAIN region
1472  }
1473  die "Adding HOOK function failed " if($hook_status == 2);
1474}
1475#==========================================================================
1476
1477sub doc_char{
1478# Returns suggested prefix in case of DOCTOR violation (otherwise null string)
1479  my($type,$usage,$var) = @_;
1480  my $prefix="";
1481# INTEGER variables
1482  if( $type eq "i") {
1483    if($usage eq "arg") {
1484      $prefix="K" unless($var=~/^K/i);
1485    }
1486    elsif($usage eq "local") {
1487      $prefix="I" unless($var=~/^[IJ]/i);
1488    }
1489    elsif($usage eq "module") {
1490      $prefix="N" unless($var=~/^[MN]/i);
1491    }
1492    elsif($usage eq "namvar") {
1493      $prefix="I" unless($var=~/^[MNIJ]/i);
1494    }
1495    else { 
1496      die "Unknown usage";
1497    }
1498  }
1499# REAL variables
1500  elsif( $type eq "r") {
1501    if($usage eq "arg") {
1502      $prefix="P" unless($var=~/^P/i);
1503    }
1504    elsif($usage eq "local") {
1505      $prefix="Z" unless($var=~/^Z|^PP/i);
1506    }
1507    elsif($usage eq "module") {
1508      $prefix="R" if ($var=~/^[ZPIJKLMNCY]/i);
1509    }
1510    elsif($usage eq "namvar") {
1511      $prefix="Z" if ($var=~/^[PIJKLMNCY]/i);
1512    }
1513    else { 
1514      die "Unknown usage";
1515    }
1516  }
1517#LOGICAL variables
1518  elsif( $type eq "l") {
1519    if($usage eq "arg") {
1520      $prefix="LD" unless($var=~/^LD/i);
1521    }
1522    elsif($usage eq "local") {
1523      $prefix="LL" unless($var=~/^LL/i);
1524    }
1525    elsif($usage eq "module") {
1526      $prefix="L" unless($var=~/^L[^LD]/i);
1527    }
1528    elsif($usage eq "namvar") {
1529      $prefix="LL" unless($var=~/^L/i);
1530    }
1531    else { 
1532      die "Unknown usage";
1533    }
1534  }
1535#CHARACTER variables
1536  elsif( $type eq "c") {
1537    if($usage eq "arg") {
1538      $prefix="CD" unless($var=~/^CD/i);
1539    }
1540    elsif($usage eq "local") {
1541      $prefix="CL" unless($var=~/^CL/i);
1542    }
1543    elsif($usage eq "module") {
1544      $prefix="C" unless($var=~/^C[^LD]/i);
1545    }
1546    elsif($usage eq "namvar") {
1547      $prefix="CL" unless($var=~/^C/i);
1548    }
1549    else { 
1550      die "Unknown usage";
1551    }
1552  }
1553# USER DEFINED TYPES
1554  elsif( $type eq 't') {
1555    if($usage eq "arg") {
1556      $prefix="YD" unless($var=~/^YD/i);
1557    }
1558    elsif($usage eq "local") {
1559      $prefix="YL" unless($var=~/^YL/i);
1560    }
1561    elsif($usage eq "module") {
1562      $prefix="Y" unless($var=~/^Y[^LD]/i);
1563    }
1564    elsif($usage eq "namvar") {
1565      $prefix="YL" unless($var=~/^Y/i);
1566    }
1567    else { 
1568      die "Unknown usage";
1569    }
1570  }
1571# FUNCTION/EXTERNAL declarations
1572  elsif( $type eq 'f' || $type eq 'e' || $type eq 's') {
1573# Everything is OK
1574  }
1575  else {
1576    die "Unknown type $type"
1577  }
1578  ($prefix);
1579}
1580#==========================================================================
1581     
1582sub parse_prog_unit {
1583  # Find out type (return), name ($$unit_name) and arguments (@$args)
1584  # from a program unit statement ($_)
1585  my ($unit_name, $args) = @_;
1586  $$unit_name = '';
1587  @$args      = ();
1588
1589  my $type = '';
1590
1591  our ($name, $type_spec, $attribute);
1592
1593  if (/^\s*(MODULE|PROGRAM|BLOCK\s*DATA)\s+($name)\s*$/io) {
1594    $type       = lc ($1);
1595    $$unit_name = $2;
1596
1597    # Remove space from "block data"
1598    $type       =~ s/\s*//;
1599
1600  } elsif (/^\s*(?:$attribute)?\s*(SUBROUTINE)\s+($name)\b/io or
1601           /^\s*(?:$attribute)?\s*(?:$type_spec)?\s*(FUNCTION)\s+($name)\b/io) {
1602    $type       = lc ($1);
1603    $$unit_name = $2;
1604
1605    # Get arguments/keywords from SUBROUTINE/FUNCTION
1606    if(/^[^\(]+\([^\)]+\)/) {
1607      my $tstatm = $_;
1608
1609      # Remove trailing comment
1610      $tstatm =~ s/\!.*\n/\n/g;
1611
1612      # Remove space characters
1613      $tstatm =~ s/\s//g;
1614
1615      # Add the RESULT clause to the argument/keyword list
1616      $tstatm =~ s/\)result\((\w+\))$/,$1/i if $type eq 'function';
1617
1618      # Remove the parenthesis around the argument list
1619      $tstatm =~ s/.+\((.+)\)/$1/;
1620
1621      @$args = split (',', uc ($tstatm));
1622
1623      # For FUNCTION, add its name to the list if necessary
1624      push @$args, uc ($$unit_name)
1625        if $type eq 'function' and not grep {$_ eq uc ($$unit_name)} @$args;
1626    }
1627  }
1628
1629  return $type;
1630}
1631
1632#==========================================================================
1633
1634sub setup_parse {
1635  # Set up some "global" variables that helps with parsing statements
1636
1637  # Pattern for nested parenthesis
1638  our $nest_par;
1639  $nest_par = qr/\((?:(?>[^()]+)|(??{$nest_par}))*\)/; #Camel p214
1640
1641  # Patterns for variable name and natural digit
1642  our $name='[a-zA-Z]\w*';
1643  our $digit_string='\d+';
1644  our $type_name=$name;
1645
1646  # Patterns for specification
1647  our $specification_expr='(?:'.$name.'|'.$digit_string.')'; # Simplification
1648  our $type_param_value='(?:\*|'.$specification_expr.')';
1649
1650  # Patterns for length/kind attributes
1651  our $char_selector='LEN *= *'.$type_param_value; # Simplification
1652  our $kind_selector='\( *KIND *= *'.$name.' *\)';    # Simplification
1653
1654  # Pattern for type specification
1655  our $type_spec='INTEGER *(?:'.$kind_selector.')?|REAL *(?:'.$kind_selector.
1656    ')?|DOUBLE PRECISION|COMPLEX *(?:'.$kind_selector.')?|CHARACTER *'.
1657    $char_selector.'|LOGICAL *(?:'.$kind_selector.')?|TYPE\s*\(\s*'.$type_name.
1658    '\s*\)';
1659
1660  # Pattern for function/subroutine attribute
1661  our $attribute = 'ELEMENTAL|(?:RECURSIVE(?:\s+PURE)?|PURE(?:\s+RECURSIVE)?)';
1662
1663  return;
1664}
1665
1666#==========================================================================
1667
1668sub f90_indent {
1669# Indent free-format F90 program to our standards
1670  my($line_hash,$lines)=@_;
1671  my($delta)='  '; 
1672  my($cur_indent)='';
1673  @$lines=();
1674  foreach my $href (@$line_hash) {
1675    $_=$href->{line};
1676    if($href->{content} eq 'comment') {
1677      push(@$lines,$_);
1678      next;
1679    }
1680    s/^ *//; # Remove current indentation
1681    my($post_chg)=0;
1682    my($pre_chg)=0;
1683    my($cont_line)='';
1684    exit if (! exists $href->{content});
1685    if($href->{content} eq 'DO') {
1686      $post_chg=1 unless /^DO\s+\d/;
1687    }
1688    elsif($href->{content} eq 'ENDDO') {
1689      $pre_chg=1;
1690    }
1691    elsif($href->{content} eq 'IF_construct') {
1692      $post_chg=1;
1693    }
1694    elsif($href->{content} eq 'ELSEIF') {
1695      $post_chg=1;
1696      $pre_chg=1;
1697    }
1698    elsif($href->{content} eq 'ELSE') {
1699      $post_chg=1;
1700      $pre_chg=1;
1701    }
1702    elsif($href->{content} eq 'ENDIF') {
1703      $pre_chg=1;
1704    }
1705    elsif($href->{content} eq 'ENDIF') {
1706      $pre_chg=1;
1707    }
1708    elsif($href->{content} eq 'WHERE_construct') {
1709      $post_chg=1;
1710    }
1711    elsif($href->{content} eq 'ELSEWHERE') {
1712      $post_chg=1;
1713      $pre_chg=1;
1714    }
1715    elsif($href->{content} eq 'ENDWHERE') {
1716      $pre_chg=1;
1717    }
1718    elsif($href->{content} eq 'ENDIF') {
1719      $pre_chg=1;
1720    }
1721    elsif($href->{content} eq 'SELECT CASE') {
1722      $post_chg=1;
1723    }
1724    elsif($href->{content} eq 'CASE') {
1725      $post_chg=1;
1726      $pre_chg=1;
1727    }
1728    elsif($href->{content} eq 'END SELECT') {
1729      $pre_chg=1;
1730    }
1731    $cont_line=' ' if($href->{content} eq 'cont_line');
1732    if( $pre_chg ) {
1733      unless($cur_indent=~s/^$delta//o) {
1734        print STDERR $_;
1735        die  "f90_indent: something wrong, indent negative\n";;
1736      }
1737    }
1738#    print "$cur_indent$cont_line$_";
1739   
1740    $_=$cur_indent.$cont_line.$_;
1741    push(@$lines,$_);
1742    $cur_indent.=$delta if( $post_chg );
1743  }
1744
1745  if(! ($cur_indent eq '')) {
1746    die "f90_indent: something wrong, indent=XX${cur_indent}XX\n";
1747  }
1748}
1749
1750#==========================================================================
1751
1752sub tidy {
1753# Straigthforward tidiyng of statements
1754  my($statements) = @_;
1755  my($href,$content);
1756  foreach $href (@$statements) {
1757    $_=$href->{statement};
1758    $content=$href->{content};
1759# Substitute tab with four blanks
1760    s/\t/    /g;
1761    if($content eq 'comment') {
1762# Substitute empty comment line with empty line
1763      s/^[!] *\n$/\n/;
1764      $href->{statement}=$_;
1765      next;
1766    }
1767    if($href->{exec}) {
1768      if($content eq 'ENDDO') {
1769        s/\bEND DO\b/ENDDO/i;
1770        $href->{statement}=$_;
1771        next;
1772      }
1773      if($content eq 'ENDIF') {
1774        s/\bEND IF\b/ENDIF/i;
1775        $href->{statement}=$_;
1776        next;
1777      }
1778      if($content eq 'ENDWHERE') {
1779        s/\bEND WHERE\b/ENDWHERE/i;
1780        $href->{statement}=$_;
1781        next;
1782      }
1783
1784      s/\bELSE IF\b/ELSEIF/i  if($content eq 'ELSEIF');
1785
1786      if(/\./) {
1787        s/ *\.EQ\. */ == /gi;
1788        s/ *\.NE\. */ \/= /gi;
1789        s/ *\.LT\. */ < /gi;
1790        s/ *\.LE\. */ <= /gi;
1791        s/ *\.GT\. */ > /gi;
1792        s/ *\.GE\. */ >= /gi;
1793      }
1794
1795#
1796      s/\bA?MAX[01]\b/MAX/gi;
1797      s/\bA?MIN[01]\b/MIN/gi;
1798      s/\bAMOD\b/MOD/gi;
1799      s/\bALOG\b/LOG/gi;
1800      s/\bALOG10\b/LOG10/gi;
1801#      s/\bI(SIGN *\()/$1/gi; # Goes wrong in larcinad etc.
1802      s/\bFLOAT\b/REAL/g;
1803      s/\bfloat\b/real/g;
1804    }
1805   
1806    $href->{statement}=$_;
1807  }
1808}
1809
1810#==========================================================================
1811
1812sub process_include_files {
1813# Read include files and put reference to the anonomys array
1814# holding the array of "statement" hashes in $href->{inc_statm}
1815  my($statements,$prog_info,$inc_statements) = @_;
1816  my ($content,$fname,$href);
1817  return unless ($$prog_info{has_include});
1818  my @lines=();
1819  foreach $href (@$statements) {
1820    $content=$href->{content};
1821    if($content eq 'include'){
1822      $_=$href->{statement};
1823      /["](\S+)["]/;
1824      $fname=$1;
1825      &get_inc_lines($fname,\@lines);
1826# Macro-removal
1827      &remove_macro(\@lines);
1828# Expand lines into statements and put refernce to this
1829# array of hashes into $href->{inc_statm}
1830      my @inc_statms=();
1831      my $dum={};
1832      &expcont(\@lines,\@inc_statms);
1833      $href->{inc_statm}=[@inc_statms];
1834      my $incs=$href->{inc_statm};
1835# Study the read in file and add more attributes
1836      &study($incs);
1837#      print Dumper($incs,$dum);
1838     
1839    }
1840  }
1841}
1842#==========================================================================
1843sub get_inc_lines{
1844# Recurcivly get lines from include files, flatten into array of lines
1845  my ($fname,$lines) = @_;
1846  my ($VPATH,@vpath,@tmp_lines);
1847
1848  $VPATH=$ENV{VPATH} or die "VPATH not defined ";
1849# IFS VPATH /tmp/27/ifs/function:/tmp/27/ifs/common:/tmp/27/ifs/interface:/tmp/27/ifs/namelist:/tmp/27/ifsaux/include:/tmp/27/trans/interface:/tmp/27/obsort/interface:/tmp/27/ifs/ald_inc/function:/tmp/27/ifs/ald_inc/interface:/tmp/27/ifs/ald_inc/namelist
1850  @vpath=split(":",$VPATH);
1851# Look for include file in VPATH
1852  foreach my $path (@vpath) {
1853    my $ffname=$path.'/'.$fname;
1854    if( -f $ffname) {
1855# Read lines from include file
1856      @tmp_lines = &readfile($ffname);
1857#      print "$ffname \n";
1858      for (@tmp_lines) {
1859        if(/^\#include\b/){
1860          /["](\S+)["]/;
1861          my $fname2=$1;
1862          &get_inc_lines($fname2,$lines);
1863        }
1864        else {
1865          push(@$lines,$_);
1866        }
1867      }
1868      last;
1869    }
1870  }
1871  die "Include file $fname not found in VPATH=$VPATH " unless(@$lines);
1872}
1873
1874# ------------------------------------------------------------------------------
1875# SYNOPSIS
1876#   &create_interface_block (\@statements, \@interface_block);
1877#
1878# DESCRIPTION
1879#   This function analyses the Fortran statements in \@statements and returns
1880#   an interface block in \@interface_block.
1881# ------------------------------------------------------------------------------
1882
1883sub create_interface_block {
1884  # Create a "minimal" interface block for subroutines
1885  my  ($statements, $interface_block) = @_;
1886  my  (%pu_args, %tokens);
1887  our ($name, $nest_par);
1888
1889  @$interface_block = ();
1890
1891  my @tokens_in_lines = (); # List of tokens in each line
1892
1893  # Gather information needed to create interface block for routine
1894  for my $href (@$statements) {
1895    last if $href->{exec}; # exit loop at beginning of executable statements
1896
1897    # Get arguments of subroutine or function
1898    if ($href->{content} eq 'SUBROUTINE' or $href->{content} eq 'FUNCTION') {
1899      my $func;
1900      my @pu_args;
1901      $_ = $href->{statement};
1902      &parse_prog_unit (\$func, \@pu_args);
1903      $pu_args{uc ($_)} = 1 for @pu_args;
1904      next;
1905    }
1906
1907    # Get tokens from lines where arguments are present
1908    # Inspect only type declaration statements
1909    next unless $href->{decl} == 2;
1910
1911    my $statement = uc $href->{statement};
1912    $statement =~ s/!.*$//; # Remove trailing comment
1913
1914    my @line_tokens = ();
1915    if ($statement =~ s/^(.*?):://) {
1916      # New style declaration statement contains "::"
1917
1918      # Tokens in specification part
1919      my $spec = $1;
1920      my @tokens = ($spec =~ /\b$name\b/g);
1921      shift @tokens; # Remove leading token
1922
1923      for (@tokens) {
1924        push @line_tokens, $_
1925          unless /^(?:KIND|LEN|ALLOCATABLE|POINTER|TARGET|DIMENSION|OPTIONAL|
1926                  SAVE|INTENT|IN|OUT|INOUT|PARAMETER)$/x;
1927      }
1928
1929      # Tokens in declaration part
1930      push @line_tokens, ($statement =~ /\b$name\b/g);
1931
1932    } else {
1933      # Old style declaration statement does not contain "::"
1934      @line_tokens = ($statement =~ /\b$name\b/g);
1935      shift @line_tokens; # Remove leading token
1936    }
1937
1938    push @tokens_in_lines, \@line_tokens;
1939
1940    # Check whether each token matches an argument
1941    for my $token (@line_tokens) {
1942      if (exists $pu_args{$token}) {
1943        $tokens{$_} = 1 for @line_tokens;
1944        last;
1945      }
1946    }
1947  }
1948
1949  # Parse statements one more time to ensure all required tokens are included
1950  for (@tokens_in_lines) {
1951    my @line_tokens = @{ $_ };
1952
1953    # Check whether line contains an essential token
1954    for my $token (@line_tokens) {
1955      if (exists $tokens{$token}) {
1956        $tokens{$_} = 1 for @line_tokens;
1957        last;
1958      }
1959    }
1960  }
1961
1962  # Create the interface block
1963  for my $href (@$statements) {
1964    my %myhref  = %$href;
1965    my $content = $myhref{content};
1966
1967    # Ignore comment, executable statements and items in CONTAINS block
1968    next if $content eq 'comment';
1969    next if $myhref{exec};
1970    next if $myhref{in_contain};
1971
1972    # Delete existing pre- and post -inserts
1973    delete $myhref{pre_insert}  if exists $myhref{pre_insert};
1974    delete $myhref{post_insert} if exists $myhref{post_insert};
1975
1976    # Put SUBROUTINE/FUNCTION statement into interface block
1977    if ($content =~ /^(?:SUBROUTINE|FUNCTION)$/) {
1978      $myhref{pre_insert} = 'INTERFACE' . "\n"; # Insert INTERFACE statement
1979      push @$interface_block, \%myhref;
1980    }
1981
1982    # Add USE statement in interface block, if necessary
1983    if($myhref{decl} == 4) {
1984      $_ = uc $myhref{statement};
1985      tr/ \n//d;
1986
1987      if(/^USE$name,ONLY:(.+)$/) {
1988        # USE statement with ONLY, check token to see if it is necessary
1989        my @line_tokens = /\b$name\b/g;
1990
1991        for (@line_tokens) {
1992          if (exists $tokens{$_}) {
1993            push @$interface_block, \%myhref;
1994            last;
1995          }
1996        }
1997
1998      } else {
1999        # Always add USE statement without ONLY
2000        push @$interface_block, \%myhref;
2001      } 
2002    }
2003
2004    if ($myhref{decl} == 1 or $myhref{decl} == 2) {
2005      $_ = uc ($myhref{statement});
2006      s/\s*!.*$//;
2007
2008      if ($content eq 'INTEGER' or $content eq 'PARAMETER') {
2009        # INTEGER and PARAMETER may be used for dimensioning
2010        my @line_tokens = /\b$name\b/g;
2011
2012        for (@line_tokens) {
2013          if (exists $tokens{$_}) {
2014            push @$interface_block, \%myhref;
2015            last;
2016          }
2017        }
2018      } else {
2019        # Add line only if an argument is present
2020        s/$nest_par//g;
2021        my @line_tokens = /\b$name\b/g;
2022
2023        for (@line_tokens) {
2024          if (exists $pu_args{$_}) {
2025            push @$interface_block, \%myhref;
2026            last;
2027          }
2028        }
2029      }
2030    }
2031
2032    # Add END statement to interface block
2033    if ($content =~ /^END\s+(?:SUBROUTINE|FUNCTION)/) {
2034      $myhref{post_insert} = 'END INTERFACE' . "\n";
2035      push @$interface_block, \%myhref;
2036    }
2037  }
2038
2039  # Beautify the interface block
2040  for my $href (@$interface_block) {
2041    $_ = $href->{statement};
2042
2043    s/\!.*\n/\n/g; # Remove trailing comments
2044    s/ +/ /g;      # Only one space
2045    s/\n *\n/\n/g; # Remove empty lines
2046    s/\n *\n/\n/g; # Remove empty lines again
2047    s/ +\n/\n/g;   # No trailing spaces
2048
2049    $href->{statement} = $_;
2050  }
2051
2052  return;
2053}
2054
2055# ------------------------------------------------------------------------------
2056
2057sub change_var_names{
2058  my($statements) = @_;
2059  foreach my $href (@$statements) {
2060    $_=$href->{statement};
2061    s/\bVAZX\b/YVAZX/ig;
2062    s/\bPVAZX\b/YDVAZX/ig;
2063    s/\bVAZG\b/YVAZG/ig;
2064    s/\bPVAZG\b/YDVAZG/ig;
2065    s/\bSCALP_DV\b/YSCALP/ig;
2066    s/\bRSCALP_DV\b/YRSCALP/ig;
2067    s/\bSCALPSQRT_DV\b/YSCALPSQRT/ig;
2068    s/\bRSCALPSQRT_DV\b/YRSCALPSQRT/ig;
2069    s/\bPYBAR\b/YDYBAR/ig;
2070    s/\bPSBAR\b/YDSBAR/ig;
2071    s/\bVCGLPC\b/YVCGLPC/ig;
2072    s/\bVCGLEV\b/YVCGLEV/ig;
2073    s/\bSKFROT\b/YSKFROT/ig;
2074    s/\bSKFMAT\b/YSKFMAT/ig;
2075    s/\bSTATE_VECTOR_4D\b/YSTATE_VECTOR_4D/ig;
2076    s/\bVAZX0\b/YVAZX0/ig;
2077    s/\bVAZG0\b/YVAZG0/ig;
2078    s/\bRSPFORCE\b/YSPFORCE/ig;
2079    $href->{statement}=$_;
2080  }
2081}
2082# =========================================================================
2083sub remake_arg_decl{
2084  my($statements,$prog_info) = @_;
2085  my($href,$content,@pu_args,$func,%tokens);
2086  my($left,$right,%arghash,$dim);
2087  our($nest_par,$name);
2088
2089  my $dims='';
2090# Crack existing dummy declarations, build hash arghash
2091  foreach $href (@$statements) {
2092    last if($href->{prog_unit} >0);
2093    if($href->{content} eq 'SUBROUTINE') {   # Get arguments of subroutine
2094      $_=$href->{statement};
2095      my $dum=&parse_prog_unit(\$func,\@pu_args);
2096#      print Dumper(\@pu_args);
2097      for(@pu_args) {
2098        $_=uc($_);
2099        $arghash{$_}{other}='';
2100        $arghash{$_}{dimuse}=0;
2101        $arghash{$_}{intent}='';
2102        $arghash{$_}{used}=0;
2103        $arghash{$_}{set}=0;
2104        $arghash{$_}{reallyset}=0;
2105        $arghash{$_}{type}='';
2106        $arghash{$_}{comment}='';
2107        $arghash{$_}{inif}=0;
2108      }
2109      next;
2110    }
2111    if($href->{decl} == 2) {
2112      $_=$href->{statement};
2113      my $comment='';
2114      $comment=$1 if(/.*(\!.*)$/);
2115      s/\!.*\n/\n/g;                        # Remove trailing comments in all lines
2116      $_=uc($_);
2117      s/\s//g;
2118      if(/^(.+)::(.+)$/){
2119        $left=$1;
2120        $right=$2;
2121        $_=$right;
2122        s/$nest_par//g;
2123        s/($name)\*\w+/$1/g;
2124#       print "XX  $_ \n";
2125        foreach my $arg (@pu_args) {
2126          if(/\b$arg\b/) {
2127#           print "ARG $arg $left $_ \n";
2128            $arghash{$arg}{linedec}=$href->{number};
2129            $arghash{$arg}{comment}=$comment;
2130            my @locdec =split ',',$left;
2131            my $i=0;
2132            foreach my $locdec (@locdec) {
2133              if($i == 0) {
2134                $arghash{$arg}{type}=$locdec;
2135              }
2136              elsif($locdec=~/\bINTENT/) {
2137                $arghash{$arg}{intent}=','.$locdec;
2138              }
2139              else {
2140                $arghash{$arg}{other}=$arghash{$arg}{other}.','.$locdec;
2141              }
2142              $i++;
2143            }
2144            if($right=~/\b$arg\b(\*\w+)/) {
2145              $dim=$1;
2146            }
2147            elsif($right=~/\b$arg\b($nest_par\*$nest_par)/) {
2148              $dim=$1;
2149            }
2150            elsif($right=~/\b$arg\b($nest_par\*\w+)/) {
2151              $dim=$1;
2152            }
2153            elsif($right=~/\b$arg\b(\*$nest_par)/) {
2154              $dim=$1;
2155            }
2156            elsif($right=~/\b$arg\b($nest_par)/) {
2157              $dim=$1;
2158            }
2159            else {
2160              $dim='';
2161            }
2162            $arghash{$arg}{dim}=$dim;
2163            $dims=$dims.$dim
2164              }
2165        }
2166        foreach my $arg (@pu_args) {  # Is arg. used for dimensioning other args?
2167          if($dims=~/\b$arg\b/i) {
2168            $arghash{$arg}{dimuse}=1;
2169          }
2170        } 
2171      }
2172    }
2173  }
2174  my $insert_line=0;
2175  foreach $href (@$statements) {
2176    last if($href->{prog_unit} >0);
2177    if($href->{decl} == 2 or $href->{content} eq 'PARAMETER') {                 
2178      $_=uc($href->{statement});
2179      next unless /\bPARAMETER\b/;
2180      my @tmpvar=/\b$name\b/g;
2181      foreach my $token (@tmpvar) {
2182        if($dims=~/\b$token\b/) {
2183          $insert_line=$href->{number};
2184        }
2185      }
2186    }
2187  }
2188     
2189# Gather info to decide INTENT status
2190  my $inif=0;
2191  my @inif_stack=();
2192  my $cur_inif=0;
2193  foreach $href (@$statements) {
2194    last if($href->{prog_unit} >0);
2195    if($href->{exec}) {
2196      if($href->{content} eq 'ENDIF') {
2197        $inif--;
2198        $cur_inif=pop @inif_stack;
2199        next;
2200      }
2201      elsif($href->{content} eq 'ELSEIF' or $href->{content} eq 'ELSE') {
2202        $cur_inif=pop @inif_stack;
2203        $cur_inif=$href->{number};
2204        push @inif_stack,$cur_inif;
2205      }
2206      my ($left,$right);
2207      $_=$href->{statement};
2208      s/\!.*\n/\n/g;                        # Remove trailing comments in all lines
2209      my %setnow=();
2210      foreach my $arg (@pu_args) {
2211        $setnow{$arg}=0;
2212        $setnow{$arg}=1 if($arghash{$arg}{reallyset});
2213        unless ($setnow{$arg}) {
2214          foreach my $xx (@inif_stack) {
2215            $setnow{$arg}=1 if($xx == $arghash{$arg}{inif});
2216          }
2217        }
2218      }
2219     
2220      if($href->{content} eq 'scal_assign' or $href->{content} eq 'array_assign') {
2221        s/\s//g;
2222        ($left,$right)=/^(.+)=(.+)$/;
2223        $_=$right;
2224        foreach my $arg (@pu_args) {
2225          if(/\b$arg\b/i) {
2226            $arghash{$arg}{used}=1 unless $setnow{$arg};
2227          }
2228        }
2229        $_=$left;
2230        if(/($nest_par)/) {
2231          $_=$1;
2232          foreach my $arg (@pu_args) {
2233            if(/\b$arg\b/i) {
2234              $arghash{$arg}{used}=1 unless $setnow{$arg};
2235            }
2236          }
2237        }
2238        $_=$left;
2239        foreach my $arg (@pu_args) {
2240          if(/^$arg\b/i) {
2241            $arghash{$arg}{set}=1;
2242            $arghash{$arg}{inif}=$cur_inif;
2243            $arghash{$arg}{reallyset}=1 unless($inif);
2244          }
2245        }
2246      }
2247      elsif($href->{content} eq 'IF' ) {
2248        if($href->{content2} eq 'scal_assign' or $href->{content2} eq 'array_assign' or 
2249           $href->{content2} eq 'CALL') {
2250          s/\n//g;
2251          ($left,$right)=/^\s*(IF\b\s*$nest_par)(.+)/i;
2252          $_=$left;
2253          foreach my $arg (@pu_args) {
2254            if(/\b$arg\b/i) {
2255              $arghash{$arg}{used}=1 unless $setnow{$arg};
2256            }
2257          }
2258          $_=$right;
2259          if($href->{content2} eq 'CALL') {
2260            my $statement=$right;
2261            my $inifx=1;
2262            &propag_arg(\$statement,\%arghash,\$inifx,\%setnow);
2263          }
2264          else {
2265            s/\s//g;
2266            ($left,$right)=/^(.+)=(.+)$/;
2267            $_=$right;
2268            foreach my $arg (@pu_args) {
2269              if(/\b$arg\b/i) {
2270                $arghash{$arg}{used}=1 unless $setnow{$arg};
2271              }
2272            }
2273            $_=$left;
2274            if(/($nest_par)/) {
2275              $_=$1;
2276              foreach my $arg (@pu_args) {
2277                if(/\b$arg\b/i) {
2278                  $arghash{$arg}{used}=1 unless $setnow{$arg};
2279                }
2280              }
2281            }
2282            $_=$left;
2283            foreach my $arg (@pu_args) {
2284              if(/^$arg\b/i) {
2285                $arghash{$arg}{inif}=$cur_inif;
2286                $arghash{$arg}{set}=1;
2287              }
2288            }
2289          }
2290        }
2291        else {
2292          foreach my $arg (@pu_args) {
2293            if(/\b$arg\b/i) {
2294              $arghash{$arg}{used}=1 unless $setnow{$arg};
2295            }
2296          }
2297        }
2298      }
2299      elsif($href->{content} eq 'WHERE' ) {
2300        s/\s//g;
2301        ($left,$right)=/^(WHERE$nest_par)(.+)/i;
2302        $_=$left;
2303        foreach my $arg (@pu_args) {
2304          if(/\b$arg\b/i) {
2305            $arghash{$arg}{used}=1 unless $setnow{$arg};
2306          }
2307        }
2308        $_=$right;
2309        ($left,$right)=/^(.+)=(.+)$/;
2310        $_=$right;
2311        foreach my $arg (@pu_args) {
2312          if(/\b$arg\b/i) {
2313            $arghash{$arg}{used}=1 unless $setnow{$arg};
2314          }
2315        }
2316        $_=$left;
2317        foreach my $arg (@pu_args) {
2318          if(/^$arg\b/i) {
2319            $arghash{$arg}{inif}=$cur_inif;
2320            $arghash{$arg}{set}=1;
2321          }
2322        }
2323      }
2324      elsif($href->{content} eq 'CALL') {
2325        my $statement=$_;
2326        &propag_arg(\$statement,\%arghash,\$inif);
2327      }
2328      else{
2329        foreach my $arg (@pu_args) {
2330          if(/\b$arg\b/i) {
2331            $arghash{$arg}{used}=1 unless $setnow{$arg};
2332          }
2333        }
2334      }
2335      if($href->{content} eq 'IF_construct') {
2336        $inif++;
2337        $cur_inif=$href->{number};
2338        push @inif_stack,$cur_inif;
2339      }
2340    }     
2341  }
2342
2343# Create INTENT statemant based on gathered info
2344  foreach my $arg (@pu_args) {
2345    if($arghash{$arg}{linedec}) {
2346      if($arghash{$arg}{nointent}) {
2347        unless($arghash{$arg}{intent}) {
2348          $arghash{$arg}{intent}=' ';
2349          $arghash{$arg}{comment}='! UNDETERMINED INTENT';
2350        }
2351      }
2352      else{
2353        my $intent='';
2354        $intent='IN' if($arghash{$arg}{used} or $arghash{$arg}{dimuse});
2355        $intent=$intent.'OUT' if($arghash{$arg}{set});
2356        if($intent) {
2357          if($arghash{$arg}{intent} and $intent eq 'OUT') {
2358            $intent='INOUT' if $arghash{$arg}{intent}=~/INOUT/i;
2359          }
2360          $arghash{$arg}{intent}=',INTENT('.$intent.')';
2361        }
2362        else {
2363          $arghash{$arg}{intent}=' ';
2364          $arghash{$arg}{comment}='! Argument NOT used';
2365        }
2366      }
2367    }
2368  }
2369
2370# Remove existing argument declarations
2371  foreach my $arg (@pu_args) {
2372    if($arghash{$arg}{linedec}) {
2373      $_=$$statements[$arghash{$arg}{linedec}]->{statement};
2374      #   print "BEFORE $arg $_";
2375      if(/.*::\s*\b$arg\b\s*(\!.*\n)*$/i) {
2376        $_='';
2377      }
2378      elsif(/.*::\s*\b$arg\b\s*$nest_par\s*(\!.*\n)*$/i) {
2379        $_='';
2380      }
2381      elsif(/.*::\s*\b$arg\b\s*\*\s*\w+\s*(\!.*\n)*$/i) {
2382        $_='';
2383      }
2384      elsif(/.*::\s*\b$arg\b\s*\*\s*$nest_par\s*(\!.*\n)*$/i) {
2385        $_='';
2386      }
2387      elsif(/.*::\s*\b$arg\b\s*$nest_par\s*\*\s*\w+\s*(\!.*\n)*$/i) {
2388        $_='';
2389      }
2390      elsif(/.*::\s*\b$arg\b\s*$nest_par\s*\*\s*$nest_par\s*(\!.*\n)*$/i) {
2391        $_='';
2392      }
2393      else{
2394        /^(.*::)(.*)$/s;
2395        my $left=$1;
2396        $_=$2;
2397        s/\b$arg\b\s*$nest_par//i;
2398        s/\b$arg\b\s*\*\s*\w+//i;
2399        s/\b$arg\b\s*\*\s*$nest_par//i;
2400        s/\b$arg\b//i;
2401        s/,\s*,/,/;
2402        s/,(\s*)$/$1/;
2403        s/\n\s*\n/\n/g;
2404        $_=$left.$_;
2405        s/::\s*,/::/;
2406      }
2407 #   print "AFTER $arg $_\n";
2408      $$statements[$arghash{$arg}{linedec}]->{statement}=$_; 
2409    }
2410  }
2411
2412 # Write out
2413
2414  my $newdecl='';
2415  my $linedec;
2416  foreach my $arg (@pu_args) {
2417    if($arghash{$arg}{linedec}) {
2418      if($arghash{$arg}{other} and ! $arghash{$arg}{dim}) {
2419        $arghash{$arg}{other}=~s/\s//g;
2420        if($arghash{$arg}{other}=~/^,DIMENSION($nest_par)$/i) {
2421          $arghash{$arg}{other}='';
2422          $arghash{$arg}{dim}=$1;
2423        }
2424      }
2425      if($arghash{$arg}{dimuse}) { # Put declerations of args first
2426        $linedec=sprintf "%-18s%s%-14s%s%s%s%s %s",
2427        $arghash{$arg}{type},$arghash{$arg}{other},$arghash{$arg}{intent},
2428            ' :: ',$arg,$arghash{$arg}{dim},$arghash{$arg}{comment},"\n";
2429        $newdecl=$newdecl.$linedec;
2430      }
2431    }
2432  }
2433  foreach my $arg (@pu_args) {
2434    if($arghash{$arg}{linedec}) {
2435      unless($arghash{$arg}{dimuse}) {
2436        $linedec=sprintf "%-18s%s%-14s%s%s%s %s%s",
2437        $arghash{$arg}{type},$arghash{$arg}{other},$arghash{$arg}{intent},
2438            ' :: ',$arg,$arghash{$arg}{dim},$arghash{$arg}{comment},"\n";
2439        $newdecl=$newdecl.$linedec;
2440      }
2441    }
2442  }
2443#  print "INSERT_LINE $insert_line \n";
2444  if($insert_line) {
2445    $$statements[$insert_line]->{post_insert}=$newdecl;
2446  }
2447  else{
2448    foreach $href (@$statements) {
2449      if($href->{decl} == 2) {                 
2450        $href->{pre_insert}=$newdecl;
2451        last;
2452      }
2453    }
2454  }
2455
2456#  print $newdecl;
2457#  print Dumper(\%arghash);
2458}
2459
2460sub propag_arg{
2461  my ($statement,$arghash,$inif,$setnow) = @_;
2462  our ($name,$nest_par);
2463  my (%argpos);
2464  $_=$$statement;
2465  s/^\s*CALL\s+($name)//i;
2466  my $called=lc($1);
2467  s/\s//g;
2468  s/^\((.*)\)$/$1/s;
2469  my @inpars=/$nest_par/g;
2470  s/$nest_par//g;
2471  s/($name)%$name/$1/g;
2472  $_=uc($_);
2473#  print "PROPAG $called $_ ££ @inpars \n";
2474  my @call_args=split ',' , $_;
2475  my $i=0;
2476  my $interesting=0;
2477  %argpos=();
2478  foreach my $call (@call_args) {
2479   
2480#    print "CALL $called $call \n" ;
2481    if($call=~/(.+)=(.+)/) {
2482      $call=$2; #This just by-passes the problem
2483    }
2484    if(exists $$arghash{$call}) {
2485      if(exists $argpos{$call}) {
2486        push @{$argpos{$call}},$i;
2487      }
2488      else {
2489        my @i=($i);
2490        $argpos{$call}=[@i];
2491      }
2492      $interesting=1;
2493    }
2494    $i++;
2495  }
2496  if($interesting) {
2497    my $fname='/tmp/intblocks/'.$called.'.intfb.h';
2498    if( -f $fname ) {
2499      my @dumargs=();
2500      my $unit_name;
2501      print "FILE $fname FOUND \n";
2502      my @lines = &readfile($fname);
2503      my @loc_statements=(); 
2504      &expcont(\@lines,\@loc_statements);
2505      foreach my $href (@loc_statements) {
2506        $_=$href->{statement};
2507        if(/^\s*SUBROUTINE/i) {
2508          my $dum=&parse_prog_unit(\$unit_name,\@dumargs);
2509          next;
2510        }
2511        if(/::/) {
2512          s/\s//g;
2513          foreach my $arg (keys (%argpos)) {
2514            my $set_before=$$setnow{$arg};
2515            foreach my $i (@{$argpos{$arg}}){
2516              if(/::$dumargs[$i]/) {
2517                if(/INTENT\(IN\)/i) {
2518                  $$arghash{$arg}{used}=1 unless $set_before;
2519                }
2520                elsif(/INTENT\(OUT\)/i) {
2521                  $$arghash{$arg}{set}=1;
2522                  $$setnow{$arg}=1 unless($$inif);
2523                }
2524                elsif(/INTENT\(INOUT\)/i) {
2525                  $$arghash{$arg}{set}=1;
2526                  $$arghash{$arg}{used}=1 unless $set_before;;
2527                  $$arghash{$arg}{reallyset}=1 unless($$inif);
2528                }
2529                elsif(/\! UNDETERMINED INTENT/) {
2530                  $$arghash{$arg}{nointent}=1;
2531                }
2532              }
2533            }
2534          }
2535        }
2536      }
2537    }
2538    else {
2539      foreach my $arg (keys (%argpos)) {
2540        $$arghash{$arg}{nointent}=1;
2541      }
2542    }
2543  }
2544  for (@inpars) {
2545    foreach my $arg (keys (%$arghash)) {
2546      if(exists $$arghash{$arg}) {
2547        if(/\b$arg\b/i) {
2548          $$arghash{$arg}{used}=1 unless $$setnow{$arg};
2549        }
2550      }
2551    }
2552  }
2553}
2554 
2555sub add_interface_blocks {
2556# Add interface block for called routines
2557  use File::Find;
2558  my($statements,$prog_info) = @_;
2559  my($href,$call);
2560  our($name,$nest_par);
2561  our(@call_names,@call_names_found,%call_names);
2562
2563  return unless ($$prog_info{no_calls}); # Skip if there are no calls
2564  @call_names=();
2565  %call_names=();
2566
2567  my $last_decl=0;
2568  my $in_intfblk=0;
2569  my %already_in=();
2570  ST:foreach $href (@$statements) {
2571    last if($href->{prog_unit} > 0);  # Only consider first program unit (no contains)
2572    if($href->{content} eq 'INTERFACE') {
2573      $in_intfblk=1;
2574      next;
2575    }
2576    if($href->{content} eq 'END INTERFACE') {
2577      $in_intfblk=0;
2578      next;
2579    }
2580    if($in_intfblk) {
2581      $_=$href->{statement};
2582      s/\#include\s*\"(\w+)\.h\"\s*$/$1/;
2583      $_=lc($_);
2584      $already_in{$_}++;
2585      next;
2586    }
2587   
2588# Find last declaration
2589    if($href->{decl}) {
2590      next if($href->{content} eq 'FORMAT');
2591      next if($href->{content} eq 'DATA');
2592      $last_decl = $href->{number} ;
2593    }
2594# Find calls
2595    next unless($href->{exec});
2596    if($href->{content} eq 'CALL' or 
2597       (exists  $href->{content2} and$ href->{content2} eq 'CALL') ) {
2598      $_=$href->{statement};
2599      /\s*\bCALL\b\s*($name)/i;
2600      my $call=lc($1);
2601      next if($already_in{$call}); # Exclude already existing interface block
2602      next if($call eq 'packmsg'); # A couple of special exceptions
2603      next if($call eq 'unpkmsg');
2604      $call_names{$call}++;
2605    }
2606  }
2607 
2608
2609# Check that routine exists in IFS
2610  @call_names_found=();
2611  find(\&calls_wanted,'/tmp/27/ifs/');
2612#  find(\&calls_wanted,'/home/mats/work/cy28/ifs/');
2613#  find(\&calls_wanted,'/tmp/27/trans/');
2614  @call_names_found=sort(@call_names_found);
2615#  print "P2 @call_names_found \n";
2616  @call_names=@call_names_found;
2617
2618# Contruct include block
2619  my $block='';
2620  for (@call_names) {
2621    $block=$block.'#include "'.$_.'.intfb.h"'."\n";
2622  }
2623#  print $block;
2624
2625  my $clean=0;
2626  if(@call_names) {
2627    if($$prog_info{has_interface_block}) {
2628      foreach $href (@$statements) {
2629# Add interface block to routine that already has INTERFACE statement
2630        if($href->{content} eq 'END INTERFACE'){
2631          if($href->{post_insert}) {
2632            $href->{post_insert}=$href->{post_insert}."\n".$block;
2633          }
2634          else {
2635            $href->{post_insert}="\n".$block;
2636          }         
2637          last;
2638        }
2639      }
2640    }
2641# Add interface block to routine that does not have previous INTERFACE statement
2642    else {
2643      $href=@$statements[$last_decl];
2644      if($href->{post_insert}) {
2645        $href->{post_insert}=$href->{post_insert}."\n".$block;
2646      }
2647      else {
2648        $href->{post_insert}="\n".$block;
2649      }     
2650    }
2651# Remove from EXTERNAL statement where interface block has been added
2652    foreach $href (@$statements) {
2653      if($href->{content} eq 'EXTERNAL') {
2654        $_=$href->{statement};
2655        foreach my $ext (@call_names) {
2656          s/\b$ext\b//i;
2657        }
2658        s/,\s*,/,/g;
2659        s/^(\s*EXTERNAL\s*),/$1/i;
2660        s/^(\s*EXTERNAL.*),\s*$/$1/i;
2661        s/^\s*EXTERNAL\s*,*\s*$//i;
2662        $href->{statement}=$_; 
2663      }
2664    }
2665  }
2666}
2667#======================================================================================
2668sub calls_wanted {
2669  # Used by Find as called from add_interface_blocks
2670  our(%call_names,@call_names_found);
2671  return unless (/^(\w+)\.F90$/);
2672  my $call=$1;
2673  if($call_names{$call}) {
2674    push(@call_names_found,$call);
2675  }   
2676}
2677sub remove_some_comments{
2678  my($statements) = @_;
2679  my $prev_empty=0;
2680  foreach my $href (@$statements) {
2681    if($href->{content} eq 'comment'){
2682      $_=$href->{statement};
2683      if(/^\s*$/) {
2684        if($prev_empty) {
2685          s/\s*//;
2686          $href->{statement}=$_;
2687        }
2688        else {
2689          $prev_empty=1;
2690        } 
2691        next;
2692      }
2693      $prev_empty=0;
2694      s/^\s*![\s\*]*\bLOCAL\s+(INTEGER|REAL|LOGICAL|CHARACTER)\s+(SCALARS|ARRAYS).*\n$//i;
2695      s/^\s*![\s\*]*\bDUMMY\s+(INTEGER|REAL|LOGICAL|CHARACTER)\s+(SCALARS|ARRAYS).*\n$//i;
2696      s/^\s*![\s\*]*\bLOCAL\s+(INTEGER|REAL|LOGICAL|CHARACTER).*\n$//i;
2697      s/^\s*![\s\*]*\bDUMMY\b\s*$//i;
2698      s/^\s*![\s\*]*\bLOCAL\b\s*$//i;
2699      s/^\s*![\s\*]*\bLOCAL\b:\s*$//i;
2700      s/^\s*![\s\*]*\bLOCAL ARRAYS\b[\s\*]*$//i;
2701      s/^\s*![\s\*]*\bLOCAL SCALARS\b\s*$//i;
2702      s/^\s*![\s\*]*\s*\d\.\d+\s*\bLOCAL ARRAYS\b\s*$//i;
2703      s/^\s*![\s\*]*\s*=== LOCAL ARRAYS ===\s*$//i;
2704      $href->{statement}=$_;
2705    }
2706    else {
2707      $prev_empty=0;
2708    }
2709  }
2710}     
2711sub get_calls_inc {
2712  my($statements,$calls,$intfb) = @_;
2713  foreach my $href (@$statements) {
2714    if($href->{content} eq 'CALL') {
2715      $_=$href->{statement};
2716      /^\s*CALL\s+([A-Z]\w*)/i;
2717      $$calls{lc($1)}++;
2718    }
2719    elsif($href->{content} eq 'IF') {
2720      if($href->{content2} eq 'CALL') {
2721        $_=$href->{statement};
2722        /\bCALL\s+([A-Z]\w*)/i;
2723        $$calls{lc($1)}++;
2724      }
2725    }
2726    elsif($href->{content} eq 'include') {
2727      $_=$href->{statement};
2728      $$intfb{$1}=1 if(/["](\S+)\.intfb\.h["]/);
2729      $$intfb{$1}=2 if(/["](\S+)\.h["]/); # For old-style interface blocks
2730    }
2731  }
2732}
2733
27341;
2735     
2736__END__
Note: See TracBrowser for help on using the repository browser.