
      BLOCK DATA aclmeb
      IMPLICIT NONE

        INCLUDE 'aclmem.inc'
        DATA    acptr /0/

      END

      BLOCK DATA acconb
      IMPLICIT NONE

        INCLUDE 'acconf.inc'
        DATA    state /sbegn/

      END


C     Error-handling...print error message and abort.


      SUBROUTINE acmes (source, messag)
      IMPLICIT NONE
      CHARACTER *(*) source, messag

	INCLUDE 'acids.inc'

	IF (report) THEN
	  WRITE (6, *) source // ': ' // messag
	ENDIF

      END

      SUBROUTINE acmes1 (source, messag, par)
      IMPLICIT NONE
      CHARACTER *(*) source, messag
      INTEGER par

	INCLUDE 'acids.inc'
        INTEGER posn

        posn = INDEX (messag, '%')

	IF (report) THEN
          WRITE (6, *) source // ': ' // messag (:posn - 1),
     1                 par,
     2                 messag (posn + 1:)
	ENDIF

      END

      SUBROUTINE acmes2 (source, messag, par1, par2)
      IMPLICIT NONE
      CHARACTER *(*) source, messag
      INTEGER par1, par2

	INCLUDE 'acids.inc'
        INTEGER posn1, posn2

        posn1 = INDEX (messag, '%')
        messag (posn1:posn1) = ' '
        posn2 = INDEX (messag, '%')
        messag (posn1:posn1) = '%'

	IF (report) THEN
          WRITE (6, *) source // ': ' // messag (:posn1 - 1),
     1                 par1,
     2                 messag (posn1 + 1:posn2 - 1),
     3                 par2,
     4                 messag (posn2 + 1:)
	ENDIF

      END

      SUBROUTINE acerr (source, messag)
      IMPLICIT NONE
      CHARACTER *(*) source, messag

        CALL acmes (source, messag)
        STOP

      END

      SUBROUTINE acerr1 (source, messag, par)
      IMPLICIT NONE
      CHARACTER *(*) source, messag
      INTEGER par

        CALL acmes1 (source, messag, par)
        STOP

      END

      SUBROUTINE acerr2 (source, messag, par1, par2)
      IMPLICIT NONE
      CHARACTER *(*) source, messag
      INTEGER par1, par2

        CALL acmes2 (source, messag, par1, par2)
        STOP

      END


C     ``malloc''


      INTEGER FUNCTION acallo (words)
      IMPLICIT NONE
      INTEGER words

C       Simple memory allocation.

        INCLUDE 'aclmem.inc'

        acallo = acptr
        acptr  = acptr + words

        IF (acptr .GT. acmsiz) CALL acerr ('acallo', 'out of memory')
      END

      
C     List-handling primitives.  Actually these implement queues.


      SUBROUTINE acmkls (list)
      IMPLICIT NONE
      INTEGER list 

C       Create an empty list

        INCLUDE 'aclmem.inc'
	INTEGER acallo

        list = acallo (2)
        MEM (list    ) = NULL
        MEM (list + 1) = NULL

      END
 
      SUBROUTINE acadls (list, record)
      IMPLICIT NONE
      INTEGER list, record

C       Add an item to the end of a list.  It's pretty much assumed that
C       the datum `record' is a pointer to the real data, though
C       that isn't essential here.

        INCLUDE 'aclmem.inc'
	INTEGER acallo
        INTEGER node

        node = acallo (2)
        MEM (node    ) = record
        MEM (node + 1) = NULL

        IF (MEM (list) .EQ. NULL) THEN
          MEM (list) = node
        ELSE
          MEM (MEM (list + 1) + 1) = node
        ENDIF
        MEM (list + 1) = node

      END
 
      INTEGER FUNCTION acfrls (list)
      IMPLICIT NONE
      INTEGER list

C       Returns node at front of list

        INCLUDE 'aclmem.inc'

        acfrls = MEM (list)

      END

      INTEGER FUNCTION acdtls (node)
      IMPLICIT NONE
      INTEGER node

C       Returns (pointer to) data field in node

        INCLUDE 'aclmem.inc'

        acdtls = MEM (node)

      END

      INTEGER FUNCTION acnxls (node)
      IMPLICIT NONE
      INTEGER node

C       Returns (pointer to) following node

        INCLUDE 'aclmem.inc'

        acnxls = MEM (node + 1)

      END

      LOGICAL FUNCTION acinls (list, tag, record)
      IMPLICIT NONE
      INTEGER list, tag, record

C       Search for an entry in a list.  The `tag' searched on is the
C       value of the first field in the data record, and `record'
C       returned is a pointer to the data record.  If no matching
C       record is found, .FALSE. is returned.

        INCLUDE 'aclmem.inc'
        INTEGER acfrls, acdtls, acnxls
        INTEGER node

        acinls = .FALSE.
        node   = acfrls (list)

 10     IF (.NOT. acinls .AND. (node .NE. NULL)) THEN
	  record = acdtls (node)
          IF (MEM (record) .EQ. tag) THEN
            acinls = .TRUE.
          ELSE
            node   = acnxls (node)
          ENDIF
	  GOTO 10
	ENDIF

      END
 

C     Other utilities...


      SUBROUTINE acusag (chan)
      IMPLICIT NONE
      INTEGER chan

C       Check usage of channel.  Checks that channel is connected
C       at both ends (warning-level message if they're not) and
C       that the rank of the array at either end is a superset of
C       the rank of the channel.

        INCLUDE 'aclmem.inc'
        INCLUDE 'acconf.inc'

        INTEGER acfrls, acdtls, acnxls
        LOGICAL acinls
        INTEGER cid, rank
        INTEGER end (0 : 1)
        INTEGER node, xid, i, ptr
        INTEGER array, arrank, aid

        cid     = MEM (chan + cname)
        rank    = MEM (chan + crank)
        end (0) = MEM (chan + cref1)
        end (1) = MEM (chan + cref2)

        IF     ((end (0) .EQ. anull) .AND. (end (1) .EQ. anull)) THEN
          CALL acmes1 ('acdone', 'warning---channel % is unused', cid)
        ELSEIF ((end (0) .EQ. anull) .OR.  (end (1) .EQ. anull)) THEN
          CALL acmes1 ('acdone',
     1      'warning---channel % only connected at one end', cid)
        ENDIF

        node = acfrls (rank)

 10     IF (node .NE. NULL) THEN
          xid = MEM (acdtls (node) + iname)

          DO 20 i = 0, 1
            array = end (i)
            IF (array .NE. anull) THEN
              aid    = MEM (array + anumb)
              arrank = MEM (array + arank)
              IF (.NOT. acinls (arrank, xid, ptr)) CALL acerr2
     1          ('acdone',
     2        'array % and attached channel % have incompatible ranks',
     3           aid, cid)
            ENDIF
 20       CONTINUE

          node = acnxls (node)
          GOTO 10
	ENDIF

      END

      INTEGER FUNCTION acenum (list)
      IMPLICIT NONE
      INTEGER list

C       Number records in a list 0 to N-1, and return
C       total number, N, of records.

        INCLUDE 'aclmem.inc'
        INCLUDE 'acconf.inc'

        INTEGER acfrls, acdtls, acnxls
        INTEGER node, record

        acenum = 0
        node   = acfrls (list)

 10     IF (node .NE. NULL) THEN
          record = acdtls (node)
          MEM (record + rnumb) = acenum
          acenum = acenum + 1
          node   = acnxls (node)
          GOTO 10
	ENDIF

      END

      SUBROUTINE acplac (array, base)
      IMPLICIT NONE
      INTEGER array, base

C       Allocate processor ids for an array, starting from `base'.
C       `base' is incremented to the next free location.

        INCLUDE 'aclmem.inc'
	INTEGER acallo
        INCLUDE 'acconf.inc'
	INTEGER dim, rank, stride, strds, node, i, index, desc
	INTEGER acfrls, acdtls, acnxls

	dim  = MEM (array + adim )
	rank = MEM (array + arank)

	strds  = acallo (acmaxd)
        DO 10 i = 0, acmaxd - 1
          MEM (strds + i) = 0
 10     CONTINUE
	stride = 1
	node   = acfrls (rank)
	DO 20 i = 0, dim - 1
          index  = acdtls (node)
          desc   = MEM (index + idesc)
	  MEM (strds + desc) = stride
	  stride = stride * MEM (index + isize)
          node   = acnxls (node)
 20     CONTINUE

	MEM (array + abase) = base
	MEM (array + asite) = stride
	MEM (array + astrd) = strds
	base   = base + stride
      END

      SUBROUTINE accnfr (array)
      IMPLICIT NONE
      INTEGER array

C     Assign a ``configuration record'' for the given array.
C     Contents of a configuration record are
C
C	array_id, dimension, num_channels, base
C
C	FOREACH index in dimension
C	  desc, size, stride
C
C	FOREACH channel
C	  type, rank_size, remote_base
C	  FOREACH index in dimension
C	    if (is in rank) then remote_stride else null
C
C     (Going through this ``flat'' representation, containing
C     just the vital information, would allow an implementation where
C     all records are calculated centrally then distributed)

        INCLUDE 'aclmem.inc'
	INTEGER acallo
        INCLUDE 'acconf.inc'
	INTEGER dim, nchan
        INTEGER confl, confr, ptr, rank, node, strds, i, index
        INTEGER desc, chans, mode, j, chan, remote, chrnk
        INTEGER xid, remstr, junk
	INTEGER acfrls, acdtls, acnxls
        LOGICAL acinls

	dim   = MEM (array + adim )
	nchan = MEM (array + anchn)

        confl = 4 + (dim * 3) + (nchan * (3 + dim))
        confr = acallo (confl)

        MEM (confr + 0) = MEM (array + aname)
        MEM (confr + 1) = dim
        MEM (confr + 2) = nchan
        MEM (confr + 3) = MEM (array + abase)
        ptr = 4

        rank  = MEM (array + arank)
        node  = acfrls (rank)
        strds = MEM (array + astrd)
        DO 10 i = 0, dim - 1
          index = acdtls (node)
          desc  = MEM (index + idesc)
          MEM (confr + ptr + 0) = desc
          MEM (confr + ptr + 1) = MEM (index + isize)
          MEM (confr + ptr + 2) = MEM (strds + desc)
          ptr   = ptr + 3
          node  = acnxls (node)
 10     CONTINUE

        chans = MEM (array + achan)
        mode  = acfrls (chans)
        DO 30 j = 0, nchan - 1
          chan = acdtls (mode)
          IF (MEM (chan + cref1) .EQ. array) THEN
            remote = MEM (chan + cref2)
          ELSE
            remote = MEM (chan + cref1)
          ENDIF

          MEM (confr + ptr + 0) = MEM (chan + ctype)
          MEM (confr + ptr + 1) = MEM (chan + cdim )
          IF (remote .NE. anull) THEN
	    MEM (confr + ptr + 2) = MEM (remote + abase)
          ELSE
	    MEM (confr + ptr + 2) = -1
          ENDIF
          ptr   = ptr + 3

          chrnk  = MEM (chan + crank)
	  node  = acfrls (rank)
	  DO 20 i = 0, dim - 1
	    index = acdtls (node)

	    xid   = MEM (index + iname)
	    desc  = MEM (index + idesc)
	    IF (acinls (chrnk, xid, junk)) THEN
	      IF (remote .NE. anull) THEN
		remstr = MEM (remote + astrd)
		MEM (confr + ptr) = MEM (remstr + desc)
	      ELSE
		MEM (confr + ptr) = 0
	      ENDIF
            ELSE
              MEM (confr + ptr) = -1
            ENDIF
	    ptr   = ptr + 1

	    node  = acnxls (node)
 20       CONTINUE
	   
	  mode  = acnxls (mode)
 30     CONTINUE

	MEM (array + acnfl) = confl
	MEM (array + acnfr) = confr
      END

      INTEGER FUNCTION acibld (desc, size, base, stride)
      IMPLICIT NONE
      INTEGER desc, size, base, stride

C       Build an index structure.

        INCLUDE 'aclmem.inc'
	INTEGER acallo
	INCLUDE 'acids.inc'

	INTEGER coord, pids, remote, i

	coord = MOD ((local - base) / stride, size)
	pids  = acallo (size)

	DO 10 i = 0, size - 1
	  remote = local + (i - coord) * stride
	  MEM (pids + i) = MEM (procid + remote)
 10     CONTINUE

	CALL idefn (acibld, MEM (pids), desc, size, coord)
      END

      INTEGER FUNCTION accbld (type, remid, corsiz, corank)
      IMPLICIT NONE
      INTEGER type, remid, corsiz
      INTEGER corank (0 : corsiz - 1)

C       Build a distributed channel structure.

        INCLUDE 'aclmem.inc'
	INCLUDE 'acids.inc'

        CALL iodefn (accbld, type, MEM (procid + remid),
     1               corank, corsiz)
      END

      SUBROUTINE acparm (arrid, nchans, chans, dim, rank, cnfrec)
      IMPLICIT NONE
      INTEGER arrid, nchans, chans, dim, rank, cnfrec

C       Build communication structures from configuration record.

        INCLUDE 'aclmem.inc'
	INTEGER acallo
        INCLUDE 'acconf.inc'
	INTEGER acibld, accbld
	INTEGER icoord
	INTEGER ptr, base, desc, size, stride, type
	INTEGER rnksiz, corank, corsiz, rembas, remid, remstr, cptr
	INTEGER i, j

	arrid  = MEM (cnfrec + 0)
	dim    = MEM (cnfrec + 1)
	nchans = MEM (cnfrec + 2)
	base   = MEM (cnfrec + 3)
	ptr    = 4

	rank   = acallo (   dim)
	chans  = acallo (nchans)

        DO 10 i = 0, dim - 1
	  desc   = MEM (cnfrec + ptr + 0)
	  size   = MEM (cnfrec + ptr + 1)
	  stride = MEM (cnfrec + ptr + 2)
	  ptr    = ptr + 3
	  MEM (rank + i) = acibld (desc, size, base, stride)
 10     CONTINUE

	DO 30 j = 0, nchans - 1
	  type   = MEM (cnfrec + ptr + 0)
	  rnksiz = MEM (cnfrec + ptr + 1)
	  rembas = MEM (cnfrec + ptr + 2)
	  ptr    = ptr + 3

          corsiz = dim - rnksiz
	  corank = acallo (corsiz)

	  remid  = rembas
	  cptr   = 0
	  DO 20 i = 0, dim - 1
	    remstr = MEM (cnfrec + ptr)
	    ptr    = ptr + 1
	    IF (remstr .EQ. -1) THEN

C             Index is in corank

	      MEM (corank + cptr) = MEM (rank + i)
	      cptr = cptr + 1
	    ELSE

C             Index is in rank

              IF (remid .NE. -1)
     1          remid = remid + (remstr * icoord (MEM (rank + i)))
	    ENDIF
 20       CONTINUE

	  MEM (chans + j) = accbld (type, remid, corsiz, MEM (corank))
 30     CONTINUE
      END


C     The configuration routines proper, called by the user.


      SUBROUTINE acbegn ()
      IMPLICIT NONE

C       Start of configuration

        INCLUDE 'aclmem.inc'
        INCLUDE 'acconf.inc'

C       Calls to 'achost' flags whether we are on the host.  Otherwise
C       configuration error messages aren't reported.

	CALL achost ()

        IF (state .NE. sbegn) CALL acerr ('acbegn', 'out of order call')

        CALL acmkls (ilist)
        CALL acmkls (alist)
        CALL acmkls (clist)
        
        state = sdefn
      END

      SUBROUTINE acindx (name, size)
      IMPLICIT NONE
      INTEGER name, size

C       Configure an index (add it to the index list)

        INCLUDE 'aclmem.inc'
	INTEGER acallo
        INCLUDE 'acconf.inc'
        LOGICAL acinls
        INTEGER index, ptr

        CALL achost ()

        IF     (state .EQ. sbegn) THEN
          CALL acerr ('acindx', 'called before acbegn')
        ELSEIF (state .EQ. sdefn) THEN
          CONTINUE
        ELSEIF (state .EQ. sdone) THEN
          CALL acerr ('acindx', 'called after acdone')
        ENDIF

        IF (name .LT. 0) CALL acerr1 ('acindx', 
     1                     'illegal index identifier...%', name)
        IF (acinls (ilist, name, ptr)) CALL acerr1 ('acindx',
     1                   'index % multiply defined', name)

        index = acallo (irecl)
        MEM (index + iname) = name
        MEM (index + isize) = size

        CALL acadls (ilist, index)
      END

      SUBROUTINE acchan (name, dim, indxes)
      IMPLICIT NONE
      INTEGER name, dim
      INTEGER indxes (0 : dim - 1)

C       Configure a channel (add it to the channel list)

        INCLUDE 'aclmem.inc'
	INTEGER acallo
        INCLUDE 'acconf.inc'
        LOGICAL acinls
        INTEGER rank, xid, index, chan
        INTEGER i, ptr

	CALL achost ()

        IF     (state .EQ. sbegn) THEN
          CALL acerr ('acchan', 'called before acbegn')
        ELSEIF (state .EQ. sdefn) THEN
          CONTINUE
        ELSEIF (state .EQ. sdone) THEN
          CALL acerr ('acchan', 'called after acdone')
        ENDIF

        IF (name .LT. 0) CALL acerr1 ('acchan', 
     1                     'illegal channel identifier...%', name)
        IF (acinls (clist, name, ptr)) CALL acerr1 ('acchan',
     1                   'channel % multiply defined', name)

        CALL acmkls (rank)
        DO 10 i = 0, dim - 1
          xid = indxes (i)

          IF (.NOT. acinls (ilist, xid, index)) CALL acerr2 ('acchan',
     1        'undefined index % in rank of channel %', xid, name)
          IF (acinls (rank, xid, ptr)) CALL acerr2 ('acchan',
     1        'multiple instances of index % in rank of channel %',
     2        xid, name)

          CALL acadls (rank, index)
 10     CONTINUE

        chan = acallo (crecl)
        MEM (chan + cname) = name
        MEM (chan + cdim ) = dim
        MEM (chan + crank) = rank
        MEM (chan + cref1) = anull
        MEM (chan + cref2) = anull
        CALL acadls (clist, chan)
      END

      SUBROUTINE acarry (name, nchan, chans, dim, indxes)
      IMPLICIT NONE
      EXTERNAL name
      INTEGER nchan, dim
      INTEGER chans (0 : nchan - 1), indxes (0 : dim - 1)

C       Configure an array (add it to the array list)

        INCLUDE 'aclmem.inc'
	INTEGER acallo
        INCLUDE 'acconf.inc'
        LOGICAL acinls
	INTEGER acenum
        INTEGER rank, io, array
        INTEGER narry, i, cid, xid, chan, index, ptr

	CALL achost ()

        IF     (state .EQ. sbegn) THEN
          CALL acerr ('acarry', 'called before acbegn')
        ELSEIF (state .EQ. sdefn) THEN
          CONTINUE
        ELSEIF (state .EQ. sdone) THEN
          CALL acerr ('acarry', 'called after acdone')
        ENDIF

C       `narry' is a unique number reported in error messages to identify
C       this array.

        narry = acenum (alist)

        array = acallo (arecl)

        CALL acmkls (rank)
        DO 10 i = 0, dim - 1
          xid = indxes (i)

          IF (.NOT. acinls (ilist, xid, index)) CALL acerr2 ('acarry',
     1        'undefined index % in rank of array %', xid, narry)
          IF (acinls (rank, xid, ptr)) CALL acerr2 ('acarry',
     1        'multiple instances of index % in rank of array %',
     2        xid, narry)

          CALL acadls (rank, index)
 10     CONTINUE

        CALL acmkls (io)
        DO 20 i = 0, nchan - 1
          cid  = chans (i)

          IF (.NOT. acinls (clist, cid, chan)) CALL acerr2 ('acarry',
     1        'undefined channel % connected to array %', cid, narry)
          IF (acinls (io, cid, ptr)) CALL acerr2 ('acarry',
     1        'multiple instances of channel % connected to array %',
     2        cid, narry)

C         Save pointer to self in channel record
C         (Checking of rank compatibility of channels done elsewhere, later).

          IF     (MEM (chan + cref1) .EQ. anull) THEN
            MEM (chan + cref1) = array
          ELSEIF (MEM (chan + cref2) .EQ. anull) THEN
            MEM (chan + cref2) = array
          ELSE
            CALL acerr1 ('acarry',
     1             'channel % connected to more than two arrays', cid)
          ENDIF

          CALL acadls (io, chan)
 20     CONTINUE

	CALL catch (MEM (array + aname), name)
        MEM (array + anchn) = nchan
        MEM (array + achan) = io
        MEM (array + adim ) = dim
        MEM (array + arank) = rank
        CALL acadls (alist, array)
      END

      SUBROUTINE acdone ()
      IMPLICIT NONE

C       Do the configuration, given the array and channel lists:
C
C         1) Check channel usage.
C         2) Allocate index descriptors and channel ``types''.
C         3) Define placement---bases and strides for all arrays.
C         4) ``Initialise nodes''
C         5) Work out ``configuration record'' for local array.
C         6) Build communication structures and invoke user code.

        INCLUDE 'aclmem.inc'
        INCLUDE 'acconf.inc'
	INCLUDE 'acids.inc'

        INTEGER acfrls, acdtls, acnxls
        INTEGER acenum
        INTEGER node, chan
        INTEGER narry, nindx, nchan
	INTEGER nprocs, array
	INTEGER base, sites
	INTEGER cnfrec, arrid, dim, rank, nchans, chans

	CALL achost ()

        IF (state .EQ. sbegn) THEN
          CALL acerr ('acdone', 'called before acbegn')
        ELSEIF (state .EQ. sdefn) THEN
          state = sdone
        ELSEIF (state .EQ. sdone) THEN
          CALL acerr ('acdone', 'called twice')
        ENDIF

C       Check channel usage.

        node = acfrls (clist)
 10     IF (node .NE. NULL) THEN
          chan = acdtls (node)
          CALL acusag   (chan)
          node = acnxls (node)
          GOTO 10
	ENDIF

C       Allocate index descriptors and channel types.

        nindx = acenum (ilist)
        nchan = acenum (clist)
        narry = acenum (alist)

	IF (nindx .GT. acmaxd) CALL acerr ('acdone',
     1               'implementation limit---too many indices')

C       Allocate placements (bases and index strides for arrays).

        nprocs = 0
        node = acfrls (alist)
  20    IF (node .NE. NULL) THEN
	  array = acdtls (node)
	  CALL acplac (array, nprocs)
	  node  = acnxls (node)
	  GOTO 20
	ENDIF

C       Initialise nodes (including `acids' block).

	CALL acnode (nprocs)

C       Build configuration record for local array.

        node = acfrls (alist)
  30    IF (node .NE. NULL) THEN
	  array = acdtls (node)
	  base  = MEM (array + abase)
	  sites = MEM (array + asite)
	  IF ((base .LE. local) .AND. (local .LT. base + sites)) THEN
	    CALL accnfr (array)
	    cnfrec = MEM (array + acnfr)
	  ENDIF
	  node  = acnxls (node)
	  GOTO 30
	ENDIF

C       Build communication structures, and invoke user code

        CALL acparm (arrid, nchans, chans, dim, rank, cnfrec)
        CALL invoke (arrid, nchans, MEM (chans), dim, MEM (rank))
      END

