File indexing completed on 2024-04-06 12:15:26
0001 PROGRAM AllMaterialMixtures
0002
0003
0004
0005
0006
0007 IMPLICIT NONE
0008
0009 Integer Narg, Iarg, Istatus
0010
0011
0012 CALL SYSTEM('rm -f do', Istatus)
0013 CALL SYSTEM('touch do', Istatus)
0014
0015
0016 Narg = IARGC()
0017
0018 if (Narg.eq.0) then
0019 write (*,*) "No input file(s) given."
0020 write (*,*) "Usage: mixture FILE"
0021 write (*,*) "Run the mixture program on the input FILE(s)."
0022 write (*,*) "File names without the extension .in!"
0023 endif
0024
0025
0026 do Iarg=1, Narg
0027
0028 call MaterialMixtures(Iarg)
0029
0030 enddo
0031
0032
0033 END
0034
0035
0036 SUBROUTINE MaterialMixtures(Iarg)
0037
0038
0039 IMPLICIT NONE
0040
0041 Integer Iarg
0042
0043 Integer ISTAT,i,j,k,l
0044
0045 Character*1 Coding, Code
0046 Character*120 Filename,OutFile,InFile,tzfile,x0file,l0file
0047 Character*120 inputstring
0048
0049 Integer Nmix, Ndiv,LunOut,LunIn,Index, Luntz,Lunx0,Lunl0
0050
0051
0052 Integer MaxDiv
0053 Parameter (MaxDiv=30)
0054 Character*40 MixtureName, GMIXName
0055 Character*80 Command
0056 Character*60 Comment(MaxDiv),Material(MaxDiv)
0057 Character*3 Type(MaxDiv)
0058 Real Volume(MaxDiv), Mult(MaxDiv),
0059 + Density(MaxDiv),Radl(MaxDiv),MCVolume,MCArea
0060 Real Intl(MaxDiv)
0061 Common /MatMix/ Comment, Material,Volume,Mult,Density,Radl,Intl,
0062 + MCVolume,MCArea,MixtureName,GMIXName,Type
0063
0064
0065
0066 External Lenocc
0067 Integer Lenocc
0068
0069
0070
0071
0072
0073
0074
0075
0076 CALL GETARG(Iarg , Filename)
0077
0078 InFile = Filename(1:LENOCC(Filename))//".in"
0079 OutFile = Filename(1:LENOCC(Filename))//".tex"
0080 tzfile = Filename(1:LENOCC(Filename))//".titles"
0081 x0file = Filename(1:LENOCC(Filename))//".x0"
0082 l0file = Filename(1:LENOCC(Filename))//".l0"
0083
0084
0085
0086 LunIn = 23
0087 LunOut = 24
0088 Luntz = LunOut + 1
0089 Lunx0 = LunOut + 2
0090 Lunl0 = LunOut + 3
0091 open(unit=LunIn,file=InFile,status="OLD",IOSTAT=istat)
0092 if(istat.ne.0) then
0093 write(*,*) "Input file not found. Filename: ", InFile
0094 return
0095 endif
0096
0097 open(unit=LunOut,file=OutFile,status="REPLACE")
0098 open(unit=Luntz,file=tzfile,status="REPLACE")
0099 open(unit=Lunx0,file=x0file,status="REPLACE")
0100 open(unit=Lunl0,file=l0file,status="REPLACE")
0101 call LatexSetup(LunOut)
0102
0103
0104
0105
0106 Nmix = 0
0107 Ndiv = 0
0108 do l = 1, 10000 !! file should not have more lines than that
0109
0110 read(LunIn,'(A)',END=20) inputstring
0111
0112
0113
0114
0115 Coding = inputstring(1:1)
0116
0117 if ( Coding.eq.'#') then ! the next mixture starts
0118 if (Nmix.gt.0) then ! do everything for the last mixture
0119 call MakeMixture(NMix,Ndiv,LunOut)
0120
0121
0122
0123
0124
0125
0126 endif
0127
0128 Call ClearCommon
0129 Nmix = Nmix + 1
0130 Ndiv = 0
0131 read(inputstring,*) Code,MixtureName,GMIXName,
0132 + MCVolume,MCArea
0133
0134 elseif ( Coding.eq.'*') then ! components
0135 Ndiv = Ndiv + 1
0136 read(inputstring,*) Code, Index, Comment(Ndiv),
0137 + Material(Ndiv),Volume(Ndiv), Mult(Ndiv), Type(Ndiv)
0138 call MatchMaterial(Ndiv)
0139 if(Ndiv.ne.Index) write(*,*)
0140 + "******* Inconsistency reading in ",InFile," ******"
0141 endif
0142
0143 enddo
0144 20 continue
0145
0146
0147
0148 write(LunOut,*) "\\end{landscape}"
0149 write(LunOut,*) "\\end{document}"
0150
0151 close(LunIn)
0152 close(LunOut)
0153 close(Luntz)
0154 close(Lunx0)
0155 close(Lunl0)
0156
0157
0158
0159
0160
0161
0162
0163
0164
0165
0166
0167
0168 write(command,*) "echo 'latex ",Filename(1:LENOCC(Filename)),
0169 + "' >> do"
0170 CALL SYSTEM(command, istat)
0171
0172 write(command,*) "echo 'dvips ",Filename(1:LENOCC(Filename)),
0173 + " -o",Filename(1:LENOCC(Filename)),".ps' ",
0174 + " >> do"
0175 CALL SYSTEM(command, istat)
0176
0177 write(command,*) "echo 'gv -landscape ",
0178 + Filename(1:LENOCC(Filename))," &' ",
0179 + " >> do"
0180 CALL SYSTEM(command, istat)
0181
0182 write(command,*) "chmod +x do"
0183 CALL SYSTEM(command, istat)
0184
0185 write(*,*) "--> I made ",Filename(1:LENOCC(Filename)),
0186 + " for you. Type ''do'' to see it "
0187
0188 return
0189 end
0190
0191
0192
0193
0194 Subroutine MatchMaterial(Index)
0195
0196
0197 Implicit None
0198
0199 Integer Index, Istat, I,J
0200
0201 Integer MaxPure
0202 Parameter (MaxPure=350)
0203 Integer NPure,match
0204 CHARACTER*25 PureName(MaxPure)
0205 REAL Pureweight(MaxPure), Purenumber(MaxPure), Puredens(MaxPure),
0206 + PureX0(MaxPure), PureL0(MaxPure)
0207 SAVE NPure, Pureweight, Purenumber, Puredens, PureX0, PureL0,
0208 + Purename
0209
0210 Character*60 string,teststring
0211
0212 Logical DEBUG,FIRST
0213 DATA FIRST /.TRUE./
0214 DATA DEBUG /.TRUE./
0215
0216 EXTERNAL LENOCC
0217 Integer LENOCC
0218
0219
0220
0221 Integer MaxDiv
0222 Parameter (MaxDiv=30)
0223 Character*40 MixtureName, GMIXName
0224 Character*60 Comment(MaxDiv),Material(MaxDiv)
0225 Character*3 Type(MaxDiv)
0226 Real Volume(MaxDiv), Mult(MaxDiv),
0227 + Density(MaxDiv),Radl(MaxDiv),MCVolume,MCArea
0228 Real Intl(MaxDiv)
0229 Common /MatMix/ Comment, Material,Volume,Mult,Density,Radl,Intl,
0230 + MCVolume,MCArea,MixtureName,GMIXName,Type
0231
0232
0233
0234
0235 Character MatDir*150
0236 Character MixFile*150
0237 Character PureFile*150
0238 call getenv("CMSSW_BASE", MatDir)
0239 MatDir = MatDir(:lnblnk(MatDir)) // "/src/"
0240 + // "Geometry/TrackerCommonData/data/Materials/"
0241 if (FIRST) then
0242 PureFile = MatDir(:lnblnk(MatDir)) // "pure_materials.input"
0243 open(unit=22,file= PureFile(:lnblnk(PureFile)),
0244 + status="OLD", IOSTAT=istat)
0245 if(istat.ne.0) then
0246 write(*,*) "Pure Materials input file could not be opened",
0247 + " - I quit"
0248 stop
0249 endif
0250
0251 Npure = 0
0252 do i=1, MaxPure
0253 read(22,*,END=10) PureName(i), Pureweight(i),
0254 + PureNumber(i),PureDens(i), PureX0(i), PureL0(i)
0255 Npure = Npure + 1
0256 enddo
0257 10 continue
0258
0259 close(22)
0260
0261
0262 MixFile = MatDir(:lnblnk(MatDir)) // "mixed_materials.input"
0263 open(unit=22, file= MixFile(:lnblnk(MixFile)),
0264 + status="OLD", IOSTAT=istat)
0265
0266 if(istat.ne.0) then
0267 write(*,*) "Mixed Materials input file could not be opened",
0268 + " - I quit"
0269 stop
0270 endif
0271
0272 do i=Npure+1, MaxPure
0273 read(22,*,END=20) PureName(i), Pureweight(i),
0274 + PureNumber(i),PureDens(i), PureX0(i), PureL0(i)
0275 Npure = Npure + 1
0276 enddo
0277 20 continue
0278
0279 close(22)
0280
0281 if (debug) then
0282 write(*,*) "Number of pure materials: ", Npure
0283 write(*,*) "Material name ", "A ",
0284 + "Z ",
0285 + "dens [g/cm3]", " X_0 [cm] "," l_0 [cm]"
0286 do j= 1, NPure
0287 write(*,200) PureName(j), Pureweight(j),
0288 + PureNumber(j),PureDens(j), PureX0(j), PureL0(j)
0289 enddo
0290 endif
0291 200 Format(A30,F10.5,F7.0,3F15.5)
0292 201 Format(A30,A30,F10.5,F7.0,3F15.5)
0293
0294 FIRST = .FALSE.
0295 endif
0296
0297
0298
0299 String = Material(Index)
0300
0301 if (DEBUG) write(*,*) 'Matching now ', String
0302
0303 match = 0
0304 Do i = 1,NPure
0305 teststring = PureName(i)
0306 if(teststring(1:LENOCC(teststring)).eq.
0307 + string(1:LENOCC(string))) then
0308 if (debug) write(*,201) string, PureName(i), Pureweight(i),
0309 + PureNumber(i), PureDens(i), PureX0(i), PureL0(i)
0310 match = 1
0311
0312 Density(Index) = Puredens(I)
0313 Radl(Index) = PureX0(I)
0314 Intl(Index) = PureL0(I)
0315 endif
0316 enddo
0317
0318 if (match.ne.1)then
0319 write(*,*) "Couldn't find match for material ",
0320 + Index, Material(Index)
0321 write(*,*) "Exiting !!"
0322 stop
0323 else
0324 if(Radl(Index).le.0.) then
0325 write(*,*) "Radiation length is zero for material ",
0326 + Index, Material(Index)
0327 endif
0328 if(Density(Index).le.0) then
0329 write(*,*) "Density is zero for material ",
0330 + Index, Material(Index)
0331 endif
0332 if(Intl(Index).le.0.) then
0333 write(*,*)
0334 + "Nuclear Interaction length is zero for material ",
0335 + Index, Material(Index)
0336 endif
0337 endif
0338
0339 return
0340 end
0341
0342 C--------------------------------------------------------------
0343
0344 Subroutine MakeMixture(Nmix,NMat,LUN)
0345 C =====================================
0346
0347 Implicit None
0348
0349 C...Common Block .................................................
0350 Integer MaxDiv
0351 Parameter (MaxDiv=30)
0352 Character*40 MixtureName, GMIXName
0353 Character*60 Comment(MaxDiv),Material(MaxDiv)
0354 Character*3 Type(MaxDiv)
0355 Real Volume(MaxDiv), Mult(MaxDiv),
0356 + Density(MaxDiv),Radl(MaxDiv),MCVolume,MCArea
0357 Real Intl(MaxDiv)
0358 Common /MatMix/ Comment, Material,Volume,Mult,Density,Radl,Intl,
0359 + MCVolume,MCArea,MixtureName,GMIXName,Type
0360 C.................................................................
0361
0362 Integer NMat, i, j, k,LUN,NMix,LUNTZ,NTZ,Lunx0,Lunl0
0363
0364 Real TVOL,TDEN,TRAD,Weight,PVOL(MaxDiv),PWeight(MaxDiv)
0365 Real TINT
0366 Real ws(MaxDiv),tmp,PRAD(MaxDiv),Norm,Ndens,NRadl,PRadl
0367 Real ws2(MaxDiv),tmp2,PINT(MaxDiv),NIntl,PIntl
0368
0369 Real PSUP,PSEN,PCAB,PCOL,PELE
0370 Real PSUP2,PSEN2,PCAB2,PCOL2,PELE2
0371
0372 Character*60 string,string1,string2,stringmatname
0373
0374 Character*30 TZName(MaxDiv)
0375 Character*32 tzstring
0376 Real TZVol(MaxDiv), TZVolTot
0377
0378 External LENOCC
0379 Integer LENOCC
0380
0381 character*100 sformat
0382
0383 C..................................................................
0384
0385 C..initialize
0386 TVOL = 0. ! compound volume
0387 TDEN = 0. ! compound density
0388 TRAD = 0. ! compound radiation length
0389 Weight = 0. ! Total weight
0390 TINT = 0. ! compound nuclear interaction length
0391 call VZERO(PVOL,MaxDiv)
0392 call VZERO(Pweight,MaxDiv)
0393 call VZERO(ws,MaxDiv)
0394 call VZERO(ws2,MaxDiv)
0395 call VZERO(PRAD,MaxDiv)
0396 call VZERO(TZVol,MaxDiv)
0397 tmp = 0.
0398 tmp2 = 0.
0399
0400 * total volume
0401 do i=1, NMat
0402 Volume(i) = Mult(i)*Volume(i)
0403 TVOL = TVOL + Volume(i)
0404 enddo
0405
0406 if (tvol.le.0.) return
0407 * percentual volume and total density
0408 do i=1,NMat
0409 PVOL(i) = Volume(i)/TVOL
0410 TDEN = TDEN + PVOL(i)*Density(i)
0411 enddo
0412
0413 * total weight
0414 Weight = TDEN * TVOL
0415
0416 do j = 1,NMat
0417 * percentual weight
0418 if(Volume(j).gt.0.) then
0419 PWeight(j) = Density(j)*Volume(j)/Weight
0420 * weight for X0 calculation (pweight/(density*radl))
0421 ws(j) = Pweight(j)/(Density(j)*Radl(j))
0422 tmp = tmp + ws(j)
0423 * weight for Lambda0 calculation (pweight/(density*intl))
0424 ws2(j) = Pweight(j)/(Density(j)*Intl(j))
0425 tmp2 = tmp2 + ws2(j)
0426 endif
0427 enddo
0428
0429 * radiation length of compound
0430 TRAD = 1/(tmp*TDEN)
0431
0432 * nuclear interaction length of compound
0433 TINT = 1/(tmp2*TDEN)
0434
0435 * contribution to compound X0
0436 do k = 1,NMat
0437 PRAD(k) = ws(k)*TRAD*TDEN
0438 enddo
0439
0440 * contribution to compound Lambda0
0441 do k = 1,NMat
0442 PINT(k) = ws2(k)*TINT*TDEN
0443 enddo
0444
0445 * Normalization factor Mixture/MC volume
0446 if (MCVolume.gt.0.) then
0447 Norm = TVOL/MCVolume
0448 else
0449 Norm = 1.
0450 endif
0451
0452 * Normalized density and radiation length and nuclear interaction length
0453
0454 ndens = TDEN*Norm
0455 NRadl = TRAD / norm
0456 NIntl = TINT / norm
0457
0458 * percentual radiation length of compound (if area is given)
0459 if (MCArea.gt.0) then
0460 PRadl = MCVolume/(MCArea*NRadl)
0461 endif
0462
0463 * percentual nuclear interaction length of compound (if area is given)
0464 if (MCArea.gt.0) then
0465 PIntl = MCVolume/(MCArea*NIntl)
0466 endif
0467
0468 C---> separate contributions to X_0 by type
0469 PSUP = 0.
0470 PSEN = 0.
0471 PCAB = 0.
0472 PCOL = 0.
0473 PELE = 0.
0474 do i = 1, NMat
0475 if(Type(i).eq."SUP") then
0476 PSUP = PSUP + PRAD(i)
0477 elseif (Type(i).eq."SEN") then
0478 PSEN = PSEN + PRAD(i)
0479 elseif (Type(i).eq."CAB") then
0480 PCAB = PCAB + PRAD(i)
0481 elseif (Type(i).eq."COL") then
0482 PCOL = PCOL + PRAD(i)
0483 elseif (Type(i).eq."ELE") then
0484 PELE = PELE + PRAD(i)
0485 else
0486 write(*,*) "No grouping given for material ",
0487 + Material(i)
0488 endif
0489 enddo
0490
0491 C---> separate contributions to Lambda_0 by type
0492 PSUP2 = 0.
0493 PSEN2 = 0.
0494 PCAB2 = 0.
0495 PCOL2 = 0.
0496 PELE2 = 0.
0497 do i = 1, NMat
0498 if(Type(i).eq."SUP") then
0499 PSUP2 = PSUP2 + PINT(i)
0500 elseif (Type(i).eq."SEN") then
0501 PSEN2 = PSEN2 + PINT(i)
0502 elseif (Type(i).eq."CAB") then
0503 PCAB2 = PCAB2 + PINT(i)
0504 elseif (Type(i).eq."COL") then
0505 PCOL2 = PCOL2 + PINT(i)
0506 elseif (Type(i).eq."ELE") then
0507 PELE2 = PELE2 + PINT(i)
0508 else
0509 write(*,*) "No grouping given for material ",
0510 + Material(i)
0511 endif
0512 enddo
0513
0514 C---> write out the results ..................
0515
0516 c$$$ stringmatname = GMIXName
0517 c$$$ call LatexUnderscore(stringmatname)
0518 c$$$ write(LUN,1000) Nmix,MixtureName,stringmatname
0519 c$$$ 1000 Format('\\subsection*{\\underline{',I3,2X,A40,2X,
0520 c$$$ + '(Material name: ',A40,')',' }}')
0521 c$$$
0522 c$$$C write(LUN,*) "\\begin{table}[ht]"
0523 c$$$ write(LUN,*) "\\begin{tabular}{rlrrr}"
0524 c$$$ write(LUN,*) "\\hline\\hline"
0525 c$$$ write(LUN,*) " & Item & \\% Volume & \\% Weight & ",
0526 c$$$ + "\\% Total X0 \\","\\"
0527 c$$$ write(LUN,*) "\\hline\\hline"
0528 c$$$
0529 c$$$ do k=1,NMat
0530 c$$$ string = Material(k)
0531 c$$$ call LatexUnderscore(string)
0532 c$$$ write(LUN,1001) k, string(1:LENOCC(string)),100.*PVOL(k),
0533 c$$$ + 100.*Pweight(k),100.*PRAD(k)
0534 c$$$ write(LUN,*) "\\hline"
0535 c$$$ enddo
0536 c$$$ 1001 Format(1X,I4,2X,' & ',A20,' & ',2(1X,F8.3,' & '),1X,F8.3,
0537 c$$$ + '\\','\\')
0538
0539 C
0540 C--------------------New big table START
0541 C
0542 stringmatname = GMIXName
0543 call LatexUnderscore(stringmatname)
0544 write(LUN,1000) MixtureName,stringmatname
0545 1000 Format('\\subsection*{\\underline{',2X,A40,2X,
0546 + '(Material name: ',A40,')',' }}')
0547
0548 C write(LUN,*) "\\begin{table}[ht]"
0549 write(LUN,*) "\\begin{tabular}{crlrlrlcrrrr}"
0550 C write(LUN,*) "\\hline\\hline"
0551 write(LUN,*) " & Component & Material & ",
0552 + " Volume & \\% & ",
0553 + " Weight & \\% & Density ",
0554 + " & X$_0$ & ",
0555 + " \\% ",
0556 + " & $\\lambda_0$ & ",
0557 + " \\% "
0558 write(LUN,*) "\\","\\"
0559 write(LUN,*) " & & & ",
0560 + " [cm$^3$] & & ",
0561 + " [g] & & [g/cm$^3$]",
0562 + " & [cm] & ",
0563 + " ",
0564 + " & [cm] & ",
0565 + " "
0566 write(LUN,*) "\\","\\"
0567 C write(LUN,*) "\\hline\\hline"
0568 write(LUN,*) "\\hline"
0569
0570 do k=1,NMat
0571 string = Material(k)
0572 string1 = Comment(k)
0573 call LatexUnderscore(string)
0574 call LatexUnderscore(string1)
0575
0576 if (Volume(k).ge.0.1) then
0577 write(LUN,1001) k,string1(1:LENOCC(string1)),
0578 + string(1:LENOCC(string)),Volume(k),100.*PVOL(k),
0579 + Density(k)*Volume(k),
0580 + 100.*Pweight(k),Density(k),Radl(k),100.*PRAD(k),
0581 + Intl(k),100*PINT(k)
0582 else
0583 write(LUN,2001) k,string1(1:LENOCC(string1)),
0584 + string(1:LENOCC(string)),Volume(k),100.*PVOL(k),
0585 + Density(k)*Volume(k),
0586 + 100.*Pweight(k),Density(k),Radl(k),100.*PRAD(k),
0587 + Intl(k),100*PINT(k)
0588 endif
0589 write(LUN,*) "\\hline"
0590 enddo
0591 1001 Format(1X,I4,2X,' & ',A60,' & ',A20,' & ',
0592 + (1X,F10.4,' & '),(1X,F12.3,' & '),(1X,F10.4,' & '),
0593 + 5(1X,F12.3,' & '),1X,F12.3,
0594 + '\\','\\')
0595 2001 Format(1X,I4,2X,' & ',A60,' & ',A20,' & ',
0596 + (1X,E10.4,' & '),(1X,F12.3,' & '),(1X,E10.4,' & '),
0597 + 5(1X,F12.3,' & '),1X,F12.3,
0598 + '\\','\\')
0599
0600 C
0601 C--------------------New big table END
0602 C
0603 write(LUN,*) "\\end{tabular}"
0604 C write(LUN,*) "\\vskip 0.1cm"
0605 write(LUN,*) " "
0606 write(LUN,*) "\\begin{tabular}{lrr}"
0607 write(LUN,*) "\\fbox{\\begin{tabular}{rl}"
0608 write(LUN,1002) "Mixture density [g/cm$^3$]",TDEN
0609 write(LUN,1002) "Norm. mixture density [g/cm$^3$]",Ndens
0610 write(LUN,1002) "Mixture Volume [cm$^3$]",TVOL
0611 write(LUN,1002) "MC Volume [cm$^3$]",MCVolume
0612 write(LUN,1002) "MC Area [cm$^2]$",MCArea
0613 write(LUN,1002) "Normalization factor",Norm
0614 write(LUN,1002) "Mixture X$_0$ [cm]", TRAD
0615 write(LUN,1002) "Norm. Mixture X$_0$ [cm]",NRadl
0616 if (MCArea.gt.0) then
0617 write(LUN,1002) "Norm. Mixture X$_0$ (\\%)",100*PRadl
0618 endif
0619 write(LUN,1002) "Mixture $\\lambda_0$ [cm]", TINT
0620 write(LUN,1002) "Norm. Mixture $\\lambda_0$ [cm]",NIntl
0621 if (MCArea.gt.0) then
0622 write(LUN,1002) "Norm. Mixture $\\lambda_0$ (\\%)",100*PIntl
0623 endif
0624 write(LUN,1002) "Total weight (g)",weight
0625 1002 Format(A40," & ",F15.5," \\","\\")
0626
0627 write(LUN,*) "\\end{tabular}} & \\fbox{\\begin{tabular}{rl}"
0628
0629 write(LUN,1006) "\\underline{X$_0$ contribution}"
0630 write(LUN,1005) "Support: ",PSUP
0631 write(LUN,1005) "Sensitive: ",PSEN
0632 write(LUN,1005) "Cables: ",PCAB
0633 write(LUN,1005) "Cooling: ",PCOL
0634 write(LUN,1005) "Electronics: ", PELE
0635
0636 write(LUN,*) "\\end{tabular}} & \\fbox{\\begin{tabular}{rl}"
0637
0638 write(LUN,1006) "\\underline{$\\lambda_0$ contribution}"
0639 write(LUN,1005) "Support: ",PSUP2
0640 write(LUN,1005) "Sensitive: ",PSEN2
0641 write(LUN,1005) "Cables: ",PCAB2
0642 write(LUN,1005) "Cooling: ",PCOL2
0643 write(LUN,1005) "Electronics: ", PELE2
0644
0645 1005 Format(A25," & ",F5.3,"\\","\\")
0646 1006 Format(A40," & \\","\\")
0647
0648 write(LUN,*) "\\end{tabular}}\\end{tabular}"
0649 write(LUN,*) "\\clearpage"
0650
0651 C----> now write out a pseudo title file
0652
0653 LUNTZ = LUN+1
0654
0655 C * first add volumes of same material
0656
0657 Ntz = 0
0658
0659 do 500 i = 1, NMat
0660 C.. see if there's a match
0661 do j = 1, Ntz
0662 if(Material(i)(1:LENOCC(Material(i))).eq.
0663 + TZName(j)(1:LENOCC(TZName(j))) ) then
0664 TZVol(j) = TZVol(j) + PVol(i)
0665 go to 500
0666 endif
0667 enddo
0668 Ntz = Ntz + 1
0669 TZName(Ntz) = material(i)
0670
0671 TZVol(Ntz) = PVol(i)
0672 500 continue
0673
0674 TZVolTot = 0.
0675 do i = 1, Ntz
0676 TZVolTot = TZVolTot + TZVol(i)
0677 enddo
0678 if( abs(TZVolTot-1.) .gt. 1.E-6) then
0679 write(*,*) "Percentual Volumes don't add up to 1 !!"
0680 endif
0681
0682 C write(*,*) "NTZ: ", Ntz
0683 C do i =1, Ntz
0684 C write(*,*) TZName(i)
0685 C enddo
0686
0687 tzstring = '"'//GMIXName(1:LENOCC(GMIXName))//'"'
0688 write(LUNTZ,1010) tzstring,-1*Ntz, ndens
0689 do j = 1, Ntz
0690 tzstring = '"'//TZName(j)(1:LENOCC(TZName(j)))//'"'
0691 write(LUNTZ,1011) tzstring, -100.*TZVol(j)
0692 enddo
0693
0694 1010 Format(7X,A20,I3,4X,F12.6)
0695 1011 Format(10X,A22,F8.3)
0696
0697 C--> and x0 contributions into a separate file
0698
0699 Lunx0 = LUN+2
0700 Lunl0 = LUN+3
0701
0702 C Original
0703 C tzstring = '"'//GMIXName(1:LENOCC(GMIXName))//'"'
0704 C if(PSUP.gt.0.) write(Lunx0,1012) tzstring,'" SUP"',PSUP
0705 C if(PSEN.gt.0.) write(Lunx0,1012) tzstring,'" SEN"',PSEN
0706 C if(PCAB.gt.0.) write(Lunx0,1012) tzstring,'" CAB"',PCAB
0707 C if(PCOL.gt.0.) write(Lunx0,1012) tzstring,'" COL"',PCOL
0708 C if(PELE.gt.0.) write(Lunx0,1012) tzstring,'" ELE"',PELE
0709 C write(Lunx0,*) " "
0710 C 1012 Format(1X,A23,A6,1X,F5.3)
0711 C
0712
0713 C rr
0714 tzstring = GMIXName(1:LENOCC(GMIXName))
0715 write(Lunx0,1012) tzstring,PSUP,PSEN,PCAB,PCOL,PELE
0716 write(Lunx0,*) " "
0717 tzstring = GMIXName(1:LENOCC(GMIXName))
0718 write(Lunl0,1012) tzstring,PSUP2,PSEN2,PCAB2,PCOL2,PELE2
0719 write(Lunl0,*) " "
0720 1012 Format(A32,1X,F5.3,1X,F5.3,1X,F5.3,1X,F5.3,1X,F5.3)
0721 C rr
0722
0723 return
0724 end
0725
0726 C----------------------------------------------------------------
0727
0728 Subroutine ClearCommon
0729 C ----------------------
0730
0731 Implicit None
0732
0733 Integer I
0734
0735 C...Common Block .................................................
0736 Integer MaxDiv
0737 Parameter (MaxDiv=30)
0738 Character*40 MixtureName, GMIXName
0739 Character*60 Comment(MaxDiv),Material(MaxDiv)
0740 Character*3 Type(MaxDiv)
0741 Real Volume(MaxDiv), Mult(MaxDiv),
0742 + Density(MaxDiv),Radl(MaxDiv),MCVolume,MCArea
0743 Real Intl(MaxDiv)
0744 Common /MatMix/ Comment, Material,Volume,Mult,Density,Radl,Intl,
0745 + MCVolume,MCArea,MixtureName,GMIXName,Type
0746 C.................................................................
0747
0748 do i=1, MaxDiv
0749 Comment(i) = " "
0750 Material(i) = " "
0751 Type(i) = " "
0752 enddo
0753
0754 Call VZERO(Volume,MaxDiv)
0755 Call VZERO(Mult,MaxDiv)
0756 Call VZERO(Density,MaxDiv)
0757 Call VZERO(Radl,MaxDiv)
0758 Call VZERO(Intl,MaxDiv)
0759 MCVolume = 0.
0760 MCArea = 0.
0761 MixtureName = " "
0762 GMIXName = " "
0763
0764 return
0765 end
0766
0767 C------------------------------------------------------------------
0768
0769 Subroutine LatexSetup(LUN)
0770 C ==========================
0771
0772 Implicit None
0773 Integer LUN
0774 C--
0775 write(LUN,*) "\\documentclass[10pt]{article}"
0776 write(LUN,*) "\\usepackage{lscape}"
0777 write(LUN,*) "\\usepackage{a4}"
0778 write(LUN,*) "\\pagestyle{empty}"
0779 write(LUN,*) "\\renewcommand{\\baselinestretch}{1.1}"
0780 write(LUN,*) "\\parskip4pt"
0781 write(LUN,*) "\\setlength{\\textwidth}{18cm}"
0782 write(LUN,*) "\\setlength{\\textheight}{28cm}"
0783 write(LUN,*) "\\addtolength{\\oddsidemargin}{-1.5cm}"
0784 write(LUN,*) "\\addtolength{\\evensidemargin}{-1.5cm}"
0785 write(LUN,*) "\\addtolength{\\topmargin}{-5cm}"
0786 write(LUN,*) "\\begin{document}"
0787 write(LUN,*) "\\begin{landscape}"
0788
0789 return
0790 end
0791
0792
0793
0794 Subroutine LatexUnderscore(stringname)
0795 C =======================================
0796 Implicit None
0797 Character*60 stringname,stringtemp
0798 Integer k,maxunderscore,findunderscore,findspace
0799 Integer underscorefound
0800
0801 stringtemp = stringname
0802 findunderscore = 0
0803 k = 0
0804 maxunderscore = 5 !At most maxunderscore '_' searched
0805 underscorefound = 0
0806
0807 C Avoid LaTeX errors when compiling names with '_'
0808 c write(*,*) k,stringname,stringtemp
0809 do k=1,maxunderscore
0810 findunderscore = INDEX(stringtemp,'_')
0811 if(findunderscore.ne.0) then
0812 underscorefound = underscorefound + 1
0813 if(k.eq.1) then
0814 stringname = stringtemp(1:findunderscore-1) // '\\'
0815 + // stringtemp(findunderscore:findunderscore)
0816 else
0817 findspace = INDEX(stringname,' ')
0818 stringname = stringname(1:findspace-1)
0819 + // stringtemp(1:findunderscore-1) // '\\'
0820 + // stringtemp(findunderscore:findunderscore)
0821 endif
0822 stringtemp = stringtemp(findunderscore+1:)
0823 endif
0824 c write(*,*) k,stringname,stringtemp
0825 enddo
0826 if(underscorefound.ne.0) then
0827 findspace = INDEX(stringname,' ')
0828 stringname = stringname(1:findspace-1) // stringtemp
0829 endif
0830 c write(*,*) k,stringname,stringtemp
0831 return
0832 end
