FTN4,L
      SUBROUTINE SFMWC(IUNIT,IFUN,ICWFM,MODE,IRES,IRATE), 
     +09580-16449 REV.2001 791023 
C 
C-------------------------------------
C 
C  HP 5342A MICROWAVE FREQUENCY COUNTER 
C 
C  RELOCATABLE 09580-16449
C  SOURCE      09580-18449
C 
C  T. KONDO   790727
C  BOB RICHARDS  791023 
C 
C------------------------------------ 
C 
C  !=================================================!
C  !                                                 !
C  ! (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979      !
C  !                ALL RIGHTS RESERVED              !
C  !                                                 !
C  ! NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,     !
C  ! REPRODUCED OR TRANSLATED INTO ANOTHER PROGRAM   !
C  ! LANGUAGE WITHOUT THE PRIOR WRITTEN CONSENT OF   !
C  ! THE HEWLETT-PACKARD COMPANY.                    !
C  !                                                 !
C  !-------------------------------------------------!
C  !                                                 !
C  ! TEST SYSTEM SOURCE SOFTWARE IS THE PROPRIETARY  !
C  ! MATERIAL OF THE HEWLETT-PACKARD COMPANY.        !
C  !                                                 !
C  ! THIS SOURCE DATA SHALL BE USED SOLELY IN        !
C  ! CONJUNCTION WITH ELECTRONIC COMPUTER SYSTEMS    !
C  ! SUPPLIED TO THE USER BY HEWLETT-PACKARD.        !
C  !                                                 !
C  ! THIS PROPRIETARY DATA SHALL NOT BE COPIED OR    !
C  ! OTHERWISE REPRODUCED WITHOUT THE PRIOR WRITTEN  !
C  ! CONSENT OF HEWLETT-PACKARD, EXCEPT THAT ONE     !
C  ! COPY MAY BE MADE AND RETAINED BY THE USER FOR   !
C  ! ARCHIVE PURPOSES.                               !
C  !                                                 !
C  ! THE USER SHALL NOT DISCLOSE THIS DATA TO ANY    !
C  ! THIRD PARTIES WITHOUT THE PRIOR WRITTEN CONSENT !
C  ! OF HEWLETT-PACKARD. IN ADDITION, THE USER SHALL !
C  ! USE AT LEAST THE SAME CARE AND SAFEGUARDS TO    !
C  ! PROTECT THIS DATA FROM UNAUTHORIZED USE OR      !
C  ! DISCLOSURE AS THE USER USES TO PROTECT ITS OWN  !
C  ! PROPRIETARY DATA.                               !
C  !                                                 !
C  !=================================================!
C 
C  GENERAL: 
C  -------- 
C 
C    THE FOLLOWING DEVICES ARE USED 
C    TO PROGRAM THE HP 5342A MICROWAVE FREQUENCY COUNTER
C 
C  HARDWARE REQUIRED: 
C  ------------------ 
C    A. HP 5342A
C    B. HP59310  BUS INTERFACE KIT. 
C 
C         JUMPER POSITION:
C          SW1-1 - 1
C          SW1-2 TO SW1-8 - 0 
C          SW2-1 - 0
C          SW2-2 - 0
C          SW2-3 - 0
C          SW2-4 - 0
C          SW2-5 - 1
C          SW2-6 - REN
C          SW2-7 - ICF
C          SW2-8 - CNX
C 
C    C. HP 21XX SERIES COMPUTER 
C 
C  BRANCH AND MNEMONIC TABLE ENTRIES: 
C  ---------------------------------- 
C 
C    SFMWC(I,I,I,I,I,I),      OV=XX,   ENT=SFMWC,   FIL=%SFMWC
C    OSMWC(I,I,I,R,R),        OV=XX,   ENT=OSMWC,   FIL=%SFMWC
C    RDMWC(I,RV,RV),          OV=XX,   ENT=RDMWC,   FIL=%SFMWC
C 
C  FOR OPTION 002:
C    RDMWC(I,RV,RV,RV),       OV=XX,   ENT=RDMWC,   FIL=%SFMWC
C 
C 
C 
C 
C------------------------------------ 
C 
C     SUBROUTINE SFMWC(IUNIT,IFUN,ICWFM,MODE,IRES,IRATE)
C 
C      IUNIT = UNIT NUMBER
C      IFUNC = FUNCTION SELECT
C              1 = 10HZ - 500MHZ
C              2 = 500MHZ - 18GHZ 
C              3 = AMPLITUDE - OFF (OPT 002)
C              4 = AMPLITUDE - ON  (OPT 002)
C              5 = CHECK MODE (75MHZ) 
C              6 = RESET COUNTER
C 
C      ICWFM = CW/FM MODE 
C              1 = CW 
C              2 = FM 
C 
C      MODE = AUTO/MANUAL 
C              1 = AUTO 
C              2 = MANUAL (1 MHZ - 17999 MHZ) 
C 
C      IRES  = RESOLUTION 
C              0 = 1 HZ 
C              1 = 10 HZ
C              2 = 100 HZ 
C              3 = 1 KHZ
C              4 = 10 KHZ 
C              5 = 100 KHZ
C              6 = 1 MHZ
C 
C      IRATE = SAMPLE RATE
C              1 = FRONT PANEL SAMPLE RATE
C              2 = HOLD 
C              3 = FAST SAMPLE (NO DELAY) 
C              4 = SAMPLE THEN HOLD 
C 
C      NOTE:  THE HPIB BASIC CALL "TRIGR(I)" MUST BE USED 
C             WHEN EVER IRATE = 2.  FOR EXAMPLE:
C 
C             10 CALL SFMWC(1,2,1,1,3,2)
C             20 WAIT (1000)
C             30 LET I = ISN(0) 
C             40 LET L = LUDV(I,68,1) 
C             50 CALL TRIGR(L)
C             60 CALL RDMWC(1,D1,D2)
C             70 PRINT D1,D2
C             80 END
C 
C-------------------------------------------------------
C 
C 
C     SUBROUTINE OSMWC(IUNIT,IFUNC,IOFON,OFFS1,OFFS2) 
C 
C      IUNIT = UNIT NUMBER
C      IFUNC = FUNCTION 
C              1 = FREQUENCY
C              2 = AMPLITUDE
C 
C      IOFON = OFFSET ON/OFF
C              0 = OFF
C              1 = ON 
C              2 = AUTOMATIC OFFSET 
C              3 = RESET
C 
C      OFFS1 = OFFSET VALUE 
C               +- MHZ OR +- DB 
C      OFFS2 = OFFSET VALUE 
C               +- HZ 
C 
C 
C     SUBROUTINE RDMWC(IUNIT,DAT1,DAT2,DAT3)
C 
C      IUNIT = UNIT NUMBER
C      DAT1  = MEASURED FREQUENCY (XXXXX.E+6 HZ)
C      DAT2  = MEASURED FREQUENCY (HZ)
C      DAT3  = AMPLITUDE
C 
C 
C ----------------------------------- 
      DIMENSION IERMS(5)
      DATA IDTN / 68 /
      DATA IERMS / 10,5,2HSF,2HMW,2HC  /
C 
      IERMS=10
C 
C  FIND STATION AND LU #'S
C   ISTN = STATION #
C   LU1 = HP 5342A LU 
C   LUIB = HPIB LU
C 
      ISTN=ISN(DUMMY) 
      LU1=LUDV(ISTN,IDTN,IUNIT) 
      LUIB=IBLU0(LU1) 
      IF(LU1 .LE. 0 .OR. LUIB .LE. 0)GOTO 800 
C 
C  CALL X SUB 
C 
      CALL XFMWC(LU1,LUIB,IERMS,IUNIT,IFUN,ICWFM,MODE,IRES,IRATE) 
      IF(IERMS)800,20,800 
C 
C  EXIT 
C 
20    RETURN
C 
C  ERROR EXIT 
C 
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
C 
C---------------------------------------------
C 
      SUBROUTINE OSMWC(IUNIT,IFUN,IOFON,OFF1,OFF2), 
     +09580-16449 REV.2001 791023 
      DIMENSION IERMS(5)
      DATA IDTN / 68 /
      DATA IERMS / 10,5,2HOS,2HMW,2HC  /
C 
      IERMS=10
C 
C  FIND STATION AND LU #'S
C   ISTN = STATION #
C   LU1 = HP 5342A LU 
C   LUIB = HPIB LU
C 
      ISTN=ISN(DUMMY) 
      LU1=LUDV(ISTN,IDTN,IUNIT) 
      LUIB=IBLU0(LU1) 
      IF(LU1 .LE. 0 .OR. LUIB .LE. 0)GOTO 800 
C 
C  CALL X SUB 
C 
      CALL XSMWC(LU1,LUIB,IERMS,IUNIT,IFUN,IOFON,OFF1,OFF2) 
      IF(IERMS)800,20,800 
C 
C  EXIT 
C 
20    RETURN
C 
C  ERROR EXIT 
C 
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
C 
C---------------------------------------------
C 
      SUBROUTINE RDMWC(IUNIT,DAT1,DAT2,DAT3), 
     +9580-16449 REV.2001 791023  
      DIMENSION IERMS(5)
      DATA IDTN / 68 /
      DATA IERMS / 10,5,2HRD,2HMW,2HC  /
C 
      IERMS=10
C 
C  FIND STATION AND LU #'S
C   ISTN = STATION #
C   LU1 = HP 5342A LU 
C   LUIB = HPIB LU
C 
      ISTN=ISN(DUMMY) 
      LU1=LUDV(ISTN,IDTN,IUNIT) 
      LUIB=IBLU0(LU1) 
      IF(LU1 .LE. 0 .OR. LUIB .LE. 0)GOTO 800 
C 
C  CALL X SUB 
C 
      CALL XDMWC(LU1,LUIB,IERMS,DAT1,DAT2)
      IF(IERMS)800,20,800 
C 
C  EXIT 
C 
20    RETURN
C 
C  ERROR EXIT 
C 
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
C 
C---------------------------------------------
C 
      SUBROUTINE XFMWC(LU1,LUIB,IERMS,IUNIT,IFUNC,ICWFM,MODE,IRES,
     +IRATE),09580-16449 REV.2001 791023
      DIMENSION IERMS(5)
      DIMENSION IREG(2),IOBUF(10),NMBR(5) 
      EQUIVALENCE (REG,IREG,IA),(IREG(2),IB)
C 
C---------------------------------------------
C 
C 
C  THE PARAMETERS IN THE CALLING SEGUENCE HAVE THE FOLLOWING
C  MEANINGS.
C 
C     LUIB = LU # OF HPIB.
C     LU1  = LU # OF HP5342A
C 
C    IERMS IS A FIVE WORD ARRAY WITH IERR(1) CONTAINING 
C      THE ERROR CODE.
C 
C        0 = NO ERROR 
C        1 = PARAMETER ERROR
C 
C    ERROR MESSAGES THAT PERTAIN TO THE HPIB. 
C 
C        9 = I/O CALL REJECTED
C       10 = LUIB OR LU1 = 0
C       12 = I/O DEVICE TIME OUT
C       13 = IFC DETECTED DURING I/O REQUEST
C       14 = SRQ ABORTED
C       15 = NON-EXISTENT ALARM PROGRAM 
C       16 = ILLEGAL CONTROL REQUEST
C       17 = EQT EXTENSION AREA FULL
C 
C    IERMS(2) = ERROR MNEMONIC CHARACTER COUNT
C    IERMS(3) TO IERMS(5) = ERROR MNEMONIC
C 
C 
C 
C  CHECK PARAMETERS 
C 
      IF(IFUNC.LT.1.OR.IFUNC.GT.6)GOTO 9900 
      IF(ICWFM.LT.1.OR.ICWFM.GT.2)GOTO 9900 
      IF(MODE.LT.0.OR.MODE.GT.17999)GOTO 9900 
      IF(IRES.LT.0.OR.IRES.GT.6)GOTO 9900 
      IF(IRATE.LT.1.OR.IRATE.GT.4)GOTO 9900 
C 
      IF(IFUNC.NE.6)GOTO 110
      IOBUF = 2HRE
      NCHAR = 1 
      GOTO 2000 
C 
 110  IOBUF = 2HAM
      IF(IFUNC.EQ.3.OR.IFUNC.EQ.4)GO TO 130 
      IF(IFUNC.EQ.5)IOBUF = 2HSR
      IF(IFUNC.EQ.1.AND.ICWFM.EQ.1)IOBUF = 2HLC 
      IF(IFUNC.EQ.2.AND.ICWFM.EQ.1)IOBUF = 2HHC 
      IF(IFUNC.EQ.1.AND.ICWFM.EQ.2)IOBUF = 2HLF 
      IF(IFUNC.EQ.2.AND.ICWFM.EQ.2)IOBUF = 2HHF 
C 
      IF(IFUNC.EQ.1.OR.IFUNC.EQ.5)GOTO 120
      IOBUF(2) = 2HAU 
      IF(MODE.NE.0)GOTO 150 
C 
      IOBUF(3) = 2HSR 
      IOBUF(4) = IOR((IRES+63B)*256,124B) 
      IOBUF(5) = ((IRATE-1)+60B)*256
      NCHAR = -9
      GOTO 2000 
C 
C  CHECK MODE 
C 
 120  IOBUF(2) = 30400B 
      NCHAR = -3
      GOTO 2000 
C 
C  AMPLITUDE (OPT 002) OFF/ON 
C 
 130  IOBUF(2) = (60B - (IFUNC-3)) * 256
      NCHAR = -3
      GOTO 2000 
C 
C  MANUAL CENTER FREQUENCY
C 
 150  IOBUF(2) = 2HSM 
      IF(IFUNC.EQ.1)GOTO 9900 
C 
      IFREQ = MODE
C 
C  CONVERT TO ASCII 
C 
      CALL CNUMD(IFREQ,NMBR)
C 
C  FIND NUMBER OF DIGITS
C 
      NXM = 6 
      DO 170  I = 1 , 3 
      IDU = IAND(NMBR(I),177400B) 
      IDL = IAND(NMBR(I),377B)
      IF(IDU.EQ.20000B)NXM = NXM - 1
      IF(IDL.EQ.40B)NXM = NXM - 1 
 170  CONTINUE
C 
      IF(NXM.GT.4)GOTO 200
      IF(NXM.LT.3)NMBR = NMBR(3)
      IF(NXM.LT.3)NMBR(2) = 0 
      IF(NXM.LT.3)GOTO 200
      NMBR = NMBR(2)
      NMBR(2) = NMBR(3) 
      NMBR(3) = 0 
C 
 200  IFLG = 1
      NMBR(4) = 0 
      IF(NXM.EQ.2.OR.NXM.EQ.4)IFLG = 0
C 
      INX = 3 
      IDX = 1 
      IF(IFLG.NE.0)IOBUF(INX) = IAND(NMBR,377B) * 256 
      IF(IFLG.EQ.0)IOBUF(INX) = NMBR
 210  CONTINUE
      IF(NMBR(IDX+1).EQ.0)GOTO 250
      IDX = IDX + 1 
      IF(IDX.GT.3)GOTO 250
      IF(IFLG.NE.0)NMBR = IAND(NMBR(IDX),177400B) / 256 
      IF(IFLG.NE.0)IOBUF(INX) = IOR(IOBUF(INX),NMBR)
      INX = INX + 1 
      IF(IFLG.NE.0)IOBUF(INX) = IAND(NMBR(IDX),377B) * 256
      IF(IFLG.EQ.0)IOBUF(INX) = NMBR(IDX) 
      GOTO 210
C 
 250  CONTINUE
      IF(IFLG.NE.0)IOBUF(INX) = IOR(IOBUF(INX),105B)
      INX = INX + 1 
      IF(IFLG.EQ.0)IOBUF(INX) = 2HES
      IF(IFLG.NE.0)IOBUF(INX) = 2HSR
      INX = INX + 1 
C 
C  RESOLUTION 
C 
      IF(IFLG.EQ.0)IOBUF(INX) = IOR(51000B,63B+IRES)
      IF(IFLG.NE.0)IOBUF(INX) = IOR((63B+IRES)*256,124B)
      INX = INX + 1 
C 
C  SAMPLE RATE
C 
      IF(IFLG.EQ.0)IOBUF(INX) = IOR(52000B,IRATE+57B) 
      IF(IFLG.NE.0)IOBUF(INX) = (IRATE + 57B) * 256 
      NCHAR = INX 
      IF(IFLG.EQ.0)GOTO 2000
C 
      NCHAR = 2*(INX-1) + 1 
      NCHAR = -NCHAR
C 
C 
C 
C  REMOTE ENABLE
C 
2000  CALL EXEC(100003B,1600B+LUIB) 
      GOTO 9000 
70    CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
C 
C  SEND OUTPUT BUFFER 
C 
      CALL REIO(100002B,LU1,IOBUF(1),NCHAR,IDUMY,0) 
      GOTO 9000 
71    CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
C 
C 
C  RETURN 
C 
      IERMS=0 
      RETURN
C 
C  ERROR EXIT 
C 
8500  IERMS=IAND(IA,377B)+11
      GOTO 8000 
9000  IERMS=9 
      GOTO 8000 
9900  IERMS = 1 
8000  IERMS(2)=5
      IERMS(3)=2HSF 
      IERMS(4)=2HMW 
      IERMS(5)=2HC
      RETURN
      END 
C 
C 
      SUBROUTINE XSMWC(LU1,LUIB,IERMS,IUNIT,IFUNC,IOFON,OFFS1,OFFS2), 
     + 9580-16449 REV.2001 791023 
C 
C      IUNIT = UNIT NUMBER
C      IFUNC = FUNCTION 
C              1 = FREQUENCY
C              2 = AMPLITUDE
C 
C      IOFON = OFFSET ON/OFF
C              0 = OFF
C              1 = ON 
C              2 = AUTOMATIC OFFSET 
C              3 = RESET
C 
C      OFFS1 = OFFSET VALUE 
C               +- MHZ OR +- DB 
C      OFFS2 = OFFSET VALUE 
C               +- HZ 
C 
      DIMENSION IERMS(5)
      DIMENSION IREG(2),IBUFR(20),NMBR(6),IAR(6)
      EQUIVALENCE (REG,IREG,IA),(IREG(2),IB)
C 
C  CHECK PARAMETERS 
C 
      IF(IFUNC.LT.1.OR.IFUNC.GT.2)GOTO 9900 
      IF(IOFON.LT.0.OR.IOFON.GT.3)GOTO 9900 
C 
      IBUFR = 2HRE
      INX = 1 
      IF(IOFON.EQ.3)GOTO 2000 
C 
C  OFFSET ON/OFF
C 
      IBUFR = 2HOM
      IF(IFUNC.EQ.2)IBUFR = 2HOB
      IBUFR(2) = 30000B 
      INX = 2 
      IF(IOFON.EQ.0)GOTO 2000 
C 
C  AUTO OFFSET
C 
      IBUFR = 2HSO
      IF(IFUNC.EQ.1.AND.IOFON.EQ.2)IBUFR(2) = 2HMB
      IF(IFUNC.EQ.2.AND.IOFON.EQ.2)IBUFR(2) = 2HBB
      IF(IOFON.EQ.2)GOTO 2000 
C 
C  SET FREQ/AMPL OFFSET 
C 
      IBUFR(2) = 2H1S 
      IF(IFUNC.EQ.1)IBUFR(3) = 2HOM 
      IF(IFUNC.EQ.2)IBUFR(3) = 2HOB 
      INX = 4 
C 
C  SET OFFSET VALUE 
C 
      VAL1 = OFFS1
      IF(VAL1.LT.0.0)VAL1 = -OFFS1
      IFLG = 0
      IF(IFUNC.EQ.2)GOTO 300
C 
C FREQUENCY 
C 
      VAL2 = OFFS2
      IF(VAL2.LT.0.0)VAL2 = -OFFS2
      IF(VAL1.GT.99999.)GOTO 9900 
      IF(VAL2.GT.999999.)GOTO 9900
      ISIGN = 0 
      IF(OFFS1.LT.0.0.OR.OFFS2.LT.0.0)ISIGN = 1 
      INX = 4 
      IF(ISIGN.EQ.0)IBUFR(INX) = 20000B 
      IF(ISIGN.EQ.1)IBUFR(INX) = 26400B 
C 
C CONVERT 'OFFS1' MHZ VALUE TO 5 ASCII DIGITS 
C 
      IF(VAL1.EQ.0.0)GOTO 200 
      CALL GENF2(VAL1,NMBR) 
      IF(NMBR.EQ.-1)GOTO 9900 
C 
C  FIND NUMBER OF DIGITS
C 
      NXM = 2 
      IF(NMBR.EQ.3.OR.NMBR.EQ.4)NXM = 3 
      IF(NMBR.LT.3)NXM = 4
      IF(ISIGN.EQ.0)GOTO 180
C 
      DO 175  I=NXM,4 
      IVAH = IAND(NMBR(I),177400B) / 256
      IVLO = IAND(NMBR(I),377B) * 256 
      IBUFR(INX) =  IOR(IBUFR(INX),IVAH)
      INX = INX + 1 
 175  IBUFR(INX) = IVLO 
C 
      GOTO 200
C 
 180  CONTINUE
      DO 190  J = NXM, 4
      IBUFR(INX) = NMBR(J)
 190  INX = INX + 1 
C 
      IBUFR(INX) =27000B
      IF(VAL2.EQ.0.0)GOTO 2000
      IFLG = 1
      GOTO 210
C 
C 
C CONVERT 'OFFS2' HZ VALUE TO 6 ASCII DIGITS
C 
 200  IF(VAL2.EQ.0.0)GOTO 2000
C 
C INSERT DECIMAL POINT
C 
      IBUFR(INX) = IOR(IBUFR(INX),56B)
      INX = INX + 1 
      IFLG = 0
 210  CALL GENF2(VAL2,NMBR) 
      IF(NMBR.EQ.-1)GOTO 9900 
C 
C 
      IF(IFLG.EQ.0)GOTO 260 
C 
      DO 250  J = 2 , 4 
      IVAH = IAND(NMBR(J),177400B) / 256
      IVLO = IAND(NMBR(J),377B) * 256 
      IBUFR(INX) = IOR(IBUFR(INX),IVAH) 
      INX = INX + 1 
 250  IBUFR(INX) = IVLO 
      GOTO 2000 
C 
 260  CONTINUE
      DO 270  J = 2, 4
      IBUFR(INX) = NMBR(J)
 270  INX = INX + 1 
C 
      INX = INX - 1 
      GOTO 2000 
C 
C  AMPLITUDE
C 
 300  IF(VAL1.GT.99.9)GOTO 9900 
      ISIGN = 0 
      IF(OFFS1.LT.0.0)ISIGN = 1 
      IF(ISIGN.EQ.0)IBUFR(INX) = 25400B 
      IF(ISIGN.EQ.1)IBUFR(INX) = 26400B 
C 
C  CONVERT AMPLITUDE OFFSET VALUE TO ASCII DIGITS 
C 
      IVAL = VAL1 
      VAL2 = IVAL 
      CALL GENF2(VAL2,NMBR) 
      IF(NMBR.EQ.-1)GOTO 9900 
C 
      NVAL = (VAL1-VAL2)  * 10.0
      IVHI = IAND(NMBR(4),177400B) / 256
      IVLO = IAND(NMBR(4),377B) 
      IF(IVAL.LT.10)GOTO 310
C 
      IBUFR(INX) = IOR(IBUFR(INX),IVHI) 
      INX = INX + 1 
      IBUFR(INX) = IOR(IVLO*256,56B)
      INX = INX + 1 
      IBUFR(INX) = (60B+NVAL) * 256 
      GOTO 2000 
C 
 310  CONTINUE
      IF(IVLO.EQ.60B)IBUFR(INX) = IOR(IBUFR(INX),56B) 
      IF(IVLO.EQ.60B)GOTO 320 
      IBUFR(INX) = IOR(IBUFR(INX),IVLO) 
      INX = INX + 1 
      IBUFR(INX) = IOR(27000B,60B+NVAL) 
      GOTO 2000 
C 
 320  INX = INX + 1 
      IBUFR(INX) = (NVAL+60B)*256 
C 
C  REMOTE ENABLE
C 
2000  CALL EXEC(100003B,1600B+LUIB) 
      GOTO 9000 
70    CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
C 
C  SEND OUTPUT BUFFER 
C 
      IVAL = IAND(IBUFR(INX),377B)
      NUM = INX 
      IF(IVAL.EQ.0)NUM = -(2 * INX - 1) 
C 
      CALL REIO(100002B,LU1,IBUFR(1),NUM,IDUMY,0) 
      GOTO 9000 
71    CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
C 
C  RETURN 
C 
      IERMS=0 
      RETURN
C 
C  ERROR EXIT 
C 
8500  IERMS=IAND(IA,377B)+11
      GOTO 8000 
9000  IERMS=9 
      GOTO 8000 
9900  IERMS = 1 
8000  IERMS(2)=5
      IERMS(3)=2HOS 
      IERMS(4)=2HMW 
      IERMS(5)=2HC
      RETURN
      END 
C 
C 
      SUBROUTINE XDMWC(LU1,LUIB,IERMS,DAT1,DAT2,DAT3),
     +09580-16449 REV.2001 791023 
C 
      DIMENSION IERMS(5),IREG(2),IOBUF(4) 
      DIMENSION IBUF(20),IVAL(6)
      EQUIVALENCE (REG,IREG,IA),(IREG(2),IB)
      DATA IOBUF /2HST,2H1 /
C 
C  REMOTE ENABLE
C 
2000  CALL EXEC(100003B,1600B+LUIB) 
      GOTO 9000 
70    CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
C 
C  SEND OUTPUT BUFFER 
C 
      INUM = -3 
      CALL REIO(100002B,LU1,IOBUF(1),INUM,IDUMY,0)
      GOTO 9000 
 71   CALL ABREG(IA,IB) 
      IF(IB .LT. 0) GOTO 8500 
C 
C  READ DATA
C 
      CALL REIO(100001B,LU1,IBUF,18,IDUMY,0)
      GOTO 9000 
 72   CALL ABREG(IA,IB) 
      IF(IB.LT.0)GOTO 8500
C 
C  CHECK POSITION OF BUFFR
C 
      IFLD = IAND(IBUF,377B)
      ISTRT = 2 
      IF(IFLD.EQ.40B)ISTRT = 3
C 
      IDX = 1 
      DO 2500  I = ISTRT, 5 
      IDX = IDX + 1 
      IVAL(IDX) = IBUF(I) 
      IF(ISTRT.EQ.3)GOTO 2500 
      IVAL(IDX) = IAND(IVAL(IDX),377B) * 256
      LCHR = IAND(IBUF(I+1),177400B) / 256
      IVAL(IDX) = IOR(IVAL(IDX),LCHR) 
 2500 CONTINUE
C 
C 
 2520 IVAL(5) = 2HE+
      IVAL(6) = 2H06
      IVAL = 10 
      LDG = IAND(IVAL(2),177400B) / 256 
      IF(LDG.NE.40B)GOTO 2530 
      LDG = IAND(IVAL(2),377B)
      IVAL(2) = IOR(25400B,LDG) 
 2530 IREG = A2F(IVAL,1,IVAL,DAT1)
      IF(IREG.LT.0)GOTO 8400
C 
C  CONVERT HZ 
C 
      IDX = 1 
      DO 2550  I = 6 , 9
      IDX = IDX + 1 
 2550 IVAL(IDX) = IBUF(I) 
C 
      IF(ISTRT.EQ.2)GOTO 2570 
C 
      DO 2560  I = 2 , 4
      IVAL(I) = IAND(IVAL(I),377B) * 256
      LDG = IAND(IVAL(I+1),177400B) / 256 
 2560 IVAL(I) = IOR(IVAL(I),LDG)
C 
 2570 IVAL = 6
      IVAL(5) = 2H
      IREG = A2F(IVAL,1,IVAL,DAT2)
      IF(IREG.LT.0)GOTO 8400
      DAT3 = 0.0
      IF(IB.LT.12)GOTO 5000 
C 
C AMPLITUDE (OPTION 002)
C 
      IDX = 1 
      IF(ISTRT.EQ.3)GOTO 2590 
C 
      DO 2580  I=12, 15 
      IDX = IDX + 1 
      IVAL(IDX) = IAND(IBUF(I),377B) * 256
      LDG = IAND(IBUF(I+1),177400B) / 256 
 2580 IVAL(INX) = IOR(IVAL(IDX),LDG)
C 
      GOTO 2700 
C 
 2590 CONTINUE
C 
      DO 2595  I=13, 16 
      IDX = IDX + 1 
 2595 IVAL(IDX) = IBUF(I) 
C 
C 
 2700 IVAL = 8
      IREG = A2F(IVAL,1,IVAL,DAT3)
      IF(IREG.LT.0)GOTO 8400
C 
C  RETURN 
C 
 5000 IERMS=0 
      RETURN
C 
C  ERROR EXIT 
C 
 8400 IERMS = 4 
      GOTO 8000 
C 
8500  IERMS=IAND(IA,377B)+11
      GOTO 8000 
9000  IERMS=9 
8000  IERMS(2)=5
      IERMS(3)=2HRD 
      IERMS(4)=2HMW 
      IERMS(5)=2HC
      RETURN
      END 
C 
      SUBROUTINE GENF2(FNUM,IFS),09580-16449 REV.2001 791023
C 
C 
C     ON ENTRY, FNUM CONTAINS A FLOATING POINT NUMBER IN THE
C     THE RANGE 0.0 - 999999.0 (ANY F.P. FORMAT ACCEPTABLE TO 
C     SUBROUTINE "F2A").  THE NUMBER MUST BE POSITIVE.
C 
C     ON RETURN, IFS(2-4) CONTAINS PACKED ASCII WITH LEADING
C     ZEROES, NO DECIMAL POINT, NO "E".  IFS(5-6) CONTAINS
C     ASCII BLANKS (20040B).
C 
C     IFS(1) = -1 (INTEGER FORMAT) FOR ERROR RETURN.
C 
C 
C 
      DIMENSION IFS(6),JFS(10)
C 
C 
C 
      IF (FNUM .GE. 0.0 .OR. FNUM .LT. 1E6) GO TO 10
      IFS(1) = -1 
      RETURN
C 
C 
C 
10    DO 100 I=1,6
      IFS(I) = 20040B 
100   CONTINUE
C 
C     CONVERT TO ASCII
C 
C 
      CALL F2A(FNUM,IFS(1)) 
      IF(IAND(IFS(2),177400B) .NE. 37400B) GO TO 110
      IFS(1) = -1 
      RETURN
C 
C     FIND "E" IF PRESENT 
C 
110   IEFLG = 0 
      DO 150 I=2,6
      IF (IAND(IFS(I),177400B) .EQ. 42400B) GO TO 130 
      IF (IAND(IFS(I),377B) .EQ. 105B) GO TO 120
      GO TO 150 
120   IENUM = (IAND(IFS(I+1),177400B))/256
      GO TO 140 
130   IF (I .EQ. 2) IEFLG = 1 
      IENUM = IAND(IFS(I),377B) 
140   IENUM = IENUM - 60B 
      GO TO 160 
150   CONTINUE
      IENUM = 0 
C 
C     IENUM CONTAINS INTEGER VALUE OF "E" (0-6).
C     NOW UNPACK CHARACTERS.
C 
160   DO 200 I=1,5
      N=(I*2)-1 
      JFS(N) = (IAND(IFS(I+1),177400B))/256 
      JFS(N) = IAND(JFS(N),377B)
      JFS(N+1) = IAND(IFS(I+1),377B)
200   CONTINUE
      IF (IEFLG .NE. 1) GO TO 210 
      JFS(1) = 61B
      JFS(2) = 40B
      IENUM = IENUM - 1 
C 
C     LOCATE THE DECIMAL POINT
C 
210   DO 220 ID=1,10
      IF (JFS(ID) .EQ. 56B .OR. JFS(ID) .EQ. 40B) GO TO 230 
      IF (JFS(ID) .EQ. 105B) GO TO 225
220   CONTINUE
      IFS(1) = -1 
      RETURN
C 
C     VALID NUMBER BUT NO DECIMAL POINT 
C 
225   JFS(ID+1) = 60B 
C 
C     DELETE DECIMAL POINT, ADJUST E VALUE
C 
230   DO 250 I=ID,9 
      JFS(I) = JFS(I+1) 
      IF (JFS(I) .EQ. 105B .OR. JFS(I) .EQ.40B) GO TO 240 
      GO TO 250 
240   DO 245 J=I,10 
      JFS(J) = 60B
245   CONTINUE
      GO TO 260 
250   CONTINUE
C 
C     SHIFT CHARACTERS AS NECESSARY 
C 
260   ISHFT = 7 - (ID+IENUM)
      IF (ISHFT .EQ. 0) GO TO 300 
      DO 280 I=10,ISHFT+1,-1
      JFS(I) = JFS(I-ISHFT) 
280   CONTINUE
C 
C     ADD LEADING ZEROES
C 
      DO 290 I=1,ISHFT
      JFS(I) = 60B
290   CONTINUE
C 
C     PACK CHARACTERS 
C 
300   DO 310 I=1,3
      J = (I*2)-1 
      JFS(J) = JFS(J)*256 
      JFS(J) = IAND(JFS(J),177400B) 
      JFS(J+1) = IAND(JFS(J+1),377B)
      IFS(I+1) = JFS(J)+JFS(J+1)
310   CONTINUE
C 
C     LOAD TRAILING BLANKS
C 
      DO 320 I=5,6
      IFS(I) = 20040B 
320   CONTINUE
C 
C 
C 
      RETURN
      END 
      END$