FTN,L C************************************************************** C* * C* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * C* RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, * C* REPRODUCED OR TRANSLATED TO ANOTHER PROGRAMMING LANGUAGE * C* WITHOUT THE PRIOR WRITTEN CONSENT OF THE HEWLETT-PACKARD * C* COMPANY. * C* * C************************************************************** C* C* NAME: ZCTRL C* SOURCE: 92070-18318 C* RELOC: PART OF 92070-12013 C* PGMR: KKB C* C C SUBROUTINE ZCTRL(LU,IBUFR) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) INTEGER IBUFR(1) C C RTE-L emulation of the DVA32 passive mode "control" call: C CALL EXEC(1,LU+2200B,IBUFR,1,1,0) C CALL ZGNRL(2,LU,IBUFR,0) RETURN END C C C SUBROUTINE ZSENS(LU,IBUFR,L) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) INTEGER IBUFR(1) C C RTE-L emulation of the DVA32 passive mode "sense" call: C CALL EXEC(1,LU+2200B,IBUFR,L,2,0) C C L is the size of the data part of the user buffer (+words/-bytes), C which starts at IBUFR(17). C If L is negative the data will be returned in unpacked byte format. C The L-series interface card does not do the unpacking, so it is C done by making a call to ZUNPK. C LEN is the actual size of the data transfer, the length passed to C ZGNRL, which will only be L/2 if L is negative, due to C unpacking. C If L is negative, it should be even, since two bytes of buffer C are required for every byte input. C C Calculate the length of the actual data transfer. LEN = L C If L<0 (unpacked mode) the size of the actual data transfer C will only be half the size of the user's buffer. IF (L .LT. 0) LEN = LEN / 2 C Do the I/O. CALL ZGNRL(1,LU,IBUFR,LEN) C Save the A and B registers. CALL ABREG(A,B) C Unpack if L<0 unless the transmission log is zero, in which case C the data buffer should remain unaltered. C The length parameter passed to ZUNPK (positive) is the number of C bytes before unpacking, or the number of words after unpacking. IF (B .NE. 0 .AND. L .LT. 0) CALL ZUNPK(IBUFR(17),-LEN) C Restore the A and B registers from ZGNRL. CALL ABSET(A,B) RETURN END C C C SUBROUTINE ZREAD(LU,IBUFR,L) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) INTEGER IBUFR(1) C C RTE-L emulation of the DVA32 passive mode "read" call: C CALL EXEC(1,LU+2200B,IBUFR,L,3,0) C C CALL ZGNRL(1,LU,IBUFR,L) RETURN END C C C SUBROUTINE ZWRIT(LU,IBUFR,L) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) INTEGER IBUFR(1) C C RTE-L emulation of the DVA32 passive mode "write" call: C CALL EXEC(1,LU+2200B,IBUFR,L,4,0) C CALL ZGNRL(2,LU,IBUFR,L) RETURN END C C C SUBROUTINE ZDSJ(LU,HPIB,KDSJ) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) C C RTE-L emulation of the DVA32 passive mode "get DSJ" call: C CALL EXEC(1,LU+2200B,KDSJ,1,5,HPIB) C INTEGER BUF(5) DATA BUF/537B,477B,476B,0,560B/ C BUF(4) = 500B + HPIB CWD = 170100B + BUSLU(LU) CALL EXEC(1,CWD,KDSJ,-1,BUF,5) CALL ABREG(A,B) KDSJ = KDSJ / 256 IF (IAND(A,1) .NE. 0) B = 0 CALL ABSET(A,B) RETURN END C C C SUBROUTINE ZPPOL(LU,IPOLL) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) C C RTE-L emulation of the DVA32 passive mode "parallel poll" call: C CALL EXEC(1,LU+2200B,IPOLL,1,6,0) C INTEGER XSTAT(5) BLU = BUSLU(LU) CALL EXEC(3,100600B+BLU,0,0,0,0) CALL RMPAR(XSTAT) IPOLL = XSTAT(3) RETURN END C C C SUBROUTINE ZTMAP(LU,IBUFR,L) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) INTEGER IBUFR(1) C C RTE-L emulation of the DVA32 passive mode "get track map" call: C CALL EXEC(1,LU+2200B,IBUFR,L,0,0) C C If L is less than 5, return with no operation. C C If L is 5, return the track map table entry for disc logical unit LU C in the first 5 words of IBUFR. C C If L is greater than 5, return track map table entries for each C disc logical unit on the same select code as LU (including logical C unit LU itself), unless L (the length of IBUFR) is not large enough C to accomodate all the entries. In the latter case return as many C entries as will fit in IBUFR. The first word of IBUFR will contain C minus the number of entries stored in IBUFR. The first entry begins C in the second word, and subsequent entries follow it. The maximum C number of entries for buffer length L is therefore (L-1)/5. C IF (L .LT. 5) RETURN C IF (L .NE. 5) GOTO 199 C L = 5: Return single entry for LU. CALL TMENT(LU,IBUFR) GOTO 299 199 CONTINUE C L > 5: Return entry for each disc on select code. MAXENT = (L - 1) / 5 C Determine select code (SELCOD) of LU. CALL EXEC(13,LU,DVT6,IFT6) SELCOD = IAND(IFT6,77B) C Number of entries so far is zero. COUNT = 0 C First entry will go in IBUFR(2) PTR = 2 C Scan all logical units for discs on same select code as LU. DO 250, LUN=1,63 C Determine select code (SC) and device type (DTYP) of lu LUN. C Set no-abort bit to detect last lu condition. CALL EXEC(100000B+13,LUN,DVT6,IFT6,DP1) C This is the no-abort error return, taken if LUN C exceeds the largest gen'd LU, causing loop to be exited. GOTO 255 210 SC = IAND(IFT6,77B) DTYP = IAND(DVT6,37400B) / 400B C If select code matches and device type is disc (30-32 octal) C then append track map entry to IBUFR. IF (SC.NE.SELCOD .OR. DTYP.LT.30B .OR. DTYP.GT.32B) GOTO 245 C If no room for another entry then exit loop. IF (COUNT .GE. MAXENT) GOTO 255 C Otherwise increment count and store entry in IBUFR. COUNT = COUNT + 1 CALL TMENT(LUN,IBUFR(PTR)) PTR = PTR + 5 245 CONTINUE 250 CONTINUE 255 CONTINUE C Store minus count in first word if IBUFR. IBUFR(1) = -COUNT 299 CONTINUE RETURN END C C C SUBROUTINE TMENT(LU,ENTRY) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) INTEGER ENTRY(5) C C Return track map table entry for LU in first five words of ENTRY. C INTEGER DP(8) C CALL EXEC(13,10000B+LU,P1,P2,DP,8) ENTRY(1) = 2 * DP(7) ENTRY(2) = DP(4) ENTRY(3) = 2000B * DP(8) + 20B * DP(3) + DP(1) ENTRY(4) = DP(6) ENTRY(5) = 2000B * DP(2) + DP(5) RETURN END C C C SUBROUTINE ZGNRL(CODE,LU,IBUFR,L) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) INTEGER IBUFR(1) C C ZGNRL does most of the real work for ZCTRL, ZSENS, ZREAD, and ZWRIT, C i.e., emulates the DVA32 passive mode "control", "sense", "read", and C "write" calls: C CALL EXEC(1,LU+2200B,IBUFR,L,IFC,0) for IFC = 1, 2, 3, and 4. C C In fact, ZGNRL does all of the work for ZCTRL, ZREAD, and ZWRIT. C ZSENS must take care of byte unpacking logic in addition to calling C ZGNRL. C C On the L the I/O architecture is simpler than on M/E/F (e.g. all C I/O is done using DMA). The result is that the "sense" and "read" C functions are identical (except for the byte unpacking which is done C by ZSENS) and can both be emulated by ZGNRL calls with CODE = 1 (read). C Also the "control" function is the same as a "write" function with no C data buffer, so that both can be emulated by ZGNRL calls with CODE = 2 C (write). C C Outputting the header part of IBUFR (words 1 thru 16) is more complex C on the L because the HP-IB interface card is set to talk or listen C by the command stream output to it rather than by special control C functions as on the M/E/F interface card. The controller is set to C talk or listen by a talk or listen primary command specifying address C 36 octal--the address of the HP-IB controller on the CPU side of the bus. C These commands must be output to the bus along with all the other C commands. But since the external definition of the buffer header C IBUFR(1) through IBUFR(16) does not include these special address 36 C commands, the L emulation must insert the appropriate special commands C in the data stream included in the buffer header. C The L emulation must also include various untalk/unlisten commands C which the user does not have to supply in his buffer, but which C DVA32 generates implicitly. C INTEGER SETUP1(3),SETUP2(2),FINISH(2) LOGICAL MTA,LBO DATA SETUP1/537B,477B,536B/,SETUP2/537B,476B/,FINISH/537B,477B/ C C Create control word for I/O to bus lu with the "bypass logical driver", C "unbuffered", "user-error", and "Z" (double-buffer) bits set, and C with the "fixed-length binary record" subfunction (01) selected. C CWD = 170100B + BUSLU(LU) C C Output initial command sequence: UNT, UNL, MTA controller. C CALL EXEC(2,CWD,0,0,SETUP1,3) CALL ABREG(A,B) IF (IAND(A,1) .NE. 0) GOTO 9999 C C Work on the buffer header. C C Set reference marker at word 1 I0 = 1 C Loop for each word in header. DO 100, I=1,16 C Get the Ith word from the header. WORD = IBUFR(I) C Mask off the LBO, EOI, and parity bits. TEMP = IAND(WORD,577B) C Determine whether this word is a (peripheral) talk command. MTA = (TEMP .GE. 500B .AND. TEMP .LE. 535B) C Is the LBO (last byte out) bit set (sign bit) ? LBO = (WORD .LT. 0) IF (.NOT. MTA) GOTO 10 C The current word is a talk command. C Output the header from the reference marker up to (but not C including) the current word. CALL EXEC(2,CWD,0,0,IBUFR(I0),I-I0) CALL ABREG(A,B) IF (IAND(A,1) .NE. 0) GOTO 9999 C Set the reference marker to the current word. I0 = I C Output the command sequence which is to be inserted before C talk commands: UNT, MLA controller. CALL EXEC(2,CWD,0,0,SETUP2,2) CALL ABREG(A,B) IF (IAND(A,1) .NE. 0) GOTO 9999 GOTO 20 10 CONTINUE IF (.NOT. LBO) GOTO 20 C The current word has the LBO (last byte out) bit set. C Clear the LBO bit in the buffer for output. IBUFR(I) = IAND(WORD,77777B) C Output the header from the refence marker through the C current word (the LBO word) using the Z-buffer, and C input or output (depending on CODE) the data buffer C which starts at IBUFR(17) and is L words long. CALL EXEC(CODE,CWD,IBUFR(17),L,IBUFR(I0),I-I0+1) CALL ABREG(A,B) C Restore the LBO bit in the user's buffer. IBUFR(I) = WORD IF (IAND(A,1) .NE. 0) GOTO 9999 C Since the current word was the LBO word, exit the loop. GOTO 1000 20 CONTINUE 100 CONTINUE C C Output final command sequence: UNT, UNL. C Then set the A and B registers accordng to the data buffer transfer, C and return. C 1000 CONTINUE CALL EXEC(2,CWD,0,0,FINISH,2) CALL ABSET(A,B) RETURN C C Error return. Set the A register as it was after the request that C failed. Set the B register to 0, indicating no bytes transferred. C 9999 CONTINUE CALL ABSET(A,0) RETURN END C C C SUBROUTINE ZUNPK(BUF,LEN) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) INTEGER BUF(1) C C Unpack the data bytes in BUF one byte per word, right-justified and C zero-filled. C LEN is the number of bytes before unpacking, which is the same as C the number of words after unpacking. C C Start unpacking from the end of the buffer. C I is the index of the next source word. C J is the index of the next destination word. C C Initialize I as the source word index of the last full word C (the last word with two bytes to be unpacked). I = LEN / 2 C Initialize J as the destination word index for the second byte C in the last full word to be unpacked. (Example: the second byte C in word #4 is the 8th byte and will therefore be moved to word #8.) J = I * 2 C If there is a left-over byte at the end, move it first. IF (J .NE. LEN) BUF(J+1) = BUF(I+1)/256 C C Loop to unpack all the full words. 100 CONTINUE C Move the right byte of the current source word to the current C destination word. BUF(J) = IAND(BUF(I),377B) C Decrement the current destination word pointer. J = J - 1 C Move the left byte of the current source word to the current C destination word. BUF(J) = BUF(I) / 256 C Decrement the current destination word pointer. J = J - 1 C Decrement the current source word pointer. I = I - 1 C If there are more words to be unpacked the continue looping. IF (I .GT. 0) GOTO 100 C RETURN END C C C INTEGER FUNCTION BUSLU(LU) +,92070-1X318 REV.2040 800723 IMPLICIT INTEGER(A-Z) C C Return the logical unit of the bus lu (HP-IB) corresponding C to logical unit LU. If there is no such bus lu, then 0 is returned. C INTEGER BLU(63) C The BLU array is used to save bus lu information from call to call C so that the slow process of determining the bus lu only needs C to be done once each time the program is run (or once per boot C if the program is memory-resident). C BLU(I) is the bus lu corresponding to logical unit I. C The array is initialized to all -1's at load-time. C A -1 value indicates that the bus lu for a particular lu C has not yet been determined. DATA BLU/63*-1/ C C If bus lu for this LU has already been determined (there is a C non-negative entry in the BLU table) then skip the indented code C (which determines the bus lu and makes an entry in the table). IF (BLU(LU) .GE. 0) GOTO 1000 C Find the first logical unit (BL) which has same select code C (SELCOD) as logical unit LU and whose first driver parameter C is 36B, indicating HP-IB controller logical unit. CALL EXEC(13,LU,DVT6,IFT6) SELCOD = IAND(IFT6,77B) BL = 0 C 10 CONTINUE BL = BL + 1 CALL EXEC(100000B+13,BL,DVT6,IFT6,DP1) C This is the no-abort error return, taken if BL C exceeds the largest gen'd LU, causing loop to be exited. GOTO 99 C If this is the bus lu, then exit loop and make entry in table. 90 IF (DP1.EQ.36B .AND. IAND(IFT6,77B).EQ.SELCOD) GOTO 100 GOTO 10 C 99 CONTINUE C Bus lu was not found. Make zero entry in BLU table. BL = 0 100 CONTINUE C Make entry in BLU table. BLU(LU) = BL 1000 CONTINUE C Return value from BLU table. BUSLU=BLU(LU) RETURN END C C C REAL FUNCTION ABSET(A,B) +,92070-1X318 REV.2040 800723 C C Set the A and B registers to the specified values. C This routine should be called as a subroutine, not a function. C It is declared to be a function here to provide a way to set the C A and B registers. C IMPLICIT INTEGER(A-Z) REAL REGS INTEGER REG(2),AREG,BREG EQUIVALENCE (REGS,REG(1),AREG),(REG(2),BREG) AREG = A BREG = B ABSET = REGS RETURN END