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



      subroutine TRANSPOSE_2_I(A, a1, a2, a3, a4, A_INFO, result, r1, 
     &    r2, r3, r4, result_info, proclist)
      
C     WORKS FOR SQUARE GLOBAL MATRIX WHEN NO. OF PROCESSORS ALONG
C     ROWS IS A MULTIPLE OF NO. OF PROCESSORS ALONG COLUMNS
C     GRID     -----> X
C              |
C              |
C             Y|

      integer a1, a2, a3, a4, r1, r2, r3, r4
      integer A(a1:a2, a3:a4), result(r1:r2, r3:r4)
      integer A_INFO(8,7), result_info(8,7)

      integer i, j, status, min_row, max_row, min_col, max_col
      integer intsize, type
      data intsize, type /4, 57/
      integer env(4), coord(2), nproc(2), mynode, dest_coord(2)
      integer dest_node
      integer A_trans_virtual(512*512)

      integer fac_h, fac_v, virtual_m, virtual_n, m_trans, n_trans
      integer m_trans_virtual, n_trans_virtual, coeff, k, l, q
      integer virtual_coord(2), virtual_dest_coord(2)
      integer coeff1, coeff2, rows, cols

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

      status = KXPARA(env)
      mynode = env(1)

      nproc(1) = A_INFO(8,2)
      nproc(2) = A_INFO(8,1)

      status = KXGDIN(2, nproc)

      if ((MOD(nproc(1), nproc(2)) .NE. 0) .AND.
     &     (MOD(nproc(2), nproc(1)) .NE. 0)) then
         print *, 'This processor config. is NOT supported !'
         STOP
      end if

      status = KXGDCO(mynode, coord)

      if (nproc(2) .GE. nproc(1)) then
         fac_h = nproc(2)/nproc(1)
         fac_v = 1
         rows = a2 - a1 + 1
         cols = a4 - a3 + 1
         virtual_m = rows/fac_v
         virtual_n = cols/fac_h
         m_trans = virtual_n * fac_v
         n_trans = virtual_m * fac_h
         m_trans_virtual = virtual_n
         n_trans_virtual = virtual_m
         
         virtual_coord(2) = coord(2)
         virtual_dest_coord(1) = virtual_coord(2)
         
         k = 1
         do coeff = 0, (fac_h-1)
            coeff1 = virtual_n * coeff
            do i = 1, virtual_n
               coeff2 = coeff1 + i
               do j = 1, virtual_m
                  A_trans_virtual(k) = A(j, coeff2)
                  k = k+1
               end do
            end do
            
            virtual_coord(1) = coeff + (coord(1) * fac_h)
            
            virtual_dest_coord(2) = virtual_coord(1)
            
            dest_coord(1) = virtual_dest_coord(1)/fac_h
            dest_coord(2) = virtual_dest_coord(2)
            dest_node = KXGDPR(dest_coord)
            status = KXWRIT(A_trans_virtual, 
     &           intsize * m_trans_virtual * n_trans_virtual, 
     &           dest_node, virtual_dest_coord(1))
         end do
         
         do coeff = 0, (fac_h-1)
            coeff1 = n_trans_virtual * coeff
            coeff2 = coeff1 + n_trans_virtual
            virtual_coord(1) = coeff + (coord(1) * fac_h)
            virtual_dest_coord(2) = virtual_coord(1)
            
            dest_coord(2) = virtual_dest_coord(2)
            dest_coord(1) = virtual_dest_coord(1)/fac_h
            dest_node = KXGDPR(dest_coord)
            status = KXREAD(A_trans_virtual, 
     &           intsize * m_trans_virtual * n_trans_virtual, 
     &           dest_node, virtual_dest_coord(2))
            
            k = 1
            do i = 1, m_trans
               do j = coeff1 + 1, coeff2
                  result(i,j) = A_trans_virtual(k)
                  k = k+1
               end do
            end do
         end do

      else
         fac_h = 1
         fac_v = nproc(1)/nproc(2)
         rows = a2 - a1 + 1
         cols = a4 - a3 + 1
         virtual_m = rows/fac_v
         virtual_n = cols/fac_h
         m_trans = virtual_n * fac_v
         n_trans = virtual_m * fac_h
         m_trans_virtual = virtual_n
         n_trans_virtual = virtual_m
         
         virtual_coord(1) = coord(1)
         virtual_dest_coord(2) = virtual_coord(1)
         
         k = 1
         do coeff = 0, (fac_v-1)
            coeff1 = virtual_m * coeff
            do i = 1, virtual_m
               coeff2 = coeff1 + i
               do j = 1, virtual_n
                  A_trans_virtual(k) = A(coeff2, j)
                  k = k+1
               end do
            end do
            
            
            virtual_coord(2) = coeff + (coord(2) * fac_v)
            
            virtual_dest_coord(1) = virtual_coord(2)
            
            dest_coord(1) = virtual_dest_coord(1)
            dest_coord(2) = virtual_dest_coord(2)/fac_v
            dest_node = KXGDPR(dest_coord)
            status = KXWRIT(A_trans_virtual, 
     &           intsize * m_trans_virtual * n_trans_virtual, 
     &           dest_node, virtual_dest_coord(2))
         end do
         
         do coeff = 0, (fac_v-1)
            coeff1 = m_trans_virtual * coeff
            coeff2 = coeff1 + m_trans_virtual
            virtual_coord(2) = coeff + (coord(2) * fac_v)
            virtual_dest_coord(1) = virtual_coord(2)
            
            dest_coord(1) = virtual_dest_coord(1)
            dest_coord(2) = virtual_dest_coord(2)/fac_v
            dest_node = KXGDPR(dest_coord)
            status = KXREAD(A_trans_virtual, 
     &           intsize * m_trans_virtual * n_trans_virtual, 
     &           dest_node, virtual_dest_coord(1))
            
            k = 1
            do j = 1, n_trans
               do i = coeff1 + 1, coeff2
                  result(i, j) = A_trans_virtual(k)
                  k = k+1
               end do
            end do
         end do
      end if
         
      return
      end







CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC



      subroutine TRANSPOSE_2_R(A, a1, a2, a3, a4, A_INFO, result, r1, 
     &    r2, r3, r4, result_info, proclist)
      
C     WORKS FOR SQUARE GLOBAL MATRIX WHEN NO. OF PROCESSORS ALONG
C     ROWS IS A MULTIPLE OF NO. OF PROCESSORS ALONG COLUMNS
C     GRID     -----> X
C              |
C              |
C             Y|

      integer a1, a2, a3, a4, r1, r2, r3, r4
      real A(a1:a2, a3:a4), result(r1:r2, r3:r4)
      integer A_INFO(8,7), result_info(8,7), proclist(*)

      integer i, j, status
      integer realsize, type
      data realsize, type /4, 57/
      integer env(4), coord(2), nproc(2), mynode, dest_coord(2)
      integer dest_node
      real A_trans_virtual(512*512)

      integer fac_h, fac_v, virtual_m, virtual_n, m_trans, n_trans
      integer m_trans_virtual, n_trans_virtual, coeff, k
      integer virtual_coord(2), virtual_dest_coord(2)
      integer coeff1, coeff2, rows, cols


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

      status = KXPARA(env)
      mynode = env(1)

      nproc(1) = A_INFO(8,2)
      nproc(2) = A_INFO(8,1)

      status = KXGDIN(2, nproc)

      if ((MOD(nproc(1), nproc(2)) .NE. 0) .AND.
     &     (MOD(nproc(2), nproc(1)) .NE. 0)) then
         print *, 'This processor config. is NOT supported !'
         STOP
      end if

      status = KXGDCO(mynode, coord)

      if (nproc(2) .GE. nproc(1)) then
         fac_h = nproc(2)/nproc(1)
         fac_v = 1
         rows = a2 - a1 + 1
         cols = a4 - a3 + 1
         virtual_m = rows/fac_v
         virtual_n = cols/fac_h
         m_trans = virtual_n * fac_v
         n_trans = virtual_m * fac_h
         m_trans_virtual = virtual_n
         n_trans_virtual = virtual_m
         
         virtual_coord(2) = coord(2)
         virtual_dest_coord(1) = virtual_coord(2)
         
         k = 1
         do coeff = 0, (fac_h-1)
            coeff1 = virtual_n * coeff
            do i = 1, virtual_n
               coeff2 = coeff1 + i
               do j = 1, virtual_m
                  A_trans_virtual(k) = A(j, coeff2)
                  k = k+1
               end do
            end do
            
            virtual_coord(1) = coeff + (coord(1) * fac_h)
            
            virtual_dest_coord(2) = virtual_coord(1)
            
            dest_coord(1) = virtual_dest_coord(1)/fac_h
            dest_coord(2) = virtual_dest_coord(2)
            dest_node = KXGDPR(dest_coord)
            status = KXWRIT(A_trans_virtual, 
     &           realsize * m_trans_virtual * n_trans_virtual, 
     &           dest_node, virtual_dest_coord(1))
         end do
         
         do coeff = 0, (fac_h-1)
            coeff1 = n_trans_virtual * coeff
            coeff2 = coeff1 + n_trans_virtual
            virtual_coord(1) = coeff + (coord(1) * fac_h)
            virtual_dest_coord(2) = virtual_coord(1)
            
            dest_coord(2) = virtual_dest_coord(2)
            dest_coord(1) = virtual_dest_coord(1)/fac_h
            dest_node = KXGDPR(dest_coord)
            status = KXREAD(A_trans_virtual, 
     &           realsize * m_trans_virtual * n_trans_virtual, 
     &           dest_node, virtual_dest_coord(2))
            
            k = 1
            do i = 1, m_trans
               do j = coeff1 + 1, coeff2
                  result(i,j) = A_trans_virtual(k)
                  k = k+1
               end do
            end do
         end do

      else
         fac_h = 1
         fac_v = nproc(1)/nproc(2)
         rows = a2 - a1 + 1
         cols = a4 - a3 + 1
         virtual_m = rows/fac_v
         virtual_n = cols/fac_h
         m_trans = virtual_n * fac_v
         n_trans = virtual_m * fac_h
         m_trans_virtual = virtual_n
         n_trans_virtual = virtual_m
         
         virtual_coord(1) = coord(1)
         virtual_dest_coord(2) = virtual_coord(1)
         
         k = 1
         do coeff = 0, (fac_v-1)
            coeff1 = virtual_m * coeff
            do i = 1, virtual_m
               coeff2 = coeff1 + i
               do j = 1, virtual_n
                  A_trans_virtual(k) = A(coeff2, j)
                  k = k+1
               end do
            end do
            
            
            virtual_coord(2) = coeff + (coord(2) * fac_v)
            
            virtual_dest_coord(1) = virtual_coord(2)
            
            dest_coord(1) = virtual_dest_coord(1)
            dest_coord(2) = virtual_dest_coord(2)/fac_v
            dest_node = KXGDPR(dest_coord)
            status = KXWRIT(A_trans_virtual, 
     &           realsize * m_trans_virtual * n_trans_virtual, 
     &           dest_node, virtual_dest_coord(2))
         end do
         
         do coeff = 0, (fac_v-1)
            coeff1 = m_trans_virtual * coeff
            coeff2 = coeff1 + m_trans_virtual
            virtual_coord(2) = coeff + (coord(2) * fac_v)
            virtual_dest_coord(1) = virtual_coord(2)
            
            dest_coord(1) = virtual_dest_coord(1)
            dest_coord(2) = virtual_dest_coord(2)/fac_v
            dest_node = KXGDPR(dest_coord)
            status = KXREAD(A_trans_virtual, 
     &           realsize * m_trans_virtual * n_trans_virtual, 
     &           dest_node, virtual_dest_coord(1))
            
            k = 1
            do j = 1, n_trans
               do i = coeff1 + 1, coeff2
                  result(i, j) = A_trans_virtual(k)
                  k = k+1
               end do
            end do
         end do
      end if
         
      return
      end





