From: JSNYDER%PPC.MFENET@CCC.MFECC.LLNL.GOV
Newsgroups: comp.os.vms
Subject: Fortran routine for Ethernet address
Date: 26 Apr 89 17:40:41 GMT
Organization: The Internet

C  The Fortran subroutine ETHERNET_ADDRESS called by this program will return
C  the Ethernet address of the specified device.  For the device, enter the
C  two-character device name (for example, XE for a DEUNA, XQ for a DELQA).
C
C  The subroutine sends a QIO to the Ethernet driver, which returns a
C  buffer of data that includes the Ethernet hardware address.  Note that
C  this is not the DECnet address, but the actual hardware address.
C
C  Most of what is done here I got out of the I/O User's Guide, Part II.
C
C  Jim Snyder - Princeton University Plasma Physics Lab
C
      PROGRAM TEST

      INTEGER ETHERNET_ADDRESS
      CHARACTER*2 DEVICE
      BYTE IB_ADDRESS(6)

      WRITE (6,10)
   10 FORMAT (' Enter device > ', $)
      READ (5, '(A)') DEVICE

      ISTATUS = ETHERNET_ADDRESS( DEVICE, IB_ADDRESS )
      IF (.NOT. ISTATUS) CALL LIB$SIGNAL(%VAL(ISTATUS))
 
      WRITE (6,20) (IB_ADDRESS(I),I=1,6)
   20 FORMAT (1X,5(Z2.2,'-'),Z2.2)

      END

C*************************************************************/ETHERNET_ADDRESS

      INTEGER FUNCTION ETHERNET_ADDRESS( DEVICE, IB_ADDRESS )

C------------------------------------------------------------------------------
C
C  This subroutine returns the Ethernet address of the specified device.
C
C     Input Argument
C     --------------
      CHARACTER*(*) DEVICE          ! Device in question (e.g., XE, XQ, ET)
C
C     Output Argument
C     ---------------
      BYTE IB_ADDRESS(6)            ! Ethernet hardware address, 6 bytes,
                                    !  hex format.
C
C  This routine is called as a function.  The returned function value is:
C     SS$_NORMAL if everything worked;
C     0 if for some reason, the address could not be determined;
C     Error status code from SYS$ASSIGN or SYS$QIOW if either of those failed.
C
C  J. Snyder - Princeton University Plasma Physics Lab - 25-APR-1989
C------------------------------------------------------------------------------

      INCLUDE '($SYSSRVNAM)'
      INCLUDE '($SSDEF)'
      INCLUDE '($IODEF)'

      PARAMETER NMA$C_PCLI_HWA = '00000488'X   ! There is no $NMADEF Fortran
                                               ! INCLUDE file, so I swiped
                                               ! this value from the Macro one.

      INTEGER*2 ICHAN
      BYTE      BUFFER(120)
      INTEGER   IDESC(2)

      BYTE      IBYTE(2)
      INTEGER*2 IWORD
      EQUIVALENCE (IBYTE,IWORD)

      INTEGER*2 MASKED_WORD
      
      STRUCTURE /IOSTAT_BLOCK/
                 INTEGER*2 IOSTAT
                 INTEGER*2 ICOUNT
                 BYTE      NOT_USED_1
                 BYTE      ISTATUS
                 BYTE      ERROR_SUMMARY
                 BYTE      NOT_USED_2
      END STRUCTURE

      RECORD /IOSTAT_BLOCK/ IOSB

*-------------------------*
*     EXECUTABLE CODE     *
*-------------------------*

      DO I = 1, 6                      ! Initialize
         IB_ADDRESS(I) = 0
      ENDDO

      ISTATUS = SYS$ASSIGN( DEVICE, ICHAN, , )      ! Assign channel to device.
      IF (.NOT. ISTATUS) GO TO 200

      ICODE = IO$_SENSEMODE .OR. IO$M_CTRL          ! Modifiers for driver.

      IDESC(1) = 120                                ! Descriptor for buffer.
      IDESC(2) = %LOC(BUFFER)

      ISTATUS = SYS$QIOW( , %VAL(ICHAN), %VAL(ICODE), IOSB, , ,  ! Read data.
     +                    , IDESC, , , , )

      IF (.NOT. ISTATUS) GO TO 200                  ! Check status.
      IF (.NOT. IOSB.IOSTAT) THEN
         ISTATUS = IOSB.ISTATUS
         GO TO 200
      ENDIF

      ISTATUS = SYS$DASSGN( %VAL(ICHAN) )           ! Deassign the channel.

      IPT = 1                         ! Trudge through the buffer until
                                      ! the correct parameter id is found;
                                      ! punt if we can't find it.

      DO WHILE (.TRUE.)

         IF (IPT .GT. IOSB.ICOUNT-1) GO TO 100
         IBYTE(1) = BUFFER(IPT)
         IBYTE(2) = BUFFER(IPT+1)
         MASKED_WORD = IIAND(IWORD,'0FFF'X)

         IF (MASKED_WORD .EQ. NMA$C_PCLI_HWA) THEN     ! Got it.
            IPT = IPT + 2
            IF (IPT .GT. IOSB.ICOUNT-1) GO TO 100
            IBYTE(1) = BUFFER(IPT)
            IBYTE(2) = BUFFER(IPT+1)
            IF (IWORD .NE. 6) GO TO 100
            IF (IPT .GT. IOSB.ICOUNT-7) GO TO 100
            DO I = 1, 6
               IB_ADDRESS(I) = BUFFER(I+IPT+1)
            ENDDO
            GO TO 500

         ELSE
            IF (BITEST(IWORD,12)) THEN                ! String parameter.
               IPT = IPT + 2
               IF (IPT .GT. IOSB.ICOUNT-1) GO TO 100
               IBYTE(1) = BUFFER(IPT)
               IBYTE(2) = BUFFER(IPT+1)
               IPT = IPT + 2 + IWORD
            ELSE                                      ! Longword parameter.
               IPT = IPT + 6
            ENDIF
         ENDIF
      ENDDO

  100 ETHERNET_ADDRESS = 0                            ! Set function value.
      GO TO 900

  200 ETHERNET_ADDRESS = ISTATUS
      GO TO 900

  500 ETHERNET_ADDRESS = SS$_NORMAL

  900 RETURN
      END