Actual source code: zmatnestf.c

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

      4: #if defined(PETSC_HAVE_FORTRAN_CAPS)
      5:   #define matcreatenest_     MATCREATENEST
      6:   #define matnestsetsubmats_ MATNESTSETSUBMATS
      7:   #define matnestgetsubmats_ MATNESTGETSUBMATS
      8: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
      9:   #define matcreatenest_     matcreatenest
     10:   #define matnestsetsubmats_ matnestsetsubmats
     11:   #define matnestgetsubmats_ matnestgetsubmats
     12: #endif

     14: PETSC_EXTERN void matcreatenest_(MPI_Fint *comm, PetscInt *nr, IS is_row[], PetscInt *nc, IS is_col[], Mat a[], Mat *B, PetscErrorCode *ierr)
     15: {
     16:   Mat     *m, *tmp;
     17:   PetscInt i;

     19:   CHKFORTRANNULLOBJECT(is_row);
     20:   CHKFORTRANNULLOBJECT(is_col);

     22:   *ierr = PetscMalloc1((*nr) * (*nc), &m);
     23:   if (*ierr) return;
     24:   for (i = 0; i < (*nr) * (*nc); i++) {
     25:     tmp = &a[i];
     26:     CHKFORTRANNULLOBJECT(tmp);
     27:     if (a[i] == (Mat)-2 || a[i] == (Mat)-3) {
     28:       (void)PetscError(MPI_Comm_f2c(*comm), __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_MAT for missing blocks");
     29:       *ierr = PETSC_ERR_ARG_WRONG;
     30:       return;
     31:     }
     32:     m[i] = (tmp == NULL ? NULL : a[i]);
     33:   }
     34:   *ierr = MatCreateNest(MPI_Comm_f2c(*comm), *nr, is_row, *nc, is_col, m, B);
     35:   if (*ierr) return;
     36:   *ierr = PetscFree(m);
     37: }

     39: PETSC_EXTERN void matnestsetsubmats_(Mat *B, PetscInt *nr, IS is_row[], PetscInt *nc, IS is_col[], Mat a[], PetscErrorCode *ierr)
     40: {
     41:   Mat     *m, *tmp;
     42:   PetscInt i;
     43:   MPI_Comm comm;

     45:   CHKFORTRANNULLOBJECT(is_row);
     46:   CHKFORTRANNULLOBJECT(is_col);

     48:   *ierr = PetscMalloc1((*nr) * (*nc), &m);
     49:   if (*ierr) return;
     50:   for (i = 0; i < (*nr) * (*nc); i++) {
     51:     tmp = &a[i];
     52:     CHKFORTRANNULLOBJECT(tmp);
     53:     if (a[i] == (Mat)-2 || a[i] == (Mat)-3) {
     54:       *ierr = PetscObjectGetComm((PetscObject)*B, &comm);
     55:       if (*ierr) return;
     56:       (void)PetscError(comm, __LINE__, PETSC_FUNCTION_NAME, __FILE__, PETSC_ERR_ARG_WRONG, PETSC_ERROR_INITIAL, "Use PETSC_NULL_MAT for missing blocks");
     57:       *ierr = PETSC_ERR_ARG_WRONG;
     58:       return;
     59:     }
     60:     m[i] = (tmp == NULL ? NULL : a[i]);
     61:   }
     62:   *ierr = MatNestSetSubMats(*B, *nr, is_row, *nc, is_col, m);
     63:   if (*ierr) return;
     64:   *ierr = PetscFree(m);
     65: }

     67: PETSC_EXTERN void matnestgetsubmats_(Mat *A, PetscInt *M, PetscInt *N, Mat *sub, PetscErrorCode *ierr)
     68: {
     69:   PetscInt i, j, m, n;
     70:   Mat    **mat;

     72:   CHKFORTRANNULLINTEGER(M);
     73:   CHKFORTRANNULLINTEGER(N);
     74:   CHKFORTRANNULLOBJECT(sub);

     76:   *ierr = MatNestGetSubMats(*A, &m, &n, &mat);

     78:   if (M) *M = m;
     79:   if (N) *N = n;
     80:   if (sub) {
     81:     for (i = 0; i < m; i++) {
     82:       for (j = 0; j < n; j++) {
     83:         if (mat[i][j]) {
     84:           sub[j + n * i] = mat[i][j];
     85:         } else {
     86:           sub[j + n * i] = (Mat)-1;
     87:         }
     88:       }
     89:     }
     90:   }
     91: }