+OPTION,MAPASM.
+ASM,23.
+USE,GCDES,TestEm1,T=EXE.
*
+EXE,CRA*.
*
+PAM,11,T=CARD,T=ATTACH.     /cern/pro/src/car/geant321.car
+PATCH,TestEm1.        
+DECK,BLANKDEK.
* 
* TestEm1   1.00 /01  980918 13.00 GEANT EXAMPLES
* 
*             TEST PROGRAM FOR GEANT TEST
*                                                                               
*             Author    M.Maire  *********
*                                   
*     
* History                  
* -------                                            
*
*                                      
+KEEP,CALOR.                  
      COMMON/CALOR/Imat,BoxSize,Field  
*                                                               
*  Imat    = GEANT material number.                     (data card CALOR)
*  BoxSize = total size of the box (cm)                 (data card CALOR)
*  Field   = magnetic field (tesla)                     (data card CALOR)
*                                                                               
+KEEP,CELOSS.                                                                                                                      
      COMMON/CELOSS/ ETOT,NTRAK0,NTRAK1,NSTEP0,NSTEP1,NBCALL(12),
     +                    NSTRK0,NSTRK1                                                        

+DECK,main,if=batch.
      PROGRAM main
*
*
      PARAMETER (NGBANK=100000, NHBOOK=10000)
      COMMON/GCBANK/Q(NGBANK)
      COMMON/PAWC  /H(NHBOOK)
*
      CALL GZEBRA( NGBANK)
      CALL HLIMIT(-NHBOOK)
*
* *** initialize HIGZ
      CALL HPLINT(0)
*
* *** GEANT initialisation
      CALL UGINIT
*
* *** Start events processing
      CALL GRUN
*
* *** End of RUN
      CALL UGLAST
*
      STOP
      END
+DECK,main,IF=-batch.
      PROGRAM main
*
*     GEANT main program. To link with the MOTIF user interface
*     the routine GPAWPP(NWGEAN,NWPAW) should be called, whereas
*     the routine GPAW(NWGEAN,NWPAW) gives access to the basic
*     graphics version.
*
      PARAMETER (NWGEAN=3000000, NWPAW=1000000)
      COMMON/GCBANK/GEANT(NWGEAN)
      COMMON/PAWC  /PAW  (NWPAW)
*
*
      CALL GPAW (NWGEAN,NWPAW)
*
      END
*
      SUBROUTINE qnext
      END
*
      SUBROUTINE czopen
      END
*
      SUBROUTINE cztcp
      END
*
      SUBROUTINE czclos
      END
*
      SUBROUTINE czputa
      END
+DECK,UGINIT                                                                    
      SUBROUTINE UGINIT                                                         
*                                                                               
*     To initialise GEANT/USER  program and read data cards                     
*
+SEQ,CALOR,CELOSS.                                                                               
*
      CHARACTER*20 filnam                                                                                                                                                                                                      
*                                                                               
* *** Define the GEANT parameters                                                          
      CALL GINIT 
                                                                          
* *** read data cards
      PRINT *, 'G3 > gives the filename of the data cards to be read:'
      READ (*,'(A)') filnam
      IF (filnam.EQ.' ') filnam = 'testem1.dat'
      OPEN (unit=5,file=filnam,status='unknown',form='formatted')
                                              
*
* *** Calor definition                                               
      CALL FFKEY('CALOR',Imat,3,'MIXED')
*                                                                    
* *** read data cards                                                           
      CALL GFFGO 
                                                                     
*                                                                               
      CALL GZINIT                                                               
      CALL GPART 
*
      CALL GDINIT                                                                     
*                                                                               
* *** Geometry and materials description                                        
      CALL UGEOM                                                                
*                                                                               
* *** Energy loss and cross-sections initialisations                            
      CALL GPHYSI                                                               
*                                                                               
      CALL GPRINT('MATE',0)                                                     
      CALL GPRINT('TMED',0)                                                     
      CALL GPRINT('VOLU',0)                                                     
*                                                                                                                                                              
* *** Define user histograms                                                    
      CALL UHINIT
*
* *** some initialisation
      NTRAK0 = 0
      NTRAK1 = 0
      NSTEP0 = 0
      NSTEP1 = 0
      CALL VZERO (NBCALL,12)                                                               
*                                                                               
      END                                                                       
+DECK,UGEOM.                                                                    
      SUBROUTINE UGEOM                                                          
*                                                                               
* *** Define user geometry set up                                               
*                                                                                                                                                                                                                       
*
+SEQ,CALOR.
*                                                                               
      DIMENSION PAR(3)
      
      DIMENSION Aair(2),Zair(2),Wair(2)
      DIMENSION AH2O(2),ZH2O(2),WH2O(2)                                        
*                                                                               
* *** Air compound parameters                                                   
      DATA Aair/14.01, 16.00/                                            
      DATA Zair/ 7.  ,  8.  /                                                     
      DATA Wair/ 0.7 ,  0.3 /
*                                                                               
* *** Air compound parameters                                                   
      DATA AH2O/ 1.01, 16.00/                                            
      DATA ZH2O/ 1.  ,  8.  /                                                     
      DATA WH2O/ 2.  ,  1.  /                                                           
*
* *** Defines USER perticular materials
      CALL GSMIXT( 1,'Air'      , Aair ,Zair, 1.29E-3, 2   , Wair)                                                
      CALL GSMATE( 2,'H2 Liquid',  1.01,  1., 0.0708 , 865., 790., 0,0)
      CALL GSMIXT( 3,'Water'    , AH2O ,ZH2O, 1.0    ,-2   , WH2O)      
      CALL GSMATE( 4,'Liquid Ar', 39.95, 18., 1.39   , 14.0, 84.0, 0,0)             
      CALL GSMATE( 5,'Aluminium', 26.98, 13., 2.7    ,  8.9, 37.2, 0,0)
      CALL GSMATE( 6,'Iron     ', 55.85, 26., 7.87   , 1.76, 17.1, 0,0)             
      CALL GSMATE( 7,'Lead     ',207.19, 82., 11.35  , 0.56, 18.5, 0,0)              
      CALL GSMATE( 8,'Uranium  ',238.03, 92., 18.95  , 0.32, 12. , 0,0)                    
*                                               
*                                                                               
* *** Defines USER tracking media parameters
      IFIELD = 0                                                             
      IF (Field.GT.0.) IFIELD = 3
      FIELDM = 10*Field                                                               
      TMAXFD = 10.0                                                             
      STEMAX = 1000.                                                            
      DEEMAX = 0.20                                                            
      EPSIL  = 0.001                                                           
      STMIN  = 0.010                                                           
*                                                                               
      CALL GSTMED( 1,'Container',Imat, 0 ,IFIELD,FIELDM,TMAXFD,                
     *               STEMAX,DEEMAX,EPSIL,STMIN, 0 , 0 )        
*
*
* *** Geometry                                                                               
      PAR(1) = BoxSize/2.                                                               
      PAR(2) = BoxSize/2.                                                               
      PAR(3) = BoxSize/2.                                                               
      CALL GSVOLU('aBox','BOX ',1,PAR,3,IVOL)                     
*                                                                               
* *** Close geometry banks. (obligatory system routine)                         
      CALL GGCLOS                                                               
*
*
* *** dessin
      CALL GSATT ('*','SEEN',1)
*
      DO IX = 1,3
        CALL GDOPEN (IX)
        SCALE =   18./BoxSize
        PAXIS =   0.
        SAXIS =   1.
        CALL GDRAWC ('aBox',IX,0.,10.,9.3,SCALE,SCALE)
        CALL GDAXIS (PAXIS,PAXIS,PAXIS,SAXIS)
        CALL GDSCAL (10. , 0.3)
        CALL GDCLOS
      END DO
*
                                                                               
      END                                                                       
+DECK,UHINIT.                                                                   
      SUBROUTINE UHINIT                                                         
*                                                                               
*     To book the user's histograms                                             
*
      CALL HBOOK1(1,'track length (mm) of a charged particle',
     +              100,0.,500.,0.)
      CALL HBOOK1(2,'Nb of steps per track (charged particle)',
     +              100,0.,100.,0.)
      CALL HBOOK1(3,'step length (mm)  charged particle',
     +              100,0.,10. ,0.)                                                                                                                                                                                           
*                                                                               
      END                                                                       
+DECK,GUKINE                                                                    
      SUBROUTINE GUKINE                                                         
*                                                                               
*    Generates Kinematics for primary track
*
*    Data card Kine : Itype  Ekine                                       
*                                                                               
+SEQ,GCBANK,GCFLAG,GCKINE.                                                                                                                           
*                                                                               
      DIMENSION VERTEX(3),PLAB(3)
*                                                     
      DATA VERTEX/3*0./
      DATA PLAB  /3*0./                                                                                                                  
*
*                                                                  
      CALL GSVERT(VERTEX,0,0,0,0,NVERT)
*
*
      JPA     = LQ(JPART-IKINE)
      XMASS   =  Q(JPA+7)
      PLAB(1) = SQRT(PKINE(1)*(PKINE(1)+2*XMASS))                                       
*                                                          
      CALL GSKINE(PLAB,IKINE,NVERT,0,0,NT)                           
*                                                                   
* *** Kinematics debug                     
      IF (IEVENT.EQ.1.OR.IDEBUG.NE.0) CALL GPRINT('KINE',0)                                                                     
*                                                                               
      END                                                                       
+DECK,GUTREV                                                          
      SUBROUTINE GUTREV                                                         
*                                                                               
*     User routine to control tracking of one event                 
*     Called by GRUN                                                            
*                                                                     
+SEQ,CELOSS                                                                     
*                                                                          
      ETOT = 0.                                                               
*                                                                               
      CALL GTREVE                                                               
*                                                                               
      END 
+DECK,GUTRAK                                                          
      SUBROUTINE GUTRAK                                                         
*                                                                               
*     User routine to control tracking of one track                 
*     Called by GTREVE                                                            
*
+SEQ,GCKINE.
+SEQ,GCTRAK.                                                                     
+SEQ,CELOSS.                                                                     
*                                                                                                                                         
*
* *** initialisation track per track
      NSTRK0 = 0
      NSTRK1 = 0
*                                                                                     
      CALL GTRACK
*
* *** count nb of tracks
      IF (CHARGE.NE.0.) THEN
           NTRAK1 = NTRAK1 + 1
	   CALL HFILL (1,SLENG*10,0.,1.)
	   CALL HFILL (2,REAL(NSTRK1),0.,1.)
      ELSE 
           NTRAK0 = NTRAK0 + 1
      ENDIF                                                                     
*                                                                               
      END                                                                            
+DECK,GUSTEP                                                                    
      SUBROUTINE GUSTEP                                                         
*                                                                               
*     User routine called at the end of each tracking step           
*                                                               
+SEQ,GCFLAG.
+SEQ,GCKINE,GCKING,GCTRAK.                                 
+SEQ,CELOSS.                                                             
*                                                                               
*                                                                               
* *** Debug event and store tracks for drawing
      IF (IDEBUG.NE.0)   CALL GPCXYZ      
      IF ((ISWIT(1).EQ.1).AND.(CHARGE.NE.0.)) CALL GSXYZ
      IF  (ISWIT(1).EQ.2)                     CALL GSXYZ                        
*                                                                               
* *** Something generated ?                                                     
      IF(NGKINE.GT.0) CALL GSKING(0)                                            
*                                                                               
* *** Energy deposited                                                          
      ETOT = ETOT + DESTEP
*
* *** count number of steps
      IF (CHARGE.NE.0.) THEN
           NSTEP1 = NSTEP1 + 1
	   NSTRK1 = NSTRK1 + 1
	   CALL HFILL (3,STEP*10,0.,1.)
      ELSE 
           NSTEP0 = NSTEP0 + 1
	   NSTRK0 = NSTRK0 + 1
      ENDIF                                                          
*
* *** count nb of invoked processes
      IF (NMEC.GT.0) THEN
        DO IM = 1,NMEC
          IPROC = LMEC(IM)
          IF (IPROC.EQ.21) IPROC = 12
          IF (IPROC.LE.12) NBCALL(IPROC) = NBCALL(IPROC)+1
        ENDDO
      ENDIF
         
      END                                                                       
+DECK,GUOUT                                                                     
      SUBROUTINE GUOUT                                                          
*                                                                               
*     User routine called at the end of each event                              
*                                                                               
+SEQ,GCFLAG.
+SEQ,CELOSS.
*
      CHARACTER*4 unit                                                              
*                                                                               
* *** drawing
*
+self,if=-batch.                                                          
        IF (ISWIT(1).NE.0) THEN
         CALL GDHEAD (110110,'TestEm1',0.)
         CALL GDSHOW (3)
         CALL GDXYZ  (0)
      END IF
+self.      
*
*     energy deposited
*                                                                                
      CALL GEVKEV (ETOT,ETunit,unit)                                                 
      IF (ISWIT(1).NE.0) PRINT 750,ETunit,unit
*      
  750 FORMAT(1X,'Energy deposit: ',F8.3,A4)    
*                                                                                
      END                                                                       
+DECK,UGLAST                                                                    
      SUBROUTINE UGLAST                                                         
*                                                                               
*     Termination routine to print histograms and statistics                    
*                                                                               
+SEQ,GCFLAG.
+SEQ,GCTRAK.
+SEQ,CELOSS.                                                      

*
* *** nb of steps and tracks per event
      TOTEVT = IEVENT
      FNTRK0 = NTRAK0/TOTEVT
      FNTRK1 = NTRAK1/TOTEVT
      FNSTP0 = NSTEP0/TOTEVT
      FNSTP1 = NSTEP1/TOTEVT
      PRINT 750, FNTRK0,FNTRK1,FNSTP0,FNSTP1
*
* *** frequency of processes call
      CALL UCTOH('MUNU',NAMEC(12),4,4)
      PRINT 760,(NAMEC(I),I=1,12)
      PRINT 761,(NBCALL(I)/TOTEVT,I=1,12)      
*                                                                                                                        
* *** geant termination                                                                               
      CALL GLAST
*
* *** print  selected histo                                                      

*
* *** close HIGZ file
      CALL HPLEND
*                                                                               
* *** Save selected histograms                                                  
      IF (ISWIT(2).EQ.1) THEN                                                   
         CALL HRPUT(0,'testem1.histo','N')                                                                        
      ENDIF                                                                     
*
* *** formats            
  750 FORMAT(//,1X,'nb tracks/event neutral: ',F9.2,'  charged: ',F9.2,
     +        /,1X,'nb steps/event  neutral: ',F9.2,'  charged: ',F9.2)
     
  760 FORMAT(//,1X,'nb of process calls per event: ',
     +        /,3X,12A9)
  761 FORMAT(   3X,12F9.2,//)
*
      END
+DECK,ffread,T=data.      
LIST
CALOR   5 (Imat) 2000. (size) 0. (field)
TRIG    100
KINE    3 (Itype)   0.100 (Ekine)
DEBUG   10  5 1000
SWIT    0 (draw) 0 (save)
CUTS    10.e-6 (cutgam)    10.e-6 (cutele)  3*10.e-3 (cutneu/had/muo)
      2*10.e-6 (bcute/m) 2*10.e-6 (dcute/m)   10.e-3 (ppcutm) 
ABAN    0
LOSS    1
TIME    2=1.
+QUIT.
