Actual source code: znleigsf.c

      1: /*
      2:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      3:    SLEPc - Scalable Library for Eigenvalue Problem Computations
      4:    Copyright (c) 2002-, Universitat Politecnica de Valencia, Spain

      6:    This file is part of SLEPc.
      7:    SLEPc is distributed under a 2-clause BSD license (see LICENSE).
      8:    - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      9: */

     11: #include <petsc/private/ftnimpl.h>
     12: #include <slepcnep.h>

     14: #if defined(PETSC_HAVE_FORTRAN_CAPS)
     15: #define nepnleigssetsingularitiesfunction_ NEPNLEIGSSETSINGULARITIESFUNCTION
     16: #define nepnleigsgetrkshifts_              NEPNLEIGSGETRKSHIFTS
     17: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
     18: #define nepnleigssetsingularitiesfunction_ nepnleigssetsingularitiesfunction
     19: #define nepnleigsgetrkshifts_              nepnleigsgetrkshifts
     20: #endif

     22: static struct {
     23:   PetscFortranCallbackId singularities;
     24: } _cb;

     26: static PetscErrorCode oursingularitiesfunc(NEP nep,PetscInt *maxnp,PetscScalar *xi,void *ctx)
     27: {
     28:   PetscObjectUseFortranCallback(nep,_cb.singularities,(NEP*,PetscInt*,PetscScalar*,void*,PetscErrorCode*),(&nep,maxnp,xi,_ctx,&ierr));
     29: }

     31: SLEPC_EXTERN void nepnleigssetsingularitiesfunction_(NEP *nep,void (*func)(NEP*,PetscInt*,PetscScalar*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr)
     32: {
     33:   CHKFORTRANNULLOBJECT(ctx);
     34:   *ierr = PetscObjectSetFortranCallback((PetscObject)*nep,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.singularities,(PetscFortranCallbackFn*)func,ctx); if (*ierr) return;
     35:   *ierr = NEPNLEIGSSetSingularitiesFunction(*nep,oursingularitiesfunc,*nep);
     36: }

     38: SLEPC_EXTERN void nepnleigsgetrkshifts_(NEP *nep,PetscInt *ns,PetscScalar *pshifts,PetscErrorCode *ierr)
     39: {
     40:   PetscScalar *oshifts;
     41:   PetscInt    n;

     43:   CHKFORTRANNULLSCALAR(pshifts);
     44:   *ierr = NEPNLEIGSGetRKShifts(*nep,&n,&oshifts); if (*ierr) return;
     45:   if (pshifts) { *ierr = PetscArraycpy(pshifts,oshifts,n); if (*ierr) return; }
     46:   *ns = n;
     47:   *ierr = PetscFree(oshifts);
     48: }