      program revised_node
      implicit none

      include '/usr/include/fcube.h'
      include 'revcube.h'
      include 'revnode.h'
   
c---------------------------------------------------------------------------
c   
c  This code perfomes the revised simplex method to solve
c  linear programming problems on hypercube iPSC/2
c 
c  This is a node program
c
c version date: 4/16/1991
c
c-------------------------------------------------------------------------
c
c  local variables
c
      integer i, j, k

      thisNode = mynode()
      hostNode = myhost()
      numNode = numnodes()
      numDim = nodeDim()
      iteration = 0

      call initial

c
c  code for node 0
c
      if (thisNode .eq. 0) then
        if (numGE .eq. 0) then
          print *, ' There is no phase I'
         else
          print *, ' Starting phase I....'
        end if
        timeBegin = mclock()
      end if
c
c  code for the last node
c
      if (kLastRow) then
        print *, 'w = ', x(numEqu-minRow+2)
      end if
c
c  code for all node
c
      if ( numGE .ne. 0 ) then
        call simplex(1)
      end if
c
c  code for the last node
c
      if (kLastRow) then
        print *, 'w = ', x(numEqu-minRow+2)
      end if
c
c  code for node 0
c
      if ((numGE .ne. 0) .and. (thisNode .eq. 0)) then
        if ( .not. bounded) then
          print *, ' It is not bounded'
        end if
        if (cont) then
          print *, ' Phase I was not successful, please killcube'
         else
          print *, ' Phase I was successful'
          print *, ' Starting phase II'
        end if
      end if
c
c  redistribution coefficient matrx a in phase II
c
      if (numGE .ne. 0) then
        if (numNode .gt. 1) then
c
c  code for node 0
c
          if (thisNode .eq. 0) then
            call csend(gtype+20,info,intSize,hostNode,npid)
          end if
          minCol = allColRow(5, thisNode+1)
          maxCol = allColRow(6, thisNode+1)
          numCol = maxCol - minCol + 1
          k = minCol
          do j = 1, numCol
            row1_node(j) = row1(k)
            nonbasic_node(j) = nonbasic(k)
            k = k + 1
          end do
          do i = 1, numEqu-1
            call crecv(gtype+21,realBuf,numCol*doubleSize)
            do j = 1, numCol
              a(i, j) = realBuf(j)
            end do
          end do 
         else
          if ( maxCol .eq. numVarI) then
            maxCol = numVarII
            numCol = maxCol - minCol + 1
          end if
        end if
      end if
c
c code for all node
c
      call simplex(2)
c
c  code for node 0
c
      if (thisNode .eq. 0) then
        timeEnd = mclock()
        if (bounded) then
          print *, ' Phase II was successful'
         else
          print *, ' Phase II was not successful, plsase killcube'
          print *, ' Variable', pivotCol, ' is not bounded'
        end if
        print *, ' Elapsed time: ', timeEnd-timeBegin
      end if
c
c  code for the the last node
c
      if (kLastRow) then
        print *, ' At node, Min =', x(numEqu-minRow+1)
        call csend(gtype,x(numEqu-minRow+1),doubleSize,hostNode,NPID)
        print *, ' It takes ', iteration, ' iterations'
      end if
c
c  code for node 0
c
      if (thisNode .eq. 0) then
        call csend(gtype, x(1), doubleSize, hostNode,npid)
      end if

      stop
      end

c-----------------------------------------------------------------

      subroutine initial
      implicit none

      include 'revcube.h'
      include 'revnode.h'
c
c  local variables
c
      integer i, j, k

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c  receiving info numVar, numEqu, numCon, numG, numE, numL
c
      call crecv(gtype, info, 6*intSize)

      numVar = info(1)
      numEqu = info(2)
      numCon = info(3)
      numG = info(4)
      numE = info(5)
      numL = info(6)
      numGL = numG + numL
      numGE = numG + numE
      numVarI = numVar + numGE + numGL
      numVarII = numVar + numGL
c
c  receiving allColRow 
c
      call crecv(gtype-1,allColRow,6*numNode*intSize)

      minCol = allColRow(1, thisNode+1)
      maxCol = allColRow(2, thisNode+1)
      numCol = maxCol - minCol + 1
      minRow = allColRow(3, thisNode+1)
      maxRow = allColRow(4, thisNode+1)
      numRow = maxRow - minRow + 1
      kLastRow = (numEqu-1) .le. maxRow
c
c  receiving the right hand side x
c
      call crecv(gtype-2, realBuf, (numEqu+1)*doubleSize)
 
      k = minRow
      do i = 1, numRow+2
        x(i) = realBuf(k)
        k = k + 1
      end do
c
c  receiving the last two rows of the coefficient matrix
c
      call crecv(gtype-3,row1,(numVar+numGL+numGE)*doubleSize)
      k = minCol 
      do i = 1, numCol
        row1_node(i) = row1(k)
        k = k + 1
      end do
      call crecv(gtype-4,realBuf,(numVar+numGL+numGE)*doubleSize)
      k = minCol 
      do i = 1, numCol
        row2_node(i) = realBuf(k)
        k = k + 1
      end do
c
c  receiving coefficient matrix A at node
c
      do i = 1, numEqu-1
        call crecv(gtype+1,realBuf,numCol*doubleSize)
        do j = 1, numCol
          a(i, j) = realBuf(j)
        end do
      end do
c
c  code for all node
c
      do j = 1, numVarI
         nonbasic_node(j) = .true.
         nonbasic(j) = .true.
      end do
      do i = numVar+numG+1, numVarII
         basic(i-numVar+numE) = i
         nonbasic(i) = .false.
         if ((i .ge. minCol) .and. (i .le. maxCol)) then
           nonbasic_node(i-minCol+1) = .false.
         end if
      end do 
      do i = numVarII+1, numVarI
        basic(i-numVarII) = i
        nonbasic(i) = .false.
         if ((i .ge. minCol) .and. (i .le. maxCol)) then
           nonbasic_node(i-minCol+1) = .false.
         end if
      end do

      do j = 1, numCon
         do i = 1, numRow
            b(i, j) = 0.0
         end do 
         lastB1(j) = 0.0
         lastB2(j) = 0.0
      end do
      k =  minRow
      do i = 1, numRow
        b(i, k) = 1.0
        k = k +1
      end do
      do j = 1, numGE
         lastB2(j) = 1.0
      end do

      return
      end

c-----------------------------------------------------------------

      subroutine simplex(phase)
      implicit none

      include 'revcube.h'
      include 'revnode.h'
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call next(phase)
      do while (cont .and. bounded)
         call trans(phase)
         call next(phase)
      end do

      return
      end

c------------------------------------------------------------------
      subroutine next(phase)
      implicit none
 
      include 'revcube.h'
      include 'revnode.h'
c
c  local variables
c
      double precision large, small
      parameter (large = 1.0d+7)
      parameter (small = 1.0d-7)

      double precision val, sum
      integer i, j, k
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c
c  code for all nodes
c
      pivotCol = -1
      maxval = -large
      do j = 1, numCol
         if (nonbasic_node(j)) then
            sum = 0.0
            if (phase .eq. 1) then
               do i = 1, numCon 
                  sum = sum + lastB2(i)*a(i, j)
               end do
               c(j) = row2_node(j) + sum
             else
               do i = 1, numCon 
                  sum = sum + lastB1(i)*a(i, j)
               end do
               c(j) = row1_node(j) + sum
            end if
            if (c(j) .gt. maxval) then
               maxval = c(j)
               pivotCol = j
            end if
         end if 
      end do
c
c  reduct on maxval over all nodes to get one pivotCol and maxval
c
      realBuf(1) = maxval
      realBuf(2) = minCol + pivotCol -1
      call GOPF(realBuf, 2*doubleSize, work2, MaxReduct)
      maxval = realBuf(1)
      pivotCol = realBuf(2)

      cont = (maxval .gt. small)
c
c  pivot column is in this node
c
      kIndxCol = (pivotCol .le. maxCol) .and. (pivotCol .ge. minCol)

      if (cont) then
        if (kIndxCol) then
c
c  leaving column of matrix A is in this node, this column needs
c  to send to all nodes (broadcast)
c
          k = pivotCol - minCol + 1
          do i = 1, numCon
            realBuf(i) = a(i, k)
          end do
          if (numNode .gt. 1) then
          call csend(stype+3*iteration+1,realBuf,
     *                  numCon*doubleSize,allNode,npid)
          end if
         else if (pivotCol .ne. -1) then
          call crecv(stype+3*iteration+1, realBuf, numCon*doubleSize)
        end if 
c
c  in phase I
c
        if (phase .eq. 1) then
          sum = 0.0
          do i = 1, numCon
            sum = sum + lastB1(i)*realBuf(i)
          end do
          correct = row1(pivotCol) + sum
        end if
c
c  compute the column d and check if it is bounded
c
        bounded = .false.
        do i = 1, numRow
          sum = 0.0
          do j = 1, numCon 
            sum = sum + b(i, j)*realBuf(j)
          end do
          d(i) = sum
          if ((.not. bounded) .and. (sum .gt. small)) then
            bounded = .true.
          end if
        end do

        call GLOR(bounded, 1, worklogical)
c
c  find the pivot row
c
        pivotRow = -1
        minval = large
        if (bounded) then
          do i = 1, numRow
            if (d(i) .gt. small) then
              val = x(i)/d(i)
              if ((pivotRow .eq. -1) .or. (val .lt. minval)) then
                minval = val
                pivotRow = i
              end if
            end if
          end do
          pivot = d(pivotRow)
c
c  reduct on min to get a pivotRow and minval
c
          realBuf(1) = minval
          realBuf(2) = pivotRow + minRow - 1
          call GOPF(realBuf, 2*doubleSize, work2, MinReduct)
          minval = realBuf(1)
          pivotRow = realBuf(2)
c
c   pivot row is in this node
c
          kIndxRow= (pivotRow .ge. minRow) .and. (pivotRow .le. maxRow)
c
c   code for a special node
c
          if ((basic(pivotRow) .ge. minCol) .and.
     *        (basic(pivotRow) .le. maxCol)) then
            nonbasic_node(basic(pivotRow)-minCol+1) = .true.
          end if
          nonbasic(basic(pivotRow)) = .true.
c
c  code for all node
c
          basic(pivotRow) = pivotCol
c
c  code for a special node (pivot Column)
c
          if (kIndxCol) then
            nonbasic_node(pivotCol-minCol+1) = .false.
          end if
          nonbasic(pivotCol) = .false.
        end if       
      end if

      return
      end

c-------------------------------------------------------------------

      subroutine trans(phase)
      implicit none

      include 'revcube.h'
      include 'revnode.h'
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c  local variables
c
      integer i, j
c
c  code for all nodes
c
c  /*   x = x - d*minval   */
c
      do i = 1, numRow
         x(i) = x(i) - d(i)*minval
      end do
c
c  code for the last node
c
      if (kLastRow) then
         if (phase .eq. 1) then
            x(numEqu-minRow+1) = x(numEqu-minRow+1)
     *                               - correct*minval
            x(numEqu-minRow+2) = x(numEqu-minRow+2)
     *                               - maxval*minval
           else
            x(numequ-minRow+1) = x(numEqu-minRow+1)
     *                               - maxval*minval
         end if
      end if
c
c  code for a special nodes  (pivot row)
c  extract a row from matrix b  -- b(pivotRow, :)
c  and send to all nodes
c
      if (kIndxRow) then
        x(pivotRow-minRow+1) = minval
        do j = 1, numCon 
          realBuf(j) = b(pivotRow-minRow+1, j)/pivot
        end do
        if (numNode .gt. 1) then
          call csend(stype+3*iteration+2,realBuf,
     *                     numCon*doubleSize,allnode,npid)
         end if 
       else
        call crecv(stype+3*iteration+2,realBuf,numCon*doubleSize)
      end if
c
c  code for all nodes
c
      do i = 1, numRow
         do j = 1, numCon 
            b(i, j) = b(i, j) - d(i)*realBuf(j)
         end do
      end do
c
c code for a special node
c
      if (kIndxRow) then
         do j = 1, numCon
           b(pivotRow-minRow+1, j) = realBuf(j)
         end do
      end if
c
c  code for all nodes
c
      if (phase .eq. 1) then
         do j = 1, numCon
            lastB1(j) = lastB1(j) - correct*realBuf(j)
            lastB2(j) = lastB2(j) - maxval*realBuf(j)
         end do
        else
         do j = 1, numCon
            lastB1(j) = lastB1(j) - maxval*realBuf(j)
         end do
      end if

      iteration = iteration + 1

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C			MaxReduct				C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
        subroutine MaxReduct(mine, work)
        implicit none

        double precision mine(2), work(2)

        if ((mine(2) .LT. 0.0) .or. ((work(2) .gt. 0.0) .and. 
     &	     ((mine(1) .LT. work(1)) .or. ((mine(1) .eq. work(1))
     &      .and. (mine(2) .GT. work(2)))))) then
          mine(1) = work(1)
          mine(2) = work(2)
        end if
        return
        end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C			MinReduct				C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
        subroutine MinReduct(mine, work)
        implicit none

        double precision mine(2), work(2)

        if ((mine(2) .LT. 0.0) .or. ((work(2) .gt. 0.0) .and. 
     &	    ((mine(1) .GT. work(1)) .OR. ((mine(1) .eq. work(1))
     &      .AND. (mine(2) .GT. work(2)))))) then
          mine(1) = work(1)
          mine(2) = work(2)
        end if
        return
        end

