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



CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C routine for cshift operation 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine CSHIFT_1_I(ARRAY, a1, a2, ARRAY_INFO, SHIFT, RESULT, 
     &  r1, r2, RESULT_INFO, PROCLIST)
      integer a1, a2, r1, r2
      integer ARRAY_INFO(8,7), RESULT_INFO(8,7)
      integer ARRAY(a1:a2), RESULT(r1:r2)
      integer SHIFT, PROCLIST(*)
      
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      
      integer ENV(4), nproc(2)
      integer intSize, realSize
      data realSize, intSize/4, 4/
      integer lb, ub, size, i, k
      integer type, status, in
      integer sp1, sp2, dp1, dp2, L1, L2, U1, U2, loc_shift
      integer pe1, pe2, len1, len2
      
      nproc(1) = ARRAY_INFO(8,1)
      status = KXGDIN(1, nproc)
      status = KXPARA(ENV)
      lb   = ARRAY_INFO(1,1)
      ub   = ARRAY_INFO(2,1)
      size = ub - lb + 1
      
      if (SHIFT .LT. 0) then
         loc_shift = -SHIFT
         pe1 = (lb - 1 + loc_shift)/size
         dp1 = KXGDNO(ENV(1), 0, -pe1)
         
         if (dp1 .NE. ENV(1)) then
            L1 = MOD(loc_shift, size) + 1
            U1 = size
            len1 = U1-L1+1
            type = 255+dp1
            status = KXWRIT(ARRAY(L1), len1*intSize, dp1, type)
         end if
         
         pe2 = (ub - 1 + loc_shift)/size
         dp2 = KXGDNO(ENV(1), 0, -pe2)
         L2 = lb
         U2 = MOD(loc_shift -1, size)+1
         len2 = U2-L2+1
         if ((dp2 .NE. ENV(1)) .AND. (dp2 .NE. dp1)) then
            type = 355+dp2
            status = KXWRIT(ARRAY(L2), len2*intSize, dp2, type)
         end if
         
      else if (SHIFT .GT. 0) then
         pe1 = (lb- 1 + SHIFT)/size
         dp1 = KXGDNO(ENV(1), 0, pe1)
         
         if (dp1 .NE. ENV(1)) then
            L1 = lb
            U1 = MOD(ENV(2)*size -1 - SHIFT, size) +1 
            len1 = U1-L1+1
            type = 255+dp1
            status = KXWRIT(ARRAY(L1), len1*intSize, dp1, type)
         end if
         
         pe2 = (ub- 1 + SHIFT)/size
         dp2 = KXGDNO(ENV(1), 0, pe2)
         L2 = MOD(ENV(2)*size - SHIFT, size)+1
         U2 = size
         len2 = U2-L2+1
         if ((dp2 .NE. ENV(1)) .AND. (dp2 .NE. dp1)) then
            type = 355+dp2
            status = KXWRIT(ARRAY(L2), len2*intSize, dp2, type)
         end if
         
      end if
      
CC    receiving side
      
      if (SHIFT .LT. 0) then
         in = lb
         loc_shift = - SHIFT
         if (loc_shift .LT. size) then
            do i = lb+loc_shift, ub
               RESULT(i-loc_shift) = ARRAY(i)
               in = in + 1
            end do
         end if
         
         sp1 = KXGDNO(ENV(1), 0, pe1)
         
         if (sp1 .NE. ENV(1)) then
            type = 255+ENV(1)
            status = KXREAD(RESULT(in),len1*intSize,sp1, type)
            in = in + len1
         end if
         
         sp2 = KXGDNO(ENV(1), 0, pe2)
         if (sp2 .NE. sp1) then
            if (sp2 .NE. ENV(1)) then
               type = 355+ENV(1)
               status = KXREAD(RESULT(in), len2*intSize, sp2, type)
            else
               do i = 0, len2-1
                  RESULT(in+i) = ARRAY(L2+i)
               end do
            end if
         end if
         
         if ((sp2 .EQ. ENV(1)) .AND. (sp1 .EQ. ENV(1))) then
            in = in -1
            do i = lb, loc_shift
               RESULT(in+k) = ARRAY(i)
               k = K+1
            end do
         end if
         
      else if (SHIFT .GT. 0) then
         in = lb
         if (SHIFT .LT. size) then
            in = ub
            do i = ub-SHIFT, lb, - 1
               RESULT(i+SHIFT) = ARRAY(i)
               in = in - 1
            end do
         end if
         
         sp1 = KXGDNO(ENV(1), 0, -pe1)
         
         if (sp1 .NE. ENV(1)) then
            in = ub-len1+1
            type = 255+ENV(1)
            status = KXREAD(RESULT(in),len1*intSize,sp1, type)
         end if
         
         sp2 = KXGDNO(ENV(1), 0, -pe2)
         if (sp2 .NE. sp1) then
            in = lb
            if (sp2 .NE. ENV(1)) then
               type = 355+ENV(1)
               status = KXREAD(RESULT(in), len2*intSize, sp2, type)
            else
               do i = 0, len2-1
                  RESULT(in+i) = ARRAY(L2+i)
               end do
            end if
         end if
         
         if ((sp2 .EQ. ENV(1)) .AND. (sp1 .EQ. ENV(1))) then
            k = 1
            do i = ub-SHIFT+1, ub
               RESULT(k) = ARRAY(i)
               k = k+1
            end do
         end if
      end if
      
      
      return
      end 
      
      

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C routine for cshift operation (REAL)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine CSHIFT_1_R(ARRAY, a1, a2, ARRAY_INFO, SHIFT, RESULT, 
     &  r1, r2, RESULT_INFO, PROCLIST)
      integer a1, a2, r1, r2
      integer ARRAY_INFO(8,7), RESULT_INFO(8,7)
      real ARRAY(a1:a2), RESULT(r1:r2)
      integer SHIFT, PROCLIST(*)
      
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      
      integer ENV(4)
      integer intSize, realSize
      data realSize, intSize/4, 4/
      integer lb, ub, size, i, k
      integer type, status, in
      integer sp1, sp2, dp1, dp2, L1, L2, U1, U2, loc_shift
      integer pe1, pe2, len1, len2, nproc(2)

      nproc(1) = ARRAY_INFO(8,1)
      status = KXGDIN(1,nproc)
      
      status = KXPARA(ENV)
      lb   = ARRAY_INFO(1,1)
      ub   = ARRAY_INFO(2,1)
      size = ARRAY_INFO(5,1)
      
      if (SHIFT .LT. 0) then
         loc_shift = -SHIFT
         pe1 = (lb - 1 + loc_shift)/size
         dp1 = KXGDNO(ENV(1), 0, -pe1)
         
         if (dp1 .NE. ENV(1)) then
            L1 = MOD(loc_shift, size) + 1
            U1 = size
            len1 = U1-L1+1
            type = 255+dp1
            status = KXWRIT(ARRAY(L1), len1*intSize, dp1, type)
         end if
         
         pe2 = (ub - 1 + loc_shift)/size
         dp2 = KXGDNO(ENV(1), 0, -pe2)
         L2 = lb
         U2 = MOD(loc_shift -1, size)+1
         len2 = U2-L2+1
         if ((dp2 .NE. ENV(1)) .AND. (dp2 .NE. dp1)) then
            type = 355+dp2
            status = KXWRIT(ARRAY(L2), len2*intSize, dp2, type)
         end if
         
      else if (SHIFT .GT. 0) then
         pe1 = (lb- 1 + SHIFT)/size
         dp1 = KXGDNO(ENV(1), 0, pe1)
         
         if (dp1 .NE. ENV(1)) then
            L1 = lb
            U1 = MOD(ENV(2)*size -1 - SHIFT, size) +1 
            len1 = U1-L1+1
            type = 255+dp1
            status = KXWRIT(ARRAY(L1), len1*intSize, dp1, type)
         end if
         
         pe2 = (ub- 1 + SHIFT)/size
         dp2 = KXGDNO(ENV(1), 0, pe2)
         L2 = MOD(ENV(2)*size - SHIFT, size)+1
         U2 = size
         len2 = U2-L2+1
         if ((dp2 .NE. ENV(1)) .AND. (dp2 .NE. dp1)) then
            type = 355+dp2
            status = KXWRIT(ARRAY(L2), len2*intSize, dp2, type)
         end if
         
      end if
      
CC    receiving side
      
      if (SHIFT .LT. 0) then
         in = lb
         loc_shift = - SHIFT
         if (loc_shift .LT. size) then
            do i = lb+loc_shift, ub
               RESULT(i-loc_shift) = ARRAY(i)
               in = in + 1
            end do
         end if
         
         sp1 = KXGDNO(ENV(1), 0, pe1)
         
         if (sp1 .NE. ENV(1)) then
            type = 255+ENV(1)
            status = KXREAD(RESULT(in),len1*intSize,sp1, type)
            in = in + len1
         end if
         
         sp2 = KXGDNO(ENV(1), 0, pe2)
         if (sp2 .NE. sp1) then
            if (sp2 .NE. ENV(1)) then
               type = 355+ENV(1)
               status = KXREAD(RESULT(in), len2*intSize, sp2, type)
            else
               do i = 0, len2-1
                  RESULT(in+i) = ARRAY(L2+i)
               end do
            end if
         end if
         
         if ((sp2 .EQ. ENV(1)) .AND. (sp1 .EQ. ENV(1))) then
            in = in -1
            do i = lb, loc_shift
               RESULT(in+k) = ARRAY(i)
               k = K+1
            end do
         end if
         
      else if (SHIFT .GT. 0) then
         in = lb
         if (SHIFT .LT. size) then
            in = ub
            do i = ub-SHIFT, lb, - 1
               RESULT(i+SHIFT) = ARRAY(i)
               in = in - 1
            end do
         end if
         
         sp1 = KXGDNO(ENV(1), 0, -pe1)
         
         if (sp1 .NE. ENV(1)) then
            in = ub-len1+1
            type = 255+ENV(1)
            status = KXREAD(RESULT(in),len1*intSize,sp1, type)
         end if
         
         sp2 = KXGDNO(ENV(1), 0, -pe2)
         if (sp2 .NE. sp1) then
            in = lb
            if (sp2 .NE. ENV(1)) then
               type = 355+ENV(1)
               status = KXREAD(RESULT(in), len2*intSize, sp2, type)
            else
               do i = 0, len2-1
                  RESULT(in+i) = ARRAY(L2+i)
               end do
            end if
         end if
         
         if ((sp2 .EQ. ENV(1)) .AND. (sp1 .EQ. ENV(1))) then
            k = 1
            do i = ub-SHIFT+1, ub
               RESULT(k) = ARRAY(i)
               k = k+1
            end do
         end if
      end if
      
      
      return
      end 
      
      



CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC



      subroutine CSHIFT_1_D(ARRAY, a1, a2, ARRAY_INFO, SHIFT, RESULT, 
     &  r1, r2, RESULT_INFO, PROCLIST)
      integer a1, a2, r1, r2
      integer ARRAY_INFO(8,7), RESULT_INFO(8,7)
      double precision ARRAY(a1:a2), RESULT(r1:r2)
      integer SHIFT, PROCLIST(*)
      
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      
      integer ENV(4)
      integer intSize, doubleSize
      data doubleSize, intSize/8, 4/
      integer lb, ub, size, i, k
      integer type, status, in
      integer sp1, sp2, dp1, dp2, L1, L2, U1, U2, loc_shift
      integer pe1, pe2, len1, len2, nproc(2)

      nproc(1) = ARRAY_INFO(8,1)
      status = KXGDIN(1,nproc)
      
      status = KXPARA(ENV)
      lb   = ARRAY_INFO(1,1)
      ub   = ARRAY_INFO(2,1)
      size = ARRAY_INFO(5,1)
      
      if (SHIFT .LT. 0) then
         loc_shift = -SHIFT
         pe1 = (lb - 1 + loc_shift)/size
         dp1 = KXGDNO(ENV(1), 0, -pe1)
         
         if (dp1 .NE. ENV(1)) then
            L1 = MOD(loc_shift, size) + 1
            U1 = size
            len1 = U1-L1+1
            type = 255+dp1
            status = KXWRIT(ARRAY(L1), len1*doubleSize, dp1, type)
         end if
         
         pe2 = (ub - 1 + loc_shift)/size
         dp2 = KXGDNO(ENV(1), 0, -pe2)
         L2 = lb
         U2 = MOD(loc_shift -1, size)+1
         len2 = U2-L2+1
         if ((dp2 .NE. ENV(1)) .AND. (dp2 .NE. dp1)) then
            type = 355+dp2
            status = KXWRIT(ARRAY(L2), len2*doubleSize, dp2, type)
         end if
         
      else if (SHIFT .GT. 0) then
         pe1 = (lb- 1 + SHIFT)/size
         dp1 = KXGDNO(ENV(1), 0, pe1)
         
         if (dp1 .NE. ENV(1)) then
            L1 = lb
            U1 = MOD(ENV(2)*size -1 - SHIFT, size) +1 
            len1 = U1-L1+1
            type = 255+dp1
            status = KXWRIT(ARRAY(L1), len1*doubleSize, dp1, type)
         end if
         
         pe2 = (ub- 1 + SHIFT)/size
         dp2 = KXGDNO(ENV(1), 0, pe2)
         L2 = MOD(ENV(2)*size - SHIFT, size)+1
         U2 = size
         len2 = U2-L2+1
         if ((dp2 .NE. ENV(1)) .AND. (dp2 .NE. dp1)) then
            type = 355+dp2
            status = KXWRIT(ARRAY(L2), len2*doubleSize, dp2, type)
         end if
         
      end if
      
CC    receiving side
      
      if (SHIFT .LT. 0) then
         in = lb
         loc_shift = - SHIFT
         if (loc_shift .LT. size) then
            do i = lb+loc_shift, ub
               RESULT(i-loc_shift) = ARRAY(i)
               in = in + 1
            end do
         end if
         
         sp1 = KXGDNO(ENV(1), 0, pe1)
         
         if (sp1 .NE. ENV(1)) then
            type = 255+ENV(1)
            status = KXREAD(RESULT(in),len1*doubleSize,sp1, type)
            in = in + len1
         end if
         
         sp2 = KXGDNO(ENV(1), 0, pe2)
         if (sp2 .NE. sp1) then
            if (sp2 .NE. ENV(1)) then
               type = 355+ENV(1)
               status = KXREAD(RESULT(in), len2*doubleSize, sp2, type)
            else
               do i = 0, len2-1
                  RESULT(in+i) = ARRAY(L2+i)
               end do
            end if
         end if
         
         if ((sp2 .EQ. ENV(1)) .AND. (sp1 .EQ. ENV(1))) then
            in = in -1
            do i = lb, loc_shift
               RESULT(in+k) = ARRAY(i)
               k = K+1
            end do
         end if
         
      else if (SHIFT .GT. 0) then
         in = lb
         if (SHIFT .LT. size) then
            in = ub
            do i = ub-SHIFT, lb, - 1
               RESULT(i+SHIFT) = ARRAY(i)
               in = in - 1
            end do
         end if
         
         sp1 = KXGDNO(ENV(1), 0, -pe1)
         
         if (sp1 .NE. ENV(1)) then
            in = ub-len1+1
            type = 255+ENV(1)
            status = KXREAD(RESULT(in),len1*doubleSize,sp1, type)
         end if
         
         sp2 = KXGDNO(ENV(1), 0, -pe2)
         if (sp2 .NE. sp1) then
            in = lb
            if (sp2 .NE. ENV(1)) then
               type = 355+ENV(1)
               status = KXREAD(RESULT(in), len2*doubleSize, sp2, type)
            else
               do i = 0, len2-1
                  RESULT(in+i) = ARRAY(L2+i)
               end do
            end if
         end if
         
         if ((sp2 .EQ. ENV(1)) .AND. (sp1 .EQ. ENV(1))) then
            k = 1
            do i = ub-SHIFT+1, ub
               RESULT(k) = ARRAY(i)
               k = k+1
            end do
         end if
      end if
      
      
      return
      end 
      
      


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC



      subroutine CSHIFT_2_I_S(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &  SHIFT, DIM, RESULT, r1, r2, r3, r4, RESULT_INFO, PROCLIST)

      integer a1, a2, a3, a4, r1, r2, r3, r4
      integer ARRAY_INFO(8,7), RESULT_INFO(8,7)
      integer ARRAY(a1:a2,a3:a4), RESULT(r1:r2,r3:r4), SHIFT
      integer DIM, PROCLIST(*)
      
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      
      integer temp(1024), temp_info(8,7)

      do i=1, 1024
         temp(i) = SHIFT
      end do
      
      call CSHIFT_2_I_V(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &     temp, 1, 1024, temp_info, DIM, RESULT, r1, r2, r3, r4, 
     &     RESULT_INFO, PROCLIST)
      
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      subroutine CSHIFT_2_I_V(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &  SHIFT, s1, s2, SHIFT_INFO, DIM, RESULT, r1, r2, r3, r4, 
     &  RESULT_INFO, PROCLIST)
      
      integer a1, a2, a3, a4, r1, r2, r3, r4, s1, s2
      integer ARRAY_INFO(8,7), RESULT_INFO(8,7), SHIFT_INFO(8,7)
      integer ARRAY(a1:a2,a3:a4), RESULT(r1:r2,r3:r4), SHIFT(s1:s2)
      integer DIM, PROCLIST(*)
      
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      
      logical more
      integer temp(1024), temp2(1024), asize, shift_size
      integer direc(1024), status, nproc(2)
      integer lb1, lb2, ub1, ub2, size1, size2, i, j
      
      nproc(1) = ARRAY_INFO(8,2)
      nproc(2) = ARRAY_INFO(8,1)
      status = KXGDIN(2,nproc)
        
      lb1 = ARRAY_INFO(1,1)
      lb2 = ARRAY_INFO(1,2)
      ub1 = ARRAY_INFO(2,1)
      ub2 = ARRAY_INFO(2,2)
      
      size1 = ub1 - lb1 + 1
      size2 = ub2 - lb2 + 1
      shift_size = ARRAY_INFO(2,DIM) - ARRAY_INFO(1,DIM) + 1
      
      do i = lb1, ub1
         do j = lb2, ub2
            RESULT(i,j) = ARRAY(i,j)
         end do
      end do
      
      do i=s1, s2
         SHIFT(i) = -SHIFT(i)
      end do

      if (DIM .EQ. 1) then
         asize = size2
      else if (DIM .EQ. 2) then
         asize = size1
      end if

      do i = 1, shift_size
         if (SHIFT(i) .GE. 0) then
            direc(i) = 1
         else
            direc(i) = -1
         end if
         temp2(i) = ABS(SHIFT(i))
      end do
      
      more = .TRUE.
      do while (more)
         do i = 1, shift_size
            if (temp2(i) .GT. asize) then
               temp(i) = asize
               temp2(i) = temp2(i) - asize
            else
               temp(i) = temp2(i)
               temp2(i) = 0
            end if
         end do
         call CSHIFTB_2_I(RESULT, r1, r2, r3, r4, RESULT_INFO,
     &        temp,DIM,direc)
         
         more = .FALSE.
         do i = 1, shift_size
            if (temp2(i) .GT. 0) then
               more = .TRUE.
            end if
         end do
      end do
      
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C    INTERMEDIATE SUBROUTINE USED FOR CSHIFT

	subroutine CSHIFTB_2_I(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &      SHIFT, DIM, direc)

        integer a1, a2, a3, a4, ARRAY_INFO(8,7)
	integer ARRAY(a1:a2,a3:a4)
	integer DIM, SHIFT(*), direc(*)

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

	integer shift_size
	integer intSize, realSize
	data realSize, intSize/4, 4/
	integer i, j, lnode, rnode,unode, dnode
	integer lb1, ub1
	integer lb2, ub2
	integer type, status, temp
	integer rec_buff(1024), send_buff(1024), len
	integer ENV(4)

	status = KXPARA(ENV)
	lb1   = ARRAY_INFO(1,1)
	ub1   = ARRAY_INFO(2,1)
	size1 = ub1 - lb1 + 1
	lb2   = ARRAY_INFO(1,2)
	ub2   = ARRAY_INFO(2,2)
	size2 = ub2 - lb2 + 1
	shift_size = ARRAY_INFO(2,DIM) - ARRAY_INFO(1,DIM) + 1

	if (DIM .EQ. 2) then
	len = 0
C communicate with negative side
        do i = lb1, ub1
           if (direc(i) .LT. 0) then
              temp = -SHIFT(i)
              do j = 0, SHIFT(i) -1
                 len = len + 1
                 send_buff(len) = ARRAY(i, lb2+j)
              end do
              do k = lb2+SHIFT(i), ub2
                 ARRAY(i, k-SHIFT(i)) = ARRAY(i, k)
              end do 
           end if
        end do
        if (len .GT. 0) then
           lnode = KXGDNO(ENV(1), 0, -1)
           type = 255+lnode
           status = KXWRIT(send_buff, len*intSize, lnode, type)
           rnode = KXGDNO(ENV(1), 0, 1)
           type = 255+ENV(1)
           status = KXREAD(rec_buff,len*intSize,rnode, type)
           
           len = 1
           do i = lb1, ub1
              if (direc(i) .LT. 0) then
                 temp = -SHIFT(i)
                 do k = 1, SHIFT(i)
                    ARRAY(i, ub2-SHIFT(i)+k) 
     &                   = rec_buff(len)
                    len = len + 1
                 end do
              end if
           end do
        end if
        
	len = 0
        do i = lb1, ub1
C     communicate with positive side
           if (direc(i) .GT. 0) then
              do j = 1, SHIFT(i)
                 len = len + 1
                 send_buff(len) = ARRAY(i, ub2-SHIFT(i)+j)
              end do
              do k = ub2-SHIFT(i), lb2, -1
                 ARRAY(i, k+SHIFT(i)) = ARRAY(i, k)
              end do 
           end if
        end do
        if (len .GT. 0) then
           rnode = KXGDNO(ENV(1), 0, 1)
           type = 255+rnode
           status = KXWRIT(send_buff, len*intSize, rnode, type)
           lnode = KXGDNO(ENV(1), 0, -1)
           type = 255+ENV(1)
           status = KXREAD(rec_buff,len*intSize,lnode, type)
           
           len = 1
           do i = lb1, ub1
              if (SHIFT(i) .GT. 0) then
                 do k = 0, SHIFT(i) -1
                    ARRAY(i,lb2+k)=rec_buff(len)
                    len = len + 1
                 end do
              end if
           end do
        end if
CCCC  
CCCCCCCCCCCCCif DIM 1
CCCC  
        
      else if (DIM .EQ. 1) then
         len = 0
         do i = lb2, ub2
C     communicate with negative side
            if (direc(i) .LT. 0) then
               temp = - SHIFT(i)
               do j = 0, SHIFT(i) -1
                  len = len + 1
                  send_buff(len) = ARRAY(lb1+j,i)
               end do
               do k = lb1+SHIFT(i), ub1
                  ARRAY(k-SHIFT(i),i) = ARRAY(k,i)
               end do 
            end if
         end do
         if (len .GT. 0) then
            unode = KXGDNO(ENV(1), 1, 1)
            type = 255+unode
            status = KXWRIT(send_buff, len*intSize, unode, type)
            dnode = KXGDNO(ENV(1), 1, -1)
            type = 255+ENV(1)
            status = KXREAD(rec_buff,len*intSize,dnode, type)
            len = 1
            do i = lb2, ub2
               if (direc(i) .LT. 0) then
                  temp = -SHIFT(i)
                  do k = 1, SHIFT(i)
                     ARRAY(ub1-SHIFT(i)+k,i) 
     &                    = rec_buff(len)
                     len = len + 1
                  end do
               end if
            end do
         end if
         
         len = 0
         do i = lb2, ub2
C     communicate with positive side
            if (direc(i) .GT. 0) then
               do j = 1, SHIFT(i)
                  len = len + 1
                  send_buff(len) = ARRAY(ub1-SHIFT(i)+j,i)
               end do
               do k = ub1-SHIFT(i), lb1, -1
                  ARRAY(k+SHIFT(i),i) = ARRAY(k,i)
               end do 
            end if
         end do
         if (len .GT. 0) then
            dnode = KXGDNO(ENV(1), 1, -1)
            type = 255+dnode
            status = KXWRIT(send_buff, len*intSize, dnode, type)
            unode = KXGDNO(ENV(1), 1, 1)
            type = 255+ENV(1)
            status = KXREAD(rec_buff,len*intSize,unode, type)
            
            len = 1
            do i = lb2, ub2
               if (direc(i) .GT. 0) then
                  do k = 0, SHIFT(i) -1
                     ARRAY(lb1+k,i)=rec_buff(len)
                     len = len + 1
                  end do
               end if
            end do
         end if
      end if

      return
      end




CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC



      subroutine CSHIFT_2_R_S(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &  SHIFT, DIM, RESULT, r1, r2, r3, r4, RESULT_INFO, PROCLIST)

      integer a1, a2, a3, a4, r1, r2, r3, r4
      integer ARRAY_INFO(8,7), RESULT_INFO(8,7), SHIFT
      real ARRAY(a1:a2,a3:a4), RESULT(r1:r2,r3:r4)
      integer DIM, PROCLIST(*)
      
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      
      integer temp(1024), temp_info(8,7)

      do i=1, 1024
         temp(i) = SHIFT
      end do
      
      call CSHIFT_2_R_V(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &     temp, 1, 1024, temp_info, DIM, RESULT, r1, r2, r3, r4, 
     &     RESULT_INFO, PROCLIST)
      
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      subroutine CSHIFT_2_R_V(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &  SHIFT, s1, s2, SHIFT_INFO, DIM, RESULT, r1, r2, r3, r4, 
     &  RESULT_INFO, PROCLIST)
      
      integer a1, a2, a3, a4, r1, r2, r3, r4, s1, s2
      integer ARRAY_INFO(8,7), RESULT_INFO(8,7), SHIFT_INFO(8,7)
      real ARRAY(a1:a2,a3:a4), RESULT(r1:r2,r3:r4)
      integer DIM, PROCLIST(*), SHIFT(s1:s2)
      
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      
      logical more
      integer temp(1024), temp2(1024), asize, shift_size
      integer direc(1024), status, nproc(2)
      integer lb1, lb2, ub1, ub2, size1, size2, i, j
      
      nproc(1) = ARRAY_INFO(8,2)
      nproc(2) = ARRAY_INFO(8,1)
      status = KXGDIN(2,nproc)
        
      lb1 = ARRAY_INFO(1,1)
      lb2 = ARRAY_INFO(1,2)
      ub1 = ARRAY_INFO(2,1)
      ub2 = ARRAY_INFO(2,2)
      
      size1 = ub1 - lb1 + 1
      size2 = ub2 - lb2 + 1
      shift_size = ARRAY_INFO(2,DIM) - ARRAY_INFO(1,DIM) + 1
      
      do i = lb1, ub1
         do j = lb2, ub2
            RESULT(i,j) = ARRAY(i,j)
         end do
      end do
      
      do i=s1, s2
         SHIFT(i) = -SHIFT(i)
      end do

      if (DIM .EQ. 1) then
         asize = size2
      else if (DIM .EQ. 2) then
         asize = size1
      end if

      do i = 1, shift_size
         if (SHIFT(i) .GE. 0) then
            direc(i) = 1
         else
            direc(i) = -1
         end if
         temp2(i) = ABS(SHIFT(i))
      end do
      
      more = .TRUE.
      do while (more)
         do i = 1, shift_size
            if (temp2(i) .GT. asize) then
               temp(i) = asize
               temp2(i) = temp2(i) - asize
            else
               temp(i) = temp2(i)
               temp2(i) = 0
            end if
         end do
         call CSHIFTB_2_R(RESULT, r1, r2, r3, r4, RESULT_INFO,
     &        temp,DIM,direc)
         
         more = .FALSE.
         do i = 1, shift_size
            if (temp2(i) .GT. 0) then
               more = .TRUE.
            end if
         end do
      end do
      
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C    INTERMEDIATE SUBROUTINE USED FOR CSHIFT

	subroutine CSHIFTB_2_R(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &      SHIFT, DIM, direc)

        integer a1, a2, a3, a4, ARRAY_INFO(8,7)
	real ARRAY(a1:a2,a3:a4)
	integer DIM, SHIFT(*), direc(*)

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

	integer shift_size
	integer intSize, realSize
	data realSize, intSize/4, 4/
	integer i, j, lnode, rnode,unode, dnode
	integer lb1, ub1
	integer lb2, ub2
	integer type, status, temp, len
	real rec_buff(1024), send_buff(1024)
	integer ENV(4)

	status = KXPARA(ENV)
	lb1   = ARRAY_INFO(1,1)
	ub1   = ARRAY_INFO(2,1)
	size1 = ub1 - lb1 + 1
	lb2   = ARRAY_INFO(1,2)
	ub2   = ARRAY_INFO(2,2)
	size2 = ub2 - lb2 + 1
	shift_size = ARRAY_INFO(2,DIM) - ARRAY_INFO(1,DIM) + 1

	if (DIM .EQ. 2) then
	len = 0
C communicate with negative side
        do i = lb1, ub1
           if (direc(i) .LT. 0) then
              temp = -SHIFT(i)
              do j = 0, SHIFT(i) -1
                 len = len + 1
                 send_buff(len) = ARRAY(i, lb2+j)
              end do
              do k = lb2+SHIFT(i), ub2
                 ARRAY(i, k-SHIFT(i)) = ARRAY(i, k)
              end do 
           end if
        end do
        if (len .GT. 0) then
           lnode = KXGDNO(ENV(1), 0, -1)
           type = 255+lnode
           status = KXWRIT(send_buff, len*intSize, lnode, type)
           rnode = KXGDNO(ENV(1), 0, 1)
           type = 255+ENV(1)
           status = KXREAD(rec_buff,len*intSize,rnode, type)
           
           len = 1
           do i = lb1, ub1
              if (direc(i) .LT. 0) then
                 temp = -SHIFT(i)
                 do k = 1, SHIFT(i)
                    ARRAY(i, ub2-SHIFT(i)+k) 
     &                   = rec_buff(len)
                    len = len + 1
                 end do
              end if
           end do
        end if
        
	len = 0
        do i = lb1, ub1
C     communicate with positive side
           if (direc(i) .GT. 0) then
              do j = 1, SHIFT(i)
                 len = len + 1
                 send_buff(len) = ARRAY(i, ub2-SHIFT(i)+j)
              end do
              do k = ub2-SHIFT(i), lb2, -1
                 ARRAY(i, k+SHIFT(i)) = ARRAY(i, k)
              end do 
           end if
        end do
        if (len .GT. 0) then
           rnode = KXGDNO(ENV(1), 0, 1)
           type = 255+rnode
           status = KXWRIT(send_buff, len*intSize, rnode, type)
           lnode = KXGDNO(ENV(1), 0, -1)
           type = 255+ENV(1)
           status = KXREAD(rec_buff,len*intSize,lnode, type)
           
           len = 1
           do i = lb1, ub1
              if (SHIFT(i) .GT. 0) then
                 do k = 0, SHIFT(i) -1
                    ARRAY(i,lb2+k)=rec_buff(len)
                    len = len + 1
                 end do
              end if
           end do
        end if
CCCC  
CCCCCCCCCCCCCif DIM 1
CCCC  
        
      else if (DIM .EQ. 1) then
         len = 0
         do i = lb2, ub2
C     communicate with negative side
            if (direc(i) .LT. 0) then
               temp = - SHIFT(i)
               do j = 0, SHIFT(i) -1
                  len = len + 1
                  send_buff(len) = ARRAY(lb1+j,i)
               end do
               do k = lb1+SHIFT(i), ub1
                  ARRAY(k-SHIFT(i),i) = ARRAY(k,i)
               end do 
            end if
         end do
         if (len .GT. 0) then
            unode = KXGDNO(ENV(1), 1, 1)
            type = 255+unode
            status = KXWRIT(send_buff, len*intSize, unode, type)
            dnode = KXGDNO(ENV(1), 1, -1)
            type = 255+ENV(1)
            status = KXREAD(rec_buff,len*intSize,dnode, type)
            len = 1
            do i = lb2, ub2
               if (direc(i) .LT. 0) then
                  temp = -SHIFT(i)
                  do k = 1, SHIFT(i)
                     ARRAY(ub1-SHIFT(i)+k,i) 
     &                    = rec_buff(len)
                     len = len + 1
                  end do
               end if
            end do
         end if
         
         len = 0
         do i = lb2, ub2
C     communicate with positive side
            if (direc(i) .GT. 0) then
               do j = 1, SHIFT(i)
                  len = len + 1
                  send_buff(len) = ARRAY(ub1-SHIFT(i)+j,i)
               end do
               do k = ub1-SHIFT(i), lb1, -1
                  ARRAY(k+SHIFT(i),i) = ARRAY(k,i)
               end do 
            end if
         end do
         if (len .GT. 0) then
            dnode = KXGDNO(ENV(1), 1, -1)
            type = 255+dnode
            status = KXWRIT(send_buff, len*intSize, dnode, type)
            unode = KXGDNO(ENV(1), 1, 1)
            type = 255+ENV(1)
            status = KXREAD(rec_buff,len*intSize,unode, type)
            
            len = 1
            do i = lb2, ub2
               if (direc(i) .GT. 0) then
                  do k = 0, SHIFT(i) -1
                     ARRAY(lb1+k,i)=rec_buff(len)
                     len = len + 1
                  end do
               end if
            end do
         end if
      end if

      return
      end



CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine CSHIFT_2_D_S(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &  SHIFT, DIM, RESULT, r1, r2, r3, r4, RESULT_INFO, PROCLIST)

      integer a1, a2, a3, a4, r1, r2, r3, r4
      integer ARRAY_INFO(8,7), RESULT_INFO(8,7), SHIFT
      double precision ARRAY(a1:a2,a3:a4), RESULT(r1:r2,r3:r4)
      integer DIM, PROCLIST(*)
      
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      
      integer temp(1024), temp_info(8,7)

      do i=1, 1024
         temp(i) = SHIFT
      end do
      
      call CSHIFT_2_D_V(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &     temp, 1, 1024, temp_info, DIM, RESULT, r1, r2, r3, r4, 
     &     RESULT_INFO, PROCLIST)
      
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC


      subroutine CSHIFT_2_D_V(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &  SHIFT, s1, s2, SHIFT_INFO, DIM, RESULT, r1, r2, r3, r4, 
     &  RESULT_INFO, PROCLIST)
      
      integer a1, a2, a3, a4, r1, r2, r3, r4, s1, s2
      integer ARRAY_INFO(8,7), RESULT_INFO(8,7), SHIFT_INFO(8,7)
      double precision ARRAY(a1:a2,a3:a4), RESULT(r1:r2,r3:r4)
      integer DIM, PROCLIST(*), SHIFT(s1:s2)
      
      COMMON /XPRESS/ NOCARE, NORDER, NONODE, IHOST, IALNOD, IALPRC
      
      logical more
      integer temp(1024), temp2(1024), asize, shift_size
      integer direc(1024), status, nproc(2)
      integer lb1, lb2, ub1, ub2, size1, size2, i, j
      
      nproc(1) = ARRAY_INFO(8,2)
      nproc(2) = ARRAY_INFO(8,1)
      status = KXGDIN(2,nproc)
        
      lb1 = ARRAY_INFO(1,1)
      lb2 = ARRAY_INFO(1,2)
      ub1 = ARRAY_INFO(2,1)
      ub2 = ARRAY_INFO(2,2)
      
      size1 = ub1 - lb1 + 1
      size2 = ub2 - lb2 + 1
      shift_size = ARRAY_INFO(2,DIM) - ARRAY_INFO(1,DIM) + 1
      
      do i = lb1, ub1
         do j = lb2, ub2
            RESULT(i,j) = ARRAY(i,j)
         end do
      end do
      
      do i=s1, s2
         SHIFT(i) = -SHIFT(i)
      end do

      if (DIM .EQ. 1) then
         asize = size2
      else if (DIM .EQ. 2) then
         asize = size1
      end if

      do i = 1, shift_size
         if (SHIFT(i) .GE. 0) then
            direc(i) = 1
         else
            direc(i) = -1
         end if
         temp2(i) = ABS(SHIFT(i))
      end do
      
      more = .TRUE.
      do while (more)
         do i = 1, shift_size
            if (temp2(i) .GT. asize) then
               temp(i) = asize
               temp2(i) = temp2(i) - asize
            else
               temp(i) = temp2(i)
               temp2(i) = 0
            end if
         end do
         call CSHIFTB_2_D(RESULT, r1, r2, r3, r4, RESULT_INFO,
     &        temp,DIM,direc)
         
         more = .FALSE.
         do i = 1, shift_size
            if (temp2(i) .GT. 0) then
               more = .TRUE.
            end if
         end do
      end do
      
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C    INTERMEDIATE SUBROUTINE USED FOR CSHIFT

	subroutine CSHIFTB_2_D(ARRAY, a1, a2, a3, a4, ARRAY_INFO, 
     &      SHIFT, DIM, direc)

        integer a1, a2, a3, a4, ARRAY_INFO(8,7)
	double precision ARRAY(a1:a2,a3:a4)
	integer DIM, SHIFT(*), direc(*)

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

	integer shift_size
	integer intSize, doubleSize
	data doubleSize, intSize/8, 4/
	integer i, j, lnode, rnode,unode, dnode
	integer lb1, ub1
	integer lb2, ub2
	integer type, status, temp, len
	double precision rec_buff(1024), send_buff(1024)
	integer ENV(4)

	status = KXPARA(ENV)
	lb1   = ARRAY_INFO(1,1)
	ub1   = ARRAY_INFO(2,1)
	size1 = ub1 - lb1 + 1
	lb2   = ARRAY_INFO(1,2)
	ub2   = ARRAY_INFO(2,2)
	size2 = ub2 - lb2 + 1
	shift_size = ARRAY_INFO(2,DIM) - ARRAY_INFO(1,DIM) + 1

	if (DIM .EQ. 2) then
	len = 0
C communicate with negative side
        do i = lb1, ub1
           if (direc(i) .LT. 0) then
              temp = -SHIFT(i)
              do j = 0, SHIFT(i) -1
                 len = len + 1
                 send_buff(len) = ARRAY(i, lb2+j)
              end do
              do k = lb2+SHIFT(i), ub2
                 ARRAY(i, k-SHIFT(i)) = ARRAY(i, k)
              end do 
           end if
        end do
        if (len .GT. 0) then
           lnode = KXGDNO(ENV(1), 0, -1)
           type = 255+lnode
           status = KXWRIT(send_buff, len*doubleSize, lnode, type)
           rnode = KXGDNO(ENV(1), 0, 1)
           type = 255+ENV(1)
           status = KXREAD(rec_buff,len*doubleSize,rnode, type)
           
           len = 1
           do i = lb1, ub1
              if (direc(i) .LT. 0) then
                 temp = -SHIFT(i)
                 do k = 1, SHIFT(i)
                    ARRAY(i, ub2-SHIFT(i)+k) 
     &                   = rec_buff(len)
                    len = len + 1
                 end do
              end if
           end do
        end if
        
	len = 0
        do i = lb1, ub1
C     communicate with positive side
           if (direc(i) .GT. 0) then
              do j = 1, SHIFT(i)
                 len = len + 1
                 send_buff(len) = ARRAY(i, ub2-SHIFT(i)+j)
              end do
              do k = ub2-SHIFT(i), lb2, -1
                 ARRAY(i, k+SHIFT(i)) = ARRAY(i, k)
              end do 
           end if
        end do
        if (len .GT. 0) then
           rnode = KXGDNO(ENV(1), 0, 1)
           type = 255+rnode
           status = KXWRIT(send_buff, len*doubleSize, rnode, type)
           lnode = KXGDNO(ENV(1), 0, -1)
           type = 255+ENV(1)
           status = KXREAD(rec_buff,len*doubleSize,lnode, type)
           
           len = 1
           do i = lb1, ub1
              if (SHIFT(i) .GT. 0) then
                 do k = 0, SHIFT(i) -1
                    ARRAY(i,lb2+k)=rec_buff(len)
                    len = len + 1
                 end do
              end if
           end do
        end if
CCCC  
CCCCCCCCCCCCCif DIM 1
CCCC  
        
      else if (DIM .EQ. 1) then
         len = 0
         do i = lb2, ub2
C     communicate with negative side
            if (direc(i) .LT. 0) then
               temp = - SHIFT(i)
               do j = 0, SHIFT(i) -1
                  len = len + 1
                  send_buff(len) = ARRAY(lb1+j,i)
               end do
               do k = lb1+SHIFT(i), ub1
                  ARRAY(k-SHIFT(i),i) = ARRAY(k,i)
               end do 
            end if
         end do
         if (len .GT. 0) then
            unode = KXGDNO(ENV(1), 1, 1)
            type = 255+unode
            status = KXWRIT(send_buff, len*doubleSize, unode, type)
            dnode = KXGDNO(ENV(1), 1, -1)
            type = 255+ENV(1)
            status = KXREAD(rec_buff,len*doubleSize,dnode, type)
            len = 1
            do i = lb2, ub2
               if (direc(i) .LT. 0) then
                  temp = -SHIFT(i)
                  do k = 1, SHIFT(i)
                     ARRAY(ub1-SHIFT(i)+k,i) 
     &                    = rec_buff(len)
                     len = len + 1
                  end do
               end if
            end do
         end if
         
         len = 0
         do i = lb2, ub2
C     communicate with positive side
            if (direc(i) .GT. 0) then
               do j = 1, SHIFT(i)
                  len = len + 1
                  send_buff(len) = ARRAY(ub1-SHIFT(i)+j,i)
               end do
               do k = ub1-SHIFT(i), lb1, -1
                  ARRAY(k+SHIFT(i),i) = ARRAY(k,i)
               end do 
            end if
         end do
         if (len .GT. 0) then
            dnode = KXGDNO(ENV(1), 1, -1)
            type = 255+dnode
            status = KXWRIT(send_buff, len*doubleSize, dnode, type)
            unode = KXGDNO(ENV(1), 1, 1)
            type = 255+ENV(1)
            status = KXREAD(rec_buff,len*doubleSize,unode, type)
            
            len = 1
            do i = lb2, ub2
               if (direc(i) .GT. 0) then
                  do k = 0, SHIFT(i) -1
                     ARRAY(lb1+k,i)=rec_buff(len)
                     len = len + 1
                  end do
               end if
            end do
         end if
      end if

      return
      end




