Actual source code: zvectorf90.c

  1: #include <petscvec.h>
  2: #include <petsc/private/ftnimpl.h>

  4: #if defined(PETSC_HAVE_FORTRAN_CAPS)
  5:   #define vecgetarraywrite_     VECGETARRAYWRITE
  6:   #define vecrestorearraywrite_ VECRESTOREARRAYWRITE
  7:   #define vecgetarray_          VECGETARRAY
  8:   #define vecrestorearray_      VECRESTOREARRAY
  9:   #define vecgetarrayread_      VECGETARRAYREAD
 10:   #define vecrestorearrayread_  VECRESTOREARRAYREAD
 11:   #define vecduplicatevecs_     VECDUPLICATEVECS
 12:   #define vecdestroyvecs_       VECDESTROYVECS
 13: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 14:   #define vecgetarraywrite_     vecgetarraywrite
 15:   #define vecrestorearraywrite_ vecrestorearraywrite
 16:   #define vecgetarray_          vecgetarray
 17:   #define vecrestorearray_      vecrestorearray
 18:   #define vecgetarrayread_      vecgetarrayread
 19:   #define vecrestorearrayread_  vecrestorearrayread
 20:   #define vecduplicatevecs_     vecduplicatevecs
 21:   #define vecdestroyvecs_       vecdestroyvecs
 22: #endif

 24: PETSC_EXTERN void vecgetarraywrite_(Vec *x, F90Array1d *ptr, int *ierr PETSC_F90_2PTR_PROTO(ptrd))
 25: {
 26:   PetscScalar *fa;
 27:   PetscInt     len;
 28:   if (!ptr) {
 29:     *ierr = PetscError(((PetscObject)*x)->comm, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_BADPTR, PETSC_ERROR_INITIAL, "ptr==NULL, maybe #include <petsc/finclude/petscvec.h> is missing?");
 30:     return;
 31:   }
 32:   *ierr = VecGetArrayWrite(*x, &fa);
 33:   if (*ierr) return;
 34:   *ierr = VecGetLocalSize(*x, &len);
 35:   if (*ierr) return;
 36:   *ierr = F90Array1dCreate(fa, MPIU_SCALAR, 1, len, ptr PETSC_F90_2PTR_PARAM(ptrd));
 37: }

 39: PETSC_EXTERN void vecrestorearraywrite_(Vec *x, F90Array1d *ptr, int *ierr PETSC_F90_2PTR_PROTO(ptrd))
 40: {
 41:   PetscScalar *fa;
 42:   *ierr = F90Array1dAccess(ptr, MPIU_SCALAR, (void **)&fa PETSC_F90_2PTR_PARAM(ptrd));
 43:   if (*ierr) return;
 44:   *ierr = F90Array1dDestroy(ptr, MPIU_SCALAR PETSC_F90_2PTR_PARAM(ptrd));
 45:   if (*ierr) return;
 46:   *ierr = VecRestoreArrayWrite(*x, &fa);
 47: }

 49: PETSC_EXTERN void vecgetarray_(Vec *x, F90Array1d *ptr, int *ierr PETSC_F90_2PTR_PROTO(ptrd))
 50: {
 51:   PetscScalar *fa;
 52:   PetscInt     len;
 53:   if (!ptr) {
 54:     *ierr = PetscError(((PetscObject)*x)->comm, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_BADPTR, PETSC_ERROR_INITIAL, "ptr==NULL, maybe #include <petsc/finclude/petscvec.h> is missing?");
 55:     return;
 56:   }
 57:   *ierr = VecGetArray(*x, &fa);
 58:   if (*ierr) return;
 59:   *ierr = VecGetLocalSize(*x, &len);
 60:   if (*ierr) return;
 61:   *ierr = F90Array1dCreate(fa, MPIU_SCALAR, 1, len, ptr PETSC_F90_2PTR_PARAM(ptrd));
 62: }

 64: PETSC_EXTERN void vecrestorearray_(Vec *x, F90Array1d *ptr, int *ierr PETSC_F90_2PTR_PROTO(ptrd))
 65: {
 66:   PetscScalar *fa;
 67:   *ierr = F90Array1dAccess(ptr, MPIU_SCALAR, (void **)&fa PETSC_F90_2PTR_PARAM(ptrd));
 68:   if (*ierr) return;
 69:   *ierr = F90Array1dDestroy(ptr, MPIU_SCALAR PETSC_F90_2PTR_PARAM(ptrd));
 70:   if (*ierr) return;
 71:   *ierr = VecRestoreArray(*x, &fa);
 72: }

 74: PETSC_EXTERN void vecgetarrayread_(Vec *x, F90Array1d *ptr, int *ierr PETSC_F90_2PTR_PROTO(ptrd))
 75: {
 76:   const PetscScalar *fa;
 77:   PetscInt           len;
 78:   if (!ptr) {
 79:     *ierr = PetscError(((PetscObject)*x)->comm, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_BADPTR, PETSC_ERROR_INITIAL, "ptr==NULL, maybe #include <petsc/finclude/petscvec.h> is missing?");
 80:     return;
 81:   }
 82:   *ierr = VecGetArrayRead(*x, &fa);
 83:   if (*ierr) return;
 84:   *ierr = VecGetLocalSize(*x, &len);
 85:   if (*ierr) return;
 86:   *ierr = F90Array1dCreate((PetscScalar *)fa, MPIU_SCALAR, 1, len, ptr PETSC_F90_2PTR_PARAM(ptrd));
 87: }

 89: PETSC_EXTERN void vecrestorearrayread_(Vec *x, F90Array1d *ptr, int *ierr PETSC_F90_2PTR_PROTO(ptrd))
 90: {
 91:   const PetscScalar *fa;
 92:   *ierr = F90Array1dAccess(ptr, MPIU_SCALAR, (void **)&fa PETSC_F90_2PTR_PARAM(ptrd));
 93:   if (*ierr) return;
 94:   *ierr = F90Array1dDestroy(ptr, MPIU_SCALAR PETSC_F90_2PTR_PARAM(ptrd));
 95:   if (*ierr) return;
 96:   *ierr = VecRestoreArrayRead(*x, &fa);
 97: }

 99: PETSC_EXTERN void vecduplicatevecs_(Vec *v, int *m, F90Array1d *ptr, int *ierr PETSC_F90_2PTR_PROTO(ptrd))
100: {
101:   Vec              *lV;
102:   PetscFortranAddr *newvint;
103:   int               i;
104:   *ierr = VecDuplicateVecs(*v, *m, &lV);
105:   if (*ierr) return;
106:   *ierr = PetscMalloc1(*m, &newvint);
107:   if (*ierr) return;

109:   for (i = 0; i < *m; i++) newvint[i] = (PetscFortranAddr)lV[i];
110:   *ierr = PetscFree(lV);
111:   if (*ierr) return;
112:   *ierr = F90Array1dCreate(newvint, MPIU_FORTRANADDR, 1, *m, ptr PETSC_F90_2PTR_PARAM(ptrd));
113: }

115: PETSC_EXTERN void vecdestroyvecs_(int *m, F90Array1d *ptr, int *ierr PETSC_F90_2PTR_PROTO(ptrd))
116: {
117:   Vec *vecs;
118:   int  i;

120:   *ierr = F90Array1dAccess(ptr, MPIU_FORTRANADDR, (void **)&vecs PETSC_F90_2PTR_PARAM(ptrd));
121:   if (*ierr) return;
122:   for (i = 0; i < *m; i++) {
123:     PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(&vecs[i]);
124:     *ierr = VecDestroy(&vecs[i]);
125:     if (*ierr) return;
126:     PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(&vecs[i]);
127:   }
128:   *ierr = F90Array1dDestroy(ptr, MPIU_FORTRANADDR PETSC_F90_2PTR_PARAM(ptrd));
129:   if (*ierr) return;
130:   *ierr = PetscFree(vecs);
131: }