Context Navigation

Fortran90_stuff.pm

Last change on this file 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

Rev	Line
[1578]	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: LMDZ5/trunk/tools/fcm/lib/Ecmwf/Fortran90_stuff.pm

Download in other formats: