xref: /phasta/svLS/INCOMMU.f (revision 712d3df0b59ebebaaeaea358162c8d2c043c6e08)

!     This software is Copyright (c) 2012-2015 The Regents of the
!     University of California. All Rights Reserved.
!
!     Permission to copy and modify this software and its documentation
!     for educational, research and non-profit purposes, without fee,
!     and without a written agreement is hereby granted, provided that
!     the above copyright notice, this paragraph and the following three
!     paragraphs appear in all copies.
!
!     Permission to make commercial use of this software may be obtained
!     by contacting:
!
!     Technology Transfer Office
!     9500 Gilman Drive, Mail Code 0910
!     University of California
!     La Jolla, CA 92093-0910
!     (858) 534-5815
!     invent@ucsd.edu
!
!     This software program and documentation are copyrighted by The
!     Regents of the University of California. The software program and
!     documentation are supplied "as is", without any accompanying
!     services from The Regents. The Regents does not warrant that the
!     operation of the program will be uninterrupted or error-free. The
!     end-user understands that the program was developed for research
!     purposes and is advised not to rely exclusively on the program for
!     any reason.
!
!     IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY
!     PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL
!     DAMAGES, INCLUDING LOST PROFITS, ARISING OUT OF THE USE OF THIS
!     SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
!     CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!     THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY
!     WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
!     OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
!     SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND THE
!     UNIVERSITY OF CALIFORNIA HAS NO OBLIGATIONS TO PROVIDE
!     MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.

      SUBROUTINE COMMUV(dof, nNo, commu, cS, R)

      INCLUDE "svLS_STD.h"

      INTEGER, INTENT(IN) :: dof, nNo
      TYPE(svLS_commuType), INTENT(IN) :: commu
      TYPE(svLS_cSType), INTENT(IN) :: cS(commu%nTasks)
      REAL*8, INTENT(INOUT) :: R(dof,nNo)

      INTEGER i, j, k, s, e, ierr, nTasks, tF, stat(MPI_STATUS_SIZE)
      INTEGER comm
      REAL*8, ALLOCATABLE :: rTmp(:,:)

      IF (commu%nTasks .EQ. 1) RETURN

      nTasks = commu%nTasks
      tF     = commu%tF
      comm   = commu%comm

      IF (tF .NE. 1) THEN
         i = tF - 1
         i = cS(i)%ptr + cS(i)%n - 1
         ALLOCATE(rTmp(dof,i))
      END IF

      DO i=1, nTasks
         IF (cS(i)%tag .NE. 0) THEN
            s = cS(i)%ptr
            e = s + cS(i)%n - 1
            IF (i .LT. tF) THEN
               CALL MPI_IRECV(rTmp(:,s:e), cS(i)%n*dof, mpreal, i-1,
     2            cS(i)%tag, comm, cS(i)%req, ierr)
            ELSE
               CALL MPI_ISEND(R(:,s:e), cS(i)%n*dof, mpreal, i-1,
     2            cS(i)%tag, comm, cS(i)%req, ierr)
            END IF
         END IF
      END DO

      k = 1
      DO i=1, tF - 1
         IF (cS(i)%tag .NE. 0) THEN
            CALL MPI_WAIT(cS(i)%req, stat, ierr)
            DO j=1, cS(i)%nBl
               s = cS(i)%blPtr(j)
               e = s + cS(i)%blN(j) - 1
               R(:,s:e) = R(:,s:e) + rTmp(:,k:k+e-s)
               k = k + cS(i)%blN(j)
            END DO
         END IF
      END DO

      k = 1
      DO i=1, tF - 1
         DO j=1, cS(i)%nBl
            s = cS(i)%blPtr(j)
            e = s + cS(i)%blN(j) - 1
            rTmp(:,k:k+e-s) = R(:,s:e)
            k = k + cS(i)%blN(j)
         END DO
      END DO

      DO i=1, nTasks
         IF (cS(i)%tag .NE. 0) THEN
            s = cS(i)%ptr
            e = s + cS(i)%n - 1
            IF (i .GT. tF) THEN
               CALL MPI_WAIT(cS(i)%req, stat, ierr)
               CALL MPI_IRECV(R(:,s:e), cS(i)%n*dof, mpreal, i-1,
     2            cS(i)%tag, comm, cS(i)%req, ierr)
            ELSE
               CALL MPI_ISEND(rTmp(:,s:e), cS(i)%n*dof, mpreal, i-1,
     2            cS(i)%tag, comm, cS(i)%req, ierr)
            END IF
         END IF
      END DO

      DO i=1, nTasks
         IF (cS(i)%tag .NE. 0) THEN
            CALL MPI_WAIT(cS(i)%req, stat, ierr)
         END IF
      END DO

      RETURN
      END SUBROUTINE COMMUV

!====================================================================

      SUBROUTINE COMMUS(nNo, commu, cS, R)

      INCLUDE "svLS_STD.h"

      INTEGER, INTENT(IN) :: nNo
      TYPE(svLS_commuType), INTENT(IN) :: commu
      TYPE(svLS_cSType), INTENT(IN) :: cS(commu%nTasks)
      REAL*8, INTENT(INOUT) :: R(nNo)

      INTEGER i, j, k, s, e, ierr, nTasks, tF, stat(MPI_STATUS_SIZE)
      INTEGER comm
      REAL*8, ALLOCATABLE :: rTmp(:)

      IF (commu%nTasks .EQ. 1) RETURN

      nTasks = commu%nTasks
      tF     = commu%tF
      comm   = commu%comm

      IF (tF .NE. 1) THEN
         i = tF - 1
         i = cS(i)%ptr + cS(i)%n - 1
         ALLOCATE(rTmp(i))
      END IF

      DO i=1, nTasks
         IF (cS(i)%tag .NE. 0) THEN
            s = cS(i)%ptr
            e = s + cS(i)%n - 1
            IF (i .LT. tF) THEN
               CALL MPI_IRECV(rTmp(s:e), cS(i)%n, mpreal, i-1,
     2            cS(i)%tag, comm, cS(i)%req, ierr)
            ELSE
               CALL MPI_ISEND(R(s:e), cS(i)%n, mpreal, i-1,
     2            cS(i)%tag, comm, cS(i)%req, ierr)
            END IF
         END IF
      END DO

      k = 1
      DO i=1, tF - 1
         IF (cS(i)%tag .NE. 0) THEN
            CALL MPI_WAIT(cS(i)%req, stat, ierr)
            DO j=1, cS(i)%nBl
               s = cS(i)%blPtr(j)
               e = s + cS(i)%blN(j) - 1
               R(s:e) = R(s:e) + rTmp(k:k+e-s)
               k = k + cS(i)%blN(j)
            END DO
         END IF
      END DO

      k = 1
      DO i=1, tF - 1
         DO j=1, cS(i)%nBl
            s = cS(i)%blPtr(j)
            e = s + cS(i)%blN(j) - 1
            rTmp(k:k+e-s) = R(s:e)
            k = k + cS(i)%blN(j)
         END DO
      END DO

      DO i=1, nTasks
         IF (cS(i)%tag .NE. 0) THEN
            s = cS(i)%ptr
            e = s + cS(i)%n - 1
            IF (i .GT. tF) THEN
               CALL MPI_WAIT(cS(i)%req, stat, ierr)
               CALL MPI_IRECV(R(s:e), cS(i)%n, mpreal, i-1,
     2            cS(i)%tag, comm, cS(i)%req, ierr)
            ELSE
               CALL MPI_ISEND(rTmp(s:e), cS(i)%n, mpreal, i-1,
     2            cS(i)%tag, comm, cS(i)%req, ierr)
            END IF
         END IF
      END DO

      DO i=1, nTasks
         IF (cS(i)%tag .NE. 0) THEN
            CALL MPI_WAIT(cS(i)%req, stat, ierr)
         END IF
      END DO

      RETURN
      END SUBROUTINE COMMUS