Actual source code: ex1f.F90
petsc-3.12.1 2019-10-22
1: !
2: !
3: ! Formatted test for IS general routines
4: !
5: program main
6: #include <petsc/finclude/petscis.h>
7: use petscis
8: implicit none
10: PetscErrorCode ierr
11: PetscInt i,n,indices(1000),ii(1)
12: PetscMPIInt size,rank
13: PetscOffset iis
14: IS is,newis
15: PetscBool flag
17: call PetscInitialize(PETSC_NULL_CHARACTER,ierr)
18: if (ierr .ne. 0) then
19: print*,'Unable to initialize PETSc'
20: stop
21: endif
22: call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr)
23: call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr)
25: ! Test IS of size 0
27: n = 0
28: call ISCreateGeneral(PETSC_COMM_SELF,n,indices,PETSC_COPY_VALUES,is,ierr);CHKERRA(ierr);
29: call ISGetLocalSize(is,n,ierr);CHKERRA(ierr);
30: if (n .ne. 0) then; SETERRA(PETSC_COMM_SELF,1,'Error getting size of zero IS'); endif
31: call ISDestroy(is,ierr)
34: ! Create large IS and test ISGetIndices(,ierr)
35: ! fortran indices start from 1 - but IS indices start from 0
36: n = 1000
37: do 10, i=1,n
38: indices(i) = i-1
39: 10 continue
40: call ISCreateGeneral(PETSC_COMM_SELF,n,indices,PETSC_COPY_VALUES,is,ierr);CHKERRA(ierr)
41: call ISGetIndices(is,ii,iis,ierr);CHKERRA(ierr)
42: do 20, i=1,n
43: if (ii(i+iis) .ne. indices(i)) then; SETERRA(PETSC_COMM_SELF,1,'Error getting indices'); endif
44: 20 continue
45: call ISRestoreIndices(is,ii,iis,ierr);CHKERRA(ierr)
47: ! Check identity and permutation
49: call ISPermutation(is,flag,ierr);CHKERRA(ierr)
50: if (flag) then; SETERRA(PETSC_COMM_SELF,1,'Error checking permutation'); endif
51: call ISIdentity(is,flag,ierr);CHKERRA(ierr)
52: if (.not. flag) then; SETERRA(PETSC_COMM_SELF,1,'Error checking identity'); endif
53: call ISSetPermutation(is,ierr);CHKERRA(ierr)
54: call ISSetIdentity(is,ierr);CHKERRA(ierr)
55: call ISPermutation(is,flag,ierr);CHKERRA(ierr)
56: if (.not. flag) then; SETERRA(PETSC_COMM_SELF,1,'Error checking permutation second time'); endif
57: call ISIdentity(is,flag,ierr);CHKERRA(ierr)
58: if (.not. flag) then; SETERRA(PETSC_COMM_SELF,1,'Error checking identity second time'); endif
60: ! Check equality of index sets
62: call ISEqual(is,is,flag,ierr);CHKERRA(ierr)
63: if (.not. flag) then; SETERRA(PETSC_COMM_SELF,1,'Error checking equal'); endif
65: ! Sorting
67: call ISSort(is,ierr);CHKERRA(ierr)
68: call ISSorted(is,flag,ierr);CHKERRA(ierr)
69: if (.not. flag) then; SETERRA(PETSC_COMM_SELF,1,'Error checking sorted'); endif
71: ! Thinks it is a different type?
73: call PetscObjectTypeCompare(is,ISSTRIDE,flag,ierr);CHKERRA(ierr)
74: if (flag) then; SETERRA(PETSC_COMM_SELF,1,'Error checking stride'); endif
75: call PetscObjectTypeCompare(is,ISBLOCK,flag,ierr);CHKERRA(ierr)
76: if (flag) then; SETERRA(PETSC_COMM_SELF,1,'Error checking block'); endif
78: call ISDestroy(is,ierr);CHKERRA(ierr)
80: ! Inverting permutation
82: do 30, i=1,n
83: indices(i) = n - i
84: 30 continue
86: call ISCreateGeneral(PETSC_COMM_SELF,n,indices,PETSC_COPY_VALUES,is,ierr);CHKERRA(ierr)
87: call ISSetPermutation(is,ierr);CHKERRA(ierr)
88: call ISInvertPermutation(is,PETSC_DECIDE,newis,ierr);CHKERRA(ierr)
89: call ISGetIndices(newis,ii,iis,ierr);CHKERRA(ierr)
90: do 40, i=1,n
91: if (ii(iis+i) .ne. n - i) then; SETERRA(PETSC_COMM_SELF,1,'Error getting permutation indices'); endif
92: 40 continue
93: call ISRestoreIndices(newis,ii,iis,ierr);CHKERRA(ierr)
94: call ISDestroy(newis,ierr);CHKERRA(ierr)
95: call ISDestroy(is,ierr);CHKERRA(ierr)
96: call PetscFinalize(ierr)
97: end
99: !/*TEST
100: !
101: ! test:
102: ! output_file: output/ex1_1.out
103: !
104: !TEST*/