Subversion Repositories slepc-dev

/*

   This provides a simple shell interface for programmers to

   create their own spectral transformations without writing much

   interface code.

   - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      SLEPc - Scalable Library for Eigenvalue Problem Computations

      Copyright (c) 2002-2007, Universidad Politecnica de Valencia, Spain

      This file is part of SLEPc. See the README file for conditions of use

      and additional information.

   - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

*/

#include "src/st/stimpl.h"        /*I "slepcst.h" I*/

#include "slepceps.h"

EXTERN_C_BEGIN

typedef struct {

  void           *ctx;                       /* user provided context */

  PetscErrorCode (*apply)(void *,Vec,Vec);

  PetscErrorCode (*applytrans)(void *,Vec,Vec);

  PetscErrorCode (*backtr)(void *,PetscScalar*,PetscScalar*);

  char           *name;

} ST_Shell;

EXTERN_C_END

#undef __FUNCT__  

#define __FUNCT__ "STShellGetContext"

/*@C

    STShellGetContext - Returns the user-provided context associated with a shell ST

    Not Collective

    Input Parameter:

.   st - spectral transformation context

    Output Parameter:

.   ctx - the user provided context

    Level: advanced

    Notes:

    This routine is intended for use within various shell routines

.seealso: STShellSetContext()

@*/

PetscErrorCode STShellGetContext(ST st,void **ctx)

{

  PetscErrorCode ierr;

  PetscTruth     flg;

  PetscFunctionBegin;

  PetscValidHeaderSpecific(st,ST_COOKIE,1);

  PetscValidPointer(ctx,2);

  ierr = PetscTypeCompare((PetscObject)st,STSHELL,&flg);CHKERRQ(ierr);

  if (!flg) *ctx = 0;

  else      *ctx = ((ST_Shell*)(st->data))->ctx;

  PetscFunctionReturn(0);

}

#undef __FUNCT__  

#define __FUNCT__ "STShellSetContext"

/*@C

    STShellSetContext - sets the context for a shell ST

   Collective on ST

    Input Parameters:

+   st - the shell ST

-   ctx - the context

   Level: advanced

   Fortran Notes: The context can only be an integer or a PetscObject;

      unfortunately it cannot be a Fortran array or derived type.

.seealso: STShellGetContext()

@*/

PetscErrorCode STShellSetContext(ST st,void *ctx)

{

  ST_Shell      *shell = (ST_Shell*)st->data;

  PetscErrorCode ierr;

  PetscTruth     flg;

  PetscFunctionBegin;

  PetscValidHeaderSpecific(st,ST_COOKIE,1);

  ierr = PetscTypeCompare((PetscObject)st,STSHELL,&flg);CHKERRQ(ierr);

  if (flg) {

    shell->ctx = ctx;

  }

  PetscFunctionReturn(0);

}

#undef __FUNCT__  

#define __FUNCT__ "STApply_Shell"

PetscErrorCode STApply_Shell(ST st,Vec x,Vec y)

{

  PetscErrorCode ierr;

  ST_Shell       *shell = (ST_Shell*)st->data;

  PetscFunctionBegin;

  if (!shell->apply) SETERRQ(PETSC_ERR_USER,"No apply() routine provided to Shell ST");

  PetscStackPush("PCSHELL user function");

  CHKMEMQ;

  ierr  = (*shell->apply)(shell->ctx,x,y);CHKERRQ(ierr);

  CHKMEMQ;

  PetscStackPop;

  PetscFunctionReturn(0);

}

#undef __FUNCT__  

#define __FUNCT__ "STApplyTranspose_Shell"

PetscErrorCode STApplyTranspose_Shell(ST st,Vec x,Vec y)

{

  PetscErrorCode ierr;

  ST_Shell       *shell = (ST_Shell*)st->data;

  PetscFunctionBegin;

  if (!shell->applytrans) SETERRQ(PETSC_ERR_USER,"No applytranspose() routine provided to Shell ST");

  ierr  = (*shell->applytrans)(shell->ctx,x,y);CHKERRQ(ierr);

  PetscFunctionReturn(0);

}

#undef __FUNCT__  

#define __FUNCT__ "STBackTransform_Shell"

PetscErrorCode STBackTransform_Shell(ST st,PetscScalar *eigr,PetscScalar *eigi)

{

  PetscErrorCode ierr;

  ST_Shell       *shell = (ST_Shell*)st->data;

  PetscFunctionBegin;

  if (shell->backtr) {

    ierr  = (*shell->backtr)(shell->ctx,eigr,eigi);CHKERRQ(ierr);

  }

  PetscFunctionReturn(0);

}

#undef __FUNCT__  

#define __FUNCT__ "STDestroy_Shell"

PetscErrorCode STDestroy_Shell(ST st)

{

  PetscErrorCode ierr;

  ST_Shell       *shell = (ST_Shell*)st->data;

  PetscFunctionBegin;

  ierr = PetscFree(shell->name);CHKERRQ(ierr);

  ierr = PetscFree(shell);CHKERRQ(ierr);

  PetscFunctionReturn(0);

}

#undef __FUNCT__  

#define __FUNCT__ "STView_Shell"

PetscErrorCode STView_Shell(ST st,PetscViewer viewer)

{

  PetscErrorCode ierr;

  ST_Shell       *ctx = (ST_Shell*)st->data;

  PetscTruth     isascii;

  PetscFunctionBegin;

  ierr = PetscTypeCompare((PetscObject)viewer,PETSC_VIEWER_ASCII,&isascii);CHKERRQ(ierr);

  if (isascii) {

    if (ctx->name) {ierr = PetscViewerASCIIPrintf(viewer,"  ST Shell: %s\n",ctx->name);CHKERRQ(ierr);}

    else           {ierr = PetscViewerASCIIPrintf(viewer,"  ST Shell: no name\n");CHKERRQ(ierr);}

  } else {

    SETERRQ1(1,"Viewer type %s not supported for STShell",((PetscObject)viewer)->type_name);

  }

  PetscFunctionReturn(0);

}

EXTERN_C_BEGIN

#undef __FUNCT__  

#define __FUNCT__ "STShellSetApply_Shell"

PetscErrorCode STShellSetApply_Shell(ST st,PetscErrorCode (*apply)(void*,Vec,Vec))

{

  ST_Shell *shell = (ST_Shell*)st->data;

  PetscFunctionBegin;

  shell->apply = apply;

  PetscFunctionReturn(0);

}

EXTERN_C_END

EXTERN_C_BEGIN

#undef __FUNCT__  

#define __FUNCT__ "STShellSetApplyTranspose_Shell"

PetscErrorCode STShellSetApplyTranspose_Shell(ST st,PetscErrorCode (*applytrans)(void*,Vec,Vec))

{

  ST_Shell *shell = (ST_Shell*)st->data;

  PetscFunctionBegin;

  shell->applytrans = applytrans;

  PetscFunctionReturn(0);

}

EXTERN_C_END

EXTERN_C_BEGIN

#undef __FUNCT__  

#define __FUNCT__ "STShellSetBackTransform_Shell"

PetscErrorCode STShellSetBackTransform_Shell(ST st,PetscErrorCode (*backtr)(void*,PetscScalar*,PetscScalar*))

{

  ST_Shell *shell = (ST_Shell *) st->data;

  PetscFunctionBegin;

  shell->backtr = backtr;

  PetscFunctionReturn(0);

}

EXTERN_C_END

EXTERN_C_BEGIN

#undef __FUNCT__  

#define __FUNCT__ "STShellSetName_Shell"

PetscErrorCode STShellSetName_Shell(ST st,const char name[])

{

  ST_Shell *shell = (ST_Shell*)st->data;

  PetscErrorCode ierr;

  PetscFunctionBegin;

  ierr = PetscStrfree(shell->name);CHKERRQ(ierr);    

  ierr = PetscStrallocpy(name,&shell->name);CHKERRQ(ierr);

  PetscFunctionReturn(0);

}

EXTERN_C_END

EXTERN_C_BEGIN

#undef __FUNCT__  

#define __FUNCT__ "STShellGetName_Shell"

PetscErrorCode STShellGetName_Shell(ST st,char *name[])

{

  ST_Shell *shell = (ST_Shell*)st->data;

  PetscFunctionBegin;

  *name  = shell->name;

  PetscFunctionReturn(0);

}

EXTERN_C_END

#undef __FUNCT__  

#define __FUNCT__ "STShellSetApply"

/*@C

   STShellSetApply - Sets routine to use as the application of the

   operator to a vector in the user-defined spectral transformation.

   Collective on ST

   Input Parameters:

+  st    - the spectral transformation context

-  apply - the application-provided transformation routine

   Calling sequence of apply:

.vb

   PetscErrorCode apply (void *ptr,Vec xin,Vec xout)

.ve

+  ptr  - the application context

.  xin  - input vector

-  xout - output vector

   Level: developer

.seealso: STShellSetBackTransform(), STShellSetApplyTranspose()

@*/

PetscErrorCode STShellSetApply(ST st,PetscErrorCode (*apply)(void*,Vec,Vec))

{

  PetscErrorCode ierr, (*f)(ST,PetscErrorCode (*)(void*,Vec,Vec));

  PetscFunctionBegin;

  PetscValidHeaderSpecific(st,ST_COOKIE,1);

  ierr = PetscObjectQueryFunction((PetscObject)st,"STShellSetApply_C",(void (**)(void))&f);CHKERRQ(ierr);

  if (f) {

    ierr = (*f)(st,apply);CHKERRQ(ierr);

  }

  PetscFunctionReturn(0);

}

#undef __FUNCT__  

#define __FUNCT__ "STShellSetApplyTranspose"

/*@C

   STShellSetApplyTranspose - Sets routine to use as the application of the

   transposed operator to a vector in the user-defined spectral transformation.

   Collective on ST

   Input Parameters:

+  st    - the spectral transformation context

-  applytrans - the application-provided transformation routine

   Calling sequence of apply:

.vb

   PetscErrorCode applytrans (void *ptr,Vec xin,Vec xout)

.ve

+  ptr  - the application context

.  xin  - input vector

-  xout - output vector

   Level: developer

.seealso: STShellSetApply(), STShellSetBackTransform()

@*/

PetscErrorCode STShellSetApplyTranspose(ST st,PetscErrorCode (*applytrans)(void*,Vec,Vec))

{

  PetscErrorCode ierr, (*f)(ST,PetscErrorCode (*)(void*,Vec,Vec));

  PetscFunctionBegin;

  PetscValidHeaderSpecific(st,ST_COOKIE,1);

  ierr = PetscObjectQueryFunction((PetscObject)st,"STShellSetApplyTranspose_C",(void (**)(void))&f);CHKERRQ(ierr);

  if (f) {

    ierr = (*f)(st,applytrans);CHKERRQ(ierr);

  }

  PetscFunctionReturn(0);

}

#undef __FUNCT__  

#define __FUNCT__ "STShellSetBackTransform"

/*@C

   STShellSetBackTransform - Sets the routine to be called after the

   eigensolution process has finished in order to transform back the

   computed eigenvalues.

   Collective on ST

   Input Parameters:

+  st     - the spectral transformation context

-  backtr - the application-provided backtransform routine

   Calling sequence of backtr:

.vb

   PetscErrorCode backtr (void *ptr,PetscScalar *eigr,PetscScalar *eigi)

.ve

+  ptr  - the application context

.  eigr - pointer ot the real part of the eigenvalue to transform back

-  eigi - pointer ot the imaginary part

   Level: developer

.seealso: STShellSetApply(), STShellSetApplyTranspose()

@*/

PetscErrorCode STShellSetBackTransform(ST st,PetscErrorCode (*backtr)(void*,PetscScalar*,PetscScalar*))

{

  PetscErrorCode ierr, (*f)(ST,PetscErrorCode (*)(void*,PetscScalar*,PetscScalar*));

  PetscFunctionBegin;

  PetscValidHeaderSpecific(st,ST_COOKIE,1);

  ierr = PetscObjectQueryFunction((PetscObject)st,"STShellSetBackTransform_C",(void (**)(void))&f);CHKERRQ(ierr);

  if (f) {

    ierr = (*f)(st,(int (*)(void*,PetscScalar*,PetscScalar*))backtr);CHKERRQ(ierr);

  }

  PetscFunctionReturn(0);

}

#undef __FUNCT__  

#define __FUNCT__ "STShellSetName"

/*@C

   STShellSetName - Sets an optional name to associate with a shell

   spectral transformation.

   Not Collective

   Input Parameters:

+  st   - the spectral transformation context

-  name - character string describing the shell spectral transformation

   Level: developer

.seealso: STShellGetName()

@*/

PetscErrorCode STShellSetName(ST st,const char name[])

{

  PetscErrorCode ierr, (*f)(ST,const char []);

  PetscFunctionBegin;

  PetscValidHeaderSpecific(st,ST_COOKIE,1);

  ierr = PetscObjectQueryFunction((PetscObject)st,"STShellSetName_C",(void (**)(void))&f);CHKERRQ(ierr);

  if (f) {

    ierr = (*f)(st,name);CHKERRQ(ierr);

  }

  PetscFunctionReturn(0);

}

#undef __FUNCT__  

#define __FUNCT__ "STShellGetName"

/*@C

   STShellGetName - Gets an optional name that the user has set for a shell

   spectral transformation.

   Not Collective

   Input Parameter:

.  st - the spectral transformation context

   Output Parameter:

.  name - character string describing the shell spectral transformation

          (you should not free this)

   Level: developer

.seealso: STShellSetName()

@*/

PetscErrorCode STShellGetName(ST st,char *name[])

{

  PetscErrorCode ierr, (*f)(ST,char *[]);

  PetscFunctionBegin;

  PetscValidHeaderSpecific(st,ST_COOKIE,1);

  ierr = PetscObjectQueryFunction((PetscObject)st,"STShellGetName_C",(void (**)(void))&f);CHKERRQ(ierr);

  if (f) {

    ierr = (*f)(st,name);CHKERRQ(ierr);

  } else {

    SETERRQ(PETSC_ERR_ARG_WRONG,"Not shell spectral transformation, cannot get name");

  }

  PetscFunctionReturn(0);

}

/*MC

   STSHELL - Creates a new spectral transformation class.

          This is intended to provide a simple class to use with EPS.

          You should not use this if you plan to make a complete class.

  Level: advanced

  Usage:

$             PetscErrorCode (*apply)(void*,Vec,Vec);

$             PetscErrorCode (*applytrans)(void*,Vec,Vec);

$             PetscErrorCode (*backtr)(void*,PetscScalar*,PetscScalar*);

$             STCreate(comm,&st);

$             STSetType(st,STSHELL);

$             STShellSetApply(st,apply);

$             STShellSetApplyTranspose(st,applytrans);

$             STShellSetBackTransform(st,backtr);    (optional)

M*/

EXTERN_C_BEGIN

#undef __FUNCT__  

#define __FUNCT__ "STCreate_Shell"

PetscErrorCode STCreate_Shell(ST st)

{

  PetscErrorCode ierr;

  ST_Shell       *shell;

  PetscFunctionBegin;

  st->ops->destroy = STDestroy_Shell;

  ierr = PetscNew(ST_Shell,&shell);CHKERRQ(ierr);

  ierr = PetscLogObjectMemory(st,sizeof(ST_Shell));CHKERRQ(ierr);

  st->data           = (void *) shell;

  ((PetscObject)st)->name           = 0;

  st->ops->apply     = STApply_Shell;

  st->ops->applytrans= STApplyTranspose_Shell;

  st->ops->backtr    = STBackTransform_Shell;

  st->ops->view      = STView_Shell;

  shell->apply       = 0;

  shell->applytrans  = 0;

  shell->backtr      = 0;

  shell->name        = 0;

  shell->ctx         = 0;

  ierr = PetscObjectComposeFunctionDynamic((PetscObject)st,"STShellSetApply_C","STShellSetApply_Shell",

                    STShellSetApply_Shell);CHKERRQ(ierr);

  ierr = PetscObjectComposeFunctionDynamic((PetscObject)st,"STShellSetApplyTranspose_C","STShellSetApplyTranspose_Shell",

                    STShellSetApplyTranspose_Shell);CHKERRQ(ierr);

  ierr = PetscObjectComposeFunctionDynamic((PetscObject)st,"STShellSetBackTransform_C","STShellSetBackTransform_Shell",

                    STShellSetBackTransform_Shell);CHKERRQ(ierr);

  ierr = PetscObjectComposeFunctionDynamic((PetscObject)st,"STShellSetName_C","STShellSetName_Shell",

                    STShellSetName_Shell);CHKERRQ(ierr);

  ierr = PetscObjectComposeFunctionDynamic((PetscObject)st,"STShellGetName_C","STShellGetName_Shell",

                    STShellGetName_Shell);CHKERRQ(ierr);

  PetscFunctionReturn(0);

}

EXTERN_C_END