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