FTN4,L
      SUBROUTINE MOUTP(IU),09580-16019 REV.2013 800128
C 
C  THIS DEVICE SUBROUTINE IS USED TO PROGRAM A MEMORY OUTPUT CALL 
C  AS USED WITH THE BIOMATION 8100. 
C 
C**************************************** 
C 
C  RELOCATABLE  09580-16019 
C  SOURCE       09580-18019 
C 
C  V.POVIO  11-23-76
C  REY UNTALAN 10-23-79 
C  BOB RICHARDS 800128
C 
C 
C 
C*********************************************************************
C 
C      HP 92425B TEST SYSTEM SOFTWARE IS THE PROPRIETARY
C      MATERIAL OF THE HEWLETT-PACKARD COMPANY.  USE AND
C      DISCLOSURE THEREOF ARE RESTRICTED BY WRITTEN AGREEMENT.
C 
C      (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980.
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 
C 
C***************************************
C 
      DIMENSION IERMS(5),INUM(13) 
      DATA IERMS/10,5,2HMO,2HUT,2HP / 
      DATA IDTN/41/ 
C 
C  FIND STATION # AND LU #
C 
      IERMS=10
      ISTN=ISN(DUMMY) 
      ILU1=LUDV(ISTN,IDTN)
      IF(ILU1 .EQ. 0)GOTO 800 
C 
C  RETRIEVE DATA FROM CONFIGURATION FILE
C 
      IERMS=1 
      CALL TIM(IDTN,1,1,INUM,13,N)
      IF(N .NE. 0)RETURN
      IF(IU .GT. INUM)GOTO 800
C 
C  JUMP TO DEVICE SUBROUTINE
C 
      CALL XOUTP(ILU1,IERMS,IU) 
      RETURN
C 
C  ERROR EXIT 
C 
800   CALL ERROR(IERMS,IERMS(2))
      RETURN
      END 
C 
C**************************************** 
C 
      SUBROUTINE XOUTP(ILU1,IERMS,IU),09580-16019 REV.2013 800128 
      DIMENSION IUNIT(7),IREG(2),IDATA(10), 
     1IDCB(144),NAME(3),IERMS(5), 
     1IXFER(2),IA(128),IB(2048) 
      EQUIVALENCE (REG,IREG,LA),(IREG(2),LB)
      DATA IUNIT / 25400B,45400B,65400B,105400B,
     1125400B,145400B,165400B / 
      DATA NAME / 2HDM,2HOU,2HTP/ 
C 
C***************************************
C 
C  F) MEMORY DATA OUTPUT CALL:
C     ------------------------
C 
C      MOUTP(IU)
C 
C      WHERE
C 
C      IU=UNIT NUMBER (1-7) 
C 
C 
C 
C       ERRORS HAVE THE FOLLOWING MEANING:
C 
C         1= PARAMETER ERROR
C         2= TIME OUT OR I/O INCOMPLETE 
C         3= FAILED TO OPEN DATA FILE (DMOUTP)
C         9= I/O CALL REJECTED
C 
C 
C  COMMENT:A TYPE 1 FILE CALLED DMOUTP WITH A SECURITY CODE 
C          OF VP AND 32 SECTORS LONG WILL HAVE TO BE
C          CREATED BEFORE THIS DEVICE SUBROUTINE CAN BE USED. 
C 
C             :CR,DMOUTP:VP:-2:1:32 
C 
C 
C***************************************
C 
C  INITIALIZE 
C 
      IDTN=41 
      IERMS=0 
      ITEMP=0 
C 
C  OPEN DATA FILE DMOUTP
C 
      CALL OPEN(IDCB,IERMS,NAME,5,2HVP) 
      IF(IERMS .NE. 1)GOTO 8003 
      IERMS=2 
C 
C  SET UP OUTPUT DATA WORD
C 
      IDATA(1)=IUNIT(IU)
C 
C  OUTPUT DATA WORD 
C 
400   ICNWD=300B+ILU1 
      IDATA(1)=IUNIT(IU)
      CALL EXEC(100002B,ICNWD,IDATA(1),1) 
      GOTO 8002 
8900  CALL ABREG(LA,LB) 
      IF(IAND(IREG(1),177B) .NE. 0)GOTO 8001
C 
C  READ DATA BACK 
C 
C 
      ICNWD=500B+ILU1 
      CALL EXEC(100001B,ICNWD,IB(1),2048) 
      GOTO 8002 
8901  CALL ABREG(LA,LB) 
      IF(IAND(IREG(1),177B) .NE. 0)GOTO 8001
C 
C  CONVERT AND STORE IN RETURN VARIABLE 
C 
      ISTRT=1 
      IEND=64 
C 
C 
      DO 470 J3=1,32
      K=1 
      DO 410 J=ISTRT,IEND 
      IXFER(2)=20B
      INEG=IAND(IB(J),200B) 
      IF(INEG .EQ. 0)GOTO 430 
C 
      IXFER(1)=IOR(IB(J),177600B) 
      IF(IXFER(1) .EQ. 177777B)IXFER(2)=67363B
      IF(IXFER(1) .EQ. 177776B)IXFER(2)=67365B
      IF(IXFER(1) .GT. 177775B)IXFER(1)=100064B 
      GOTO 440
C 
430   IXFER(1)=IAND(IB(J),177B) 
C 
440   IA(K)=IXFER(1)
      IF(IA(K) .EQ. 0)IA(K)=1 
      IA(K+1)=IXFER(2)
      K=K+2 
410   CONTINUE
      IERMS=0 
C 
C  WRITE TO DATA FILE 
C 
      CALL WRITF(IDCB,IERMS,IA,128,J3)
      IF(IERMS .LT. 0)GOTO 8000 
      ISTRT=ISTRT+64
      IEND=IEND+64
470   CONTINUE
C 
C  CLOSE DATA FILE
C 
      CALL CLOSE(IDCB,IERMS)
      IF(IERMS .LT. 0)GOTO 8000 
C 
C  EXIT 
C 
      IERMS=0 
500   RETURN
C 
C  ERROR EXIT 
C 
C 
8003  IERMS=3 
      GOTO 8001 
C 
C 
8002  IERMS=9 
8000  IF(IERMS .LT. 0)IERMS=IABS(IERMS) 
8001  IERMS(2)=5
      IERMS(3)=2HMO 
      IERMS(4)=2HUT 
      IERMS(5)=2HP
      RETURN
      END 
                                                                                                                          