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