Date: 2025-03-28T21:11:21+00:00

Actual source code: ex1f.F90

      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

      7:       program main
      8: #include <petsc/finclude/petscvec.h>
      9:       use petscmpi  ! or mpi or mpi_f08
     10:       use petscvec
     11:       implicit none

     13:       PetscErrorCode                ierr
     14:       PetscInt                      i,nroots,nrootsalloc,nleaves,nleavesalloc,mine(6),stride
     15:       type(PetscSFNode)             remote(6)
     16:       PetscMPIInt                   rank,size
     17:       PetscSF                       sf
     18:       PetscInt                      rootdata(6),leafdata(6)

     20: ! used with PetscSFGetGraph()
     21:       type(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:       stride = 2
     31:       PetscCallMPIA(MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr))
     32:       PetscCallMPIA(MPI_Comm_size(PETSC_COMM_WORLD,size,ierr))

     34:       if (rank == 0) then
     35:          nroots = 3
     36:       else
     37:          nroots = 2
     38:       endif
     39:       nrootsalloc  = nroots * stride;
     40:       if (rank > 0) then
     41:          nleaves = 3
     42:       else
     43:          nleaves = 2
     44:       endif
     45:       nleavesalloc = nleaves * stride
     46:       if (stride > 1) then
     47:          do i=1,nleaves
     48:             mine(i) = stride * (i-1)
     49:          enddo
     50:       endif

     52: ! Left periodic neighbor
     53:       remote(1)%rank  = modulo(rank+size-1,size)
     54:       remote(1)%index = 1 * stride
     55: ! Right periodic neighbor
     56:       remote(2)%rank  = modulo(rank+1,size)
     57:       remote(2)%index = 0 * stride
     58:       if (rank > 0) then !               All processes reference rank 0, index
     59:          remote(3)%rank  = 0
     60:          remote(3)%index = 2 * stride
     61:       endif

     63: !  Create a star forest for communication
     64:       PetscCallA(PetscSFCreate(PETSC_COMM_WORLD,sf,ierr))
     65:       PetscCallA(PetscSFSetFromOptions(sf,ierr))
     66:       PetscCallA(PetscSFSetGraph(sf,nrootsalloc,nleaves,mine,PETSC_COPY_VALUES,remote,PETSC_COPY_VALUES,ierr))
     67:       PetscCallA(PetscSFSetUp(sf,ierr))

     69: !   View graph, mostly useful for debugging purposes.
     70:       PetscCallA(PetscViewerPushFormat(PETSC_VIEWER_STDOUT_WORLD,PETSC_VIEWER_ASCII_INFO_DETAIL,ierr))
     71:       PetscCallA(PetscSFView(sf,PETSC_VIEWER_STDOUT_WORLD,ierr))
     72:       PetscCallA(PetscViewerPopFormat(PETSC_VIEWER_STDOUT_WORLD,ierr))

     74: !   Allocate space for send and receive buffers. This example communicates PetscInt, but other types, including
     75: !     * user-defined structures, could also be used.
     76: !     Set rootdata buffer to be broadcast
     77:       do i=1,nrootsalloc
     78:          rootdata(i) = -1
     79:       enddo
     80:       do i=1,nroots
     81:          rootdata(1 + (i-1)*stride) = 100*(rank+1) + i - 1
     82:       enddo

     84: !     Initialize local buffer, these values are never used.
     85:       do i=1,nleavesalloc
     86:          leafdata(i) = -1
     87:       enddo

     89: !     Broadcast entries from rootdata to leafdata. Computation or other communication can be performed between the begin and end calls.
     90:       PetscCallA(PetscSFBcastBegin(sf,MPIU_INTEGER,rootdata,leafdata,MPI_REPLACE,ierr))
     91:       PetscCallA(PetscSFBcastEnd(sf,MPIU_INTEGER,rootdata,leafdata,MPI_REPLACE,ierr))
     92:       PetscCallA(PetscViewerASCIIPrintf(PETSC_VIEWER_STDOUT_WORLD,'## Bcast Rootdata\n',ierr))
     93:       PetscCallA(PetscIntView(nrootsalloc,rootdata,PETSC_VIEWER_STDOUT_WORLD,ierr))
     94:       PetscCallA(PetscViewerASCIIPrintf(PETSC_VIEWER_STDOUT_WORLD,'## Bcast Leafdata\n',ierr))
     95:       PetscCallA(PetscIntView(nleavesalloc,leafdata,PETSC_VIEWER_STDOUT_WORLD,ierr))

     97: !     Reduce entries from leafdata to rootdata. Computation or other communication can be performed between the begin and end calls.
     98:       PetscCallA(PetscSFReduceBegin(sf,MPIU_INTEGER,leafdata,rootdata,MPI_SUM,ierr))
     99:       PetscCallA(PetscSFReduceEnd(sf,MPIU_INTEGER,leafdata,rootdata,MPI_SUM,ierr))
    100:       PetscCallA(PetscViewerASCIIPrintf(PETSC_VIEWER_STDOUT_WORLD,'## Reduce Leafdata\n',ierr))
    101:       PetscCallA(PetscIntView(nleavesalloc,leafdata,PETSC_VIEWER_STDOUT_WORLD,ierr))
    102:       PetscCallA(PetscViewerASCIIPrintf(PETSC_VIEWER_STDOUT_WORLD,'## Reduce Rootdata\n',ierr))
    103:       PetscCallA(PetscIntView(nrootsalloc,rootdata,PETSC_VIEWER_STDOUT_WORLD,ierr))

    105:       PetscCallA(PetscSFGetGraph(sf,gnroots,gnleaves,gmine,gremote,ierr))
    106:       PetscCheckA(gnleaves .eq. nleaves,PETSC_COMM_WORLD,PETSC_ERR_PLIB,'nleaves returned from PetscSFGetGraph() does not match that set with PetscSFSetGraph()')
    107:       do i=1,nleaves
    108:         PetscCheckA(gmine(i) .eq. mine(i),PETSC_COMM_WORLD,PETSC_ERR_PLIB,'Root from PetscSFGetGraph() does not match that set with PetscSFSetGraph()')
    109:       enddo
    110:       do i=1,nleaves
    111:        PetscCheckA(gremote(i)%index .eq. remote(i)%index,PETSC_COMM_WORLD,PETSC_ERR_PLIB,'Leaf from PetscSFGetGraph() does not match that set with PetscSFSetGraph()')
    112:       enddo

    114:       deallocate(gremote)

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

    120: !    Clean storage for star forest.
    121:       PetscCallA(PetscSFDestroy(sf,ierr))

    123: !  Create a star forest with continuous leaves and hence no buffer
    124:       PetscCallA(PetscSFCreate(PETSC_COMM_WORLD,sf,ierr))
    125:       PetscCallA(PetscSFSetFromOptions(sf,ierr))
    126:       PetscCallA(PetscSFSetGraph(sf,nrootsalloc,nleaves,PETSC_NULL_INTEGER_ARRAY,PETSC_COPY_VALUES,remote,PETSC_COPY_VALUES,ierr))
    127:       PetscCallA(PetscSFSetUp(sf,ierr))

    129: !   View graph, mostly useful for debugging purposes.
    130:       PetscCallA(PetscViewerPushFormat(PETSC_VIEWER_STDOUT_WORLD,PETSC_VIEWER_ASCII_INFO_DETAIL,ierr))
    131:       PetscCallA(PetscSFView(sf,PETSC_VIEWER_STDOUT_WORLD,ierr))
    132:       PetscCallA(PetscViewerPopFormat(PETSC_VIEWER_STDOUT_WORLD,ierr))

    134:       PetscCallA(PetscSFGetGraph(sf,gnroots,gnleaves,gmine,gremote,ierr))
    135:       PetscCheckA(loc(gmine) .eq. loc(PETSC_NULL_INTEGER),PETSC_COMM_WORLD,PETSC_ERR_PLIB,'Leaves from PetscSFGetGraph() not null as expected')
    136:       deallocate(gremote)
    137:       PetscCallA(PetscSFDestroy(sf,ierr))
    138:       PetscCallA(PetscFinalize(ierr))
    139:   end

    141: !/*TEST
    142: !  build:
    143: !    requires: defined(PETSC_HAVE_FORTRAN_TYPE_STAR)
    144: !
    145: !  test:
    146: !    nsize: 3
    147: !
    148: !TEST*/