Date: 2025-03-28T21:11:22+00:00

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: }