subroutine istkpr
      common /cstak / dstak(500)
      integer istats(6), isize(5)
      double precision dstak
      integer istak(1000)
      logical init
c
      equivalence (dstak(1), istak(1))
      equivalence (istak(1), lout)
      equivalence (istak(2), lnow)
      equivalence (istak(3), lused)
      equivalence (istak(4), lbnd)
      equivalence (istak(5), lmax)
      equivalence (istak(6), lalc)
      equivalence (istak(7),lbook)
      equivalence (istak(8),isize(1))
c
      data init / .true. /
c
      if (init) call i0tk00 (init, 500, 4)
c
      lperm = lmax - lbnd + 1
      ltotal = lused + lperm
c
      iunit = i1mach(2)
      write (iunit, 10) lout, lalc, lnow, lused, lperm, ltotal, lmax
 10   format (///5x, 28h---- storage statistics ----
     1  //35h number of active stack allocations, 7x, i8
     2   /35h total number of allocations so far, 7x, i8
     3  //41h current active length of dynamic storage, 1x, i8
     4   /39h maximum length of dynamic storage used, 3x, i8
     5  //42h current = max length of permanent storage, i8
     6  //27h total maximum storage used, 15x, i8
     7   /30h total maximum storage allowed, 12x, i8 /)
c
      return
      end
      integer function istkgt (nitems,itype)
c
c  allocates space out of the integer array istak (in common
c  block cstak) for an array of length nitems and of type
c  determined by itype as follows
c
c    1 - logical
c    2 - integer
c    3 - real
c    4 - double precision
c    5 - complex
c
c  on return, the array will occupy
c
c    stak(istkgt), stak(istkgt+1), ..., stak(istkgt+nitems-1)
c
c  where stak is an array of type itype equivalenced to istak.
c
c  (for those wanting to make dependent modifications
c  to support other types, codes 6,7,8,9,10,11 and 12 have
c  been reserved for 1/4 logical, 1/2 logical, 1/4 integer,
c  1/2 integer, quad precision, double complex and quad
c  complex, respectively.)
c
c  the allocator reserves the first twelve integer words of the stack
c  for its own internal book-keeping.  these are initialized by
c  the initializing subprogram i0tk00 upon the first call
c  to a subprogram in the allocation package.
c
c  the use of the first seven words is described below.
c
c    istak( 1) - lout,   the number of current allocations.
c    istak( 2) - lnow,   the current active length of the stack.
c    istak( 3) - lused,  the maximum value of istak(2) achieved.
c    istak( 4) - lbnd,   the lower bound of permanent storage which is
c                          one word more than the maximum allowed
c                          length of the stack.
c    istak( 5) - lmax,   the maximum length of storage.
c    istak( 6) - lalc,   the total number of allocations handled by
c                          istkgt.
c    istak( 7) - lbook,  the number of words used for bookkeeping.
c
c  the next five words contain integers describing the amount
c  of storage allocated by the fortran system to the various
c  data types.  the unit of measurement is arbitrary and may
c  be words, bytes or bits or whatever is convenient.  the
c  values currently assumed correspond to an ans fortran
c  environment.  for some mini-computer systems the values may
c  have to be changed (see i0tk00).
c
c    istak( 8) - the number of units allocated to logical
c    istak( 9) - the number of units allocated to integer
c    istak(10) - the number of units allocated to real
c    istak(11) - the number of units allocated to double precision
c    istak(12) - the number of units allocated to complex
c
c  error states -
c
c    1 - nitems .lt. 0
c    2 - itype .le. 0 .or. itype .ge. 6
c    3 - one or more of first seven words in stack overwritten
c    4 - stack overflow - need longer stack
c
      common /cstak/dstak
c
      double precision dstak(500)
      integer istak(1000)
      integer isize(5)
      logical init
c
      equivalence (dstak(1),istak(1))
      equivalence (istak(1),lout)
      equivalence (istak(2),lnow)
      equivalence (istak(3),lused)
      equivalence (istak(4), lbnd)
      equivalence (istak(5), lmax)
      equivalence (istak(6), lalc)
      equivalence (istak(7),lbook)
      equivalence (istak(8),isize(1))
c
      data init/.true./
c
      if (init) call i0tk00(init,500,4)
c
      if (nitems.lt.0) call seterr(20histkgt - nitems.lt.0,20,1,2)
c
      if (itype.eq.0 .or. iabs(itype).ge.6) call seterr (
     1  34histkgt  itype.eq.0 .or. itype.ge.6, 34, 2, 2)
c
      if (lnow.lt.lbook .or. lnow.gt.lused .or. lused.gt.lmax .or.
     1  lnow.ge.lbnd .or. lout.gt.lalc) call seterr (
     2  61histkgt  one or more of first seven words in stack overwritten
     3  , 61, 3, 2)
c
      if (itype.lt.0) go to 10
      istkgt = (lnow*isize(2)-1)/isize(itype) + 2
      i = ( (istkgt-1+nitems)*isize(itype) - 1 )/isize(2) + 3
c
c  stack overflow is an unrecoverable error.
c
      if (i.ge.lbnd) call seterr(68histkgt - stack too short. enlarge by
     1 calling istkin in main program., 68, 4, 2)
c
c  istak(i-1) contains the type for this allocation.
c  istak(i  ) contains lnow for the previous allocation.
c
      istak(i-1) = itype
      istak(i  ) = lnow
      lout = lout+1
      lalc = lalc + 1
      lnow = i
      lused = max0(lused,lnow)
      return
c
 10   jtype = -itype
      i = (lbnd*isize(2)-1)/isize(jtype)
      istkgt = i + 1 - nitems
      i = ((istkgt-1)*isize(jtype))/isize(2) - 1
c
c  stack overflow is an unrecoverable error.
c
      if (lnow.ge.i) call seterr ( 68histkgt - stack too short. enlarge
     1by calling istkin in main program., 68, 4, 2)
c
c  istak(i  ) contains lbnd for previous permanent storage allocation.
c  istak(i+1) contains the type for this allocation.
c
      istak(i) = lbnd
      istak(i+1) = jtype
      lalc = lalc + 1
      lbnd = i
      return
c
      end
      subroutine istkrl (number)
c
c  de-allocates the last (number) allocations made in the stack
c  by istkgt.
c
c  error states -
c
c    1 - number .lt. 0
c    2 - one or more of first seven words in stack overwritten
c    3 - attempt to de-allocate non-existent allocation
c    4 - the pointer at istak(lnow) overwritten
c    5 - a pointer in permanent storage has been overwritten
c
      common /cstak/dstak
c
      double precision dstak(500)
      integer istak(1000)
      logical init
c
      equivalence (dstak(1),istak(1))
      equivalence (istak(1),lout)
      equivalence (istak(2),lnow)
      equivalence (istak(3),lused)
      equivalence (istak(4), lbnd)
      equivalence (istak(5), lmax)
      equivalence (istak(6), lalc)
      equivalence (istak(7),lbook)
c
      data init/.true./
c
      if (init) call i0tk00(init,500,4)
c
      if (number.lt.0) call seterr(20histkrl - number.lt.0,20,1,2)
c
      if (lnow.lt.lbook .or. lnow.gt.lused .or. lused.gt.lmax .or.
     1  lnow.ge.lbnd .or. lout.gt.lalc) call seterr (
     2  61histkgt  one or more of first seven words in stack overwritten
     3  , 61, 3, 2)
c
c
c check all the pointers in the permanent storage area.  they must be
c monotone increasing and less than or equal to lmax, and the index of
c the last pointer must be lmax+1.
c
      ndx = lbnd
      if (ndx.eq.lmax+1) go to 20
      do 10 i=1,lalc
        next = istak(ndx)
        if (next.eq.lmax+1) go to 20
c
        if (next.le.ndx .or. next.gt.lmax) call seterr (
     1    59histkgt  a pointer in permanent storage has been overwritten
     2  , 59, 5, 2)
        ndx = next
 10   continue
      call seterr (59histkgt  a pointer in permanent storage has been ov
     1erwritten, 59, 5, 2)
c
 20   if (number.eq.0) return
      do 30 in=1,number
         if (lnow.le.lbook) call seterr
     1   (55histkrl - attempt to de-allocate non-existent allocation,
     2   55,3,2)
c
c     check to make sure the back pointers are monotone.
c
         if (istak(lnow).lt.lbook.or.istak(lnow).ge.lnow-1) call seterr
     1   (47histkrl - the pointer at istak(lnow) overwritten,
     2   47,4,2)
c
         lout = lout-1
         lnow = istak(lnow)
 30   continue
      return
c
      end
      subroutine istkin (nitems,itype)
c
c  initializes the stack allocator, setting the length of the stack.
c
c  error states -
c
c    1 - nitems .le. 0
c    2 - itype .le. 0 .or. itype .ge. 6
c
      logical init
c
      data init/.true./
c
      if (nitems.le.0) call seterr(20histkin - nitems.le.0,20,1,2)
c
      if (itype.le.0.or.itype.ge.6) call seterr
     1   (33histkin - itype.le.0.or.itype.ge.6,33,2,2)
c
      if (init) call i0tk00(init,nitems,itype)
c
      return
c
      end
      integer function istkqu (itype)
c
c  returns the number of items of type itype that remain
c  to be allocated in one request.
c
c  error states -
c
c    1 - one or more of first seven words in stack overwritten
c    2 - itype .le. 0 .or. itype .ge. 6
c
      common /cstak/dstak
c
      double precision dstak(500)
      integer istak(1000)
      integer isize(5)
      logical init
c
      equivalence (dstak(1),istak(1))
      equivalence (istak(1), lout)
      equivalence (istak(2),lnow)
      equivalence (istak(3),lused)
      equivalence (istak(4), lbnd)
      equivalence (istak(5), lmax)
      equivalence (istak(6), lalc)
      equivalence (istak(7),lbook)
      equivalence (istak(8),isize(1))
c
      data init/.true./
c
      if (init) call i0tk00(init,500,4)
c
      if (lnow.lt.lbook .or. lnow.gt.lused .or. lused.gt.lmax .or.
     1  lnow.ge.lbnd .or. lout.gt.lalc) call seterr (
     2  61histkgt  one or more of first seven words in stack overwritten
     3  , 61, 1, 2)
c
      if (itype.le.0.or.itype.ge.6) call seterr
     1   (33histkqu - itype.le.0.or.itype.ge.6,33,2,2)
c
      istkqu = max0( ((lbnd-3)*isize(2))/isize(itype)
     1             - (lnow*isize(2)-1)/isize(itype)
     2             - 1, 0 )
c
      return
c
      end
      integer function istkmd (nitems)
c
c  changes the length of the frame at the top of the stack
c  to nitems.
c
c  error states -
c
c    1 - lnow overwritten
c    2 - istak(lnowo-1) overwritten
c
      common /cstak/dstak
c
      double precision dstak(500)
      integer istak(1000)
      logical init
c
      equivalence (dstak(1),istak(1))
      equivalence (istak(2),lnow)
c
      data init/.true./
c
      if (init) call i0tk00(init,500,4)
c
      lnowo = lnow
      call istkrl(1)
c
      itype = istak(lnowo-1)
c
      if (itype.le.0.or.itype.ge.6) call seterr
     1   (35histkmd - istak(lnowo-1) overwritten,35,1,2)
c
      istkmd = istkgt(nitems,itype)
c
      return
c
      end
      integer function istkst (nfact)
c
c  returns control information as follows
c
c  nfact    item returned
c
c    1         lout,  the number of current allocations excluding
c                     permanent storage allocations.  at the end of a
c                     run, there should be no active allocations.
c    2         lnow,  the current active length
c    3         ltotal the total maximum storage used so far.
c    4         lmax,  the maximum allowed
c    5         lalc,  the total number of allocations by istkgt so far
c
      common /cstak/dstak
c
      double precision dstak(500)
      integer istak(1000)
      integer istats(4)
      logical init
c
      equivalence (dstak(1),istak(1))
      equivalence (istak(1),istats(1))
c
      data init/.true./
c
      if (init) call i0tk00(init,500,4)
c
      if (nfact.le.0.or.nfact.ge.6) call seterr
     1   (33histkst - nfact.le.0.or.nfact.ge.6, 33, 1, 2)
c
      if (nfact.eq.1) istkst = istats(1)
      if (nfact.eq.2) istkst = istats(2) + (istats(5) - istats(4) + 1)
      if (nfact.eq.3) istkst = istats(3) + (istats(5)-istats(4)+1)
      if (nfact.eq.4) istkst = istats(5)
      if (nfact.eq.5) istkst = istats(6)
c
      return
c
      end
      subroutine i0tk00 (larg, nitems, itype)
c
c  initializes the stack to nitems of type itype
c
      common /cstak/dstak
c
      double precision dstak(500)
      integer istak(1000)
      logical larg,init
      integer isize(5)
c
      equivalence (dstak(1),istak(1))
      equivalence (istak(1),lout)
      equivalence (istak(2),lnow)
      equivalence (istak(3),lused)
      equivalence (istak(4), lbnd)
      equivalence (istak(5), lmax)
      equivalence (istak(6), lalc)
      equivalence (istak(7),lbook)
      equivalence (istak(8),isize(1))
c
      data init/.false./
c
      larg = .false.
      if (init) return
c
c  here to initialize
c
      init = .true.
c
c  set data sizes appropriate for a standard conforming
c  fortran system using the fortran *storage unit* as the
c  measure of size.
c
c  logical
      isize(1) = 1
c  integer
      isize(2) = 1
c  real
      isize(3) = 1
c  double precision
      isize(4) = 2
c  complex
      isize(5) = 2
c
      lbook = 12
      lnow = lbook
      lused = lbook
      lmax = max0( (nitems*isize(itype))/isize(2), lbook+2)
      lbnd = lmax + 1
      lout = 0
      lalc = 0
c
      return
c
      end