SUBROUTINE FIGEVL INCLUDE 'FIGI01.FTN' INTEGER*2 IVALU(2) ! Integer for value. REAL*4 VALU ! Value. INTEGER*4 JVALU,JVALU2 ! Double integer value. EQUIVALENCE (VALU,IVALU,JVALU) VALPTR = 0 ! Init. intermed. val. pointer. IOPND = 0 ! Initially, no operand. LSTOUT = MXVLSK + 1 ! Result output flag. I = 0 ! Init. loop counter. GO TO 7990 ! Loop manually. 1000 J = OPSTAK(I) ! Get the operation. IF (J .GT. 0) GO TO 1100 ! Pick up operand. IF (IOPND .LE. 0) GO TO 1040 ! If no implied push, fine. VALPTR = VALPTR + 1 ! Update value pointer. VALSTK(VALPTR) = VARVAL(IOPND) ! Push the value. IOPND = 0 ! Clear the operand pointer. 1040 IF (J .EQ. OPPUSH) GO TO 1200 ! Push IF (J .EQ. OPPOP) GO TO 1300 ! Pop IF (J .EQ. OPADD) GO TO 1400 ! Add. IF (J .EQ. OPSUB) GO TO 1500 ! Subtract. IF (J .EQ. OPOR) GO TO 1600 ! Logical 'or'. IF (J .EQ. OPMUL) GO TO 1700 ! Multiplication. IF (J .EQ. OPDIV) GO TO 1800 ! Division. IF (J .EQ. OPAND) GO TO 1900 ! Logical 'and'. IF (J .EQ. OPEXP) GO TO 2000 ! Exponentiation. IF (J .EQ. OPNOT) GO TO 2100 ! Logical 'not'. IF (J .EQ. OPNEG) GO TO 2200 ! Negation. IF (J .EQ. OPCMP) GO TO 2300 ! Compare. IF (J .EQ. OPSTO) GO TO 2400 ! Store. IF (J .EQ. OPPSHI) GO TO 2500 ! Push immediate. IF (J .EQ. OPSGN) GO TO 2600 ! Signum IF (J .EQ. OPIDIV) GO TO 2700 ! Integer divide. IF (J .EQ. OPMOD) GO TO 2800 ! Remainder. IF (J .EQ. OPABS) GO TO 2900 ! Absolute value. IF (J .EQ. OPTRUE) GO TO 3000 ! "True". IF (J .EQ. OPFALS) GO TO 3100 ! "False". 1100 IOPND = J ! Get operand address. GO TO 7990 ! Go to bottom of loop. 1200 I = I + 1 ! Point to next item in op. list. IOPND = OPSTAK(I) ! Use it as operand. VALPTR = VALPTR + 1 ! Update value pointer. VALSTK(VALPTR) = VARVAL(IOPND) ! Push the value. IOPND = 0 ! Clear the operand pointer. GO TO 7990 ! Go to bottom of loop. 1300 I = I + 1 ! Point to next item in op. list. IOPND = OPSTAK(I) ! Use it as operand. VARVAL(IOPND) = VALSTK(VALPTR) ! Pop the value. CALL VALWRT(IOPND) ! Write it. LSTOUT = VALPTR ! Record the write. VALPTR = VALPTR - 1 ! Update value pointer. IOPND = 0 ! Clear the operand pointer. GO TO 7990 ! Go to bottom of loop. 1400 VALSTK(VALPTR-1) = ! New value = 1 VALSTK(VALPTR-1) + ! sum of 2 VALSTK(VALPTR) ! old values. VALPTR = VALPTR - 1 ! Update value pointer. GO TO 7990 ! Go to bottom of loop. 1500 VALSTK(VALPTR-1) = ! New value = 1 VALSTK(VALPTR-1) - ! difference of 2 VALSTK(VALPTR) ! old values. VALPTR = VALPTR - 1 ! Update value pointer. GO TO 7990 ! Go to bottom of loop. 1600 CALL RALIGN(VALSTK(VALPTR-1), ! Convert the stacked 1 VALSTK(VALPTR), ! values to scaled and 2 JVALU,JVALU2,ISCALE) ! aligned integers. JVALU = JVALU .OR. JVALU2 ! Compute logical 'or'. VALPTR = VALPTR - 1 ! Pop first value off stack. CALL SITOR(VALSTK(VALPTR), ! Convert result to real, and 1 JVALU,ISCALE) ! put on the stack. GO TO 7990 ! Go to bottom of loop. 1700 VALSTK(VALPTR-1) = ! New value = 1 VALSTK(VALPTR-1) * ! product of 2 VALSTK(VALPTR) ! old values. VALPTR = VALPTR - 1 ! Update value pointer. GO TO 7990 ! Go to bottom of loop. 1800 VALSTK(VALPTR-1) = ! New value = 1 VALSTK(VALPTR-1) / ! quotient of 2 VALSTK(VALPTR) ! old values. VALPTR = VALPTR - 1 ! Update value pointer. GO TO 7990 ! Go to bottom of loop. 1900 CALL RALIGN(VALSTK(VALPTR-1), ! Convert the stacked 1 VALSTK(VALPTR), ! values to scaled and 2 JVALU,JVALU2,ISCALE) ! aligned integers. JVALU = JVALU .AND. JVALU2 ! Compute logical 'and'. VALPTR = VALPTR - 1 ! Pop first value off stack. CALL SITOR(VALSTK(VALPTR), ! Convert result to real, and 1 JVALU,ISCALE) ! put on the stack. GO TO 7990 ! Go to bottom of loop. 2000 VALSTK(VALPTR-1) = ! New value = 1 VALSTK(VALPTR-1) ** ! exponentiation of 2 VALSTK(VALPTR) ! old values. VALPTR = VALPTR - 1 ! Update value pointer. GO TO 7990 ! Go to bottom of loop. 2100 IF (PTRIM .LE. 0) GO TO 2030 ! If no trim mask, punt. IF (VARVAL(PTRIM) .EQ. 0.) ! If mask is clear, 1 GO TO 2030 ! punt. CALL RALIGN(VALSTK(VALPTR), ! Convert the stacked 1 VARVAL(PTRIM), ! values to scaled and 2 JVALU,JVALU2,ISCALE) ! aligned integers. JVALU = .NOT. JVALU .AND. JVALU2 !Compute logical 'not', trim. GO TO 2050 ! 2030 CALL RTOSI(VALSTK(VALPTR), ! Convert the stacked value 2 JVALU,ISCALE) ! to scaled integer. JVALU = .NOT. JVALU ! Logical 'not'. IF (VALSTK(VALPTR) .EQ. 0.) ! If argument is exactly zero, 1 CALL RTOSI(1.,JVALU2,ISCALE) ! force integer. 2050 CALL SITOR(VALSTK(VALPTR), ! Convert result to real, and 1 JVALU,ISCALE) ! put on the stack. GO TO 7990 ! Go to bottom of loop. 2200 VALSTK(VALPTR) = ! New value = 1 - VALSTK(VALPTR) ! negation of old. GO TO 7990 ! Go to bottom of loop. 2300 IF (VALSTK(VALPTR-1) - ! Test the difference 1 VALSTK(VALPTR)) ! between the 2 2310,2320,2330 ! operands. 2310 J = 1 ! (1) Less than (2) GO TO 2340 ! Go process. 2320 J = 2 ! (1) equal to (2) GO TO 2340 ! Go process. 2330 J = 4 ! (1) greater than (2) 2340 VALPTR = VALPTR - 1 ! Drop the top item. VALSTK(VALPTR) = 0. ! Assume cond. false. I = I + 1 ! Get cond. mask. IF ((OPSTAK(I) .AND. J) .NE. 0) ! If cond. true, 1 VALSTK(VALPTR) = -1. ! Store the fact. GO TO 7990 ! Go to bottom of loop. 2400 I = I + 1 ! Point to next item in op. list. IOPND = OPSTAK(I) ! Use it as operand. VARVAL(IOPND) = VALSTK(VALPTR) ! Pop the value. CALL VALWRT(IOPND) ! Write it. LSTOUT = VALPTR ! Record the write. IOPND = 0 ! Clear the operand pointer. GO TO 7990 ! Go to bottom of loop. 2500 I = I + 1 ! Point to next item in op. list. IVALU(1) = OPSTAK(I) ! Get first part of value. I = I + 1 ! Point to next item in op. list. IVALU(2) = OPSTAK(I) ! Get second part of value. VALPTR = VALPTR + 1 ! Update value pointer. VALSTK(VALPTR) = VALU ! Push the value. GO TO 7990 ! Go to bottom of loop. 2600 IF (VALSTK(VALPTR)) ! Test the value of 1 2610,2620,2630 ! the item. 2610 VALSTK(VALPTR) = -1. ! Negative. GO TO 7990 ! Go to bottom of loop. 2620 VALSTK(VALPTR) = 0. ! Zero. GO TO 7990 ! Go to bottom of loop. 2630 VALSTK(VALPTR) = 1. ! Positive. GO TO 7990 ! Go to bottom of loop. 2700 JVALU = ! New value = 1 VALSTK(VALPTR-1) / ! quotient of 2 VALSTK(VALPTR) ! old values. VALPTR = VALPTR - 1 ! Update value pointer. VALSTK(VALPTR) = JVALU ! Store new value. GO TO 7990 ! Go to bottom of loop. 2800 JVALU = ! New value = 1 VALSTK(VALPTR-1) / ! quotient of 2 VALSTK(VALPTR) ! old values. VALSTK(VALPTR-1) = ! Compute the remainder 1 VALSTK(VALPTR-1) - ! after the 2 JVALU*VALSTK(VALPTR) ! operation. VALPTR = VALPTR - 1 ! Update value pointer. GO TO 7990 ! Go to bottom of loop. 2900 VALSTK(VALPTR) = ! New value = 1 ABS(VALSTK(VALPTR)) ! absolute value of old. GO TO 7990 ! Go to bottom of loop. 3000 VALPTR = VALPTR + 1 ! Update stack pointer. VALSTK(VALPTR) = -1. ! Stack "True". GO TO 7990 ! Go to bottom of loop. 3100 VALPTR = VALPTR + 1 ! Update stack pointer. VALSTK(VALPTR) = 0. ! Stack "False". GO TO 7990 ! Go to bottom of loop. 7990 I = I + 1 ! Next operation. IF (I .LE. OPPNTR) GO TO 1000 ! If there is one, do. IF (PRESUL .LE. 0) RETURN ! If no result, return. VARVAL(PRESUL) = VALSTK(VALPTR) ! Save result. IF (LSTOUT .GT. VALPTR) ! If not previously written, 1 CALL VALWRT(PRESUL) ! do so. RETURN ! Done. END SUBROUTINE MSGWRT(LEN,MSG) LOGICAL*1 MSG(LEN) WRITE (LUNOUT,91000) MSG 91000 FORMAT (X,A1,'.') RETURN END SUBROUTINE VALWRT(INDX) INCLUDE 'FIGI01.FTN' LOGICAL*1 VNAM(6,MXVNAM) LOGICAL*1 VDSPLY(40) REAL*8 VALU INTEGER*2 IX LOGICAL*1 MINUS LOGICAL*1 DP LOGICAL*1 SPACE ! = ASCII . INTEGER*4 JINT ! Screatch I*4. INTEGER*2 IRADIX ! Current radix. DATA MINUS /'-'/ DATA DP /'.'/ DATA SPACE /' '/ IX = 0 ! Init buffer pointer. IF (INDX .LE. 0) RETURN ! If no-op, handle. CALL R50ASC(MXVNAM*6,VARNAM(1,INDX),VNAM) ! Convert name to R50. VALU = VARVAL(INDX) ! Get the value. IRADIX = CURRDX ! Get current radix. IF (IRADIX .LE. 1) GO TO 2000 IF (VALU .EQ. 0) GO TO 1100 ! Zero a special case. IF (VALU .GE. 0) GO TO 1010 ! If positive, OK. VALU = -VALU ! Make positive. IX = IX + 1 ! Update index position. VDSPLY(IX) = MINUS ! Insert the sign. 1010 IEXP = 0 ! Assume "E" not needed. IPLCS = ALOG(2.)/ALOG(FLOAT(IRADIX))*22. !Places to display. JINT = IRADIX ! Force double-precision JINT = JINT**(IPLCS) ! Find top lim. for "F". VRANGE = JINT ! Convert to real. VALU = (.5/VRANGE + 1.)*VALU ! Round the value. IF (VALU .GE. VRANGE) GO TO 1200 ! If too high, "E". IF (VALU .LE. 1./VRANGE) GO TO 1200 ! If too low, "E" GO TO 1300 ! "F" format. 1100 CONTINUE ! Exactly zero. IX = IX + 1 ! Update pointer. VDSPLY(IX) = 48 ! Store zero. GO TO 1800 ! Go write it. 1200 CONTINUE ! "F" format. IF (VALU .LT. 1.) GO TO 1240 ! If a fraction, align. 1210 IF (VALU .LT. IRADIX) GO TO 1300 ! If aligned, fine. VALU = VALU/IRADIX ! "Shift right". IEXP = IEXP + 1 ! Count exponent. GO TO 1210 ! Try again. 1240 IF (VALU .GT. 1.) GO TO 1300 ! If aligned, fine. VALU = VALU*IRADIX ! "Shift left". IEXP = IEXP - 1 ! Count. GO TO 1240 ! Try again. 1300 CONTINUE ! Put out integr part. JINT = VALU ! Get the integer part. 1310 IX = IX + 1 ! Up a space. IPLCS = IPLCS - 1 ! Count radix place. JINT = JINT/IRADIX ! Knock off the number. IF (JINT .GT. 0) GO TO 1310 ! Not done yet. JINT = VALU ! Get integr part again. IF (JINT .EQ. 0) IPLCS = IPLCS + 1 ! If zero, don't count. I = IX ! Place marker. 1320 J = JINT - (JINT/IRADIX)*IRADIX ! Get the next digit. JINT = JINT/IRADIX ! Cut it out. J = J + 48 ! Convert to numeric. IF (J .GT. 57) J = J + 7 ! If > 10., bump to alph VDSPLY(I) = J ! Store it. I = I - 1 ! Go down 1. IF (JINT .GT. 0) GO TO 1320 ! If more to do, do it. IX = IX + 1 ! Bump index. VDSPLY(IX) = DP ! Store decimal point. JINT = VALU ! Get value again. VALU = VALU - JINT ! Strip integer part. 1400 CONTINUE ! Store fractional part. IF (IPLCS .LE. 0) GO TO 1450 ! If max, go store expon IF (VALU .LE. 0.) GO TO 1450 ! If no more, get expon. VALU = VALU*IRADIX ! Get next digit. J = VALU ! Strip it out. VALU = VALU - J ! Take it from value. J = J + 48 ! Convert to numeric. IF (J .GT. 57) J = J + 7 ! If > 10., bump to alph IX = IX + 1 ! Place for it. VDSPLY(IX) = J ! Store it. IPLCS = IPLCS - 1 ! Another radix place. GO TO 1400 ! Loop back. 1450 IF (VDSPLY(IX) .NE. 48) GO TO 1500 ! If no trlng 0, OK. IX = IX - 1 ! Strip it. GO TO 1450 ! Loop back. 1500 CONTINUE ! Store exponent. IF (IEXP .EQ. 0) GO TO 1600 ! If none, done. IX = IX + 1 ! Update position. VDSPLY(IX) = IRXMRK ! Store the exp. mark. IF (IEXP .GT. 0) GO TO 1520 ! If positive, proceed. IX = IX + 1 ! Update index position. VDSPLY(IX) = MINUS ! Insert the sign. IEXP = -IEXP ! Flip the sign. 1520 JINT = IEXP ! Save the exponent. 1530 IEXP = IEXP/IRADIX ! Strip a place. IX = IX + 1 ! Count it. IF (IEXP .GT. 0) GO TO 1530 ! If more, do. I = IX ! Get location. IEXP = JINT ! Restore radix. 1540 J = IEXP - (IEXP/IRADIX)*IRADIX ! Get digit. IEXP = IEXP/IRADIX ! Strip it out. J = J + 48 ! Convert to numeric. IF (J .GT. 57) J = J + 7 ! If > 10., bump to alph VDSPLY(I) = J ! Store it. I = I - 1 ! Go to previous space. IF (IEXP .GT. 0) GO TO 1540 ! Repeat as needed. 1600 CONTINUE ! Display the radix. IF (IRADIX .EQ. 10) GO TO 1800 ! If ten, no need. IX = IX + 1 ! Put in a VDSPLY(IX) = SPACE ! space. IX = IX + 1 ! Put in the VDSPLY(IX) = '(' ! left paren. I = IRADIX/10 ! Get top digit. IF (I .LE. 0) GO TO 1630 ! If none, skip. IX = IX + 1 ! Put in the top VDSPLY(IX) = I+48 ! digit. 1630 I = IRADIX - (IRADIX/10)*10 ! Get the bottom digit. IX = IX + 1 ! Put in the bottom VDSPLY(IX) = I+48 ! digit. IX = IX + 1 ! Put in the VDSPLY(IX) = ')' ! right paren. 1800 WRITE (LUNOUT,91800) VNAM, ! Write it, already. 1 (VDSPLY(I),I=1,IX) 91800 FORMAT (X,(6A1),' = ',A1) RETURN ! Return to caller. 2000 IF (VALU .LT. 0.) GO TO 2010 ! If true, handle. WRITE (LUNOUT,92000) VNAM ! Write the (false) valu 92000 FORMAT (X,(6A1),' = FALSE') ! Format. RETURN ! Return to caller. 2010 WRITE (LUNOUT,92010) VNAM ! Write the (true) value 92010 FORMAT (X,(6A1),' = TRUE') ! Format. RETURN ! Return to caller. END SUBROUTINE RALIGN(R1,R2,J1,J2,IAL) ! Cvrt 2 reals to scaled INTEGER*4 R1,R2 ! The reals to convert. INTEGER*4 J1,J2 ! The scaled ints. INTEGER*2 IAL ! The scale factor. INTEGER*4 JVAL(2) ! Values. INTEGER*2 IEXP(2) ! Scales. CALL RTOSI(R1,JVAL(1),IEXP(1)) ! Pick apart first. CALL RTOSI(R2,JVAL(2),IEXP(2)) ! Pick apart second. IF (IEXP(1) .EQ. IEXP(2)) GO TO 190 ! If already aligned. ISH = 1 ! Assume shift first. IF (IEXP(1) .GT. IEXP(2)) ISH = 2 ! If wrong, correct. 110 JVAL(ISH) = JVAL(ISH)/2 ! Shift. IEXP(ISH) = IEXP(ISH) + 1 ! Adjust exponent. IF (IEXP(ISH) .LT. IEXP(3-ISH)) ! If not aligned yet, 1 GO TO 110 ! repeat as needed. 190 J1 = JVAL(1) ! Return J2 = JVAL(2) ! the IAL = IEXP(1) ! values. RETURN ! Return to caller. END SUBROUTINE RTOSI(R,JINT,ISCAL) ! Cvrt real to scaled I. INTEGER*4 R ! The real to scale. INTEGER*4 JINT ! The scaled integer. INTEGER*2 ISCAL ! The scale factor. INTEGER*4 JVAL ! Temporary. INTEGER*2 IVAL(2) ! Temporary. INTEGER*2 IISCAL ! Internal scale factor. INTEGER*2 ISIGN ! Internal sign bit. EQUIVALENCE (JVAL,IVAL) ! Equiv. the two. JVAL = R ! Copy the real. ISCAL = IVAL(1) ! Swap the IVAL(1) = IVAL(2) ! words, to be in IVAL(2) = ISCAL ! I*4 order. ISCAL = (IVAL(2) .AND. "77600)/128 ! Get the exponent. IVAL(2) = IVAL(2) .AND. .NOT. "77600 ! Mask it out. IVAL(2) = IVAL(2) .OR. 128 ! Set the hidden bit. IF (IVAL(2) .GE. 0) GO TO 90 ! If positive, fine. IVAL(2) = IVAL(2) .AND. 32767 ! Mask out sign bit. JVAL = -JVAL ! Negate. 90 IF (ISCAL .EQ. 0) JVAL = 0 ! Force zero if needed. JINT = JVAL ! Return to caller. RETURN ENTRY SITOR(R,JINT,ISCAL) ! Scaled int. to real. JVAL = JINT ! Copy value. IF (JVAL .EQ. 0) GO TO 190 ! If zero, fine. IISCAL = ISCAL ! Save scale. ISIGN = 0 ! Assume positive. IF (JVAL .GE. 0) GO TO 120 ! If so, fine. ISIGN = -32768 ! If not, save sign. IF (IVAL(2) .EQ. -32768 .AND. IVAL(1) ! If minus (big numbr) 1 .EQ. 0) GO TO 170 ! handle. JVAL = -JVAL ! Make positive. 120 IF ((IVAL(2) .AND. "177400) .EQ. 0) ! If not too big, 1 GO TO 130 ! see if too small. JVAL = JVAL/2 ! Scale down, IISCAL = IISCAL + 1 ! adj. exponent. GO TO 120 ! Try again. 130 IF ((IVAL(2) .AND. 128) .NE. 0) ! If right size, 1 GO TO 140 ! done. JVAL = JVAL*2 ! Scale up, IISCAL = IISCAL - 1 ! adj. exponent. GO TO 130 ! Try again. 140 IF (IISCAL .LE. 0) GO TO 180 ! If underflow, zero. IF (IISCAL .GT. 255) GO TO 170 ! If overflow, max. IISCAL = IISCAL*128 ! Shift the scale. IVAL(2) = IVAL(2) .AND. 127 .OR. ! Insert the scale 1 IISCAL .OR. ISIGN ! and the sign. IISCAL = IVAL(1) ! Swap IVAL(1) = IVAL(2) ! the IVAL(2) = IISCAL ! words. GO TO 190 ! Go return the value. 170 JVAL = -1 ! Set all bits. IVAL(1) = IVAL(1) .AND. 32767 .OR. ISIGN ! Set sign. GO TO 190 ! Return value. 180 JVAL = 0 ! Return zero. 190 R = JVAL ! Return value. RETURN ! Return to caller. END