#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	README
#	blkjac.f
#	d_and_c.f
#	data
#	data.blkjac
#	data.ts_dynamic
#	example.f
#	ftsubs.f
#	ftsubs.graph.f
#	indx0.h
#	indxj.h
#	make1
#	makefile
#	maxparms.h
#	oldtest
#	putq.c
#	second.f
#	stuffspawn.f
#	testrun
#	ts_dynamic.f
# This archive created: Fri Sep 15 13:06:43 1989
export PATH; PATH=/bin:$PATH
if test -f 'README'
then
	echo shar: over-writing existing file "'README'"
fi
cat << \SHAR_EOF > 'README'
This package contains an enhanced version of the SCHEDULE Parallel
Programming Package for the Sun workstation.
By way of reusable or recycling queues, applications 
with the new ftsubs.f are now limited to 1000 active job processes,
rather than a 1000 cumulative job processes (see the new version of 
the demonstration program ts_dynamic.f that illustrates the use of 
the new SCHEDULE subroutine GETTAG and see the description below;
i.e. jobtags are now assigned by SCHEDULE instead of the user).

This new version of ftsubs.f now also permits iterations of static 
dependency graphs (see the example blkjac.f that illustrates the 
use of the new SCHEDULE subroutines RESET and RSCHED).

The new putq.c requires "include" files:  maxparms.h, indx0.h and indxj.h
(these may be easily changed from 20 to 60 parameters to allow an
increased number of parameters in the calls to sched, putq and spawn;
CAUTION:  there is usually more overhead in subroutine argument passing
than common argument passing, so rely more on common unless the job is
big enough to underwrite the extra overhead or subroutine arguments
can not be avoided).

This revised version of SCHEDULE is currently only available on the
Alliant, Balance, Symmetry, and Sun.

*******************************************************************************
READ THIS PART!!!
CAUTION:  The first two arguments of NXTAG and SPAWN are now 
reversed from older versions to make them consistent with the 
static dependency subroutines DEP and PUTQ.
*******************************************************************************

Caution:  Calls to SCHED, PUTQ and SPAWN, should include at
least one parameter in the argument list.

To build the libraries, type: 

"make sched" or "make graph"

     make sched will produce the schedule library in file sched.a .
           This is the standard libarary for schedule. All examples
           begining with 'x' use this library.

     make graph will produce the trace version of schedule in file graph.a .
           This version produces output which can be viewed using the
           Schedule Trace Facility. All examples begining with 'g' use
           this library.

To run the examples type:

"make xtest; xtest" or "make gtest; gtest"

     This will make and run a test program which solves a triangular
     system of equations using the spawning capabilities of schedule.

"make xdandc; xdandc" or "make gdandc; gdandc"

     This will make and run a test program which implements a recursive
     divide and conquer technique using the spawning capabilities of schedule.
     The output from gdandc will not work with the current trace facility
     because spawned processes also spawn other processes and the trace
     facility does not yet support more than one level of spawning.

"make xexample; xexample" or "make gexample; gexample"

     This will make and run a test program which computes the
     inner product of two vectors.

"make xts_tsdynamic; xts_dynamic" or "make gts_tsdynamic; gts_dynamic"

     This will make and run an example program illustrating use of the
     new SCHEDULE package with the triangular stuffer demonstration program;
     note especially the new subroutine GETTAG that gets a SCHEDULE generated
     job for each of the user's processes; note that the arguments of NXTAG
     and SPAWN have been reordered to be more like that of DEP and PUTQ.
     The input to ts_dynamic the form:
       [n_processors] [n_array_size] [n_work_iterations].
     There is a sample input file in data.ts_dynamic.

"make xblkjac; xblkjac" or "make gblkjac; gblkjac"

     This will make and run asample FORTRAN static iteration driver
     for ftsubs.f with block Jacobi iteration of a variable coefficient EPDE;
     The input has the form:
        [n_processors] [n_x_size] [n_y_size] [n_x_blocks]
        [n_y_blocks] [max_iterations] [n_result_precision].
     There is a sample input file in data.blkjac.
     Up to 10 X 10 blocks are permitted. The new SCHEDULE subroutine RSET
     marks processes that will take part in an iteration. Another new
     SCHEDULE subroutine RSCHED restores only those parameters, such as
     ICANGO, that have changed; NSLOTS have been increased to 105 to permit
     at most 10 X 10 block iterations.

A complete make and test can be carried out by doing:

testrun >& testout
diff oldtest testout
SHAR_EOF
if test -f 'blkjac.f'
then
	echo shar: over-writing existing file "'blkjac.f'"
fi
cat << \SHAR_EOF > 'blkjac.f'
      program blkjac
c
Code Name:  blkjac.f  (STATIC VERSION)
Code Data Input:  [n_processors] [n_x_size] [n_y_size] [n_x_blocks] [n_y_blocks]
Continued Input (single line assumed):  [max_iterations] [n_result_precision]
Change:  Block Jacobi test for SCHEDULE rsched to restore STATIC & DYNAMIC
cont: dependency graph for the next iteration.
      implicit real*8 (a-h,o-z)
      parameter(mdim=102, ndim=102, maxblk=11, maxprc=8)
      parameter(xmax1=100.d0,ymax1=100.d0,tol1=0.5d-4)
      parameter(nmyck=10*maxblk)
      parameter(mxprcs = 1000)
      integer itmp(maxblk),jtmp(maxblk),mychkn(nmyck),statag(mdim,ndim)
      integer itag(mxprcs)
      real t1,t2,t3,tt,second,foo
      real*8 u(mdim,ndim),v(mdim,ndim)
      common /comint/ m,n,mb,nb,mbpts,nbpts,niter,mxiter,idone
      common /comdat/ xmax,ymax,dx,dy,tol,uvdiff
Caution:  common block CONWRT is used in SCHEDULE for concurrent prints.
      COMMON /CONWRT/ WRLOCK
      EXTERNAL PARALG
      read(5,*) nprocs,m,n,mb,nb,mxiter,nprec
      write(6,6666) nprocs,m,n,mb,nb,mxiter,nprec
6666  format(' Static Block Jacobi Input:'
     & /3x,'nprocs =',i3,'; (m,n) = (',i4,',',i4
     & ,'); (mblks,nblks) = (',i3,',',i3
     & ,')'/3x,'; max iterations =',i6,'; nprec =',i3)
      mbpts = m/mb
      nbpts = n/nb
      tol = 0.5d0/10**nprec
      write(6,6667) mdim,ndim,maxblk,maxprc,nmyck,mbpts,nbpts
     & ,xmax1,ymax1,nprec,tol
6667  format('  Parameter input:'/3x,'(mdim,ndim) = (',i4,',',i4
     &  ,'); maxblkdim = ',i4
     &  /3x,'; maxprc =',i3,'; nmychk =',i6,'; (mbpts,nbpts) = ('
     &  ,i4,',',i4,')'
     &  /3x,' (xmax,ymax) = (',f7.2,',',f7.2,'); nprec =',i2
     &  ,'( tol =',d11.4,')')
c
      if(m.gt.(mdim-2).or.n.gt.(ndim-2).or.mb.gt.maxblk.or.nb.gt.maxblk
     &   .or.nprocs.gt.maxprc.or.nprocs.lt.1.or.mb*nb.gt.100) 
     &   then
         write(6,6668) mdim,ndim,maxblk,m,n,mb,nb,nprocs,mxiter
6668     format('  Improper inputs with limits exceeded; input was:'
     &   ' mdim =',i5,'; ndim =',i5,'; maxblk =',i5
     &     /' m =',i5,'; n =',i5,';mb =',i5,';nb =',i5
     &     /' nprocs =',i5,'; max iterations =',i5)
         write(6,*) 'S T O P   E X E C U T I O N   I N    M A I N'
         stop
      endif
c
      xmax = xmax1
      ymax = ymax1
c 
      do 10 ib = 1,mb
10      itmp(ib) = ib 
      do 11 jb = 1,nb
11      jtmp(jb) = jb 
c
c:  remove second.f timer
       t1 = second(foo)
       t2 = second(foo)
c
      CALL SCHED(nprocs,paralg,mdim,ndim,itmp,jtmp,itag,statag,mychkn
     &    ,u,v)
c
        t3 = second(foo)
        tt = t3-t2-(t2-t1)
c
c     output
c
      amstep = amax1(m/10.,1.)
      anstep = amax1(n/10.,1.)
      mtop = min0(m+1,11)
      ntop = min0(n+1,11)
      do 1002 i = 1,mtop
1002  itmp(i) = 1 + (i-1)*amstep + .5
      do 1003 j = 1,ntop
1003  jtmp(j) = 1 + (j-1)*anstep + .5
      write(6,1001) (itmp(i),i = 1,mtop),m+2 
      j = n+2
             write(6,1000) j,(u(itmp(i),n+2),i = 1,mtop),u(m+2,n+2)
      do 100 k = 1,ntop
             j = jtmp(ntop+1-k)
             write(6,1000) j,(u(itmp(i),j),i = 1,mtop),u(m+2,j)
100   continue 
1000    format(i4,2x,12f5.2)
1001    format('  Static Block Jacobi -'
     &        ,' Iteration SCHEDULE Final Results:'
     &      /3x,'j/i',12i5)
c
      mxjobs = 1+niter*(1+mb*nb+2)+1
      if(nprocs.eq.1) write(6,664) mb,nb,niter,mxiter
664   format(' #  Static Block Jacobi Schedule rsched & gettag & name '
     &    ,'program'
     &      /' #  ftsubs.f for iterated circular readyq & parmq & '
     &    ,'freeq version'
     &      /' #  with mblks, nblks =',2i5'; niter =',i8,'; mxiter=',i8)
      write(6,665) nprocs,tt
665   format(' #',i2,f12.5)
      write(*,666) m,n,mb,nb,niter,nprocs,mxjobs,tt,uvdiff
666   format(9x,'code',7x,'m',7x,'n',3x,'mblks',3x,'nblks',3x,'niter'
     &  ,2x,'nprocs',1x,'maxjobs'
     &  /1x,'BLOCK-JACOBI',7i8
     &  /1x,'STATIC VERSION',5x,'seconds =',f12.5,'; uvdiff =',d12.5)
      if(uvdiff.ge.tol) write(6,667) niter,mxiter,uvdiff,tol
667   format(3x,'Iteration UNSUCCESSFUL:  niter =',i6, ' & mxiter ='
     &    ,i6/5x,'while uvdiff =',d12.5,' .GE. tol = ',d12.5)
c
      stop
      end
c
      subroutine paralg(mdim,ndim,itmp,jtmp,itag,statag,mychkn
     &    ,u,v)
      parameter(mxprcs = 1000)
      implicit real*8 (a-h,o-z)
      integer m,n,mb,nb,statag(mdim,*),mychkn(*),itmp(*),jtmp(*)
      integer itag(mxprcs)
      integer jobtag,initag,strtag,cnvtag,testag,stptag
      real*8 u(mdim,*),v(mdim,*)
      common /comint/ m,n,mb,nb,mbpts,nbpts,niter,mxiter,idone
      common /comdat/ xmax,ymax,dx,dy,tol,uvdiff
      EXTERNAL INIT,STARTT,JACOBI,CONVRG,TEST,STOPIT
c
c     this is the parallel driver for the iterated dependency graph
c
c     first, get all static job tags necessary to construct the 
c     dependency graph.
c
CAUTION:  At this point, execution is in parallel because sub paralg 
CAUTION:  and its args are only passed to SCHEDULE by sub sched and is
CAUTION:  executed in concurrent mode by a copy of the sub work.
CAUTION:  It is essential that all subsequent sub args must be global
CAUTION:  variables, such as itag, statag, itmp and jtmp, else values
CAUTION:  passed will not be protected from concurrent overwrite.
c 
      CALL GETTAG(initag)
      itag(initag) = initag
      CALL GETTAG(strtag)
      itag(strtag) = strtag
      do 100 jb = 1,nb
         do 100 ib = 1,mb
Caution:  statag(ib,jb) gets the static job tag 
cont:  for the block (ib,jb).
            CALL GETTAG(statag(ib,jb))
100   continue
      CALL GETTAG(cnvtag)
      itag(cnvtag) = cnvtag
      CALL GETTAG(testag)
      itag(testag) = testag
      CALL GETTAG(stptag)
      itag(stptag) = stptag
c
            jobtag = itag(initag)
            icango =  0
            nchks = 1
            nreset = 0
            mychkn(1) = itag(strtag)
c
CAUTION:  PUTQ does not call INIT, but only passes its name and args to
CONT: SCHEDULE.
c
            CALL name(jobtag,' init')
            CALL DEP(jobtag,icango,nchks,mychkn)
            CALL PUTQ(jobtag,init,itag(initag),mdim,u)
c
            jobtag = itag(strtag)
            icango =  1
            nchks = mb*nb
Comment:  Here nreset = 2 is used as the iteration set number,
cont:  but it may be any nonzero integer.
            nreset = 2
      do 201 jb = 1,nb
            do 201 ib = 1,mb
            mychkn(ib+mb*(jb-1)) = statag(ib,jb)
201   continue
c
            CALL name(jobtag,'startt')
            CALL DEP(jobtag,icango,nchks,mychkn)
            CALL RESET(jobtag,nreset)
            CALL PUTQ(jobtag,startt,itag(strtag),mdim,u,v)
c
      do 301 jb = 1,nb
            do 301 ib = 1,mb
            jobtag = statag(ib,jb)
            icango =  1
            nchks = 1
            nreset = 2
            mychkn(1) = itag(cnvtag)
c
            CALL name(jobtag,'jacobi')
            CALL DEP(jobtag,icango,nchks,mychkn)
            CALL RESET(jobtag,nreset)
CAUTION:  Make certain that global variables like itmp are passed as
cont: arguments of subroutines that are passed to Schedule.
            CALL PUTQ(jobtag,jacobi,statag(ib,jb),mdim
     &               ,itmp(ib),jtmp(jb),u,v)
301   continue
c
            jobtag = itag(cnvtag)
            icango = mb*nb
            nchks = 1
            nreset = 2
            mychkn(1) = itag(testag)
c
            CALL name(jobtag,'convrg')
            CALL DEP(jobtag,icango,nchks,mychkn)
            CALL RESET(jobtag,nreset)
            CALL PUTQ(jobtag,convrg,itag(cnvtag),mdim,u,v)
c
            jobtag = itag(testag)
            icango = 1
            nchks = 1
            nreset = 2
            mychkn(1) = itag(stptag)
c
            CALL name(jobtag,'  test')
            CALL DEP(jobtag,icango,nchks,mychkn)
            CALL RESET(jobtag,nreset)
            CALL PUTQ(jobtag,test,itag(testag),itag(strtag)
     &          ,itag(stptag))
c
            jobtag = itag(stptag)
            icango =  1
            nchks = 0
            nreset = 0
c
            CALL name(jobtag,'stopit')
            CALL DEP(jobtag,icango,nchks,mychkn)
            CALL PUTQ(jobtag,stopit,itag(stptag))
c
      return
      end
c
           subroutine init(initag,mdim,u)
      implicit real*8 (a-h,o-z)
      real*8 u(mdim,*)
      integer initag,mdim,m,n
      common /comint/ m,n,mb,nb,mbpts,nbpts,niter,mxiter,idone
      common /comdat/ xmax,ymax,dx,dy,tol,uvdiff
      niter = 0
      dx = xmax/(m+1)
      dy = ymax/(n+1)
      do 200 i = 1,m+2
         x = (i-1)*dx
         u(i,1) = (x/xmax)**2
         u(i,n+2) = 0.5*(1+(x/xmax)**2)
200   continue
      do 300 j = 2,n+1
         y = (j-1)*dy
         u(1,j)= 0.5*(y/ymax)**3
         u(m+2,j) = 1.0
300   continue
      do 100 j = 2,n+1
         do 100 i = 2,m+1
            u(i,j) = ((n+2-j)*u(i,1)+(j-1)*u(i,n+2))/(n+1)
100   continue
	  mstep=m/10
	  nstep=n/10
      return
      end
           subroutine startt(strtag,mdim,u,v)
      implicit real*8 (a-h,o-z)
      integer strtag,mdim,m,n
      real*8 u(mdim,*),v(mdim,*)
      common /comint/ m,n,mb,nb,mbpts,nbpts,niter,mxiter,idone
      common /comdat/ xmax,ymax,dx,dy,tol,uvdiff
Code:  saves current node values and is restarting point for iterations.
      niter = niter + 1
      do 100 j = 1,n+2
         do 100 i = 1,m+2
            v(i,j) = u(i,j)
100   continue
      return
      end
           subroutine jacobi(statag,mdim,ib,jb,u,v)
      implicit real*8 (a-h,o-z)
      integer statag,mdim,m,n,mb,nb,ib,jb
      real*8 u(mdim,*),v(mdim,*)
      common /comint/ m,n,mb,nb,mbpts,nbpts,niter,mxiter,idone
      common /comdat/ xmax,ymax,dx,dy,tol,uvdiff
      r = dy/dx
      do 100 js = 1,nbpts
         j = js + 1 + nbpts*(jb-1)
         y = (j-1)*dy
         do 100 is = 1,mbpts
            i = is + 1 + mbpts*(ib-1)
            x =  (i-1)*dx
            a = 1.d0/dsqrt(1.d0+x**2+y**2)
            b = dexp(-x**2 -y**2)
            den = 2*(r**2*a + b)
            u(i,j) = (r**2*a*(v(i+1,j)+v(i-1,j)) 
     &             + b*(v(i,j+1)+v(i,j-1)))/den
100   continue
	  mstep=m/10
	  nstep=n/10
Code:  computes Block Jacobi updates for block (ib,jb)
      return
      end
           subroutine convrg(cnvtag,mdim,u,v)
      implicit real*8 (a-h,o-z)
      integer cnvtag,mdim,m,n,idone
      real*8 u(mdim,*),v(mdim,*)
      common /comint/ m,n,mb,nb,mbpts,nbpts,niter,mxiter,idone
      common /comdat/ xmax,ymax,dx,dy,tol,uvdiff
Code:  computes the Cauchy Convergence crierion in the inf-norm and
cont:  passes the flag idone as 0 for reset and 1 for stop
      uvdiff = 0
      do 100 j = 2,n+1
         do 100 i = 2,m+1
            dumax = abs(u(i,j)-v(i,j))
            if(dumax.gt.uvdiff) uvdiff = dumax
100   continue
      if(uvdiff.lt.tol.or.niter.ge.mxiter) then
         idone = 1
      else
         idone = 0
      endif
c
      return
      end
            subroutine test(testag,strtag,stptag)
      implicit real*8 (a-h,o-z)
      integer testag,strtag,stptag,reset
      common /comint/ m,n,mb,nb,mbpkts,nbpts,niter,mxiter,idone
      common /comdat/ xmax,ymax,dx,dy,tol,uvdiff
CTERM      INTEGER WRLOCK
CTERM      COMMON /CONWRT/ WRLOCK
      if(idone.eq.0) then
Comment:  If iteration is unfinished, Reset SCHEDULE sub RSCHED is called 
Cont:  and my check in is changed to iteration start tag strtag.
Comment:  In this example, the iteration set integer is 2.
            kreset = 2
            CALL RSCHED(testag,strtag,kreset)
      else
Comment:  Else, reset my check in to the iteration stop tag stptag.
            kreset = 0
            CALL RSCHED(testag,stptag,kreset)
      endif
      return
      end
           subroutine stopit(stptag)
      integer stptag
      continue
	  return
      end
SHAR_EOF
if test -f 'd_and_c.f'
then
	echo shar: over-writing existing file "'d_and_c.f'"
fi
cat << \SHAR_EOF > 'd_and_c.f'
      integer a(256),klevl(8),myid(256)
      external top
      write(6,*) ' input nprocs nlevls '
      read (5,*) nprocs,nlevls
      do 50 j = 1,8
         klevl(j) = j
   50 continue
      call sched(nprocs,top,a,nlevls,klevl,myid)
      do 100 j = 1,2**nlevls-1
         write(6,*) a(j)
  100 continue
      stop
      end
      subroutine top(a,nlevls,klevl,myid)
      integer a(*),klevl(*),myid(*)
      character*6 subnam
      external split
c      write(6,*) ' from top ' , a(1)
      call gettag(jobtag)
      icango = 0
      nchks = 0
      myid(1) = jobtag
      a(1) = 1
c
      subnam = 'split'
      call name(jobtag,subnam)
      call dep(jobtag,icango,nchks,mychkn)
      call putq(jobtag,split,myid,a,nlevls,klevl)
c
      return
      end
      subroutine split(myid,a,nlevls,klevl)
      integer a(*),klevl(*),myid(*),rnode
      external clone
      character*6 subnam
c      write(6,*) ' from split ',a(1)
c
      if (klevl(1) .ge. nlevls) return
c
      lnode = 2*a(1)
      rnode = lnode + 1
      indx = lnode - a(1) + 1
      a(indx) = lnode
      a(indx+1) = rnode
      mytag = myid(a(1))
c
      call gettag(jobtag)
      subnam = 'split'
      call name(jobtag,subnam)
      call nxtag(jobtag,mytag)
      myid(lnode) = jobtag
      call spawn(jobtag,mytag,clone,myid,a(indx),nlevls,klevl(2))
c
      call gettag(jobtag)
      subnam = 'split'
      call name(jobtag,subnam)
      call nxtag(jobtag,mytag)
      myid(rnode) = jobtag
      call spawn(jobtag,mytag,clone,myid,a(indx+1),nlevls,klevl(2))
c
      return
      end
SHAR_EOF
if test -f 'data'
then
	echo shar: over-writing existing file "'data'"
fi
cat << \SHAR_EOF > 'data'
1
3
SHAR_EOF
if test -f 'data.blkjac'
then
	echo shar: over-writing existing file "'data.blkjac'"
fi
cat << \SHAR_EOF > 'data.blkjac'
1 100 100 10 10 100 2
SHAR_EOF
if test -f 'data.ts_dynamic'
then
	echo shar: over-writing existing file "'data.ts_dynamic'"
fi
cat << \SHAR_EOF > 'data.ts_dynamic'
1 43 1000
SHAR_EOF
if test -f 'example.f'
then
	echo shar: over-writing existing file "'example.f'"
fi
cat << \SHAR_EOF > 'example.f'
      program main
      integer n, k
c
      external parprd
c
      real a(1000), b(1000), temp(50), sigma
      write (6,*) 'Input number of processors'
      read (5,*) nprocs
      n = 1000
      k = 20
c
      do 100 j = 1, n
        a(j) = j
        b(j) = 1
100   continue
c
      call sched(nprocs, parprd, n, k, a, b, temp, sigma)
c
      write (6,*) ' sigma = ', sigma
      stop
      end
c
      subroutine parprd(n, k, a, b, temp, sigma)
c
      integer n, k
      real a(*), b(*), temp(*), sigma
c
      integer m1, m2, index, j, jobtag, icango, ncheks, mychkn(2)
      integer itags(500)
c
      character*6 subnam
      external inprod, addup
      save m1, m2
c
      do 150 j = 1, k + 1
        call gettag(jobtag)
        itags(j) = jobtag
 150  continue
c
      m1 = n/k
      index = 1
      do 200 j = 1, k - 1
        jobtag = itags(j)
        icango = 0
        ncheks = 1
        mychkn(1) = itags(k + 1)
        subnam = 'inprod'
        call name(jobtag,subnam)
        call dep(jobtag, icango, ncheks, mychkn)
        call putq(jobtag, inprod, m1, a(index), b(index), temp(j))
        index = index + m1
200   continue
c
      m2 = n - index + 1
      jobtag = itags(k)
      icango = 0
      ncheks = 1
      mychkn(1) = itags(k + 1)
      subnam = 'inprod'
      call name(jobtag,subnam)
      call dep(jobtag, icango, ncheks, mychkn)
      call putq(jobtag, inprod, m2, a(index), b(index), temp(k))
      index = index + m1
c
      jobtag = itags(k + 1)
      icango = k
      ncheks = 0
      subnam = 'addup'
      call name(jobtag,subnam)
      call dep(jobtag, icango, ncheks, mychkn)
      call putq(jobtag, addup, k, sigma, temp)
c
      return
      end
c
c
      subroutine inprod(m, a, b, sigma)
      integer m
      real a(*), b(*), sigma
      sigma = 0.0
      do 100 j = 1, m
        sigma = sigma + a(j)*b(j)
100   continue
      return
      end
c
c
      subroutine addup(k, sigma, temp)
      integer k
      real sigma, temp(*)
      sigma = 0.0
      do 100 j = 1, k
        sigma = sigma + temp(j)
100   continue
      return
      end
SHAR_EOF
if test -f 'ftsubs.f'
then
	echo shar: over-writing existing file "'ftsubs.f'"
fi
cat << \SHAR_EOF > 'ftsubs.f'
      subroutine chekin(jobtag)
Comment:  integrated iteration version of ftsubs.f and ftsubs.iter.f
cont:  with option to iterate a set of nodes with reset dependencies.
Comment:  combined graphics and terminal trace version of ftsubt.f
Code parent: alliant:/afs1/hanson/dirsched/ftsubs.f
change(1):  iprcs = 200 <- 120;
change(2):  automatic return stmt removed out of loop do 20 in chekin;
change(3):  installed vector-circular ready queue,
cont:  vector <= nproc sub-qs, elastic with nproc processors;
cont:  circular <= readyq free space wraps around from rtail to rhead,
cont:  with the top end of readyq connected to the bottom end;
cont:  ready(rhead(id)+ndmrsq*(id-1)) <- readyq(rhead(id),id);
cont:  most mxces replaced by nprocc = nproc = no. sub-qs;
cont:  ldimrq = leading dim of readyq = iprcs*mxces
cont:  ndmrsq = dim of a ready-sub-q = ldimrq/nproc
cont:  idrsq = id of ready-sub-q <- iwrkr; dummy iw used in do's;
cont:  installed SCHED ERROR flags for readyq over-runs (mtail cond.);
cont:  round robin test in getprb reduced to single statement.
Change:  corrected next in nxtag & intspn in start2 to recover lost tag.
CAUTION:  nxtag and spawn arguments are consistent with dep and putq 
cont:  now, but order of arguments may not be consistent with older 
cont:  versions of ftsubs.f.
Change(4): installed circular parm queue, jobtag is the circular 
cont:  (reusable) job tag with 1.le.jobtag.le.mxprcs, 
cont:  snext is the schedule or sum or cumulative jobtag.
Change(5):  install super next tag, whereby user gets schedule job tags
cont:  from new schedule sub gettag;  hence schedule has no knowledge
cont:  of user tags and consequently the principal restriction on user
cont:  is that there be less than "mxprcs" undone jobs at any time.
cont:  integer array "unitag" keeps a unique job tag for undone jobs.
Change(6):  install rest and save arrays for jobtags that will be 
cont:  iterated more than once with original dependencies:  ireset, 
cont:  icnsav.  install sub rsched to reset icangoes 
cont:  and call sub place on iteration.
Change(6a):  nslots = 105 <- 30 to handle multiple dependencies.
Change(7):  installed common block CONWRT with key WRLOCK for concurrent
cont:  writes for use in both ftsubs.f and the user's driver code.
Change(8):  installed c-include indx*.h files to enable the passing of
cont:  up to 60 parameters with sched, putq and spawn calls (via m. 
cont:  johnson, ssi).
Change(9):  installed lock initializations in libopn to make porting
cont:  to other machines without automatic variable initialization.
CAUTION:  subroutine second uses machine dependent timer, which must be 
cont:  changed when porting to other machines.
cgraphChange:  install write nproc in sub libopn.
cgraphChange:  installed extra traces in chekin & place.
cgraphChange:  replaced qlock(mxprcs) by glock as igraph's own lock.
cgraphChange:  installed process names for Dongarra/Brewer's sched.trace.
cgraphChange(8):  cgraph lines made compatible for SCHED.TRACE/sched.trace.
cgraphcdirectory:  /usr/alcaid/brewer/SCHED.TRACE/sched.trace
cgraphcomment:  for graphics trace, change 'cgraph' to null '' and run.
ctermComment:  for terminal trace, change 'cterm' to null '' and run.
Change(9): Conversion of ftsubs.f to run on Sun
cont: Change parameter "mxces" from 8 to 1.
cont: Change parameter "iprcs" from 200 to 1000.
cont: Add routines lckasn, lockon, lockoff, & nops.
CVD$R NOCONCUR
      integer jobtag
c***********************************************************************
c
c     this subroutine reports unit of computation labeled by 
c     jobtag has completed to all dependent nodes.  these nodes are 
c     recorded in parmq(i,jobtag)  where 6 .le. i .le. nchks+5
c     checkin consists of decrementing the value in each of these
c     locations by 1.  each of these is done in a critical section
c     protected by qlock(jobtag)
c
c     if the value in parmq(2,jobtag) is 0 where jobtag is a process
c     dependent upon this one then jobtag is placed on the readyq
c     by entering the critical section protected by trlock.  the
c     pointer rtail to the tail of the readyq is  incremented
c     unless task done is to be recorded.  task done is placed on
c     the ready q and the pointer rtail left in place if nchks .eq. 0
c     is found. 
c
c     see the common block description in libopn for more detail.
c     
c***********************************************************************
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
Caution:  common block CONWRT is used for concurrent writes,
cont:  with WRLOCK as the key to the LOCK.
      INTEGER WRLOCK
      COMMON /CONWRT/ WRLOCK
cgraph      integer endgrf
cgraph      integer glock
cgraph      real igraph
cgraph      character*6 names,gnames
cgraph      common /calls/ names(mxprcs)
cgraph      common /gphnam/ gnames(nbuffr)
cgraph      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c
c     common block description:
c
c     a complete common block description is given in the routine libopn
c
c****************************************************************************
c
c     check to see if this process has completed.  if not do not checkin
c
      mtail = 0
	  idrsq = 0
c
c     first ask if any kids spawned by jobtag 
c
      if (parmq(4,jobtag) .ne. 0 .or. parmq(5,jobtag) .ne. 0 ) then
c
c          either kids have been spawned or ientry has been referenced
c          indicating reentry is required
c
c
c          find out how many are waiting to complete
c
         if (parmq(4,jobtag) .ne. 0) then
            call lockon(qlock(jobtag))
               parmq(2,jobtag) = parmq(2,jobtag) - parmq(4,jobtag)
            call lockoff(qlock(jobtag))
         endif
c
c          reset number of kids
c
         parmq(4,jobtag) = 0
c
c          update the number of times this procedure has been
c          entered
c
         parmq(1,jobtag) = parmq(1,jobtag) + 1
c
c          return without checkin if all the kids have not 
c          checked in to jobtag yet or if a reentry is required.  
c          process jobtag is not done in either case.
c
comment:  extra trace data.
         if (parmq(2,jobtag) .ne. 0) then
cgraph            call lockon(glock)
cgraph                  if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cgraph                  insrt = endgrf
cgraph                  endgrf = endgrf + 1
cgraph            call lockoff(glock)
cgraph            inext = unitag(jobtag)
cgraph            if (inext .ge. intspn) then
cgraphc  trace for chekin/child (entry_flag.ne.0.or.nkids.ne.0 & icango.ne.0)
cgraph               igraph(1,insrt) = 7
cgraph               igraph(2,insrt) = parmq(6,jobtag)
cgraph               igraph(3,insrt) = inext
cgraph               igraph(4,insrt) = second(foo)
cgraph            else
cgraphc  trace for chekin/parent (entry_flag.ne.0.or.nkids.ne.0 & icango.ne.0)
cgraph               igraph(1,insrt) = 6
cgraph               igraph(2,insrt) = inext
cgraph               igraph(3,insrt) = second(foo)
cgraph            endif
            return
         endif 
c
c        if ientry has been called but jobtag is not waiting
c        on any kids then jobtag is placed back on the readyq
c
         if ( parmq(5,jobtag) .ne. 0) then    
            idrsq = mod((jobtag-1),nprocc) + 1
            call lockon(trlock(idrsq))
               if(mod(rtail(idrsq),ndmrsq) + 1 .ne. rhead(idrsq)) then
                  readyq(rtail(idrsq)+ndmrsq*(idrsq-1)) = jobtag
                  rtail(idrsq) = mod(rtail(idrsq),ndmrsq) + 1
               else
                  mtail = -1
               endif
            call lockoff(trlock(idrsq))
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm            inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for chekin/child (entry_flag.ne.0 & icango=0 & nkids=0)
cterm               igraph(1,insrt) = 10
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(8,jobtag)
cterm               igraph(4,insrt) = idrsq
cterm               igraph(5,insrt) = rhead(idrsq)
cterm               igraph(6,insrt) = rtail(idrsq)
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for chekin/parent (entry_flag.ne.0 & icango=0 & nkids=0)
cterm               igraph(1,insrt) = 9
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = rhead(idrsq)
cterm               igraph(5,insrt) = rtail(idrsq) 
cterm               igraph(6,insrt) = parmq(8,jobtag)
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            endif
            return
         endif
      endif
c
c     the process has completed so chekin proceeds
c
cgraph      call lockon(glock)
cgraph            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cgraph            insrt = endgrf
cgraph            endgrf = endgrf + 1
cgraph      call lockoff(glock)
cgraph      inext = unitag(jobtag)
cgraph            if (inext .ge. intspn) then
cgraphc  trace for chekin/child (entry_flag.eq.0 & nkids = 0)
cgraph               igraph(1,insrt) = 5
cgraph               igraph(2,insrt) = parmq(6,jobtag)
cgraph               igraph(3,insrt) = inext
cgraph               igraph(4,insrt) = second(foo)
cgraph               gnames(insrt) = names(jobtag)
cgraph            else
cgraphc  trace for chekin/parent (entry_flag.eq.0 & nkids = 0)
cgraph               igraph(1,insrt) = 2
cgraph               igraph(2,insrt) = inext
cgraph               igraph(3,insrt) = second(foo)
cgraph               gnames(insrt) = names(jobtag)
cgraph            endif
c
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for chekin/child (entry_flag.eq.0 & nkids = 0)
cterm               igraph(1,insrt) = 5
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(6,jobtag)
cterm               igraph(4,insrt) = idrsq
cterm               igraph(5,insrt) = jobtag
cterm               igraph(6,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for chekin/parent (entry_flag.eq.0 & nkids = 0)
cterm               igraph(1,insrt) = 2
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = jobtag
cterm               igraph(5,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            endif
c
c
      if (mtail .lt. 0) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      user attempt  to create too many processes'
         write(6,*) '      exceeding the space in a single sub-queue'
         write(6,*) '      the maximum allowed is ',ndmrsq,' per sub-q'   
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine CHEKIN'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
c
      nchks = parmq(3,jobtag)
c
c     if this is the final process (indicated by nchks .eq. 0) then
c     record task done.  do not advance the tail so task done sequence
c     is set.  all subsequent gtprb queries will leave rhead .eq. rtail
c     with readyq(rhead+ndmrsq*(i-1)) .eq. done.
c
      if (nchks .eq. 0) then 
         do 20 iw = 1,nprocc
            call lockon(trlock(iw))
               readyq(rtail(iw)+ndmrsq*(iw-1)) = done
            call lockoff(trlock(iw))
   20    continue
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for chekin/child (nchks.eq.0 & nkids=0 & entry_flag=0)
cterm               igraph(1,insrt) = 12
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(6,jobtag)
cterm               igraph(4,insrt) = idrsq
cterm               igraph(5,insrt) = rhead(idrsq)
cterm               igraph(6,insrt) = rtail(idrsq)
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for chekin/parent (nchks.eq.0 & nkids=0 & entry_flag=0)
cterm               igraph(1,insrt) = 11
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = rhead(idrsq)
cterm               igraph(5,insrt) = rtail(idrsq)
cterm               igraph(6,insrt) = parmq(6,jobtag)
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            endif
Change(2):  removed following return from end of above loop do 20.
            return
      endif
      do 50 j = 6,nchks+5
         mychek = parmq(j,jobtag)
c                  
c     get unique access to the checkin node mychek
c     and checkin by decrementing the appropriate counter
c
         mchkgo = 1
         call lockon(qlock(mychek))
            parmq(2,mychek) = parmq(2,mychek) - 1
            mchkgo = parmq(2,mychek)
         call lockoff(qlock(mychek))
c
c     place mychek on readyq if parmq(2,mychek) is 0
c
         if (mchkgo .eq. 0 ) then
            idrsq = mod((mychek-1),nprocc) + 1
            call lockon(trlock(idrsq))
               if(mod(rtail(idrsq),ndmrsq) + 1 .ne. rhead(idrsq)) then
                  readyq(rtail(idrsq)+ndmrsq*(idrsq-1)) = mychek
                  rtail(idrsq) = mod(rtail(idrsq),ndmrsq) + 1
               else
                  mtail = -1
               endif
            call lockoff(trlock(idrsq))
         endif
   50 continue
c
c     place finished process at the end of the free list freeq
c     provided it will not be reset for another iteration.
c
      if(ireset(jobtag).eq.0) then
         call lockon(tflock)
            ftail = mod(ftail,mxprcs) + 1
            if(fhead.eq. ftail) free = 0
            freeq(ftail) = jobtag
         call lockoff(tflock)
      endif
c
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for chekin/child (nchks.ne.0 & nkids=0 & entry_flag=0)
cterm               igraph(1,insrt) = 8
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(6,jobtag)
cterm               igraph(4,insrt) = idrsq
cterm               igraph(5,insrt) = fhead
cterm               igraph(6,insrt) = ftail
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for chekin/parent (nchks.ne.0 & nkids=0 & entry_flag=0)
cterm               igraph(1,insrt) = 7
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = fhead
cterm               igraph(5,insrt) = ftail
cterm               igraph(6,insrt) = parmq(6,jobtag)
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            endif
c
      if (mtail .lt. 0) then
         write(6,*) '*************SCHED LIMIT ERROR********************'
         write(6,*) '      user attempt  to create too many processes'
         write(6,*) '      exceeding the space in a single sub-queue'
         write(6,*) '      the maximum allowed is ',ndmrsq,' per sub-q'   
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine CHEKIN'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
c
      if ( free .eq. 0 ) then
         call lockon(WRLOCK)
         inext = unitag(jobtag)
         write(6,*) '*************SCHED ERROR*************************'
         write(6,*) '     more processes have checked into sub chekin,'
         write(6,*) '     than should be active for free slots in the'
         write(6,*) '     parmq parameter queue.  jobs are too many.'
         write(6,*) ' total number of jobtags were:',inext 
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine CHEKIN'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         call lockoff(WRLOCK)
         stop
c
      endif
c
      return
c
c     last card of chekin
c
      end
      subroutine gettag(jobtag)
CVD$R NOCONCUR
      integer jobtag
c*************************************************************************
c
c     this subroutine gets a schedule jobtag for problem on the queue,
c     provided a free column is available in parmq.
c
c*************************************************************************
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      INTEGER WRLOCK
      COMMON /CONWRT/ WRLOCK
cgraph      integer endgrf
cgraph      integer glock
cgraph      real igraph
cgraph      character*6 names,gnames
cgraph      common /calls/ names(mxprcs)
cgraph      common /gphnam/ gnames(nbuffr)
cgraph      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c
c     common block description:
c
c     for a complete common block description see the subroutine libopn
c
c
      if ( free .eq. 0 ) then
         call lockon(WRLOCK)
         write(6,*) '*************SCHED LIMIT ERROR*******************'
         write(6,*) '      user attempt to create to many active '
         write(6,*) '      processes ; total number of jobs =',snext
         write(6,*) '      too many unfinished jobs while in gettag '
         write(6,*) '      and no free slots on the parameter queue '
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine GETTAG'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         call lockoff(WRLOCK)
         stop
c
      endif
c
c     get tag for process on the next free column in the problem queue
c
      call lockon(hflock)
         jobtag = freeq(fhead)
         snext = snext + 1
         if(fhead.eq. ftail) free = 0
         fhead = mod(fhead,mxprcs) + 1
         if(jobtag.ge.1.and.jobtag.le.mxprcs) unitag(jobtag) = snext
      call lockoff(hflock)
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
ctermc  trace for gettag
cterm               igraph(1,insrt) = 15
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = jobtag
cterm               igraph(4,insrt) = fhead
cterm               igraph(5,insrt) = ftail
c
      if ( jobtag .le. 0 .or. jobtag .gt. mxprcs ) then
         write(6,*) '*************SCHED ERROR***********************'
         write(6,*) '      illegal jobtag for parmq column;'
         write(6,*) '      need  1 .le. jobtag .le. ',mxprcs,';'
         write(6,*) '      current jobtag =',jobtag,' in gettag'
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine GETTAG'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
c
      endif
c
      return
c
c     last card of gettag
c
      end
      subroutine rsched(jobtag,settag,kreset)
CVD$R NOCONCUR
      integer jobtag,settag,kreset
c*************************************************************************
c
comment:      usage
c      subroutine paralg(<subargs>)
c      integer strtag,stptag,itag(*)
c      external start,test
c              .
c              .
c      call gettag(strtag)
c      itag(strtag) = strtag
c              .
c              .
c      call gettag(stptag)
c      itag(stptag) = stptag
c              .
c              .
comment:  start iteration or time stepping
c           jobtag = strtag
c           icango = 1
c           nchks = ...
c           nreset = <positive number for iteration set>
c              .
c              .
c           call dep(jobtag,icango,nchks,mychkn)
c           call reset(jobtag,nreset)
c           call putq(jobtag,start,itag(strtag))
c              .
c              .
comment:  test and continue iteration at start if undone
c           jobtag = testag
c           icango = ...
c           nreset = <positive number for iteration set>
c              .
c              .
c           call dep(jobtag,icango,nchks,mychkn)
c           call reset(jobtag,nreset)
c           call putq(jobtag,test,itag(strtag),itag(stptag))
c              .
c              .
c      subroutine test(jobtag,strtag,stptag)
c      common /<label>/ <finished>
c              .
c              .
c      if(<finished>) then
c             kreset = <positive number for iteration set>
c             call rsched(jobtag,strtag,kreset)
c      else
c             kreset = 0
c             call rsched(jobtag,stptag,kreset)
c      endif
c      return
c      end
c
c     this subroutine restores the icangoes of jobtags that work in    
c     an iteration of a loop and calls place to place the reset jobtags
c     back on the ready queue.   only those jobtags with 
c     ireset(*) = kreset are reset.
c
c
c   jobtag  is an integer job tag of the calling test subroutine,
c           that tests whether or not the iteration is done.
c
c   strtag  is an integer job tag of the iteration starting node.
c
c   stptag  is an integer job tag of the iteration stopping node.
c
c   settag  is an integer job tag of the iteration reset node, strtag if
c           kreset = <nonzero> and stptag if kreset = 0.
c
c   kreset  is an integer iteration number specifying how a resetting of 
c           parmq and replacement on the readyq is in progress.
c 
c************************************************************************* 
c 
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105) 
      parameter (nbuffr = 500,ldimrq = 8*iprcs) 
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
cgraph      integer endgrf
cgraph      integer glock
cgraph      real igraph
cgraph      character*6 names,gnames
cgraph      common /calls/ names(mxprcs)
cgraph      common /gphnam/ gnames(nbuffr)
cgraph      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   common block description:
c
c   for a complete common block description see the subroutine libopn
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      mtail = 0
      if(kreset.ne.0) then
        parmq(6,jobtag) = settag
        jmax = min0(mxprcs,snext)
        do 1111 j = 1,jmax
          if(ireset(j).eq.kreset) then
            if(j.ne.settag) then
              parmq(2,j) = icnsav(j)
            else
              parmq(2,j) =  1
            endif
            icango = parmq(2,j)
Caution:  dynamic spawning nodes must have nentries reset to 1
            parmq(1,j) = 1
	    parmq(5,j) = 0
c
caution:  what about race condition for dynamically spawned jobs?
caution:  what about resetting nkids = parmq(4,j)?
c
            idrsq = mod((j-1),nprocc) + 1
            if (icango .eq. 0 ) then
              call lockon(trlock(idrsq))
                if(mod(rtail(idrsq),ndmrsq) + 1 .ne. rhead(idrsq)) then
                  readyq(rtail(idrsq)+ndmrsq*(idrsq-1)) = j
                  rtail(idrsq) = mod(rtail(idrsq),ndmrsq) + 1
                else
                  mtail = -1
                endif
              call lockoff(trlock(idrsq))
            endif
c
          endif
1111   continue
      else
comment:  kreset = 0 and the stop tag must be restored.
         parmq(6,jobtag) = settag
      endif
c
      if (mtail .lt. 0) then
         write(6,*) '*************SCHED LIMIT ERROR********************'
         write(6,*) '      user attempt to create too many processes'
         write(6,*) '      exceeding the space in a single sub-queue'
         write(6,*) '      the maximum allowed is ',ndmrsq,' per sub-q'
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine RSCHED'
cgraph      call dump(endgrf,igraph)
         stop
      endif
c
      return
c
c     last card of rsched
c
      end
      subroutine dep(jobtag,icango,nchks,mychkn)
CVD$R NOCONCUR
      integer jobtag,icango,nchks,mychkn(*)
c*************************************************************************
c
c  warning - this routine may only be used by driver in a static definition
c            of the data dependencies in the task.
c
c
c      usage
c      subroutine xxx(<parms>)
c      external yyy
c       .
c       .
c       .
c           call dep(jobtag,icango,nchks,mychkn)
c           call putq(jobtag,yyy,<parms2>)
c       .
c       .
c       .
c
c     this subroutine puts data dependencies for problem on the queue.  
c     no synchronization is necessary because each index of a column of 
c     parmq is associated with a jobtag specified by the user and 
c     associated with a unique unit of computation.  the arguments of 
c     dep specify a the data dependencies associated with the unit of  
c     computation labeled by jobtag and are placed in a column of parmq 
c     to the menu specified below.
c
c
c   jobtag  is an integer specifying a unique column of parmq obtained
c           from subprogram gettag and is reused when the process jobtag
c           becomes done.
c
c   icango  is a positive integer specifying how many processes must check 
c           in to this process before it can be placed on the readyq.
c
c    nchks  is the number of processes that depend upon the completion of 
c           this process.
c
c   mychkn  is an integer array specifying schedule jobtags of the 
c           processes which depend upon completion of this process.
c
c*************************************************************************
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
cgraph      integer endgrf
cgraph      integer glock
cgraph      real igraph
cgraph      character*6 names,gnames
cgraph      common /calls/ names(mxprcs)
cgraph      common /gphnam/ gnames(nbuffr)
cgraph      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c
c     common block description:
c
c     for a complete common block description see the subroutine libopn
c
c
c     place process jobtag on the problem queue
c     no synchronization required since
c     only one program work executes this code.
c
      if( icango .lt. 0 .or. nchks .lt. 0) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      incorrect specification of dependencies '
         write(6,*) '      DEP parameters icango and nchks '
         write(6,*) '      must be non-negative'
         write(6,*) ' input was '
         write(6,*) '      jobtag ',jobtag 
         write(6,*) '      icango ',icango
         write(6,*) '      nchks  ',nchks
         write(6,*) ' '
         write(6,*) ' EXECUTION TERMINATED BY SCHED in subroutine DEP'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
c
      endif
c
      parmq(1,jobtag) = 1
      parmq(2,jobtag) = icango
      parmq(3,jobtag) = nchks
      parmq(4,jobtag) = 0
c
c     check to see that exactly one node has nchks set to 0
c
       if (nchks .eq. 0 .and. done .eq. 0) then
           done = -2
       else
          if (nchks .eq. 0) done = 0
       endif
c
c     specify identifiers of processes which depend on this one
c     if there are too many abort
c
      if (nchks .gt. nslots - 5) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      attempt to place too many dependencies '
         write(6,*) '      on chekin list during call to dep '
         write(6,*) '      with jobtag ',jobtag
         write(6,*) ' '
         write(6,*) '      user tried to place ',nchks ,' dependencies '
         write(6,*) '      the maximum number is ',nslots - 5
         write(6,*) ' '
         write(6,*) ' EXECUTION TERMINATED BY SCHED in subroutine DEP'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
c
      endif
      do 50 j = 1,nchks
       parmq(j+5,jobtag) = mychkn(j)
c
        if (mychkn(j) .le. 0) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      incorrect specification of dependencies '
         write(6,*) '      all mychkn entries must be positive'
         write(6,*) ' input was '
         write(6,*) '      mychkn(',j,') = ',mychkn(j)
         write(6,*) ' '
         write(6,*) ' EXECUTION TERMINATED BY SCHED in subroutine DEP'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
        endif
c
   50 continue
cgraph      call lockon(glock)
cgraph            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cgraph            insrt = endgrf
cgraph            endgrf = endgrf + 1
cgraph      call lockoff(glock)
cgraph      inext = unitag(jobtag)
cgraphc  trace for dep
cgraph               igraph(1,insrt) = 0
cgraph               igraph(2,insrt) = inext
cgraph               igraph(3,insrt) = icango
cgraph               igraph(4,insrt) = nchks
cgraph               do 9001 jnsrt = 5,nchks + 4
cgraph                  igraph(jnsrt,insrt) = parmq(jnsrt+1,jobtag)
cgraph 9001          continue
cgraph               gnames(insrt) = names(jobtag)
c
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
ctermc  trace for dep
cterm               igraph(1,insrt) = 0
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = icango
cterm               igraph(4,insrt) = nchks
cterm               igraph(5,insrt) = fhead
cterm               igraph(6,insrt) = ftail
cterm               igraph(7,insrt) = jobtag
cterm               do 9001 jnsrt = 8,nchks + 7
cterm                  igraph(jnsrt,insrt) = parmq(jnsrt-2,jobtag)
cterm 9001          continue
cterm               gnames(insrt) = names(jobtag)
c
      return
c
c     last card of dep
c
      end
      subroutine reset(jobtag,nreset)
CVD$R NOCONCUR
      integer jobtag,nreset
c**************************************************************************
c
c     this subroutine saves reset values of icango if nreset .ne. 0.
c
c   nreset  is the integer flag specifing that job jobtag can have its     
c           dependencies reset to the originals for the next iteration.
c
c**************************************************************************
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      if (nreset .ne. 0) then
         ireset(jobtag) = nreset
         icnsav(jobtag) = parmq(2,jobtag)
      endif
c
      return
c
c     last card of reset
c
      end
      integer function gtprb(id,jobtag)
CVD$R NOCONCUR
c**************************************************************************
c
c     this function gets unique access to the head of the readyq
c     pointed to by   id    and then claims the pointer to the next 
c     schedulable process if there is one and returns with a nonzero 
c     value when there is a process to schedule. if there are no entries
c     in the readyq indexed by   id   then the remaning ready ques are 
c     polled in a round robin manner until schedulable process is found
c     or task done is recorded. if task done has been recorded the value 
c     zero is returned in gtprb.  if a nonzero value is returned in gtprb, 
c     the integer jobtag will contain the identifier of the unit of 
c     computation that is to be executed.
c     
c     input parameter
c
c        id  an integer specifying which readyq to access first
c            for work to do.
c
c     output parameters
c
c       jobtag an integer containing the next process to be executed
c
c       gtprb  the return value of this integer function is:
c       
c               0 if task done has been posted
c
c               nonzero if a schedulable process has been claimed.	
c
c
c***************************************************************************
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
cgraph      integer endgrf
cgraph      integer glock
cgraph      real igraph
cgraph      character*6 names,gnames
cgraph      common /calls/ names(mxprcs)
cgraph      common /gphnam/ gnames(nbuffr)
cgraph      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c     common block description:
c
c     for a complete common block description see the routine libopn
c
c
      nspins = 0
      fsave = second(foo)
      idrsq = id
   10 continue
      mhead = -1
      call lockon(hrlock(idrsq))
c
c     gain access to head of readyq.  if task done has not been recorded
c     then increment the head of the readyq. otherwise the head pointer
c     is left fixed so the next active process will receive task done.
c
         if (rhead(idrsq) .ne. rtail(idrsq)) then
            mhead = rhead(idrsq)
            rhead(idrsq) = mod(rhead(idrsq),ndmrsq) + 1
         endif
      call lockoff(hrlock(idrsq))
      if (mhead .gt. 0) then
c
c        there was a work unit on the readyq
c
         jobtag = readyq(mhead+ndmrsq*(idrsq-1))
Change:  events 1 & 4 changed from here to if/else below.
c
         if (jobtag .ne. done) then
c
c           record the subroutine call identifier in gtprb and return
c           the process identifier in jobtag.
c
            gtprb = parmq(1,jobtag)
            if (gtprb .gt. 1 .and. parmq(5,jobtag) .eq. 0) then
               gtprb = -1
            else
cgraph      call lockon(glock)
cgraph            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cgraph            insrt = endgrf
cgraph            endgrf = endgrf + 1
cgraph      call lockoff(glock)
cgraph      inext = unitag(jobtag)
cgraph            if (inext .ge. intspn) then
cgraphc  trace for grprb/child(mhead.gt.0)
cgraph               igraph(1,insrt) = 4
cgraph               igraph(2,insrt) = parmq(6,jobtag)
cgraph               igraph(3,insrt) = inext
cgraph               igraph(4,insrt) = second(foo)
cgraph               igraph(5,insrt) = id
cgraph               gnames(insrt) = names(jobtag)
cgraph            else
cgraphc  trace for grprb/parent(mhead.gt.0)
cgraph               igraph(1,insrt) = 1
cgraph               igraph(2,insrt) = inext
cgraph               igraph(3,insrt) = second(foo)
cgraph               igraph(4,insrt) = id
cgraph               gnames(insrt) = names(jobtag)
cgraph            endif
c
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for grprb/child(mhead.gt.0)
cterm               igraph(1,insrt) = 4
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(6,jobtag)
cterm               igraph(4,insrt) = idrsq
cterm               igraph(5,insrt) = rhead(idrsq)
cterm               igraph(6,insrt) = rtail(idrsq)
cterm               igraph(7,insrt) = id
cterm               igraph(8,insrt) = jobtag
cterm               igraph(9,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for grprb/parent(mhead.gt.0)
cterm               igraph(1,insrt) = 1
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = rhead(idrsq)
cterm               igraph(5,insrt) = rtail(idrsq)
cterm               igraph(6,insrt) = id
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
            endif
c
         else
c
c           task done has been indicated.  request a return from subroutine work
c           by returning the value 0 in gtprb.
c
            gtprb = 0
c
         endif
      else 
c
         jobtag = readyq(rhead(idrsq)+ndmrsq*(idrsq-1))
         if (jobtag .eq. done) then
c
c           task done has been posted
c
            gtprb = 0
c
         else
c
c           there was not any work on the readyq
c
Change(3a):  round robin test replaced by single statement.
            idrsq = mod(idrsq,nprocc) + 1  
             nspins = nspins + 1
            if (mod(nspins,nprocc) .eq. 0) call nops
            go to 10
c
         endif
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for grprb/child(mhead.le.0)
cterm               igraph(1,insrt) = 14
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(6,jobtag)
cterm               igraph(4,insrt) = id
cterm               igraph(5,insrt) = jobtag
cterm               igraph(6,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for grprb/parent(mhead.le.0)
cterm               igraph(1,insrt) = 13
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = id
cterm               igraph(4,insrt) = jobtag
cterm               igraph(5,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            endif
c
      endif
      return
c
c     last card of gtprb
c
      end
      subroutine libopn(nproc)
      integer nproc
c************************************************************************
c
c     this routine sets locks and initializes variables
c     and then spawns nproc generic work routines.
c
c     nproc is a positive integer.  care should be taken to 
c           match nproc to the number of physical processors 
c           available.
c
c************************************************************************
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      INTEGER WRLOCK
      COMMON /CONWRT/ WRLOCK
cgraph      integer endgrf
cgraph      integer glock
cgraph      real igraph
cgraph      character*6 names,gnames
cgraph      common /calls/ names(mxprcs)
cgraph      common /gphnam/ gnames(nbuffr)
cgraph      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
      integer ispace(mxces)
c
c     common block description:
c
c     common/qdata/
c     
c     parmq is a two dimensional integer array.  each column of 
c           this array represents a schedulable process.  a process is
c           identified by its jobtag which corresponds to a unique 
c           column of parmq.  a column of parmq has the following 
c           entries
c
c                     parmq(1,jobtag) = nentries
c                                     a nonzero integer. if  process jobtag
c                                     is on the readyq then this integer
c                                     is equal to the one plus number of times 
c                                     process jobtag has been entered.
c                                     thus when work executes this process
c                                     the integer is equal to the number
c                                     of times the process has been entered.
c      
c                     parmq(2,jobtag) = icango 
c                                     an integer specifying the number
c                                     of processes that must check in
c                                     before this process may scheduled
c                                     (ie. be placed on the ready queue)
c
c                     parmq(3,jobtag) = nchks
c                                     an integer specifying the number
c                                     of processes that this process 
c                                     must checkin to.  identifiers of
c                                     these processes are recorded below.
c                                     if nchks .eq. 0 then completion of 
c                                     this process signifies completion of
c                                     task.
c
c                     parmq(4,jobtag) = the number of kids spawned by this
c                                     process.  if this value is zero
c                                     then this process has not spawned
c                                     any subprocesses.
c
c                     parmq(5,jobtag) = entry_flag
c                                     has the value 1 if ientry was called
c                                     has the value 0  otherwise      
c
c             parmq(6:5+nchks,jobtag) is reserved for identifiers of the nchks
c                                     processes that must wait for completion
c                                     of this process before they can execute.
c
c    fhead   integer pointer to head of freeq.
c
c    ftail   integer pointer to tail of freeq.
c
c     free   integer flag so that there are free columns on parmq if 
c            free = 1, while there are no free columns if free = 0.
c
c    freeq   one dimensional free list of free columns of parmq, with 
c            free columns starting at fhead and ending at ftail in a 
c            circular order.  once a job is finished at the end of 
c            chekin, its column or slot is added back onto freeq, 
c            incrementing ftail mod mxprcs.
c
c    snext   integer counter holding the cumulative number of job tags 
c            given out by gettag.
c
c   unitag   integer array holding the unique job tags "snext"s 
c            corresponding to each current jobtag.
c
c   intspn   pointer to first spawned process.  all jobtags with values
c            greater than or equal to intspn will be spawned processes.
c
c   readyq   a one dimensional integer array that holds the jobtags of 
c            those processes that are ready to execute.  the k-th block 
c            of this array serves as a readyq for the k-th work routine.
c            on executing gtprb, the k-th work  routine will look for work
c            in the k-th readyq first and then the others (round robin).
c            if readyq(*) .eq. done has been set then a return from 
c            subroutine work(*,*)  is indicated.
c
c    rhead   an integer array.  the i-th entry of rhead is a pointer to the 
c            head of the i-th block of readyq
c
c    rtail   an integer array.  the i-th entry of rtail is a pointer to the 
c            tail of the i-th block of readyq
c
c
c     common/qsync/
c
c    qlock  is an integer array of locks.  there is one lock for each 
c           column of parmq.  the purpose of this lock is to ensure
c           unique access to a column of parmq during the checkin operation.
c
c    hrlock  is an integer lock.  the purpose of this lock is to ensure
c            unique access to the pointer rhead to the head of the readyq.
c
c    trlock  is an integer lock.  the purpose of this lock is to ensure
c            unique access to the pointer rtail to the tail of the readyq.
c
c    hflock  is an integer lock.  the purpose of this lock is to ensure
c            unique access to the pointer fhead to the head of the freeq.
c
c    tflock  is an integer lock.  the purpose of this lock is to ensure
c            unique access to the pointer ftail to the tail of the freeq.
c
c    common /qreset/
c
c    ireset  is an integer flag array with ireset(j) .ne. 0 if job j
c            dependency will be reset, else ireset(j) = 0.
c
c    icnsav  is an integer array where icango will be caved for each job
c            that will be reset.
c
c    common /CONWRT/
c
c    WRLOCK  is an integer lock.  the purpose of this lock is to ensure
c            a unique write during concurrent execution.
c
c     done   is a unique non positive integer set in libopn to indicate
c            task done.
c
c    common /gphout/
c
c    endgrf  is an integer pointing to the next available
c            slot in igraph
c
c     glock  is an integer lock.  the purpose of this lock is to ensure
c            unique access to the pointer endgrf of a column of igraph.
c
c    igraph  is a two dimensional integer array
c            used as a buffer for graphics output
c            each column of igraph records an event.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
Change(3):  nproc passed in common as nprocc
      nprocc = nproc
Change(3):  ndmrsq is the size of each sub-q, corresp. one proc.
      ndmrsq = ldimrq/nprocc
c
      if (nproc .gt. mxces .or. nproc .lt. 1) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      user asking for non-physical processors'
         write(6,*) '      on this system:  nprocs =  ',nproc
         write(6,*) '      the maximum allowed is nproc =  ',mxces
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine LIBOPN'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
c
      done = -1
c
c     set readyq locks off
c     initialize readyq(*) = -1  to set done sequence 
c
      do 50 j = 1,nprocc
         call lckasn(hrlock(j))
         call lckasn(trlock(j))
         rhead(j)  = 1
         rtail(j)  = 1
         do 20 i = 1,ndmrsq
            readyq(i+ndmrsq*(j-1)) = -1
   20    continue
   50 continue
c
c     set freeq pointers and locks
c     set qlocks off
c     initialize reentry indicator in parmq(5,*)
c     initial circular freeq with all parmq columns
c
      free = 1
      fhead = 1
      ftail = mxprcs
      call lckasn(hflock)
      call lckasn(tflock)
      call lckasn(WRLOCK)
cgraph      call lckasn(glock)
cterm      call lckasn(glock)
      do 100 j = 1,mxprcs
         call lckasn(qlock(j))
         parmq(5,j) = 0
         freeq(j) = j
         ireset(j) = 0
         icnsav(j) = 0
  100 continue
c
c     initialize queue pointers
c
      intspn = 1
      snext = 0 
cgraph      endgrf = 1
cgraph      open( file='trace.graph',unit=3)
cgraphc
cgraphChange: Output nproc for sched.trace format
cgraph      write(3,30000) nproc
cgraph30000 format(i8)
cterm      endgrf = 1
cterm      open( file='term.trace',unit=3)
ctermc
ctermChange: Output nproc for terminal trace format
cterm      write(3,30000) nproc
cterm30000 format('nprocs = ',i1/)
c
c     set lock on pointer to head of readyq so 
c     no process may start until all process and data dependencies
c     have been specified by the user supplied routine driver.
c
      do 150 j = 1,nprocc
         call lockon(hrlock(j))
  150 continue
c
c     now spawn virtual processors.  these generic work routines will
c     assume the identity of any schedulable process specified by driver.
c
C$DOACROSS share(ispace)
      do 200 j = 1,nproc
         call work(j,ispace(j))
  200 continue
cgraph      call dump(endgrf,igraph)
cterm      call dump(endgrf,igraph)
      return
c
c     last card of libopn
c
      end
      subroutine nxtag(jobtag,mypar)
CVD$R NOCONCUR
CAUTION:  nxtag arguments are consistent with dep now, but order of
cont:  arguments may not be consistent with older versions of ftsubs.f.
      integer jobtag,mypar
c***********************************************************************
c
c
c     this subroutine puts parental dependencies for problem on the 
c     queue.  the arguments of spawn specify a process for this job.
c
c      jobtag  is an integer specifying a unique column of parmq.
c
c       mypar  is an integer specifying the parent of the dynamically
c              spawned process jobtag.
c
c
c***********************************************************************
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
cgraph      integer endgrf
cgraph      integer glock
cgraph      real igraph
cgraph      character*6 names,gnames
cgraph      common /calls/ names(mxprcs)
cgraph      common /gphnam/ gnames(nbuffr)
cgraph      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c
c     common block description:
c
c     for a complete common block description see the subroutine libopn
c
c
c
c     place this process on the free slot in the problem queue
c     obtained from subprogram gettag.
c
      parmq(1,jobtag) = 1
      parmq(2,jobtag) = 0
      parmq(3,jobtag) = 1     
      parmq(6,jobtag) = mypar
c
cgraph      call lockon(glock)
cgraph            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cgraph            insrt = endgrf
cgraph            endgrf = endgrf + 1
cgraph      call lockoff(glock)
cgraph      inext = unitag(jobtag)
cgraphc  trace for nxtag
cgraph               igraph(1,insrt) = 3
cgraph               igraph(2,insrt) = mypar
cgraph               igraph(3,insrt) = inext
cgraph               gnames(insrt) = names(jobtag)
c
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
ctermc  trace for nxtag
cterm               igraph(1,insrt) = 3
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = mypar
cterm               igraph(4,insrt) = fhead
cterm               igraph(5,insrt) = ftail
cterm               igraph(6,insrt) = jobtag
cterm               gnames(insrt) = names(jobtag)
c
c     update the icango counter of the parent process
c     by adding 2 to parmq(2,mypar)... prevents race condition.
c     add 1 to the number of kids spawned by parent mypar
c
         call lockon(qlock(mypar))
            parmq(2,mypar) = parmq(2,mypar) + 2
            parmq(4,mypar) =  parmq(4,mypar) + 1
         call lockoff(qlock(mypar))
c
c     set number of kids spawned by jobtag to zero
c
         parmq(4,jobtag) = 0
c
c
c
      return
c
c     last card of nxtag
c
      end
      subroutine start2
c
c     this routine allows parallel processing to start after user supplied
c     driver has completed by unlocking the head of the readyq
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      logical nostrt
cgraph      integer endgrf
cgraph      integer glock
cgraph      real igraph
cgraph      character*6 names,gnames
cgraph      common /calls/ names(mxprcs)
cgraph      common /gphnam/ gnames(nbuffr)
cgraph      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c
c     for common block description see subroutine libopn.
c
      if (done .ne. 0) then
         write(6,*) '*************SCHED USER ERROR********************'
         if (done .eq. -1 ) then
            write(6,*) '      no process has set nchks  equal to 0 '
         else
            write(6,*) '      more than one process has set nchks to 0 '
         endif
         write(6,*) '      SCHEDULE will not be able to terminate job'
         write(6,*) '      correctly '
         write(6,*) ' '
         write(6,*) '      check subroutine passed to initial call to'
         write(6,*) '      to see that at exactly one call to DEP  has '
         write(6,*) '      set nchks = 0 '
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine START2'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
c
      nostrt = .true.
      do 100 iw = 1,nprocc
         if (rhead(iw) .ne. rtail(iw)) nostrt = .false.
  100 continue
      if (nostrt) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      no process had an intitial icango of 0 '
         write(6,*) '      SCHEDULE could not begin '
         write(6,*) ' '
         write(6,*) '      check subroutine passed to initial call to'
         write(6,*) '      to see that at least one call to DEP  has '
         write(6,*) '      set icango = 0 '
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine START2'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
Change:  intspn correction to recover lost jobtag.
c     intspn is the unique tag of the first or initially spawned process.
      intspn = snext + 1

      do 200 iw = 1,nprocc
         call lockoff(hrlock(iw))
  200 continue
c
      return
c
c     last card of start2
c
      end
      subroutine place(jobtag)
CVD$R NOCONCUR
      integer jobtag
c*************************************************************************
c
c
c      this subroutine places a problem on the readyq 
c
c      jobtag  is an integer specifying a unique column of parmq.
c
c
c     icango is a positive integer specifying how many processes must check 
c            into this process before it can be placed on the readyq.
c
c
c*************************************************************************
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
cgraph      integer endgrf
cgraph      integer glock
cgraph      real igraph
cgraph      character*6 names,gnames
cgraph      common /calls/ names(mxprcs)
cgraph      common /gphnam/ gnames(nbuffr)
cgraph      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     common block description:
c
c     for a complete common block description see the subroutine libopn
c
c     place this process on readyq if icango is 0
c     when icango .eq. 0 this process does not depend on any
c     others.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      mtail = 0
      icango = parmq(2,jobtag)
      idrsq = mod((jobtag-1),nprocc) + 1
      if (icango .eq. 0 ) then
            call lockon(trlock(idrsq))
               if(mod(rtail(idrsq),ndmrsq) + 1 .ne. rhead(idrsq)) then
                  readyq(rtail(idrsq)+ndmrsq*(idrsq-1)) = jobtag
                  rtail(idrsq) = mod(rtail(idrsq),ndmrsq) + 1
               else
                  mtail = -1
               endif
            call lockoff(trlock(idrsq))
      endif
Change:
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
ctermc  trace for place
cterm               igraph(1,insrt) = 6
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = rhead(idrsq)
cterm               igraph(5,insrt) = rtail(idrsq)
cterm               igraph(6,insrt) = icango
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
c
      if (mtail .lt. 0) then
         write(6,*) '*************SCHED LIMIT ERROR********************'
         write(6,*) '      user attempt  to create too many processes'
         write(6,*) '      exceeding the space in a single sub-queue'
         write(6,*) '      the maximum allowed is ',ndmrsq,' per sub-q'   
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine PLACE'
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
c
      return
c
c     last card of place
c
      end
      integer function ientry(mypar,nentrs)
c
      integer mypar
c*****************************************************************************
c
c     this routine will allow process mypar to continue after
c     spawned processes have all checked in.  it should only be called if 
c     processes have been spawned by mypar through the use of 
c     the subroutine spawn.  
c
c          go to (1000,2000,...,N000), ientry(mypar,N)
c     1000 continue
c            .	
c            .	
c            .	
c          do 10 j = 1,nproc
c                 .
c                 . (set parameters to define spawned process)
c                 .
c             call nxtag(jobtag,mypar)
c             call spawn(jobtag,mypar,subname,<parms>)
c      10  continue
c          return
c     2000 continue
c            .
c            .
c            .
c          return
c     N000 continue
c           <statements>
c          return
c          end
c
c          this subroutine returns the number of times process mypar
c          has been entered.  if that number is equal to the total
c          number nentrs of expected reentries then parmq(5,mypar)
c          is set to 0 indicating no more reentries required.
c
c*****************************************************************************
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
cgraph      integer endgrf
cgraph      integer glock
cgraph      real igraph
cgraph      character*6 names,gnames
cgraph      common /calls/ names(mxprcs)
cgraph      common /gphnam/ gnames(nbuffr)
cgraph      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c     report the entry point where process jobtag should resume
c     computation
c
      inext = unitag(mypar)
      if (nentrs .lt. 2) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      user call to IENTRY  with number of    '
         write(6,*) '      labels in nentrs set less than  2 '
         write(6,*) '      from parent process ',inext
         write(6,*) ' '
         write(6,*) ' EXECUTION TERMINATED BY SCHED '
cgraph         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
      ientry = parmq(1,mypar) 
      if (ientry .lt. nentrs) then
         parmq(5,mypar) = nentrs
      else
         parmq(5,mypar) = 0
      endif
c
      return
c
c     last card of ientry
c
      end
      logical function wait(mypar,ienter)
c
      integer mypar,ienter
c*****************************************************************************
c
c     this routine will allow process mypar to continue after
c     spawned processes have all checked in.  it should only be called if 
c     processes have been spawned by mypar through the use of 
c     the subroutine spawn.  this routine must be used in conjunction with
c     subroutine prtspn.  the required syntax is 
c
c          go to (1000,...,L000,...,N000), ientry(mypar,N)
c     1000 continue
c            .	
c            .	
c            .	
c          do 100 j = 1,nproc
c                 .
c                 . (set parameters to define spawned process)
c                 .
c             call nxtag(jobtag,mypar)
c             call spawn(jobtag,mypar,subname,<parms>)
c      100 continue
c          label = L
c          if (wait(mypar,label)) return
c     L000 continue
c            .
c            .
c            .
c
c     if this subroutine returns a value of .true. then the calling process
c     mypar should issue a return.  if a value of .false. is returned then
c     the calling process mypar should resume execution at the 
c     statement immediately following the reference to wait (ie. at L000 in
c     the example above.  a return value .true. indicates that some spawned
c     process has not yet completed and checked in.  a return value .false.
c     indicates all spawned processes have checked in.
c
c***********************************************************************
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs)
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
c
c        
c     check the icango counter to see if all spawned processes (kids) 
c     have checked in.
c
      inext = unitag(mypar)
      icango = 1
      call lockon(qlock(mypar))
         icango = parmq(2,mypar) - parmq(4,mypar)
      call lockoff(qlock(mypar))
c
      if (icango .eq. 0) then
c
c        all kids are done ... dont wait (ie return false)
c
         wait = .false.
c
c        record re_entry label where computation is to 
c        resume after wait is complete 
c
         parmq(1,mypar) = ienter
c
         if (ienter .gt. parmq(5,mypar)) then
            write(6,*) '*************SCHED LIMIT ERROR*****************'
            write(6,*) '      executing SCHEDULE function WAIT '
            write(6,*) '      return label larger than the maximum '
            write(6,*) '      specified by user in call to ientry  '
            write(6,*) '      from parent process ', inext
            write(6,*) ' '
            write(6,*) '      the maximum reentry number is '
            write(6,*) '      ', parmq(5,mypar)
            write(6,*) ' '
            write(6,*) ' EXECUTION TERMINATED BY SCHED '
cgraph            call dump(endgrf,igraph)
cterm            call dump(endgrf,igraph)
            stop
         endif
c
c        set last re_entry indication (parmq(5,mypar) = 0)
c        if this reentry point corresponds to last one
c        (recorded in parmq(5,mypar) during call to ientry)
c
         if (ienter .eq. parmq(5,mypar)) parmq(5,mypar) = 0
c
      else
c
c        kids are not done 
c
         wait = .true.
c
c        a checkin will be made so set the number of 
c        entries to return label ienter - 1 to get
c        correct entry point after checkin
c
         parmq(1,mypar) = ienter - 1
c
      endif
c
      return
c
c     last card of wait
c
      end
      subroutine dump(endgrf,igraph)
CVD$R NOCONCUR
Change:  combined SUN SCHED.TRACE/sched.trace and terminal version of dump.
      parameter (nslots = 105,nbuffr = 500)
      parameter (mxprcs = 1000)
      integer endgrf
      real igraph(nslots,nbuffr)
      character*6 gnames,aname
      common /gphnam/ gnames(nbuffr)
      integer ievent(nslots)
c***********************************************************************
c
c     this routine writes graphics and terminal output to a file
c     and resets endgrf to 1
c
c***********************************************************************
       do 300 j = 1,endgrf-1
         do 302 i = 1,nslots
            ievent(i) = igraph(i,j)
  302    continue
         inext = ievent(2)
         if( ievent(1) .eq. 0 ) then
			   aname  = gnames(j)
cgraph               write(3,30000) (ievent(i),i=1,ievent(4)+4)
cgraph               write(3,30010) aname
cterm               write(3,3000) j,(ievent(i),i=1,7)
cterm     &          ,aname,(ievent(i),i=8,ievent(4)+7)
         endif
         if( ievent(1) .eq. 1 ) then
			   aname  = gnames(j)
cgraph               write(3,30001) (ievent(i),i=1,2),igraph(3,j)
cgraph     &            ,ievent(4)
cterm               write(3,3001) j,(ievent(i),i=1,7),aname,igraph(8,j)
         endif
         if( ievent(1) .eq. 2 ) then
			   aname  = gnames(j)
cgraph               write(3,30002) (ievent(i),i=1,2),igraph(3,j)
cterm               write(3,3002) j,(ievent(i),i=1,4),aname,igraph(5,j)
         endif
         if( ievent(1) .eq. 3 ) then
			   aname  = gnames(j)
cgraph               write(3,30003) (ievent(i),i=1,3),aname
cterm               write(3,3003) j,(ievent(i),i=1,6),aname
         endif
         if( ievent(1) .eq. 4 ) then
			   aname  = gnames(j)
cgraph               write(3,30004) (ievent(i),i=1,3),igraph(4,j)
cgraph     &              ,ievent(5)
cterm               write(3,3004) j,(ievent(i),i=1,8),aname,igraph(9,j)
         endif
         if( ievent(1) .eq. 5 ) then
			   aname  = gnames(j)
cgraph               write(3,30005) (ievent(i),i=1,3),igraph(4,j)
cterm               write(3,3005) j,(ievent(i),i=1,5),aname,igraph(6,j)
         endif
         if( ievent(1) .eq. 6 ) then
cgraph               write(3,30002) (ievent(i),i=1,2),igraph(3,j)
         endif
         if( ievent(1) .eq. 7 ) then
cgraph               write(3,30005) (ievent(i),i=1,3),igraph(4,j)
         endif
cterm         if( ievent(1) .eq. 6 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3006) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 7 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3007) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 8 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3008) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 9 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3009) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 10 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3010) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 11 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3011) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 12 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3012) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 13 ) then
cterm                           if ( ievent(4) .ne. 0 ) then
cterm                              aname  = gnames(j)
cterm                           else
cterm                              aname  = '  work'
cterm                           endif
cterm               write(3,3013) j,(ievent(i),i=1,4),aname,igraph(5,j)
cterm         endif
cterm         if( ievent(1) .eq. 14 ) then
cterm                           if ( ievent(5) .ne. 0 ) then
cterm                              aname  = gnames(j)
cterm                           else
cterm                              aname  = '  work'
cterm                           endif
cterm               write(3,3014) j,(ievent(i),i=1,5),aname,igraph(6,j)
cterm         endif
cterm         if( ievent(1) .eq. 15 ) then
cterm               write(3,3015) j,(ievent(i),i=1,5)
cterm         endif
cgraph30000 format(14i8)
cgraph30010 format(2x,a)
cgraph30001 format(2i8,1pe16.8,i8)
cgraph30002 format(2i8,1pe16.8)
cgraph30003 format(3i8,2x,a)
cgraph30004 format(3i8,1pe16.8,i8)
cgraph30005 format(3i8,1pe16.8)
cterm3000  format(i4,'.          dep:',i2,';jobtag=',i4,';icango=',i4
cterm     &  ,'; nchks=',i4,';fhead,ftail=',i4,',',i4
cterm     &  /21x,12x,';idparm=',i4,';mytask= ',a6
cterm     &  /21x,'; mychkn(s)=',5i4,(/21x,10i4))
cterm3001  format(i4,'. gtprb/parent:',i2,';jobtag=',i4,12x
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /4x,' (mhead.gt.0)    ',';idwork=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3002  format(i4,'.chekin/parent:',i2,';jobtag=',i4,12x
cterm     &  ,'; idrsq=',i4
cterm     &  /4x,' (entryflag.eq.0)',12x
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3003  format(i4,'.        nxtag:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,12x,';fhead,ftail=',i4,',',i4
cterm     &  /21x,12x,';idparm=',i4,';mytask= ',a6)
cterm3004  format(i4,'.  gtprb/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /4x,'   (mhead.gt.0)  ',';idwork=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3005  format(i4,'. chekin/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,' idrsq=',i4
cterm     &  /4x,' (entryflag.eq.0)',12x
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3006  format(i4,'.        place:',i2,';jobtag=',i4,12x	
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /21x,';icango=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3007  format(i4,'.chekin/parent:',i2,';jobtag=',i4,12x
cterm     &  ,'; idrsq=',i4,';fhead,ftail=',i4,',',i4
cterm     &  /4x,'  (nchks.ne.0) ',2x,';mychek=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3008  format(i4,'. chekin/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,'; idrsq=',i4,';fhead,ftail=',i4,',',i4
cterm     &  /4x,'  (nchks.ne.0) ',2x,12x
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3009  format(i4,'.chekin/parent:',i2,';jobtag=',i4,12x
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /4x,' (entryflag.ne.0)',';mychek=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3010  format(i4,'. chekin/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /4x,' (entryflag.ne.0)',12x
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3011  format(i4,'.chekin/parent:',i2,';jobtag=',i4,12x
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /4x,'  (nchks.eq.0) ',2x,';mychek=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3012  format(i4,'. chekin/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /,4x,'  (nchks.eq.0) ',12x
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3013  format(i4,'. gtprb/parent:',i2,';jobtag=',i4,12x
cterm     &  /4x,'   (mhead.le.0)  ',';idwork=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3014  format(i4,'.  gtprb/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  /4x,' (mhead.lt.0)    ',';idwork=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3015  format(i4,'.       gettag:',i2,';jobtag=',i4,';idparm=',i4
cterm     &  ,12x,';fhead,ftail=',i4,',',i4)
  300 continue
c
      endgrf = 1
c
      return
c
c     last line of dump
c
      end
      subroutine name(jobtag,myname)
      parameter (mxprcs = 1000)
      character*6 names,myname
      common /calls/ names(mxprcs)
      names(jobtag) = myname
      return
c
c     last card of name
c
      end
c
      subroutine lckasn(ilock)
      integer ilock
      ilock = 0
      return
      end
c
      subroutine lockon(lock)
      integer lock
      lock = 1
      return
      end
c
      subroutine lockoff(lock)
      integer lock
      lock = 0
      return
      end
c
      subroutine nops
      j = 1
      return
      end
SHAR_EOF
if test -f 'ftsubs.graph.f'
then
	echo shar: over-writing existing file "'ftsubs.graph.f'"
fi
cat << \SHAR_EOF > 'ftsubs.graph.f'
      subroutine chekin(jobtag)
Comment:  integrated iteration version of ftsubs.f and ftsubs.iter.f
cont:  with option to iterate a set of nodes with reset dependencies.
Comment:  combined graphics and terminal trace version of ftsubt.f
Code parent: alliant:/afs1/hanson/dirsched/ftsubs.f
change(1):  iprcs = 200 <- 120;
change(2):  automatic return stmt removed out of loop do 20 in chekin;
change(3):  installed vector-circular ready queue,
cont:  vector <= nproc sub-qs, elastic with nproc processors;
cont:  circular <= readyq free space wraps around from rtail to rhead,
cont:  with the top end of readyq connected to the bottom end;
cont:  ready(rhead(id)+ndmrsq*(id-1)) <- readyq(rhead(id),id);
cont:  most mxces replaced by nprocc = nproc = no. sub-qs;
cont:  ldimrq = leading dim of readyq = iprcs*mxces
cont:  ndmrsq = dim of a ready-sub-q = ldimrq/nproc
cont:  idrsq = id of ready-sub-q <- iwrkr; dummy iw used in do's;
cont:  installed SCHED ERROR flags for readyq over-runs (mtail cond.);
cont:  round robin test in getprb reduced to single statement.
Change:  corrected next in nxtag & intspn in start2 to recover lost tag.
CAUTION:  nxtag and spawn arguments are consistent with dep and putq 
cont:  now, but order of arguments may not be consistent with older 
cont:  versions of ftsubs.f.
Change(4): installed circular parm queue, jobtag is the circular 
cont:  (reusable) job tag with 1.le.jobtag.le.mxprcs, 
cont:  snext is the schedule or sum or cumulative jobtag.
Change(5):  install super next tag, whereby user gets schedule job tags
cont:  from new schedule sub gettag;  hence schedule has no knowledge
cont:  of user tags and consequently the principal restriction on user
cont:  is that there be less than "mxprcs" undone jobs at any time.
cont:  integer array "unitag" keeps a unique job tag for undone jobs.
Change(6):  install rest and save arrays for jobtags that will be 
cont:  iterated more than once with original dependencies:  ireset, 
cont:  icnsav.  install sub rsched to reset icangoes 
cont:  and call sub place on iteration.
Change(6a):  nslots = 105 <- 30 to handle multiple dependencies.
Change(7):  installed common block CONWRT with key WRLOCK for concurrent
cont:  writes for use in both ftsubs.f and the user's driver code.
Change(8):  installed c-include indx*.h files to enable the passing of
cont:  up to 60 parameters with sched, putq and spawn calls (via m. 
cont:  johnson, ssi).
Change(9):  installed lock initializations in libopn to make porting
cont:  to other machines without automatic variable initialization.
CAUTION:  subroutine second uses machine dependent timer, which must be 
cont:  changed when porting to other machines.
cgraphChange:  install write nproc in sub libopn.
cgraphChange:  installed extra traces in chekin & place.
cgraphChange:  replaced qlock(mxprcs) by glock as igraph's own lock.
cgraphChange:  installed process names for Dongarra/Brewer's sched.trace.
cgraphChange(8):  cgraph lines made compatible for SCHED.TRACE/sched.trace.
cgraphcdirectory:  /usr/alcaid/brewer/SCHED.TRACE/sched.trace
cgraphcomment:  for graphics trace, change 'cgraph' to null '' and run.
ctermComment:  for terminal trace, change 'cterm' to null '' and run.
Change(9): Conversion of ftsubs.f to run on Sun
cont: Change parameter "mxces" from 8 to 1.
cont: Change parameter "iprcs" from 200 to 1000.
cont: Add routines lckasn, lockon, lockoff, & nops.
CVD$R NOCONCUR
      integer jobtag
c***********************************************************************
c
c     this subroutine reports unit of computation labeled by 
c     jobtag has completed to all dependent nodes.  these nodes are 
c     recorded in parmq(i,jobtag)  where 6 .le. i .le. nchks+5
c     checkin consists of decrementing the value in each of these
c     locations by 1.  each of these is done in a critical section
c     protected by qlock(jobtag)
c
c     if the value in parmq(2,jobtag) is 0 where jobtag is a process
c     dependent upon this one then jobtag is placed on the readyq
c     by entering the critical section protected by trlock.  the
c     pointer rtail to the tail of the readyq is  incremented
c     unless task done is to be recorded.  task done is placed on
c     the ready q and the pointer rtail left in place if nchks .eq. 0
c     is found. 
c
c     see the common block description in libopn for more detail.
c     
c***********************************************************************
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
Caution:  common block CONWRT is used for concurrent writes,
cont:  with WRLOCK as the key to the LOCK.
      INTEGER WRLOCK
      COMMON /CONWRT/ WRLOCK
      integer endgrf
      integer glock
      real igraph
      character*6 names,gnames
      common /calls/ names(mxprcs)
      common /gphnam/ gnames(nbuffr)
      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c
c     common block description:
c
c     a complete common block description is given in the routine libopn
c
c****************************************************************************
c
c     check to see if this process has completed.  if not do not checkin
c
      mtail = 0
	  idrsq = 0
c
c     first ask if any kids spawned by jobtag 
c
      if (parmq(4,jobtag) .ne. 0 .or. parmq(5,jobtag) .ne. 0 ) then
c
c          either kids have been spawned or ientry has been referenced
c          indicating reentry is required
c
c
c          find out how many are waiting to complete
c
         if (parmq(4,jobtag) .ne. 0) then
            call lockon(qlock(jobtag))
               parmq(2,jobtag) = parmq(2,jobtag) - parmq(4,jobtag)
            call lockoff(qlock(jobtag))
         endif
c
c          reset number of kids
c
         parmq(4,jobtag) = 0
c
c          update the number of times this procedure has been
c          entered
c
         parmq(1,jobtag) = parmq(1,jobtag) + 1
c
c          return without checkin if all the kids have not 
c          checked in to jobtag yet or if a reentry is required.  
c          process jobtag is not done in either case.
c
comment:  extra trace data.
         if (parmq(2,jobtag) .ne. 0) then
            call lockon(glock)
                  if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
                  insrt = endgrf
                  endgrf = endgrf + 1
            call lockoff(glock)
            inext = unitag(jobtag)
            if (inext .ge. intspn) then
c  trace for chekin/child (entry_flag.ne.0.or.nkids.ne.0 & icango.ne.0)
               igraph(1,insrt) = 7
               igraph(2,insrt) = parmq(6,jobtag)
               igraph(3,insrt) = inext
               igraph(4,insrt) = second(foo)
            else
c  trace for chekin/parent (entry_flag.ne.0.or.nkids.ne.0 & icango.ne.0)
               igraph(1,insrt) = 6
               igraph(2,insrt) = inext
               igraph(3,insrt) = second(foo)
            endif
            return
         endif 
c
c        if ientry has been called but jobtag is not waiting
c        on any kids then jobtag is placed back on the readyq
c
         if ( parmq(5,jobtag) .ne. 0) then    
            idrsq = mod((jobtag-1),nprocc) + 1
            call lockon(trlock(idrsq))
               if(mod(rtail(idrsq),ndmrsq) + 1 .ne. rhead(idrsq)) then
                  readyq(rtail(idrsq)+ndmrsq*(idrsq-1)) = jobtag
                  rtail(idrsq) = mod(rtail(idrsq),ndmrsq) + 1
               else
                  mtail = -1
               endif
            call lockoff(trlock(idrsq))
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm            inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for chekin/child (entry_flag.ne.0 & icango=0 & nkids=0)
cterm               igraph(1,insrt) = 10
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(8,jobtag)
cterm               igraph(4,insrt) = idrsq
cterm               igraph(5,insrt) = rhead(idrsq)
cterm               igraph(6,insrt) = rtail(idrsq)
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for chekin/parent (entry_flag.ne.0 & icango=0 & nkids=0)
cterm               igraph(1,insrt) = 9
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = rhead(idrsq)
cterm               igraph(5,insrt) = rtail(idrsq) 
cterm               igraph(6,insrt) = parmq(8,jobtag)
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            endif
            return
         endif
      endif
c
c     the process has completed so chekin proceeds
c
      call lockon(glock)
            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
            insrt = endgrf
            endgrf = endgrf + 1
      call lockoff(glock)
      inext = unitag(jobtag)
            if (inext .ge. intspn) then
c  trace for chekin/child (entry_flag.eq.0 & nkids = 0)
               igraph(1,insrt) = 5
               igraph(2,insrt) = parmq(6,jobtag)
               igraph(3,insrt) = inext
               igraph(4,insrt) = second(foo)
               gnames(insrt) = names(jobtag)
            else
c  trace for chekin/parent (entry_flag.eq.0 & nkids = 0)
               igraph(1,insrt) = 2
               igraph(2,insrt) = inext
               igraph(3,insrt) = second(foo)
               gnames(insrt) = names(jobtag)
            endif
c
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for chekin/child (entry_flag.eq.0 & nkids = 0)
cterm               igraph(1,insrt) = 5
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(6,jobtag)
cterm               igraph(4,insrt) = idrsq
cterm               igraph(5,insrt) = jobtag
cterm               igraph(6,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for chekin/parent (entry_flag.eq.0 & nkids = 0)
cterm               igraph(1,insrt) = 2
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = jobtag
cterm               igraph(5,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            endif
c
c
      if (mtail .lt. 0) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      user attempt  to create too many processes'
         write(6,*) '      exceeding the space in a single sub-queue'
         write(6,*) '      the maximum allowed is ',ndmrsq,' per sub-q'   
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine CHEKIN'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
c
      nchks = parmq(3,jobtag)
c
c     if this is the final process (indicated by nchks .eq. 0) then
c     record task done.  do not advance the tail so task done sequence
c     is set.  all subsequent gtprb queries will leave rhead .eq. rtail
c     with readyq(rhead+ndmrsq*(i-1)) .eq. done.
c
      if (nchks .eq. 0) then 
         do 20 iw = 1,nprocc
            call lockon(trlock(iw))
               readyq(rtail(iw)+ndmrsq*(iw-1)) = done
            call lockoff(trlock(iw))
   20    continue
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for chekin/child (nchks.eq.0 & nkids=0 & entry_flag=0)
cterm               igraph(1,insrt) = 12
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(6,jobtag)
cterm               igraph(4,insrt) = idrsq
cterm               igraph(5,insrt) = rhead(idrsq)
cterm               igraph(6,insrt) = rtail(idrsq)
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for chekin/parent (nchks.eq.0 & nkids=0 & entry_flag=0)
cterm               igraph(1,insrt) = 11
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = rhead(idrsq)
cterm               igraph(5,insrt) = rtail(idrsq)
cterm               igraph(6,insrt) = parmq(6,jobtag)
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            endif
Change(2):  removed following return from end of above loop do 20.
            return
      endif
      do 50 j = 6,nchks+5
         mychek = parmq(j,jobtag)
c                  
c     get unique access to the checkin node mychek
c     and checkin by decrementing the appropriate counter
c
         mchkgo = 1
         call lockon(qlock(mychek))
            parmq(2,mychek) = parmq(2,mychek) - 1
            mchkgo = parmq(2,mychek)
         call lockoff(qlock(mychek))
c
c     place mychek on readyq if parmq(2,mychek) is 0
c
         if (mchkgo .eq. 0 ) then
            idrsq = mod((mychek-1),nprocc) + 1
            call lockon(trlock(idrsq))
               if(mod(rtail(idrsq),ndmrsq) + 1 .ne. rhead(idrsq)) then
                  readyq(rtail(idrsq)+ndmrsq*(idrsq-1)) = mychek
                  rtail(idrsq) = mod(rtail(idrsq),ndmrsq) + 1
               else
                  mtail = -1
               endif
            call lockoff(trlock(idrsq))
         endif
   50 continue
c
c     place finished process at the end of the free list freeq
c     provided it will not be reset for another iteration.
c
      if(ireset(jobtag).eq.0) then
         call lockon(tflock)
            ftail = mod(ftail,mxprcs) + 1
            if(fhead.eq. ftail) free = 0
            freeq(ftail) = jobtag
         call lockoff(tflock)
      endif
c
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for chekin/child (nchks.ne.0 & nkids=0 & entry_flag=0)
cterm               igraph(1,insrt) = 8
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(6,jobtag)
cterm               igraph(4,insrt) = idrsq
cterm               igraph(5,insrt) = fhead
cterm               igraph(6,insrt) = ftail
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for chekin/parent (nchks.ne.0 & nkids=0 & entry_flag=0)
cterm               igraph(1,insrt) = 7
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = fhead
cterm               igraph(5,insrt) = ftail
cterm               igraph(6,insrt) = parmq(6,jobtag)
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            endif
c
      if (mtail .lt. 0) then
         write(6,*) '*************SCHED LIMIT ERROR********************'
         write(6,*) '      user attempt  to create too many processes'
         write(6,*) '      exceeding the space in a single sub-queue'
         write(6,*) '      the maximum allowed is ',ndmrsq,' per sub-q'   
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine CHEKIN'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
c
      if ( free .eq. 0 ) then
         call lockon(WRLOCK)
         inext = unitag(jobtag)
         write(6,*) '*************SCHED ERROR*************************'
         write(6,*) '     more processes have checked into sub chekin,'
         write(6,*) '     than should be active for free slots in the'
         write(6,*) '     parmq parameter queue.  jobs are too many.'
         write(6,*) ' total number of jobtags were:',inext 
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine CHEKIN'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         call lockoff(WRLOCK)
         stop
c
      endif
c
      return
c
c     last card of chekin
c
      end
      subroutine gettag(jobtag)
CVD$R NOCONCUR
      integer jobtag
c*************************************************************************
c
c     this subroutine gets a schedule jobtag for problem on the queue,
c     provided a free column is available in parmq.
c
c*************************************************************************
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      INTEGER WRLOCK
      COMMON /CONWRT/ WRLOCK
      integer endgrf
      integer glock
      real igraph
      character*6 names,gnames
      common /calls/ names(mxprcs)
      common /gphnam/ gnames(nbuffr)
      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c
c     common block description:
c
c     for a complete common block description see the subroutine libopn
c
c
      if ( free .eq. 0 ) then
         call lockon(WRLOCK)
         write(6,*) '*************SCHED LIMIT ERROR*******************'
         write(6,*) '      user attempt to create to many active '
         write(6,*) '      processes ; total number of jobs =',snext
         write(6,*) '      too many unfinished jobs while in gettag '
         write(6,*) '      and no free slots on the parameter queue '
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine GETTAG'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         call lockoff(WRLOCK)
         stop
c
      endif
c
c     get tag for process on the next free column in the problem queue
c
      call lockon(hflock)
         jobtag = freeq(fhead)
         snext = snext + 1
         if(fhead.eq. ftail) free = 0
         fhead = mod(fhead,mxprcs) + 1
         if(jobtag.ge.1.and.jobtag.le.mxprcs) unitag(jobtag) = snext
      call lockoff(hflock)
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
ctermc  trace for gettag
cterm               igraph(1,insrt) = 15
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = jobtag
cterm               igraph(4,insrt) = fhead
cterm               igraph(5,insrt) = ftail
c
      if ( jobtag .le. 0 .or. jobtag .gt. mxprcs ) then
         write(6,*) '*************SCHED ERROR***********************'
         write(6,*) '      illegal jobtag for parmq column;'
         write(6,*) '      need  1 .le. jobtag .le. ',mxprcs,';'
         write(6,*) '      current jobtag =',jobtag,' in gettag'
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine GETTAG'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
c
      endif
c
      return
c
c     last card of gettag
c
      end
      subroutine rsched(jobtag,settag,kreset)
CVD$R NOCONCUR
      integer jobtag,settag,kreset
c*************************************************************************
c
comment:      usage
c      subroutine paralg(<subargs>)
c      integer strtag,stptag,itag(*)
c      external start,test
c              .
c              .
c      call gettag(strtag)
c      itag(strtag) = strtag
c              .
c              .
c      call gettag(stptag)
c      itag(stptag) = stptag
c              .
c              .
comment:  start iteration or time stepping
c           jobtag = strtag
c           icango = 1
c           nchks = ...
c           nreset = <positive number for iteration set>
c              .
c              .
c           call dep(jobtag,icango,nchks,mychkn)
c           call reset(jobtag,nreset)
c           call putq(jobtag,start,itag(strtag))
c              .
c              .
comment:  test and continue iteration at start if undone
c           jobtag = testag
c           icango = ...
c           nreset = <positive number for iteration set>
c              .
c              .
c           call dep(jobtag,icango,nchks,mychkn)
c           call reset(jobtag,nreset)
c           call putq(jobtag,test,itag(strtag),itag(stptag))
c              .
c              .
c      subroutine test(jobtag,strtag,stptag)
c      common /<label>/ <finished>
c              .
c              .
c      if(<finished>) then
c             kreset = <positive number for iteration set>
c             call rsched(jobtag,strtag,kreset)
c      else
c             kreset = 0
c             call rsched(jobtag,stptag,kreset)
c      endif
c      return
c      end
c
c     this subroutine restores the icangoes of jobtags that work in    
c     an iteration of a loop and calls place to place the reset jobtags
c     back on the ready queue.   only those jobtags with 
c     ireset(*) = kreset are reset.
c
c
c   jobtag  is an integer job tag of the calling test subroutine,
c           that tests whether or not the iteration is done.
c
c   strtag  is an integer job tag of the iteration starting node.
c
c   stptag  is an integer job tag of the iteration stopping node.
c
c   settag  is an integer job tag of the iteration reset node, strtag if
c           kreset = <nonzero> and stptag if kreset = 0.
c
c   kreset  is an integer iteration number specifying how a resetting of 
c           parmq and replacement on the readyq is in progress.
c 
c************************************************************************* 
c 
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105) 
      parameter (nbuffr = 500,ldimrq = 8*iprcs) 
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      integer endgrf
      integer glock
      real igraph
      character*6 names,gnames
      common /calls/ names(mxprcs)
      common /gphnam/ gnames(nbuffr)
      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   common block description:
c
c   for a complete common block description see the subroutine libopn
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      mtail = 0
      if(kreset.ne.0) then
        parmq(6,jobtag) = settag
        jmax = min0(mxprcs,snext)
        do 1111 j = 1,jmax
          if(ireset(j).eq.kreset) then
            if(j.ne.settag) then
              parmq(2,j) = icnsav(j)
            else
              parmq(2,j) =  1
            endif
            icango = parmq(2,j)
Caution:  dynamic spawning nodes must have nentries reset to 1
            parmq(1,j) = 1
	    parmq(5,j) = 0
c
caution:  what about race condition for dynamically spawned jobs?
caution:  what about resetting nkids = parmq(4,j)?
c
            idrsq = mod((j-1),nprocc) + 1
            if (icango .eq. 0 ) then
              call lockon(trlock(idrsq))
                if(mod(rtail(idrsq),ndmrsq) + 1 .ne. rhead(idrsq)) then
                  readyq(rtail(idrsq)+ndmrsq*(idrsq-1)) = j
                  rtail(idrsq) = mod(rtail(idrsq),ndmrsq) + 1
                else
                  mtail = -1
                endif
              call lockoff(trlock(idrsq))
            endif
c
          endif
1111   continue
      else
comment:  kreset = 0 and the stop tag must be restored.
         parmq(6,jobtag) = settag
      endif
c
      if (mtail .lt. 0) then
         write(6,*) '*************SCHED LIMIT ERROR********************'
         write(6,*) '      user attempt to create too many processes'
         write(6,*) '      exceeding the space in a single sub-queue'
         write(6,*) '      the maximum allowed is ',ndmrsq,' per sub-q'
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine RSCHED'
      call dump(endgrf,igraph)
         stop
      endif
c
      return
c
c     last card of rsched
c
      end
      subroutine dep(jobtag,icango,nchks,mychkn)
CVD$R NOCONCUR
      integer jobtag,icango,nchks,mychkn(*)
c*************************************************************************
c
c  warning - this routine may only be used by driver in a static definition
c            of the data dependencies in the task.
c
c
c      usage
c      subroutine xxx(<parms>)
c      external yyy
c       .
c       .
c       .
c           call dep(jobtag,icango,nchks,mychkn)
c           call putq(jobtag,yyy,<parms2>)
c       .
c       .
c       .
c
c     this subroutine puts data dependencies for problem on the queue.  
c     no synchronization is necessary because each index of a column of 
c     parmq is associated with a jobtag specified by the user and 
c     associated with a unique unit of computation.  the arguments of 
c     dep specify a the data dependencies associated with the unit of  
c     computation labeled by jobtag and are placed in a column of parmq 
c     to the menu specified below.
c
c
c   jobtag  is an integer specifying a unique column of parmq obtained
c           from subprogram gettag and is reused when the process jobtag
c           becomes done.
c
c   icango  is a positive integer specifying how many processes must check 
c           in to this process before it can be placed on the readyq.
c
c    nchks  is the number of processes that depend upon the completion of 
c           this process.
c
c   mychkn  is an integer array specifying schedule jobtags of the 
c           processes which depend upon completion of this process.
c
c*************************************************************************
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      integer endgrf
      integer glock
      real igraph
      character*6 names,gnames
      common /calls/ names(mxprcs)
      common /gphnam/ gnames(nbuffr)
      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c
c     common block description:
c
c     for a complete common block description see the subroutine libopn
c
c
c     place process jobtag on the problem queue
c     no synchronization required since
c     only one program work executes this code.
c
      if( icango .lt. 0 .or. nchks .lt. 0) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      incorrect specification of dependencies '
         write(6,*) '      DEP parameters icango and nchks '
         write(6,*) '      must be non-negative'
         write(6,*) ' input was '
         write(6,*) '      jobtag ',jobtag 
         write(6,*) '      icango ',icango
         write(6,*) '      nchks  ',nchks
         write(6,*) ' '
         write(6,*) ' EXECUTION TERMINATED BY SCHED in subroutine DEP'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
c
      endif
c
      parmq(1,jobtag) = 1
      parmq(2,jobtag) = icango
      parmq(3,jobtag) = nchks
      parmq(4,jobtag) = 0
c
c     check to see that exactly one node has nchks set to 0
c
       if (nchks .eq. 0 .and. done .eq. 0) then
           done = -2
       else
          if (nchks .eq. 0) done = 0
       endif
c
c     specify identifiers of processes which depend on this one
c     if there are too many abort
c
      if (nchks .gt. nslots - 5) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      attempt to place too many dependencies '
         write(6,*) '      on chekin list during call to dep '
         write(6,*) '      with jobtag ',jobtag
         write(6,*) ' '
         write(6,*) '      user tried to place ',nchks ,' dependencies '
         write(6,*) '      the maximum number is ',nslots - 5
         write(6,*) ' '
         write(6,*) ' EXECUTION TERMINATED BY SCHED in subroutine DEP'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
c
      endif
      do 50 j = 1,nchks
       parmq(j+5,jobtag) = mychkn(j)
c
        if (mychkn(j) .le. 0) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      incorrect specification of dependencies '
         write(6,*) '      all mychkn entries must be positive'
         write(6,*) ' input was '
         write(6,*) '      mychkn(',j,') = ',mychkn(j)
         write(6,*) ' '
         write(6,*) ' EXECUTION TERMINATED BY SCHED in subroutine DEP'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
        endif
c
   50 continue
      call lockon(glock)
            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
            insrt = endgrf
            endgrf = endgrf + 1
      call lockoff(glock)
      inext = unitag(jobtag)
c  trace for dep
               igraph(1,insrt) = 0
               igraph(2,insrt) = inext
               igraph(3,insrt) = icango
               igraph(4,insrt) = nchks
               do 9001 jnsrt = 5,nchks + 4
                  igraph(jnsrt,insrt) = parmq(jnsrt+1,jobtag)
 9001          continue
               gnames(insrt) = names(jobtag)
c
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
ctermc  trace for dep
cterm               igraph(1,insrt) = 0
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = icango
cterm               igraph(4,insrt) = nchks
cterm               igraph(5,insrt) = fhead
cterm               igraph(6,insrt) = ftail
cterm               igraph(7,insrt) = jobtag
cterm               do 9001 jnsrt = 8,nchks + 7
cterm                  igraph(jnsrt,insrt) = parmq(jnsrt-2,jobtag)
cterm 9001          continue
cterm               gnames(insrt) = names(jobtag)
c
      return
c
c     last card of dep
c
      end
      subroutine reset(jobtag,nreset)
CVD$R NOCONCUR
      integer jobtag,nreset
c**************************************************************************
c
c     this subroutine saves reset values of icango if nreset .ne. 0.
c
c   nreset  is the integer flag specifing that job jobtag can have its     
c           dependencies reset to the originals for the next iteration.
c
c**************************************************************************
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      if (nreset .ne. 0) then
         ireset(jobtag) = nreset
         icnsav(jobtag) = parmq(2,jobtag)
      endif
c
      return
c
c     last card of reset
c
      end
      integer function gtprb(id,jobtag)
CVD$R NOCONCUR
c**************************************************************************
c
c     this function gets unique access to the head of the readyq
c     pointed to by   id    and then claims the pointer to the next 
c     schedulable process if there is one and returns with a nonzero 
c     value when there is a process to schedule. if there are no entries
c     in the readyq indexed by   id   then the remaning ready ques are 
c     polled in a round robin manner until schedulable process is found
c     or task done is recorded. if task done has been recorded the value 
c     zero is returned in gtprb.  if a nonzero value is returned in gtprb, 
c     the integer jobtag will contain the identifier of the unit of 
c     computation that is to be executed.
c     
c     input parameter
c
c        id  an integer specifying which readyq to access first
c            for work to do.
c
c     output parameters
c
c       jobtag an integer containing the next process to be executed
c
c       gtprb  the return value of this integer function is:
c       
c               0 if task done has been posted
c
c               nonzero if a schedulable process has been claimed.	
c
c
c***************************************************************************
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      integer endgrf
      integer glock
      real igraph
      character*6 names,gnames
      common /calls/ names(mxprcs)
      common /gphnam/ gnames(nbuffr)
      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c     common block description:
c
c     for a complete common block description see the routine libopn
c
c
      nspins = 0
      fsave = second(foo)
      idrsq = id
   10 continue
      mhead = -1
      call lockon(hrlock(idrsq))
c
c     gain access to head of readyq.  if task done has not been recorded
c     then increment the head of the readyq. otherwise the head pointer
c     is left fixed so the next active process will receive task done.
c
         if (rhead(idrsq) .ne. rtail(idrsq)) then
            mhead = rhead(idrsq)
            rhead(idrsq) = mod(rhead(idrsq),ndmrsq) + 1
         endif
      call lockoff(hrlock(idrsq))
      if (mhead .gt. 0) then
c
c        there was a work unit on the readyq
c
         jobtag = readyq(mhead+ndmrsq*(idrsq-1))
Change:  events 1 & 4 changed from here to if/else below.
c
         if (jobtag .ne. done) then
c
c           record the subroutine call identifier in gtprb and return
c           the process identifier in jobtag.
c
            gtprb = parmq(1,jobtag)
            if (gtprb .gt. 1 .and. parmq(5,jobtag) .eq. 0) then
               gtprb = -1
            else
      call lockon(glock)
            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
            insrt = endgrf
            endgrf = endgrf + 1
      call lockoff(glock)
      inext = unitag(jobtag)
            if (inext .ge. intspn) then
c  trace for grprb/child(mhead.gt.0)
               igraph(1,insrt) = 4
               igraph(2,insrt) = parmq(6,jobtag)
               igraph(3,insrt) = inext
               igraph(4,insrt) = second(foo)
               igraph(5,insrt) = id
               gnames(insrt) = names(jobtag)
            else
c  trace for grprb/parent(mhead.gt.0)
               igraph(1,insrt) = 1
               igraph(2,insrt) = inext
               igraph(3,insrt) = second(foo)
               igraph(4,insrt) = id
               gnames(insrt) = names(jobtag)
            endif
c
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for grprb/child(mhead.gt.0)
cterm               igraph(1,insrt) = 4
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(6,jobtag)
cterm               igraph(4,insrt) = idrsq
cterm               igraph(5,insrt) = rhead(idrsq)
cterm               igraph(6,insrt) = rtail(idrsq)
cterm               igraph(7,insrt) = id
cterm               igraph(8,insrt) = jobtag
cterm               igraph(9,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for grprb/parent(mhead.gt.0)
cterm               igraph(1,insrt) = 1
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = rhead(idrsq)
cterm               igraph(5,insrt) = rtail(idrsq)
cterm               igraph(6,insrt) = id
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
            endif
c
         else
c
c           task done has been indicated.  request a return from subroutine work
c           by returning the value 0 in gtprb.
c
            gtprb = 0
c
         endif
      else 
c
         jobtag = readyq(rhead(idrsq)+ndmrsq*(idrsq-1))
         if (jobtag .eq. done) then
c
c           task done has been posted
c
            gtprb = 0
c
         else
c
c           there was not any work on the readyq
c
Change(3a):  round robin test replaced by single statement.
            idrsq = mod(idrsq,nprocc) + 1  
             nspins = nspins + 1
            if (mod(nspins,nprocc) .eq. 0) call nops
            go to 10
c
         endif
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
cterm            if (inext .ge. intspn) then
ctermc  trace for grprb/child(mhead.le.0)
cterm               igraph(1,insrt) = 14
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = parmq(6,jobtag)
cterm               igraph(4,insrt) = id
cterm               igraph(5,insrt) = jobtag
cterm               igraph(6,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            else
ctermc  trace for grprb/parent(mhead.le.0)
cterm               igraph(1,insrt) = 13
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = id
cterm               igraph(4,insrt) = jobtag
cterm               igraph(5,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
cterm            endif
c
      endif
      return
c
c     last card of gtprb
c
      end
      subroutine libopn(nproc)
      integer nproc
c************************************************************************
c
c     this routine sets locks and initializes variables
c     and then spawns nproc generic work routines.
c
c     nproc is a positive integer.  care should be taken to 
c           match nproc to the number of physical processors 
c           available.
c
c************************************************************************
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      INTEGER WRLOCK
      COMMON /CONWRT/ WRLOCK
      integer endgrf
      integer glock
      real igraph
      character*6 names,gnames
      common /calls/ names(mxprcs)
      common /gphnam/ gnames(nbuffr)
      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
      integer ispace(mxces)
c
c     common block description:
c
c     common/qdata/
c     
c     parmq is a two dimensional integer array.  each column of 
c           this array represents a schedulable process.  a process is
c           identified by its jobtag which corresponds to a unique 
c           column of parmq.  a column of parmq has the following 
c           entries
c
c                     parmq(1,jobtag) = nentries
c                                     a nonzero integer. if  process jobtag
c                                     is on the readyq then this integer
c                                     is equal to the one plus number of times 
c                                     process jobtag has been entered.
c                                     thus when work executes this process
c                                     the integer is equal to the number
c                                     of times the process has been entered.
c      
c                     parmq(2,jobtag) = icango 
c                                     an integer specifying the number
c                                     of processes that must check in
c                                     before this process may scheduled
c                                     (ie. be placed on the ready queue)
c
c                     parmq(3,jobtag) = nchks
c                                     an integer specifying the number
c                                     of processes that this process 
c                                     must checkin to.  identifiers of
c                                     these processes are recorded below.
c                                     if nchks .eq. 0 then completion of 
c                                     this process signifies completion of
c                                     task.
c
c                     parmq(4,jobtag) = the number of kids spawned by this
c                                     process.  if this value is zero
c                                     then this process has not spawned
c                                     any subprocesses.
c
c                     parmq(5,jobtag) = entry_flag
c                                     has the value 1 if ientry was called
c                                     has the value 0  otherwise      
c
c             parmq(6:5+nchks,jobtag) is reserved for identifiers of the nchks
c                                     processes that must wait for completion
c                                     of this process before they can execute.
c
c    fhead   integer pointer to head of freeq.
c
c    ftail   integer pointer to tail of freeq.
c
c     free   integer flag so that there are free columns on parmq if 
c            free = 1, while there are no free columns if free = 0.
c
c    freeq   one dimensional free list of free columns of parmq, with 
c            free columns starting at fhead and ending at ftail in a 
c            circular order.  once a job is finished at the end of 
c            chekin, its column or slot is added back onto freeq, 
c            incrementing ftail mod mxprcs.
c
c    snext   integer counter holding the cumulative number of job tags 
c            given out by gettag.
c
c   unitag   integer array holding the unique job tags "snext"s 
c            corresponding to each current jobtag.
c
c   intspn   pointer to first spawned process.  all jobtags with values
c            greater than or equal to intspn will be spawned processes.
c
c   readyq   a one dimensional integer array that holds the jobtags of 
c            those processes that are ready to execute.  the k-th block 
c            of this array serves as a readyq for the k-th work routine.
c            on executing gtprb, the k-th work  routine will look for work
c            in the k-th readyq first and then the others (round robin).
c            if readyq(*) .eq. done has been set then a return from 
c            subroutine work(*,*)  is indicated.
c
c    rhead   an integer array.  the i-th entry of rhead is a pointer to the 
c            head of the i-th block of readyq
c
c    rtail   an integer array.  the i-th entry of rtail is a pointer to the 
c            tail of the i-th block of readyq
c
c
c     common/qsync/
c
c    qlock  is an integer array of locks.  there is one lock for each 
c           column of parmq.  the purpose of this lock is to ensure
c           unique access to a column of parmq during the checkin operation.
c
c    hrlock  is an integer lock.  the purpose of this lock is to ensure
c            unique access to the pointer rhead to the head of the readyq.
c
c    trlock  is an integer lock.  the purpose of this lock is to ensure
c            unique access to the pointer rtail to the tail of the readyq.
c
c    hflock  is an integer lock.  the purpose of this lock is to ensure
c            unique access to the pointer fhead to the head of the freeq.
c
c    tflock  is an integer lock.  the purpose of this lock is to ensure
c            unique access to the pointer ftail to the tail of the freeq.
c
c    common /qreset/
c
c    ireset  is an integer flag array with ireset(j) .ne. 0 if job j
c            dependency will be reset, else ireset(j) = 0.
c
c    icnsav  is an integer array where icango will be caved for each job
c            that will be reset.
c
c    common /CONWRT/
c
c    WRLOCK  is an integer lock.  the purpose of this lock is to ensure
c            a unique write during concurrent execution.
c
c     done   is a unique non positive integer set in libopn to indicate
c            task done.
c
c    common /gphout/
c
c    endgrf  is an integer pointing to the next available
c            slot in igraph
c
c     glock  is an integer lock.  the purpose of this lock is to ensure
c            unique access to the pointer endgrf of a column of igraph.
c
c    igraph  is a two dimensional integer array
c            used as a buffer for graphics output
c            each column of igraph records an event.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
Change(3):  nproc passed in common as nprocc
      nprocc = nproc
Change(3):  ndmrsq is the size of each sub-q, corresp. one proc.
      ndmrsq = ldimrq/nprocc
c
      if (nproc .gt. mxces .or. nproc .lt. 1) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      user asking for non-physical processors'
         write(6,*) '      on this system:  nprocs =  ',nproc
         write(6,*) '      the maximum allowed is nproc =  ',mxces
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine LIBOPN'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
c
      done = -1
c
c     set readyq locks off
c     initialize readyq(*) = -1  to set done sequence 
c
      do 50 j = 1,nprocc
         call lckasn(hrlock(j))
         call lckasn(trlock(j))
         rhead(j)  = 1
         rtail(j)  = 1
         do 20 i = 1,ndmrsq
            readyq(i+ndmrsq*(j-1)) = -1
   20    continue
   50 continue
c
c     set freeq pointers and locks
c     set qlocks off
c     initialize reentry indicator in parmq(5,*)
c     initial circular freeq with all parmq columns
c
      free = 1
      fhead = 1
      ftail = mxprcs
      call lckasn(hflock)
      call lckasn(tflock)
      call lckasn(WRLOCK)
      call lckasn(glock)
cterm      call lckasn(glock)
      do 100 j = 1,mxprcs
         call lckasn(qlock(j))
         parmq(5,j) = 0
         freeq(j) = j
         ireset(j) = 0
         icnsav(j) = 0
  100 continue
c
c     initialize queue pointers
c
      intspn = 1
      snext = 0 
      endgrf = 1
      open( file='trace.graph',unit=3)
c
Change: Output nproc for sched.trace format
      write(3,30000) nproc
30000 format(i8)
cterm      endgrf = 1
cterm      open( file='term.trace',unit=3)
ctermc
ctermChange: Output nproc for terminal trace format
cterm      write(3,30000) nproc
cterm30000 format('nprocs = ',i1/)
c
c     set lock on pointer to head of readyq so 
c     no process may start until all process and data dependencies
c     have been specified by the user supplied routine driver.
c
      do 150 j = 1,nprocc
         call lockon(hrlock(j))
  150 continue
c
c     now spawn virtual processors.  these generic work routines will
c     assume the identity of any schedulable process specified by driver.
c
C$DOACROSS share(ispace)
      do 200 j = 1,nproc
         call work(j,ispace(j))
  200 continue
      call dump(endgrf,igraph)
cterm      call dump(endgrf,igraph)
      return
c
c     last card of libopn
c
      end
      subroutine nxtag(jobtag,mypar)
CVD$R NOCONCUR
CAUTION:  nxtag arguments are consistent with dep now, but order of
cont:  arguments may not be consistent with older versions of ftsubs.f.
      integer jobtag,mypar
c***********************************************************************
c
c
c     this subroutine puts parental dependencies for problem on the 
c     queue.  the arguments of spawn specify a process for this job.
c
c      jobtag  is an integer specifying a unique column of parmq.
c
c       mypar  is an integer specifying the parent of the dynamically
c              spawned process jobtag.
c
c
c***********************************************************************
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      integer endgrf
      integer glock
      real igraph
      character*6 names,gnames
      common /calls/ names(mxprcs)
      common /gphnam/ gnames(nbuffr)
      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c
c     common block description:
c
c     for a complete common block description see the subroutine libopn
c
c
c
c     place this process on the free slot in the problem queue
c     obtained from subprogram gettag.
c
      parmq(1,jobtag) = 1
      parmq(2,jobtag) = 0
      parmq(3,jobtag) = 1     
      parmq(6,jobtag) = mypar
c
      call lockon(glock)
            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
            insrt = endgrf
            endgrf = endgrf + 1
      call lockoff(glock)
      inext = unitag(jobtag)
c  trace for nxtag
               igraph(1,insrt) = 3
               igraph(2,insrt) = mypar
               igraph(3,insrt) = inext
               gnames(insrt) = names(jobtag)
c
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
ctermc  trace for nxtag
cterm               igraph(1,insrt) = 3
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = mypar
cterm               igraph(4,insrt) = fhead
cterm               igraph(5,insrt) = ftail
cterm               igraph(6,insrt) = jobtag
cterm               gnames(insrt) = names(jobtag)
c
c     update the icango counter of the parent process
c     by adding 2 to parmq(2,mypar)... prevents race condition.
c     add 1 to the number of kids spawned by parent mypar
c
         call lockon(qlock(mypar))
            parmq(2,mypar) = parmq(2,mypar) + 2
            parmq(4,mypar) =  parmq(4,mypar) + 1
         call lockoff(qlock(mypar))
c
c     set number of kids spawned by jobtag to zero
c
         parmq(4,jobtag) = 0
c
c
c
      return
c
c     last card of nxtag
c
      end
      subroutine start2
c
c     this routine allows parallel processing to start after user supplied
c     driver has completed by unlocking the head of the readyq
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      logical nostrt
      integer endgrf
      integer glock
      real igraph
      character*6 names,gnames
      common /calls/ names(mxprcs)
      common /gphnam/ gnames(nbuffr)
      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c
c     for common block description see subroutine libopn.
c
      if (done .ne. 0) then
         write(6,*) '*************SCHED USER ERROR********************'
         if (done .eq. -1 ) then
            write(6,*) '      no process has set nchks  equal to 0 '
         else
            write(6,*) '      more than one process has set nchks to 0 '
         endif
         write(6,*) '      SCHEDULE will not be able to terminate job'
         write(6,*) '      correctly '
         write(6,*) ' '
         write(6,*) '      check subroutine passed to initial call to'
         write(6,*) '      to see that at exactly one call to DEP  has '
         write(6,*) '      set nchks = 0 '
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine START2'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
c
      nostrt = .true.
      do 100 iw = 1,nprocc
         if (rhead(iw) .ne. rtail(iw)) nostrt = .false.
  100 continue
      if (nostrt) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      no process had an intitial icango of 0 '
         write(6,*) '      SCHEDULE could not begin '
         write(6,*) ' '
         write(6,*) '      check subroutine passed to initial call to'
         write(6,*) '      to see that at least one call to DEP  has '
         write(6,*) '      set icango = 0 '
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine START2'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
Change:  intspn correction to recover lost jobtag.
c     intspn is the unique tag of the first or initially spawned process.
      intspn = snext + 1

      do 200 iw = 1,nprocc
         call lockoff(hrlock(iw))
  200 continue
c
      return
c
c     last card of start2
c
      end
      subroutine place(jobtag)
CVD$R NOCONCUR
      integer jobtag
c*************************************************************************
c
c
c      this subroutine places a problem on the readyq 
c
c      jobtag  is an integer specifying a unique column of parmq.
c
c
c     icango is a positive integer specifying how many processes must check 
c            into this process before it can be placed on the readyq.
c
c
c*************************************************************************
c
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      integer endgrf
      integer glock
      real igraph
      character*6 names,gnames
      common /calls/ names(mxprcs)
      common /gphnam/ gnames(nbuffr)
      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     common block description:
c
c     for a complete common block description see the subroutine libopn
c
c     place this process on readyq if icango is 0
c     when icango .eq. 0 this process does not depend on any
c     others.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
      mtail = 0
      icango = parmq(2,jobtag)
      idrsq = mod((jobtag-1),nprocc) + 1
      if (icango .eq. 0 ) then
            call lockon(trlock(idrsq))
               if(mod(rtail(idrsq),ndmrsq) + 1 .ne. rhead(idrsq)) then
                  readyq(rtail(idrsq)+ndmrsq*(idrsq-1)) = jobtag
                  rtail(idrsq) = mod(rtail(idrsq),ndmrsq) + 1
               else
                  mtail = -1
               endif
            call lockoff(trlock(idrsq))
      endif
Change:
cterm      call lockon(glock)
cterm            if (endgrf .gt. nbuffr) call dump(endgrf,igraph)
cterm            insrt = endgrf
cterm            endgrf = endgrf + 1
cterm      call lockoff(glock)
cterm      inext = unitag(jobtag)
ctermc  trace for place
cterm               igraph(1,insrt) = 6
cterm               igraph(2,insrt) = inext
cterm               igraph(3,insrt) = idrsq
cterm               igraph(4,insrt) = rhead(idrsq)
cterm               igraph(5,insrt) = rtail(idrsq)
cterm               igraph(6,insrt) = icango
cterm               igraph(7,insrt) = jobtag
cterm               igraph(8,insrt) = second(foo)
cterm               gnames(insrt) = names(jobtag)
c
      if (mtail .lt. 0) then
         write(6,*) '*************SCHED LIMIT ERROR********************'
         write(6,*) '      user attempt  to create too many processes'
         write(6,*) '      exceeding the space in a single sub-queue'
         write(6,*) '      the maximum allowed is ',ndmrsq,' per sub-q'   
         write(6,*) ' '
         write(6,*) 'EXECUTION TERMINATED BY SCHED in subroutine PLACE'
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
c
      return
c
c     last card of place
c
      end
      integer function ientry(mypar,nentrs)
c
      integer mypar
c*****************************************************************************
c
c     this routine will allow process mypar to continue after
c     spawned processes have all checked in.  it should only be called if 
c     processes have been spawned by mypar through the use of 
c     the subroutine spawn.  
c
c          go to (1000,2000,...,N000), ientry(mypar,N)
c     1000 continue
c            .	
c            .	
c            .	
c          do 10 j = 1,nproc
c                 .
c                 . (set parameters to define spawned process)
c                 .
c             call nxtag(jobtag,mypar)
c             call spawn(jobtag,mypar,subname,<parms>)
c      10  continue
c          return
c     2000 continue
c            .
c            .
c            .
c          return
c     N000 continue
c           <statements>
c          return
c          end
c
c          this subroutine returns the number of times process mypar
c          has been entered.  if that number is equal to the total
c          number nentrs of expected reentries then parmq(5,mypar)
c          is set to 0 indicating no more reentries required.
c
c*****************************************************************************
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs) 
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
      integer endgrf
      integer glock
      real igraph
      character*6 names,gnames
      common /calls/ names(mxprcs)
      common /gphnam/ gnames(nbuffr)
      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
cterm      integer endgrf
cterm      integer glock
cterm      real igraph
cterm      character*6 names,gnames
cterm      common /calls/ names(mxprcs)
cterm      common /gphnam/ gnames(nbuffr)
cterm      common /gphout/ endgrf,igraph(nslots,nbuffr),glock
c
c     report the entry point where process jobtag should resume
c     computation
c
      inext = unitag(mypar)
      if (nentrs .lt. 2) then
         write(6,*) '*************SCHED USER ERROR********************'
         write(6,*) '      user call to IENTRY  with number of    '
         write(6,*) '      labels in nentrs set less than  2 '
         write(6,*) '      from parent process ',inext
         write(6,*) ' '
         write(6,*) ' EXECUTION TERMINATED BY SCHED '
         call dump(endgrf,igraph)
cterm         call dump(endgrf,igraph)
         stop
      endif
      ientry = parmq(1,mypar) 
      if (ientry .lt. nentrs) then
         parmq(5,mypar) = nentrs
      else
         parmq(5,mypar) = 0
      endif
c
      return
c
c     last card of ientry
c
      end
      logical function wait(mypar,ienter)
c
      integer mypar,ienter
c*****************************************************************************
c
c     this routine will allow process mypar to continue after
c     spawned processes have all checked in.  it should only be called if 
c     processes have been spawned by mypar through the use of 
c     the subroutine spawn.  this routine must be used in conjunction with
c     subroutine prtspn.  the required syntax is 
c
c          go to (1000,...,L000,...,N000), ientry(mypar,N)
c     1000 continue
c            .	
c            .	
c            .	
c          do 100 j = 1,nproc
c                 .
c                 . (set parameters to define spawned process)
c                 .
c             call nxtag(jobtag,mypar)
c             call spawn(jobtag,mypar,subname,<parms>)
c      100 continue
c          label = L
c          if (wait(mypar,label)) return
c     L000 continue
c            .
c            .
c            .
c
c     if this subroutine returns a value of .true. then the calling process
c     mypar should issue a return.  if a value of .false. is returned then
c     the calling process mypar should resume execution at the 
c     statement immediately following the reference to wait (ie. at L000 in
c     the example above.  a return value .true. indicates that some spawned
c     process has not yet completed and checked in.  a return value .false.
c     indicates all spawned processes have checked in.
c
c***********************************************************************
      parameter (mxprcs = 1000,iprcs = 1000,mxces = 1,nslots = 105)
      parameter (nbuffr = 500,ldimrq = 8*iprcs)
      integer parmq,freeq,readyq,intspn,rhead,rtail,
     &        done,free,fhead,ftail,snext,unitag
     &        ,ireset,icnsav
      integer qlock,hrlock,trlock,hflock,tflock
      common /qdata/ parmq(nslots,mxprcs),freeq(mxprcs),intspn,
     &               readyq(ldimrq),rhead(mxces),rtail(mxces),
     &               ndmrsq,nprocc,fhead,ftail,snext,unitag(mxprcs)
      common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces),
     &               done,free,hflock,tflock
      common /qreset/ ireset(mxprcs),icnsav(mxprcs)
c
c        
c     check the icango counter to see if all spawned processes (kids) 
c     have checked in.
c
      inext = unitag(mypar)
      icango = 1
      call lockon(qlock(mypar))
         icango = parmq(2,mypar) - parmq(4,mypar)
      call lockoff(qlock(mypar))
c
      if (icango .eq. 0) then
c
c        all kids are done ... dont wait (ie return false)
c
         wait = .false.
c
c        record re_entry label where computation is to 
c        resume after wait is complete 
c
         parmq(1,mypar) = ienter
c
         if (ienter .gt. parmq(5,mypar)) then
            write(6,*) '*************SCHED LIMIT ERROR*****************'
            write(6,*) '      executing SCHEDULE function WAIT '
            write(6,*) '      return label larger than the maximum '
            write(6,*) '      specified by user in call to ientry  '
            write(6,*) '      from parent process ', inext
            write(6,*) ' '
            write(6,*) '      the maximum reentry number is '
            write(6,*) '      ', parmq(5,mypar)
            write(6,*) ' '
            write(6,*) ' EXECUTION TERMINATED BY SCHED '
            call dump(endgrf,igraph)
cterm            call dump(endgrf,igraph)
            stop
         endif
c
c        set last re_entry indication (parmq(5,mypar) = 0)
c        if this reentry point corresponds to last one
c        (recorded in parmq(5,mypar) during call to ientry)
c
         if (ienter .eq. parmq(5,mypar)) parmq(5,mypar) = 0
c
      else
c
c        kids are not done 
c
         wait = .true.
c
c        a checkin will be made so set the number of 
c        entries to return label ienter - 1 to get
c        correct entry point after checkin
c
         parmq(1,mypar) = ienter - 1
c
      endif
c
      return
c
c     last card of wait
c
      end
      subroutine dump(endgrf,igraph)
CVD$R NOCONCUR
Change:  combined SUN SCHED.TRACE/sched.trace and terminal version of dump.
      parameter (nslots = 105,nbuffr = 500)
      parameter (mxprcs = 1000)
      integer endgrf
      real igraph(nslots,nbuffr)
      character*6 gnames,aname
      common /gphnam/ gnames(nbuffr)
      integer ievent(nslots)
c***********************************************************************
c
c     this routine writes graphics and terminal output to a file
c     and resets endgrf to 1
c
c***********************************************************************
       do 300 j = 1,endgrf-1
         do 302 i = 1,nslots
            ievent(i) = igraph(i,j)
  302    continue
         inext = ievent(2)
         if( ievent(1) .eq. 0 ) then
			   aname  = gnames(j)
               write(3,30000) (ievent(i),i=1,ievent(4)+4)
               write(3,30010) aname
cterm               write(3,3000) j,(ievent(i),i=1,7)
cterm     &          ,aname,(ievent(i),i=8,ievent(4)+7)
         endif
         if( ievent(1) .eq. 1 ) then
			   aname  = gnames(j)
               write(3,30001) (ievent(i),i=1,2),igraph(3,j)
     &            ,ievent(4)
cterm               write(3,3001) j,(ievent(i),i=1,7),aname,igraph(8,j)
         endif
         if( ievent(1) .eq. 2 ) then
			   aname  = gnames(j)
               write(3,30002) (ievent(i),i=1,2),igraph(3,j)
cterm               write(3,3002) j,(ievent(i),i=1,4),aname,igraph(5,j)
         endif
         if( ievent(1) .eq. 3 ) then
			   aname  = gnames(j)
               write(3,30003) (ievent(i),i=1,3),aname
cterm               write(3,3003) j,(ievent(i),i=1,6),aname
         endif
         if( ievent(1) .eq. 4 ) then
			   aname  = gnames(j)
               write(3,30004) (ievent(i),i=1,3),igraph(4,j)
     &              ,ievent(5)
cterm               write(3,3004) j,(ievent(i),i=1,8),aname,igraph(9,j)
         endif
         if( ievent(1) .eq. 5 ) then
			   aname  = gnames(j)
               write(3,30005) (ievent(i),i=1,3),igraph(4,j)
cterm               write(3,3005) j,(ievent(i),i=1,5),aname,igraph(6,j)
         endif
         if( ievent(1) .eq. 6 ) then
               write(3,30002) (ievent(i),i=1,2),igraph(3,j)
         endif
         if( ievent(1) .eq. 7 ) then
               write(3,30005) (ievent(i),i=1,3),igraph(4,j)
         endif
cterm         if( ievent(1) .eq. 6 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3006) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 7 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3007) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 8 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3008) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 9 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3009) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 10 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3010) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 11 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3011) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 12 ) then
cterm                        aname  = gnames(j)
cterm               write(3,3012) j,(ievent(i),i=1,7),aname,igraph(8,j)
cterm         endif
cterm         if( ievent(1) .eq. 13 ) then
cterm                           if ( ievent(4) .ne. 0 ) then
cterm                              aname  = gnames(j)
cterm                           else
cterm                              aname  = '  work'
cterm                           endif
cterm               write(3,3013) j,(ievent(i),i=1,4),aname,igraph(5,j)
cterm         endif
cterm         if( ievent(1) .eq. 14 ) then
cterm                           if ( ievent(5) .ne. 0 ) then
cterm                              aname  = gnames(j)
cterm                           else
cterm                              aname  = '  work'
cterm                           endif
cterm               write(3,3014) j,(ievent(i),i=1,5),aname,igraph(6,j)
cterm         endif
cterm         if( ievent(1) .eq. 15 ) then
cterm               write(3,3015) j,(ievent(i),i=1,5)
cterm         endif
30000 format(14i8)
30010 format(2x,a)
30001 format(2i8,1pe16.8,i8)
30002 format(2i8,1pe16.8)
30003 format(3i8,2x,a)
30004 format(3i8,1pe16.8,i8)
30005 format(3i8,1pe16.8)
cterm3000  format(i4,'.          dep:',i2,';jobtag=',i4,';icango=',i4
cterm     &  ,'; nchks=',i4,';fhead,ftail=',i4,',',i4
cterm     &  /21x,12x,';idparm=',i4,';mytask= ',a6
cterm     &  /21x,'; mychkn(s)=',5i4,(/21x,10i4))
cterm3001  format(i4,'. gtprb/parent:',i2,';jobtag=',i4,12x
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /4x,' (mhead.gt.0)    ',';idwork=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3002  format(i4,'.chekin/parent:',i2,';jobtag=',i4,12x
cterm     &  ,'; idrsq=',i4
cterm     &  /4x,' (entryflag.eq.0)',12x
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3003  format(i4,'.        nxtag:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,12x,';fhead,ftail=',i4,',',i4
cterm     &  /21x,12x,';idparm=',i4,';mytask= ',a6)
cterm3004  format(i4,'.  gtprb/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /4x,'   (mhead.gt.0)  ',';idwork=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3005  format(i4,'. chekin/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,' idrsq=',i4
cterm     &  /4x,' (entryflag.eq.0)',12x
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3006  format(i4,'.        place:',i2,';jobtag=',i4,12x	
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /21x,';icango=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3007  format(i4,'.chekin/parent:',i2,';jobtag=',i4,12x
cterm     &  ,'; idrsq=',i4,';fhead,ftail=',i4,',',i4
cterm     &  /4x,'  (nchks.ne.0) ',2x,';mychek=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3008  format(i4,'. chekin/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,'; idrsq=',i4,';fhead,ftail=',i4,',',i4
cterm     &  /4x,'  (nchks.ne.0) ',2x,12x
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3009  format(i4,'.chekin/parent:',i2,';jobtag=',i4,12x
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /4x,' (entryflag.ne.0)',';mychek=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3010  format(i4,'. chekin/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /4x,' (entryflag.ne.0)',12x
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3011  format(i4,'.chekin/parent:',i2,';jobtag=',i4,12x
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /4x,'  (nchks.eq.0) ',2x,';mychek=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3012  format(i4,'. chekin/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  ,'; idrsq=',i4,';rhead,rtail=',i4,',',i4
cterm     &  /,4x,'  (nchks.eq.0) ',12x
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3013  format(i4,'. gtprb/parent:',i2,';jobtag=',i4,12x
cterm     &  /4x,'   (mhead.le.0)  ',';idwork=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3014  format(i4,'.  gtprb/child:',i2,';jobtag=',i4,'; mypar=',i4
cterm     &  /4x,' (mhead.lt.0)    ',';idwork=',i4
cterm     &  ,';idparm=',i4,';mytask= ',a6,';  time=',1pe16.8)
cterm3015  format(i4,'.       gettag:',i2,';jobtag=',i4,';idparm=',i4
cterm     &  ,12x,';fhead,ftail=',i4,',',i4)
  300 continue
c
      endgrf = 1
c
      return
c
c     last line of dump
c
      end
      subroutine name(jobtag,myname)
      parameter (mxprcs = 1000)
      character*6 names,myname
      common /calls/ names(mxprcs)
      names(jobtag) = myname
      return
c
c     last card of name
c
      end
c
      subroutine lckasn(ilock)
      integer ilock
      ilock = 0
      return
      end
c
      subroutine lockon(lock)
      integer lock
      lock = 1
      return
      end
c
      subroutine lockoff(lock)
      integer lock
      lock = 0
      return
      end
c
      subroutine nops
      j = 1
      return
      end
SHAR_EOF
if test -f 'indx0.h'
then
	echo shar: over-writing existing file "'indx0.h'"
fi
cat << \SHAR_EOF > 'indx0.h'
	   indx[0].subname(indx[0].parms[0], indx[0].parms[1],
			       indx[0].parms[2], indx[0].parms[3],
			       indx[0].parms[4], indx[0].parms[5],
			       indx[0].parms[6], indx[0].parms[7],
			       indx[0].parms[8], indx[0].parms[9],
			       indx[0].parms[10], indx[0].parms[11],
			       indx[0].parms[12], indx[0].parms[13],
			       indx[0].parms[14], indx[0].parms[15],
			       indx[0].parms[16], indx[0].parms[17],
			       indx[0].parms[18], indx[0].parms[19]);
/* For more parms, remove comments and move paren/semicolon.
	               indx[0].parms[20], indx[0].parms[21],
			       indx[0].parms[22], indx[0].parms[23],
			       indx[0].parms[24], indx[0].parms[25],
			       indx[0].parms[26], indx[0].parms[27],
			       indx[0].parms[28], indx[0].parms[29],
			       indx[0].parms[30], indx[0].parms[31],
			       indx[0].parms[32], indx[0].parms[33],
			       indx[0].parms[34], indx[0].parms[35],
			       indx[0].parms[36], indx[0].parms[37],
			       indx[0].parms[38], indx[0].parms[39],
			       indx[0].parms[40], indx[0].parms[41],
			       indx[0].parms[42], indx[0].parms[43],
			       indx[0].parms[44], indx[0].parms[45],
			       indx[0].parms[46], indx[0].parms[47],
			       indx[0].parms[48], indx[0].parms[49],
	               indx[0].parms[50], indx[0].parms[51],
			       indx[0].parms[52], indx[0].parms[53],
			       indx[0].parms[54], indx[0].parms[55],
			       indx[0].parms[56], indx[0].parms[57],
			       indx[0].parms[58], indx[0].parms[59],
	               indx[0].parms[60], indx[0].parms[61],
			       indx[0].parms[62], indx[0].parms[63],
			       indx[0].parms[64], indx[0].parms[65],
			       indx[0].parms[66], indx[0].parms[67],
			       indx[0].parms[68], indx[0].parms[69],
			       indx[0].parms[70], indx[0].parms[71],
			       indx[0].parms[72], indx[0].parms[73],
			       indx[0].parms[74], indx[0].parms[75],
			       indx[0].parms[76], indx[0].parms[77],
			       indx[0].parms[78], indx[0].parms[79],
			       indx[0].parms[80], indx[0].parms[81],
			       indx[0].parms[82], indx[0].parms[83],
			       indx[0].parms[84], indx[0].parms[85],
			       indx[0].parms[86], indx[0].parms[87],
			       indx[0].parms[88], indx[0].parms[89],
			       indx[0].parms[90], indx[0].parms[91],
			       indx[0].parms[92], indx[0].parms[93],
			       indx[0].parms[94], indx[0].parms[95],
			       indx[0].parms[96], indx[0].parms[97],
			       indx[0].parms[98], indx[0].parms[99]);
 */
SHAR_EOF
if test -f 'indxj.h'
then
	echo shar: over-writing existing file "'indxj.h'"
fi
cat << \SHAR_EOF > 'indxj.h'
	       indx[j].subname(indx[j].parms[0], indx[j].parms[1],
			       indx[j].parms[2], indx[j].parms[3],
			       indx[j].parms[4], indx[j].parms[5],
			       indx[j].parms[6], indx[j].parms[7],
			       indx[j].parms[8], indx[j].parms[9],
			       indx[j].parms[10], indx[j].parms[11],
			       indx[j].parms[12], indx[j].parms[13],
			       indx[j].parms[14], indx[j].parms[15],
			       indx[j].parms[16], indx[j].parms[17],
			       indx[j].parms[18], indx[j].parms[19]);
/* For more parms, remove comments and move paren/semicolon.
	               indx[j].parms[20], indx[j].parms[21],
			       indx[j].parms[22], indx[j].parms[23],
			       indx[j].parms[24], indx[j].parms[25],
			       indx[j].parms[26], indx[j].parms[27],
			       indx[j].parms[28], indx[j].parms[29],
			       indx[j].parms[30], indx[j].parms[31],
			       indx[j].parms[32], indx[j].parms[33],
			       indx[j].parms[34], indx[j].parms[35],
			       indx[j].parms[36], indx[j].parms[37],
			       indx[j].parms[38], indx[j].parms[39],
			       indx[j].parms[40], indx[j].parms[41],
			       indx[j].parms[42], indx[j].parms[43],
			       indx[j].parms[44], indx[j].parms[45],
			       indx[j].parms[46], indx[j].parms[47],
			       indx[j].parms[48], indx[j].parms[49],
	               indx[j].parms[50], indx[j].parms[51],
			       indx[j].parms[52], indx[j].parms[53],
			       indx[j].parms[54], indx[j].parms[55],
			       indx[j].parms[56], indx[j].parms[57],
			       indx[j].parms[58], indx[j].parms[59],
	               indx[j].parms[60], indx[j].parms[61],
			       indx[j].parms[62], indx[j].parms[63],
			       indx[j].parms[64], indx[j].parms[65],
			       indx[j].parms[66], indx[j].parms[67],
			       indx[j].parms[68], indx[j].parms[69],
			       indx[j].parms[70], indx[j].parms[71],
			       indx[j].parms[72], indx[j].parms[73],
			       indx[j].parms[74], indx[j].parms[75],
			       indx[j].parms[76], indx[j].parms[77],
			       indx[j].parms[78], indx[j].parms[79],
			       indx[j].parms[80], indx[j].parms[81],
			       indx[j].parms[82], indx[j].parms[83],
			       indx[j].parms[84], indx[j].parms[85],
			       indx[j].parms[86], indx[j].parms[87],
			       indx[j].parms[88], indx[j].parms[89],
			       indx[j].parms[90], indx[j].parms[91],
			       indx[j].parms[92], indx[j].parms[93],
			       indx[j].parms[94], indx[j].parms[95],
			       indx[j].parms[96], indx[j].parms[97],
			       indx[j].parms[98], indx[j].parms[99]);
 */
SHAR_EOF
if test -f 'make1'
then
	echo shar: over-writing existing file "'make1'"
fi
cat << \SHAR_EOF > 'make1'
FILES1 = ftsubs.o putq.o second.o
FILES2 = ftsubs.graph.o putq.o second.o

sched :	$(FILES1)
	rm -f sched.a; ar q sched.a $(FILES1); ranlib sched.a

graph :	$(FILES2)
	rm -f graph.a; ar q graph.a $(FILES2); ranlib graph.a

.f.o : ;	f77 -g -c $*.f
.c.o : ;	cc -g -c $*.c


SHAR_EOF
if test -f 'makefile'
then
	echo shar: over-writing existing file "'makefile'"
fi
cat << \SHAR_EOF > 'makefile'
FILES1 = stuffspawn.o
xtest :	$(FILES1)
	f77 $(FILES1) sched.a -o xtest
gtest :	$(FILES1)
	f77 $(FILES1) graph.a -o gtest

FILES2 = d_and_c.o
xdandc : $(FILES2)
	f77 $(FILES2) sched.a -o xdandc
gdandc : $(FILES2)
	f77 $(FILES2) graph.a -o gdandc

FILES6 = example.o
xexample : $(FILES6)
	f77 $(FILES6) sched.a -o xexample
gexample : $(FILES6)
	f77 $(FILES6) graph.a -o gexample

FILES7 = ts_dynamic.o
xts_dynamic : $(FILES7)
	f77 $(FILES7) sched.a -o xts_dynamic
gts_dynamic : $(FILES7)
	f77 $(FILES7) graph.a -o gts_dynamic

FILES8 = blkjac.o
xblkjac : $(FILES8)
	f77 $(FILES8) sched.a -o xblkjac
gblkjac : $(FILES8)
	f77 $(FILES8) graph.a -o gblkjac

sched: 
	make -f make1 sched
graph: 
	make -f make1 graph

clean:
	/bin/rm -f *.o *~

.f.o : ;	f77 -c $*.f
SHAR_EOF
if test -f 'maxparms.h'
then
	echo shar: over-writing existing file "'maxparms.h'"
fi
cat << \SHAR_EOF > 'maxparms.h'
#define MAXPARMS	20
SHAR_EOF
if test -f 'oldtest'
then
	echo shar: over-writing existing file "'oldtest'"
fi
cat << \SHAR_EOF > 'oldtest'
make -f make1 sched
f77 -g -c ftsubs.f
ftsubs.f:
	chekin:
	gettag:
	rsched:
	dep:
	reset:
	gtprb:
	libopn:
	nxtag:
	start2:
	place:
	ientry:
	wait:
	dump:
	name:
	lckasn:
	lockon:
	lockoff:
	nops:
cc -g -c putq.c
f77 -g -c second.f
second.f:
	second:
rm -f sched.a; ar q sched.a ftsubs.o putq.o second.o; ranlib sched.a
ar: creating sched.a
make -f make1 graph
f77 -g -c ftsubs.graph.f
ftsubs.graph.f:
	chekin:
	gettag:
	rsched:
	dep:
	reset:
	gtprb:
	libopn:
	nxtag:
	start2:
	place:
	ientry:
	wait:
	dump:
	name:
	lckasn:
	lockon:
	lockoff:
	nops:
rm -f graph.a; ar q graph.a ftsubs.graph.o putq.o second.o; ranlib graph.a
ar: creating graph.a
f77 -c stuffspawn.f
stuffspawn.f:
 MAIN:
	paralg:
	stuff1:
	stuff2:
	stuff3:
f77 stuffspawn.o sched.a -o xtest
   input nprocs 
   time =    49.02000   nprocs =   1
   1.00000000000000
  -4.00000000000000
  -6.00000000000000
  -8.00000000000000
 -10.00000000000000
  -12.0000000000000
  -14.0000000000000
  -16.0000000000000
   2.00000000000000
  -6.00000000000000
  -8.00000000000000
 -10.00000000000000
  -12.0000000000000
  -14.0000000000000
  -16.0000000000000
   3.00000000000000
  -8.00000000000000
 -10.00000000000000
  -12.0000000000000
  -14.0000000000000
  -16.0000000000000
   4.00000000000000
 -10.00000000000000
  -12.0000000000000
  -14.0000000000000
  -16.0000000000000
   5.00000000000000
  -12.0000000000000
  -14.0000000000000
  -16.0000000000000
   6.00000000000000
  -14.0000000000000
  -16.0000000000000
   7.00000000000000
  -16.0000000000000
   8.00000000000000
f77 stuffspawn.o graph.a -o gtest
   input nprocs 
   time =    48.90000   nprocs =   1
   1.00000000000000
  -4.00000000000000
  -6.00000000000000
  -8.00000000000000
 -10.00000000000000
  -12.0000000000000
  -14.0000000000000
  -16.0000000000000
   2.00000000000000
  -6.00000000000000
  -8.00000000000000
 -10.00000000000000
  -12.0000000000000
  -14.0000000000000
  -16.0000000000000
   3.00000000000000
  -8.00000000000000
 -10.00000000000000
  -12.0000000000000
  -14.0000000000000
  -16.0000000000000
   4.00000000000000
 -10.00000000000000
  -12.0000000000000
  -14.0000000000000
  -16.0000000000000
   5.00000000000000
  -12.0000000000000
  -14.0000000000000
  -16.0000000000000
   6.00000000000000
  -14.0000000000000
  -16.0000000000000
   7.00000000000000
  -16.0000000000000
   8.00000000000000
f77 -c d_and_c.f
d_and_c.f:
 MAIN:
	top:
	split:
f77 d_and_c.o sched.a -o xdandc
   input nprocs nlevls 
  1
  2
  3
  4
  5
  6
  7
f77 d_and_c.o graph.a -o gdandc
   input nprocs nlevls 
  1
  2
  3
  4
  5
  6
  7
f77 -c example.f
example.f:
 MAIN main:
	parprd:
	inprod:
	addup:
f77 example.o sched.a -o xexample
  Input number of processors
   sigma =    500500.0
f77 example.o graph.a -o gexample
  Input number of processors
   sigma =    500500.0
f77 -c ts_dynamic.f
ts_dynamic.f:
 MAIN dynamc:
	paralg:
	stuff1:
	stuff2:
f77 ts_dynamic.o sched.a -o xts_dynamic
     1.
    47.     5.
    51.   209.     9.
    55.   213.   355.    13.
    59.   217.   359.   485.    17.
    63.   221.   363.   489.   599.    21.
    67.   225.   367.   493.   603.   697.    25.
    71.   229.   371.   497.   607.   701.   779.    29.
    75.   233.   375.   501.   611.   705.   783.   845.    33.
    79.   237.   379.   505.   615.   709.   787.   849.   895.    37.
    83.   241.   383.   509.   619.   713.   791.   853.   899.   929.    41.
    85.   243.   385.   511.   621.   715.   793.   855.   901.   931.   945.
    43.
 #  ts_dynamic.f = pgm.f schedule gettag & name program
 #  ftsubs.f for circular readyq & parmq & freeq version
 #  with nblks =   43; niter =    1000; maxjobs =     946
 # 1    53.66000
           code    norder     niter    nprocs   maxjobs     seconds
   ts_dynamic.f        43      1000         1       946    53.66000
f77 ts_dynamic.o graph.a -o gts_dynamic
testrun: ./gts_dynamic: too big
f77 -c blkjac.f
blkjac.f:
 MAIN blkjac:
	paralg:
	init:
	startt:
	jacobi:
	convrg:
	test:
Warning on line 341 of blkjac.f: local variable reset never used
	stopit:
f77 blkjac.o sched.a -o xblkjac
 Static Block Jacobi Input:
   nprocs =  1; (m,n) = ( 100, 100); (mblks,nblks) = ( 10, 10)
   ; max iterations =   100; nprec =  2
  Parameter input:
   (mdim,ndim) = ( 102, 102); maxblkdim =   11
   ; maxprc =  8; nmychk =   110; (mbpts,nbpts) = (  10,  10)
    (xmax,ymax) = ( 100.00, 100.00); nprec = 2( tol = 0.5000d-02)
  Static Block Jacobi - Iteration SCHEDULE Final Results:
   j/i    1   11   21   31   41   51   61   71   81   91  101  102
 102   0.50 0.50 0.52 0.54 0.58 0.62 0.68 0.74 0.81 0.90 0.99 1.00
 101   0.49 0.50 0.52 0.54 0.58 0.62 0.67 0.74 0.81 0.90 0.99 1.00
  91   0.35 0.45 0.47 0.50 0.53 0.58 0.64 0.71 0.79 0.89 0.99 1.00
  81   0.25 0.40 0.42 0.45 0.49 0.55 0.61 0.69 0.78 0.88 0.99 1.00
  71   0.17 0.35 0.37 0.41 0.45 0.51 0.58 0.66 0.76 0.87 0.99 1.00
  61   0.10 0.30 0.33 0.36 0.41 0.47 0.55 0.64 0.74 0.86 0.99 1.00
  51   0.06 0.25 0.28 0.32 0.37 0.43 0.51 0.61 0.72 0.85 0.99 1.00
  41   0.03 0.20 0.23 0.27 0.33 0.40 0.48 0.58 0.70 0.84 0.98 1.00
  31   0.01 0.16 0.18 0.23 0.28 0.36 0.45 0.56 0.68 0.83 0.98 1.00
  21   0.00 0.11 0.14 0.18 0.24 0.32 0.42 0.53 0.67 0.82 0.98 1.00
  11   0.00 0.06 0.09 0.14 0.20 0.28 0.39 0.51 0.65 0.81 0.98 1.00
   1   0.00 0.01 0.04 0.09 0.16 0.25 0.35 0.48 0.63 0.79 0.98 1.00
 #  Static Block Jacobi Schedule rsched & gettag & name program
 #  ftsubs.f for iterated circular readyq & parmq & freeq version
 #  with mblks, nblks =   10   10; niter =      19; mxiter=     100
 # 1   277.60001
         code       m       n   mblks   nblks   niter  nprocs maxjobs
 BLOCK-JACOBI     100     100      10      10      19       1    1959
 STATIC VERSION     seconds =   277.60001; uvdiff = 0.48139d-02
f77 blkjac.o graph.a -o gblkjac
 Static Block Jacobi Input:
   nprocs =  1; (m,n) = ( 100, 100); (mblks,nblks) = ( 10, 10)
   ; max iterations =   100; nprec =  2
  Parameter input:
   (mdim,ndim) = ( 102, 102); maxblkdim =   11
   ; maxprc =  8; nmychk =   110; (mbpts,nbpts) = (  10,  10)
    (xmax,ymax) = ( 100.00, 100.00); nprec = 2( tol = 0.5000d-02)
  Static Block Jacobi - Iteration SCHEDULE Final Results:
   j/i    1   11   21   31   41   51   61   71   81   91  101  102
 102   0.50 0.50 0.52 0.54 0.58 0.62 0.68 0.74 0.81 0.90 0.99 1.00
 101   0.49 0.50 0.52 0.54 0.58 0.62 0.67 0.74 0.81 0.90 0.99 1.00
  91   0.35 0.45 0.47 0.50 0.53 0.58 0.64 0.71 0.79 0.89 0.99 1.00
  81   0.25 0.40 0.42 0.45 0.49 0.55 0.61 0.69 0.78 0.88 0.99 1.00
  71   0.17 0.35 0.37 0.41 0.45 0.51 0.58 0.66 0.76 0.87 0.99 1.00
  61   0.10 0.30 0.33 0.36 0.41 0.47 0.55 0.64 0.74 0.86 0.99 1.00
  51   0.06 0.25 0.28 0.32 0.37 0.43 0.51 0.61 0.72 0.85 0.99 1.00
  41   0.03 0.20 0.23 0.27 0.33 0.40 0.48 0.58 0.70 0.84 0.98 1.00
  31   0.01 0.16 0.18 0.23 0.28 0.36 0.45 0.56 0.68 0.83 0.98 1.00
  21   0.00 0.11 0.14 0.18 0.24 0.32 0.42 0.53 0.67 0.82 0.98 1.00
  11   0.00 0.06 0.09 0.14 0.20 0.28 0.39 0.51 0.65 0.81 0.98 1.00
   1   0.00 0.01 0.04 0.09 0.16 0.25 0.35 0.48 0.63 0.79 0.98 1.00
 #  Static Block Jacobi Schedule rsched & gettag & name program
 #  ftsubs.f for iterated circular readyq & parmq & freeq version
 #  with mblks, nblks =   10   10; niter =      19; mxiter=     100
 # 1   287.62003
         code       m       n   mblks   nblks   niter  nprocs maxjobs
 BLOCK-JACOBI     100     100      10      10      19       1    1959
 STATIC VERSION     seconds =   287.62003; uvdiff = 0.48139d-02
SHAR_EOF
if test -f 'putq.c'
then
	echo shar: over-writing existing file "'putq.c'"
fi
cat << \SHAR_EOF > 'putq.c'
#include <stdio.h>

#include "maxparms.h"

/*  
    Code:  putq.c for number of active jobs up to 1000 (indx[1001]).
    
    Caution:  spawn (& nxtag) are reordered to be consistent with
              putq (& dep) arguments.
*/
struct parms	{
	int	(*subname)();
	long	*parms[MAXPARMS];
		};
struct parms indx[1001]; 
sched_(nprocs,parms)
int *nprocs;
struct parms	parms;
/*  
    this procedure obtains nprocs physical processors devoted
    to the the execution of the parallel program indicated through parms
    which is a structure whose first entry is a subroutine name and whose
    remaining entries are parameters appearing in the calling sequence
    of that subroutine.
*/
{
        int libopn_();
	bcopy(&parms, &indx[0], sizeof(struct parms));
/*      
           the subroutine name and prameter list have been copied and 
           placed in a special slot on the parmq      
          
           then libopn is invoked to initialize pointers, grab physical
           processors and begin the computation
*/
        libopn_(nprocs);
	return(0);
}
putq_(jobtag,parms)
int *jobtag;
struct parms	parms;
/*  
    this procedure puts the descriptor of a schedulable process <jobtag>
    onto the problem queue.  this process will be scheduled for execution
    when its data dependencies have been satisfied (indicated by icango==0).
    the argument parms is a structure whose first entry is a subroutine name 
    and whose remaining entries are parameters appearing in the calling sequence
    of that subroutine.
*/
{
        register int j;
        int place_();
        j = *jobtag;
	bcopy(&parms, &indx[j], sizeof(struct parms));
/*
        first the parms block is copied into the slot pointed to by 
        by jobtag and then this descriptor is placed on the problem 
        queue
*/ 
        place_(jobtag);
	return(0);
}
spawn_(jobtag,parent,parms)
int *jobtag,*parent;
struct parms	parms;
/*  
    this procedure puts the descriptor of a schedulable process <jobtag>
    onto the problem queue.  this process will be scheduled for execution
    when its data dependencies have been satisfied (indicated by icango==0).
    the argument parms is a structure whose first entry is a subroutine name 
    and whose remaining entries are parameters appearing in the calling sequence
    of that subroutine.
    
    the action of this procedure differs from putq in that the user does not
    assign jobtags or data dependencies.  a parent may spawn any number of 
    children but these child processes only report to the parent.
    Caution:  First two arguments of NXTAG and SPAWN are reversed
    from older versions.
*/
{
        register int j,i;
        int place_(),clone_();
        j = *jobtag;
        i = *parent;
	bcopy(&parms, &indx[j], sizeof(struct parms));
/*
        first the parms block is copied into the slot pointed to by 
        by jobtag and then this descriptor is placed on the problem 
        queue
*/ 
        if (indx[j].subname == clone_) indx[j].subname = indx[i].subname;
/*
        here we ask if this is a recursive spawning.  if so the name
        clone has been called instead of subname so we replace the name
        clone by subname.
*/
        place_(jobtag);
	return(0);
}
clone_()
{
/*
        this is a dummy routine to satisfy unresolved external
*/
        return(0);
}
work_(id,jobtag)
int *id,*jobtag;
{
        int start2_(),gtprb_();
        register int j,myjob;
        j = *id;
        if (j == 1) 
/*
        the worker whose id is 1 will execute the subroutine passed to 
        sched.  this subroutine executes the static data dependency graph.
        this graph must have at least one node.
*/
        {

#include "indx0.h"

              start2_();
        }
         myjob = gtprb_(id,jobtag);
         while (myjob != 0) 
         {
           j = *jobtag;
           if (myjob <= -1 )
           {
/*
              reenter... simple spawning was done
              all kids completed and no reentry
              is required.  this indicates
              jobtag is all done and checkin can proceed.
*/
              chekin_(jobtag);
              myjob = gtprb_(id,jobtag);
           }
           else
           {
/*
               call subname(<parms>)..........
*/

#include "indxj.h"

             chekin_(jobtag); 
             myjob = gtprb_(id,jobtag);
           }
          }
          return(0);
}
SHAR_EOF
if test -f 'second.f'
then
	echo shar: over-writing existing file "'second.f'"
fi
cat << \SHAR_EOF > 'second.f'
      real function second(t)
      real t
      real t1(2)
      t = etime(t1)
      t = t1(1)
      second = t
      return
      end
    
SHAR_EOF
if test -f 'stuffspawn.f'
then
	echo shar: over-writing existing file "'stuffspawn.f'"
fi
cat << \SHAR_EOF > 'stuffspawn.f'
      double precision a,b
      common /prbdef/ a(1000),b(100),itmp(10),jtmp(10),myid(10)
      EXTERNAL PARALG
      nblks = 8
      do 10 j = 1,10
         itmp(j) = j
         jtmp(j) = j
   10 continue
      write(6,*) ' input nprocs '
      read (5,*) nprocs
      t1 = second(foo)
c
      CALL SCHED(nprocs,paralg,nblks,a,b,itmp,jtmp,myid)
c
      t2 = second(foo)
      write(6,*) ' time = ',t2-t1,' nprocs = ',nprocs
      nn = 36
      do 100 j = 1,nn
      write(6,*) a(j)
  100 continue 
      stop
      end
c
      subroutine paralg(n,a,b,itmp,jtmp,myid)
      integer itmp(*),jtmp(*),myid(*)
      double precision a(*),b(*)
      integer mychkn(1)
      character*6 subnam
      EXTERNAL STUFF1
c
c     this is the driver for filling a packed triangular matrix with 
c     i on the i-th diagonal and -(i+j) in the (i,j) off diagonal position
c
      do 150 j = 1, n
        call GETTAG(jobtag)
        myid(j) = jobtag
 150  continue
c
      icount = 1
      do 200 j = 1, n
c
c        the j-th diagonal waits for the diagonal above to complete
c        the j-th diagonal completion will allow 
c        the (j+1)-st diagonal to start
c
         jobtag = myid(j)
         if (j .eq. 1) then
           icango = 0
         else
           icango = 1
         endif
         if (j .eq. n) then
           nchks = 0
         else
           nchks = 1
           mychkn(1) = myid(j + 1)
         endif
c
c        we just set up data dependencies and are ready to put
c        this process on the queue
c
         subnam = 'stuff1'
         CALL NAME(jobtag,subnam)
         CALL DEP(jobtag,icango,nchks,mychkn)
         CALL PUTQ(jobtag,stuff1,myid(j),n,a(icount),jtmp(j),itmp(1))
c
c        when the data dependencies for process jobtag are satisfied
c        the following call will be made
c
c          call  stuff1(myid....,itmp(1))
c
         icount = icount + (n-j+1)
  200 continue
c
      return
      end
c
      subroutine stuff1(myid,n,a,j,itmp)
      double precision a(*)
      integer myid,n,j,itmp(*)
      logical wait
      character*6 subnam
      EXTERNAL STUFF2,STUFF3
c
         go to (1111,2222,3333),ientry(myid,3)
 1111    continue
         ii = 2
         do 100 i = 2,n  
c
            CALL GETTAG(jobtag)
            subnam = 'stuff2'
            CALL NAME(jobtag,subnam)
            CALL NXTAG(jobtag,myid)
            CALL SPAWN(jobtag,myid,stuff2,a(ii + 1),itmp(i),itmp(j))
c
c           this spawns a process that will execute a call to stuff2
c           and report completion to process MYID
c
            ii = ii + 1
  100    continue
         call stuff2(a(2),itmp(1),itmp(j))
         if (wait(myid,2)) return
c
c        return to help out and then return here (at label 2222) 
c        on the next reentry
c
 2222    continue
         ii = 2
         do 200 i = 2,n  
c
            CALL GETTAG(jobtag)
            subnam = 'stuff3'
            CALL NAME(jobtag,subnam)
            CALL NXTAG(jobtag,myid)
            CALL SPAWN(jobtag,myid,stuff3,a(ii + 1),itmp(i),itmp(j))
c
c           this spawns a process that will execute a call to stuff3
c           and report completion to process MYID
c
            ii = ii + 1
  200    continue
         call stuff3(a(2),itmp(1),itmp(j))
         if (wait(myid,3)) return
 3333    continue
         a(1) = j
c
      return
      end
      subroutine stuff2(a,i,j)
      double precision a(*),one
      one = 1.0d0
      a(1) = 0.0d0
         do 100 kk = 1,10000
            a(1) = a(1) + one
  100    continue
         a(1) = -(i+j)
      return
      end
      subroutine stuff3(a,i,j)
      double precision a(*),one,save
      one = 1.0d0
      save = a(1) 
         do 100 kk = 1,10000
            a(1) = a(1) + one
  100    continue
         a(1) = -(i+j) + save
      return
      end
c
SHAR_EOF
if test -f 'testrun'
then
	echo shar: over-writing existing file "'testrun'"
fi
cat << \SHAR_EOF > 'testrun'
make sched; make graph
make xtest; xtest < data
make gtest; gtest < data
make xdandc; xdandc < data
make gdandc; gdandc < data
make xexample; xexample < data
make gexample; gexample < data
make xts_dynamic; xts_dynamic < data.ts_dynamic
make gts_dynamic; gts_dynamic < data.ts_dynamic
make xblkjac; xblkjac < data.blkjac
make gblkjac; gblkjac < data.blkjac
SHAR_EOF
chmod +x 'testrun'
if test -f 'ts_dynamic.f'
then
	echo shar: over-writing existing file "'ts_dynamic.f'"
fi
cat << \SHAR_EOF > 'ts_dynamic.f'
      program dynamc
c
Code Name:  ts_dynamic.f
Code Input Data: [nprocessors] [narraysize] [nworkiterations]
Code Note:  variation on tridiagonal stuffer program ts_dynamic.f
Change:  Modification for circular parmq & super nxtag.
c:  modification of ts_dynamic.f to correspond to ts_static.f     
c...or old stuffspawn.f:  the triangular array stuffer.
      parameter(maxsiz=1000,mxszsq=500500,maxprc=8)
c:  mxszsq .ge. maxsiz*(maxsiz+1)/2
      double precision a,b
      common /comitr/ niter
      common /prbdef/ a(mxszsq),b(maxsiz),itmp(maxsiz),jtmp(maxsiz)
     &  ,statag(maxsiz)
      EXTERNAL PARALG
C     write(6,*) ' input order of array .le. 44, but dim =',maxsiz
C     read (5,*) nblks
C     write(6,*) ' input nprocs .le. ',maxprc
C     read (5,*) nprocs
      read(5,*) nprocs,nblks,niter
c
      if(nblks.gt.maxsiz) then
         write(6,*) 'order of array, nblks =',nblks,' .gt. ',maxsiz
     &           ,' = maxsize'
         write(6,*) 'S T O P   E X E C U T I O N   I N    M A I N'
         stop
      endif
c
      mxjobs = nblks*(nblks+1)/2
      jstep = (nblks)/(10-0)
c
      do 10 j = 1,nblks
         itmp(j) = j
         jtmp(j) = j
   10 continue
c
c:  add second.f timer
       t1=second(foo)
       t2=second(foo)
c     do 111 jj = 1,100
c
      CALL SCHED(nprocs,paralg,nblks,a,b,itmp,jtmp,statag)
c
c111  continue
        t3=second(foo)
        tt=t3-t2-(t2-t1)
c
c     output
c     lower triangle of a matrix of order n 
c
      do 100 j = 1,nblks
         k = j
         b(1)= a(j)
         do 50 i = 1,j-1
            b(i+1) = a(k+nblks-i)
            k = k+nblks-i
   50    continue
         if(mxjobs.lt.100) then
             write(6,1000) (b(i),i=1,j)
         else
            if(mod(j-1,jstep).eq.0.or.j.eq.nblks) 
     &         write(6,2000) (b(i),i=1,j-1,jstep),b(j)
         endif
  100 continue 
1000    format(16f5.0)
2000    format(11f7.0)
c
      if(nprocs.eq.1) write(6,664) nblks,niter,mxjobs
664   format(' #  ts_dynamic.f = pgm.f schedule gettag & name program'
     &      /' #  ftsubs.f for circular readyq & parmq & freeq version'
     &      /' #  with nblks =',i5'; niter =',i8,'; maxjobs =',i8)
      write(6,665) nprocs,tt
665   format(' #',i2,f12.5)
      write(*,666) nblks,niter,nprocs,mxjobs,tt
666   format(11x,'code',4x,'norder',4x,' niter',4x,'nprocs'
     &  ,3x,'maxjobs',5x,'seconds'
     &  /3x,'ts_dynamic.f',4i10,f12.5)
c
      stop
      end
c
      subroutine paralg(n,a,b,itmp,jtmp,statag)
      integer n,itmp(*),jtmp(*),statag(*)
      double precision a(*),b(*)
      integer mychkn(1)
      EXTERNAL STUFF1
c
c     this is the driver for filling a packed triangular matrix with 
c     j on the j-th diagonal and (j*n+i-j*(j+1)/2) in the (i,j) off 
c     diagonal position
c
c     first, get all static job tags necessary to construct the 
c     dependency graph.
c
      do 100 j = 1,n
Caution:  statag(j) gets the schedule output static job tag.
         CALL GETTAG(statag(j))
100   continue
c
      icount = 1
      do 200 j = 1,n-1
c
c
c        the j-th diagonal waits for the diagonal above to complete
c
c        the j-th diagonal completion will allow 
c        the (j+1)-st diagonal to start
c
c
            jobtag = j
            icango =  1
            if (jobtag .eq. 1) icango = 0
            nchks = 1
Caution:  jobtag = j 's chekin is defined in terms of schedule static tags.
            mychkn(1) = statag(j+1)
c
c        we just set up data dependencies and are ready to put
c        this process on the queue
c
            jobtag = statag(j)
            CALL name(jobtag,'stuff1')
            CALL DEP(jobtag,icango,nchks,mychkn)
CAUTION:  Make certain that all arguments of the subroutine whose name
cont:  is passed to SCHEDULE, are global variables, as jtmp(j) is for 
cont:  sub name stuff1.
            CALL PUTQ(jobtag,stuff1,statag(j),n,
     &                        a(icount),jtmp(j),itmp(1))
c
c        when the data dependencies for process statag(j) are satisfied
c        the following call will be made
c
c          call  stuff1(jobtag,....,itmp(1))
c
         icount = icount + (n-j+1)
  200 continue
c
         icango = 1
         nchks = 0
Caution:  mychkn gets dummy value only.
         mychkn(1) = n+1
c
         jobtag = statag(n)
         CALL name(jobtag,'stuff1')
         CALL DEP(jobtag,icango,nchks,mychkn)
         CALL PUTQ(jobtag,stuff1,statag(n),n,
     &                     a(icount),jtmp(n),itmp(1))
c
      return
      end
c
      subroutine stuff1(mypar,n,a,j,itmp)
      double precision a(*)
      integer mypar,n,j,itmp(*)
      logical wait
      EXTERNAL STUFF2
c
c         write(6,*) ' enter stuff1 ',mypar,j
c
c         write(6,*) ' enter stuff1 ',ientry(mypar),mypar
         nentrs=2
         go to (1111,2222),ientry(mypar,nentrs)
 1111    continue
         ii = 1
         do 100 i = j+1,n  
c
            CALL GETTAG(jobtag)
            CALL name(jobtag,'stuff2')
CAUTION:  ARGUMENTS OF NXTAG & SPAWN ARE REORDERED FROM OLDER VERSIONS,
CAUTION:  MAKING THEM MORE CONSISTENT WITH DEP & PUTQ.
            CALL NXTAG(jobtag,mypar)
c           write(6,*) ' about to spawn jobtag, mypar ',jobtag,mypar
            CALL SPAWN(jobtag,mypar,stuff2,a(ii + 1),itmp(i),itmp(j),n)
c
c           this spawns a process that will execute a call to stuff2
c           and report completion to parent process MYPAR
c
            ii = ii + 1
  100    continue
         iexit=2
         if (wait(mypar,iexit)) return
c
c        return to help out and then return here (at label 2222) 
c        on the next reentry
c
 2222    continue
c
         a(1) = j
c
      return
      end
      subroutine stuff2(a,i,j,n)
      double precision a(*)
      common /comitr/ niter
         do 99999 kk = 1,niter
         a(1) = a(1) + kk
99999    continue
         a(1) = j*n + i - j*(j+1)/2
      return
      end
SHAR_EOF
#	End of shell archive
exit 0