InitComm.f90

Go to the documentation of this file.

!*********************************************************************
!* Illinois Open Source License                                      *
!*                                                                   *
!* University of Illinois/NCSA                                       * 
!* Open Source License                                               *
!*                                                                   *
!* Copyright@2008, University of Illinois.  All rights reserved.     *
!*                                                                   *
!*  Developed by:                                                    *
!*                                                                   *
!*     Center for Simulation of Advanced Rockets                     *
!*                                                                   *
!*     University of Illinois                                        *
!*                                                                   *
!*     www.csar.uiuc.edu                                             *
!*                                                                   *
!* Permission is hereby granted, free of charge, to any person       *
!* obtaining a copy of this software and associated documentation    *
!* files (the "Software"), to deal with the Software without         *
!* restriction, including without limitation the rights to use,      *
!* copy, modify, merge, publish, distribute, sublicense, and/or      *
!* sell copies of the Software, and to permit persons to whom the    *
!* Software is furnished to do so, subject to the following          *
!* conditions:                                                       *
!*                                                                   *
!*                                                                   *
!* @ Redistributions of source code must retain the above copyright  * 
!*   notice, this list of conditions and the following disclaimers.  *
!*                                                                   * 
!* @ Redistributions in binary form must reproduce the above         *
!*   copyright notice, this list of conditions and the following     *
!*   disclaimers in the documentation and/or other materials         *
!*   provided with the distribution.                                 *
!*                                                                   *
!* @ Neither the names of the Center for Simulation of Advanced      *
!*   Rockets, the University of Illinois, nor the names of its       *
!*   contributors may be used to endorse or promote products derived * 
!*   from this Software without specific prior written permission.   *
!*                                                                   *
!* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,   *
!* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES   *
!* OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND          *
!* NONINFRINGEMENT.  IN NO EVENT SHALL THE CONTRIBUTORS OR           *
!* COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER       * 
!* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,   *
!* ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE    *
!* USE OR OTHER DEALINGS WITH THE SOFTWARE.                          *
!*********************************************************************
!* Please acknowledge The University of Illinois Center for          *
!* Simulation of Advanced Rockets in works and publications          *
!* resulting from this software or its derivatives.                  *
!*********************************************************************

!!****
!!
!!  NAME
!!     InitComm1
!!
!!  FUNCTION
!!     Initializes global communication variables for communicating
!!     boundary data from this proc to other procs
!!
!!  INPUTS
!!     none
!!
!!  OUTPUTS
!!     none
!!
!!  USES
!!     MPI
!!
!!****

SUBROUTINE initcomm1(global)

  USE precision
  USE implicit_global
  USE rocstar_rocfraccomm

  IMPLICIT NONE

  include 'mpif.h'

  TYPE(rocfrac_global)  :: global
  INTEGER :: i, j, counter  ! counters
  INTEGER :: tempnodes
  INTEGER, ALLOCATABLE, DIMENSION(:) :: numcommnodesfromall  ! Number of nodes to be recieved from all processors



!
! Determine communications to be sent to other procs
!


  ! Count the processors to be communicated with
  numcommprocs1 = 0
  DO i = 0, nprocs
     IF (i /= myid) THEN
        counter = 0
        DO j = 1, global%NumNp
           IF (nodeproc(j) == i) THEN
              counter = 1
              EXIT
           ENDIF
        ENDDO
        IF (counter == 1) THEN  ! New proc found
           numcommprocs1 = numcommprocs1 + 1
        ENDIF
     ENDIF
  ENDDO
  
  ! Number the processors to be communicated with
  ALLOCATE(commprocs1(1:numcommprocs1))
  counter = 0
  DO i = 0, nprocs
     IF (i /= myid) THEN
        DO j = 1, global%NumNp
           IF (nodeproc(j) == i) THEN
              counter = counter + 1
              commprocs1(counter) = i
              EXIT
           ENDIF
        ENDDO
     ENDIF
  ENDDO
  
  ! Count the nodes to be sent to each processor
  ALLOCATE(numcommnodes1(1:numcommprocs1))
  DO i = 1, numcommprocs1
     numcommnodes1(i) = 0
     DO j = 1, global%NumNp
        IF (nodeproc(j) == commprocs1(i)) THEN
           numcommnodes1(i) = numcommnodes1(i) + 1
        ENDIF
     ENDDO
  ENDDO
  
  ! Number the nodes to be sent to each processor
  maxnumcommnodes1 = maxval(numcommnodes1)
  ALLOCATE(commnodes1(1:numcommprocs1,1:maxnumcommnodes1))
  DO i = 1, numcommprocs1
     commnodes1(i,1:maxnumcommnodes1) = -1  ! Flag everything as unused
     counter = 0
     DO j = 1, global%NumNp
        IF (nodeproc(j) == commprocs1(i)) THEN
           counter = counter + 1
           commnodes1(i,counter) = j
        ENDIF
     ENDDO
  ENDDO


!
! Communicate how many nodes will be sent to each processor
!
  
  ! Allocate MPI arrays
  ALLOCATE(frmproc(0:nprocs-1))
  ALLOCATE(req_rcv(1:nprocs))
  ALLOCATE(stat_rcv(1:mpi_status_size,1:nprocs))
  ALLOCATE(req_snd(1:nprocs))
  ALLOCATE(stat_snd(1:mpi_status_size,1:nprocs))
  DO i = 1, nprocs
     req_rcv(i) = 0
     req_snd(i) = 0
     DO j = 1, mpi_status_size
        stat_rcv(1,i) = 0
        stat_snd(j,i) = 0
     ENDDO
  ENDDO

  ! Perform the communication
  ALLOCATE(numcommnodesfromall(0:nprocs-1))
  DO i = 0, nprocs-1
     CALL mpi_irecv(numcommnodesfromall(i),1, &
          mpi_integer,i,10,rocstar_communicator, &
          req_rcv(i+1),ierr)
  ENDDO
  DO i = 0, nprocs-1
     tempnodes = 0
     DO j = 1, numcommprocs1
        IF (commprocs1(j) == i) THEN
           tempnodes = numcommnodes1(j)
        ENDIF
     ENDDO
     CALL mpi_isend(tempnodes,1,mpi_integer, &
     i,10,rocstar_communicator,req_snd(i+1),ierr)
  ENDDO
  CALL mpi_waitall(nprocs,req_rcv,stat_rcv,ierr)
  CALL mpi_waitall(nprocs,req_snd,stat_snd,ierr)

  ! Deallocate MPI arrays
  DEALLOCATE(frmproc)
  DEALLOCATE(req_rcv)
  DEALLOCATE(stat_rcv)
  DEALLOCATE(req_snd)
  DEALLOCATE(stat_snd)

  ! Count the number of procs that will send me data
  numcommprocsfrom1 = 0
  DO i = 0, nprocs-1
     IF (numcommnodesfromall(i) > 0) THEN
        numcommprocsfrom1 = numcommprocsfrom1 + 1
     ENDIF
  ENDDO

  ! Number the procs that will send me data
  ALLOCATE(commprocsfrom1(1:numcommprocsfrom1))
  ALLOCATE(numcommnodesfrom1(1:numcommprocsfrom1))
  counter = 0
  DO i = 0, nprocs-1
     IF (numcommnodesfromall(i) > 0) THEN
        counter = counter + 1
        commprocsfrom1(counter) = i
        numcommnodesfrom1(counter) = numcommnodesfromall(i)
     ENDIF
  ENDDO


  ! Deallocate stuff
  DEALLOCATE(numcommnodesfromall)



END SUBROUTINE initcomm1


















!!****
!!
!!  NAME
!!     InitComm2
!!
!!  FUNCTION
!!     Initializes global communication variables for communicating
!!     boundary data from other procs to this proc
!!
!!  INPUTS
!!     none
!!
!!  OUTPUTS
!!     none
!!
!!  USES
!!     MPI
!!
!!****

SUBROUTINE initcomm2(global)

  USE precision
  USE implicit_global

  IMPLICIT NONE

  include 'mpif.h'

  TYPE(rocfrac_global)  :: global
  INTEGER :: i, j, counter  ! counters
  INTEGER :: tempnodes
  INTEGER, ALLOCATABLE, DIMENSION(:) :: numcommnodesfromall  ! Number of nodes to be recieved from all processors
  INTEGER, ALLOCATABLE, DIMENSION(:,:) :: commnodesfrom2
  REAL(kind=wp), ALLOCATABLE, DIMENSION(:) :: bufsnd  ! MPI send buffer


!
! Determine communications to be sent to other procs
!


  ! Count the processors that will send me data
  numcommprocsfrom2 = 0
  DO i = 0, nprocs
     IF (i /= myid) THEN
        counter = 0
        DO j = 1, global%NumNp
           IF (nodeproc(j) == i) THEN
              counter = 1
              EXIT
           ENDIF
        ENDDO
        IF (counter == 1) THEN  ! New proc found
           numcommprocsfrom2 = numcommprocsfrom2 + 1
        ENDIF
     ENDIF
  ENDDO
  
  ! Number the processors that will send me data
  ALLOCATE(commprocsfrom2(1:numcommprocsfrom2))
  counter = 0
  DO i = 0, nprocs
     IF (i /= myid) THEN
        DO j = 1, global%NumNp
           IF (nodeproc(j) == i) THEN
              counter = counter + 1
              commprocsfrom2(counter) = i
              EXIT
           ENDIF
        ENDDO
     ENDIF
  ENDDO
  
  ! Count the nodes to be received from each processor
  ALLOCATE(numcommnodesfrom2(1:numcommprocsfrom2))
  DO i = 1, numcommprocsfrom2
     numcommnodesfrom2(i) = 0
     DO j = 1, global%NumNp
        IF (nodeproc(j) == commprocsfrom2(i)) THEN
           numcommnodesfrom2(i) = numcommnodesfrom2(i) + 1
        ENDIF
     ENDDO
  ENDDO


!
! Communicate how many nodes are needed to each processor
!
  
  ! Allocate MPI arrays
  ALLOCATE(frmproc(0:nprocs-1))
  ALLOCATE(req_rcv(1:nprocs))
  ALLOCATE(stat_rcv(1:mpi_status_size,1:nprocs))
  ALLOCATE(req_snd(1:nprocs))
  ALLOCATE(stat_snd(1:mpi_status_size,1:nprocs))
  DO i = 1, nprocs
     req_rcv(i) = 0
     req_snd(i) = 0
     DO j = 1, mpi_status_size
        stat_rcv(1,i) = 0
        stat_snd(j,i) = 0
     ENDDO
  ENDDO

  ! Perform the communication
  ALLOCATE(numcommnodesfromall(0:nprocs-1))
  DO i = 0, nprocs-1
     CALL mpi_irecv(numcommnodesfromall(i),1, &
          mpi_integer,i,10,rocstar_communicator, &
          req_rcv(i+1),ierr)
  ENDDO
  DO i = 0, nprocs-1
     tempnodes = 0
     DO j = 1, numcommprocsfrom2
        IF (commprocsfrom2(j) == i) THEN
           tempnodes = numcommnodesfrom2(j)
        ENDIF
     ENDDO
     CALL mpi_isend(tempnodes,1,mpi_integer, &
     i,10,rocstar_communicator,req_snd(i+1),ierr)
  ENDDO
  CALL mpi_waitall(nprocs,req_rcv,stat_rcv,ierr)
  CALL mpi_waitall(nprocs,req_snd,stat_snd,ierr)

  ! Deallocate MPI arrays
  DEALLOCATE(frmproc)
  DEALLOCATE(req_rcv)
  DEALLOCATE(stat_rcv)
  DEALLOCATE(req_snd)
  DEALLOCATE(stat_snd)

  ! Count the number of procs that I will send data to
  numcommprocs2 = 0
  DO i = 0, nprocs-1
     IF (numcommnodesfromall(i) > 0) THEN
        numcommprocs2 = numcommprocs2 + 1
     ENDIF
  ENDDO

  ! Number the procs that I will send data to
  ALLOCATE(commprocs2(1:numcommprocs2))
  ALLOCATE(numcommnodes2(1:numcommprocs2))
  counter = 0
  DO i = 0, nprocs-1
     IF (numcommnodesfromall(i) > 0) THEN
        counter = counter + 1
        commprocs2(counter) = i
        numcommnodes2(counter) = numcommnodesfromall(i)
     ENDIF
  ENDDO


  ! Deallocate stuff
  DEALLOCATE(numcommnodesfromall)

  ! Number the nodes to be received from each processor
  maxnumcommnodes2 = maxval(numcommnodesfrom2)
  ALLOCATE(commnodesfrom2(1:numcommprocsfrom2,1:maxnumcommnodes2))
  DO i = 1, numcommprocsfrom2
     commnodesfrom2(i,1:maxnumcommnodes2) = -1  ! Flag everything as unused
     counter = 0
     DO j = 1, global%NumNp
        IF (nodeproc(j) == commprocsfrom2(i)) THEN
           counter = counter + 1
           commnodesfrom2(i,counter) = j
        ENDIF
     ENDDO
  ENDDO

  !DO i = 1, NumCommProcs
  !   print*,myid,' has to receive info about ',NumCommNodesFrom(i),' nodes from proc ',CommProcsFrom(i)
  !   print*,myid,' CommNodesFrom(i,:) = ',Local2Global(CommNodesFrom(i,:))
  !ENDDO


!
! Communicate which nodes are needed to each processor
!
  
  ! Allocate MPI arrays
  !ALLOCATE(req_rcv(1:NumCommProcs2))
  !ALLOCATE(req_snd(1:NumCommProcsFrom2))
  !ALLOCATE(stat_snd(1:MPI_STATUS_SIZE,1:NumCommProcsFrom2))
  !ALLOCATE(stat_rcv(1:MPI_STATUS_SIZE,1:NumCommProcs2))
  ALLOCATE(req_rcv(1:nprocs))
  ALLOCATE(req_snd(1:nprocs))
  ALLOCATE(stat_snd(1:mpi_status_size,1:nprocs))
  ALLOCATE(stat_rcv(1:mpi_status_size,1:nprocs))
  DO i = 1, nprocs
     req_rcv(i) = 0
     req_snd(i) = 0
     DO j = 1, mpi_status_size
        stat_rcv(1,i) = 0
        stat_snd(j,i) = 0
     ENDDO
  ENDDO

  ! Perform the communication
  ALLOCATE(frmproc(1:numcommprocs2))
  DO i = 1, numcommprocs2
     ALLOCATE(frmproc(i)%rcvbuf(1:numcommnodes2(i)))
     CALL mpi_irecv(frmproc(i)%rcvbuf(1),numcommnodes2(i), &
          mpi_double_precision,commprocs2(i),10,rocstar_communicator, &
          req_rcv(i+1),ierr)
  ENDDO
  DO i = 1, numcommprocsfrom2
     ALLOCATE(bufsnd(1:numcommnodesfrom2(i)))
     DO j = 1, numcommnodesfrom2(i)
        bufsnd(j) = local2global(commnodesfrom2(i,j))
     ENDDO
     !print*,myid,' bufsnd = ',bufsnd(:)
     CALL mpi_isend(bufsnd,numcommnodesfrom2(i),mpi_double_precision, &
     commprocsfrom2(i),10,rocstar_communicator,req_snd(i+1),ierr)
     DEALLOCATE(bufsnd)
  ENDDO
  !CALL MPI_WAITALL(NumCommProcs2,req_rcv,stat_rcv,ierr)
  !CALL MPI_WAITALL(NumCommProcsFrom2,req_snd,stat_snd,ierr)
  CALL mpi_waitall(nprocs,req_rcv,stat_rcv,ierr)
  CALL mpi_waitall(nprocs,req_snd,stat_snd,ierr)

  ! Deallocate MPI arrays
  DEALLOCATE(req_rcv)
  DEALLOCATE(stat_rcv)
  DEALLOCATE(req_snd)
  DEALLOCATE(stat_snd)

  !DO i = 1, NumCommProcs
  !   DO j = 1, NumCommNodes(i)
  !      print*,myid,' has to send info about global node ',frmproc(i)%rcvbuf(j),' to proc ',CommProcs(i)
  !   ENDDO
  !ENDDO

  ! Number the nodes to be sent to each processor
  maxnumcommnodes2 = maxval(numcommnodes2)
  ALLOCATE(commnodes2(1:numcommprocs2,1:maxnumcommnodes2))
  DO i = 1, numcommprocs2
     commnodes2(i,1:maxnumcommnodes2) = -1  ! Flag everything as unused
     DO j = 1, numcommnodes2(i)
        commnodes2(i,j) = int(frmproc(i)%rcvbuf(j))
     ENDDO
  ENDDO

  ! Deallocate stuff
  DEALLOCATE(frmproc)
  DEALLOCATE(commnodesfrom2)

  

END SUBROUTINE initcomm2