Actual source code: ex1f.F90

petsc-3.13.4 2020-08-01
Report Typos and Errors
  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),ii(1)
 12:        PetscMPIInt size,rank
 13:        PetscOffset iis
 14:        IS          is,newis
 15:        PetscBool   flag,compute,permanent

 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,PETSC_ERR_PLIB,'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 + rank
 37:       do 10, i=1,n
 38:         indices(i) = rank + 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,PETSC_ERR_PLIB,'Error getting indices'); endif
 44:  20   continue
 45:       call ISRestoreIndices(is,ii,iis,ierr);CHKERRA(ierr)

 47: !     Check identity and permutation

 49:       compute = PETSC_TRUE
 50:       permanent = PETSC_FALSE
 51:       call ISPermutation(is,flag,ierr);CHKERRA(ierr)
 52:       if (flag) then; SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,'Error checking permutation'); endif
 53:       call ISGetInfo(is,IS_PERMUTATION,IS_LOCAL,compute,flag,ierr);CHKERRA(ierr)
 54:       !if ((rank .eq. 0) .and. (.not. flag)) SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,"ISGetInfo(IS_PERMUTATION,IS_LOCAL)")
 55:       !if (rank .eq. 0 .and. flag) SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,"ISGetInfo(IS_PERMUTATION,IS_LOCAL)")
 56:       call ISIdentity(is,flag,ierr);CHKERRA(ierr)
 57:       if ((rank .eq. 0) .and. (.not. flag)) then; SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,'Error checking identity'); endif
 58:       if ((rank .ne. 0) .and. flag) then; SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,'Error checking identity'); endif
 59:       call ISSetInfo(is,IS_PERMUTATION,IS_LOCAL,permanent,PETSC_TRUE,ierr);CHKERRA(ierr)
 60:       call ISSetInfo(is,IS_IDENTITY,IS_LOCAL,permanent,PETSC_TRUE,ierr);CHKERRA(ierr)
 61:       call ISGetInfo(is,IS_PERMUTATION,IS_LOCAL,compute,flag,ierr);CHKERRA(ierr)
 62:       if (.not. flag) then; SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,'Error checking permutation second time'); endif
 63:       call ISGetInfo(is,IS_IDENTITY,IS_LOCAL,compute,flag,ierr);CHKERRA(ierr)
 64:       if (.not. flag) then; SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,'Error checking identity second time'); endif
 65:       call ISClearInfoCache(is,PETSC_TRUE,ierr);CHKERRA(ierr)

 67: !     Check equality of index sets

 69:       call ISEqual(is,is,flag,ierr);CHKERRA(ierr)
 70:       if (.not. flag) then; SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,'Error checking equal'); endif

 72: !     Sorting

 74:       call ISSort(is,ierr);CHKERRA(ierr)
 75:       call ISSorted(is,flag,ierr);CHKERRA(ierr)
 76:       if (.not. flag) then; SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,'Error checking sorted'); endif

 78: !     Thinks it is a different type?

 80:       call PetscObjectTypeCompare(is,ISSTRIDE,flag,ierr);CHKERRA(ierr)
 81:       if (flag) then; SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,'Error checking stride'); endif
 82:       call PetscObjectTypeCompare(is,ISBLOCK,flag,ierr);CHKERRA(ierr)
 83:       if (flag) then; SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,'Error checking block'); endif

 85:       call ISDestroy(is,ierr);CHKERRA(ierr)

 87: !     Inverting permutation

 89:       do 30, i=1,n
 90:         indices(i) = n - i
 91:  30   continue

 93:       call ISCreateGeneral(PETSC_COMM_SELF,n,indices,PETSC_COPY_VALUES,is,ierr);CHKERRA(ierr)
 94:       call ISSetPermutation(is,ierr);CHKERRA(ierr)
 95:       call ISInvertPermutation(is,PETSC_DECIDE,newis,ierr);CHKERRA(ierr)
 96:       call ISGetIndices(newis,ii,iis,ierr);CHKERRA(ierr)
 97:       do 40, i=1,n
 98:         if (ii(iis+i) .ne. n - i) then; SETERRA(PETSC_COMM_SELF,PETSC_ERR_PLIB,'Error getting permutation indices'); endif
 99:  40   continue
100:       call ISRestoreIndices(newis,ii,iis,ierr);CHKERRA(ierr)
101:       call ISDestroy(newis,ierr);CHKERRA(ierr)
102:       call ISDestroy(is,ierr);CHKERRA(ierr)
103:       call PetscFinalize(ierr)
104:       end

106: !/*TEST
107: !
108: !   test:
109: !     nsize: {{1 2 3 4 5}}
110: !     output_file: output/ex1_1.out
111: !
112: !TEST*/