*
* $Id: epbout.F,v 1.1.1.1 1996/03/08 15:21:43 mclareni Exp $
*
* $Log: epbout.F,v $
* Revision 1.1.1.1  1996/03/08 15:21:43  mclareni
* Epio
*
*
#include "epio/pilot.h"
      SUBROUTINE EPBOUT(IBUF,IERR)
C. WRITES ONE PHYSICAL BLOCK
C.
C. INPUT:
C.
C. IBUF      BUFFER CONTAINING OUTPUT
C.
C. OUTPUT:
C.
C. IERR      =0  : SUCCESSFUL OPERATION
C.           =2 : WRITE PARITY ERROR
C.           =11 : UNIT NOT DEFINED (IBM)
C.           =12 : WRITE OPERATION FAILED (END OF VOLUME)
#include "epio/epiocom.inc"
      DIMENSION IL(12),NZERO(2)
#include "epio/wordsize.inc"
#if defined(CERNLIB_IBM)||defined(CERNLIB_CDC)||defined(CERNLIB_UNIVAC)||defined(CERNLIB_NORD)||defined(CERNLIB_CRAY)||defined(CERNLIB_CONVEX)||defined(CERNLIB_STF77)||defined(CERNLIB_STF77VX)
      DIMENSION IBUF(2)
#endif
#if defined(CERNLIB_VAX)
      INTEGER*2 IBUF(1)
      INCLUDE 'SYS$LIBRARY:FORIOSDEF'
      EXTERNAL SS$_ENDOFTAPE
#endif
#if defined(CERNLIB_APOLLO)
%INCLUDE '/sys/ins/base.ins.ftn'
%INCLUDE '/sys/ins/error.ins.ftn'
%INCLUDE '/sys/ins/streams.ins.ftn'
      INTEGER*2  ERROR_$RETURNED, IBUF(1)
      INTEGER STATUS_$RETURNED
#endif
#if defined(CERNLIB_UNIVAC)
      DIMENSION NACC(2)
      DATA NBLKSZ/'EP  '/
#endif
      DATA NZERO/2*0/,NEND/65535/
#if (defined(CERNLIB_HLESS))&&(!defined(CERNLIB_ND100B16))
      NFLAG=IERR
#endif
      IERR=0
      NW16=LIST(ISTART+14)
C--- SKIP IF BLOCK IS EMPTY
      IF(NW16.EQ.LIST(ISTART+7))  GOTO 77777
C--- PRESET NO. OF 16 BIT WORDS ACTUALLY WRITTEN
      N16OUT=NW16
C--- GET PAD FLAG
      IPAD=MOD(LIST(ISTART+8),10)
      IF(IPAD.EQ.1)  GOTO 10
      IF(IPAD.EQ.2)  GOTO 20
      GOTO 30
   10 CONTINUE
C--- PAD TO FIXED BLOCK LENGTH
      N16OUT=LIST(ISTART+1)
      GOTO 21
   20 CONTINUE
C--- PAD TO NEXT MAGIC MULTIPLE
      N16OUT=((NW16-1)/LIST(5)+1)*LIST(5)
C--- GET NUMBER OF MACHINE WORDS FOR OUTPUT
#if defined(CERNLIB_STF77)||defined(CERNLIB_STF77VX)
   21 NWMACH=(16*N16OUT-1)/LIST(4)+1
#endif
#if (!defined(CERNLIB_STF77))&&(!defined(CERNLIB_STF77VX))
   21 NWMACH=16*N16OUT/LIST(4)
#endif
      IF(N16OUT.EQ.NW16)  GOTO 31
C--- PAD - FIND FIRST MACHINE WORD TO BECOME ENTIRELY ZERO
      NSMACH=(16*NW16-1)/LIST(4)+2
C--- GET NO. OF TRAILING 16 BIT WORDS IN FRONT OF NSMACH
C--- (PARTIAL OVERLAP POSSIBLE)
C--- 4 ARE SUFFICIENT (UP TO 64 BIT WORDS)
      NPAD=MIN0(4,N16OUT-NW16)
C--- SET TO ZERO
      CALL W16MOV(NZERO,1,IBUF,NW16+1,NPAD)
      IF(NSMACH.LE.NWMACH) CALL UZERO(IBUF,NSMACH,NWMACH)
C--- SET END OF DATA INDICATOR
      CALL BUN16W(NEND,1,IBUF,NW16+1,1)
C--- SET POINTER TO E.O.D. WORD IF NO RECORD START IN THIS BLOCK
      IF(LIST(ISTART+15).EQ.0)  LIST(ISTART+15)=NW16
      GOTO 31
   30 CONTINUE
C--- DO NOT PAD - GET NO. OF MACHINE WORDS
      NWMACH=(16*N16OUT-1)/LIST(4)+1
   31 CONTINUE
C--- INCREASE P.R. COUNT
      LIST(ISTART+11)=LIST(ISTART+11)+1
C--- SPECIFY NECESSARY P.H. CONTROL WORDS
#if (defined(CERNLIB_HLESS))&&(!defined(CERNLIB_ND100B16))
      IF(NFLAG.LT.0)  GOTO 32
#endif
      IF(LIST(ISTART+29).EQ.0)  THEN
*--- 16 bit physical header
         CALL BLO16W(IBUF,1,IL,1,12)
      ELSE
         CALL BLO32W(IBUF,1,IL,1,12)
         CALL CFRIBM(IL,12,2)
      ENDIF
      IL(1)=N16OUT
      IL(2)=LIST(ISTART+7)
      IL(3)=LIST(ISTART+11)
      IL(4)=LIST(ISTART+15)
      IL(5)=LIST(ISTART+4)
      IL(6)=LIST(ISTART+9)
      IL(11)=LIST(ISTART+3)
      IF(LIST(ISTART+29).EQ.0)  THEN
         CALL BUN16W(IL,1,IBUF,1,12)
      ELSE
         CALL CTOIBM(IL,12,2)
         CALL BUN32W(IL,1,IBUF,1,12)
      ENDIF
#if (defined(CERNLIB_HLESS))&&(!defined(CERNLIB_ND100B16))
   32 CONTINUE
#endif
      LUNIT=LIST(ISTART+10)
#if defined(CERNLIB_CDC)
      BUFFER OUT(LUNIT,1) (IBUF(1),IBUF(NWMACH))
C--- WAIT FOR END OF OPERATION
      IF(UNIT(LUNIT).GT.0.)  IERR=2
#endif
#if defined(CERNLIB_CRAY)
C  FOR CRAY ONLY
      NWMACH=(16*N16OUT-1)/LIST(4)+1
      NUBC  =NWMACH*LIST(4)-N16OUT*16
      CALL WRITE (LUNIT,IBUF(1),NWMACH,NUBC)
#endif
#if defined(CERNLIB_IBM)||defined(CERNLIB_NORD)
      NBYTES=2*N16OUT
      CALL IORITE(LUNIT,IBUF,NBYTES,IRETCD)
      IF(IRETCD.EQ.0)  GOTO 77777
      IF(IRETCD.EQ.1)  IERR=11
      IF(IRETCD.EQ.2.OR.IRETCD.EQ.4) IERR=12
      IF(IRETCD.EQ.3)  IERR=2
      IF(IRETCD.EQ.8)  IERR=1
#endif
#if defined(CERNLIB_VAX)
      IF(LIST(ISTART+25).NE.0)THEN
C
C     MAGTAPE CASE USES QIO
C
          CALL EPMTWRITE(IBUF,2*N16OUT,IOS)
          IF(IOS.EQ.1)GO TO 77777
          IF(IOS.EQ.%LOC(SS$_ENDOFTAPE))THEN
           IERR = 2
           GO TO 9901
      ELSE
           WRITE(NOUTUT,1001) IOS
1001       FORMAT(/' +++ EP I/O PACKAGE VAX MAGTAPE ERROR ',Z10,' HEX')
           IERR = 12
           GO TO 9901
      ENDIF
      ELSE
      WRITE(LUNIT,IOSTAT=IOS)(IBUF(I),I=1,N16OUT)
      IF(IOS.NE.0) THEN
           IF(IOS.EQ.FOR$IOS_ERRDURWRI)THEN
                   IERR= 0
                   WRITE(NOUTUT,1002)
1002    FORMAT(/' +++ EP I/O PACKAGE SPECIAL VAX WRITE ERROR  +++'/
     1   '     DISK SPACE RAN OUT, OR TAPE PARITY ERROR OR???')
C
C       ERRDURWRI IS A VERY AMBIGUOUS MESSAGE. IT CAN BE DUE TO
C           WRITE PARITY ERROR
C           INSUFFICIENT SPACE ON DISK
C           INCORRECT BLOCK LENGTH ON WRITE
C           AND WHO KNOWS WHAT ELSE??
C
           ELSE
                IERR = 12
                WRITE(NOUTUT,1000)  IOS
 1000      FORMAT(/' +++ EP I/O PACKAGE SPECIAL VAX ERROR NO.',I5)
           ENDIF
      ENDIF
      ENDIF
#endif
#if defined(CERNLIB_APOLLO)
      IF(LIST(ISTART+25).NE.0)THEN
C
C      IN THE APOLLO CASE THE WRITING ROUTINE IS THE SAME FOR
C      MAGTAPE AND FOR DISK FILES
C
        CALL WRITE_$STREAM(IBUF,2*N16OUT,STATUS_$RETURNED)
        IF(STATUS_$RETURNED.EQ.STATUS_$OK) GO TO 77777
        IF(LSHFT(ERROR_$SUBSYS(STATUS_$RETURNED),8)
     +  .NE.STREAM_$SUBS) THEN
          WRITE(NOUTUT,1000)
1000      FORMAT(' +++ EPIO/DOMAIN: Not a stream I/O error ???')
          GO TO 9901
        END IF
        ERROR_$RETURNED=ERROR_$CODE(STATUS_$RETURNED)
        IF(ERROR_$RETURNED.EQ.STREAM_$BOF_ERR) THEN
          IERR = 2
          GO TO 9901
        END IF
        WRITE(NOUTUT,1001) ERROR_$RETUNED
1001    FORMAT(/' +++ EP I/O package stream error ',Z10,' hex')
        IERR = 12
      ELSE
C
C     HERE SIMPLY SOMETHING IS WRONG
C
        GO TO 9901
      END IF
#endif
#if defined(CERNLIB_UNIVAC)
C--FILENAME IN FIELDATA CHARACTERS
      LUNFD=LIST(ISTART+24)
C--FILE ADDRESS.  < 0 IF TAPE, >= 0 IF DISK
      IOAD=LIST(ISTART+25)
      IF(IOAD.GE.0) THEN
C--AN EP-FORMATTED BLOCK ON DISK IS PRECEEDED BY ONE WORD CONTAINING
C--  ('EP',BLOCK SIZE) ON UNIVAC
        BITS(NBLKSZ,19,18)=NWMACH
        NACC(1)=2**18+LOCF(NBLKSZ)
        NACC(2)=NWMACH*2**18+LOCF(IBUF)
        CALL FIOGW(LUNFD,NACC,2,IOAD,ISTAT)
       ELSE
        CALL FIOW(LUNFD,IBUF,NWMACH,IOAD,ISTAT)
       ENDIF
      IF(ISTAT.LT.0) THEN
C--IERR=2+100*IABS(UNIVAC ERROR CODE)
        IERR=2+IABS(ISTAT)*100
        LIST(ISTART+13)=LIST(ISTART+13)+1
       ELSE IF(IOAD.GE.0) THEN
C--UPDATE ADDRESS IF DISK FILE. WE ASSUME F-FORMAT WITH 28 WORDS/SECTOR
        LIST(ISTART+25)=LIST(ISTART+25)+(NWMACH+28)/28
       ENDIF
#endif
#if defined(CERNLIB_STF77)||defined(CERNLIB_STF77VX)
      IF(LIST(ISTART+33).EQ.1)THEN
       WRITE(LUNIT,REC=LIST(ISTART+11),IOSTAT=IERR)
     1       (IBUF(IWRD),IWRD=1,NWMACH)
      ELSE IF(LIST(ISTART+33).EQ.2)THEN
       call cfput(list(istart+25),0,NWMACH,IBUF,IERR)
      ELSE
       WRITE(LUNIT,IOSTAT=IERR)(IBUF(IWRD),IWRD=1,NWMACH)
      ENDIF
      IF(IERR.GT.0)  IERR=2
#endif
      IF(IERR.NE.0)  GOTO 9901
77777 CONTINUE
C--- RESET CONTROL WORDS
      LIST(ISTART+14)=LIST(ISTART+7)
      LIST(ISTART+15)=0
      RETURN
 9901 CONTINUE
C--- ERROR HANDLING
      CALL EPERRH(LIST(ISTART+10),IERR)
      GOTO 77777
      END