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