SUBROUTINE STKDMP C C THIS PROCEDURE PROVIDES A DUMP OF THE PORT STACK. C C WRITTEN BY D. D. WARNER. C C MOSTLY REWRITTEN BY P. A. FOX, OCTOBER 13, 1982 C AND COMMENTS ADDED. C C ALLOCATED REGIONS OF THE STACK ARE PRINTED OUT IN THE APPROPRIATE C FORMAT, EXCEPT IF THE STACK APPEARS TO HAVE BEEN OVERWRITTEN. C IF OVERWRITE SEEMS TO HAVE HAPPENED, THE ENTIRE STACK IS PRINTED OUT C IN UNSTRUCTURED FORM, ONCE FOR EACH OF THE POSSIBLE C (LOGICAL, INTEGER, REAL, DOUBLE PRECISION, OR COMPLEX) FORMATS. C COMMON /CSTAK/ DSTAK DOUBLE PRECISION DSTAK(500) REAL RSTAK(1000) C/R C REAL CMSTAK(2,500) C/C COMPLEX CMSTAK(500) C/ INTEGER ISTAK(1000) LOGICAL LSTAK(1000) C INTEGER LOUT, LNOW, LUSED, LMAX, LBOOK INTEGER LLOUT, BPNTR INTEGER IPTR, ERROUT, MCOL, NITEMS INTEGER WR, DR, WD, DD, WI INTEGER LNG(5), ISIZE(5) INTEGER I, LNEXT, ITYPE, I1MACH C LOGICAL INIT, TRBL1, TRBL2 C EQUIVALENCE (DSTAK(1), ISTAK(1)) EQUIVALENCE (DSTAK(1), LSTAK(1)) EQUIVALENCE (DSTAK(1), RSTAK(1)) C/R C EQUIVALENCE (DSTAK(1), CMSTAK(1,1)) C/C EQUIVALENCE (DSTAK(1), CMSTAK(1)) C/ EQUIVALENCE (ISTAK(1), LOUT) EQUIVALENCE (ISTAK(2), LNOW) EQUIVALENCE (ISTAK(3), LUSED) EQUIVALENCE (ISTAK(4), LMAX) EQUIVALENCE (ISTAK(5), LBOOK) EQUIVALENCE (ISTAK(6), ISIZE(1)) C DATA MCOL/132/ DATA INIT/.TRUE./ C C I0TK00 CHECKS TO SEE IF THE FIRST TEN, BOOKKEEPING, LOCATIONS OF C THE STACK HAVE BEEN INITIALIZED (AND DOES IT, IF NEEDED). C IF (INIT) CALL I0TK00(INIT, 500, 4) C C C I1MACH(4) IS THE STANDARD ERROR MESSAGE WRITE UNIT. C ERROUT = I1MACH(4) WRITE (ERROUT, 9901) 9901 FORMAT (11H1STACK DUMP) C C C FIND THE MACHINE-DEPENDENT FORMATS FOR PRINTING - BUT ADD 1 TO C THE WIDTH TO GET SEPARATION BETWEEN ITEMS, AND SUBTRACT 1 FROM C THE NUMBER OF DIGITS AFTER THE DECIMAL POINT TO ALLOW FOR THE C 1P IN THE DUMP FORMAT OF 1PEW.D C C (NOTE, THAT ALTHOUGH IT IS NOT NECESSARY, 2 HAS BEEN ADDED TO C THE INTEGER WIDTH, WI, TO CONFORM WITH DAN WARNERS PREVIOUS C USAGE - SO PEOPLE CAN COMPARE DUMPS WITH ONES THEY HAVE HAD C AROUND FOR A LONG TIME.) C CALL FRMATR(WR,DR) CALL FRMATD(WD,DD) CALL FRMATI(WI) C WR = WR+1 WD = WD+1 WI = WI+2 DR = DR-1 DD = DD-1 C C CHECK, IN VARIOUS WAYS, THE BOOKKEEPING PART OF THE STACK TO SEE C IF THINGS WERE OVERWRITTEN. C C LOUT IS THE NUMBER OF CURRENT ALLOCATIONS C LNOW IS THE CURRENT ACTIVE LENGTH OF THE STACK C LUSED IS THE MAXIMUM VALUE OF LNOW ACHIEVED C LMAX IS THE MAXIMUM LENGTH OF THE STACK C LBOOK IS THE NUMBER OF WORDS USED FOR BOOK-KEEPING C TRBL1 = LBOOK .NE. 10 IF (.NOT. TRBL1) TRBL1 = LMAX .LT. 12 IF (.NOT. TRBL1) TRBL1 = LMAX .LT. LUSED IF (.NOT. TRBL1) TRBL1 = LUSED .LT. LNOW IF (.NOT. TRBL1) TRBL1 = LNOW .LT. LBOOK IF (.NOT. TRBL1) TRBL1 = LOUT .LT. 0 IF (.NOT. TRBL1) GO TO 10 C WRITE (ERROUT, 9902) 9902 FORMAT (29H0STACK HEADING IS OVERWRITTEN) WRITE (ERROUT, 9903) 9903 FORMAT (47H UNSTRUCTURED DUMP OF THE DEFAULT STACK FOLLOWS) C C SINCE INFORMATION IS LOST, SIMPLY SET THE USUAL DEFAULT VALUES FOR C THE LENGTH OF THE ENTIRE STACK IN TERMS OF EACH (LOGICAL, INTEGER, C ETC.,) TYPE. C LNG(1) = 1000 LNG(2) = 1000 LNG(3) = 1000 LNG(4) = 500 LNG(5) = 500 C C CALL U9DMP(LNG, MCOL, WI, WR, DR, WD, DD) GO TO 110 C C WRITE OUT THE STORAGE UNITS USED BY EACH TYPE OF VARIABLE C 10 WRITE (ERROUT, 9904) 9904 FORMAT (19H0STORAGE PARAMETERS) WRITE (ERROUT, 9905) ISIZE(1) 9905 FORMAT (18H LOGICAL , I7, 14H STORAGE UNITS) WRITE (ERROUT, 9906) ISIZE(2) 9906 FORMAT (18H INTEGER , I7, 14H STORAGE UNITS) WRITE (ERROUT, 9907) ISIZE(3) 9907 FORMAT (18H REAL , I7, 14H STORAGE UNITS) WRITE (ERROUT, 9908) ISIZE(4) 9908 FORMAT (18H DOUBLE PRECISION , I7, 14H STORAGE UNITS) WRITE (ERROUT, 9909) ISIZE(5) 9909 FORMAT (18H COMPLEX , I7, 14H STORAGE UNITS) C C WRITE OUT THE CURRENT STACK STATISTICS (I.E. USAGE) C WRITE (ERROUT, 9910) 9910 FORMAT (17H0STACK STATISTICS) WRITE (ERROUT, 9911) LMAX 9911 FORMAT (23H STACK SIZE , I7) WRITE (ERROUT, 9912) LUSED 9912 FORMAT (23H MAXIMUM STACK USED , I7) WRITE (ERROUT, 9913) LNOW 9913 FORMAT (23H CURRENT STACK USED , I7) WRITE (ERROUT, 9914) LOUT 9914 FORMAT (23H NUMBER OF ALLOCATIONS , I7) C C HERE AT LEAST THE BOOKKEEPING PART OF THE STACK HAS NOT BEEN C OVERWRITTEN. C C STACKDUMP WORKS BACKWARDS FROM THE END (MOST RECENT ALLOCATION) OF C THE STACK, PRINTING INFORMATION, BUT ALWAYS CHECKING TO SEE IF C THE POINTERS FOR AN ALLOCATION HAVE BEEN OVERWRITTEN. C C LLOUT COUNTS THE NUMBER OF ALLOCATIONS STILL LEFT TO PRINT C SO LLOUT IS INITIALLY LOUT OR ISTAK(1). C C THE STACK ALLOCATION ROUTINE PUTS, AT THE END OF EACH ALLOCATION, C TWO EXTRA SPACES - ONE FOR THE TYPE OF THE ALLOCATION AND THE NEXT C TO HOLD A BACK POINTER TO THE PREVIOUS ALLOCATION. C THE BACK POINTER IS THEREFORE INITIALLY LOCATED AT THE INITIAL END, C LNOW, OF THE STACK. C CALL THIS LOCATION BPNTR. C LLOUT = LOUT BPNTR = LNOW C C IF WE ARE DONE, THE BACK POINTER POINTS BACK INTO THE BOOKKEEPING C PART OF THE STACK. C C IF WE ARE NOT DONE, OBTAIN THE NEXT REGION TO PRINT AND GET ITS TYPE. C 20 IF (BPNTR .LE. LBOOK) GO TO 110 C LNEXT = ISTAK(BPNTR) ITYPE = ISTAK(BPNTR-1) C C SEE IF ANY OF THESE NEW DATA ARE INCONSISTENT - WHICH WOULD SIGNAL C AN OVERWRITE. C TRBL2 = LNEXT .LT. LBOOK IF (.NOT. TRBL2) TRBL2 = BPNTR .LE. LNEXT IF (.NOT. TRBL2) TRBL2 = ITYPE .LT. 0 IF (.NOT. TRBL2) TRBL2 = 5 .LT. ITYPE IF (.NOT. TRBL2) GO TO 40 C C HERE THERE SEEMS TO HAVE BEEN A PARTIAL OVERWRITE. C COMPUTE THE LENGTH OF THE ENTIRE STACK IN TERMS OF THE VALUES GIVEN C IN THE BOOKKEEPING PART OF THE STACK (WHICH, AT LEAST, SEEMS NOT TO C HAVE BEEN OVERWRITTEN), AND DO AN UNFORMATTED DUMP, AND RETURN. C WRITE (ERROUT, 9915) 9915 FORMAT (28H0STACK PARTIALLY OVERWRITTEN) WRITE (ERROUT, 9916) 9916 FORMAT (45H UNSTRUCTURED DUMP OF REMAINING STACK FOLLOWS) C DO 30 I = 1, 5 LNG(I) = (BPNTR*ISIZE(2)-1)/ISIZE(I)+1 30 CONTINUE C CALL U9DMP(LNG, MCOL, WI, WR, DR, WD, DD) GO TO 110 C C C COMES HERE EACH TIME TO PRINT NEXT (BACK) ALLOCATION. C C AT THIS POINT BPNTR POINTS TO THE END OF THE ALLOCATION ABOUT TO C BE PRINTED, LNEXT = ISTAK(BPNTR) POINTS BACK TO THE END OF THE C PREVIOUS ALLOCATION, AND ITYPE = ISTAK(BPNTR-1) GIVES THE TYPE OF C THE ALLOCATION ABOUT TO BE PRINTED. C C THE PRINTING ROUTINES NEED TO KNOW THE START OF THE ALLOCATION AND C THE NUMBER OF ITEMS. C THESE ARE COMPUTED FROM THE EQUATIONS USED WHEN THE FUNCTION ISTKGT C COMPUTED THE ORIGINAL ALLOCATION - THE POINTER TO THE C START OF THE ALLOCATION WAS COMPUTED BY ISTKGT FROM THE (THEN) C END OF THE PREVIOUS ALLOCATION VIA THE FORMULA, C C ISTKGT = (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) + 2 C 40 IPTR = (LNEXT*ISIZE(2)-1)/ISIZE(ITYPE) + 2 C C THE FUNCTION ISTKGT THEN FOUND NEW END OF THE STACK, LNOW, FROM THE C FORMULA C C I = ( (ISTKGT-1+NITEMS)*ISIZE(ITYPE) - 1 )/ISIZE(2) + 3 C C HERE WE SOLVE THIS FOR NITEMS TO DETERMINE THE NUMBER OF LOCATIONS C IN THIS ALLOCATION. C NITEMS = 1-IPTR + ((BPNTR-3)*ISIZE(2)+1)/ISIZE(ITYPE) C C C USE THE TYPE (INTEGER, REAL, ETC.) TO DTERMINE WHICH PRINTING C ROUTINE TO USE. C IF (ITYPE .EQ. 1) GO TO 50 IF (ITYPE .EQ. 2) GO TO 60 IF (ITYPE .EQ. 3) GO TO 70 IF (ITYPE .EQ. 4) GO TO 80 IF (ITYPE .EQ. 5) GO TO 90 C 50 WRITE (ERROUT, 9917) LLOUT, IPTR 9917 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =, 1 I7, 23H, TYPE LOGICAL) CALL A9RNTL(LSTAK(IPTR), NITEMS, ERROUT, MCOL) GO TO 100 C 60 WRITE (ERROUT, 9918) LLOUT, IPTR 9918 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =, 1 I7, 23H, TYPE INTEGER) CALL A9RNTI(ISTAK(IPTR), NITEMS, ERROUT, MCOL, WI) GO TO 100 C 70 WRITE (ERROUT, 9919) LLOUT, IPTR 9919 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =, 1 I7, 20H, TYPE REAL) CALL A9RNTR(RSTAK(IPTR), NITEMS, ERROUT, MCOL, WR, DR) GO TO 100 C 80 WRITE (ERROUT, 9920) LLOUT, IPTR 9920 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =, 1 I7, 32H, TYPE DOUBLE PRECISION) CALL A9RNTD(DSTAK(IPTR), NITEMS, ERROUT, MCOL, WD, DD) GO TO 100 C 90 WRITE (ERROUT, 9921) LLOUT, IPTR 9921 FORMAT (13H0ALLOCATION =, I7, 20H, POINTER =, 1 I7, 23H, TYPE COMPLEX) C/R C CALL A9RNTC(CMSTAK(1,IPTR), NITEMS, ERROUT, MCOL, WR,DR) C/C CALL A9RNTC(CMSTAK(IPTR), NITEMS, ERROUT, MCOL, WR, DR) C/ C 100 BPNTR = LNEXT LLOUT = LLOUT-1 GO TO 20 C 110 WRITE (ERROUT, 9922) 9922 FORMAT (18H0END OF STACK DUMP) RETURN END