
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C   Intrinsic function: spread 1-to-2 (real)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine spread_1_R(src, src_lbo1, src_ubo1, src_info, dim, 
     &     ncopies, dest, dest_lbo1, dest_ubo1, dest_lbo2, 
     &     dest_ubo2, dest_info)

C      implicit none

      integer src_lbo1, src_ubo1
      integer dest_lbo1, dest_ubo1, dest_lbo2, dest_ubo2
      integer src_info(11,7), dest_info(11,7), dim, ncopies 
      real src(src_lbo1:src_ubo1) 
      real dest(dest_lbo1:dest_ubo1,dest_lbo2:dest_ubo2)
      
      integer myid, numpe, grids, mycord(4), nprocs(4)
      integer intsize, realsize, dpsize

      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      common /kxparms/ myid, numpe, grids, mycord, nprocs
      common /varsize/ intsize, realsize, dpsize

      integer i, j, k
      integer non_spd, gdest_lb, nnodes, direct
      integer nodel(128), tnode, loc_size, bigger_nodes
      integer mybyte, ressz, status, sizes(128)
      integer local_to_global, type
      real src_temp(1024)

C--   find out the non spreaded dim of the 2-d dest
      if (dim .EQ. 1 ) then
         non_spd = 2
      else if (dim .EQ. 2) then
         non_spd = 1
      else
         print *, '***ERROR(isp1): PE ', myid, 
     &        ' DIM not equal to 1 or 2'
         return
      endif

      if (src_info(6,1) .EQ. 0) then
C--   CASE 1: src is replicated at every node, no comm needed
         if (dest_info(6,non_spd) .EQ. 0) then
C--   CASE 1.1: dest is replicated along non-spd dim, all-to-all copy
            k = src_info(1,1)
            call src_to_dest_1_R(dim,k,non_spd,dest_info,dest,dest_lbo1,
     &           dest_ubo1,dest_lbo2,dest_ubo2,src,src_lbo1,src_ubo1)
         else if (dest_info(6,non_spd) .EQ. 1) then
C--   CASE 1.2: dest is block dist along non-spd dim, convert to global index
            gdest_lb = local_to_global(dest_info(1,non_spd), 
     &           dest_info, non_spd)
            k = gdest_lb + (src_info(1,1) - 1)
C--   assume that global index of dest begins at 1
            call src_to_dest_1_R(dim,k,non_spd,dest_info,dest,dest_lbo1,
     &           dest_ubo1,dest_lbo2,dest_ubo2,src,src_lbo1,src_ubo1)
         else
C--   CASE 1.3: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp1): PE ', myid, 
     &           ' dest is not BLOCK distributed'
         endif
      else if (src_info(9,1) .EQ. dest_info(9,non_spd)) then
C--   CASE 2: src and dest(non_spd) are dist at same dim , no comm needed
         if (src_info(6,1) .EQ. dest_info(6,non_spd)) then
C--   CASE 2.1: src and dest are dist in same way
            k = src_info(1,1)
            call src_to_dest_1_R(dim,k,non_spd,dest_info,dest,dest_lbo1,
     &           dest_ubo1,dest_lbo2,dest_ubo2,src,src_lbo1,src_ubo1)
         else
C--   CASE 2.2: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp1): PE ', myid,
     &           ' src and dest are not distributed in same type'
         endif
      else
C--   CASE 3: concatenate src along spread dim, every node will have entire src
C--   prepare concatenate list (or spread list)
         nnodes = src_info(8,1)
         direct = src_info(9,1)
         do i = 1, nnodes
            nodel(i) = KXGDNO(myid, direct, i)
         end do
C--   sort nodel so each node has exactually same one
         call sort_nodel(nnodes,nodel)
         loc_size = src_info(5,1) / src_info(8,1)
         bigger_nodes = src_info(5,1) - loc_size * src_info(8,1)
         if ((bigger_nodes .EQ. 0) .AND. (src_info(6,1) .EQ. 1)) then
C--   CASE 3.1: all are equal size and BLOCK distributed
            mybyte = (src_info(2,1) - src_info(1,1) + 1) * realsize
            ressz = mybyte
            type = 31
            status = KXCONC(src(src_info(1,1)),mybyte,src_temp,
     &           ressz,sizes,nnodes,nodel,type)
C--   assign src to dest
            if (dest_info(6,non_spd) .LE. 1) then
C--   CASE 3.1.1: dest is block dist along non-spd dim, cal it's global index
               if (dest_info(6,non_spd) .EQ. 0) then
                  gdest_lb = 1
               else
                  gdest_lb = local_to_global(dest_info(1,non_spd),
     &                 dest_info, non_spd)
               endif
               k = gdest_lb
C--   spread along dest's 1st dim, src_temp's index begins at 1
               call src_to_dest_1_R(dim,k,non_spd,dest_info,dest,
     &              dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,
     &              src_temp,1,1024)
            else
C--   CASE 3.1.2: FURTHER IMPLEMENT NEEDED - 10/02/92
               print *, '***ERROR(isp1): PE ', myid,
     &              ' dest is not BLOCK distributed'
            endif
         else
C--   CASE 3.2: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp1): PE ', myid,
     &           ' src is not evenly BLOCK distributed'
         endif
      endif

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     assign src to dest (1D)(real)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine src_to_dest_1_R(dim,k,non_spd,dest_info,dest,dest_lbo1,
     &     dest_ubo1,dest_lbo2,dest_ubo2,src,src_lbo1,src_ubo1)

C      implicit none
      integer dim,k,non_spd
      integer dest_info(11,7)
      integer dest_lbo1, dest_ubo1, dest_lbo2, dest_ubo2
      integer src_lbo1, src_ubo1
      real dest(dest_lbo1:dest_ubo1,dest_lbo2:dest_ubo2)
      real src(src_lbo1:src_ubo1)

      integer i, j
      
      if (dim .EQ. 1) then
C--   spread along dest's 1st dim
         do j = dest_info(1,non_spd), dest_info(2,non_spd)
            do i = dest_info(1,dim), dest_info(2,dim)
               dest(i,j) = src(k)
            enddo
            k = k + 1
         enddo
      else
         do j = dest_info(1,non_spd), dest_info(2,non_spd)
            do i = dest_info(1,dim), dest_info(2,dim)
               dest(j,i) = src(k)
            enddo
            k = k + 1
         enddo
      endif

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C   Intrinsic function: spread 1-to-2 (integer)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine spread_1_I(src, src_lbo1, src_ubo1, src_info, dim, 
     &     ncopies, dest, dest_lbo1, dest_ubo1, dest_lbo2, 
     &     dest_ubo2, dest_info)

C      implicit none

      integer src_lbo1, src_ubo1
      integer dest_lbo1, dest_ubo1, dest_lbo2, dest_ubo2
      integer src_info(11,7), dest_info(11,7), dim, ncopies 
      integer src(src_lbo1:src_ubo1) 
      integer dest(dest_lbo1:dest_ubo1,dest_lbo2:dest_ubo2)
      
      integer myid, numpe, grids, mycord(4), nprocs(4)
      integer intsize, realsize, dpsize

      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      common /kxparms/ myid, numpe, grids, mycord, nprocs
      common /varsize/ intsize, realsize, dpsize

      integer i, j, k
      integer non_spd, gdest_lb, nnodes, direct
      integer nodel(128), tnode, loc_size, bigger_nodes
      integer mybyte, ressz, status, sizes(128)
      integer local_to_global, type
      integer src_temp(1024)

C--   find out the non spreaded dim of the 2-d dest
      if (dim .EQ. 1 ) then
         non_spd = 2
      else if (dim .EQ. 2) then
         non_spd = 1
      else
         print *, '***ERROR(isp1): PE ', myid, 
     &        ' DIM not equal to 1 or 2'
         return
      endif

      if (src_info(6,1) .EQ. 0) then
C--   CASE 1: src is replicated at every node, no comm needed
         if (dest_info(6,non_spd) .EQ. 0) then
C--   CASE 1.1: dest is replicated along non-spd dim, all-to-all copy
            k = src_info(1,1)
            call src_to_dest_1_R(dim,k,non_spd,dest_info,dest,dest_lbo1,
     &           dest_ubo1,dest_lbo2,dest_ubo2,src,src_lbo1,src_ubo1)
         else if (dest_info(6,non_spd) .EQ. 1) then
C--   CASE 1.2: dest is block dist along non-spd dim, convert to global index
            gdest_lb = local_to_global(dest_info(1,non_spd), 
     &           dest_info, non_spd)
            k = gdest_lb + (src_info(1,1) - 1)
C--   assume that global index of dest begins at 1
            call src_to_dest_1_R(dim,k,non_spd,dest_info,dest,dest_lbo1,
     &           dest_ubo1,dest_lbo2,dest_ubo2,src,src_lbo1,src_ubo1)
         else
C--   CASE 1.3: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp1): PE ', myid, 
     &           ' dest is not BLOCK distributed'
         endif
      else if (src_info(9,1) .EQ. dest_info(9,non_spd)) then
C--   CASE 2: src and dest(non_spd) are dist at same dim , no comm needed
         if (src_info(6,1) .EQ. dest_info(6,non_spd)) then
C--   CASE 2.1: src and dest are dist in same way
            k = src_info(1,1)
            call src_to_dest_1_R(dim,k,non_spd,dest_info,dest,dest_lbo1,
     &           dest_ubo1,dest_lbo2,dest_ubo2,src,src_lbo1,src_ubo1)
         else
C--   CASE 2.2: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp1): PE ', myid,
     &           ' src and dest are not distributed in same type'
         endif
      else
C--   CASE 3: concatenate src along spread dim, every node will have entire src
C--   prepare concatenate list (or spread list)
         nnodes = src_info(8,1)
         direct = src_info(9,1)
         do i = 1, nnodes
            nodel(i) = KXGDNO(myid, direct, i)
         end do
C--   sort nodel so each node has exactually same one
         call sort_nodel(nnodes,nodel)
         loc_size = src_info(5,1) / src_info(8,1)
         bigger_nodes = src_info(5,1) - loc_size * src_info(8,1)
         if ((bigger_nodes .EQ. 0) .AND. (src_info(6,1) .EQ. 1)) then
C--   CASE 3.1: all are equal size and BLOCK distributed
            mybyte = (src_info(2,1) - src_info(1,1) + 1) * intsize
            ressz = mybyte
            type = 31
            status = KXCONC(src(src_info(1,1)),mybyte,src_temp,
     &           ressz,sizes,nnodes,nodel,type)
C--   assign src to dest
            if (dest_info(6,non_spd) .LE. 1) then
C--   CASE 3.1.1: dest is block dist along non-spd dim, cal it's global index
               if (dest_info(6,non_spd) .EQ. 0) then
                  gdest_lb = 1
               else
                  gdest_lb = local_to_global(dest_info(1,non_spd),
     &                 dest_info, non_spd)
               endif
               k = gdest_lb
C--   spread along dest's 1st dim, src_temp's index begins at 1
               call src_to_dest_1_R(dim,k,non_spd,dest_info,dest,
     &              dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,
     &              src_temp,1,1024)
            else
C--   CASE 3.1.2: FURTHER IMPLEMENT NEEDED - 10/02/92
               print *, '***ERROR(isp1): PE ', myid,
     &              ' dest is not BLOCK distributed'
            endif
         else
C--   CASE 3.2: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp1): PE ', myid,
     &           ' src is not evenly BLOCK distributed'
         endif
      endif

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     assign src to dest (1D)(integer)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine src_to_dest_1_I(dim,k,non_spd,dest_info,dest,dest_lbo1,
     &     dest_ubo1,dest_lbo2,dest_ubo2,src,src_lbo1,src_ubo1)

C      implicit none
      integer dim,k,non_spd
      integer dest_info(11,7)
      integer dest_lbo1, dest_ubo1, dest_lbo2, dest_ubo2
      integer src_lbo1, src_ubo1
      integer dest(dest_lbo1:dest_ubo1,dest_lbo2:dest_ubo2)
      integer src(src_lbo1:src_ubo1)

      integer i, j
      
      if (dim .EQ. 1) then
C--   spread along dest's 1st dim
         do j = dest_info(1,non_spd), dest_info(2,non_spd)
            do i = dest_info(1,dim), dest_info(2,dim)
               dest(i,j) = src(k)
            enddo
            k = k + 1
         enddo
      else
         do j = dest_info(1,non_spd), dest_info(2,non_spd)
            do i = dest_info(1,dim), dest_info(2,dim)
               dest(j,i) = src(k)
            enddo
            k = k + 1
         enddo
      endif

      return
      end






CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C   Intrinsic function: spread 2-to-3 (real)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine spread_2_R(src,src_lbo1,src_ubo1,src_lbo2,src_ubo2,
     &     src_info,dim,ncopies,dest,dest_lbo1,dest_ubo1,dest_lbo2,
     &     dest_ubo2,dest_lbo3,dest_ubo3,dest_info)

C      implicit none
      integer src_lbo1, src_ubo1, src_lbo2, src_ubo2
      integer dest_lbo1, dest_ubo1, dest_lbo2, dest_ubo2
      integer dest_lbo3, dest_ubo3
      integer src_info(11,7), dest_info(11,7), dim, ncopies 
      real src(src_lbo1:src_ubo1,src_lbo2:src_ubo2) 
      real dest(dest_lbo1:dest_ubo1,dest_lbo2:dest_ubo2,
     &     dest_lbo3:dest_ubo3)
      
      integer myid, mycord(3), numpe, grids, nprocs(3)
      integer intsize, realsize, dpsize

      integer i, j, k, k1, k2
      integer non_spd1, non_spd2, gdest_lb1, gdest_lb2, nnodes, direct
      integer nodel(128), tnode, loc_size, bigger_nodes
      integer mybyte, ressz, status, sizes(128)
      integer local_to_global, type, loc, src_case
      real src_buf1(1024), src_buf2(1024), src_temp(1024)

      COMMON/XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      common /kxparms/ myid, mycord, numpe, grids, nprocs
      common /varsize/ intsize, realsize, dpsize

C--   find out the non spreaded dims of the 3-d dest
      if (dim .EQ. 1 ) then
         non_spd1 = 2
         non_spd2 = 3
      else if (dim .EQ. 2) then
         non_spd1 = 1
         non_spd2 = 3
      else if (dim .EQ. 3) then
         non_spd1 = 1
         non_spd2 = 2
      else
         print *, '***ERROR(isp2): PE ', myid, 
     &        ' DIM not equal to 1, 2 or 3'
         return
      endif

      if ((src_info(6,1) .EQ. 0) .AND. (src_info(6,2) .EQ. 0)) then
C--   CASE 1: src is replicated at every node, no comm needed
         if ((dest_info(6,non_spd1) .EQ. 0) .AND.
     &        (dest_info(6,non_spd2) .EQ. 0)) then
C--   CASE 1.1: dest is replicated along non-spd dims, all-to-all copy
            k1 = src_info(1,1)
            k2 = src_info(1,2)
            call src_to_dest_2_R(dim,k1,k2,non_spd1,non_spd2,dest_info,
     &           dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,dest_lbo3,
     &           dest_ubo3,src,src_lbo1,src_ubo1,src_lbo2,src_ubo2)
         else if ((dest_info(6,non_spd1) .LE. 1) .AND.
     &           (dest_info(6,non_spd2) .LE. 1)) then
C--   CASE 1.2: dest is replicated or block dist along non-spd dims, convert 
C     to global index. assume that global index of dest begins at 1
            if (dest_info(6,non_spd1) .EQ. 1) then
               gdest_lb1 = local_to_global(dest_info(1,non_spd1), 
     &              dest_info, non_spd1)
            else
               gdest_lb1 = 1
            endif
            if (dest_info(6,non_spd2) .EQ. 1) then
               gdest_lb2 = local_to_global(dest_info(1,non_spd2),
     &              dest_info, non_spd2)
            else
               gdest_lb2 = 1
            endif
            k1 = gdest_lb1 + (src_info(1,1) - 1)
            k2 = gdest_lb2 + (src_info(1,2) - 1)
            call src_to_dest_2_R(dim,k1,k2,non_spd1,non_spd2,dest_info,
     &           dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,dest_lbo3,
     &           dest_ubo3,src,src_lbo1,src_ubo1,src_lbo2,src_ubo2)
         else
C--   CASE 1.3: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp2): PE ', myid, 
     &           ' dest is not BLOCK distributed'
         endif
      else if ((src_info(9,1) .EQ. dest_info(9,non_spd1)) .AND.
     &        (src_info(9,2) .EQ. dest_info(9,non_spd2))) then
C--   CASE 2: src and dest(non_spd) are dist at same dim , no comm needed
         if ((src_info(6,1) .EQ. dest_info(6,non_spd1)) .AND.
     &        (src_info(6,2) .EQ. dest_info(6,non_spd2))) then
C--   CASE 2.1: src and dest are dist in same way
            k1 = src_info(1,1)
            k2 = src_info(1,2)
            call src_to_dest_2_R(dim,k1,k2,non_spd1,non_spd2,dest_info,
     &           dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,dest_lbo3,
     &           dest_ubo3,src,src_lbo1,src_ubo1,src_lbo2,src_ubo2)
         else
C--   CASE 2.2: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp2): PE ', myid,
     &           ' src and dest are not distributed in same type'
         endif
      else
C--   CASE 3: concatenate src along spread dim, every node will have entire src
C--   prepare concatenate list (or spread list)
         if (((src_info(1,6) .EQ. 1) .AND. 
     &        (mod(src_info(1,5),src_info(1,8)) .EQ. 0)) .AND.
     &        (src_info(2,6) .EQ. 0)) then
            src_case = 1
         else if ((src_info(1,6) .EQ. 0) .AND. 
     &           ((src_info(2,6) .EQ. 1) .AND.
     &           (mod(src_info(2,5),src_info(2,8)) .EQ. 0))) then
            src_case = 2
         else if (((src_info(1,6) .EQ. 1) .AND. 
     &           (mod(src_info(1,5),src_info(1,8)) .EQ. 0)) .AND.
     &           ((src_info(2,6) .EQ. 1) .AND.
     &           (mod(src_info(2,5),src_info(2,8)) .EQ. 0))) then
            src_case = 3
         else
            src_case = 4
         endif

         if (src_case .NE. 4) then
C--   CASE 3.1: src is BOLCK dist, concatenate src
            if (src_case .EQ. 1) then
C--   CASE 3.1.1: src even BLOCK along 1st dim and replicated along 2nd dim
C--   rearrange local src to 1-d buffer
               call src_concate_R(src_case,src_info,src,src_lbo1,
     &              src_ubo1,src_lbo2,src_ubo2,src_buf1,src_buf2,
     &              src_temp,311)
            else if (src_case .EQ. 2) then
C--   CASE 3.1.2: src replicated along 1st dim and even BLOCK along 2nd dim
C--   rearrange local src to 1-d buffer
               call src_concate_R(src_case,src_info,src,src_lbo1,
     &              src_ubo1,src_lbo2,src_ubo2,src_buf1,src_buf2,
     &              src_temp,312)
            else
C--   CASE 3.1.3: src even BLOCK along 1st and 2nd dims
C--   rearrange 1st of local src to 1-d buffer
               call src_concate_R(src_case,src_info,src,src_lbo1,
     &              src_ubo1,src_lbo2,src_ubo2,src_buf1,src_buf2,
     &              src_temp,3131)
C--   prepare concatenate along 2nd dim parameters
               nnodes = src_info(8,2)
               direct = src_info(9,2)
               do i = 1, nnodes
                  nodel(i) = KXGDNO(myid, direct, i)
               end do
C--   sort nodel so each node has exactually same one
               call sort_nodel(nnodes,nodel)
               mybyte = mybyte * src_info(8,1)
               ressz = mybyte
               type = 3132
               status = KXCONC(src_buf2,mybyte,src_temp,
     &              ressz,sizes,nnodes,nodel,type)
            endif
C--   assign src to dest
C--   dest is replicated or block dist along non-spd dims, convert
C     to global index. assume that global index of dest begins at 1
            if (dest_info(6,non_spd1) .EQ. 1) then
               gdest_lb1 = local_to_global(dest_info(1,non_spd1),
     &              dest_info, non_spd1)
            else
               gdest_lb1 = 1
            endif
            if (dest_info(6,non_spd2) .EQ. 1) then
               gdest_lb2 = local_to_global(dest_info(1,non_spd2),
     &              dest_info, non_spd2)
            else
               gdest_lb2 = 1
            endif
            k1 = gdest_lb1
            k2 = gdest_lb2
            call src_to_dest_2_R_loc(dim,k1,k2,non_spd1,non_spd2,
     &           dest_info,dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,
     &           dest_lbo3,dest_ubo3,src_temp,src_info,src_case)
         else
C--   CASE 3.2: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp2): PE ', myid,
     &           ' communication required - ',
     &           'src is not even BLOCK dist and/or ...'
         endif

      endif

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     convert local index to global index
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      integer function local_to_global(local, array_info, da_dim)

C      implicit none
      integer local, array_info(11,7), da_dim

      integer myid, mycord(3), numpe, grids, nprocs(3)
      integer intsize, realsize, dpsize, maxsize

      integer real_loc, pr_dim, loc_size, bigger_nodes, prev_ub
      
      COMMON/XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      common /kxparms/ myid, mycord, numpe, grids, nprocs
      common /varsize/ intsize, realsize, dpsize, maxsize

C--   I assume that the global index always begins at 1 (= glb)
C--   local lb may not begin at 1, so
      real_loc = local - array_info(1,da_dim) + 1

C--   the corresponding processor grid dim which the data array da_dim
C--   is distributed 
      pr_dim = array_info(9,da_dim)
      if (array_info(6,da_dim) .EQ. 1) then
C--   BLOCK dist, use ceiling(N/P) and floor(N/P) as block size
         loc_size = array_info(5,da_dim) / array_info(8,da_dim)
         bigger_nodes = array_info(5,da_dim) - array_info(8,da_dim) *
     &        loc_size
         if (mycord(pr_dim) .LT. bigger_nodes) then
            prev_ub = loc_size * mycord(pr_dim) + mycord(pr_dim)
         else
            prev_ub = loc_size * mycord(pr_dim) + bigger_nodes
         endif
         local_to_global = real_loc + prev_ub
      else if (array_info(6,da_dim) .EQ. 2) then
C--   CYCLIC dist
         local_to_global = (mycord(pr_dim) + 1) + (real_loc - 1) * 
     &        array_info(8,da_dim)
      else
C--   FURTHER IMPLEMENT NEEDED - 10/02/92
         print *, '***ERROR(L_to_G): PE ', myid, 
     &        ' no BLOCK-CYCLIC supported'
         local_to_global = -1
      endif

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C   assign src to dest (2D)(real)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine src_to_dest_2_R(dim,k1,k2,non_spd1,non_spd2,dest_info,
     &     dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,dest_lbo3,
     &     dest_ubo3,src,src_lbo1,src_ubo1,src_lbo2,src_ubo2)

C      implicit none
      integer dim, k1, k2, non_spd1, non_spd2
      integer src_lbo1, src_ubo1, src_lbo2, src_ubo2
      integer dest_lbo1, dest_ubo1, dest_lbo2, dest_ubo2
      integer dest_lbo3, dest_ubo3
      integer dest_info(11,7)
      real src(src_lbo1:src_ubo1,src_lbo2:src_ubo2) 
      real dest(dest_lbo1:dest_ubo1,dest_lbo2:dest_ubo2,
     &     dest_lbo3:dest_ubo3)
      
      integer i, j, k

      if (dim .EQ. 1) then
C--   spread along dest's 1st dim
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(k,i,j) = src(k1,k2)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      else if (dim .EQ. 2) then
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(i,k,j) = src(k1,k2)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      else
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(i,j,k) = src(k1,k2)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      endif

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C   assign src to dest (2D)(real) with location conversion
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine src_to_dest_2_R_loc(dim,k1,k2,non_spd1,non_spd2,
     &     dest_info,dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,
     &     dest_lbo3,dest_ubo3,src_temp,src_info,src_case)

C      implicit none
      integer dim, k1, k2, non_spd1, non_spd2, src_case
      integer dest_lbo1, dest_ubo1, dest_lbo2, dest_ubo2
      integer dest_lbo3, dest_ubo3
      integer dest_info(11,7), src_info(11,7)
      real src_temp(*)
      real dest(dest_lbo1:dest_ubo1,dest_lbo2:dest_ubo2,
     &     dest_lbo3:dest_ubo3)

      integer i, j, k
      integer src_g1, src_l1, src_g2, src_l2
      integer loc_in_1d, loc

C--   calculate src's block size and global size
      src_g1 = src_info(5,1)
      src_l1 = src_info(5,1) / src_info(8,1)
      src_g2 = src_info(5,2)
      src_l2 = src_info(5,2) / src_info(8,2)

      if (dim .EQ. 1) then
C--   spread along dest's 1st dim
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               loc = loc_in_1d(src_case,k1,k2,src_l1, src_g1,
     &              src_l2, src_g2)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(k,i,j) = src_temp(loc)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      else if (dim .EQ. 2) then
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               loc = loc_in_1d(src_case,k1,k2,src_l1, src_g1,
     &              src_l2, src_g2)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(i,k,j) = src_temp(loc)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      else
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               loc = loc_in_1d(src_case,k1,k2,src_l1, src_g1,
     &              src_l2, src_g2)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(i,j,k) = src_temp(loc)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      endif
      
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     sort nodel
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine sort_nodel(nnodes,nodel)

C      implicit none
      integer nnodes, nodel(*)

      integer i, j, tnode

C--   sort nodel so each node has exactually same one
      do i = 1, (nnodes-2)
         do j = (nnodes-1), (i+1), -1
            if (nodel(j-1) .GT. nodel(j)) then
               tnode = nodel(j-1)
               nodel(j-1) = nodel(j)
               nodel(j) = tnode
            endif
         end do
      end do

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     arrange src and process concatenate (real)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine src_concate_R(src_case,src_info,src,src_lbo1,src_ubo1,
     &     src_lbo2,src_ubo2,src_buf1,src_buf2,src_temp,type)

C      implicit none
      integer src_case, src_info(11,7), type
      integer src_lbo1, src_ubo1, src_lbo2, src_ubo2
      real src(src_lbo1:src_ubo1,src_lbo2:src_ubo2)
      real src_buf1(*), src_buf2(*), src_temp(*)

      integer myid, mycord(3), numpe, grids, nprocs(3)
      integer intsize, realsize, dpsize

      integer i, j, k, nnodes, direct, nodel(128), case
      integer mybyte, ressz, sizes(128), status

      COMMON/XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      common /kxparms/ myid, mycord, numpe, grids, nprocs
      common /varsize/ intsize, realsize, dpsize

C--   rearrange local src to 1-d buffer
      if ((src_case .EQ. 1) .OR. (src_case .EQ. 3)) then
         case = 1
         k = 1
         do j = src_info(1,2), src_info(2,2)
            do i = src_info(1,1), src_info(2,1)
               src_buf1(k) = src(i,j)
               k = k + 1
            enddo
         enddo
      else if (src_case .EQ. 2) then
         case = 2
         k = 1
         do j = src_info(1,2), src_info(2,2)
            do i = src_info(1,1), src_info(2,1)
               src_buf2(k) = src(i,j)
               k = k + 1
            enddo
         enddo
      else
         print *, '***ERROR(src_con): src_case .NE. 1,2,3'
      endif

C--   prepare concatenate parameters
      nnodes = src_info(8,case)
      direct = src_info(9,case)
      do i = 1, nnodes
         nodel(i) = KXGDNO(myid, direct, i)
      end do
C--   sort nodel so each node has exactually same one
      call sort_nodel(nnodes,nodel)
      mybyte = (k - 1) * realsize
      ressz = mybyte
      if (src_case .EQ. 1) then
         status = KXCONC(src_buf1,mybyte,src_temp,
     &        ressz,sizes,nnodes,nodel,type)
      else if (src_case .EQ. 2) then
         status = KXCONC(src_buf2,mybyte,src_temp,
     &        ressz,sizes,nnodes,nodel,type)
      else
         status = KXCONC(src_buf1,mybyte,src_buf2,
     &        ressz,sizes,nnodes,nodel,type)
      endif

      return
      end
         



CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C   Intrinsic function: spread 2-to-3 (integer)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine spread_2_I(src,src_lbo1,src_ubo1,src_lbo2,src_ubo2,
     &     src_info,dim,ncopies,dest,dest_lbo1,dest_ubo1,dest_lbo2,
     &     dest_ubo2,dest_lbo3,dest_ubo3,dest_info)

C      implicit none
      integer src_lbo1, src_ubo1, src_lbo2, src_ubo2
      integer dest_lbo1, dest_ubo1, dest_lbo2, dest_ubo2
      integer dest_lbo3, dest_ubo3
      integer src_info(11,7), dest_info(11,7), dim, ncopies 
      integer src(src_lbo1:src_ubo1,src_lbo2:src_ubo2) 
      integer dest(dest_lbo1:dest_ubo1,dest_lbo2:dest_ubo2,
     &     dest_lbo3:dest_ubo3)
      
      integer myid, mycord(3), numpe, grids, nprocs(3)
      integer intsize, realsize, dpsize

      integer i, j, k, k1, k2
      integer non_spd1, non_spd2, gdest_lb1, gdest_lb2, nnodes, direct
      integer nodel(128), tnode, loc_size, bigger_nodes
      integer mybyte, ressz, status, sizes(128)
      integer local_to_global, type, loc, src_case
      integer src_buf1(1024), src_buf2(1024), src_temp(1024)

      COMMON/XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      common /kxparms/ myid, mycord, numpe, grids, nprocs
      common /varsize/ intsize, realsize, dpsize

C--   find out the non spreaded dims of the 3-d dest
      if (dim .EQ. 1 ) then
         non_spd1 = 2
         non_spd2 = 3
      else if (dim .EQ. 2) then
         non_spd1 = 1
         non_spd2 = 3
      else if (dim .EQ. 3) then
         non_spd1 = 1
         non_spd2 = 2
      else
         print *, '***ERROR(isp2): PE ', myid, 
     &        ' DIM not equal to 1, 2 or 3'
         return
      endif

      if ((src_info(6,1) .EQ. 0) .AND. (src_info(6,2) .EQ. 0)) then
C--   CASE 1: src is replicated at every node, no comm needed
         if ((dest_info(6,non_spd1) .EQ. 0) .AND.
     &        (dest_info(6,non_spd2) .EQ. 0)) then
C--   CASE 1.1: dest is replicated along non-spd dims, all-to-all copy
            k1 = src_info(1,1)
            k2 = src_info(1,2)
            call src_to_dest_2_I(dim,k1,k2,non_spd1,non_spd2,dest_info,
     &           dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,dest_lbo3,
     &           dest_ubo3,src,src_lbo1,src_ubo1,src_lbo2,src_ubo2)
         else if ((dest_info(6,non_spd1) .LE. 1) .AND.
     &           (dest_info(6,non_spd2) .LE. 1)) then
C--   CASE 1.2: dest is replicated or block dist along non-spd dims, convert 
C     to global index. assume that global index of dest begins at 1
            if (dest_info(6,non_spd1) .EQ. 1) then
               gdest_lb1 = local_to_global(dest_info(1,non_spd1), 
     &              dest_info, non_spd1)
            else
               gdest_lb1 = 1
            endif
            if (dest_info(6,non_spd2) .EQ. 1) then
               gdest_lb2 = local_to_global(dest_info(1,non_spd2),
     &              dest_info, non_spd2)
            else
               gdest_lb2 = 1
            endif
            k1 = gdest_lb1 + (src_info(1,1) - 1)
            k2 = gdest_lb2 + (src_info(1,2) - 1)
            call src_to_dest_2_I(dim,k1,k2,non_spd1,non_spd2,dest_info,
     &           dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,dest_lbo3,
     &           dest_ubo3,src,src_lbo1,src_ubo1,src_lbo2,src_ubo2)
         else
C--   CASE 1.3: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp2): PE ', myid, 
     &           ' dest is not BLOCK distributed'
         endif
      else if ((src_info(9,1) .EQ. dest_info(9,non_spd1)) .AND.
     &        (src_info(9,2) .EQ. dest_info(9,non_spd2))) then
C--   CASE 2: src and dest(non_spd) are dist at same dim , no comm needed
         if ((src_info(6,1) .EQ. dest_info(6,non_spd1)) .AND.
     &        (src_info(6,2) .EQ. dest_info(6,non_spd2))) then
C--   CASE 2.1: src and dest are dist in same way
            k1 = src_info(1,1)
            k2 = src_info(1,2)
            call src_to_dest_2_I(dim,k1,k2,non_spd1,non_spd2,dest_info,
     &           dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,dest_lbo3,
     &           dest_ubo3,src,src_lbo1,src_ubo1,src_lbo2,src_ubo2)
         else
C--   CASE 2.2: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp2): PE ', myid,
     &           ' src and dest are not distributed in same type'
         endif
      else
C--   CASE 3: concatenate src along spread dim, every node will have entire src
C--   prepare concatenate list (or spread list)
         if (((src_info(1,6) .EQ. 1) .AND. 
     &        (mod(src_info(1,5),src_info(1,8)) .EQ. 0)) .AND.
     &        (src_info(2,6) .EQ. 0)) then
            src_case = 1
         else if ((src_info(1,6) .EQ. 0) .AND. 
     &           ((src_info(2,6) .EQ. 1) .AND.
     &           (mod(src_info(2,5),src_info(2,8)) .EQ. 0))) then
            src_case = 2
         else if (((src_info(1,6) .EQ. 1) .AND. 
     &           (mod(src_info(1,5),src_info(1,8)) .EQ. 0)) .AND.
     &           ((src_info(2,6) .EQ. 1) .AND.
     &           (mod(src_info(2,5),src_info(2,8)) .EQ. 0))) then
            src_case = 3
         else
            src_case = 4
         endif

         if (src_case .NE. 4) then
C--   CASE 3.1: src is BOLCK dist, concatenate src
            if (src_case .EQ. 1) then
C--   CASE 3.1.1: src even BLOCK along 1st dim and replicated along 2nd dim
C--   rearrange local src to 1-d buffer
               call src_concate_I(src_case,src_info,src,src_lbo1,
     &              src_ubo1,src_lbo2,src_ubo2,src_buf1,src_buf2,
     &              src_temp,311)
            else if (src_case .EQ. 2) then
C--   CASE 3.1.2: src replicated along 1st dim and even BLOCK along 2nd dim
C--   rearrange local src to 1-d buffer
               call src_concate_I(src_case,src_info,src,src_lbo1,
     &              src_ubo1,src_lbo2,src_ubo2,src_buf1,src_buf2,
     &              src_temp,312)
            else
C--   CASE 3.1.3: src even BLOCK along 1st and 2nd dims
C--   rearrange 1st of local src to 1-d buffer
               call src_concate_I(src_case,src_info,src,src_lbo1,
     &              src_ubo1,src_lbo2,src_ubo2,src_buf1,src_buf2,
     &              src_temp,3131)
C--   prepare concatenate along 2nd dim parameters
               nnodes = src_info(8,2)
               direct = src_info(9,2)
               do i = 1, nnodes
                  nodel(i) = KXGDNO(myid, direct, i)
               end do
C--   sort nodel so each node has exactually same one
               call sort_nodel(nnodes,nodel)
               mybyte = mybyte * src_info(8,1)
               ressz = mybyte
               type = 3132
               status = KXCONC(src_buf2,mybyte,src_temp,
     &              ressz,sizes,nnodes,nodel,type)
            endif
C--   assign src to dest
C--   dest is replicated or block dist along non-spd dims, convert
C     to global index. assume that global index of dest begins at 1
            if (dest_info(6,non_spd1) .EQ. 1) then
               gdest_lb1 = local_to_global(dest_info(1,non_spd1),
     &              dest_info, non_spd1)
            else
               gdest_lb1 = 1
            endif
            if (dest_info(6,non_spd2) .EQ. 1) then
               gdest_lb2 = local_to_global(dest_info(1,non_spd2),
     &              dest_info, non_spd2)
            else
               gdest_lb2 = 1
            endif
            k1 = gdest_lb1
            k2 = gdest_lb2
            call src_to_dest_2_I_loc(dim,k1,k2,non_spd1,non_spd2,
     &           dest_info,dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,
     &           dest_lbo3,dest_ubo3,src_temp,src_info,src_case)
         else
C--   CASE 3.2: FURTHER IMPLEMENT NEEDED - 10/02/92
            print *, '***ERROR(isp2): PE ', myid,
     &           ' communication required - ',
     &           'src is not even BLOCK dist and/or ...'
         endif

      endif

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     convert 2-D index set into 1-D location
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      integer function loc_in_1d(case, k1, k2, lbk1, gbk1, lbk2, gbk2)

C      implicit none
      integer case, k1, k2, lbk1, gbk1, lbk2, gbk2

      integer myid, mycord(3), numpe, grids, nprocs(3)
      integer intsize, realsize, dpsize

      integer real_loc, pr_dim, loc_size, bigger_nodes, prev_ub
      
      COMMON/XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      common /kxparms/ myid, mycord, numpe, grids, nprocs
      common /varsize/ intsize, realsize, dpsize

      if (case .EQ. 1) then
         loc_in_1d = (k1 / lbk1) * (lbk1 * gbk2) + (k2 - 1) * lbk1 + 
     &        mod(k1,lbk1)
      else if (case .EQ. 2) then
         loc_in_1d = (k2 - 1) * gbk1 + k1 
      else if (case .EQ. 3) then
         loc_in_1d = (k2 / lbk2) * (gbk1 * lbk2) + (k1 / lbk1) * 
     &        (lbk1 * lbk2) + (mod(k2,lbk2) - 1) * lbk1 + mod(k1,lbk1)
      else
         print *, '***ERROR(loc_in_1d): PE ', myid, ' wrong case'
      endif

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C   assign src to dest (2D)(integer)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine src_to_dest_2_I(dim,k1,k2,non_spd1,non_spd2,dest_info,
     &     dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,dest_lbo3,
     &     dest_ubo3,src,src_lbo1,src_ubo1,src_lbo2,src_ubo2)

C      implicit none
      integer dim, k1, k2, non_spd1, non_spd2
      integer src_lbo1, src_ubo1, src_lbo2, src_ubo2
      integer dest_lbo1, dest_ubo1, dest_lbo2, dest_ubo2
      integer dest_lbo3, dest_ubo3
      integer dest_info(11,7)
      integer src(src_lbo1:src_ubo1,src_lbo2:src_ubo2) 
      integer dest(dest_lbo1:dest_ubo1,dest_lbo2:dest_ubo2,
     &     dest_lbo3:dest_ubo3)

      integer i, j, k

      if (dim .EQ. 1) then
C--   spread along dest's 1st dim
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(k,i,j) = src(k1,k2)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      else if (dim .EQ. 2) then
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(i,k,j) = src(k1,k2)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      else
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(i,j,k) = src(k1,k2)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      endif

      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C   assign src to dest (2D)(integer) with location conversion
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine src_to_dest_2_I_loc(dim,k1,k2,non_spd1,non_spd2,
     &     dest_info,dest,dest_lbo1,dest_ubo1,dest_lbo2,dest_ubo2,
     &     dest_lbo3,dest_ubo3,src_temp,src_info,src_case)

C      implicit none
      integer dim, k1, k2, non_spd1, non_spd2, src_case
      integer dest_lbo1, dest_ubo1, dest_lbo2, dest_ubo2
      integer dest_lbo3, dest_ubo3
      integer dest_info(11,7), src_info(11,7)
      integer src_temp(*)
      integer dest(dest_lbo1:dest_ubo1,dest_lbo2:dest_ubo2,
     &     dest_lbo3:dest_ubo3)

      integer i, j, k
      integer src_g1, src_l1, src_g2, src_l2
      integer loc_in_1d, loc

C--   calculate src's block size and global size
      src_g1 = src_info(5,1)
      src_l1 = src_info(5,1) / src_info(8,1)
      src_g2 = src_info(5,2)
      src_l2 = src_info(5,2) / src_info(8,2)

      if (dim .EQ. 1) then
C--   spread along dest's 1st dim
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               loc = loc_in_1d(src_case,k1,k2,src_l1, src_g1,
     &              src_l2, src_g2)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(k,i,j) = src_temp(loc)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      else if (dim .EQ. 2) then
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               loc = loc_in_1d(src_case,k1,k2,src_l1, src_g1,
     &              src_l2, src_g2)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(i,k,j) = src_temp(loc)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      else
         do j = dest_info(1,non_spd2), dest_info(2,non_spd2)
            do i = dest_info(1,non_spd1), dest_info(2,non_spd1)
               loc = loc_in_1d(src_case,k1,k2,src_l1, src_g1,
     &              src_l2, src_g2)
               do k = dest_info(1,dim), dest_info(2,dim)
                  dest(i,j,k) = src_temp(loc)
               enddo
               k1 = k1 + 1
            enddo
            k2 = k2 + 1
         enddo
      endif
      
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     arrange src and process concatenate (integer)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine src_concate_I(src_case,src_info,src,src_lbo1,src_ubo1,
     &     src_lbo2,src_ubo2,src_buf1,src_buf2,src_temp,type)

C      implicit none
      integer src_case, src_info(11,7), type
      integer src_lbo1, src_ubo1, src_lbo2, src_ubo2
      integer src(src_lbo1:src_ubo1,src_lbo2:src_ubo2)
      integer src_buf1(*), src_buf2(*), src_temp(*)

      integer myid, mycord(3), numpe, grids, nprocs(3)
      integer intsize, realsize, dpsize

      integer i, j, k, nnodes, direct, nodel(128), case
      integer mybyte, ressz, sizes(128), status

      COMMON/XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      common /kxparms/ myid, mycord, numpe, grids, nprocs
      common /varsize/ intsize, realsize, dpsize

C--   rearrange local src to 1-d buffer
      if ((src_case .EQ. 1) .OR. (src_case .EQ. 3)) then
         case = 1
         k = 1
         do j = src_info(1,2), src_info(2,2)
            do i = src_info(1,1), src_info(2,1)
               src_buf1(k) = src(i,j)
               k = k + 1
            enddo
         enddo
      else if (src_case .EQ. 2) then
         case = 2
         k = 1
         do j = src_info(1,2), src_info(2,2)
            do i = src_info(1,1), src_info(2,1)
               src_buf2(k) = src(i,j)
               k = k + 1
            enddo
         enddo
      else
         print *, '***ERROR(src_con): src_case .NE. 1,2,3'
      endif

C--   prepare concatenate parameters
      nnodes = src_info(8,case)
      direct = src_info(9,case)
      do i = 1, nnodes
         nodel(i) = KXGDNO(myid, direct, i)
      end do
C--   sort nodel so each node has exactually same one
      call sort_nodel(nnodes,nodel)
      mybyte = (k - 1) * intsize
      ressz = mybyte
      if (src_case .EQ. 1) then
         status = KXCONC(src_buf1,mybyte,src_temp,
     &        ressz,sizes,nnodes,nodel,type)
      else if (src_case .EQ. 2) then
         status = KXCONC(src_buf2,mybyte,src_temp,
     &        ressz,sizes,nnodes,nodel,type)
      else
         status = KXCONC(src_buf1,mybyte,src_buf2,
     &        ressz,sizes,nnodes,nodel,type)
      endif

      return
      end
         


