#if defined(RS6K)
      SUBROUTINE SGEMMX(NRP,NCP,M,
     &                  ONE,SA,IAC,IAR,SB,IBC,IBR,
     &                  ZER,SC,ICC,ICR)
      REAL SA(*),SB(*),SC(*)
      REAL A(NRP*m),B(m*NCP),C(NRP*NCP)
      INTEGER(KIND=8):: PA,PB,PC
      CHARACTER*1 CA1,CA2,CB1,CB2,CC1,CC2
C
C   Check if ONE and ZERO have valid values, else ABORT
C
      IF (ONE.NE.1.0D0.OR.ZER.NE.0.0D0)
     &     CALL ABOR1(' UNVALID ARGUMENTS IN SGEMMX CALL')
 
      if(ncp.eq.0) return

      PA=LOC(A)
      PB=LOC(B)
      PC=LOC(C)
      IF(IAC.EQ.1) THEN
        PA=LOC(SA)
        IAL=IAR
        CA1="N"
        CA2="T"
      ENDIF
      IF(IAR.EQ.1) THEN
        PA=LOC(SA)
        IAL=IAC
        CA1="N"
        CA2="T"
      ENDIF
      IF(IBC.EQ.1) THEN
        PB=LOC(SB)
        IBL=IBR
        CB1="N"
        CB2="T"
      ENDIF
      IF(IBR.EQ.1) THEN
        PB=LOC(SB)
        IBL=IBC
        CB1="N"
        CB2="T"
      ENDIF
      IF(ICC.EQ.1 .AND. ICR.EQ.NRP) PC=LOC(SC)
!     write(0,*) "IAC,IBC,ICC,IAR,IBR,ICR,NRP,NCP,M=",
!    &            IAC,IBC,ICC,IAR,IBR,ICR,NRP,NCP,M
!     write(0,*) "loc(a),pa",loc(a),pa  
!     write(0,*) "loc(b),pb",loc(b),pb  
!     write(0,*) "loc(c),pc",loc(c),pc  

!     write(0,'(a,i12,9i8)') 
!    &  "SGEMMX: NRP*NCP*M,NRP,NCP,M,IAC,IAR,IBC,IBR,ICC,ICR=",
!    &           NRP*NCP*M,NRP,NCP,M,IAC,IAR,IBC,IBR,ICC,ICR

      if(pa.eq.loc(a)) then
!       write(0,*) "copying a"
        if(iar.gt.iac) then
          do j=1,m
            do i=1,nrp
              a(i+(j-1)*nrp)=SA(1+(I-1)*IAC+(J-1)*IAR)
            enddo
          enddo
          ial=nrp
          CA1="N"
          CA2="T"
        else
          do i=1,nrp
            do j=1,m
              a(j+(i-1)*m)=SA(1+(I-1)*IAC+(J-1)*IAR)
            enddo
          enddo
          ial=m
          CA1="N"
          CA2="T"
        endif
      endif
C
      if(pb.eq.loc(b)) then
!       write(0,*) "copying b"
        if(ibr.gt.ibc) then
          do k=1,ncp
            do j=1,m
              b(j+(k-1)*m)=SB(1+(J-1)*IBC+(K-1)*IBR)
            enddo
          enddo
          ibl=m
          CB1="N"
          CB2="T"
        else
          do j=1,m
            do k=1,ncp
              b(k+(j-1)*ncp)=SB(1+(J-1)*IBC+(K-1)*IBR)
            enddo
          enddo
          ibl=ncp
          CB1="N"
          CB2="T"
        endif
      endif

C     CALL DGEMM('N','N',NRP,NCP,M,ONE,A,NRP,B,M,ZER,C,NRP)

      call sgemmxz(a,b)

      if(icr.gt.icc) then
        if(ibr.gt.ibc) then
          if(iar.gt.iac) then
            CALL DGEMUL(%VAL(PA),IAL,CA1,
     &                  %VAL(PB),IBL,CB1,%VAL(PC),NRP,NRP,M,NCP)
          else
            CALL DGEMUL(%VAL(PA),IAL,CA2,
     &                  %VAL(PB),IBL,CB1,%VAL(PC),NRP,NRP,M,NCP)
          endif
        else
          if(iar.gt.iac) then
            CALL DGEMUL(%VAL(PA),IAL,CA1,
     &                  %VAL(PB),IBL,CB2,%VAL(PC),NRP,NRP,M,NCP)
          else
            CALL DGEMUL(%VAL(PA),IAL,CA2,
     &                  %VAL(PB),IBL,CB2,%VAL(PC),NRP,NRP,M,NCP)
          endif
        endif
      else
        if(ibr.gt.ibc) then
          if(iar.gt.iac) then
            CALL DGEMUL(%VAL(PB),IBL,CB2,
     &                  %VAL(PA),IAL,CA2,%VAL(PC),NCP,NCP,M,NRP)
          else
            CALL DGEMUL(%VAL(PB),IBL,CB2,
     &                  %VAL(PA),IAL,CA1,%VAL(PC),NCP,NCP,M,NRP)
          endif
        else
          if(iar.gt.iac) then
            CALL DGEMUL(%VAL(PB),IBL,CB1,
     &                  %VAL(PA),IAL,CA2,%VAL(PC),NCP,NCP,M,NRP)
          else
            CALL DGEMUL(%VAL(PB),IBL,CB1,
     &                  %VAL(PA),IAL,CA1,%VAL(PC),NCP,NCP,M,NRP)
          endif
        endif
      endif

      if(pc.eq.loc(c)) then
!       write(0,*) "copying c"
        if(icr.gt.icc) then
          do k=1,ncp
            do i=1,nrp
              SC(1+(I-1)*ICC+(K-1)*ICR)=c(i+nrp*(k-1))
            enddo
          enddo
        else
          do i=1,nrp
            do k=1,ncp
              SC(1+(I-1)*ICC+(K-1)*ICR)=c(k+ncp*(i-1))
            enddo
          enddo
        endif
      endif

!     do i=1,nrp
!       do k=1,ncp
!         write(0,*) SC(1+(I-1)*ICC+(K-1)*ICR)
!       enddo
!     enddo

      RETURN
      END

      subroutine sgemmxz(a,b)
      end
#elif defined(BLAS) && !defined(USE_MATMUL)
!OCL  NOUNROLL,NOPREEX,NOEVAL
      SUBROUTINE SGEMMX(NRP,NCP,M,
     &                  ONE,SA,IAC,IAR,SB,IBC,IBR,
     &                  ZER,SC,ICC,ICR)
C
C  Fortran subroutine equivalent to SGEMMX using SSLII dvmggm routine
C
C   C=A*B  , with arbitrary increments IAC,IAR, IBC,IBR, ICC,ICR
C
C  It will only work if ONE=1.0 and ZER=0.0
C
      REAL SA(*),SB(*),SC(*)
      REAL A(NRP,m),B(m,NCP),C(NRP,NCP)
C
C   Check if ONE and ZERO have valid values, else ABORT
C
      IF (ONE.NE.1.0D0.OR.ZER.NE.0.0D0)
     &     CALL ABOR1(' UNVALID ARGUMENTS IN SGEMMX CALL')
c
      if(ncp.eq.0) return
c
!$OMP PARALLEL PRIVATE(i,j,k)
!OMP DO
      do 1000 j=1,m
!OCL  NOVREC
      do 1000 i=1,nrp
        a(i,j)=SA(1+(I-1)*IAC+(J-1)*IAR)
1000  continue
!OMP END DO
c
!OMP DO
      do 1100 k=1,ncp
!OCL  NOVREC
      do 1100 j=1,m
        b(j,k)=SB(1+(J-1)*IBC+(K-1)*IBR)
1100  continue
!OMP END DO
!$OMP END PARALLEL
c 
      CALL DGEMM('N','N',NRP,NCP,M,ONE,A,NRP,B,M,ZER,C,NRP)
c
!$OMP PARALLEL DO PRIVATE(i,k)
      do 1200 k=1,ncp
!OCL  NOVREC
      do 1200 i=1,nrp
        SC(1+(I-1)*ICC+(K-1)*ICR)=c(i,k)
1200  continue
!$OMP END PARALLEL DO
      RETURN
      END
#elif defined(USE_MATMUL)
      SUBROUTINE SGEMMX(NRP,NCP,M,
     &                  ONE,SA,IAC,IAR,SB,IBC,IBR,
     &                  ZER,SC,ICC,ICR)
C
C  Fortran subroutine equivalent to SGEMMX using MATMUL function
C  Written by F. Vana (august 2004)
C  Corrected on 2006-January-11
C
C
C   C=A*B  , with arbitrary increments IAC,IAR, IBC,IBR, ICC,ICR
C
C  It will only work if ONE=1.0 and ZER=0.0
C
      IMPLICIT LOGICAL (L)
      REAL SA(*),SB(*),SC(*)
      REAL A(NRP,m),B(m,NCP),C(NRP,NCP)
C
C   Check if ONE and ZERO have valid values, else ABORT
C
      IF((ONE.NE.1.0.OR.ZER.NE.0.0).and.(ONE.NE.1.0D0.OR.ZER.NE.0.0D0))
     &     CALL ABOR1(' UNVALID ARGUMENTS IN SGEMMX CALL')
C
      if(ncp.eq.0) return
C
C  Preparation for matrix multiplication
C
!$OMP PARALLEL PRIVATE(i,j,k)
!OMP DO
!cdir OUTERUNROLL=4
      do 1000 j=1,m
!cdir NODEP
      do 1000 i=1,nrp
        a(i,j)=SA(1+(I-1)*IAC+(J-1)*IAR)
1000  continue
!OMP END DO
c
!OMP DO
!cdir OUTERUNROLL=4
      do 1100 k=1,ncp
!cdir NODEP
      do 1100 j=1,m
        b(j,k)=SB(1+(J-1)*IBC+(K-1)*IBR)
1100  continue
!OMP END DO
!$OMP END PARALLEL
C
C  Multiply matrices A and B
C
      C=MATMUL(A,B)
C
C  Final data transfer
C
!$OMP PARALLEL DO PRIVATE(i,k)
!cdir OUTERUNROLL=4
      do 1200 k=1,ncp
!cdir NODEP
      do 1200 i=1,nrp
        SC(1+(I-1)*ICC+(K-1)*ICR)=c(i,k)
1200  continue
!$OMP END PARALLEL DO

      RETURN
      END
#elif defined(VPP)
      SUBROUTINE SGEMMX(NRP,NCP,M,
     & ONE,SA,IAC,IAR,SB,IBC,IBR,
     & ZER,SC,ICC,ICR)
!
!  Fortran subroutine equivalent to SGEMMX using SSLII dvmggm routine
!
!   C=A*B  , with arbitrary increments IAC,IAR, IBC,IBR, ICC,ICR
!
!  It will only work if ONE=1.0 and ZER=0.0
!
      REAL SA(*),SB(*),SC(*)
!     REAL A(NRP,m),B(m,NCP),C(NRP,NCP)
!
!   For maximum performance in dvmggm columns of matrices must
!   always start on a 64 byte boundary.
!
      real,allocatable :: a(:)

      integer apadlen,bpadlen,cpadlen
      integer aoffset,boffset,coffset
      integer offset
!
!   Check if ONE and ZERO have valid values, else ABORT
!
      IF (ONE.NE.1.0D0.OR.ZER.NE.0.0D0) then
           write(0,*) ' INVALID ARGUMENTS IN SGEMMX CALL'
           stop
      ENDIF
!

      if(ncp.eq.0) return

      nsize = 8 + (nrp+8)*m + (m+8)*ncp + (nrp+8)*ncp

      allocate(a(nsize))

      aoffset = mod(loc(a),64)/8
      apadlen = ((nrp+8)/8)*8


      boffset= aoffset + apadlen*m
      bpadlen = ((m+8)/8)*8

      coffset = boffset + bpadlen*ncp
      cpadlen = apadlen


!
      if(icc.eq.1)then

      do j=1,m
        offset = aoffset + (j-1)*apadlen
!OCL  NOVREC
        do i=1,nrp
          a(offset + i)=SA(1+(I-1)*IAC+(J-1)*IAR)
        enddo
      enddo
!
      do k=1,ncp
        offset = boffset + (k-1)*bpadlen
!OCL  NOVREC
        do j=1,m
          a(offset + j)=SB(1+(J-1)*IBC+(K-1)*IBR)
        enddo
      enddo

      call dvmggm(a(aoffset+1),apadlen,a(boffset+1),bpadlen,
     &            sc,icr,nrp,m,ncp,icon)
      if(icon.ne.0) stop 'icon error at dvmggm SGEMMX.f'


      else if(iac.eq.1)then

!
      do k=1,ncp
        offset = boffset + (k-1)*bpadlen
!OCL  NOVREC
        do j=1,m
          a(offset + j)=SB(1+(J-1)*IBC+(K-1)*IBR)
        enddo
      enddo

      call dvmggm(sa,iar,a(boffset+1),bpadlen,
     &            a(coffset+1),cpadlen,nrp,m,ncp,icon)
      if(icon.ne.0) stop 'icon error at dvmggm SGEMMX.f'


      do k=1,ncp
        offset = coffset + (k-1)*cpadlen
!OCL  NOVREC
        do i=1,nrp
          SC(1+(I-1)*ICC+(K-1)*ICR)=a(offset +i)
        enddo
      enddo

      else

      do j=1,m
        offset = aoffset + (j-1)*apadlen
!OCL  NOVREC
        do i=1,nrp
          a(offset + i)=SA(1+(I-1)*IAC+(J-1)*IAR)
        enddo
      enddo
!
      do k=1,ncp
        offset = boffset + (k-1)*bpadlen
!OCL  NOVREC
        do j=1,m
          a(offset + j)=SB(1+(J-1)*IBC+(K-1)*IBR)
        enddo
      enddo

      call dvmggm(a(aoffset+1),apadlen,a(boffset+1),bpadlen,
     &            a(coffset+1),cpadlen,nrp,m,ncp,icon)
      if(icon.ne.0) stop 'icon error at dvmggm SGEMMX.f'


      do k=1,ncp
        offset = coffset + (k-1)*cpadlen
!OCL  NOVREC
        do i=1,nrp
          SC(1+(I-1)*ICC+(K-1)*ICR)=a(offset +i)
        enddo
      enddo

      endif

      deallocate(a)

      RETURN
      END
#else
      SUBROUTINE SGEMMX(NRP,NCP,M,
     &                  ONE,SA,IAC,IAR,SB,IBC,IBR,
     &                  ZER,SC,ICC,ICR)
C
C  Fortran subroutine equivalent to SGEMMX, made from CRAY MXMA(3SCI)
C  See page 170 in CRAY Res. SR-2081 5.0
C
C   C=A*B  , with arbitrary increments IAC,IAR, IBC,IBR, ICC,ICR
C
C  It will only work if ONE=1.0 and ZER=0.0
C
      IMPLICIT LOGICAL (L)
      REAL SA(*),SB(*),SC(*)
C
C   Check if ONE and ZERO have valid values, else ABORT
C
      IF((ONE.NE.1.0.OR.ZER.NE.0.0).and.(ONE.NE.1.0D0.OR.ZER.NE.0.0D0))
     &     CALL ABOR1(' UNVALID ARGUMENTS IN SGEMMX CALL')
C  Initialize product
      DO 120 K=1,NCP
       DO 110 I=1,NRP
        SC(1+(I-1)*ICC+(K-1)*ICR) = 0.
C       (C(I,K) := 0.)
110    CONTINUE
120   CONTINUE
C  Multiply matrices from SA and SB
      DO 230 K=1,NCP
       DO 220 J=1,M
        DO 210 I=1,NRP
         SC(1+(I-1)*ICC+(K-1)*ICR)
     &     =SC(1+(I-1)*ICC+(K-1)*ICR)
     &      +SA(1+(I-1)*IAC+(J-1)*IAR)
     &       *SB(1+(J-1)*IBC+(K-1)*IBR)
C        (C(I,K):=C(I,K)+A(I,J)*B(J,K))
210     CONTINUE
220    CONTINUE
230   CONTINUE
      RETURN
      END
#endif
