Actual source code: zvectorf.c

  1: #include <petsc/private/fortranimpl.h>
  2: #include <petscvec.h>
  3: #include <petscviewer.h>

  5: #if defined(PETSC_HAVE_FORTRAN_CAPS)
  6:   #define vecsetvalue_         VECSETVALUE
  7:   #define vecsetvaluelocal_    VECSETVALUELOCAL
  8:   #define vecgetarray_         VECGETARRAY
  9:   #define vecgetarrayread_     VECGETARRAYREAD
 10:   #define vecgetarrayaligned_  VECGETARRAYALIGNED
 11:   #define vecrestorearray_     VECRESTOREARRAY
 12:   #define vecrestorearrayread_ VECRESTOREARRAYREAD
 13:   #define vecduplicatevecs_    VECDUPLICATEVECS
 14:   #define vecdestroyvecs_      VECDESTROYVECS
 15:   #define vecmin1_             VECMIN1
 16:   #define vecmin2_             VECMIN2
 17:   #define vecmax1_             VECMAX1
 18:   #define vecmax2_             VECMAX2

 20: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 21:   #define vecgetarrayaligned_  vecgetarrayaligned
 22:   #define vecsetvalue_         vecsetvalue
 23:   #define vecsetvaluelocal_    vecsetvaluelocal
 24:   #define vecgetarray_         vecgetarray
 25:   #define vecrestorearray_     vecrestorearray
 26:   #define vecgetarrayaligned_  vecgetarrayaligned
 27:   #define vecgetarrayread_     vecgetarrayread
 28:   #define vecrestorearrayread_ vecrestorearrayread
 29:   #define vecduplicatevecs_    vecduplicatevecs
 30:   #define vecdestroyvecs_      vecdestroyvecs
 31:   #define vecmin1_             vecmin1
 32:   #define vecmin2_             vecmin2
 33:   #define vecmax1_             vecmax1
 34:   #define vecmax2_             vecmax2
 35: #endif

 37: PETSC_EXTERN void vecsetvalue_(Vec *v, PetscInt *i, PetscScalar *va, InsertMode *mode, PetscErrorCode *ierr)
 38: {
 39:   /* cannot use VecSetValue() here since that uses PetscCall() which has a return in it */
 40:   *ierr = VecSetValues(*v, 1, i, va, *mode);
 41: }
 42: PETSC_EXTERN void vecsetvaluelocal_(Vec *v, PetscInt *i, PetscScalar *va, InsertMode *mode, PetscErrorCode *ierr)
 43: {
 44:   /* cannot use VecSetValue() here since that uses PetscCall() which has a return in it */
 45:   *ierr = VecSetValuesLocal(*v, 1, i, va, *mode);
 46: }

 48: /*MC
 49:          VecGetArrayAligned - FORTRAN only. Forces alignment of vector
 50:       arrays so that arrays of derived types may be used.

 52:    Synopsis:
 53:    VecGetArrayAligned(PetscErrorCode ierr)

 55:      Not Collective

 57:      Level: advanced

 59:      Notes:
 60:     Allows code such as

 62: .vb
 63:      type  :: Field
 64:         PetscScalar :: p1
 65:         PetscScalar :: p2
 66:       end type Field

 68:       type(Field)       :: lx_v(0:1)

 70:       call VecGetArray(localX, lx_v, lx_i, ierr)
 71:       call InitialGuessLocal(lx_v(lx_i/2), ierr)

 73:       subroutine InitialGuessLocal(a,ierr)
 74:       type(Field)     :: a(*)
 75: .ve

 77:      If you have not called `VecGetArrayAligned()` the code may generate incorrect data
 78:      or crash.

 80:      lx_i needs to be divided by the number of entries in Field (in this case 2)

 82:      You do NOT need `VecGetArrayAligned()` if lx_v and a are arrays of `PetscScalar`

 84: .seealso: `VecGetArray()`, `VecGetArrayF90()`
 85: M*/
 86: static PetscBool  VecGetArrayAligned = PETSC_FALSE;
 87: PETSC_EXTERN void vecgetarrayaligned_(PetscErrorCode *ierr)
 88: {
 89:   VecGetArrayAligned = PETSC_TRUE;
 90: }

 92: PETSC_EXTERN void vecgetarray_(Vec *x, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr)
 93: {
 94:   PetscScalar *lx;
 95:   PetscInt     m, bs;

 97:   *ierr = VecGetArray(*x, &lx);
 98:   if (*ierr) return;
 99:   *ierr = VecGetLocalSize(*x, &m);
100:   if (*ierr) return;
101:   bs = 1;
102:   if (VecGetArrayAligned) {
103:     *ierr = VecGetBlockSize(*x, &bs);
104:     if (*ierr) return;
105:   }
106:   *ierr = PetscScalarAddressToFortran((PetscObject)*x, bs, fa, lx, m, ia);
107: }

109: /* Be to keep vec/examples/ex21.F and snes/examples/ex12.F up to date */
110: PETSC_EXTERN void vecrestorearray_(Vec *x, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr)
111: {
112:   PetscInt     m;
113:   PetscScalar *lx;

115:   *ierr = VecGetLocalSize(*x, &m);
116:   if (*ierr) return;
117:   *ierr = PetscScalarAddressFromFortran((PetscObject)*x, fa, *ia, m, &lx);
118:   if (*ierr) return;
119:   *ierr = VecRestoreArray(*x, &lx);
120:   if (*ierr) return;
121: }

123: PETSC_EXTERN void vecgetarrayread_(Vec *x, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr)
124: {
125:   const PetscScalar *lx;
126:   PetscInt           m, bs;

128:   *ierr = VecGetArrayRead(*x, &lx);
129:   if (*ierr) return;
130:   *ierr = VecGetLocalSize(*x, &m);
131:   if (*ierr) return;
132:   bs = 1;
133:   if (VecGetArrayAligned) {
134:     *ierr = VecGetBlockSize(*x, &bs);
135:     if (*ierr) return;
136:   }
137:   *ierr = PetscScalarAddressToFortran((PetscObject)*x, bs, fa, (PetscScalar *)lx, m, ia);
138: }

140: /* Be to keep vec/examples/ex21.F and snes/examples/ex12.F up to date */
141: PETSC_EXTERN void vecrestorearrayread_(Vec *x, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr)
142: {
143:   PetscInt           m;
144:   const PetscScalar *lx;

146:   *ierr = VecGetLocalSize(*x, &m);
147:   if (*ierr) return;
148:   *ierr = PetscScalarAddressFromFortran((PetscObject)*x, fa, *ia, m, (PetscScalar **)&lx);
149:   if (*ierr) return;
150:   *ierr = VecRestoreArrayRead(*x, &lx);
151:   if (*ierr) return;
152: }

154: /*
155:       vecduplicatevecs() and vecdestroyvecs() are slightly different from C since the
156:     Fortran provides the array to hold the vector objects,while in C that
157:     array is allocated by the VecDuplicateVecs()
158: */
159: PETSC_EXTERN void vecduplicatevecs_(Vec *v, PetscInt *m, Vec *newv, PetscErrorCode *ierr)
160: {
161:   Vec     *lV;
162:   PetscInt i;
163:   *ierr = VecDuplicateVecs(*v, *m, &lV);
164:   if (*ierr) return;
165:   for (i = 0; i < *m; i++) newv[i] = lV[i];
166:   *ierr = PetscFree(lV);
167: }

169: PETSC_EXTERN void vecdestroyvecs_(PetscInt *m, Vec *vecs, PetscErrorCode *ierr)
170: {
171:   PetscInt i;
172:   for (i = 0; i < *m; i++) {
173:     *ierr = VecDestroy(&vecs[i]);
174:     if (*ierr) return;
175:   }
176: }

178: PETSC_EXTERN void vecmin1_(Vec *x, PetscInt *p, PetscReal *val, PetscErrorCode *ierr)
179: {
180:   CHKFORTRANNULLINTEGER(p);
181:   *ierr = VecMin(*x, p, val);
182: }

184: PETSC_EXTERN void vecmin2_(Vec *x, PetscInt *p, PetscReal *val, PetscErrorCode *ierr)
185: {
186:   CHKFORTRANNULLINTEGER(p);
187:   *ierr = VecMin(*x, p, val);
188: }

190: PETSC_EXTERN void vecmax1_(Vec *x, PetscInt *p, PetscReal *val, PetscErrorCode *ierr)
191: {
192:   CHKFORTRANNULLINTEGER(p);
193:   *ierr = VecMax(*x, p, val);
194: }

196: PETSC_EXTERN void vecmax2_(Vec *x, PetscInt *p, PetscReal *val, PetscErrorCode *ierr)
197: {
198:   CHKFORTRANNULLINTEGER(p);
199:   *ierr = VecMax(*x, p, val);
200: }

202: PETSC_EXTERN void vecgetownershipranges_(Vec *x, PetscInt *range, PetscErrorCode *ierr)
203: {
204:   PetscMPIInt     size, mpi_ierr;
205:   const PetscInt *r;

207:   mpi_ierr = MPI_Comm_size(PetscObjectComm((PetscObject)*x), &size);
208:   if (mpi_ierr) {
209:     *ierr = PETSC_ERR_MPI;
210:     return;
211:   }
212:   *ierr = VecGetOwnershipRanges(*x, &r);
213:   if (*ierr) return;
214:   *ierr = PetscArraycpy(range, r, size + 1);
215: }