FTN4,L C SUBROUTINE WAVSA(IUN,IVAR),09580-16318 REV.2001 791023 C **************************************************** C C SOURCE 09580-18318 C RELOCATABLE 09580-16318 C C T. KONDO 12/11/78 REV. A C BOB RICHARDS 02/20/79 REV. B C BOB RICHARDS 05/02/79 C BOB RICHARDS 791023 C C TEST SYSTEM SOURCE SOFTWARE IS THE PROPRIETRY C MATERIAL OF THE HEWLETT-PACKARD COMPANY. C C (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979 C ALL RIGHTS RESERVED. NO PART OF THIS PROGRAM C MAY BE PHOTOCOPIED, REPRODUCED OR TRANSLATED C TO ANOTHER PROGRAM LANGUAGE WITHOUT THE PRIOR C WRITTEN CONSENT OF THE HEWLETT-PACKARD COMPANY. C ********************************************************** C C THIS SUBROUTINE PASSES ASCII STRINGS TO AUTEK 505 C C WAVSA(IUNIT,IVAR) C C WHERE: IUNIT = UNIT NUMBER C C IVAR = ASCII STRING C C C THIS SUBROUTINE, BASIC CALLABLE ONLY, IS USED TO CHECK C THE ASCII STRINGS PASSED TO THE AUTEK 505. IF THE IN- C STRUMENT MUST BE PROGRAMMED IN FORTRAN, PASS THE ASCII C STRING IN A BUFFER WHERE THE FIRST WORD CONTAINS THE NUM- C BER OF WORDS IN THE BUFFER. C C =========================================================== C C BRANCH & MNEMONIC TABLE ENTRIES: C C WAVSA(I,IA), OV=X, ENT=WAVSA, FIL=%WAVSA C C =========================================================== DIMENSION IVAR(40),IBUFR(40),IFCDE(9),ITDIV(26) DIMENSION IVERT(12),IERR(5),IREG(2) EQUIVALENCE (REG,IREG,IA),(IREG(2),IB) DATA IFCDE /2HRA,2HAP,2HBP,2HST,2HSP,2HAM,2HBM,2HDC,2HTG/ DATA ITDIV /2H29,2H59,2H19,2H28,2H58,2H18,2H27,2H57,2H17, S2H26,2H56,2H16,2H25,2H55,2H15,2H24,2H54,2H14,2H53,2H13, S2H22,2H52,2H12,2H21,2H51,2H11/ DATA IVERT /2H20,2H50,2H10,2H21,2H51,2H11,2H22,2H52, S2H12,2H23,2H53,2H13/ DATA IDTN /52/ C C READ BUFFER STORAGE C CALL TIM(IDTN,IUN,1,IBUFR,39,IERFG) IF(IERFG.LT.0)GOTO 9000 NUMS = 8 IF(IBUFR(2).NE.0)NUMS = 9 MAXNM = NUMS * 8 C C NUMBERS OF CHARACTERS C NUMBR = IAND(IVAR(1),377B) IF(NUMBR.GT.MAXNM)GOTO 9100 ICNTR = NUMBR INX = 2 10 CONTINUE IF(ICNTR.EQ.8)GOTO 20 IF(ICNTR.LT.8)GOTO 9100 ICNTR = ICNTR - 8 GO TO 10 C C CHECK FIELD CHARACTERS C 20 IDX = 1 NWDS = NUMBR / 2 DO 30 I=1,9 IF(IVAR(INX).EQ.IFCDE(I))GOTO 40 30 IDX = IDX + 1 GO TO 9100 C 40 INX = INX + 1 GO TO (100,200,200,400,400,600,600,800,900),IDX C C RA FIELD C 100 JNX = INX DO 110 I=1,26 IF(IVAR(JNX).EQ.ITDIV(I))GOTO 120 110 CONTINUE GO TO 9100 C 120 JNX = JNX + 1 ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.LT.30000B.OR.ICHAR.GT.34400B)GOTO 9100 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.LT.60B.OR.ICHAR.GT.71B)GOTO 9100 C JNX = JNX + 1 ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.LT.40400B.OR.ICHAR.GT.52000B)GOTO 9100 IF(ICHAR.GT.41000B.AND.ICHAR.LT.52000B)GOTO 9100 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.LT.60B.OR.ICHAR.GT.67B)GOTO 9100 GO TO 4000 C C A & B PROBES C 200 JNX = INX ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.LT.30000B.OR.ICHAR.GT.34400B)GOTO 9100 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.LT.60B.OR.ICHAR.GT.71B)GOTO 9100 C JNX = JNX + 1 KNX = 1 DO 210 I=1,12 IF(IVAR(JNX).EQ.IVERT(KNX))GOTO 220 210 KNX = KNX + 1 GO TO 9100 C 220 JNX = JNX + 1 ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.EQ.25400B.OR.ICHAR.EQ.26400B)GOTO 230 GO TO 9100 C 230 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.LT.60B.OR.ICHAR.GT.71B)GOTO 9100 GO TO 4000 C C ST & SP FIELDS C 400 JNX = INX ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.LT.30000B.OR.ICHAR.GT.34400B)GOTO 9100 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.LT.60B.OR.ICHAR.GT.71B)GOTO 9100 C JNX = JNX + 1 ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.EQ.22400B.OR.ICHAR.EQ.25400B)GOTO 410 IF(ICHAR.EQ.26400B)GOTO 410 GO TO 9100 C 410 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.LT.101B.OR.ICHAR.GT.102B)GOTO 9100 JNX = JNX + 1 ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.LT.30000B.OR.ICHAR.GT.34400B)GOTO 9100 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.EQ.53B.OR.ICHAR.EQ.55B)GOTO 4000 GO TO 9100 C C AM & BM FIELDS C 600 JNX = INX ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.LT.30000B.OR.ICHAR.GT.34400B)GOTO 9100 KCHAR = IAND(IVAR(JNX),377B) IF(KCHAR.LT.0.OR.KCHAR.GT.71B)GOTO 9100 IF(ICHAR.EQ.60B.AND.KCHAR.EQ.60B)GOTO 9100 C JNX = JNX + 1 ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.EQ.43400B.OR.ICHAR.EQ.50000B)GOTO 610 IF(ICHAR.EQ.51000B)GOTO 610 GO TO 9100 C 610 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.LT.60B.OR.ICHAR.GT.71B)GOTO 9100 JNX = JNX + 1 KCHAR = IAND(IVAR(JNX),177400B) IF(KCHAR.LT.30000B.OR.KCHAR.GT.34400B)GOTO 9100 IF(KCHAR.EQ.30000B.AND.ICHAR.EQ.60B)GOTO 9100 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.EQ.107B.OR.ICHAR.EQ.120B)GOTO 4000 GO TO 9100 C C AUTO DELAY & CALIBRATOR C 800 CONTINUE JNX = INX ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.EQ.40400B.OR.ICHAR.EQ.41000B.OR.ICHAR.EQ.30000B)GOTO 810 GO TO 9100 810 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.EQ.53B.OR.ICHAR.EQ.55B)GOTO 815 GO TO 9100 815 JNX = JNX + 1 ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.LT.30000B.OR.ICHAR.GT.30400B)GOTO 9100 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.NE.60B)GOTO 9100 IF(IVAR(JNX+1).NE.30060B)GOTO 9100 GO TO 4000 C C TRIGGER SOURCE C 900 CONTINUE JNX = INX ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.LT.30000B.OR.ICHAR.GT.34000B)GOTO 9100 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.LT.61B.OR.ICHAR.GT.63B)GOTO 9100 JNX = JNX + 1 ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.EQ.25400B.OR.ICHAR.EQ.26400B)GOTO 910 GO TO 9100 910 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.LT.30000B.OR.ICHAR.GT.34400B)GOTO 9100 JNX = JNX + 1 ICHAR = IAND(IVAR(JNX),177400B) IF(ICHAR.LT.30000B.OR.ICHAR.GT.34400B)GOTO 9100 ICHAR = IAND(IVAR(JNX),377B) IF(ICHAR.NE.53B .OR. ICHAR .NE. 55B) GOTO 9100 C C STORE NEW DATA IN STORAGE BUFFER C 4000 KNX = IDX * 4 + 1 DO 4100 I=1,3 IBUFR(KNX) = IVAR(INX) INX = INX + 1 4100 KNX = KNX + 1 NUMBR = NUMBR - 8 IF(NUMBR.NE.0)GOTO 20 C C OUTPUT NEW PROGRAM C 5000 CONTINUE ISTN = ISN(DUMY) LU1 = LUDV(ISTN,IDTN,IUN) LU0 =IBLU0(LU1) CALL EXEC(100003B,1600B+LU0) GO TO 9200 5100 CALL ABREG(IA,IB) IF(IB.LT.0)GOTO 9300 CALL REIO(100002B,LU1,IVAR(2),NWDS,IDUMY,0) GO TO 9200 5200 CALL ABREG(IA,IB) IF(IB.LT.0)GOTO 9300 CALL TIM(IDTN,IUN,2,IBUFR,39,IERFG) IF(IERFG.LT.0)GOTO 9000 RETURN C C ERROR ROUTINE C 9000 IERR = 10 GO TO 9900 9100 IERR = 1 GO TO 9900 9200 IERR = 9 GO TO 9900 9300 IERR = IAND(IREG,377B) + 11 9900 IERR(2) = 5 IERR(3) = 2HWA IERR(4) = 2HVS IERR(5) = 2HA CALL ERROR(IERR,IERR(2)) RETURN END