TESTING THE PORT UTILITIES P. A. FOX, A. D. HALL, AND N. L. SCHRYER FEBRUARY 1978 THE TAPE ON WHICH YOU FOUND THIS DOCUMENT HAS THREE FILES: FILE 1 - THIS OPERATIONS GUIDE FILE 2 - FORTRAN SOURCE FOR THE PORT UTILITY PROGRAMS FILE 3 - TEST PROGRAMS THE NAMES OF THE PORT UTILITY SUBPROGRAMS, WHOSE SOURCE IS PROVIDED ON THE SECOND FILE, ARE LISTED BELOW IN AN ORDER CONSISTENT WITH THE REQUIREMENTS OF A ONE-PASS LOADER: SUBPROGRAMS INVOKED BY OTHER SUBPROGRAMS COME AFTER THEIR INVOKERS ON THE LIST. ENTSRC RETSRC ISTKQU ISTKMD ISTKRL ISTKGT ISTKIN ISTKST I0TK00 R1MACH D1MACH NERROR ERROFF SETERR EPRINT E9RINT I1MACH I8SAVE S88FMT FDUMP SUBPROGRAMS CONSTITUTING THE PORT UTILITIES FEBRUARY 1978 - 1 - PORT UTILITIES TESTS IN THIS OPERATIONS GUIDE WE DESCRIBE THE TESTS TO BE USED IN CHECKING THAT THE PORT UTILITIES, THAT IS, THE MACHINE- CONSTANTS FUNCTIONS, THE AUTOMATIC ERROR HANDLING ROUTINES, AND THE STACK ALLOCATION ROUTINES, ARE ALL OPERATING COR- RECTLY ON A COMPUTER AFTER THEY HAVE BEEN INSTALLED. THE THIRD FILE ON THIS TAPE CONTAINS THE FOLLOWING TESTS: A TEST OF THE PORT LINGUISTIC HYPOTHESES A TEST OF THE INSTALLATION OF THE MACHINE CONSTANTS THREE TESTS OF THE AUTOMATIC ERROR HANDLING TWO TESTS OF THE STACK ALLOCATOR EACH TEST IS A SELF-CONTAINED PROGRAM CONSISTING OF A MAIN PROGRAM AND PERHAPS ONE OR MORE SUBPROGRAMS. BEFORE RUNNING THE TESTS, THE THREE PORT FUNCTIONS, R1MACH, D1MACH, AND I1MACH, WHICH RETURN REAL, FLOATING-POINT, AND INTEGER CONSTANTS, RESPECTIVELY, MUST BE SET FOR THE COM- PUTER ON WHICH THE TESTS ARE TO BE RUN. IN PARTICULAR, THE OUTPUT FROM THE TESTS IS WRITTEN ON THE LOGICAL UNIT SPECIFIED BY I1MACH(2). WITHIN THESE THREE FUNCTIONS, APPROPRIATE CONSTANTS HAVE BEEN SPECIFIED FOR MANY COMPUTER CLASSES, AND CONSTANTS FOR YET OTHER MACHINES CAN EASILY BE ADDED. THE NUMERICAL VALUES, IN THE FUNCTIONS, ARE GIVEN IN FORTRAN DATA STATE- MENTS MADE INTO COMMENTS BY A C IN COLUMN 1. TO ADAPT THE FUNCTIONS TO A GIVEN COMPUTER, THE CORRESPONDING DATA STATE- MENTS MUST BE MADE ACTIVE BY MAKING EACH INITIAL C INTO A BLANK. AFTER THE THREE MACHINE-CONSTANTS FUNCTIONS HAVE BEEN PAR- TICULARIZED TO THE HOST COMPUTER, THEY AND THE REST OF THE SUBPROGRAMS CONSTITUTING THE PORT UTILITIES (LISTED ABOVE) SHOULD BE COMPILED ONTO AN OBJECT LIBRARY FOR USE BY THE TEST PROGRAMS. FEBRUARY 1978 - 2 - PORT UTILITIES TESTS TESTING THE PORT LINGUISTIC HYPOTHESES THIS TEST CONSISTS OF ONE MAIN PROGRAM AND SOME SUBPROGRAMS. THESE PROGRAMS SHOULD BE RUN TO TEST THE FOLLOWING PREMISES MADE IN PORT ON THE COMPILING AND RUNNING OF FORTRAN PROGRAMS: 1. A VARIABLE (LOCAL TO A SUBPROGRAM) THAT IS INITIALIZED BY A DATA STATEMENT AND THEN CHANGED WITHIN THE SUB- C PROGRAM, RETAINS ITS MOST RECENTLY ASSIGNED VALUE FROM ONE INVOCATION TO THE NEXT. 2. THERE IS NO SUBSCRIPT RANGE CHECKING FOR DUMMY ARRAYS OR ARRAYS IN COMMON. THUS AN ARRAY WHICH IS A PARAMETER IN A CALL TO A SUBPROGRAM, OR WHICH IS IN A NAMED COMMON REGION, MAY BE INDEXED BEYOND ITS LOCALLY DECLARED LENGTH. 3. IT IS LEGAL FOR A NAMED COMMON REGION TO BE DECLARED OF DIFFERENT LENGTHS IN VARIOUS SUBPROGRAMS. THE LENGTH ASSIGNED BY THE OPERATING SYSTEM TO SUCH A COM- MON REGION MUST BE THE LENGTH DECLARED IN THE MAIN C PROGRAM. IF THIS TEST RUNS CORRECTLY, ONLY THE FOLLOWING LINE WILL BE PRINTED OUT: TEST OF PORT LINGUISTIC HYPOTHESES COMPLETE. IF THE TEST FINDS ERRORS, APPROPRIATE DIAGNOSTICS WILL BE PRINTED. FEBRUARY 1978 - 3 - PORT UTILITIES TESTS TESTING THE MACHINE CONSTANT FUNCTIONS THIS TEST, CONSISTING OF A MAIN PROGRAM WITH SOME ASSOCIATED SUBPROGRAMS, CHECKS THAT THE THREE PORT FUNCTIONS, R1MACH, D1MACH, AND I1MACH, WHICH ARE USED TO OBTAIN MACHINE- DEPENDENT CONSTANTS, HAVE BEEN CORRECTLY ADAPTED TO THE COM- PUTER USING THE PROCEDURE DESCRIBED ON PAGE 2. A CHECK FOR THE CONSISTENCY OF THE CONSTANTS IS MADE BY COMPARING THE REAL AND DOUBLE-PRECISION CONSTANTS GIVEN BY R1MACH AND D1MACH WITH THE CORRESPONDING VALUES COMPUTED FROM THE IN- TEGER SPECIFICATIONS GIVEN IN I1MACH. THE OUTPUT FROM THIS TEST RUN ON AN IBM 370 COMPUTER IS GIVEN ON THE NEXT PAGE FOR REFERENCE. THE DISAGREEMENT SHOWN AT THE END FOR THE VALUE OF D1MACH(5) SAYS THAT THE VALUE OF THE LOG (TO THE BASE TEN) OF THE BASE OF THE MACHINE AS PROVIDED BY D1MACH DOES NOT AGREE WITH THE VALUE CALCULATED USING THE LOG ROUTINE ON THE LOCAL COM- PUTER'S FORTRAN LIBRARY. THIS USUALLY OCCURS BECAUSE THE LOG ROUTINE DOES NOT CALCULATE THE VALUES TO THE ACCURACY (LAST BIT) PROVIDED IN D1MACH. FEBRUARY 1978 - 4 - PORT UTILITIES TESTS FORMAT CONVERSION FOR INTEGERS IS - I12 INTEGER CONSTANTS FOLLOW THE STANDARD INPUT UNIT 5 THE STANDARD OUTPUT UNIT 6 THE STANDARD PUNCH UNIT 7 THE STANDARD ERROR MESSAGE UNIT 6 THE NUMBER OF BITS PER WORD 32 THE NUMBER OF CHARACTERS PER WORD 4 A, THE BASE OF AN S-DIGIT INTEGER 2 S, THE NUMBER OF BASE-A DIGITS 31 A**S - 1, THE LARGEST MAGNITUDE 2147483647 B, THE BASE OF A T-DIGIT FLOATING-POINT NUMBER 16 T, THE NUMBER OF BASE-B DIGITS IN SINGLE-PRECISION 6 EMIN, THE SMALLEST SINGLE-PRECISION EXPONENT -64 EMAX, THE LARGEST SINGLE-PRECISION EXPONENT 63 T, THE NUMBER OF BASE-B DIGITS IN DOUBLE-PRECISION 14 EMIN, THE SMALLEST DOUBLE-PRECISION EXPONENT -64 EMAX, THE LARGEST DOUBLE-PRECISION EXPONENT 63 FORMAT CONVERSION FOR SINGLE-PRECISION IS - E16.08 SINGLE-PRECISION CONSTANTS FOLLOW THE SMALLEST POSITIVE MAGNITUDE 0.53976053E-78 THE LARGEST MAGNITUDE 0.72370051E+76 THE SMALLEST RELATIVE SPACING 0.59604645E-07 THE LARGEST RELATIVE SPACING 0.95367432E-06 LOG10 OF THE BASE 0.12041197E+01 FORMAT CONVERSION FOR DOUBLE-PRECISION IS - D25.17 DOUBLE-PRECISION CONSTANTS FOLLOW THE SMALLEST POSITIVE MAGNITUDE 0.53976053469340279D-78 THE LARGEST MAGNITUDE 0.72370055773322621D+76 THE SMALLEST RELATIVE SPACING 0.13877787807814457D-16 THE LARGEST RELATIVE SPACING 0.22204460492503131D-15 LOG10 OF THE BASE 0.12041199826559248D+01 D1MACH(5) DOES NOT AGREE WITH CALCULATED VALUE D1MACH(5) = 0.120411998265592479D+01 CALCULATED VALUE = 0.120411998265592457D+01 DIFFERENCE = 0.222044604925031308D-15 MACHINE-CONSTANT TEST: IBM 370 OUTPUT FEBRUARY 1978 - 5 - PORT UTILITIES TESTS TESTING THE AUTOMATIC ERROR HANDLING THERE ARE THREE MAIN PROGRAMS FOR TESTING ERROR HANDLING: THE FOLLOWING PARAGRAPHS DESCRIBE THE ACTIONS THAT ARE TAKEN BY THESE PROGRAMS AND THE OUTPUT THAT SHOULD BE PRODUCED. 1. THE FIRST MAIN PROGRAM TESTS RECOVERABLE ERRORS. IT CHECKS THAT THE RECOVERY STATE IS CORRECTLY TURNED ON AND OFF BY THE PAIR OF PORT SUBPROGRAMS ENTSRC AND RETSRC, AND THAT THE ERROR-SETTING SUBPROGRAM, SETERR, THE ERROR-PRINTING SUBPROGRAM, EPRINT, AND THE SUBPROGRAM TO TURN OFF THE ERROR STATE, ERROFF, ALL WORK CORRECTLY. THE TEST STARTS OUT BY ENTERING THE RECOVERY MODE, SETTING AN ERROR AND PRINTING THE ERROR USING EPRINT. THE OUTPUT SHOULD BE ERROR 1 IN FIRST ERROR TEST - RECOVERABLE ERROR OK THE ERROR STATE IS THEN TURNED OFF, USING THE SUB- C PROGRAM ERROFF, AND A CHECK IS MADE TO BE SURE THAT IT IS OFF AND THAT NO ERROR MESSAGE IS OUTSTANDING. (THE SECOND EPRINT SHOULD FIND NO MESSAGE AND HAVE NO OUTPUT.) FINALLY A NEW RECOVERABLE ERROR IS SET WITH THE MES- SAGE ERROR 2 IN SAME TEST - LEAVING RECOVERY MODE AND THE RECOVERY MODE IS SET TO NONRECOVERY USING THE SUBPROGRAM RETSRC, BUT SINCE IT IS ILLEGAL TO LEAVE THE RECOVERY STATE WHEN AN UNRECOVERED ERROR IS OUT- STANDING, THE ABOVE MESSAGE IS PRINTED OUT AND THE RUN TERMINATED. FEBRUARY 1978 - 6 - PORT UTILITIES TESTS TESTING THE AUTOMATIC ERROR HANDLING, CONTINUED 2. THE SECOND MAIN PROGRAM FOR TESTING ERROR-HANDLING TESTS FATAL ERRORS. A CALL IS MADE TO THE SUBPROGRAM, SETERR, SIGNALING A FATAL ERROR BY SETTING THE LAST ARGUMENT IN THE CALL, IOPT, TO 2. THIS SHOULD CAUSE THE FOLLOWING MESSAGE TO BE PRINTED, THE DUMP SUBPROGRAM, FDUMP, TO BE CALLED AND THE RUN TERMINATED. ERROR 1 IN SECOND ERROR TEST - FATAL ERROR CHECKED THE FDUMP ROUTINE SENT OUT WITH THE PORT UTILITIES IS A SIMPLE, DUMMY, RETURN-END SUBPROGRAM. INDIVIDUAL SITES SHOULD PROVIDE A LOCAL VERSION. 3. THE THIRD MAIN PROGRAM FOR TESTING ERROR HANDLING CHECKS THAT THE OCCURRENCE OF TWO RECOVERABLE ERRORS IN A ROW CAUSES A FATAL ERROR. THIS SITUATION CAN ONLY ARISE WHEN THE USER HAS GONE INTO THE RECOVERY MODE, BECAUSE OTHERWISE THE FIRST ERROR IS CONSIDERED FATAL. IN THE RECOVERY MODE, THE USER IS EXPECTED TO RECOVER FROM A RECOVERABLE ERROR AND TURN IT OFF BEFORE RESUMING EXECUTION. THE TEST PROGRAM SETS THE FIRST RECOVERABLE ERROR BY CALLING SETERR, AND THEN CALLS IT AGAIN TO SET ANOTHER. ON THE SECOND CALL SETERR SHOULD SIGNAL A FATAL ERROR, BY PRINTING THE FOLLOWING ERROR MES- SAGES, PROVIDING A DUMP AND TERMINATING THE RUN. ERROR 3 IN SETERR - AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR. THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW. ERROR 1 IN MAIN - FIRST RECOVERABLE ERROR ERROR 2 IN MAIN - SECOND RECOVERABLE ERROR FEBRUARY 1978 - 7 - PORT UTILITIES TESTS TESTING THE STACK ALLOCATOR THERE ARE TWO TESTS TO BE USED FOR TESTING THE STORAGE ALLOCATION PACKAGE. EACH OF THESE TESTS CON- SISTS OF A MAIN PROGAM AND ASSOCIATED SUBPROGRAMS. THE FIRST TEST IS USED TO TEST THE STANDARD CASE WHEN THE STACK IS AUTOMATICALLY SET TO ITS DEFAULT LENGTH; THE SECOND TEST IS USED TO TEST THE ALTERNATIVE SITUATION WHERE THE USER HAS INITIALLY SET THE STACK TO A DIFFERENT (NON-DEFAULT) LENGTH. 1. THE FIRST ALLOCATOR TEST USES THE PORT DEFAULT STACK LENGTH OF 500 DOUBLE-PRECISION LOCATIONS. THE TEST PROCEDURE CONSISTS OF A NUMBER OF ALLOCATIONS AND AS- SIGNMENTS OF VALUES ON THE STACK, FOLLOWED BY DE- ALLOCATIONS AND CHECKING FOR CONSISTENCY. REAL, DOUBLE-PRECISION, COMPLEX, INTEGER AND LOGICAL VALUES ARE PUT ON THE STACK IN ALTERNATING PATTERNS, AND THEN RELEASED. ALL THE STACK-HANDLING ROUTINES ARE CALLED INTO PLAY TO BE SURE THE MECHANISM IS WORKING AS IT SHOULD. BEFORE THE TEST IS RUN THE FOLLOWING LINE IS PRINTED BY THE TEST PROGRAM: AN ERROR BELOW INDICATES TROUBLE WITH THE STORAGE ALLOCATOR, WHEN USING THE STACK WITH DEFAULT LENGTH. THEN, IF NO ERRORS HAVE BEEN FOUND DURING THE FIRST PART OF THIS TEST, THE FOLLOWING MESSAGE APPEARS: FIRST STORAGE ALLOCATION TEST COMPLETE. FINALLY, THE TEST PROGRAM FORCES AN ERROR BY RE- QUESTING MORE SPACE THAN IS LEFT ON THE STACK, AND THE FOLLOWING IS PRINTED, A CALL TO FDUMP MADE AND THE RUN TERMINATED. NOW FORCE AN ERROR BY REQUESTING TOO MUCH SPACE. ERROR 4 IN ISTKGT - STACK TOO SHORT. ENLARGE IT AND CALL ISTKIN IN MAIN PROGRAM. FEBRUARY 1978 - 8 - PORT UTILITIES TESTS TESTING THE STACK ALLOCATOR, CONTINUED 2. THE SECOND STACK ALLOCATOR TEST IS EXACTLY THE SAME AS THE FIRST EXCEPT THAT THE STACK IS FIRST INITIALIZED, IN THE MAIN TEST PROGRAM, TO A LENGTH OF 5000 DOUBLE-PRECISION LOCATIONS. BEFORE THE TEST IS RUN, THE FOLLOWING MESSAGE IS PRINTED: AN ERROR BELOW INDICATES TROUBLE WITH THE ALLOCATOR, WHEN USING A STACK INITIALIZED TO NON-DEFAULT LENGTH. THEN, AGAIN, AFTER THE FIRST PART OF THE TEST IS RUN, PROVIDED NO ERRORS HAVE BEEN FOUND, THE FOLLOWING MESSAGE APPEARS: SECOND STORAGE ALLOCATOR TEST COMPLETE. FINALLY, THE TEST PROGRAM FORCES AN ERROR BY RE- QUESTING MORE SPACE THAN IS LEFT ON THE STACK, AND THE FOLLOWING IS PRINTED, A CALL TO FDUMP MADE AND THE RUN TERMINATED. NOW FORCE AN ERROR BY REQUESTING TOO MUCH SPACE. ERROR 4 IN ISTKGT - STACK TOO SHORT. ENLARGE IT AND CALL ISTKIN IN MAIN PROGRAM. FEBRUARY 1978 - 9 - PORT UTILITIES TESTS SUBROUTINE ENTSRC(IROLD,IRNEW) C C THIS ROUTINE RETURNS IROLD = LRECOV AND SETS LRECOV = IRNEW. C C IF THERE IS AN ACTIVE ERROR STATE, THE MESSAGE IS PRINTED C AND EXECUTION STOPS. C C IRNEW = 0 LEAVES LRECOV UNCHANGED, WHILE C IRNEW = 1 GIVES RECOVERY AND C IRNEW = 2 TURNS RECOVERY OFF. C C ERROR STATES - C C 1 - ILLEGAL VALUE OF IRNEW. C 2 - CALLED WHILE IN AN ERROR STATE. C IF (IRNEW.LT.0 .OR. IRNEW.GT.2) 1 CALL SETERR(31HENTSRC - ILLEGAL VALUE OF IRNEW,31,1,2) C IROLD=I8SAVE(2,IRNEW,IRNEW.NE.0) C C IF HAVE AN ERROR STATE, STOP EXECUTION. C IF (I8SAVE(1,0,.FALSE.) .NE. 0) CALL SETERR 1 (39HENTSRC - CALLED WHILE IN AN ERROR STATE,39,2,2) C RETURN C END SUBROUTINE RETSRC(IROLD) RECB0000 C C THIS ROUTINE SETS LRECOV = IROLD. C C IF THE CURRENT ERROR BECOMES UNRECOVERABLE, C THE MESSAGE IS PRINTED AND EXECUTION STOPS. C C ERROR STATES - C C 1 - ILLEGAL VALUE OF IROLD. C IF (IROLD.LT.1 .OR. IROLD.GT.2) 1 CALL SETERR(31HRETSRC - ILLEGAL VALUE OF IROLD,31,1,2) C ITEMP=I8SAVE(2,IROLD,.TRUE.) C C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP. C IF (IROLD.EQ.1 .OR. I8SAVE(1,0,.FALSE.).EQ.0) RETURN C CALL EPRINT STOP C END INTEGER FUNCTION ISTKQU(ITYPE) STKA0000 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 - LNOW, LUSED, LMAX OR LBOOK 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) C LOGICAL INIT C EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(2),LNOW) EQUIVALENCE (ISTAK(3),LUSED) EQUIVALENCE (ISTAK(4),LMAX) EQUIVALENCE (ISTAK(5),LBOOK) EQUIVALENCE (ISTAK(6),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) CALL SETERR 1 (47HISTKQU - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN, 2 47,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( ((LMAX-2)*ISIZE(2))/ISIZE(ITYPE) 1 - (LNOW*ISIZE(2)-1)/ISIZE(ITYPE) 2 - 1, 0 ) C RETURN C END INTEGER FUNCTION ISTKMD(NITEMS) STKB0000 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) C EQUIVALENCE (DSTAK(1),ISTAK(1)) EQUIVALENCE (ISTAK(2),LNOW) 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 SUBROUTINE ISTKRL(NUMBER) STKC0000 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 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN C 3 - ATTEMPT TO DE-ALLOCATE NON-EXISTENT ALLOCATION C 4 - THE POINTER AT ISTAK(LNOW) 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),LMAX) EQUIVALENCE (ISTAK(5),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) CALL SETERR 1 (47HISTKRL - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN, 2 47,2,2) C IN = NUMBER 10 IF (IN.EQ.0) RETURN C 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) IN = IN-1 GO TO 10 C END INTEGER FUNCTION ISTKGT(NITEMS,ITYPE) STKE0000 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 MACHINE 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 TEN 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 FIVE 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) - LMAX, THE MAXIMUM LENGTH THE STACK. C ISTAK( 5) - LBOOK, THE NUMBER OF WORDS USED FOR BOOKEEPING. 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( 6) - THE NUMBER OF UNITS ALLOCATED TO LOGICAL C ISTAK( 7) - THE NUMBER OF UNITS ALLOCATED TO INTEGER C ISTAK( 8) - THE NUMBER OF UNITS ALLOCATED TO REAL C ISTAK( 9) - THE NUMBER OF UNITS ALLOCATED TO DOUBLE PRECISION C ISTAK(10) - 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 - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN C 4 - STACK OVERFLOW C COMMON /CSTAK/DSTAK C DOUBLE PRECISION DSTAK(500) INTEGER ISTAK(1000) INTEGER ISIZE(5) C LOGICAL INIT C EQUIVALENCE (DSTAK(1),ISTAK(1)) 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 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.LE.0 .OR. ITYPE.GE.6) CALL SETERR 1 (33HISTKGT - ITYPE.LE.0.OR.ITYPE.GE.6,33,2,2) C IF (LNOW.LT.LBOOK.OR.LNOW.GT.LUSED.OR.LUSED.GT.LMAX) CALL SETERR 1 (47HISTKGT - LNOW, LUSED, LMAX OR LBOOK OVERWRITTEN, 2 47,3,2) C 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.GT.LMAX) CALL SETERR(69HISTKGT - STACK TOO SHORT. ENLARGE IT 1 AND CALL ISTKIN IN MAIN PROGRAM.,69,4,2) C C ISTAK(I-1) CONTAINS THE TYPE FOR THIS ALLOCATION. C ISTAK(I ) CONTAINS A POINTER TO THE END OF THE PREVIOUS C ALLOCATION. C ISTAK(I-1) = ITYPE ISTAK(I ) = LNOW LOUT = LOUT+1 LNOW = I LUSED = MAX0(LUSED,LNOW) C RETURN C END SUBROUTINE ISTKIN(NITEMS,ITYPE) STKF0000 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 ISTKST(NFACT) STKS0000 C C RETURNS CONTROL INFORMATION AS FOLLOWS C C NFACT ITEM RETURNED C C 1 LOUT, THE NUMBER OF CURRENT ALLOCATIONS C 2 LNOW, THE CURRENT ACTIVE LENGTH C 3 LUSED, THE MAXIMUM USED C 4 LMAX, THE MAXIMUM ALLOWED 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.5) CALL SETERR 1 (33HISTKST - NFACT.LE.0.OR.NFACT.GE.5,33,1,2) C ISTKST = ISTATS(NFACT) C RETURN C END SUBROUTINE I0TK00(LARG,NITEMS,ITYPE) STKG0000 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),LMAX) EQUIVALENCE (ISTAK(5),LBOOK) EQUIVALENCE (ISTAK(6),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 = 10 LNOW = LBOOK LUSED = LBOOK LMAX = MAX0( (NITEMS*ISIZE(ITYPE))/ISIZE(2), 12 ) LOUT = 0 C RETURN C END REAL FUNCTION R1MACH(I) MCHR0000 C C SINGLE-PRECISION MACHINE CONSTANTS C C R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. C C R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING. C C R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING. C C R1MACH(5) = LOG10(B) C C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY C REMOVING THE C FROM COLUMN 1. C C WHERE POSSIBLE, OCTAL OR HEXADECIMAL CONSTANTS HAVE BEEN USED C TO SPECIFY THE CONSTANTS EXACTLY WHICH HAS IN SOME CASES C REQUIRED THE USE OF EQUIVALENT INTEGER ARRAYS. C INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) C REAL RMACH(5) C EQUIVALENCE (RMACH(1),SMALL(1)) EQUIVALENCE (RMACH(2),LARGE(1)) EQUIVALENCE (RMACH(3),RIGHT(1)) EQUIVALENCE (RMACH(4),DIVER(1)) EQUIVALENCE (RMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C C DATA RMACH(1) / Z400800000 / C DATA RMACH(2) / Z5FFFFFFFF / C DATA RMACH(3) / Z4E9800000 / C DATA RMACH(4) / Z4EA800000 / C DATA RMACH(5) / Z500E730E8 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS. C C DATA RMACH(1) / O1771000000000000 / C DATA RMACH(2) / O0777777777777777 / C DATA RMACH(3) / O1311000000000000 / C DATA RMACH(4) / O1301000000000000 / C DATA RMACH(5) / O1157163034761675 / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. C C DATA RMACH(1) / 00014000000000000000B / C DATA RMACH(2) / 37767777777777777777B / C DATA RMACH(3) / 16404000000000000000B / C DATA RMACH(4) / 16414000000000000000B / C DATA RMACH(5) / 17164642023241175720B / C C MACHINE CONSTANTS FOR THE CRAY 1 C C DATA RMACH(1) / 200004000000000000000B / C DATA RMACH(2) / 577777777777777777777B / C DATA RMACH(3) / 377214000000000000000B / C DATA RMACH(4) / 377224000000000000000B / C DATA RMACH(5) / 377774642023241175720B / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - C STATIC RMACH(5) C C DATA SMALL/20K,0/,LARGE/77777K,177777K/ C DATA RIGHT/35420K,0/,DIVER/36020K,0/ C DATA LOG10/40423K,42023K/ C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / C DATA LARGE(1),LARGE(2) / '37777777, '00000177 / C DATA RIGHT(1),RIGHT(2) / '20000000, '00000352 / C DATA DIVER(1),DIVER(2) / '20000000, '00000353 / C DATA LOG10(1),LOG10(2) / '23210115, '00000377 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. C C DATA RMACH(1) / O402400000000 / C DATA RMACH(2) / O376777777777 / C DATA RMACH(3) / O714400000000 / C DATA RMACH(4) / O716400000000 / C DATA RMACH(5) / O776464202324 / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. C C DATA RMACH(1) / Z00100000 / C DATA RMACH(2) / Z7FFFFFFF / C DATA RMACH(3) / Z3B100000 / C DATA RMACH(4) / Z3C100000 / C DATA RMACH(5) / Z41134413 / C C MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR). C C DATA RMACH(1) / "000400000000 / C DATA RMACH(2) / "377777777777 / C DATA RMACH(3) / "146400000000 / C DATA RMACH(4) / "147400000000 / C DATA RMACH(5) / "177464202324 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1) / 8388608 / C DATA LARGE(1) / 2147483647 / C DATA RIGHT(1) / 880803840 / C DATA DIVER(1) / 889192448 / C DATA LOG10(1) / 1067065499 / C C DATA RMACH(1) / O00040000000 / C DATA RMACH(2) / O17777777777 / C DATA RMACH(3) / O06440000000 / C DATA RMACH(4) / O06500000000 / C DATA RMACH(5) / O07746420233 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1),SMALL(2) / 128, 0 / C DATA LARGE(1),LARGE(2) / 32767, -1 / C DATA RIGHT(1),RIGHT(2) / 13440, 0 / C DATA DIVER(1),DIVER(2) / 13568, 0 / C DATA LOG10(1),LOG10(2) / 16282, 8347 / C C DATA SMALL(1),SMALL(2) / O000200, O000000 / C DATA LARGE(1),LARGE(2) / O077777, O177777 / C DATA RIGHT(1),RIGHT(2) / O032200, O000000 / C DATA DIVER(1),DIVER(2) / O032400, O000000 / C DATA LOG10(1),LOG10(2) / O037632, O020233 / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C DATA RMACH(1) / O000400000000 / C DATA RMACH(2) / O377777777777 / C DATA RMACH(3) / O146400000000 / C DATA RMACH(4) / O147400000000 / C DATA RMACH(5) / O177464202324 / C IF (I .LT. 1 .OR. I .GT. 5) 1 CALL SETERR(24HR1MACH - I OUT OF BOUNDS,24,1,2) C R1MACH = RMACH(I) RETURN C END DOUBLE PRECISION FUNCTION D1MACH(I) MCHD0000 C C DOUBLE-PRECISION MACHINE CONSTANTS C C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. C C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. C C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. C C D1MACH( 5) = LOG10(B) C C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY C REMOVING THE C FROM COLUMN 1. C C WHERE POSSIBLE, OCTAL OR HEXADECIMAL CONSTANTS HAVE BEEN USED C TO SPECIFY THE CONSTANTS EXACTLY WHICH HAS IN SOME CASES C REQUIRED THE USE OF EQUIVALENT INTEGER ARRAYS. C INTEGER SMALL(4) INTEGER LARGE(4) INTEGER RIGHT(4) INTEGER DIVER(4) INTEGER LOG10(4) C DOUBLE PRECISION DMACH(5) C EQUIVALENCE (DMACH(1),SMALL(1)) EQUIVALENCE (DMACH(2),LARGE(1)) EQUIVALENCE (DMACH(3),RIGHT(1)) EQUIVALENCE (DMACH(4),DIVER(1)) EQUIVALENCE (DMACH(5),LOG10(1)) C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C C DATA SMALL(1) / ZC00800000 / C DATA SMALL(2) / Z000000000 / C C DATA LARGE(1) / ZDFFFFFFFF / C DATA LARGE(2) / ZFFFFFFFFF / C C DATA RIGHT(1) / ZCC5800000 / C DATA RIGHT(2) / Z000000000 / C C DATA DIVER(1) / ZCC6800000 / C DATA DIVER(2) / Z000000000 / C C DATA LOG10(1) / ZD00E730E7 / C DATA LOG10(2) / ZC77800DC0 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O0000000000000000 / C C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O0007777777777777 / C C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 / C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. C C DATA SMALL(1) / O1771000000000000 / C DATA SMALL(2) / O7770000000000000 / C C DATA LARGE(1) / O0777777777777777 / C DATA LARGE(2) / O7777777777777777 / C C DATA RIGHT(1) / O1461000000000000 / C DATA RIGHT(2) / O0000000000000000 / C C DATA DIVER(1) / O1451000000000000 / C DATA DIVER(2) / O0000000000000000 / C C DATA LOG10(1) / O1157163034761674 / C DATA LOG10(2) / O0006677466732724 / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. C C DATA SMALL(1) / 00604000000000000000B / C DATA SMALL(2) / 00000000000000000000B / C C DATA LARGE(1) / 37767777777777777777B / C DATA LARGE(2) / 37167777777777777777B / C C DATA RIGHT(1) / 15604000000000000000B / C DATA RIGHT(2) / 15000000000000000000B / C C DATA DIVER(1) / 15614000000000000000B / C DATA DIVER(2) / 15010000000000000000B / C C DATA LOG10(1) / 17164642023241175717B / C DATA LOG10(2) / 16367571421742254654B / C C MACHINE CONSTANTS FOR THE CRAY 1 C C DATA SMALL(1) / 200004000000000000000B / C DATA SMALL(2) / 00000000000000000000B / C C DATA LARGE(1) / 577777777777777777777B / C DATA LARGE(2) / 000007777777777777777B / C C DATA RIGHT(1) / 377214000000000000000B / C DATA RIGHT(2) / 000000000000000000000B / C C DATA DIVER(1) / 377224000000000000000B / C DATA DIVER(2) / 000000000000000000000B / C C DATA LOG10(1) / 377774642023241175717B / C DATA LOG10(2) / 000007571421742254654B / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - C STATIC DMACH(5) C C DATA SMALL/20K,3*0/,LARGE/77777K,3*177777K/ C DATA RIGHT/31420K,3*0/,DIVER/32020K,3*0/ C DATA LOG10/40423K,42023K,50237K,74776K/ C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / C DATA LARGE(1),LARGE(2) / '37777777, '37777577 / C DATA RIGHT(1),RIGHT(2) / '20000000, '00000333 / C DATA DIVER(1),DIVER(2) / '20000000, '00000334 / C DATA LOG10(1),LOG10(2) / '23210115, '10237777 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. C C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. C C DATA SMALL(1),SMALL(2) / Z00100000, Z00000000 / C DATA LARGE(1),LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / C DATA RIGHT(1),RIGHT(2) / Z33100000, Z00000000 / C DATA DIVER(1),DIVER(2) / Z34100000, Z00000000 / C DATA LOG10(1),LOG10(2) / Z41134413, Z509F79FF / C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). C C DATA SMALL(1),SMALL(2) / "033400000000, "000000000000 / C DATA LARGE(1),LARGE(2) / "377777777777, "344777777777 / C DATA RIGHT(1),RIGHT(2) / "113400000000, "000000000000 / C DATA DIVER(1),DIVER(2) / "114400000000, "000000000000 / C DATA LOG10(1),LOG10(2) / "177464202324, "144117571776 / C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). C C DATA SMALL(1),SMALL(2) / "000400000000, "000000000000 / C DATA LARGE(1),LARGE(2) / "377777777777, "377777777777 / C DATA RIGHT(1),RIGHT(2) / "103400000000, "000000000000 / C DATA DIVER(1),DIVER(2) / "104400000000, "000000000000 / C DATA LOG10(1),LOG10(2) / "177464202324, "476747767461 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1),SMALL(2) / 8388608, 0 / C DATA LARGE(1),LARGE(2) / 2147483647, -1 / C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / C DATA DIVER(1),DIVER(2) / 620756992, 0 / C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 / C C DATA SMALL(1),SMALL(2) / O00040000000, O00000000000 / C DATA LARGE(1),LARGE(2) / O17777777777, O37777777777 / C DATA RIGHT(1),RIGHT(2) / O04440000000, O00000000000 / C DATA DIVER(1),DIVER(2) / O04500000000, O00000000000 / C DATA LOG10(1),LOG10(2) / O07746420232, O20476747770 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). C C DATA SMALL(1),SMALL(2) / 128, 0 / C DATA SMALL(3),SMALL(4) / 0, 0 / C C DATA LARGE(1),LARGE(2) / 32767, -1 / C DATA LARGE(3),LARGE(4) / -1, -1 / C C DATA RIGHT(1),RIGHT(2) / 9344, 0 / C DATA RIGHT(3),RIGHT(4) / 0, 0 / C C DATA DIVER(1),DIVER(2) / 9472, 0 / C DATA DIVER(3),DIVER(4) / 0, 0 / C C DATA LOG10(1),LOG10(2) / 16282, 8346 / C DATA LOG10(3),LOG10(4) / -31493, -12296 / C C DATA SMALL(1),SMALL(2) / O000200, O000000 / C DATA SMALL(3),SMALL(4) / O000000, O000000 / C C DATA LARGE(1),LARGE(2) / O077777, O177777 / C DATA LARGE(3),LARGE(4) / O177777, O177777 / C C DATA RIGHT(1),RIGHT(2) / O022200, O000000 / C DATA RIGHT(3),RIGHT(4) / O000000, O000000 / C C DATA DIVER(1),DIVER(2) / O022400, O000000 / C DATA DIVER(3),DIVER(4) / O000000, O000000 / C C DATA LOG10(1),LOG10(2) / O037632, O020232 / C DATA LOG10(3),LOG10(4) / O102373, O147770 / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 / C C IF (I .LT. 1 .OR. I .GT. 5) 1 CALL SETERR(24HD1MACH - I OUT OF BOUNDS,24,1,2) C D1MACH = DMACH(I) RETURN C END INTEGER FUNCTION NERROR(NERR) ERRN0000 C C RETURNS NERROR = NERR = THE VALUE OF THE ERROR FLAG LERROR. C NERROR=I8SAVE(1,0,.FALSE.) NERR=NERROR RETURN C END SUBROUTINE ERROFF ERRF0000 C C TURNS OFF THE ERROR STATE OFF BY SETTING LERROR=0. C I=I8SAVE(1,0,.TRUE.) RETURN C END SUBROUTINE SETERR(MESSG,NMESSG,NERR,IOPT) ERRS0000 C C SETERR SETS LERROR = NERR, OPTIONALLY PRINTS THE MESSAGE AND DUMPS C ACCORDING TO THE FOLLOWING RULES... C C IF IOPT = 1 AND RECOVERING - JUST REMEMBER THE ERROR. C IF IOPT = 1 AND NOT RECOVERING - PRINT AND STOP. C IF IOPT = 2 - PRINT, DUMP AND STOP. C C INPUT C C MESSG - THE ERROR MESSAGE. C NMESSG - THE LENGTH OF THE MESSAGE, IN CHARACTERS. C NERR - THE ERROR NUMBER. MUST HAVE NERR NON-ZERO. C IOPT - THE OPTION. MUST HAVE IOPT=1 OR 2. C C ERROR STATES - C C 1 - MESSAGE LENGTH NOT POSITIVE. C 2 - CANNOT HAVE NERR=0. C 3 - AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR. C 4 - BAD VALUE FOR IOPT. C C ONLY THE FIRST 72 CHARACTERS OF THE MESSAGE ARE PRINTED. C C THE ERROR HANDLER CALLS A SUBROUTINE NAMED FDUMP TO PRODUCE A C SYMBOLIC DUMP. TO COMPLETE THE PACKAGE, A DUMMY VERSION OF FDUMP C IS SUPPLIED, BUT IT SHOULD BE REPLACED BY A LOCALLY WRITTEN VERSION C WHICH AT LEAST GIVES A TRACE-BACK. C INTEGER MESSG(1) C C THE UNIT FOR ERROR MESSAGES. C IWUNIT=I1MACH(4) C IF (NMESSG.GE.1) GO TO 10 C C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL. C WRITE(IWUNIT,9000) 9000 FORMAT(52H1ERROR 1 IN SETERR - MESSAGE LENGTH NOT POSITIVE.) GO TO 60 C C NW IS THE NUMBER OF WORDS THE MESSAGE OCCUPIES. C 10 NW=(MIN0(NMESSG,72)-1)/I1MACH(6)+1 C IF (NERR.NE.0) GO TO 20 C C CANNOT TURN THE ERROR STATE OFF USING SETERR. C WRITE(IWUNIT,9001) 9001 FORMAT(42H1ERROR 2 IN SETERR - CANNOT HAVE NERR=0// 1 34H THE CURRENT ERROR MESSAGE FOLLOWS///) CALL E9RINT(MESSG,NW,NERR,.TRUE.) ITEMP=I8SAVE(1,1,.TRUE.) GO TO 50 C C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR. C 20 IF (I8SAVE(1,NERR,.TRUE.).EQ.0) GO TO 30 C WRITE(IWUNIT,9002) 9002 FORMAT(23H1ERROR 3 IN SETERR -, 1 48H AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.// 2 48H THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.///) CALL EPRINT CALL E9RINT(MESSG,NW,NERR,.TRUE.) GO TO 50 C C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY. C 30 CALL E9RINT(MESSG,NW,NERR,.TRUE.) C IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40 C C MUST HAVE IOPT = 1 OR 2. C WRITE(IWUNIT,9003) 9003 FORMAT(42H1ERROR 4 IN SETERR - BAD VALUE FOR IOPT// 1 34H THE CURRENT ERROR MESSAGE FOLLOWS///) GO TO 50 C C TEST FOR RECOVERY. C 40 IF (IOPT.EQ.2) GO TO 50 C IF (I8SAVE(2,0,.FALSE.).EQ.1) RETURN C CALL EPRINT STOP C 50 CALL EPRINT 60 CALL FDUMP STOP C END SUBROUTINE EPRINT ERRP0000 C C THIS SUBROUTINE PRINTS THE LAST ERROR MESSAGE, IF ANY. C INTEGER MESSG(1) C CALL E9RINT(MESSG,1,1,.FALSE.) RETURN C END SUBROUTINE E9RINT(MESSG,NW,NERR,SAVE) ERRR0000 C C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE, C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. . C INTEGER MESSG(NW) LOGICAL SAVE C C MESSGP STORES AT LEAST THE FIRST 72 CHARACTERS OF THE PREVIOUS C MESSAGE. ITS LENGTH IS MACHINE DEPENDENT AND MUST BE AT LEAST C C 1 + 71/(THE NUMBER OF CHARACTERS STORED PER INTEGER WORD). C INTEGER MESSGP(36),FMT(14),CCPLUS C C START WITH NO PREVIOUS MESSAGE. C DATA MESSGP(1)/1H1/, NWP/0/, NERRP/0/ C C SET UP THE FORMAT FOR PRINTING THE ERROR MESSAGE. C THE FORMAT IS SIMPLY (A1,14X,72AXX) WHERE XX=I1MACH(6) IS THE C NUMBER OF CHARACTERS STORED PER INTEGER WORD. C DATA CCPLUS / 1H+ / C DATA FMT( 1) / 1H( / DATA FMT( 2) / 1HA / DATA FMT( 3) / 1H1 / DATA FMT( 4) / 1H, / DATA FMT( 5) / 1H1 / DATA FMT( 6) / 1H4 / DATA FMT( 7) / 1HX / DATA FMT( 8) / 1H, / DATA FMT( 9) / 1H7 / DATA FMT(10) / 1H2 / DATA FMT(11) / 1HA / DATA FMT(12) / 1HX / DATA FMT(13) / 1HX / DATA FMT(14) / 1H) / C IF (.NOT.SAVE) GO TO 20 C C SAVE THE MESSAGE. C NWP=NW NERRP=NERR DO 10 I=1,NW 10 MESSGP(I)=MESSG(I) C GO TO 30 C 20 IF (I8SAVE(1,0,.FALSE.).EQ.0) GO TO 30 C C PRINT THE MESSAGE. C IWUNIT=I1MACH(4) WRITE(IWUNIT,9000) NERRP 9000 FORMAT(7H ERROR ,I4,4H IN ) C CALL S88FMT(2,I1MACH(6),FMT(12)) WRITE(IWUNIT,FMT) CCPLUS,(MESSGP(I),I=1,NWP) C 30 RETURN C END INTEGER FUNCTION I1MACH(I) MCHI0000 C C I/O UNIT NUMBERS. C C I1MACH( 1) = THE STANDARD INPUT UNIT. C C I1MACH( 2) = THE STANDARD OUTPUT UNIT. C C I1MACH( 3) = THE STANDARD PUNCH UNIT. C C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. C C WORDS. C C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. C C I1MACH( 6) = THE NUMBER OF CHARACTERS PER INTEGER STORAGE UNIT. C C INTEGERS. C C ASSUME INTEGERS ARE REPRESENTED IN THE S-DIGIT, BASE-A FORM C C SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) C C WHERE 0 .LE. X(I) .LT. A FOR I=0,...,S-1. C C I1MACH( 7) = A, THE BASE. C C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. C C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. C C FLOATING-POINT NUMBERS. C C ASSUME FLOATING-POINT NUMBERS ARE REPRESENTED IN THE T-DIGIT, C BASE-B FORM C C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, C 0 .LT. X(1), AND EMIN .LE. E .LE. EMAX. C C I1MACH(10) = B, THE BASE. C C SINGLE-PRECISION C C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. C C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. C C I1MACH(13) = EMAX, THE LARGEST EXPONENT E. C C DOUBLE-PRECISION C C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. C C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. C C I1MACH(16) = EMAX, THE LARGEST EXPONENT E. C C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY C REMOVING THE C FROM COLUMN 1. ALSO, THE VALUES OF C I1MACH(1) - I1MACH(4) SHOULD BE CHECKED FOR CONSISTENCY C WITH THE LOCAL OPERATING SYSTEM. C INTEGER IMACH(16),OUTPUT C EQUIVALENCE (IMACH(4),OUTPUT) C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C C DATA IMACH( 1) / 7 / C DATA IMACH( 2) / 2 / C DATA IMACH( 3) / 2 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 33 / C DATA IMACH( 9) / Z1FFFFFFFF / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -256 / C DATA IMACH(13) / 255 / C DATA IMACH(14) / 60 / C DATA IMACH(15) / -256 / C DATA IMACH(16) / 255 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 39 / C DATA IMACH( 9) / O0007777777777777 / C DATA IMACH(10) / 8 / C DATA IMACH(11) / 13 / C DATA IMACH(12) / -50 / C DATA IMACH(13) / 76 / C DATA IMACH(14) / 26 / C DATA IMACH(15) / -50 / C DATA IMACH(16) / 76 / C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 39 / C DATA IMACH( 9) / O0007777777777777 / C DATA IMACH(10) / 8 / C DATA IMACH(11) / 13 / C DATA IMACH(12) / -50 / C DATA IMACH(13) / 76 / C DATA IMACH(14) / 26 / C DATA IMACH(15) / -32754 / C DATA IMACH(16) / 32780 / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 60 / C DATA IMACH( 6) / 10 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 48 / C DATA IMACH( 9) / 00007777777777777777B / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 48 / C DATA IMACH(12) / -974 / C DATA IMACH(13) / 1070 / C DATA IMACH(14) / 96 / C DATA IMACH(15) / -927 / C DATA IMACH(16) / 1070 / C C MACHINE CONSTANTS FOR THE CRAY 1 C C DATA IMACH( 1) / 100 / C DATA IMACH( 2) / 101 / C DATA IMACH( 3) / 102 / C DATA IMACH( 4) / 101 / C DATA IMACH( 5) / 64 / C DATA IMACH( 6) / 8 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / 777777777777777777777B / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 48 / C DATA IMACH(12) / -8192 / C DATA IMACH(13) / 8191 / C DATA IMACH(14) / 96 / C DATA IMACH(15) / -8192 / C DATA IMACH(16) / 8191 / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C C DATA IMACH( 1) / 11 / C DATA IMACH( 2) / 12 / C DATA IMACH( 3) / 8 / C DATA IMACH( 4) / 10 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) /32767 / C DATA IMACH(10) / 16 / C DATA IMACH(11) / 6 / C DATA IMACH(12) / -64 / C DATA IMACH(13) / 63 / C DATA IMACH(14) / 14 / C DATA IMACH(15) / -64 / C DATA IMACH(16) / 63 / C C MACHINE CONSTANTS FOR THE HARRIS 220 C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 0 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / 3 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 23 / C DATA IMACH( 9) / 8388607 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 23 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 38 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 43 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 63 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / Z7FFFFFFF / C DATA IMACH(10) / 16 / C DATA IMACH(11) / 6 / C DATA IMACH(12) / -64 / C DATA IMACH(13) / 63 / C DATA IMACH(14) / 14 / C DATA IMACH(15) / -64 / C DATA IMACH(16) / 63 / C C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 5 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / "377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 54 / C DATA IMACH(15) / -101 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 5 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / "377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 62 / C DATA IMACH(15) / -128 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING C 32-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 32 / C DATA IMACH( 6) / 4 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 31 / C DATA IMACH( 9) / 2147483647 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR PDP-11 FORTRAN'S SUPPORTING C 16-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 5 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 16 / C DATA IMACH( 6) / 2 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 15 / C DATA IMACH( 9) / 32767 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 24 / C DATA IMACH(12) / -127 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 56 / C DATA IMACH(15) / -127 / C DATA IMACH(16) / 127 / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. C C DATA IMACH( 1) / 5 / C DATA IMACH( 2) / 6 / C DATA IMACH( 3) / 7 / C DATA IMACH( 4) / 6 / C DATA IMACH( 5) / 36 / C DATA IMACH( 6) / 6 / C DATA IMACH( 7) / 2 / C DATA IMACH( 8) / 35 / C DATA IMACH( 9) / O377777777777 / C DATA IMACH(10) / 2 / C DATA IMACH(11) / 27 / C DATA IMACH(12) / -128 / C DATA IMACH(13) / 127 / C DATA IMACH(14) / 60 / C DATA IMACH(15) /-1024 / C DATA IMACH(16) / 1023 / C IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 C I1MACH=IMACH(I) RETURN C 10 WRITE(OUTPUT,9000) 9000 FORMAT(39H1ERROR 1 IN I1MACH - I OUT OF BOUNDS) C CALL FDUMP C STOP C END INTEGER FUNCTION I8SAVE(ISW,IVALUE,SET) ERRV0000 C C IF (ISW = 1) I8SAVE RETURNS THE CURRENT ERROR NUMBER AND C SETS IT TO IVALUE IF SET = .TRUE. . C C IF (ISW = 2) I8SAVE RETURNS THE CURRENT RECOVERY SWITCH AND C SETS IT TO IVALUE IF SET = .TRUE. . C LOGICAL SET C INTEGER IPARAM(2) EQUIVALENCE (IPARAM(1),LERROR) , (IPARAM(2),LRECOV) C C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF. C DATA LERROR/0/ , LRECOV/2/ C I8SAVE=IPARAM(ISW) IF (SET) IPARAM(ISW)=IVALUE C RETURN C END SUBROUTINE S88FMT( N, W, IFMT ) ERRM0000 C C S88FMT REPLACES IFMT(1), ... , IFMT(N) WITH C THE CHARACTERS CORRESPONDING TO THE N LEAST SIGNIFICANT C DIGITS OF W. C INTEGER N,W,IFMT(N) C INTEGER NT,WT,DIGITS(10) C DATA DIGITS( 1) / 1H0 / DATA DIGITS( 2) / 1H1 / DATA DIGITS( 3) / 1H2 / DATA DIGITS( 4) / 1H3 / DATA DIGITS( 5) / 1H4 / DATA DIGITS( 6) / 1H5 / DATA DIGITS( 7) / 1H6 / DATA DIGITS( 8) / 1H7 / DATA DIGITS( 9) / 1H8 / DATA DIGITS(10) / 1H9 / C NT = N WT = W C 10 IF (NT .LE. 0) RETURN IDIGIT = MOD( WT, 10 ) IFMT(NT) = DIGITS(IDIGIT+1) WT = WT/10 NT = NT - 1 GO TO 10 C END SUBROUTINE FDUMP FDMP0000 C THIS IS A DUMMY ROUTINE TO BE SENT OUT ON C THE PORT SEDIT TAPE C RETURN END C MAIN PROGRAM THYP0010 C ********************************************** THYP0020 C THYP0030 C TEST OF PORT LINGUISTIC HYPOTHESES THYP0040 C THYP0050 C ********************************************** THYP0060 C THYP0070 COMMON /OK/ CREM, DREM, RREM, IREM, LREM, CIDX, DIDX, RIDX, IIDX THYP0080 1 , LIDX THYP0090 LOGICAL CREM, DREM, RREM, IREM, LREM, CIDX THYP0100 LOGICAL DIDX, RIDX, IIDX, LIDX THYP0110 COMMON /LNAME/ L THYP0120 LOGICAL L(1000) THYP0130 COMMON /INAME/ I THYP0140 INTEGER I(1000) THYP0150 COMMON /RNAME/ R THYP0160 REAL R(1000) THYP0170 COMMON /DNAME/ D THYP0180 DOUBLE PRECISION D(1000) THYP0190 COMMON /CNAME/ C THYP0200 COMPLEX C(1000) THYP0210 INTEGER P, I1MACH THYP0220 REAL FLOAT THYP0230 LOGICAL LOGVAR THYP0240 COMPLEX CMPLX THYP0250 INTEGER TEMP THYP0260 C TO TEST THE PORT LINGUISTIC HYPOTHESES. THYP0270 C .REM MEANS REMEMBERED AND .IDX MEANS INDEXING OK IN THE FOLLOWING. THYP0280 CREM = .TRUE. THYP0290 DREM = .TRUE. THYP0300 RREM = .TRUE. THYP0310 IREM = .TRUE. THYP0320 LREM = .TRUE. THYP0330 CIDX = .TRUE. THYP0340 DIDX = .TRUE. THYP0350 RIDX = .TRUE. THYP0360 IIDX = .TRUE. THYP0370 LIDX = .TRUE. THYP0380 LOGVAR = .TRUE. THYP0390 C MAKE SOME DATA. THYP0400 DO 1 P = 1, 1000 THYP0410 C(P) = CMPLX(-FLOAT(P), FLOAT(P)) THYP0420 D(P) = P THYP0430 R(P) = -P THYP0440 I(P) = P THYP0450 L(P) = LOGVAR THYP0460 LOGVAR = .NOT. LOGVAR THYP0470 1 CONTINUE THYP0480 C CHECK IT IN ARGUMENT AND COMMON LISTS. THYP0490 DO 2 P = 1, 999 THYP0500 CALL CHECK(C, D, R, I, L, P) THYP0510 2 CONTINUE THYP0520 IF (CREM) GOTO 4 THYP0530 TEMP = I1MACH(2) THYP0540 WRITE (TEMP, 3) THYP0550 3 FORMAT (49H COMPLEX VALUES NOT REMEMBERED BY DATA STATEMENT.) THYP0560 4 IF (DREM) GOTO 6 THYP0570 TEMP = I1MACH(2) THYP0580 WRITE (TEMP, 5) THYP0590 5 FORMAT ( THYP0600 1 58H DOUBLE PRECISION VALUES NOT REMEMBERED BY DATA STATEMENT.THYP0610 2 ) THYP0620 6 IF (RREM) GOTO 8 THYP0630 TEMP = I1MACH(2) THYP0640 WRITE (TEMP, 7) THYP0650 7 FORMAT (46H REAL VALUES NOT REMEMBERED BY DATA STATEMENT.) THYP0660 8 IF (IREM) GOTO 10 THYP0670 TEMP = I1MACH(2) THYP0680 WRITE (TEMP, 9) THYP0690 9 FORMAT (49H INTEGER VALUES NOT REMEMBERED BY DATA STATEMENT.) THYP0700 10 IF (LREM) GOTO 12 THYP0710 TEMP = I1MACH(2) THYP0720 WRITE (TEMP, 11) THYP0730 11 FORMAT (49H LOGICAL VALUES NOT REMEMBERED BY DATA STATEMENT.) THYP0740 12 IF (CIDX) GOTO 14 THYP0750 TEMP = I1MACH(2) THYP0760 WRITE (TEMP, 13) THYP0770 13 FORMAT (45H COMPLEX INDICES LARGER THAN ONE NOT ALLOWED.) THYP0780 14 IF (DIDX) GOTO 16 THYP0790 TEMP = I1MACH(2) THYP0800 WRITE (TEMP, 15) THYP0810 15 FORMAT ( THYP0820 1 54H DOUBLE PRECISION INDICES LARGER THAN ONE NOT ALLOWED.) THYP0830 16 IF (RIDX) GOTO 18 THYP0840 TEMP = I1MACH(2) THYP0850 WRITE (TEMP, 17) THYP0860 17 FORMAT (42H REAL INDICES LARGER THAN ONE NOT ALLOWED.) THYP0870 18 IF (IIDX) GOTO 20 THYP0880 TEMP = I1MACH(2) THYP0890 WRITE (TEMP, 19) THYP0900 19 FORMAT (45H INTEGER INDICES LARGER THAN ONE NOT ALLOWED.) THYP0910 20 IF (LIDX) GOTO 22 THYP0920 TEMP = I1MACH(2) THYP0930 WRITE (TEMP, 21) THYP0940 21 FORMAT (45H LOGICAL INDICES LARGER THAN ONE NOT ALLOWED.) THYP0950 22 TEMP = I1MACH(2) THYP0960 WRITE (TEMP, 23) THYP0970 23 FORMAT (45H TEST OF PORT LINGUISTIC HYPOTHESES COMPLETE.) THYP0980 STOP THYP0990 END THYP1000 SUBROUTINE CHECK(C, D, R, I, L, P) THYP1010 INTEGER I(1), P REAL R(1) LOGICAL L(1) COMPLEX C(1) DOUBLE PRECISION D(1) COMMON /OK/ CREM, DREM, RREM, IREM, LREM, CIDX, DIDX, RIDX, IIDX 1 , LIDX LOGICAL CREM, DREM, RREM, IREM, LREM, CIDX LOGICAL DIDX, RIDX, IIDX, LIDX COMMON /LNAME/ CL LOGICAL CL(1) COMMON /INAME/ CI INTEGER CI(1) COMMON /RNAME/ CR REAL CR(1) COMMON /DNAME/ CD DOUBLE PRECISION CD(1) COMMON /CNAME/ CC COMPLEX CC(1) INTEGER LI, Q, I1MACH REAL LR, AIMAG, REAL LOGICAL LL COMPLEX LC DOUBLE PRECISION LD INTEGER TEMP DATA LC/(-1., 1.)/ DATA LD/1.0D0/ DATA LR/-1.0E0/ DATA LI/1/ DATA LL/.TRUE./ C LOCAL VARIABLES. C START LOCAL VARIABLES AS COMMON C VARIABLES BEGIN. IF (P .NE. 1) GOTO 11 IF (REAL(LC) .EQ. REAL(C(P)) .AND. AIMAG(LC) .EQ. AIMAG(C(P)) 1 ) GOTO 2 TEMP = I1MACH(2) C CHECK DATA VALUES OF LOCAL VARIABLES. WRITE (TEMP, 1) 1 FORMAT (34H DATA STATEMENT FAILS FOR COMPLEX.) 2 IF (LD .EQ. D(P)) GOTO 4 TEMP = I1MACH(2) WRITE (TEMP, 3) 3 FORMAT (43H DATA STATEMENT FAILS FOR DOUBLE PRECISION.) 4 IF (LR .EQ. R(P)) GOTO 6 TEMP = I1MACH(2) WRITE (TEMP, 5) 5 FORMAT (31H DATA STATEMENT FAILS FOR REAL.) 6 IF (LI .EQ. I(P)) GOTO 8 TEMP = I1MACH(2) WRITE (TEMP, 7) 7 FORMAT (34H DATA STATEMENT FAILS FOR INTEGER.) 8 IF ((LL .OR. (.NOT. L(P))) .AND. ((.NOT. LL) .OR. L(P))) GOTO 1 10 TEMP = I1MACH(2) WRITE (TEMP, 9) 9 FORMAT (34H DATA STATEMENT FAILS FOR LOGICAL.) 10 CONTINUE GOTO 12 11 IF (REAL(LC) .NE. REAL(C(P)) .OR. AIMAG(LC) .NE. AIMAG(C(P))) 1 CREM = .FALSE. C CHECK THE REMEMBERED LOCAL VALUES. IF (LD .NE. D(P)) DREM = .FALSE. IF (LR .NE. R(P)) RREM = .FALSE. IF (LI .NE. I(P)) IREM = .FALSE. IF ((.NOT. LL) .AND. L(P) .OR. LL .AND. (.NOT. L(P))) LREM = 1 .FALSE. C MAKE A LOCAL COPY OF THE NEXT VALUES TO BE SEEN BY CHECK. 12 LC = C(P+1) LD = D(P+1) LR = R(P+1) LI = I(P+1) LL = L(P+1) IF (P .NE. 1) GOTO 13 IF (REAL(LC) .EQ. (-1.) .AND. AIMAG(LC) .EQ. 1.) CIDX = 1 .FALSE. C CHECK THAT LOCAL VARIABLES WERE REALLY UPDATED. IF (LD .EQ. 1D0) DIDX = .FALSE. IF (LR .EQ. (-1.)) RIDX = .FALSE. IF (LI .EQ. 1) IIDX = .FALSE. IF (LL) LIDX = .FALSE. C CHECK THAT THE LOCAL VARIABLES WERE UPDATED. 13 IF (REAL(LC) .EQ. REAL(C(P)) .AND. AIMAG(LC) .EQ. AIMAG(C(P))) 1 CIDX = .FALSE. IF (LD .EQ. D(P)) DIDX = .FALSE. IF (LR .EQ. R(P)) RIDX = .FALSE. IF (LI .EQ. I(P)) IIDX = .FALSE. IF (LL .AND. L(P) .OR. (.NOT. LL) .AND. (.NOT. L(P))) LIDX = 1 .FALSE. DO 14 Q = P, 999 IF (REAL(C(Q+1)) .NE. REAL(CC(Q+1)) .OR. AIMAG(C(Q+1)) .NE. 1 AIMAG(CC(Q+1))) CIDX = .FALSE. IF (D(Q+1) .NE. CD(Q+1)) DIDX = .FALSE. IF (R(Q+1) .NE. CR(Q+1)) RIDX = .FALSE. IF (I(Q+1) .NE. CI(Q+1)) IIDX = .FALSE. IF ((.NOT. L(Q+1)) .AND. CL(Q+1) .OR. L(Q+1) .AND. (.NOT. CL(Q+ 1 1))) LIDX = .FALSE. 14 CONTINUE RETURN END C MAIN PROGRAM MACH0010 C ********************************************** MACH0020 C MACH0030 C TEST OF PORT MACHINE CONSTANTS (FOR CONSISTENCY) MACH0040 C MACH0050 C ********************************************** MACH0060 C MACH0070 CALL S1MACH MACH0080 STOP MACH0090 END MACH0100 SUBROUTINE S1MACH MACH0110 C C S1MACH TESTS THE CONSISTENCY OF THE MACHINE CONSTANTS IN C I1MACH, R1MACH AND D1MACH. C INTEGER IMACH(16),I1MACH INTEGER STDOUT INTEGER DIGINT, DIGSP, DIGDP REAL RMACH(5),R1MACH REAL S2MACH, XR REAL SBASE, SBASEM DOUBLE PRECISION DMACH(5),D1MACH DOUBLE PRECISION S3MACH, XD DOUBLE PRECISION DBASE, DBASEM C INTEGER IFMT(12) INTEGER EFMT(15) INTEGER DFMT(15) INTEGER CCPLUS INTEGER DWIDTH, WWIDTH, EWIDTH INTEGER DEMAX, DEMIN C EQUIVALENCE ( STDOUT, IMACH(2) ) EQUIVALENCE ( DIGINT, IMACH(8) ) EQUIVALENCE ( DIGSP, IMACH(11) ) EQUIVALENCE ( DIGDP, IMACH(14) ) C DATA CCPLUS / 1H+ / C DATA IFMT(1 ) / 1H( / DATA IFMT(2 ) / 1HA / DATA IFMT(3 ) / 1H1 / DATA IFMT(4 ) / 1H, / DATA IFMT(5 ) / 1H5 / DATA IFMT(6 ) / 1H1 / DATA IFMT(7 ) / 1HX / DATA IFMT(8 ) / 1H, / DATA IFMT(9 ) / 1HI / DATA IFMT(10) / 1H / DATA IFMT(11) / 1H / DATA IFMT(12) / 1H) / C DATA EFMT( 1) / 1H( /, DFMT( 1) / 1H( / DATA EFMT( 2) / 1HA /, DFMT( 2) / 1HA / DATA EFMT( 3) / 1H1 /, DFMT( 3) / 1H1 / DATA EFMT( 4) / 1H, /, DFMT( 4) / 1H, / DATA EFMT( 5) / 1H3 /, DFMT( 5) / 1H3 / DATA EFMT( 6) / 1H2 /, DFMT( 6) / 1H2 / DATA EFMT( 7) / 1HX /, DFMT( 7) / 1HX / DATA EFMT( 8) / 1H, /, DFMT( 8) / 1H, / DATA EFMT( 9) / 1HE /, DFMT( 9) / 1HD / DATA EFMT(10) / 1H /, DFMT(10) / 1H / DATA EFMT(11) / 1H /, DFMT(11) / 1H / DATA EFMT(12) / 1H. /, DFMT(12) / 1H. / DATA EFMT(13) / 1H /, DFMT(13) / 1H / DATA EFMT(14) / 1H /, DFMT(14) / 1H / DATA EFMT(15) / 1H) /, DFMT(15) / 1H) / C C FETCH ALL CONSTANTS INTO LOCAL ARRAYS C DO 10 I = 1,16 IMACH(I) = I1MACH(I) 10 CONTINUE C DO 20 I = 1,5 RMACH(I) = R1MACH(I) DMACH(I) = D1MACH(I) 20 CONTINUE C C COMPUTE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING C OUT THE LARGEST INTEGER ALLOWING FOR ONE SPACE AND A SIGN C AND PLUG THE FIELD WIDTH IN THE FORMAT. C WWIDTH = ICEIL( ALOG10(FLOAT(IMACH(7)))*FLOAT(IMACH(8)) ) + 2 CALL S88FMT( 2, WWIDTH, IFMT(10) ) C WRITE( STDOUT, 900 ) ( IFMT(I), I = 9, 11 ) 900 FORMAT(//37H FORMAT CONVERSION FOR INTEGERS IS - ,3A1 1 / 25H INTEGER CONSTANTS FOLLOW///) C C NOW WRITE OUT THE INTEGER CONSTANTS C WRITE( STDOUT, 1001 ) 1001 FORMAT(24H THE STANDARD INPUT UNIT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(1) C WRITE( STDOUT, 1002 ) 1002 FORMAT(25H THE STANDARD OUTPUT UNIT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(2) C WRITE( STDOUT, 1003 ) 1003 FORMAT(24H THE STANDARD PUNCH UNIT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(3) C WRITE( STDOUT, 1004 ) 1004 FORMAT(32H THE STANDARD ERROR MESSAGE UNIT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(4) C WRITE( STDOUT, 1005 ) 1005 FORMAT(28H THE NUMBER OF BITS PER WORD) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(5) C WRITE( STDOUT, 1006 ) 1006 FORMAT(34H THE NUMBER OF CHARACTERS PER WORD) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(6) C WRITE( STDOUT, 1007 ) 1007 FORMAT(34H A, THE BASE OF AN S-DIGIT INTEGER) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(7) C WRITE( STDOUT, 1008 ) 1008 FORMAT(31H S, THE NUMBER OF BASE-A DIGITS) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(8) C WRITE( STDOUT, 1009 ) 1009 FORMAT(32H A**S - 1, THE LARGEST MAGNITUDE) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(9) C WRITE( STDOUT, 1010 ) 1010 FORMAT(47H B, THE BASE OF A T-DIGIT FLOATING-POINT NUMBER) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(10) C WRITE( STDOUT, 1011 ) 1011 FORMAT(51H T, THE NUMBER OF BASE-B DIGITS IN SINGLE-PRECISION) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(11) C WRITE( STDOUT, 1012 ) 1012 FORMAT(45H EMIN, THE SMALLEST SINGLE-PRECISION EXPONENT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(12) C WRITE( STDOUT, 1013 ) 1013 FORMAT(44H EMAX, THE LARGEST SINGLE-PRECISION EXPONENT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13) C WRITE( STDOUT, 1014 ) 1014 FORMAT(51H T, THE NUMBER OF BASE-B DIGITS IN DOUBLE-PRECISION) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(14) C WRITE( STDOUT, 1015 ) 1015 FORMAT(45H EMIN, THE SMALLEST DOUBLE-PRECISION EXPONENT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(15) C WRITE( STDOUT, 1016 ) 1016 FORMAT(44H EMAX, THE LARGEST DOUBLE-PRECISION EXPONENT) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16) C C COMPUTE THE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING C OUT A SINGLE-PRECISION NUMBER ALLOWING FOR ONE SPACE AND C A SIGN AND PLUG THE FIELDS IN THE FORMAT. C DWIDTH = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(11)) ) CALL S88FMT( 2, DWIDTH, EFMT(13) ) C DEMIN = IFLR( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(12)-1) ) + 1 DEMAX = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(13)) ) EWIDTH = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1 WWIDTH = DWIDTH + EWIDTH + 6 CALL S88FMT( 2, WWIDTH, EFMT(10) ) C WRITE( STDOUT, 1900 ) ( EFMT(I), I = 9, 14 ) 1900 FORMAT(//45H FORMAT CONVERSION FOR SINGLE-PRECISION IS - ,6A1 1 / 34H SINGLE-PRECISION CONSTANTS FOLLOW///) C C NOW WRITE OUT THE SINGLE-PRECISION CONSTANTS C WRITE( STDOUT, 2001 ) 2001 FORMAT(32H THE SMALLEST POSITIVE MAGNITUDE) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1) C WRITE( STDOUT, 2002 ) 2002 FORMAT(22H THE LARGEST MAGNITUDE) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2) C WRITE( STDOUT, 2003 ) 2003 FORMAT(30H THE SMALLEST RELATIVE SPACING) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(3) C WRITE( STDOUT, 2004 ) 2004 FORMAT(29H THE LARGEST RELATIVE SPACING) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(4) C WRITE( STDOUT, 2005 ) 2005 FORMAT(18H LOG10 OF THE BASE) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(5) C CALL S88FMT( 2, WWIDTH+1, EFMT(10) ) CALL S88FMT( 2, DWIDTH+1, EFMT(13) ) C C COMPUTE THE NUMBER OF CHARACTER POSITIONS NEEDED FOR WRITING C OUT A DOUBLE-PRECISION NUMBER ALLOWING FOR ONE SPACE AND C A SIGN AND PLUG THE FIELDS IN THE FORMAT. C DWIDTH = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(14)) ) CALL S88FMT( 2, DWIDTH, DFMT(13) ) C DEMIN = IFLR( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(15)-1) ) + 1 DEMAX = ICEIL( ALOG10(FLOAT(IMACH(10)))*FLOAT(IMACH(16)) ) EWIDTH = IFLR( ALOG10(FLOAT(MAX0(IABS(DEMIN),IABS(DEMAX)))) ) + 1 WWIDTH = DWIDTH + EWIDTH + 6 CALL S88FMT( 2, WWIDTH, DFMT(10) ) C WRITE( STDOUT, 2900 ) ( DFMT(I), I = 9, 14 ) 2900 FORMAT(//45H FORMAT CONVERSION FOR DOUBLE-PRECISION IS - ,6A1 1 / 34H DOUBLE-PRECISION CONSTANTS FOLLOW///) C C NOW WRITE OUT THE DOUBLE-PRECISION CONSTANTS C WRITE( STDOUT, 3001 ) 3001 FORMAT(32H THE SMALLEST POSITIVE MAGNITUDE) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1) C WRITE( STDOUT, 3002 ) 3002 FORMAT(22H THE LARGEST MAGNITUDE) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2) C WRITE( STDOUT, 3003 ) 3003 FORMAT(30H THE SMALLEST RELATIVE SPACING) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(3) C WRITE( STDOUT, 3004 ) 3004 FORMAT(29H THE LARGEST RELATIVE SPACING) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(4) C WRITE( STDOUT, 3005 ) 3005 FORMAT(18H LOG10 OF THE BASE) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(5) C CALL S88FMT( 2, WWIDTH+1, DFMT(10) ) CALL S88FMT( 2, DWIDTH+1, DFMT(13) ) C C NOW CHECK CONSISTENCY OF INTEGER CONSTANTS C CALL S88FMT( 2, 14, IFMT(5) ) C IF( IMACH(11) .LE. IMACH(14) ) GOTO 4009 WRITE( STDOUT, 4001 ) 4001 FORMAT(30H0I1MACH(11) EXCEEDS I1MACH(14) ) WRITE( STDOUT, 4002 ) 4002 FORMAT(13H I1MACH(11) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(11) WRITE( STDOUT, 4003 ) 4003 FORMAT(13H I1MACH(14) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(14) 4009 CONTINUE C IF( IMACH(13) .LE. IMACH(16) ) GOTO 4019 WRITE( STDOUT, 4011 ) 4011 FORMAT(40H0WARNING - I1MACH(13) EXCEEDS I1MACH(16) ) WRITE( STDOUT, 4012 ) 4012 FORMAT(13H I1MACH(13) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13) WRITE( STDOUT, 4013 ) 4013 FORMAT(13H I1MACH(16) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16) 4019 CONTINUE C IF( IMACH(16)-IMACH(15) .GE. IMACH(13)-IMACH(12) ) GOTO 4029 WRITE( STDOUT, 4021 ) 4021 FORMAT(34H0WARNING - I1MACH(13) - I1MACH(12) ) WRITE( STDOUT, 4022 ) 4022 FORMAT(32H EXCEEDS I1MACH(16) - I1MACH(15) ) WRITE( STDOUT, 4023 ) 4023 FORMAT(13H I1MACH(12) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(12) WRITE( STDOUT, 4024 ) 4024 FORMAT(13H I1MACH(13) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(13) WRITE( STDOUT, 4025 ) 4025 FORMAT(13H I1MACH(15) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(15) WRITE( STDOUT, 4026 ) 4026 FORMAT(13H I1MACH(16) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(16) 4029 CONTINUE C N = 0 IBASEM = IMACH(7) - 1 DO 4030 I = 1, DIGINT N = N*IMACH(7) + IBASEM 4030 CONTINUE C IF( IMACH(9) .EQ. N) GOTO 4039 WRITE( STDOUT, 4031 ) 4031 FORMAT(39H1IMACH(9) IS NOT IMACH(7)**IMACH(8) - 1 ) WRITE( STDOUT, 4032 ) 4032 FORMAT(12H I1MACH(7) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(7) WRITE( STDOUT, 4034 ) 4034 FORMAT(12H I1MACH(8) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(8) WRITE( STDOUT, 4035 ) 4035 FORMAT(12H I1MACH(9) = ) WRITE( STDOUT, IFMT ) CCPLUS, IMACH(9) 4039 CONTINUE C C NOW CHECK CONSISTENCY OF SINGLE-PRECISION CONSTANTS C CALL S88FMT( 2, 19, EFMT(5) ) C XR = S2MACH( 1.0, IMACH(10), IMACH(12)-1 ) IF( XR .EQ. RMACH(1) ) GOTO 5009 WRITE( STDOUT, 5001 ) 5001 FORMAT(47H0R1MACH(1) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 5002 ) 5002 FORMAT(12H R1MACH(1) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1) WRITE( STDOUT, 5003 ) 5003 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, EFMT ) CCPLUS, XR WRITE( STDOUT, 5004 ) 5004 FORMAT(14H DIFFERENCE = ) XR = RMACH(1) - XR WRITE( STDOUT, EFMT ) CCPLUS, XR 5009 CONTINUE C XR = 0.0 SBASE = FLOAT( IMACH(10) ) SBASEM = FLOAT( IMACH(10)-1 ) DO 5010 I = 1, DIGSP XR = (XR + SBASEM)/SBASE 5010 CONTINUE C XR = S2MACH( XR, IMACH(10), IMACH(13) ) IF( XR .EQ. RMACH(2) ) GOTO 5019 WRITE( STDOUT, 5011 ) 5011 FORMAT(47H0R1MACH(2) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 5012 ) 5012 FORMAT(12H R1MACH(2) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2) WRITE( STDOUT, 5013 ) 5013 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, EFMT ) CCPLUS, XR WRITE( STDOUT, 5014 ) 5014 FORMAT(14H DIFFERENCE = ) XR = RMACH(2) - XR WRITE( STDOUT, EFMT ) CCPLUS, XR 5019 CONTINUE C XR = S2MACH( 1.0, IMACH(10), -IMACH(11) ) IF( XR .EQ. RMACH(3) ) GOTO 5029 WRITE( STDOUT, 5021 ) 5021 FORMAT(47H0R1MACH(3) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 5022 ) 5022 FORMAT(12H R1MACH(3) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(3) WRITE( STDOUT, 5023 ) 5023 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, EFMT ) CCPLUS, XR WRITE( STDOUT, 5024 ) 5024 FORMAT(14H DIFFERENCE = ) XR = RMACH(3) - XR WRITE( STDOUT, EFMT ) CCPLUS, XR 5029 CONTINUE C XR = S2MACH( 1.0, IMACH(10), 1-IMACH(11) ) IF( XR .EQ. RMACH(4) ) GOTO 5039 WRITE( STDOUT, 5031 ) 5031 FORMAT(47H0R1MACH(4) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 5032 ) 5032 FORMAT(12H R1MACH(4) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(4) WRITE( STDOUT, 5033 ) 5033 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, EFMT ) CCPLUS, XR WRITE( STDOUT, 5034 ) 5034 FORMAT(14H DIFFERENCE = ) XR = RMACH(4) - XR WRITE( STDOUT, EFMT ) CCPLUS, XR 5039 CONTINUE C XR = ALOG10( FLOAT(IMACH(10)) ) IF( XR .EQ. RMACH(5) ) GOTO 5049 WRITE( STDOUT, 5041 ) 5041 FORMAT(47H0R1MACH(5) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 5042 ) 5042 FORMAT(12H R1MACH(5) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(5) WRITE( STDOUT, 5043 ) 5043 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, EFMT ) CCPLUS, XR WRITE( STDOUT, 5044 ) 5044 FORMAT(14H DIFFERENCE = ) XR = RMACH(5) - XR WRITE( STDOUT, EFMT ) CCPLUS, XR 5049 CONTINUE C C NOW CHECK CONSISTENCY OF DOUBLE-PRECISION CONSTANTS C CALL S88FMT( 2, 19, DFMT(5) ) C XD = S3MACH( 1.0D0, IMACH(10), IMACH(15)-1 ) IF( XD .EQ. DMACH(1) ) GOTO 6009 WRITE( STDOUT, 6001 ) 6001 FORMAT(47H0D1MACH(1) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 6002 ) 6002 FORMAT(12H D1MACH(1) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1) WRITE( STDOUT, 6003 ) 6003 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, DFMT ) CCPLUS, XD WRITE( STDOUT, 6004 ) 6004 FORMAT(14H DIFFERENCE = ) XD = DMACH(1) - XD WRITE( STDOUT, DFMT ) CCPLUS, XD 6009 CONTINUE C XD = 0.0D0 DBASE = DBLE ( FLOAT( IMACH(10) ) ) DBASEM = DBLE ( FLOAT( IMACH(10)-1 ) ) DO 6010 I = 1, DIGDP XD = (XD + DBASEM)/DBASE 6010 CONTINUE C XD = S3MACH( XD, IMACH(10), IMACH(16) ) IF( XD .EQ. DMACH(2) ) GOTO 6019 WRITE( STDOUT, 6011 ) 6011 FORMAT(47H0D1MACH(2) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 6012 ) 6012 FORMAT(12H D1MACH(2) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2) WRITE( STDOUT, 6013 ) 6013 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, DFMT ) CCPLUS, XD WRITE( STDOUT, 6014 ) 6014 FORMAT(14H DIFFERENCE = ) XD = DMACH(2) - XD WRITE( STDOUT, DFMT ) CCPLUS, XD 6019 CONTINUE C XD = S3MACH( 1.0D0, IMACH(10), -IMACH(14) ) IF( XD .EQ. DMACH(3) ) GOTO 6029 WRITE( STDOUT, 6021 ) 6021 FORMAT(47H0D1MACH(3) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 6022 ) 6022 FORMAT(12H D1MACH(3) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(3) WRITE( STDOUT, 6023 ) 6023 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, DFMT ) CCPLUS, XD WRITE( STDOUT, 6024 ) 6024 FORMAT(14H DIFFERENCE = ) XD = DMACH(3) - XD WRITE( STDOUT, DFMT ) CCPLUS, XD 6029 CONTINUE C XD = S3MACH( 1.0D0, IMACH(10), 1-IMACH(14) ) IF( XD .EQ. DMACH(4) ) GOTO 6039 WRITE( STDOUT, 6031 ) 6031 FORMAT(47H0D1MACH(4) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 6032 ) 6032 FORMAT(12H D1MACH(4) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(4) WRITE( STDOUT, 6033 ) 6033 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, DFMT ) CCPLUS, XD WRITE( STDOUT, 6034 ) 6034 FORMAT(14H DIFFERENCE = ) XD = DMACH(4) - XD WRITE( STDOUT, DFMT ) CCPLUS, XD 6039 CONTINUE C XD = DLOG10( DBLE(FLOAT(IMACH(10))) ) IF( XD .EQ. DMACH(5) ) GOTO 6049 WRITE( STDOUT, 6041 ) 6041 FORMAT(47H0D1MACH(5) DOES NOT AGREE WITH CALCULATED VALUE) WRITE( STDOUT, 6042 ) 6042 FORMAT(12H D1MACH(5) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(5) WRITE( STDOUT, 6043 ) 6043 FORMAT(19H CALCULATED VALUE = ) WRITE( STDOUT, DFMT ) CCPLUS, XD WRITE( STDOUT, 6044 ) 6044 FORMAT(14H DIFFERENCE = ) XD = DMACH(5) - XD WRITE( STDOUT, DFMT ) CCPLUS, XD 6049 CONTINUE C C NOW SEE IF SINGLE-PRECISION IS CLOSED UNDER NEGATION C XR = -RMACH(1) XR = -XR IF( XR .EQ. RMACH(1) ) GOTO 7009 WRITE( STDOUT, 7001 ) 7001 FORMAT(29H0-(-R1MACH(1)) .NE. R1MACH(1)) WRITE( STDOUT, 7002 ) 7002 FORMAT(16H R1MACH(1) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(1) WRITE( STDOUT, 7003 ) 7003 FORMAT(16H -(-R1MACH(1)) = ) WRITE( STDOUT, EFMT ) CCPLUS, XR 7009 CONTINUE C XR = -RMACH(2) XR = -XR IF( XR .EQ. RMACH(2) ) GOTO 7019 WRITE( STDOUT, 7011 ) 7011 FORMAT(29H0-(-R1MACH(2)) .NE. R1MACH(2)) WRITE( STDOUT, 7012 ) 7012 FORMAT(16H R1MACH(2) = ) WRITE( STDOUT, EFMT ) CCPLUS, RMACH(2) WRITE( STDOUT, 7013 ) 7013 FORMAT(16H -(-R1MACH(2)) = ) WRITE( STDOUT, EFMT ) CCPLUS, XR 7019 CONTINUE C C NOW SEE IF DOUBLE-PRECISION IS CLOSED UNDER NEGATION C XD = -DMACH(1) XD = -XD IF( XD .EQ. DMACH(1) ) GOTO 8009 WRITE( STDOUT, 8001 ) 8001 FORMAT(29H0-(-D1MACH(1)) .NE. D1MACH(1)) WRITE( STDOUT, 8002 ) 8002 FORMAT(16H D1MACH(1) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(1) WRITE( STDOUT, 8003 ) 8003 FORMAT(16H -(-D1MACH(1)) = ) WRITE( STDOUT, DFMT ) CCPLUS, XD 8009 CONTINUE C XD = -DMACH(2) XD = -XD IF( XD .EQ. DMACH(2) ) GOTO 8019 WRITE( STDOUT, 8011 ) 8011 FORMAT(29H0-(-D1MACH(2)) .NE. D1MACH(2)) WRITE( STDOUT, 8012 ) 8012 FORMAT(16H D1MACH(2) = ) WRITE( STDOUT, DFMT ) CCPLUS, DMACH(2) WRITE( STDOUT, 8013 ) 8013 FORMAT(16H -(-D1MACH(2)) = ) WRITE( STDOUT, DFMT ) CCPLUS, XD 8019 CONTINUE C RETURN C END REAL FUNCTION S2MACH( XR, BASE, EXP ) MACH5470 C C S2MACH = XR * BASE**EXP C INTEGER BASE, EXP REAL TBASE, XR C TBASE = FLOAT(BASE) S2MACH = XR C N = EXP IF( N .GE. 0 ) GO TO 20 C N = -N TBASE = 1.0/TBASE C 20 IF( MOD(N,2) .NE. 0 ) S2MACH = S2MACH*TBASE N = N/2 IF( N .EQ. 0 ) GO TO 30 TBASE = TBASE * TBASE GO TO 20 C 30 RETURN C END DOUBLE PRECISION FUNCTION S3MACH( XD, BASE, EXP ) MACH5720 C C S3MACH = XD * BASE**EXP C INTEGER BASE, EXP DOUBLE PRECISION TBASE, XD C TBASE = FLOAT(BASE) S3MACH = XD C N = EXP IF( N .GE. 0 ) GO TO 20 C N = -N TBASE = 1.0D0/TBASE C 20 IF( MOD(N,2) .NE. 0 ) S3MACH = S3MACH*TBASE N = N/2 IF( N .EQ. 0 ) GO TO 30 TBASE = TBASE * TBASE GO TO 20 C 30 RETURN C END INTEGER FUNCTION ICEIL(X) MACH5970 C C ICEIL RETURNS CEIL(X) C ICEIL = INT(X) IF (X .LE. 0.0) RETURN IF (FLOAT(ICEIL) .NE. X) ICEIL = ICEIL + 1 C RETURN END INTEGER FUNCTION IFLR(X) MACH6070 C C IFLR RETURNS FLR(X) C IFLR = INT(X) IF (X .GE. 0.0) RETURN IF (FLOAT(IFLR) .NE. X) IFLR = IFLR - 1 C RETURN END C MAIN PROGRAM ERR10010 C ********************************************** ERR10020 C ERR10030 C TO TEST THE ERROR HANDLING PACKAGE. ERR10040 C TEST NUMBER 1: TURNING RECOVERY ON AND OFF. ERR10050 C ERR10060 C ********************************************** ERR10070 INTEGER OLDREC, NERR, NERROR, I1MACH ERR10080 INTEGER TEMP ERR10090 C ENTER RECOVERY MODE. ERR10100 CALL ENTSRC(OLDREC, 1) ERR10110 C SET AN ERROR. ERR10120 CALL SETERR(39HFIRST ERROR TEST - RECOVERABLE ERROR OK, 39, 1, 1) ERR10130 C PRINT THE ERROR. ERR10140 CALL EPRINT ERR10150 IF (NERROR(NERR) .EQ. 1) GOTO 2 ERR10160 TEMP = I1MACH(2) ERR10170 WRITE (TEMP, 1) ERR10180 1 FORMAT (14H NERROR FAILS.) ERR10190 C TURN THE ERROR STATE OFF. ERR10200 2 CALL ERROFF ERR10210 IF (NERROR(NERR) .EQ. 0) GOTO 4 ERR10220 TEMP = I1MACH(2) ERR10230 WRITE (TEMP, 3) ERR10240 3 FORMAT (42H ERROFF FAILS TO TURN THE ERROR STATE OFF.) ERR10250 C SEE IF THE ERROR PRINTS. ERR10260 4 CALL EPRINT ERR10270 CALL SETERR( ERR10280 1 34HSAME TEST - LEAVING RECOVERY MODE, ERR10290 2 34, 2, 1) ERR10300 C RESTORE OLD RECOVERY LEVEL, THE DEFAULT. ERR10310 CALL RETSRC(OLDREC) ERR10320 TEMP = I1MACH(2) ERR10330 WRITE (TEMP, 5) ERR10340 5 FORMAT (42H RECOVERY MODE REMAINS ON WHEN TURNED OFF.) ERR10350 STOP ERR10360 END ERR10370 C MAIN PROGRAM ERR20010 C ********************************************** ERR20020 C ERR20030 C TO TEST THE ERROR HANDLING PACKAGE. ERR20040 C TEST NUMBER 2: FATAL ERRORS. ERR20050 C ERR20060 C ********************************************** ERR20070 INTEGER I1MACH ERR20080 INTEGER TEMP ERR20090 C SET AN ERROR. ERR20100 CALL SETERR( ERR20110 1 39HSECOND ERROR TEST - FATAL ERROR CHECKED, 39, 1, 2) ERR20120 TEMP = I1MACH(2) ERR20130 WRITE (TEMP, 1) ERR20140 1 FORMAT (39H A FATAL ERROR FAILS TO HALT EXECUTION.) ERR20150 STOP ERR20160 END ERR20170 C MAIN PROGRAM ERR30010 C ********************************************** ERR30020 C ERR30030 C TO TEST THE ERROR HANDLING PACKAGE. ERR30040 C TEST NUMBER 3: TWO RECOVERABLE ERRORS IN A ROW. ERR30050 C ERR30060 C ********************************************** ERR30070 INTEGER OLDREC, I1MACH ERR30080 INTEGER TEMP ERR30090 C ENTER RECOVERY MODE. ERR30100 CALL ENTSRC(OLDREC, 1) ERR30110 CALL SETERR(30HMAIN - FIRST RECOVERABLE ERROR, 30, 1, 1) ERR30120 CALL SETERR(31HMAIN - SECOND RECOVERABLE ERROR, 31, 2, 1) ERR30130 TEMP = I1MACH(2) ERR30140 WRITE (TEMP, 1) ERR30150 1 FORMAT ( ERR30160 1 56H TWO RECOVERABLE ERRORS IN A ROW FAIL TO HALT EXECUTION.) ERR30170 STOP ERR30180 END ERR30190 C MAIN PROGRAM STK10010 C ********************************************** STK10020 C STK10030 C FIRST STORAGE ALLOCATOR TEST. STK10040 C TESTS THE STORAGE ALLOCATOR WITH DEFAULT INITIALIZATION LENGTH. STK10050 C STK10060 C ********************************************** STK10070 C NUMBER OF OUTSTANDING ALLOCATIONS. STK10080 COMMON /CSTAK/ DS STK10090 DOUBLE PRECISION DS(500) STK10100 INTEGER IS(1000), ISTKMD, ISTKGT, ISTKQU, ISTKST, I STK10110 INTEGER J, K, NALOCS, I1MACH STK10120 REAL RS(1000), R1MACH STK10130 LOGICAL LS(1000) STK10140 COMPLEX CS(500), CMPLX STK10150 DOUBLE PRECISION D1MACH STK10160 INTEGER TEMP STK10170 EQUIVALENCE (DS(1), CS(1), RS(1), IS(1), LS(1)) STK10180 NALOCS = 0 STK10190 TEMP = I1MACH(2) STK10200 WRITE (TEMP, 1) STK10210 1 FORMAT ( STK10220 1 61H AN ERROR BELOW INDICATES TROUBLE WITH THE STORAGE ALLOCATOR,STK10230 2 ) STK10240 TEMP = I1MACH(2) STK10250 WRITE (TEMP, 2) STK10260 2 FORMAT (42H WHEN USING THE STACK WITH DEFAULT LENGTH.,//) STK10270 I = 0 STK10280 GOTO 4 STK10290 3 I = I+1 STK10300 4 K = 5 STK10310 C GET THE ENTIRE STACK, I ITEMS AT A TIME. STK10320 C DO THE ALLOCATIONS IN ORDER OF STK10330 C COMPLEX, LONG REAL, REAL, INTEGER AND LOGICAL. STK10340 GOTO 6 STK10350 5 K = K-1 STK10360 6 IF (K .LT. 1) GOTO 16 STK10370 IF (ISTKQU(K) .LT. I) GOTO 17 STK10380 C GET ALL THE REMAINING STACK. STK10390 J = ISTKGT(ISTKQU(K), K) STK10400 C TRUNCATE TO I ITEMS. STK10410 J = ISTKMD(I) STK10420 GOTO 12 STK10430 C FILL THE SPACE UP ACCORDINGLY. STK10440 7 CALL SETC(I, CMPLX(R1MACH(2), R1MACH(2)), CS(J)) STK10450 GOTO 13 STK10460 8 CALL SETD(I, D1MACH(2), DS(J)) STK10470 GOTO 13 STK10480 9 CALL SETR(I, R1MACH(2), RS(J)) STK10490 GOTO 13 STK10500 10 CALL SETI(I, I1MACH(9), IS(J)) STK10510 GOTO 13 STK10520 11 CALL SETL(I, .TRUE., LS(J)) STK10530 GOTO 13 STK10540 12 IF (K .EQ. 1) GOTO 11 STK10550 IF (K .EQ. 2) GOTO 10 STK10560 IF (K .EQ. 3) GOTO 9 STK10570 IF (K .EQ. 4) GOTO 8 STK10580 IF (K .EQ. 5) GOTO 7 STK10590 13 NALOCS = NALOCS+1 STK10600 IF (ISTKST(1) .EQ. NALOCS) GOTO 15 STK10610 TEMP = I1MACH(2) STK10620 WRITE (TEMP, 14) STK10630 14 FORMAT (24H ISTKST(1) IS INCORRECT.) STK10640 15 CONTINUE STK10650 GOTO 5 STK10660 16 CONTINUE STK10670 GOTO 3 STK10680 17 IF (NALOCS .GE. 6) GOTO 19 STK10690 TEMP = I1MACH(2) STK10700 WRITE (TEMP, 18) NALOCS STK10710 18 FORMAT (30H THE DEFAULT STACK ONLY HOLDS , I1, 7H ITEMS,, STK10720 1 32H IT SHOULD HOLD SEVERAL HUNDRED.) STK10730 C RELEASE THE ALLOCATIONS, ONE BY ONE. STK10740 19 I = 1 STK10750 GOTO 21 STK10760 20 I = I+1 STK10770 21 IF (I .GT. NALOCS) GOTO 25 STK10780 IF (ISTKST(1) .LE. 0) GOTO 22 STK10790 CALL ISTKRL(1) STK10800 GOTO 24 STK10810 22 TEMP = I1MACH(2) STK10820 WRITE (TEMP, 23) STK10830 23 FORMAT ( STK10840 1 50H ALLOCATOR OUT OF ALLOCATIONS BEFORE IT SHOULD BE.) STK10850 24 CONTINUE STK10860 GOTO 20 STK10870 25 IF (ISTKST(1) .EQ. 0) GOTO 27 STK10880 TEMP = I1MACH(2) STK10890 WRITE (TEMP, 26) STK10900 26 FORMAT (49H AFTER DE-ALLOCATING ALL THE ITEMS, ITEMS REMAIN.) STK10910 27 TEMP = I1MACH(2) STK10920 WRITE (TEMP, 28) STK10930 28 FORMAT ( STK10940 1 39H FIRST STORAGE ALLOCATOR TEST COMPLETE.//) STK10950 TEMP = I1MACH(2) STK10960 WRITE (TEMP, 29) STK10970 29 FORMAT (49H NOW FORCE AN ERROR BY REQUESTING TOO MUCH SPACE.) STK10980 I = ISTKGT(2*ISTKQU(5)+10, 5) STK10990 STOP STK11000 END STK11010 SUBROUTINE SETC(N,V,B) STK11020 C C SETC SETS THE N COMPLEX ITEMS IN B TO V C COMPLEX B(N),V C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = V C RETURN C END SUBROUTINE SETD(N,V,B) STK11160 C C SETD SETS THE N DOUBLE PRECISION ITEMS IN B TO V C DOUBLE PRECISION B(N),V C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = V C RETURN C END SUBROUTINE SETI(N,V,B) STK11300 C C SETI SETS THE N INTEGER ITEMS IN B TO V C INTEGER B(N),V C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = V C RETURN C END SUBROUTINE SETL(N,V,B) STK11440 C C SETL SETS THE N LOGICAL ITEMS IN B TO V C LOGICAL B(N),V C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = V C RETURN C END SUBROUTINE SETR(N,V,B) STK11580 C C SETR SETS THE N REAL ITEMS IN B TO V C REAL B(N),V C IF(N .LE. 0) RETURN C DO 10 I = 1, N 10 B(I) = V C RETURN C END C MAIN PROGRAM STK20010 C ********************************************** STK20020 C STK20030 C SECOND ALLOCATOR TEST. STK20040 C TESTS THE STORAGE ALLOCATOR WHEN INITIALIZED TO A NON-DEFAULT LENGTH. STK20050 C STK20060 C ********************************************** STK20070 COMMON /CSTAK/ DS STK20080 DOUBLE PRECISION DS(5000) STK20090 INTEGER IS(1000), ISTKMD, ISTKGT, ISTKQU, ISTKST, I STK20100 INTEGER J, K, NALOCS, I1MACH STK20110 REAL RS(1000), R1MACH STK20120 LOGICAL LS(1000) STK20130 COMPLEX CS(500), CMPLX STK20140 DOUBLE PRECISION D1MACH STK20150 INTEGER TEMP STK20160 EQUIVALENCE (DS(1), CS(1), RS(1), IS(1), LS(1)) STK20170 C INITIALIZE THE STACK. STK20180 CALL ISTKIN(5000, 4) STK20190 C NUMBER OF OUTSTANDING ALLOCATIONS. STK20200 NALOCS = 0 STK20210 TEMP = I1MACH(2) STK20220 WRITE (TEMP, 1) STK20230 1 FORMAT ( STK20240 1 61H AN ERROR BELOW INDICATES TROUBLE WITH THE STORAGE ALLOCATOR,STK20250 2 ) STK20260 TEMP = I1MACH(2) STK20270 WRITE (TEMP, 2) STK20280 2 FORMAT (54H WHEN USING A STACK INITIALIZED TO NON-DEFAULT LENGTH.,STK20290 1 //) STK20300 I = 0 STK20310 GOTO 4 STK20320 3 I = I+1 STK20330 4 K = 5 STK20340 C GET THE ENTIRE STACK, I ITEMS AT A TIME. STK20350 C DO THE ALLOCATIONS IN ORDER OF STK20360 C COMPLEX, LONG REAL, REAL, INTEGER AND LOGICAL. STK20370 GOTO 6 STK20380 5 K = K-1 STK20390 6 IF (K .LT. 1) GOTO 16 STK20400 IF (ISTKQU(K) .LT. I) GOTO 17 STK20410 C GET ALL THE REMAINING STACK. STK20420 J = ISTKGT(ISTKQU(K), K) STK20430 C TRUNCATE TO I ITEMS. STK20440 J = ISTKMD(I) STK20450 GOTO 12 STK20460 C FILL THE SPACE UP ACCORDINGLY. STK20470 7 CALL SETC(I, CMPLX(R1MACH(2), R1MACH(2)), CS(J)) STK20480 GOTO 13 STK20490 8 CALL SETD(I, D1MACH(2), DS(J)) STK20500 GOTO 13 STK20510 9 CALL SETR(I, R1MACH(2), RS(J)) STK20520 GOTO 13 STK20530 10 CALL SETI(I, I1MACH(9), IS(J)) STK20540 GOTO 13 STK20550 11 CALL SETL(I, .TRUE., LS(J)) STK20560 GOTO 13 STK20570 12 IF (K .EQ. 1) GOTO 11 STK20580 IF (K .EQ. 2) GOTO 10 STK20590 IF (K .EQ. 3) GOTO 9 STK20600 IF (K .EQ. 4) GOTO 8 STK20610 IF (K .EQ. 5) GOTO 7 STK20620 13 NALOCS = NALOCS+1 STK20630 IF (ISTKST(1) .EQ. NALOCS) GOTO 15 STK20640 TEMP = I1MACH(2) STK20650 WRITE (TEMP, 14) STK20660 14 FORMAT (24H ISTKST(1) IS INCORRECT.) STK20670 15 CONTINUE STK20680 GOTO 5 STK20690 16 CONTINUE STK20700 GOTO 3 STK20710 17 IF (NALOCS .GE. 6) GOTO 19 STK20720 TEMP = I1MACH(2) STK20730 WRITE (TEMP, 18) NALOCS STK20740 18 FORMAT (30H THE DEFAULT STACK ONLY HOLDS , I1, 7H ITEMS,, STK20750 1 32H IT SHOULD HOLD SEVERAL HUNDRED.) STK20760 C RELEASE THE ALLOCATIONS, ONE BY ONE. STK20770 19 I = 1 STK20780 GOTO 21 STK20790 20 I = I+1 STK20800 21 IF (I .GT. NALOCS) GOTO 25 STK20810 IF (ISTKST(1) .LE. 0) GOTO 22 STK20820 CALL ISTKRL(1) STK20830 GOTO 24 STK20840 22 TEMP = I1MACH(2) STK20850 WRITE (TEMP, 23) STK20860 23 FORMAT ( STK20870 1 50H ALLOCATOR OUT OF ALLOCATIONS BEFORE IT SHOULD BE.) STK20880 24 CONTINUE STK20890 GOTO 20 STK20900 25 IF (ISTKST(1) .EQ. 0) GOTO 27 STK20910 TEMP = I1MACH(2) STK20920 WRITE (TEMP, 26) STK20930 26 FORMAT (49H AFTER DE-ALLOCATING ALL THE ITEMS, ITEMS REMAIN.) STK20940 27 TEMP = I1MACH(2) STK20950 WRITE (TEMP, 28) STK20960 28 FORMAT (40H SECOND STORAGE ALLOCATOR TEST COMPLETE.,//) STK20970 TEMP = I1MACH(2) STK20980 WRITE (TEMP, 29) STK20990 29 FORMAT (49H NOW FORCE AN ERROR BY REQUESTING TOO MUCH SPACE.) STK21000 I = ISTKGT(2*ISTKQU(5)+10, 5) STK21010 STOP STK21020 END STK21030 .