Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

Fortran90_stuff.pm @ 3511

Last change on this file since 3511 was 1578, checked in by jghattas, 13 years ago

Add fcm in LMDZ5/tools directory

It is no longer needed to have fcm in your environement PATH variable.
Now makelmdz_fcm takes by default this fcm. It is still possible to use
another fcm, using -fcm_path argument in makelmdz_fcm.

File size: 70.9 KB

Line
1	#!/usr/bin/perl
2	# ------------------------------------------------------------------------------
3	# NAME
4	# Ecmwf::Fortran90_stuff
5	#
6	# DESCRIPTION
7	# This is a module for analysing Fortran 9X code. It is used by the FCM
8	# system to generate interface blocks for Fortran 9X free source files.
9	#
10	# ABOUT THIS MODULE:
11	# The original version of this module was developed by the European Centre
12	# for Medium-Range Weather Forecasts (ECMWF). This version has been modified
13	# by UK Met Office to become part of the FCM system.
14	# ------------------------------------------------------------------------------
15
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 type (return), name ($$unit_name) and arguments (@$args)
1584	# from a program unit statement ($_)
1585	my ($unit_name, $args) = @_;
1586	$$unit_name = '';
1587	@$args = ();
1588
1589	my $type = '';
1590
1591	our ($name, $type_spec, $attribute);
1592
1593	if (/^\s(MODULE\|PROGRAM\|BLOCK\sDATA)\s+($name)\s*$/io) {
1594	$type = lc ($1);
1595	$$unit_name = $2;
1596
1597	# Remove space from "block data"
1598	$type =~ s/\s*//;
1599
1600	} elsif (/^\s(?:$attribute)?\s(SUBROUTINE)\s+($name)\b/io or
1601	/^\s(?:$attribute)?\s(?:$type_spec)?\s*(FUNCTION)\s+($name)\b/io) {
1602	$type = lc ($1);
1603	$$unit_name = $2;
1604
1605	# Get arguments/keywords from SUBROUTINE/FUNCTION
1606	if(/^[^$]+\([^$]+\)/) {
1607	my $tstatm = $_;
1608
1609	# Remove trailing comment
1610	$tstatm =~ s/\!.*\n/\n/g;
1611
1612	# Remove space characters
1613	$tstatm =~ s/\s//g;
1614
1615	# Add the RESULT clause to the argument/keyword list
1616	$tstatm =~ s/\)result$(\w+$)$/,$1/i if $type eq 'function';
1617
1618	# Remove the parenthesis around the argument list
1619	$tstatm =~ s/.+$(.+)$/$1/;
1620
1621	@$args = split (',', uc ($tstatm));
1622
1623	# For FUNCTION, add its name to the list if necessary
1624	push @$args, uc ($$unit_name)
1625	if $type eq 'function' and not grep {$_ eq uc ($$unit_name)} @$args;
1626	}
1627	}
1628
1629	return $type;
1630	}
1631
1632	#==========================================================================
1633
1634	sub setup_parse {
1635	# Set up some "global" variables that helps with parsing statements
1636
1637	# Pattern for nested parenthesis
1638	our $nest_par;
1639	$nest_par = qr/$(?:(?>[^()]+)\|(??{$nest_par}))*$/; #Camel p214
1640
1641	# Patterns for variable name and natural digit
1642	our $name='[a-zA-Z]\w*';
1643	our $digit_string='\d+';
1644	our $type_name=$name;
1645
1646	# Patterns for specification
1647	our $specification_expr='(?:'.$name.'\|'.$digit_string.')'; # Simplification
1648	our $type_param_value='(?:\*\|'.$specification_expr.')';
1649
1650	# Patterns for length/kind attributes
1651	our $char_selector='LEN = '.$type_param_value; # Simplification
1652	our $kind_selector='$ KIND = '.$name.' $'; # Simplification
1653
1654	# Pattern for type specification
1655	our $type_spec='INTEGER (?:'.$kind_selector.')?\|REAL (?:'.$kind_selector.
1656	')?\|DOUBLE PRECISION\|COMPLEX (?:'.$kind_selector.')?\|CHARACTER '.
1657	$char_selector.'\|LOGICAL (?:'.$kind_selector.')?\|TYPE\s\(\s*'.$type_name.
1658	'\s*\)';
1659
1660	# Pattern for function/subroutine attribute
1661	our $attribute = 'ELEMENTAL\|(?:RECURSIVE(?:\s+PURE)?\|PURE(?:\s+RECURSIVE)?)';
1662
1663	return;
1664	}
1665
1666	#==========================================================================
1667
1668	sub f90_indent {
1669	# Indent free-format F90 program to our standards
1670	my($line_hash,$lines)=@_;
1671	my($delta)=' ';
1672	my($cur_indent)='';
1673	@$lines=();
1674	foreach my $href (@$line_hash) {
1675	$_=$href->{line};
1676	if($href->{content} eq 'comment') {
1677	push(@$lines,$_);
1678	next;
1679	}
1680	s/^ *//; # Remove current indentation
1681	my($post_chg)=0;
1682	my($pre_chg)=0;
1683	my($cont_line)='';
1684	exit if (! exists $href->{content});
1685	if($href->{content} eq 'DO') {
1686	$post_chg=1 unless /^DO\s+\d/;
1687	}
1688	elsif($href->{content} eq 'ENDDO') {
1689	$pre_chg=1;
1690	}
1691	elsif($href->{content} eq 'IF_construct') {
1692	$post_chg=1;
1693	}
1694	elsif($href->{content} eq 'ELSEIF') {
1695	$post_chg=1;
1696	$pre_chg=1;
1697	}
1698	elsif($href->{content} eq 'ELSE') {
1699	$post_chg=1;
1700	$pre_chg=1;
1701	}
1702	elsif($href->{content} eq 'ENDIF') {
1703	$pre_chg=1;
1704	}
1705	elsif($href->{content} eq 'ENDIF') {
1706	$pre_chg=1;
1707	}
1708	elsif($href->{content} eq 'WHERE_construct') {
1709	$post_chg=1;
1710	}
1711	elsif($href->{content} eq 'ELSEWHERE') {
1712	$post_chg=1;
1713	$pre_chg=1;
1714	}
1715	elsif($href->{content} eq 'ENDWHERE') {
1716	$pre_chg=1;
1717	}
1718	elsif($href->{content} eq 'ENDIF') {
1719	$pre_chg=1;
1720	}
1721	elsif($href->{content} eq 'SELECT CASE') {
1722	$post_chg=1;
1723	}
1724	elsif($href->{content} eq 'CASE') {
1725	$post_chg=1;
1726	$pre_chg=1;
1727	}
1728	elsif($href->{content} eq 'END SELECT') {
1729	$pre_chg=1;
1730	}
1731	$cont_line=' ' if($href->{content} eq 'cont_line');
1732	if( $pre_chg ) {
1733	unless($cur_indent=~s/^$delta//o) {
1734	print STDERR $_;
1735	die "f90_indent: something wrong, indent negative\n";;
1736	}
1737	}
1738	# print "$cur_indent$cont_line$_";
1739
1740	$_=$cur_indent.$cont_line.$_;
1741	push(@$lines,$_);
1742	$cur_indent.=$delta if( $post_chg );
1743	}
1744
1745	if(! ($cur_indent eq '')) {
1746	die "f90_indent: something wrong, indent=XX${cur_indent}XX\n";
1747	}
1748	}
1749
1750	#==========================================================================
1751
1752	sub tidy {
1753	# Straigthforward tidiyng of statements
1754	my($statements) = @_;
1755	my($href,$content);
1756	foreach $href (@$statements) {
1757	$_=$href->{statement};
1758	$content=$href->{content};
1759	# Substitute tab with four blanks
1760	s/\t/ /g;
1761	if($content eq 'comment') {
1762	# Substitute empty comment line with empty line
1763	s/^[!] *\n$/\n/;
1764	$href->{statement}=$_;
1765	next;
1766	}
1767	if($href->{exec}) {
1768	if($content eq 'ENDDO') {
1769	s/\bEND DO\b/ENDDO/i;
1770	$href->{statement}=$_;
1771	next;
1772	}
1773	if($content eq 'ENDIF') {
1774	s/\bEND IF\b/ENDIF/i;
1775	$href->{statement}=$_;
1776	next;
1777	}
1778	if($content eq 'ENDWHERE') {
1779	s/\bEND WHERE\b/ENDWHERE/i;
1780	$href->{statement}=$_;
1781	next;
1782	}
1783
1784	s/\bELSE IF\b/ELSEIF/i if($content eq 'ELSEIF');
1785
1786	if(/\./) {
1787	s/ \.EQ\. / == /gi;
1788	s/ \.NE\. / \/= /gi;
1789	s/ \.LT\. / < /gi;
1790	s/ \.LE\. / <= /gi;
1791	s/ \.GT\. / > /gi;
1792	s/ \.GE\. / >= /gi;
1793	}
1794
1795	#
1796	s/\bA?MAX[01]\b/MAX/gi;
1797	s/\bA?MIN[01]\b/MIN/gi;
1798	s/\bAMOD\b/MOD/gi;
1799	s/\bALOG\b/LOG/gi;
1800	s/\bALOG10\b/LOG10/gi;
1801	# s/\bI(SIGN *\()/$1/gi; # Goes wrong in larcinad etc.
1802	s/\bFLOAT\b/REAL/g;
1803	s/\bfloat\b/real/g;
1804	}
1805
1806	$href->{statement}=$_;
1807	}
1808	}
1809
1810	#==========================================================================
1811
1812	sub process_include_files {
1813	# Read include files and put reference to the anonomys array
1814	# holding the array of "statement" hashes in $href->{inc_statm}
1815	my($statements,$prog_info,$inc_statements) = @_;
1816	my ($content,$fname,$href);
1817	return unless ($$prog_info{has_include});
1818	my @lines=();
1819	foreach $href (@$statements) {
1820	$content=$href->{content};
1821	if($content eq 'include'){
1822	$_=$href->{statement};
1823	/["](\S+)["]/;
1824	$fname=$1;
1825	&get_inc_lines($fname,\@lines);
1826	# Macro-removal
1827	&remove_macro(\@lines);
1828	# Expand lines into statements and put refernce to this
1829	# array of hashes into $href->{inc_statm}
1830	my @inc_statms=();
1831	my $dum={};
1832	&expcont(\@lines,\@inc_statms);
1833	$href->{inc_statm}=[@inc_statms];
1834	my $incs=$href->{inc_statm};
1835	# Study the read in file and add more attributes
1836	&study($incs);
1837	# print Dumper($incs,$dum);
1838
1839	}
1840	}
1841	}
1842	#==========================================================================
1843	sub get_inc_lines{
1844	# Recurcivly get lines from include files, flatten into array of lines
1845	my ($fname,$lines) = @_;
1846	my ($VPATH,@vpath,@tmp_lines);
1847
1848	$VPATH=$ENV{VPATH} or die "VPATH not defined ";
1849	# IFS VPATH /tmp/27/ifs/function:/tmp/27/ifs/common:/tmp/27/ifs/interface:/tmp/27/ifs/namelist:/tmp/27/ifsaux/include:/tmp/27/trans/interface:/tmp/27/obsort/interface:/tmp/27/ifs/ald_inc/function:/tmp/27/ifs/ald_inc/interface:/tmp/27/ifs/ald_inc/namelist
1850	@vpath=split(":",$VPATH);
1851	# Look for include file in VPATH
1852	foreach my $path (@vpath) {
1853	my $ffname=$path.'/'.$fname;
1854	if( -f $ffname) {
1855	# Read lines from include file
1856	@tmp_lines = &readfile($ffname);
1857	# print "$ffname \n";
1858	for (@tmp_lines) {
1859	if(/^\#include\b/){
1860	/["](\S+)["]/;
1861	my $fname2=$1;
1862	&get_inc_lines($fname2,$lines);
1863	}
1864	else {
1865	push(@$lines,$_);
1866	}
1867	}
1868	last;
1869	}
1870	}
1871	die "Include file $fname not found in VPATH=$VPATH " unless(@$lines);
1872	}
1873
1874	# ------------------------------------------------------------------------------
1875	# SYNOPSIS
1876	# &create_interface_block (\@statements, \@interface_block);
1877	#
1878	# DESCRIPTION
1879	# This function analyses the Fortran statements in \@statements and returns
1880	# an interface block in \@interface_block.
1881	# ------------------------------------------------------------------------------
1882
1883	sub create_interface_block {
1884	# Create a "minimal" interface block for subroutines
1885	my ($statements, $interface_block) = @_;
1886	my (%pu_args, %tokens);
1887	our ($name, $nest_par);
1888
1889	@$interface_block = ();
1890
1891	my @tokens_in_lines = (); # List of tokens in each line
1892
1893	# Gather information needed to create interface block for routine
1894	for my $href (@$statements) {
1895	last if $href->{exec}; # exit loop at beginning of executable statements
1896
1897	# Get arguments of subroutine or function
1898	if ($href->{content} eq 'SUBROUTINE' or $href->{content} eq 'FUNCTION') {
1899	my $func;
1900	my @pu_args;
1901	$_ = $href->{statement};
1902	&parse_prog_unit (\$func, \@pu_args);
1903	$pu_args{uc ($_)} = 1 for @pu_args;
1904	next;
1905	}
1906
1907	# Get tokens from lines where arguments are present
1908	# Inspect only type declaration statements
1909	next unless $href->{decl} == 2;
1910
1911	my $statement = uc $href->{statement};
1912	$statement =~ s/!.*$//; # Remove trailing comment
1913
1914	my @line_tokens = ();
1915	if ($statement =~ s/^(.*?):://) {
1916	# New style declaration statement contains "::"
1917
1918	# Tokens in specification part
1919	my $spec = $1;
1920	my @tokens = ($spec =~ /\b$name\b/g);
1921	shift @tokens; # Remove leading token
1922
1923	for (@tokens) {
1924	push @line_tokens, $_
1925	unless /^(?:KIND\|LEN\|ALLOCATABLE\|POINTER\|TARGET\|DIMENSION\|OPTIONAL\|
1926	SAVE\|INTENT\|IN\|OUT\|INOUT\|PARAMETER)$/x;
1927	}
1928
1929	# Tokens in declaration part
1930	push @line_tokens, ($statement =~ /\b$name\b/g);
1931
1932	} else {
1933	# Old style declaration statement does not contain "::"
1934	@line_tokens = ($statement =~ /\b$name\b/g);
1935	shift @line_tokens; # Remove leading token
1936	}
1937
1938	push @tokens_in_lines, \@line_tokens;
1939
1940	# Check whether each token matches an argument
1941	for my $token (@line_tokens) {
1942	if (exists $pu_args{$token}) {
1943	$tokens{$_} = 1 for @line_tokens;
1944	last;
1945	}
1946	}
1947	}
1948
1949	# Parse statements one more time to ensure all required tokens are included
1950	for (@tokens_in_lines) {
1951	my @line_tokens = @{ $_ };
1952
1953	# Check whether line contains an essential token
1954	for my $token (@line_tokens) {
1955	if (exists $tokens{$token}) {
1956	$tokens{$_} = 1 for @line_tokens;
1957	last;
1958	}
1959	}
1960	}
1961
1962	# Create the interface block
1963	for my $href (@$statements) {
1964	my %myhref = %$href;
1965	my $content = $myhref{content};
1966
1967	# Ignore comment, executable statements and items in CONTAINS block
1968	next if $content eq 'comment';
1969	next if $myhref{exec};
1970	next if $myhref{in_contain};
1971
1972	# Delete existing pre- and post -inserts
1973	delete $myhref{pre_insert} if exists $myhref{pre_insert};
1974	delete $myhref{post_insert} if exists $myhref{post_insert};
1975
1976	# Put SUBROUTINE/FUNCTION statement into interface block
1977	if ($content =~ /^(?:SUBROUTINE\|FUNCTION)$/) {
1978	$myhref{pre_insert} = 'INTERFACE' . "\n"; # Insert INTERFACE statement
1979	push @$interface_block, \%myhref;
1980	}
1981
1982	# Add USE statement in interface block, if necessary
1983	if($myhref{decl} == 4) {
1984	$_ = uc $myhref{statement};
1985	tr/ \n//d;
1986
1987	if(/^USE$name,ONLY:(.+)$/) {
1988	# USE statement with ONLY, check token to see if it is necessary
1989	my @line_tokens = /\b$name\b/g;
1990
1991	for (@line_tokens) {
1992	if (exists $tokens{$_}) {
1993	push @$interface_block, \%myhref;
1994	last;
1995	}
1996	}
1997
1998	} else {
1999	# Always add USE statement without ONLY
2000	push @$interface_block, \%myhref;
2001	}
2002	}
2003
2004	if ($myhref{decl} == 1 or $myhref{decl} == 2) {
2005	$_ = uc ($myhref{statement});
2006	s/\s!.$//;
2007
2008	if ($content eq 'INTEGER' or $content eq 'PARAMETER') {
2009	# INTEGER and PARAMETER may be used for dimensioning
2010	my @line_tokens = /\b$name\b/g;
2011
2012	for (@line_tokens) {
2013	if (exists $tokens{$_}) {
2014	push @$interface_block, \%myhref;
2015	last;
2016	}
2017	}
2018	} else {
2019	# Add line only if an argument is present
2020	s/$nest_par//g;
2021	my @line_tokens = /\b$name\b/g;
2022
2023	for (@line_tokens) {
2024	if (exists $pu_args{$_}) {
2025	push @$interface_block, \%myhref;
2026	last;
2027	}
2028	}
2029	}
2030	}
2031
2032	# Add END statement to interface block
2033	if ($content =~ /^END\s+(?:SUBROUTINE\|FUNCTION)/) {
2034	$myhref{post_insert} = 'END INTERFACE' . "\n";
2035	push @$interface_block, \%myhref;
2036	}
2037	}
2038
2039	# Beautify the interface block
2040	for my $href (@$interface_block) {
2041	$_ = $href->{statement};
2042
2043	s/\!.*\n/\n/g; # Remove trailing comments
2044	s/ +/ /g; # Only one space
2045	s/\n *\n/\n/g; # Remove empty lines
2046	s/\n *\n/\n/g; # Remove empty lines again
2047	s/ +\n/\n/g; # No trailing spaces
2048
2049	$href->{statement} = $_;
2050	}
2051
2052	return;
2053	}
2054
2055	# ------------------------------------------------------------------------------
2056
2057	sub change_var_names{
2058	my($statements) = @_;
2059	foreach my $href (@$statements) {
2060	$_=$href->{statement};
2061	s/\bVAZX\b/YVAZX/ig;
2062	s/\bPVAZX\b/YDVAZX/ig;
2063	s/\bVAZG\b/YVAZG/ig;
2064	s/\bPVAZG\b/YDVAZG/ig;
2065	s/\bSCALP_DV\b/YSCALP/ig;
2066	s/\bRSCALP_DV\b/YRSCALP/ig;
2067	s/\bSCALPSQRT_DV\b/YSCALPSQRT/ig;
2068	s/\bRSCALPSQRT_DV\b/YRSCALPSQRT/ig;
2069	s/\bPYBAR\b/YDYBAR/ig;
2070	s/\bPSBAR\b/YDSBAR/ig;
2071	s/\bVCGLPC\b/YVCGLPC/ig;
2072	s/\bVCGLEV\b/YVCGLEV/ig;
2073	s/\bSKFROT\b/YSKFROT/ig;
2074	s/\bSKFMAT\b/YSKFMAT/ig;
2075	s/\bSTATE_VECTOR_4D\b/YSTATE_VECTOR_4D/ig;
2076	s/\bVAZX0\b/YVAZX0/ig;
2077	s/\bVAZG0\b/YVAZG0/ig;
2078	s/\bRSPFORCE\b/YSPFORCE/ig;
2079	$href->{statement}=$_;
2080	}
2081	}
2082	# =========================================================================
2083	sub remake_arg_decl{
2084	my($statements,$prog_info) = @_;
2085	my($href,$content,@pu_args,$func,%tokens);
2086	my($left,$right,%arghash,$dim);
2087	our($nest_par,$name);
2088
2089	my $dims='';
2090	# Crack existing dummy declarations, build hash arghash
2091	foreach $href (@$statements) {
2092	last if($href->{prog_unit} >0);
2093	if($href->{content} eq 'SUBROUTINE') { # Get arguments of subroutine
2094	$_=$href->{statement};
2095	my $dum=&parse_prog_unit(\$func,\@pu_args);
2096	# print Dumper(\@pu_args);
2097	for(@pu_args) {
2098	$_=uc($_);
2099	$arghash{$_}{other}='';
2100	$arghash{$_}{dimuse}=0;
2101	$arghash{$_}{intent}='';
2102	$arghash{$_}{used}=0;
2103	$arghash{$_}{set}=0;
2104	$arghash{$_}{reallyset}=0;
2105	$arghash{$_}{type}='';
2106	$arghash{$_}{comment}='';
2107	$arghash{$_}{inif}=0;
2108	}
2109	next;
2110	}
2111	if($href->{decl} == 2) {
2112	$_=$href->{statement};
2113	my $comment='';
2114	$comment=$1 if(/.(\!.)$/);
2115	s/\!.*\n/\n/g; # Remove trailing comments in all lines
2116	$_=uc($_);
2117	s/\s//g;
2118	if(/^(.+)::(.+)$/){
2119	$left=$1;
2120	$right=$2;
2121	$_=$right;
2122	s/$nest_par//g;
2123	s/($name)\*\w+/$1/g;
2124	# print "XX $_ \n";
2125	foreach my $arg (@pu_args) {
2126	if(/\b$arg\b/) {
2127	# print "ARG $arg $left $_ \n";
2128	$arghash{$arg}{linedec}=$href->{number};
2129	$arghash{$arg}{comment}=$comment;
2130	my @locdec =split ',',$left;
2131	my $i=0;
2132	foreach my $locdec (@locdec) {
2133	if($i == 0) {
2134	$arghash{$arg}{type}=$locdec;
2135	}
2136	elsif($locdec=~/\bINTENT/) {
2137	$arghash{$arg}{intent}=','.$locdec;
2138	}
2139	else {
2140	$arghash{$arg}{other}=$arghash{$arg}{other}.','.$locdec;
2141	}
2142	$i++;
2143	}
2144	if($right=~/\b$arg\b(\*\w+)/) {
2145	$dim=$1;
2146	}
2147	elsif($right=~/\b$arg\b($nest_par\*$nest_par)/) {
2148	$dim=$1;
2149	}
2150	elsif($right=~/\b$arg\b($nest_par\*\w+)/) {
2151	$dim=$1;
2152	}
2153	elsif($right=~/\b$arg\b(\*$nest_par)/) {
2154	$dim=$1;
2155	}
2156	elsif($right=~/\b$arg\b($nest_par)/) {
2157	$dim=$1;
2158	}
2159	else {
2160	$dim='';
2161	}
2162	$arghash{$arg}{dim}=$dim;
2163	$dims=$dims.$dim
2164	}
2165	}
2166	foreach my $arg (@pu_args) { # Is arg. used for dimensioning other args?
2167	if($dims=~/\b$arg\b/i) {
2168	$arghash{$arg}{dimuse}=1;
2169	}
2170	}
2171	}
2172	}
2173	}
2174	my $insert_line=0;
2175	foreach $href (@$statements) {
2176	last if($href->{prog_unit} >0);
2177	if($href->{decl} == 2 or $href->{content} eq 'PARAMETER') {
2178	$_=uc($href->{statement});
2179	next unless /\bPARAMETER\b/;
2180	my @tmpvar=/\b$name\b/g;
2181	foreach my $token (@tmpvar) {
2182	if($dims=~/\b$token\b/) {
2183	$insert_line=$href->{number};
2184	}
2185	}
2186	}
2187	}
2188
2189	# Gather info to decide INTENT status
2190	my $inif=0;
2191	my @inif_stack=();
2192	my $cur_inif=0;
2193	foreach $href (@$statements) {
2194	last if($href->{prog_unit} >0);
2195	if($href->{exec}) {
2196	if($href->{content} eq 'ENDIF') {
2197	$inif--;
2198	$cur_inif=pop @inif_stack;
2199	next;
2200	}
2201	elsif($href->{content} eq 'ELSEIF' or $href->{content} eq 'ELSE') {
2202	$cur_inif=pop @inif_stack;
2203	$cur_inif=$href->{number};
2204	push @inif_stack,$cur_inif;
2205	}
2206	my ($left,$right);
2207	$_=$href->{statement};
2208	s/\!.*\n/\n/g; # Remove trailing comments in all lines
2209	my %setnow=();
2210	foreach my $arg (@pu_args) {
2211	$setnow{$arg}=0;
2212	$setnow{$arg}=1 if($arghash{$arg}{reallyset});
2213	unless ($setnow{$arg}) {
2214	foreach my $xx (@inif_stack) {
2215	$setnow{$arg}=1 if($xx == $arghash{$arg}{inif});
2216	}
2217	}
2218	}
2219
2220	if($href->{content} eq 'scal_assign' or $href->{content} eq 'array_assign') {
2221	s/\s//g;
2222	($left,$right)=/^(.+)=(.+)$/;
2223	$_=$right;
2224	foreach my $arg (@pu_args) {
2225	if(/\b$arg\b/i) {
2226	$arghash{$arg}{used}=1 unless $setnow{$arg};
2227	}
2228	}
2229	$_=$left;
2230	if(/($nest_par)/) {
2231	$_=$1;
2232	foreach my $arg (@pu_args) {
2233	if(/\b$arg\b/i) {
2234	$arghash{$arg}{used}=1 unless $setnow{$arg};
2235	}
2236	}
2237	}
2238	$_=$left;
2239	foreach my $arg (@pu_args) {
2240	if(/^$arg\b/i) {
2241	$arghash{$arg}{set}=1;
2242	$arghash{$arg}{inif}=$cur_inif;
2243	$arghash{$arg}{reallyset}=1 unless($inif);
2244	}
2245	}
2246	}
2247	elsif($href->{content} eq 'IF' ) {
2248	if($href->{content2} eq 'scal_assign' or $href->{content2} eq 'array_assign' or
2249	$href->{content2} eq 'CALL') {
2250	s/\n//g;
2251	($left,$right)=/^\s(IF\b\s$nest_par)(.+)/i;
2252	$_=$left;
2253	foreach my $arg (@pu_args) {
2254	if(/\b$arg\b/i) {
2255	$arghash{$arg}{used}=1 unless $setnow{$arg};
2256	}
2257	}
2258	$_=$right;
2259	if($href->{content2} eq 'CALL') {
2260	my $statement=$right;
2261	my $inifx=1;
2262	&propag_arg(\$statement,\%arghash,\$inifx,\%setnow);
2263	}
2264	else {
2265	s/\s//g;
2266	($left,$right)=/^(.+)=(.+)$/;
2267	$_=$right;
2268	foreach my $arg (@pu_args) {
2269	if(/\b$arg\b/i) {
2270	$arghash{$arg}{used}=1 unless $setnow{$arg};
2271	}
2272	}
2273	$_=$left;
2274	if(/($nest_par)/) {
2275	$_=$1;
2276	foreach my $arg (@pu_args) {
2277	if(/\b$arg\b/i) {
2278	$arghash{$arg}{used}=1 unless $setnow{$arg};
2279	}
2280	}
2281	}
2282	$_=$left;
2283	foreach my $arg (@pu_args) {
2284	if(/^$arg\b/i) {
2285	$arghash{$arg}{inif}=$cur_inif;
2286	$arghash{$arg}{set}=1;
2287	}
2288	}
2289	}
2290	}
2291	else {
2292	foreach my $arg (@pu_args) {
2293	if(/\b$arg\b/i) {
2294	$arghash{$arg}{used}=1 unless $setnow{$arg};
2295	}
2296	}
2297	}
2298	}
2299	elsif($href->{content} eq 'WHERE' ) {
2300	s/\s//g;
2301	($left,$right)=/^(WHERE$nest_par)(.+)/i;
2302	$_=$left;
2303	foreach my $arg (@pu_args) {
2304	if(/\b$arg\b/i) {
2305	$arghash{$arg}{used}=1 unless $setnow{$arg};
2306	}
2307	}
2308	$_=$right;
2309	($left,$right)=/^(.+)=(.+)$/;
2310	$_=$right;
2311	foreach my $arg (@pu_args) {
2312	if(/\b$arg\b/i) {
2313	$arghash{$arg}{used}=1 unless $setnow{$arg};
2314	}
2315	}
2316	$_=$left;
2317	foreach my $arg (@pu_args) {
2318	if(/^$arg\b/i) {
2319	$arghash{$arg}{inif}=$cur_inif;
2320	$arghash{$arg}{set}=1;
2321	}
2322	}
2323	}
2324	elsif($href->{content} eq 'CALL') {
2325	my $statement=$_;
2326	&propag_arg(\$statement,\%arghash,\$inif);
2327	}
2328	else{
2329	foreach my $arg (@pu_args) {
2330	if(/\b$arg\b/i) {
2331	$arghash{$arg}{used}=1 unless $setnow{$arg};
2332	}
2333	}
2334	}
2335	if($href->{content} eq 'IF_construct') {
2336	$inif++;
2337	$cur_inif=$href->{number};
2338	push @inif_stack,$cur_inif;
2339	}
2340	}
2341	}
2342
2343	# Create INTENT statemant based on gathered info
2344	foreach my $arg (@pu_args) {
2345	if($arghash{$arg}{linedec}) {
2346	if($arghash{$arg}{nointent}) {
2347	unless($arghash{$arg}{intent}) {
2348	$arghash{$arg}{intent}=' ';
2349	$arghash{$arg}{comment}='! UNDETERMINED INTENT';
2350	}
2351	}
2352	else{
2353	my $intent='';
2354	$intent='IN' if($arghash{$arg}{used} or $arghash{$arg}{dimuse});
2355	$intent=$intent.'OUT' if($arghash{$arg}{set});
2356	if($intent) {
2357	if($arghash{$arg}{intent} and $intent eq 'OUT') {
2358	$intent='INOUT' if $arghash{$arg}{intent}=~/INOUT/i;
2359	}
2360	$arghash{$arg}{intent}=',INTENT('.$intent.')';
2361	}
2362	else {
2363	$arghash{$arg}{intent}=' ';
2364	$arghash{$arg}{comment}='! Argument NOT used';
2365	}
2366	}
2367	}
2368	}
2369
2370	# Remove existing argument declarations
2371	foreach my $arg (@pu_args) {
2372	if($arghash{$arg}{linedec}) {
2373	$_=$$statements[$arghash{$arg}{linedec}]->{statement};
2374	# print "BEFORE $arg $_";
2375	if(/.::\s\b$arg\b\s(\!.\n)*$/i) {
2376	$_='';
2377	}
2378	elsif(/.::\s\b$arg\b\s$nest_par\s(\!.\n)$/i) {
2379	$_='';
2380	}
2381	elsif(/.::\s\b$arg\b\s\\s\w+\s(\!.\n)$/i) {
2382	$_='';
2383	}
2384	elsif(/.::\s\b$arg\b\s\\s$nest_par\s(\!.\n)$/i) {
2385	$_='';
2386	}
2387	elsif(/.::\s\b$arg\b\s$nest_par\s\\s\w+\s(\!.\n)*$/i) {
2388	$_='';
2389	}
2390	elsif(/.::\s\b$arg\b\s$nest_par\s\\s$nest_par\s(\!.\n)*$/i) {
2391	$_='';
2392	}
2393	else{
2394	/^(.::)(.)$/s;
2395	my $left=$1;
2396	$_=$2;
2397	s/\b$arg\b\s*$nest_par//i;
2398	s/\b$arg\b\s\\s*\w+//i;
2399	s/\b$arg\b\s\\s*$nest_par//i;
2400	s/\b$arg\b//i;
2401	s/,\s*,/,/;
2402	s/,(\s*)$/$1/;
2403	s/\n\s*\n/\n/g;
2404	$_=$left.$_;
2405	s/::\s*,/::/;
2406	}
2407	# print "AFTER $arg $_\n";
2408	$$statements[$arghash{$arg}{linedec}]->{statement}=$_;
2409	}
2410	}
2411
2412	# Write out
2413
2414	my $newdecl='';
2415	my $linedec;
2416	foreach my $arg (@pu_args) {
2417	if($arghash{$arg}{linedec}) {
2418	if($arghash{$arg}{other} and ! $arghash{$arg}{dim}) {
2419	$arghash{$arg}{other}=~s/\s//g;
2420	if($arghash{$arg}{other}=~/^,DIMENSION($nest_par)$/i) {
2421	$arghash{$arg}{other}='';
2422	$arghash{$arg}{dim}=$1;
2423	}
2424	}
2425	if($arghash{$arg}{dimuse}) { # Put declerations of args first
2426	$linedec=sprintf "%-18s%s%-14s%s%s%s%s %s",
2427	$arghash{$arg}{type},$arghash{$arg}{other},$arghash{$arg}{intent},
2428	' :: ',$arg,$arghash{$arg}{dim},$arghash{$arg}{comment},"\n";
2429	$newdecl=$newdecl.$linedec;
2430	}
2431	}
2432	}
2433	foreach my $arg (@pu_args) {
2434	if($arghash{$arg}{linedec}) {
2435	unless($arghash{$arg}{dimuse}) {
2436	$linedec=sprintf "%-18s%s%-14s%s%s%s %s%s",
2437	$arghash{$arg}{type},$arghash{$arg}{other},$arghash{$arg}{intent},
2438	' :: ',$arg,$arghash{$arg}{dim},$arghash{$arg}{comment},"\n";
2439	$newdecl=$newdecl.$linedec;
2440	}
2441	}
2442	}
2443	# print "INSERT_LINE $insert_line \n";
2444	if($insert_line) {
2445	$$statements[$insert_line]->{post_insert}=$newdecl;
2446	}
2447	else{
2448	foreach $href (@$statements) {
2449	if($href->{decl} == 2) {
2450	$href->{pre_insert}=$newdecl;
2451	last;
2452	}
2453	}
2454	}
2455
2456	# print $newdecl;
2457	# print Dumper(\%arghash);
2458	}
2459
2460	sub propag_arg{
2461	my ($statement,$arghash,$inif,$setnow) = @_;
2462	our ($name,$nest_par);
2463	my (%argpos);
2464	$_=$$statement;
2465	s/^\s*CALL\s+($name)//i;
2466	my $called=lc($1);
2467	s/\s//g;
2468	s/^$(.*)$$/$1/s;
2469	my @inpars=/$nest_par/g;
2470	s/$nest_par//g;
2471	s/($name)%$name/$1/g;
2472	$_=uc($_);
2473	# print "PROPAG $called $_ ££ @inpars \n";
2474	my @call_args=split ',' , $_;
2475	my $i=0;
2476	my $interesting=0;
2477	%argpos=();
2478	foreach my $call (@call_args) {
2479
2480	# print "CALL $called $call \n" ;
2481	if($call=~/(.+)=(.+)/) {
2482	$call=$2; #This just by-passes the problem
2483	}
2484	if(exists $$arghash{$call}) {
2485	if(exists $argpos{$call}) {
2486	push @{$argpos{$call}},$i;
2487	}
2488	else {
2489	my @i=($i);
2490	$argpos{$call}=[@i];
2491	}
2492	$interesting=1;
2493	}
2494	$i++;
2495	}
2496	if($interesting) {
2497	my $fname='/tmp/intblocks/'.$called.'.intfb.h';
2498	if( -f $fname ) {
2499	my @dumargs=();
2500	my $unit_name;
2501	print "FILE $fname FOUND \n";
2502	my @lines = &readfile($fname);
2503	my @loc_statements=();
2504	&expcont(\@lines,\@loc_statements);
2505	foreach my $href (@loc_statements) {
2506	$_=$href->{statement};
2507	if(/^\s*SUBROUTINE/i) {
2508	my $dum=&parse_prog_unit(\$unit_name,\@dumargs);
2509	next;
2510	}
2511	if(/::/) {
2512	s/\s//g;
2513	foreach my $arg (keys (%argpos)) {
2514	my $set_before=$$setnow{$arg};
2515	foreach my $i (@{$argpos{$arg}}){
2516	if(/::$dumargs[$i]/) {
2517	if(/INTENT$IN$/i) {
2518	$$arghash{$arg}{used}=1 unless $set_before;
2519	}
2520	elsif(/INTENT$OUT$/i) {
2521	$$arghash{$arg}{set}=1;
2522	$$setnow{$arg}=1 unless($$inif);
2523	}
2524	elsif(/INTENT$INOUT$/i) {
2525	$$arghash{$arg}{set}=1;
2526	$$arghash{$arg}{used}=1 unless $set_before;;
2527	$$arghash{$arg}{reallyset}=1 unless($$inif);
2528	}
2529	elsif(/\! UNDETERMINED INTENT/) {
2530	$$arghash{$arg}{nointent}=1;
2531	}
2532	}
2533	}
2534	}
2535	}
2536	}
2537	}
2538	else {
2539	foreach my $arg (keys (%argpos)) {
2540	$$arghash{$arg}{nointent}=1;
2541	}
2542	}
2543	}
2544	for (@inpars) {
2545	foreach my $arg (keys (%$arghash)) {
2546	if(exists $$arghash{$arg}) {
2547	if(/\b$arg\b/i) {
2548	$$arghash{$arg}{used}=1 unless $$setnow{$arg};
2549	}
2550	}
2551	}
2552	}
2553	}
2554
2555	sub add_interface_blocks {
2556	# Add interface block for called routines
2557	use File::Find;
2558	my($statements,$prog_info) = @_;
2559	my($href,$call);
2560	our($name,$nest_par);
2561	our(@call_names,@call_names_found,%call_names);
2562
2563	return unless ($$prog_info{no_calls}); # Skip if there are no calls
2564	@call_names=();
2565	%call_names=();
2566
2567	my $last_decl=0;
2568	my $in_intfblk=0;
2569	my %already_in=();
2570	ST:foreach $href (@$statements) {
2571	last if($href->{prog_unit} > 0); # Only consider first program unit (no contains)
2572	if($href->{content} eq 'INTERFACE') {
2573	$in_intfblk=1;
2574	next;
2575	}
2576	if($href->{content} eq 'END INTERFACE') {
2577	$in_intfblk=0;
2578	next;
2579	}
2580	if($in_intfblk) {
2581	$_=$href->{statement};
2582	s/\#include\s\"(\w+)\.h\"\s$/$1/;
2583	$_=lc($_);
2584	$already_in{$_}++;
2585	next;
2586	}
2587
2588	# Find last declaration
2589	if($href->{decl}) {
2590	next if($href->{content} eq 'FORMAT');
2591	next if($href->{content} eq 'DATA');
2592	$last_decl = $href->{number} ;
2593	}
2594	# Find calls
2595	next unless($href->{exec});
2596	if($href->{content} eq 'CALL' or
2597	(exists $href->{content2} and$ href->{content2} eq 'CALL') ) {
2598	$_=$href->{statement};
2599	/\s\bCALL\b\s($name)/i;
2600	my $call=lc($1);
2601	next if($already_in{$call}); # Exclude already existing interface block
2602	next if($call eq 'packmsg'); # A couple of special exceptions
2603	next if($call eq 'unpkmsg');
2604	$call_names{$call}++;
2605	}
2606	}
2607
2608
2609	# Check that routine exists in IFS
2610	@call_names_found=();
2611	find(\&calls_wanted,'/tmp/27/ifs/');
2612	# find(\&calls_wanted,'/home/mats/work/cy28/ifs/');
2613	# find(\&calls_wanted,'/tmp/27/trans/');
2614	@call_names_found=sort(@call_names_found);
2615	# print "P2 @call_names_found \n";
2616	@call_names=@call_names_found;
2617
2618	# Contruct include block
2619	my $block='';
2620	for (@call_names) {
2621	$block=$block.'#include "'.$_.'.intfb.h"'."\n";
2622	}
2623	# print $block;
2624
2625	my $clean=0;
2626	if(@call_names) {
2627	if($$prog_info{has_interface_block}) {
2628	foreach $href (@$statements) {
2629	# Add interface block to routine that already has INTERFACE statement
2630	if($href->{content} eq 'END INTERFACE'){
2631	if($href->{post_insert}) {
2632	$href->{post_insert}=$href->{post_insert}."\n".$block;
2633	}
2634	else {
2635	$href->{post_insert}="\n".$block;
2636	}
2637	last;
2638	}
2639	}
2640	}
2641	# Add interface block to routine that does not have previous INTERFACE statement
2642	else {
2643	$href=@$statements[$last_decl];
2644	if($href->{post_insert}) {
2645	$href->{post_insert}=$href->{post_insert}."\n".$block;
2646	}
2647	else {
2648	$href->{post_insert}="\n".$block;
2649	}
2650	}
2651	# Remove from EXTERNAL statement where interface block has been added
2652	foreach $href (@$statements) {
2653	if($href->{content} eq 'EXTERNAL') {
2654	$_=$href->{statement};
2655	foreach my $ext (@call_names) {
2656	s/\b$ext\b//i;
2657	}
2658	s/,\s*,/,/g;
2659	s/^(\sEXTERNAL\s),/$1/i;
2660	s/^(\sEXTERNAL.),\s*$/$1/i;
2661	s/^\sEXTERNAL\s,\s$//i;
2662	$href->{statement}=$_;
2663	}
2664	}
2665	}
2666	}
2667	#======================================================================================
2668	sub calls_wanted {
2669	# Used by Find as called from add_interface_blocks
2670	our(%call_names,@call_names_found);
2671	return unless (/^(\w+)\.F90$/);
2672	my $call=$1;
2673	if($call_names{$call}) {
2674	push(@call_names_found,$call);
2675	}
2676	}
2677	sub remove_some_comments{
2678	my($statements) = @_;
2679	my $prev_empty=0;
2680	foreach my $href (@$statements) {
2681	if($href->{content} eq 'comment'){
2682	$_=$href->{statement};
2683	if(/^\s*$/) {
2684	if($prev_empty) {
2685	s/\s*//;
2686	$href->{statement}=$_;
2687	}
2688	else {
2689	$prev_empty=1;
2690	}
2691	next;
2692	}
2693	$prev_empty=0;
2694	s/^\s![\s\]\bLOCAL\s+(INTEGER\|REAL\|LOGICAL\|CHARACTER)\s+(SCALARS\|ARRAYS).\n$//i;
2695	s/^\s![\s\]\bDUMMY\s+(INTEGER\|REAL\|LOGICAL\|CHARACTER)\s+(SCALARS\|ARRAYS).\n$//i;
2696	s/^\s![\s\]\bLOCAL\s+(INTEGER\|REAL\|LOGICAL\|CHARACTER).\n$//i;
2697	s/^\s![\s\]\bDUMMY\b\s$//i;
2698	s/^\s![\s\]\bLOCAL\b\s$//i;
2699	s/^\s![\s\]\bLOCAL\b:\s$//i;
2700	s/^\s![\s\]\bLOCAL ARRAYS\b[\s\]*$//i;
2701	s/^\s![\s\]\bLOCAL SCALARS\b\s$//i;
2702	s/^\s![\s\]\s\d\.\d+\s\bLOCAL ARRAYS\b\s$//i;
2703	s/^\s![\s\]\s=== LOCAL ARRAYS ===\s*$//i;
2704	$href->{statement}=$_;
2705	}
2706	else {
2707	$prev_empty=0;
2708	}
2709	}
2710	}
2711	sub get_calls_inc {
2712	my($statements,$calls,$intfb) = @_;
2713	foreach my $href (@$statements) {
2714	if($href->{content} eq 'CALL') {
2715	$_=$href->{statement};
2716	/^\sCALL\s+([A-Z]\w)/i;
2717	$$calls{lc($1)}++;
2718	}
2719	elsif($href->{content} eq 'IF') {
2720	if($href->{content2} eq 'CALL') {
2721	$_=$href->{statement};
2722	/\bCALL\s+([A-Z]\w*)/i;
2723	$$calls{lc($1)}++;
2724	}
2725	}
2726	elsif($href->{content} eq 'include') {
2727	$_=$href->{statement};
2728	$$intfb{$1}=1 if(/["](\S+)\.intfb\.h["]/);
2729	$$intfb{$1}=2 if(/["](\S+)\.h["]/); # For old-style interface blocks
2730	}
2731	}
2732	}
2733
2734	1;
2735
2736	__END__

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

Context Navigation

source: LMDZ6/trunk/tools/fcm/lib/Ecmwf/Fortran90_stuff.pm @ 3511

Download in other formats: