GEANT321/giopa/grout.F.ori

   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 GROUT(CHOBJT,IDVERS,CHOPT)
  13 C.
  14 C.    ******************************************************************
  15 C.    *                                                                *
  16 C.    *       Routine to write GEANT object(s) in the RZ file          *
  17 C.    *         at the Current Working Directory (See RZCDIR)          *
  18 C.    *       Input is taken from the data structures in memory        *
  19 C.    *           (VOLU,ROTM,TMED,MATE,SETS,PART,SCAN)                 *
  20 C.    *                                                                *
  21 C.    *       CHOBJ  The type of object to be written:                 *
  22 C.    *              MATE write JMATE structure                        *
  23 C.    *              TMED write JTMED structure                        *
  24 C.    *              VOLU write JVOLUM structure                       *
  25 C.    *              ROTM write JROTM structure                        *
  26 C.    *              SETS write JSET  structure                        *
  27 C.    *              PART write JPART structure                        *
  28 C.    *              SCAN write LSCAN structure                       *
  29 C.    *              INIT write all initialisation structures          *
  30 C.    *                                                                *
  31 C.    *       IDVERS is a positive integer which specifies the version *
  32 C.    *           number of the object(s).                             *
  33 C.    *                                                                *
  34 C.    *       CHOPT List of options (none for the time being)          *
  35 C.    *                                                                *
  36 C.    *    Note that if the cross-sections and energy loss tables      *
  37 C.    *       are available in the data structure JMATE, then they are *
  38 C.    *       saved on the data base.                                  *
  39 C.    *                                                                *
  40 C.    *                                                                *
  41 C.    *    The data structures saved by this routine can be retrieved  *
  42 C.    *    with the routine GRIN.                                      *
  43 C.    *                                                                *
  44 C.    *    Before calling this routine a RZ data base must have been   *
  45 C.    *    created using GRFILE.                                       *
  46 C.    *    The data base must be closed with RZEND.                    *
  47 C.    *                                                                *
  48 C.    *    The RZ data base can be transported between different       *
  49 C.    *    machines in using the ZEBRA RZ utility RZTOFZ.              *
  50 C.    *                                                                *
  51 C.    *    The interactive version of GEANT provides facilities        *
  52 C.    *    to interactively update, create and display objects.        *
  53 C.    *                                                                *
  54 C.    *      Example.                                                  *
  55 C.    *                                                                *
  56 C.    *      CALL GRFILE(1,'Geometry.dat','N')                         *
  57 C.    *      CALL GROUT('VOLU',1,' ')                                  *
  58 C.    *      CALL GROUT('MATE',1,' ')                                  *
  59 C.    *      CALL GROUT('TMED',1,' ')                                  *
  60 C.    *      CALL GROUT('ROTM',1,' ')                                  *
  61 C.    *      CALL GROUT('PART',1,' ')                                  *
  62 C.    *      CALL GROUT('SCAN',1,' ')                                  *
  63 C.    *      CALL GROUT('SETS',1,' ')                                  *
  64 C.    *                                                                *
  65 C.    *      The same result can be achieved by:                       *
  66 C.    *      CALL GRFILE(1,'Geometry.dat','NO')                        *
  67 C.    *                                                                *
  68 C.    *    ==>Called by : <USER>,GRFILE                                *
  69 C.    *       Author    R.Brun  *********                              *
  70 C.    *                                                                *
  71 C.    ******************************************************************
  72 C.
  73 #include "geant321/gcbank.inc"
  74 #include "geant321/gcflag.inc"
  75 #include "geant321/gcnum.inc"
  76 #include "geant321/gccuts.inc"
  77 #include "geant321/gcscal.inc"
  78 #include "geant321/gcdraw.inc"
  79 #include "geant321/gcunit.inc"
  80 *      COMMON/GCLINK/JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART
  81 *     +      ,JROTM ,JRUNG ,JSET  ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX
  82 *     +      ,JVOLUM,JXYZ  ,JGPAR ,JGPAR2,JSKLT
  83       COMMON/QUEST/IQUEST(100)
  84       PARAMETER (NLINIT=9,NLKINE=2,NLTRIG=6,NMKEY=22)
  85       DIMENSION JNAMES(20),KEYS(2)
  86       DIMENSION LINIT(NLINIT),LKINE(NLKINE),LTRIG(NLTRIG),IXD(NMKEY)
  87       DIMENSION LINK(NMKEY),LDIV(2)
  88       EQUIVALENCE (JNAMES(1),JDIGI)
  89       CHARACTER*4 CHOBJ,NAMES(NMKEY)
  90       CHARACTER*(*) CHOPT,CHOBJT
  91       DATA NAMES/'DIGI','DRAW','HEAD','HITS','KINE','MATE','PART',
  92      +    'ROTM','RUNG','SETS','STAK','STAT','TMED','NULL','VERT',
  93      +    'VOLU','JXYZ','NULL','NULL','NULL','SCAN','NULL'/
  94       DATA IXD/2,1,2,2,2,8*1,2,2,1,2,3*0,1,0/
  95       DATA LINIT/2,6,7,8,9,10,13,16,21/
  96       DATA LKINE/5,15/
  97       DATA LTRIG/1,3,4,5,15,17/
  98 C.
  99 C.    ------------------------------------------------------------------
 100 C.
 101       IQUEST(1)=0
 102       LDIV(1)  =IXCONS
 103       LDIV(2)  =IXDIV
 104       CHOBJ=CHOBJT
 105 *
 106       IOPTI=INDEX(CHOPT,'i')+INDEX(CHOPT,'I')
 107       IOPTT=INDEX(CHOPT,'t')+INDEX(CHOPT,'T')
 108       IOPTK=INDEX(CHOPT,'k')+INDEX(CHOPT,'K')
 109       IOPTQ=INDEX(CHOPT,'q')+INDEX(CHOPT,'Q')
 110 *
 111       IF(CHOBJ.EQ.'INIT') THEN
 112          CHOBJ='*'
 113          IOPTI=1
 114          IOPTT=0
 115          IOPTK=0
 116       ELSEIF(CHOBJ.EQ.'TRIG') THEN
 117          CHOBJ='*'
 118          IOPTI=0
 119          IOPTT=1
 120          IOPTK=0
 121       ELSEIF(CHOBJ.EQ.'KINE') THEN
 122          CHOBJ='*'
 123          IOPTI=0
 124          IOPTT=0
 125          IOPTK=1
 126       ENDIF
 127 *
 128       IF(CHOBJ.EQ.'*') THEN
 129          IF(IOPTI.NE.0) THEN
 130             DO 10 J=1, NLINIT
 131                LINK(J)=LINIT(J)
 132    10       CONTINUE
 133             NLINK=NLINIT
 134          ELSEIF(IOPTT.NE.0) THEN
 135             DO 20 J=1, NLTRIG
 136                LINK(J)=LTRIG(J)
 137    20       CONTINUE
 138             NLINK=NLTRIG
 139          ELSEIF(IOPTK.NE.0) THEN
 140             DO 30 J=1, NLKINE
 141                LINK(J)=LKINE(J)
 142    30       CONTINUE
 143             NLINK=NLKINE
 144          ENDIF
 145       ELSE
 146          NLINK=0
 147          DO 90 J=1, NMKEY
 148             IF(CHOBJ.EQ.NAMES(J)) THEN
 149                IF(IOPTI.NE.0) THEN
 150                   DO 40 L=1, NLINIT
 151                      IF(LINIT(L).EQ.J) GOTO 70
 152    40             CONTINUE
 153                   GOTO 80
 154                ELSEIF(IOPTT.NE.0) THEN
 155                   DO 50 L=1, NLTRIG
 156                      IF(LTRIG(L).EQ.J) GOTO 70
 157    50             CONTINUE
 158                   GOTO 80
 159                ELSEIF(IOPTK.NE.0) THEN
 160                   DO 60 L=1, NLKINE
 161                      IF(LKINE(L).EQ.J) GOTO 70
 162    60             CONTINUE
 163                   GOTO 80
 164                ENDIF
 165    70          NLINK=1
 166                LINK(1)=J
 167                GOTO 100
 168 *
 169    80          WRITE(CHMAIL,10000) CHOBJ, CHOPT
 170                CALL GMAIL(0,0)
 171                GOTO 999
 172 *
 173             ENDIF
 174    90    CONTINUE
 175       ENDIF
 176 *
 177   100 IF(NLINK.EQ.0) THEN
 178          WRITE(CHMAIL,10100) CHOBJ
 179          CALL GMAIL(0,0)
 180          GOTO 999
 181       ENDIF
 182 *
 183       NOUT=0
 184       DO 110 I=1,NLINK
 185          NKEY=LINK(I)
 186          CALL UCTOH(NAMES(NKEY),KEYS,4,4)
 187          KEYS(2)=IDVERS
 188          IDIV=LDIV(IXD(NKEY))
 189          IF(NKEY.LE.20)THEN
 190             IF(JNAMES(NKEY).GT.0)    THEN
 191                CALL RZOUT(IDIV,JNAMES(NKEY),KEYS,ICYCLE,' ')
 192                LINK(I)=-LINK(I)
 193             ENDIF
 194          ELSE
 195             IF(ISLINK(NKEY-20).GT.0)    THEN
 196                CALL RZOUT(IDIV,ISLINK(NKEY-20),KEYS,ICYCLE,' ')
 197                LINK(I)=-LINK(I)
 198             ENDIF
 199          ENDIF
 200          IF(LINK(I).GT.0) THEN
 201             IF(IOPTQ.EQ.0) THEN
 202             WRITE(CHMAIL,10200) NAMES(LINK(I))
 203             CALL GMAIL(0,0)
 204             ENDIF
 205             GOTO 110
 206          ELSEIF(LINK(I).LT.0) THEN
 207             IF(IQUEST(1).EQ.0) THEN
 208             IF(IOPTQ.EQ.0) THEN
 209                WRITE(CHMAIL,10300) NAMES(-LINK(I)), IDVERS
 210                CALL GMAIL(0,0)
 211             ENDIF
 212                NOUT=NOUT+1
 213             ELSE
 214                WRITE(CHMAIL,10400) NAMES(-LINK(I))
 215                CALL GMAIL(0,0)
 216             ENDIF
 217          ENDIF
 218   110 CONTINUE
 219 *
 220       IF(NOUT.EQ.0) THEN
 221          WRITE(CHMAIL,10500)
 222          CALL GMAIL(0,0)
 223       ENDIF
 224 *
 225 10000 FORMAT(' *** GROUT *** Data structure ',A4,' not written ',
 226      +       'in phase ',A)
 227 10100 FORMAT(' *** GROUT *** Unknown key ',A4)
 228 10200 FORMAT(' *** GROUT *** Data structure ',A4,' was not found')
 229 10300 FORMAT(' *** GROUT *** Data structure ',A4,' version ',I10,
 230      +       ' saved to disk')
 231 10400 FORMAT(' *** GROUT *** Error in writing data structure ',
 232      +        A4,' to disk')
 233 10500 FORMAT(' *** GROUT *** Nothing written to disk !')
 234   999 END