ISAJET/isatape/bufin.F

   1 #include "isajet/pilot.h"
   2       SUBROUTINE BUFIN(IL,IFLAG)
   3 C
   4 C          INVERSE OF BUFOUT.
   5 C          IF CDCPACK IS USED, READ INPUT RECORD INTO ZVOUT AND
   6 C          UNPACK EACH ZVOUT WORD INTO TWO ZEVEL WORDS BY CALL EXPAIR.
   7 C          OTHERWISE, READ ONE INPUT RECORD INTO ZEVEL.
   8 C
   9 #include "isajet/itapes.inc"
  10 #include "isajet/ita.inc"
  11 #include "isajet/zevel.inc"
  12 #include "isajet/zvout.inc"
  13       DIMENSION W(2),IW(2)
  14       EQUIVALENCE(W(1),IW(1))
  15       DATA NPARR/0/
  16     1 CONTINUE
  17 #if defined(CERNLIB_CDCPACK)
  18 C          USE CDC BUFFER IN TO READ PACKED RECORD.
  19       BUFFER IN(ITB,1) (ZVOUT(1),ZVOUT(512))
  20       IF(UNIT(ITB,ZVOUT(1),ZVOUT(512))) 300,200,100
  21 #endif
  22 #if defined(CERNLIB_STDIO)
  23 C          STANDARD FORTRAN 77 READ.
  24       CALL ZEROL(ZEVEL,MAXLEN)
  25       READ(ITB,ERR=100,END=200) IZVL1,IZVL2,(ZEVEL(JJ),JJ=3,IZVL2)
  26       GO TO 300
  27 #endif
  28 C            TAPE READ ERROR
  29   100 WRITE(ITLIS,10) ITB
  30       NPARR=NPARR+1
  31    10 FORMAT(1X,' TAPE READ ERROR ON TAPE',I3)
  32       IFLAG=1
  33       IF(NPARR.LT.20) GOTO 1
  34 C            END OF FILE
  35   200 IFLAG=-1
  36       RETURN
  37 C            GOOD RECORD
  38   300 IFLAG=0
  39 #if defined(CERNLIB_CDCPACK)
  40 C          USE CDC ASSEMBLY LANGUAGE ROUTINE EXPAIR TO UNPACK 1 ZVOUT
  41 C          WORDS INTO 2 ZEVEL WORDS.
  42       WOUT=ZVOUT(1)
  43       CALL EXPAIR(W(1),W(2),WOUT,IFL)
  44       IZEVEL(1)=IW(1)
  45       IZEVEL(2)=IW(2)
  46       IL=IW(2)
  47       NW=IL/2+MOD(IL,2)
  48       DO 310 I=2,NW
  49       WOUT=ZVOUT(I)
  50       II=2*I-1
  51       CALL EXPAIR(W(1),W(2),WOUT,IFL)
  52       CALL MOVLEV(W,IZEVEL(II),2)
  53   310 CONTINUE
  54 #endif
  55       IL=3
  56       RETURN
  57       END