Context Navigation

g3routines.F @ 1232

Last change on this file since 1232 was 965, checked in by garnier, 15 years ago
update g3tog4
File size: 34.0 KB

Line
1	*
2	* ********************************************************************
3	* * License and Disclaimer *
4	* * *
5	* * The Geant4 software is copyright of the Copyright Holders of *
6	* * the Geant4 Collaboration. It is provided under the terms and *
7	* * conditions of the Geant4 Software License, included in the file *
8	* * LICENSE and available at http://cern.ch/geant4/license . These *
9	* * include a list of copyright holders. *
10	* * *
11	* * Neither the authors of this software system, nor their employing *
12	* * institutes,nor the agencies providing financial support for this *
13	* * work make any representation or warranty, express or implied, *
14	* * regarding this software system or assume any liability for its *
15	* * use. Please see the license in the file LICENSE and URL above *
16	* * for the full disclaimer and the limitation of liability. *
17	* * *
18	* * This code implementation is the result of the scientific and *
19	* * technical work of the GEANT4 collaboration. *
20	* * By using, copying, modifying or distributing the software (or *
21	* * any work based on the software) you agree to acknowledge its *
22	* * use in resulting scientific publications, and indicate your *
23	* * acceptance of all terms of the Geant4 Software license. *
24	* ********************************************************************
25	*
26	*
27	* $Id: g3routines.F,v 1.5 2006/06/29 18:15:10 gunter Exp $
28	* GEANT4 tag $Name: geant4-09-02-ref-02 $
29	*
30	#define CALL_GEANT
31
32	#ifndef CALL_GEANT
33	subroutine gsvolu(name, shape, nmed, par, npar, ivol)
34	#else
35	subroutine Ksvolu(name, shape, nmed, par, npar, ivol)
36	#endif
37	************************************************************************
38	************************************************************************
39	implicit none
40	character name4, shape4, fmt*150
41	integer nmed, npar, ivol, k
42	real par(npar)
43	character rname*6
44	#include "G3toG4.inc"
45	data rname /'GSVOLU'/
46	*
47	call check_lines
48	#ifdef CALL_GEANT
49	if (dogeom) call gsvolu(name, shape, nmed, par, npar, ivol)
50	#endif
51	if (npar.ne.0) call checkshape(name, shape, par, npar)
52	*
53	if (lunlist.ne.0) then
54	* write(lunlist,
55	* + '(a4,1x,a6,1x,a4,1x,a4,2i5,<npar>e15.8)')
56	* + context, rname, name, shape, nmed, npar,
57	* + (par(k),k=1,npar)
58	write(fmt,'(A,I2,A)')'(a4,1x,a6,1x,a4,1x,a4,2i5,',max(npar,1),
59	> '(1x,e16.8))'
60	write(lunlist,fmt) context, rname, name, shape, nmed, npar,
61	+ (par(k),k=1,npar)
62	endif
63	if (luncode.ne.0) then
64	write(luncode,'(''{'')')
65	call g3ldpar(par,npar)
66	write(luncode,1000) name, shape, nmed, npar
67	1000 format('G4gsvolu(name="',a,'",shape="',a,'",nmed=',i5,
68	+ ',par,npar=',i4,');')
69	write(luncode,'(''}'')')
70	endif
71	*
72	end
73	*
74	#ifndef CALL_GEANT
75	subroutine gspos(name, num, moth, x, y, z, irot, only)
76	#else
77	subroutine Kspos(name, num, moth, x, y, z, irot, only)
78	#endif
79	************************************************************************
80	************************************************************************
81	implicit none
82	character name4, moth4, only*4
83	integer num, irot
84	real x, y, z
85	character rname*6
86	#include "G3toG4.inc"
87	data rname /'GSPOS '/
88	*
89	call check_lines
90	#ifdef CALL_GEANT
91	if (dogeom) call gspos(name, num, moth, x, y, z, irot, only)
92	#endif
93	if (lunlist.ne.0) then
94	write(lunlist,
95	+ '(a4,1x,a6,1x,a4,i5,1x,a4,3(1x,e16.8),i5,1x,a4)')
96	+ context, rname, name, num, moth, x, y, z, irot, only
97	endif
98	if (luncode.ne.0) then
99	write(luncode,'(''{'')')
100	call rtocp('x',x)
101	call rtocp('y',y)
102	call rtocp('z',z)
103	write(luncode,1000) name,num,moth,irot,only
104	1000 format('G4gspos(name="',a,'",num=',i5,',moth="',a,
105	+ '",x,y,z,irot=',i5,',only="',a,'");')
106	write(luncode,'(''}'')')
107	endif
108	*
109	end
110	*
111	#ifndef CALL_GEANT
112	subroutine gsposp(name, num, moth, x, y, z, irot, only, par, npar)
113	#else
114	subroutine Ksposp(name, num, moth, x, y, z, irot, only, par, npar)
115	#endif
116	************************************************************************
117	************************************************************************
118	implicit none
119	character name4, moth4, only*4
120	integer num, irot, npar, k
121	real x, y, z, par(npar)
122	character rname6, fmt150
123	#include "G3toG4.inc"
124	data rname /'GSPOSP'/
125	*
126	call check_lines
127	#ifdef CALL_GEANT
128	if (dogeom) call gsposp(name, num, moth, x, y, z, irot, only,
129	+ par, npar)
130	#endif
131	if (lunlist.ne.0) then
132	do k=1,npar
133	if (abs(par(k)).gt.1.e10) then
134	print *,'Warning: huge junk value in PAR for GSPOS'
135	print *,' zeroed out. Volume ',name
136	par(k) = 0.
137	endif
138	enddo
139	* write(lunlist,
140	* + '(a4,1x,a6,1x,a4,i5,1x,a4,3e15.8,i5,1x,a4,
141	* + i5,<npar>e15.8)')
142	* + context, rname, name, num, moth, x, y, z, irot, only,
143	* + npar,
144	* + (par(k),k=1,npar)
145	write(fmt,'(A,A,I2,A)')
146	> '(a4,1x,a6,1x,a4,i5,1x,a4,3(1x,e16.8),',
147	+ 'i5,1x,a4,i5,',max(npar,1),'(1x,e16.8))'
148	write(lunlist,fmt)
149	+ context, rname, name, num, moth, x, y, z, irot, only,
150	+ npar,
151	+ (par(k),k=1,npar)
152	endif
153	if (luncode.ne.0) then
154	write(luncode,'(''{'')')
155	call rtocp('x',x)
156	call rtocp('y',y)
157	call rtocp('z',z)
158	call g3ldpar(par,npar)
159	write(luncode,1000) name,num,moth,irot,only,npar
160	1000 format('G4gsposp(name="',a,'",num=',i5,',moth="',a,
161	+ '",x,y,z,irot=',i5,',only="',a,'",par,npar=',i4,');')
162	write(luncode,'(''}'')')
163	endif
164	*
165	end
166	*
167	#ifndef CALL_GEANT
168	subroutine gsatt(name, attr, ival)
169	#else
170	subroutine Ksatt(name, attr, ival)
171	#endif
172	************************************************************************
173	************************************************************************
174	implicit none
175	character name4, attr4
176	integer ival
177	character rname*6
178	#include "G3toG4.inc"
179	data rname /'GSATT '/
180	*
181	call check_lines
182	#ifdef CALL_GEANT
183	if (dogeom) call gsatt(name, attr, ival)
184	#endif
185	if (lunlist.ne.0) then
186	write(lunlist,
187	+ '(a4,1x,a6,1x,a4,1x,a4,i12)')
188	+ context, rname, name, attr, ival
189	endif
190	if (luncode.ne.0) then
191	write(luncode,'(''{'')')
192	write(luncode,1000) name,attr,ival
193	1000 format('G4gsatt(name="',a,'",attr="',a,'",ival=',i10,');')
194	write(luncode,'(''}'')')
195	endif
196	*
197	end
198	*
199	#ifndef CALL_GEANT
200	subroutine gsrotm(irot, theta1, phi1, theta2, phi2,
201	+ theta3, phi3)
202	#else
203	subroutine Ksrotm(irot, theta1, phi1, theta2, phi2,
204	+ theta3, phi3)
205	#endif
206	************************************************************************
207	************************************************************************
208	implicit none
209	integer irot
210	real theta1, phi1, theta2, phi2, theta3, phi3
211	character rname*6
212	#include "G3toG4.inc"
213	data rname /'GSROTM'/
214	*
215	call check_lines
216	#ifdef CALL_GEANT
217	if (dogeom) call gsrotm(irot, theta1, phi1, theta2, phi2,
218	+ theta3, phi3)
219	#endif
220	if (lunlist.ne.0) then
221	write(lunlist,
222	+ '(a4,1x,a6,i5,6f11.5)')
223	+ context, rname, irot, theta1, phi1, theta2, phi2,
224	+ theta3, phi3
225	endif
226	if (luncode.ne.0) then
227	write(luncode,'(''{'')')
228	call rtocp('theta1',theta1)
229	call rtocp('phi1',phi1)
230	call rtocp('theta2',theta2)
231	call rtocp('phi2',phi2)
232	call rtocp('theta3',theta3)
233	call rtocp('phi3',phi3)
234	write(luncode,1000) irot
235	1000 format('G4gsrotm(irot=',i5,
236	+ ',theta1,phi1,theta2,phi2,theta3,phi3);')
237	write(luncode,'(''}'')')
238	endif
239	*
240	end
241	*
242	#ifndef CALL_GEANT
243	subroutine gsdvn(name, moth, ndiv, iaxis)
244	#else
245	subroutine Ksdvn(name, moth, ndiv, iaxis)
246	#endif
247	************************************************************************
248	************************************************************************
249	implicit none
250	character name4, moth4
251	integer ndiv, iaxis
252	character rname*6
253	#include "G3toG4.inc"
254	data rname /'GSDVN '/
255	*
256	call check_lines
257	#ifdef CALL_GEANT
258	if (dogeom) call gsdvn(name, moth, ndiv, iaxis)
259	#endif
260	if (lunlist.ne.0) then
261	write(lunlist,
262	+ '(a4,1x,a6,1x,a4,1x,a4,i5,i3)')
263	+ context, rname, name, moth, ndiv, iaxis
264	endif
265	if (luncode.ne.0) then
266	write(luncode,'(''{'')')
267	write(luncode,1000) name, moth, ndiv, iaxis
268	1000 format('G4gsdvn(name="',a,'",moth="',a,'",ndiv=',i3,
269	+ ',iaxis=',i1,');')
270	write(luncode,'(''}'')')
271	endif
272	*
273	end
274	*
275	#ifndef CALL_GEANT
276	subroutine gsdvt(name, moth, step, iaxis, numed, ndvmx)
277	#else
278	subroutine Ksdvt(name, moth, step, iaxis, numed, ndvmx)
279	#endif
280	************************************************************************
281	************************************************************************
282	implicit none
283	character name4, moth4
284	real step
285	integer iaxis, numed, ndvmx
286	character rname*6
287	#include "G3toG4.inc"
288	data rname /'GSDVT '/
289	*
290	call check_lines
291	#ifdef CALL_GEANT
292	if (dogeom) call gsdvt(name, moth, step, iaxis, numed, ndvmx)
293	#endif
294	if (lunlist.ne.0) then
295	write(lunlist,
296	+ '(a4,1x,a6,1x,a4,1x,a4,(1x,e16.8),3i5)')
297	+ context, rname, name, moth, step, iaxis, numed, ndvmx
298	endif
299	if (luncode.ne.0) then
300	write(luncode,'(''{'')')
301	call rtocp('step',step)
302	write(luncode,1000) name,moth,iaxis,numed,ndvmx
303	1000 format('G4gsdvt(name="',a,'",moth="',a,'",step,iaxis=',
304	+ i1,',numed=',i4,',ndvmx=',i4,');')
305	write(luncode,'(''}'')')
306	endif
307	*
308	end
309	*
310	#ifndef CALL_GEANT
311	subroutine gsdvx(name, moth, ndiv, iaxis, step, c0, numed, ndvmx)
312	#else
313	subroutine Ksdvx(name, moth, ndiv, iaxis, step, c0, numed, ndvmx)
314	#endif
315	************************************************************************
316	************************************************************************
317	implicit none
318	character name4, moth4
319	integer ndiv, iaxis, numed, ndvmx
320	real step, c0
321	character rname*6
322	#include "G3toG4.inc"
323	data rname /'GSDVX '/
324	*
325	call check_lines
326	#ifdef CALL_GEANT
327	if (dogeom) call gsdvx(name, moth, ndiv, iaxis, step, c0, numed,
328	+ ndvmx)
329	#endif
330	if (lunlist.ne.0) then
331	write(lunlist,
332	+ '(a4,1x,a6,1x,a4,1x,a4,i5,i3,2(1x,e16.8),2i5)')
333	+ context, rname, name, moth, ndiv, iaxis,step, c0,
334	+ numed, ndvmx
335	endif
336	if (luncode.ne.0) then
337	write(luncode,'(''{'')')
338	call rtocp('step',step)
339	call rtocp('c0',c0)
340	write(luncode,1000) name,moth,ndiv,iaxis,numed,ndvmx
341	1000 format('G4gsdvx(name="',a,'",moth="',a,'",ndiv=',i3,',iaxis=',
342	+ i1,',step,c0,numed=',i4,',ndvmx=',i4,');')
343	write(luncode,'(''}'')')
344	endif
345	*
346	end
347	*
348	#ifndef CALL_GEANT
349	subroutine gsdvn2(name, moth, ndiv, iaxis, c0, numed)
350	#else
351	subroutine Ksdvn2(name, moth, ndiv, iaxis, c0, numed)
352	#endif
353	************************************************************************
354	************************************************************************
355	implicit none
356	character name4, moth4
357	integer ndiv, iaxis, numed
358	real c0
359	character rname*6
360	#include "G3toG4.inc"
361	data rname /'GSDVN2'/
362	*
363	call check_lines
364	#ifdef CALL_GEANT
365	if (dogeom) call gsdvn2(name, moth, ndiv, iaxis, c0, numed)
366	#endif
367	if (lunlist.ne.0) then
368	write(lunlist,
369	+ '(a4,1x,a6,1x,a4,1x,a4,i5,i3,(1x,e16.8),i5)')
370	+ context, rname, name, moth, ndiv, iaxis, c0, numed
371	endif
372	if (luncode.ne.0) then
373	write(luncode,'(''{'')')
374	call rtocp('c0',c0)
375	write(luncode, 1000) name,moth,ndiv,iaxis,numed
376	1000 format('G4gsdvn2(name="',a,'",moth="',a,'",ndiv=',i3,',iaxis=',
377	+ i1,',c0,numed=',i4,');')
378	write(luncode,'(''}'')')
379	endif
380	*
381	end
382	*
383	#ifndef CALL_GEANT
384	subroutine gsdvt2(name, moth, step, iaxis, c0, numed, ndvmx)
385	#else
386	subroutine Ksdvt2(name, moth, step, iaxis, c0, numed, ndvmx)
387	#endif
388	************************************************************************
389	************************************************************************
390	implicit none
391	character name4, moth4
392	integer iaxis, numed, ndvmx
393	real step, c0
394	character rname*6
395	#include "G3toG4.inc"
396	data rname /'GSDVT2'/
397	*
398	call check_lines
399	#ifdef CALL_GEANT
400	if (dogeom) call gsdvt2(name, moth, step, iaxis, c0, numed, ndvmx)
401	#endif
402	if (lunlist.ne.0) then
403	write(lunlist,
404	+ '(a4,1x,a6,1x,a4,1x,a4,(1x,e16.8),i3,(1x,e16.8),2i5)')
405	+ context, rname, name, moth, step, iaxis, c0, numed, ndvmx
406	endif
407	if (luncode.ne.0) then
408	write(luncode,'(''{'')')
409	call rtocp('step',step)
410	call rtocp('c0',c0)
411	write(luncode,1000) name,moth,iaxis,numed,ndvmx
412	1000 format('G4gsdvt2(name="',a,'",moth="',a,'",step,iaxis=',
413	+ i1,',c0,numed=',i4,',ndvmx=',i4,');')
414	write(luncode,'(''}'')')
415	endif
416	*
417	end
418	*
419	#ifndef CALL_GEANT
420	subroutine gsmate(imate, name, a, z, dens, radl, absl, ubf, nwbf)
421	#else
422	subroutine Ksmate(imate, name, a, z, dens, radl, absl, ubf, nwbf)
423	#endif
424	************************************************************************
425	************************************************************************
426	implicit none
427	character name()
428	integer imate, nwbf, k
429	real a, z, dens, radl, absl, ubf(nwbf)
430	character rname6, fmt150
431	#include "G3toG4.inc"
432	data rname /'GSMATE'/
433	*
434	call check_lines
435	#ifdef CALL_GEANT
436	if (dogeom) call gsmate
437	+ (imate, name, a, z, dens, radl, absl, ubf, nwbf)
438	#endif
439	if (lunlist.ne.0) then
440	write(fmt,'(A,I3,A)')
441	> '(a4,1x,a6,i5,1x,''"'',a,''"'',4(1x,e16.8),i3,',
442	> max(nwbf,1),'(1x,e16.8))'
443	write(lunlist,fmt)
444	+ context, rname, imate, name, a, z, dens, radl,
445	+ nwbf, (ubf(k), k=1,nwbf)
446	endif
447	if (luncode.ne.0) then
448	write(luncode,'(''{'')')
449	call rtocp('a',a)
450	call rtocp('z',z)
451	call rtocp('dens',dens)
452	call rtocp('radl',radl)
453	call g3ldpar(ubf,nwbf)
454	write(luncode,1000) imate, name, nwbf
455	1000 format('G4gsmate(imate=',i4,',name="',a,
456	+ '",a,z,dens,radl,npar=',i4,',par);')
457	write(luncode,'(''}'')')
458	endif
459	*
460	end
461	*
462	#ifndef CALL_GEANT
463	subroutine gsmixt(imate, name, a, z, dens, nlmat, wmat)
464	#else
465	subroutine Ksmixt(imate, name, a, z, dens, nlmat, wmat)
466	#endif
467	************************************************************************
468	************************************************************************
469	implicit none
470	character name()
471	integer imate, nlmat, k, nlmata
472	real a(), z(), dens, wmat(*)
473	character rname6, fmt150
474	#include "G3toG4.inc"
475	data rname /'GSMIXT'/
476	*
477	call check_lines
478	#ifdef CALL_GEANT
479	if (dogeom) call gsmixt
480	+ (imate, name, a, z, dens, nlmat, wmat)
481	#endif
482	if (lunlist.ne.0) then
483	nlmata = abs(nlmat)
484	write(fmt,'(A,I3,A,I3,A,I3,A)')
485	+ '(a4,1x,a6,i5,1x,''"'',a,''"'',1x,e16.8,1x,i3,',
486	> max(nlmata,1),
487	> '(1x,e16.8),',max(nlmata,1),'(1x,e16.8),',
488	> max(nlmata,1),'(1x,e16.8))'
489	write(lunlist,fmt)
490	+ context, rname, imate, name, dens,
491	+ nlmat,
492	+ (a(k), k=1,abs(nlmat)),
493	+ (z(k), k=1,abs(nlmat)),
494	+ (wmat(k), k=1,abs(nlmat))
495	endif
496	if (luncode.ne.0) then
497	write(luncode,'(''{'')')
498	call rtocp('dens',dens)
499	call artocp('aa',a,abs(nlmat))
500	call artocp('zz',z,abs(nlmat))
501	call artocp('wmat',wmat,abs(nlmat))
502	write(luncode,1000) imate,name,nlmat
503	1000 format('G4gsmixt(imate=',i5,',name="',a,
504	+ '",aa,zz,dens,nlmat=',i3,',wmat);')
505	write(luncode,'(''}'')')
506	endif
507	*
508	end
509	*
510	#ifndef CALL_GEANT
511	subroutine gstmed(
512	+ itmed, name, nmat, isvol, ifield, fieldm,
513	+ tmaxfd, stemax, deemax, epsil, stmin, ubuf, nwbuf)
514	#else
515	subroutine Kstmed(
516	+ itmed, name, nmat, isvol, ifield, fieldm,
517	+ tmaxfd, stemax, deemax, epsil, stmin, ubuf, nwbuf)
518	#endif
519	************************************************************************
520	************************************************************************
521	implicit none
522	character name()
523	integer itmed, nmat, isvol, ifield, nwbuf, k
524	real fieldm, tmaxfd, stemax, deemax, epsil, stmin, ubuf(nwbuf)
525	character rname6, fmt150
526	#include "G3toG4.inc"
527	data rname /'GSTMED'/
528	*
529	call check_lines
530	#ifdef CALL_GEANT
531	if (dogeom) call gstmed(
532	+ itmed, name, nmat, isvol, ifield, fieldm,
533	+ tmaxfd, stemax, deemax, epsil, stmin, ubuf, nwbuf)
534	#endif
535	if (lunlist.ne.0) then
536	* write(lunlist,
537	* + '(a4,1x,a6,i5,1x,''"'',a,''"'',3i3,6e15.8,i3,<nwbuf>e15.8)')
538	* + context, rname, itmed, name, nmat, isvol, ifield, fieldm,
539	* + tmaxfd, stemax, deemax, epsil, stmin,
540	* + nwbuf, (ubuf(k),k=1,nwbuf)
541	write(fmt,'(A,I3,A)')
542	> '(a4,1x,a6,i5,1x,''"'',a,''"'',3i3,6(1x,e16.8),i3,',
543	> max(nwbuf,1),'(1x,e16.8))'
544	write(lunlist,fmt)
545	+ context, rname, itmed, name, nmat, isvol, ifield, fieldm,
546	+ tmaxfd, stemax, deemax, epsil, stmin,
547	+ nwbuf, (ubuf(k),k=1,nwbuf)
548	endif
549	if (luncode.ne.0) then
550	write(luncode,'(''{'')')
551	call rtocp('fieldm',fieldm)
552	call rtocp('tmaxfd',tmaxfd)
553	call rtocp('stemax',stemax)
554	call rtocp('deemax',deemax)
555	call rtocp('epsil',epsil)
556	call rtocp('stmin',stmin)
557	call g3ldpar(ubuf,nwbuf)
558	write(luncode,1000) itmed,name,nmat,isvol,ifield,nwbuf
559	1000 format('G4gstmed(itmed=',i4,',name="',a,'",nmat=',i4,
560	+ ',isvol=',i2,',ifield=',i2,',',/
561	+ ' fieldm,tmaxfd,stemax,deemax,epsil,stmin,par,npar=',
562	+ i4,');')
563	write(luncode,'(''}'')')
564	endif
565	*
566	end
567	*
568	#ifndef CALL_GEANT
569	subroutine gstpar(itmed, chpar, parval)
570	#else
571	subroutine Kstpar(itmed, chpar, parval)
572	#endif
573	************************************************************************
574	************************************************************************
575	implicit none
576	character chpar()
577	integer itmed
578	real parval
579	character rname*6
580	#include "G3toG4.inc"
581	data rname /'GSTPAR'/
582	*
583	call check_lines
584	#ifdef CALL_GEANT
585	if (dogeom) call gstpar (itmed, chpar, parval)
586	#endif
587	if (lunlist.ne.0) then
588	write(lunlist,
589	+ '(a4,1x,a6,i5,1x,a4,(1x,e16.8))')
590	+ context, rname, itmed, chpar, parval
591	endif
592	if (luncode.ne.0) then
593	write(luncode,'(''{'')')
594	write(luncode,1000) itmed, chpar, parval
595	1000 format('G4gstpar(itmed=',i4,',chpar="',a,'",parval=',
596	+ (1x,e16.8),');')
597	write(luncode,'(''}'')')
598	endif
599	*
600	end
601	*
602	#ifndef CALL_GEANT
603	subroutine gspart(
604	+ ipart, chpar, itrtyp, amass, charge, tlife, ub, nwb)
605	#else
606	subroutine Kspart(
607	+ ipart, chpar, itrtyp, amass, charge, tlife, ub, nwb)
608	#endif
609	************************************************************************
610	************************************************************************
611	implicit none
612	character chpar()
613	integer ipart, itrtyp, nwb, k
614	real amass, charge, tlife, ub(nwb)
615	character rname6, fmt150
616	#include "G3toG4.inc"
617	data rname /'GSPART'/
618	*
619	call check_lines
620	#ifdef CALL_GEANT
621	if (dogeom) call gspart(
622	+ ipart, chpar, itrtyp, amass, charge, tlife, ub, nwb)
623	#endif
624	if (lunlist.ne.0) then
625	* write(lunlist,
626	* + '(a4,1x,a6,i5,1x,''"'',a,''"'',i3,3e15.8,i3,<nwb>e15.8)')
627	* + context, rname, ipart, chpar, itrtyp, amass, charge, tlife,
628	* + nwb, (ub(k), k=1,nwb)
629	write(fmt,'(A,I3,A)')
630	> '(a4,1x,a6,i5,1x,''"'',a,''"'',i3,3(1x,e16.8),i3,',
631	> max(nwb,1),'(1x,e16.8))'
632	write(lunlist,fmt)
633	+ context, rname, ipart, chpar, itrtyp, amass, charge,
634	> tlife,
635	+ nwb, (ub(k), k=1,nwb)
636	endif
637	if (luncode.ne.0) then
638	write(luncode,'(''{'')')
639	call rtocp('amass',amass)
640	call rtocp('charge',charge)
641	call rtocp('tlife',tlife)
642	call g3ldpar(ub,nwb)
643	write(luncode,1000) ipart,chpar,itrtyp,nwb
644	1000 format('G4gspart(ipart=',i8,',chpar="',a,'",itrtyp=',i8,
645	+ ',amass,charge,'/' tlife,par,npar=',i4,');')
646	write(luncode,'(''}'')')
647	endif
648	*
649	end
650	*
651	#ifndef CALL_GEANT
652	subroutine gsdk(ipart, bratio, mode)
653	#else
654	subroutine Ksdk(ipart, bratio, mode)
655	#endif
656	************************************************************************
657	************************************************************************
658	implicit none
659	integer ipart, mode(6)
660	real bratio(6)
661	character rname*6
662	#include "G3toG4.inc"
663	data rname /'GSDK '/
664	*
665	call check_lines
666	#ifdef CALL_GEANT
667	if (dogeom) call gsdk(ipart, bratio, mode)
668	#endif
669	if (lunlist.ne.0) then
670	*** 6 is prefixed to the arrays for consistency with other
671	*** array treatments (count precedes the array)
672	write(lunlist,
673	+ '(a4,1x,a6,i5,i3,6(1x,e16.8),6i8)')
674	+ context, rname, ipart, 6, bratio, mode
675	endif
676	if (luncode.ne.0) then
677	write(luncode,'(''{'')')
678	call artocp('bratio',bratio,6)
679	call aitocp('mode',mode,6)
680	write(luncode,1000) ipart
681	1000 format('G4gsdk(ipart=',i8,',bratio,mode);')
682	write(luncode,'(''}'')')
683	endif
684	*
685	end
686	*
687	#ifndef CALL_GEANT
688	subroutine gsdet(chset, chdet, nv, chnam, nbits, idtyp, nwhi,
689	+ nwdi, iset, idet)
690	#else
691	subroutine Ksdet(chset, chdet, nv, chnam, nbits, idtyp, nwhi,
692	+ nwdi, iset, idet)
693	#endif
694	************************************************************************
695	************************************************************************
696	implicit none
697	integer nv, nbits(nv), idtyp, nwhi, nwdi, iset, idet, k
698	character rname6, chset4, chdet4, chnam(nv)4, fmt*150
699	#include "G3toG4.inc"
700	data rname /'GSDET '/
701	*
702	call check_lines
703	#ifdef CALL_GEANT
704	if (dogeom) call gsdet(chset, chdet, nv, chnam, nbits, idtyp,
705	+ nwhi, nwdi, iset, idet)
706	#endif
707	if (lunlist.ne.0) then
708	* write(lunlist,
709	* + '(a4,1x,a6,1x,a4,1x,a4,i5,<nv>(1x,a4),<nv>i10,i10,2i5)')
710	* + context, rname, chset, chdet, nv, (chnam(k), k=1,nv),
711	* + (nbits(k), k=1,nv), idtyp, nwhi, nwdi
712	write(fmt,'(A,I3,A,I3,A)')'(a4,1x,a6,1x,a4,1x,a4,i5,',
713	> max(nv,1),'(1x,a4),',max(nv,1),'i10,i10,2i5)'
714	write(lunlist,fmt)
715	+ context, rname, chset, chdet, nv, (chnam(k), k=1,nv),
716	+ (nbits(k), k=1,nv), idtyp, nwhi, nwdi
717	endif
718	if (luncode.ne.0) then
719	write(luncode,'(''{'')')
720	call astocp('chnam',chnam,nv)
721	call aitocp('nbits',nbits,nv)
722	write(luncode,1000) chset, chdet, nv, idtyp, nwhi, nwdi
723	1000 format('G4gsdet(chset="',a,'",chdet="',a,'",nv=',i3,
724	+ ',chnam,nbits,idtyp=',i8,','/
725	+ ' nwhi=',i8,',nwdi=',i8,');')
726	write(luncode,'(''}'')')
727	endif
728	*
729	end
730	*
731	#ifndef CALL_GEANT
732	subroutine gsdetv(chset, chdet, idtyp, nwhi, nwdi, iset, idet)
733	#else
734	subroutine Ksdetv(chset, chdet, idtyp, nwhi, nwdi, iset, idet)
735	#endif
736	************************************************************************
737	************************************************************************
738	implicit none
739	integer idtyp, nwhi, nwdi, iset, idet
740	character rname6, chset4, chdet*4
741	#include "G3toG4.inc"
742	data rname /'GSDETV'/
743	*
744	call check_lines
745	#ifdef CALL_GEANT
746	if (dogeom) call gsdetv(chset, chdet, idtyp,
747	+ nwhi, nwdi, iset, idet)
748	#endif
749	if (lunlist.ne.0) then
750	write(lunlist,
751	+ '(a4,1x,a6,1x,a4,1x,a4,i10,2i5)')
752	+ context, rname, chset, chdet, idtyp, nwhi, nwdi
753	endif
754	if (luncode.ne.0) then
755	write(luncode,'(''{'')')
756	write(luncode,1000) chset, chdet, idtyp, nwhi, nwdi
757	1000 format('G4gsdetv(chset="',a,'",chdet="',a,'",idtyp=',i8,
758	+ ',nwhi=',i8,',nwdi=',i8,');')
759	write(luncode,'(''}'')')
760	endif
761	*
762	end
763	*
764	#ifndef CALL_GEANT
765	subroutine gsdeta(chset, chdet, chali, nwhi, nwdi, iali)
766	#else
767	subroutine Ksdeta(chset, chdet, chali, nwhi, nwdi, iali)
768	#endif
769	************************************************************************
770	************************************************************************
771	implicit none
772	integer nwhi, nwdi, iali
773	character rname6, chset4, chdet4, chali4
774	#include "G3toG4.inc"
775	data rname /'GSDETA'/
776	*
777	call check_lines
778	#ifdef CALL_GEANT
779	if (dogeom) call gsdeta(chset, chdet, chali, nwhi, nwdi, iali)
780	#endif
781	if (lunlist.ne.0) then
782	write(lunlist,
783	+ '(a4,1x,a6,1x,a4,1x,a4,1x,a4,2i5)')
784	+ context, rname, chset, chdet, chali, nwhi, nwdi
785	endif
786	if (luncode.ne.0) then
787	write(luncode,'(''{'')')
788	write(luncode,1000) chset, chdet, chali, nwhi, nwdi
789	1000 format('G4gsdeta(chset="',a,'",chdet="',a,'",chali="',a,
790	+ '",nwhi=',i8,',nwdi=',i8,');')
791	write(luncode,'(''}'')')
792	endif
793	*
794	end
795	*
796	#ifndef CALL_GEANT
797	subroutine gsdeth(chset, chdet, nh, chnam, nbits, orig, fact)
798	#else
799	subroutine Ksdeth(chset, chdet, nh, chnam, nbits, orig, fact)
800	#endif
801	************************************************************************
802	************************************************************************
803	implicit none
804	integer nh, nbits(nh), k
805	real orig(nh), fact(nh)
806	character rname6, chset4, chdet4, chnam(nh)4, fmt*150
807	#include "G3toG4.inc"
808	data rname /'GSDETH'/
809	*
810	call check_lines
811	#ifdef CALL_GEANT
812	if (dogeom) call gsdeth(chset, chdet, nh, chnam, nbits,
813	+ orig, fact)
814	#endif
815	if (lunlist.ne.0) then
816	* write(lunlist,
817	* + '(a4,1x,a6,1x,a4,1x,a4,i5,<nh>(1x,a4),<nh>i5,<nh>e15.8,
818	* + <nh>e15.8)')
819	* + context, rname, chset, chdet, nh, (chnam(k), k=1,nh),
820	* + (nbits(k), k=1,nh), (orig(k), k=1,nh), (fact(k), k=1,nh)
821	write(fmt,'(A,I3,A,I3,A,I3,A,I3,A)')
822	> '(a4,1x,a6,1x,a4,1x,a4,i5,',max(nh,1),'(1x,a4),',
823	> max(nh,1),'i5,',max(nh,1),'(1x,e16.8),',max(nh,1),
824	> '(1x,e16.8))'
825	write(lunlist, fmt)
826	+ context, rname, chset, chdet, nh, (chnam(k), k=1,nh),
827	+ (nbits(k), k=1,nh), (orig(k), k=1,nh), (fact(k), k=1,nh)
828	endif
829	if (luncode.ne.0) then
830	write(luncode,'(''{'')')
831	call astocp('chnam',chnam,nh)
832	call aitocp('nbits',nbits,nh)
833	call artocp('orig',orig,nh)
834	call artocp('fact',fact,nh)
835	write(luncode,1000) chset,chdet,nh
836	1000 format('G4gsdeth(chset="',a,'",chdet="',a,'",nh=',i4,
837	+ ',chnam,nbits,orig,fact);')
838	write(luncode,'(''}'')')
839	endif
840	*
841	end
842	*
843	#ifndef CALL_GEANT
844	subroutine gsdetd(chset, chdet, nd, chnam, nbits)
845	#else
846	subroutine Ksdetd(chset, chdet, nd, chnam, nbits)
847	#endif
848	************************************************************************
849	************************************************************************
850	implicit none
851	integer nd, nbits(nd), k
852	character rname6, chset4, chdet4, chnam(nd)4, fmt*150
853	#include "G3toG4.inc"
854	data rname /'GSDETD'/
855	*
856	call check_lines
857	#ifdef CALL_GEANT
858	if (dogeom) call gsdetd(chset, chdet, nd, chnam, nbits)
859	#endif
860	if (lunlist.ne.0) then
861	* write(lunlist,
862	* + '(a4,1x,a6,1x,a4,1x,a4,i5,<nd>(1x,a4),<nd>i5)')
863	* + context, rname, chset, chdet, nd, (chnam(k), k=1,nd),
864	* + (nbits(k), k=1,nd)
865	write(fmt,'(A,I3,A,I3,A)')
866	+ '(a4,1x,a6,1x,a4,1x,a4,i5,',max(nd,1),'(1x,a4),',
867	> max(nd,1),'i5)'
868	write(lunlist,fmt)
869	+ context, rname, chset, chdet, nd, (chnam(k), k=1,nd),
870	+ (nbits(k), k=1,nd)
871	endif
872	if (luncode.ne.0) then
873	write(luncode,'(''{'')')
874	call astocp('chnam',chnam,nd)
875	call aitocp('nbits',nbits,nd)
876	write(luncode,1000) chset, chdet, nd
877	1000 format('G4gsdetd(chset="',a,'",chdet="',a,'",nd=',i4,
878	+ ',chnam,nbits);')
879	write(luncode,'(''}'')')
880	endif
881	*
882	end
883	*
884	#ifndef CALL_GEANT
885	subroutine gsdetu(chset, chdet, nupar, upar)
886	#else
887	subroutine Ksdetu(chset, chdet, nupar, upar)
888	#endif
889	************************************************************************
890	************************************************************************
891	implicit none
892	integer nupar, k
893	real upar(nupar)
894	character rname6, chset4, chdet4, fmt150
895	#include "G3toG4.inc"
896	data rname /'GSDETU'/
897	*
898	call check_lines
899	#ifdef CALL_GEANT
900	if (dogeom) call gsdetu(chset, chdet, nupar, upar)
901	#endif
902	if (lunlist.ne.0) then
903	* write(lunlist,
904	* + '(a4,1x,a6,1x,a4,1x,a4,i5,<nupar>e15.8)')
905	* + context, rname, chset, chdet, nupar, (upar(k), k=1,nupar)
906	write(fmt,'(A,I3,A)')
907	+ '(a4,1x,a6,1x,a4,1x,a4,i5,',max(nupar,1),'(1x,e16.8))'
908	write(lunlist,fmt)
909	+ context, rname, chset, chdet, nupar, (upar(k), k=1,nupar)
910	endif
911	if (luncode.ne.0) then
912	write(luncode,'(''{'')')
913	call g3ldpar(upar,nupar)
914	write(luncode,1000) chset, chdet, nupar
915	1000 format('G4gsdetu(chset="',a,'",chdet="',a,'",npar=',
916	+ i4,',par);')
917	write(luncode,'(''}'')')
918	endif
919	*
920	end
921	*
922	#ifndef CALL_GEANT
923	subroutine ggclos
924	#else
925	subroutine kgclos
926	#endif
927	************************************************************************
928	************************************************************************
929	implicit none
930	character rname*6
931	#include "G3toG4.inc"
932	data rname /'GGCLOS'/
933	*
934	call check_lines
935	#ifdef CALL_GEANT
936	if (dogeom) call ggclos
937	#endif
938	if (lunlist.ne.0) then
939	write(lunlist,'(a4,1x,a6)') context, rname
940	close(lunlist)
941	endif
942	if (luncode.ne.0) then
943	write(luncode,'(''//GeoMgr->CloseGeometry();'')')
944	write(luncode,'(''}'')')
945	call g3main
946	close(luncode)
947	endif
948	*
949	end
950
951	subroutine checkshape(name, shape, par, npar)
952	implicit none
953	************************************************************************
954	* convert TRAP, PARA and GTRA to external form
955	************************************************************************
956	character name4, shape4
957	real ph, par(*), tt, raddeg
958	integer npar
959
960	raddeg = 180./3.1415926
961
962	if (shape(1:3).eq.'BOX'.and.npar.ne.3) then
963	print *,'!! error, BOX with ',npar,' parameters, vol ',name
964	endif
965	if (shape.eq.'TRD1'.and.npar.ne.4) then
966	print *,'!! error, TRD1 with ',npar,' parameters, vol ',name
967	endif
968	if (shape.eq.'TRD2'.and.npar.ne.5) then
969	print *,'!! error, TRD2 with ',npar,' parameters, vol ',name
970	endif
971	if (shape.eq.'TRAP'.and.npar.ne.35.and.npar.ne.11) then
972	*** G3 sets 11 to 35. Why?
973	print *,'!! error, TRAP with ',npar,' parameters, vol ',name
974	endif
975	if (shape.eq.'TUBE'.and.npar.ne.3) then
976	print *,'!! error, TUBE with ',npar,' parameters, vol ',name
977	endif
978	if (shape.eq.'TUBS'.and.npar.ne.5) then
979	print *,'!! error, TUBS with ',npar,' parameters, vol ',name
980	endif
981	if (shape.eq.'CONE'.and.npar.ne.5) then
982	print *,'!! error, CONE with ',npar,' parameters, vol ',name
983	endif
984	if (shape.eq.'CONS'.and.npar.ne.7) then
985	print *,'!! error, CONS with ',npar,' parameters, vol ',name
986	endif
987	if (shape.eq.'SPHE'.and.npar.ne.6) then
988	print *,'!! error, SPHE with ',npar,' parameters, vol ',name
989	endif
990	if (shape.eq.'PARA'.and.npar.ne.6) then
991	print *,'!! error, PARA with ',npar,' parameters, vol ',name
992	endif
993	if (shape.eq.'PARA') then
994	*
995	* ** PARA
996	*
997	ph = 0.
998	if (par(5).ne.0.) ph = atan2(par(6),par(5))*raddeg
999	tt = sqrt(par(5)2+par(6)2)
1000	par(4) = atan(par(4))*raddeg
1001	if (par(4).gt.90.0) par(4) = par(4)-180.0
1002	par(5) = atan(tt)*raddeg
1003	if (ph.lt.0.0) ph = ph + 360.0
1004	par(6) = PH
1005	end if
1006	if (shape.eq.'TRAP') then
1007	*
1008	* ** TRAP
1009	*
1010	npar=11
1011	ph = 0.
1012	if (par(2).ne.0.) ph = atan2(par(3),par(2))*raddeg
1013	tt = sqrt(par(2)2+par(3)2)
1014	par(2) = atan(tt)*raddeg
1015	if (ph.lt.0.0) ph = ph+360.0
1016	par(3) = ph
1017	par(7) = atan(par(7))*raddeg
1018	if (par(7).gt.90.0) par(7) = par(7)-180.0
1019	par(11)= atan(par(11))*raddeg
1020	if (par(11).gt.90.0) par(11) = par(11)-180.0
1021
1022	end if
1023	end

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format