* * $Id$ * * $Log$ * Revision 1.1.1.1 1995/10/24 10:21:17 cernlib * Geant * * #include "geant321/pilot.h" *CMZ : 3.21/02 29/03/94 15.41.21 by S.Giani *-- Author : SUBROUTINE GROUT(CHOBJT,IDVERS,CHOPT) C. C. ****************************************************************** C. * * C. * Routine to write GEANT object(s) in the RZ file * C. * at the Current Working Directory (See RZCDIR) * C. * Input is taken from the data structures in memory * C. * (VOLU,ROTM,TMED,MATE,SETS,PART,SCAN) * C. * * C. * CHOBJ The type of object to be written: * C. * MATE write JMATE structure * C. * TMED write JTMED structure * C. * VOLU write JVOLUM structure * C. * ROTM write JROTM structure * C. * SETS write JSET structure * C. * PART write JPART structure * C. * SCAN write LSCAN structure * C. * INIT write all initialisation structures * C. * * C. * IDVERS is a positive integer which specifies the version * C. * number of the object(s). * C. * * C. * CHOPT List of options (none for the time being) * C. * * C. * Note that if the cross-sections and energy loss tables * C. * are available in the data structure JMATE, then they are * C. * saved on the data base. * C. * * C. * * C. * The data structures saved by this routine can be retrieved * C. * with the routine GRIN. * C. * * C. * Before calling this routine a RZ data base must have been * C. * created using GRFILE. * C. * The data base must be closed with RZEND. * C. * * C. * The RZ data base can be transported between different * C. * machines in using the ZEBRA RZ utility RZTOFZ. * C. * * C. * The interactive version of GEANT provides facilities * C. * to interactively update, create and display objects. * C. * * C. * Example. * C. * * C. * CALL GRFILE(1,'Geometry.dat','N') * C. * CALL GROUT('VOLU',1,' ') * C. * CALL GROUT('MATE',1,' ') * C. * CALL GROUT('TMED',1,' ') * C. * CALL GROUT('ROTM',1,' ') * C. * CALL GROUT('PART',1,' ') * C. * CALL GROUT('SCAN',1,' ') * C. * CALL GROUT('SETS',1,' ') * C. * * C. * The same result can be achieved by: * C. * CALL GRFILE(1,'Geometry.dat','NO') * C. * * C. * ==>Called by : ,GRFILE * C. * Author R.Brun ********* * C. * * C. ****************************************************************** C. #include "geant321/gcbank.inc" #include "geant321/gcflag.inc" #include "geant321/gcnum.inc" #include "geant321/gccuts.inc" #include "geant321/gcscal.inc" #include "geant321/gcdraw.inc" #include "geant321/gcunit.inc" * COMMON/GCLINK/JDIGI ,JDRAW ,JHEAD ,JHITS ,JKINE ,JMATE ,JPART * + ,JROTM ,JRUNG ,JSET ,JSTAK ,JGSTAT,JTMED ,JTRACK,JVERTX * + ,JVOLUM,JXYZ ,JGPAR ,JGPAR2,JSKLT COMMON/QUEST/IQUEST(100) PARAMETER (NLINIT=9,NLKINE=2,NLTRIG=6,NMKEY=22) DIMENSION JNAMES(20),KEYS(2) DIMENSION LINIT(NLINIT),LKINE(NLKINE),LTRIG(NLTRIG),IXD(NMKEY) DIMENSION LINK(NMKEY),LDIV(2) EQUIVALENCE (JNAMES(1),JDIGI) CHARACTER*4 CHOBJ,NAMES(NMKEY) CHARACTER*(*) CHOPT,CHOBJT DATA NAMES/'DIGI','DRAW','HEAD','HITS','KINE','MATE','PART', + 'ROTM','RUNG','SETS','STAK','STAT','TMED','NULL','VERT', + 'VOLU','JXYZ','NULL','NULL','NULL','SCAN','NULL'/ DATA IXD/2,1,2,2,2,8*1,2,2,1,2,3*0,1,0/ DATA LINIT/2,6,7,8,9,10,13,16,21/ DATA LKINE/5,15/ DATA LTRIG/1,3,4,5,15,17/ C. C. ------------------------------------------------------------------ C. IQUEST(1)=0 LDIV(1) =IXCONS LDIV(2) =IXDIV CHOBJ=CHOBJT * IOPTI=INDEX(CHOPT,'i')+INDEX(CHOPT,'I') IOPTT=INDEX(CHOPT,'t')+INDEX(CHOPT,'T') IOPTK=INDEX(CHOPT,'k')+INDEX(CHOPT,'K') IOPTQ=INDEX(CHOPT,'q')+INDEX(CHOPT,'Q') * IF(CHOBJ.EQ.'INIT') THEN CHOBJ='*' IOPTI=1 IOPTT=0 IOPTK=0 ELSEIF(CHOBJ.EQ.'TRIG') THEN CHOBJ='*' IOPTI=0 IOPTT=1 IOPTK=0 ELSEIF(CHOBJ.EQ.'KINE') THEN CHOBJ='*' IOPTI=0 IOPTT=0 IOPTK=1 ENDIF * IF(CHOBJ.EQ.'*') THEN IF(IOPTI.NE.0) THEN DO 10 J=1, NLINIT LINK(J)=LINIT(J) 10 CONTINUE NLINK=NLINIT ELSEIF(IOPTT.NE.0) THEN DO 20 J=1, NLTRIG LINK(J)=LTRIG(J) 20 CONTINUE NLINK=NLTRIG ELSEIF(IOPTK.NE.0) THEN DO 30 J=1, NLKINE LINK(J)=LKINE(J) 30 CONTINUE NLINK=NLKINE ENDIF ELSE NLINK=0 DO 90 J=1, NMKEY IF(CHOBJ.EQ.NAMES(J)) THEN IF(IOPTI.NE.0) THEN DO 40 L=1, NLINIT IF(LINIT(L).EQ.J) GOTO 70 40 CONTINUE GOTO 80 ELSEIF(IOPTT.NE.0) THEN DO 50 L=1, NLTRIG IF(LTRIG(L).EQ.J) GOTO 70 50 CONTINUE GOTO 80 ELSEIF(IOPTK.NE.0) THEN DO 60 L=1, NLKINE IF(LKINE(L).EQ.J) GOTO 70 60 CONTINUE GOTO 80 ENDIF 70 NLINK=1 LINK(1)=J GOTO 100 * 80 WRITE(CHMAIL,10000) CHOBJ, CHOPT CALL GMAIL(0,0) GOTO 999 * ENDIF 90 CONTINUE ENDIF * 100 IF(NLINK.EQ.0) THEN WRITE(CHMAIL,10100) CHOBJ CALL GMAIL(0,0) GOTO 999 ENDIF * NOUT=0 DO 110 I=1,NLINK NKEY=LINK(I) CALL UCTOH(NAMES(NKEY),KEYS,4,4) KEYS(2)=IDVERS IDIV=LDIV(IXD(NKEY)) IF(NKEY.LE.20)THEN IF(JNAMES(NKEY).GT.0) THEN CALL RZOUT(IDIV,JNAMES(NKEY),KEYS,ICYCLE,' ') LINK(I)=-LINK(I) ENDIF ELSE IF(ISLINK(NKEY-20).GT.0) THEN CALL RZOUT(IDIV,ISLINK(NKEY-20),KEYS,ICYCLE,' ') LINK(I)=-LINK(I) ENDIF ENDIF IF(LINK(I).GT.0) THEN IF(IOPTQ.EQ.0) THEN WRITE(CHMAIL,10200) NAMES(LINK(I)) CALL GMAIL(0,0) ENDIF GOTO 110 ELSEIF(LINK(I).LT.0) THEN IF(IQUEST(1).EQ.0) THEN IF(IOPTQ.EQ.0) THEN WRITE(CHMAIL,10300) NAMES(-LINK(I)), IDVERS CALL GMAIL(0,0) ENDIF NOUT=NOUT+1 ELSE WRITE(CHMAIL,10400) NAMES(-LINK(I)) CALL GMAIL(0,0) ENDIF ENDIF 110 CONTINUE * IF(NOUT.EQ.0) THEN WRITE(CHMAIL,10500) CALL GMAIL(0,0) ENDIF * 10000 FORMAT(' *** GROUT *** Data structure ',A4,' not written ', + 'in phase ',A) 10100 FORMAT(' *** GROUT *** Unknown key ',A4) 10200 FORMAT(' *** GROUT *** Data structure ',A4,' was not found') 10300 FORMAT(' *** GROUT *** Data structure ',A4,' version ',I10, + ' saved to disk') 10400 FORMAT(' *** GROUT *** Error in writing data structure ', + A4,' to disk') 10500 FORMAT(' *** GROUT *** Nothing written to disk !') 999 END