Actual source code: ex1f.F90

  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(1004)
 12:   PetscInt, pointer :: ii(:)
 13:   PetscMPIInt size, rank
 14:   IS is, newis
 15:   PetscBool flag, compute, permanent

 17:   PetscCallA(PetscInitialize(ierr))
 18:   PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr))
 19:   PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD, size, ierr))

 21: !     Test IS of size 0

 23:   n = 0
 24:   PetscCallA(ISCreateGeneral(PETSC_COMM_SELF, n, indices, PETSC_COPY_VALUES, is, ierr))
 25:   PetscCallA(ISGetLocalSize(is, n, ierr))
 26:   PetscCheckA(n == 0, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error getting size of zero IS')
 27:   PetscCallA(ISDestroy(is, ierr))

 29: !     Create large IS and test ISGetIndices(,ierr))
 30: !     fortran indices start from 1 - but IS indices start from 0
 31:   n = 1000 + rank
 32:   do 10, i = 1, n
 33:     indices(i) = rank + i - 1
 34: 10  continue
 35:     PetscCallA(ISCreateGeneral(PETSC_COMM_SELF, n, indices, PETSC_COPY_VALUES, is, ierr))
 36:     PetscCallA(ISGetIndices(is, ii, ierr))
 37:     do 20, i = 1, n
 38:       PetscCheckA(ii(i) == indices(i), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error getting indices')
 39: 20    continue
 40:       PetscCallA(ISRestoreIndices(is, ii, ierr))

 42: !     Check identity and permutation

 44:       compute = PETSC_TRUE
 45:       permanent = PETSC_FALSE
 46:       PetscCallA(ISPermutation(is, flag, ierr))
 47:       PetscCheckA(.not. flag, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error checking permutation')
 48:       PetscCallA(ISGetInfo(is, IS_PERMUTATION, IS_LOCAL, compute, flag, ierr))
 49:       PetscCallA(ISIdentity(is, flag, ierr))
 50:       PetscCheckA((rank /= 0) .or. flag, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error checking identity')
 51:       PetscCheckA((rank == 0) .or. (.not. flag), PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error checking identity')
 52:       PetscCallA(ISSetInfo(is, IS_PERMUTATION, IS_LOCAL, permanent, PETSC_TRUE, ierr))
 53:       PetscCallA(ISSetInfo(is, IS_IDENTITY, IS_LOCAL, permanent, PETSC_TRUE, ierr))
 54:       PetscCallA(ISGetInfo(is, IS_PERMUTATION, IS_LOCAL, compute, flag, ierr))
 55:       PetscCheckA(flag, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error checking permutation second time')
 56:       PetscCallA(ISGetInfo(is, IS_IDENTITY, IS_LOCAL, compute, flag, ierr))
 57:       PetscCheckA(flag, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error checking identity second time')
 58:       PetscCallA(ISClearInfoCache(is, PETSC_TRUE, ierr))

 60: !     Check equality of index sets

 62:       PetscCallA(ISEqual(is, is, flag, ierr))
 63:       PetscCheckA(flag, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error checking equal')

 65: !     Sorting

 67:       PetscCallA(ISSort(is, ierr))
 68:       PetscCallA(ISSorted(is, flag, ierr))
 69:       PetscCheckA(flag, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error checking sorted')

 71: !     Thinks it is a different type?

 73:       PetscCallA(PetscObjectTypeCompare(is, ISSTRIDE, flag, ierr))
 74:       PetscCheckA(.not. flag, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error checking stride')
 75:       PetscCallA(PetscObjectTypeCompare(is, ISBLOCK, flag, ierr))
 76:       PetscCheckA(.not. flag, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error checking block')

 78:       PetscCallA(ISDestroy(is, ierr))

 80: !     Inverting permutation

 82:       do 30, i = 1, n
 83:         indices(i) = n - i
 84: 30      continue

 86:         PetscCallA(ISCreateGeneral(PETSC_COMM_SELF, n, indices, PETSC_COPY_VALUES, is, ierr))
 87:         PetscCallA(ISSetPermutation(is, ierr))
 88:         PetscCallA(ISInvertPermutation(is, PETSC_DECIDE, newis, ierr))
 89:         PetscCallA(ISGetIndices(newis, ii, ierr))
 90:         do 40, i = 1, n
 91:           PetscCheckA(ii(i) == n - i, PETSC_COMM_SELF, PETSC_ERR_PLIB, 'Error getting permutation indices')
 92: 40        continue
 93:           PetscCallA(ISRestoreIndices(newis, ii, ierr))
 94:           PetscCallA(ISDestroy(newis, ierr))
 95:           PetscCallA(ISDestroy(is, ierr))
 96:           PetscCallA(PetscFinalize(ierr))
 97:         end

 99: !/*TEST
100: !
101: !   test:
102: !     nsize: {{1 2 3 4 5}}
103: !     output_file: output/empty.out
104: !
105: !TEST*/