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