
C ********************  display_ndp ***************************
C The following function displays the numeric and 
C environment registers of the NDP in use. If the
C program is running on a system with both an 80x87
C and an mW1167 coprocessor, the function will choose
C the correct action depending on the compiler options
C used. In case of an error, the function returns NO,
C otherwise it returns YES.
C
      INTEGER FUNCTION DISPLAY_NDP()

      INTEGER IM,DM,ZM,OM,UM,PM,OUM,DCM
      PARAMETER(IM=1,DM=2,ZM=4,OM=8,UM=16,PM=32,OUM=64,DCM=128)

      INTEGER YES,NO
      PARAMETER (YES=1,NO=0)

C The following section is specific for the 80287 and
C 80387. To use it, just uncomment the code part and
C comment out code in sections specific to the mW1167
C The placement of the Control Word, Status Word, and Tag
C Word in the buffer differ between the 80287 and the 80387.
      INTEGER*4 BUFF(27)
      INTEGER*2 WBUFF(54)
      INTEGER*1 BBUFF(108)
      EQUIVALENCE (BUFF, WBUFF, BBUFF)
      COMMON BUFF
C The following are to be used as subscripts into the
C WBUFF array. To use them, just uncomment the PARAMETER
C statement for the coprocessor you intend to use.
      INTEGER CW,SW,TW
C The following statement is specific for the 80287
C      PARAMETER (CW=1,SW=2,TW=3)
C The following statement is specific for the 80387
      PARAMETER (CW=1,SW=3,TW=5)
C end of 80287 and 80387 specific section

C The following section is specific for the mW1167
C To use it, just uncomment the code part and
C comment out code in sections specific to the
C 80387 and 80287
C In the following arrays, the genuine data items begin
C at subscript 1. Any subscript lower than that is padding
C so as to align all genuine data items on the same boundary
C      INTEGER*4 BUFF (-1:32)
C      INTEGER*2 WBUFF (-1:2)
C      REAL*4   R4BUFF (-1:32)
C      REAL*8   R8BUFF (0:16)
C      EQUIVALENCE (BUFF, WBUFF, R4BUFF, R8BUFF)
C end of mW1167 specific section

      INTEGER I, J
C Top of Stack Register
      INTEGER*2 TOS_REG
C Rearranged Tag Word, Temporary Tag Word
      INTEGER*2 NEW_TW, TMP_TW, K
      INTEGER*1 ITEMP

C Receives results from TEMP_DBL
      REAL*8 TD
C converts temporary real to real*8
      REAL*8 TEMP_DBL

C The following section is specific for the 80287
C and 80387. To use it, just uncomment the code part
C and comment out code in sections specific to the
C mW1167
      WRITE (*,1000)
 1000 FORMAT (1X)
      WRITE (*,1010) 'Control word:         ',WBUFF(CW)
 1010 FORMAT (1X,A,Z8)
      WRITE (*,1010) 'Status word:          ',WBUFF(SW)
      WRITE (*,1010) 'Tag word:             ',WBUFF(TW)
      WRITE (*,1010) 'IP offset:            ',BUFF(4)
      WRITE (*,1010) 'CS selector:          ',WBUFF(9)
      WRITE (*,1010) 'Data operand offset:  ',BUFF(6)
      WRITE (*,1010) 'Operand selector:     ',WBUFF(13)

C Which numeric register is Top of Stack ? 
      TOS_REG = RSHIFT (WBUFF(SW), 11)
      TOS_REG = IAND (TOS_REG, 7)

C The following if-else block rearranges the bit pattern
C of the Tag Word, if necessary, to correctly associate bit
C pairs representing physical numeric registers 0-7 with
C relative stack registers ST(0)-ST(7).
      IF (TOS_REG .NE. 0) THEN
          NEW_TW = RSHIFT (WBUFF(TW), (TOS_REG * 2))
          TMP_TW = LSHIFT (WBUFF(TW), (16 - (TOS_REG * 2)))
          NEW_TW = IOR (NEW_TW, TMP_TW)
      ELSE
          NEW_TW = WBUFF(TW)
      ENDIF

      WRITE (*,1020) 'Registers:'
 1020 FORMAT (1X,A)
      DO 1030, I = 29,99,10
        WRITE (*,1040) 'ST',((I-29)/10),' = '         
        DO 1050, J = 0,9
          ITEMP = RSHIFT (BBUFF(I+9-J),4)
          ITEMP = IAND (ITEMP,15)
          WRITE (*,1060) ITEMP
          ITEMP = IAND (BBUFF(I+9-J),15)
          WRITE (*,1060) ITEMP
 1050   CONTINUE
        K = RSHIFT (NEW_TW, (2*((I-29)/10)))
        K = IAND (K, 3)
        IF ((K .EQ. 0) .OR. (K .EQ. 1)) THEN
          TD = TEMP_DBL(BBUFF(I))
          WRITE (*,1070) TD
        ELSE IF (K .EQ. 2) THEN
          WRITE (*,1020) '   Infinity,NAN,or denormal'
        ELSE
          WRITE (*,1020) '   Empty register'
        ENDIF
 1030 CONTINUE
 1040 FORMAT (1X,A,I1,A,$)
 1060 FORMAT (1X,Z1,$)
 1070 FORMAT (4X,D20.14)
C end of code specific to the 80387 and 80287

C The following section is specific for the mW1167
C To use it, just uncomment the code part and
C comment out code in sections specific to the
C 80387 and 80287
C      WRITE (*,1000)
C 1000 FORMAT (1X)
C      WRITE (*,1010) 'Control word:         ',WBUFF(1)
C 1010 FORMAT (1X,A,Z4)
C      WRITE (*,1010) 'Status word:          ',WBUFF(2)
C      DO 1020, I = 0,15
C        WRITE (*,1030) BUFF(2*I+1),BUFF(2*I+2),R4BUFF(2*I+1),
C     _      R4BUFF(2*I+1),R8BUFF(I+1)
C 1020 CONTINUE
C 1030 FORMAT (1X,Z8,1X,Z8,1X,E10.4,8X,E10.4,8X,D16.8)
C      WRITE (*,1000)
C end of code specific to the mW1167

      WRITE (*,1000)
      DISPLAY_NDP = YES
      END
C ********************  end of display_ndp ************************
