Trailing-Edge
-
PDP-10 Archives
-
BB-H348C-RM_1982
-
swskit-v21/demos/status.for
There are no other files named status.for in the archive.
c
c This program reports network info using NICE.
c
IMPLICIT INTEGER (A-Z)
DIMENSION LINE(128),A(512),UNIT(50),D(2),COU(7)
C
C LINE - DECnet task to task buffer (4 8bit bytes/word)
c A - DECnet task to task buffer (1 8bit byte/word)
c UNIT - Table of unit types
c D - Date string
c COU - Line counts
c
UNIT(12)=' DMC'
UNIT(20)=' DTE'
UNIT(10)=' DUP'
UNIT(24)=' DZ'
UNIT(28)=' KDP'
UNIT(30)=' KDZ'
WRITE(5,55)
READ (5,56) ANSWER
55 FORMAT (' Log data in a file (Default=Yes) ? ',$)
56 FORMAT (R1)
DEVN=1
IF ((ANSWER.EQ.78).OR.(ANSWER.EQ.110)) DEVN=5
TWO7=2**7
TWO8=2**8
TWO20=2**20
TWO28=2**28
VERSN=0
FE1='DN20A' ; FE2=' '
ENTRY=1
CALL DATE(D) ; CALL TIME(TM)
IF (DEVN.EQ.5) GOTO 75
OPEN (UNIT=1, DEVICE='DSK', MODE='ASCII',ACCESS='APPEND',
2FILE='STATUS.LOG')
75 WRITE (DEVN,80) FE1,FE2,ENTRY,VERSN,D(1),D(2),TM
80 FORMAT (X,A5,A1,X,I1,X,I1,X,A5,A4,X,A5,X
2,23H*** Status starting *** )
CLOSE (UNIT=1)
c
c Open the network link.
c
100 IF (DEVN.EQ.5) GOTO 150
OPEN (UNIT=1, DEVICE='DSK', MODE='ASCII',ACCESS='APPEND',
2FILE='STATUS.LOG')
150 CALL NFOPN (NETLN,1,'DCN:DN20A-NCU',8,1,RETCOD)
WHERE='OPN 1'
IF(RETCOD.NE.0)GOTO 5000
c
c Send NICE a request for status of known lines.
c
LINE(1)="20024000000
SIZE=3
CALL NFSND (NETLN,SIZE,LINE,1,RETCOD)
WHERE='SND 1'
IF(RETCOD.NE.0)GOTO 5000
c
c Get the NICE count of links
c
SIZE=512
CALL NFRCV(NETLN,SIZE,LINE,1,1,RETCOD)
WHERE='RCV 1'
IF(RETCOD.NE.0)GOTO 5000
X=LINE(1)/TWO28
IF(X.NE.1)GOTO 6000
COUNT=LINE(1)/TWO20
TEMP=COUNT/TWO8
TEMP=TEMP*TWO8
COUNT=COUNT-TEMP
c
c Receive each status report individually
c
DO 1000 I=1,COUNT
SIZE=512
CALL NFRCV(NETLN,SIZE,LINE,1,1,RETCOD)
WHERE='RCV 2'
IF(RETCOD.NE.0)GOTO 5000
C
C Process status for one line
C
CALL EIGHT(LINE,A)
ENTRY=2
STATE='OFF '
NAME1='None '
NAME1=NAME1/2
NAME2=0
C Is state on or off?
IF (A(7).NE.0) GOTO 400
STATE='ON '
c Is the length of the node name 0?
NAME1='down '
NAME1=NAME1/2
IF (A(10).EQ.0) GOTO 400
200 NAME1=0
DO 300 J=1,6
NAME2=NAME2*TWO7
IF (J.LE.A(10)) NAME2=NAME2+A(J+10)
IF (J.NE.5) GOTO 300
NAME1=NAME2
NAME2=0
300 CONTINUE
400 CALL DATE(D) ; CALL TIME(TM)
WRITE (DEVN,401) FE1,FE2,ENTRY,VERSN,D(1),D(2),TM,
2UNIT(A(3)),A(4),A(5),STATE,NAME1,NAME2
401 FORMAT(X,A5,A1,X,I1,X,I1,X,A5,A4,X,A5,X,A4,'_',I1,'_',
2I1,X,A3,X,R5,R1)
1000 CONTINUE
C
C Now close line to NICE and reopen it because NICE
C doesn't like to give me two different types of messages
C through the same link.
C
CALL NFCLS(NETLN,0,0,0,0,RETCOD)
WHERE='CLS 1'
IF (RETCOD.NE.0) GOTO 5000
CALL NFOPN (NETLN,0,'DCN:DN20A-NCU',8,1,RETCOD)
WHERE='OPN 2'
IF(RETCOD.NE.0)GOTO 5000
C
C Send NICE a request for counts of known lines
C
SIZE=3
LINE(1)="20020000000
CALL NFSND(NETLN,SIZE,LINE,1,RETCOD)
WHERE='SND 2'
IF (RETCOD.NE.0) GOTO 5000
C
C Get the NICE count of links again...
C
SIZE=512
CALL NFRCV(NETLN,SIZE,LINE,1,1,RETCOD)
WHERE='RCV 3'
IF(RETCOD.NE.0)GOTO 5000
X=LINE(1)/TWO28
IF(X.NE.1)GOTO 6000
COUNT=LINE(1)/TWO20
TEMP=COUNT/TWO8
TEMP=TEMP*TWO8
COUNT=COUNT-TEMP
C
C Receive each set of counts individually
C
DO 1500 I=1,COUNT
SIZE=512
CALL NFRCV(NETLN,SIZE,LINE,1,1,RETCOD)
WHERE='RCV 4'
IF (RETCOD.NE.0) GOTO 5000
C
C Process counts for one line
C
CALL EIGHT(LINE,A)
DO 1100 J=0,6
COU(J+1)=0
1100 CONTINUE
888 DO 1200 INDEX=7,SIZE,3
877 DATA=A(INDEX+2)*TWO8+A(INDEX+1)
866 COU(A(INDEX)+1)=DATA
1200 CONTINUE
c* index=7
c*1210 data=a(index+1)+a(index+2)*2**8
c* write(devn,1220) a(index),data
c*1220 format(' type ',2i7)
c* index=index+3
c* if (index.lt.size) goto 1210
ENTRY=3
CALL DATE(D) ; CALL TIME(TM)
WRITE (DEVN,1301) FE1,FE2,ENTRY,VERSN,D(1),D(2),
2TM,UNIT(A(3)),A(4),A(5),(COU(J),J=1,7)
1301 FORMAT(X,A5,A1,X,I1,X,I1,X,A5,A4,X,A5,X,A4,'_',I1,'_',
2I1,3I8,4I5)
1500 CONTINUE
C
C Now close line to NICE and reopen it because NICE
C doesn't like to give me two different types of messages
C through the same link.
C
C CALL NFCLS(NETLN,0,0,0,0,RETCOD)
C WHERE='CLS 2'
C IF (RETCOD.NE.0) GOTO 5000
C CALL NFOPN (NETLN,0,'DCN:DN20A-NCU',8,1,RETCOD)
C WHERE='OPN 3'
C IF(RETCOD.NE.0)GOTO 5000
C
C Now zero the line counts
C
C LINE(1)="22010000700
C SIZE=3
C CALL NFSND(NETLN,SIZE,LINE,1,RETCOD)
C WHERE='SND 3'
C IF(RETCOD.NE.0)GOTO 5000
C
C Close the network line for a while
C
2000 CALL NFCLS(NETLN,0,0,0,0,RETCOD)
WHERE='CLS 3'
IF (RETCOD.NE.0) GOTO 5000
2001 CLOSE (UNIT=1)
CALL SLEEP(X)
GOTO 100
C
C Somewhere down here on any error
C
5000 CALL DATE(D) ; CALL TIME(TM) ; ENTRY=4
WRITE(DEVN,5001) FE1,FE2,ENTRY,VERSN,D(1),D(2),
2 TM,RETCOD,WHERE
5001 FORMAT(' ',A5,A1,X,I1,X,I1,X,A5,A4,X,A5,
2' ?Fatal error - RETCOD: ',I8,' at ',A5)
CLOSE (UNIT=1)
IF ((WHERE.EQ.'CLS 1').OR.(WHERE.EQ.'CLS 2').OR.(WHERE.EQ.
2'CLS 3')) GOTO 2001
GOTO 2000
6000 CALL DATE(D) ; CALL TIME(TM) ; ENTRY=5
WRITE(DEVN,6001) FE1,FE2,ENTRY,VERSN,D(1),D(2),
2 TM,X,WHERE
6001 FORMAT(' ',A5,A1,X,I1,X,I1,X,A5,A4,X,A5,
2' ?NICE ERROR: ',I8,' at ',A5)
CLOSE (UNIT=1)
IF ((WHERE.EQ.'CLS 1').OR.(WHERE.EQ.'CLS 2').OR.(WHERE.EQ.
2'CLS 3')) GOTO 2001
GOTO 2000
END
SUBROUTINE EIGHT(BUFFER,ARRAY)
IMPLICIT INTEGER(A-H,O-Z)
DIMENSION BUFFER(128),ARRAY(512)
DO 10 I=1,128
ARRAY(I*4-3)=BUFFER(I)/2**28
ARRAY(I*4-2)=BUFFER(I)/2**20-ARRAY(I*4-3)*2**8
ARRAY(I*4-1)=BUFFER(I)/2**12-ARRAY(I*4-2)*2**8
ARRAY(I*4-1)=ARRAY(I*4-1)-ARRAY(I*4-3)*2**16
ARRAY(I*4)=BUFFER(I)/2**4-ARRAY(I*4-1)*2**8-ARRAY(I*4-2)*2**16
ARRAY(I*4)=ARRAY(I*4)-ARRAY(I*4-3)*2**24
10 CONTINUE
RETURN
END