Actual source code: ex10f.F90
1: ! Tests array outputs, omitted arguments and error returns in the PCASM Fortran bindings.
2: #include <petsc/finclude/petscksp.h>
3: program main
4: use petscksp
5: implicit none
7: Mat A, saved_null_mat
8: Mat, target :: matrix_target(1)
9: Mat, pointer :: submatrices(:) => null(), saved_mat_pointer(:)
10: IS, pointer :: subdomains(:) => null(), inner(:) => null(), saved_is_pointer(:)
11: IS saved_null_is
12: IS, target :: explicit_outer(1), explicit_inner(1)
13: KSP, pointer :: ksps(:) => null(), saved_ksp_pointer(:)
14: KSP saved_null_ksp
15: PC pc
16: PetscInt i, nsub, first_sub, m, n, imin, imax, saved_null_integer
17: PetscInt, parameter :: nrows = 4
18: PetscScalar, parameter :: one = 1
19: PetscScalar value(1)
20: PetscErrorCode ierr, expected_error, second_error
21: character(len=16) :: test_case = 'create'
23: PetscCallA(PetscInitialize(ierr))
24: saved_mat_pointer => PETSC_NULL_MAT_POINTER
25: saved_is_pointer => PETSC_NULL_IS_POINTER
26: saved_ksp_pointer => PETSC_NULL_KSP_POINTER
27: saved_null_mat = PETSC_NULL_MAT_ARRAY(1)
28: saved_null_is = PETSC_NULL_IS_ARRAY(1)
29: saved_null_ksp = PETSC_NULL_KSP_ARRAY(1)
30: saved_null_integer = PETSC_NULL_INTEGER
31: call CheckNullOutputs()
32: PetscCallA(PetscOptionsGetString(PETSC_NULL_OPTIONS, PETSC_NULL_CHARACTER, '-case', test_case, PETSC_NULL_BOOL, ierr))
33: PetscCallA(MatCreateSeqAIJ(PETSC_COMM_SELF, nrows, nrows, 1_PETSC_INT_KIND, PETSC_NULL_INTEGER_ARRAY, A, ierr))
34: do i = 0, nrows - 1
35: PetscCallA(MatSetValue(A, i, i, one, INSERT_VALUES, ierr))
36: end do
37: PetscCallA(MatAssemblyBegin(A, MAT_FINAL_ASSEMBLY, ierr))
38: PetscCallA(MatAssemblyEnd(A, MAT_FINAL_ASSEMBLY, ierr))
39: matrix_target(1) = A
40: PetscCallA(PCCreate(PETSC_COMM_SELF, pc, ierr))
41: PetscCallA(PCSetOperators(pc, A, A, ierr))
42: PetscCallA(PCSetType(pc, PCASM, ierr))
43: PetscCallA(PCASMSetOverlap(pc, 0_PETSC_INT_KIND, ierr))
44: PetscCallA(PCSetUp(pc, ierr))
45: nsub = -1
46: select case (trim(test_case))
47: case ('create')
48: nsub = 1
49: PetscCallA(PCASMCreateSubdomains(A, nsub, subdomains, ierr))
50: case ('create_null')
51: nsub = 1
52: PetscCallA(PetscPushErrorHandler(ReturnError, PETSC_NULL_INTEGER, ierr))
53: call PCASMCreateSubdomains(A, nsub, PETSC_NULL_IS_POINTER, expected_error)
54: call PCASMDestroySubdomains(nsub, PETSC_NULL_IS_POINTER, PETSC_NULL_IS_POINTER, second_error)
55: PetscCallA(PetscPopErrorHandler(ierr))
56: PetscCheckA(expected_error == PETSC_ERR_ARG_NULL, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Creation accepted an omitted required output')
57: PetscCheckA(second_error == PETSC_ERR_ARG_NULL, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Destruction accepted an omitted required array')
58: call CheckNullOutputs()
59: ! Creation returns no inner IS array, so omit it when destroying.
60: PetscCallA(PCASMCreateSubdomains(A, nsub, subdomains, ierr))
61: PetscCallA(PCASMDestroySubdomains(nsub, subdomains, PETSC_NULL_IS_POINTER, ierr))
62: call CheckNullOutputs()
63: case ('create2d')
64: ! PCASMCreateSubdomains2D() always creates both arrays, so neither may be omitted.
65: PetscCallA(PetscPushErrorHandler(ReturnError, PETSC_NULL_INTEGER, ierr))
66: call PCASMCreateSubdomains2D(2_PETSC_INT_KIND, 2_PETSC_INT_KIND, 1_PETSC_INT_KIND, 1_PETSC_INT_KIND, 1_PETSC_INT_KIND, 0_PETSC_INT_KIND, nsub, subdomains, PETSC_NULL_IS_POINTER, expected_error)
67: call PCASMCreateSubdomains2D(2_PETSC_INT_KIND, 2_PETSC_INT_KIND, 1_PETSC_INT_KIND, 1_PETSC_INT_KIND, 1_PETSC_INT_KIND, 0_PETSC_INT_KIND, nsub, PETSC_NULL_IS_POINTER, inner, second_error)
68: PetscCallA(PetscPopErrorHandler(ierr))
69: PetscCheckA(expected_error == PETSC_ERR_ARG_NULL .and. second_error == PETSC_ERR_ARG_NULL, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'PCASMCreateSubdomains2D() accepted an omitted output')
70: PetscCheckA(.not. associated(subdomains) .and. .not. associated(inner), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'A rejected PCASMCreateSubdomains2D() associated its output')
71: call CheckNullOutputs()
72: PetscCallA(PCASMCreateSubdomains2D(2_PETSC_INT_KIND, 2_PETSC_INT_KIND, 1_PETSC_INT_KIND, 1_PETSC_INT_KIND, 1_PETSC_INT_KIND, 0_PETSC_INT_KIND, nsub, subdomains, inner, ierr))
73: PetscCheckA(associated(inner), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'PCASMCreateSubdomains2D() left the inner output disassociated')
74: PetscCheckA(size(inner) == 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong inner subdomain array extent')
75: case ('subksp')
76: first_sub = -1
77: PetscCallA(PCASMGetSubKSP(pc, nsub, first_sub, PETSC_NULL_KSP_POINTER, ierr))
78: call CheckNullOutputs()
79: PetscCheckA(first_sub == 0, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Omitting the KSP array lost the first block')
80: PetscCallA(PCASMRestoreSubKSP(pc, nsub, first_sub, PETSC_NULL_KSP_POINTER, ierr))
81: call CheckNullOutputs()
82: PetscCallA(PCASMGetSubKSP(pc, PETSC_NULL_INTEGER, PETSC_NULL_INTEGER, ksps, ierr))
83: PetscCheckA(associated(ksps), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'PCASMGetSubKSP() left the output disassociated')
84: PetscCheckA(size(ksps) == 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong KSP array extent')
85: PetscCallA(PCASMRestoreSubKSP(pc, PETSC_NULL_INTEGER, PETSC_NULL_INTEGER, ksps, ierr))
86: call CheckNullOutputs()
87: case ('subdomains')
88: PetscCallA(PCASMGetLocalSubdomains(pc, nsub, subdomains, inner, ierr))
89: PetscCheckA(.not. associated(inner), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Expected no inner subdomain array for one block')
90: case ('submatrices')
91: PetscCallA(PCASMGetLocalSubmatrices(pc, nsub, submatrices, ierr))
92: PetscCheckA(associated(submatrices), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'PCASMGetLocalSubmatrices() left the output disassociated')
93: PetscCheckA(size(submatrices) == 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong submatrix array extent')
94: PetscCallA(MatGetSize(submatrices(1), m, n, ierr))
95: PetscCheckA(m == nrows .and. n == nrows, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong submatrix dimensions')
96: PetscCallA(MatGetValues(submatrices(1), 1_PETSC_INT_KIND, [0_PETSC_INT_KIND], 1_PETSC_INT_KIND, [0_PETSC_INT_KIND], value, ierr))
97: PetscCheckA(value(1) == one, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong submatrix value')
98: case default
99: SETERRA(PETSC_COMM_SELF, PETSC_ERR_ARG_WRONG, 'Unknown -case value')
100: end select
101: PetscCheckA(nsub == 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Expected exactly one subdomain')
102: if (test_case == 'create' .or. test_case == 'create2d' .or. test_case == 'subdomains') then
103: PetscCheckA(associated(subdomains), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'PCASM left the subdomain output disassociated')
104: PetscCheckA(size(subdomains) == 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong subdomain array extent')
105: PetscCallA(ISGetSize(subdomains(1), n, ierr))
106: PetscCallA(ISGetMinMax(subdomains(1), imin, imax, ierr))
107: PetscCheckA(n == nrows .and. imin == 0 .and. imax == nrows - 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong subdomain indices')
108: end if
109: select case (trim(test_case))
110: case ('submatrices')
111: nullify (submatrices)
112: PetscCallA(PCASMGetLocalSubmatrices(pc, PETSC_NULL_INTEGER, submatrices, ierr))
113: call CheckNullOutputs()
114: PetscCheckA(associated(submatrices), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Omitting the count lost the submatrix output')
115: PetscCheckA(size(submatrices) == 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong submatrix extent with omitted count')
116: nsub = -1
117: PetscCallA(PCASMGetLocalSubmatrices(pc, nsub, PETSC_NULL_MAT_POINTER, ierr))
118: call CheckNullOutputs()
119: PetscCheckA(nsub == 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Omitting matrices lost the count')
120: PetscCallA(PCASMGetLocalSubmatrices(pc, PETSC_NULL_INTEGER, PETSC_NULL_MAT_POINTER, ierr))
121: call CheckNullOutputs()
122: ! Before setup, both getters must return the C error and leave their outputs untouched.
123: nullify (submatrices)
124: PetscCallA(PCSetType(pc, PCNONE, ierr))
125: PetscCallA(PCSetType(pc, PCASM, ierr))
126: nsub = -1
127: first_sub = -1
128: PetscCallA(PetscPushErrorHandler(ReturnError, PETSC_NULL_INTEGER, ierr))
129: call PCASMGetLocalSubmatrices(pc, nsub, submatrices, expected_error)
130: call PCASMGetSubKSP(pc, nsub, first_sub, ksps, second_error)
131: PetscCallA(PetscPopErrorHandler(ierr))
132: PetscCheckA(expected_error == PETSC_ERR_ARG_WRONGSTATE, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'PCASMGetLocalSubmatrices() lost the error before setup')
133: PetscCheckA(second_error == PETSC_ERR_ORDER, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'PCASMGetSubKSP() lost the error before setup')
134: PetscCheckA(nsub == -1 .and. first_sub == -1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'A failed getter changed its counts')
135: PetscCheckA(.not. associated(submatrices) .and. .not. associated(ksps), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'A failed getter associated its output')
136: call CheckNullOutputs()
137: PetscCallA(PCSetType(pc, PCNONE, ierr))
138: PetscCallA(PCSetUp(pc, ierr))
139: submatrices => matrix_target
140: PetscCallA(PCASMGetLocalSubmatrices(pc, nsub, submatrices, ierr))
141: PetscCheckA(nsub == 0 .and. .not. associated(submatrices), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Empty matrix output retained an old association')
142: case ('subdomains')
143: inner => PETSC_NULL_IS_ARRAY
144: PetscCallA(PCASMGetLocalSubdomains(pc, PETSC_NULL_INTEGER, PETSC_NULL_IS_POINTER, inner, ierr))
145: call CheckNullOutputs()
146: PetscCheckA(.not. associated(inner), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Absent inner IS array retained an old association')
147: nullify (subdomains, inner)
148: PetscCallA(PCSetType(pc, PCNONE, ierr))
149: PetscCallA(PCSetType(pc, PCASM, ierr))
150: ! Before setup, neither IS array exists. Ordinary pointers may alias the null arrays.
151: subdomains => PETSC_NULL_IS_ARRAY
152: inner => PETSC_NULL_IS_ARRAY
153: PetscCallA(PCASMGetLocalSubdomains(pc, nsub, subdomains, inner, ierr))
154: PetscCheckA(.not. associated(subdomains) .and. .not. associated(inner), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Absent IS outputs retained old associations')
155: call CheckNullOutputs()
156: PetscCallA(ISCreateStride(PETSC_COMM_SELF, nrows, 0_PETSC_INT_KIND, 1_PETSC_INT_KIND, explicit_outer(1), ierr))
157: PetscCallA(ISCreateStride(PETSC_COMM_SELF, 2_PETSC_INT_KIND, 0_PETSC_INT_KIND, 1_PETSC_INT_KIND, explicit_inner(1), ierr))
158: PetscCallA(PCASMSetLocalSubdomains(pc, 1_PETSC_INT_KIND, explicit_outer, explicit_inner, ierr))
159: nsub = -1
160: PetscCallA(PCASMGetLocalSubdomains(pc, nsub, PETSC_NULL_IS_POINTER, PETSC_NULL_IS_POINTER, ierr))
161: call CheckNullOutputs()
162: PetscCheckA(nsub == 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Omitting IS arrays lost the count')
163: PetscCallA(PCASMGetLocalSubdomains(pc, PETSC_NULL_INTEGER, PETSC_NULL_IS_POINTER, PETSC_NULL_IS_POINTER, ierr))
164: call CheckNullOutputs()
165: ! Omit the count, then each array independently, using fresh output descriptors.
166: do i = 1, 3
167: nullify (subdomains, inner)
168: if (i == 1) then
169: PetscCallA(PCASMGetLocalSubdomains(pc, PETSC_NULL_INTEGER, subdomains, inner, ierr))
170: else if (i == 2) then
171: PetscCallA(PCASMGetLocalSubdomains(pc, PETSC_NULL_INTEGER, subdomains, PETSC_NULL_IS_POINTER, ierr))
172: else
173: PetscCallA(PCASMGetLocalSubdomains(pc, PETSC_NULL_INTEGER, PETSC_NULL_IS_POINTER, inner, ierr))
174: end if
175: call CheckNullOutputs()
176: if (i /= 3) then
177: PetscCheckA(associated(subdomains), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Omitted arguments lost the outer IS array')
178: PetscCheckA(size(subdomains) == 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong outer IS array extent')
179: PetscCheckA(subdomains(1) == explicit_outer(1), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong outer IS returned')
180: end if
181: if (i /= 2) then
182: PetscCheckA(associated(inner), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Omitted arguments lost the inner IS array')
183: PetscCheckA(size(inner) == 1, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong inner IS array extent')
184: PetscCheckA(inner(1) == explicit_inner(1), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Wrong inner IS returned')
185: end if
186: end do
187: PetscCallA(ISDestroy(explicit_outer(1), ierr))
188: PetscCallA(ISDestroy(explicit_inner(1), ierr))
189: end select
190: if (test_case == 'create' .or. test_case == 'create2d') then
191: PetscCallA(PCASMDestroySubdomains(nsub, subdomains, inner, ierr))
192: end if
193: ! Getter outputs are borrowed from pc; only the create cases own their arrays.
194: nullify (subdomains, inner, submatrices)
195: PetscCallA(PCDestroy(pc, ierr))
196: PetscCallA(MatDestroy(A, ierr))
197: call CheckNullOutputs()
198: PetscCallA(PetscFinalize(ierr))
200: contains
202: subroutine ReturnError(comm, line, fun, file, n, p, mess, ctx, ierr)
203: MPIU_Comm comm
204: integer line, p
205: character(*) fun, file, mess
206: PetscInt ctx
207: PetscErrorCode n, ierr
209: ierr = n
210: end subroutine
212: subroutine CheckNullOutputs()
213: PetscCheckA(associated(PETSC_NULL_MAT_POINTER) .eqv. associated(saved_mat_pointer), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Changed null Mat association')
214: if (associated(saved_mat_pointer)) then
215: PetscCheckA(associated(PETSC_NULL_MAT_POINTER, saved_mat_pointer), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Changed null Mat target')
216: end if
217: PetscCheckA(associated(PETSC_NULL_IS_POINTER) .eqv. associated(saved_is_pointer), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Changed null IS association')
218: if (associated(saved_is_pointer)) then
219: PetscCheckA(associated(PETSC_NULL_IS_POINTER, saved_is_pointer), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Changed null IS target')
220: end if
221: PetscCheckA(associated(PETSC_NULL_KSP_POINTER) .eqv. associated(saved_ksp_pointer), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Changed null KSP association')
222: if (associated(saved_ksp_pointer)) then
223: PetscCheckA(associated(PETSC_NULL_KSP_POINTER, saved_ksp_pointer), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Changed null KSP target')
224: end if
225: PetscCheckA(PETSC_NULL_MAT_ARRAY(1) == saved_null_mat, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Changed null Mat target')
226: PetscCheckA(PETSC_NULL_IS_ARRAY(1) == saved_null_is, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Changed null IS target')
227: PetscCheckA(PETSC_NULL_KSP_ARRAY(1) == saved_null_ksp, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Changed null KSP target')
228: PetscCheckA(PETSC_NULL_INTEGER == saved_null_integer, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Changed null integer')
229: end subroutine
230: end program
232: !/*TEST
233: !
234: ! testset:
235: ! nsize: 1
236: ! output_file: output/empty.out
237: !
238: ! test:
239: ! suffix: create
240: ! args: -case create
241: ! test:
242: ! suffix: create_null
243: ! args: -case create_null
244: ! test:
245: ! suffix: create2d
246: ! args: -case create2d
247: ! test:
248: ! suffix: subksp
249: ! args: -case subksp
250: ! test:
251: ! suffix: submatrices
252: ! args: -case submatrices
253: ! test:
254: ! suffix: subdomains
255: ! args: -case subdomains
256: !
257: !TEST*/