btprim.f

Go to the documentation of this file.

      SUBROUTINE btsetup( MEM, MEMLEN, CMEM, CMEMLEN, OUTNUM,
     $                    TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX,
     $                    IAM, NNODES )
*
*  -- BLACS tester (version 1.0) --
*  University of Tennessee
*  December 15, 1994
*
*     .. Scalar Arguments ..
      LOGICAL TESTSDRV, TESTBSBR, TESTCOMB, TESTAUX
      INTEGER MEMLEN, CMEMLEN, OUTNUM, IAM, NNODES
*     ..
*     .. Array Arguments ..
      INTEGER MEM(MEMLEN)
      CHARACTER*1 CMEM(CMEMLEN)
*     ..
*
*  Purpose
*  =======
*  BTSETUP:  Sets up communicator and initiliazes MPI if needed.
*
*  ====================================================================
*
*     ..
*     .. Local Scalars
      LOGICAL INIT
*     ..
*     .. Include Files ..
      include 'mpif.h'
*     ..
*     .. Common Blocks ..
      COMMON /btmpi/ btcomm, ierr
      INTEGER BTCOMM, IERR
*     ..
*     .. Executable Statements ..
*
      ierr = 0
      CALL mpi_initialized(init, ierr)
      IF (.NOT.init) CALL mpi_init(ierr)
      IF (ierr.NE.0) CALL btmpierr("mpi_init", ierr)
      CALL mpi_comm_dup(mpi_comm_world, btcomm, ierr)
      IF (ierr.NE.0) CALL btmpierr("MPI_COMM_DUP", ierr)
*
      RETURN
      END
      INTEGER FUNCTION ibtmyproc()
*
*  -- BLACS tester (version 1.0) --
*  University of Tennessee
*  December 15, 1994
*
*  Purpose
*  =======
*  IBTMYPROC: returns a process number between 0 .. NPROCS-1.  On
*  systems not natively in this numbering scheme, translates to it.
*
*  ====================================================================
*     ..
*     .. Include Files ..
      include 'mpif.h'
*     ..
*     .. Local Scalars ..
      INTEGER rank
*     ..
*     .. Common Blocks ..
      COMMON /btmpi/ btcomm, ierr
      INTEGER btcomm, ierr
*     ..
*     .. Executable Statements ..
*
      CALL mpi_comm_rank(btcomm, rank, ierr)
      IF (ierr.NE.0) CALL btmpierr("MPI_COMM_RANK", ierr)
      ibtmyproc = rank
      RETURN
*
*     End of IBTMYPROC
*
      END
*
      INTEGER FUNCTION ibtnprocs()
*
*  -- BLACS tester (version 1.0) --
*  University of Tennessee
*  December 15, 1994
*
*  Purpose
*  =======
*  IBTNPROCS: returns the number of processes in the machine.
*
*  ====================================================================
*     ..
*     .. Include Files ..
      include 'mpif.h'
*     ..
*     .. Local Scalars ..
      INTEGER nproc
*     ..
*     .. Common Blocks ..
      COMMON /btmpi/ btcomm, ierr
      INTEGER btcomm, ierr
*     ..
*     .. Executable Statements ..
*
      CALL mpi_comm_size(btcomm, nproc, ierr)
      IF (ierr.NE.0) CALL btmpierr("MPI_COMM_SIZE", ierr)
      ibtnprocs = nproc
*
      RETURN
*
*     End of IBTNPROCS
*
      END
*
      SUBROUTINE btsend(DTYPE, N, BUFF, DEST, MSGID)
*
*  -- BLACS tester (version 1.0) --
*  University of Tennessee
*  December 15, 1994
*
*     .. Scalar Arguments ..
      INTEGER N, DTYPE, DEST, MSGID
*     ..
*     .. Array Arguments ..
      REAL BUFF(*)
*     ..
*
*     PURPOSE
*     =======
*     BTSEND: Communication primitive used to send messages independent
*     of the BLACS.  May safely be either locally or globally blocking.
*
*     Arguments
*     =========
*     DTYPE    (input) INTEGER
*              Indicates what data type BUFF is (same as PVM):
*                1  =  RAW BYTES
*                3  =  INTEGER
*                4  =  SINGLE PRECISION REAL
*                6  =  DOUBLE PRECISION REAL
*                5  =  SINGLE PRECISION COMPLEX
*                7  =  DOUBLE PRECISION COMPLEX
*
*     N        (input) INTEGER
*              The number of elements of type DTYPE in BUFF.
*
*     BUFF     (input) accepted as INTEGER array
*              The array to be communicated.  Its true data type is
*              indicated by DTYPE.
*
*     DEST      (input) INTEGER
*               The destination of the message.
*
*     MSGID     (input) INTEGER
*               The message ID (AKA message tag or type).
*
* =====================================================================
*     .. External Functions ..
      INTEGER  IBTMYPROC, IBTNPROCS, IBTSIZEOF
      EXTERNAL IBTMYPROC, IBTNPROCS, IBTSIZEOF
*     ..
*     .. Local Scalars ..
      INTEGER I, IAM, MPIDTYPE
*     ..
*     .. Include Files ..
      include 'mpif.h'
*     ..
*     .. Common Blocks ..
      COMMON /btmpi/ btcomm, ierr
      INTEGER BTCOMM, IERR
*
      IF( dtype .EQ. 1 ) THEN
         mpidtype = mpi_byte
      ELSE IF( dtype .EQ. 3 ) THEN
         mpidtype = mpi_integer
      ELSE IF( dtype .EQ. 4 ) THEN
         mpidtype = mpi_real
      ELSE IF( dtype .EQ. 5 ) THEN
         mpidtype = mpi_complex
      ELSE IF( dtype .EQ. 6 ) THEN
         mpidtype = mpi_double_precision
      ELSE IF( dtype .EQ. 7 ) THEN
         mpidtype = mpi_double_complex
      END IF
*
*     Send the message
*
      IF( dest .EQ. -1 ) THEN
         iam = ibtmyproc()
         DO 10 i = 0, ibtnprocs()-1
            IF( i .NE. iam ) THEN
               CALL mpi_send(buff, n, mpidtype, i, 0, btcomm, ierr)
               IF (ierr.NE.0) CALL btmpierr("MPI_SEND", ierr)
            END IF
   10    CONTINUE
      ELSE
         CALL mpi_send(buff, n, mpidtype, dest, 0, btcomm, ierr)
         IF (ierr.NE.0) CALL btmpierr("MPI_SEND", ierr)
      END IF
*
      RETURN
*
*     End BTSEND
*
      END
*
      SUBROUTINE btrecv(DTYPE, N, BUFF, SRC, MSGID)
*
*  -- BLACS tester (version 1.0) --
*  University of Tennessee
*  December 15, 1994
*
*
*     .. Scalar Arguments ..
      INTEGER N, DTYPE, SRC, MSGID
*     ..
*     .. Array Arguments ..
      REAL BUFF(*)
*     ..
*
*     PURPOSE
*     =======
*     BTRECV: Globally blocking receive.
*
*     Arguments
*     =========
*     DTYPE    (input) INTEGER
*              Indicates what data type BUFF is:
*                1  =  RAW BYTES
*                3  =  INTEGER
*                4  =  SINGLE PRECISION REAL
*                6  =  DOUBLE PRECISION REAL
*                5  =  SINGLE PRECISION COMPLEX
*                7  =  DOUBLE PRECISION COMPLEX
*
*     N        (input) INTEGER
*              The number of elements of type DTYPE in BUFF.
*
*     BUFF     (output) INTEGER
*              The buffer to receive into.
*
*     SRC      (input) INTEGER
*              The source of the message.
*
*     MSGID    (input) INTEGER
*              The message ID.
*
* =====================================================================
*     ..
*     .. Local Scalars ..
      INTEGER MPIDTYPE
*     ..
*     .. Include Files ..
      include 'mpif.h'
*     ..
*     .. Local Arrays ..
      INTEGER STAT(MPI_STATUS_SIZE)
*     ..
*     .. Common Blocks ..
      COMMON /btmpi/ btcomm, ierr
      INTEGER BTCOMM, IERR
*
      IF( dtype .EQ. 1 ) THEN
         mpidtype = mpi_byte
      ELSE IF( dtype .EQ. 3 ) THEN
         mpidtype = mpi_integer
      ELSE IF( dtype .EQ. 4 ) THEN
         mpidtype = mpi_real
      ELSE IF( dtype .EQ. 5 ) THEN
         mpidtype = mpi_complex
      ELSE IF( dtype .EQ. 6 ) THEN
         mpidtype = mpi_double_precision
      ELSE IF( dtype .EQ. 7 ) THEN
         mpidtype = mpi_double_complex
      END IF
*
      CALL mpi_recv( buff, n, mpidtype, src, 0, btcomm, stat, ierr )
      IF (ierr.NE.0) CALL btmpierr("MPI_RECV", ierr)
*
      RETURN
*
*     End of BTRECV
*
      END
*
      INTEGER FUNCTION ibtsizeof(TYPE)
*
*  -- BLACS tester (version 1.0) --
*  University of Tennessee
*  December 15, 1994
*
*     .. Scalar Arguments ..
      CHARACTER*1 type
*     ..
*
*  Purpose
*  =======
*  IBTSIZEOF: Returns the size, in bytes, of the 5 data types.
*  If your platform has a different size for DOUBLE PRECISION, you must
*  change the parameter statement in BLACSTEST as well.
*
*  Arguments
*  =========
*  TYPE     (input) CHARACTER*1
*           The data type who's size is to be determined:
*           'I' : INTEGER
*           'S' : SINGLE PRECISION REAL
*           'D' : DOUBLE PRECISION REAL
*           'C' : SINGLE PRECISION COMPLEX
*           'Z' : DOUBLE PRECISION COMPLEX
*
* =====================================================================
*
*     .. External Functions ..
      LOGICAL  lsame
      EXTERNAL lsame
*     ..
*     .. Include Files ..
      include 'mpif.h'
*     ..
*     .. Common Blocks ..
      COMMON /btmpi/ btcomm, ierr
      INTEGER btcomm, ierr
*     ..
*     .. Local Scalars ..
      INTEGER length
      LOGICAL init
      DATA init /.false./
*     ..
*     .. Executable Statements ..
*
*
*     Initialize MPI, if necessary
*
      IF (.NOT.init) THEN
         CALL mpi_initialized(init, ierr)
         IF (.NOT.init) CALL mpi_init(ierr)
         IF (ierr.NE.0) CALL btmpierr("mpi_init", ierr)
         init = .true.
      END IF
*
      IF( lsame(TYPE, 'I') ) then
         call mpi_type_size( mpi_integer, length, ierr )
         IF (ierr.NE.0) CALL btmpierr("MPI_TYPE_SIZE", ierr)
      ELSE IF( lsame(TYPE, 'S') ) then
         CALL mpi_type_size( mpi_real, length, ierr )
         IF (ierr.NE.0) CALL btmpierr("MPI_TYPE_SIZE", ierr)
      ELSE IF( lsame(TYPE, 'D') ) then
         CALL mpi_type_size( mpi_double_precision, length, ierr )
         IF (ierr.NE.0) CALL btmpierr("MPI_TYPE_SIZE", ierr)
      ELSE IF( lsame(TYPE, 'C') ) then
         CALL mpi_type_size( mpi_complex, length, ierr )
         IF (ierr.NE.0) CALL btmpierr("MPI_TYPE_SIZE", ierr)
      ELSE IF( lsame(TYPE, 'Z') ) then
         CALL mpi_type_size( mpi_double_complex, length, ierr )
         IF (ierr.NE.0) CALL btmpierr("MPI_TYPE_SIZE", ierr)
      END IF
      ibtsizeof = length
*
      RETURN
      END
      SUBROUTINE btmpierr(ROUT, IERR0)
      CHARACTER*(*) rout
      INTEGER ierr0
*     ..
*     .. Include Files ..
      include 'mpif.h'
*     ..
*     .. Common Blocks ..
      COMMON /btmpi/ btcomm, ierr
      INTEGER btcomm, ierr
*
      WRITE(*,1000) rout, ierr
      CALL mpi_abort(btcomm, ierr0, ierr)
*
 1000 FORMAT('Error #',i20,' from routine ',a)
      RETURN
      END