ISAJET/isatape/bufout.F

   1 #include "isajet/pilot.h"
   2       SUBROUTINE BUFOUT(IL)
   3 C
   4 C          INVERSE OF BUFIN.
   5 C          IF CDCPACK IS USED, PACK TWO ZEVEL WORDS INTO EACH ZVOUT WORD
   6 C          BY CALL PAIRPAK AND BUFFER OUT ZVOUT ARRAY.
   7 C          OTHERWISE WRITE OUT ZEVEL.
   8 C
   9 C          NRECS INCREMENTED BY 1
  10 C          IL SET TO 3
  11
  12
  13 #include "isajet/itapes.inc"
  14 #include "isajet/final.inc"
  15 #include "isajet/idrun.inc"
  16 #include "isajet/zevel.inc"
  17 #include "isajet/zvout.inc"
  18       DIMENSION W(2),IW(2)
  19       EQUIVALENCE(W(1),IW(1))
  20 C          THESE ARE NOW INITIALIZED IN BLOCK DATA
  21       ITA=IABS(ITEVT)
  22 #if defined(CERNLIB_CDCPACK)
  23 C          USE CDC ASSEMBLY LANGUAGE ROUTINE PAIRPAK TO PACK 2 ZEVEL
  24 C          WORDS INTO 1 ZVOUT WORD AND THEN CALL CDC BUFFER OUT.
  25       IW(1)=IZEVEL(1)
  26       IZEVEL(2)=IL
  27       IW(2)=IL
  28       CALL PAIRPAK(W(1),W(2),WOUT,IFL)
  29       ZVOUT(1)=WOUT
  30       NW=IL/2+MOD(IL,2)
  31       DO 1 I=2,NW
  32       II=2*I-1
  33       CALL MOVLEV(IZEVEL(II),W,2)
  34       CALL PAIRPAK(W(1),W(2),WOUT,IFL)
  35       ZVOUT(I)=WOUT
  36     1 CONTINUE
  37       IL=3
  38       NRECS=NRECS+1
  39       BUFFER OUT(ITA,1) (ZVOUT(1),ZVOUT(NW))
  40       IF(UNIT(ITA,ZVOUT(1),ZVOUT(NW))) 10,10,11
  41 #endif
  42 #if defined(CERNLIB_STDIO)
  43 C          STANDARD FORTRAN 77 WRITE.
  44       IZEVEL(2)=IL
  45       WRITE(ITA,ERR=11) (ZEVEL(I),I=1,IL)
  46       IL=3
  47       NRECS=NRECS+1
  48 #endif
  49    10 RETURN
  50    11 WRITE(ITLIS,200) IEVT,IDG
  51   200 FORMAT(//'  BAD WRITE, EVENT NO.',I10,5X,'EVENT ID',2I10)
  52       RETURN
  53       END