Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

Fortran90_stuff.pm @ 225

Last change on this file since 225 was 225, checked in by ymipsl, 10 years ago

File size: 70.3 KB

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: codes/icosagcm/branches/SATURN_DYNAMICO/ICOSAGCM/tools/FCM/lib/Ecmwf/Fortran90_stuff.pm @ 225

Download in other formats: