GEANT321/giopa/gsave.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1995/10/24 10:21:17  cernlib
   6 * Geant
   7 *
   8 *
   9 #include "geant321/pilot.h"
  10 *CMZ :  3.21/02 29/03/94  15.41.21  by  S.Giani
  11 *-- Author :
  12       SUBROUTINE GSAVE(LUN,KEYSU,NUKEYS,IDENT,IER)
  13 C.
  14 C.    ******************************************************************
  15 C.    *                                                                *
  16 C.    *       Routine to write out data structures                     *
  17 C.    *                                                                *
  18 C.    *       LUN      Logical unit number                             *
  19 C.    *       KEYSU    Keywords to select data structures              *
  20 C.    *       NKEYS    Number of keywords                              *
  21 C.    *       IER      Error flag                                      *
  22 C.    *                                                                *
  23 C.    *    ==>Called by : <USER>, UGINIT,GUOUT                         *
  24 C.    *       Author    R.Brun  *********                              *
  25 C.    *                                                                *
  26 C.    ******************************************************************
  27 C.
  28 #include "geant321/gcbank.inc"
  29 #include "geant321/gcunit.inc"
  30       CHARACTER*4 KLEY(22)
  31       CHARACTER*4 KEYSU(1)
  32       DIMENSION KEYS(22),IUHEAD(2)
  33       DIMENSION KSEL(14),LKEY(22),LKNUM(22),LINK(14),JLINK(17)
  34       EQUIVALENCE (JLINK(1),JDIGI)
  35       COMMON/QUEST/IQUEST(100)
  36       SAVE IFIRST,LKEY
  37 C
  38       DATA LINK/7,6,13,16,8,10,2,9,3,15,5,17,4,1/
  39       DATA KLEY/'PART','MATE','TMED','VOLU','ROTM','SETS','DRAW','RUNG'
  40      +         ,'INIT','INIT','INIT','INIT','INIT','INIT','INIT','INIT'
  41      +         ,'HEAD','KINE','KINE','JXYZ','HITS','DIGI'/
  42       DATA LKNUM/1,2,3,4,5,6,7,8,1,2,3,4,5,6,7,8,9,10,11,12,13,14/
  43       DATA IFIRST/0/
  44 C.
  45 C.    ------------------------------------------------------------------
  46 C.
  47       IF(IFIRST.EQ.0)THEN
  48          IFIRST=1
  49          CALL UCTOH(KLEY,LKEY,4,88)
  50       ENDIF
  51 *
  52       WRITE(CHMAIL,10000)
  53       CALL GMAIL(0,0)
  54 10000 FORMAT(' *** GSAVE *** Obsolete routine. Please use GFOUT')
  55 C
  56       IER    = 0
  57       NKEYS=IABS(NUKEYS)
  58       IF (NKEYS.LE.0)                                 GO TO 99
  59       CALL UCTOH(KEYSU,KEYS,4,4*NKEYS)
  60 C
  61       IF(NUKEYS.LT.0)THEN
  62         I1=1
  63         I2=15
  64         K1=1
  65         K2=7
  66       ELSE
  67         I1=18
  68         I2=22
  69         K1=10
  70         K2=14
  71       ENDIF
  72 C
  73       DO 10 K=K1,K2
  74   10  KSEL(K)=0
  75       NK=0
  76       DO 25 I=I1,I2
  77          N=LKNUM(I)
  78          DO 20 IK=1,NKEYS
  79             IF(KEYS(IK).EQ.LKEY(I))THEN
  80                IL=LINK(N)
  81                IF(JLINK(IL).NE.0)THEN
  82                   KSEL(N)=1
  83                   NK=NK+1
  84                ENDIF
  85             ENDIF
  86   20     CONTINUE
  87   25  CONTINUE
  88 C
  89       IUHEAD(1)=IDENT
  90       IUHEAD(2)=NK
  91       IF(NUKEYS.LT.0)THEN
  92 C
  93 C======>      Write RUN header and constants
  94 C
  95          CALL FZOUT(LUN,IXCONS,JRUNG,1,'L',2,2,IUHEAD)
  96          IF(IQUEST(1).NE.0)GO TO 90
  97          DO 30 I=1,7
  98             IF(KSEL(I).NE.0)THEN
  99                IL=LINK(I)
 100                CALL FZOUT(LUN,IXCONS,JLINK(IL),0,'L',2,1,I)
 101                IF(IQUEST(1).NE.0)GO TO 90
 102             ENDIF
 103   30     CONTINUE
 104 C
 105       ELSE
 106 C
 107 C======>      Write event header and data structures
 108 C             Released unused space in JHITS and JDIGI
 109 C
 110          IF(KSEL(13).NE.0)CALL GRLEAS(JHITS)
 111          IF(KSEL(14).NE.0)CALL GRLEAS(JDIGI)
 112 C
 113          CALL FZOUT(LUN,IXDIV,JHEAD,1,' ',2,2,IUHEAD)
 114          IF(IQUEST(1).NE.0)GO TO 90
 115          DO 40 I=10,14
 116             IF(KSEL(I).NE.0)THEN
 117                IL=LINK(I)
 118                CALL FZOUT(LUN,IXDIV ,JLINK(IL),0,'L',2,1,I)
 119                IF(IQUEST(1).NE.0)GO TO 90
 120             ENDIF
 121   40     CONTINUE
 122 C
 123       ENDIF
 124       GO TO 99
 125 C
 126 C             Error
 127 C
 128   90  IER=IQUEST(1)
 129 C
 130   99  RETURN
 131       END