*
* $Id: epread.F,v 1.1.1.1 1996/03/08 15:21:44 mclareni Exp $
*
* $Log: epread.F,v $
* Revision 1.1.1.1  1996/03/08 15:21:44  mclareni
* Epio
*
*
#include "epio/pilot.h"
      SUBROUTINE EPREAD(LUNIT,MODEX,NW,IREC,IBUF,IERR)
CD    COMMON/EPDBGC/DBUGFL
CD    LOGICAL DBUGFL
C.
C. INPUT:
C.
C. LUNIT    LOGICAL UNIT NUMBER
C.
C. MODEX    =J  ,  J=1,2,3 : GET NEXT LOGICAL RECORD DATA
C.                 J=1     : DATA TRANSFERRED IN PACKED FORM
C.                 J=2     : DATA UNPACKED AS 16 BIT BYTES/WORD
C.                 J=3     : DATA UNPACKED AS 32 BIT BYTES/WORD
C.
C.          =10+J, J=1,2,3 AS ABOVE: GET DATA OF CURRENT LOGICAL RECORD
C.                 (ONLY POSSIBLE AFTER A PREVIOUS CALL WITH J=20).
C.
C.          =20    : GET HEADER OF NEXT LOGICAL RECORD. THE HEADER WILL
C.                 ALWAYS BE UNPACKED IN UNITS (16 OR 32 BIT WORDS).
C.
C.          =30    : GET NEXT PHYSICAL HEADER.
C.                 THE HEADER WILL ALWAYS BE UNPACKED AS 16 BIT/WORD.
C.
C. INPUT/OUTPUT:
C.
C. IBUF     USER PROVIDED UNIT BUFFER. MUST NOT BE TOUCHED BY USER.
C.
C. OUTPUT:
C.
C. NW       NO. OF WORDS TRANSFERRED INTO IREC.
C.          FOR J=1 NO. OF UNITS, FOR J=2 OR J=3 NO. OF 16 OR 32 BIT
C.          WORDS, I.E. NUMBER OF MACHINE WORDS OCCUPIED IN IREC.
C.
C. IREC     USER PROVIDED AREA TO STORE THE HEADER OR DATA REQUESTED.
C.
C. IERR     ERROR FLAG. SEE SEPARATE LIST.
C.
C. REMARK:
C. ------
C. FOR READING THE OLD EP FORMAT, THE PREVIOUS CALL TO EVENT
C.         CALL EVENT(IARRAY,ISTAT)
C. HAS TO BE REPLACED BY A CALL WITH J=1,2, OR 3.  IN THIS CASE, AS  FOR
C. EVENT  NOW,  THE  COMPLETE  RECORD  (INCLUDING  THE  HEADER)  WILL BE
C. TRANSFERRED.  PLEASE NOTE THAT  THE  DATA  NOW  START  IN  IREC(1),
C. INSTEAD OF IARRAY(2) BEFORE.
#include "epio/epiocom.inc"
      DIMENSION IBUF(1),IHEAD(3),IREC(1)
      LOGICAL FLAG1,FLAG2,FLAG3
      DATA NEND/65535/
      MODE=MODEX
      FLAG1=MODE.EQ.1.OR.MODE.EQ.2.OR.MODE.EQ.3
      FLAG2=MODE.EQ.11.OR.MODE.EQ.12.OR.MODE.EQ.13
      IF(FLAG1.OR.FLAG2.OR.MODE.EQ.20.OR.MODE.EQ.30)  GOTO 5
      IERR=8
      GOTO 9999
  5   CONTINUE
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--- ERROR IF UNIT IS OUTPUT UNIT
      IF(LIST(ISTART+16).EQ.1)  GOTO 9901
C--- SET UPPER LENGTH OF USER RECORD SPACE
      MLUSER=LIST(ISTART+2)
C--- FOR HEADER, TAKE STATUS WORD 26
      IF(MODE.EQ.20 .OR. MODE.EQ.30)  MLUSER=LIST(ISTART+26)
C--- FOR BIT STRING, TAKE CORRECT LENGTH IN MACHINE WORDS
      IF(MODE.EQ.1 .OR. MODE.EQ.11)MLUSER=MLUSER*LIST(4)/16
   10 LPOS=LIST(ISTART+22)
      IF(LPOS.EQ.4)  GOTO 9905
      IF(FLAG2.AND.LPOS.NE.1) GOTO 9902
      IF(MODE .EQ. 30)GOTO 20
C--CHECK FOR NEW BLOCK REQUIRED
      IF(LIST(ISTART+14).EQ.0)GOTO 20
      IP1=LIST(ISTART+23)
      IF(LPOS.EQ.2)  IP1=LIST(ISTART+15)
      IF(IWD16(IBUF,IP1+1).NE.NEND.OR.LPOS.EQ.1)GOTO 30
C-- READ NEW BLOCK
 20   CALL EPBLIN(IBUF,IERR)
      IF(IERR.NE.0) GOTO 9999
      IF(LIST(ISTART+7).EQ.0)GOTO 20
*--- take the 1st pointer from word(15) if sequential mode or next
*--- record in direct access mode
      IF(LIST(ISTART+32).NE.1)  THEN
         IP1=LIST(ISTART+15)
      ELSE
*--- random access       HG  march 17, 89
*--- take the 1st pointer from word(23) if direct access mode and
*--- 1st record after a call to EPDACR.
         IP1=LIST(ISTART+23)
         LIST(ISTART+32)=2
      ENDIF
      IF(LPOS.EQ.1) IP1=LIST(ISTART+7)
      IF(MODE.NE.30)GOTO 30
C--GET THE PHYSICAL HEADER
      LPH=LIST(ISTART+7)
      ML=MLUSER
      IF(LIST(ISTART+29).EQ.0)  THEN
         NW=MIN(LPH,ML)
         CALL BLO16W(IBUF,1,IREC,1,NW)
      ELSE
         NW=MIN(LPH/2,ML)
         CALL BLO32W(IBUF,1,IREC,1,NW)
         CALL CFRIBM(IREC,NW,2)
      ENDIF
      LIST(ISTART+22)=2
      IF(LPH.GT.ML) GOTO 9903
      GOTO 77777
C--SET UP POINTERS
 30   CONTINUE
C--- IF OLD FORMAT FORCE MODE=2
      LOLD=LIST(ISTART+17)
      IF(LOLD.EQ.1 .AND. MODE.GT.3)GOTO 9907
      IF(LOLD.EQ.1)  MODE=2
      LPOS=LIST(ISTART+22)
      IF(LPOS.EQ.2)IP1=LIST(ISTART+15)
C--  IP1=0 IMPLIES NO L.R. STARTING IN BLOCK
      IF(IP1.EQ.0)GOTO 20
C--- NOW THERE IS A LOGICAL RECORD STARTING IN CURRENT BLOCK,
C    OR IP1 POINTS TO THE START OF DATA IN THIS BLOCK
*--- new pointer to start of header (always)  HG  march 17, 89
      LIST(ISTART+31)=IP1
      NP=LIST(ISTART+14)
      IUNIT=LIST(ISTART+3)
      IF(.NOT.(IUNIT.EQ.16 .OR. IUNIT.EQ.32))GOTO 9908
      NFACT=IUNIT/16
      NHMIN=3*NFACT
      FLAG3=MODE.EQ.3.OR.MODE.EQ.13.OR.(MODE.EQ.20.AND.IUNIT.EQ.32)
      ML=MLUSER
C--- SPECIAL HEADER TREATMENT FOR OLD FORMAT
      IF(LOLD.EQ.0)  GOTO 40
      NL=IWD16(IBUF,IP1+1)
      IF(NL.EQ.0)  GOTO 9904
      LHL=0
      NHMIN=0
      IUNIT=16
      NFACT=1
      GOTO 170
   40 CONTINUE
CD    LABEL=30
CD    IF(DBUGFL)PRINT*,LABEL,LUNIT,IP1,NP,IUNIT,LPOS,MODE
      IF(LPOS.NE.1)  GOTO 110
      NL=LIST(ISTART+20)
      LHL=LIST(ISTART+21)
      IF(FLAG2)  GOTO 160
      LPOS=-1
      NWDS=NFACT*(NL-LHL)
      GOTO 210
C--PUT LOGICAL HEADER INTO IHEAD
 110  J=NP-IP1
      IF(J.LT.NHMIN)GOTO 120
CD    LABEL=110
CD    IF(DBUGFL)PRINT*,LABEL,LUNIT,IP1,NP,J
      CALL W16MOV(IBUF,IP1+1,IHEAD,1,NHMIN)
      IP1=IP1+NHMIN
      GOTO 140
C-- LOGICAL HEADER IS SPLIT
 120  CALL W16MOV(IBUF,IP1+1,IHEAD,1,J)
      IF(J.LT.NFACT)  GOTO 121
      IF(NFACT.EQ.1) THEN
         NL=IWD16(IHEAD,1)
      ELSE
         CALL BLO32W(IHEAD,1,NL,1,1)
         CALL CFRIBM(NL,1,2)
      ENDIF
      IF(NL.EQ.0)  GOTO 9904
  121 CALL EPBLIN(IBUF,IERR)
      IF(IERR.NE.0) GOTO 9999
      NP=LIST(ISTART+14)
      IP1=LIST(ISTART+7)
      N3=NHMIN-J
      CALL W16MOV(IBUF,IP1+1,IHEAD,J+1,N3)
      IP1=IP1+N3
 140  IF(IUNIT.EQ.32)GOTO 150
      NL=IWD16(IHEAD,1)
      LHL=IWD16(IHEAD,3)
      GOTO 160
 150  CALL BLO32W(IHEAD,1,NL,1,1)
      CALL BLO32W(IHEAD,5,LHL,1,1)
      CALL CFRIBM(NL,1,2)
      CALL CFRIBM(LHL,1,2)
 160  IF(NL.EQ.0) GOTO 9904
C--SET UP LOOP LIMITS
 170  NWDS=NFACT*(NL-LHL)
C--- IF DATA REQUESTED, SHIFT POINTER TO START OF DATA
      IF(FLAG1)  IP1=IP1+NFACT*LHL-NHMIN
      IF(IP1.LE.NP)  GOTO 171
C--- SKIP REST OF HEADER WHICH IS SPLIT - READ NEXT BLOCK
      CALL EPBLIN(IBUF,IERR)
      IF(IERR.NE.0)  GOTO 9999
      IP1=LIST(ISTART+7)+IP1-NP
      NP=LIST(ISTART+14)
  171 CONTINUE
C--- FOR UNKNOWN LENGTH, GIVE DATA UNTIL END OF BLOCK
      IF(NL.EQ.1)  NWDS=NP-IP1
C--- GET UPPER SIZE OF USER RECORD LIMIT
      ML=MLUSER
 180  IP2=0
      L32=0
      NW=0
      NTOT=0
CD    LABEL=180
CD    IF(DBUGFL)PRINT*,LABEL,LUNIT,NWDS,NL,LHL,IUNIT,ML,IP1
C--IF MODE=20 FIRST MOVE IHEAD INTO IREC
      IF(MODE.NE.20)GOTO 210
      NTOT=NTOT+NHMIN
      IF(NFACT.EQ.1)  CALL BLO16W(IHEAD,1,IREC,1,3)
      IF(NFACT.EQ.2)  CALL BLO32W(IHEAD,1,IREC,1,3)
      IP2=IP2+3
      NW=NW+3
      NWDS=NFACT*(LHL-3)
C--CALCULATE NO. OF WORDS TO MOVE
 210  NMIN1=MIN0(NWDS,NP-IP1)
      N3=MIN0(NMIN1,ML-IP2)
      IF(LPOS.EQ.-1)N3=0
CD    LABEL=210
CD    IF(DBUGFL)PRINT*,LABEL,LUNIT,NMIN1,NWDS,NP,IP1,IP2,N3
      IF(N3.LE.0)GOTO 320
      IF(FLAG3)  GOTO 230
C-- 16 BIT CASES
      IF(MODE.EQ.1 .OR. MODE.EQ.11)GOTO 220
      CALL BLO16W(IBUF,IP1+1,IREC,IP2+1,N3)
      GOTO 310
 220  CALL W16MOV(IBUF,IP1+1,IREC,IP2+1,N3)
      GOTO 310
 230  IF(L32.EQ.0)GOTO 240
C-- GET SECOND HALF OF SPLIT 32 BIT WORD
      CALL W16MOV(IBUF,IP1+1,KEEP,2,1)
      IP2=IP2+1
      CALL BLO32W(KEEP,1,IREC,IP2,1)
      NW=NW+1
      IP1=IP1+1
      NMIN1=NMIN1-1
      NWDS=NWDS-1
      NTOT=NTOT+1
      L32=0
  240  N3=MIN0(NMIN1/2,ML-IP2)
       IF(NL.NE.1.AND. NWDS.LE.NMIN1)N3=MIN0((NMIN1+1)/2,ML-IP2)
      CALL BLO32W(IBUF,IP1+1,IREC,IP2+1,N3)
      IF(MOD(NMIN1,2) .EQ.0)GOTO 310
C-- KEEP 1ST HALF OF SPLIT 32 BIT WORD
      L32=1
      CALL W16MOV(IBUF,NP,KEEP,1,1)
C-- UPDATE POINTERS IN IREC
 310  NW=NW+N3
      IP2=IP2+N3
C-- UPDATE POINTERS IN IBUF
 320  IP1=IP1+NMIN1
      NWDS=NWDS-NMIN1
      NTOT=NTOT+NMIN1
CD    LABEL=320
CD    IF(DBUGFL)PRINT*,LABEL,LUNIT,IP1,IP2,NW,N3,NMIN1,NWDS,LPOS
      IF(NL.EQ.1.AND.MODE.NE.20)  GOTO 330
      IF(NWDS.NE.0)GOTO 330
C-- THE LOGICAL RECORD IS FINISHED
      LIST(ISTART+20)=NL
C--- NL=0 INDICATES HERE BLOCK WITH L.R. START FOUND
      IF(NL.EQ.0)LIST(ISTART+20)=NTOT+LHL
      LIST(ISTART+21)=LHL
      LIST(ISTART+23)=IP1
      LIST(ISTART+22)=0
      IF(MODE.EQ.20)  THEN
         LIST(ISTART+22)=1
         IF(IUNIT.EQ.32)  CALL CFRIBM(IREC,NW,2)
      ENDIF
      IF(LPOS.EQ.-1)LIST(ISTART+22)=0
      IF(NP.EQ.IP1)LIST(ISTART+14)=0
      IF(LPOS.EQ.-1)GOTO 10
      IF(IUNIT.EQ.32.AND.(MODE.EQ.1.OR.MODE.EQ.11))  NW=NW/2
      IF(MODE.EQ.20 .OR. MODE.LE.3)LIST(ISTART+12)=LIST(ISTART+12)+1
      IF(NL.NE.0.OR.IERR.NE.1) GOTO 321
C--- E.O.F. AFTER UNKNOWN LENGTH RECORD - SPECIAL TREATMENT
      LIST(ISTART+22)=4
      IERR=0
C--   TEST FOR TRUNCATED DATA
  321 IF(FLAG3)  ML=2*ML
      IF(NTOT.GT.ML)  GOTO 9903
      GOTO 77777
C-- READ NEXT BLOCK
 330  CALL EPBLIN(IBUF,IERR)
C--- CHECK FOR E.O.F. AFTER UNKNOWN LENGTH RECORD
      IF(IERR.EQ.1.AND.NL.EQ.1)  GOTO 341
      IF(IERR.NE.0) GOTO 9999
      NP=LIST(ISTART+14)
      IP1=LIST(ISTART+7)
      IF(NL.EQ.1)  GOTO 335
C--- CHECK FOR INCONSISTENT LS FOR CURRENT L.R.
C    ( ESPECIALLY FOR OLD EP FORMAT )
      LS=LIST(ISTART+15)
      IF(LS.EQ.0)  GOTO 210
      NNWDS=NWDS
      IF(MODE.EQ.20.AND.LPOS.NE.(-1))  NNWDS=NWDS+NFACT*(NL-LHL)
      IF(LS.EQ.NNWDS+LIST(ISTART+7))  GOTO 210
      LIST(ISTART+22)=0
      LIST(ISTART+23)=LS
      GOTO 9906
  335 CONTINUE
      IF(LIST(ISTART+15).EQ.0)GOTO 340
      NL=0
      NWDS=LIST(ISTART+15)-IP1
      GOTO 210
 340  NWDS=NP-IP1
      GOTO 210
C--- E.O.F. AFTER UNKNOWN LENGTH RECORD
  341 NWDS=0
      IP1=0
      NL=0
      GOTO 210
77777 RETURN
 9901 CONTINUE
C--- UNIT IS OUTPUT UNIT
      IERR=17
      GOTO 9999
 9902 CONTINUE
C--- MODE 11,12,13 WITHOUT 20
      IERR=9
      GOTO 9999
 9903 CONTINUE
C--- DATA TRUNCATED
      IERR=6
      GOTO 9999
 9904 CONTINUE
C--NL=0 IMPLIES END OF RUN
      IERR=10
      LIST(ISTART+14)=0
      GOTO 9999
 9905 CONTINUE
C--- E.O.F. CONDITION TO USER AFTER UNKNOWN LENGTH RECORD
      IERR=1
      LIST(ISTART+22)=0
      GOTO 9999
 9906 CONTINUE
C--- LS (OFF-SET IN BLOCK) AND L.R. LENGTH DO NOT CHECK
      IERR=18
      GOTO 9999
 9907 CONTINUE
C--- OLD FORMAT AND MODE GT 3
      IERR=21
      GOTO 9999
 9908 CONTINUE
C--- LOGICAL RECORD UNIT (LIST(ISTART+3)) NE 16 OR 32
      LIST(ISTART+14)=0
      IERR=23
 9999 CALL EPERRH(LUNIT,IERR)
      GOTO 77777
      END