CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                    C
C     THIS FILE CONTAINS THE SOURCE CODE FOR FORTRAN 90D INTRINSIC   C
C     FUNCTIONS.                                                     C
C                                                                    C
C     VERSION 1.00, 10/11/92                                         C
C                                                                    C
C     COPYRIGHT (C) NORTHEAST PARALLEL ARCHITECTURES CENTER,         C
C     SYRACUSE UNIVERSITY, SYRACUSE, NY 13244, USA.                  C
C                                                                    C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     xdim must be a multiple of ydim or vice versa
C     fix: myarow, myacol, msgbuf, integer or real
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE MATMUL_2_I(amat,a1,a2,a3,a4,a_info,bmat,b1,b2,b3,b4,
     &  b_info,cmat,c1,c2,c3,c4,c_info,proclist)

      integer a1,a2,a3,a4,b1,b2,b3,b4,c1,c2,c3,c4,proclist(*)
      integer amat(a1:a2,a3:a4), bmat(b1:b2,b3:b4), cmat(c1:c2,c3:c4)
      integer a_info(8,7), b_info(8,7), c_info(8,7)
      
      integer  NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC

      integer myarow, myacol, mybrow, mybcol, arow, acol, nprocs(2)

      integer  tmat(512,512), msgbuf(512*512), tmat2(512,512)

C     tmat SHOULD BE EXACTLY OF THE SAME SIZE AS B 
C     tmat2 SHOULD BE EXACTLY OF THE SAME SIZE AS A

C     LOCAL VARIABLES
      integer xdim, ydim, nx, ny, coord(2), nlocal,
     &  sq_size, env(4)
      integer i, j, step, max_proc, stat


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     ....x....
C     .
C     y
C     .
C     .
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      

      nprocs(1) = A_INFO(8,2)
      nprocs(2) = A_INFO(8,1)
      stat = KXGDIN(2,nprocs)
      stat = KXPARA(env)
      stat = KXGDCO(env(1), coord)

      myarow = a2 - a1 + 1
      myacol = a4 - a3 + 1
      mybrow = b2 - b1 + 1
      mybcol = b4 - b3 + 1
      arow = myarow * A_INFO(8,1)
      acol = myacol * A_INFO(8,2)

      xdim = A_INFO(8,2)
      ydim = A_INFO(8,1)

      if ( xdim .GE. ydim)  then
         nx = 1
         ny = xdim/ydim
         max_proc = xdim
      else
         nx = ydim/xdim
         ny = 1
         max_proc = ydim
      endif

      if (mod(acol, xdim) .EQ. 0) then 
         nlocal = (acol/max_proc)  
      else
         nlocal = (acol/max_proc) + 1
      endif
      
      
      sq_size = nlocal * nlocal 

      do j = 1, mybcol
         do i = 1, mybrow
            cmat(i,j) = 0
         enddo
      end do


      call urotate_I(bmat, b1,b2,b3,b4,tmat, env, xdim, ydim, nx, 
     $ ny, nlocal, sq_size, mybrow, mybcol,  coord, msgbuf)

      call hrotate_I(amat, a1,a2,a3,a4,tmat2, env,  xdim, ydim, nx, 
     $ ny, nlocal, sq_size, myarow, myacol, coord, msgbuf)

      do step = 0, ny*ydim-1
        call multiply_I(tmat2, a1,a2,a3,a4,tmat,b1,b2,b3,b4,cmat,c1,
     &    c2,c3,c4,nx,ny,nlocal, env)
        call ushift_I(tmat, b1,b2,b3,b4,msgbuf, env, xdim, ydim, nx, 
     $ ny, nlocal, sq_size)
        call hshift_I(tmat2, a1,a2,a3,a4,msgbuf, env, xdim, ydim, nx, 
     $ ny, nlocal, sq_size) 
      end do

      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine multiply_I(amat, a1,a2,a3,a4,bmat, b1,b2,b3,b4, cmat, 
     $  c1,c2,c3,c4,nx, ny, nlocal, env)
      integer a1,a2,a3,a4,b1,b2,b3,b4,c1,c2,c3,c4
      integer nx, ny,  nlocal, env(4)
      integer amat(a1:a2,a3:a4), bmat(b1:b2,b3:b4),cmat(c1:c2,c3:c4)
      integer sum

      integer i, j, k, x, y
      integer col_ind, row_ind, xcoord, ycoord

      do x = 0, nx-1
         do y = 0, ny-1
            xcoord = nlocal*x
            ycoord = nlocal*y
            do i = 1, nlocal
              do j = 1, nlocal
                sum = 0
                col_ind = xcoord + j
                do k = 1, nlocal
                   row_ind = ycoord + k
                   cmat(row_ind, col_ind) =
     $                cmat(row_ind, col_ind)  +
     $               amat(row_ind,xcoord+i) *
     $                     bmat(ycoord+i,col_ind)
                end do
              end do
            end do
          end do
       end do


       return
       end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine hshift_I(amat,a1,a2,a3,a4, msgbuf,env,xdim,ydim, nx,
     $  ny, nlocal, sq_size)

      integer a1,a2,a3,a4
      integer env(4), xdim, ydim, nx,ny,  nlocal, sq_size
      integer IHORIZ
      PARAMETER (IHORIZ = 0)
      integer amat(a1:a2,a3:a4), msgbuf(*)
      integer i, j, k, pto, pfrom
      integer nbytes, atype
      integer intsize
      data intsize /4/
      
      integer  NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC

      atype = 300

      pto   = kxgdno(env(1), IHORIZ, -1) 
      pfrom = kxgdno(env(1), IHORIZ, 1) 

      if (nx .gt. 1) then
         nbytes = nlocal*nlocal *ny *intsize
        call copy_I(msgbuf, amat, a1,a2,a3,a4, 1, 1, nlocal)
         do i = 0, nx-2
            do j = 1, nlocal
               do k = 1, nlocal
                 amat(k, nlocal*i+j) = amat(k, nlocal*(i+1)+j)
               end do
            end do
         end do
        call kxwrit(msgbuf, nbytes, pto, atype)
         call kxread(msgbuf, nbytes, pfrom, atype)
C         call kxchan(msgbuf,nbytes,pto,atype,msgbuf,nbytes,pfrom, atype)
         do i = 1, nlocal
            do k = 1, nlocal
               amat(k, nlocal*(nx-1)+i) = msgbuf(nlocal*(i-1)+k)
            end do
         end do

      else if (ny .eq. nx .or. ny .gt. 1) then
         nbytes = nlocal*nlocal *ny *intsize
         call kxwrit(amat, nbytes, pto, atype)
         call kxread(amat, nbytes, pfrom, atype)
C         call kxchan(amat,nbytes, pto,atype,amat,nbytes,pfrom,atype)
      end if

      return 
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine ushift_I(bmat, b1,b2,b3,b4,msgbuf, env, xdim, ydim, 
     $ nx, ny, nlocal, sq_size)

      integer  NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      integer b1,b2,b3,b4
      integer env(4), xdim, ydim, nx,ny,  nlocal, sq_size
      integer IVERT
      PARAMETER (IVERT = 1)
      integer bmat(b1:b2, b3:b4), msgbuf(*)
      integer i, j, k, pto, pfrom
      integer nbytes, btype
      integer intsize
      data intsize /4/
      
      btype = 200

      pto   = kxgdno(env(1), IVERT, 1) 
      pfrom = kxgdno(env(1), IVERT, -1) 

      if (ny .gt. 1) then
        nbytes = nlocal*nlocal *nx *intsize
        call copy_I(msgbuf, bmat, b1,b2,b3,b4,1, 1, nlocal)
         do i = 0, ny-2
            do k = 1, nlocal
               do j = 1, nlocal
                 bmat(nlocal*i+j,k) = bmat(nlocal*(i+1)+j,k)
               end do
            end do
         end do
         call  kxwrit(msgbuf, nbytes, pto, btype)
         call kxread(msgbuf,nbytes,pfrom, btype)

         do i = 1, nlocal
           do j = 1, nlocal
              bmat(nlocal*(ny-1)+j, i) = msgbuf((i-1)*nlocal+j)
           end do
         end do

      else if (ny .eq. nx .or. nx .gt. 1) then
         nbytes = nlocal*nlocal *nx *intsize
         call kxwrit(bmat, nbytes, pto, btype)
         call kxread(bmat, nbytes, pfrom, btype)
      end if

      return 
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine urotate_I(bmat,b1,b2,b3,b4,tmat, env, xdim, ydim, 
     $ nx, ny, nlocal, sq_size, nrow, ncol, coord, msgbuf)

      integer b1, b2, b3, b4
      integer env(4), xdim, ydim, nx,ny,  nlocal,
     $ sq_size, nrow, ncol,  coord(2)
      integer IVERT
      PARAMETER (IVERT = 1)
      integer bmat(b1:b2, b3:b4), msgbuf(*), tmat(b1:b2, b3:b4)
      integer i, j, k, pto, pfrom, y, m
      integer nbytes
      integer btype
      integer pcoord(2)
      integer intsize
      data intsize /4/

      integer  NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC

      btype = 400

      nbytes = nrow*ncol*intsize

      if (xdim .EQ. ydim) then
        pcoord(1) = coord(1)
        pcoord(2) = mod(coord(2)-coord(1)+ydim, ydim)
        pto = kxgdpr(pcoord)
        pcoord(2) = mod(coord(2)+coord(1), ydim)
        pfrom = kxgdpr(pcoord)

        if (pto .eq. env(1)) then
          do j = 1, ncol
            do i = 1, nrow
              tmat(i, j) = bmat(i, j)
            end do
          end do

	  return
        end if

        call kxwrit(bmat, nbytes, pto, btype)
        call kxread(tmat, nbytes, pfrom, btype)

      else if(xdim . gt. ydim) then

        nbytes = nlocal*nlocal*intsize
        pcoord(1) = coord(1)
        do i = 0, ny-1
          do y = 0, ny-1
           pcoord(2)= mod(coord(2)*ny-coord(1)+y+ydim*ny,ydim*ny)
            if (mod(pcoord(2),ny) .eq. i) then
              pcoord(2) = pcoord(2)/ ny
              pto = kxgdpr(pcoord)
              call copy_I(msgbuf, bmat,b1,b2,b3,b4, 1,nlocal*y+1,
     &             nlocal)
              go to 100
            end if
          enddo
 100      continue
          pcoord(2)= mod(coord(2)*ny+coord(1)+i,ydim*ny)
          pcoord(2) = pcoord(2)/ ny
          pfrom = kxgdpr(pcoord)
          call kxwrit(msgbuf, nbytes, pto, btype)
          call kxread(msgbuf, nbytes, pfrom, btype)
          do k = 1, nlocal
            do m = 1, nlocal
               tmat(i*nlocal+m, k) =
     $             msgbuf((k-1)*nlocal+m)
            end do
          end do
        end do

       else if (ydim .gt. xdim) then 
         nbytes = nlocal*nlocal*intsize
         pcoord(1) = coord(1)
         do i = 0, nx-1
             pcoord(2) = mod(coord(2)-coord(1)-i+ydim, ydim)
             pto = kxgdpr(pcoord)
             call copy_I(msgbuf, bmat, b1,b2,b3,b4,nlocal*i+1,1,nlocal)
             pcoord(2) = mod(coord(2)+coord(1)+i, ydim)
             pfrom = kxgdpr(pcoord)
             call kxwrit(msgbuf, nbytes, pto, btype)
             call kxread(msgbuf, nbytes, pfrom, btype)
             do k = 1, nlocal
                do m = 1, nlocal
                   tmat(i*nlocal+m, k) =
     $                  msgbuf((k-1)*nlocal+m)
                end do
             end do
          end do
       end if

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine hrotate_I(amat, a1,a2,a3,a4,tmat2, env, xdim, ydim, 
     $ nx, ny, nlocal,sq_size, nrow, ncol, coord, msgbuf)

      integer a1, a2, a3, a4
      integer env(4), xdim, ydim, nx,ny,  nlocal,
     $ sq_size, nrow, ncol, coord(2)
      integer IHORIZ
      PARAMETER (IHORIZ = 0)
      integer amat(a1:a2, a3:a4), msgbuf(*), tmat2(a1:a2, a3:a4)
      integer i, j, k, pto, pfrom, x, m
      integer nbytes, atype
      integer pcoord(2)
      integer intsize
      data intsize /4/

      integer  NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC

      atype = 500

      nbytes = nrow*ncol*intsize
      if (nx. eq. ny) then

        pcoord(2) = coord(2)
        pcoord(1) = mod(coord(1)-coord(2)+xdim, xdim)
        pto = kxgdpr(pcoord)
        pcoord(1) = mod(coord(1)+coord(2), xdim)
        pfrom = kxgdpr(pcoord)

         if (pto .eq. env(1)) then
          do j = 1, ncol
            do i = 1, nrow
              tmat2(i, j) = amat(i, j)
            end do
          end do

          return
        end if


        call kxwrit(amat, nbytes, pto, atype)
        call kxread(tmat2, nbytes, pfrom, atype)
      else if (xdim .gt. ydim) then 
        nbytes = nlocal*nlocal*intsize
        pcoord(2) = coord(2)
        do i = 0, ny-1
              pcoord(1) = mod(coord(1)-coord(2)-i+xdim, xdim)
              pto = kxgdpr(pcoord)
              call copy_I(msgbuf, amat, a1,a2,a3,a4,1,nlocal*i+1,
     &             nlocal)
              pcoord(1) = mod(coord(1)+coord(2)+i, xdim)
              pfrom = kxgdpr(pcoord)
              call kxwrit(msgbuf, nbytes, pto, atype)
              call kxread(msgbuf, nbytes, pfrom, atype)
          do k = 1, nlocal
             do m = 1, nlocal
                tmat2(i*nlocal+m, k) = msgbuf((k-1)*nlocal+m)
             end do
          end do
        end do

      else if (ydim .gt. xdim) then
         nbytes = nlocal*nlocal*intsize
         pcoord(2) = coord(2)
         do i = 0, nx-1
           do x = 0, nx-1
             pcoord(1)=mod(coord(1)*nx-coord(2)+x+xdim*nx, xdim*nx)
            if (mod(pcoord(1),nx) .eq. i) then
              pcoord(1) = pcoord(1)/ nx
              pto = kxgdpr(pcoord)
              call copy_I(msgbuf, amat, a1,a2,a3,a4,nlocal*x+1, 1, 
     &           nlocal)
              goto 200
            end if
           end do
 200       continue
           pcoord(1)=mod(coord(1)*nx+coord(2)+i, xdim*nx)
           pcoord(1) = pcoord(1)/ nx
           pfrom = kxgdpr(pcoord)
           call kxwrit(msgbuf, nbytes, pto, atype)
           call kxread(msgbuf, nbytes, pfrom, atype)
           do k = 1, nlocal
              do m = 1, nlocal
                 tmat2(i*nlocal+m, k) =
     $               msgbuf((k-1)*nlocal+m)
              end do
           end do
        end do
      end if

      return 
      end
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine copy_I(a, b, b1,b2,b3,b4,x, y, nlocal)

      integer x, y, nlocal, b1,b2,b3,b4
      integer a(*), b(b1:b2, b3:b4)
      integer  i, j, k

      k = 1
      do i = x, x+nlocal-1
        do j = y,y+nlocal-1
          a(k) = b(j,i)
          k = k + 1
        end do
      end do

      return
      end



CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C   for real
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      SUBROUTINE MATMUL_2_R(amat,a1,a2,a3,a4,a_info,bmat,b1,b2,b3,b4,
     &  b_info,cmat,c1,c2,c3,c4,c_info,proclist)

      integer a1,a2,a3,a4,b1,b2,b3,b4,c1,c2,c3,c4,proclist(*)
      real amat(a1:a2,a3:a4), bmat(b1:b2,b3:b4), cmat(c1:c2,c3:c4)
      integer a_info(8,7), b_info(8,7), c_info(8,7), nprocs(2)
      
      integer  NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC

      integer myarow, myacol, mybrow, mybcol, arow, acol

      real  tmat(512,512), msgbuf(512*512), tmat2(512,512)

C     tmat SHOULD BE EXACTLY OF THE SAME SIZE AS B 
C     tmat2 SHOULD BE EXACTLY OF THE SAME SIZE AS A

C     LOCAL VARIABLES
      integer xdim, ydim, nx, ny, coord(2), nlocal, sq_size, env(4)
      integer i, j, step, max_proc, stat


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     ....x....
C     .
C     y
C     .
C     .
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      
      nprocs(1) = A_INFO(8,2)
      nprocs(2) = A_INFO(8,1)
      stat = KXGDIN(2,nprocs)
      stat = KXPARA(env)
      stat = KXGDCO(env(1), coord)

      myarow = a2 - a1 + 1
      myacol = a4 - a3 + 1
      mybrow = b2 - b1 + 1
      mybcol = b4 - b3 + 1

      xdim = A_INFO(8,2)
      ydim = A_INFO(8,1)
      arow = myarow * A_INFO(8,1)
      acol = myacol * A_INFO(8,2)


      if ( xdim .GE. ydim)  then
         nx = 1
         ny = xdim/ydim
         max_proc = xdim
      else
         nx = ydim/xdim
         ny = 1
         max_proc = ydim
      endif

      if (mod(acol, xdim) .EQ. 0) then 
         nlocal = (acol/max_proc)  
      else
         nlocal = (acol/max_proc) + 1
      endif
      
      
      sq_size = nlocal * nlocal 

      do j = 1, mybcol
         do i = 1, mybrow
            cmat(i,j) = 0
         enddo
      end do


      call urotate_R(bmat, b1,b2,b3,b4,tmat, env, xdim, ydim, nx, 
     $ ny, nlocal, sq_size, mybrow, mybcol,  coord, msgbuf)

      call hrotate_R(amat, a1,a2,a3,a4,tmat2, env,  xdim, ydim, nx, 
     $ ny, nlocal, sq_size, myarow, myacol, coord, msgbuf)

      do step = 0, ny*ydim-1
        call multiply_R(tmat2, a1,a2,a3,a4,tmat,b1,b2,b3,b4,cmat,c1,
     &    c2,c3,c4,nx,ny,nlocal, env)
        call ushift_R(tmat, b1,b2,b3,b4,msgbuf, env, xdim, ydim, nx, 
     $ ny, nlocal, sq_size)
        call hshift_R(tmat2, a1,a2,a3,a4,msgbuf, env, xdim, ydim, nx, 
     $ ny, nlocal, sq_size) 
      end do

      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine multiply_R(amat, a1,a2,a3,a4,bmat, b1,b2,b3,b4, cmat, 
     $  c1,c2,c3,c4,nx, ny, nlocal, env)
      integer a1,a2,a3,a4,b1,b2,b3,b4,c1,c2,c3,c4
      integer nx, ny,  nlocal, env(4)
      real amat(a1:a2,a3:a4), bmat(b1:b2,b3:b4),cmat(c1:c2,c3:c4)
      real sum

      integer i, j, k, x, y
      integer col_ind, row_ind, xcoord, ycoord

      do x = 0, nx-1
         do y = 0, ny-1
            xcoord = nlocal*x
            ycoord = nlocal*y
            do i = 1, nlocal
              do j = 1, nlocal
                sum = 0.0
                col_ind = xcoord + j
                do k = 1, nlocal
                   row_ind = ycoord + k
                   cmat(row_ind, col_ind) =
     $                cmat(row_ind, col_ind)  +
     $               amat(row_ind,xcoord+i) *
     $                     bmat(ycoord+i,col_ind)
                end do
              end do
            end do
          end do
       end do


       return
       end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine hshift_R(amat,a1,a2,a3,a4, msgbuf,env,xdim,ydim, nx,
     $  ny, nlocal, sq_size)

      integer a1,a2,a3,a4
      integer env(4), xdim, ydim, nx, ny, nlocal, sq_size
      integer IHORIZ
      PARAMETER (IHORIZ = 0)
      real amat(a1:a2,a3:a4), msgbuf(*)
      integer i, j, k, pto, pfrom
      integer nbytes, atype
      integer intsize
      data intsize /4/
      
      integer  NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC

      atype = 300

      pto   = kxgdno(env(1), IHORIZ, -1) 
      pfrom = kxgdno(env(1), IHORIZ, 1) 

      if (nx .gt. 1) then
         nbytes = nlocal*nlocal *ny *intsize
        call copy_R(msgbuf, amat, a1,a2,a3,a4, 1, 1, nlocal)
         do i = 0, nx-2
            do j = 1, nlocal
               do k = 1, nlocal
                 amat(k, nlocal*i+j) = amat(k, nlocal*(i+1)+j)
               end do
            end do
         end do
        call kxwrit(msgbuf, nbytes, pto, atype)
         call kxread(msgbuf, nbytes, pfrom, atype)
         do i = 1, nlocal
            do k = 1, nlocal
               amat(k, nlocal*(nx-1)+i) = msgbuf(nlocal*(i-1)+k)
            end do
         end do

      else if (ny .eq. nx .or. ny .gt. 1) then
         nbytes = nlocal*nlocal *ny *intsize
         call kxwrit(amat, nbytes, pto, atype)
         call kxread(amat, nbytes, pfrom, atype)
      end if

      return 
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine ushift_R(bmat, b1,b2,b3,b4,msgbuf, env, xdim, ydim, 
     $ nx, ny, nlocal, sq_size)

      integer  NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      integer b1,b2,b3,b4
      integer env(4), xdim, ydim, nx, ny, nlocal, sq_size
      integer IVERT
      PARAMETER (IVERT = 1)
      real bmat(b1:b2, b3:b4), msgbuf(*)
      integer i, j, k, pto, pfrom
      integer nbytes, btype
      integer intsize
      data intsize /4/
      
      btype = 200

      pto   = kxgdno(env(1), IVERT, 1) 
      pfrom = kxgdno(env(1), IVERT, -1) 

      if (ny .gt. 1) then
        nbytes = nlocal*nlocal *nx *intsize
        call copy_R(msgbuf, bmat, b1,b2,b3,b4,1, 1, nlocal)
         do i = 0, ny-2
            do k = 1, nlocal
               do j = 1, nlocal
                 bmat(nlocal*i+j,k) = bmat(nlocal*(i+1)+j,k)
               end do
            end do
         end do
         call  kxwrit(msgbuf, nbytes, pto, btype)
         call kxread(msgbuf,nbytes,pfrom, btype)

         do i = 1, nlocal
           do j = 1, nlocal
              bmat(nlocal*(ny-1)+j, i) = msgbuf((i-1)*nlocal+j)
           end do
         end do

      else if (ny .eq. nx .or. nx .gt. 1) then
         nbytes = nlocal*nlocal *nx *intsize
         call kxwrit(bmat, nbytes, pto, btype)
         call kxread(bmat, nbytes, pfrom, btype)
      end if

      return 
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine urotate_R(bmat,b1,b2,b3,b4,tmat, env, xdim, ydim, 
     $ nx, ny, nlocal, sq_size, nrow, ncol, coord, msgbuf)

      integer b1, b2, b3, b4
      integer env(4), xdim, ydim, nx,ny,  nlocal,
     $ sq_size, nrow, ncol,  coord(2)
      integer IVERT
      PARAMETER (IVERT = 1)
      real bmat(b1:b2, b3:b4), msgbuf(*), tmat(b1:b2, b3:b4)
      integer i, j, k, pto, pfrom, y, m
      integer nbytes
      integer btype
      integer pcoord(2)
      integer intsize
      data intsize /4/

      integer  NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC

      btype = 400

      nbytes = nrow*ncol*intsize

      if (xdim .EQ. ydim) then
        pcoord(1) = coord(1)
        pcoord(2) = mod(coord(2)-coord(1)+ydim, ydim)
        pto = kxgdpr(pcoord)
        pcoord(2) = mod(coord(2)+coord(1), ydim)
        pfrom = kxgdpr(pcoord)

        if (pto .eq. env(1)) then
          do j = 1, ncol
            do i = 1, nrow
              tmat(i, j) = bmat(i, j)
            end do
          end do

	  return
        end if

        call kxwrit(bmat, nbytes, pto, btype)
        call kxread(tmat, nbytes, pfrom, btype)

      else if(xdim . gt. ydim) then

        nbytes = nlocal*nlocal*intsize
        pcoord(1) = coord(1)
        do i = 0, ny-1
          do y = 0, ny-1
           pcoord(2)= mod(coord(2)*ny-coord(1)+y+ydim*ny,ydim*ny)
            if (mod(pcoord(2),ny) .eq. i) then
              pcoord(2) = pcoord(2)/ ny
              pto = kxgdpr(pcoord)
              call copy_R(msgbuf, bmat,b1,b2,b3,b4, 1,nlocal*y+1,
     &             nlocal)
              go to 100
            end if
          enddo
 100      continue
          pcoord(2)= mod(coord(2)*ny+coord(1)+i,ydim*ny)
          pcoord(2) = pcoord(2)/ ny
          pfrom = kxgdpr(pcoord)
          call kxwrit(msgbuf, nbytes, pto, btype)
          call kxread(msgbuf, nbytes, pfrom, btype)
          do k = 1, nlocal
            do m = 1, nlocal
               tmat(i*nlocal+m, k) =
     $             msgbuf((k-1)*nlocal+m)
            end do
          end do
        end do

       else if (ydim .gt. xdim) then 
         nbytes = nlocal*nlocal*intsize
         pcoord(1) = coord(1)
         do i = 0, nx-1
             pcoord(2) = mod(coord(2)-coord(1)-i+ydim, ydim)
             pto = kxgdpr(pcoord)
             call copy_R(msgbuf, bmat, b1,b2,b3,b4,nlocal*i+1,1,nlocal)
             pcoord(2) = mod(coord(2)+coord(1)+i, ydim)
             pfrom = kxgdpr(pcoord)
             call kxwrit(msgbuf, nbytes, pto, btype)
             call kxread(msgbuf, nbytes, pfrom, btype)
             do k = 1, nlocal
                do m = 1, nlocal
                   tmat(i*nlocal+m, k) =
     $                  msgbuf((k-1)*nlocal+m)
                end do
             end do
          end do
       end if

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine hrotate_R(amat, a1,a2,a3,a4,tmat2, env, xdim, ydim, 
     $ nx, ny, nlocal,sq_size, nrow, ncol, coord, msgbuf)

      integer a1, a2, a3, a4
      integer env(4), xdim, ydim, nx,ny,  nlocal,
     $ sq_size, nrow, ncol, coord(2)
      integer IHORIZ
      PARAMETER (IHORIZ = 0)
      real amat(a1:a2, a3:a4), msgbuf(*), tmat2(a1:a2, a3:a4)
      integer i, j, k, pto, pfrom, x, m
      integer nbytes, atype
      integer pcoord(2)
      integer intsize
      data intsize /4/

      integer  NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC

      atype = 500

      nbytes = nrow*ncol*intsize
      if (nx. eq. ny) then

        pcoord(2) = coord(2)
        pcoord(1) = mod(coord(1)-coord(2)+xdim, xdim)
        pto = kxgdpr(pcoord)
        pcoord(1) = mod(coord(1)+coord(2), xdim)
        pfrom = kxgdpr(pcoord)

         if (pto .eq. env(1)) then
          do j = 1, ncol
            do i = 1, nrow
              tmat2(i, j) = amat(i, j)
            end do
          end do

          return
        end if


        call kxwrit(amat, nbytes, pto, atype)
        call kxread(tmat2, nbytes, pfrom, atype)
      else if (xdim .gt. ydim) then 
        nbytes = nlocal*nlocal*intsize
        pcoord(2) = coord(2)
        do i = 0, ny-1
              pcoord(1) = mod(coord(1)-coord(2)-i+xdim, xdim)
              pto = kxgdpr(pcoord)
              call copy_R(msgbuf, amat, a1,a2,a3,a4,1,nlocal*i+1,
     &             nlocal)
              pcoord(1) = mod(coord(1)+coord(2)+i, xdim)
              pfrom = kxgdpr(pcoord)
              call kxwrit(msgbuf, nbytes, pto, atype)
              call kxread(msgbuf, nbytes, pfrom, atype)
          do k = 1, nlocal
             do m = 1, nlocal
                tmat2(i*nlocal+m, k) = msgbuf((k-1)*nlocal+m)
             end do
          end do
        end do

      else if (ydim .gt. xdim) then
         nbytes = nlocal*nlocal*intsize
         pcoord(2) = coord(2)
         do i = 0, nx-1
           do x = 0, nx-1
             pcoord(1)=mod(coord(1)*nx-coord(2)+x+xdim*nx, xdim*nx)
            if (mod(pcoord(1),nx) .eq. i) then
              pcoord(1) = pcoord(1)/ nx
              pto = kxgdpr(pcoord)
              call copy_R(msgbuf, amat, a1,a2,a3,a4,nlocal*x+1, 1, 
     &           nlocal)
              goto 200
            end if
           end do
 200       continue
           pcoord(1)=mod(coord(1)*nx+coord(2)+i, xdim*nx)
           pcoord(1) = pcoord(1)/ nx
           pfrom = kxgdpr(pcoord)
           call kxwrit(msgbuf, nbytes, pto, atype)
           call kxread(msgbuf, nbytes, pfrom, atype)
           do k = 1, nlocal
              do m = 1, nlocal
                 tmat2(i*nlocal+m, k) =
     $               msgbuf((k-1)*nlocal+m)
              end do
           end do
        end do
      end if

      return 
      end
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine copy_R(a, b, b1,b2,b3,b4,x, y, nlocal)

      integer x, y, nlocal, b1,b2,b3,b4
      real a(*), b(b1:b2, b3:b4)
      integer  i, j, k

      k = 1
      do i = x, x+nlocal-1
        do j = y,y+nlocal-1
          a(k) = b(j,i)
          k = k + 1
        end do
      end do

      return
      end



