buildiface

fortran并行计算包

sub status_array_in_arg {
    my $count = $_[0];
    print $OUTFD "(MPI_Status *)v$count";
}
# --------------------------------------------------------------------------
# aintToint
sub aintToInt_ctof {
    my $coutvar = $_[0];
    my $outvar  = $_[1];
    print $OUTFD "    *$outvar = (MPI_Fint)($coutvar);\n";
}
sub aintToInt_out_decl {
    my $count = $_[0];
    print $OUTFD "    MPI_Aint l$count;\n";
}
sub aintToInt_out_arg {
    my $count = $_[0];
    print $OUTFD "\&l$count";
}
# --------------------------------------------------------------------------
# aintToVal - Convert address of Aint to value
sub aintToVal_ftoc {
    my $coutvar = $_[0];
    my $outvar  = $_[1];
}
sub aintToVal_in_decl {
    my $count = $_[0];
}
sub aintToVal_in_arg {
    my $count = $_[0];
    print $OUTFD "*v$count";
}
# ---------------------------------------------------------------------------
# This is the routine that handles the post-call processing
sub print_post_call {
    my $routine_name = $_[0];
    my $args = $_[1];
    if (defined($special_args{$routine_name})) { 
	# Erg.  Special processing
	foreach $count (split(/:/,$special_args{$routine_name})) {
	    $rule = $special_args{"${routine_name}-$count"};
	    ($direction,$method,$Array_size) = split(/:/,$rule);
	    print STDERR "$routine_name: dir = $direction, method = $method\n" if $debug;
	    $processing_in_routine = "${method}_in_ctof";
	    if ($direction eq "out" || $direction eq "inout") {
		$processing_routine = "${method}_ctof";
		&$processing_routine( "l$count", "v$count" );
	    }
	    elsif (defined(&$processing_in_routine)) {
		# Invoke even for "in" args incase we need to free a temp
		&$processing_in_routine( "l$count", "v$count" );
	    }
	    if ($clean_up ne "") {
		print $OUTFD $clean_up;
		$clean_up = "";
	    }
	}
    }
    
    # Handle here any special post-only calls
    if (defined($specialPost{$routine_name})) {
	my $argnum = $specialPost{$routine_name};
	my $postRoutine = $specialPost{"$routine_name-$argnum"};
	&$postRoutine( $OUTFD, $argnum );
    }
}
#
# ---------------------------------------------------------------------------
#
# Blankpad strings
# This is complicated by the fact that the Fortran strings do not contain
# null terminators and the MPI definitions of string lengths, such as
# MPI_MAX_PORT_NAME, are one smaller in Fortran than in C (see 4.12.9
# in the MPI-2 specification).  Because of this, we need to allocate a 
# temporary that is one longer on 
sub blankpad_out_decl {
    my $count = $_[0];
    print $OUTFD "    char *p$count;\n";
}
sub blankpad_out_arg {
    my $count = $_[0];
    print $OUTFD "p$count";
}
sub blankpad_out_ftoc {
    my $count = $_[0];

    # Allocate space to hold the C version of the output
    $strlen = "d$count";
    print $OUTFD "    p$count = (char *)$malloc( $strlen + 1 );\n";
}
sub blankpad_ctof {
    my $coutvar = $_[0];
    my $outvar  = $_[1];
    
    # find the null character.  Replace with blanks from there to the
    # end of the string.  The declared lenght is given by a variable
    # whose name is derived from outvar
    $strlen = $outvar;
    $strlen =~ s/^v/d/;
    my $cvar = $outvar; 
    $cvar =~ s/^v/p/;
    print $OUTFD "\
    {char *p = $outvar, *pc=$cvar;
        while (*pc) {*p++ = *pc++;}
        while ((p-$outvar) < $strlen) { *p++ = ' '; }
    }
";
    $clean_up .= "    $free( $cvar );\n";
}
#
# Blankpad strings if a flag is true (for info_get, perhaps others?)
# This is complicated by the fact that the Fortran strings do not contain
# null terminators and the MPI definitions of string lengths, such as
# MPI_MAX_PORT_NAME, are one smaller in Fortran than in C (see 4.12.9
# in the MPI-2 specification).  Because of this, we need to allocate a 
# temporary that is one longer on 
sub blankpadonflag_out_decl {
    my $count = $_[0];
    print $OUTFD "    char *p$count;\n";
}
sub blankpadonflag_out_arg {
    my $count = $_[0];
    print $OUTFD "p$count";
}
sub blankpadonflag_out_ftoc {
    my $count = $_[0];

    # Allocate space to hold the C version of the output
    $strlen = "d$count";
    print $OUTFD "    p$count = (char *)$malloc( $strlen + 1 );\n";
}
sub blankpadonflag_ctof {
    my $coutvar = $_[0];
    my $outvar  = $_[1];
    
    # find the null character.  Replace with blanks from there to the
    # end of the string.  The declared lenght is given by a variable
    # whose name is derived from outvar
    $strlen = $outvar;
    $strlen =~ s/^v/d/;
    my $cvar = $outvar; 
    $cvar =~ s/^v/p/;
    print $OUTFD "\
    if ($Array_size) {char *p = $outvar, *pc=$cvar;
        while (*pc) {*p++ = *pc++;}
        while ((p-$outvar) < $strlen) { *p++ = ' '; }
    }
";
    $clean_up .= "    $free( $cvar );\n";
}

# ---------------------------------------------------------------------------
# Add null to input strings
# We must make a copy 
sub addnull_in_decl {
    my $count = $_[0];
    print $OUTFD "    char *p$count;\n";
}
sub addnull_in_arg {
    my $count = $_[0];
    print $OUTFD "p$count";
}
sub addnull_ftoc {
    my $count = $_[0];
    
    # Working backwards from the length argument, find the first 
    # nonblank character
    # end of the string.  The declared length is given by a variable
    # whose name is derived from outvar
    $strlen = "v$count";
    $strlen =~ s/^v/d/;
    print $OUTFD "\
    {char *p = v$count + $strlen - 1;
     int  li;
        while (*p == ' ' && p > v$count) p--;
        p++;
        p$count = (char *)$malloc( p-v$count + 1 );
        for (li=0; li<(p-v$count); li++) { p$count\[li\] = v$count\[li\]; }
        p$count\[li\] = 0; 
    }
";
    $clean_up .= "    $free( p$count );\n";
}
# ----------------------------------------------------------------------------
# Add null to input strings, also trim all LEADING and trailing blanks.
# This is required by Info_set (but not explicitly for the other
# routines).
# We must make a copy 
sub addnullandtrim_in_decl {
    my $count = $_[0];
    print $OUTFD "    char *p$count;\n";
}
sub addnullandtrim_in_arg {
    my $count = $_[0];
    print $OUTFD "p$count";
}
sub addnullandtrim_ftoc {
    my $count = $_[0];
    
    # Working backwards from the length argument, find the first 
    # nonblank character
    # end of the string.  The declared length is given by a variable
    # whose name is derived from outvar
    $strlen = "v$count";
    $strlen =~ s/^v/d/;
    print $OUTFD "\
    {char *p = v$count + $strlen - 1;
     char *pin = v$count;
     int  li;
        while (*p == ' ' && p > v$count) p--;
        p++;
        while (*pin == ' ' && pin < p) pin++;
        p$count = (char *)$malloc( p-pin + 1 );
        for (li=0; li<(p-pin); li++) { p$count\[li\] = pin\[li\]; }
        p$count\[li\] = 0; 
    }
";
    $clean_up .= "    $free( p$count );\n";
}

# ----------------------------------------------------------------------------
# Add null to arrays of input strings
# We must make a copy 
# chararray is used ONLY in comm_spawn
sub chararray_in_decl {
    my $count = $_[0];
    print $OUTFD "    char **p$count;\n";
    if (!$Array_size) { print $OUTFD "    char *pcpy$count;\n"; }
    # pcpy<digit> is used for the case where the array length is not known
    print $OUTFD "    int  asize$count=0;\n";
}
sub chararray_in_arg {
    my $count = $_[0];
    print $OUTFD "p$count";
}
sub chararray_ftoc {
    my $count = $_[0];

    # There is a special case - the input is MPI_ARGV_NULL.  We
    # detect this by checking for a null string (all blanks).
    # The initialization of MPI_ARGV_NULL is done in the special
    #init setup
    &specialInitStatement( $OUTFD );
    # First, compute the number of elements.  In Fortran, a null
    # string terminates the array.  The array is stored as 
    # a two-dimensional field of fixed-length characters.
    # Then copy the strings into the new storage, appending the
    # null at the end
    print $OUTFD "\
    { int i;
      char *ptmp;\n";
    if ($Array_size) {
	print $OUTFD "\
      asize$count = $Array_size + 1;\n";
    }
    else {
	print $OUTFD "\
      /* Compute the size of the array by looking for an all-blank line */
      pcpy$count = v$count;
      for (asize$count=1; 1; asize$count++) {
          char *pt = pcpy$count + d$count - 1;
          while (*pt == ' ' && pt > pcpy$count) pt--;
          if (*pt == ' ') break;
          pcpy$count += d$count;
      }\n";
    }
    print $OUTFD "\
      p$count = (char **)$malloc( asize$count * sizeof(char *) );
      ptmp    = (char *)$malloc( asize$count * (d$count + 1) );
      for (i=0; i<asize$count-1; i++) {
          char *p = v$count + i * d$count, *pin, *pdest;
          int j;

          pdest = ptmp + i * (d$count + 1);
          p$count\[i\] = pdest;
          /* Move to the end and work back */
          pin = p + d$count - 1;
          while (*pin == ' ' && pin > p) pin--;
          /* Copy and then null terminate */
          for (j=0; j<(pin-p)+1; j++) { pdest\[j\] = p\[j\]; }
          pdest\[j\] = 0;
          }
    /* Null terminate the array */
    p$count\[asize$count-1\] = 0;
    }\n";
    $clean_up .= "    $free( p$count\[0\] ); $free( p$count );\n";
}

# Add null to 2-dimensional arrays of input strings.  Used only 
# by comm_spawn_multiple
# FIXME : THIS CODE IS NOT CORRECT YET
# Note the special handling of MPI_ARGVS_NULL
sub chararray2_in_decl {
    my $count = $_[0];
    print $OUTFD "    char ***p$count=0;\n";
}
sub chararray2_in_arg {
    my $count = $_[0];
    print $OUTFD "p$count";
}
sub chararray2_ftoc {
    my $count = $_[0];

    if ($Array_size eq "") {
	print STDERR "A leading array size is required for 2-d Character arrays\n";
	return 1;
    }

    # First, compute the number of elements.  In Fortran, a null
    # string terminates the array.  The array is stored as 
    # a two-dimensional field of fixed-length characters.
    # Then copy the strings into the new storage, appending the
    # null at the end
    # Since this is a 2-d array, we always know the first dimension,
    # the second dimension must be computed, this is asize$count.
    # The first dimension is Array_size.
    &specialInitStatement( $OUTFD );
    print $OUTFD "\
    /* Check for the special case of a the null args case. */
    if (v$count == MPI_F_ARGVS_NULL) { v$count = (char *)MPI_ARGVS_NULL; } 
    else { 
        /* We must convert from the 2-dimensional Fortran array of
           fixed length strings to a C variable-sized array (really an
           array of pointers for each command of pointers to each 
           argument, which is null terminated.*/\n";

    # We must be careful.  A blank line is ALL blank, not just leading blank
    # We must also be careful allocating the array, as C and Fortran 
    # arrays are not the same.  In C, for a two dimensional array
    # sized at run time, we must
    # allocate an array of pointers to arrays.
    #    p = (char ***) malloc( nrows * sizeof(char **) )
    # where we are letting using p[nrows][colindex].  
    # For MPI_Comm_spawn_multiple, each of these rows is for one command.
    # Each p[k] is a pointer to an array of character strings.  
    # For MPI_Comm_spawn_multiple, all we know is that in the 
    # corresponding Fortran code, the two-dimensional character array
    # contains an all-blank entry as the terminating element; the
    # corresponding C array must have a null entry (pointer) in
    # the corresponding position.  
    # Thus, the C code must make several allocations:
    #    p = nrows * sizeof(char **)
    # for p[k], (ncols + 1) * sizeof(char *)
    # for p[k][i], space for the ith input argument.
    # To reduce the number of allocations, we allocate space for all
    # elements on a row at one time.

    # Purely local variables don't need $count
    print $OUTFD "\
      int k;

      /* Allocate the array of pointers for the commands */
      p$count = (char ***)$malloc( $Array_size * sizeof(char **) );

      for (k=0; k<$Array_size; k++) {
        /* For each command, find the number of command-line arguments.
           They are terminated by an empty entry. */
        /* Find the first entry in the Fortran array for this row */
        char *p = v$count + k * d$count;
        int arglen = 0, argcnt=0, i;
        char **pargs, *pdata;
        for (argcnt=0; 1; argcnt ++) {
            char *pin = p + d$count - 1; /* Move to the end of the
                                            current Fortran string */
            while (*pin == ' ' && pin > p) pin--; /* Move backwards until
                                                    we find a non-blank
                                                    (Fortran is blank padded)*/
            if (pin == p && *pin == ' ') {
                /* found the terminating empty arg */
                break;
            }
            /* Keep track of the amount of space needed */
            arglen += (pin - p) + 2;   /* add 1 for the null */
            /* Advance to the next entry in the array */
            p += ($Array_size) * d$count;
        }

        /* argcnt is the number of provided arguments.  
           Allocate the necessary elements and copy, null terminating copies */
        pargs = (char **)$malloc( (argcnt+1)*sizeof(char *) );
        pdata = (char *)$malloc( arglen );
        p$count\[k\] = pargs;
        pargs\[argcnt\] = 0;