Date: 2026-05-01T10:02:21+00:00

Actual source code: zshellf.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 <slepcst.h>

     14: #if defined(PETSC_HAVE_FORTRAN_CAPS)
     15: #define stshellsetapply_                   STSHELLSETAPPLY
     16: #define stshellsetapplytranspose_          STSHELLSETAPPLYTRANSPOSE
     17: #define stshellsetapplyhermitiantranspose_ STSHELLSETAPPLYHERMITIANTRANSPOSE
     18: #define stshellsetbacktransform_           STSHELLSETBACKTRANSFORM
     19: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
     20: #define stshellsetapply_                   stshellsetapply
     21: #define stshellsetapplytranspose_          stshellsetapplytranspose
     22: #define stshellsetapplyhermitiantranspose_ stshellsetapplyhermitiantranspose
     23: #define stshellsetbacktransform_           stshellsetbacktransform
     24: #endif

     26: static struct {
     27:   PetscFortranCallbackId apply;
     28:   PetscFortranCallbackId applytranspose;
     29:   PetscFortranCallbackId applyhermtrans;
     30:   PetscFortranCallbackId backtransform;
     31: } _cb;

     33: /* These are not extern C because they are passed into non-extern C user level functions */
     34: static PetscErrorCode ourshellapply(ST st,Vec x,Vec y)
     35: {
     36:   PetscObjectUseFortranCallback(st,_cb.apply,(ST*,Vec*,Vec*,PetscErrorCode*),(&st,&x,&y,&ierr));
     37: }

     39: static PetscErrorCode ourshellapplytranspose(ST st,Vec x,Vec y)
     40: {
     41:   PetscObjectUseFortranCallback(st,_cb.applytranspose,(ST*,Vec*,Vec*,PetscErrorCode*),(&st,&x,&y,&ierr));
     42: }

     44: static PetscErrorCode ourshellapplyhermitiantranspose(ST st,Vec x,Vec y)
     45: {
     46:   PetscObjectUseFortranCallback(st,_cb.applyhermtrans,(ST*,Vec*,Vec*,PetscErrorCode*),(&st,&x,&y,&ierr));
     47: }

     49: static PetscErrorCode ourshellbacktransform(ST st,PetscInt n,PetscScalar *eigr,PetscScalar *eigi)
     50: {
     51:   PetscObjectUseFortranCallback(st,_cb.backtransform,(ST*,PetscInt*,PetscScalar*,PetscScalar*,PetscErrorCode*),(&st,&n,eigr,eigi,&ierr));
     52: }

     54: SLEPC_EXTERN void stshellsetapply_(ST *st,void (*apply)(ST*,Vec*,Vec*,PetscErrorCode*),PetscErrorCode *ierr)
     55: {
     56:   *ierr = PetscObjectSetFortranCallback((PetscObject)*st,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.apply,(PetscFortranCallbackFn*)apply,NULL); if (*ierr) return;
     57:   *ierr = STShellSetApply(*st,ourshellapply);
     58: }

     60: SLEPC_EXTERN void stshellsetapplytranspose_(ST *st,void (*applytranspose)(ST*,Vec*,Vec*,PetscErrorCode*),PetscErrorCode *ierr)
     61: {
     62:   *ierr = PetscObjectSetFortranCallback((PetscObject)*st,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.applytranspose,(PetscFortranCallbackFn*)applytranspose,NULL); if (*ierr) return;
     63:   *ierr = STShellSetApplyTranspose(*st,ourshellapplytranspose);
     64: }

     66: SLEPC_EXTERN void stshellsetapplyhermitiantranspose_(ST *st,void (*applyhermtrans)(ST*,Vec*,Vec*,PetscErrorCode*),PetscErrorCode *ierr)
     67: {
     68:   *ierr = PetscObjectSetFortranCallback((PetscObject)*st,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.applyhermtrans,(PetscFortranCallbackFn*)applyhermtrans,NULL); if (*ierr) return;
     69:   *ierr = STShellSetApplyHermitianTranspose(*st,ourshellapplyhermitiantranspose);
     70: }

     72: SLEPC_EXTERN void stshellsetbacktransform_(ST *st,void (*backtransform)(ST*,PetscScalar*,PetscScalar*,PetscErrorCode*),PetscErrorCode *ierr)
     73: {
     74:   *ierr = PetscObjectSetFortranCallback((PetscObject)*st,PETSC_FORTRAN_CALLBACK_CLASS,&_cb.backtransform,(PetscFortranCallbackFn*)backtransform,NULL); if (*ierr) return;
     75:   *ierr = STShellSetBackTransform(*st,ourshellbacktransform);
     76: }