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 6 - double complex c 7 - quadruple precision c 8 - quadruple precision complex c 9 - half integer 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 the allocator reserves the first 14 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 ten 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) - lneed the number of words by which the stack c must be increased for all past c allocations to succeed. c istak( 8) - lbook the number of words used for bookkeeping. c istak( 9) - lchar the pointer in the (permanent) stack for the c character stack bookkeeping array and ptrs. c istak(10) - llchar the length of the character bookkeeping array. c c the next six 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(11) - the number of units allocated to logical c istak(12) - the number of units allocated to integer c istak(13) - the number of units allocated to real c istak(14) - the number of units allocated to double precision c istak(15) - the number of units allocated to complex c istak(16) - the number of units allocated to double complex c istak(17) - the number of units allocated to quad precision c istak(18) - the number of units allocated to quad complex c c error states - c c 1 - nitems .lt. 0 c 2 - itype .le. 0 .or. itype .ge. 7 c 3 - one or more of first eight 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(6) 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) equivalence (istak(11), 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.7) call 1 seterr (34histkgt itype.eq.0 .or. itype.ge.7, 34, 2, 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 61histkgt one or more of first eight 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 b 1y 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) lneed = 0 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 b 1y 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 lneed = 0 return c end