subroutine istkrl (number) c c de-allocates the last (number) allocations made in the stack c by istkrl. c c error states - c c 1 - number .lt. 0 c 2 - one or more of first eight 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), lneed) equivalence (istak(8), 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. lnow 1 .ge.lbnd .or. lout.gt.lalc) call seterr ( 2 61histkrl one or more of first eight words in stack overwritten 3 , 61, 3, 2) 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 59histkrl a pointer in permanent storage has been overwritten 2 , 59, 5, 2) ndx = next 10 continue call seterr ( 1 59histkrl a pointer in permanent storage has been overwritten, 2 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 1 seterr (47histkrl - the pointer at istak(lnow) overwritten, 2 47, 4, 2) c lout = lout - 1 lnow = istak(lnow) 30 continue return c end