void FATR PBEGINF_()
/*
Hewlett Packard Risc box, SparcWorks F77 2.* and Paragon compilers.
Have to construct the argument list by calling FORTRAN.
*/
{
extern char *strdup();
#if defined(WIN32)
int argc = iargc_() + 1;
#elif defined(HPUX)
int argc = hpargc_();
#else
int argc = iargc_() + 1;
#endif
int i, len, maxlen=LEN;
char *argv[LEN], arg[LEN];
for (i=0; i<argc; i++) {
# if defined(HPUX)
len = hpargv_(&i, arg, &maxlen);
# elif defined(WIN32)
short n=(short)i, status;
getarg_(&n, arg, maxlen, &status);
if(status == -1)Error("getarg failed for argument",i);
len = status;
# else
getarg_(&i, arg, maxlen);
for(len = maxlen-2; len && (arg[len] == ' '); len--);
len++;
# endif
arg[len] = '\0'; /* insert string terminator */
/* printf("%10s, len=%d\n", arg, len); fflush(stdout); */
argv[i] = strdup(arg);
}
PBEGIN_(argc, argv);
}
/* ---------------------------- *\
FORTRAN Wrapper for DDI_Init
\* ---------------------------- */
void F77_Init() {
int i,j,lenmax=256,argc=iargc_();
char **argv = NULL;
char arg[256];
STD_DEBUG((stdout," DDI: Entering F77 DDI_Init.\n"))
/* -------------------------- *\
Get command line arguments
\* -------------------------- */
if(argc) {
argc++;
argv = Malloc(argc*sizeof(char*));
for(i=0; i<argc; i++) {
for(j=0; j<256; j++) arg[j]=' ';
# if defined CRAY
getarg_(&i,arg,&lenmax);
# else
getarg_(&i,arg,lenmax);
# endif
for(j=0; j<256 && arg[j] != ' '; j++);
arg[j] = 0;
argv[i] = (char *) strdup(arg);
}
}
MAX_DEBUG((stdout," DDI: Calling DDI_Init.\n"))
/* -------------- *\
Initialize DDI
\* -------------- */
DDI_Init(argc,argv);
}
PetscErrorCode PETScParseFortranArgs_Private(int *argc,char ***argv)
{
#if defined(PETSC_USE_NARGS)
short i,flg;
#else
int i;
#endif
PetscErrorCode ierr;
int warg = 256;
PetscMPIInt rank;
char *p;
ierr = MPI_Comm_rank(PETSC_COMM_WORLD,&rank);CHKERRQ(ierr);
if (!rank) {
#if defined(PETSC_HAVE_IARG_COUNT_PROGNAME)
*argc = iargc_();
#else
/* most compilers do not count the program name for argv[0] */
*argc = 1 + iargc_();
#endif
}
ierr = MPI_Bcast(argc,1,MPI_INT,0,PETSC_COMM_WORLD);CHKERRQ(ierr);
/* PetscTrMalloc() not yet set, so don't use PetscMalloc() */
ierr = PetscMallocAlign((*argc+1)*(warg*sizeof(char)+sizeof(char*)),0,0,0,(void**)argv);CHKERRQ(ierr);
(*argv)[0] = (char*)(*argv + *argc + 1);
if (!rank) {
ierr = PetscMemzero((*argv)[0],(*argc)*warg*sizeof(char));CHKERRQ(ierr);
for (i=0; i<*argc; i++) {
(*argv)[i+1] = (*argv)[i] + warg;
#if defined (PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT) /* same as 'else' case */
getarg_(&i,(*argv)[i],warg);
#elif defined(PETSC_HAVE_PXFGETARG_NEW)
{char *tmp = (*argv)[i];
int ilen;
getarg_(&i,tmp,&ilen,&ierr,warg);CHKERRQ(ierr);
tmp[ilen] = 0;}
#elif defined(PETSC_USE_NARGS)
GETARG(&i,(*argv)[i],warg,&flg);
#else
/*
Because the stupid #defines above define all kinds of things to getarg_ we cannot do this test
#elif defined(PETSC_HAVE_GETARG)
getarg_(&i,(*argv)[i],warg);
#else
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"Cannot get Fortran command line arguments");
*/
getarg_(&i,(*argv)[i],warg);
#endif
/* zero out garbage at end of each argument */
p = (*argv)[i] + warg-1;
while (p > (*argv)[i]) {
if (*p == ' ') *p = 0;
p--;
}
}
}
ierr = MPI_Bcast((*argv)[0],*argc*warg,MPI_CHAR,0,PETSC_COMM_WORLD);CHKERRQ(ierr);
if (rank) {
for (i=0; i<*argc; i++) (*argv)[i+1] = (*argv)[i] + warg;
}
return 0;
}
/* Main program */ int MAIN__(void)
{
/* System generated locals */
integer i__1, i__2;
olist o__1;
cllist cl__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), f_open(olist *), s_rsle(cilist *), e_rsle(void),
f_clos(cllist *), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static real a[1000000] /* was [1000][1000] */, b[1000];
static integer i__, j, k, n;
static real p[1000];
static char orientacao[6];
static real num;
static integer argc;
extern /* Subroutine */ int exit_(void);
static char nome_arquivo__[20];
extern integer iargc_(void), lucol_(integer *, integer *, real *, real *),
sscol_(integer *, integer *, real *, real *, real *), lurow_(
integer *, integer *, real *, real *), ssrow_(integer *, integer *
, real *, real *, real *);
extern /* Subroutine */ int getarg_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___4 = { 0, 6, 0, 0, 0 };
static cilist io___5 = { 0, 1, 0, 0, 0 };
static cilist io___8 = { 0, 1, 0, 0, 0 };
static cilist io___13 = { 0, 1, 0, 0, 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, 0, 0 };
static cilist io___19 = { 0, 6, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, 0, 0 };
/* Matriz LU */
argc = iargc_();
if (argc > 1) {
getarg_(&c__1, nome_arquivo__, (ftnlen)20);
getarg_(&c__2, orientacao, (ftnlen)6);
} else {
s_wsle(&io___4);
do_lio(&c__9, &c__1, "Digite o nome do arquivo e se e orientada a li"
"nha ou coluna. (Ex: m1.dat linha)", (ftnlen)79);
e_wsle();
exit_();
}
o__1.oerr = 0;
o__1.ounit = 1;
o__1.ofnmlen = 20;
o__1.ofnm = nome_arquivo__;
o__1.orl = 0;
o__1.osta = "old";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
s_rsle(&io___5);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
/* Computing 2nd power */
i__2 = n;
i__1 = i__2 * i__2;
for (k = 1; k <= i__1; ++k) {
s_rsle(&io___8);
do_lio(&c__3, &c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&j, (ftnlen)sizeof(integer));
do_lio(&c__4, &c__1, (char *)&num, (ftnlen)sizeof(real));
e_rsle();
a[i__ + 1 + (j + 1) * 1000 - 1001] = num;
}
i__1 = n;
for (k = 1; k <= i__1; ++k) {
s_rsle(&io___13);
do_lio(&c__3, &c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_lio(&c__4, &c__1, (char *)&num, (ftnlen)sizeof(real));
e_rsle();
b[i__] = num;
}
cl__1.cerr = 0;
cl__1.cunit = 1;
cl__1.csta = 0;
f_clos(&cl__1);
/* ====================================================== */
/* OPERACAO POR LINHA */
if (s_cmp(orientacao, "linha", (ftnlen)6, (ftnlen)5) == 0 && lurow_(&n, &
c__1000, a, p) == -1) {
s_wsle(&io___16);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
if (s_cmp(orientacao, "linha", (ftnlen)6, (ftnlen)5) == 0 && ssrow_(&n, &
c__1000, a, p, b) == -1) {
s_wsle(&io___17);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
/* ====================================================== */
/* OPERACAO POR COLUNA */
if (s_cmp(orientacao, "coluna", (ftnlen)6, (ftnlen)6) == 0 && lucol_(&n, &
c__1000, a, p) == -1) {
s_wsle(&io___18);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
if (s_cmp(orientacao, "coluna", (ftnlen)6, (ftnlen)6) == 0 && sscol_(&n, &
c__1000, a, p, b) == -1) {
s_wsle(&io___19);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
/* ====================================================== */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
s_wsle(&io___20);
do_lio(&c__4, &c__1, (char *)&b[i__ - 1], (ftnlen)sizeof(real));
e_wsle();
}
return 0;
} /* MAIN__ */
void mpi_init_(int *ierr)
{
/* some code in here is taken from MPICH-1 */
int argc;
char **argv;
#if 0
int i, argsize = 1024;
char *p;
/* int argcSave; Save the argument count */
char **argvSave; /* Save the pointer to the argument vector */
#endif
DBGEARLYINIT();
DBGPRINT3("Entering Old Fortran MPI_Init at base level");
if (init_was_fortran==0)
{
*ierr=MPI_SUCCESS;
return;
}
init_was_fortran=1;
#if 0
/* argcSave = */ argc = iargc_() + 1;
argvSave = argv = (char **) malloc( argc * sizeof(char *) );
if (!argv)
{
WARNPRINT("Can't allocate memory for argv table - exiting");
exit(1);
}
for (i=0; i<argc; i++)
{
argvSave[i] = argv[i] = (char *)malloc( argsize + 1 );
if (!argv[i])
{
WARNPRINT("Can't allocate memory for argv[%i] - exiting",i);
exit(1);
}
getarg_( &i, argv[i], argsize );
/* Trim trailing blanks */
p = argv[i] + argsize - 1;
while (p > argv[i])
{
if (*p != ' ')
{
p[1] = '\0';
break;
}
p--;
}
}
#ifdef DBGLEVEL
DBGPRINT4("ARGUMENT COUNT IS %i\n",argc);
for (i=0; i<argc; i++)
{
DBGPRINT4("ARGUMENT %i IS %s",i,argv[i]);
}
#endif /* DBGLEVEL */
*ierr=PNMPI_Common_MPI_Init(&argc,&argv);
#endif
argc=0;
argv=NULL;
*ierr=PNMPI_Common_MPI_Init(&argc,&argv);
return;
}
