buildiface

fortran并行计算包

	&print_weak_decl( $OUTFD, "mpi_${lcname}", $args, $lcname );
	&print_weak_decl( $OUTFD, "mpi_${lcname}_", $args, $lcname );
	&print_weak_decl( $OUTFD, "pmpi_${lcname}_", $args, $lcname );
	print $OUTFD "\
#pragma weak MPI_$ucname = pmpi_${lcname}__
#pragma weak mpi_${lcname}__ = pmpi_${lcname}__
#pragma weak mpi_${lcname}_ = pmpi_${lcname}__
#pragma weak mpi_${lcname} = pmpi_${lcname}__
#pragma weak pmpi_${lcname}_ = pmpi_${lcname}__\n\n";

       print $OUTFD "\
#elif defined(HAVE_PRAGMA_WEAK)\

#if defined(F77_NAME_UPPER)\n";
        &print_weak_decl( $OUTFD, "MPI_$ucname", $args, $lcname );
        print $OUTFD "\
#pragma weak MPI_$ucname = PMPI_$ucname\
#elif defined(F77_NAME_LOWER_2USCORE)\n";
        &print_weak_decl( $OUTFD, "mpi_${lcname}__", $args, $lcname );
	print $OUTFD "\
#pragma weak mpi_${lcname}__ = pmpi_${lcname}__\
#elif !defined(F77_NAME_LOWER_USCORE)\n";
        &print_weak_decl( $OUTFD, "mpi_$lcname", $args, $lcname );
	print $OUTFD "\
#pragma weak mpi_$lcname = pmpi_$lcname\
#else\n";
        &print_weak_decl( $OUTFD, "mpi_${lcname}_", $args, $lcname );
	print $OUTFD "\
#pragma weak mpi_${lcname}_ = pmpi_${lcname}_\
#endif\
\
#elif defined(HAVE_PRAGMA_HP_SEC_DEF)\
#if defined(F77_NAME_UPPER)\
#pragma _HP_SECONDARY_DEF PMPI_$ucname  MPI_$ucname\
#elif defined(F77_NAME_LOWER_2USCORE)\
#pragma _HP_SECONDARY_DEF pmpi_${lcname}__  mpi_${lcname}__\
#elif !defined(F77_NAME_LOWER_USCORE)\
#pragma _HP_SECONDARY_DEF pmpi_$lcname  mpi_$lcname\
#else\
#pragma _HP_SECONDARY_DEF pmpi_${lcname}_  mpi_${lcname}_\
#endif\
\
#elif defined(HAVE_PRAGMA_CRI_DUP)\
#if defined(F77_NAME_UPPER)\
#pragma _CRI duplicate MPI_$ucname as PMPI_$ucname\
#elif defined(F77_NAME_LOWER_2USCORE)\
#pragma _CRI duplicate mpi_${lcname}__ as pmpi_${lcname}__\
#elif !defined(F77_NAME_LOWER_USCORE)\
#pragma _CRI duplicate mpi_${lcname} as pmpi_${lcname}\
#else\
#pragma _CRI duplicate mpi_${lcname}_ as pmpi_${lcname}_\
#endif\
#endif /* HAVE_PRAGMA_WEAK */\
#endif /* USE_WEAK_SYMBOLS */\
/* End MPI profiling block */\n\n";

    &AddFwrapWeakName( $lcname, $ucname );
    }
}

#
# Print the code that modifies the name
# The function prototypes must be loaded *after* the name block so that the
# name used in the function prototypes will match the one that is declared
# in this file.
sub print_name_map_block {
    my $routine_name = $_[0];
    my $lcname = $_[1];
    my $ucname = uc($lcname);
    
    # This include the code to map names for the profiling interface,
    # using the same macro as for the rest of the MPI code
    $uc_out_prefix = uc($out_prefix);
    if ($do_profiling) {
	# Remove the leading MPI_ if the name has it.
	if ($routine_name =~ /^MPI_/) {
	    $routine_name =~ s/^MPI_//;
	}
	print $OUTFD "
/* Map the name to the correct form */
#ifndef MPICH_MPI_FROM_PMPI
#ifdef F77_NAME_UPPER
#define ${out_prefix}${lcname}_ PMPI_${ucname}
#elif defined(F77_NAME_LOWER_2USCORE)
#define ${out_prefix}${lcname}_ pmpi_${lcname}__
#elif !defined(F77_NAME_LOWER_USCORE)
#define ${out_prefix}${lcname}_ pmpi_${lcname}
#else
#define ${out_prefix}${lcname}_ pmpi_${lcname}_
#endif
/* This defines the routine that we call, which must be the PMPI version
   since we're renaming the Fortran entry as the pmpi version.  The MPI name
   must be undefined first to prevent any conflicts with previous renamings,
   such as those put in place by the globus device when it is building on
   top of a vendor MPI. */
#undef MPI_${routine_name}
#define MPI_${routine_name} PMPI_${routine_name} 

#else
";
    }
    print $OUTFD "
#ifdef F77_NAME_UPPER
#define ${out_prefix}${lcname}_ ${uc_out_prefix}${ucname}
#elif defined(F77_NAME_LOWER_2USCORE)
#define ${out_prefix}${lcname}_ ${out_prefix}${lcname}__
#elif !defined(F77_NAME_LOWER_USCORE)
#define ${out_prefix}${lcname}_ ${out_prefix}${lcname}
/* Else leave name alone */
#endif

";
    if ($do_profiling) {
	print $OUTFD "
#endif /* MPICH_MPI_FROM_PMPI */
";
    }
    if ($build_prototypes) {
	print $OUTFD "
/* Prototypes for the Fortran interfaces */
#include \"$prototype_header_file\"
";
    }
}

# Print the arguments for the routine DEFINITION.
sub print_args { 
    my @parms = split(/\s*,\s*/, $_[1] );
    my $OUTFD = $_[0];
    my $count = 1;
    my $last_args = "";
    my $prototype_only = $_[2];
    my $routine = $_[3];

    # Clear the @arg_addresses and $arg_qualifiers array.
    $#arg_addresses = -1;
    $#arg_qualifiers = -1;

    # Special case: if the only parm is "void", remove it from the list
    print STDERR "Nparms = $#parms, parms = " . join(',',@parms) . "\n" if $debug;
    if ($#parms == 0 && $parms[0] eq "void") {
	$#parms = -1;
    }
    # argsep is used to add a comma before every argument, except for the 
    # first
    $argsep = "";
    print $OUTFD "( ";
    foreach $parm (@parms) {
	# Match type to replacement
	print "parm = :$parm:\n" if $debug;
	# Remove qualifiers from the parm
	$arg_qualifiers[$count] = "";
	if ($parm =~ /^const\s+/) {
	    $parm =~ s/^const\s+//;
	    $arg_qualifiers[$count] .= "const ";
	}
	if ($parm =~ /^restrict\s+/) {
	    $parm =~ s/restrict\s+//;
	    $arg_qualifiers[$count] .= "restrict ";
	}
	# Remove arg names from array types
	if ($parm =~ /(\w+)\s+(\w+)\s*\[\]/) {
	    # Assume that this is <type> <name>[]; convert to
	    # <type>[]
	    print "    Removing argname $2 from parm array $parm\n" if $debug;
	    $parm = "$1" . "[]";
	}
	# Remove arg names from pointer types
	elsif ($parm =~ /(.*\*)\s+(\w+)/) {
	    print "    Removing argname $2 from parm pointer\n" if $debug;
	    $parm = $1;
	}
	# Remove blanks from the parm
	$parm =~ s/\s+//;
	$arg_addresses[$count] = 0;

	# This handles routines that have special declaration requirements
	# for particular arguments
	if (defined($declarg{"$routine-$count"})) {
	    print "    Using declarg{$routine} for this parm\n" if $debug;
	    $parm = $declarg{"$routine-$count"};
	    if ($prototype_only) {
		print $OUTFD "$argsep$parm";
	    }
	    else {
		print $OUTFD "$argsep$parm v$count";
	    }
	}
	elsif ($parm =~ /char\s*\*/) {
	    # char's go out at char *v FORT_MIXED_LEN(d) 
	    # and FORT_END_LEN(d) at the end
	    # (even if an array, because at the Fortran level, it
	    # is still a pointer to a character variable; the length
	    # of each entry in the array is the "d" value).
	    # FORT_END_LEN and FORT_MIXED_LEN contain the necessary comman
	    # if they are prsent at all.
	    print "    parm is a character string\n" if $debug;
	    if ($prototype_only) {
		print $OUTFD "${argsep}char * FORT_MIXED_LEN_DECL";
		$last_args .= "FORT_END_LEN_DECL ";
	    }
	    else {
		print $OUTFD "${argsep}char *v$count FORT_MIXED_LEN(d$count)";
		$last_args .= "FORT_END_LEN(d$count) ";
	    }
	}
	elsif ($parm =~/\[/) {
	    # Argument type is array, so we need to 
	    #  a) mark as containing a star
	    #  b) place parameter correctly
	    $star_count = 1;
	    $arg_addresses[$count] = $star_count;
	    # Split into raw type and []
            # Use \S* instead of the equivalent [^\s]*.
            # (\S is not-a-space)
            # perl 5.8 is known to mishandle the latter, leading to
	    # an empty basetype
	    if ($parm =~ /\s*(\S*)\s*(\[\s*\])/) {
		$basetype = $1;
	    }
	    else {
		print STDERR "Internal error.  Could not find basetype\n";
		print STDERR "This may be a bug in perl in the handling of certain expressions\n";
	    }
	    print "\tparm $parm is array of >$basetype<\n" if $debug;
	    #$foundbrack = $2;
	    if (defined($tof77{$parm})) {
		# This is a special case; the full type is defined.
		# This is used, for example, for int [][3] in the
		# routines that specify a range.
		print "Matched to full type $parm with replacement $tof77{$parm}\n" if $debug;
		# We use the replacement type
		$basetype = $tof77{$parm};
		$star_count = 0;
		$arg_addresses[$count] = $star_count;
	    }
	    elsif ($basetype eq "int") {
		# Do nothing because the [] added to the arg below
		# is all that is necessary.
		$star_count = 0;
		$arg_addresses[$count] = $star_count;
	    }
	    elsif (defined($tof77{"$basetype\[\]"})) {
		# Use the code for handling array parameters if
		# mapping code is provided.
		print "Match to array type $basetype\[\]\n" if $debug;
		$star_count = 0;
		$arg_addresses[$count] = $star_count;
		$basetype = $tof77{"$basetype\[\]"};
	    }
	    elsif (defined($tof77{$basetype})) {
		# FIXME: This code (now commented out) is not correct
		print STDERR "Using fall through for $basetype in $routine\n" if $debug;
# 		if ($useOldCode eq "yes") {
# 		$nstar_before = ($basetype =~ /\*/);
# 		$basetype = $tof77{$basetype};
# 		# The following fixes the case where the underlying type 
# 		# is a simple int.
# 		if ($basetype eq "int") {
# 		    $arg_addresses[$count] = 0;
# 		}
# 		print "\tparm has defined type of $basetype\n" if $debug;
# 		$nstar_after = ($basetype =~ /\*/);
# 		if ($nstar_before != $nstar_after) {
# 		    $star_count++;
# 		}
		# If we have an array, and a type mapping to fortran
		# We want to simply pretend that all is well (like int
		# above)
		$star_count = 0;
		$arg_addresses[$count] = $star_count;
	    }
	    if ($prototype_only) {
		print $OUTFD "$argsep$basetype \[\]";
	    }
	    else {
		print $OUTFD "$argsep$basetype v$count\[\]";
	    }
	}
	else {
	    $nstar_before = ($parm =~ /\*/);
	    $nstar_after = $nstar_before;
	    print "Nstar = $nstar_after\n" if $debug;
	    if (defined($tof77{$parm})) {
		$parm = $tof77{$parm};
		$nstar_after = ($parm =~ /\*/);
	    }
	    $leadspace = "";
	    if ($parm =~ /\w$/) {
		$leadspace = " ";
	    }
	    if ($prototype_only) {
		print $OUTFD "${argsep}${parm}";
	    }
	    else {
		print $OUTFD "${argsep}${parm}${leadspace}v$count";
	    }
	    $star_count = 0;
	    if ($nstar_before != $nstar_after) {
		$star_count = 1;
	    }
	    $arg_addresses[$count] = $star_count;
	}
	$count++;
	$argsep = ", ";
    }
    # Add the new error return code if necessary
    $tmpargs= $errparm;
    $tmpargs =~ s/\s*//g;
    if ($tmpargs ne "") {
	if ($prototype_only) {
	    print $OUTFD "$argsep$errparmtype";
	}
	else {
	    print $OUTFD "$argsep$errparm";
	}
    }
    print $OUTFD " $last_args";
    print $OUTFD ")";
}

# Print the arguments for the routine CALL.  
# Handle the special arguments
sub print_call_args {
    my @parms = split(/\s*,\s*/, $_[0] );
    my $count = 1;
    my $first = 1;
    print $OUTFD "( ";
    # Special case: if the only parm is "void", remove it from the list
    if ($#parms == 0 && $parms[0] eq "void") {
	$#parms = -1;
    }

    foreach $parm (@parms) {
	$parm =~ s/^const\s//;  # Remove const if present
	# Remove variable name if present in an array arg
	if ($parm =~ /(.*)\s+(\w+)\[\]/) {
	    $parm = "$1 \[\]";
	}
	# Compress multiple spaces
	$parm =~ s/\s\s/ /g;
	if (!$first) { print $OUTFD ", "; } else { $first = 0; }

	if (defined($special_args{"${routine_name}-$count"})) {
	    # We must handle this argument specially
	    &print_special_call_arg( $routine_name, $count );
	}
	else {
	    # Convert to/from object type as required.  
	    #print "TMP: parm = $arg_qualifiers[$count]$parm\n";
	    $fullparm="$arg_qualifiers[$count]$parm";
	    if (defined($argsneedcast{$fullparm})) {
		$argval = "v$count";
		if ($arg_addresses[$count] > 0) {
		    $argval = "*$argval";
		}
		$callparm = $argsneedcast{$fullparm};
		$callparm =~ s/ARG/$argval/;
		print $OUTFD "$callparm";
	    }
	    else {
		# Since MPICH objects are ints, we don't need to do 
		# anything unless MPI_Fint and int are different.
# print STDERR "XXX $count $#arg_addresses XXX\n";
		if ($arg_addresses[$count] > 0) {
		    print $OUTFD "*";
		}
		print $OUTFD "v$count";
	    }
	}
	$count++;
    }
    print $OUTFD " );\n";
}

# Print the option function attribute; this supports GCC, particularly 
# the __atribute__ ((weak)) option.  Unfortunately, the name must be
# made into a string and inserted into the attribute list.
sub print_attr {
    my $OUTFD = $_[0];
    my $name  = $_[1];
    if ($do_weak) {
	print $OUTFD " FUNC_ATTRIBUTES($name)";