Actual source code: ex1f.F90
petsc-3.12.4 2020-02-04
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(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*/