mpi.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
C*******************************************************************
C
C  This file contains stub MPI/BLACS/ScaLAPACK library functions for
C  linking/running MUMPS on a platform where MPI is not installed.
C
C*******************************************************************
C
C MPI
C
C******************************************************************
      SUBROUTINE mpi_bsend( BUF, CNT, DATATYPE, DEST, TAG, COMM,
     &            IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR
      INTEGER BUF(*)
      WRITE(*,*) 'Error. MPI_BSEND should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_bsend
C***********************************************************************
      SUBROUTINE mpi_buffer_attach(BUF, CNT,  IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, IERR
      INTEGER BUF(*)
      ierr = 0
      RETURN
      END SUBROUTINE mpi_buffer_attach
C***********************************************************************
      SUBROUTINE mpi_buffer_detach(BUF, CNT,  IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, IERR
      INTEGER BUF(*)
           ierr = 0
      RETURN
      END SUBROUTINE mpi_buffer_detach
      SUBROUTINE mpi_gather( SENDBUF, CNT, 
     &         DATATYPE, RECVBUF, RECCNT, RECTYPE,
     &         ROOT, COMM, IERR )
      IMPLICIT NONE
      INTEGER CNT, DATATYPE, RECCNT, RECTYPE, ROOT, COMM, IERR
      INTEGER SENDBUF(*), RECVBUF(*)
      IF ( reccnt .NE. cnt ) THEN
        WRITE(*,*) 'ERROR in MPI_GATHER, RECCNT != CNT'
        stop
      ELSE
        CALL mumps_copy( cnt, sendbuf, recvbuf, datatype, ierr )
        IF ( ierr .NE. 0 ) THEN
          WRITE(*,*) 'ERROR in MPI_GATHER, DATATYPE=',datatype
          stop
        END IF
      END IF
      ierr = 0
      RETURN
      END SUBROUTINE mpi_gather
C***********************************************************************
      SUBROUTINE mpi_gatherv( SENDBUF, CNT, 
     &         DATATYPE, RECVBUF, RECCNT, DISPLS, RECTYPE,
     &         ROOT, COMM, IERR )
      IMPLICIT NONE
      INTEGER CNT, DATATYPE, RECTYPE, ROOT, COMM, IERR
      INTEGER RECCNT(1)
      INTEGER SENDBUF(*), RECVBUF(*)
      INTEGER DISPLS(*)
C
C     Note that DISPLS is ignored in this version. One may
C     want to copy in reception buffer with a shift DISPLS(1).
C     This requires passing the offset DISPLS(1) to
C     "MUMPS_COPY_DATATYPE" routines.
C
      IF ( reccnt(1) .NE. cnt ) THEN
        WRITE(*,*) 'ERROR in MPI_GATHERV, RECCNT(1) != CNT'
        stop
      ELSE
        CALL mumps_copy( cnt, sendbuf, recvbuf, datatype, ierr )
        IF ( ierr .NE. 0 ) THEN
          WRITE(*,*) 'ERROR in MPI_GATHERV, DATATYPE=',datatype
          stop
        END IF
      END IF
      ierr = 0
      RETURN
      END SUBROUTINE mpi_gatherv
C***********************************************************************
      SUBROUTINE mpi_allreduce( SENDBUF, RECVBUF, CNT, DATATYPE,
     &                          OPERATION, COMM, IERR )
      IMPLICIT NONE
      INTEGER CNT, DATATYPE, OPERATION, COMM, IERR
      INTEGER SENDBUF(*), RECVBUF(*)
      LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE
      IF (.NOT. mumps_is_in_place(sendbuf, cnt)) THEN
        CALL mumps_copy( cnt, sendbuf, recvbuf, datatype, ierr )
        IF ( ierr .NE. 0 ) THEN
          WRITE(*,*) 'ERROR in MPI_ALLREDUCE, DATATYPE=',datatype
          stop
        END IF
      ENDIF
      ierr = 0
      RETURN
      END SUBROUTINE mpi_allreduce
C***********************************************************************
      SUBROUTINE mpi_reduce( SENDBUF, RECVBUF, CNT, DATATYPE, OP,
     &           ROOT, COMM, IERR )
      IMPLICIT NONE
      INTEGER CNT, DATATYPE, OP, ROOT, COMM, IERR
      INTEGER SENDBUF(*), RECVBUF(*)
      LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE
      IF (.NOT. MUMPS_IS_IN_PLACE(SENDBUF, CNT)) THEN
        CALL mumps_copy( cnt, sendbuf, recvbuf, datatype, ierr )
        IF ( ierr .NE. 0 ) THEN
          WRITE(*,*) 'ERROR in MPI_REDUCE, DATATYPE=',datatype
          stop
        END IF
      ENDIF
      ierr = 0
      RETURN
      END SUBROUTINE mpi_reduce
C***********************************************************************
      SUBROUTINE mpi_reduce_scatter( SENDBUF, RECVBUF, RCVCNT, 
     &           DATATYPE, OP, COMM, IERR )
      IMPLICIT NONE
      INTEGER RCVCNT, DATATYPE, OP, COMM, IERR
      INTEGER SENDBUF(*), RECVBUF(*)
      LOGICAL, EXTERNAL :: MUMPS_IS_IN_PLACE
      IF (.NOT. mumps_is_in_place(sendbuf, rcvcnt)) THEN
        CALL mumps_copy( rcvcnt, sendbuf, recvbuf, datatype, ierr )
        IF ( ierr .NE. 0 ) THEN
          WRITE(*,*) 'ERROR in MPI_REDUCE_SCATTER, DATATYPE=',datatype
          stop
        END IF
      ENDIF
      ierr = 0
      RETURN
      END SUBROUTINE mpi_reduce_scatter
C***********************************************************************
      SUBROUTINE mpi_abort( COMM, IERRCODE, IERR )
      IMPLICIT NONE
      INTEGER COMM, IERRCODE, IERR
      WRITE(*,*) "** MPI_ABORT called"
      stop
      END SUBROUTINE mpi_abort
C***********************************************************************
      SUBROUTINE mpi_alltoall( SENDBUF, SENDCNT, SENDTYPE,
     &                         RECVBUF, RECVCNT, RECVTYPE, COMM, IERR )
      IMPLICIT NONE
      INTEGER SENDCNT, SENDTYPE, RECVCNT, RECVTYPE, COMM, IERR
      INTEGER SENDBUF(*), RECVBUF(*)
      IF ( recvcnt .NE. sendcnt ) THEN
        WRITE(*,*) 'ERROR in MPI_ALLTOALL, RECVCNT != SENDCNT'
        stop
      ELSE IF ( recvtype .NE. sendtype ) THEN
        WRITE(*,*) 'ERROR in MPI_ALLTOALL, RECVTYPE != SENDTYPE'
        stop
      ELSE
        CALL mumps_copy( sendcnt, sendbuf, recvbuf, sendtype, ierr )
        IF ( ierr .NE. 0 ) THEN
          WRITE(*,*) 'ERROR in MPI_ALLTOALL, SENDTYPE=',sendtype
          stop
        END IF
      END IF
      ierr = 0
      RETURN
      END SUBROUTINE mpi_alltoall
C***********************************************************************
      SUBROUTINE mpi_attr_put( COMM, KEY, VAL, IERR )
      IMPLICIT NONE
      INTEGER COMM, KEY, VAL, IERR
      RETURN
      END SUBROUTINE mpi_attr_put
C***********************************************************************
      SUBROUTINE mpi_barrier( COMM, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER COMM, IERR
      ierr = 0
      RETURN
      END SUBROUTINE mpi_barrier
C***********************************************************************
      SUBROUTINE mpi_get_processor_name( NAME, RESULTLEN, IERROR)
      CHARACTER (LEN=*) NAME
      INTEGER RESULTLEN,IERROR
      resultlen = 1
      ierror = 0
      name = 'X'
      RETURN
      END SUBROUTINE mpi_get_processor_name
C***********************************************************************
      SUBROUTINE mpi_bcast( BUFFER, CNT, DATATYPE, ROOT, COMM, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, DATATYPE, ROOT, COMM, IERR
      INTEGER BUFFER( * )
      ierr = 0
      RETURN
      END SUBROUTINE mpi_bcast
C***********************************************************************
      SUBROUTINE mpi_cancel( IREQ, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IREQ, IERR
      ierr = 0
      RETURN
      END SUBROUTINE mpi_cancel
C***********************************************************************
      SUBROUTINE mpi_comm_create( COMM, GROUP, COMM2, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER COMM, GROUP, COMM2, IERR
      ierr = 0
      RETURN
      END SUBROUTINE mpi_comm_create
C***********************************************************************
      SUBROUTINE mpi_comm_dup( COMM, COMM2, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER COMM, COMM2, IERR
      ierr = 0
      RETURN
      END SUBROUTINE mpi_comm_dup
C***********************************************************************
      SUBROUTINE mpi_comm_free( COMM, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER COMM, IERR
      ierr = 0
      RETURN
      END SUBROUTINE mpi_comm_free
C***********************************************************************
      SUBROUTINE mpi_comm_group( COMM, GROUP, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER COMM, GROUP, IERR
      ierr = 0
      RETURN
      END SUBROUTINE mpi_comm_group
C***********************************************************************
      SUBROUTINE mpi_comm_rank( COMM, RANK, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER COMM, RANK, IERR
      rank = 0
      ierr = 0
      RETURN
      END SUBROUTINE mpi_comm_rank
C***********************************************************************
      SUBROUTINE mpi_comm_size( COMM, SIZE, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER COMM, SIZE, IERR
      SIZE = 1
      ierr = 0
      RETURN
      END SUBROUTINE mpi_comm_size
C***********************************************************************
      SUBROUTINE mpi_comm_split( COMM, COLOR, KEY, COMM2, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER COMM, COLOR, KEY, COMM2, IERR
      ierr = 0
      RETURN
      END SUBROUTINE mpi_comm_split
C***********************************************************************
c     SUBROUTINE MPI_ERRHANDLER_SET( COMM, ERRHANDLER, IERR )
c     IMPLICIT NONE
c     INCLUDE 'mpif.h'
c     INTEGER COMM, ERRHANDLER, IERR
c     IERR = 0
c     RETURN
c     END SUBROUTINE MPI_ERRHANDLER_SET
C***********************************************************************
      SUBROUTINE mpi_finalize( IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IERR
      IERR = 0
      return
      END SUBROUTINE mpi_finalize
C***********************************************************************
      SUBROUTINE mpi_get_count( STATUS, DATATYPE, CNT, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER DATATYPE, CNT, IERR
      INTEGER STATUS( MPI_STATUS_SIZE )
      WRITE(*,*) 'Error. MPI_GET_CNT should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_get_count
C***********************************************************************
      SUBROUTINE mpi_group_free( GROUP, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER GROUP, IERR
      ierr = 0
      RETURN
      END SUBROUTINE mpi_group_free
C***********************************************************************
      SUBROUTINE mpi_group_range_excl( GROUP, N, RANGES, GROUP2, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER GROUP, N, GROUP2, IERR
      INTEGER RANGES(*)
      ierr = 0
      RETURN
      END SUBROUTINE mpi_group_range_excl
C***********************************************************************
      SUBROUTINE mpi_group_size( GROUP, SIZE, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER GROUP, SIZE, IERR
      SIZE = 1 ! Or should it be zero ?
      ierr = 0
      RETURN
      END SUBROUTINE mpi_group_size
C***********************************************************************
      SUBROUTINE mpi_init_thread(MPI_THREAD_REQ, THREAD_SUPPORT, IERR)
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IERR, MPI_THREAD_REQ, THREAD_SUPPORT
      ierr = 0
      thread_support=mpi_thread_req
      RETURN
      END SUBROUTINE mpi_init_thread
C***********************************************************************
      SUBROUTINE mpi_init(IERR)
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IERR
      ierr = 0
      RETURN
      END SUBROUTINE mpi_init
C***********************************************************************
      SUBROUTINE mpi_initialized( FLAG, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      LOGICAL FLAG
      INTEGER IERR
      flag = .true.
      ierr = 0
      RETURN
      END SUBROUTINE mpi_initialized
C***********************************************************************
      SUBROUTINE mpi_iprobe( SOURCE, TAG, COMM, FLAG, STATUS, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER SOURCE, TAG, COMM, IERR
      INTEGER STATUS(MPI_STATUS_SIZE)
      LOGICAL FLAG
      flag = .false.
      ierr = 0
      RETURN
      END SUBROUTINE mpi_iprobe
C***********************************************************************
      SUBROUTINE mpi_irecv( BUF, CNT, DATATYPE, SOURCE, TAG, COMM,
     &           IREQ, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, DATATYPE, SOURCE, TAG, COMM, IREQ, IERR
      INTEGER BUF(*)
      ierr = 0
      RETURN
      END SUBROUTINE mpi_irecv
C***********************************************************************
      SUBROUTINE mpi_isend( BUF, CNT, DATATYPE, DEST, TAG, COMM,
     &           IREQ, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR, IREQ
      INTEGER BUF(*)
      WRITE(*,*) 'Error. MPI_ISEND should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_isend
C***********************************************************************
      SUBROUTINE mpi_type_commit( NEWTYP, IERR_MPI )
      IMPLICIT NONE
      INTEGER NEWTYP, IERR_MPI
      RETURN
      END SUBROUTINE mpi_type_commit
C***********************************************************************
      SUBROUTINE mpi_type_free( NEWTYP, IERR_MPI )
      IMPLICIT NONE
      INTEGER NEWTYP, IERR_MPI
      RETURN
      END SUBROUTINE mpi_type_free
C***********************************************************************
      SUBROUTINE mpi_type_contiguous( LENGTH, DATATYPE, NEWTYPE,
     &                                IERR_MPI )
      IMPLICIT NONE
      INTEGER LENGTH, DATATYPE, NEWTYPE, IERR_MPI
      RETURN
      END SUBROUTINE mpi_type_contiguous
C***********************************************************************
      SUBROUTINE mpi_op_create( FUNC, COMMUTE, OP, IERR )
      IMPLICIT NONE
      EXTERNAL func
      LOGICAL COMMUTE
      INTEGER OP, IERR
      op = 0
      RETURN
      END SUBROUTINE mpi_op_create
C***********************************************************************
      SUBROUTINE mpi_op_free( OP, IERR )
      IMPLICIT NONE
      INTEGER OP, IERR
      RETURN
      END SUBROUTINE mpi_op_free
C***********************************************************************
      SUBROUTINE mpi_pack( INBUF, INCNT, DATATYPE, OUTBUF, OUTCNT,
     &           POSITION, COMM, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER INCNT, DATATYPE, OUTCNT, POSITION, COMM, IERR
      INTEGER INBUF(*), OUTBUF(*)
      WRITE(*,*) 'Error. MPI_PACKED should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_pack
C***********************************************************************
      SUBROUTINE mpi_pack_size( INCNT, DATATYPE, COMM, SIZE, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER INCNT, DATATYPE, COMM, SIZE, IERR
      WRITE(*,*) 'Error. MPI_PACK_SIZE should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_pack_size
C***********************************************************************
      SUBROUTINE mpi_probe( SOURCE, TAG, COMM, STATUS, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER SOURCE, TAG, COMM, IERR
      INTEGER STATUS( MPI_STATUS_SIZE )
      WRITE(*,*) 'Error. MPI_PROBE should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_probe
C***********************************************************************
      SUBROUTINE mpi_recv( BUF, CNT, DATATYPE, SOURCE, TAG, COMM,
     &           STATUS, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, DATATYPE, SOURCE, TAG, COMM, IERR
      INTEGER BUF(*), STATUS(MPI_STATUS_SIZE)
      WRITE(*,*) 'Error. MPI_RECV should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_recv
C***********************************************************************
      SUBROUTINE mpi_request_free( IREQ, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IREQ, IERR
      ierr = 0
      RETURN
      END SUBROUTINE mpi_request_free
C***********************************************************************
      SUBROUTINE mpi_send( BUF, CNT, DATATYPE, DEST, TAG, COMM, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR
      INTEGER BUF(*)
      WRITE(*,*) 'Error. MPI_SEND should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_send
C***********************************************************************
      SUBROUTINE mpi_ssend( BUF, CNT, DATATYPE, DEST, TAG, COMM, IERR)
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, DATATYPE, DEST, TAG, COMM, IERR
      INTEGER BUF(*)
      WRITE(*,*) 'Error. MPI_SSEND should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_ssend
C***********************************************************************
      SUBROUTINE mpi_test( IREQ, FLAG, STATUS, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IREQ, IERR
      INTEGER STATUS( MPI_STATUS_SIZE )
      LOGICAL FLAG
      flag = .false.
      ierr = 0
      RETURN
      END SUBROUTINE mpi_test
C***********************************************************************
      SUBROUTINE mpi_unpack( INBUF, INSIZE, POSITION, OUTBUF, OUTCNT,
     &           DATATYPE, COMM, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER INSIZE, POSITION, OUTCNT, DATATYPE, COMM, IERR
      INTEGER INBUF(*), OUTBUF(*)
      WRITE(*,*) 'Error. MPI_UNPACK should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_unpack
C***********************************************************************
      SUBROUTINE mpi_wait( IREQ, STATUS, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER IREQ, IERR
      INTEGER STATUS( MPI_STATUS_SIZE )
      WRITE(*,*) 'Error. MPI_WAIT should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_wait
C***********************************************************************
      SUBROUTINE mpi_waitall( CNT, ARRAY_OF_REQUESTS, STATUS, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, IERR
      INTEGER STATUS( MPI_STATUS_SIZE )
      INTEGER ARRAY_OF_REQUESTS( CNT )
      WRITE(*,*) 'Error. MPI_WAITALL should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_waitall
C***********************************************************************
      SUBROUTINE mpi_waitany( CNT, ARRAY_OF_REQUESTS, INDEX, STATUS,
     &           IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, INDEX, IERR
      INTEGER STATUS( MPI_STATUS_SIZE )
      INTEGER ARRAY_OF_REQUESTS( CNT )
      WRITE(*,*) 'Error. MPI_WAITANY should not be called.'
      stop
      ierr = 0
      RETURN
      END SUBROUTINE mpi_waitany
C***********************************************************************
      DOUBLE PRECISION FUNCTION mpi_wtime( )
C     elapsed time
      DOUBLE PRECISION val
C     write(*,*) 'Entering MPI_WTIME'
      CALL mumps_elapse( val )
      mpi_wtime = val
C     write(*,*) 'Exiting MPI_WTIME'
      RETURN
      END FUNCTION mpi_wtime
 
 
C***********************************************************************
C
C  Utilities to copy data
C
C***********************************************************************
 
      SUBROUTINE mumps_copy( CNT, SENDBUF, RECVBUF, DATATYPE, IERR )
      IMPLICIT NONE
      include 'mpif.h'
      INTEGER CNT, DATATYPE, IERR
      INTEGER SENDBUF(*), RECVBUF(*)
      IF ( DATATYPE .EQ. MPI_INTEGER ) THEN
         CALL mumps_copy_integer( sendbuf, recvbuf, cnt )
      ELSEIF ( datatype .EQ. mpi_logical ) THEN
         CALL mumps_copy_logical( sendbuf, recvbuf, cnt )
      ELSE IF ( datatype .EQ. mpi_real ) THEN
         CALL mumps_copy_real( sendbuf, recvbuf, cnt )
      ELSE IF ( datatype .EQ. mpi_double_precision .OR.
     &        datatype .EQ. mpi_real8 ) THEN
         CALL mumps_copy_double_precision( sendbuf, recvbuf, cnt )
      ELSE IF ( datatype .EQ. mpi_complex ) THEN
         CALL mumps_copy_complex( sendbuf, recvbuf, cnt )
      ELSE IF ( datatype .EQ. mpi_double_complex ) THEN
         CALL mumps_copy_double_complex( sendbuf, recvbuf, cnt )
      ELSE IF ( datatype .EQ. mpi_2double_precision) THEN
         CALL mumps_copy_2double_precision( sendbuf, recvbuf, cnt )
      ELSE IF ( datatype .EQ. mpi_2integer) THEN
         CALL mumps_copy_2integer( sendbuf, recvbuf, cnt )
      ELSE IF ( datatype .EQ. mpi_integer8) THEN
        CALL mumps_copy_integer8( sendbuf, recvbuf, cnt )
      ELSE
        ierr=1
        RETURN
      END IF
      ierr=0
      RETURN
      END SUBROUTINE mumps_copy
 
      SUBROUTINE mumps_copy_integer( S, R, N )
      IMPLICIT NONE
      INTEGER N
      INTEGER S(N),R(N)
      INTEGER I
      DO i = 1, n
        r(i) = s(i)
      END DO
      RETURN
      END SUBROUTINE mumps_copy_integer
      SUBROUTINE mumps_copy_integer8( S, R, N )
      IMPLICIT NONE
      INTEGER N
      INTEGER(8) S(N),R(N)
      INTEGER I
      DO I = 1, n
        r(i) = s(i)
      END DO
      RETURN
      END SUBROUTINE mumps_copy_integer8
      SUBROUTINE mumps_copy_logical( S, R, N )
      IMPLICIT NONE
      INTEGER N
      LOGICAL S(N),R(N)
      INTEGER I
      DO i = 1, n
        r(i) = s(i)
      END DO
      RETURN
      END
      SUBROUTINE mumps_copy_2integer( S, R, N )
      IMPLICIT NONE
      INTEGER N
      INTEGER S(N+N),R(N+N)
      INTEGER I
      DO i = 1, n+n
        r(i) = s(i)
      END DO
      RETURN
      END SUBROUTINE mumps_copy_2integer
      SUBROUTINE mumps_copy_real( S, R, N )
      IMPLICIT NONE
      INTEGER N
      REAL S(N),R(N)
      INTEGER I
      DO i = 1, n
        r(i) = s(i)
      END DO
      RETURN
      END
      SUBROUTINE mumps_copy_2double_precision( S, R, N )
      IMPLICIT NONE
      INTEGER N
      DOUBLE PRECISION S(N+N),R(N+N)
      INTEGER I
      DO i = 1, n+n
        r(i) = s(i)
      END DO
      RETURN
      END SUBROUTINE mumps_copy_2double_precision
      SUBROUTINE mumps_copy_double_precision( S, R, N )
      IMPLICIT NONE
      INTEGER N
      DOUBLE PRECISION S(N),R(N)
      INTEGER I
      DO i = 1, n
        r(i) = s(i)
      END DO
      RETURN
      END
      SUBROUTINE mumps_copy_complex( S, R, N )
      IMPLICIT NONE
      INTEGER N
      COMPLEX S(N),R(N)
      INTEGER I
      DO i = 1, n
        r(i) = s(i)
      END DO
      RETURN
      END SUBROUTINE mumps_copy_complex
      SUBROUTINE mumps_copy_double_complex( S, R, N )
      IMPLICIT NONE
      INTEGER N
C     DOUBLE COMPLEX S(N),R(N)
      COMPLEX(kind=kind(0.0D0)) :: S(N),R(N)
      INTEGER I
      DO i = 1, n
        r(i) = s(i)
      END DO
      RETURN
      END
      LOGICAL FUNCTION mumps_is_in_place( SENDBUF, CNT )
      INTEGER sendbuf(*), cnt
      include 'mpif.h'
      INTEGER :: i
C     Check address using C code
      mumps_is_in_place = .false.
      IF ( cnt .GT. 0 ) THEN
        CALL mumps_checkaddrequal(sendbuf(1), mpi_in_place, i)
        IF (i .EQ. 1) THEN
          mumps_is_in_place = .true.
        ENDIF
      ENDIF
C Begin old code which requires the MPI_IN_PLACE
C variable to have the F2003 attribute VOLATILE
C     IF ( CNT .GT. 0 ) THEN
C       MPI_IN_PLACE = -1
C       IF (SENDBUF(1) .EQ. MPI_IN_PLACE) THEN
C         MPI_IN_PLACE = -9876543
C         IF (MUMPS_CHECK_EQUAL(SENDBUF(1), MPI_IN_PLACE)) THEN
C           MUMPS_IS_IN_PLACE = .TRUE.
C         ENDIF
C       ENDIF
C     ENDIF
C End old code
      RETURN
      END FUNCTION mumps_is_in_place
C Begin old code
C     LOGICAL FUNCTION MUMPS_CHECK_EQUAL(I,J)
C     INTEGER :: I,J
C     IF (I.EQ.J) THEN
C       MUMPS_CHECK_EQUAL = .TRUE. 
C     ELSE
C       MUMPS_CHECK_EQUAL = .FALSE. 
C     ENDIF
C     END FUNCTION MUMPS_CHECK_EQUAL
C End old code
 
 
 
C***********************************************************************
C
C     BLACS
C
C***********************************************************************
      SUBROUTINE blacs_gridinit( CNTXT, C, NPROW, NPCOL )
      IMPLICIT NONE
      INTEGER CNTXT, NPROW, NPCOL
      CHARACTER C
        WRITE(*,*) 'Error. BLACS_GRIDINIT should not be called.'
        STOP
      RETURN
      END SUBROUTINE blacs_gridinit
C***********************************************************************
      SUBROUTINE blacs_gridinfo( CNTXT, NPROW, NPCOL, MYROW, MYCOL )
      IMPLICIT NONE
      INTEGER CNTXT, NPROW, NPCOL, MYROW, MYCOL
        WRITE(*,*) 'Error. BLACS_GRIDINFO should not be called.'
        STOP
      RETURN
      END SUBROUTINE blacs_gridinfo
C***********************************************************************
      SUBROUTINE blacs_gridexit( CNTXT )
      IMPLICIT NONE
      INTEGER CNTXT
        WRITE(*,*) 'Error. BLACS_GRIDEXIT should not be called.'
        stop
      RETURN
      END SUBROUTINE blacs_gridexit
 
 
C***********************************************************************
C
C     ScaLAPACK
C
C***********************************************************************
      SUBROUTINE descinit( DESC, M, N, MB, NB, IRSRC, ICSRC,
     &           ICTXT, LLD, INFO )
      IMPLICIT NONE
      INTEGER ICSRC, ICTXT, INFO, IRSRC, LLD, M, MB, N, NB
      INTEGER DESC( * )
        WRITE(*,*) 'Error. DESCINIT should not be called.'
        stop
      RETURN
      END SUBROUTINE descinit
C***********************************************************************
      INTEGER FUNCTION numroc( N, NB, IPROC, ISRCPROC, NPROCS ) 
      INTEGER n, nb, iproc, isrcproc, nprocs
C     Can be called
      if ( nprocs .ne. 1 ) then
        write(*,*) 'Error. Last parameter from NUMROC should be 1'
        stop
      endif
      IF ( iproc .ne. 0 ) THEN
        WRITE(*,*) 'Error. IPROC should be 0 in NUMROC.'
        stop
      ENDIF
      numroc = n
      RETURN
      END FUNCTION numroc
C***********************************************************************
      SUBROUTINE pcpotrf( UPLO, N, A, IA, JA, DESCA, INFO )
      IMPLICIT NONE
      CHARACTER          UPLO
      INTEGER            IA, INFO, JA, N
      INTEGER            DESCA( * )
      COMPLEX            A( * )
        WRITE(*,*) 'Error. PCPOTRF should not be called.'
        stop
      RETURN
      END SUBROUTINE pcpotrf
C***********************************************************************
      SUBROUTINE pcgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO )
      IMPLICIT NONE
      INTEGER            IA, INFO, JA, M, N
      INTEGER            DESCA( * ), IPIV( * )
      COMPLEX            A( * )
        WRITE(*,*) 'Error. PCGETRF should not be called.'
        stop
      RETURN
      END SUBROUTINE pcgetrf
C***********************************************************************
      SUBROUTINE pctrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA,
     &                    B, IB, JB, DESCB, INFO )
      IMPLICIT NONE
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            IA, IB, INFO, JA, JB, N, NRHS
      INTEGER            DESCA( * ), DESCB( * )
      COMPLEX            A( * ), B( * )
        WRITE(*,*) 'Error. PCTRTRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pctrtrs
C***********************************************************************
      SUBROUTINE pzpotrf( UPLO, N, A, IA, JA, DESCA, INFO )
      IMPLICIT NONE
      CHARACTER          UPLO
      INTEGER            IA, INFO, JA, N
      INTEGER            DESCA( * )
C     DOUBLE COMPLEX     A( * )
      COMPLEX(kind=kind(0.0D0)) ::     A( * )
        WRITE(*,*) 'Error. PZPOTRF should not be called.'
        stop
      RETURN
      END SUBROUTINE pzpotrf
C***********************************************************************
      SUBROUTINE pzgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO )
      IMPLICIT NONE
      INTEGER            IA, INFO, JA, M, N
      INTEGER            DESCA( * ), IPIV( * )
C     DOUBLE COMPLEX     A( * )
      COMPLEX(kind=kind(0.0D0)) ::     A( * )
        WRITE(*,*) 'Error. PZGETRF should not be called.'
        stop
      RETURN
      END SUBROUTINE pzgetrf
C***********************************************************************
      SUBROUTINE pztrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA,
     &                    B, IB, JB, DESCB, INFO )
      IMPLICIT NONE
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            IA, IB, INFO, JA, JB, N, NRHS
      INTEGER            DESCA( * ), DESCB( * )
C     DOUBLE COMPLEX     A( * ), B( * )
      COMPLEX(kind=kind(0.0D0)) ::     A( * ), B( * )
        WRITE(*,*) 'Error. PZTRTRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pztrtrs
C***********************************************************************
      SUBROUTINE pspotrf( UPLO, N, A, IA, JA, DESCA, INFO )
      IMPLICIT NONE
      CHARACTER          UPLO
      INTEGER            IA, INFO, JA, N
      INTEGER            DESCA( * )
      REAL               A( * )
        WRITE(*,*) 'Error. PSPOTRF should not be called.'
        stop
      RETURN
      END SUBROUTINE pspotrf
C***********************************************************************
      SUBROUTINE psgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO )
      IMPLICIT NONE
      INTEGER            IA, INFO, JA, M, N
      INTEGER            DESCA( * ), IPIV( * )
      REAL               A( * )
        WRITE(*,*) 'Error. PSGETRF should not be called.'
        stop
      RETURN
      END SUBROUTINE psgetrf
C***********************************************************************
      SUBROUTINE pstrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA,
     &                    B, IB, JB, DESCB, INFO )
      IMPLICIT NONE
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            IA, IB, INFO, JA, JB, N, NRHS
      INTEGER            DESCA( * ), DESCB( * )
      REAL               A( * ), B( * )
        WRITE(*,*) 'Error. PSTRTRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pstrtrs
C***********************************************************************
      SUBROUTINE pdpotrf( UPLO, N, A, IA, JA, DESCA, INFO )
      IMPLICIT NONE
      CHARACTER          UPLO
      INTEGER            IA, INFO, JA, N
      INTEGER            DESCA( * )
      DOUBLE PRECISION   A( * )
        WRITE(*,*) 'Error. PDPOTRF should not be called.'
        stop
      RETURN
      END SUBROUTINE pdpotrf
C***********************************************************************
      SUBROUTINE pdgetrf( M, N, A, IA, JA, DESCA, IPIV, INFO )
      IMPLICIT NONE
      INTEGER            IA, INFO, JA, M, N
      INTEGER            DESCA( * ), IPIV( * )
      DOUBLE PRECISION   A( * )
        WRITE(*,*) 'Error. PDGETRF should not be called.'
        stop
      RETURN
      END SUBROUTINE pdgetrf
C***********************************************************************
      SUBROUTINE pdtrtrs( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA,
     &                    B, IB, JB, DESCB, INFO )
      IMPLICIT NONE
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            IA, IB, INFO, JA, JB, N, NRHS
      INTEGER            DESCA( * ), DESCB( * )
      DOUBLE PRECISION   A( * ), B( * )
        WRITE(*,*) 'Error. PDTRTRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pdtrtrs
C***********************************************************************
      SUBROUTINE infog2l( GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW,
     &                    MYCOL, LRINDX, LCINDX, RSRC, CSRC )
      IMPLICIT NONE
      INTEGER            CSRC, GCINDX, GRINDX, LRINDX, LCINDX, MYCOL,
     &                   myrow, npcol, nprow, rsrc
      INTEGER            DESC( * )
        WRITE(*,*) 'Error. INFOG2L should not be called.'
        stop
      RETURN
      END SUBROUTINE infog2l
C***********************************************************************
      INTEGER FUNCTION indxg2p( INDXGLOB, NB, IPROC, ISRCPROC, NPROCS )
      INTEGER            indxglob, iproc, isrcproc, nb, nprocs
        indxg2p = 0
        WRITE(*,*) 'Error. INFOG2L should not be called.'
        stop
      RETURN
      END FUNCTION indxg2p
C***********************************************************************
      SUBROUTINE pcscal(N, ALPHA, X, IX, JX, DESCX, INCX)
      IMPLICIT NONE
      INTEGER            INCX, N, IX, JX
      COMPLEX            ALPHA
      COMPLEX            X( * )
      INTEGER            DESCX( * )
        WRITE(*,*) 'Error. PCSCAL should not be called.'
        stop
      RETURN
      END SUBROUTINE pcscal
C***********************************************************************
      SUBROUTINE pzscal(N, ALPHA, X, IX, JX, DESCX, INCX)
      IMPLICIT NONE
      INTEGER            INCX, N, IX, JX
C     DOUBLE COMPLEX     ALPHA
C     DOUBLE COMPLEX     X( * )
      COMPLEX(kind=kind(0.0D0)) :: ALPHA, X( * )
      INTEGER            DESCX( * )
        WRITE(*,*) 'Error. PZSCAL should not be called.'
        stop
      RETURN
      END SUBROUTINE pzscal
C***********************************************************************
      SUBROUTINE pdscal(N, ALPHA, X, IX, JX, DESCX, INCX)
      IMPLICIT NONE
      INTEGER            INCX, N, IX, JX
      DOUBLE PRECISION   ALPHA
      DOUBLE PRECISION   X( * )
      INTEGER            DESCX( * )
        WRITE(*,*) 'Error. PDSCAL should not be called.'
        stop
      RETURN
      END SUBROUTINE pdscal
C***********************************************************************
      SUBROUTINE psscal(N, ALPHA, X, IX, JX, DESCX, INCX)
      IMPLICIT NONE
      INTEGER            INCX, N, IX, JX
      REAL               ALPHA
      REAL               X( * )
      INTEGER            DESCX( * )
        WRITE(*,*) 'Error. PSSCAL should not be called.'
        stop
      RETURN
      END SUBROUTINE psscal
C***********************************************************************
      SUBROUTINE pzdot
     &    ( n, dot, x, ix, jx, descx, incx, y, iy, jy, descy, incy )
      IMPLICIT NONE
      INTEGER N, IX, JX, IY, JY, INCX, INCY
      INTEGER DESCX(*), DESCY(*)
C     DOUBLE COMPLEX X(*), Y(*)
      COMPLEX(kind=kind(0.0D0)) :: X(*), Y(*)
      DOUBLE PRECISION DOT
        dot = 0.0d0
        WRITE(*,*) 'Error. PZDOT should not be called.'
        stop
      RETURN
      END SUBROUTINE pzdot
C***********************************************************************
      SUBROUTINE pcdot
     &    ( n, dot, x, ix, jx, descx, incx, y, iy, jy, descy, incy )
      IMPLICIT NONE
      INTEGER N, IX, JX, IY, JY, INCX, INCY
      INTEGER DESCX(*), DESCY(*)
      COMPLEX X(*), Y(*)
      REAL DOT
        DOT = 0.0e0
        WRITE(*,*) 'Error. PCDOT should not be called.'
        stop
      RETURN
      END SUBROUTINE pcdot
C***********************************************************************
      SUBROUTINE pddot
     &    ( n, dot, x, ix, jx, descx, incx, y, iy, jy, descy, incy )
      IMPLICIT NONE
      INTEGER N, IX, JX, IY, JY, INCX, INCY
      INTEGER DESCX(*), DESCY(*)
      DOUBLE PRECISION X(*), Y(*), DOT
        dot = 0.0d0
        WRITE(*,*) 'Error. PDDOT should not be called.'
        stop
      RETURN
      END SUBROUTINE pddot
C***********************************************************************
      SUBROUTINE psdot
     &    ( n, dot, x, ix, jx, descx, incx, y, iy, jy, descy, incy )
      IMPLICIT NONE
      INTEGER N, IX, JX, IY, JY, INCX, INCY
      INTEGER DESCX(*), DESCY(*)
      REAL X(*), Y(*), DOT
        dot = 0.0e0
        WRITE(*,*) 'Error. PSDOT should not be called.'
        stop
      RETURN
      END SUBROUTINE psdot
C***********************************************************************
      SUBROUTINE zgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA )
      IMPLICIT NONE
      INTEGER CONTXT, M, N, LDA
C     DOUBLE COMPLEX A(*)
      COMPLEX(kind=kind(0.0D0)) :: A(*)
      CHARACTER SCOPE, TOP
        WRITE(*,*) 'Error. ZGEBS2D should not be called.'
        stop
      RETURN
      END SUBROUTINE zgebs2d
C***********************************************************************
      SUBROUTINE cgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA )
      IMPLICIT NONE
      INTEGER CONTXT, M, N, LDA
      COMPLEX A(*)
      CHARACTER SCOPE, TOP
        WRITE(*,*) 'Error. CGEBS2D should not be called.'
        stop
      RETURN
      END SUBROUTINE cgebs2d
C***********************************************************************
      SUBROUTINE sgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA )
      IMPLICIT NONE
      INTEGER CONTXT, M, N, LDA
      REAL A(*)
      CHARACTER SCOPE, TOP
        WRITE(*,*) 'Error. SGEBS2D should not be called.'
        stop
      RETURN
      END SUBROUTINE sgebs2d
C***********************************************************************
      SUBROUTINE dgebs2d( CONTXT, SCOPE, TOP, M, N, A, LDA )
      IMPLICIT NONE
      INTEGER CONTXT, M, N, LDA
      DOUBLE PRECISION A(*)
      CHARACTER SCOPE, TOP
        WRITE(*,*) 'Error. DGEBS2D should not be called.'
        stop
      RETURN
      END SUBROUTINE dgebs2d
C***********************************************************************
      SUBROUTINE zgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA )
      IMPLICIT NONE
      INTEGER CONTXT, M, N, LDA
C     DOUBLE COMPLEX A(*)
      COMPLEX(kind=kind(0.0D0)) :: A(*)
      CHARACTER SCOPE, TOP
        WRITE(*,*) 'Error. ZGEBR2D should not be called.'
        stop
      RETURN
      END SUBROUTINE zgebr2d
C***********************************************************************
      SUBROUTINE cgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA )
      IMPLICIT NONE
      INTEGER CONTXT, M, N, LDA
      COMPLEX A(*)
      CHARACTER SCOPE, TOP
        WRITE(*,*) 'Error. CGEBR2D should not be called.'
        stop
      RETURN
      END SUBROUTINE cgebr2d
C***********************************************************************
      SUBROUTINE sgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA )
      IMPLICIT NONE
      INTEGER CONTXT, M, N, LDA
      REAL A(*)
      CHARACTER SCOPE, TOP
        WRITE(*,*) 'Error. SGEBR2D should not be called.'
        stop
      RETURN
      END SUBROUTINE sgebr2d
C***********************************************************************
      SUBROUTINE dgebr2d( CONTXT, SCOPE, TOP, M, N, A, LDA )
      IMPLICIT NONE
      INTEGER CONTXT, M, N, LDA
      DOUBLE PRECISION A(*)
      CHARACTER SCOPE, TOP
        WRITE(*,*) 'Error. DGEBR2D should not be called.'
        stop
      RETURN
      END SUBROUTINE dgebr2d
C***********************************************************************
      SUBROUTINE pcgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B,
     &                    IB, JB, DESCB, INFO )
      IMPLICIT NONE
      CHARACTER          TRANS
      INTEGER            IA, IB, INFO, JA, JB, N, NRHS
      INTEGER            DESCA( * ), DESCB( * ), IPIV( * )
      COMPLEX            A( * ), B( * )
        WRITE(*,*) 'Error. PCGETRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pcgetrs
C***********************************************************************
      SUBROUTINE pzgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B,
     &                    IB, JB, DESCB, INFO )
      IMPLICIT NONE
      CHARACTER          TRANS
      INTEGER            IA, IB, INFO, JA, JB, N, NRHS
      INTEGER            DESCA( * ), DESCB( * ), IPIV( * )
c     DOUBLE COMPLEX     A( * ), B( * )
      COMPLEX(kind=kind(0.0D0)) ::     A( * ), B( * )
        WRITE(*,*) 'Error. PZGETRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pzgetrs
C***********************************************************************
      SUBROUTINE psgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B,
     &                    IB, JB, DESCB, INFO )
      IMPLICIT NONE
      CHARACTER          TRANS
      INTEGER            IA, IB, INFO, JA, JB, N, NRHS
      INTEGER            DESCA( * ), DESCB( * ), IPIV( * )
      REAL               A( * ), B( * )
        WRITE(*,*) 'Error. PSGETRS should not be called.'
        stop
      RETURN
      END SUBROUTINE psgetrs
C***********************************************************************
      SUBROUTINE pdgetrs( TRANS, N, NRHS, A, IA, JA, DESCA, IPIV, B,
     &                    IB, JB, DESCB, INFO )
      IMPLICIT NONE
      CHARACTER          TRANS
      INTEGER            IA, IB, INFO, JA, JB, N, NRHS
      INTEGER            DESCA( * ), DESCB( * ), IPIV( * )
      DOUBLE PRECISION   A( * ), B( * )
        WRITE(*,*) 'Error. PDGETRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pdgetrs
C***********************************************************************
      SUBROUTINE pcpotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB,
     &           DESCB, INFO )
      IMPLICIT NONE
      CHARACTER       UPLO
      INTEGER         IA, IB, INFO, JA, JB, N, NRHS
      INTEGER         DESCA( * ), DESCB( * )
      COMPLEX         A( * ), B( * )
        WRITE(*,*) 'Error. PCPOTRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pcpotrs
C***********************************************************************
      SUBROUTINE pzpotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB,
     &           DESCB, INFO )
      IMPLICIT NONE
      CHARACTER       UPLO
      INTEGER         IA, IB, INFO, JA, JB, N, NRHS
      INTEGER         DESCA( * ), DESCB( * )
c     DOUBLE COMPLEX     A( * ), B( * )
      COMPLEX(kind=kind(0.0D0)) ::     A( * ), B( * )
        WRITE(*,*) 'Error. PZPOTRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pzpotrs
C***********************************************************************
      SUBROUTINE pspotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB,
     &           DESCB, INFO )
      IMPLICIT NONE
      CHARACTER       UPLO
      INTEGER         IA, IB, INFO, JA, JB, N, NRHS
      INTEGER         DESCA( * ), DESCB( * )
      REAL            A( * ), B( * )
        WRITE(*,*) 'Error. PSPOTRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pspotrs
C***********************************************************************
      SUBROUTINE pdpotrs( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB,
     &           DESCB, INFO )
      IMPLICIT NONE
      CHARACTER       UPLO
      INTEGER         IA, IB, INFO, JA, JB, N, NRHS
      INTEGER         DESCA( * ), DESCB( * )
      DOUBLE          PRECISION A( * ), B( * )
        WRITE(*,*) 'Error. PDPOTRS should not be called.'
        stop
      RETURN
      END SUBROUTINE pdpotrs
C***********************************************************************
      SUBROUTINE pscnrm2( N, NORM2, X, IX, JX, DESCX, INCX )
      IMPLICIT NONE
      INTEGER N, IX, JX, INCX
      INTEGER DESCX(*)
      REAL NORM2
      COMPLEX X( * )
        WRITE(*,*) 'Error. PCNRM2 should not be called.'
        stop
      RETURN
      END SUBROUTINE pscnrm2
C***********************************************************************
      SUBROUTINE pdznrm2( N, NORM2, X, IX, JX, DESCX, INCX )
      IMPLICIT NONE
      INTEGER N, IX, JX, INCX
      INTEGER DESCX(*)
      DOUBLE PRECISION NORM2
C     DOUBLE COMPLEX X( * )
      COMPLEX(kind=kind(0.0D0)) :: X( * )
        WRITE(*,*) 'Error. PZNRM2 should not be called.'
        stop
      RETURN
      END SUBROUTINE pdznrm2
C***********************************************************************
      SUBROUTINE psnrm2( N, NORM2, X, IX, JX, DESCX, INCX )
      IMPLICIT NONE
      INTEGER N, IX, JX, INCX
      INTEGER DESCX(*)
      REAL    NORM2, X( * )
        WRITE(*,*) 'Error. PSNRM2 should not be called.'
        stop
      RETURN
      END SUBROUTINE psnrm2
C***********************************************************************
      SUBROUTINE pdnrm2( N, NORM2, X, IX, JX, DESCX, INCX )
      IMPLICIT NONE
      INTEGER N, IX, JX, INCX
      INTEGER DESCX(*)
      DOUBLE PRECISION NORM2, X( * )
        WRITE(*,*) 'Error. PDNRM2 should not be called.'
        stop
      RETURN
      END SUBROUTINE pdnrm2
C***********************************************************************
      REAL function pclange( norm, m, n, a, ia,  ja,
     &                 desca, work )
      CHARACTER    norm
      INTEGER      ia, ja, m, n
      INTEGER      desca( * )
      COMPLEX      a( * ), work( * )
      pclange = 0.0e0
        WRITE(*,*) 'Error. PCLANGE should not be called.'
        stop
      RETURN
      END FUNCTION pclange
C***********************************************************************
      DOUBLE PRECISION FUNCTION pzlange( NORM, M, N, A, IA,  JA,
     &                 DESCA, WORK )
      CHARACTER    norm
      INTEGER      ia, ja, m, n
      INTEGER      desca( * )
      REAL         a( * ), work( * )
      pzlange = 0.0d0
        WRITE(*,*) 'Error. PZLANGE should not be called.'
        stop
      RETURN
      END FUNCTION pzlange
C***********************************************************************
      REAL function pslange( norm, m, n, a, ia,  ja,
     &                 desca, work )
      CHARACTER    norm
      INTEGER      ia, ja, m, n
      INTEGER      desca( * )
      REAL         a( * ), work( * )
      pslange = 0.0e0
        WRITE(*,*) 'Error. PSLANGE should not be called.'
        stop
      RETURN
      END FUNCTION pslange
C***********************************************************************
      DOUBLE PRECISION FUNCTION pdlange( NORM, M, N, A, IA,  JA,
     &                 DESCA, WORK )
      CHARACTER    norm
      INTEGER      ia, ja, m, n
      INTEGER      desca( * )
      DOUBLE       PRECISION a( * ), work( * )
      pdlange = 0.0d0
        WRITE(*,*) 'Error. PDLANGE should not be called.'
        stop
      RETURN
      END FUNCTION pdlange
C***********************************************************************
      SUBROUTINE pcgecon( NORM, N,  A,  IA,  JA,  DESCA,  ANORM,
     &           RCOND,  WORK,  LWORK,  IWORK,  LIWORK, INFO )
      IMPLICIT NONE
 
      CHARACTER       NORM
      INTEGER         IA, INFO, JA, LIWORK, LWORK, N
      REAL            ANORM, RCOND
      INTEGER         DESCA( * ), IWORK( * )
      COMPLEX         A( * ), WORK( * )
        WRITE(*,*) 'Error. PCGECON should not be called.'
        stop
      RETURN
      END SUBROUTINE pcgecon
C***********************************************************************
      SUBROUTINE pzgecon( NORM, N,  A,  IA,  JA,  DESCA,  ANORM,
     &           RCOND,  WORK,  LWORK,  IWORK,  LIWORK, INFO )
      IMPLICIT NONE
 
      CHARACTER       NORM
      INTEGER         IA, INFO, JA, LIWORK, LWORK, N
      DOUBLE PRECISION ANORM, RCOND
      INTEGER         DESCA( * ), IWORK( * )
C     DOUBLE COMPLEX  A( * ), WORK( * )
      COMPLEX(kind=kind(0.0D0)) :: A( * ), WORK( * )
        WRITE(*,*) 'Error. PZGECON should not be called.'
        stop
      RETURN
      END SUBROUTINE pzgecon
C***********************************************************************
      SUBROUTINE psgecon( NORM, N,  A,  IA,  JA,  DESCA,  ANORM,
     &           RCOND,  WORK,  LWORK,  IWORK,  LIWORK, INFO )
      IMPLICIT NONE
 
      CHARACTER       NORM
      INTEGER         IA, INFO, JA, LIWORK, LWORK, N
      REAL            ANORM, RCOND
      INTEGER         DESCA( * ), IWORK( * )
      REAL            A( * ), WORK( * )
        WRITE(*,*) 'Error. PSGECON should not be called.'
        stop
      RETURN
      END SUBROUTINE psgecon
C***********************************************************************
      SUBROUTINE pdgecon( NORM, N,  A,  IA,  JA,  DESCA,  ANORM,
     &           RCOND,  WORK,  LWORK,  IWORK,  LIWORK, INFO )
      IMPLICIT NONE
 
      CHARACTER       NORM
      INTEGER         IA, INFO, JA, LIWORK, LWORK, N
      DOUBLE          PRECISION ANORM, RCOND
      INTEGER         DESCA( * ), IWORK( * )
      DOUBLE          PRECISION A( * ), WORK( * )
        WRITE(*,*) 'Error. PDGECON should not be called.'
        stop
      RETURN
      END SUBROUTINE pdgecon
C***********************************************************************
      SUBROUTINE pcgeqpf( M,  N,  A,  IA,  JA, DESCA, IPIV, TAU,
     &           WORK, LWORK, INFO )
      IMPLICIT NONE
      INTEGER    IA, JA, INFO, LWORK, M, N
      INTEGER    DESCA( * ), IPIV( * )
      COMPLEX    A( * ), TAU( * ), WORK( * )
        WRITE(*,*) 'Error. PCGEQPF should not be called.'
        stop
      RETURN
      END SUBROUTINE pcgeqpf
C***********************************************************************
      SUBROUTINE pzgeqpf( M,  N,  A,  IA,  JA, DESCA, IPIV, TAU,
     &           WORK, LWORK, INFO )
      IMPLICIT NONE
      INTEGER    IA, JA, INFO, LWORK, M, N
      INTEGER    DESCA( * ), IPIV( * )
C     DOUBLE COMPLEX A( * ), TAU( * ), WORK( * )
      COMPLEX(kind=kind(0.0D0)) :: A( * ), TAU( * ), WORK( * )
        WRITE(*,*) 'Error. PZGEQPF should not be called.'
        stop
      RETURN
      END SUBROUTINE pzgeqpf
C***********************************************************************
      SUBROUTINE psgeqpf( M,  N,  A,  IA,  JA, DESCA, IPIV, TAU,
     &           WORK, LWORK, INFO )
      IMPLICIT NONE
      INTEGER         IA, JA, INFO, LWORK, M, N
      INTEGER         DESCA( * ), IPIV( * )
      REAL       A( * ), TAU( * ), WORK( * )
        WRITE(*,*) 'Error. PSGEQPF should not be called.'
        stop
      RETURN
      END SUBROUTINE psgeqpf
C***********************************************************************
      SUBROUTINE pdgeqpf( M,  N,  A,  IA,  JA, DESCA, IPIV, TAU,
     &           WORK, LWORK, INFO )
      IMPLICIT NONE
      INTEGER         IA, JA, INFO, LWORK, M, N
      INTEGER         DESCA( * ), IPIV( * )
      DOUBLE PRECISION A( * ), TAU( * ), WORK( * )
        WRITE(*,*) 'Error. PDGEQPF should not be called.'
        stop
      RETURN
      END SUBROUTINE pdgeqpf
C***********************************************************************
      SUBROUTINE pcaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY,
     &           DESCY, INCY)
      IMPLICIT NONE
      INTEGER N, IX, IY, JX, JY, INCX, INCY
      INTEGER DESCX(*), DESCY(*)
      COMPLEX A(*),X(*),Y(*)
        WRITE(*,*) 'Error. PCAXPY should not be called.'
        stop
      RETURN
      END SUBROUTINE pcaxpy
C***********************************************************************
      SUBROUTINE pzaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY,
     &           DESCY, INCY)
      IMPLICIT NONE
      INTEGER N, IX, IY, JX, JY, INCX, INCY
      INTEGER DESCX(*), DESCY(*)
C     DOUBLE COMPLEX A(*),X(*),Y(*)
      COMPLEX(kind=kind(0.0D0)) :: A(*),X(*),Y(*)
        WRITE(*,*) 'Error. PZAXPY should not be called.'
        stop
      RETURN
      END SUBROUTINE pzaxpy
C***********************************************************************
      SUBROUTINE psaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY,
     &           DESCY, INCY)
      IMPLICIT NONE
      INTEGER N, IX, IY, JX, JY, INCX, INCY
      INTEGER DESCX(*), DESCY(*)
      REAL A(*),X(*),Y(*)
        WRITE(*,*) 'Error. PSAXPY should not be called.'
        stop
      RETURN
      END SUBROUTINE psaxpy
C***********************************************************************
      SUBROUTINE pdaxpy(N, A, X, IX, JX, DESCX, INCX, Y, IY, JY,
     &           DESCY, INCY)
      IMPLICIT NONE
      INTEGER N, IX, IY, JX, JY, INCX, INCY
      INTEGER DESCX(*), DESCY(*)
      DOUBLE PRECISION A(*),X(*),Y(*)
        WRITE(*,*) 'Error. PDAXPY should not be called.'
        stop
      RETURN
      END SUBROUTINE pdaxpy
C***********************************************************************
      SUBROUTINE pctrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA,
     $                   JA, DESCA, B, IB, JB, DESCB )
      IMPLICIT NONE
      CHARACTER          SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, IA, JA, IB, JB
      COMPLEX            ALPHA
      INTEGER            DESCA( * ), DESCB( * )
      COMPLEX            A( * ), B( * )
        WRITE(*,*) 'Error. PCTRSM should not be called.'
        stop
      RETURN
      END SUBROUTINE pctrsm 
C***********************************************************************
      SUBROUTINE pztrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA,
     $                   JA, DESCA, B, IB, JB, DESCB )
      IMPLICIT NONE
      CHARACTER          SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, IA, JA, IB, JB
C     DOUBLE COMPLEX     ALPHA
      COMPLEX(kind=kind(0.0D0)) ::     ALPHA
      INTEGER            DESCA( * ), DESCB( * )
C     DOUBLE COMPLEX     A( * ), B( * )
      COMPLEX(kind=kind(0.0D0)) ::     A( * ), B( * )
        WRITE(*,*) 'Error. PZTRSM should not be called.'
        stop
      RETURN
      END SUBROUTINE pztrsm 
C***********************************************************************
      SUBROUTINE pstrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA,
     $                   JA, DESCA, B, IB, JB, DESCB )
      IMPLICIT NONE
      CHARACTER          SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, IA, JA, IB, JB
      REAL               ALPHA
      INTEGER            DESCA( * ), DESCB( * )
      REAL               A( * ), B( * )
        WRITE(*,*) 'Error. PSTRSM should not be called.'
        stop
      RETURN
      END SUBROUTINE pstrsm 
C***********************************************************************
      SUBROUTINE pdtrsm ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, IA,
     $                   JA, DESCA, B, IB, JB, DESCB )
      IMPLICIT NONE
      CHARACTER          SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, IA, JA, IB, JB
      DOUBLE PRECISION   ALPHA
      INTEGER            DESCA( * ), DESCB( * )
      DOUBLE PRECISION   A( * ), B( * )
        WRITE(*,*) 'Error. PDTRSM should not be called.'
        stop
      RETURN
      END SUBROUTINE pdtrsm 
C***********************************************************************
      SUBROUTINE pcunmqr( SIDE,  TRANS,  M,  N,  K,  A,  IA, JA,
     &                    DESCA, TAU, C, IC,  JC,  DESCC,  WORK,
     &                    LWORK, INFO )
      IMPLICIT NONE
      CHARACTER SIDE, TRANS
      INTEGER   IA, IC, INFO, JA, JC, K, LWORK, M, N
      INTEGER   DESCA( * ), DESCC( * )
      COMPLEX   A(  *  ), C( * ), TAU( * ), WORK( * )
        WRITE(*,*) 'Error. PCUNMQR should not be called.'
        stop
      RETURN
      END SUBROUTINE pcunmqr
C***********************************************************************
      SUBROUTINE pzunmqr( SIDE,  TRANS,  M,  N,  K,  A,  IA, JA,
     &                    DESCA, TAU, C, IC,  JC,  DESCC,  WORK,
     &                    LWORK, INFO )
      IMPLICIT NONE
      CHARACTER SIDE, TRANS
      INTEGER   IA, IC, INFO, JA, JC, K, LWORK, M, N
      INTEGER   DESCA( * ), DESCC( * )
C     DOUBLE COMPLEX A(  *  ), C( * ), TAU( * ), WORK( * )
      COMPLEX(kind=kind(0.0D0)) :: A(  *  ), C( * ), TAU( * ), WORK( * )
        WRITE(*,*) 'Error. PZUNMQR should not be called.'
        stop
      RETURN
      END SUBROUTINE pzunmqr
C***********************************************************************
      SUBROUTINE psormqr( SIDE,  TRANS,  M,  N,  K,  A,  IA, JA,
     &                    DESCA, TAU, C, IC,  JC,  DESCC,  WORK,
     &                    LWORK, INFO )
      IMPLICIT NONE
      CHARACTER SIDE, TRANS
      INTEGER   IA, IC, INFO, JA, JC, K, LWORK, M, N
      INTEGER   DESCA( * ), DESCC( * )
      REAL      A(  *  ), C( * ), TAU( * ), WORK( * )
        WRITE(*,*) 'Error. PSORMQR should not be called.'
        stop
      RETURN
      END SUBROUTINE psormqr
C***********************************************************************
      SUBROUTINE pdormqr( SIDE,  TRANS,  M,  N,  K,  A,  IA, JA,
     &                    DESCA, TAU, C, IC,  JC,  DESCC,  WORK,
     &                    LWORK, INFO )
      IMPLICIT NONE
      CHARACTER SIDE, TRANS
      INTEGER         IA, IC, INFO, JA, JC, K, LWORK, M, N
      INTEGER         DESCA( * ), DESCC( * )
      DOUBLE PRECISION  A(  *  ), C( * ), TAU( * ), WORK( * )
        WRITE(*,*) 'Error. PDORMQR should not be called.'
        stop
      RETURN
      END SUBROUTINE pdormqr
C***********************************************************************
      SUBROUTINE chk1mat( MA, MAPOS0, NA, NAPOS0, IA, JA, DESCA,
     &                    DESCAPOS0, INFO )
      IMPLICIT NONE
      INTEGER            DESCAPOS0, IA, INFO, JA, MA, MAPOS0, NA, NAPOS0
      INTEGER            DESCA( * )
        WRITE(*,*) 'Error. CHK1MAT should not be called.'
        STOP
      RETURN
      END SUBROUTINE chk1mat
C***********************************************************************
      SUBROUTINE pchk2mat( MA, MAPOS0, NA, NAPOS0, IA, JA, DESCA,
     &                     DESCAPOS0, MB, MBPOS0, NB, NBPOS0, IB, JB,
     &                     DESCB, DESCBPOS0, NEXTRA, EX, EXPOS, INFO )
      IMPLICIT NONE
      INTEGER            DESCAPOS0, DESCBPOS0, IA, IB, INFO, JA, JB, MA,
     &                   mapos0, mb, mbpos0, na, napos0, nb, nbpos0,
     &                   nextra
      INTEGER            DESCA( * ), DESCB( * ), EX( NEXTRA ),
     &                   EXPOS( NEXTRA )
        WRITE(*,*) 'Error. PCHK2MAT should not be called.'
        stop
      RETURN
      END SUBROUTINE pchk2mat
C***********************************************************************
      SUBROUTINE pxerbla( CONTXT, SRNAME, INFO )
      IMPLICIT NONE
      INTEGER CONTXT, INFO
      CHARACTER SRNAME
        WRITE(*,*) 'Error. PXERBLA should not be called.'
        stop
      RETURN
      END SUBROUTINE pxerbla
C***********************************************************************
      SUBROUTINE descset( DESC, M, N, MB, NB, IRSRC, ICSRC, ICTXT,
     &                    LLD )
      IMPLICIT NONE
      INTEGER            ICSRC, ICTXT, IRSRC, LLD, M, MB, N, NB
      INTEGER            DESC( * )
        WRITE(*,*) 'Error. DESCSET should not be called.'
        stop
      RETURN
      END SUBROUTINE descset