1: !    Description: A star forest is a simple tree with one root and zero or more leaves.
  2: !    Many common communication patterns can be expressed as updates of rootdata using leafdata and vice-versa.
  3: !     This example creates a star forest, communicates values using the graph  views the graph, then destroys it.
  4: !
  5: !     This is a copy of ex1.c but currently only tests the broadcast operation
  6: #include <petsc/finclude/petscvec.h>
  7: program main
  8:   use petscvec
  9:   implicit none

 11:   PetscErrorCode ierr
 12:   PetscInt i, nroots, nrootsalloc, nleaves, nleavesalloc, mine(6)
 13:   PetscInt, parameter :: stride = 2
 14:   PetscSFNode remote(6)
 15:   PetscMPIInt rank, size
 16:   PetscSF sf
 17:   PetscInt rootdata(6), leafdata(6)
 18:   PetscBool rootbool(6), leafbool(6)

 20: ! used with PetscSFGetGraph()
 21:   PetscSFNode, pointer ::       gremote(:)
 22:   PetscInt, pointer ::          gmine(:)
 23:   PetscInt gnroots, gnleaves

 25:   PetscMPIInt niranks, nranks
 26:   PetscMPIInt, pointer ::       iranks(:), ranks(:)
 27:   PetscInt, pointer ::          ioffset(:), irootloc(:), roffset(:), rmine(:), rremote(:)

 29:   PetscCallA(PetscInitialize(ierr))
 30:   PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD, rank, ierr))
 31:   PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD, size, ierr))

 33:   nroots = merge(3, 2, rank == 0)
 34:   nrootsalloc = nroots*stride
 35:   nleaves = merge(2, 3, rank == 0)
 36:   nleavesalloc = nleaves*stride

 38:   do i = 1, nleaves
 39:     mine(i) = stride*(i - 1)
 40:   end do

 42: ! Left periodic neighbor
 43:   remote(1)%rank = modulo(rank + size - 1, size)
 44:   remote(1)%index = 1*stride
 45: ! Right periodic neighbor
 46:   remote(2)%rank = modulo(rank + 1, size)
 47:   remote(2)%index = 0*stride
 48:   if (rank > 0) then !               All processes reference rank 0, index
 49:     remote(3)%rank = 0
 50:     remote(3)%index = 2*stride
 51:   end if

 53: ! Create a star forest for communication
 54:   PetscCallA(PetscSFCreate(PETSC_COMM_WORLD, sf, ierr))
 55:   PetscCallA(PetscSFSetFromOptions(sf, ierr))
 56:   PetscCallA(PetscSFSetGraph(sf, nrootsalloc, nleaves, mine, PETSC_COPY_VALUES, remote, PETSC_COPY_VALUES, ierr))
 57:   PetscCallA(PetscSFSetUp(sf, ierr))

 59: ! View graph, mostly useful for debugging purposes.
 60:   PetscCallA(PetscViewerPushFormat(PETSC_VIEWER_STDOUT_WORLD, PETSC_VIEWER_ASCII_INFO_DETAIL, ierr))
 61:   PetscCallA(PetscSFView(sf, PETSC_VIEWER_STDOUT_WORLD, ierr))
 62:   PetscCallA(PetscViewerPopFormat(PETSC_VIEWER_STDOUT_WORLD, ierr))

 64: ! Allocate space for send and receive buffers. This example communicates PetscInt, but other types, including
 65: !   * user-defined structures, could also be used.
 66: ! Set rootdata buffer to be broadcast
 67:   rootdata(1:nrootsalloc) = -1
 68:   do i = 1, nroots
 69:     rootdata(1 + (i - 1)*stride) = 100*(rank + 1) + i - 1
 70:   end do

 72: ! Initialize local buffer, these values are never used.
 73:   leafdata(1:nleavesalloc) = -1

 75: ! Broadcast entries from rootdata to leafdata. Computation or other communication can be performed between the begin and end calls.
 76:   PetscCallA(PetscSFBcastBegin(sf, MPIU_INTEGER, rootdata, leafdata, MPI_REPLACE, ierr))
 77:   PetscCallA(PetscSFBcastEnd(sf, MPIU_INTEGER, rootdata, leafdata, MPI_REPLACE, ierr))
 78:   PetscCallA(PetscViewerASCIIPrintf(PETSC_VIEWER_STDOUT_WORLD, '## Bcast Rootdata\n', ierr))
 79:   PetscCallA(PetscIntView(nrootsalloc, rootdata, PETSC_VIEWER_STDOUT_WORLD, ierr))
 80:   PetscCallA(PetscViewerASCIIPrintf(PETSC_VIEWER_STDOUT_WORLD, '## Bcast Leafdata\n', ierr))
 81:   PetscCallA(PetscIntView(nleavesalloc, leafdata, PETSC_VIEWER_STDOUT_WORLD, ierr))

 83: ! Reduce entries from leafdata to rootdata. Computation or other communication can be performed between the begin and end calls.
 84:   PetscCallA(PetscSFReduceBegin(sf, MPIU_INTEGER, leafdata, rootdata, MPI_SUM, ierr))
 85:   PetscCallA(PetscSFReduceEnd(sf, MPIU_INTEGER, leafdata, rootdata, MPI_SUM, ierr))
 86:   PetscCallA(PetscViewerASCIIPrintf(PETSC_VIEWER_STDOUT_WORLD, '## Reduce Leafdata\n', ierr))
 87:   PetscCallA(PetscIntView(nleavesalloc, leafdata, PETSC_VIEWER_STDOUT_WORLD, ierr))
 88:   PetscCallA(PetscViewerASCIIPrintf(PETSC_VIEWER_STDOUT_WORLD, '## Reduce Rootdata\n', ierr))
 89:   PetscCallA(PetscIntView(nrootsalloc, rootdata, PETSC_VIEWER_STDOUT_WORLD, ierr))

 91:   PetscCallA(PetscSFGetGraph(sf, gnroots, gnleaves, gmine, gremote, ierr))
 92:   PetscCheckA(gnleaves == nleaves, PETSC_COMM_WORLD, PETSC_ERR_PLIB, 'nleaves returned from PetscSFGetGraph() does not match that set with PetscSFSetGraph()')
 93:   do i = 1, nleaves
 94:     PetscCheckA(gmine(i) == mine(i), PETSC_COMM_WORLD, PETSC_ERR_PLIB, 'Root from PetscSFGetGraph() does not match that set with PetscSFSetGraph()')
 95:   end do
 96:   do i = 1, nleaves
 97:     PetscCheckA(gremote(i)%index == remote(i)%index, PETSC_COMM_WORLD, PETSC_ERR_PLIB, 'Leaf from PetscSFGetGraph() does not match that set with PetscSFSetGraph()')
 98:   end do
 99:   PetscCallA(PetscSFRestoreGraph(sf, gnroots, gnleaves, gmine, gremote, ierr))

101: ! Test PetscSFGet{Leaf,Root}Ranks
102:   PetscCallA(PetscSFGetLeafRanks(sf, niranks, iranks, ioffset, irootloc, ierr))
103:   PetscCallA(PetscSFGetRootRanks(sf, nranks, ranks, roffset, rmine, rremote, ierr))

105: ! Broadcast a PetscBool buffer using MPI_C_BOOL to exercise the Fortran -> C datatype conversion.
106: ! Every leaf references an active root slot, so each populated leaf slot must receive PETSC_TRUE.
107:   rootbool(1:nrootsalloc) = PETSC_FALSE
108:   rootbool(1 + ([(i, i=0, nroots - 1)])*stride) = PETSC_TRUE
109:   leafbool(1:nleavesalloc) = PETSC_FALSE
110:   PetscCallA(PetscSFBcastBegin(sf, MPI_C_BOOL, rootbool, leafbool, MPI_REPLACE, ierr))
111:   PetscCallA(PetscSFBcastEnd(sf, MPI_C_BOOL, rootbool, leafbool, MPI_REPLACE, ierr))
112:   do i = 1, nleaves
113:     PetscCheckA(leafbool(mine(i) + 1), PETSC_COMM_WORLD, PETSC_ERR_PLIB, 'PetscSFBcast with MPI_C_BOOL did not deliver expected value')
114:   end do

116: !    Clean storage for star forest.
117:   PetscCallA(PetscSFDestroy(sf, ierr))

119: !  Create a star forest with continuous leaves and hence no buffer
120:   PetscCallA(PetscSFCreate(PETSC_COMM_WORLD, sf, ierr))
121:   PetscCallA(PetscSFSetFromOptions(sf, ierr))
122:   PetscCallA(PetscSFSetGraph(sf, nrootsalloc, nleaves, PETSC_NULL_INTEGER_ARRAY, PETSC_COPY_VALUES, remote, PETSC_COPY_VALUES, ierr))
123:   PetscCallA(PetscSFSetUp(sf, ierr))

125: !   View graph, mostly useful for debugging purposes.
126:   PetscCallA(PetscViewerPushFormat(PETSC_VIEWER_STDOUT_WORLD, PETSC_VIEWER_ASCII_INFO_DETAIL, ierr))
127:   PetscCallA(PetscSFView(sf, PETSC_VIEWER_STDOUT_WORLD, ierr))
128:   PetscCallA(PetscViewerPopFormat(PETSC_VIEWER_STDOUT_WORLD, ierr))

130:   PetscCallA(PetscSFGetGraph(sf, gnroots, gnleaves, gmine, gremote, ierr))
131:   PetscCheckA(loc(gmine) == loc(PETSC_NULL_INTEGER), PETSC_COMM_WORLD, PETSC_ERR_PLIB, 'Leaves from PetscSFGetGraph() not null as expected')
132:   PetscCallA(PetscSFRestoreGraph(sf, gnroots, gnleaves, gmine, gremote, ierr))
133:   PetscCallA(PetscSFDestroy(sf, ierr))
134:   PetscCallA(PetscFinalize(ierr))
135: end

137: !/*TEST
138: !
139: !  test:
140: !    nsize: 3
141: !
142: !TEST*/