*
* $Id: epoutl.F,v 1.1.1.1 1996/03/08 15:21:44 mclareni Exp $
*
* $Log: epoutl.F,v $
* Revision 1.1.1.1  1996/03/08 15:21:44  mclareni
* Epio
*
*
#include "epio/pilot.h"
      SUBROUTINE EPOUTL(LUNIT,MODE,NH,IHEAD,NW,IREC,IBUF,IERR)
C.
C. THIS ROUTINE WRITES A USER SPECIFIED LOGICAL RECORD HEADER IN FRONT
C. OF THE DATA, INSTEAD OF THE HEADER PRODUCED AUTOMATICALLY FROM THE
C. STATUS WORDS.
C.
C. THE LOGICAL RECORD DATA ARE GIVEN IN THE SAME CALL.
C.
C.
C. INPUT:
C.
C. LUNIT    LOGICAL UNIT NUMBER
C.
C. MODE     =1,2,3
C.          1: TRANSFER DATA AS THEY ARE (BIT STRING)
C.          2: PACK DATA BEFORE WRITING, GIVEN AS 16 BIT RIGHT ADJ.
C.          3: PACK DATA BEFORE WRITING, GIVEN AS 32 BIT RIGHT ADJ.
C.
C. NH       HEADER LENGTH IN WORDS .
C.
C. IHEAD    ARRAY CONTAINING HEADER.
C.
C. NW       NO. OF WORDS TO BE WRITTEN.
C.          FOR MODE=1 IN UNITS, FOR MODE=2 OR =3 IN 16 RESP. 32 BIT
C.          WORDS,I.E. THE NUMBER OF MACHINE WORDS OCCUPIED.
C.
C. IREC    ARRAY CONTAINING THE USER DATA.
C.
C. INPUT/OUTPUT:
C.
C. IBUF     USER PROVIDED UNIT BUFFER. MUST NOT BE TOUCHED BY USER.
C.
C. OUTPUT:
C.
C. IERR     ERROR FLAG. SEE SEPARATE LIST.
C.
#include "epio/epiocom.inc"
#if !defined(CERNLIB_F4)
      DIMENSION IREC(1),IBUF(1),IHEAD(*)
#endif
#if defined(CERNLIB_F4)
      DIMENSION IREC(1),IBUF(1),IHEAD(1)
#endif
#if (defined(CERNLIB_HLESS))&&(!defined(CERNLIB_ND100B16))
C---
      DIMENSION LOCH(12)
C---
#endif
C--- CHECK MODE VALIDITY
      IF(MODE.LE.0.OR.MODE.GT.3)  GOTO 9901
C--- CHECK VALIDITY OF NUMBER OF WORDS, AND HEADER WORDS
      IF(NW.LT.0.OR.NH.LE.0)  GOTO 9904
C--- GET UNIT NUMBER
C--- CHECK WHETHER SAME USER UNIT AS LAST TIME
      IF(LASTUT.EQ.LUNIT)  GOTO 1551
C--- NEW UNIT - GET REF
      CALL EPUNIT(LUNIT,IERR)
      IF(IERR.EQ.0)  GOTO 1552
      GOTO 77777
 1551 IERR=0
      IF(LREF.NE.0)  GOTO 1552
      IERR=13
      CALL EPERRH(LUNIT,IERR)
      GOTO 77777
 1552 CONTINUE
C--- START-1 OF CONTROL WORDS
C--- ERROR IF UNIT IS INPUT UNIT
      IF(LIST(ISTART+16).EQ.2)  GOTO 9903
C--- INITIALIZE PHYS. HEADER, MARK UNIT FOR WRITING
      IF(LIST(ISTART+14).EQ.0)  CALL EPHEAD(IBUF)
C--- SET LOG. REC. DATA TYPE : 1 = 16 BIT, 2 = 32 BIT
      NTYPE=LIST(ISTART+3)/16
      IF(NTYPE.LE.0.OR.NTYPE.GT.2)  NTYPE=1
C--- LOGICAL RECORD HEADER LENGTH IN 16 BIT WORDS
      NHL=NTYPE*NH
C--- SPAN (=0) OR NOSPAN(=1) FLAG
      NOSPAN=LIST(ISTART+8)/10
C--- LOGICAL RECORD DATA LENGTH IN 16 BIT WORDS
      IF(MODE.EQ.1)  NWD=NTYPE*NW
      IF(MODE.NE.1)  NWD=(MODE-1)*NW
      IF(NTYPE.EQ.1 .AND. NWD+NHL.GT.65535)GOTO 9905
      IF(MODE.EQ.2.AND.NTYPE.EQ.2)  NWD=2*((NW+1)/2)
#if (defined(CERNLIB_HSPAN))&&(!defined(CERNLIB_ND100B16))
      IF(LIST(ISTART+14).GE.LIST(ISTART+1))  THEN
         CALL EPBOUT(IBUF,IERR)
         IF(IERR.NE.0)  GOTO 77777
      ENDIF
#endif
#if !defined(CERNLIB_HSPAN)
C--- WRITE BLOCK OUT IF L.H. DOES NOT FIT, OR ENTIRE REC.
C    IF IN NOSPAN MODE
      IF(LIST(ISTART+14)+NHL+NWD*NOSPAN.LE.LIST(ISTART+1)) GOTO 20
C--- WRITE
      CALL EPBOUT(IBUF,IERR)
      IF(IERR.NE.0)  GOTO 77777
C--- CHECK WHETHER LOC.REC. HEADER (+POSSIBLY DATA)FITS AT ALL
      IF(LIST(ISTART+14)+NHL+NWD*NOSPAN.GT.LIST(ISTART+1)) GOTO 9902
   20 CONTINUE
#endif
C--- INCREASE LOGICAL RECORD COUNT
      LIST(ISTART+12)=LIST(ISTART+12)+1
#if (defined(CERNLIB_ULENG))&&(!defined(CERNLIB_ND100B16))
      IHEAD(1)=1
#endif
#if !defined(CERNLIB_ULENG)
      IHEAD(1)=NH+NWD/NTYPE
#endif
      IF(LIST(ISTART+5).GE.0)  IHEAD(2)=LIST(ISTART+5)
      IHEAD(3)=NH
      IF(LIST(ISTART+6).GE.0)  IHEAD(4)=LIST(ISTART+12)
C--- TRANSFER LOG. REC. HEADER
      NS=LIST(ISTART+14)
C--- SET START OF FIRST LOG. REC. (P.H. WORD 4)
      IF(LIST(ISTART+15).EQ.0) LIST(ISTART+15)=NS
#if (defined(CERNLIB_HSPAN))&&(!defined(CERNLIB_ND100B16))
      NPT=LIST(ISTART+1)-LIST(ISTART+14)
      IF(NHL.GT.NPT)  THEN
C--- SPLIT HEADER
         IF(NTYPE.EQ.1)  THEN
C--- 16 BIT HEADER
            CALL BUN16W(IHEAD,1,IBUF,NS+1,NPT)
         ELSE
C--- 32 BIT HEADER
            IMD=MOD(NPT,2)
            NPT2=NPT/2
            CALL CTOIBM(IHEAD,NH,2)
            CALL BUN32W(IHEAD,1,IBUF,NS+1,NPT2)
            IF(IMD.NE.0)  THEN
               CALL BUN32W(IHEAD,NPT2+1,KEEP,1,1)
               CALL W16MOV(KEEP,1,IBUF,NS+NPT,1)
            ENDIF
         ENDIF
         LIST(ISTART+14)=LIST(ISTART+1)
         CALL EPBOUT(IBUF,IERR)
         IF(IERR.NE.0)  GOTO 77777
         NS=LIST(ISTART+14)
         IF(NTYPE.EQ.1)  THEN
            CALL BUN16W(IHEAD,NPT+1,IBUF,NS+1,NHL-NPT)
            NS=NS+NHL-NPT
         ELSE
            IF(IMD.NE.0)  THEN
               CALL W16MOV(KEEP,2,IBUF,NS+1,1)
               NS=NS+1
               NPT2=NPT2+1
            ENDIF
            CALL BUN32W(IHEAD,NPT2+1,IBUF,NS+1,NH-NPT2)
            NS=NS+2*(NH-NPT2)
            CALL CFRIBM(IHEAD,NH,2)
         ENDIF
         GOTO 30
      ENDIF
#endif
      IF(NTYPE.EQ.1)  THEN
         CALL BUN16W(IHEAD,1,IBUF,NS+1,NH)
      ELSE
         CALL CTOIBM(IHEAD,NH,2)
         CALL BUN32W(IHEAD,1,IBUF,NS+1,NH)
         CALL CFRIBM(IHEAD,NH,2)
      ENDIF
      NS=NS+NHL
#if (defined(CERNLIB_HSPAN))&&(!defined(CERNLIB_ND100B16))
   30 CONTINUE
#endif
      LIST(ISTART+14)=NS
C--- LOOP AND TRANSFER
      IPTUS=0
      LEFT16=NWD
C--- FLAG FOR 32 BIT WORD SPLITTING
#if (defined(CERNLIB_HLESS))&&(!defined(CERNLIB_ND100B16))
C--- KEEP P.H.
      IF(LIST(ISTART+29).EQ.1) THEN
      CALL W16MOV(IBUF,1,LOCH,1,24)
       ELSE
      CALL W16MOV(IBUF,1,LOCH,1,12)
       ENDIF
C--- GET NO. OF HEADERLESS BLOCKS FOLLOWING
      NHLESS=(NWD+NS)/LIST(ISTART+1)
C--- INSERT IN CONTROL WORD
      IF(LIST(ISTART+29).EQ.1) THEN
      CALL CTOIBM(NHLESS,1,2)
      CALL BUN32W(NHLESS,1,IBUF,17,1)
      CALL CFRIBM(NHLESS,1,2)
       ELSE
      CALL BUN16W(NHLESS,1,IBUF,9,1)
       ENDIF
C---
#endif
      L32=0
  100 CONTINUE
C--- NO. OF 16 BIT STILL TO TRANSFER (UP TO BUFFER SIZE)
      NT16=MIN0(LEFT16,LIST(ISTART+1)-NS)
      GOTO (110,120,130),MODE
  110 CONTINUE
C--- MODE = 1 : TRANSFER PACKED STRING
      CALL W16MOV(IREC,IPTUS+1,IBUF,NS+1,NT16)
      IPTUS=IPTUS+NT16
      GOTO 200
  120 CONTINUE
C--- MODE = 2 : PACK 16 BIT WORDS
      CALL BUN16W(IREC,IPTUS+1,IBUF,NS+1,NT16)
      IPTUS=IPTUS+NT16
      GOTO 200
  130 CONTINUE
C--- MODE = 3 : PACK 32 BIT WORDS
C--- CHECK WHETHER RIGHT HALF OF SPLIT WORD LEFT OVER
      IF(L32.EQ.0)  GOTO 131
      CALL W16MOV(KEEP,2,IBUF,NS+1,1)
      NS=NS+1
      NT16=NT16-1
      LEFT16=LEFT16-1
      L32=0
  131 CONTINUE
      NT=NT16/2
      CALL BUN32W(IREC,IPTUS+1,IBUF,NS+1,NT)
      IPTUS=IPTUS+NT
C--- CHECK FOR SPLITTING
      IF(MOD(NT16,2).EQ.0)  GOTO 200
      L32=1
      CALL BUN32W(IREC,IPTUS+1,KEEP,1,1)
      CALL W16MOV(KEEP,1,IBUF,NS+NT16,1)
      IPTUS=IPTUS+1
  200 CONTINUE
      NS=NS+NT16
      LIST(ISTART+14)=NS
      LEFT16=LEFT16-NT16
C--- CHECK WHETHER ALL DATA TRANSFERRED
#if (defined(CERNLIB_HLESS))&&(!defined(CERNLIB_ND100B16))
      IF(LEFT16.EQ.0)  GOTO 77776
#endif
#if !defined(CERNLIB_HLESS)
      IF(LEFT16.EQ.0)  GOTO 77777
#endif
C--- NO - WRITE AND CONTINUE
      CALL EPBOUT(IBUF,IERR)
      IF(IERR.NE.0)  GOTO 77777
#if (defined(CERNLIB_HLESS))&&(!defined(CERNLIB_ND100B16))
      LIST(ISTART+14)=0
      LIST(ISTART+7)=0
      IERR=-1
#endif
      NS=LIST(ISTART+14)
      GOTO 100
#if (defined(CERNLIB_HLESS))&&(!defined(CERNLIB_ND100B16))
77776 CONTINUE
C--- RESET IF NECESSARY
      IF(NHLESS.EQ.0)  GOTO 77777
      IERR=-1
      CALL EPBOUT(IBUF,IERR)
      IF(LIST(ISTART+29).EQ.1) THEN
      CALL W16MOV(LOCH,1,IBUF,1,24)
        LIST(ISTART+14)=24
        LIST(ISTART+7)=24
       ELSE
      CALL W16MOV(LOCH,1,IBUF,1,12)
      LIST(ISTART+14)=12
      LIST(ISTART+7)=12
       ENDIF
#endif
77777 RETURN
 9901 CONTINUE
C--- MODE ERROR
      IERR=8
      GOTO 599
#if !defined(CERNLIB_HSPAN)
 9902 CONTINUE
C--- LOGICAL RECORD HEADER TOO LONG TO FIT IN ONE PHYS. BLOCK
      IERR=15
      GOTO 599
#endif
 9903 CONTINUE
C--- UNIT IS INPUT UNIT
      IERR=17
      GOTO 599
 9904 CONTINUE
C--- NEGATIVE NUMBER OF WORDS, OR ZERO (NEG.) LENGTH HEADER GIVEN
      IERR=20
      GOTO 599
 9905 CONTINUE
C--- with 16 bit headers the record plus header length must be lt 65536
      IERR=24
  599 CONTINUE
      CALL EPERRH(LUNIT,IERR)
      GOTO 77777
      END