Actual source code: ex1f.F
petsc-3.4.2 2013-07-02
1: !
2: !
3: ! Formatted test for IS general routines
4: !
5: program main
6: implicit none
7: #include <finclude/petscsys.h>
8: #include <finclude/petscis.h>
11: PetscErrorCode ierr
12: PetscInt i,n,indices(1000),ii(1)
13: PetscMPIInt size,rank
14: PetscOffset iis
15: IS is,newis
16: PetscBool flag
18: call PetscInitialize(PETSC_NULL_CHARACTER,ierr)
19: CHKERRQ(ierr)
20: call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr)
21: call MPI_Comm_size(PETSC_COMM_WORLD,size,ierr)
23: ! Test IS of size 0
25: n = 0
26: call ISCreateGeneral(PETSC_COMM_SELF,n,indices,PETSC_COPY_VALUES, &
27: & is,ierr)
28: CHKERRQ(ierr)
29: call ISGetLocalSize(is,n,ierr)
30: CHKERRQ(ierr)
31: if (n .ne. 0) then
32: print*, 'Error getting size of zero IS'
33: stop
34: endif
35: call ISDestroy(is,ierr)
38: ! Create large IS and test ISGetIndices(,ierr)
39: ! fortran indices start from 1 - but IS indices start from 0
40: n = 1000
41: do 10, i=1,n
42: indices(i) = i-1
43: 10 continue
44: call ISCreateGeneral(PETSC_COMM_SELF,n,indices,PETSC_COPY_VALUES, &
45: & is,ierr)
46: CHKERRQ(ierr)
47: call ISGetIndices(is,ii,iis,ierr)
48: CHKERRQ(ierr)
49: do 20, i=1,n
50: if (ii(i+iis) .ne. indices(i)) then
51: print*, 'Error getting indices'
52: stop
53: endif
54: 20 continue
55: call ISRestoreIndices(is,ii,iis,ierr)
56: CHKERRQ(ierr)
58: ! Check identity and permutation
60: call ISPermutation(is,flag,ierr)
61: CHKERRQ(ierr)
62: if (flag) then
63: print*, 'Error checking permutation'
64: stop
65: endif
66: call ISIdentity(is,flag,ierr)
67: CHKERRQ(ierr)
68: if (.not. flag) then
69: print*, 'Error checking identity'
70: stop
71: endif
72: call ISSetPermutation(is,ierr)
73: CHKERRQ(ierr)
74: call ISSetIdentity(is,ierr)
75: CHKERRQ(ierr)
76: call ISPermutation(is,flag,ierr)
77: CHKERRQ(ierr)
78: if (.not. flag) then
79: print*, 'Error checking permutation second time'
80: stop
81: endif
82: call ISIdentity(is,flag,ierr)
83: CHKERRQ(ierr)
84: if (.not. flag) then
85: print*, 'Error checking identity second time'
86: stop
87: endif
89: ! Check equality of index sets
91: call ISEqual(is,is,flag,ierr)
92: CHKERRQ(ierr)
93: if (.not. flag) then
94: print*, 'Error checking equal'
95: stop
96: endif
98: ! Sorting
100: call ISSort(is,ierr)
101: CHKERRQ(ierr)
102: call ISSorted(is,flag,ierr)
103: CHKERRQ(ierr)
104: if (.not. flag) then
105: print*, 'Error checking sorted'
106: stop
107: endif
109: ! Thinks it is a different type?
111: call PetscObjectTypeCompare(is,ISSTRIDE,flag,ierr)
112: CHKERRQ(ierr)
113: if (flag) then
114: print*, 'Error checking stride'
115: stop
116: endif
117: call PetscObjectTypeCompare(is,ISBLOCK,flag,ierr)
118: CHKERRQ(ierr)
119: if (flag) then
120: print*, 'Error checking block'
121: stop
122: endif
124: call ISDestroy(is,ierr)
125: CHKERRQ(ierr)
127: ! Inverting permutation
129: do 30, i=1,n
130: indices(i) = n - i
131: 30 continue
133: call ISCreateGeneral(PETSC_COMM_SELF,n,indices,PETSC_COPY_VALUES, &
134: & is,ierr)
135: CHKERRQ(ierr)
136: call ISSetPermutation(is,ierr)
137: CHKERRQ(ierr)
138: call ISInvertPermutation(is,PETSC_DECIDE,newis,ierr)
139: CHKERRQ(ierr)
140: call ISGetIndices(newis,ii,iis,ierr)
141: CHKERRQ(ierr)
142: do 40, i=1,n
143: if (ii(iis+i) .ne. n - i) then
144: print*, 'Error getting permutation indices'
145: stop
146: endif
147: 40 continue
148: call ISRestoreIndices(newis,ii,iis,ierr)
149: CHKERRQ(ierr)
150: call ISDestroy(newis,ierr)
151: CHKERRQ(ierr)
152: call ISDestroy(is,ierr)
153: CHKERRQ(ierr)
154: call PetscFinalize(ierr)
155: end