g3routines.F

Go to the documentation of this file.

*    
*     ********************************************************************
*     * License and Disclaimer                                           *
*     *                                                                  *
*     * The  Geant4 software  is  copyright of the Copyright Holders  of *
*     * the Geant4 Collaboration.  It is provided  under  the terms  and *
*     * conditions of the Geant4 Software License,  included in the file *
*     * LICENSE and available at  http://cern.ch/geant4/license .  These *
*     * include a list of copyright holders.                             *
*     *                                                                  *
*     * Neither the authors of this software system, nor their employing *
*     * institutes,nor the agencies providing financial support for this *
*     * work  make  any representation or  warranty, express or implied, *
*     * regarding  this  software system or assume any liability for its *
*     * use.  Please see the license in the file  LICENSE  and URL above *
*     * for the full disclaimer and the limitation of liability.         *
*     *                                                                  *
*     * This  code  implementation is the result of  the  scientific and *
*     * technical work of the GEANT4 collaboration.                      *
*     * By using,  copying,  modifying or  distributing the software (or *
*     * any work based  on the software)  you  agree  to acknowledge its *
*     * use  in  resulting  scientific  publications,  and indicate your *
*     * acceptance of all terms of the Geant4 Software license.          *
*     ********************************************************************
*    
*    
*     $Id: g3routines.F 67982 2013-03-13 10:36:03Z gcosmo $
*    
#define CALL_GEANT

#ifndef CALL_GEANT
      subroutine gsvolu(name, shape, nmed, par, npar, ivol)
#else 
      subroutine ksvolu(name, shape, nmed, par, npar, ivol)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*4, shape*4, fmt*150
      integer nmed, npar, ivol, k
      real par(npar)
      character rname*6
#include "G3toG4.inc"
      data rname /'GSVOLU'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsvolu(name, shape, nmed, par, npar, ivol)
#endif
      if (npar.ne.0) call checkshape(name, shape, par, npar)
*     
      if (lunlist.ne.0) then
*        write(lunlist,
*     +    '(a4,1x,a6,1x,a4,1x,a4,2i5,<npar>e15.8)')
*     +    context, rname, name, shape, nmed, npar,
*     +    (par(k),k=1,npar)
         write(fmt,'(A,I2,A)')'(a4,1x,a6,1x,a4,1x,a4,2i5,',max(npar,1),
     >        '(1x,e16.8))'
         write(lunlist,fmt) context, rname, name, shape, nmed, npar,
     +        (par(k),k=1,npar)
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call g3ldpar(par,npar)
         write(luncode,1000) name, shape, nmed, npar
 1000    format('G4gsvolu(name="',a,'",shape="',a,'",nmed=',i5,
     +        ',par,npar=',i4,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gspos(name, num, moth, x, y, z, irot, only)
#else 
      subroutine kspos(name, num, moth, x, y, z, irot, only)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*4, moth*4, only*4
      integer num, irot
      real x, y, z
      character rname*6
#include "G3toG4.inc"
      data rname /'GSPOS '/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gspos(name, num, moth, x, y, z, irot, only)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,1x,a4,i5,1x,a4,3(1x,e16.8),i5,1x,a4)')
     +        context, rname, name, num, moth, x, y, z, irot, only
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('x',x)
         call rtocp('y',y)
         call rtocp('z',z)
         write(luncode,1000) name,num,moth,irot,only
 1000    format('G4gspos(name="',a,'",num=',i5,',moth="',a,
     +        '",x,y,z,irot=',i5,',only="',a,'");')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsposp(name, num, moth, x, y, z, irot, only, par, npar)
#else 
      subroutine ksposp(name, num, moth, x, y, z, irot, only, par, npar)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*4, moth*4, only*4
      integer num, irot, npar, k
      real x, y, z, par(npar)
      character rname*6, fmt*150
#include "G3toG4.inc"
      data rname /'GSPOSP'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsposp(name, num, moth, x, y, z, irot, only,
     +     par, npar)
#endif
      if (lunlist.ne.0) then
         do k=1,npar
            if (abs(par(k)).gt.1.e10) then
               print *,'Warning: huge junk value in PAR for GSPOS'
               print *,'  zeroed out. Volume ',name
               par(k) = 0.
            endif
         enddo
*        write(lunlist,
*     +    '(a4,1x,a6,1x,a4,i5,1x,a4,3e15.8,i5,1x,a4,
*     +    i5,<npar>e15.8)')
*     +    context, rname, name, num, moth, x, y, z, irot, only,
*     +    npar,
*     +    (par(k),k=1,npar)
         write(fmt,'(A,A,I2,A)')
     >        '(a4,1x,a6,1x,a4,i5,1x,a4,3(1x,e16.8),',       
     +        'i5,1x,a4,i5,',max(npar,1),'(1x,e16.8))'
         write(lunlist,fmt)
     +        context, rname, name, num, moth, x, y, z, irot, only,
     +        npar,
     +        (par(k),k=1,npar)
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('x',x)
         call rtocp('y',y)
         call rtocp('z',z)
         call g3ldpar(par,npar)
         write(luncode,1000) name,num,moth,irot,only,npar
 1000    format('G4gsposp(name="',a,'",num=',i5,',moth="',a,
     +        '",x,y,z,irot=',i5,',only="',a,'",par,npar=',i4,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsatt(name, attr, ival)
#else 
      subroutine ksatt(name, attr, ival)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*4, attr*4
      integer ival
      character rname*6
#include "G3toG4.inc"
      data rname /'GSATT '/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsatt(name, attr, ival)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,1x,a4,1x,a4,i12)')
     +        context, rname, name, attr, ival
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         write(luncode,1000) name,attr,ival
 1000    format('G4gsatt(name="',a,'",attr="',a,'",ival=',i10,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsrotm(irot, theta1, phi1, theta2, phi2,
     +     theta3, phi3)
#else 
      subroutine ksrotm(irot, theta1, phi1, theta2, phi2,
     +     theta3, phi3)
#endif
************************************************************************
************************************************************************
      implicit none
      integer irot
      real theta1, phi1, theta2, phi2, theta3, phi3
      character rname*6
#include "G3toG4.inc"
      data rname /'GSROTM'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsrotm(irot, theta1, phi1, theta2, phi2,
     +     theta3, phi3)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,i5,6f11.5)')
     +        context, rname, irot, theta1, phi1, theta2, phi2,
     +        theta3, phi3
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('theta1',theta1)
         call rtocp('phi1',phi1)
         call rtocp('theta2',theta2)
         call rtocp('phi2',phi2)
         call rtocp('theta3',theta3)
         call rtocp('phi3',phi3)
         write(luncode,1000) irot
 1000    format('G4gsrotm(irot=',i5,
     +        ',theta1,phi1,theta2,phi2,theta3,phi3);')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdvn(name, moth, ndiv, iaxis)
#else 
      subroutine ksdvn(name, moth, ndiv, iaxis)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*4, moth*4
      integer ndiv, iaxis
      character rname*6
#include "G3toG4.inc"
      data rname /'GSDVN '/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdvn(name, moth, ndiv, iaxis)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,1x,a4,1x,a4,i5,i3)')
     +        context, rname, name, moth, ndiv, iaxis
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         write(luncode,1000) name, moth, ndiv, iaxis
 1000    format('G4gsdvn(name="',a,'",moth="',a,'",ndiv=',i3,
     +        ',iaxis=',i1,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdvt(name, moth, step, iaxis, numed, ndvmx)
#else 
      subroutine ksdvt(name, moth, step, iaxis, numed, ndvmx)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*4, moth*4
      real step
      integer iaxis, numed, ndvmx
      character rname*6
#include "G3toG4.inc"
      data rname /'GSDVT '/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdvt(name, moth, step, iaxis, numed, ndvmx)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,1x,a4,1x,a4,(1x,e16.8),3i5)')
     +        context, rname, name, moth, step, iaxis, numed, ndvmx
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('step',step)
         write(luncode,1000) name,moth,iaxis,numed,ndvmx
 1000    format('G4gsdvt(name="',a,'",moth="',a,'",step,iaxis=',
     +        i1,',numed=',i4,',ndvmx=',i4,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdvx(name, moth, ndiv, iaxis, step, c0, numed, ndvmx)
#else 
      subroutine ksdvx(name, moth, ndiv, iaxis, step, c0, numed, ndvmx)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*4, moth*4
      integer ndiv, iaxis, numed, ndvmx
      real step, c0
      character rname*6
#include "G3toG4.inc"
      data rname /'GSDVX '/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdvx(name, moth, ndiv, iaxis, step, c0, numed,
     +     ndvmx)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,1x,a4,1x,a4,i5,i3,2(1x,e16.8),2i5)')
     +        context, rname, name, moth, ndiv, iaxis,step, c0,
     +        numed, ndvmx
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('step',step)
         call rtocp('c0',c0)
         write(luncode,1000) name,moth,ndiv,iaxis,numed,ndvmx
 1000    format('G4gsdvx(name="',a,'",moth="',a,'",ndiv=',i3,',iaxis=',
     +        i1,',step,c0,numed=',i4,',ndvmx=',i4,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdvn2(name, moth, ndiv, iaxis, c0, numed)
#else 
      subroutine ksdvn2(name, moth, ndiv, iaxis, c0, numed)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*4, moth*4
      integer ndiv, iaxis, numed
      real c0
      character rname*6
#include "G3toG4.inc"
      data rname /'GSDVN2'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdvn2(name, moth, ndiv, iaxis, c0, numed)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,1x,a4,1x,a4,i5,i3,(1x,e16.8),i5)')
     +        context, rname, name, moth, ndiv, iaxis, c0, numed
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('c0',c0)
         write(luncode, 1000) name,moth,ndiv,iaxis,numed
 1000    format('G4gsdvn2(name="',a,'",moth="',a,'",ndiv=',i3,',iaxis=',
     +        i1,',c0,numed=',i4,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdvt2(name, moth, step, iaxis, c0, numed, ndvmx)
#else 
      subroutine ksdvt2(name, moth, step, iaxis, c0, numed, ndvmx)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*4, moth*4
      integer iaxis, numed, ndvmx
      real step, c0
      character rname*6
#include "G3toG4.inc"
      data rname /'GSDVT2'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdvt2(name, moth, step, iaxis, c0, numed, ndvmx)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,1x,a4,1x,a4,(1x,e16.8),i3,(1x,e16.8),2i5)')
     +        context, rname, name, moth, step, iaxis, c0, numed, ndvmx
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('step',step)
         call rtocp('c0',c0)
         write(luncode,1000) name,moth,iaxis,numed,ndvmx
 1000    format('G4gsdvt2(name="',a,'",moth="',a,'",step,iaxis=',
     +        i1,',c0,numed=',i4,',ndvmx=',i4,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsmate(imate, name, a, z, dens, radl, absl, ubf, nwbf)
#else 
      subroutine ksmate(imate, name, a, z, dens, radl, absl, ubf, nwbf)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*(*)
      integer imate, nwbf, k
      real a, z, dens, radl, absl, ubf(nwbf)
      character rname*6, fmt*150
#include "G3toG4.inc"
      data rname /'GSMATE'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsmate
     +     (imate, name, a, z, dens, radl, absl, ubf, nwbf)
#endif
      if (lunlist.ne.0) then
         write(fmt,'(A,I3,A)')
     >        '(a4,1x,a6,i5,1x,''"'',a,''"'',4(1x,e16.8),i3,',
     >        max(nwbf,1),'(1x,e16.8))'
         write(lunlist,fmt)
     +        context, rname, imate, name, a, z, dens, radl,
     +        nwbf, (ubf(k), k=1,nwbf)
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('a',a)
         call rtocp('z',z)
         call rtocp('dens',dens)
         call rtocp('radl',radl)
         call g3ldpar(ubf,nwbf)
         write(luncode,1000) imate, name, nwbf
 1000    format('G4gsmate(imate=',i4,',name="',a,
     +        '",a,z,dens,radl,npar=',i4,',par);')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsmixt(imate, name, a, z, dens, nlmat, wmat)
#else 
      subroutine ksmixt(imate, name, a, z, dens, nlmat, wmat)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*(*)
      integer imate, nlmat, k, nlmata
      real a(*), z(*), dens, wmat(*)
      character rname*6, fmt*150
#include "G3toG4.inc"
      data rname /'GSMIXT'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsmixt
     +     (imate, name, a, z, dens, nlmat, wmat)
#endif
      if (lunlist.ne.0) then
         nlmata = abs(nlmat)
         write(fmt,'(A,I3,A,I3,A,I3,A)')
     +        '(a4,1x,a6,i5,1x,''"'',a,''"'',1x,e16.8,1x,i3,',
     >        max(nlmata,1),
     >        '(1x,e16.8),',max(nlmata,1),'(1x,e16.8),',
     >        max(nlmata,1),'(1x,e16.8))'
         write(lunlist,fmt)
     +        context, rname, imate, name, dens,
     +        nlmat, 
     +        (a(k), k=1,abs(nlmat)),
     +        (z(k), k=1,abs(nlmat)),
     +        (wmat(k), k=1,abs(nlmat))
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('dens',dens)
         call artocp('aa',a,abs(nlmat))
         call artocp('zz',z,abs(nlmat))
         call artocp('wmat',wmat,abs(nlmat))
         write(luncode,1000) imate,name,nlmat
 1000    format('G4gsmixt(imate=',i5,',name="',a,
     +        '",aa,zz,dens,nlmat=',i3,',wmat);')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gstmed(
     +     itmed, name, nmat, isvol, ifield, fieldm,
     +     tmaxfd, stemax, deemax, epsil, stmin, ubuf, nwbuf)
#else 
      subroutine kstmed(
     +     itmed, name, nmat, isvol, ifield, fieldm,
     +     tmaxfd, stemax, deemax, epsil, stmin, ubuf, nwbuf)
#endif
************************************************************************
************************************************************************
      implicit none
      character name*(*)
      integer itmed, nmat, isvol, ifield, nwbuf, k
      real fieldm, tmaxfd, stemax, deemax, epsil, stmin, ubuf(nwbuf)
      character rname*6, fmt*150
#include "G3toG4.inc"
      data rname /'GSTMED'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gstmed(
     +     itmed, name, nmat, isvol, ifield, fieldm,
     +     tmaxfd, stemax, deemax, epsil, stmin, ubuf, nwbuf)
#endif
      if (lunlist.ne.0) then
*         write(lunlist,
*     +        '(a4,1x,a6,i5,1x,''"'',a,''"'',3i3,6e15.8,i3,<nwbuf>e15.8)')
*     +        context, rname, itmed, name, nmat, isvol, ifield, fieldm,
*     +        tmaxfd, stemax, deemax, epsil, stmin,
*     +        nwbuf, (ubuf(k),k=1,nwbuf)
         write(fmt,'(A,I3,A)') 
     >        '(a4,1x,a6,i5,1x,''"'',a,''"'',3i3,6(1x,e16.8),i3,',
     >        max(nwbuf,1),'(1x,e16.8))'
         write(lunlist,fmt)
     +        context, rname, itmed, name, nmat, isvol, ifield, fieldm,
     +        tmaxfd, stemax, deemax, epsil, stmin,
     +        nwbuf, (ubuf(k),k=1,nwbuf)
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('fieldm',fieldm)
         call rtocp('tmaxfd',tmaxfd)
         call rtocp('stemax',stemax)
         call rtocp('deemax',deemax)
         call rtocp('epsil',epsil)
         call rtocp('stmin',stmin)
         call g3ldpar(ubuf,nwbuf)
         write(luncode,1000) itmed,name,nmat,isvol,ifield,nwbuf
 1000    format('G4gstmed(itmed=',i4,',name="',a,'",nmat=',i4,
     +        ',isvol=',i2,',ifield=',i2,',',/
     +        '    fieldm,tmaxfd,stemax,deemax,epsil,stmin,par,npar=',
     +        i4,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gstpar(itmed, chpar, parval)
#else 
      subroutine kstpar(itmed, chpar, parval)
#endif
************************************************************************
************************************************************************
      implicit none
      character chpar*(*)
      integer itmed
      real parval
      character rname*6
#include "G3toG4.inc"
      data rname /'GSTPAR'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gstpar (itmed, chpar, parval)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,i5,1x,a4,(1x,e16.8))')
     +        context, rname, itmed, chpar, parval
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         write(luncode,1000) itmed, chpar, parval
 1000    format('G4gstpar(itmed=',i4,',chpar="',a,'",parval=',
     +        (1x,e16.8),');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gspart(
     +     ipart, chpar, itrtyp, amass, charge, tlife, ub, nwb)
#else 
      subroutine kspart(
     +     ipart, chpar, itrtyp, amass, charge, tlife, ub, nwb)
#endif
************************************************************************
************************************************************************
      implicit none
      character chpar*(*)
      integer ipart, itrtyp, nwb, k
      real amass, charge, tlife, ub(nwb)
      character rname*6, fmt*150
#include "G3toG4.inc"
      data rname /'GSPART'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gspart(
     +     ipart, chpar, itrtyp, amass, charge, tlife, ub, nwb)
#endif
      if (lunlist.ne.0) then
*         write(lunlist,
*     +        '(a4,1x,a6,i5,1x,''"'',a,''"'',i3,3e15.8,i3,<nwb>e15.8)')
*     +        context, rname, ipart, chpar, itrtyp, amass, charge, tlife,
*     +        nwb, (ub(k), k=1,nwb)
         write(fmt,'(A,I3,A)') 
     >        '(a4,1x,a6,i5,1x,''"'',a,''"'',i3,3(1x,e16.8),i3,',        
     >        max(nwb,1),'(1x,e16.8))'
         write(lunlist,fmt)
     +        context, rname, ipart, chpar, itrtyp, amass, charge, 
     >        tlife,
     +        nwb, (ub(k), k=1,nwb)
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call rtocp('amass',amass)
         call rtocp('charge',charge)
         call rtocp('tlife',tlife)
         call g3ldpar(ub,nwb)
         write(luncode,1000) ipart,chpar,itrtyp,nwb
 1000    format('G4gspart(ipart=',i8,',chpar="',a,'",itrtyp=',i8,
     +        ',amass,charge,'/'         tlife,par,npar=',i4,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdk(ipart, bratio, mode)
#else 
      subroutine ksdk(ipart, bratio, mode)
#endif
************************************************************************
************************************************************************
      implicit none
      integer ipart, mode(6)
      real bratio(6)
      character rname*6
#include "G3toG4.inc"
      data rname /'GSDK  '/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdk(ipart, bratio, mode)
#endif
      if (lunlist.ne.0) then
***   6 is prefixed to the arrays for consistency with other
***   array treatments (count precedes the array)
         write(lunlist,
     +        '(a4,1x,a6,i5,i3,6(1x,e16.8),6i8)')
     +        context, rname, ipart, 6, bratio, mode
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call artocp('bratio',bratio,6)
         call aitocp('mode',mode,6)
         write(luncode,1000) ipart
 1000    format('G4gsdk(ipart=',i8,',bratio,mode);')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdet(chset, chdet, nv, chnam, nbits, idtyp, nwhi,
     +     nwdi, iset, idet)
#else 
      subroutine ksdet(chset, chdet, nv, chnam, nbits, idtyp, nwhi,
     +     nwdi, iset, idet)
#endif
************************************************************************
************************************************************************
      implicit none
      integer nv, nbits(nv), idtyp, nwhi, nwdi, iset, idet, k
      character rname*6, chset*4, chdet*4, chnam(nv)*4, fmt*150
#include "G3toG4.inc"
      data rname /'GSDET '/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdet(chset, chdet, nv, chnam, nbits, idtyp,
     +     nwhi, nwdi, iset, idet)
#endif
      if (lunlist.ne.0) then
*         write(lunlist,
*     +        '(a4,1x,a6,1x,a4,1x,a4,i5,<nv>(1x,a4),<nv>i10,i10,2i5)')
*     +        context, rname, chset, chdet, nv, (chnam(k), k=1,nv),
*     +        (nbits(k), k=1,nv), idtyp, nwhi, nwdi
         write(fmt,'(A,I3,A,I3,A)')'(a4,1x,a6,1x,a4,1x,a4,i5,',
     >        max(nv,1),'(1x,a4),',max(nv,1),'i10,i10,2i5)'
         write(lunlist,fmt)
     +        context, rname, chset, chdet, nv, (chnam(k), k=1,nv),
     +        (nbits(k), k=1,nv), idtyp, nwhi, nwdi
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call astocp('chnam',chnam,nv)
         call aitocp('nbits',nbits,nv)
         write(luncode,1000) chset, chdet, nv, idtyp, nwhi, nwdi
 1000    format('G4gsdet(chset="',a,'",chdet="',a,'",nv=',i3,
     +        ',chnam,nbits,idtyp=',i8,','/
     +        '        nwhi=',i8,',nwdi=',i8,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdetv(chset, chdet, idtyp, nwhi, nwdi, iset, idet)
#else 
      subroutine ksdetv(chset, chdet, idtyp, nwhi, nwdi, iset, idet)
#endif
************************************************************************
************************************************************************
      implicit none
      integer idtyp, nwhi, nwdi, iset, idet
      character rname*6, chset*4, chdet*4
#include "G3toG4.inc"
      data rname /'GSDETV'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdetv(chset, chdet, idtyp,
     +     nwhi, nwdi, iset, idet)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,1x,a4,1x,a4,i10,2i5)')
     +        context, rname, chset, chdet, idtyp, nwhi, nwdi
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         write(luncode,1000) chset, chdet, idtyp, nwhi, nwdi
 1000    format('G4gsdetv(chset="',a,'",chdet="',a,'",idtyp=',i8,
     +        ',nwhi=',i8,',nwdi=',i8,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdeta(chset, chdet, chali, nwhi, nwdi, iali)
#else 
      subroutine ksdeta(chset, chdet, chali, nwhi, nwdi, iali)
#endif
************************************************************************
************************************************************************
      implicit none
      integer nwhi, nwdi, iali
      character rname*6, chset*4, chdet*4, chali*4
#include "G3toG4.inc"
      data rname /'GSDETA'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdeta(chset, chdet, chali, nwhi, nwdi, iali)
#endif
      if (lunlist.ne.0) then
         write(lunlist,
     +        '(a4,1x,a6,1x,a4,1x,a4,1x,a4,2i5)')
     +        context, rname, chset, chdet, chali, nwhi, nwdi
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         write(luncode,1000) chset, chdet, chali, nwhi, nwdi
 1000    format('G4gsdeta(chset="',a,'",chdet="',a,'",chali="',a,
     +        '",nwhi=',i8,',nwdi=',i8,');')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdeth(chset, chdet, nh, chnam, nbits, orig, fact)
#else 
      subroutine ksdeth(chset, chdet, nh, chnam, nbits, orig, fact)
#endif
************************************************************************
************************************************************************
      implicit none
      integer nh, nbits(nh), k
      real orig(nh), fact(nh)
      character rname*6, chset*4, chdet*4, chnam(nh)*4, fmt*150
#include "G3toG4.inc"
      data rname /'GSDETH'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdeth(chset, chdet, nh, chnam, nbits,
     +     orig, fact)
#endif
      if (lunlist.ne.0) then
*         write(lunlist,
*     +        '(a4,1x,a6,1x,a4,1x,a4,i5,<nh>(1x,a4),<nh>i5,<nh>e15.8,
*     +        <nh>e15.8)')
*     +        context, rname, chset, chdet, nh, (chnam(k), k=1,nh),
*     +        (nbits(k), k=1,nh), (orig(k), k=1,nh), (fact(k), k=1,nh)
         write(fmt,'(A,I3,A,I3,A,I3,A,I3,A)')
     >        '(a4,1x,a6,1x,a4,1x,a4,i5,',max(nh,1),'(1x,a4),',
     >        max(nh,1),'i5,',max(nh,1),'(1x,e16.8),',max(nh,1),
     >        '(1x,e16.8))'
         write(lunlist, fmt)
     +        context, rname, chset, chdet, nh, (chnam(k), k=1,nh),
     +        (nbits(k), k=1,nh), (orig(k), k=1,nh), (fact(k), k=1,nh)
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call astocp('chnam',chnam,nh)
         call aitocp('nbits',nbits,nh)
         call artocp('orig',orig,nh)
         call artocp('fact',fact,nh)
         write(luncode,1000) chset,chdet,nh
 1000    format('G4gsdeth(chset="',a,'",chdet="',a,'",nh=',i4,
     +        ',chnam,nbits,orig,fact);')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdetd(chset, chdet, nd, chnam, nbits)
#else 
      subroutine ksdetd(chset, chdet, nd, chnam, nbits)
#endif
************************************************************************
************************************************************************
      implicit none
      integer nd, nbits(nd), k
      character rname*6, chset*4, chdet*4, chnam(nd)*4, fmt*150
#include "G3toG4.inc"
      data rname /'GSDETD'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdetd(chset, chdet, nd, chnam, nbits)
#endif
      if (lunlist.ne.0) then
*         write(lunlist,
*     +        '(a4,1x,a6,1x,a4,1x,a4,i5,<nd>(1x,a4),<nd>i5)')
*     +        context, rname, chset, chdet, nd, (chnam(k), k=1,nd),
*     +        (nbits(k), k=1,nd)
         write(fmt,'(A,I3,A,I3,A)')
     +        '(a4,1x,a6,1x,a4,1x,a4,i5,',max(nd,1),'(1x,a4),',
     >        max(nd,1),'i5)'
         write(lunlist,fmt)
     +        context, rname, chset, chdet, nd, (chnam(k), k=1,nd),
     +        (nbits(k), k=1,nd)
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call astocp('chnam',chnam,nd)
         call aitocp('nbits',nbits,nd)
         write(luncode,1000) chset, chdet, nd
 1000    format('G4gsdetd(chset="',a,'",chdet="',a,'",nd=',i4,
     +        ',chnam,nbits);')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine gsdetu(chset, chdet, nupar, upar)
#else 
      subroutine ksdetu(chset, chdet, nupar, upar)
#endif
************************************************************************
************************************************************************
      implicit none
      integer nupar, k
      real upar(nupar)
      character rname*6, chset*4, chdet*4, fmt*150
#include "G3toG4.inc"
      data rname /'GSDETU'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call gsdetu(chset, chdet, nupar, upar)
#endif
      if (lunlist.ne.0) then
*         write(lunlist,
*     +        '(a4,1x,a6,1x,a4,1x,a4,i5,<nupar>e15.8)')
*     +        context, rname, chset, chdet, nupar, (upar(k), k=1,nupar)
         write(fmt,'(A,I3,A)')
     +        '(a4,1x,a6,1x,a4,1x,a4,i5,',max(nupar,1),'(1x,e16.8))'
         write(lunlist,fmt)
     +        context, rname, chset, chdet, nupar, (upar(k), k=1,nupar)
      endif
      if (luncode.ne.0) then
         write(luncode,'(''{'')')
         call g3ldpar(upar,nupar)
         write(luncode,1000) chset, chdet, nupar
 1000    format('G4gsdetu(chset="',a,'",chdet="',a,'",npar=',
     +        i4,',par);')
         write(luncode,'(''}'')')
      endif
*     
      end
*     
#ifndef CALL_GEANT
      subroutine ggclos
#else 
      subroutine kgclos
#endif
************************************************************************
************************************************************************
      implicit none
      character rname*6
#include "G3toG4.inc"
      data rname /'GGCLOS'/
*     
      call check_lines
#ifdef CALL_GEANT
      if (dogeom) call ggclos
#endif
      if (lunlist.ne.0) then
         write(lunlist,'(a4,1x,a6)') context, rname
         close(lunlist)
      endif
      if (luncode.ne.0) then
         write(luncode,'(''//GeoMgr->CloseGeometry();'')')
         write(luncode,'(''}'')')
         call g3main
         close(luncode)
      endif
*     
      end

      subroutine checkshape(name, shape, par, npar)
      implicit none
************************************************************************
* convert TRAP, PARA and GTRA to external form
************************************************************************
      character name*4, shape*4
      real ph, par(*), tt, raddeg
      integer npar
      
      raddeg = 180./3.1415926

      if (shape(1:3).eq.'BOX'.and.npar.ne.3) then
         print *,'!! error, BOX with ',npar,' parameters, vol ',name
      endif
      if (shape.eq.'TRD1'.and.npar.ne.4) then
         print *,'!! error, TRD1 with ',npar,' parameters, vol ',name
      endif
      if (shape.eq.'TRD2'.and.npar.ne.5) then
         print *,'!! error, TRD2 with ',npar,' parameters, vol ',name
      endif
      if (shape.eq.'TRAP'.and.npar.ne.35.and.npar.ne.11) then
***   G3 sets 11 to 35. Why?
         print *,'!! error, TRAP with ',npar,' parameters, vol ',name
      endif
      if (shape.eq.'TUBE'.and.npar.ne.3) then
         print *,'!! error, TUBE with ',npar,' parameters, vol ',name
      endif
      if (shape.eq.'TUBS'.and.npar.ne.5) then
         print *,'!! error, TUBS with ',npar,' parameters, vol ',name
      endif
      if (shape.eq.'CONE'.and.npar.ne.5) then
         print *,'!! error, CONE with ',npar,' parameters, vol ',name
      endif
      if (shape.eq.'CONS'.and.npar.ne.7) then
         print *,'!! error, CONS with ',npar,' parameters, vol ',name
      endif
      if (shape.eq.'SPHE'.and.npar.ne.6) then
         print *,'!! error, SPHE with ',npar,' parameters, vol ',name
      endif
      if (shape.eq.'PARA'.and.npar.ne.6) then
         print *,'!! error, PARA with ',npar,' parameters, vol ',name
      endif
      if (shape.eq.'PARA') then
*
*  **    PARA
*
         ph = 0.
         if (par(5).ne.0.) ph = atan2(par(6),par(5))*raddeg
         tt = sqrt(par(5)**2+par(6)**2)
         par(4) = atan(par(4))*raddeg
         if (par(4).gt.90.0) par(4) = par(4)-180.0
         par(5) = atan(tt)*raddeg
         if (ph.lt.0.0) ph = ph + 360.0
         par(6) = ph
      end if
      if (shape.eq.'TRAP') then
*
*  **    TRAP
*
         npar=11
         ph = 0.
         if (par(2).ne.0.) ph = atan2(par(3),par(2))*raddeg
         tt = sqrt(par(2)**2+par(3)**2)
         par(2) = atan(tt)*raddeg
         if (ph.lt.0.0) ph = ph+360.0
         par(3) = ph
         par(7) = atan(par(7))*raddeg
         if (par(7).gt.90.0) par(7) = par(7)-180.0
         par(11)= atan(par(11))*raddeg
         if (par(11).gt.90.0) par(11) = par(11)-180.0

      end if
      end