| fe4da5cc |
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 |
git://git.uio.no / u / mrichter / AliRoot.git / blame