*
* $Id: Parallel-tcgmsg.F 26429 2014-12-03 21:31:11Z bylaska $
*

* Parallel.f
* Author - Eric Bylaska
*
*   These routines are to be used to keep track of the parallel message
* passing variables, as well as iniitialize and deinitialize the
* message passing routines.
*


*     *************************************
*     *                                   *
*     *        Parallel_Init              *
*     *                                   *
*     *************************************

      subroutine Parallel_Init()
      implicit none

#include "Parallel.fh"
#include "bafdecls.fh"
#include "errquit.fh"

#include "tcgmsg.fh"
#include "global.fh"

c      include 'mpif.h'
c      integer mpierr

*     **** local variables ****
      integer i

      np     = nnodes()
      taskid = nodeid()


*     **** set up 3d processor grid = np x 1 x 1****
      if (.not.BA_alloc_get(mt_int,np,'procNd',procNd(2),procNd(1)))
     >  call errquit('Parallel_init:out of heap memory',0, MA_ERR)

      np_i = np
      np_j = 1
      np_k = 1
      do i=0,np-1
        int_mb(procNd(1)+i) = i
      end do
      taskid_i = taskid
      taskid_j = 0
      taskid_k = 0
      comm_i   = ga_pgroup_get_world()
      comm_j   = -99 
      comm_k   = -99 

      return 
      end


*     *************************************
*     *                                   *
*     *        Parallel2d_Init            *
*     *                                   *
*     *************************************

*     Sset up the 2d processor grid = np_i x np_j, 
*     where np_i = ncolumns, and np_j = np/np_i
*
      subroutine Parallel2d_Init(ncolumns)
      implicit none
      integer ncolumns

#include "Parallel.fh"
#include "bafdecls.fh"
#include "errquit.fh"
#include "global.fh"

*     *** local variables ***
      integer i,j,icount
      integer tmp(2)

      np_i = np/ncolumns
      np_j = ncolumns

      if (np_j.gt.1) then

      icount = 0
      do j=0,np_j-1
      do i=0,np_i-1
        if (icount.eq.taskid) then
           taskid_i = i
           taskid_j = j
        end if
        int_mb(procNd(1) + i + j*np_i) = icount
        icount = mod((icount+1),np)
      end do
      end do

      if (.not.BA_push_get(mt_int,np,'tmppp2',tmp(2),tmp(1)))
     >  call errquit('Parallel2d_init:out of stack memory',0, MA_ERR)
        do i=0,np_i-1
          int_mb(tmp(1)+i) = int_mb(procNd(1) + i + taskid_j*np_i) 
        end do
        comm_i = ga_pgroup_create(int_mb(tmp(1)),np_i)
        do j=0,np_j-1
          int_mb(tmp(1)+j) = int_mb(procNd(1) + taskid_i + j*np_i) 
        end do
        comm_j = ga_pgroup_create(int_mb(tmp(1)),np_j)
      if (.not.BA_pop_stack(tmp(2)))
     >  call errquit('Parallel2d_init:popping stack memory',0, MA_ERR)

      end if

      return
      end


*     *************************************
*     *                                   *
*     *        Parallel2d_Finalize        *
*     *                                   *
*     *************************************

      subroutine Parallel2d_Finalize()
      implicit none

#include "Parallel.fh"
#include "bafdecls.fh"
#include "errquit.fh"
#include "global.fh"

       if (np_j.gt.1) then

*      **** free comm_i and comm_j communicators ****
       if (.not.ga_pgroup_destroy(comm_i))
     >  call errquit('Parallel2d_Finalize: error destoying comm_i',0,0)
       if (.not.ga_pgroup_destroy(comm_j))
     >  call errquit('Parallel2d_Finalize: error destoying comm_j',0,1)

      end if
      return
      end


*     *************************************
*     *                                   *
*     *        Parallel3d_Init            *
*     *                                   *
*     *************************************

*     Sset up the 3d processor grid = np_i x np_j x np_k, 
*     where np_i = np/(np_j*np_k), and np_j = ncolumns and np_k=nzones
*
      subroutine Parallel3d_Init(ncolumns,nzones)
      implicit none
      integer ncolumns,nzones

#include "Parallel.fh"
#include "bafdecls.fh"
#include "errquit.fh"
#include "global.fh"

*     *** local variables ***
      integer i,j,k,icount
      integer tmp(2)

      np_i = np/(ncolumns*nzones)
      np_j = ncolumns
      np_k = nzones

      if ((np_j.gt.1).or.(np_k.gt.1)) then

      icount = 0
      do k=0,np_k-1
      do j=0,np_j-1
      do i=0,np_i-1
        if (icount.eq.taskid) then
           taskid_i = i
           taskid_j = j
           taskid_k = k
        end if
        int_mb(procNd(1) + i + j*np_i + k*np_i*np_j) = icount
        icount = mod((icount+1),np)
      end do
      end do
      end do

      if (.not.BA_push_get(mt_int,np,'tmppp2',tmp(2),tmp(1)))
     >  call errquit('Parallel3d_init:out of stack memory',0, MA_ERR)
        do i=0,np_i-1
          int_mb(tmp(1)+i) = int_mb(procNd(1) 
     >                             + i 
     >                             + taskid_j*np_i
     >                             + taskid_k*np_i*np_j) 
        end do
        comm_i = ga_pgroup_create(int_mb(tmp(1)),np_i)
        do j=0,np_j-1
          int_mb(tmp(1)+j) = int_mb(procNd(1)
     >                              + taskid_i 
     >                              + j*np_i
     >                              + taskid_k*np_i*np_j) 
        end do
        comm_j = ga_pgroup_create(int_mb(tmp(1)),np_j)
        do k=0,np_k-1
          int_mb(tmp(1)+k) = int_mb(procNd(1)
     >                              + taskid_i 
     >                              + taskid_j*np_i
     >                              + k*np_i*np_j) 
        end do
        comm_k = ga_pgroup_create(int_mb(tmp(1)),np_k)
      if (.not.BA_pop_stack(tmp(2)))
     >  call errquit('Parallel3d_init:popping stack memory',0, MA_ERR)

      end if

      return
      end


*     *************************************
*     *                                   *
*     *        Parallel3d_Finalize        *
*     *                                   *
*     *************************************

      subroutine Parallel3d_Finalize()
      implicit none

#include "Parallel.fh"
#include "bafdecls.fh"
#include "errquit.fh"
#include "global.fh"

      if ((np_j.gt.1).or.(np_k.gt.1)) then

*      **** free comm_i and comm_j communicators ****
       if (.not.ga_pgroup_destroy(comm_i))
     >  call errquit('Parallel3d_Finalize: error destoying comm_i',0,0)
       if (.not.ga_pgroup_destroy(comm_j))
     >  call errquit('Parallel3d_Finalize: error destoying comm_j',0,1)
       if (.not.ga_pgroup_destroy(comm_k))
     >  call errquit('Parallel3d_Finalize: error destoying comm_k',0,2)

      end if
      return
      end



*     ***********************************
*     *                                 *
*     *         Parallel_MaxAll         *
*     *                                 *
*     ***********************************

      subroutine Parallel_MaxAll(sum)
c     implicit none
      real*8  sum

#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

      if (np.gt.1) then
         call GA_DGOP(9+MSGDBL,sum,1,'max')
      end if

      return
      end





*     ***********************************
*     *                                 *
*     *         Parallel_IMaxAll        *
*     *                                 *
*     ***********************************
      subroutine Parallel_IMaxAll(isum)
c     implicit none
      integer isum

#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

      if (np.gt.1) then
         call GA_IGOP(9+MSGINT,isum,1,'max')
      end if
      return
      end




*     ***********************************
*     *                                 *
*     *         Parallel_SumAll         *
*     *                                 *
*     ***********************************

      subroutine Parallel_SumAll(sum)
c     implicit none
      real*8  sum

#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

      if (np.gt.1) then
         call GA_DGOP(9+MSGDBL,sum,1,'+')
      end if

      return
      end



*     ***********************************
*     *                                 *
*     *         Parallel_ISumAll        *
*     *                                 *
*     ***********************************

      subroutine Parallel_ISumAll(sum)
c     implicit none
      integer  sum

#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

      if (np.gt.1) then
         call GA_IGOP(9+MSGINT,sum,1,'+')
      end if
      
      return
      end


*     ***********************************
*     *                                 *
*     *      Parallel_Vector_SumAll     *
*     *                                 *
*     ***********************************
      subroutine Parallel_Vector_SumAll(n,sum)
c     implicit none
      integer n
      real*8  sum(*)

#include "bafdecls.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "errquit.fh"
#include "Parallel.fh"


      call nwpw_timing_start(2)
      if (np.gt.1) then
         call GA_DGOP(9+MSGDBL,sum,n,'+')
      end if
      call nwpw_timing_end(2)
      return
      end



*     ***********************************
*     *                                 *
*     *     Parallel_Vector_ISumAll     *
*     *                                 *
*     ***********************************

      subroutine Parallel_Vector_ISumAll(n,sum)
c     implicit none
      integer n
      integer  sum(*)

#include "bafdecls.fh"
#include "errquit.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"


      call nwpw_timing_start(2)
      if (np.gt.1) then
         call GA_IGOP(9+MSGINT,sum,n,'+')
      end if
      call nwpw_timing_end(2)

      return
      end



*     ***********************************
*     *                                 *
*     *      Parallel_Brdcst_value      *
*     *                                 *
*     ***********************************

      subroutine Parallel_Brdcst_value(psend,sum)
      implicit none
      integer psend
      real*8  sum

#include "bafdecls.fh"
#include "errquit.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

*     **** local variables ****
      integer msglen

      if (np.gt.1) then
         msglen = 1
         call BRDCST(9+MSGDBL,sum,mdtob(msglen),psend)
      end if

      return
      end


*     ***********************************
*     *                                 *
*     *      Parallel_Brdcst_values     *
*     *                                 *
*     ***********************************

      subroutine Parallel_Brdcst_values(psend,nsize,sum)
      implicit none
      integer psend,nsize
      real*8  sum(*)

#include "bafdecls.fh"
#include "errquit.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"


      if (np.gt.1) then
         call BRDCST(9+MSGDBL,sum,mdtob(nsize),psend)
      end if

      return
      end

*     ***********************************
*     *                                 *
*     *      Parallel_Brdcst_ivalue     *
*     *                                 *
*     ***********************************

      subroutine Parallel_Brdcst_ivalue(psend,isum)
      implicit none
      integer psend
      integer isum

#include "bafdecls.fh"
#include "errquit.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

*     **** local variables ****
      integer msglen

      if (np.gt.1) then
         msglen = 1
         call BRDCST(9+MSGINT,isum,mitob(msglen),psend)
      end if

      return
      end



*     ***********************************
*     *                                 *
*     *      Parallel_Brdcst_ivalues     *
*     *                                 *
*     ***********************************

      subroutine Parallel_Brdcst_ivalues(psend,nsize,isum)
      implicit none
      integer psend,nsize
      integer  isum(*)

#include "bafdecls.fh"
#include "errquit.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

      if (np.gt.1) then
         call BRDCST(9+MSGINT,isum,mitob(nsize),psend)
      end if
      return
      end




*     ***********************************
*     *                                 *
*     *         Parallela_MaxAll        *
*     *                                 *
*     ***********************************

      subroutine Parallela_MaxAll(ic,sum)
c     implicit none
      integer ic
      real*8  sum

#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

      if (np.gt.1) then
         if (ic.eq.1) then
            call GA_PGROUP_DGOP(comm_i,9+MSGDBL,sum,1,'max')
         else if (ic.eq.2) then
            call GA_PGROUP_DGOP(comm_j,9+MSGDBL,sum,1,'max')
         else if (ic.eq.3) then
            call GA_PGROUP_DGOP(comm_k,9+MSGDBL,sum,1,'max')
         else
            call GA_DGOP(9+MSGDBL,sum,1,'max')
         end if
      end if

      return
      end




*     ***********************************
*     *                                 *
*     *         Parallela_SumAll        *
*     *                                 *
*     ***********************************

      subroutine Parallela_SumAll(ic,sum)
c     implicit none
      integer ic
      real*8  sum

#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

      if (np.gt.1) then
         if (ic.eq.1) then
            call GA_PGROUP_DGOP(comm_i,9+MSGDBL,sum,1,'+')
         else if (ic.eq.1) then
            call GA_PGROUP_DGOP(comm_j,9+MSGDBL,sum,1,'+')
         else if (ic.eq.3) then
            call GA_PGROUP_DGOP(comm_k,9+MSGDBL,sum,1,'+')
         else 
            call GA_DGOP(9+MSGDBL,sum,1,'+')
         end if
      end if

      return
      end



*     ***********************************
*     *                                 *
*     *         Parallela_ISumAll       *
*     *                                 *
*     ***********************************

      subroutine Parallela_ISumAll(ic,sum)
c     implicit none
      integer ic
      integer  sum

#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

      if (np.gt.1) then
         if (ic.eq.1) then
            call GA_PGROUP_IGOP(comm_i,9+MSGINT,sum,1,'+')
         else if (ic.eq.2) then
            call GA_PGROUP_IGOP(comm_j,9+MSGINT,sum,1,'+')
         else if (ic.eq.3) then
            call GA_PGROUP_IGOP(comm_k,9+MSGINT,sum,1,'+')
         else 
            call GA_IGOP(9+MSGINT,sum,1,'+')
         end if
      end if
      
      return
      end


*     ***********************************
*     *                                 *
*     *      Parallela_Vector_SumAll    *
*     *                                 *
*     ***********************************
      subroutine Parallela_Vector_SumAll(ic,n,sum)
c     implicit none
      integer ic
      integer n
      real*8  sum(*)

#include "bafdecls.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "errquit.fh"
#include "Parallel.fh"


      call nwpw_timing_start(2)
      if (np.gt.1) then
         if (ic.eq.1) then
            call GA_PGROUP_DGOP(comm_i,9+MSGDBL,sum,n,'+')
         else if (ic.eq.2) then
            call GA_PGROUP_DGOP(comm_j,9+MSGDBL,sum,n,'+')
         else if (ic.eq.3) then
            call GA_PGROUP_DGOP(comm_k,9+MSGDBL,sum,n,'+')
         else
            call GA_DGOP(9+MSGDBL,sum,n,'+')
         end if
      end if
      call nwpw_timing_end(2)
      return
      end



*     ***********************************
*     *                                 *
*     *     Parallela_Vector_ISumAll    *
*     *                                 *
*     ***********************************

      subroutine Parallela_Vector_ISumAll(ic,n,sum)
c     implicit none
      integer ic
      integer n
      integer  sum(*)

#include "bafdecls.fh"
#include "errquit.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"


      call nwpw_timing_start(2)
      if (np.gt.1) then
         if (ic.eq.1) then
            call GA_PGROUP_IGOP(comm_i,9+MSGINT,sum,n,'+')
         else if (ic.eq.2) then
            call GA_PGROUP_IGOP(comm_j,9+MSGINT,sum,n,'+')
         else if (ic.eq.3) then
            call GA_PGROUP_IGOP(comm_k,9+MSGINT,sum,n,'+')
         else 
            call GA_IGOP(9+MSGINT,sum,n,'+')
         end if
      end if
      call nwpw_timing_end(2)

      return
      end



*     ***********************************
*     *                                 *
*     *      Parallela_Brdcst_value      *
*     *                                 *
*     ***********************************

      subroutine Parallela_Brdcst_value(ic,psend,sum)
      implicit none
      integer ic
      integer psend
      real*8  sum

#include "bafdecls.fh"
#include "errquit.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

*     **** local variables ****
      integer msglen

      if (np.gt.1) then
         msglen = 1
         if (ic.eq.1) then
          call GA_PGROUP_BRDCST(comm_i,9+MSGDBL,sum,mdtob(msglen),psend)
         else if (ic.eq.2) then
          call GA_PGROUP_BRDCST(comm_j,9+MSGDBL,sum,mdtob(msglen),psend)
         else if (ic.eq.3) then
          call GA_PGROUP_BRDCST(comm_k,9+MSGDBL,sum,mdtob(msglen),psend)
         else
            call GA_BRDCST(9+MSGDBL,sum,mdtob(msglen),psend)
         end if
      end if

      return
      end


*     ***********************************
*     *                                 *
*     *      Parallela_Brdcst_values    *
*     *                                 *
*     ***********************************

      subroutine Parallela_Brdcst_values(ic,psend,nsize,sum)
      implicit none
      integer ic
      integer psend,nsize
      real*8  sum(*)

#include "bafdecls.fh"
#include "errquit.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"


      if (np.gt.1) then
         if (ic.eq.1) then
           call GA_PGROUP_BRDCST(comm_i,9+MSGDBL,sum,mdtob(nsize),psend)
         else if (ic.eq.2) then
           call GA_PGROUP_BRDCST(comm_j,9+MSGDBL,sum,mdtob(nsize),psend)
         else if (ic.eq.3) then
           call GA_PGROUP_BRDCST(comm_k,9+MSGDBL,sum,mdtob(nsize),psend)
         else
            call GA_BRDCST(9+MSGDBL,sum,mdtob(nsize),psend)
         end if
      end if

      return
      end



*     ***********************************
*     *                                 *
*     *      Parallela_Brdcst_ivalue    *
*     *                                 *
*     ***********************************
      subroutine Parallela_Brdcst_ivalue(ic,psend,isum)
      implicit none
      integer ic
      integer psend
      integer isum

#include "bafdecls.fh"
#include "errquit.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

*     **** local variables ****
      integer msglen

      if (np.gt.1) then
         msglen = 1
         if (ic.eq.1) then
         call GA_PGROUP_BRDCST(comm_i,9+MSGINT,isum,mitob(msglen),psend)
         else if (ic.eq.2) then
         call GA_PGROUP_BRDCST(comm_j,9+MSGINT,isum,mitob(msglen),psend)
         else if (ic.eq.3) then
         call GA_PGROUP_BRDCST(comm_k,9+MSGINT,isum,mitob(msglen),psend)
         else
         call GA_BRDCST(9+MSGINT,isum,mitob(msglen),psend)
         end if
      end if

      return
      end




*     ***********************************
*     *                                 *
*     *      Parallela_Brdcst_ivalues   *
*     *                                 *
*     ***********************************

      subroutine Parallela_Brdcst_ivalues(ic,psend,nsize,isum)
      implicit none
      integer ic
      integer psend,nsize
      integer  isum(*)

#include "bafdecls.fh"
#include "errquit.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "Parallel.fh"

      if (np.gt.1) then
         if (ic.eq.1) then
          call GA_PGROUP_BRDCST(comm_i,9+MSGINT,isum,mitob(nsize),psend)
         else if (ic.eq.2) then
          call GA_PGROUP_BRDCST(comm_j,9+MSGINT,isum,mitob(nsize),psend)
         else if (ic.eq.3) then
          call GA_PGROUP_BRDCST(comm_k,9+MSGINT,isum,mitob(nsize),psend)
         else 
            call GA_BRDCST(9+MSGINT,isum,mitob(nsize),psend)
         end if
      end if
      return
      end



*     ***********************************
*     *                                 *
*     *      Parallela_start_rotate     *
*     *                                 *
*     ***********************************

      subroutine Parallela_start_rotate(ic,shift,
     >                                  A1,nsize1,
     >                                  A2,nsize2,request)
      implicit none
      integer ic,shift
      real*8  A1(*)
      integer nsize1
      real*8  A2(*)
      integer nsize2
      integer request(*)

#include "bafdecls.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "errquit.fh"

#include "Parallel.fh"


*     **** local variables ****
      integer i,mynp,mytaskid,msglen,msgype,mpierr,proc_to,proc_from
      integer rcv_proc,rcv_len,psr,tmp(2),pto

*     ***** external functions ****
      integer  Parallel3d_convert_taskid_i
      integer  Parallel3d_convert_taskid_j
      integer  Parallel3d_convert_taskid_k
      external Parallel3d_convert_taskid_i
      external Parallel3d_convert_taskid_j
      external Parallel3d_convert_taskid_k

      if (ic.eq.1) then
         mynp     = np_i
         mytaskid = taskid_i
         proc_to   = mod(mytaskid+shift+mynp,mynp)
         proc_from = mod(mytaskid-shift+mynp,mynp)

         proc_to   = Parallel3d_convert_taskid_i(proc_to)
         proc_from = Parallel3d_convert_taskid_i(proc_from)
      else if (ic.eq.2) then
         mynp     = np_j
         mytaskid = taskid_j
         proc_to   = mod(mytaskid+shift+mynp,mynp)
         proc_from = mod(mytaskid-shift+mynp,mynp)

         proc_to   = Parallel3d_convert_taskid_j(proc_to)
         proc_from = Parallel3d_convert_taskid_j(proc_from)
      else if (ic.eq.3) then
         mynp     = np_k
         mytaskid = taskid_k
         proc_to   = mod(mytaskid+shift+mynp,mynp)
         proc_from = mod(mytaskid-shift+mynp,mynp)

         proc_to   = Parallel3d_convert_taskid_k(proc_to)
         proc_from = Parallel3d_convert_taskid_k(proc_from)
      else
         mynp     = np
         mytaskid = taskid
         proc_to   = mod(mytaskid+shift+mynp,mynp)
         proc_from = mod(mytaskid-shift+mynp,mynp)
      end if

*      /* determine psr - should be made w/o using tmp array! */
      if (.not.BA_push_get(mt_int,mynp,'tmppp2',tmp(2),tmp(1)))
     >  call errquit('Parallela_start_rotate:out of stack',0,MA_ERR)
      do i=0,np-1
         int_mb(tmp(1)+i) = 0
      end do
      do i=0,np-1
         pto = mod(i+shift+mynp,mynp)
         if ((int_mb(tmp(1)+i).eq.0).and.(int_mb(tmp(1)+pto).eq.0)) then
            int_mb(tmp(1)+i)   = 1
            int_mb(tmp(1)+pto) = 2
         end if
      end do
      psr = int_mb(tmp(1)+mytaskid)
      if (psr.eq.0) psr = 2
      if (.not.BA_pop_stack(tmp(2)))
     >  call errquit('Parallela_start_rotate:popping stack',0,MA_ERR)

*     **** send then receive ****
      if (psr.eq.1) then

         if (nsize1.gt.0) then
            msglen  = nsize1
            call SND(9+MSGDBL,A1,mdtob(msglen),proc_to,1)
            request(4) = 1
         else
            request(4) = 0
         end if

         if (nsize2.gt.0) then
            msglen  = nsize2
            call RCV(9+MSGDBL,A2,mdtob(msglen),rcv_len,
     >            proc_from,rcv_proc,1)
            request(3) = 1
         else
            request(3) = 0
         end if

*     **** receive then receive ****
      else
         if (nsize2.gt.0) then
            msglen  = nsize2
            call RCV(9+MSGDBL,A2,mdtob(msglen),rcv_len,
     >            proc_from,rcv_proc,1)
            request(3) = 1
         else
            request(3) = 0
         end if

         if (nsize1.gt.0) then
            msglen  = nsize1
            call SND(9+MSGDBL,A1,mdtob(msglen),proc_to,1)
            request(4) = 1
         else
            request(4) = 0
         end if
      end if

      if ((request(3).eq.1).and.(request(4).eq.1)) then
         request(3) = 1
      else if (request(3).eq.1) then
         request(3) = 2
      else if (request(4).eq.1) then
         request(3) = 3
      else
         request(3) = 4
      end if

      return
      end


*     ***********************************
*     *                                 *
*     *      Parallela_start_Irotate    *
*     *                                 *
*     ***********************************
      subroutine Parallela_start_Irotate(ic,shift,
     >                                  A1,nsize1,
     >                                  A2,nsize2,request)
      implicit none
      integer ic,shift
      integer A1(*)
      integer nsize1
      integer A2(*)
      integer nsize2
      integer request(*)

#include "bafdecls.fh"
#include "tcgmsg.fh"
#include "msgtypesf.h"
#include "errquit.fh"

#include "Parallel.fh"


*     **** local variables ****
      integer i,mynp,mytaskid,msglen,msgype,mpierr,proc_to,proc_from
      integer rcv_proc,rcv_len,psr,tmp(2),pto

*     ***** external functions ****
      integer  Parallel3d_convert_taskid_i
      integer  Parallel3d_convert_taskid_j
      integer  Parallel3d_convert_taskid_k
      external Parallel3d_convert_taskid_i
      external Parallel3d_convert_taskid_j
      external Parallel3d_convert_taskid_k

      if (ic.eq.1) then
         mynp     = np_i
         mytaskid = taskid_i
         proc_to   = mod(mytaskid+shift+mynp,mynp)
         proc_from = mod(mytaskid-shift+mynp,mynp)

         proc_to   = Parallel3d_convert_taskid_i(proc_to)
         proc_from = Parallel3d_convert_taskid_i(proc_from)
      else if (ic.eq.2) then
         mynp     = np_j
         mytaskid = taskid_j
         proc_to   = mod(mytaskid+shift+mynp,mynp)
         proc_from = mod(mytaskid-shift+mynp,mynp)

         proc_to   = Parallel3d_convert_taskid_j(proc_to)
         proc_from = Parallel3d_convert_taskid_j(proc_from)
      else if (ic.eq.3) then
         mynp     = np_k
         mytaskid = taskid_k
         proc_to   = mod(mytaskid+shift+mynp,mynp)
         proc_from = mod(mytaskid-shift+mynp,mynp)

         proc_to   = Parallel3d_convert_taskid_k(proc_to)
         proc_from = Parallel3d_convert_taskid_k(proc_from)
      else
         mynp     = np
         mytaskid = taskid
         proc_to   = mod(mytaskid+shift+mynp,mynp)
         proc_from = mod(mytaskid-shift+mynp,mynp)
      end if

*      /* determine psr - should be made w/o using tmp array! */
      if (.not.BA_push_get(mt_int,mynp,'tmppp2',tmp(2),tmp(1)))
     >  call errquit('Parallela_start_rotate:out of stack',0,MA_ERR)
      do i=0,np-1
         int_mb(tmp(1)+i) = 0
      end do
      do i=0,np-1
         pto = mod(i+shift+mynp,mynp)
         if ((int_mb(tmp(1)+i).eq.0).and.(int_mb(tmp(1)+pto).eq.0)) then
            int_mb(tmp(1)+i)   = 1
            int_mb(tmp(1)+pto) = 2
         end if
      end do
      psr = int_mb(tmp(1)+mytaskid)
      if (psr.eq.0) psr = 2
      if (.not.BA_pop_stack(tmp(2)))
     >  call errquit('Parallela_start_rotate:popping stack',0,MA_ERR)

*     **** send then receive ****
      if (psr.eq.1) then

         if (nsize1.gt.0) then
            msglen  = nsize1
            call SND(9+MSGINT,A1,mitob(msglen),proc_to,1)
            request(4) = 1
         else
            request(4) = 0
         end if

         if (nsize2.gt.0) then
            msglen  = nsize2
            call RCV(9+MSGINT,A2,mitob(msglen),rcv_len,
     >            proc_from,rcv_proc,1)
            request(3) = 1
         else
            request(3) = 0
         end if

*     **** receive then receive ****
      else
         if (nsize2.gt.0) then
            msglen  = nsize2
            call RCV(9+MSGINT,A2,mitob(msglen),rcv_len,
     >            proc_from,rcv_proc,1)
            request(3) = 1
         else
            request(3) = 0
         end if

         if (nsize1.gt.0) then
            msglen  = nsize1
            call SND(9+MSGINT,A1,mitob(msglen),proc_to,1)
            request(4) = 1
         else
            request(4) = 0
         end if
      end if

      if ((request(3).eq.1).and.(request(4).eq.1)) then
         request(3) = 1
      else if (request(3).eq.1) then
         request(3) = 2
      else if (request(4).eq.1) then
         request(3) = 3
      else
         request(3) = 4
      end if

      return
      end






*     ***********************************
*     *                                 *
*     *      Parallela_end_rotate       *
*     *                                 *
*     ***********************************

      subroutine Parallela_end_rotate(request)
      implicit none
      integer request(*)

*     **** wait for completion of mp_send, also do a sync ****
      !*** do nothing ***

      return
      end



*     ***********************************
*     *                                 *
*     *      Parallel_send_characters   *
*     *                                 *
*     ***********************************
      subroutine Parallel_send_characters(pto,msgtype,nsize,cval)
      implicit none
      integer pto,msgtype,nsize
      character cval(*)

#include "tcgmsg.fh"
#include "msgtypesf.h"

      integer  rcv_len,rcv_proc

      call SND(9+MSGCHR,cval,nsize,pto,1)
      return
      end

*     ***********************************
*     *                                 *
*     *      Parallel_send_values       *
*     *                                 *
*     ***********************************
      subroutine Parallel_send_values(pto,msgtype,nsize,rval)
      implicit none                     
      integer pto,msgtype,nsize
      character rval(*)                 

#include "tcgmsg.fh"
#include "msgtypesf.h"

      call SND(9+MSGDBL,rval,mdtob(nsize),pto,1)
      return
      end

*     ***********************************
*     *                                 *
*     *      Parallel_send_ivalues      *
*     *                                 *
*     ***********************************
      subroutine Parallel_send_ivalues(pto,msgtype,nsize,ival)
      implicit none
      integer pto,msgtype,nsize
      integer   ival(*)

#include "tcgmsg.fh"
#include "msgtypesf.h"

      call SND(9+MSGINT,ival,mitob(nsize),pto,1)
      return
      end





*     ***********************************
*     *                                 *
*     *      Parallel_recv_characters   *
*     *                                 *
*     ***********************************
      subroutine Parallel_recv_characters(pfrom,msgtype,nsize,cval)
      implicit none
      integer  pfrom,msgtype,nsize
      character cval(*)

#include "tcgmsg.fh"
#include "msgtypesf.h"

      integer  rcv_len,rcv_proc

      call RCV(9+MSGCHR,cval,nsize,rcv_len,pfrom,rcv_proc,1)
      return
      end


*     ***********************************
*     *                                 *
*     *      Parallel_recv_values       *
*     *                                 *
*     ***********************************
      subroutine Parallel_recv_values(pfrom,msgtype,nsize,rval)
      implicit none
      integer  pfrom,msgtype,nsize
      real*8   rval(*)

#include "tcgmsg.fh"
#include "msgtypesf.h"

      integer  rcv_len,rcv_proc

      call RCV(9+MSGDBL,rval,mdtob(nsize),rcv_len,pfrom,rcv_proc,1)
      return
      end


*     ***********************************
*     *                                 *
*     *      Parallel_recv_ivalues      *
*     *                                 *
*     ***********************************
      subroutine Parallel_recv_ivalues(pfrom,msgtype,nsize,ival)
      implicit none
      integer  pfrom,msgtype,nsize
      integer  ival(*)

#include "tcgmsg.fh"
#include "msgtypesf.h"

      integer  rcv_len,rcv_proc

      call RCV(9+MSGINT,ival,mitob(nsize),rcv_len,pfrom,rcv_proc,1)
      return
      end

