4 *=== comscw ===========================================================*
6 DOUBLE PRECISION FUNCTION COMSCW ( IJ , XA , YA , ZA ,
7 & MREG , RULL , LLO , ICALL )
13 *----------------------------------------------------------------------*
15 * Special multiplication factors for activity scoring. *
17 * Note: Data files 'LE-CH.dat' and 'LE-EC.dat' read on unit 20. *
20 * SDUM = 'abcdefgh' Lesco *
22 * 'ab' = 'LE' division by exemption limits activated *
24 * 'c' = 'C' : division by CERN zonage limits *
25 * 'def' = '10 ' : division by 1/10 of the value 10 *
26 * 'def' = '100' : division by 1/100 of the value 100 *
27 * otherwise: division by the value itself 1 *
28 * 'c' = 'S' : division by Swiss LE values 2 *
29 * 'c' = 'E' : division by European concentration limits 3 *
31 * Comscw = 1. for selected isotope *
34 * 'ab' = 'IS' selection of individual isotops activated 9999 *
36 * 'cd' = symbol of isotope *
37 * 'efg' = mass number of isotope *
38 * 'h' = 'm' : metastable state *
40 * Comscw = 1. for selected isotope *
43 * otherwise Comscw = 1. -1 *
47 * SDUM = 'LEC10xxx' : division by 1/10 of LE(EU) or by Swiss LE *
48 * = 'LESxxxxx' : division by Swiss LE *
49 * = 'ISV 48x' : scoring of activity for V48 *
50 * = 'ISMn 52m' : scoring of activity for mMn52 *
52 * Note: 'x' refers to characters without specific meaning *
56 * Ij = (generalized) particle code *
57 * Xa,Ya,Za = position *
58 * Mreg = region number *
59 * Rull = amount to be deposited *
60 * Llo = particle generation *
65 * Comscw = factor the scored amount will be multiplied by *
66 * Lsczer = logical flag, if true no amount will be scored *
67 * regardless of Comscw *
69 * Useful variables (common SCOHLP): *
71 * Energy/Star binnings/scorings (Comscw): *
72 * ISCRNG = 1 --> Energy density binning *
73 * ISCRNG = 2 --> Star density binning *
74 * ISCRNG = 3 --> Residual nuclei scoring *
75 * ISCRNG = 4 --> Momentum transfer density binning *
76 * ISCRNG = 5 --> Activity density binning *
77 * JSCRNG = # of the binning *
79 * Useful variables (common SOUEVT): *
81 * X,Y,Zsoevt(i) = position of the i_th source particle *
82 * TX,Y,Zsoev(i) = direction of the i_th source particle *
83 * Wtsoev(i) = weight of the i_th source particle *
84 * Pmsoev(i) = momentum of the i_th source particle *
85 * Tksoev(i) = kin. energy of the i_th source particle *
86 * Agsoev(i) = age of the i_th source particle *
87 * Aksoev(i) = Kaon ampl. of the i_th source particle *
88 * Ussoev(i) = user var. of the i_th source particle *
89 * Ijsoev(i) = identity of the i_th source particle *
90 * Nrsoev(i) = region of the i_th source particle *
91 * Nlsoev(i) = lattice of the i_th source particle *
92 * Npsoev = number of the source particles *
93 *----------------------------------------------------------------------*
101 DIMENSION IZSCO(MXUSBN),IASCO(MXUSBN),ISSCO(MXUSBN),
104 CHARACTER CISOIN*2,CISO*2,CSET*10,CDUM*4,CA*3
105 PARAMETER (IZMAX = 109,
108 DIMENSION CISO(IZMAX)
109 DIMENSION XLESWS(IZMAX,IAZMIN:IAZMAX,2),
110 & XLEECO(IZMAX,IAZMIN:IAZMAX,2),
111 & XLEO10(IZMAX,IAZMIN:IAZMAX,2)
113 & 'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne','Na',
114 & 'Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca','Sc','Ti',
115 & 'V ','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As',
116 & 'Se','Br','Kr','Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru',
117 & 'Rh','Pd','Ag','Cd','In','Sn','Sb','Te','I ','Xe','Cs',
118 & 'Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy',
119 & 'Ho','Er','Tm','Yb','Lu','Hf','Ta','W ','Re','Os','Ir',
120 & 'Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn','Fr','Ra',
121 & 'Ac','Th','Pa','U ','Np','Pu','Am','Cm','Bk','Cf','Es',
122 & 'Fm','Md','No','Lr','Rf','Ha','Sg','Ns','Hs','Mt'/
124 LOGICAL LFIRST,LFOUND
132 WRITE(LUNOUT,'(A)') ' COMSCW: activity weighting activated'
135 *----------------------------------------------------------------------*
138 * LE data taken from Appendix 3 column 9,
139 * Ordonnance sur la radioprotection (ORaP) du 22 juin 1994
140 * (etat au 4 avril 2000)
142 * (data file in Bq/kg!)
145 DO 105 IAZ=IAZMIN,IAZMAX
146 XLESWS(IZ,IAZ,1) = ZERZER
147 XLESWS(IZ,IAZ,2) = ZERZER
151 OPEN(20,FILE='LE-CH.dat',STATUS='UNKNOWN')
155 READ(20,*,END=101) CISOIN,IA,XLIMIT
156 * convert from Bq/kg into Bq/g
157 XLIMIT = 1.0D-3*XLIMIT
160 IF (CISOIN.EQ.CISO(IZ)) THEN
168 IF ((IAZ.LT.IAZMIN).OR.(IAZ.GT.IAZMAX)) THEN
170 & ' COMSCW: warning! Iaz out of allowed range: ',
174 IF (XLESWS(IZ,IAZ,IS).GT.ZERZER) THEN
176 & ' COMSCW: warning! two entries for this isotope: ',
180 XLESWS(IZ,IAZ,IS) = XLIMIT
189 & ' COMSCW: isotope not recognized: ',CISOIN,IA,XLIMIT
197 * Official journal of the European Communities L159, 29 June 1996
198 * Council Directive 96/29/Euratom
200 * (data file in Bq/g!)
203 DO 205 IAZ=IAZMIN,IAZMAX
204 XLEECO(IZ,IAZ,1) = ZERZER
205 XLEECO(IZ,IAZ,2) = ZERZER
209 OPEN(20,FILE='LE-EC.dat',STATUS='UNKNOWN')
213 READ(20,*,END=201) CISOIN,IA,XLIMIT,IFLAG
216 IF (CISOIN.EQ.CISO(IZ)) THEN
224 IF ((IAZ.LT.IAZMIN).OR.(IAZ.GT.IAZMAX)) THEN
226 & ' COMSCW: warning! Iaz out of allowed range: ',
230 IF (XLEECO(IZ,IAZ,IS).GT.ZERZER) THEN
232 & ' COMSCW: warning! two entries for this isotope: ',
236 XLEECO(IZ,IAZ,IS) = XLIMIT
237 * zero entries with Swiss values
238 IF (IFLAG.EQ.1) XLEECO(IZ,IAZ,IS) = ZERZER
247 & ' COMSCW: isotope not recognized: ',CISOIN,IA,XLIMIT
254 DO 405 IAZ=IAZMIN,IAZMAX
256 XLEO10(IZ,IAZ,IS) = ZERZER
257 IF (XLEECO(IZ,IAZ,IS).GT.ZERZER) THEN
258 XLEO10(IZ,IAZ,IS) = XLEECO(IZ,IAZ,IS)/10.0D0
260 XLEO10(IZ,IAZ,IS) = XLESWS(IZ,IAZ,IS)
275 *----------------------------------------------------------------------*
278 IF ( ISCRNG .EQ. 5 ) THEN
280 * determine type of weighting
281 IF (LESCO(JSCRNG).EQ.0) THEN
282 CSET = TITUSB(JSCRNG)
283 IF (CSET(1:2).EQ.'IS') THEN
286 IF (CSET(3:4).EQ.CISO(IZ)) THEN
288 READ(CSET,'(A4,A3)') CDUM,CA
289 READ(CA,'(I3)') IASCO(JSCRNG)
290 IF (CSET(8:8).EQ.'m') THEN
297 IF ((IZSCO(JSCRNG).LE.0).OR.(IASCO(JSCRNG).LE.0)
298 & .OR.(ISSCO(JSCRNG).LE.0)) THEN
299 WRITE(LUNOUT,*) ' COMSCW: unknown isotope, Z,A,S = ',
300 & IZSCO(JSCRNG),IASCO(JSCRNG),ISSCO(JSCRNG)
303 ELSEIF(CSET(1:2).EQ.'LE') THEN
304 IF (CSET(3:3).EQ.'C') THEN
305 IF (CSET(4:6).EQ.'100') THEN
307 ELSEIF (CSET(4:6).EQ.'10') THEN
312 ELSEIF (CSET(3:3).EQ.'S') THEN
314 ELSEIF (CSET(3:3).EQ.'E') THEN
317 WRITE(LUNOUT,*) ' COMSCW: unknown LE set ',CSET(3:3)
323 WRITE(LUNOUT,1000) ' COMSCW: scoring ',JSCRNG,CSET,
324 & ' weighted with properties ',
325 & LESCO(JSCRNG),IZSCO(JSCRNG),IASCO(JSCRNG),ISSCO(JSCRNG)
326 1000 FORMAT(A,I3,2A,I5,3I4)
329 * obtain present isotope from common block
337 IF (LESCO(JSCRNG).EQ.-1) THEN
339 ELSEIF (LESCO(JSCRNG).EQ.9999) THEN
340 IF ((JA.EQ.IASCO(JSCRNG)).AND.(JZ.EQ.IZSCO(JSCRNG)).AND.
341 & (JS.EQ.ISSCO(JSCRNG))) THEN
346 ELSEIF ((LESCO(JSCRNG).EQ.1).OR.(LESCO(JSCRNG).EQ.10).OR.
347 & (LESCO(JSCRNG).EQ.100)) THEN
348 FACT = 10.0D0/DBLE(LESCO(JSCRNG))
349 IF (XLEO10(JZ,JAZ,JS).GT.ZERZER)
350 & COMSCW = ONEONE/(FACT*XLEO10(JZ,JAZ,JS))
351 ELSEIF (LESCO(JSCRNG).EQ.2) THEN
352 IF (XLESWS(JZ,JAZ,JS).GT.ZERZER)
353 & COMSCW = ONEONE/XLESWS(JZ,JAZ,JS)
354 ELSEIF (LESCO(JSCRNG).EQ.3) THEN
355 IF (XLEECO(JZ,JAZ,JS).GT.ZERZER)
356 & COMSCW = ONEONE/XLEECO(JZ,JAZ,JS)
358 WRITE(LUNOUT,*) ' COMSCW: invalid option ',LESCO(JSCRNG)
365 *=== End of function Comscw ===========================================*