Ejemplo n.º 1
0
Archivo: lgm_domain.c Proyecto: rolk/ug
LGM_PROBLEM* NS_DIM_PREFIX CreateProblem (const char *name, InitProcPtr init, DomainSizeConfig domconfig, BndCondProcPtr BndCond, int numOfCoefficients, CoeffProcPtr coeffs[], int numOfUserFct, UserProcPtr userfct[])
{
  LGM_PROBLEM *newProblem;
  int i;

  if (ChangeEnvDir("/LGM_PROBLEM")==NULL) return(NULL);

  /* allocate new problem structure */
  newProblem = (LGM_PROBLEM *) MakeEnvItem (name,theProblemVarID,sizeof(LGM_PROBLEM)+(numOfCoefficients+numOfUserFct-1)*sizeof(void*));
  if (newProblem==NULL) return(NULL);

  /* fill in data */
  LGM_PROBLEM_INIT(newProblem)            = init;
  LGM_PROBLEM_CONFIG(newProblem)          = NULL;
  LGM_PROBLEM_DOMCONFIG(newProblem)       = domconfig;
  LGM_PROBLEM_BNDCOND(newProblem)         = BndCond;
  LGM_PROBLEM_INNERBNDCOND(newProblem)= NULL;
  LGM_PROBLEM_NCOEFF(newProblem)          = numOfCoefficients;
  LGM_PROBLEM_NUSERF(newProblem)          = numOfUserFct;
  for (i=0; i<numOfCoefficients; i++) LGM_PROBLEM_SETCOEFF(newProblem,i,coeffs[i]);
  for (i=0; i<numOfUserFct; i++) LGM_PROBLEM_SETUSERF(newProblem,i,userfct[i]);

  UserWrite("lgm_problem "); UserWrite(name); UserWrite(" installed\n");

  return (newProblem);
}
Ejemplo n.º 2
0
Archivo: nliter.c Proyecto: rolk/ug
INT NS_DIM_PREFIX NPNLIterDisplay (NP_NL_ITER *np)
{
  if ((np->A == NULL) && (np->x == NULL) && (np->b == NULL))
    return(0);
  UserWrite("symbolic user data:\n");
  if (np->A != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"A",ENVITEM_NAME(np->A));
  if (np->x != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"x",ENVITEM_NAME(np->x));
  if (np->b != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"r",ENVITEM_NAME(np->b));
  UserWrite("\n");

  return(0);
}
Ejemplo n.º 3
0
Archivo: ts.c Proyecto: rolk/ug
INT NS_DIM_PREFIX NPTSolverInit (NP_T_SOLVER *np, INT argc , char **argv)
{
  INT r;

  r = NP_EXECUTABLE;       /* highest state */

  /* The solution is required for execution */
  np->y = ReadArgvVecDesc(np->nlass.base.mg,"y",argc,argv);
  if (np->y == NULL)
  {
    r = NP_NOT_ACTIVE;
    UserWrite("Warning: solution y is required for execution !\n");
  }

  /* assemble numproc is required for execution */
  np->tass = (NP_T_ASSEMBLE *)
             ReadArgvNumProc(np->nlass.base.mg,"A",T_ASSEMBLE_CLASS_NAME,argc,argv);
  if (np->tass == NULL) r = NP_NOT_ACTIVE;

  /* solver numproc is required for execution */
  np->nlsolve = (NP_NL_SOLVER *)
                ReadArgvNumProc(np->nlass.base.mg,"S",NL_SOLVER_CLASS_NAME,argc,argv);
  if (np->nlsolve == NULL) r = NP_NOT_ACTIVE;

  return(r);
}
Ejemplo n.º 4
0
Archivo: newton.c Proyecto: rolk/ug
static INT NonLinearDefect (MULTIGRID *mg, INT level, INT init, VECDATA_DESC *x, NP_NEWTON *newton, NP_NL_ASSEMBLE *ass, VEC_SCALAR defect, INT *error)
{
  LRESULT lr;                           /* result of linear solver				*/
  INT i,n_unk;

  n_unk = VD_NCOMP(x);

  /* project solution to all grid levels */
  if (newton->trans->PreProcessProject!=NULL)
    if ((*newton->trans->PreProcessProject)(newton->trans,0,level,error)) { *error = __LINE__; REP_ERR_RETURN(*error); }
  if ((*newton->trans->ProjectSolution)(newton->trans,0,level,x,error)) { *error = __LINE__; REP_ERR_RETURN(*error); }
  if (newton->trans->PostProcessProject!=NULL)
    if ((*newton->trans->PostProcessProject)(newton->trans,0,level,error)) { *error = __LINE__; REP_ERR_RETURN(*error); }

  if (init)
  {
    /* preprocess assemble once before all calls */
    if (ass->PreProcess!=NULL)
      if ((*ass->PreProcess)(ass,0,level,x,error)) { *error = __LINE__; REP_ERR_RETURN(*error); }

    /* set dirichlet conditions on all grid levels */
    if ((*ass->NLAssembleSolution)(ass,0,level,x,error)) { *error = __LINE__; REP_ERR_RETURN(*error); }
  }

  /* compute new nonlinear defect */
  CSTART();
  dset(mg,0,level,ALL_VECTORS,newton->d,0.0);
  *error = 0;
  if ((*ass->NLAssembleDefect)(ass,0,level,x,newton->d,newton->J,error)) { *error = __LINE__; REP_ERR_RETURN(*error); }
  if (*error) return(0);
  CSTOP(defect_t,defect_c);

  if (newton->lineSearch == 3)
    dcopy(mg,0,level,ALL_VECTORS,newton->dsave,newton->d);
  if (UG_math_error) { UserWrite("math error in NLAssembleDefect\n"); UG_math_error = 0; *error = __LINE__; REP_ERR_RETURN(*error); }

  IFDEBUG(np,3)
  UserWrite("---- After computation of nonlinear defect\n");
  ListVectorRange(mg,0,level,0,0,1000,FALSE,TRUE,~(INT)1,LV_MOD_DEFAULT);
  ENDDEBUG

  /* compute norm of defect */
  if ((*newton->solve->Residuum)(newton->solve,0,level,newton->v,newton->d,newton->J,&lr)) { *error = __LINE__; REP_ERR_RETURN(*error); }
  for (i=0; i<n_unk; i++) defect[i] = lr.last_defect[i];

  return (0);
}
Ejemplo n.º 5
0
Archivo: ewn.c Proyecto: rolk/ug
static INT EWDisplay (NP_BASE *theNP)
{
  INT i;
  NP_EW_SOLVER *npew;
  NP_EWN *np;

  np = (NP_EWN *) theNP;
  npew = (NP_EW_SOLVER *) theNP;

  if (npew->nev > 0) UserWrite("symbolic user data:\n");
  for (i=0; i<npew->nev; i++)
    if (i<10) UserWriteF("ev[%d]            = %-35.32s\n", i,ENVITEM_NAME(npew->ev[i]));
    else UserWriteF("ev[%d]           = %-35.32s\n", i,ENVITEM_NAME(npew->ev[i]));
  UserWrite("\n");
  UserWrite("configuration parameters:\n");
  if (sc_disp(npew->reduction,npew->ev[0],"red")) return (1);
  if (sc_disp(npew->abslimit,npew->ev[0],"abslimit")) return (1);

  UserWriteF(DISPLAY_NP_FORMAT_SI,"m",(int)np->maxiter);
  if (np->LS != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"L",ENVITEM_NAME(np->LS));
  else
    UserWriteF(DISPLAY_NP_FORMAT_SS,"L","---");
  if (np->Transfer != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"T",ENVITEM_NAME(np->Transfer));
  else
    UserWriteF(DISPLAY_NP_FORMAT_SS,"T","---");
  if (np->display == PCR_NO_DISPLAY)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"DispMode","NO_DISPLAY");
  else if (np->display == PCR_RED_DISPLAY)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"DispMode","RED_DISPLAY");
  else if (np->display == PCR_FULL_DISPLAY)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"DispMode","FULL_DISPLAY");
  if (np->r != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"r",ENVITEM_NAME(np->r));
  if (np->t != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"t",ENVITEM_NAME(np->t));
  if (np->M != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"M",ENVITEM_NAME(np->M));

  return(0);
}
Ejemplo n.º 6
0
Archivo: ts.c Proyecto: rolk/ug
INT NS_DIM_PREFIX NPTSolverDisplay (NP_T_SOLVER *np)
{
  UserWrite("symbolic user data:\n");
  if (np->y != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"y",ENVITEM_NAME(np->y));
  UserWrite("\n");

  UserWrite("configuration parameters:\n");
  if (np->y != NULL)
  {
    if (sc_disp(np->reduction,np->y,"reduction")) return (1);
    if (sc_disp(np->abslimit,np->y,"abslimit")) return (1);
  }
  if (np->tass != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"tass",ENVITEM_NAME(np->tass));
  if (np->nlsolve != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"nlsolve",ENVITEM_NAME(np->nlsolve));

  return(0);
}
Ejemplo n.º 7
0
Archivo: reinit.c Proyecto: rolk/ug
INT NS_DIM_PREFIX REINIT_Display (NP_BASE *base)
{
  NP_REINIT *reinit;
  INT i;

  reinit=(NP_REINIT*)base;
  UserWrite("\nreinit configuration:\n");
  for (i=0; i<reinit->n; i++)
    UserWriteF(DISPLAY_NP_FORMAT_SF,reinit->name[i],(float)reinit->parameter[i]);

  return (0);
}
Ejemplo n.º 8
0
Archivo: nliter.c Proyecto: rolk/ug
static INT NLSmoother (NP_NL_ITER *theNP, INT level,
                       VECDATA_DESC *x, VECDATA_DESC *b,MATDATA_DESC *A,
                       NP_NL_ASSEMBLE *ass, INT *result)
{
  NP_NL_SMOOTHER *np;
  GRID *theGrid;

  /* store passed XXXDATA_DESCs */
  NPINL_A(theNP) = A;
  NPINL_x(theNP) = x;
  NPINL_b(theNP) = b;

  np = (NP_NL_SMOOTHER *) theNP;
  theGrid = NP_GRID(theNP,level);
  /* check function pointers in numprocs */
  if (ass->NLAssembleMatrix==NULL)
  {
    UserWrite("NLGS: ass->NLAssembleMatrix not defined\n");
    REP_ERR_RETURN (1);
  }
  if (ass->NLNAssembleMatrix==NULL)
  {
    UserWrite("NLGS: ass->NLNAssembleMatrix not defined\n");
    REP_ERR_RETURN (1);
  }

  np->iter.Assemble = ass;

  if ((*np->Step)(np,level,x,b,np->c,A,np->L,result))
    REP_ERR_RETURN (1);
    #ifdef ModelP
  if (l_vector_consistent(theGrid,x) != NUM_OK) NP_RETURN(1,result[0]);
    #endif
  if (dscalx(NP_MG(theNP),level,level,ALL_VECTORS,x,np->damp) != NUM_OK)
    NP_RETURN(1,result[0]);
  if (dmatmul_minus(NP_MG(theNP),level,level,ALL_VECTORS,b,A,x)!= NUM_OK)
    NP_RETURN(1,result[0]);

  return (0);
}
Ejemplo n.º 9
0
Archivo: amg_ug.c Proyecto: rolk/ug
static INT AMGSolverDisplay (NP_BASE *theNP)
{
  NP_AMG *theAMGC;

  theAMGC = (NP_AMG *)theNP;

  /* display symbols */
  NPLinearSolverDisplay(&theAMGC->ls);

  /* display configuration parameters */
  UserWrite("configuration parameters:\n");

  return (0);
}
Ejemplo n.º 10
0
void FAMGWrite(ostrstream &OutputString)
{
#ifdef UG_DRAW
	ostrstream ostr(testf,FAMG_IOBUFFFER_LEN);
	
	assert(OutputString.pcount()<FAMG_IOBUFFFER_LEN);
	ostr << OutputString.rdbuf() << '\0';
	UserWrite( ostr.str() );
#else	
	#ifdef ModelP
		cout << me << ": ";
	#endif
	cout << OutputString.rdbuf() << flush;
#endif
}
Ejemplo n.º 11
0
Archivo: newton.c Proyecto: rolk/ug
static INT NewtonPreProcess  (NP_NL_SOLVER *solve, INT level, VECDATA_DESC *x, INT *result)
{
  NP_NEWTON *newton;

  newton = (NP_NEWTON *) solve;
  if (AllocMDFromVD(solve->base.mg,0,level,x,x,&newton->J))
    NP_RETURN(1,result[0]);

  /* check function pointers in numprocs */
  if (newton->trans->base.status < NP_ACTIVE)
  {
    UserWrite("Newton: newton->trans not active\n");
    NP_RETURN(1,result[0]);
  }
  if (newton->trans->ProjectSolution==NULL)
  {
    UserWrite("Newton: newton->trans->ProjectSolution not defined\n");
    NP_RETURN(1,result[0]);
  }
  if (newton->solve->base.status < NP_ACTIVE)
  {
    UserWrite("Newton: newton->solve not active\n");
    NP_RETURN(1,result[0]);
  }
  if (newton->solve->Solver==NULL)
  {
    UserWrite("Newton: newton->solve->Solver not defined\n");
    NP_RETURN(1,result[0]);
  }
  if (newton->solve->Residuum==NULL)
  {
    UserWrite("Newton: newton->solve->Residuum not defined\n");
    NP_RETURN(1,result[0]);
  }
  return(0);
}
Ejemplo n.º 12
0
Archivo: nliter.c Proyecto: rolk/ug
static INT NLSmootherDisplay (NP_NL_SMOOTHER *theNP)
{
  NPNLIterDisplay(&theNP->iter);
  UserWrite("configuration parameters:\n");
  if (sc_disp(theNP->damp,theNP->iter.b,"damp")) REP_ERR_RETURN (1);
  if (theNP->c != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"c",ENVITEM_NAME(theNP->c));
  if (theNP->L != NULL)
    UserWriteF(DISPLAY_NP_FORMAT_SS,"L",ENVITEM_NAME(theNP->L));
    #ifdef ModelP
  UserWriteF(DISPLAY_NP_FORMAT_SI,"cons_mode",(int)theNP->cons_mode);
        #endif

  return (0);
}
Ejemplo n.º 13
0
Archivo: ewn.c Proyecto: rolk/ug
static INT EWInit (NP_BASE *theNP, INT argc , char **argv)
{
  NP_EW_SOLVER *npew;
  NP_EWN *np;
  INT i,n;
  char *token,*names,buffer[128];

  npew = (NP_EW_SOLVER *) theNP;
  np = (NP_EWN *) theNP;

  np->reset = 1;
  np->LS = (NP_LINEAR_SOLVER *)ReadArgvNumProc(theNP->mg,"L",LINEAR_SOLVER_CLASS_NAME,argc,argv);
  if (np->LS == NULL) return(NP_NOT_ACTIVE);
  np->Transfer = (NP_TRANSFER *)ReadArgvNumProc(theNP->mg,"T",TRANSFER_CLASS_NAME,argc,argv);
  np->Project = (NP_PROJECT *)ReadArgvNumProc(theNP->mg,"P",PROJECT_CLASS_NAME,argc,argv);

  np->M = ReadArgvMatDesc(theNP->mg,"M",argc,argv);
  if (np->M==NULL) return(NP_NOT_ACTIVE);
  np->N = ReadArgvMatDesc(theNP->mg,"N",argc,argv);
  if (np->N==NULL || np->M==np->N) return(NP_NOT_ACTIVE);
  np->E = ReadArgvVecDesc(theNP->mg,"E",argc,argv);
  if (np->E==NULL) return(NP_NOT_ACTIVE);
  np->t = ReadArgvVecDesc(theNP->mg,"t",argc,argv);
  np->r = ReadArgvVecDesc(theNP->mg,"r",argc,argv);
  if (ReadArgvINT("m",&(np->maxiter),argc,argv))
    return(NP_NOT_ACTIVE);
  np->display = ReadArgvDisplay(argc,argv);
  np->baselevel = 0;

  n = 0;
  for (i=1; i<argc; i++)
    if (argv[i][0]=='e')
    {
      if (sscanf(argv[i],"e %s",buffer)!=1)
      {
        UserWrite("Missing symbol for eigenvector in init of ew\n");
        return(NP_NOT_ACTIVE);
      }
      names=argv[i];
      names++;
      while ((*names==' ')||(*names=='\t')) names++;
      token = strtok(names," ");
      npew->ev[n] = GetVecDataDescByName(npew->base.mg,token);
      if (npew->ev[n] == NULL) npew->ev[n] = CreateVecDescOfTemplate(npew->base.mg,token,NULL);
      if (npew->ev[n++] == NULL) return(NP_NOT_ACTIVE);
      token = strtok(NULL," ");
      if (token!=NULL)
        if (sscanf(token,"%d",&n) != 1)
        {
          n = 1;
          while (token!=NULL) {
            npew->ev[n] = GetVecDataDescByName(npew->base.mg,token);
            if (npew->ev[n] == NULL)
              npew->ev[n] = CreateVecDescOfTemplate(npew->base.mg,
                                                    token,NULL);
            if (npew->ev[n++] == NULL)
              return(NP_NOT_ACTIVE);
            token = strtok(NULL," ");
          }
        }
    }
  npew->nev = n;
  if (ReadArgvINT("c_n",&np->c_n,argc,argv)) np->c_n=npew->nev;
  if (np->c_n<1 || np->c_n>npew->nev) return(NP_NOT_ACTIVE);
  if (ReadArgvINT("c_d",&np->c_d,argc,argv)) np->c_d=6;
  if (np->c_d<1 || np->c_d>16) return(NP_NOT_ACTIVE);
  if (sc_read(npew->abslimit,NP_FMT(npew),npew->ev[0],"abslimit",argc,argv))
    for (i=0; i<MAX_VEC_COMP; i++)
      npew->abslimit[i] = ABS_LIMIT;
  if (sc_read(npew->reduction,NP_FMT(npew),npew->ev[0],"red",argc,argv))
    return(NP_ACTIVE);
  if (ReadArgvChar("type",buffer,argc,argv)) return(NP_ACTIVE);
  if (strcmp(buffer,"std")==0) np->type=MD_STD;
  else if (strcmp(buffer,"0")==0) np->type=MD_0;
  else if (strcmp(buffer,"id")==0) np->type=MD_ID;
  else np->type=MD_UNDEF;
  if (ReadArgvDOUBLE("scale",&np->scale,argc,argv)) np->scale=1.0;
  if (np->scale<=0.0) return(NP_ACTIVE);
  if (ReadArgvDOUBLE("smin",&np->shift_min,argc,argv)) np->shift_min=0.0;
  if (ReadArgvDOUBLE("smax",&np->shift_max,argc,argv)) np->shift_max=0.0;
  if (ReadArgvDOUBLE("imax",&np->imag_max,argc,argv)) np->imag_max=0.0;
  if (sc_read(np->weight,NP_FMT(npew),npew->ev[0],"weight",argc,argv))
    for (i=0; i<MAX_VEC_COMP; i++)
      np->weight[i]=1.0;
  if (ReadArgvChar("cmode",buffer,argc,argv)) np->conv_mode=0;
  else
  {
    if (strcmp(buffer,"val")==0) np->conv_mode=0;
    else if (strcmp(buffer,"vec")==0) np->conv_mode=1;
    else return(NP_ACTIVE);
  }
  if (ReadArgvChar("order",buffer,argc,argv)) np->order=ORDER_REAL_UP;
  else
  {
    if (strcmp(buffer,"real_up")==0) np->order=ORDER_REAL_UP;
    else if (strcmp(buffer,"real_down")==0) np->order=ORDER_REAL_DOWN;
    else if (strcmp(buffer,"abs_up")==0) np->order=ORDER_ABS_UP;
    else if (strcmp(buffer,"abs_down")==0) np->order=ORDER_ABS_DOWN;
    else return(NP_ACTIVE);
  }

  return(NP_EXECUTABLE);
}
Ejemplo n.º 14
0
Archivo: lbrcb.c Proyecto: rolk/ug
int NS_DIM_PREFIX BalanceGridRCB (MULTIGRID *theMG, int level)
{
  HEAP *theHeap = theMG->theHeap;
  GRID *theGrid = GRID_ON_LEVEL(theMG,level);       /* balance grid of level */
  LB_INFO *lbinfo;
  ELEMENT *e;
  int i, son;
  INT MarkKey;

  /* distributed grids cannot be redistributed by this function */
  if (me!=master && FIRSTELEMENT(theGrid) != NULL)
  {
    printf("Error: Redistributing distributed grids using recursive coordinate bisection is not implemented!\n");
    return (1);
  }

  if (me==master)
  {
    if (NT(theGrid) == 0)
    {
      UserWriteF("WARNING in BalanceGridRCB: no elements in grid\n");
      return (1);
    }

    Mark(theHeap,FROM_TOP,&MarkKey);
    lbinfo = (LB_INFO *)
             GetMemUsingKey(theHeap, NT(theGrid)*sizeof(LB_INFO), FROM_TOP, MarkKey);

    if (lbinfo==NULL)
    {
      Release(theHeap,FROM_TOP,MarkKey);
      UserWrite("ERROR in BalanceGridRCB: could not allocate memory from the MGHeap\n");
      return (1);
    }


    /* construct LB_INFO list */
    for (i=0, e=FIRSTELEMENT(theGrid); e!=NULL; i++, e=SUCCE(e))
    {
      lbinfo[i].elem = e;
      CenterOfMass(e, lbinfo[i].center);
    }


    /* apply coordinate bisection strategy */
    theRCB(lbinfo, NT(theGrid), 0, 0, DimX, DimY, 0);

    IFDEBUG(dddif,1)
    for (e=FIRSTELEMENT(theGrid); e!=NULL; e=SUCCE(e))
    {
      UserWriteF("elem %08x has dest=%d\n",
                 DDD_InfoGlobalId(PARHDRE(e)), PARTITION(e));
    }
    ENDDEBUG

    for (i=0, e=FIRSTELEMENT(theGrid); e!=NULL; i++, e=SUCCE(e))
    {
      InheritPartition (e);
    }

    Release(theHeap,FROM_TOP,MarkKey);
  }

  return 0;
}
Ejemplo n.º 15
0
Archivo: newton.c Proyecto: rolk/ug
static INT NewtonSolver      (NP_NL_SOLVER *nls, INT level, VECDATA_DESC *x,
                              NP_NL_ASSEMBLE *ass, VEC_SCALAR abslimit, VEC_SCALAR reduction,
                              NLRESULT *res)
{
  NP_NEWTON *newton;                                            /* object pointer						*/
  MULTIGRID *mg;                                                /* multigrid from base class			*/
  INT r;                                                                /* iteration counter			                */
  INT i,kk;                                                             /* some loop counters					*/
  char text[DISPLAY_WIDTH+4];                           /* display text in PCR					*/
  INT PrintID;                                                  /* print id for PCR						*/
  VEC_SCALAR defect, defect2reach;              /* component--wise norm					*/
  VEC_SCALAR defectmax;                                 /* max defect without codivergence		*/
  INT n_unk;                                                            /* number of components in solution		*/
  DOUBLE s,sold,sprime,s2reach,sred;            /* combined defect norm					*/
  INT reassemble=1;                                             /* adaptive computation of jacobian		*/
  VEC_SCALAR linred;                                            /* parameters for linear solver			*/
  DOUBLE red_factor[MAX_VEC_COMP];              /* convergence factor for linear iter	*/
  DOUBLE la;                                                            /* damping factor in line search		*/
  DOUBLE rho[MAX_LINE_SEARCH+1];                /* reduction factors of linesearch		*/
  DOUBLE rhomin;                                                /* best reduction if !accept			*/
  INT best_ls;                                                  /* best ls if !accept					*/
  INT accept;                                                           /* line search accepted					*/
  INT bl;                                                               /* baselevel returned by preprocess		*/
  INT error;                                                            /* for return value						*/
  LRESULT lr;                                                           /* result of linear solver				*/
  DOUBLE lambda_old;                    /* last accepted lamda                  */
  DOUBLE lambda_min;                    /* minimal lamda                        */
  INT use_second;

  /* get status */
  newton = (NP_NEWTON *) nls;      /* cast from abstract base class to final class*/
  mg = nls->base.mg;
  UG_math_error = 0;

  /* fill result variable with error condition */
  res->error_code = 0;
  res->converged = 0;
  res->rho_first = 0.0;
  res->number_of_nonlinear_iterations = 0;
  res->number_of_line_searches = 0;
  res->total_linear_iterations = 0;
  res->max_linear_iterations = 0;
  res->exec_time = 0.0;

  /* initialize timers and counters */
  defect_c = newton_c = linear_c = 0;
  defect_t = newton_t = linear_t = 0.0;
  if (newton->lineSearch == 3) {
    lambda_min = lambda_old = 1.0;
    for (kk=1; kk<=newton->maxLineSearch; kk++)
      lambda_min = LINE_SEARCH_REDUCTION * lambda_min;
  }
  /* check function pointers in numprocs */
  if (ass->NLAssembleSolution==NULL)
  {
    UserWrite("Newton: ass->NLAssembleSolution not defined\n");
    res->error_code = __LINE__;
    REP_ERR_RETURN(res->error_code);
  }
  if (ass->NLAssembleDefect==NULL)
  {
    UserWrite("Newton: ass->NLAssembleDefect not defined\n");
    res->error_code = __LINE__;
    REP_ERR_RETURN(res->error_code);
  }
  if (ass->NLAssembleMatrix==NULL)
  {
    UserWrite("Newton: ass->NLAssembleMatrix not defined\n");
    res->error_code = __LINE__;
    REP_ERR_RETURN(res->error_code);
  }
  /* dynamic XDATA_DESC allocation */
  if (ass->A == NULL)
    ass->A = newton->J;
  if (AllocVDFromVD(mg,0,level,x,  &(newton->v)))
  {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}
  if (AllocVDFromVD(mg,0,level,x,  &(newton->d)))
  {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}
  if (newton->lineSearch == 3) {
    if (AllocVDFromVD(mg,0,level,x,  &(newton->dold)))
    {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}
    if (AllocVDFromVD(mg,0,level,x,  &(newton->dsave)))
    {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}
  }
  /* get number of components */
  n_unk = VD_NCOMP(x);

  /* init ass once and compute nonlinear defect */
  if (NonLinearDefect(mg,level,TRUE,x,newton,ass,defect,&error)!=0)
  {
    res->error_code = __LINE__;
    REP_ERR_RETURN(res->error_code);
  }
  if (error)
    goto exit;
  /* display norm of nonlinear defect */
  CenterInPattern(text,DISPLAY_WIDTH,ENVITEM_NAME(newton),'#',"\n");
  if (PreparePCR(newton->d,newton->displayMode,text,&PrintID))    {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}
  if (sc_mul(defect2reach,defect,reduction,newton->d))                    {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}
  if (sc_mul(defectmax,defect,newton->divFactor,newton->d))               {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}
  use_second=0; for (i=0; i<n_unk; i++) if (defectmax[i]==0.0) use_second=1;
  if (DoPCR(PrintID,defect,PCR_CRATE))                                                    {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}
  for (i=0; i<n_unk; i++) res->first_defect[i] = defect[i];

  /* compute single norm */
  s = 0.0;
  for (i=0; i<n_unk; i++)
    s += newton->scale[i]*newton->scale[i]*defect[i]*defect[i];
  s = sqrt(s);
  sprime = s;
  sold = s * sqrt(2.0);
  sred = 1.0E10; for (i=0; i<n_unk; i++) sred = MIN(sred,reduction[i]);
  s2reach = s*sred;
  if (newton->lineSearch)
    if (newton->displayMode == PCR_FULL_DISPLAY)
      UserWriteF(" ++ s=%12.4E Initial nonlinear residual\n",s);

  /* check if iteration is necessary */
  if (sc_cmp(defect,abslimit,newton->d) && !newton->force_iteration) {
    res->converged = 1;
    for (i=0; i<n_unk; i++) res->last_defect[i] = defect[i];
    res->error_code = 0;
    goto exit;
  }

  /* initialize reduction factor for linear solver */
  for (i=0; i<n_unk; i++) red_factor[i] = newton->linMinRed[i];
  reassemble = 1;

  /* do newton iterations */
  for (r=1; r<=newton->maxit; r++)
  {
    if (UG_math_error) {
      UserWrite("math error before newton loop !\n");
      UG_math_error = 0;
      res->error_code = __LINE__;
      break;
    }

    if (res->converged && newton->force_iteration!=2) break;             /* solution already found */

    /* compute jacobian */
    CSTART();
    dset(mg,0,level,ALL_VECTORS,newton->v,0.0);
    if (reassemble)
    {
      if ((*ass->NLAssembleMatrix)(ass,0,level,x,newton->d,newton->v,newton->J,&error)) {
        res->error_code = __LINE__;
        REP_ERR_RETURN(res->error_code);
      }
      reassemble = 0;
    }
    CSTOP(newton_t,newton_c);
    if (UG_math_error) {
      UserWrite("math error in NLAssembleMatrix !\n");
      UG_math_error = 0;
      res->error_code = __LINE__;
      break;
    }

    /* solve linear system */
    CSTART();
    for (i=0; i<n_unk; i++) linred[i] = red_factor[i];bl = 0;
    if (newton->solve->PreProcess!=NULL)
      if ((*newton->solve->PreProcess)(newton->solve,level,newton->v,newton->d,newton->J,&bl,&error)) {
        UserWriteF("NewtonSolver: solve->PreProcess failed, error code %d\n",error);
        res->error_code = __LINE__;
                #ifndef ModelP
        REP_ERR_RETURN (res->error_code);
                #endif
        REP_ERR_INC;
                                #ifndef Debug
        return (res->error_code);
                #endif
      }
    if ((*newton->solve->Residuum)(newton->solve,0,level,newton->v,newton->d,newton->J,&lr))
    {
      res->error_code = __LINE__;
      goto exit;
    }
    if ((*newton->solve->Solver)(newton->solve,level,newton->v,newton->d,newton->J,newton->solve->abslimit,linred,&lr))
    {
      res->error_code = 0;
      goto exit;
    }
    if (newton->solve->PostProcess!=NULL)
      if ((*newton->solve->PostProcess)(newton->solve,level,newton->v,newton->d,newton->J,&error)) {
        res->error_code = __LINE__;
        REP_ERR_RETURN(res->error_code);
      }
    CSTOP(linear_t,linear_c);
    if (UG_math_error) {
      UG_math_error = 0;
      res->error_code = __LINE__;
    }



    /* if linear solver did not converge, return here */
    if (!lr.converged && newton->force_iteration!=2) {
      UserWrite("\nLinear solver did not converge in Newton method\n");
      if (newton->linearRate < 2) {
        res->error_code = 0;                     /* no error but exit */
        goto exit;                         /* or goto exit2 ??? */
      }
    }

    IFDEBUG(np,3)
    UserWrite("---- After linear solver\n");
    ListVectorRange(mg,0,level,0,0,1000,FALSE,TRUE,~(INT)1,LV_MOD_DEFAULT);
    ENDDEBUG

    /* linear solver statistics */
    res->total_linear_iterations += lr.number_of_linear_iterations;
    res->max_linear_iterations = MAX(res->max_linear_iterations,lr.number_of_linear_iterations);

    if (newton->lineSearch)
      if (newton->displayMode == PCR_FULL_DISPLAY)
        UserWriteF(" ++ newton step %3d\n",r);

    /* save current solution for line search */
    if (AllocVDFromVD(mg,0,level,x,  &(newton->s)))
    {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}
    dcopy(mg,0,level,ALL_VECTORS,newton->s,x);

    /* do a line search */
    la = newton->lambda; accept=0;
    for (kk=1; kk<=newton->maxLineSearch; kk++) {

      /* update solution */
      dcopy(mg,0,level,ALL_VECTORS,x,newton->s);
      daxpy(mg,0,level,ALL_VECTORS,x,-la,newton->v);

      if (newton->maxit==r && newton->noLastDef) {
        res->error_code = 0;
        if (FreeVD(mg,0,level,newton->s)) REP_ERR_RETURN(1);
        goto exit2;
      }

      /* if linear problem: use result of linear solver ! */
      if (newton->linearMode)
      {
        for (i=0; i<n_unk; i++) defect[i] = lr.last_defect[i];
        error = 0;
      }
      else
      if (NonLinearDefect(mg,level,FALSE,x,newton,ass,defect,&error)!=0)
      {
        res->error_code = __LINE__;
        REP_ERR_RETURN(res->error_code);
      }
      if (error)
        goto exit;

      /* compute single norm */
      sold = sprime;
      sprime = 0.0;
      for (i=0; i<n_unk; i++)
        sprime += newton->scale[i]*newton->scale[i]*defect[i]*defect[i];
      sprime = sqrt(sprime);

      rho[kk] = sprime/s;

      /* print results */
      if (newton->lineSearch)
        if (newton->displayMode == PCR_FULL_DISPLAY)
          UserWriteF(" ++ ls=%2d, s=%12.4E, rho=%8.4g, lambda= %8.4g\n",
                     kk,sprime,rho[kk],la);

      if (sprime/s<=1-0.25*fabs(la) || !newton->lineSearch) {
        lambda_old = la;
        accept=1;
        break;
      }

      /* else reduce lambda */
      la = LINE_SEARCH_REDUCTION*la;
    }

    /* if not accepted */
    if (!accept)
      switch (newton->lineSearch)
      {
      case 1 :
        /* break iteration */
        UserWrite("line search not accepted, Newton diverged\n");
        res->error_code = 0;
        if (FreeVD(mg,0,level,newton->s)) REP_ERR_RETURN(1);
        goto exit;

      case 2 :
        /* accept best result */
        best_ls = 1;
        rhomin = rho[best_ls];
        for (kk=2; kk<=newton->maxLineSearch; kk++)
          if (rhomin>rho[kk]) {
            rhomin = rho[kk];
            best_ls = kk;
          }

        UserWriteF(" ++ accepting linesearch %d\n",best_ls);

        /* set lambda factor */
        la = newton->lambda * pow(LINE_SEARCH_REDUCTION,best_ls-1);
        lambda_old = la;

        /* update solution */
        dcopy(mg,0,level,ALL_VECTORS,x,newton->s);
        daxpy(mg,0,level,ALL_VECTORS,x,-la,newton->v);

        if (NonLinearDefect(mg,level,FALSE,x,newton,ass, defect,&error)!=0)
        {
          res->error_code = __LINE__;
          REP_ERR_RETURN(res->error_code);
        }
        if (error)
          goto exit;
        break;

        /*default: accept */
      }
    if (FreeVD(mg,0,level,newton->s)) REP_ERR_RETURN(1);

    /* print norm of defect */
    if (DoPCR(PrintID,defect,PCR_CRATE)) {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}

    /* save convergence of first step, may be used to increase stepsize */
    if (r==1) res->rho_first = sprime/s;

    /* reassemble if nonlinear convergence bad */
    if (sprime/s >= newton->rhoReass) reassemble = 1;
    if (!newton->linearRate) reassemble = 1;

    /* check convergence of nonlinear iteration */
    if (newton->force_iteration!=2)
    {
      if (sprime<s2reach) {res->converged=1; break;}
      if (sc_cmp(defect,abslimit,newton->d)) {res->converged=1; break;}
      if (sc_cmp(defect,defect2reach,newton->d)) {res->converged=1; break;}
    }
    else
    if (r==newton->maxit) {res->converged=1; break;}
    if (use_second)
    {
      use_second=0;
      if (sc_mul(defectmax,defect,newton->divFactor,newton->d))
      {
        res->error_code = __LINE__;
        REP_ERR_RETURN(res->error_code);
      }
    }            /*
                    else
                    {
                        if (!sc_cmp(defect,defectmax,newton->d)) break;
                    }
                  */

    /* compute new reduction factor, assuming quadratic convergence */
    for (i=0; i<n_unk; i++)
    {
      red_factor[i] = MIN((sprime/s)*(sprime/s),newton->linMinRed[i]);
      if (newton->linearRate == 1)
        red_factor[i] = MIN(sprime/s,newton->linMinRed[i]);
      if (newton->linearRate == 2)
        red_factor[i] = newton->linMinRed[i];
    }

    /* accept new iterate */
    sold = s;
    s = sprime;
  }

  /* print norm of defect */
  if (DoPCR(PrintID,defect,PCR_AVERAGE))  {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}

  /* report results and mean execution times */
  res->error_code = 0;
  res->number_of_nonlinear_iterations = newton_c;
  res->number_of_line_searches = defect_c;
  for (i=0; i<n_unk; i++) res->last_defect[i] = defect[i];
  if (!res->converged) UserWriteF("NL SOLVER: desired convergence not reached\n");
exit2:
  UserWriteF("AVG EXEC TIMES: DEF[%2d]=%10.4g JAC[%2d]=%10.4g LIN[%2d]=%10.4g\n",
             defect_c,defect_t/defect_c,newton_c,newton_t/newton_c,linear_c,linear_t/linear_c);
  res->exec_time = defect_t+newton_t+linear_t;

  /* postprocess assemble once at the end */
  if (ass->PostProcess!=NULL)
    if ((*ass->PostProcess)(ass,0,level,x,newton->d,newton->J,&error)) {
      res->error_code = __LINE__;
      REP_ERR_RETURN(res->error_code);
    }

exit:
  if (PostPCR(PrintID,NULL))                              {res->error_code = __LINE__; REP_ERR_RETURN(res->error_code);}

  /* deallocate local XDATA_DESCs */
  if (FreeVD(mg,0,level,newton->d)) REP_ERR_RETURN(1);
  if (FreeVD(mg,0,level,newton->v)) REP_ERR_RETURN(1);
  if (newton->lineSearch == 3) {
    if (FreeVD(mg,0,level,newton->dold)) REP_ERR_RETURN(1);
    if (FreeVD(mg,0,level,newton->dsave)) REP_ERR_RETURN(1);
  }
  if (res->error_code==0)
    return (0);
  else
    REP_ERR_RETURN (res->error_code);
}
Ejemplo n.º 16
0
Archivo: ewn.c Proyecto: rolk/ug
static INT EWNSolver (NP_EW_SOLVER *theNP, INT level, INT New, VECDATA_DESC **ev, DOUBLE *ew, NP_NL_ASSEMBLE *Assemble, VEC_SCALAR abslimit, VEC_SCALAR reduction, EWRESULT *ewresult)
{
  NP_EWN     *np    = (NP_EWN *) theNP;
  MULTIGRID *theMG = theNP->base.mg;
  INT i,j,iter,done,result,DoLS;
  char text[DISPLAY_WIDTH+4],format2[64],format3[64],formatr1[64],formatr2[64],formats[64];
  DOUBLE shift,shift_old,cnorm[MAX_NUMBER_EW],norm_x1x2,norm_yx2,norm_yx1,delta;
  DOUBLE A[MAX_NUMBER_EW][MAX_NUMBER_EW];
  DOUBLE B[MAX_NUMBER_EW][MAX_NUMBER_EW];
  DOUBLE E[MAX_NUMBER_EW][MAX_NUMBER_EW];
  DOUBLE ew_re[MAX_NUMBER_EW],ew_im[MAX_NUMBER_EW];
  DOUBLE ew_re_out,ew_im_out;
  DOUBLE tmp_re[MAX_NUMBER_EW],tmp_im[MAX_NUMBER_EW];
  DOUBLE old_re[MAX_NUMBER_EW],old_im[MAX_NUMBER_EW],norm;
  DOUBLE* table[MAX_NUMBER_EW];
  INT index[MAX_NUMBER_EW];
  INT bl = 0;

  ewresult->error_code = 0;
  CenterInPattern(text,DISPLAY_WIDTH,ENVITEM_NAME(np),'§',"\n"); UserWrite(text);
  sprintf(text,"%d.%d",np->c_d+1,np->c_d-1);
  strcpy(formats," %-3d    S:  % "); strcat(formats,text); strcat(formats,"e\n");
  strcpy(format2,"      %3d: (% "); strcat(format2,text); strcat(format2,"e, % "); strcat(format2,text); strcat(format2,"e)");
  strcpy(format3,"      %3d: [% "); strcat(format3,text); strcat(format3,"e, % "); strcat(format3,text); strcat(format3,"e]");
  strcpy(formatr1," %-3d   res: %3d: (% "); strcat(formatr1,text); strcat(formatr1,"e, % "); strcat(formatr1,text); strcat(formatr1,"e)\n");
  strcpy(formatr2,"            %3d: (% "); strcat(formatr2,text); strcat(formatr2,"e, % "); strcat(formatr2,text); strcat(formatr2,"e)\n");
  shift=np->shift_min; DoLS=0; shift_old=shift-1;
  for (iter=0; iter<np->maxiter; iter++)
  {
    /* preprocess if */
    if (iter==0 || DoLS)
    {
      if (dmatcopy(theNP->base.mg,bl,level,ALL_VECTORS,np->M,np->N)) return(1);
      if (dcopy(theNP->base.mg,bl,level,ALL_VECTORS,np->t,np->E)) return(1);
      if (dscal(theNP->base.mg,bl,level,ALL_VECTORS,np->t,-shift)) return(1);
      if (dmassadd(theNP->base.mg,bl,level,ALL_VECTORS,np->M,np->t,np->type)) return(1);
      if (np->LS->PreProcess != NULL) if ((*np->LS->PreProcess)(np->LS,level,ev[0],np->r,np->M, &np->baselevel,&result)) return(1);
    }
    for (i=0; i<New; i++)
    {
      if (np->conv_mode==1)
        if (dcopy(theMG,bl,level,ALL_VECTORS,np->s[i],ev[i])) NP_RETURN(1,ewresult->error_code);
      if (dcopy(theMG,bl,level,ALL_VECTORS,np->t,ev[i])) NP_RETURN(1,ewresult->error_code);
      if (dmassdot(theMG,bl,level,ALL_VECTORS,np->t,np->E,np->type)) NP_RETURN(1,ewresult->error_code);
      if (np->LS->Defect!=NULL) if ((*np->LS->Defect)(np->LS,level,ev[i],np->t,np->M, &ewresult->error_code)) NP_RETURN(1,ewresult->error_code);
      if (np->LS->Residuum!=NULL) if ((*np->LS->Residuum)(np->LS,0,level,ev[i],np->t,np->M, &ewresult->lresult[i])) NP_RETURN(1,ewresult->error_code);
      if ((*np->LS->Solver)(np->LS,level,ev[i],np->t,np->M, abslimit,reduction, &ewresult->lresult[i])) NP_RETURN(1,ewresult->error_code);
      if (np->Project != NULL) if (np->Project->Project(np->Project,bl,level, ev[i],&ewresult->error_code) != NUM_OK) NP_RETURN(1,ewresult->error_code);
    }
    for (i=0; i<New; i++)
    {
      if (ddot(theMG,0,level,ON_SURFACE,ev[i],ev[i],&B[i][i])) NP_RETURN(1,ewresult->error_code);
      if (dscal(theMG,0,level,ALL_VECTORS,ev[i],1/sqrt(B[i][i])) != NUM_OK) NP_RETURN(1,ewresult->error_code);
    }
    for (i=0; i<New; i++)
    {
      if (dmatmul (theMG,0,level,ON_SURFACE,np->t,np->M,ev[i]) != NUM_OK) NP_RETURN(1,ewresult->error_code);
      for (j=0; j<New; j++)
        if (ddotw(theMG,0,level,ON_SURFACE,np->t,ev[j],np->weight,&A[i][j])) NP_RETURN(1,ewresult->error_code);
    }
    for (i=0; i<New; i++)
    {
      if (dcopy(theMG,bl,level,ALL_VECTORS,np->t,ev[i])) NP_RETURN(1,ewresult->error_code);
      if (dmassdot(theMG,bl,level,ALL_VECTORS,np->t,np->E,np->type)) NP_RETURN(1,ewresult->error_code);
      for (j=0; j<New; j++)
        if (ddotw(theMG,0,level,ON_SURFACE,np->t,ev[j],np->weight,&B[i][j])) NP_RETURN(1,ewresult->error_code);
    }

    /* Special Eigenvalue problem  G E_i = lambda E_i */
    SmallEWNSolver_Sci(New,A,B,ew_re,ew_im,E);

    IFDEBUG(np,1)
    UserWriteF("A\n"); for (i=0; i<New; i++) { for (j=0; j<New; j++) UserWriteF("%8.4f\t",A[i][j]);UserWriteF("\n"); }
    UserWriteF("B\n"); for (i=0; i<New; i++) { for (j=0; j<New; j++) UserWriteF("%8.4f\t",B[i][j]);UserWriteF("\n"); }
    UserWriteF("E\n"); for (i=0; i<New; i++) { for (j=0; j<New; j++) UserWriteF("%8.4f\t",E[i][j]);UserWriteF("\n"); }
    ENDDEBUG

    for (i=0; i<New; i++)
      if (AllocVDFromVD(theMG,bl,level,ev[0],&np->e[i])) NP_RETURN(1,ewresult->error_code);
    for (i=0; i<New; i++)
    {
      if (dset(theMG,bl,level,ALL_VECTORS,np->e[i],0.0)) NP_RETURN(1,ewresult->error_code);
      for (j=0; j<New; j++)
        if (daxpy(theMG,bl,level,ALL_VECTORS,np->e[i],E[j][i],ev[j]) != NUM_OK) NP_RETURN(1,ewresult->error_code);
      ddotw(theMG,bl,level,ON_SURFACE,np->e[i],np->e[i],np->weight,&norm); norm=sqrt(norm);
      dscal(theMG,bl,level,ALL_VECTORS,np->e[i],1.0/norm);
    }

    /* sort eigen-values/vectors */
    for (i=0; i<New; i++)
    {
      tmp_re[i]=ew_re[i]; tmp_im[i]=ew_im[i];
      switch (np->order)
      {
      case ORDER_REAL_UP :
        ew[i]=ew_re[i];
        break;
      case ORDER_REAL_DOWN :
        ew[i]=-ew_re[i];
        break;
      case ORDER_ABS_UP :
        ew[i]=ew_re[i]*ew_re[i]+ew_im[i]*ew_im[i];
        break;
      case ORDER_ABS_DOWN :
        ew[i]=-ew_re[i]*ew_re[i]-ew_im[i]*ew_im[i];
        break;
      }
      table[i] = &ew[i];
    }
    qsort(table, New, sizeof(*table),(int (*)(const void *, const void *))EWCompare);
    for (i=0; i<New; i++)
      for (j=0; j<New; j++)
        if (table[i]==&ew[j])
          index[i] = j;

    for (i=0; i<New; i++)
    {
      if (dcopy(theMG,bl,level,ALL_VECTORS,ev[i],np->e[index[i]])) NP_RETURN(1,ewresult->error_code);
      ew_re[i]=tmp_re[index[i]]; ew_im[i]=tmp_im[index[i]];
    }

    /* shift back eigenvalues */
    for (i=0; i<np->ew.nev; i++) ew_re[i]+=shift;

    /* check convergence */
    if (iter>0)
    {
      done=1;
      if (np->conv_mode==0)
      {
        /* convergence according to eigenvalues */
        for (i=0; i<np->c_n; i++)
        {
          if (Round(ew_re[i],np->c_d)!=Round(old_re[i],np->c_d)) done=0;
          if (Round(ABS(ew_im[i]),np->c_d)!=Round(ABS(old_im[i]),np->c_d)) done=0;
        }
      }
      else
      {
        /* convergence according to eigenvectors */
        for (i=0; i<New; i++)
          if (ew_im[i]==0.0)
          {
            ddotw(theMG,bl,level,ON_SURFACE,np->s[i],np->e[index[i]],np->weight,&norm);
            cnorm[i]=1-ABS(norm);
            if (cnorm[i]>pow(0.1,np->c_d) && i<np->c_n) done=0;
          }
          else
          {
            ddotw(theMG,bl,level,ON_SURFACE,np->s[i],np->s[i+1],np->weight,&norm_x1x2);
            ddotw(theMG,bl,level,ON_SURFACE,np->s[i],np->e[index[i]],np->weight,&norm_yx1);
            ddotw(theMG,bl,level,ON_SURFACE,np->s[i+1],np->e[index[i]],np->weight,&norm_yx2);
            norm=(norm_yx1*norm_yx1+norm_yx2*norm_yx2-2.0*norm_x1x2*norm_yx1*norm_yx2)/(1.0-norm_x1x2*norm_x1x2);
            cnorm[i]=1-ABS(norm);
            if (cnorm[i]>pow(0.1,np->c_d) && i<np->c_n) done=0;
            ddotw(theMG,bl,level,ON_SURFACE,np->s[i],np->e[index[i+1]],np->weight,&norm_yx1);
            ddotw(theMG,bl,level,ON_SURFACE,np->s[i+1],np->e[index[i+1]],np->weight,&norm_yx2);
            i++;
            norm=(norm_yx1*norm_yx1+norm_yx2*norm_yx2-2.0*norm_x1x2*norm_yx1*norm_yx2)/(1.0-norm_x1x2*norm_x1x2);
            cnorm[i]=1-ABS(norm);
            if (cnorm[i]>pow(0.1,np->c_d) && i<np->c_n) done=0;
          }
      }
    }
    else
      done=0;

    for (i=0; i<New; i++)
    {
      old_re[i]=ew_re[i];
      old_im[i]=ew_im[i];
    }

    /* display */
    if (np->display > PCR_NO_DISPLAY)
    {
      UserWriteF(formats,iter,shift*np->scale);
      if (np->conv_mode==0)
      {
        /* conv_mode val */
        for (i=0; i<np->ew.nev; i++)
        {
          ew_re_out=np->scale*ew_re[i];
          ew_im_out=np->scale*ew_im[i];
          if (i<np->c_n)  { UserWriteF(format2,(int)i,ew_re_out,ew_im_out); UserWriteF("\n"); }
          else                    { UserWriteF(format3,(int)i,ew_re_out,ew_im_out); UserWriteF("\n"); }
        }
        UserWriteF("\n");
      }
      else
      {
        /* conv_mode vec */
        for (i=0; i<np->ew.nev; i++)
        {
          ew_re_out=np->scale*ew_re[i];
          ew_im_out=np->scale*ew_im[i];
          if (i<np->c_n)  { UserWriteF(format2,(int)i,ew_re_out,ew_im_out); UserWriteF("      (%8.6e)\n",cnorm[i]); }
          else                    { UserWriteF(format3,(int)i,ew_re_out,ew_im_out); UserWriteF("      [%8.6e]\n",cnorm[i]); }
        }
        UserWriteF("\n");
      }
    }

    /* free VEC_DATADESC's */
    for (i=0; i<New; i++)
      if (FreeVD(theMG,bl,level,np->e[i])) NP_RETURN(1,ewresult->error_code);

    /* convergence of smallest */
    UserWriteF("convergence of smallest\n");
    UserWriteF("-----------------------\n");
    delta=0.0; for (i=0; i<New; i++) delta=MAX(delta,(ew_re[i]-shift)*(ew_re[i]-shift)+ew_im[i]*ew_im[i]);
    delta=((ew_re[0]-shift)*(ew_re[0]-shift)+ew_im[0]*ew_im[0])/delta; delta=sqrt(delta);
    UserWriteF("gamma: %e\n\n",delta);

    /* calculate shift */
    delta=0.0; for (i=0; i<New; i++) delta=MAX(delta,ABS(ew_im[i]));delta=MAX(delta,np->imag_max);
    shift=ew_re[0]+delta*delta/(ew_re[0]-ew_re[New-1]);
    delta=0.0; for (i=0; i<New; i++) { delta=ew_re[0]-ew_re[i]; if (delta!=0.0) break;}
    shift=MIN(shift,ew_re[0]+0.5*delta);
    shift=MAX(shift,np->shift_min);
    shift=MIN(shift,np->shift_max);
    DoLS=0; if (shift!=shift_old) DoLS=1;shift_old=shift;

    /* postprocess if */
    if (done || iter==np->maxiter-1 || DoLS)
    {
      if (np->LS->PostProcess!=NULL)
        if ((*np->LS->PostProcess)(np->LS,level,ev[0],np->r,np->M,&result)) return(1);
    }

    /* done? */
    if (done) break;
  }

  /* print result */
  for (i=0; i<np->c_n; i++)
  {
    ew_re_out=np->scale*ew_re[i];
    ew_im_out=np->scale*ew_im[i];
    if (i==0)
      UserWriteF(formatr1,(int)iter,(int)i,ew_re_out,ew_im_out);
    else
      UserWriteF(formatr2,(int)i,ew_re_out,ew_im_out);
  }
  UserWriteF("\n");

  return (0);
}
Ejemplo n.º 17
0
Archivo: enrol.c Proyecto: rolk/ug
FORMAT * NS_DIM_PREFIX CreateFormat (char *name, INT sVertex, INT sMultiGrid,
                                     ConversionProcPtr PrintVertex, ConversionProcPtr PrintGrid,
                                     ConversionProcPtr PrintMultigrid,
                                     TaggedConversionProcPtr PrintVector, TaggedConversionProcPtr PrintMatrix,
                                     INT nvDesc, VectorDescriptor *vDesc, INT nmDesc, MatrixDescriptor *mDesc,
                                     SHORT ImatTypes[], INT po2t[MAXDOMPARTS][MAXVOBJECTS],
                                     INT nodeelementlist, INT edata, INT ndata)
{
  FORMAT *fmt;
  INT i, j, type, type2, part, obj, MaxDepth, NeighborhoodDepth, MaxType;


  /* change to /Formats directory */
  if (ChangeEnvDir("/Formats")==NULL)
    REP_ERR_RETURN_PTR (NULL);

  /* allocate new format structure */
  fmt = (FORMAT *) MakeEnvItem (name,theFormatDirID,sizeof(FORMAT));
  if (fmt==NULL) REP_ERR_RETURN_PTR(NULL);

  /* fill in data */
  FMT_S_VERTEX(fmt)               = sVertex;
  FMT_S_MG(fmt)                   = sMultiGrid;
  FMT_PR_VERTEX(fmt)              = PrintVertex;
  FMT_PR_GRID(fmt)                = PrintGrid;
  FMT_PR_MG(fmt)                  = PrintMultigrid;
  FMT_PR_VEC(fmt)                 = PrintVector;
  FMT_PR_MAT(fmt)                 = PrintMatrix;

  FMT_NODE_ELEM_LIST(fmt) = nodeelementlist;
  FMT_ELEM_DATA(fmt)              = edata;
  FMT_NODE_DATA(fmt)              = ndata;

  /* initialize with zero */
  for (i=0; i<MAXVECTORS; i++)
  {
    FMT_S_VEC_TP(fmt,i) = 0;
  }
  for (i=0; i<MAXCONNECTIONS; i++)
  {
    FMT_S_MAT_TP(fmt,i) = 0;
    FMT_CONN_DEPTH_TP(fmt,i) = 0;
  }
  for (i=FROM_VTNAME; i<=TO_VTNAME; i++)
    FMT_SET_N2T(fmt,i,NOVTYPE);
  MaxDepth = NeighborhoodDepth = 0;

  /* set vector stuff */
  for (i=0; i<nvDesc; i++)
  {
    if ((vDesc[i].tp<0)||(vDesc[i].tp>=MAXVECTORS)||(vDesc[i].size<0)) REP_ERR_RETURN_PTR(NULL);
    FMT_S_VEC_TP(fmt,vDesc[i].tp) = vDesc[i].size;
    if ((vDesc[i].name<FROM_VTNAME) || (TO_VTNAME<vDesc[i].name))
    {
      PrintErrorMessageF('E',"CreateFormat","type name '%c' out of range (%c-%c)",vDesc[i].name,FROM_VTNAME,TO_VTNAME);
      REP_ERR_RETURN_PTR (NULL);
    }
    FMT_VTYPE_NAME(fmt,vDesc[i].tp) = vDesc[i].name;
    FMT_SET_N2T(fmt,vDesc[i].name,vDesc[i].tp);
    FMT_T2N(fmt,vDesc[i].tp) = vDesc[i].name;
  }

  /* copy part,obj to type table and derive t2p, t2o lists */
  for (type=0; type<MAXVECTORS; type++)
    FMT_T2P(fmt,type) = FMT_T2O(fmt,type) = 0;
  for (part=0; part<MAXDOMPARTS; part++)
    for (obj=0; obj<MAXVOBJECTS; obj++)
    {
      type = FMT_PO2T(fmt,part,obj) = po2t[part][obj];
      FMT_T2P(fmt,type) |= (1<<part);
      FMT_T2O(fmt,type) |= (1<<obj);
    }

#ifdef __INTERPOLATION_MATRIX__
  for (i=0; i<MAXMATRICES; i++)
    FMT_S_IMAT_TP(fmt,i) = 0;
#endif

  /* set connection stuff */
  for (i=0; i<nmDesc; i++)
  {
    if ((mDesc[i].from<0)||(mDesc[i].from>=MAXVECTORS)) REP_ERR_RETURN_PTR(NULL);
    if ((mDesc[i].to<0)  ||(mDesc[i].to>=MAXVECTORS)) REP_ERR_RETURN_PTR(NULL);
    if (mDesc[i].diag<0) REP_ERR_RETURN_PTR(NULL);
    if ((mDesc[i].size<0)||(mDesc[i].depth<0)) REP_ERR_RETURN_PTR(NULL);

    if (FMT_S_VEC_TP(fmt,mDesc[i].from)<=0) REP_ERR_RETURN_PTR(NULL);
    if (FMT_S_VEC_TP(fmt,mDesc[i].to)<=0) REP_ERR_RETURN_PTR(NULL);

    if (mDesc[i].size>0 && mDesc[i].depth>=0)
    {
      if (mDesc[i].from==mDesc[i].to)
      {
        /* set data (ensuring that size(diag) >= size(off-diag) */
        if (mDesc[i].diag)
        {
          type=DIAGMATRIXTYPE(mDesc[i].from);
          type2=MATRIXTYPE(mDesc[i].from,mDesc[i].from);
          if (mDesc[i].size>=FMT_S_MAT_TP(fmt,type2))
            FMT_S_MAT_TP(fmt,type) = mDesc[i].size;
          else
            FMT_S_MAT_TP(fmt,type) = FMT_S_MAT_TP(fmt,type2);
        }
        else
        {
          type=MATRIXTYPE(mDesc[i].from,mDesc[i].from);
          FMT_S_MAT_TP(fmt,type) = mDesc[i].size;
          type2=DIAGMATRIXTYPE(mDesc[i].from);
          if (mDesc[i].size>=FMT_S_MAT_TP(fmt,type2))
            FMT_S_MAT_TP(fmt,type2) = mDesc[i].size;
        }
      }
      else
      {
        /* set data (ensuring size symmetry, which is needed at the moment) */
        type=MATRIXTYPE(mDesc[i].from,mDesc[i].to);
        FMT_S_MAT_TP(fmt,type) = mDesc[i].size;
        type2 = MATRIXTYPE(mDesc[i].to,mDesc[i].from);
        if (mDesc[i].size>FMT_S_MAT_TP(fmt,type2))
          FMT_S_MAT_TP(fmt,type2) = mDesc[i].size;
      }
    }
    /* set connection depth information */
    FMT_CONN_DEPTH_TP(fmt,type) = mDesc[i].depth;
    MaxDepth = MAX(MaxDepth,mDesc[i].depth);
    if ((FMT_TYPE_USES_OBJ(fmt,mDesc[i].from,ELEMVEC))&&(FMT_TYPE_USES_OBJ(fmt,mDesc[i].to,ELEMVEC)))
      NeighborhoodDepth = MAX(NeighborhoodDepth,mDesc[i].depth);
    else
      NeighborhoodDepth = MAX(NeighborhoodDepth,mDesc[i].depth+1);

  }
  FMT_CONN_DEPTH_MAX(fmt) = MaxDepth;
  FMT_NB_DEPTH(fmt)           = NeighborhoodDepth;

#ifdef __INTERPOLATION_MATRIX__
  for (i=0; i<MAXVECTORS; i++)
    for (j=0; j<MAXVECTORS; j++)
      FMT_S_IMAT_TP(fmt,MATRIXTYPE(i,j)) = ImatTypes[i] * ImatTypes[j] * sizeof(DOUBLE);
#endif

  /* derive additional information */
  for (i=0; i<MAXVOBJECTS; i++) FMT_USES_OBJ(fmt,i) = FALSE;
  FMT_MAX_PART(fmt) = 0;
  MaxType = 0;
  for (i=0; i<MAXDOMPARTS; i++)
    for (j=0; j<MAXVOBJECTS; j++)
      if (po2t[i][j]!=NOVTYPE)
      {
        FMT_USES_OBJ(fmt,j) = TRUE;
        FMT_MAX_PART(fmt) = MAX(FMT_MAX_PART(fmt),i);
        MaxType = MAX(MaxType,po2t[i][j]);
      }
  FMT_MAX_TYPE(fmt) = MaxType;

  if (ChangeEnvDir(name)==NULL) REP_ERR_RETURN_PTR(NULL);
  UserWrite("format "); UserWrite(name); UserWrite(" installed\n");

  return(fmt);
}
Ejemplo n.º 18
0
Archivo: amg_ug.c Proyecto: rolk/ug
static INT AMGSolverPreProcess (NP_LINEAR_SOLVER *theNP, INT level,
                                VECDATA_DESC *VD_x, VECDATA_DESC *VD_b,
                                MATDATA_DESC *MD_A,
                                INT *baselevel, INT *result)
{
  MULTIGRID *theMG;
  GRID *theGrid;
  int n,nonzeros,blocksize;
  int Acomp;
  MATRIX *theMatrix;
  VECTOR *theVector;
  int i,j,block_i,block_j;
  int nRows_A,nCols_A,nComp_x,nComp_b;
  NP_AMG *theAMGC;
  double ti;
  int ii;
        #ifdef ModelP
  double clock_start;
        #else
  clock_t clock_start;
        #endif

  theAMGC = (NP_AMG *) theNP;

  /* prepare solving */
  theMG = theAMGC->ls.base.mg;
  theGrid = GRID_ON_LEVEL(theMG,level);

  /* mark heap for use by amg */
        #ifndef DYNAMIC_MEMORY_ALLOCMODEL
  Mark(MGHEAP(theMG),FROM_BOTTOM,&amg_MarkKey);
        #else
  Mark(MGHEAP(theMG),FROM_TOP,&amg_MarkKey);
        #endif
  mark_counter++;

  /* initialize sp package */
  AMG_InstallPrintHandler((AMG_PrintFuncPtr)UserWrite);
  amgMG=theMG;       /* make it global for memory handler */
  AMG_InstallMallocHandler((AMG_MallocFuncPtr)amgmalloc);

  /* get access to components */
  nRows_A = MD_ROWS_IN_RT_CT(MD_A,NODEVEC,NODEVEC);
  nCols_A = MD_COLS_IN_RT_CT(MD_A,NODEVEC,NODEVEC);
  nComp_x = VD_NCMPS_IN_TYPE(VD_x,NODEVEC);
  nComp_b = VD_NCMPS_IN_TYPE(VD_b,NODEVEC);
  blocksize = nComp_x;
  if (blocksize==0) goto exit;
  if (nComp_b!=blocksize) goto exit;
  if (nCols_A!=blocksize) goto exit;
  if (nRows_A!=blocksize) goto exit;
  Acomp = MD_MCMP_OF_RT_CT(MD_A,NODEVEC,NODEVEC,0);

  CSTART(); ti=0; ii=0;
  /* diagonal scaling */
  if (theAMGC->scale)
    if (DiagonalScaleSystem(theGrid,MD_A,MD_A,VD_b)!=NUM_OK)
    {
      UserWrite("Error in scaling system\n");
      goto exit;
    }

  /* gather some data for the matrix */
  n = nonzeros = 0;

  /* loop through all vectors, we assume there are only node vectors ! */
  for (theVector=FIRSTVECTOR(theGrid); theVector!= NULL; theVector=SUCCVC(theVector))
  {
    VINDEX(theVector) = n++;             /* renumber vectors just to be sure ... */
    /* now speed through this row */
    for (theMatrix=VSTART(theVector); theMatrix!=NULL; theMatrix = MNEXT(theMatrix))
      nonzeros++;
  }

#ifdef ModelP
  if (me == master)
  {
#endif
  /* now allocate fine grid vectors x and b */
  theAMGC->x = AMG_NewVector(n*blocksize,1,"x");
  if (theAMGC->x==NULL) {
    UserWrite("no memory for x\n");
    goto exit;
  }
  theAMGC->b = AMG_NewVector(n*blocksize,1,"b");
  if (theAMGC->b==NULL) {
    UserWrite("no memory for b\n");
    goto exit;
  }

  /* and a new matrix */
  theAMGC->A = AMG_NewMatrix(n*blocksize,1,nonzeros*blocksize*blocksize,blocksize,"fine grid A");
  if (theAMGC->A==NULL) {
    UserWrite("no memory for A\n");
    goto exit;
  }
                #ifdef ModelP
}
else
{
  /* no master vectors allowed */
  assert(n==0);
  /* only master builds up coarse levels */
  return (0);
}
                #endif

  /* now fill matrix */
  for (theVector=FIRSTVECTOR(theGrid); theVector!= NULL; theVector=SUCCVC(theVector))
  {
    i = VINDEX(theVector);

    /* count row length */
    nonzeros=0;
    for (theMatrix=VSTART(theVector); theMatrix!=NULL; theMatrix = MNEXT(theMatrix))
      nonzeros++;

    /* for each row */
    for (block_i=0; block_i<blocksize; block_i++)
    {
      /* allocate row */
      if (AMG_SetRowLength(theAMGC->A,i*blocksize+block_i,nonzeros*blocksize)!=AMG_OK)
      {
        UserWrite("Error in AMG_SetRowLength\n");
        goto exit;
      }

      /* the diagonal block, be careful to allocate the main diagonal first */
      theMatrix=VSTART(theVector);
      if (AMG_InsertValues(theAMGC->A,i*blocksize+block_i,i*blocksize+block_i,
                           &(MVALUE(theMatrix,Acomp+block_i*blocksize+block_i)))<0)
      {
        UserWrite("Error in AMG_InsertValues\n");
        goto exit;
      }
      for (block_j=0; block_j<blocksize; block_j++)
      {
        if (block_j==block_i) continue;
        if (AMG_InsertValues(theAMGC->A,i*blocksize+block_i,i*blocksize+block_j,
                             &(MVALUE(theMatrix,Acomp+block_i*blocksize+block_j)))<0)
        {
          UserWrite("Error in AMG_InsertValues\n");
          goto exit;
        }
      }

      /* all the offdiagonal blocks */
      for (theMatrix=MNEXT(VSTART(theVector)); theMatrix!=NULL; theMatrix = MNEXT(theMatrix))
      {
        j = VINDEX(MDEST(theMatrix));
        for (block_j=0; block_j<blocksize; block_j++)
        {
          if (AMG_InsertValues(theAMGC->A,i*blocksize+block_i,j*blocksize+block_j,
                               &(MVALUE(theMatrix,Acomp+block_i*blocksize+block_j)))<0)
          {
            UserWrite("Error in AMG_InsertValues\n");
            goto exit;
          }
        }
      }
    }
  }
  /*AMG_PrintMatrix(theAMGC->A,"Matrix");*/

  /* call algebraic multigrid solver */
  if (AMG_Build(&theAMGC->sc,&theAMGC->cc,theAMGC->A)!=AMG_OK) theAMGC->AMG_Build_failed=1;
  theAMGC->AMG_Build_failed=0;
  CSTOP(ti,ii);
  if (theAMGC->sc.verbose>0)
    UserWriteF("AMG : L=%2d BUILD=%10.4g\n",level,ti);

  return(0);       /* ok, matrix is set up */

exit: /* error */
  if (mark_counter>0) {
                #ifndef DYNAMIC_MEMORY_ALLOCMODEL
    Release(MGHEAP(theMG),FROM_BOTTOM,amg_MarkKey);
                #else
    Release(MGHEAP(theMG),FROM_TOP,amg_MarkKey);
                #endif
    mark_counter--;
  }
  return(1);
}
Ejemplo n.º 19
0
Archivo: lgm_domain.c Proyecto: rolk/ug
/* domain interface function: for description see domain.h */
BVP* NS_DIM_PREFIX BVP_Init (const char *name, HEAP *Heap, MESH *Mesh, INT MarkKey)
{
  LGM_DOMAIN *theDomain;
  LGM_PROBLEM *theProblem;
  BndCondProcPtr BndCond,InnerBndCond;
  INT i,nSubDom,conf_df_problem;
  char **argv;

  if ((theDomain = (LGM_DOMAIN *)BVP_GetByName(name))==NULL)
  {
    if ((theDomain = LGM_LoadDomain(name,name,Heap,theLGMDomainVarID,MarkKey))==NULL)
    {
      UserWriteF("ERROR in BVP_Init: cannot load domain '%s'\n",name);
      return (NULL);
    }

    /* set problem */
    theProblem = Lgm_Problem_GetByName(LGM_DOMAIN_PROBLEMNAME(theDomain));
    conf_df_problem = 0;
    if (theProblem==NULL)
    {
      theProblem = Lgm_Problem_GetByName("configurable");
      if (theProblem==NULL)
      {
        UserWrite("ERROR in BVP_Init: cannot find problem\n");
        return (NULL);
      }
      conf_df_problem = 1;
    }
    LGM_DOMAIN_PROBLEM(theDomain) = theProblem;

    /* initialize problem */
    if (conf_df_problem)
    {
      INT maxLineId = 0;

      if (theProblem->InitProblem==NULL) return (NULL);
      nSubDom = LGM_DOMAIN_NSUBDOM(theDomain);
      argv = (char **) GetTmpMem(Heap, sizeof(char *)*(nSubDom+1),MarkKey);
      if (argv==NULL)
      {
        UserWrite("ERROR in BVP_Init: cannot allocate argv\n");
        return (NULL);
      }
      for(i=1; i<=nSubDom; i++)
      {
        LGM_SUBDOMAIN *subdom = LGM_DOMAIN_SUBDOM(theDomain,i);

        argv[i] = LGM_SUBDOMAIN_UNIT(subdom);
      }

      /* get maximum Line/Surface-Id */
      maxLineId = GetMaximumSurfaceID(theDomain);

      if ((*(theProblem->InitProblem))(nSubDom, argv, maxLineId+1, LGM_DOMAIN_PROBLEMNAME(theDomain), Heap))
      {
        UserWrite("ERROR in BVP_Init: cannot initialize problem\n");
        return (NULL);
      }
    }

    /* set boundary conditions */
    BndCond = LGM_PROBLEM_BNDCOND(theProblem);
    InnerBndCond = LGM_PROBLEM_INNERBNDCOND(theProblem);
    if (SetBoundaryCondition(theDomain,BndCond,InnerBndCond)) return (NULL);
  }

  /* set bounding sphere */
  if (SetDomainSize(theDomain)) return (NULL);

  /* set mesh with nothing */
  if (Mesh!=NULL && LGM_LoadMesh(name, Heap,Mesh,theDomain,MarkKey))
  {
    Mesh->mesh_status   = MESHSTAT_EMPTY;
    Mesh->nBndP             = 0;
    Mesh->nInnP             = 0;
    Mesh->nSubDomains       = 0;
    Mesh->nbElements        = NULL;
    Mesh->nElements     = NULL;
    Mesh->VertexLevel   = NULL;
    Mesh->VertexPrio    = NULL;
    Mesh->ElementLevel  = NULL;
    Mesh->ElementPrio   = NULL;
    Mesh->ElemSideOnBnd = NULL;
  }

  /* allocate s2p table */
  LGM_DOMAIN_NPART(theDomain) = 1;
  LGM_DOMAIN_S2P_PTR(theDomain) = (INT*)GetFreelistMemory(Heap,(LGM_DOMAIN_NSUBDOM(theDomain)+1)*sizeof(INT));
  if (LGM_DOMAIN_S2P_PTR(theDomain)==NULL)
    return (NULL);
  /* HRR_TODO: fill number of parts */
  for (i=0; i<=LGM_DOMAIN_NSUBDOM(theDomain); i++)
    LGM_DOMAIN_S2P(theDomain,i) = 0;
  theDomain->theHeap = Heap;

  return ((BVP *)theDomain);
}
Ejemplo n.º 20
0
Archivo: tecplot.c Proyecto: rolk/ug
static INT TecplotCommand (INT argc, char **argv)
{
  INT i,j,k,v;                                  /* counters etc.							*/
  INT counter;                      /* for formatting output                    */
  char item[1024],it[256];      /* item buffers                             */
  INT ic=0;                     /* item length                              */
  VECTOR *vc;                                           /* a vector pointer							*/
  ELEMENT *el;                                  /* an element pointer						*/

  MULTIGRID *mg;                                /* our multigrid							*/
  char filename[NAMESIZE];      /* file name for output file				*/
  PFILE *pf;                    /* the output file pointer                  */


  INT nv;                                               /* number of variables (eval functions)		*/
  EVALUES *ev[MAXVARIABLES];            /* pointers to eval function descriptors	*/
  char ev_name[MAXVARIABLES][NAMESIZE];         /* names for eval functions     */
  char s[NAMESIZE];                             /* name of eval proc						*/
  char zonename[NAMESIZE+7] = "";               /* name for zone (initialized to
                                                                                empty string)						*/
  INT numNodes;                                 /* number of data points					*/
  INT numElements;                              /* number of elements						*/
  INT gnumNodes;                /* number of data points globally           */
  INT gnumElements;             /* number of elements globallay             */
  PreprocessingProcPtr pre;             /* pointer to prepare function				*/
  ElementEvalProcPtr eval;              /* pointer to evaluation function			*/
  DOUBLE *CornersCoord[MAX_CORNERS_OF_ELEM];       /* pointers to coordinates    */
  DOUBLE LocalCoord[DIM];               /* is one of the corners local coordinates	*/
  DOUBLE local[DIM];                            /* local coordinate in DOUBLE				*/
  DOUBLE value;                                 /* returned by user eval proc				*/
  INT oe,on;

  INT saveGeometry;                             /* save geometry flag						*/


  /* get current multigrid */
  mg = GetCurrentMultigrid();
  if (mg==NULL)
  {
    PrintErrorMessage('W',"tecplot","no multigrid open\n");
    return (OKCODE);
  }

  /* scan options */
  nv = 0; saveGeometry = 0;
  for(i=1; i<argc; i++)
  {
    switch(argv[i][0])
    {
    case 'e' :            /* read eval proc */
      if (nv>=MAXVARIABLES)
      {
        PrintErrorMessage('E',"tecplot","too many variables specified\n");
        break;
      }
      sscanf(argv[i],"e %s", s);
      ev[nv] = GetElementValueEvalProc(s);
      if (ev[nv]==NULL)
      {
        PrintErrorMessageF('E',"tecplot","could not find eval proc %s\n",s);
        break;
      }
      if (sscanf(argv[i+1],"s %s", s) == 1)
      {
        strcpy(ev_name[nv],s);
        i++;
      }
      else
        strcpy(ev_name[nv],ev[nv]->v.name);
      nv++;
      break;

    case 'z' :
      sscanf(argv[i],"z %s", zonename+3);
      memcpy(zonename, "T=\"", 3);
      memcpy(zonename+strlen(zonename), "\", \0", 4);
      break;

    case 'g' :
      sscanf(argv[i],"g %d", &saveGeometry);
      if (saveGeometry<0) saveGeometry=0;
      if (saveGeometry>1) saveGeometry=1;
      break;
    }
  }
  if (nv==0) UserWrite("tecplot: no variables given, printing mesh data only\n");

  /* get file name and open output file */
  if (sscanf(argv[0],expandfmt(CONCAT3(" tecplot %",NAMELENSTR,"[ -~]")),filename)!=1)
  {
    PrintErrorMessage('E',"tecplot","could not read name of logfile");
    return(PARAMERRORCODE);
  }
  pf = pfile_open(filename);
  if (pf==NULL) return(PARAMERRORCODE);

  /********************************/
  /* TITLE                                              */
  /********************************/

  ic = 0;
  sprintf(it,"TITLE = \"UG TECPLOT OUTPUT\"\n");
  strcpy(item+ic,it); ic+=strlen(it);
  sprintf(it,"VARIABLES = \"X\", \"Y\"");
  strcpy(item+ic,it); ic+=strlen(it);
  if (DIM==3) {
    sprintf(it,", \"Z\"");
    strcpy(item+ic,it); ic+=strlen(it);
  }
  for (i=0; i<nv; i++) {
    sprintf(it,", \"%s\"",ev[i]->v.name);
    strcpy(item+ic,it); ic+=strlen(it);
  }
  sprintf(it,"\n");
  strcpy(item+ic,it); ic+=strlen(it);
  pfile_master_puts(pf,item); ic=0;

  /********************************/
  /* compute sizes				*/
  /********************************/

  /* clear VCFLAG on all levels */
  for (k=0; k<=TOPLEVEL(mg); k++)
    for (vc=FIRSTVECTOR(GRID_ON_LEVEL(mg,k)); vc!=NULL; vc=SUCCVC(vc))
      SETVCFLAG(vc,0);

  /* run thru all levels of elements and set index */
  numNodes = numElements = 0;
  for (k=0; k<=TOPLEVEL(mg); k++)
    for (el=FIRSTELEMENT(GRID_ON_LEVEL(mg,k)); el!=NULL; el=SUCCE(el))
    {
      if (!EstimateHere(el)) continue;                          /* process finest level elements only */
      numElements++;                                            /* increase element counter */
      for (i=0; i<CORNERS_OF_ELEM(el); i++)
      {
        vc = NVECTOR(CORNER(el,i));
        if (VCFLAG(vc)) continue;                       /* we have this one already */

        VINDEX(vc) = ++numNodes;                        /* number of data points, begins with 1 ! */
        SETVCFLAG(vc,1);                                        /* tag vector as visited */
      }
    }

        #ifdef ModelP
  gnumNodes = TPL_GlobalSumINT(numNodes);
  gnumElements = TPL_GlobalSumINT(numElements);
  on=get_offset(numNodes);
  oe=get_offset(numElements);

  /* clear VCFLAG on all levels */
  for (k=0; k<=TOPLEVEL(mg); k++)
    for (vc=FIRSTVECTOR(GRID_ON_LEVEL(mg,k)); vc!=NULL; vc=SUCCVC(vc))
      SETVCFLAG(vc,0);

  /* number in unique way */
  for (k=0; k<=TOPLEVEL(mg); k++)
    for (el=FIRSTELEMENT(GRID_ON_LEVEL(mg,k)); el!=NULL; el=SUCCE(el))
    {
      if (!EstimateHere(el)) continue;                          /* process finest level elements only */
      for (i=0; i<CORNERS_OF_ELEM(el); i++)
      {
        vc = NVECTOR(CORNER(el,i));
        if (VCFLAG(vc)) continue;                       /* we have this one already */

        VINDEX(vc) += on;                                       /* add offset */
        SETVCFLAG(vc,1);                                        /* tag vector as visited */
      }
    }
    #else
  gnumNodes = numNodes;
  gnumElements = numElements;
  oe=on=0;
    #endif


  /********************************/
  /* write ZONE data				*/
  /* uses FEPOINT for data		*/
  /* uses QUADRILATERAL in 2D		*/
  /* and BRICK in 3D				*/
  /********************************/

  /* write zone record header */
  if (DIM==2) sprintf(it,"ZONE %sN=%d, E=%d, F=FEPOINT, ET=QUADRILATERAL\n", zonename, gnumNodes,gnumElements);
  if (DIM==3) sprintf(it,"ZONE %sN=%d, E=%d, F=FEPOINT, ET=BRICK\n", zonename, gnumNodes,gnumElements);
  strcpy(item+ic,it); ic+=strlen(it);
  pfile_master_puts(pf,item); ic=0;

  /* write data in FEPOINT format, i.e. all variables of a node per line*/

  for (k=0; k<=TOPLEVEL(mg); k++)
    for (vc=FIRSTVECTOR(GRID_ON_LEVEL(mg,k)); vc!=NULL; vc=SUCCVC(vc))
      SETVCFLAG(vc,0);           /* clear all flags */

  counter=0;
  for (k=0; k<=TOPLEVEL(mg); k++)
    for (el=FIRSTELEMENT(GRID_ON_LEVEL(mg,k)); el!=NULL; el=SUCCE(el))
    {
      if (!EstimateHere(el)) continue;                  /* process finest level elements only */

      for (i=0; i<CORNERS_OF_ELEM(el); i++)
        CornersCoord[i] = CVECT(MYVERTEX(CORNER(el,i)));                        /* x,y,z of corners */

      for (i=0; i<CORNERS_OF_ELEM(el); i++)
      {
        vc = NVECTOR(CORNER(el,i));
        if (VCFLAG(vc)) continue;                       /* we have this one alre ady */
        SETVCFLAG(vc,1);                                /* tag vector as visited */

        sprintf(it,"%g",(double)XC(MYVERTEX(CORNER(el,i))));
        strcpy(item+ic,it); ic+=strlen(it);
        sprintf(it," %g",(double)YC(MYVERTEX(CORNER(el,i))));
        strcpy(item+ic,it); ic+=strlen(it);
        if (DIM == 3)
        {
          sprintf(it," %g",(double)ZC(MYVERTEX(CORNER(el,i))));
          strcpy(item+ic,it); ic+=strlen(it);
        }

        /* now all the user variables */

        /* get local coordinate of corner */
        LocalCornerCoordinates(DIM,TAG(el),i,local);
        for (j=0; j<DIM; j++) LocalCoord[j] = local[j];

        for (v=0; v<nv; v++)
        {
          pre =  ev[v]->PreprocessProc;
          eval = ev[v]->EvalProc;

          /* execute prepare function */
          /* This is not really equivalent to
             the FEBLOCK-version sinc we call "pre" more
             often than there. D.Werner */

          if (pre!=NULL) pre(ev_name[v],mg);

          /* call eval function */
          value = eval(el,(const DOUBLE **)CornersCoord,LocalCoord);
          sprintf(it," %g",value);
          strcpy(item+ic,it); ic+=strlen(it);
        }
        sprintf(it,"\n");
        strcpy(item+ic,it); ic+=strlen(it);
        pfile_tagged_puts(pf,item,counter+on); ic=0;
        counter++;
      }
    }
  pfile_sync(pf);       /* end of segment */

  sprintf(it,"\n");
  strcpy(item+ic,it); ic+=strlen(it);
  pfile_master_puts(pf,item); ic=0;

  /* finally write the connectivity list */
  counter=0;
  for (k=0; k<=TOPLEVEL(mg); k++)
    for (el=FIRSTELEMENT(GRID_ON_LEVEL(mg,k)); el!=NULL; el=SUCCE(el))
    {
      if (!EstimateHere(el)) continue;           /* process finest level elements only */

      switch(DIM) {
      case 2 :
        switch(TAG(el)) {
        case TRIANGLE :
          sprintf(it,"%d %d %d %d\n",
                  VINDEX(NVECTOR(CORNER(el,0))),
                  VINDEX(NVECTOR(CORNER(el,1))),
                  VINDEX(NVECTOR(CORNER(el,2))),
                  VINDEX(NVECTOR(CORNER(el,2)))
                  );
          break;
        case QUADRILATERAL :
          sprintf(it,"%d %d %d %d\n",
                  VINDEX(NVECTOR(CORNER(el,0))),
                  VINDEX(NVECTOR(CORNER(el,1))),
                  VINDEX(NVECTOR(CORNER(el,2))),
                  VINDEX(NVECTOR(CORNER(el,3)))
                  );
          break;
        default :
          UserWriteF("tecplot: unknown 2D element type with tag(el) = %d detected. Aborting further processing of command tecplot\n", TAG(el));
          return CMDERRORCODE;
          break;
        }
        break;
      case 3 :
        switch(TAG(el)) {
        case HEXAHEDRON :
          sprintf(it,"%d %d %d %d "
                  "%d %d %d %d\n",
                  VINDEX(NVECTOR(CORNER(el,0))),
                  VINDEX(NVECTOR(CORNER(el,1))),
                  VINDEX(NVECTOR(CORNER(el,2))),
                  VINDEX(NVECTOR(CORNER(el,3))),
                  VINDEX(NVECTOR(CORNER(el,4))),
                  VINDEX(NVECTOR(CORNER(el,5))),
                  VINDEX(NVECTOR(CORNER(el,6))),
                  VINDEX(NVECTOR(CORNER(el,7)))
                  );
          break;
        case TETRAHEDRON :
          sprintf(it,"%d %d %d %d "
                  "%d %d %d %d\n",
                  VINDEX(NVECTOR(CORNER(el,0))),
                  VINDEX(NVECTOR(CORNER(el,1))),
                  VINDEX(NVECTOR(CORNER(el,2))),
                  VINDEX(NVECTOR(CORNER(el,2))),
                  VINDEX(NVECTOR(CORNER(el,3))),
                  VINDEX(NVECTOR(CORNER(el,3))),
                  VINDEX(NVECTOR(CORNER(el,3))),
                  VINDEX(NVECTOR(CORNER(el,3)))
                  );
          break;
        case PYRAMID :
          sprintf(it,"%d %d %d %d "
                  "%d %d %d %d\n",
                  VINDEX(NVECTOR(CORNER(el,0))),
                  VINDEX(NVECTOR(CORNER(el,1))),
                  VINDEX(NVECTOR(CORNER(el,2))),
                  VINDEX(NVECTOR(CORNER(el,3))),
                  VINDEX(NVECTOR(CORNER(el,4))),
                  VINDEX(NVECTOR(CORNER(el,4))),
                  VINDEX(NVECTOR(CORNER(el,4))),
                  VINDEX(NVECTOR(CORNER(el,4)))
                  );
          break;
        case PRISM :
          sprintf(it,"%d %d %d %d "
                  "%d %d %d %d\n",
                  VINDEX(NVECTOR(CORNER(el,0))),
                  VINDEX(NVECTOR(CORNER(el,1))),
                  VINDEX(NVECTOR(CORNER(el,2))),
                  VINDEX(NVECTOR(CORNER(el,2))),
                  VINDEX(NVECTOR(CORNER(el,3))),
                  VINDEX(NVECTOR(CORNER(el,4))),
                  VINDEX(NVECTOR(CORNER(el,5))),
                  VINDEX(NVECTOR(CORNER(el,5)))
                  );
          break;
        default :
          UserWriteF("tecplot: unknown 3D element type with tag(el) = %d detected. Aborting further processing of command tecplot\n", TAG(el));
          return CMDERRORCODE;
          break;
        }
        break;
      }
      strcpy(item+ic,it); ic+=strlen(it);
      pfile_tagged_puts(pf,item,counter+oe); ic=0;
      counter++;

    }

  pfile_sync(pf);       /* end of segment */

  /********************************/
  /* GEOMETRY                                   */
  /* we will do this later, since */
  /* domain interface will change */
  /********************************/

  pfile_close(pf);

  return(OKCODE);
}