FTN4 LOGICAL FUNCTION TSRD(MEDIA,INDIC,ISTAT,NFORM,KBIN,KSCE,IBUF,IHD), . 92903-16312 REV.1913 790112 1705 C C SOURCE 92903-18312 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C C PROGRAMMER *JCM* HPG C********************************************************************* C* * C* THIS LOGICAL FUNCTION READS A TRANSACTION SPECIFICA- * C* TION STORED ON A GIVEN MEDIA AND TRANSFER ITS CONTENTS IN A BU- * C* FFER SPECIFIED BY THE USER . * C* * C* A TRUE VALUE IS RETURNED IF THE READ OPERATION FAILS * C* A FALSE VALUE IS RETURNED IF THE READ SUCCEEDS * C* * C* DEFINITION OF PARAMETERS : * C* * C* MEDIA(4) : IS A 4 WORDS LONG BUFFER DEFINES THE MEDIA WHERE * C* THE TRANS. SPECS. ARE STORED : * C* -IF A DISC FILE THE FIRST 3 WORDS ARE FILE NAME * C* AND THE FOURTH CR# (0 IF NOT GIVEN) * C* IF MEDIA(1) IS > 0 AN OPEN/REWIND OF THE MEDIA * C* IS PERFORMED * C* IF MEDIA(1) IS < 0 NO OPEN/NO REWIND * C* * C* INDIC : IS A 1 WORD LONG VARIABLE TO SPECIFY WHAT OPERATION * C* IS TO BE PERFORMED : * C* INDIC=0 : READ ONLY HEADER OF LIBRARY * C* =1 : DO NOT READ SPECS ONLY FIND THEM FIRST * C* INREC1 WORDS OF BINARY SPECS ARE STORED IN * C* KBIN * C* =2 : READ BINARY + SOURCE SPECS * C* =3 : CLOSE MEDIA * C* >3 : READ BINARY SPECS + FIRST 10 WORDS OF * C* SOURCE SPECS IF THE SPECS LENGTH ARE * C* LESS THAN INDIC * C* * C* ISTAT : IS A 1 WORD LONG VARIABLE TO RETURN THE STATUS OF * C* THE PERFORMED OPERATION : * C* ISTAT=0 : NO ERROR * C* =1 : GARBAGE TAPE * C* =2 : SPECS NOT FOUND * C* =3 : OVERFLOW (INDIC>3 ONLY) * C* =4 : ILLEGAL PARAMETER * C* =5 : ERROR IN LOCKING TYPE 0 LU * C* =6 : ERROR IN UNLOCKING TYPE 0 LU * C* =7 : SPECS SECURITY CODE DOESN'T MATCH * C* =8 : 1ST RECORD INCORRECT LENGTH(BAD REV CODE) C* <0 : FMGR ERROR * C* * C* NFORM : IS A 5 WORD LONG BUFFER TO DEFINE THE SPEC TO READ * C* THE FIRST 3 WORDS CONTAINS THE SPECS NAME IF NO NAME* C* NFORM(1)=100000B * C* NFORM(4)=SPECS # (IF=100000B NO SPEC # SPECIFIED) * C* NFORM(5)=SPECS SECURITY (IF=100000B NO SC SPECIFIED)* C* THE SPEC FIND MUST HAVE THE SAME NAME OR # AS * C* SPECIFIED. * C* IF BOTH NFORM(1) AND NFORM(4) ARE = 100000B THE 1ST * C* SPECS FOUND WILL BE READ. * C* * C* KBIN : ADDRESS OF STORAGE BUFFER FOR BINARY SPECS * C* IF INDIC=1 KBIN(11) MUST BE DECLARED * C* * C* KSCE : ADDRESS OF STORAGE BUFFER FOR SOURCE SPECS * C* IF INDIC>3 OR INDIC=1 KSCE(11) MUST BE DECLARED * C* * C* IBUF : 144 WORDS LONG BUFFER (IDCB BUFFER) * C* * C* IHD : 15 WORDS LONG BUFFER FOR LIBRARY HEADER * C* THE LIBRARY HEADER IS TRANSMITED ONLY IF INDIC=1 * C* OR 2. * C* * C********************************************************************* C* C* C* INTEGER OPEN,BIT15 LOGICAL IRW,IST,CMPW,READF,RWNDF DIMENSION MEDIA(1),NFORM(1),KBIN(1),KSCE(1),IBUF(1),IREG(2) DIMENSION IHD(1) C EQUIVALENCE (REG,IREG) DATA BIT15/100000B/ C-----"INREC1" IS THE LENGTH OF THE 1ST RECORD. AS A NEW VERSION OF TGP IS C RELEASED, THE VALUE OF "INREC1" SHOULD BE INCREMENTED BY 1 SO THAT C OLDER TRANSACTIONS CAN NO LONGER BE READ BY THE NEW VERSION & NO MIX C UP CAN OCCUR. THE SAME VARIABLE (INREC1) SHOULD BE SIMILARLY CHANGED C IN "TSWR". DATA INREC1/11/ C C INITIALISE LOGICAL FLAGS C C IRW : IF TRUE MUST REWIND C IST : IF FALSE MUST STORE C TSRD=.FALSE. IRW=.FALSE. IST=.TRUE. C C CHECK CALLING PARAMETERS C IF((MEDIA.NE.0).AND.(INDIC.GE.0)) GO TO 100 ISTAT=4 GO TO 900 C C IF SPEC NAME AND # ARE NOT SPECIFIED STORE FIRST SPEC FOUND C 100 IF((NFORM.EQ.BIT15).AND.(NFORM(4).EQ.BIT15)) IST=.FALSE. C C REWIND AND OPEN ? C IF(MEDIA.GT.0) IRW=.TRUE. ISAV=MEDIA IF(MEDIA.LT.0) MEDIA=-MEDIA C GO TO 500 C C C NORMAL RETURN C 270 ISTAT=0 MEDIA=ISAV RETURN C C C ERROR RETURN C 900 TSRD=.TRUE. MEDIA=ISAV RETURN C C C IF INDIC=3 CLOSE FILE C 500 IF(INDIC.NE.3) GO TO 510 JLU=0 IF(IBUF(3).EQ.0) JLU=IAND(77B,IBUF(4)) CALL CLOSE(IBUF) IF(JLU.EQ.0) GO TO 270 C-----REWIND CALL EXEC(3,400B+JLU) IF(LURQ(0,JLU,1).EQ.0) GO TO 270 C-----ERROR, UNABLE TO UNLOCK ANYTHING. ISTAT=6 GO TO 900 C C REWIND /OPEN FILE ? C 510 IF(.NOT.(IRW)) GO TO 525 IF(OPEN(IBUF,ISTAT,MEDIA,0,0,MEDIA(4)).LT.0) GO TO 900 C C IF FILE OPENED CHECK FILE TYPE (0 OR 35) C IF(ISTAT.EQ.35) GO TO 523 IF(ISTAT.EQ.0) GO TO 512 C C-----GO TO ERROR RETURN. C ISTAT=1 GO TO 900 C C-----TYPE 0 FILE. C C-----GET LU NO. C 512 JLU=IAND(377B,IBUF(4)) C C-----LOCK IT W/O WAIT. C IF(LURQ(100001B,JLU,1).EQ.0) GO TO 523 C C-----ERROR, UNABLE TO LOCK IT, CLOSE IT, THEN EXIT. CALL CLOSE(IBUF) C ISTAT=5 GO TO 900 C C REWIND C 523 IF(RWNDF(IBUF,ISTAT)) GO TO 900 C C READ LIBRARY HEADER C IF(READF(IBUF,ISTAT,KBIN,16,LEN)) GO TO 900 IF(LEN.NE.-1) GO TO 524 ISTAT=2 GO TO 900 524 IF(LEN.EQ.15) GO TO 527 ISTAT=1 GO TO 900 527 IF(INDIC.GT.2) GO TO 525 CALL MOVEW(KBIN,IHD,15) IF(INDIC.EQ.0) GO TO 270 C C C READ FIRST RECORD C 525 IF(READF(IBUF,ISTAT,KBIN,INREC1+1,LEN)) GO TO 900 C C END OF FILE ? C 530 IF(LEN.NE.-1) GO TO 540 ISTAT=2 GO TO 900 C 540 IF(LEN.EQ.INREC1) GO TO 550 ISTAT=8 GO TO 900 C C IF INDIC > 3 CHECK IF SUFFICIENT SPACE C 550 IF(INDIC.LT.4) GO TO 560 IF(KBIN.LE.INDIC) GO TO 560 ISTAT=3 GO TO 900 C C CHECK IF NAME AND # MATCHES C 560 IF(CMPW(KBIN(2),NFORM,3)) IST=.FALSE. IF(KBIN(5).EQ.NFORM(4)) IST=.FALSE. IF(IST) GO TO 562 IF(NFORM(5).EQ.BIT15) GO TO 562 IF(KBIN(6).EQ.NFORM(5)) GO TO 562 ISTAT=7 GO TO 900 C 562 K=(KBIN-INREC1)/127 IR=(KBIN-INREC1)-K*127 C C READ BINARY SPECS C L=128 IF(INDIC.EQ.1) L=1 DO 600 I=1,K+1 IF((I.EQ.K+1).AND.(IR.EQ.0)) GO TO 610 IOF=INREC1+1+(I-1)*127 IF(INDIC.EQ.1) IOF=INREC1+1 IF(READF(IBUF,ISTAT,KBIN(IOF),L,LEN)) GO TO 900 580 IF(L.EQ.1) GO TO 600 ILX=127 IF(I.EQ.K+1) ILX=IR IF(LEN.EQ.ILX) GO TO 600 ISTAT=1 GO TO 900 600 CONTINUE C C READ SOURCE SPECS C 610 L=128 IF((INDIC.EQ.1).OR.(INDIC.GT.3)) L=10 DO 700 I=1,21 IF((I.GT.1).AND.(L.EQ.10)) L=1 IOF=1+(I-1)*127 IF(L.EQ.1) IOF=11 IF((INDIC.EQ.2).AND.(I.EQ.1)) IOF=128 IF(READF(IBUF,ISTAT,KSCE(IOF),L,LEN)) GO TO 900 620 IF(L.NE.128) GO TO 622 ILX=127 IF(I.EQ.21) ILX=7 IF(LEN.EQ.ILX) GO TO 622 ISTAT=1 GO TO 900 622 IF((INDIC.NE.2).OR.(I.NE.1)) GO TO 700 CALL MOVEW(KSCE(128),KSCE,6) CALL MOVEW(KSCE(148),KSCE(21),107) 700 CONTINUE C C SPECS FOUND ? C IF(IST) GO TO 525 C GO TO 270 C C C END END$