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: $ |
---|
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 name*4, shape*4, 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 name*4, moth*4, 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 name*4, moth*4, only*4 |
---|
120 | integer num, irot, npar, k |
---|
121 | real x, y, z, par(npar) |
---|
122 | character rname*6, fmt*150 |
---|
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 name*4, attr*4 |
---|
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 name*4, moth*4 |
---|
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 name*4, moth*4 |
---|
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 name*4, moth*4 |
---|
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 name*4, moth*4 |
---|
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 name*4, moth*4 |
---|
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 rname*6, fmt*150 |
---|
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 rname*6, fmt*150 |
---|
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 rname*6, fmt*150 |
---|
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 rname*6, fmt*150 |
---|
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 rname*6, chset*4, chdet*4, 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 rname*6, chset*4, 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 rname*6, chset*4, chdet*4, chali*4 |
---|
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 rname*6, chset*4, chdet*4, 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 rname*6, chset*4, chdet*4, 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 rname*6, chset*4, chdet*4, fmt*150 |
---|
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 name*4, shape*4 |
---|
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 |
---|