C  The level I application library: Index operations.
C  Originally written by D.B. Carpenter in Occam
C  Ported to Fortran by James Allwright (December 1991)
C  This version is a subset of the original library
C
C  #INCLUDE "acprothdr.inc"
C  #USE     "acbase.lib"
C{{{  Synchronization
C{{{  SUBROUTINE SYNCH
      SUBROUTINE SYNCH (rank, rs)
      IMPLICIT LOGICAL(A-Z)
      INTEGER rs, rank(0:rs-1)
      INTEGER token, i
C  Synchronise processes on index set.  (This doesn't terminate
C  on any of the sites connected by rank until it has been called
C  on all of them).
      token = 0
      DO 10, i = 0, rs-1
        CALL Ibroad(rank (i), token, 1, 0)
10    CONTINUE
      DO 20, i = 0, rs-1
        CALL Imerge(rank (i), token, 1, 0, FALSE)
20    CONTINUE
      END
C}}}
C}}}
C{{{  Broadcasts
C  Broadcast family...
C{{{  SUBROUTINE BCAST
      SUBROUTINE BCAST (x, result, rlen, data, dlen)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, dlen, data(0:dlen-1), rlen, result(0:rlen-1, 0:dlen-1)
C  Convert a distribution into a global array.  Algorithm is
C  fan-in to origin, followed by broadcast.  The fan-in is
C  done on a binary tree--- this obviously doesn't reduce the quantity of
C  incoming data per process, but it does minimise number of incoming
C  packets.
C  `len' (global) is the amount of data from `data' actually sent.
      INTEGER N, loc, nn
      INTEGER len, src, dst, i
      N = Isize(x)
      loc = Icoord(x)
      DO 25, i = 0, dlen-1
      result(0,i) = data(i)
25    CONTINUE
      nn = 1
      IF (nn .GE. N) GOTO 40
30    CONTINUE
        IF (MOD(loc, nn) .EQ. 0) THEN
C         C{{{  CASE
          IF (MOD((loc / nn),2) .EQ. 0) THEN
            src = loc + nn
            IF (src .LT. N) THEN
              len = N - src
              IF (len .GT. nn) THEN
                len = nn
              ENDIF
              CALL Iin (x, result(nn, 0), len, src)
            ENDIF
          ELSE
            dst = loc - nn
            len = N - loc
            IF (len .GT. nn) THEN
              len = nn
            ENDIF
            CALL Iout (x, result, len, dst)
          ENDIF
C         C}}}
        ENDIF
        nn = 2 * nn
      IF (nn .LT. N) GOTO 30
40    CONTINUE
      CALL Ibroad (x, result, N, 0)
      END
C}}}
C{{{  SUBROUTINE BCSTEL
      SUBROUTINE BCSTEL (x, result, rlen, data, dlen, src)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, rlen, dlen, src, i
      INTEGER result(0:rlen-1), data(0:dlen-1)
      DO 50, i = 0, dlen-1
        result(i) = data(i)
50    CONTINUE
      CALL Ibroad (x, result, rlen, src)
      END
C}}}
C{{{  SUBROUTINE BCSTAR
      SUBROUTINE BCSTAR (x, result, rlen, tlen, segsize, data, dlen)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, rlen, tlen, segsize, dlen
      INTEGER result(0:rlen-1, 0:tlen-1)
      INTEGER data(0:dlen-1, 0:tlen-1)
C  Convert a distribution of arrays into a global array.  Algorithm is
C  fan-in to origin, followed by broadcast.
      INTEGER N, loc, n, ressize, i, j, len, src, dst
      N = Isize(x)
      loc = Icoord(x)
      DO 70, i = 0, segsize-1
        DO 60, j = 0, tlen-1
          result(i, j) = data(i, j)
60      CONTINUE
70    CONTINUE
      ressize = segsize
      nn = 1
      IF (nn .GE. N) GOTO 90
80    CONTINUE
        IF (MOD(loc,nn) .EQ. 0) THEN
          IF (MOD((loc / nn),2) .EQ. 0) THEN
            src = loc + nn
            IF (src .LT. N) THEN
              CALL Iin (x, len, 1, src)
              CALL Iin (x, result(ressize, 0), len, src)
              ressize = ressize + len
            ENDIF
          ELSE
            dst = loc - nn
            CALL Iout (x, ressize, 1, dst)
            CALL Iout (x, result, ressize, dst)
          ENDIF
        ENDIF
        nn = 2 * nn
      IF (nn .LT. N) GOTO 80
90    CONTINUE
      CALL Ibroad (x, ressize, 1, 0)
      CALL Ibroad (x, result, ressize, 0)
      END
C}}}
C}}}
C{{{  Permutations
C  Permutation family...
C{{{  SUBROUTINE PDS
      SUBROUTINE PDS (x, result, rlen, data, dlen, src, dst)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, rlen, dlen
      INTEGER result(0:rlen-1), data(0:dlen-1)
      INTEGER src, dst, i
C  General permutation of 'data' array, result in 'result'.
      INTEGER loc
      loc = Icoord (x)
      IF (dst .NE. loc) THEN
        CALL Iout (x,   data, dlen, dst)
        CALL Iin  (x, result, rlen, src)
      ELSE
        DO 202 i = 0, rlen
          result(i) = data(i)
202     CONTINUE
      ENDIF
      END
C}}}
C{{{  SUBROUTINE PSHFT
      SUBROUTINE PSHFT (x, result, rlen, data, dlen, shift)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, rlen, dlen, shift
      INTEGER result(0:rlen-1), data(0:dlen-1)
C  Cyclic shift permutation.
      INTEGER N, loc, rshift
      N = Isize  (x)
      loc = Icoord (x)
      rshift = MOD(shift,N)
      CALL PDS (x, result, data, MOD((loc + (N - rshift)) , N),
     :                      MOD((loc + (N + rshift)) , N))
      END
C}}}
C{{{  SUBROUTINE PREFL
      SUBROUTINE PREFL (x, result, rlen, data, dlen, a)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, rlen, dlen, a
      INTEGER result(0:rlen-1)
      INTEGER data(0:dlen-1)
C  Reflection permutation.
      INTEGER N, loc, partner
      N = Isize  (x)
      loc = Icoord (x)
C  Silliness because of usual thing about REM being broken for -ve arg.
      partner = MOD(((N + MOD(a, N)) + (N - loc)), N)
      CALL PDS (x, result, data, partner, partner)
      END
C}}}
C{{{  SUBROUTINE PXOR
      SUBROUTINE PXOR (x, result, rlen, data, dlen, p)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, rlen, dlen, p
      INTEGER result(0:rlen-1)
      INTEGER data(0:dlen-1)
C  Generalised butterfly permutation
      INTEGER N, loc, partner
      N = Isize  (x)
      loc = Icoord (x)
      partner = IXOR(loc, p)
      IF (partner .GE. N) THEN
        partner = loc
      ENDIF
      CALL PDS (x, result, data, partner, partner)
      END
C}}}
C{{{  SUBROUTINE PSWAP
      SUBROUTINE PSWAP (x, result, rlen, data, dlen, i1, i2)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, rlen, dlen, i1, i2
      INTEGER result(0:rlen-1)
      INTEGER data(0:dlen-1)
C  Simple exchange permutation.
      INTEGER partner, loc
      loc = Icoord (x)
      partner = loc
      IF (loc .EQ. i1) partner = i2
      IF (loc .EQ. i2) partner = i1
      CALL PDS (x, result, data, partner, partner)
      END
C}}}
C{{{  SUBROUTINE PDSI
      SUBROUTINE PDSI (x, data, dlen, src, dst)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, dlen, src, dst
      INTEGER data(0:dlen-1)
C  General permutation "in situ" in 'data' array.
      INTEGER loc, len
      INTEGER base, residue
      PARAMETER (buflen = 512)
      INTEGER buffer(0:buflen-1)
      INTEGER i
      loc = Icoord (x)
      IF (dst .NE. loc) THEN
        base    = 0
        residue = dlen
        IF (residue .LE. 0) GOTO 120
100     CONTINUE
C         C{{{  IF
          IF (residue .GT. buflen) THEN
            len = buflen
          ELSE
            len = residue
          ENDIF
C         C}}}
          CALL Iout (x,   data(base), len, dst)
          CALL Iin  (x, buffer, len, src)
          DO 110, i = 0, len-1
            data(base + i) = buffer(i)
110       CONTINUE
          residue = residue - len
          base    = base    + len
        IF (residue .GT. 0) GOTO 100
120     CONTINUE
      ENDIF
      END
C}}}
C{{{  SUBROUTINE PSHFTI
      SUBROUTINE PSHFTI (x, data, dlen, shift)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, dlen, rshift
      INTEGER data(0:dlen-1)
C  Cyclic shift permutation.
      INTEGER N, loc, rshift
      N = Isize(x)
      loc = Icoord(x)
      rshift = MOD(shift, N)
      CALL PDSI (x, data, MOD((loc + (N - rshift)), N),
     :      MOD((loc + (N + rshift)), N))
      END
C}}}
C{{{  SUBROUTINE PREFLI
      SUBROUTINE PREFLI (x, data, dlen, a)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, dlen, a
      INTEGER data(0:dlen-1)
C  Reflection permutation.
      INTEGER N, loc, partner
      N = Isize  (x)
      loc = Icoord (x)
C  Silliness because of usual thing about REM being broken for -ve arg.
      partner = MOD(((N + MOD(a, N)) + (N - loc)), N)
      CALL PDSI (x, data, partner, partner)
      END
C}}}
C{{{  SUBROUTINE PXORI
      SUBROUTINE PXORI (x, data, dlen, p)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, dlen, p
      INTEGER data(0:dlen-1)
C  Generalised butterfly permutation
      INTEGER partner, N, loc
      N = Isize(x)
      loc = Icoord(x)
      partner = IXOR(loc, p)
      IF (partner .GE. N) THEN
        partner = loc
      ENDIF
      CALL PDSI (x, data, partner, partner)
      END
C}}}
C{{{  SUBROUTINE PSWAPI
      SUBROUTINE PSWAPI (x, data, dlen, i1, i2)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, dlen, i1, i2
      INTEGER data(0:dlen-1)
C  Simple exchange permutation.
      INTEGER partner, loc
      loc = Icoord (x)
      partner = loc
      IF (loc .EQ. i1) partner = i2
      IF (loc .EQ. i2) partner = i1
      CALL PDSI (x, data, partner, partner)
      END
C}}}
C}}}
C{{{  Prefixes
C  Prefixes...
C{{{  SUBROUTINE INSUM
      SUBROUTINE INSUM (x, result, data)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, result, data
      INTEGER N, loc, acc, nn, trans
      N = Isize(x)
      loc = Icoord(x)
      result = data
      acc = data
      nn = 1
      IF (nn .GE. N) GOTO 140
130   CONTINUE
        CALL PXOR (x, trans, 1, acc, 1, nn)
C       C{{{
        IF (.NOT. (IXOR(loc, nn) .GE. N)) THEN
C         C{{{
          IF ((IAND((loc / nn), 1)) .EQ. 0) THEN
            acc = acc + trans
          ELSE
            result = trans + result
            acc    = trans + acc
          ENDIF
C         C}}}
        ENDIF
C       C}}}
        nn = 2 * nn
      IF (nn .LT. N) GOTO 130
140   CONTINUE
      END
C}}}
C{{{  SUBROUTINE INPRD
      SUBROUTINE INPRD (x, result, data)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, result, data
      INTEGER acc, nn, N, loc, trans
      N = Isize(x)
      loc = Icoord(x)
      result = data
      acc = data
      nn = 1
      IF (nn .GE. N) GOTO 160
150   CONTINUE
        CALL PXOR (x, trans, 1, acc, 1, nn)
        IF (.NOT. (IXOR(loc, nn) .GE. N)) THEN
          IF (IAND((loc / nn), 1) .EQ. 0) THEN
            acc = acc * trans
          ELSE
            result = trans * result
            acc    = trans * acc
          ENDIF
        ENDIF
        nn = 2 * nn
      IF (nn .LT. N) GOTO 150
160   CONTINUE
      END
C}}}
C{{{  SUBROUTINE INMAX
      SUBROUTINE INMAX (x, result, resulttg, data, datatg)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, result, resulttg, data, datatg
      INTEGER N, loc
      INTEGER xacc(0:1), xtrans(0:1)
      INTEGER acc, acctg, trans, transtg, nn
C     C{{{  Equivalence
      EQUIVALENCE(acc, xacc(0))
      EQUIVALENCE(acctg, xacc(1))
      EQUIVALENCE(trans, xtrans(0))
      EQUIVALENCE(transtg, xtrans(1))
C     C}}}
      N = Isize  (x)
      loc = Icoord (x)
      result = data
      resulttg = datatg
      acc = data
      acctg = datatg
      nn   = 1
      IF (nn .GE. N) GOTO 180
170   CONTINUE
        CALL PXOR (x, xtrans, 1, xacc, 1, nn)
        IF (.NOT. (IXOR(loc, nn) .GE. N)) THEN
          IF ((trans .GT. acc) .OR. ((trans .EQ. acc) .AND.
     :        (transtg .GT. acctg))) THEN
            acc = trans
            acctg = transtg
          ENDIF
          IF (.NOT. ((IAND((loc / nn), 1)) .EQ. 0)) THEN
            IF ((trans .GT. result) .OR. ((trans .EQ. result) .AND.
     :          (transtg .GT. resulttg))) THEN
              result = trans
              resulttg = transtg
            ENDIF
          ENDIF
        ENDIF
        nn = 2 * nn
        IF (nn .LT. N) GOTO 170
180   CONTINUE
      END
C}}}
C{{{  SUBROUTINE INMIN
      SUBROUTINE INMIN (x, result, resulttg, data, datatg)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, result, resulttg, data, datatg
      INTEGER N, loc
      INTEGER acc, acctg, trans, transtg
      INTEGER xacc(0:1), xtrans(0:1)
      INTEGER nn
C     C{{{  EQUIVALENCE
      EQUIVALENCE(acc, xacc(0))
      EQUIVALENCE(acctg, xacc(1))
      EQUIVALENCE(trans, xtrans(0))
      EQUIVALENCE(transtg, xtrans(1))
C     C}}}
      N = Isize(x)
      loc = Icoord(x)
      result = data
      resulttg = datatg
      acc = data
      acctg = datatg
      nn  = 1
      IF (nn .GE. N) GOTO 200
190   CONTINUE
        CALL PXOR (x, xtrans, 1, xacc, 1, nn)
        IF (.NOT. (IXOR(loc, nn) .GE. N)) THEN
          IF ((trans .LT. acc) .OR. ((trans. EQ. acc) .AND.
     :        (transtg .LT. acctg))) THEN
            acc = trans
            acctg = transtg
          ENDIF
          IF (.NOT. ((IAND((loc / nn), 1)) .EQ. 0)) THEN
            IF ((trans .LT. result) .OR. ((trans .EQ. result) .AND.
     :          (transtg .LT. resulttg))) THEN
              result = trans
              resulttg = transtg
            ENDIF
          ENDIF
        ENDIF
        nn = 2 * nn
        IF (nn .LT. N) GOTO 190
200   CONTINUE
      END
C}}}
C{{{  SUBROUTINE PFXAND
      SUBROUTINE PFXAND (x, result, data)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x
      LOGICAL result, data
      INTEGER N, loc, nn
      LOGICAL acc, trans
      N = Isize(x)
      loc = Icoord(x)
      result = data
      acc = data
      nn = 1
      IF (nn .GE. N) GOTO 220
210   CONTINUE
        CALL PXOR (x, trans, 1, acc, 1, nn)
C       C{{{
        IF (.NOT. (IXOR(loc, nn) .GE. N)) THEN
         IF ((IAND((loc / nn), 1)) .EQ. 0) THEN
            acc = acc .AND. trans
          ELSE
            result = trans .AND. result
            acc    = trans .AND. acc
          ENDIF
        ENDIF
C       C}}}
        nn = 2 * nn
        IF (nn .LT. N) GOTO 210
220   CONTINUE
      END
C}}}
C{{{  SUBROUTINE PFXOR
      SUBROUTINE PFXOR (x, result, data)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x
      LOGICAL result, data
      INTEGER N, loc, nn
      LOGICAL acc, trans
      N = Isize  (x)
      loc = Icoord (x)
      result = data
      acc = data
      nn = 1
      IF (nn .GE. N) GOTO 240
230   CONTINUE
        CALL PXOR (x, trans, 1, acc, 1, nn)
C       C{{{
        IF (.NOT. (IXOR(loc, nn) .GE. N)) THEN
C         C{{{
          IF ((IAND((loc / nn), 1)) .EQ. 0) THEN
            acc = acc .OR. trans
          ELSE
            result = trans .OR. result
            acc    = trans .OR. acc
          ENDIF
C         C}}}
        ENDIF
C       C}}}
        nn = 2 * nn
        IF (nn .LT. N) GOTO 230
240   CONTINUE
      END
C}}}
C}}}
C{{{  "Global operations"
C  ``Global'' operations (these could be done a bit more efficiently,
C  than calculating a whole prefix)...
C{{{  INTEGER FUNCTION GINSUM
      INTEGER FUNCTION GINSUM (x, data)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, data
      INTEGER result, prefix
      CALL INSUM (x, prefix, data)
      CALL BCSTEL (x, result, prefix, Isize (x) - 1)
      GINSUM = result
      END
C}}}
C{{{  INTEGER FUNCTION GINPRD
      INTEGER FUNCTION GINPRD (x, data)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, data
      INTEGER result, prefix
      CALL INPRD (x, prefix, data)
      CALL BCSTEL (x, result, prefix, Isize (x) - 1)
      GINPRD = result
      END
C}}}
C{{{  INTEGER, INTEGER FUNCTION GINMAX
      SUBROUTINE GINMAX (res, restg, x, data, datatg)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, data, datatg
C  returns res and restg as results
      INTEGER res, restg
      INTEGER prefix(0:1)
      INTEGER resarr(0:1)
      CALL INMAX (x, prefix(0), prefix(1), data, datatg)
      CALL BCSTEL (x, resarr, prefix, Isize (x) - 1)
      res = resarr(0)
      restg = resarr(1)
      END
C}}}
C{{{  INTEGER, INTEGER FUNCTION GINMIN
      SUBROUTINE GINMIN (res, restg, x, data, datatg)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x, data, datatg
C  returns res and restg as results
      INTEGER res, restg
      INTEGER prefix(0:1)
      INTEGER resarr(0:1)
      CALL INMIN (x, prefix(0), prefix(1), data, datatg)
      CALL BCSTEL (x, resarr, prefix, Isize (x) - 1)
      res = resarr(0)
      restg = resarr(1)
      END
C}}}
C{{{  LOGICAL FUNCTION GAND
      LOGICAL FUNCTION GAND (x, data)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x
      LOGICAL data
      LOGICAL result, prefix
      CALL PXAND (x, prefix, data)
      CALL BCSTEL (x, result, prefix, Isize(x) - 1)
      GAND = result
      END
C}}}
C{{{  LOGICAL FUNCTION GOR
      LOGICAL FUNCTION GOR (x, data)
      IMPLICIT LOGICAL(A-Z)
      INTEGER x
      LOGICAL data
      LOGICAL result, prefix
      CALL PFXOR (x, prefix, data)
      CALL BCSTEL (x, result, prefix, Isize(x) - 1)
      GOR = result
      END
C}}}
C}}}
