dfac_type3_symmetrize.F

Go to the documentation of this file.

C
C  This file is part of MUMPS 5.5.1, released
C  on Tue Jul 12 13:17:24 UTC 2022
C
C
C  Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  Mumps Technologies, University of Bordeaux.
C
C  This version of MUMPS is provided to you free of charge. It is
C  released under the CeCILL-C license 
C  (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
C  https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
C
      SUBROUTINE dmumps_symmetrize( BUF, BLOCK_SIZE,
     &                           MYROW, MYCOL, NPROW, NPCOL,
     &                           A, LOCAL_M, LOCAL_N, N, MYID, COMM )
      IMPLICIT NONE
      INTEGER BLOCK_SIZE, NPROW, NPCOL, LOCAL_M, LOCAL_N, N, COMM
      INTEGER MYROW, MYCOL, MYID
      DOUBLE PRECISION BUF( BLOCK_SIZE * BLOCK_SIZE )
      DOUBLE PRECISION A( LOCAL_M, LOCAL_N )
      INTEGER NBLOCK, IBLOCK, JBLOCK, IBLOCK_SIZE, JBLOCK_SIZE
      INTEGER ROW_SOURCE, ROW_DEST, COL_SOURCE, COL_DEST
      INTEGER IGLOB, JGLOB
      INTEGER IROW_LOC_SOURCE, JCOL_LOC_SOURCE
      INTEGER IROW_LOC_DEST, JCOL_LOC_DEST
      INTEGER PROC_SOURCE, PROC_DEST
      nblock = ( n - 1 ) / block_size + 1
      DO iblock = 1, nblock
        IF ( iblock .NE. nblock
     &    ) THEN
          iblock_size = block_size
        ELSE
          iblock_size = n - ( nblock - 1 ) * block_size
        END IF
        row_source = mod( iblock - 1, nprow ) 
        col_dest   = mod( iblock - 1, npcol )
        iglob = ( iblock - 1 ) * block_size + 1
        irow_loc_source = block_size *
     &                    ( ( iglob - 1 ) / (block_size*nprow) )
     &                  + mod( iglob - 1, block_size ) + 1
        jcol_loc_dest   = block_size *
     &                    ( ( iglob - 1 ) / (block_size*npcol) )
     &                  + mod( iglob - 1, block_size ) + 1
        DO jblock = 1, iblock
          IF ( jblock .NE. nblock
     &      ) THEN
            jblock_size = block_size
          ELSE
            jblock_size = n - ( nblock - 1 ) * block_size
          END IF
          col_source = mod( jblock - 1, npcol )
          row_dest   = mod( jblock - 1, nprow )
          proc_source = row_source * npcol + col_source
          proc_dest   = row_dest   * npcol + col_dest
          IF ( proc_source .eq. proc_dest ) THEN
           IF ( myid .eq. proc_dest ) THEN
            jglob = ( jblock - 1 ) * block_size + 1
            jcol_loc_source = block_size *
     &                  ( ( jglob - 1 ) / (block_size*npcol) )
     &                  + mod( jglob - 1, block_size ) + 1
            irow_loc_dest   = block_size *
     &                    ( ( jglob - 1 ) / (block_size*nprow) )
     &                  + mod( jglob - 1, block_size ) + 1
            IF ( iblock .eq. jblock ) THEN
               IF ( iblock_size .ne. jblock_size ) THEN
                WRITE(*,*) myid,': Error in calling transdiag:unsym'
                CALL mumps_abort()
              END IF
              CALL dmumps_trans_diag( a( irow_loc_source,
     &                 jcol_loc_source),
     &                 iblock_size, local_m )
            ELSE
              CALL dmumps_transpo(
     &           a( irow_loc_source, jcol_loc_source ),
     &           a( irow_loc_dest, jcol_loc_dest ),
     &           iblock_size, jblock_size, local_m )
            END IF
           END IF
          ELSE IF (  myrow .eq. row_source 
     &    .AND. mycol .eq. col_source ) THEN
            jglob = ( jblock - 1 ) * block_size + 1
            jcol_loc_source = block_size *
     &                    ( ( jglob - 1 ) / (block_size*npcol) )
     &                  + mod( jglob - 1, block_size ) + 1
            CALL dmumps_send_block( buf,
     &           a( irow_loc_source, jcol_loc_source ), local_m,
     &           iblock_size, jblock_size, comm, proc_dest )
          ELSE IF ( myrow .eq. row_dest 
     &    .AND.     mycol .eq. col_dest ) THEN
            jglob = ( jblock - 1 ) * block_size + 1
            irow_loc_dest   = block_size *
     &                    ( ( jglob - 1 ) / (block_size*nprow) )
     &                  + mod( jglob - 1, block_size ) + 1
            CALL dmumps_recv_block( buf,
     &           a( irow_loc_dest, jcol_loc_dest ), local_m,
     &           jblock_size, iblock_size, comm, proc_source )
          END IF
        END DO
      END DO
      RETURN
      END SUBROUTINE dmumps_symmetrize
      SUBROUTINE dmumps_send_block( BUF, A, LDA, M, N, COMM, DEST )
      IMPLICIT NONE
      INTEGER M, N, LDA, DEST, COMM
      DOUBLE PRECISION BUF(*), A(LDA,*)
      INTEGER I, IBUF, IERR
      INTEGER J
      include 'mpif.h'
      include 'mumps_tags.h'
      ibuf = 1
      DO j = 1, n
        buf( ibuf: ibuf + m - 1 ) = a( 1 : m, j )
        DO i = 1, m
        END DO
        ibuf = ibuf + m
      END DO
      CALL mpi_send( buf, m * n, mpi_double_precision,
     &     dest, symmetrize, comm, ierr )
      RETURN
      END SUBROUTINE dmumps_send_block
      SUBROUTINE dmumps_recv_block( BUF, A, LDA, M, N, COMM, SOURCE )
      IMPLICIT NONE
      INTEGER LDA, M, N, COMM, SOURCE
      DOUBLE PRECISION BUF(*), A( LDA, *)
      INTEGER I, IBUF, IERR
      include 'mpif.h'
      include 'mumps_tags.h'
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      CALL mpi_recv( buf(1), m * n, mpi_double_precision, source,
     &               symmetrize, comm, status, ierr )
      ibuf = 1
      DO i = 1, m
        CALL dcopy( n, buf(ibuf), 1, a(i,1), lda )
        ibuf = ibuf + n
      END DO
      RETURN
      END SUBROUTINE dmumps_recv_block
      SUBROUTINE dmumps_trans_diag( A, N, LDA )
      IMPLICIT NONE
      INTEGER N,LDA
      DOUBLE PRECISION A( LDA, * )
      INTEGER I, J
      DO i = 2, n
        DO j = 1, i - 1
          a( j, i ) = a( i, j )
        END DO
      END DO
      RETURN
      END SUBROUTINE dmumps_trans_diag
      SUBROUTINE dmumps_transpo( A1, A2, M, N, LD )
      IMPLICIT NONE
      INTEGER M,N,LD
      DOUBLE PRECISION A1( LD,* ), A2( LD, * )
      INTEGER I, J
      DO j = 1, n
        DO i = 1, m
          a2( j, i ) = a1( i, j )
        END DO
      END DO
      RETURN
      END SUBROUTINE dmumps_transpo